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

   1 USING: accessors combinators kernel literals math math.functions
   2 math.order math.vectors namespaces opengl opengl.gl sequences
   3 ui.gadgets ui.gadgets.worlds ui.gestures ;
   4 IN: opengl.demo-support
   5
   6 CONSTANT: FOV $[ 2.0 sqrt 1 + ]
   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 pref-dim* ( gadget -- dim )
  40     drop { 640 480 } ;
  41
  42 : -+ ( x -- -x x )
  43     [ neg ] keep ;
  44
  45 : demo-world-frustum ( world -- -x x -y y near far )
  46     [ near-plane ] [ far-plane ] [ fov-ratio ] tri [
  47         nip swap FOV / v*n
  48         first2 [ -+ ] bi@
  49     ] 2keepd ;
  50
  51 M: demo-world resize-world
  52     GL_PROJECTION glMatrixMode
  53     glLoadIdentity
  54     [ [ { 0 0 } ] dip dim>> gl-viewport ]
  55     [ demo-world-frustum glFrustum ] bi ;
  56
  57 : demo-world-set-matrix ( gadget -- )
  58     flags{ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT } glClear
  59     GL_MODELVIEW glMatrixMode
  60     glLoadIdentity
  61     [ [ 0.0 0.0 ] dip distance>> neg glTranslatef ]
  62     [ pitch>> 1.0 0.0 0.0 glRotatef ]
  63     [ yaw>>   0.0 1.0 0.0 glRotatef ]
  64     tri ;
  65
  66 : reset-last-drag-rel ( -- )
  67     { 0 0 } last-drag-loc set-global ;
  68 : last-drag-rel ( -- rel )
  69     drag-loc [ last-drag-loc get v- ] keep last-drag-loc set-global ;
  70
  71 : drag-yaw-pitch ( -- yaw pitch )
  72     last-drag-rel MOUSE-MOTION-SCALE v*n first2 ;
  73
  74 : gl-vertex ( point -- )
  75     dup length {
  76         { 2 [ first2 glVertex2d ] }
  77         { 3 [ first3 glVertex3d ] }
  78         { 4 [ first4 glVertex4d ] }
  79     } case ;
  80
  81 : gl-normal ( normal -- ) first3 glNormal3d ;
  82
  83 : do-state ( mode quot -- )
  84     swap glBegin call glEnd ; inline
  85
  86 : rect-vertices ( lower-left upper-right -- )
  87     GL_QUADS [
  88         over first2 glVertex2d
  89         dup first pick second glVertex2d
  90         dup first2 glVertex2d
  91         [ first ] [ second ] bi* glVertex2d
  92     ] do-state ;
  93
  94 demo-world H{
  95     { T{ key-down f f "LEFT"  } [ KEY-ROTATE-STEP neg swap yaw-demo-world ] }
  96     { T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP     swap yaw-demo-world ] }
  97     { T{ key-down f f "DOWN"  } [ KEY-ROTATE-STEP neg swap pitch-demo-world ] }
  98     { T{ key-down f f "UP"    } [ KEY-ROTATE-STEP     swap pitch-demo-world ] }
  99     { T{ key-down f f "="     } [ dup distance-step neg swap zoom-demo-world ] }
 100     { T{ key-down f f "-"     } [ dup distance-step     swap zoom-demo-world ] }
 101
 102     { T{ button-down f f 1 }    [ drop reset-last-drag-rel ] }
 103     { T{ drag f 1 }             [ drag-yaw-pitch rot [ pitch-demo-world ] keep yaw-demo-world ] }
 104     { mouse-scroll              [ scroll-direction get second over distance-step * swap zoom-demo-world ] }
 105 } set-gestures