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.gadgets.worlds 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-world < world yaw pitch distance ;
  13
  14 : set-demo-orientation ( world yaw pitch distance -- world )
  15     [ >>yaw ] [ >>pitch ] [ >>distance ] tri* ;
  16
  17 GENERIC: far-plane ( gadget -- z )
  18 GENERIC: near-plane ( gadget -- z )
  19 GENERIC: distance-step ( gadget -- dz )
  20
  21 M: demo-world far-plane ( gadget -- z )
  22     drop 4.0 ;
  23 M: demo-world near-plane ( gadget -- z )
  24     drop 1.0 64.0 / ;
  25 M: demo-world distance-step ( gadget -- dz )
  26     drop 1.0 64.0 / ;
  27
  28 : fov-ratio ( gadget -- fov ) dim>> dup first2 min v/n ;
  29
  30 : yaw-demo-world ( yaw gadget -- )
  31     [ + ] with change-yaw relayout-1 ;
  32
  33 : pitch-demo-world ( pitch gadget -- )
  34     [ + ] with change-pitch relayout-1 ;
  35
  36 : zoom-demo-world ( distance gadget -- )
  37     [ + ] with change-distance relayout-1 ;
  38
  39 M: demo-world focusable-child* ( world -- gadget )
  40     drop t ;
  41
  42 M: demo-world pref-dim* ( gadget -- dim )
  43     drop { 640 480 } ;
  44
  45 : -+ ( x -- -x x )
  46     [ neg ] keep ;
  47
  48 : demo-world-frustum ( world -- -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 M: demo-world resize-world
  55     GL_PROJECTION glMatrixMode
  56     glLoadIdentity
  57     [ [ 0 0 ] dip dim>> first2 glViewport ]
  58     [ demo-world-frustum glFrustum ] bi ;
  59
  60 : demo-world-set-matrix ( gadget -- )
  61     GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
  62     GL_MODELVIEW glMatrixMode
  63     glLoadIdentity
  64     [ [ 0.0 0.0 ] dip distance>> neg glTranslatef ]
  65     [ pitch>> 1.0 0.0 0.0 glRotatef ]
  66     [ yaw>>   0.0 1.0 0.0 glRotatef ]
  67     tri ;
  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-world H{
  98     { T{ key-down f f "LEFT"  } [ KEY-ROTATE-STEP neg swap yaw-demo-world ] }
  99     { T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP     swap yaw-demo-world ] }
 100     { T{ key-down f f "DOWN"  } [ KEY-ROTATE-STEP neg swap pitch-demo-world ] }
 101     { T{ key-down f f "UP"    } [ KEY-ROTATE-STEP     swap pitch-demo-world ] }
 102     { T{ key-down f f "="     } [ dup distance-step neg swap zoom-demo-world ] }
 103     { T{ key-down f f "-"     } [ dup distance-step     swap zoom-demo-world ] }
 104
 105     { T{ button-down f f 1 }    [ drop reset-last-drag-rel ] }
 106     { T{ drag f 1 }             [ drag-yaw-pitch rot [ pitch-demo-world ] keep yaw-demo-world ] }
 107     { mouse-scroll              [ scroll-direction get second over distance-step * swap zoom-demo-world ] }
 108 } set-gestures
 109