#define root2 (2^.5)
* The class definitions below are what define the properties
* and behaviors of the instantiated objects.
define class tetrahedron as polyhedron
shapeid = "T1"
snapshot = "T1points"
shapevolume = 1
shapecolor = "Orange"
enddefine
define class cube as polyhedron
shapeid = "C1"
snapshot = "C1points"
shapevolume = 3
shapecolor = "Green"
enddefine
define class octahedron as polyhedron
shapeid = "O1"
snapshot = "O1points"
shapevolume = 4
shapecolor = "Red"
enddefine
define class rhdodeca as polyhedron
shapeid = "R1"
snapshot = "R1points"
shapevolume = 6
shapecolor = "Blue"
enddefine
define class icosahedron as polyhedron
shapeid = "I1"
snapshot = "I1points"
shapevolume = 18.51229586821915
shapecolor = "Cyan"
enddefine
define class cubocta as polyhedron
shapeid = "V1"
snapshot = "V1points"
shapevolume = 20
shapecolor = "Yellow"
enddefine
define class rhtriac as polyhedron
shapeid = "RT1"
snapshot = "RT1points"
shapevolume = 20 * (9/8)^0.5 && 20 * (synergetics constant)^3
emodfactor = 2/(1+5^.5) && 1/phi
tmodfactor = ((2^.5 * (2 + 5^.5))/6)^(1/3) && E-mod -> T-mod Rh Triac
shapecolor = "Magenta"
enddefine
define class polyhedron as custom
add object oMatrixOps as MatrixOps
add object oQuadrays as Quadrays
dimension pivot(3)
pivot = 0
shapecolor = ""
degrees = 0 && default rotation angle
axis = "X" && default axis of rotation
pointarch = "allpoints.dbf"
edgearch = "shapes.dbf"
baseformat = "quadrays"
shapeid = "T1"
objedges = ""
objpoints = ""
snapshot = "T1points"
procedure init(shape_selector)
if parameters()>0
this.shapeid = shape_selector
endif
* create local Edges table (alias edges)
this.objedges = sys(3) && unique filename
select * from (this.edgearch) ed ;
where this.shapeid = ed.shapeid ;
into dbf (this.objedges)
* create local (writable) Points table (alias points)
this.objpoints = sys(3) && unique filename
if this.baseformat = "xyz"
select distinct lib.pointid, xcoord, ycoord, zcoord ;
from (this.pointarch) lib, (this.objedges) ed ;
where (ed.id1=lib.pointid or ed.id2=lib.pointid) ;
into dbf (this.objpoints)
endif
if this.baseformat = "quadrays"
this.quad2xyz()
endif
close tables
use (this.objpoints)
index on pointid tag pointid
use
endproc
procedure quad2xyz
local temp(1,5), norecs
select distinct lib.pointid, acoord, bcoord, ccoord, dcoord ;
from (this.pointarch) lib, (this.objedges) ed ;
where (ed.id1=lib.pointid or ed.id2=lib.pointid) ;
into array temp
create table (this.objpoints) ;
(pointid c(5), xcoord n(10,7), ycoord n(10,7), zcoord n(10,7))
use (this.objpoints)
norecs = alen(temp,1)
for i = 1 to norecs
this.oQuadrays.quad2xyz(temp(i,2),temp(i,3),temp(i,4),temp(i,5))
append blank
replace pointid with temp(i,1), ;
xcoord with this.oQuadrays.xyzout(1), ;
ycoord with this.oQuadrays.xyzout(2), ;
zcoord with this.oQuadrays.xyzout(3)
endfor
return
endproc
procedure writetable
select select(1)
use (this.objpoints) alias points
copy to (this.snapshot)
use
endproc
procedure translate(p1, p2, p3, p4)
local x,y,z
if parameters()=4
this.oQuadrays.quad2xyz(p1,p2,p3,p4)
x = this.oQuadrays.xyzout(1)
y = this.oQuadrays.xyzout(2)
z = this.oQuadrays.xyzout(3)
else
x = p1
y = p2
z = p3
endif
select select(1)
use (this.objpoints) alias points
this.oMatrixOps.translate(x,y,z)
this.pivot(1) = this.pivot(1) + x
this.pivot(2) = this.pivot(2) + y
this.pivot(3) = this.pivot(3) + z
select points
use
return
endproc
procedure gohome()
this.translate(-this.pivot(1),-this.pivot(2),-this.pivot(3))
endproc
procedure scale(factor)
select select(1)
use (this.objpoints) alias points
this.oMatrixOps.scale(factor)
this.shapevolume = this.shapevolume * factor^3
select points
use
return
endproc
procedure setrotate(axis,deg)
this.degrees = deg * pi()/180
this.omatrixops.setdegrees(this.degrees)
this.axis = axis
this.omatrixops.axis = this.axis
endproc
procedure rotate(degrees, axis)
local posx, posy, posz
if parameters()>0
this.setrotate(degrees, axis)
endif
posx = this.pivot(1)
posy = this.pivot(2)
posz = this.pivot(3)
this.gohome()
select select(1)
use (this.objpoints) alias points
do case
case this.axis="X"
this.omatrixops.xrotate()
case this.axis="Y"
this.omatrixops.yrotate()
case this.axis="Z"
this.omatrixops.zrotate()
endcase
select points
use
this.translate(posx,posy,posz)
return
endproc
procedure destroy
close tables
set safety off
erase (this.objedges+".dbf")
erase (this.objpoints+".dbf")
erase (this.objpoints+".cdx")
set safety on
return
endproc
enddefine
define class sphere as custom
add object oQuadrays as Quadrays
dimension pivot(3)
pivot = 0
radius = 1
shapecolor = ""
shapeid = "SPH"
procedure translate(p1, p2, p3, p4)
local x,y,z
if parameters()=4
this.oQuadrays.quad2xyz(p1,p2,p3,p4)
x = this.oQuadrays.xyzout(1)
y = this.oQuadrays.xyzout(2)
z = this.oQuadrays.xyzout(3)
else
x = p1
y = p2
z = p3
endif
this.pivot(1) = this.pivot(1) + x
this.pivot(2) = this.pivot(2) + y
this.pivot(3) = this.pivot(3) + z
return
endproc
procedure gohome()
this.translate(-this.pivot(1),-this.pivot(2),-this.pivot(3))
endproc
procedure scale(factor)
this.radius = this.radius * factor
this.shapevolume = this.shapevolume * factor^3
return
endproc
enddefine
define class writepoly as custom
dimension aedges(1)
cyldiam = "0.04"
drawaxes = .T.
axlength = 2.5
axdiam = "0.02"
shapecolor = "Blue"
axcolor = "Green"
hnd = 0
outputfile = "myfile.txt"
edgeindex = 1
procedure init(filename)
if parameters()>0
this.outputfile = filename
endif
this.startoutput()
endproc
procedure opendata(obj)
select select(1)
use (obj.objedges) alias edges
dimension this.aedges(reccount())
select select(1)
use (obj.objpoints) order pointid alias points
select edges && select the Edges table
go top
endproc
procedure closedata
select edges
use
select points
use
return
endproc
procedure startoutput()
this.openfile()
endproc
procedure writeoutput(obj)
local x1,y1,z1,x2,y2,z2
this.shapecolor = obj.shapecolor
if obj.shapeid="SPH"
this.writesphere(obj)
else
this.opendata(obj)
this.startdata() && not used by all subclasses
select edges
go top
scan while not eof() && scan to the end
=seek(id1,"points") && get first vertex
x1=points.xcoord
y1=points.ycoord
z1=points.zcoord
recno1 = recno("points")
=seek(id2,"points") && get second vertex
x2=points.xcoord
y2=points.ycoord
z2=points.zcoord
recno2 = recno("points")
this.writepoint(x1,y1,z1) && nub
this.writeEdge(x1,y1,z1,x2,y2,z2,recno1,recno2) && edge
this.writepoint(x2,y2,z2) && nub
endscan
this.wrapdata() && not used by all subclasses
this.closedata()
endif
return
endproc
procedure writesphere()
endproc
procedure openfile()
local filename
filename=this.outputfile
if file(filename)
erase (filename)
endif
this.hnd=fcreate(filename)
if this.hnd>0
=fopen(filename)
endif
return
endproc
procedure makeaxes
local tempshape, tempdiam
tempshape = this.shapecolor
tempdiam = this.cyldiam
this.shapecolor = this.axcolor
this.cyldiam = this.axdiam
this.writeaxes()
this.shapecolor = tempshape
this.cyldiam = tempdiam
return
endproc
procedure writeaxes
endproc
procedure writepoint(a,b,c)
=fputs(this.hnd, "Vertex: x="+str(a,10,7)+" y="+str(b,10,7)+" z="+str(c,10,7))
endproc
procedure writeEdge(a,b,c,d,e,f,r1,r2)
=fputs(this.hnd, "Edge from ("+ ;
str(a,10,7)+","+str(b,10,7)+","+str(c,10,7)+") to ("+ ;
str(c,10,7)+","+str(d,10,7)+","+str(e,10,7)+") ")
endproc
procedure startdata
endproc
procedure wrapdata
endproc
procedure destroy()
=fclose(this.hnd)
return
endproc
enddefine
define class writepov as writepoly
outputfile = "myfile.pov"
procedure startoutput()
this.openfile()
with this
=fputs(.hnd, "//POV-Ray script")
=fputs(.hnd, '#version 3.1')
=fputs(.hnd, 'global_settings { assumed_gamma 2.2 }')
=fputs(.hnd, '#include "colors.inc"')
=fputs(.hnd, '#include "shapes.inc"')
=fputs(.hnd, '#include "glass.inc"')
=fputs(.hnd, '#include "woods.inc"')
=fputs(.hnd, '#include "metals.inc"')
=fputs(.hnd, '#include "textures.inc"')
=fputs(.hnd, '#default {texture{pigment{color White}'+;
'finish{phong 0.01 ambient 0.2 diffuse 0.6}}}')
=fputs(.hnd, '#declare T1 = texture{Gold_Metal}')
=fputs(.hnd, '#declare T2 = texture{T_Wood1} // Oak ')
=fputs(.hnd, '#declare T3 = texture{T_Copper_3A}')
=fputs(.hnd, "")
=fputs(.hnd, "#declare Cam_factor = 8")
=fputs(.hnd, "#declare Camera_X = 1 * Cam_factor")
=fputs(.hnd, "#declare Camera_Y = 0.5 * Cam_factor")
=fputs(.hnd, "#declare Camera_Z = -0.9 * Cam_factor")
=fputs(.hnd, "<Camera_X, Camera_Y, Camera_Z>camera { location ")
=fputs(.hnd, " up <0, 1.0, 0> right <-4/3, 0, 0>")
=fputs(.hnd, " direction <0, 0, 3> look_at <0, 0, 0> ")
=fputs(.hnd, " rotate <0,0,0>}")
=fputs(.hnd, "")
=fputs(.hnd, "<Camera_X - 2, Camera_Y + 5 , Camera_Z + 5>light_source { color White }")
=fputs(.hnd, "<Camera_X - 2, Camera_Y + 5 , Camera_Z - 3>light_source { color White }")
=fputs(.hnd, "")
=fputs(.hnd, "// Background:")
=fputs(.hnd, "background {color White}")
endwith
endproc
procedure writeaxes
this.writeEdge(this.axlength,0,0,-this.axlength,0,0)
this.writeEdge(0,this.axlength,0,0,-this.axlength,0)
this.writeEdge(0,0,this.axlength,0,0,-this.axlength)
return
endproc
procedure writepoint(a,b,c)
with this
=fputs(.hnd, "sphere{<";
+str(a,10,7)+",";
+str(b,10,7)+",";
+str(c,10,7)+">," + .cyldiam;
+" pigment {color "+ .shapecolor + "} no_shadow}")
endwith
endproc
procedure writeEdge(a,b,c,d,e,f,r1,r2)
* write a line in the POV file defining a cylinder w/ spherical nibs
with this
=fputs(.hnd, "cylinder{<";
+str(a,10,7)+",";
+str(b,10,7)+",";
+str(c,10,7)+">,<";
+str(d,10,7)+",";
+str(e,10,7)+",";
+str(f,10,7)+">," + .cyldiam;
+" pigment {color "+.shapecolor+"} no_shadow}")
endwith
endproc
procedure writesphere(obj)
with this
=fputs(.hnd, "sphere { <" + str(obj.pivot(1),10,7)+", "+ ;
str(obj.pivot(2),10,7)+", "+ ;
str(obj.pivot(3),10,7)+">, " + str(obj.radius,10,7))
=fputs(.hnd, " texture {")
=fputs(.hnd, " pigment {")
=fputs(.hnd, " wood")
=fputs(.hnd, " color_map {")
=fputs(.hnd, " [0.0 color DarkTan]")
=fputs(.hnd, " [0.9 color DarkBrown]")
=fputs(.hnd, " [1.0 color VeryDarkBrown]")
=fputs(.hnd, " }")
=fputs(.hnd, " turbulence 0.08")
=fputs(.hnd, " }")
=fputs(.hnd, " finish { phong .5 }")
=fputs(.hnd, " }")
=fputs(.hnd, " }")
endwith
endproc
enddefine
define class writeVRML as writepoly
outputfile = "myfile.wrl"
procedure startoutput()
this.openfile()
with this
=fputs(.hnd, '#VRML V1.0 ascii')
=fputs(.hnd, 'DEF BackgroundColor Info { string "0.0 0.0 1.0" }')
=fputs(.hnd, 'Material { diffuseColor 1 0 0} #end Material set to blue')
endwith
endproc
procedure writeaxes
with this
=fputs(.hnd, "")
=fputs(.hnd, "Coordinate3 {")
=fputs(.hnd, " point [")
=fputs(.hnd, "0 0 0,")
=fputs(.hnd, str(.axlength,10,7)+" 0 0,")
=fputs(.hnd, str(-.axlength,10,7)+" 0 0,")
=fputs(.hnd, "0 "+str(.axlength,10,7)+" 0,")
=fputs(.hnd, "0 "+str(-.axlength,10,7)+" 0,")
=fputs(.hnd, "0 0 "+str(.axlength,10,7)+",")
=fputs(.hnd, "0 0 "+str(-.axlength,10,7)+",")
=fputs(this.hnd, " ]")
=fputs(this.hnd, "}")
=fputs(this.hnd, "")
=fputs(this.hnd, "IndexedLineSet {")
=fputs(this.hnd, " coordIndex [")
=fputs(this.hnd, " 0, 1, -1,")
=fputs(this.hnd, " 0, 2, -1,")
=fputs(this.hnd, " 0, 3, -1,")
=fputs(this.hnd, " 0, 4, -1,")
=fputs(this.hnd, " 0, 5, -1,")
=fputs(this.hnd, " 0, 6, -1,")
=fputs(this.hnd, " ]")
=fputs(this.hnd, "}")
endwith
return
endproc
procedure writepoint(a,b,c)
endproc
procedure writeEdge(a,b,c,d,e,f,r1,r2)
=fputs(this.hnd,space(10)+str(r1-1,3)+", "+str(r2-1,3)+ ", -1,")
return
endproc
procedure startdata()
=fputs(this.hnd, '')
=fputs(this.hnd, 'Coordinate3 {')
=fputs(this.hnd, ' point [')
select points
set order to
go top
scan while .not. eof()
=fputs(this.hnd, str(xcoord,10,7)+" "+str(ycoord,10,7)+" "+str(zcoord,10,7)+",")
endscan
=fputs(this.hnd, " ]")
=fputs(this.hnd, "}")
=fputs(this.hnd, "")
=fputs(this.hnd, "IndexedLineSet {")
=fputs(this.hnd, " coordIndex [")
set order to pointid
endproc
procedure writesphere(obj)
with this
=fputs(.hnd, "Translation {")
=fputs(.hnd, " translation "+str(obj.pivot(1),10,7)+" "+;
str(obj.pivot(2),10,7)+" "+;
str(obj.pivot(3),10,7))
=fputs(.hnd, "}")
=fputs(.hnd, "Sphere {")
=fputs(.hnd, " radius "+str(obj.radius,10,7))
=fputs(.hnd, "}")
=fputs(.hnd, "Translation {")
=fputs(.hnd, " translation "+str(-obj.pivot(1),10,7)+" "+;
str(-obj.pivot(2),10,7)+" "+;
str(-obj.pivot(3),10,7))
=fputs(.hnd, "}")
endwith
return
endproc
procedure wrapdata
=fputs(this.hnd, " ]")
=fputs(this.hnd, "}")
endproc
enddefine
define class matrixops as custom
theta=0
axis=""
cos_theta=0
sin_theta=0
procedure setdegrees(deg)
this.theta = deg
this.cos_theta = cos(this.theta)
this.sin_theta = sin(this.theta)
return
endproc
procedure xrotate
local newx, newy, newz
* / 1 0 0 \
* X AXIS | 0 cos(a) -sin(a) |
* \ 0 sin(a) cos(a) /
scan while not eof()
newx = xcoord
newy = this.cos_theta*ycoord - this.sin_theta*zcoord
newz = this.sin_theta*ycoord + this.cos_theta*zcoord
replace xcoord with newx, ycoord with newy, zcoord with newz
endscan
return
endproc
procedure yrotate
local newx, newy, newz
* / cos(a) 0 -sin(a) \
* Y AXIS | 0 1 0 |
* \ sin(a) 0 cos(a) /
scan while not eof()
newx = this.cos_theta*xcoord - this.sin_theta*zcoord
newy = ycoord
newz = this.sin_theta*xcoord + this.cos_theta*zcoord
replace xcoord with newx, ycoord with newy, zcoord with newz
endscan
return
endproc
procedure zrotate
local newx, newy, newz
* / cos(a) -sin(a) 0 \
* Z AXIS | sin(a) cos(a) 0 |
* \ 0 0 1 /
scan while not eof()
newx = this.cos_theta*xcoord - this.sin_theta*ycoord
newy = this.sin_theta*xcoord + this.cos_theta*ycoord
newz = zcoord
replace xcoord with newx, ycoord with newy, zcoord with newz
endscan
return
endproc
procedure translate(x, y, z)
local newx, newy, newz
scan while not eof()
newx = x + xcoord
newy = y + ycoord
newz = z + zcoord
replace xcoord with newx, ycoord with newy, zcoord with newz
endscan
return
endproc
procedure scale(factor)
local newx, newy, newz
scan while not eof()
newx = xcoord * factor
newy = ycoord * factor
newz = zcoord * factor
replace xcoord with newx, ycoord with newy, zcoord with newz
endscan
return
endproc
enddefine
define class quadrays as custom
dimension xyzout(3), quadout(4)
procedure quad2xyz(a,b,c,d) && parameters passed from poly object
with this
.xyzout(1) = 1/root2 * (a - b - c + d)
.xyzout(2) = 1/root2 * (a - b + c - d)
.xyzout(3) = 1/root2 * (a + b - c - d)
endwith
endproc
procedure xyz2quad(x,y,z)
with this
.quadout(1) = 1/root2 * (iif(x>=0,x, 0)+iif(y>=0,y, 0)+iif(z>=0,z, 0))
.quadout(2) = 1/root2 * (iif(x>=0,0,-x)+iif(y>=0,0,-y)+iif(z>=0,z, 0))
.quadout(3) = 1/root2 * (iif(x>=0,0,-x)+iif(y>=0,y, 0)+iif(z>=0,0,-z))
.quadout(4) = 1/root2 * (iif(x>=0,x, 0)+iif(y>=0,0,-y)+iif(z>=0,0,-z))
.simplify()
endwith
endproc
* keep quadray coordinates in simplest form
procedure simplify
with this
local i
minval=.quadout(1)
for i=1 to 4
minval = min(minval,.quadout(i))
endfor
for i=1 to 4
.quadout(i)=.quadout(i)-minval
endfor
endwith
endproc
enddefine