  #compact
  % filename "t.exe"
 'uses rtl64
  % Title    "Vessels:    (left-click & right-click)"
  % Animated
  % ScaleUp
 '% PlaceCentral
 '% AnchorCentral

  uses ConsoleG

  %side 8

  indexbase 0

  type ShapeProfile
  =================
  float px,py,pz  'position
  float nx,ny,nz  'normal
  float ax,ay,az  'angle for bending
  float tx,ty     'texture mapping
  end type

  sub CalcNormXY(ShapeProfile*p,int n)
  ====================================
  indexbase 0
  'CREATE SMOOTH NORMALS
  int i,k
  double c,d,f
  for i=0 to n-1
    k=i+1
    if k>=n then
      k=i-1
      p[i].nx=p[k].nx
      p[i].ny=p[k].ny
      exit for
    end if
    p[i].nx=1
    c=p[k].px-p[i].px
    d=p[k].py-p[i].py
    p[i].nx= d
    p[i].ny=-c
  next
  'ADJUST NORMALS: mean of 2 slopes
  for i=n-2 to 1 step-1
    k=i-1
    p[i].nx+=p[k].nx
    p[i].ny+=p[k].ny
    'UNITY ADJUST
    f=1/hypot(p[i].nx,p[i].ny)
    p[i].nx*=f
    p[i].ny*=f
  next
  end sub

  sub CalcNormXZ(ShapeProfile*p,int n)
  ====================================
  'CREATE SMOOTH NORMALS
  indexbase 0
  int i,k
  double c,d,f
  for i=0 to n-1
    k=i+1
    if k>=n then
      k=0
    end if
    c=p[k].px-p[i].px
    d=p[k].pz-p[i].pz
    p[i].nx=-d
    p[i].nz= c
  next
  'ADJUST NORMALS: mean of 2 slopes
  for i=n-1 to 0 step-1
    k=i-1
    if k<0 then k=n-1
    p[i].nx+=p[k].nx
    p[i].nz+=p[k].nz
    'UNITY ADJUST
    f=1/hypot(p[i].nx,p[i].nz)
    p[i].nx*=f
    p[i].nz*=f
  next
  end sub


  sub rotateabout(vector*p,*q,*a)
  ===============================
  Vector r
  double dxy,dxz,dzy
  double axy,axz,azy
  r.x=p.x-q.x
  r.y=p.y-q.y
  r.z=p.z-q.z
  if a.x then
    azy=atan(r.y,r.z)+a.x : dzy=hypot(r.y,r.z)
    r.z=dxz*cos(azy) : r.y=dxz*sin(azy)
  end if
  if a.y then
    axz=atan(r.z,r.x)+a.y : dxz=hypot(r.x,r.z)
    r.x=dxz*cos(axz) : r.z=dxz*sin(axz)
  end if
  if a.z then
    axy=atan(r.y,r.x)+a.z : dxy=hypot(r.x,r.y)
    r.x=dxy*cos(axy) : r.y=dxy*sin(axy)
  end if
  p.x=r.x+q.x
  p.y=r.y+q.y
  p.z=r.z+q.z
  end sub

  sub Vessel(ShapeProfile *p,*q,*r, int m,n)
  ==========================================
  indexbase 0
  float   pr1,pr2,py1,py2,nr1,ny1,nr2,ny2
  vector  pv1,pv2,pv3,pv4
  Vector  pp1,pp2,pn1,pn2
  Vector pc0,*pc1,*pc2
  Vector *a1,*a2 'bend angle
  int     e,i,j,k
  e=m-1
  CalcNormXY(p,m)
  CalcNormXZ(q,n)
  for j=0 to e-1
    k=j+1
    pr1=p[j].px : pr2=p[k].px
    py1=p[j].py : py2=p[k].py
    nr1=p[j].nx : nr2=p[k].nx
    ny1=p[j].ny : ny2=p[k].ny
    @pc1=@r[j].px
    @pc2=@r[k].px
    @a1=@r[j].ax
    @a2=@r[k].ax
    glBegin GL_TRIANGLE_STRIP
    for i=0 to n-1
      pp1={pr1*q[i].px, py1, pr1*q[i].pz}
      pp2={pr2*q[i].px, py2, pr2*q[i].pz}
      pn1={nr1*q[i].nx, ny1, nr1*q[i].nz}
      pn2={nr2*q[i].nx, ny2, nr2*q[i].nz}
      rotateabout pp1,pc1,a1
      rotateabout pp2,pc2,a2
      rotateabout pn1,pc0,a1
      rotateabout pn2,pc0,a2
      '
      glNormal3fv pn2 : glVertex3fv pp2
      glNormal3fv pn1 : glVertex3fv pp1
    next
    glEnd
  next
  end sub

  type celltype
  =============
  int a,n
  int x,y,z
  float px,py,pz
  float tx,ty,tz
  int shape
  end type

  sys sseed=GetTickCount
  celltype cell[512]
  int      vsphere,vess

  sub initcells()
  ===============  
  sys r,x,y,z
  'seed=0x2468abcd
  seed=sseed
  celltype *c
  @c=@cell
  for z=1 to side
    for y=1 to side
      for x= 1 to side
        r=irnd(1,5)
        c.x=x
        c.y=y
        c.z=z
        c.a=r
        c.n=z*64+y*side+x-side
        c.px= rnd()*32
        c.py= rnd()*32
        c.pz=-arnd()*100+10
        select irnd 1,2
        case 1 : c.shape=sphere
        case 2 : c.shape=vess
        end select
        @c+=sizeof cell
      next
    next
  next
  end sub


  function GameLogic(int i,optional a) as int
  ===========================================
  '
  if i=0 or i>512 then exit function
  cell[i].a=0
  return 1
  end function

  static float ay

  sub render(int i)
  =================
  int a
  celltype c at (@cell[i])
  a=c.a
  if a then
    glpushmatrix
    move c.px+c.tx, c.py+c.ty, c.pz+c.tz
    glrotatef ay,0,1,0
    if pick then
      label i
      go vsphere 'crude bounding sphere
    else
      select a
      case 1 : Material RedShiny
      case 2 : Material BlueShiny
      case 3 : Material WhiteShiny
      case 4 : Material Silver
      case 5 : Material Gold
      end select
      'REDUCE TRANSITION DISTANCE
      'if c.tx then c.tx*=.75
      'if c.ty then c.ty*=.75
      'if c.tz then c.tz*=.75
      'go sphere
      'go vess
      go c.shape
    end if
    glpopmatrix
   end if
  end sub

  sub main()
  ==========
  indexbase 0
  static ShapeProfile p[400],q[400],r[400]
  static int i,j,m,n
  static float a,b,c
  '
  if not vsphere then
    'CRUDE SPHERE
    vsphere   = CompileList : Spheric 1,1,45 : glEndList
  end if
  '
  if not vess then
    '
    'CREATE VERTICAL SHAPE PROFILE
    m=10
    p[0].px=.99  : p[0].py=-2
    p[1].px=.99  : p[1].py=-1.9
    p[2].px=.2   : p[2].py=-1.8
    p[3].px=.1   : p[3].py=-1.6
    p[4].px=.1   : p[4].py=-1
    p[5].px=.30  : p[5].py=-.5
    p[6].px=.70  : p[6].py=0
    p[7].px=.99  : p[7].py=1
    p[8].px=.99  : p[8].py=1.5
    p[9].px=.80  : p[9].py=2
    '
    'CREATE HORIZONTAL SHAPE PROFILE
    n=121
    j=0
    for i=0 to n-1
      a=rad(j)
      b=rad(j*12)
      c=1 + .03125*sin(b)
      j+=3
      q[i].px=  cos(a)*c
      q[i].pz= -sin(a)*c
    next
    '
    'CREATE VERTICAL BENDING SHAPE PROFILE
    for i=0 to 9
     'r[i].py=p[i].py
      r[i].az=rad(i*2)
    next
    '
    'CREATE SHAPE
    vess = CompileList : Vessel p,q,r,m,n : glEndList
    initcells()
    '
  end if
  '
  static float az
  static int   pki,count
  glClearColor 0,0.1,0.2,0
  if pick then
    PickSetup
  else
    'Fog 0,0.10,0.2,0.025 'FOR SENSE OF DISTANCE
    '
  end if
  '
  move 16,-16,-4
  'rotatez az : az+=.03125
  scale 2
  '
  'DISPLAY
  sys a,i,x,y
  static sys en=side*side*side
  pushstate
  for i=0 to en-1
    render i
  next
  ay+=.5
  popstate
  '
  popstate 'whole
  '
  if picked then
    GameLogic(picked)
    'pki=cell[picked].n
    pki=picked
    count++
    picked=0
  end if
  '
  end sub

  EndScript
