LB Booster
Programming >> BASIC code examples >> 3D : ANAGLYPH PONG
http://lbb.conforums.com/index.cgi?board=code&action=display&num=1433848203
3D : ANAGLYPH PONG
Post by bluatigro on Jun 9th, 2015, 11:10am


you need red - blue glasses to see this

error :
- if i make a shpere bal
it does not reakt to the bats

Code:
WindowWidth = DisplayWidth
WindowHeight = DisplayHeight
global winx , winy
global scrnx , scrny , eye , you , thick
global state , speed
winx = WindowWidth
winy = WindowHeight
thick = 5
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 ) , zone( 20 , 7 )
global comp , ball , human , h.p , c.p
global h.x , h.y , h.z , h.dx , h.dy
global c.dx , c.dy
global b.x , b.y , b.z , b.dx , b.dy , b.dz , b.size
ball = 1
comp = 2
human = 3
inqbe = 4
global qbesize : qbesize = 70
b.size = 10
h.z = qbesize - b.size
speed = 1
b.dx = sign( rnd(0) * 2 - 1 ) * speed
b.dy = sign( rnd(0) * 2 - 1 ) * speed
b.dz = 0 - speed
call zoneblock human  , h.x,h.y,h.z , 20,20,20
call zoneblock comp   , 0,0,h.z , 20,20,20
call zonesphere bal   , b.x,b.y,b.z , b.size


nomainwin
open "anaglyph 3D pong" for graphics as #m
  #m "trapclose [quit]"
  #m "fill black"
  #m "when mouseMove [mmove]"
  #m "setfocus"
  #m "rule "; _R2_MERGEPEN
  call scene
  timer 100 , [tmr]
wait
end

[quit]
  close #m
end

[mmove]
  h.x = MouseX - winx / 2
  h.y = MouseY - winy / 2
  h.x = h.x * scrnx / winx
  h.y = 0 - h.y * scrny / winy
wait

[tmr]
  if zonehit( human , bal ) then
    b.dx = sign( zone( human , 0 ) _
    - zone( bal , 0 ) ) * speed
    b.dy = sign( zone( human , 1 ) _
    - zone( bal , 1 ) ) * speed
    b.dz = 0 - abs( b.dz )
  end if
  if zonehit( comp , bal ) then
    b.dx = sign( zone( comp , 0 ) _
    - zone( bal , 0 ) ) * speed
    b.dy = sign( zone( comp , 1 ) _
    - zone( bal , 1 ) ) * speed
    b.dz = abs( b.dz )
  end if
  if zone( bal , 0 ) < 0 - qbesize + b.size then
    b.dx = abs( b.dx )
  end if
  if zone( bal , 0 ) > qbesize - b.size then
    b.dx = 0 - abs( b.dx )
  end if
  if zone( bal , 1 ) < 0 - qbesize + b.size then
    b.dy = abs( b.dy )
  end if
  if zone( bal , 1 ) > qbesize - b.size then
    b.dy = 0 - abs( b.dy )
  end if
  if zone( bal , 2 ) < 0 - qbesize + b.size then
    call zoneplace bal , 0,0,0
    c.p = c.p + 1
  end if
  if zone( bal , 2 ) > qbesize + b.size then
    call zoneplace bal , 0,0,0
    h.p = h.p + 1
  end if
  c.dx = sign( zone( bal , 0 ) _
  - zone( comp , 0 ) ) * speed * 0.8
  c.dy = sign( zone( bal , 1 ) _
  - zone( comp , 1 ) ) * speed * 0.8
  call zonemove comp , c.dx , c.dy , 0
  call zonemove bal , b.dx , b.dy , b.dz
  call zoneplace human , h.x , h.y , h.z
  call scene
wait

function sign( x )
  uit = 0
  if x < 0 then uit = -1
  if x > 0 then uit = 1
  sign = uit
end function

sub scene
  #m "fill black"
  call zonedraw human
  call zonedraw bal
  call zonedraw comp
  call cubo 0,0,0 , qbesize,qbesize,qbesize , thick
  #m "flush"
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 pixel x , y , z
  call sphere x , y , z , 3 , 3
end sub

sub zonemove no , dx , dy , dz
  zone( no , 0 ) = zone( no , 0 ) + dx
  zone( no , 1 ) = zone( no , 1 ) + dy
  zone( no , 2 ) = zone( no , 2 ) + dz
end sub

sub zoneplace no , x , y , z
  zone( no , 0 ) = x
  zone( no , 1 ) = y
  zone( no , 2 ) = z
end sub

