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

   1 USING: arrays kernel math math.functions
   2 math.order math.vectors namespaces opengl opengl.gl sequences ui
   3 ui.gadgets ui.gestures ui.render accessors ;
   4 IN: opengl.demo-support
   5
   6 : FOV 2.0 sqrt 1+ ; inline
   7 : MOUSE-MOTION-SCALE 0.5 ; inline
   8 : KEY-ROTATE-STEP 1.0 ; inline
   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-gadget
  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         [ >r 0.0 0.0 r> 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 demo-gadget H{
  78     { T{ key-down f f "LEFT"  } [ KEY-ROTATE-STEP neg swap yaw-demo-gadget ] }
  79     { T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP     swap yaw-demo-gadget ] }
  80     { T{ key-down f f "DOWN"  } [ KEY-ROTATE-STEP neg swap pitch-demo-gadget ] }
  81     { T{ key-down f f "UP"    } [ KEY-ROTATE-STEP     swap pitch-demo-gadget ] }
  82     { T{ key-down f f "="     } [ dup distance-step neg swap zoom-demo-gadget ] }
  83     { T{ key-down f f "-"     } [ dup distance-step     swap zoom-demo-gadget ] }
  84
  85     { T{ button-down f f 1 }    [ drop reset-last-drag-rel ] }
  86     { T{ drag f 1 }             [ drag-yaw-pitch rot [ pitch-demo-gadget ] keep yaw-demo-gadget ] }
  87     { T{ mouse-scroll }         [ scroll-direction get second over distance-step * swap zoom-demo-gadget ] }
  88 } set-gestures
  89