aUCBLogo Demos and Tests / 3dtest


be 3dtest 
   
singleshot=Name? "framenr
   
if not singleshot [framenr=0]
   
perspective cs ht setUpdateGraph false
   
disableCylinderLines
   
setPenSize [0 0]
   
setLabelAlign 0 0 setlabelsize [30 30]
   
pr [ESC stops, + and chooses demo, * and changes speed]
   
Demos=
   
[   [Squares]
      
[pu setxyz 100 0 100 pd Squares]
      
[Squares2]
      
[Squares3]
      
[Cube wait 1]
      
[pu rt 90 fd 100 lt 90 fd 100 pd Cube wait 1]
      
[Wall_of_Cubes]
      
[Wall_of_Cubes1]
      
[Cube_of_Cubes]
      
[Cube_of_Cubes1]
      
[Cubes]
      
[Decorated_Cube]
      
[Circl 80 ]
      
[Circles ]
      
[Torous]
      
[Snail2 70]
      
[ppp]
      
[shape]
      
[shape1]
      
[wireSphere 120]
      
[Sphere3 120 waitms 1]
      
[cylinder]
      
[Moebius_Band 40]
      
[Paraboloid1]
      
[Paraboloid2]
      
[Hyperboloid]
      
[tyre]
      
[deformed_tyre]
      
[sq]
      
[Earth_and_Moon]
   
]
   
catch "3dtest_stop
   
[   (play Demos singleshot framenr)
   
]
end
;pause
be play Demos [singleshot false][FrameNr 0]
   
local [nDemos i nphi phi a_Demo c eye]
   
nDemos=count Demos
   
ifelse singleshot [i=FrameNr+1][i=1]
   
r=500
   
phi=30
;pause
   
dphi=1
   
ddphi=dphi/4
   
theta=30
   
dtheta=5
   
eye=array 3
   
a_Demo=Demos.i
   
j0 first a_Demo
   
run a_Demo
   
tfps=timefine
   
forever
   
[   phi=phi+dphi
      
eye.1=r*(cos theta)*sin phi
      
eye.2=rsin theta
      
eye.3=r*(cos theta)*cos phi
      
setEye eye {0 0 0}{0 1 0}
      
redraw
      
if singleshot [break]
      
if key?
      
[   c=readChar
         
di=false
         
ifelse c==char 255
         
[   c=readCharExt
            
if c==WXK_PRIOR [r=r/1.1]
            
if c==WXK_NEXT  [r=r*1.1]
            
if c==WXK_RIGHT [dphi=dphi+ddphi]
            
if c==WXK_LEFT  [dphi=dphi-ddphi]
            
if c==WXK_UP    [theta=theta+dtheta]
            
if c==WXK_DOWN  [theta=theta-dtheta]
            
if c==WXK_NUMPAD_ADD      [if nDemos [i=i+di=true]]
            
if c==WXK_NUMPAD_SUBTRACT [if >   1    [i=i-di=true]]
         
][
            
if c==char 27 [stop]
            
if c=="+ [if nDemos [i=i+di=true]]
            
if c=="- [if >   1    [i=i-di=true]]
            
if c=="* [dphi=dphi+0.5]
            
if c=="/ [dphi=dphi-0.5]
         
]
         
if di
         
[   a_Demo=Demos.i
            
j0 first a_Demo
            
pu setpos [-290]  seth 90 setpc 0
            
label list "fps (Int 10*repcount/(timefine-tfps))/10
            
home pd
            
run a_Demo
         
]
      
]
      
gc
   
]

   
be j0 s
      
cs pu
      
setxyz 0  250 0  seth 90  label [3D Demos]
      
setxyz -250 0  seth 90  label s
      
home axes
   
end
   
   
be j1
      
local [c]
      
setpc 1+random 6
      
c=readchar
      
