extra/nehe/4/4.factor

   1 USING: accessors calendar kernel literals math
   2 opengl.demo-support opengl.gl opengl.glu threads ui ui.gadgets
   3 ui.pixel-formats ui.render ;
   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 draw-gadget* ( gadget -- )
  18     GL_PROJECTION glMatrixMode
  19     glLoadIdentity
  20     45.0 width height / >float 0.1 100.0 gluPerspective
  21     GL_MODELVIEW glMatrixMode
  22     glLoadIdentity
  23     GL_SMOOTH glShadeModel
  24     0.0 0.0 0.0 0.0 glClearColor
  25     1.0 glClearDepth
  26     GL_DEPTH_TEST glEnable
  27     GL_LEQUAL glDepthFunc
  28     GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST glHint
  29     GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
  30     glLoadIdentity
  31     -1.5 0.0 -6.0 glTranslatef
  32     dup rtri>> 0.0 1.0 0.0 glRotatef
  33
  34     GL_TRIANGLES [
  35         1.0 0.0 0.0 glColor3f
  36         0.0 1.0 0.0 glVertex3f
  37         0.0 1.0 0.0 glColor3f
  38         -1.0 -1.0 0.0 glVertex3f
  39         0.0 0.0 1.0 glColor3f
  40         1.0 -1.0 0.0 glVertex3f
  41     ] do-state
  42
  43     glLoadIdentity
  44
  45     1.5 0.0 -6.0 glTranslatef
  46     dup rquad>> 1.0 0.0 0.0 glRotatef
  47     0.5 0.5 1.0 glColor3f
  48     GL_QUADS [
  49         -1.0 1.0 0.0 glVertex3f
  50         1.0 1.0 0.0 glVertex3f
  51         1.0 -1.0 0.0 glVertex3f
  52         -1.0 -1.0 0.0 glVertex3f
  53     ] do-state
  54     [ 0.2 + ] change-rtri
  55     [ 0.15 - ] change-rquad drop ;
  56
  57 : nehe4-update-thread ( gadget -- )
  58     dup quit?>> [ drop ] [
  59         redraw-interval sleep
  60         dup relayout-1
  61         nehe4-update-thread
  62     ] if ;
  63
  64 M: nehe4-gadget graft* ( gadget -- )
  65     f >>quit?
  66     [ nehe4-update-thread ] curry in-thread ;
  67
  68 M: nehe4-gadget ungraft* ( gadget -- )
  69     t >>quit? drop ;
  70
  71 MAIN-WINDOW: run4
  72     {
  73         { title "NeHe Tutorial 4" }
  74         { pref-dim { $ width $ height } }
  75         { pixel-format-attributes {
  76             windowed
  77             double-buffered
  78             T{ depth-bits { value 16 } }
  79         } }
  80     }
  81     <nehe4-gadget> >>gadgets ;