extra/cfdg/cfdg.factor

   1
   2 USING: kernel alien.c-types combinators namespaces arrays
   3        sequences sequences.lib namespaces.lib splitting
   4        math math.functions math.vectors math.trig
   5        opengl.gl opengl.glu opengl ui ui.gadgets.slate
   6        vars colors self self.slots
   7        random-weighted colors.hsv cfdg.gl accessors
   8        ui.gadgets.handler ui.gestures assocs ui.gadgets macros
   9        qualified ;
  10 QUALIFIED: syntax
  11 IN: cfdg
  12
  13 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  14
  15 SELF-SLOTS: hsva
  16
  17 : clear-color ( color -- ) set-clear-color GL_COLOR_BUFFER_BIT glClear ;
  18
  19 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  20
  21 ! if (adjustment < 0)
  22 !   base + base * adjustment
  23
  24 ! if (adjustment > 0)
  25 !   base + (1 - base) * adjustment
  26
  27 : adjust ( val num -- val ) dup 0 > [ 1 pick - * + ] [ dupd * + ] if ;
  28
  29 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  30
  31 : hue ( num -- ) hue-> + 360 mod ->hue ;
  32
  33 : saturation ( num -- ) saturation-> swap adjust ->saturation ;
  34 : brightness ( num -- ) value->      swap adjust ->value ;
  35 : alpha      ( num -- ) alpha->      swap adjust ->alpha ;
  36
  37 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  38
  39 : h   ( num -- ) hue ;
  40 : sat ( num -- ) saturation ;
  41 : b   ( num -- ) brightness ;
  42 : a   ( num -- ) alpha ;
  43
  44 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  45
  46 VAR: color-stack
  47
  48 : init-color-stack ( -- ) V{ } clone >color-stack ;
  49
  50 : push-color ( -- ) self> color-stack> push   self> clone >self ;
  51
  52 : pop-color ( -- ) color-stack> pop dup >self set-color ;
  53
  54 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  55
  56 : double-nth* ( c-array indices -- seq ) swap [ double-nth ] curry map ;
  57
  58 : check-size ( modelview -- num ) { 0 1 4 5 } double-nth* [ abs ] map biggest ;
  59
  60 VAR: threshold
  61
  62 : iterate? ( -- ? ) get-modelview-matrix check-size threshold> > ;
  63
  64 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  65
  66 ! cos 2a   sin 2a  0  0
  67 ! sin 2a  -cos 2a  0  0
  68 !      0        0  1  0
  69 !      0        0  0  1
  70
  71 ! column major order
  72
  73 : gl-flip ( angle -- ) deg>rad dup dup dup
  74   [ 2 * cos ,   2 * sin ,       0 ,   0 ,
  75     2 * sin ,   2 * cos neg ,   0 ,   0 ,
  76           0 ,             0 ,   1 ,   0 ,
  77           0 ,             0 ,   0 ,   1 , ]
  78   { } make >c-double-array glMultMatrixd ;
  79
  80 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  81
  82 : circle ( -- )
  83   self> set-color
  84   gluNewQuadric dup 0 0.5 20 10 gluDisk gluDeleteQuadric ;
  85
  86 : triangle ( -- )
  87   self> set-color
  88   GL_POLYGON glBegin
  89     0    0.577 glVertex2d
  90     0.5 -0.289 glVertex2d
  91    -0.5 -0.289 glVertex2d
  92   glEnd ;
  93
  94 : square ( -- )
  95   self> set-color
  96   GL_POLYGON glBegin
  97     -0.5  0.5 glVertex2d
  98      0.5  0.5 glVertex2d
  99      0.5 -0.5 glVertex2d
 100     -0.5 -0.5 glVertex2d
 101   glEnd ;
 102
 103 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 104
 105 : size ( scale -- ) dup 1 glScaled ;
 106
 107 : size* ( scale-x scale-y -- ) 1 glScaled ;
 108
 109 : rotate ( angle -- ) 0 0 1 glRotated ;
 110
 111 : x ( x -- ) 0 0 glTranslated ;
 112
 113 : y ( y -- ) 0 swap 0 glTranslated ;
 114
 115 : flip ( angle -- ) gl-flip ;
 116
 117 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 118
 119 : s  ( scale -- ) size ;
 120 : s* ( scale-x scale-y -- ) size* ;
 121 : r  ( angle -- ) rotate ;
 122 : f  ( angle -- ) flip ;
 123
 124 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 125
 126 : do ( quot -- )
 127   push-modelview-matrix
 128   push-color
 129   call
 130   pop-modelview-matrix
 131   pop-color ; inline
 132
 133 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 134
 135 : recursive ( quot -- ) iterate? swap when ; inline
 136
 137 : multi ( seq -- ) random-weighted* call ;
 138
 139 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 140
 141 : [rules] ( seq -- quot )
 142   [ unclip swap [ [ do ] curry ] map concat 2array ] map
 143   [ call-random-weighted ] swap prefix
 144   [ when ] swap prefix
 145   [ iterate? ] swap append ;
 146
 147 MACRO: rules ( seq -- quot ) [rules] ;
 148
 149 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 150
 151 : [rule] ( seq -- quot )
 152   [ [ do ] swap prefix ] map concat
 153   [ when ] swap prefix
 154   [ iterate? ] prepend ;
 155
 156 MACRO: rule ( seq -- quot ) [rule] ;
 157
 158 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 159
 160 VAR: background
 161
 162 : set-initial-background ( -- ) T{ hsva f 0 0 1 1 } clone >self ;
 163
 164 : set-background ( -- )
 165   set-initial-background
 166   background> call
 167   self> clear-color ;
 168
 169 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 170
 171 USING: rewrite-closures ;
 172
 173 VAR: viewport ! { left width bottom height }
 174
 175 VAR: start-shape
 176
 177 : set-initial-color ( -- ) T{ hsva f 0 0 0 1 } clone >self ;
 178
 179 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 180
 181 SYMBOL: dlist
 182
 183 ! : build-model-dlist ( -- )
 184 !   1 glGenLists dlist set
 185 !   dlist get GL_COMPILE_AND_EXECUTE glNewList
 186 !   start-shape> call
 187 !   glEndList ;
 188
 189 : build-model-dlist ( -- )
 190   1 glGenLists dlist set
 191   dlist get GL_COMPILE_AND_EXECUTE glNewList
 192
 193   set-initial-color
 194
 195   self> set-color
 196
 197   start-shape> call
 198
 199   glEndList ;
 200
 201 : display ( -- )
 202
 203   GL_PROJECTION glMatrixMode
 204   glLoadIdentity
 205   viewport> first  dup  viewport> second  +
 206   viewport> third  dup  viewport> fourth  + gluOrtho2D
 207
 208   GL_MODELVIEW glMatrixMode
 209   glLoadIdentity
 210
 211   set-background
 212
 213   GL_COLOR_BUFFER_BIT glClear
 214
 215   init-modelview-matrix-stack
 216   init-color-stack
 217
 218   dlist get not
 219     [ build-model-dlist ]
 220     [ dlist get glCallList ]
 221   if ;
 222
 223 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 224
 225 : delete-dlist ( -- ) dlist get [ dlist get 1 glDeleteLists dlist off ] when ;
 226
 227 : cfdg-window* ( -- )
 228   C[ display ] <slate>
 229     { 500 500 }       >>pdim
 230     C[ delete-dlist ] >>ungraft
 231   dup "CFDG" open-window ;
 232
 233 : cfdg-window ( -- ) [ cfdg-window* ] with-ui ;
 234
 235 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 236
 237 SYMBOL: the-slate
 238
 239 : rebuild ( -- ) delete-dlist the-slate get relayout-1 ;
 240
 241 : <cfdg-gadget> ( -- slate )
 242   C[ display ] <slate>
 243     dup the-slate set
 244     { 500 500 } >>pdim
 245     C[ dlist get [ dlist get 1 glDeleteLists ] when ] >>ungraft
 246   <handler>
 247     H{ } clone
 248       T{ key-down f f "ENTER" } C[ drop rebuild ] swap pick set-at
 249       T{ button-down } C[ drop rebuild ] swap pick set-at
 250     >>table ;
 251
 252 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 253
 254 USE: fry
 255
 256 : cfdg-window. ( quot -- )
 257   '[ [ @ <cfdg-gadget> "CFDG" open-window ] with-scope ] with-ui ;