''bluatigro 28 apr 2017
''sphere test

gosub [math]
gosub [color]
gosub [basis3d]
gosub [sphere]
gosub [avartar]

global frame

nomainwin

open "sphere-test" for graphics as #m
  #m "trapclose [quit]"
  call camara 0,0,0 , 0,0,0 , 1
  for height = 0 to winy
    scan
    call link 1 , 100,100,0 , 30,0,0 , xyz , 0
    call animation human.walk , hoek , 30
    call man yellow , blue
    call link 1 , -100,100,0 , 30,0,0 , xyz , 0
    call animation dog.walk , hoek , 30
    call pilko orange
  next height
wait
[quit]
  close #m
end

'include _math.bas
'include _color.bas
'include _basis3d.bas
'include _sphere.bas
'include _avartar.bas
'include _animation.bas
 

''bluatigro 18 nov 2016
''math block

[math]
  global pi , golden.ratio , true , false
  pi = atn( 1 ) * 4
  golden.ratio = ( sqr( 5 ) - 1 ) / 2
  false = 0
  true = not( false )
return               

function range( l , h )
  range = rnd(0) * ( h - l ) + l
end function

function rad( deg )
''from degrees to radians
  rad = deg * pi / 180
end function

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

 

''bluatigro 18 nov 2016
''color block
''needs math block

[color]
  global black , red , green , yellow
  global blue , magenta , cyan , white
  global pink , orange , gray , purple
  black   = rgb(   0 ,   0 ,   0 )
  red     = rgb( 255 ,   0 ,   0 )
  green   = rgb(   0 , 255 ,   0 )
  yellow  = rgb( 255 , 255 ,   0 )
  blue    = rgb(   0 ,   0 , 255 )
  magenta = rgb( 255 ,   0 , 255 )
  cyan    = rgb(   0 , 255 , 255 )
  white   = rgb( 255 , 255 , 255 )
  pink    = rgb( 255 , 127 , 127 )
  orange  = rgb( 255 , 127 ,   0 )
  gray    = rgb( 127 , 127 , 127 )
  purple  = rgb( 127 ,   0 , 127 )
return

sub setcolor kl
  r = int( kl and 255 )
  g = int( kl / 256 ) and 255
  b = int( kl / 256 / 256 ) and 255
  print #m , "backcolor " ; r ;" "; g ; " "; b
  print #m , "color " ; r ; " " ; g ; " " ; b
end sub

function rgb( r , g , b )
  rgb = ( int( r ) and 255 ) _
  + ( int( g ) and 255 ) * 256 _
  + ( int( b ) and 255 ) * 256 * 256
end function

function rainbow( x )
  r = sin( rad( x ) ) * 127 + 128
  g = sin( rad( x - 120 ) ) * 127 + 128
  b = sin( rad( x + 120 ) ) * 127 + 128
  rainbow = rgb( r , g , b )
end function

function mix( kl1 , f , kl2 )
  r1 = int( kl1 and 255 )
  g1 = int( kl1 / 256 ) and 255
  b1 = int( kl1 / 256 / 256 ) and 255
  r2 = int( kl2 and 255 )
  g2 = int( kl2 / 256 ) and 255
  b2 = int( kl2 / 256 / 256 ) and 255
  r = r1 + ( r2 - r1 ) * f
  g = g1 + ( g2 - g1 ) * f
  b = b1 + ( b2 - b1 ) * f
  mix = rgb( r , g , b )
end function
 

''bluatigro 18 nov 2016
''3d engine block
''needs math block

[basis3D]
  global mmax
  mmax = 20
  dim m( ( mmax + 5 ) * 4 * 4 + 16 ) , cam( 6 )
  dim skx( 64 ) , sky( 64 ) , skz( 64 )
  global rotx , roty , rotz  , trans , temp , number , m44nr , pi
  trans = mmax + 1
  rotx = mmax + 2
  roty = mmax + 3
  rotz = mmax + 4
  temp = mmax + 5
  pi = atn( 1 ) * 4
  global xyz , xzy , yxz , yzx , zxy , zyx
  xzy = 1
  yxz = 2
  yzx = 3
  zxy = 4
  zyx = 5   
  call startmatrix
return

