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
11 rewrite-closures bake bake.fry accessors newfx
12 processing.gadget math.geometry.rect
18 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
20 : 2random ( a b -- num ) 2dup swap - 100 / <range> random ;
22 : 1random ( b -- num ) 0 swap 2random ;
24 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
26 : chance ( fraction -- ? ) 0 1 2random > ;
28 : percent-chance ( percent -- ? ) 100 / chance ;
30 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
32 ! : at-fraction ( seq fraction -- val ) over length 1- * nth-at ;
34 : at-fraction ( seq fraction -- val ) over length 1- * at ;
36 : at-fraction-of ( fraction seq -- val ) swap at-fraction ;
38 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
40 GENERIC: canonical-color-value ( obj -- color )
42 METHOD: canonical-color-value { number } dup dup 1 rgba boa ;
44 METHOD: canonical-color-value { array }
47 { 2 [ first2 >r dup dup r> rgba boa ] }
48 { 3 [ first3 1 rgba boa ] }
49 { 4 [ first4 rgba boa ] }
53 ! METHOD: canonical-color-value { rgba }
54 ! { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave 4array ;
56 METHOD: canonical-color-value { color } ;
58 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
60 : fill ( value -- ) canonical-color-value >fill-color ;
61 : stroke ( value -- ) canonical-color-value >stroke-color ;
63 ! : no-fill ( -- ) 0 fill-color> set-fourth ;
64 ! : no-stroke ( -- ) 0 stroke-color> set-fourth ;
66 : no-fill ( -- ) fill-color> 0 >>alpha drop ;
67 : no-stroke ( -- ) stroke-color> 0 >>alpha drop ;
69 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
71 : stroke-weight ( w -- ) glLineWidth ;
73 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
75 ! : quad-vertices ( x1 y1 x2 y2 x3 y3 x4 y4 -- )
83 ! : quad ( x1 y1 x2 y2 x3 y3 x4 y4 -- )
87 ! GL_FRONT_AND_BACK GL_FILL glPolygonMode
88 ! fill-color> set-color
92 ! GL_FRONT_AND_BACK GL_LINE glPolygonMode
93 ! stroke-color> set-color
97 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
99 ! : ellipse-disk ( x y width height -- )
105 ! dup 0 0.5 20 1 gluDisk
109 ! : ellipse-center ( x y width height -- )
113 ! GL_FRONT_AND_BACK GL_FILL glPolygonMode
114 ! stroke-color> set-color
118 ! GL_FRONT_AND_BACK GL_FILL glPolygonMode
119 ! fill-color> set-color
121 ! [ 2 - ] bi@ ! [ stroke-width 1+ - ] bi@
125 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
132 ! SYMBOL: ellipse-mode-value
134 ! : ellipse-mode ( val -- ) ellipse-mode-value set ;
136 ! : ellipse-radius ( x y hori vert -- ) [ 2 * ] bi@ ellipse-center ;
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
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
153 ! : ellipse ( a b c d -- )
154 ! ellipse-mode-value get
156 ! { CENTER [ ellipse-center ] }
157 ! { RADIUS [ ellipse-radius ] }
158 ! { CORNER [ ellipse-corner ] }
159 ! { CORNERS [ ellipse-corners ] }
163 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
165 GENERIC: background ( value -- )
167 METHOD: background { number }
168 dup dup 1 glClearColor
169 GL_COLOR_BUFFER_BIT glClear ;
171 METHOD: background { array }
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 ] }
180 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
182 : translate ( x y -- ) 0 glTranslated ;
184 : rotate ( angle -- ) 0 0 1 glRotated ;
186 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
188 : mouse ( -- point ) hand-loc get ;
190 : mouse-x ( -- x ) mouse first ;
191 : mouse-y ( -- y ) mouse second ;
193 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
195 VAR: frame-rate-value
197 : frame-rate ( fps -- ) 1000 swap / >frame-rate-value ;
199 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
207 ! CENTER ellipse-mode
210 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
214 : size ( seq -- ) size-val set ;
216 : size* ( width height -- ) 2array size-val set ;
218 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
223 ! : setup ( quot -- ) closed-quot setup-action set ;
224 ! : draw ( quot -- ) closed-quot draw-action set ;
226 : setup ( quot -- ) setup-action set ;
227 : draw ( quot -- ) draw-action set ;
229 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
231 SYMBOL: key-down-action
232 SYMBOL: key-up-action
234 : key-down ( quot -- ) closed-quot key-down-action set ;
235 : key-up ( quot -- ) closed-quot key-up-action set ;
237 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
239 SYMBOL: button-down-action
240 SYMBOL: button-up-action
242 : button-down ( quot -- ) closed-quot button-down-action set ;
243 : button-up ( quot -- ) closed-quot button-up-action set ;
245 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
247 : start-processing-thread ( -- )
253 processing-gadget get frame-rate-value> '[ , relayout-1 , sleep ]
261 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
263 : get-size ( -- size ) processing-gadget get rect-dim ;
265 : width ( -- width ) get-size first ;
266 : height ( -- height ) get-size second ;
268 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
272 : setup-called? ( -- ? ) setup-called get ;
274 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
284 dup "Processing" open-window
295 setup-action get call
305 key-down-action get >>key-down
306 key-up-action get >>key-up
308 button-down-action get >>button-down
309 button-up-action get >>button-up
311 processing-gadget set
313 start-processing-thread ;