extra/nehe/4/4.factor

   1 USING: arrays kernel math opengl opengl.gl opengl.glu
   2 opengl.demo-support ui ui.gadgets ui.render threads accessors
   3 calendar ;
   4 IN: nehe.4
   5
   6 TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ;
   7
   8 CONSTANT: width 256
   9 CONSTANT: height 256
  10 : redraw-interval ( -- dt ) 10 milliseconds ;
  11
  12 : <nehe4-gadget> (  -- gadget )
  13   nehe4-gadget new
  14     0.0 >>rtri
  15     0.0 >>rquad ;
  16
  17 M: nehe4-gadget pref-dim* ( gadget -- dim )
  18   drop width height 2array ;
  19
  20 M: nehe4-gadget draw-gadget* ( gadget -- )
  21   GL_PROJECTION glMatrixMode
  22   glLoadIdentity
  23   45.0 width height / >float 0.1 100.0 gluPerspective
  24   GL_MODELVIEW glMatrixMode
  25   glLoadIdentity
  26   GL_SMOOTH glShadeModel
  27   0.0 0.0 0.0 0.0 glClearColor
  28   1.0 glClearDepth
  29   GL_DEPTH_TEST glEnable
  30   GL_LEQUAL glDepthFunc
  31   GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST glHint
  32   GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
  33   glLoadIdentity
  34   -1.5 0.0 -6.0 glTranslatef
  35   dup rtri>> 0.0 1.0 0.0 glRotatef
  36
  37   GL_TRIANGLES [
  38     1.0 0.0 0.0 glColor3f
  39     0.0 1.0 0.0 glVertex3f
  40     0.0 1.0 0.0 glColor3f
  41     -1.0 -1.0 0.0 glVertex3f
  42     0.0 0.0 1.0 glColor3f
  43     1.0 -1.0 0.0 glVertex3f
  44   ] do-state
  45
  46   glLoadIdentity
  47
  48   1.5 0.0 -6.0 glTranslatef
  49   dup rquad>> 1.0 0.0 0.0 glRotatef
  50   0.5 0.5 1.0 glColor3f
  51   GL_QUADS [
  52     -1.0 1.0 0.0 glVertex3f
  53     1.0 1.0 0.0 glVertex3f
  54     1.0 -1.0 0.0 glVertex3f
  55     -1.0 -1.0 0.0 glVertex3f
  56   ] do-state
  57   [ 0.2 + ] change-rtri
  58   [ 0.15 - ] change-rquad drop ;
  59
  60 : nehe4-update-thread ( gadget -- )
  61   dup quit?>> [ drop ] [
  62     redraw-interval sleep
  63     dup relayout-1
  64     nehe4-update-thread
  65   ] if ;
  66
  67 M: nehe4-gadget graft* ( gadget -- )
  68   f >>quit?
  69   [ nehe4-update-thread ] curry in-thread ;
  70
  71 M: nehe4-gadget ungraft* ( gadget -- )
  72   t >>quit? drop ;
  73
  74 : run4 ( -- )
  75   <nehe4-gadget> "NeHe Tutorial 4" open-window ;