extra/cfdg/cfdg.factor

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