extra/processing/processing.factor

   1
   2 USING: kernel namespaces threads combinators sequences arrays
   3        math math.functions math.ranges random
   4        opengl.gl opengl.glu vars multi-methods generalizations shuffle
   5        ui
   6        ui.gestures
   7        ui.gadgets
   8        combinators
   9        combinators.lib
  10        combinators.cleave
  11        rewrite-closures fry accessors newfx
  12        processing.gadget math.geometry.rect
  13        processing.shapes
  14        colors ;
  15
  16 IN: processing
  17
  18 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  19
  20 : 2random ( a b -- num ) 2dup swap - 100 / <range> random ;
  21
  22 : 1random ( b -- num ) 0 swap 2random ;
  23
  24 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  25
  26 : chance ( fraction -- ? ) 0 1 2random > ;
  27
  28 : percent-chance ( percent -- ? ) 100 / chance ;
  29
  30 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  31
  32 ! : at-fraction ( seq fraction -- val ) over length 1- * nth-at ;
  33
  34 : at-fraction ( seq fraction -- val ) over length 1- * at ;
  35
  36 : at-fraction-of ( fraction seq -- val ) swap at-fraction ;
  37
  38 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  39
  40 GENERIC: canonical-color-value ( obj -- color )
  41
  42 METHOD: canonical-color-value { number } dup dup 1 rgba boa ;
  43
  44 METHOD: canonical-color-value { array }
  45    dup length
  46    {
  47      { 2 [ first2 >r dup dup r> rgba boa ] }
  48      { 3 [ first3 1             rgba boa ] }
  49      { 4 [ first4               rgba boa ] }
  50    }
  51    case ;
  52
  53 ! METHOD: canonical-color-value { rgba }
  54 !   { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave 4array ;
  55
  56 METHOD: canonical-color-value { color } ;
  57
  58 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  59
  60 : fill   ( value -- ) canonical-color-value >fill-color   ;
  61 : stroke ( value -- ) canonical-color-value >stroke-color ;
  62
  63 ! : no-fill   ( -- ) 0 fill-color>   set-fourth ;
  64 ! : no-stroke ( -- ) 0 stroke-color> set-fourth ;
  65
  66 : no-fill   ( -- ) fill-color>   0 >>alpha drop ;
  67 : no-stroke ( -- ) stroke-color> 0 >>alpha drop ;
  68
  69 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  70
  71 : stroke-weight ( w -- ) glLineWidth ;
  72
  73 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  74
  75 ! : quad-vertices ( x1 y1 x2 y2 x3 y3 x4 y4 -- )
  76 !   GL_POLYGON glBegin
  77 !     glVertex2d
  78 !     glVertex2d
  79 !     glVertex2d
  80 !     glVertex2d
  81 !   glEnd ;
  82
  83 ! : quad ( x1 y1 x2 y2 x3 y3 x4 y4 -- )
  84
  85 !   8 ndup
  86
  87 !   GL_FRONT_AND_BACK GL_FILL glPolygonMode
  88 !   fill-color> set-color
  89
  90 !   quad-vertices
  91
  92 !   GL_FRONT_AND_BACK GL_LINE glPolygonMode
  93 !   stroke-color> set-color
  94
  95 !   quad-vertices ;
  96
  97 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  98
  99 ! : ellipse-disk ( x y width height -- )
 100 !   glPushMatrix
 101 !     >r >r
 102 !     0 glTranslated
 103 !     r> r> 1 glScaled
 104 !     gluNewQuadric
 105 !       dup 0 0.5 20 1 gluDisk
 106 !     gluDeleteQuadric
 107 !   glPopMatrix ;
 108
 109 ! : ellipse-center ( x y width height -- )
 110
 111 !   4dup
 112
 113 !   GL_FRONT_AND_BACK GL_FILL glPolygonMode
 114 !   stroke-color> set-color
 115
 116 !   ellipse-disk
 117
 118 !   GL_FRONT_AND_BACK GL_FILL glPolygonMode
 119 !   fill-color> set-color
 120
 121 !   [ 2 - ] bi@ ! [ stroke-width 1+ - ] bi@
 122
 123 !   ellipse-disk ;
 124
 125 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 126
 127 ! SYMBOL: CENTER
 128 ! SYMBOL: RADIUS
 129 ! SYMBOL: CORNER
 130 ! SYMBOL: CORNERS
 131
 132 ! SYMBOL: ellipse-mode-value
 133
 134 ! : ellipse-mode ( val -- ) ellipse-mode-value set ;
 135
 136 ! : ellipse-radius ( x y hori vert -- ) [ 2 * ] bi@ ellipse-center ;
 137
 138 ! : ellipse-corner ( x y width height -- )
 139 !   [ drop nip     2 / + ] 4keep
 140 !   [ nip rot drop 2 / + ] 4keep
 141 !   [ >r >r 2drop r> r>  ] 4keep
 142 !   4drop
 143 !   ellipse-center ;
 144
 145 ! : ellipse-corners ( x1 y1 x2 y2 -- )
 146 !   [ drop nip     + 2 /    ] 4keep
 147 !   [ nip rot drop + 2 /    ] 4keep
 148 !   [ drop nip     - abs 1+ ] 4keep
 149 !   [ nip rot drop - abs 1+ ] 4keep
 150 !   4drop
 151 !   ellipse-center ;
 152
 153 ! : ellipse ( a b c d -- )
 154 !   ellipse-mode-value get
 155 !     {
 156 !       { CENTER  [ ellipse-center ] }
 157 !       { RADIUS  [ ellipse-radius ] }
 158 !       { CORNER  [ ellipse-corner ] }
 159 !       { CORNERS [ ellipse-corners ] }
 160 !     }
 161 !   case ;
 162
 163 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 164
 165 GENERIC: background ( value -- )
 166
 167 METHOD: background { number }
 168    dup dup 1 glClearColor
 169    GL_COLOR_BUFFER_BIT glClear ;
 170
 171 METHOD: background { array }
 172    dup length
 173    {
 174      { 2 [ first2 >r dup dup r> glClearColor GL_COLOR_BUFFER_BIT glClear ] }
 175      { 3 [ first3 1             glClearColor GL_COLOR_BUFFER_BIT glClear ] }
 176      { 4 [ first4               glClearColor GL_COLOR_BUFFER_BIT glClear ] }
 177    }
 178    case ;
 179
 180 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 181
 182 : translate ( x y -- ) 0 glTranslated ;
 183
 184 : rotate ( angle -- ) 0 0 1 glRotated ;
 185
 186 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 187
 188 : mouse ( -- point ) hand-loc get ;
 189
 190 : mouse-x ( -- x ) mouse first  ;
 191 : mouse-y ( -- y ) mouse second ;
 192
 193 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 194
 195 VAR: frame-rate-value
 196
 197 : frame-rate ( fps -- ) 1000 swap / >frame-rate-value ;
 198
 199 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 200
 201 ! VAR: slate
 202
 203 VAR: loop-flag
 204
 205 : defaults ( -- )
 206   0.8    background
 207   ! CENTER ellipse-mode
 208   60 frame-rate ;
 209
 210 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 211
 212 SYMBOL: size-val
 213
 214 : size ( seq -- ) size-val set ;
 215
 216 : size* ( width height -- ) 2array size-val set ;
 217
 218 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 219
 220 SYMBOL: setup-action
 221 SYMBOL: draw-action
 222
 223 ! : setup ( quot -- ) closed-quot setup-action set ;
 224 ! : draw  ( quot -- ) closed-quot draw-action  set ;
 225
 226 : setup ( quot -- ) setup-action set ;
 227 : draw  ( quot -- ) draw-action  set ;
 228
 229 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 230
 231 SYMBOL: key-down-action
 232 SYMBOL: key-up-action
 233
 234 : key-down ( quot -- ) closed-quot key-down-action set ;
 235 : key-up   ( quot -- ) closed-quot key-up-action   set ;
 236
 237 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 238
 239 SYMBOL: button-down-action
 240 SYMBOL: button-up-action
 241
 242 : button-down ( quot -- ) closed-quot button-down-action set ;
 243 : button-up   ( quot -- ) closed-quot button-up-action   set ;
 244
 245 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 246
 247 : start-processing-thread ( -- )
 248   loop-flag get not
 249     [
 250       loop-flag on
 251       [
 252         [ loop-flag get ]
 253         processing-gadget get frame-rate-value> '[ , relayout-1 , sleep ]
 254         [ ]
 255         while
 256       ]
 257       in-thread
 258     ]
 259   when ;
 260
 261 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 262
 263 : get-size ( -- size ) processing-gadget get rect-dim ;
 264
 265 : width  ( -- width  ) get-size first ;
 266 : height ( -- height ) get-size second ;
 267
 268 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 269
 270 SYMBOL: setup-called
 271
 272 : setup-called? ( -- ? ) setup-called get ;
 273
 274 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 275
 276 : run ( -- )
 277
 278   loop-flag off
 279
 280   500 sleep
 281
 282   <processing-gadget>
 283     size-val get >>pdim
 284     dup "Processing" open-window
 285
 286     500 sleep
 287
 288     defaults
 289
 290     setup-called off
 291
 292     [
 293       setup-called? not
 294         [
 295           setup-action get call
 296           setup-called on
 297         ]
 298         [
 299           draw-action get call
 300         ]
 301       if
 302     ]
 303       closed-quot >>action
 304
 305     key-down-action get >>key-down
 306     key-up-action   get >>key-up
 307
 308     button-down-action get >>button-down
 309     button-up-action   get >>button-up
 310
 311   processing-gadget set
 312
 313   start-processing-thread ;