sub zoneblock no , x , y , z , dx , dy , dz
  zone( no , 0 ) = x
  zone( no , 1 ) = y
  zone( no , 2 ) = z
  zone( no , 3 ) = dx
  zone( no , 4 ) = dy
  zone( no , 5 ) = dz
  zone( no , 6 ) = -1
end sub

sub zonesphere no , x , y , z , r
  zone( no , 0 ) = x
  zone( no , 1 ) = y
  zone( no , 2 ) = z
  zone( no , 3 ) = 0
  zone( no , 4 ) = 0
  zone( no , 5 ) = 0
  zone( no , 6 ) = abs( r )
end sub

sub zonedraw no
  if zone( no , 6 ) < 0 then
    call cubo zone( no , 0 ) _
            , zone( no , 1 ) _
            , zone( no , 2 ) _
            , zone( no , 3 ) _
            , zone( no , 4 ) _
            , zone( no , 5 ) , thick
  else
    call sphere zone( no , 0 ) _
              , zone( no , 1 ) _
              , zone( no , 2 ) _
              , zone( no , 6 ) , thick
  end if
end sub

function zonehit( no1 , no2 )
''zone 1 and zone 2 = block
  if zone( no1 , 6 ) < 0 _
  and zone( no2 , 6 ) < 0 then
    dx = abs( zone( no1 , 0 ) - zone( no2 , 0 ) )
    dy = abs( zone( no1 , 1 ) - zone( no2 , 1 ) )
    dz = abs( zone( no1 , 2 ) - zone( no2 , 2 ) )
    ax = zone( no1 , 3 ) + zone( no2 , 3 )
    ay = zone( no1 , 4 ) + zone( no2 , 4 )
    az = zone( no1 , 5 ) + zone( no2 , 5 )
    zonehit = dx < ax and dy < ay and dz < ay
  end if
''zone 1 and zone 2 = sphere
  if zone( no1 , 6 ) > 0 _
  and zone( no2 , 6 ) > 0 then
    x1 = zone( no1 , 0 )
    y1 = zone( no1 , 1 )
    z1 = zone( no1 , 2 )
    d1 = zone( no1 , 6 )
    x2 = zone( no2 , 0 )
    y2 = zone( no2 , 1 )
    z2 = zone( no2 , 2 )
    d2 = zone( no2 , 6 )
    dis = sqr( ( x1 - x2 ) ^ 2 _
    + ( y1 - y2 ) ^ 2 _
    + ( z1 - z2 ) ^ 2 )
    zonehit = dis < ( d1 + d2 )
  end if
''zone 1 = sphere  zone 2 = block
  if zone( no1 , 6 ) > 0 _
  and zone( no2 , 6 ) < 0 then
    h = no1
    no1 = no2
    no2 = h
  end if
''zone 1 = block  zone 2 = sphere
  diss = 0
  x = 0 : y = 1 : z = 2 : dx = 3 : dy = 4 : dz = 5 : r = 6
  if zone( no2 , x ) _
  < ( zone( no1 , x ) - zone( no1 , dx ) ) then
    diss = diss + ( zone( no2 , x ) _
    - ( zone( no1 , x ) - zone( no1 , dx ) ) ) ^ 2
  else
    if zone( no2 , x ) _
    > ( zone( no1 , x ) + zone( no1 , dx ) ) then
      diss = diss + ( zone( no2 , x ) _
      - ( zone( no1 , x ) + zone( no1 , dx ) ) ) ^ 2
    end if
  end if
  if zone( no2 , y ) _
  < ( zone( no1 , y ) - zone( no1 , dy ) ) then
    diss = diss + ( zone( no2 , y ) _
    - ( zone( no1 , y ) - zone( no1 , dy ) ) ) ^ 2
  else
    if zone( no2 , y ) _
    > ( zone( no1 , y ) + zone( no1 , dy ) ) then
      diss = diss + ( zone( no2 , y ) _
      - ( zone( no1 , y ) + zone( no1 , dy ) ) ) ^ 2
    end if
  end if
  if zone( no2 , z ) _
  < ( zone( no1 , z ) - zone( no1 , dz ) ) then
    diss = diss + ( zone( no2 , z ) _
    - ( zone( no1 , z ) - zone( no1 , dz ) ) ) ^ 2
  else
    if zone( no2 , z ) _
    > ( zone( no1 , z ) + zone( no1 , dz ) ) then
      diss = diss + ( zone( no2 , z ) _
      - ( zone( no1 , z ) + zone( no1 , dz ) ) ) ^ 2
    end if
  end if
  zonehit = diss < zone( no2 , 6 ) ^ 2
end function

sub sphere x , y , z , d , t
  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
  #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

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


i have no stereo scopic vision
so let ne know if somthing is wrong