function pend( fase , amp )
  pend = sin( rad( fase ) ) * amp
end function

sub skelet lim , x , y , z
''for animating avatar lim's
  skx( lim ) = x
  sky( lim ) = y
  skz( lim ) = z
end sub

sub push.m44
  m44nr = m44nr + 1
end sub

sub pop.m44
  m44nr = m44nr - 1
end sub

sub ido x , y , z , lim , ax
  call child m44nr , x , y , z , lim , ax , m44nr - 1
end sub

sub child no , x , y , z , lim , ax , p
''for creating lim's of a avatar
  if lim < 0 or lim > 64 then exit sub
  call link no , x , y , z _
  , sky( lim ) , skx( lim ) , skz( lim ) , ax , p
end sub

sub link no , x , y , z , xz , yz , xy , ax , p
''set draw matrix : wil efect future drawing

''no : number new matrix
''x,y,z : translation
''xz,yz,xy : rotation in degrees
''ax : sequence of axes
''p : number old matrix

  if no < 1 or no > mmax then exit sub
  if p < 0 or p > mmax then exit sub
  if no < 1 or no > mmax then exit sub
  if p < 0 or p > mmax then exit sub
  if p = no then exit sub
''copy matrix 0 into matrix's
  call copy 0 , rotx
  call copy 0 , roty
  call copy 0 , rotz
  call copy 0 , trans
''create rotation matrix's
  m( in( rotx , 1 , 1 ) ) = cos( rad( yz ) )
  m( in( rotx , 1 , 2 ) ) = 0-sin( rad( yz ) )
  m( in( rotx , 2 , 1 ) ) = sin( rad( yz ) )
  m( in( rotx , 2 , 2 ) ) = cos( rad( yz ) )

  m( in( roty , 0 , 0 ) ) = cos( rad( xz ) )
  m( in( roty , 0 , 2 ) ) = 0-sin( rad( xz ) )
  m( in( roty , 2 , 0 ) ) = sin( rad( xz ) )
  m( in( roty , 2 , 2 ) ) = cos( rad( xz ) )

  m( in( rotz , 0 , 0 ) ) = cos( rad( xy ) )
  m( in( rotz , 0 , 1 ) ) = 0-sin( rad( xy ) )
  m( in( rotz , 1 , 0 ) ) = sin( rad( xy ) )
  m( in( rotz , 1 , 1 ) ) = cos( rad( xy ) )
''create translation matrix
  m( in( trans , 3 , 0 ) ) = x
  m( in( trans , 3 , 1 ) ) = y
  m( in( trans , 3 , 2 ) ) = z
''select axes sequence [ 1 of 6 ] and act on i
  select case ax
    case xyz
      call multiply rotx , roty , temp
      call multiply temp , rotz , no
      call multiply no , trans , temp
      call multiply temp , p , no
    case xzy
      call multiply rotx , rotz , temp
      call multiply temp , roty , no
      call multiply no , trans , temp
      call multiply temp , p , no
    case yxz
      call multiply roty , rotx , temp
      call multiply temp , rotz , no
      call multiply no , trans , temp
      call multiply temp , p , no
    case yzx
      call multiply roty , rotz , temp
      call multiply temp , rotx , no
      call multiply no , trans , temp
      call multiply temp , p , no
    case zxy
      call multiply rotz , rotx , temp
      call multiply temp , roty , no
      call multiply no , trans , temp
      call multiply temp , p , no
    case zyx
      call multiply rotz , roty , temp
      call multiply temp , rotx , no
      call multiply no , trans , temp
      call multiply temp , p , no
    case else
      call multiply rotx , roty , temp
      call multiply temp , rotz , no
      call multiply no , trans , temp
      call multiply temp , p , no
  end select
  number = no
end sub

sub copy a , b
''matrix( b ) = matrix( a )
  for i = 0 to 3
    for j = 0 to 3
      m( in( b , i , j ) ) = m( in( a , i , j ) )
    next j
  next i
end sub

