ANAGLYPH

''version 20/3/2011
WindowWidth = DisplayWidth
WindowHeight = DisplayHeight
global winx , winy , frame , pi
global scrnx , scrny , eye , you
global balx , baly , balz , baldx , baldy , baldz
global humanx , humany , humanz , humandz
global state , speed , frame , anascript$
dim sk( 20 , 3 )
global leg , knee , enkle , sholder , elbow , wrist , right
leg = 1
knee = 2
enkle = 3
sholder = 4
elbow = 5
wrist = 6
right = 8
winx = WindowWidth
winy = WindowHeight
pi = atn( 1 ) * 4
scrnx$ = str$( 350 )
prompt "Screen width in mm =" ; scrnx$
scrnx = val( scrnx$ )
scrny$ = str$( 280 )
prompt "Screen height in mm =" ; scrny$
scrny = val( scrny$ )
you$ = str$( 350 )
prompt "You - screen in mm =" ; you$
you = val( you$ )
eye = 70 ''pupil distance in mm
dim pen( 6 ) , cam( 6 )
nomainwin
open "anaglyph 3D pong" for graphics as #m
#m "trapclose [quit]"
#m "when charaterInput [key]"
#m "fill black"
#m "rule "; _R2_MERGEPEN
humanz = 50
call scene
timer 10000 , [tmr]
wait
end
[quit]
close #m
end
[tmr]
call scene
wait
[key]
select case right$( Inkey$ , 1 )
case "1"
state = state + 5
speed = -15
case "2"
speed = -30
case "3"
state = state - 5
speed = -15
case "4"
state = state + 5
speed = 0
case "5"
'' humandy = 20
case "6"
state = state - 5
speed = 0
case "7"
state = state + 5
case "8"
speed = 30
case "9"
state = state - 5
case else
speed = 0
end select
wait
sub scene
#m "fill black"
q$ = ""
w = rnd(0)*6+6
for i = 0 to w
x = rnd(0)*winx/2-winx/4
y = rnd(0)*winy/2-winy/4
z = rnd(0)*winx/2-winx/4
q$=q$;x;" ";y;" ";z;"| "
next i
call bspline q$
#m "flush"
end sub
sub man x , y , z , pan , fase , amp
call setpen x,y,z , pan,0,0
call lino 0,0,0 , 0,50,0 , 3
call lino -10,0,0 , 10,0,0 , 3
call sphere 0,70,0 , 20 , 3
call lino -20,50,0 , 20,50,0 , 3
call setpen x,y,z , pan,0,0
call movepen -20,50,0 , 0,sin(rad(fase+180))*amp,0
call lino 0,0,0 , 0,-30,0 , 3
call lino 0,-30,0 , 0,-30,-30 , 3
call setpen x,y,z , pan,0,0
call movepen 20,50,0 , 0,sin(rad(fase))*amp,0
call lino 0,0,0 , 0,-30,0 , 3
call lino 0,-30,0 , 0,-30,-30 , 3
call setpen x,y,z , pan,0,0
call movepen -10,0,0 , 0,sin(rad(fase))*amp,0
call lino 0,0,0 , 0,-30,0 , 3
call movepen 0,-30,0 , 0,-30-cos(rad(fase))*amp,0
call lino 0,0,0 , 0,-30,0 , 3
call lino 0,-30,0 , 0,-30,-20 , 3
call setpen x,y,z , pan,0,0
call movepen 10,0,0 , 0,sin(rad(fase+180))*amp,0
call lino 0,0,0 , 0,-30,0 , 3
call movepen 0,-30,0 , 0,-30-cos(rad(fase+180))*amp,0
call lino 0,0,0 , 0,-30,0 , 3
call lino 0,-30,0 , 0,-30,-20 , 3
end sub
function tox( x , y , z , rl )
''catch x/0 error
if z + you = 0 then tox = 0
''ofset red or blue
o = ( eye / 2 ) / ( z + you ) * you - ( eye / 2 )
o = o * rl
''ofset z + perspertif
a = ( x + o ) / ( z + you ) * you
''from mm to pixels
tox = winx / 2 + a * winx / scrnx
end function
function toy( x , y , z )
''catch x/0 error
if z + you = 0 then toy = 0
''ofset z + perspectif
a = y / ( z + you ) * you
''from mm to pixels
toy = winy / 2 - a * winy / scrny
end function
function lenght( x , y , z )
lenght = sqr( x^2 + y^2 + z^2 )
end function
sub bezier x1,y1,z1 , x2,y2,z2 , x3,y3,z3 , x4,y4,z4 , t
if lenght(x1-x2,y1-y2,z1-z2) <= 3 then
call lino x1 , y1 , z1 , x2 , y2 , z2 , t
else
ax = ( x1 + x2 ) / 2
ay = ( y1 + y2 ) / 2
az = ( z1 + z2 ) / 2
bx = ( x3 + x4 ) / 2
by = ( y3 + y4 ) / 2
bz = ( z3 + z4 ) / 2
cx = ( x3 + x2 ) / 2
cy = ( y3 + y2 ) / 2
cz = ( z3 + z2 ) / 2
a1x = ( ax + cx ) / 2
a1y = ( ay + cy ) / 2
a1z = ( az + cz ) / 2
b1x = ( bx + cx ) / 2
b1y = ( by + cy ) / 2
b1z = ( bz + cz ) / 2
c1x = ( a1x + b1x ) / 2
c1y = ( a1y + b1y ) / 2
c1z = ( alz + blz ) / 2
call bezier x1 , y1 , z1 _
, ax , ay , az _
, a1x , a1y , a1z _
, c1x , c1y , c1z , t
call bezier c1x , c1y , c1z _
, b1x , b1y , b1z _
, bx , by , bz _
, x4 , y4 , z4 , t
end if
end sub
SUB bspline a$
i = 1
first = not( 0 )
while right$( word$( a$ , i*3 ),1) = "|"
ax = val( word$( a$ , i*3-2 ) )
ay = val( word$( a$ , i*3-1 ) )
az = val( word$( a$ , i*3 ) )
bx = val( word$( a$ , i*3+1 ) )
by = val( word$( a$ , i*3+2 ) )
bz = val( word$( a$ , i*3+3 ) )
cx = val( word$( a$ , i*3+4 ) )
cy = val( word$( a$ , i*3+5 ) )
cz = val( word$( a$ , i*3+6 ) )
dx = val( word$( a$ , i*3+7 ) )
dy = val( word$( a$ , i*3+8 ) )
dz = val( word$( a$ , i*3+9 ) )
a3 = (0-ax+3*(by-cx)+dx)/6
a2 = (ax-2*bx+cx)/2
a1 = (cx-ax)/2
a0 = (ax+4*bx+cx)/6
b3 = (0-ay+3*(by-cy)+dy)/6
b2 = (ay-2*by+cy)/2
b1 = (cy-ay)/2
b0 = (ay+4*by+cy)/6
c3 = (0-az+3*(bz-cz)+dz)/6
c2 = (az-2*bz+cz)/2
c1 = (cz-az)/2
c0 = (az+4*bz+cz)/6
qx = a3+a2+a1
qy = b3+b2+b1
qz = c3+c2+c1
af = sqr(qx^2+qy^2+qz^2)+1e-10
for j = 0 to af
x0 = x
y0 = y
t = j / af
x=((a3*t+a2)*t+a1)*t+a0
y=((b3*t+b2)*t+b1)*t+b0
z=((c3*t+c2)*t+c1)*t+c0
if first then
first = 0
else
call pixel x , y , z
end if
x = x0
y = y0
next j
i = i + 1
wend
end sub
sub pixel x , y , z
call sphere x , y , z , 3 , 3
end sub
sub sphere x , y , z , d , t
call spot x , y , z
a = tox( x , y , z , 1 )
b = toy( x , y , z )
d = d / ( z + winx ) * winx
t = t / ( z + winx ) * winx
#m "size " ; t
#m "goto " ; a ; " " ; b
#m "down"
#m "color red"
#m "circle " ; d
#m "up"
a = tox( x , y , z , -1 )
#m "goto " ; a ; " " ; b
#m "down"
#m "color blue"
#m "circle " ; d
#m "up"
end sub
sub lino x1 , y1 , z1 , x2 , y2 , z2 , thick
call spot x1 , y1 , z1
call spot x2 , y2 , z2
#m "size "; thick
ax = tox( x1 , y1 , z1 , 1 )
ay = toy( x1 , y1 , z1 )
bx = tox( x2 , y2 , z2 , 1 )
by = toy( x2 , y2 , z2 )
#m "down"
#m "color red"
#m "line " ; ax ; " " ; ay ; " " ; bx ; " " ; by
#m "up"
ax = tox( x1 , y1 , z1 , -1 )
ay = toy( x1 , y1 , z1 )
bx = tox( x2 , y2 , z2 , -1 )
by = toy( x2 , y2 , z2 )
#m "down"
#m "color blue"
#m "line " ; ax ; " " ; ay ; " " ; bx ; " " ; by
#m "up"
end sub
function loadscript$( file$ )
file$ = DefaultDir$ ; "\scripts\" ; file$
open file$ for input as #in
txt$ = input$( #in , lof( #in ) )
close #in
loadscript$ = txt$
end function
[error]
close #in
notice Err$
end
'' stack stuf
function push$( stack$ , object$ , l )
''store object$ on left side stack
if l then
push$ = object$ + cut$ + stack$
else
push$ = stack$ + object$ + cut$
end if
end function
function pop$( stack$ )
''delete last object$
i = instr( stack$ , cut$ )
if stack$ = "" then pop$ = ""
''get right side of stack
pop$ = mid$( stack$ _
, i + 1 , len( stack$ ) - i )
end function
function top$( stack$ )
''read last object$
i = instr( stack$ , cut$ )
if stack$ = "" then top$ = ""
top$ = mid$( stack$ , 1 , i - 1 )
end function
sub runscript script$
cut$ = chr$( 13 )
''run script until its finished
while script$ <> ""
''get line from script
q$ = top$( script$ )
''go to next line
script$ = pop$( script$ )
''read variables from line
a = val( word$( q$ , 2 ) )
b = val( word$( q$ , 3 ) )
c = val( word$( q$ , 4 ) )
d = val( word$( q$ , 5 ) )
e = val( word$( q$ , 6 ) )
f = val( word$( q$ , 7 ) )
g = val( word$( q$ , 8 ) )
''read comand from line and execute
select case word$( q$ , 1 )
case "lino"
call lino a , b , c , d , e , f , g
case "cubo"
call cubo a , b , c , d , e , f , g
case "okto"
call okto a , b , c , d , e , f , g
case "dodeca"
call dodeca a , b , c , d , e
case else
''all non comands are remarks
end select
wend
end sub
sub okto x , y , z , dx , dy , dz , t
call lino x,y+dy,z,x,y,z+dz,t
call lino x,y,z+dz,x,y-dy,z,t
call lino x,y-dy,z,x,y,z-dz,t
call lino x,y,z-dz,x,y+dy,z,t
call lino x+dx,y,z,x,y,z+dz,t
call lino x,y,z+dz,x-dx,y,z,t
call lino x-dx,y,z,x,y,z-dz,t
call lino x,y,z-dz,x+dx,y,z,t
call lino x+dx,y,z,x,y+dy,z,t
call lino x,y+dy,z,x-dx,y,z,t
call lino x-dx,y,z,x,y-dy,z,t
call lino x,y-dy,z,x+dx,y,z,t
end sub
sub opo x , y , z , d , sides , t
if sides < 3 then sides = 3
if sides > 24 then sides = 24
for i = 0 to sides
a=i*pi*2/sides
b=(i+1)*pi*2/sides
call lino sin(a)*d+x , cos(a)*d+y , z _
, sin(b)*d+x , cos(b)*d+y , z , t
next i
end sub
sub dodeca x , y , z , d , dik
f = ( sqr( 5 ) - 1 ) / 2
''(±1, ±1, ±1)
''(0, ±1/f, ±f)
''(±1/f, ±f, 0)
''(±f, 0, ±1/f)
call lino x + d , y + d , z + d , x , y + 1/f*d , z + f*d ,dik
call lino x + d , y + d , z + d , x + 1/f*d , y + f*d , z ,dik
call lino x + d , y + d , z + d , x + f*d , y , z + 1/f*d ,dik
call lino x - d , y - d , z - d , x , y - 1/f*d , z - f*d ,dik
call lino x - d , y - d , z - d , x - 1/f*d , y - f*d , z ,dik
call lino x - d , y - d , z - d , x - f*d , y , z - 1/f*d ,dik
call lino x+1/f*d,y+f*d,z,x+1/f*d,y-f*d,z,dik
call lino x-1/f*d,y-f*d,z,x-1/f*d,y+f*d,z,dik
call lino x,y+1/f*d,z+f*d,x,y+1/f*d,z-f*d,dik
call lino x,y-1/f*d,z-f*d,x,y-1/f*d,z+f*d,dik
call lino x-f*d,y,z-1/f*d,x+f*d,y,z-1/f*d,dik
call lino x+f*d,y,z+1/f*d,x-f*d,y,z+1/f*d,dik
call lino x+1/f*d,y+f*d,z,x+d,y+d,z-d,dik
call lino x-1/f*d,y-f*d,z,x-d,y-d,z+d,dik
call lino x+f*d,y,z+1/f*d,x-f*d,y,z+1/f*d,dik
call lino x-f*d,y,z-1/f*d,x+f*d,y,z-1/f*d,dik
call lino x-f*d,y,z+1/f*d,x-d,y+d,z+d,dik
call lino x+f*d,y,z-1/f*d,x+d,y-d,z-d,dik
call lino x+f*d,y,z-1/f*d,x+d,y+d,z-d,dik
call lino x-f*d,y,z+1/f*d,x-d,y-d,z+d,dik
call lino x-d,y+d,z+d,x,y+1/f*d,z+f*d,dik
call lino x+d,y-d,z-d,x,y-1/f*d,z-f*d,dik
call lino x-d,y+d,z+d,x-1/f*d,y+f*d,z,dik
call lino x+d,y-d,z-d,x+1/f*d,y-f*d,z,dik
call lino x+f*d,y,z+1/f*d,x+d,y-d,z+d,dik
call lino x-f*d,y,z-1/f*d,x-d,y+d,z-d,dik
call lino x+d,y-d,z+d,x,y-1/f*d,z+f*d,dik
call lino x-d,y+d,z-d,x,y+1/f*d,z-f*d,dik
call lino x+d,y+d,z-d,x,y+1/f*d,z-f*d,dik
call lino x-d,y-d,z+d,x,y-1/f*d,z+f*d,dik
call lino x+d,y-d,z+d,x+1/f*d,y-f*d,z,dik
call lino x-d,y+d,z-d,x-1/f*d,y+f*d,z,dik
end sub
sub cubo mx , my , mz , dx , dy , dz , thick
call lino mx+dx,my+dy,mz+dz,mx-dx,my+dy,mz+dz,thick
call lino mx+dx,my+dy,mz-dz,mx-dx,my+dy,mz-dz,thick
call lino mx+dx,my-dy,mz+dz,mx-dx,my-dy,mz+dz,thick
call lino mx+dx,my-dy,mz-dz,mx-dx,my-dy,mz-dz,thick
call lino mx+dx,my+dy,mz+dz,mx+dx,my-dy,mz+dz,thick
call lino mx+dx,my+dy,mz-dz,mx+dx,my-dy,mz-dz,thick
call lino mx-dx,my+dy,mz+dz,mx-dx,my-dy,mz+dz,thick
call lino mx-dx,my+dy,mz-dz,mx-dx,my-dy,mz-dz,thick
call lino mx+dx,my+dy,mz+dz,mx+dx,my+dy,mz-dz,thick
call lino mx+dx,my-dy,mz+dz,mx+dx,my-dy,mz-dz,thick
call lino mx-dx,my+dy,mz+dz,mx-dx,my+dy,mz-dz,thick
call lino mx-dx,my-dy,mz+dz,mx-dx,my-dy,mz-dz,thick
end sub
sub setpen x , y , z , pan , tilt , rol
pen( 0 ) = x
pen( 1 ) = y
pen( 2 ) = z
pen( 3 ) = pan mod 360
pen( 4 ) = tilt mod 360
pen( 5 ) = rol mod 360
end sub
sub movepen x , y , z , pan , tilt , rol
call rotate x , y , pen( 5 )
call rotate y , z , pen( 4 )
call rotate x , z , pen( 3 )
call setpen pen( 0 ) + x , pen( 1 ) + y , pen( 2 ) + z _
, pen( 3 ) + pan , pen( 4 ) + tilt , pen( 5 ) + rol
end sub
sub camara x , y , z , pan , tilt , rol
cam( 0 ) = x
cam( 1 ) = x
cam( 2 ) = x
cam( 3 ) = pan mod 360
cam( 4 ) = tilt mod 360
cam( 5 ) = rol mod 360
end sub
sub rotate byref k , byref l , deg
s = sin( rad( deg ) )
c = cos( rad( deg ) )
hk = k * c - l * s
hl = k * s + l * c
k = hk : l = hl
end sub
sub spot byref x , byref y , byref z
call rotate x , y , pen( 5 )
call rotate y , z , pen( 4 )
call rotate x , z , pen( 3 )
x = x + pen( 0 ) - cam( 0 )
y = y + pen( 1 ) - cam( 1 )
z = z + pen( 2 ) - cam( 2 )
call rotate x , z , 0-cam( 3 )
call rotate y , z , 0-cam( 4 )
call rotate x , y , 0-cam( 5 )
end sub
function rad( x )
rad = x * pi / 180
end function