diff --git a/extra/bubble-chamber/bubble-chamber.factor b/extra/bubble-chamber/bubble-chamber.factor new file mode 100644 index 0000000000..ea8d309bdb --- /dev/null +++ b/extra/bubble-chamber/bubble-chamber.factor @@ -0,0 +1,477 @@ + +USING: kernel namespaces sequences combinators arrays threads + + math + math.libm + math.vectors + math.ranges + math.constants + math.functions + + ui + ui.gadgets + + random accessors multi-methods + combinators.cleave + vars locals + + newfx + + processing + processing.gadget + processing.color ; + +IN: bubble-chamber + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: 2random ( a b -- num ) 2dup swap - 100 / random ; + +: 1random ( b -- num ) 0 swap 2random ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: move-by ( obj delta -- obj ) over pos>> v+ >>pos ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: dim ( -- dim ) 1000 ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +VAR: collision-theta + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +VAR: boom + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +VARS: particles muons quarks hadrons axions ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: good-colors ( -- seq ) + { + T{ rgba f 0.23 0.14 0.17 1 } + T{ rgba f 0.23 0.14 0.15 1 } + T{ rgba f 0.21 0.14 0.15 1 } + T{ rgba f 0.51 0.39 0.33 1 } + T{ rgba f 0.49 0.33 0.20 1 } + T{ rgba f 0.55 0.45 0.32 1 } + T{ rgba f 0.69 0.63 0.51 1 } + T{ rgba f 0.64 0.39 0.18 1 } + T{ rgba f 0.73 0.42 0.20 1 } + T{ rgba f 0.71 0.45 0.29 1 } + T{ rgba f 0.79 0.45 0.22 1 } + T{ rgba f 0.82 0.56 0.34 1 } + T{ rgba f 0.88 0.72 0.49 1 } + T{ rgba f 0.85 0.69 0.40 1 } + T{ rgba f 0.96 0.92 0.75 1 } + T{ rgba f 0.99 0.98 0.87 1 } + T{ rgba f 0.85 0.82 0.69 1 } + T{ rgba f 0.99 0.98 0.87 1 } + T{ rgba f 0.82 0.82 0.79 1 } + T{ rgba f 0.65 0.69 0.67 1 } + T{ rgba f 0.53 0.60 0.55 1 } + T{ rgba f 0.57 0.53 0.68 1 } + T{ rgba f 0.47 0.42 0.56 1 } + } ; + +: good-color ( i -- color ) good-colors nth-of ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: x>> ( particle -- x ) pos>> first ; +: y>> ( particle -- x ) pos>> second ; + +: >>x ( particle x -- particle ) over y>> 2array >>pos ; +: >>y ( particle y -- particle ) over x>> swap 2array >>pos ; + +: x x>> ; +: y y>> ; + +: v+y ( seq y -- seq ) >r first2 r> + 2array ; +: v-y ( seq y -- seq ) >r first2 r> - 2array ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: out-of-bounds? ( particle -- particle ? ) + dup + { [ x dim neg < ] [ x dim 2 * > ] [ y dim neg < ] [ y dim 2 * > ] } cleave + or or or ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +GENERIC: collide ( particle -- ) +GENERIC: move ( particle -- ) + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: muon pos speed theta speed-d theta-d theta-dd myc mya ; + +: ( -- muon ) + muon construct-empty + 0 0 2array >>pos + 0 >>speed + 0 >>speed-d + 0 >>theta + 0 >>theta-d + 0 >>theta-dd + 0 0 0 1 >>myc + 0 0 0 1 >>mya ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: collide { muon } + + dim 2 / dup 2array >>pos + 2 32 [a,b] random >>speed + 0.0001 0.001 2random >>speed-d + + collision-theta> -0.1 0.1 2random + >>theta + 0 >>theta-d + 0 >>theta-dd + + [ dup theta-dd>> abs 0.001 < ] + [ -0.1 0.1 2random >>theta-dd ] + [ ] + while + + dup theta>> pi + + 2 pi * / + good-colors length 1 - * + [ ] [ good-colors length >= ] [ 0 < ] tri or + [ drop ] + [ + [ good-color >>myc ] + [ good-colors length swap - 1 - good-color >>mya ] + bi + ] + if + + drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: move { muon } + + dup myc>> 0.16 >>alpha stroke + dup pos>> point + + dup mya>> 0.16 >>alpha stroke + dup pos>> first2 >r dim swap - r> 2array point + + dup + [ speed>> ] [ theta>> { sin cos } ] bi n*v + move-by + + [ ] [ theta>> ] [ theta-d>> ] tri + >>theta + [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d + [ ] [ speed>> ] [ speed-d>> ] tri - >>speed + + out-of-bounds? + [ collide ] + [ drop ] + if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: quark pos vel speed theta speed-d theta-d theta-dd myc ; + +: ( -- quark ) + quark construct-empty + 0 0 2array >>pos + 0 0 2array >>vel + 0 >>speed + 0 >>speed-d + 0 >>theta + 0 >>theta-d + 0 >>theta-dd + 0 0 0 1 >>myc ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: collide { quark } + + dim 2 / dup 2array >>pos + collision-theta> -0.11 0.11 2random + >>theta + 0.5 3.0 2random >>speed + + 0.996 1.001 2random >>speed-d + 0 >>theta-d + 0 >>theta-dd + + [ dup theta-dd>> abs 0.00001 < ] + [ -0.001 0.001 2random >>theta-dd ] + [ ] + while + + drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: move { quark } + + dup myc>> 0.13 >>alpha stroke + dup pos>> point + + dup pos>> first2 >r dim swap - r> 2array point + + [ ] [ vel>> ] bi move-by + + dup + [ speed>> ] [ theta>> { sin cos } ] bi n*v + >>vel + + [ ] [ theta>> ] [ theta-d>> ] tri + >>theta + [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d + [ ] [ speed>> ] [ speed-d>> ] tri * >>speed + + 1000 random 997 > + [ + dup speed>> neg >>speed + 2 over speed-d>> - >>speed-d + ] + when + + out-of-bounds? + [ collide ] + [ drop ] + if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: hadron pos vel speed theta speed-d theta-d theta-dd myc ; + +: ( -- hadron ) + hadron construct-empty + 0 0 2array >>pos + 0 0 2array >>vel + 0 >>speed + 0 >>speed-d + 0 >>theta + 0 >>theta-d + 0 >>theta-dd + 0 0 0 1 >>myc ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: collide { hadron } + + dim 2 / dup 2array >>pos + 2 pi * 1random >>theta + 0.5 3.5 2random >>speed + + 0.996 1.001 2random >>speed-d + 0 >>theta-d + 0 >>theta-dd + + [ dup theta-dd>> abs 0.00001 < ] + [ -0.001 0.001 2random >>theta-dd ] + [ ] + while + + 0 1 0 >>myc + + drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: move { hadron } + + { 1 0.11 } stroke + dup pos>> 1 v-y point + + { 0 0.11 } stroke + dup pos>> 1 v+y point + + dup vel>> move-by + + dup + [ speed>> ] [ theta>> { sin cos } ] bi n*v + >>vel + + [ ] [ theta>> ] [ theta-d>> ] tri + >>theta + [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d + [ ] [ speed>> ] [ speed-d>> ] tri * >>speed + + 1000 random 997 > + [ + 1.0 >>speed-d + 0.00001 >>theta-dd + + 100 random 70 > + [ + dim 2 / dup 2array >>pos + dup collide + ] + when + ] + when + + out-of-bounds? + [ collide ] + [ drop ] + if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: axion pos vel speed theta speed-d theta-d theta-dd ; + +: ( -- axion ) + axion construct-empty + 0 0 2array >>pos + 0 0 2array >>vel + 0 >>speed + 0 >>speed-d + 0 >>theta + 0 >>theta-d + 0 >>theta-dd ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: collide { axion } + + dim 2 / dup 2array >>pos + 2 pi * 1random >>theta + 1.0 6.0 2random >>speed + + 0.998 1.000 2random >>speed-d + 0 >>theta-d + 0 >>theta-dd + + [ dup theta-dd>> abs 0.00001 < ] + [ -0.001 0.001 2random >>theta-dd ] + [ ] + while + + drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: move { axion } + + { 0.06 0.59 } stroke + dup pos>> point + + 1 4 [a,b] + [| dy | + 1 30 dy 6 * - 255.0 / 2array stroke + dup pos>> 0 dy neg 2array v+ point + ] with-locals + each + + 1 4 [a,b] + [| dy | + 0 30 dy 6 * - 255.0 / 2array stroke + dup pos>> dy v+y point + ] with-locals + each + + dup vel>> move-by + + dup + [ speed>> ] [ theta>> { sin cos } ] bi n*v + >>vel + + [ ] [ theta>> ] [ theta-d>> ] tri + >>theta + [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d + [ ] [ speed>> ] [ speed-d>> ] tri * >>speed + + [ ] [ speed-d>> 0.9999 * ] bi >>speed-d + + 1000 random 996 > + [ + dup speed>> neg >>speed + dup speed-d>> neg 2 + >>speed-d + + 100 random 30 > + [ + dim 2 / dup 2array >>pos + collide + ] + [ drop ] + if + ] + [ drop ] + if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! : draw ( -- ) + +! boom> +! [ particles> [ move ] each ] +! when ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: collide-all ( -- ) + + 2 pi * 1random >collision-theta + + particles> [ collide ] each ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: collide-one ( -- ) + + dim 2 / mouse-x - dim 2 / mouse-y - fatan2 >collision-theta + + hadrons> random collide + quarks> random collide + muons> random collide ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: mouse-pressed ( -- ) + boom on + 1 background ! kludge + 11 [ drop collide-one ] each ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: key-released ( -- ) + key " " = + [ + boom on + 1 background + collide-all + ] + when ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: bubble-chamber ( -- ) + + 1000 1000 size* + + [ + 1 background + no-stroke + + 1789 [ drop ] map >muons + 1300 [ drop ] map >quarks + 1000 [ drop ] map >hadrons + 111 [ drop ] map >axions + + muons> quarks> hadrons> axions> 3append append >particles + + collide-one + ] setup + + [ + boom> + [ particles> [ move ] each ] + when + ] draw + + [ mouse-pressed ] button-down + [ key-released ] key-up + + ; + +: go ( -- ) [ bubble-chamber 500 sleep run ] with-ui ; + +MAIN: go \ No newline at end of file diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor index ae92f8f6c0..df826dc295 100644 --- a/extra/newfx/newfx.factor +++ b/extra/newfx/newfx.factor @@ -68,6 +68,29 @@ IN: newfx ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: delete ( seq elt -- seq ) over sequences:delete ; +: delete-from ( elt seq -- seq ) tuck sequences:delete ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: deleted ( seq elt -- ) swap sequences:delete ; +: deleted-from ( elt seq -- ) sequences:delete ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: remove ( seq obj -- seq ) swap sequences:remove ; +: remove-from ( obj seq -- seq ) sequences:remove ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: subset-of ( quot seq -- seq ) swap subset ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: map-over ( quot seq -- seq ) swap map ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! A note about the 'mutate' qualifier. Other words also technically mutate ! their primary object. However, the 'mutate' qualifier is supposed to ! indicate that this is the main objective of the word, as a side effect. \ No newline at end of file diff --git a/extra/processing/color/color.factor b/extra/processing/color/color.factor new file mode 100644 index 0000000000..50d20fcf52 --- /dev/null +++ b/extra/processing/color/color.factor @@ -0,0 +1,22 @@ + +USING: kernel sequences ; + +IN: processing.color + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: rgba red green blue alpha ; + +C: rgba + +: ( r g b -- rgba ) 1 ; + +: ( gray -- rgba ) dup dup 1 ; + +: {rgb} ( seq -- rgba ) first3 ; + +! : hex>rgba ( hex -- rgba ) + +! : set-gl-color ( color -- ) +! { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave glColor4d ; + diff --git a/extra/processing/gadget/gadget.factor b/extra/processing/gadget/gadget.factor new file mode 100644 index 0000000000..8b78c43f00 --- /dev/null +++ b/extra/processing/gadget/gadget.factor @@ -0,0 +1,80 @@ + +USING: kernel namespaces combinators + ui.gestures qualified accessors ui.gadgets.frame-buffer ; + +IN: processing.gadget + +QUALIFIED: ui.gadgets + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: processing-gadget button-down button-up key-down key-up ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: set-gadget-delegate ( tuple gadget -- tuple ) + over ui.gadgets:set-gadget-delegate ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: ( -- gadget ) + processing-gadget construct-empty + set-gadget-delegate ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: mouse-pressed-value +SYMBOL: key-pressed-value + +SYMBOL: button-value +SYMBOL: key-value + +: key-pressed? ( -- ? ) key-pressed-value get ; +: mouse-pressed? ( -- ? ) mouse-pressed-value get ; + +: key ( -- key ) key-value get ; +: button ( -- val ) button-value get ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M: processing-gadget handle-gesture* ( gadget gesture delegate -- ? ) + rot drop swap ! delegate gesture + { + { + [ dup key-down? ] + [ + key-down-sym key-value set + key-pressed-value on + key-down>> dup [ call ] [ drop ] if + t + ] + } + { + [ dup key-up? ] + [ + key-pressed-value off + drop + key-up>> dup [ call ] [ drop ] if + t + ] } + { + [ dup button-down? ] + [ + button-down-# button-value set + mouse-pressed-value on + button-down>> dup [ call ] [ drop ] if + t + ] + } + { + [ dup button-up? ] + [ + mouse-pressed-value off + drop + button-up>> dup [ call ] [ drop ] if + t + ] + } + { [ t ] [ 2drop t ] } + } + cond ; \ No newline at end of file diff --git a/extra/processing/processing.factor b/extra/processing/processing.factor new file mode 100644 index 0000000000..acad02363b --- /dev/null +++ b/extra/processing/processing.factor @@ -0,0 +1,387 @@ + +USING: kernel namespaces threads combinators sequences arrays + math math.functions + opengl.gl opengl.glu vars multi-methods shuffle + ui + ui.gestures + ui.gadgets + combinators + combinators.lib + combinators.cleave + rewrite-closures fry accessors + processing.color + processing.gadget ; + +IN: processing + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +VAR: fill-color +VAR: stroke-color + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +GENERIC: set-color ( value -- ) + +METHOD: set-color { number } dup dup glColor3d ; + +METHOD: set-color { array } + dup length + { + { 2 [ first2 >r dup dup r> glColor4d ] } + { 3 [ first3 glColor3d ] } + { 4 [ first4 glColor4d ] } + } + case ; + +METHOD: set-color { rgba } + { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave glColor4d ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: fill ( value -- ) >fill-color ; +: stroke ( value -- ) >stroke-color ; + +: no-fill ( -- ) + fill-color> + { + { [ dup number? ] [ 0 2array fill ] } + { [ t ] + [ + [ drop 0 ] [ length 1- ] [ ] tri set-nth + ] } + } + cond ; + +: no-stroke ( -- ) + stroke-color> + { + { [ dup number? ] [ 0 2array stroke ] } + { [ t ] + [ + [ drop 0 ] [ length 1- ] [ ] tri set-nth + ] } + } + cond ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: stroke-weight ( w -- ) glLineWidth ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: point* ( x y -- ) + stroke-color> set-color + GL_POINTS glBegin + glVertex2d + glEnd ; + +: point ( seq -- ) first2 point* ; + +: line ( x1 y1 x2 y2 -- ) + stroke-color> set-color + GL_LINES glBegin + glVertex2d + glVertex2d + glEnd ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: triangle ( x1 y1 x2 y2 x3 y3 -- ) + + GL_FRONT_AND_BACK GL_FILL glPolygonMode + fill-color> set-color + + 6 ndup + + GL_TRIANGLES glBegin + glVertex2d + glVertex2d + glVertex2d + glEnd + + GL_FRONT_AND_BACK GL_LINE glPolygonMode + stroke-color> set-color + + GL_TRIANGLES glBegin + glVertex2d + glVertex2d + glVertex2d + glEnd ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: quad-vertices ( x1 y1 x2 y2 x3 y3 x4 y4 -- ) + GL_POLYGON glBegin + glVertex2d + glVertex2d + glVertex2d + glVertex2d + glEnd ; + +: quad ( x1 y1 x2 y2 x3 y3 x4 y4 -- ) + + 8 ndup + + GL_FRONT_AND_BACK GL_FILL glPolygonMode + fill-color> set-color + + quad-vertices + + GL_FRONT_AND_BACK GL_LINE glPolygonMode + stroke-color> set-color + + quad-vertices ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: rect-vertices ( x y width height -- ) + GL_POLYGON glBegin + [ 2drop glVertex2d ] 4keep + [ drop swap >r + 1- r> glVertex2d ] 4keep + [ >r swap >r + 1- r> r> + 1- glVertex2d ] 4keep + [ nip + 1- glVertex2d ] 4keep + 4drop + glEnd ; + +: rect ( x y width height -- ) + + 4dup + + GL_FRONT_AND_BACK GL_FILL glPolygonMode + fill-color> set-color + + rect-vertices + + GL_FRONT_AND_BACK GL_LINE glPolygonMode + stroke-color> set-color + + rect-vertices ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: ellipse-disk ( x y width height -- ) + glPushMatrix + >r >r + 0 glTranslated + r> r> 1 glScaled + gluNewQuadric + dup 0 0.5 20 1 gluDisk + gluDeleteQuadric + glPopMatrix ; + +: ellipse-center ( x y width height -- ) + + 4dup + + GL_FRONT_AND_BACK GL_FILL glPolygonMode + stroke-color> set-color + + ellipse-disk + + GL_FRONT_AND_BACK GL_FILL glPolygonMode + fill-color> set-color + + [ 2 - ] bi@ ! [ stroke-width 1+ - ] bi@ + + ellipse-disk ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: CENTER +SYMBOL: RADIUS +SYMBOL: CORNER +SYMBOL: CORNERS + +SYMBOL: ellipse-mode-value + +: ellipse-mode ( val -- ) ellipse-mode-value set ; + +: ellipse-radius ( x y hori vert -- ) [ 2 * ] bi@ ellipse-center ; + +: ellipse-corner ( x y width height -- ) + [ drop nip 2 / + ] 4keep + [ nip rot drop 2 / + ] 4keep + [ >r >r 2drop r> r> ] 4keep + 4drop + ellipse-center ; + +: ellipse-corners ( x1 y1 x2 y2 -- ) + [ drop nip + 2 / ] 4keep + [ nip rot drop + 2 / ] 4keep + [ drop nip - abs 1+ ] 4keep + [ nip rot drop - abs 1+ ] 4keep + 4drop + ellipse-center ; + +: ellipse ( a b c d -- ) + ellipse-mode-value get + { + { CENTER [ ellipse-center ] } + { RADIUS [ ellipse-radius ] } + { CORNER [ ellipse-corner ] } + { CORNERS [ ellipse-corners ] } + } + case ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: circle ( pos size -- ) [ first2 ] [ dup ] bi* ellipse ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +USING: multi-methods ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +GENERIC: background ( value -- ) + +METHOD: background { number } + dup dup 1 glClearColor + GL_COLOR_BUFFER_BIT glClear ; + +METHOD: background { array } + dup length + { + { 2 [ first2 >r dup dup r> glClearColor GL_COLOR_BUFFER_BIT glClear ] } + { 3 [ first3 1 glClearColor GL_COLOR_BUFFER_BIT glClear ] } + { 4 [ first4 glClearColor GL_COLOR_BUFFER_BIT glClear ] } + } + case ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: translate ( x y -- ) 0 glTranslated ; + +: rotate ( angle -- ) 0 0 1 glRotated ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: mouse ( -- point ) hand-loc get ; + +: mouse-x mouse first ; +: mouse-y mouse second ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +VAR: frame-rate-value + +: frame-rate ( fps -- ) 1000 swap / >frame-rate-value ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +VAR: slate + +VAR: loop-flag + +: defaults ( -- ) + 0.8 background + 0 >stroke-color + 1 >fill-color + CENTER ellipse-mode + 60 frame-rate ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: size-val + +: size ( seq -- ) size-val set ; + +: size* ( width height -- ) 2array size-val set ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: setup-action +SYMBOL: draw-action + +! : setup ( quot -- ) closed-quot setup-action set ; +! : draw ( quot -- ) closed-quot draw-action set ; + +: setup ( quot -- ) setup-action set ; +: draw ( quot -- ) draw-action set ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: key-down-action +SYMBOL: key-up-action + +: key-down ( quot -- ) closed-quot key-down-action set ; +: key-up ( quot -- ) closed-quot key-up-action set ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: button-down-action +SYMBOL: button-up-action + +: button-down ( quot -- ) closed-quot button-down-action set ; +: button-up ( quot -- ) closed-quot button-up-action set ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: start-processing-thread ( -- ) + loop-flag get not + [ + loop-flag on + [ + [ loop-flag get ] + processing-gadget get frame-rate-value> '[ , relayout-1 , sleep ] + [ ] + while + ] + in-thread + ] + when ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: get-size ( -- size ) processing-gadget get rect-dim ; + +: width ( -- width ) get-size first ; +: height ( -- height ) get-size second ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: setup-called + +: setup-called? ( -- ? ) setup-called get ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: run ( -- ) + + loop-flag off + + 500 sleep + + + size-val get >>dim + dup "Processing" open-window + + 500 sleep + + defaults + + setup-called off + + [ + setup-called? not + [ + setup-action get call + setup-called on + ] + [ + draw-action get call + ] + if + ] + closed-quot >>action + + key-down-action get >>key-down + key-up-action get >>key-up + + button-down-action get >>button-down + button-up-action get >>button-up + + processing-gadget set + + start-processing-thread ; \ No newline at end of file diff --git a/extra/ui/gadgets/frame-buffer/frame-buffer.factor b/extra/ui/gadgets/frame-buffer/frame-buffer.factor new file mode 100644 index 0000000000..4990254778 --- /dev/null +++ b/extra/ui/gadgets/frame-buffer/frame-buffer.factor @@ -0,0 +1,113 @@ + +USING: kernel alien.c-types combinators sequences splitting + opengl.gl ui.gadgets ui.render + math math.vectors accessors ; + +IN: ui.gadgets.frame-buffer + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: frame-buffer action dim last-dim graft ungraft pixels ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: init-frame-buffer-pixels ( frame-buffer -- frame-buffer ) + dup + rect-dim product "uint[4]" + >>pixels ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: ( -- frame-buffer ) + frame-buffer construct-gadget + [ ] >>action + { 100 100 } >>dim + [ ] >>graft + [ ] >>ungraft ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: draw-pixels ( fb -- fb ) + dup >r + dup >r + rect-dim first2 GL_RGBA GL_UNSIGNED_INT r> pixels>> glDrawPixels + r> ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: read-pixels ( fb -- fb ) + dup >r + dup >r + >r + 0 0 r> rect-dim first2 GL_RGBA GL_UNSIGNED_INT r> pixels>> glReadPixels + r> ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M: frame-buffer pref-dim* dim>> ; +M: frame-buffer graft* graft>> call ; +M: frame-buffer ungraft* ungraft>> call ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: copy-row ( old new -- ) + 2dup min-length swap >r head-slice 0 r> copy ; + +! : copy-pixels ( old-pixels old-width new-pixels new-width -- ) +! [ group ] 2bi@ +! [ copy-row ] 2each ; + +! : copy-pixels ( old-pixels old-width new-pixels new-width -- ) +! [ 16 * group ] 2bi@ +! [ copy-row ] 2each ; + +: copy-pixels ( old-pixels old-width new-pixels new-width -- ) + [ 16 * ] 2bi@ + [ copy-row ] 2each ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M: frame-buffer layout* ( fb -- ) + { + { + [ dup last-dim>> f = ] + [ + init-frame-buffer-pixels + dup + rect-dim >>last-dim + drop + ] + } + { + [ dup [ rect-dim ] [ last-dim>> ] bi = not ] + [ + dup [ pixels>> ] [ last-dim>> first ] bi + + rot init-frame-buffer-pixels + dup rect-dim >>last-dim + + [ pixels>> ] [ rect-dim first ] bi + + copy-pixels + ] + } + { [ t ] [ drop ] } + } + cond ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M: frame-buffer draw-gadget* ( fb -- ) + + dup rect-dim { 0 1 } v* first2 glRasterPos2i + + draw-pixels + + dup action>> call + + glFlush + + read-pixels + + drop ; +