if c==char 27 [throw "3dtest_stop]
   
end
   
   
be Circl r
      
pu fd rt 90 pd
      
Circl1 r lt 90 pu bk pd
   
end
   
   
be Circl1 r
      
local [n]
      
n=int r*pi/2
      
repeat n
      
[   pd fd r*2*pi/rt 360/n
      
]
   
end
   
   
be Circles
      
repeat 18
      
[   Circl1 15 pu fd 30 up 20
      
]
   
end
   
   
be Cube
      
repeat 4
      
[   Square fd 50 up 90
      
]
   
end
   
   
be Cube_of_Cubes
      
for [0 50 50]
      
[   for [0 50 50]
         
[   for[0 50 50]
            
[   pu setxyz i j k  pd
               
Cube
            
]
         
]
      
]
   
end
   
   
be Cube_of_Cubes1
      
for [50 100 50]
      
[   for [50 100 50]
         
[   for[50 100 50]
            
[   pu setxyz i j k  pd
               
Cube
            
]
         
]
      
]
   
end
   
   
be Cubes
      
repeat 7
      
[   Cube pu fd 110 down 360/pd
      
]
   
end
   
   
be cylinder
      
pu for [0 360 24][for [0 180 20][setCylinderPos 100 pd]pu]
      
pu for [0 180 20][for [0 360 24][setCylinderPos 100 pd]pu]
   
end
   
   
be setCylinderPos1 :r :s :h
      
setxyz 100+:r*cos :s :h 150+:rsin :s
   
end
   
   
be Decorated_Cube
      
repeat 4
      
[   setpc repcount
         
sq fd 115 up 90
      
]
      
rightRoll -90 down 90 fd 115 down 90 rt 90 sq
      
fd 115 down 90 fd 115 down 90 sq
   
end
   
   
be deformed_tyre
      
for [0 180 15][for [fi 0 360 15][setCylinderPos fun3 :h :fi  :fi :h/pd]pu]
      
for [fi 0 360 15][for [0 180 15][setCylinderPos fun3 :h :fi  :fi :h/pd]pu]
   
end
   
   
be Earth_and_Moon
      
sphere4 100 0 sphere4 25 250
   
end
   
   
be fun :h
      
op 80000*(sin :h/7)/(:h+600)
   
end
   
   
be fun1 :r
      
op 10*:r*:r*:r3*:r*:r3*:r
   
end
   
   
be fun2 :h
      
op 40*(2.7+sin :h)
   
end
   
   
be fun3 :h :fi
      
op 40*(2.2+ (1+sin :h)*(0.5+cos :fi))
   
end
   
   
be Hyperboloid
      
pu
      
for [h_ 10 180 20]
      
[   for [0 360 24]
         
[   setCylinderPos 4500/(h_+20)  s  h_   pd
         
]
         
pu
      
]
      
pu
      
for [0 360 24]
      
[   for [h_ 10 180 20]
         
[   setCylinderPos 4500/(h_+20)  s  h_   pd
         
]
         
pu
      
]
   
end
   
   
be Moebius_Band a
      
for [-a a 10]
      
[   for [fi 0 360 10]
         
[   setCylinderPos 140+r*cos fi/2  fi  r*sin fi/2  pd
         
]
         
pu
      
]
      
for [fi 0 360 10]
      
[   for [-a a 10]
         
[   setCylinderPos 140+r*cos fi/2  fi  r*sin fi/2  pd
         
]
         
pu
      
]
   
end
   
   
be Paraboloid1
      
pu for [0 360 24][for [0 180 20][setCylinderPos 10*sqrt pd]pu]
      
pu for [0 180 20][for [0 360 24][setCylinderPos 10*sqrt pd]pu]
   
end
   
   
be Paraboloid2
      
pu for [0 360 24][for [0 180 20][setCylinderPos h*h/200 pd]pu]
      
pu for [0 180 20][for [0 360 20][setCylinderPos h*h/200 pd]pu]
   
end
   
   
be ppp
      
pu for [-100 1800 90][for [0 360 24][setCylinderPos 80+fun :h :s -100:h/pd]pu]
      
pu for [0 360 24][for [-100 1800 90][setCylinderPos 80+fun :h :s -100:h/pd]pu]
   
end
   
   
be shape
      
pu for [-100 100 20][for [0 360 24][setCylinderPos 30+0.00001*fun1 :r :s :r pd]pu]
      
pu for [0 360 24][for [-100 100 20][setCylinderPos 30+0.00001*fun1 :r :s :r pd]pu]
   
end
   
   
be shape1
      
pu for [-100 100 20][for [0 360 24][setCylinderPos1 30+0.00001*fun1 :r :s :r pd]pu]
      
pu for [0 360 24][for [-100 100 20][setCylinderPos1 30+0.00001*fun1 :r :s :r pd]pu]
   
end
   
   
be Snail2 a
      
for [0.01 180 15]
      
[   for [0 360 15]
         
[   setSpherePos (v+a)/2*sin u  v  u   pd
         
]
         
pu
      
]
      
for [0 360 15]
      
[   for [0.01 180 15]
         
[   setSpherePos (v+a)/2*sin u  v  u   pd
         
]
         
pu
      
]
   
end
   
   
be wireSphere r
      
pu
         
for [0 360 24]
         
[       for [0 180 15]
         
[   setSpherePos r s t pd
         
]
         
pu
      
]
      
pu
         
for [0 180 15]
         
[       for [0 360 24]
         
[   setSpherePos r s t pd
         
]
         
pu
      
]
   
end
   
   
be Sphere3 r
      
pu
         
for [48 360 24]
         
[       for [45 180 16]
         
[   setSpherePos r s t pd
         
]
         
pu
      
]
      
pu
         
for [45 180 16]
         
[       for [48 360 24]
         
[   setSpherePos r s t pd
         
]
         
pu
      
]
   
end
   
   
be sphere4 :r :o
      
pu
         
for [0 360 20]
         
[       for [0 180 15]
               
[  setxyz :o:r*(cos :s)*sin :t :r*cos :t :r*(sin :s)*sin :t pd
         
]
         
pu
      
]
      
pu
         
for [0 180 15]
         
[       for [0 360 20]
               
[  setxyz :o:r*(cos :s)*sin :t :r*cos :t :r*(sin :s)*sin :t pd
         
]
         
pu
      
]
   
end
   
   
be sq
      
repeat 4
      
[   fd 115 rt 90
      
]
      
fd 24
      
Star 90
      
bk 24
   
end
   
   
be sq1
      
repeat 4
      
[   fd 115 rt 90
      
]
   
end
   
   
be Square
      
repeat 4
      
[   fd 50 rt 90
      
]
   
end
   
   
be Squares
      
repeat 12
      
[   Square fd 50 down 30
      
]
   
end
   
   
be Squares2
      
repeat 8
      
[   Square rightRoll 40
      
]
   
end
   
   
be Squares3
      
repeat 8
      
[   Square down 40
      
]
   
end
   
   
be Star l
      
if 3
      
[   repeat 5
         
[   fd l/4
            
Star l/3
            
fd l/2
            
rt 72
         
]
      
]
   
end
   
   
be Torous
      
repeat 18
      
[   Circl1 50 rightRoll 20
      
]
   
end
   
   
be tyre
      
for [0 180 15][for [fi 0 360 15][setCylinderPos fun2 :h :fi :h/pd]pu]
      
for [fi 0 360 15][for [0 180 15][setCylinderPos fun2 :h :fi :h/pd]pu]
   
end
   
   
be Wall_of_Cubes
      
for [-100 100 50]
      
[   for [-100 100 50]
         
[   pu setxyz i j  pd
            
Cube
         
]
      
]
   
end
   
   
be Wall_of_Cubes1
      
for [0 150 50]
      
[   for [0 150 50]
         
[   pu setxyz 50 i j  pd
            
Cube
         
]
      
]
   
end
end