sub spot byref x , byref y , byref z
'''lokal coordinates to world coordinates
''x,y,z = matrix( number ) * x,y,z
  no = number
  hx = m( in( no , 0 , 0 ) ) * x _
     + m( in( no , 1 , 0 ) ) * y _
     + m( in( no , 2 , 0 ) ) * z _
     + m( in( no , 3 , 0 ) )
  hy = m( in( no , 0 , 1 ) ) * x _
     + m( in( no , 1 , 1 ) ) * y _
     + m( in( no , 2 , 1 ) ) * z _
     + m( in( no , 3 , 1 ) )
  hz = m( in( no , 0 , 2 ) ) * x _
     + m( in( no , 1 , 2 ) ) * y _
     + m( in( no , 2 , 2 ) ) * z _
     + m( in( no , 3 , 2 ) )
  x = hx - cam( 0 )
  y = hy - cam( 1 )
  z = hz - cam( 2 )
  call rotate x , y , 0 - cam( 5 )
  call rotate y , z , 0 - cam( 4 )
  call rotate x , z , 0 - cam( 3 )
  if cam( 6 ) = 0 then cam( 6 ) = 1
  x = x * cam( 6 )
  y = y * cam( 6 )
  z = z * cam( 6 )
end sub

sub camara x,y,z,pan,tilt,rol,zoom
  cam( 0 ) = x
  cam( 1 ) = y
  cam( 2 ) = z
  cam( 3 ) = pan
  cam( 4 ) = tilt
  cam( 5 ) = rol
  cam( 6 ) = zoom
end sub

sub multiply a , b , c
''matrix( c ) = matrix( a ) * matrix( b )
  for i = 0 to 3
    for j = 0 to 3
      m( in( c , i , j ) ) = 0
      for k = 0 to 3
        m( in( c , i , j ) ) = m( in( c , i , j ) ) _
        + m( in( a , i , k ) ) * m( in( b , k , j ) )
      next k
    next j
  next i
end sub

sub startmatrix
''set startmatrix to unity
  for x = 0 to 3
    for y = 0 to 3
      m( in( 0,x,y ) ) = 0
    next y
    m( in( 0,x,x ) ) = 1
  next x
end sub

function in( no , x , y )
''LB4 has no 3d array's
''so i simulate them
  in = x + y * 4 + no * 16
end function
 

''bluatigro 18 nov 2016
''sphere world block
''needs color , basis3D and math block

[sphere]
  global height
return

sub sphere x , y , z , d , kl
  scan
  call spot x , y , z
  d = d * cam( 6 )
  dx = WindowWidth
  dy = WindowHeight
  if height = 0 then
    call setcolor black
    print #m , "goto " ; dx / 2 + x ; " " _
    ; dy * 5 / 6 - z / 4
    print #m , "down"
    print #m , "ellipsefilled " ; d * 2 ; " " ; d / 2
    print #m , "up"
  end if
  if abs( height - y ) < d then
    dd = sqr( d ^ 2 - ( height - y ) ^ 2 ) * 2
    kl = mix( kl , 1 - ( height - y ) / d / 2 + 0.5 , 0 )
    call setcolor kl
    print #m , "goto "; dx / 2 + x ;" " _
    ; dy * 5 / 6 - height - z / 4
    print #m , "down"
    print #m , "ellipsefilled "; dd ;" "; dd / 4
    print #m , "up"
  end if
end sub

sub egg x1 , y1 , z1 , d1 , x2 , y2 , z2 , d2 , dm , kl , n
  diff = sqr( ( x1 - x2 ) ^ 2 _
            + ( y1 - y2 ) ^ 2 _
            + ( z1 - z2 ) ^ 2 )
  dx = ( x2 - x1 ) / diff
  dy = ( y2 - y1 ) / diff
  dz = ( z2 - z1 ) / diff
  dd = ( d2 - d1 ) / diff
  if dm = 0 then dm = ( d1 + d2 ) / 2
  if n < 3 then n = diff
  for i = 0 to diff step diff / n
    scan
    call sphere x1 + dx * i _
    , y1 + dy * i _
    , z1 + dz * i _
    , d1 + dd * i _
    + sin( i / diff * pi ) _
    * ( dm - ( d1 + d2 ) / 2 ) _
    , kl
  next i
end sub

sub bezier x1,y1,z1,d1 , x2,y2,z2,d2 , x3,y3,z3,d3 , x4,y4,z4,d4 , kl , dist
  r = int( kl ) and 255
  g = int( kl / 256 ) and 255
  b = int( kl / 256 / 256 ) and 255
  if dist < 1 then dist = 1
  if sqr((x1-x2)^2+(y1-y2)^2+(z1-z2)^2) < dist then
    call sphere x1,y1,z1,d1,kl
  else
    ax = ( x1 + x2 ) / 2
    ay = ( y1 + y2 ) / 2
    az = ( z1 + z2 ) / 2
    ad = ( d1 + d2 ) / 2
    bx = ( x3 + x4 ) / 2
    by = ( y3 + y4 ) / 2
    bz = ( z3 + z4 ) / 2
    bd = ( d3 + d4 ) / 2
    cx = ( x3 + x2 ) / 2
    cy = ( y3 + y2 ) / 2
    cz = ( z3 + z2 ) / 2
    cd = ( d3 + d2 ) / 2
    a1x = ( ax + cx ) / 2
    a1y = ( ay + cy ) / 2
    a1z = ( az + cz ) / 2
    a1d = ( ad + cd ) / 2
    b1x = ( bx + cx ) / 2
    b1y = ( by + cy ) / 2
    b1z = ( bz + cz ) / 2
    b1d = ( bd + cd ) / 2
    c1x = ( a1x + b1x ) / 2
    c1y = ( a1y + b1y ) / 2
    c1z = ( a1z + b1z ) / 2
    c1d = ( a1d + b1d ) / 2
    scan
    call bezier x1,y1,z1,d1 , ax,ay,az,ad , a1x,a1y,a1z,a1d , c1x,c1y,c1z,c1d , kl , dist
    call bezier c1x,c1y,c1z,c1d , b1x,b1y,b1z,b1d , bx,by,bz,bd , x4,y4,z4,d4 , kl , dist
  end if
end sub
 

''bluatigro 1 dec 2016
''avartar block
''needs sphere|ray world , color , basis3D and math block

[avartar]
  global arm , elbow , wrist
  arm = 0
  elbow = 1
  wrist = 2
  global leg , knee , enkle
  leg = 3
  knee = 4
  enkle = 5
  global neck , head , eye
  neck = 6
  head = 7
  eye = 8
  global thumb , index , midle , ring
  thumb = 9
  index = 12
  midle = 15
  ring = 18
  global tail , body , lr
  tail = 21
  body = 22
  lr = 32
  global ileg,iknee,iwing,ineck,iarm,ielbow
  global iwrist,ithumb,ifinger,ieye,itail
  ileg = 0
  iknee = 5
  iwing = 10
  ineck = 12
  iarm = 13
  ielbow = 14
  iwrist = 15
  ithumb = 16
  ifinger = 17
  ieye = 18
  itail = 19
  global istand,ileftlegs,irightlegs,ileftbox
  global irightbox,ifly,isting,home,dogwalk,manwalk
  istand = 0
  ileftlegs = 1
  irightlegs = 2
  ileftbox = 3
  irightbox = 4
  ifly = 5
  isting = 6
  home = 7
  dogwalk = 8
  manwalk = 9
return

Sub kop qq , kl
    call link 15, 0, 0, 0, 0, 0, 0 , xyz , number
        call sphere 0, 0, 0, 30, kl
    If qq = 1 Then
        call sphere 25, 25, 0, 9, kl
        call sphere -25, 25, 0, 9, kl
        call sphere 0, 0, -40, 10, gray
    Else
        call sphere 30, 0, 0, 9, kl
        call sphere -30, 0, 0, 9, kl
        call sphere 0, 0, -40, 12, kl
    End If
        call child 16, 14, 14, -14, eye ,xyz, 15
          call sphere 0, 0, 0, 13, white
          call sphere 0, 0, -10, 7, black
        call child 16, -14, 14, -14, eye + lr,xyz, 15
          call sphere 0, 0, 0, 13, white
          call sphere 0, 0, -10, 7, black
end sub

sub man trui , broek
    call child 9, 0, 0, 0, body+lr , xyz , number
    call child 10, 0, 0, 0, body , xyz , 9
        call sphere 0, 50, 0, 30, trui
        call sphere 0, 25, 0, 23, broek
        call sphere 0, 0, 0, 15, broek
    call child 11, 0, 70, 0, neck, xyz, 10
    call child 12, 0, 30, 0, neck+lr, xyz, 11
        call kop 0, pink
    call child 11, 20, -10, 0, leg, yzx, 9
        call sphere 0, 0, 0, 16, broek
        call sphere 0, -20, 0, 16, broek
    call child 12, 0, -40, 0, knee, xyz, 11
        call sphere 0, 0, 0, 16, broek
        call sphere 0, -20, 0, 16, broek
    call child 13, 0, -40, 0, enkle, xzy, 12
        call sphere 0, 0, 0, 12, gray
        call sphere 0, 0, -20, 12, gray
    call child 11, -20, -10, 0, leg+lr , yzx, 10
        call sphere 0, 0, 0, 16, broek
        call sphere 0, -20, 0, 16, broek
    call child 12, 0, -40, 0, knee+lr, xyz, 11
        call sphere 0, 0, 0, 16, broek
        call sphere 0, -20, 0,16, broek
    call child 13, 0, -40, 0,enkle+lr, xzy, 12
        call sphere 0, 0, 0, 12, gray
        call sphere 0, 0, -20, 12, gray
    call child 11, 40, 60, 0, arm, xzy, 10
        call sphere 0, 0, 0, 16, trui
        call sphere 6, -20, 0, 12, trui
    call child 12, 6, -40, 0, elbow, xyz, 11
        call sphere 0, 0, 0, 12, trui
        call sphere 0, -20, 0, 12, trui
        call sphere 0, -42, 0, 8, pink
    call child 11, -40, 60, 0, arm+lr, xzy, 10
        call sphere 0, 0, 0, 16, trui
        call sphere -6, -20, 0, 12, trui
    call child 12, -6, -40, 0, elbow+lr, xyz, 11
        call sphere 0, 0, 0, 12, trui
        call sphere 0, -20, 0, 12, trui
        call sphere 0, -42, 0, 8, pink
end sub

sub pilko kl
call  sphere 0,0,0,30 , kl
call  sphere 0,0,50,30 , kl
call  child 2 , 0,20,-20 , neck , xyz , 1
call    child 3 , 0,20,-20 , neck + lr , zyx , 2
call      kop 1 , kl
call  child 11, 20, -10, 50, leg, yzx, 1
call    sphere 0, 0, 0, 16, kl
call    sphere 0, -20, 0, 16, kl
call    child 12, 0, -40, 0, knee, xyz, 11
call      sphere 0, 0, 0, 16, kl
call      sphere 0, -20, 0, 16, kl
call      child 13, 0, -40, 0, enkle, xzy, 12
call        sphere 0, 0, 0, 12, kl
call        sphere 0, 0, -20, 12, kl
call  child 11, -20, -10, 50, leg+lr, yzx, 1
call    sphere 0, 0, 0, 16, kl
call    sphere 0, -20, 0, 16, kl
call    child 12, 0, -40, 0, knee+lr, xyz, 11
call      sphere 0, 0, 0, 16, kl
call      sphere 0, -20, 0, 16, kl
call      child 13, 0, -40, 0, enkle+lr, xzy, 12
call        sphere 0, 0, 0, 12, kl
call        sphere 0, 0, -20, 12, kl
call  child 11, 20, -10, 0, arm, yzx, 1
call    sphere 0, 0, 0, 16, kl
call    sphere 0, -20, 0, 16, kl
call    child 12, 0, -40, 0, elbow, xyz, 11
call      sphere 0, 0, 0, 16, kl
call      sphere 0, -20, 0, 16, kl
call      child 13, 0, -40, 0, wrist, xzy, 12
call        sphere 0, 0, 0, 12, kl
call        sphere 0, 0, -20, 12, kl
call  child 11, -20, -10, 0, arm+lr, yzx, 1
call    sphere 0, 0, 0, 16, kl
call    sphere 0, -20, 0, 16, kl
call    child 12, 0, -40, 0, elbow+lr, xyz, 11
call      sphere 0, 0, 0, 16, kl
call      sphere 0, -20, 0, 16, kl
call      child 13, 0, -40, 0, wrist+lr, xzy, 12
call        sphere 0, 0, 0, 12, kl
call        sphere 0, 0, -20, 12, kl
call  child 3 , 0,14,90 , tail , xyz , 2
    for i = 0 to 5
call      sphere 0,i*12,0,10 , kl
    next i

end sub

sub animation anim , frame , amp
  select case anim
  case manwalk
call    skelet leg , pend( frame , amp ) , 0 , 0
call    skelet knee , pend( frame - 90 , amp ) + amp  , 0 , 0
call    skelet leg + lr , pend( frame + 180 , amp ) , 0 , 0
call    skelet knee + lr , pend( frame + 90 , amp ) + amp , 0 , 0
call    skelet arm , pend( frame + 180 , amp ) , 0 , 0
call    skelet elbow , 0 -amp , 0 , 0
call    skelet arm + lr , pend( frame , amp ) , 0 , 0
call    skelet elbow + lr , 0 -amp , 0 , 0
  case dogwalk
call    skelet leg , pend( frame , amp ) , 0 , 0
call    skelet knee , pend( frame - 90 , amp ) + amp  , 0 , 0
call    skelet leg + lr , pend( frame + 180 , amp ) , 0 , 0
call    skelet knee + lr , pend( frame + 90 , amp ) + amp , 0 , 0
call    skelet arm , pend( frame , amp ) , 0 , 0
call    skelet elbow , pend( frame - 90 , amp ) + amp  , 0 , 0
call    skelet arm + lr , pend( frame + 180 , amp ) , 0 , 0
call    skelet elbow + lr , pend( frame + 90 , amp ) + amp , 0 , 0
call    skelet tail , -45 , pend( frame * 2 , amp ) , 0
    case ileftlegs
      for i = 0 to 4
call          skelet ileg+i , 0,0,pend(frame+180*i,amp)
call          skelet iknee+i , pend(frame+180+180*i,amp),0,0
        next i
    case irightlegs
      for i = 0 to 4
call          skelet ileg+i+lr , 0,0,pend(frame+180*i,amp)
call          skelet iknee+i+lr , pend(frame+180+180*i,amp),0,0
      next i
    case isting
call      skelet itail , 90/7+pend(frame,amp) , 0 , 0
call      skelet itail+lr , 90/7-pend(frame,amp) , 0 , 0
    case ifly
call      skelet iwing , 0 , 0 , pend(frame,amp)
call      skelet iwing+1 , 0 , 0 , pend(frame,amp)
call      skelet iwing+lr , 0 , 0 , 0-pend(frame,amp)
call      skelet iwing+1+lr , 0 , 0 , 0-pend(frame,amp)
    case ileftbox
call      skelet iarm , 0 , pend(frame,amp)-20 , 0
call      skelet ielbow , 0 , 30-pend(frame,amp) , 0
    case irightbox
call      skelet iarm+lr , 0 , 20-pend(frame,amp) , 0
call      skelet ielbow+lr , 0 , pend(frame,amp)-30 , 0
    case home
      for i = 0 to 64
call        skelet i , 0 , 0 , 0
      next i
    case else
call    skelet itail , 90/7,0,0
call    skelet itail+lr , 90/7,0,0
call    skelet iarm , 0,-20,0
call    skelet ielbow , 0,30,0
call    skelet iarm+lr , 0,20,0
call    skelet ielbow+lr , 0,-30,0
call    skelet ineck+lr , 20,0,0
call    skelet ieye , -20,0,0
call    skelet ieye+lr , -20,0,0
  end select
end sub
 

''bluatigro 1 dec 2016
''animation block

function nr$( no , m )
  nr$ = right$( "00000000" ; no , m )
end function

sub saveframe f$ , no , m
  #m "getbmp screen 0 0 " ; winx ; " " ; winy
  bmpsave "screen" , f$ + nr$( no , m ) + ".bmp"
end sub

sub dia f$ , ms
  loadbmp "screen" , f$ + ".bmp"
  #m "background screen"
  #m "drawsprites"
  call sleep ms
end sub 

sub movie f$ , p , m , ms , k
  for i = 1 to k
    for j = 0 to p
      call dia f$ + nr$( j , m ) , ms
    next j
  next i
end sub

sub sleep ms
  CallDLL #kernel32, "Sleep" _
  , ms  As long _
  , ret As void
end sub
 

gosub [basis3d] 

[basis3D]