  '19/07/2019
  '22/02/2026
  'CP

  % on  1
  % off 0

  'DEFAULT SETTINGS
  %% fontA     "Arial",FW_NORMAL,1 // FW_SEMIBOLD
  %% fontB     "Courier New",FW_NORMAL,1
  %% ExplicitMain
 '%% WindowStyle WS_POPUP
  %% WindowStyle WS_OVERLAPPEDWINDOW
  '
  '%% Shaders
  '
  '
  macro keydown()
  ===============
  'case 32 'no action
  #ifdef NoEscape
    case 27 'take no action (otherwise close window)
  #endif
  end macro
  '
  uses OpenglSceneFrame
  uses glo2\shapes
  uses glo2\materials
  '
  #ifdef shaders
    uses glo2\ShaderSupport
  #endif
  '
  #ifdef MidiSound
    use minmidi
    sys hmo,ermo
  #endif
  
  indexbase 1

  macro SelectWithKeys(r,b,e)
  ===========================
  r=0
  select lastkey
    case 13 : r=picked  'enter
    case 32 : picked+=1 'space
    case 38 : picked-=1 'up
    case 40 : picked+=1 'down
    case 36 : picked=1  'home
    case 35 : picked=10 'end
  end select
  if picked<b then picked=e
  if picked>e then picked=b
  end macro


  'GLOBALS
  '=======

  ! main() as sys
  def print output

  type ColorType
    float r,g,b,a
  end type

  type      StateType
    float rf,gf,bf,af 'forground color
    float rb,gb,bb,ab 'background color
    float xs,ys,zs    'scale
    float xd,yd,zd    'distance
  end type
  
  def       stkmax   32
  StateType StateStack[stkmax] 'stack for color & positionstates
  sys       gwnd
  int       stko 'stack offset
  int       stke=stkmax*sizeof StateType 'stack offset limit
  sys       typeface
  int       cutn
  string    cut[1000]
  string    inputs,lastinput, previnput
  string    tab=chr(9)
  string    cr=chr(13,10)
  int       sphere,cylinder,cube
  ColorType bcolor at (@StateStack.rb) 
  ColorType fcolor at (@StateStack.rf)
 
  stke = stkmax*sizeof StateType
  bcolor={.20, .20, .40, 1.}  'background color
  fcolor = {.00, .70, .70, 1.}  'forground and text color

  sys  timer
  sys  timercall
  quad tickcount

  sub timetick (sys lpParameter,TimerOrWaitFired) callback
  ========================================================
  tickcount+=1
  if timercall then call timercall
  end sub


  sub Initialize(sys hWnd)
  ========================
  GDIplus 1
  'SetTimer hWnd,1,10,null
  % ms 20
  CreateTimerQueueTimer timer,0,@timetick, 0 ,0, ms, 0 'ms milliseconds
  gwnd=hwnd
  '
  cube = CompileList
    CubeForm 
  glEndList
  '
  sphere = CompileList
    Spheric 1,1,6
  glEndList
  '
  cylinder = CompileList
    glRotatef 180,1,0,0
    Conefaces  32,0,0,1 'BASE CAP 
    glRotatef 180,1,0,0
    Conefaces  32,1,1,1 'SIDE
    glTranslatef 0,1,0 
    Conefaces  32,0,0,1 'TOP CAP 
    glTranslatef 0,-1,0 
  glEndList
  '
  GenTextures 32
  '
  #ifdef midisound
    '-1 midimapper (will accept MidiOutLongMsg)
    ' 0 default synth
    ermo=midiOutOpen(hmo, -1, 0, 0, CALLBACK_NULL)
  #endif
  '
  end sub

  sub Release(sys hwnd)
  =====================
  DeleteAllGlCompiled
  DeleteTextures 32
  GDIplus 0
  'killTimer hwnd, 1
  DeleteTimerQueueTimer 0,timer,0
  #ifdef midisound
  MidiOutClose(hmo)
  #endif
  end sub


  sub color(float r=0.5,g=0.5,b=0.5,a=1.0)
  ========================================
  if pick then exit sub
  fcolor={r,g,b,a}
  glColor4fv fcolor.r
  '
  'SPLIT BETWEEN DIFFUSE AND AMBIENT
  float d
  d=0.75
  colortype c
  c={r*d, g*d, b*d, a}
  glMaterialfv GL_FRONT,  GL_DIFFUSE, c.r
  d=0.25
  c={r*d, g*d, b*d, a}
  glMaterialfv GL_FRONT, GL_AMBIENT, c.r
  end sub

  sub PushState
  =============
  int n=sizeof StateType
  if stko<stke
    glPushMatrix
    stko+=n
    StateType s at @StateStack+stko
    copy @s, @s-n, n
    @bcolor+=n
    @fcolor+=n
  end if
  end sub

  sub PopState
  ============
  if stko>0
    int n=sizeof StateType
    StateType s at @StateStack+stko
    @bColor-=n
    @fColor-=n
    color fcolor.r, fcolor.g, fcolor.b, fcolor.a
    stko-=n
    glPopMatrix
  end if
  end sub

  sub title(string s)
  ===================
  SetWindowText gWnd,s
  end sub

  sub PointSize(optional float ps)
  ================================
  glHint GL_POINT_SMOOTH_HINT, GL_NICEST
  glEnable GL_POINT_SMOOTH
  glPointSize ps
  end sub

  sub thickness(float th=1)
  =========================
  glHint GL_LINE_SMOOTH_HINT, GL_NICEST
  glEnable GL_LINE_SMOOTH
  glLineWidth th
  end sub

  sub point(optional float x,y,z)
  ==============================
  glBegin GL_POINTS
  glVertex3fv   x
  glEnd
  end sub

  sub line(optional float x,y,z)
  ==============================
  glBegin GL_LINES
  vector a
  glVertex3fv a.x
  glVertex3fv   x
  glEnd
  end sub

  sub grid(optional float r, int a,b,s,p)
  =======================================
  int i
  if not s then s=1
  if not r then r=s
  if not a then a=s
  if not b then b=s
  glBegin GL_LINES
  'vertical lines
  for i=0 to a step s 
    glVertex2f r*i,.0
    glVertex2f r*i,r*b
  next
  'horizontal lines
  for i=0 to b step s 
    glVertex2f .0 ,r*i
    glVertex2f r*a,r*i
  next
  glEnd
  if p then
    glColor4f 0,0,0,0 'overlay to make grid pickable
    glBegin GL_QUADS
    glVertex2f 0,0 : glVertex2f r*a,0
    glVertex2f r*a,r*b : glVertex2f 0,r*b
    glEnd
    glColor4fv fcolor
  end if
  end sub


  sub arc(optional float r,a,b,s)
  ===============================
  float ar,br,c
  if not r then r=1.0
  if a=0. and b=0. then b=360 'DEFAULT WHOLE CIRCLE
  if not s then s=5.0 'DEFAULT STEP
  s=abs(s)
  while a>b : b+=360.0 : wend
  glBegin GL_LINE_STRIP
  do
    ar=rad(a)
    br=rad(b)
    glVertex2f r*cos(ar),r*sin(ar)
    a+=s
    if a>=b
      glVertex2f r*cos(br),r*sin(br)
      exit do
    end if
  end do
  glEnd
  end sub

  sub fan(optional float r,a,b,s)
  ===============================
  float ar,br,c
  if not r then exit sub
  if a=0.0 and b=0.0 then b=360.0 'DEFAULT WHOLE CIRCLE
  if not s then s=5.0
  if not s then s=5.0 'DEFAULT STEP
  s=abs(s)
  glBegin GL_TRIANGLE_FAN
  glVertex2f 0.0, 0.0
  do
    ar=rad(a)
    br=rad(b)
    glVertex2f r*cos(ar),r*sin(ar)
    a+=s
    if a>=b
      glVertex2f r*cos(br),r*sin(br)
      exit do
    end if
  end do
  glEnd
  end sub

  sub move(optional float x,y,z)
  ==============================
  glTranslatef x,y,z
  StateType s at @StateStack+stko
  s.xd+=x
  s.yd+=y
  s.zd+=z
  end sub

  sub scale(optional float x,y,z)
  ===============================
  if not x then x=1.0
  if not y then y=x
  if not z then z=x
  glScalef x,y,z
  StateType s at @StateStack+stko
  s.xs*=x
  s.ys*=y
  s.zs*=z
  end sub

  sub Rotate(optional float a,x,y,z)
  ==================================
  if not a then exit sub
  glRotatef a,x,y,z
  end sub

  sub RotateX(optional float a)
  ==============================
  if not a then exit sub
  glRotatef a,1.,0.,0.
  end sub

  sub RotateY(optional float a)
  ==============================
  if not a then exit sub
  glRotatef a,0.,1.,0.
  end sub

  sub RotateZ(optional float a)
  ==============================
  if not a then exit sub
  glRotatef a,0.,0.,1.
  end sub


  vector*FrameScale
  '
  macro MoveThisWithMouse
  =======================
  scope
  int bl,bm,br
  if mode and 1
    'SWAP LEFT/RIGHT BUTTON FUNCTIONS
    bl=bRight
    br=bLeft
  else
    bl=bLeft
    br=bRight
  end if
  bm=bMid
  if bR
    'assume scale 1/16
    'float f=(2.4142-z*8)/crect.bottom
    float f=(32-z)/crect.bottom
    if @FrameScale
      f/=FrameScale.y
    endif
    d.x=f*(mposx-sposx)
    d.y=f*(sposy-mposy)
  else
    x+=d.x
    y+=d.y
    z+=d.z
    d.x=0.0
    d.y=0.0
    d.z=0.0
    if snap 'SNAP TO NEAREST
      x=round(x/snap)*snap
      y=round(y/snap)*snap
    end if
  end if
  '
  if bL
    a.y=aa.y+(mposx-sposx)
    a.x=aa.x+(mposy-sposy)
  else
    aa.x=a.x
    aa.y=a.y
  end if
  '
  'if bWheel
  '  if bWheel>0
  '    z-=2.0
  '  else
  '    z+=2.0
  '  end if
  'end if
  '
  if bM
    'Z MOVEMENT 
    float f=(32-z)/crect.bottom
    f=f*(sposy-mposy)*.1
    z-=f
    '
    ''SCALING
    'f=.01
    's.y=sa.y+f*(sposy-mposy)
    'if mode and 16
    '  s.x=sa.x+f*(mposx-sposx)
    '  s.z=s.x
    'else
    '  s.x=s.y
    '  s.z=s.y
    'end if
  else
    sa.x=s.x
    sa.y=s.y
    sa.z=s.z
  end if
  end scope
  end macro

  macro MoveThisWithKeys(mv,an,k)
  ===============================
  if key[VK_CONTROL]
    if key[37] then a.y-=an : k=2  ' left
    if key[39] then a.y+=an : k=2  ' right
    if key[38] then a.x-=an : k=2  ' up
    if key[40] then a.x+=an : k=2  ' down
    if key[33] then a.z+=an : k=2  ' PgUp
    if key[34] then a.z-=an : k=2  ' PgDn
    if key[36] 
      a.x=0. : a.y=0. : a.z=0. : k=3 'HOME'
    end if
    static float m
    m=1.0+m*.01
    if key[0xbd] then s.x/=m : s.y/=m : s.z/=m : k=1  ' -
    if key[0xbb] then s.x*=m : s.y*=m : s.z*=m : k=1  ' =
  else
    scope
    static float m
    if key[VK_SHIFT] then m=mv*3 else m=mv
    if key[37] then x-=m : k=1  ' left
    if key[39] then x+=m : k=1  ' right
    if key[38] then y+=m : k=1  ' up
    if key[40] then y-=m : k=1  ' down
    if key[33] then z-=m : k=1  ' PgUp
    if key[34] then z+=m : k=1  ' PgDn
    end scope
  end if
  end macro


  class MoveableObject
  ====================
  float  x,y,z    'position
  sys    render   'rendering call
  vector s        'scale
  vector a        'angle
  vector aa       'angle anchor
  vector sa       'scale anchor
  vector d        'mouse drag
  int    id       'identity for picking
  char   name[32] 'name
  float  snap     'snap to grid resolution
  int    mode     'keyboard and mouse movement modes
  int    locked   'movement & scaling locked
  int    n        'count of pp indexes   
  word   pp[32]   'indexes to other objects
  '
  method set(sys ii,rr,float xx,yy,zz)
    id=ii   : render=rr
    x=xx  : y=yy  : z=zz
    s.x=1.  : s.y=1.  : s.z=1.
    sa.x=1. : sa.y=1. : sa.z=1.
  end method
  '
  method act()
    '
    'SUPPORTS RANGE OF 100 NAMED PARTS
    if not locked
      if (picked>=id) and (picked<id+100)
        int k
        if mode and 0x100
          MoveThisWithKeys .05,1,k 'macro
        end if
        if not k
          MoveThisWithMouse      'macro
        end if
      else
        d.x=0 : d.y=0 : d.z=0 'not with picked range
      end if
      move x+d.x, y+d.y, z
      if s.x then scale s.x,s.y,s.z
      if a.z then rotateZ a.z
      if a.y then rotateY a.y
      if a.x then rotateX a.x
    end if
    PickLabel id
    if Render then call Render
  end method
  '
  end class 'moveable object

  class moveableObjects
  =====================
  moveableObject*mo
  int qo
  '
  method constructor(int n)
  @mo=getmemory n*sizeof MoveableObject
  qo=n
  end method
  '
  method destructor
  freememory @mo 
  end method
  '
  method index(int n) as MoveableObject*
    return @mo+n*sizeof MoveableObject
  end method
  '
  end class 'moveable objects


  macro Usermovement(a,c,n,nm,  i,k)
  ==================================
  if opening
    #ifndef n
      %n=1 'default single object
    #endif
    #ifndef nm
      %nm=""
    #endif
    static MoveableObject a[n] 'n moveable objects
    '#recordof a
    '#recordof moveableobject
    scope
      int k=c
      int i
      for i=1 to n             'number of objects
        a[i].mode=0x101        'key and mouse mode
        a[i].s={1.0,1.0,1.0} 'default scales
        a[i].id=k              'id of object
        a[i].name=nm
        k+=100 'addition to base ID
      next
    end scope
  endif
  #if n=1
    a.act()
  #endif
  end macro

  '#recordof usermovement

  procedure output(string s, float lf=0)
  =======================================
  if lf
    glPushMatrix
  end if
  gprint s,0,typeface
  if lf
    glPopMatrix
    glTranslatef .0,-lf,.0
  end if
  end procedure

  sub printl(optional string s)
  =============================
  output s,1.0
  end sub


  sub cls(float r=0.0, g=0.0, b=0.0, a=1.0)
  =========================================
  flat
  bcolor={r,g,b,a}
  glClearColor r, g, b, a
  end sub


  function ShowInput(string s, int cp) 
  ====================================
  int c
  int i,le,en,pt
  float x,y
  glPushMatrix
  le=len s
  en=le+1
  i=1
  pt=picktext 'save
  do
    if i>en then exit do
    if i>le then
      c=32
    else
      c=asc(s,i)
      if c<32 then c=32
    end if
    if pick=0
      colortype f at @fcolor
      if i=cp
        glColor4f f.r*.5, f.g*.5, f.b*.5, 1.0
        GetCharArea c,x,y,typeface
        PutBoxArea x,y,-.0001
        glColor4f .99,.99,.99, 1.0
      else
        glColor4f f.r, f.g, f.b, 1.0
      end if
    end if
    gprint chr(c),0,typeface
    i++
    picktext++
  end do
  picktext=pt 'restore
  glPopMatrix
  glTranslatef .0,-1.0,.0 'linefeed
  end function 'ShowInput


  int cp 'char position
  int cn ' next cell
  int le 'length of sting


  function input(bstring *s, int mo=0) as int
  ===========================================
  'mo=0 'insert
  'mo=1 'overtype
  cn=0
  le=len s
  if cp=0 or le=0
    cp=1
  endif
  if lastchar
    if key(VK_CONTROL)
      exit function
    endif
    select lastchar
    case 8 'backspace-delete
      cp-=1
      if cp<1 then
        cp=1
        function=lastchar
      else
        s=left(s,cp-1)+mid(s,cp+1)
      end if
    case 9 'tab
      '
    case 26,27 'ctrl-z, escape
      function=lastchar
    case 13 'enter
      lastinput=s
      if s then previnput=s
      function=lastchar
    case else
      s=left(s,cp-1)+chr(lastchar)+mid(s,cp+mo)
      cp+=1
    end select
  elseif lastkey
    'cursor placement etc
    select lastkey
    case 37 : cp-=1     'left
    case 39 : cp+=1     'right
    case 36 : cp=1      'home
    case 35 : cp=le+1   'end
    case 38 :           'up
    case 40 :           'down
    case 46 : 'delete
      if cp<=le
        s=left(s,cp-1)+mid(s,cp+1)
      else
        function=46
      end if
    end select
    if cp<1 then cp=1 : cn=-1
    if cp>le+1 then cp=le+1 : cn=1
  end if
  ShowInput s,cp 'show chars being entered
  end function 'input
  '
  '  
  sub TouchZone(optional float v)
  ===============================
  if not pick then exit sub
  if not v then v=1.0
  glBegin GL_QUADS
  float z=-.0001
  glVertex3f -v,-v, z
  glVertex3f  v,-v, z
  glVertex3f  v, v, z
  glVertex3f -v, v, z
  'itr 3d
  glEnd
  end sub


  sub scene(sys hWnd)
  ===================
  %ColorCodedPick
  BeginPick
  #ifdef Animated
    ActiveFrame
  #else
    LazyFrame
  #endif
  if not pick
    StandardLighting li
    StandardMaterial ma
    color .00,.80,.80,.99
  else
    PickSetup
  endif
  glDisable GL_TEXTURE_2D
  '
  #ifdef PlaceCentral
    gltranslatef  .0,.0,-2.414 'viewport bottom=-1.0 top=1.0
  #else
    #ifdef AnchorCentral
      gltranslatef  -.95,.90,-2.414 'locks to centre
    #else 'AnchorLeft
      gltranslatef  -.95*aspect,.90,-2.414 'locks to left margin
    #endif
  #endif
  float f=.0625 '1/16
  #ifndef ScaleUp
    if crect.bottom>640 then f*=640/crect.bottom
  #endif
  glscalef f,f,f
  main()
  EndPick
  bWheel=0
  end sub

  def BeginScript
  nop
  end def

  def EndScript
  MainWindow width,height, WindowStyle,2
  end def

