From: John Benediktsson Date: Sun, 22 Jan 2017 23:06:01 +0000 (-0800) Subject: processing.shapes: some cleanup. X-Git-Tag: unmaintained~239 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=575aced0f77df2476ab4c57e6b71cce3e0cd08aa processing.shapes: some cleanup. --- diff --git a/extra/flatland/flatland.factor b/extra/flatland/flatland.factor index d47ec32e3e..5b68158f1a 100644 --- a/extra/flatland/flatland.factor +++ b/extra/flatland/flatland.factor @@ -89,33 +89,33 @@ METHOD: distance { sequence sequence } v- norm ; ! A class for objects with a position -TUPLE: pos ; +TUPLE: pos pos ; -METHOD: x { } pos>> first ; -METHOD: y { } pos>> second ; +METHOD: x { pos } pos>> first ; +METHOD: y { pos } pos>> second ; -METHOD: (x!) { number } pos>> set-first ; -METHOD: (y!) { number } pos>> set-second ; +METHOD: (x!) { number pos } pos>> set-first ; +METHOD: (y!) { number pos } pos>> set-second ; -METHOD: to-the-left-of? { number } [ x ] dip < ; -METHOD: to-the-right-of? { number } [ x ] dip > ; +METHOD: to-the-left-of? { pos number } [ x ] dip < ; +METHOD: to-the-right-of? { pos number } [ x ] dip > ; -METHOD: move-left-by { number } [ pos>> ] dip move-left-by ; -METHOD: move-right-by { number } [ pos>> ] dip move-right-by ; +METHOD: move-left-by { pos number } [ pos>> ] dip move-left-by ; +METHOD: move-right-by { pos number } [ pos>> ] dip move-right-by ; -METHOD: above? { number } [ y ] dip > ; -METHOD: below? { number } [ y ] dip < ; +METHOD: above? { pos number } [ y ] dip > ; +METHOD: below? { pos number } [ y ] dip < ; -METHOD: move-by { sequence } '[ _ v+ ] change-pos drop ; +METHOD: move-by { pos sequence } '[ _ v+ ] change-pos drop ; -METHOD: distance { } [ pos>> ] bi@ distance ; +METHOD: distance { pos pos } [ pos>> ] bi@ distance ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! A class for objects with velocity. It inherits from . Hey, if +! A class for objects with velocity. It inherits from pos. Hey, if ! it's moving it has a position right? Unless it's some alternate universe... -TUPLE: < vel ; +TUPLE: vel < pos vel ; : moving-up? ( obj -- ? ) vel>> y 0 > ; : moving-down? ( obj -- ? ) vel>> y 0 < ; @@ -130,15 +130,15 @@ TUPLE: < vel ; ! The 'pos' slot indicates the lower left hand corner of the ! rectangle. The 'dim' is holds the width and height. -TUPLE: < dim ; +TUPLE: rectangle < pos dim ; -METHOD: width { } dim>> first ; -METHOD: height { } dim>> second ; +METHOD: width { rectangle } dim>> first ; +METHOD: height { rectangle } dim>> second ; -METHOD: left { } x ; -METHOD: right { } [ x ] [ width ] bi + ; -METHOD: bottom { } y ; -METHOD: top { } [ y ] [ height ] bi + ; +METHOD: left { rectangle } x ; +METHOD: right { rectangle } [ x ] [ width ] bi + ; +METHOD: bottom { rectangle } y ; +METHOD: top { rectangle } [ y ] [ height ] bi + ; : bottom-left ( rectangle -- pos ) pos>> ; @@ -147,40 +147,40 @@ METHOD: top { } [ y ] [ height ] bi + ; : center ( rectangle -- seq ) [ center-x ] [ center-y ] bi 2array ; -METHOD: to-the-left-of? { } [ x ] [ left ] bi* < ; -METHOD: to-the-right-of? { } [ x ] [ right ] bi* > ; +METHOD: to-the-left-of? { pos rectangle } [ x ] [ left ] bi* < ; +METHOD: to-the-right-of? { pos rectangle } [ x ] [ right ] bi* > ; -METHOD: below? { } [ y ] [ bottom ] bi* < ; -METHOD: above? { } [ y ] [ top ] bi* > ; +METHOD: below? { pos rectangle } [ y ] [ bottom ] bi* < ; +METHOD: above? { pos rectangle } [ y ] [ top ] bi* > ; -METHOD: horizontal-interval { } +METHOD: horizontal-interval { rectangle } [ left ] [ right ] bi [a,b] ; -METHOD: in-between-horizontally? { } +METHOD: in-between-horizontally? { pos rectangle } [ x ] [ horizontal-interval ] bi* interval-contains? ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: left right bottom top ; +TUPLE: extent left right bottom top ; -METHOD: left { } left>> ; -METHOD: right { } right>> ; -METHOD: bottom { } bottom>> ; -METHOD: top { } top>> ; +METHOD: left { extent } left>> ; +METHOD: right { extent } right>> ; +METHOD: bottom { extent } bottom>> ; +METHOD: top { extent } top>> ; -METHOD: width { } [ right>> ] [ left>> ] bi - ; -METHOD: height { } [ top>> ] [ bottom>> ] bi - ; +METHOD: width { extent } [ right>> ] [ left>> ] bi - ; +METHOD: height { extent } [ top>> ] [ bottom>> ] bi - ; -! METHOD: to-extent ( -- ) -! { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave boa ; +! METHOD: to-extent ( rectangle -- extent ) +! { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave extent boa ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -METHOD: to-the-left-of? { sequence } [ x ] [ left ] bi* < ; -METHOD: to-the-right-of? { sequence } [ x ] [ right ] bi* > ; +METHOD: to-the-left-of? { sequence rectangle } [ x ] [ left ] bi* < ; +METHOD: to-the-right-of? { sequence rectangle } [ x ] [ right ] bi* > ; -METHOD: below? { sequence } [ y ] [ bottom ] bi* < ; -METHOD: above? { sequence } [ y ] [ top ] bi* > ; +METHOD: below? { sequence rectangle } [ y ] [ bottom ] bi* < ; +METHOD: above? { sequence rectangle } [ y ] [ top ] bi* > ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -218,7 +218,7 @@ METHOD: above? { sequence } [ y ] [ top ] bi* > ; GENERIC: within? ( a b -- ? ) -METHOD: within? { } +METHOD: within? { pos rectangle } { [ left to-the-right-of? ] [ right to-the-left-of? ] diff --git a/extra/pong/pong.factor b/extra/pong/pong.factor index 9939c9fc77..ff50d3b7a2 100644 --- a/extra/pong/pong.factor +++ b/extra/pong/pong.factor @@ -8,114 +8,88 @@ FROM: multi-methods => GENERIC: METHOD: ; FROM: syntax => M: ; IN: pong -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! Inspired by this Ruby/Shoes version by why: http://gist.github.com/26431 ! ! Which was based on this Nodebox version: http://billmill.org/pong.html ! by Bill Mill. -! -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : clamp-to-interval ( x interval -- x ) - [ from>> first max ] [ to>> first min ] bi ; + [ from>> first max ] [ to>> first min ] bi ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +TUPLE: play-field < rectangle ; -TUPLE: < ; -TUPLE: < ; +TUPLE: paddle < rectangle ; -TUPLE: < { speed initial: 10 } ; +TUPLE: computer < paddle { speed initial: 10 } ; : computer-move-left ( computer -- ) dup speed>> move-left-by ; -: computer-move-right ( computer -- ) dup speed>> move-right-by ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: computer-move-right ( computer -- ) dup speed>> move-right-by ; -TUPLE: < - { diameter initial: 20 } - { bounciness initial: 1.2 } - { max-speed initial: 10 } ; +TUPLE: ball < vel + { diameter initial: 20 } + { bounciness initial: 1.2 } + { max-speed initial: 10 } ; : above-lower-bound? ( ball field -- ? ) bottom 50 - above? ; + : below-upper-bound? ( ball field -- ? ) top 50 + below? ; : in-bounds? ( ball field -- ? ) - { - [ above-lower-bound? ] - [ below-upper-bound? ] - } 2&& ; + { + [ above-lower-bound? ] + [ below-upper-bound? ] + } 2&& ; :: bounce-change-vertical-velocity ( BALL -- ) - - BALL vel>> y neg - BALL bounciness>> * - - BALL max-speed>> min - - BALL vel>> (y!) ; + BALL vel>> y neg + BALL bounciness>> * + BALL max-speed>> min + BALL vel>> (y!) ; :: bounce-off-paddle ( BALL PADDLE -- ) - BALL bounce-change-vertical-velocity - BALL x PADDLE center x - 0.25 * BALL vel>> (x!) - PADDLE top BALL pos>> (y!) ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : mouse-x ( -- x ) hand-loc get first ; :: valid-paddle-interval ( PADDLE PLAY-FIELD -- interval ) - PLAY-FIELD [ left ] [ right ] bi PADDLE width - [a,b] ; :: align-paddle-with-mouse ( PADDLE PLAY-FIELD -- ) - mouse-x - PADDLE PLAY-FIELD valid-paddle-interval - clamp-to-interval - PADDLE pos>> (x!) ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Protocol for drawing PONG objects GENERIC: draw ( obj -- ) -METHOD: draw { } [ bottom-left ] [ dim>> ] bi rectangle ; -METHOD: draw { } [ pos>> ] [ diameter>> 2 / ] bi circle ; +METHOD: draw { paddle } [ bottom-left ] [ dim>> ] bi draw-rectangle ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +METHOD: draw { ball } [ pos>> ] [ diameter>> 2 / ] bi draw-circle ; -TUPLE: < gadget paused field ball player computer ; +TUPLE: pong-gadget < gadget paused field ball player computer ; : pong ( -- gadget ) - new - T{ { pos { 0 0 } } { dim { 400 400 } } } clone >>field - T{ { pos { 50 50 } } { vel { 3 4 } } } clone >>ball - T{ { pos { 200 396 } } { dim { 75 4 } } } clone >>player - T{ { pos { 200 0 } } { dim { 75 4 } } } clone >>computer ; - -M: pref-dim* ( -- dim ) drop { 400 400 } ; -M: ungraft* ( -- ) t >>paused drop ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + pong-gadget new + T{ play-field { pos { 0 0 } } { dim { 400 400 } } } clone >>field + T{ ball { pos { 50 50 } } { vel { 3 4 } } } clone >>ball + T{ paddle { pos { 200 396 } } { dim { 75 4 } } } clone >>player + T{ computer { pos { 200 0 } } { dim { 75 4 } } } clone >>computer ; -M:: draw-gadget* ( PONG -- ) +M: pong-gadget pref-dim* ( -- dim ) drop { 400 400 } ; - PONG computer>> draw - PONG player>> draw - PONG ball>> draw ; +M: pong-gadget ungraft* ( -- ) t >>paused drop ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +M:: pong-gadget draw-gadget* ( PONG -- ) + PONG computer>> draw + PONG player>> draw + PONG ball>> draw ; :: iterate-system ( GADGET -- ) - GADGET field>> :> FIELD GADGET ball>> :> BALL GADGET player>> :> PLAYER @@ -148,22 +122,15 @@ M:: draw-gadget* ( PONG -- ) ] [ t GADGET paused<< ] if ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - :: start-pong-thread ( GADGET -- ) - f GADGET paused<< - [ - [ - GADGET paused>> - [ f ] - [ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ] - if - ] - loop - ] - in-thread ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + f GADGET paused<< [ + [ + GADGET paused>> + [ f ] + [ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ] + if + ] loop + ] in-thread ; MAIN-WINDOW: pong-window { { title "PONG" } } diff --git a/extra/processing/shapes/shapes.factor b/extra/processing/shapes/shapes.factor index a3bd5e72d6..e4e1dd44b8 100644 --- a/extra/processing/shapes/shapes.factor +++ b/extra/processing/shapes/shapes.factor @@ -3,78 +3,56 @@ kernel locals math math.vectors namespaces opengl opengl.gl opengl.glu sequences sequences.generalizations shuffle ; IN: processing.shapes -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : do-state ( mode quot -- ) swap glBegin call glEnd ; inline -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - SYMBOL: fill-color SYMBOL: stroke-color COLOR: black stroke-color set-global COLOR: white fill-color set-global -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : fill-mode ( -- ) - GL_FRONT_AND_BACK GL_FILL glPolygonMode - fill-color get gl-color ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + GL_FRONT_AND_BACK GL_FILL glPolygonMode + fill-color get gl-color ; : stroke-mode ( -- ) - GL_FRONT_AND_BACK GL_LINE glPolygonMode - stroke-color get gl-color ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + GL_FRONT_AND_BACK GL_LINE glPolygonMode + stroke-color get gl-color ; : gl-vertex-2d ( vertex -- ) first2 glVertex2d ; : gl-vertices-2d ( vertices -- ) [ gl-vertex-2d ] each ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: point* ( x y -- ) stroke-mode GL_POINTS [ glVertex2d ] do-state ; -: point ( point -- ) stroke-mode GL_POINTS [ gl-vertex-2d ] do-state ; -: points ( points -- ) stroke-mode GL_POINTS [ gl-vertices-2d ] do-state ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: line** ( x y x y -- ) - stroke-mode GL_LINES [ glVertex2d glVertex2d ] do-state ; +: draw-point* ( x y -- ) stroke-mode GL_POINTS [ glVertex2d ] do-state ; +: draw-point ( point -- ) stroke-mode GL_POINTS [ gl-vertex-2d ] do-state ; +: draw-points ( points -- ) stroke-mode GL_POINTS [ gl-vertices-2d ] do-state ; -: line* ( a b -- ) stroke-mode GL_LINES [ [ gl-vertex-2d ] bi@ ] do-state ; +: draw-line** ( x y x y -- ) + stroke-mode GL_LINES [ glVertex2d glVertex2d ] do-state ; -: lines ( seq -- ) stroke-mode GL_LINES [ gl-vertices-2d ] do-state ; +: draw-line* ( a b -- ) stroke-mode GL_LINES [ [ gl-vertex-2d ] bi@ ] do-state ; -: line ( seq -- ) lines ; +: draw-lines ( seq -- ) stroke-mode GL_LINES [ gl-vertices-2d ] do-state ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: draw-line ( seq -- ) draw-lines ; : line-strip ( seq -- ) stroke-mode GL_LINE_STRIP [ gl-vertices-2d ] do-state ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: draw-triangles ( seq -- ) + [ fill-mode GL_TRIANGLES [ gl-vertices-2d ] do-state ] + [ stroke-mode GL_TRIANGLES [ gl-vertices-2d ] do-state ] bi ; -: triangles ( seq -- ) - [ fill-mode GL_TRIANGLES [ gl-vertices-2d ] do-state ] - [ stroke-mode GL_TRIANGLES [ gl-vertices-2d ] do-state ] bi ; +: draw-triangle ( seq -- ) draw-triangles ; -: triangle ( seq -- ) triangles ; +: draw-triangle* ( a b c -- ) 3array draw-triangles ; -: triangle* ( a b c -- ) 3array triangles ; +: draw-triangle** ( x y x y x y -- ) 6 narray 2 group draw-triangles ; -: triangle** ( x y x y x y -- ) 6 narray 2 group triangles ; +: draw-polygon ( seq -- ) + [ fill-mode GL_POLYGON [ gl-vertices-2d ] do-state ] + [ stroke-mode GL_POLYGON [ gl-vertices-2d ] do-state ] bi ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: polygon ( seq -- ) - [ fill-mode GL_POLYGON [ gl-vertices-2d ] do-state ] - [ stroke-mode GL_POLYGON [ gl-vertices-2d ] do-state ] bi ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -:: rectangle ( loc dim -- ) +:: draw-rectangle ( loc dim -- ) loc first2 :> ( x y ) dim first2 :> ( dx dy ) @@ -83,38 +61,28 @@ COLOR: white fill-color set-global x dx + y dy + 2array x y dy + 2array 4array - polygon ; - -: rectangle* ( x y width height -- ) [ 2array ] 2bi@ rectangle ; + draw-polygon ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: draw-rectangle* ( x y width height -- ) [ 2array ] 2bi@ draw-rectangle ; : gl-translate-2d ( pos -- ) first2 0 glTranslated ; : gl-scale-2d ( xy -- ) first2 1 glScaled ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : gl-ellipse ( center dim -- ) - glPushMatrix + glPushMatrix [ gl-translate-2d ] [ gl-scale-2d ] bi* gluNewQuadric - dup 0 0.5 20 1 gluDisk + dup 0 0.5 20 1 gluDisk gluDeleteQuadric - glPopMatrix ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + glPopMatrix ; : gl-get-line-width ( -- width ) - GL_LINE_WIDTH 0 double tuck glGetDoublev double deref ; - -: ellipse ( center dim -- ) - GL_FRONT_AND_BACK GL_FILL glPolygonMode - [ stroke-color get gl-color gl-ellipse ] - [ fill-color get gl-color gl-get-line-width 2 * dup 2array v- gl-ellipse ] 2bi ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + GL_LINE_WIDTH 0 double tuck glGetDoublev double deref ; -: circle ( center size -- ) dup 2array ellipse ; +: draw-ellipse ( center dim -- ) + GL_FRONT_AND_BACK GL_FILL glPolygonMode + [ stroke-color get gl-color gl-ellipse ] + [ fill-color get gl-color gl-get-line-width 2 * dup 2array v- gl-ellipse ] 2bi ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: draw-circle ( center size -- ) dup 2array draw-ellipse ; diff --git a/extra/trails/trails.factor b/extra/trails/trails.factor index 1d1b4fa612..182a67f820 100644 --- a/extra/trails/trails.factor +++ b/extra/trails/trails.factor @@ -1,100 +1,60 @@ -USING: accessors calendar circular colors colors.constants -kernel locals math math.order math.vectors namespaces opengl -processing.shapes sequences threads ui ui.gadgets ui.gestures -ui.render ; +USING: accessors arrays calendar circular colors +colors.constants fry kernel locals math math.order math.vectors +namespaces opengl processing.shapes sequences threads ui +ui.gadgets ui.gestures ui.render ; IN: trails -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Example 33-15 from the Processing book -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! Return the mouse location relative to the current gadget - -: mouse ( -- point ) hand-loc get hand-gadget get screen-loc v- ; +: mouse ( -- point ) + ! Return the mouse location relative to the current gadget + hand-loc get hand-gadget get screen-loc v- ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: point-list ( n -- seq ) [ { 0 0 } ] replicate ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: point-list ( n -- seq ) { 0 0 } ; : percent->radius ( percent -- radius ) neg 1 + 25 * 5 max ; -: dot ( pos percent -- ) percent->radius circle ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: dot ( pos percent -- ) percent->radius draw-circle ; TUPLE: trails-gadget < gadget paused points ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - :: iterate-system ( GADGET -- ) - - ! Add a valid point if the mouse is in the gadget - ! Otherwise, add an "invisible" point - - hand-gadget get GADGET = - [ mouse GADGET points>> circular-push ] - [ { -10 -10 } GADGET points>> circular-push ] - if ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Add a valid point if the mouse is in the gadget + ! Otherwise, add an "invisible" point + hand-gadget get GADGET = [ mouse ] [ { -10 -10 } ] if + GADGET points>> circular-push ; :: start-trails-thread ( GADGET -- ) - GADGET f >>paused drop - [ + GADGET f >>paused drop [ - GADGET paused>> - [ f ] - [ GADGET iterate-system GADGET relayout-1 1 milliseconds sleep t ] - if - ] - loop - ] - "trails" spawn drop ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + [ + GADGET paused>> + [ f ] + [ GADGET iterate-system GADGET relayout-1 1 milliseconds sleep t ] + if + ] + loop + ] "trails" spawn drop ; -M: trails-gadget ungraft* ( trails-gadget -- ) t >>paused drop ; +M: trails-gadget ungraft* t >>paused drop ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -M: trails-gadget pref-dim* ( trails-gadget -- dim ) drop { 500 500 } ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +M: trails-gadget pref-dim* drop { 500 500 } ; : each-percent ( seq quot -- ) - [ - dup length - [ iota ] [ [ / ] curry ] bi - [ 1 + ] prepose - ] dip compose - 2each ; inline - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + [ dup length ] dip '[ 1 + _ / @ ] each-index ; inline M:: trails-gadget draw-gadget* ( GADGET -- ) T{ rgba f 1 1 1 0.4 } \ fill-color set ! White, with some transparency T{ rgba f 0 0 0 0 } \ stroke-color set ! no stroke - COLOR: black gl-clear - GADGET points>> [ dot ] each-percent ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : ( -- trails-gadget ) - - trails-gadget new - - 300 point-list >>points - - t >>clipped? - - dup start-trails-thread ; + trails-gadget new + 300 point-list >>points + t >>clipped? + dup start-trails-thread ; MAIN-WINDOW: trails-window { { title "Trails" } }