! A class for objects with a position
-TUPLE: <pos> pos ;
+TUPLE: pos pos ;
-METHOD: x { <pos> } pos>> first ;
-METHOD: y { <pos> } pos>> second ;
+METHOD: x { pos } pos>> first ;
+METHOD: y { pos } pos>> second ;
-METHOD: (x!) { number <pos> } pos>> set-first ;
-METHOD: (y!) { number <pos> } pos>> set-second ;
+METHOD: (x!) { number pos } pos>> set-first ;
+METHOD: (y!) { number pos } pos>> set-second ;
-METHOD: to-the-left-of? { <pos> number } [ x ] dip < ;
-METHOD: to-the-right-of? { <pos> 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 { <pos> number } [ pos>> ] dip move-left-by ;
-METHOD: move-right-by { <pos> 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? { <pos> number } [ y ] dip > ;
-METHOD: below? { <pos> number } [ y ] dip < ;
+METHOD: above? { pos number } [ y ] dip > ;
+METHOD: below? { pos number } [ y ] dip < ;
-METHOD: move-by { <pos> sequence } '[ _ v+ ] change-pos drop ;
+METHOD: move-by { pos sequence } '[ _ v+ ] change-pos drop ;
-METHOD: distance { <pos> <pos> } [ pos>> ] bi@ distance ;
+METHOD: distance { pos pos } [ pos>> ] bi@ distance ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! A class for objects with velocity. It inherits from <pos>. 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> < <pos> vel ;
+TUPLE: vel < pos vel ;
: moving-up? ( obj -- ? ) vel>> y 0 > ;
: moving-down? ( obj -- ? ) vel>> y 0 < ;
! The 'pos' slot indicates the lower left hand corner of the
! rectangle. The 'dim' is holds the width and height.
-TUPLE: <rectangle> < <pos> dim ;
+TUPLE: rectangle < pos dim ;
-METHOD: width { <rectangle> } dim>> first ;
-METHOD: height { <rectangle> } dim>> second ;
+METHOD: width { rectangle } dim>> first ;
+METHOD: height { rectangle } dim>> second ;
-METHOD: left { <rectangle> } x ;
-METHOD: right { <rectangle> } [ x ] [ width ] bi + ;
-METHOD: bottom { <rectangle> } y ;
-METHOD: top { <rectangle> } [ 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>> ;
: center ( rectangle -- seq ) [ center-x ] [ center-y ] bi 2array ;
-METHOD: to-the-left-of? { <pos> <rectangle> } [ x ] [ left ] bi* < ;
-METHOD: to-the-right-of? { <pos> <rectangle> } [ 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? { <pos> <rectangle> } [ y ] [ bottom ] bi* < ;
-METHOD: above? { <pos> <rectangle> } [ y ] [ top ] bi* > ;
+METHOD: below? { pos rectangle } [ y ] [ bottom ] bi* < ;
+METHOD: above? { pos rectangle } [ y ] [ top ] bi* > ;
-METHOD: horizontal-interval { <rectangle> }
+METHOD: horizontal-interval { rectangle }
[ left ] [ right ] bi [a,b] ;
-METHOD: in-between-horizontally? { <pos> <rectangle> }
+METHOD: in-between-horizontally? { pos rectangle }
[ x ] [ horizontal-interval ] bi* interval-contains? ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-TUPLE: <extent> left right bottom top ;
+TUPLE: extent left right bottom top ;
-METHOD: left { <extent> } left>> ;
-METHOD: right { <extent> } right>> ;
-METHOD: bottom { <extent> } bottom>> ;
-METHOD: top { <extent> } top>> ;
+METHOD: left { extent } left>> ;
+METHOD: right { extent } right>> ;
+METHOD: bottom { extent } bottom>> ;
+METHOD: top { extent } top>> ;
-METHOD: width { <extent> } [ right>> ] [ left>> ] bi - ;
-METHOD: height { <extent> } [ top>> ] [ bottom>> ] bi - ;
+METHOD: width { extent } [ right>> ] [ left>> ] bi - ;
+METHOD: height { extent } [ top>> ] [ bottom>> ] bi - ;
-! METHOD: to-extent ( <rectangle> -- <extent> )
-! { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave <extent> boa ;
+! METHOD: to-extent ( rectangle -- extent )
+! { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave extent boa ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-METHOD: to-the-left-of? { sequence <rectangle> } [ x ] [ left ] bi* < ;
-METHOD: to-the-right-of? { sequence <rectangle> } [ 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 <rectangle> } [ y ] [ bottom ] bi* < ;
-METHOD: above? { sequence <rectangle> } [ y ] [ top ] bi* > ;
+METHOD: below? { sequence rectangle } [ y ] [ bottom ] bi* < ;
+METHOD: above? { sequence rectangle } [ y ] [ top ] bi* > ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
GENERIC: within? ( a b -- ? )
-METHOD: within? { <pos> <rectangle> }
+METHOD: within? { pos rectangle }
{
[ left to-the-right-of? ]
[ right to-the-left-of? ]
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: <play-field> < <rectangle> ;
-TUPLE: <paddle> < <rectangle> ;
+TUPLE: paddle < rectangle ;
-TUPLE: <computer> < <paddle> { 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: <ball> < <vel>
- { 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 { <paddle> } [ bottom-left ] [ dim>> ] bi rectangle ;
-METHOD: draw { <ball> } [ pos>> ] [ diameter>> 2 / ] bi circle ;
+METHOD: draw { paddle } [ bottom-left ] [ dim>> ] bi draw-rectangle ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+METHOD: draw { ball } [ pos>> ] [ diameter>> 2 / ] bi draw-circle ;
-TUPLE: <pong> < gadget paused field ball player computer ;
+TUPLE: pong-gadget < gadget paused field ball player computer ;
: pong ( -- gadget )
- <pong> 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: <pong> pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
-M: <pong> ungraft* ( <pong> -- ) 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:: <pong> draw-gadget* ( PONG -- )
+M: pong-gadget pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
- PONG computer>> draw
- PONG player>> draw
- PONG ball>> draw ;
+M: pong-gadget ungraft* ( <pong> -- ) 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
] [ 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" } }
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 )
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 <ref> 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 <ref> 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 ;
-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 <circular> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: point-list ( n -- seq ) { 0 0 } <array> <circular> ;
: 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 )
-
- 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" } }
projects / factor.git / commitdiff