extra/opengl/demo-support/demo-support.factor

   1 USING: arrays kernel math math.functions math.order math.vectors
   2 namespaces opengl opengl.gl sequences ui ui.gadgets ui.gestures
   3 ui.render accessors combinators ;
   4 IN: opengl.demo-support
   5
   6 : FOV ( -- x ) 2.0 sqrt 1+ ; inline
   7 CONSTANT: MOUSE-MOTION-SCALE 0.5
   8 CONSTANT: KEY-ROTATE-STEP 10.0
   9
  10 SYMBOL: last-drag-loc
  11
  12 TUPLE: demo-gadget < gadget yaw pitch distance ;
  13
  14 : new-demo-gadget ( yaw pitch distance class -- gadget )
  15     new
  16         swap >>distance
  17         swap >>pitch
  18         swap >>yaw ;
  19
  20 GENERIC: far-plane ( gadget -- z )
  21 GENERIC: near-plane ( gadget -- z )
  22 GENERIC: distance-step ( gadget -- dz )
  23
  24 M: demo-gadget far-plane ( gadget -- z )
  25     drop 4.0 ;
  26 M: demo-gadget near-plane ( gadget -- z )
  27     drop 1.0 64.0 / ;
  28 M: demo-gadget distance-step ( gadget -- dz )
  29     drop 1.0 64.0 / ;
  30
  31 : fov-ratio ( gadget -- fov ) dim>> dup first2 min v/n ;
  32
  33 : yaw-demo-gadget ( yaw gadget -- )
  34     [ + ] with change-yaw relayout-1 ;
  35
  36 : pitch-demo-gadget ( pitch gadget -- )
  37     [ + ] with change-pitch relayout-1 ;
  38
  39 : zoom-demo-gadget ( distance gadget -- )
  40     [ + ] with change-distance relayout-1 ;
  41
  42 M: demo-gadget pref-dim* ( gadget -- dim )
  43     drop { 640 480 } ;
  44
  45 : -+ ( x -- -x x )
  46     [ neg ] keep ;
  47
  48 : demo-gadget-frustum ( gadget -- -x x -y y near far )
  49     [ near-plane ] [ far-plane ] [ fov-ratio ] tri [
  50         nip swap FOV / v*n
  51         first2 [ -+ ] bi@
  52     ] 3keep drop ;
  53
  54 : demo-gadget-set-matrices ( gadget -- )
  55     GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
  56     [
  57         GL_PROJECTION glMatrixMode
  58         glLoadIdentity
  59         demo-gadget-frustum glFrustum
  60     ] [
  61         GL_MODELVIEW glMatrixMode
  62         glLoadIdentity
  63         [ [ 0.0 0.0 ] dip distance>> neg glTranslatef ]
  64         [ pitch>> 1.0 0.0 0.0 glRotatef ]
  65         [ yaw>>   0.0 1.0 0.0 glRotatef ]
  66         tri
  67     ] bi ;
  68
  69 : reset-last-drag-rel ( -- )
  70     { 0 0 } last-drag-loc set-global ;
  71 : last-drag-rel ( -- rel )
  72     drag-loc [ last-drag-loc get v- ] keep last-drag-loc set-global ;
  73
  74 : drag-yaw-pitch ( -- yaw pitch )
  75     last-drag-rel MOUSE-MOTION-SCALE v*n first2 ;
  76
  77 : gl-vertex ( point -- )
  78     dup length {
  79         { 2 [ first2 glVertex2d ] }
  80         { 3 [ first3 glVertex3d ] }
  81         { 4 [ first4 glVertex4d ] }
  82     } case ;
  83
  84 : gl-normal ( normal -- ) first3 glNormal3d ;
  85
  86 : do-state ( mode quot -- )
  87     swap glBegin call glEnd ; inline
  88
  89 : rect-vertices ( lower-left upper-right -- )
  90     GL_QUADS [
  91         over first2 glVertex2d
  92         dup first pick second glVertex2d
  93         dup first2 glVertex2d
  94         swap first swap second glVertex2d
  95     ] do-state ;
  96
  97 demo-gadget H{
  98     { T{ key-down f f "LEFT"  } [ KEY-ROTATE-STEP neg swap yaw-demo-gadget ] }
  99     { T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP     swap yaw-demo-gadget ] }
 100     { T{ key-down f f "DOWN"  } [ KEY-ROTATE-STEP neg swap pitch-demo-gadget ] }
 101     { T{ key-down f f "UP"    } [ KEY-ROTATE-STEP     swap pitch-demo-gadget ] }
 102     { T{ key-down f f "="     } [ dup distance-step neg swap zoom-demo-gadget ] }
 103     { T{ key-down f f "-"     } [ dup distance-step     swap zoom-demo-gadget ] }
 104
 105     { T{ button-down f f 1 }    [ drop reset-last-drag-rel ] }
 106     { T{ drag f 1 }             [ drag-yaw-pitch rot [ pitch-demo-gadget ] keep yaw-demo-gadget ] }
 107     { T{ mouse-scroll }         [ scroll-direction get second over distance-step * swap zoom-demo-gadget ] }
 108 } set-gestures
 109