processing.shapes: some cleanup.

extra/flatland/flatland.factor

@@ -89,33 +89,33 @@ METHOD: distance { sequence sequence } v- norm ;
 
 ! A class for objects with a position
 
-TUPLE: <pos> pos ;
+TUPLE: pos pos ;
 
-METHOD: x { <pos> } pos>> first  ;
+METHOD: x { pos } pos>> first  ;
-METHOD: y { <pos> } pos>> second ;
+METHOD: y { pos } pos>> second ;
 
-METHOD: (x!) { number <pos> } pos>> set-first  ;
+METHOD: (x!) { number pos } pos>> set-first  ;
-METHOD: (y!) { number <pos> } pos>> set-second ;
+METHOD: (y!) { number pos } pos>> set-second ;
 
-METHOD: to-the-left-of?  { <pos> number } [ x ] dip < ;
+METHOD: to-the-left-of?  { pos number } [ x ] dip < ;
-METHOD: to-the-right-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-left-by  { pos number } [ pos>> ] dip move-left-by  ;
-METHOD: move-right-by { <pos> number } [ pos>> ] dip move-right-by ;
+METHOD: move-right-by { pos number } [ pos>> ] dip move-right-by ;
 
-METHOD: above? { <pos> number } [ y ] dip > ;
+METHOD: above? { pos number } [ y ] dip > ;
-METHOD: below? { <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 < ;
@@ -130,15 +130,15 @@ TUPLE: <vel> < <pos> vel ;
 ! 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: width  { rectangle } dim>> first  ;
-METHOD: height { <rectangle> } dim>> second ;
+METHOD: height { rectangle } dim>> second ;
 
-METHOD: left   { <rectangle> }    x             ;
+METHOD: left   { rectangle }    x             ;
-METHOD: right  { <rectangle> } [ x ] [ width ] bi + ;
+METHOD: right  { rectangle } [ x ] [ width ] bi + ;
-METHOD: bottom { <rectangle> }    y             ;
+METHOD: bottom { rectangle }    y             ;
-METHOD: top    { <rectangle> } [ y ] [ height ] bi + ;
+METHOD: top    { rectangle } [ y ] [ height ] bi + ;
 
 : bottom-left ( rectangle -- pos ) pos>> ;
 
@@ -147,40 +147,40 @@ METHOD: top    { <rectangle> } [ y ] [ height ] bi + ;
 
 : center ( rectangle -- seq ) [ center-x ] [ center-y ] bi 2array ;
 
-METHOD: to-the-left-of?  { <pos> <rectangle> } [ x ] [ left  ] bi* < ;
+METHOD: to-the-left-of?  { pos rectangle } [ x ] [ left  ] bi* < ;
-METHOD: to-the-right-of? { <pos> <rectangle> } [ x ] [ right ] bi* > ;
+METHOD: to-the-right-of? { pos rectangle } [ x ] [ right ] bi* > ;
 
-METHOD: below? { <pos> <rectangle> } [ y ] [ bottom ] bi* < ;
+METHOD: below? { pos rectangle } [ y ] [ bottom ] bi* < ;
-METHOD: above? { <pos> <rectangle> } [ y ] [ top    ] 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: left   { extent } left>>   ;
-METHOD: right  { <extent> } right>>  ;
+METHOD: right  { extent } right>>  ;
-METHOD: bottom { <extent> } bottom>> ;
+METHOD: bottom { extent } bottom>> ;
-METHOD: top    { <extent> } top>>    ;
+METHOD: top    { extent } top>>    ;
 
-METHOD: width  { <extent> } [ right>> ] [ left>>   ] bi - ;
+METHOD: width  { extent } [ right>> ] [ left>>   ] bi - ;
-METHOD: height { <extent> } [ top>>   ] [ bottom>> ] bi - ;
+METHOD: height { extent } [ top>>   ] [ bottom>> ] bi - ;
 
-! METHOD: to-extent ( <rectangle> -- <extent> )
+! METHOD: to-extent ( rectangle -- extent )
-!   { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave <extent> boa ;
+!   { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave extent boa ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-METHOD: to-the-left-of?  { sequence <rectangle> } [ x ] [ left ] bi* < ;
+METHOD: to-the-left-of?  { sequence rectangle } [ x ] [ left ] bi* < ;
-METHOD: to-the-right-of? { sequence <rectangle> } [ x ] [ right ] bi* > ;
+METHOD: to-the-right-of? { sequence rectangle } [ x ] [ right ] bi* > ;
 
-METHOD: below? { sequence <rectangle> } [ y ] [ bottom ] bi* < ;
+METHOD: below? { sequence rectangle } [ y ] [ bottom ] bi* < ;
-METHOD: above? { sequence <rectangle> } [ y ] [ top    ] bi* > ;
+METHOD: above? { sequence rectangle } [ y ] [ top    ] bi* > ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -218,7 +218,7 @@ 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?  ]

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: <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 ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+TUPLE: ball < vel
-
+    { diameter   initial: 20   }
-TUPLE: <ball> < <vel>
+    { bounciness initial:  1.2 }
-  { diameter   initial: 20   }
+    { max-speed  initial: 10   } ;
-  { 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? ]
+        [ above-lower-bound? ]
-    [ below-upper-bound? ]
+        [ below-upper-bound? ]
-  } 2&& ;
+    } 2&& ;
 
 :: bounce-change-vertical-velocity ( BALL -- )
-
+    BALL vel>> y neg
-  BALL vel>> y neg
+    BALL bounciness>> *
-  BALL bounciness>> *
+    BALL max-speed>> min
-
+    BALL vel>> (y!) ;
-  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 { paddle } [ bottom-left ] [ dim>> ] bi draw-rectangle ;
-METHOD: draw { <ball>   } [ pos>>       ] [ diameter>> 2 / ] bi circle    ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+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
+    pong-gadget new
-  T{ <play-field> { pos {   0   0 } } { dim { 400 400 } } } clone >>field
+        T{ play-field { pos {   0   0 } } { dim { 400 400 } } } clone >>field
-  T{ <ball>       { pos {  50  50 } } { vel {   3   4 } } } clone >>ball
+        T{ ball       { pos {  50  50 } } { vel {   3   4 } } } clone >>ball
-  T{ <paddle>     { pos { 200 396 } } { dim {  75   4 } } } clone >>player
+        T{ paddle     { pos { 200 396 } } { dim {  75   4 } } } clone >>player
-  T{ <computer>   { pos { 200   0 } } { dim {  75   4 } } } clone >>computer ;
+        T{ computer   { pos { 200   0 } } { dim {  75   4 } } } clone >>computer ;
 
-M: <pong> pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
+M: pong-gadget pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
-M: <pong> ungraft*  ( <pong> --     ) t >>paused drop  ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+M: pong-gadget ungraft*  ( <pong> --     ) t >>paused drop  ;
 
-M:: <pong> draw-gadget* ( PONG -- )
+M:: pong-gadget draw-gadget* ( PONG -- )
-
+    PONG computer>> draw
-  PONG computer>> draw
+    PONG player>>   draw
-  PONG player>>   draw
+    PONG ball>>     draw ;
-  PONG ball>>     draw ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 :: iterate-system ( GADGET -- )
-
     GADGET field>>    :> FIELD
     GADGET ball>>     :> BALL
     GADGET player>>   :> PLAYER
@@ -148,22 +122,15 @@ M:: <pong> draw-gadget* ( PONG -- )
 
     ] [ t GADGET paused<< ] if ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 :: start-pong-thread ( GADGET -- )
-  f GADGET paused<<
+    f GADGET paused<< [
-  [
+        [
-    [
+            GADGET paused>>
-      GADGET paused>>
+            [ f ]
-      [ f ]
+            [ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
-      [ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
+            if
-      if
+        ] loop
-    ]
+    ] in-thread ;
-    loop
-  ]
-  in-thread ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 MAIN-WINDOW: pong-window
     { { title "PONG" } }

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
+    GL_FRONT_AND_BACK GL_FILL glPolygonMode
-  fill-color get gl-color ;
+    fill-color get gl-color ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : stroke-mode ( -- )
-  GL_FRONT_AND_BACK GL_LINE glPolygonMode
+    GL_FRONT_AND_BACK GL_LINE glPolygonMode
-  stroke-color get gl-color ;
+    stroke-color get gl-color ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : gl-vertex-2d ( vertex -- ) first2 glVertex2d ;
 
 : gl-vertices-2d ( vertices -- ) [ gl-vertex-2d ] each ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: 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 ;
 
-: point* ( x y    -- ) stroke-mode GL_POINTS [ glVertex2d     ] do-state ;
+: draw-line** ( x y x y -- )
-: point  ( point  -- ) stroke-mode GL_POINTS [ gl-vertex-2d   ] do-state ;
+    stroke-mode GL_LINES [ glVertex2d glVertex2d ] do-state ;
-: points ( points -- ) stroke-mode GL_POINTS [ gl-vertices-2d ] do-state ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: draw-line* ( a b -- ) stroke-mode GL_LINES [ [ gl-vertex-2d ] bi@ ] do-state ;
 
-: line** ( x y x y -- )
+: draw-lines ( seq -- ) stroke-mode GL_LINES [ gl-vertices-2d ] do-state ;
-  stroke-mode GL_LINES [ glVertex2d glVertex2d ] do-state ;
 
-: line* ( a b -- ) stroke-mode GL_LINES [ [ gl-vertex-2d ] bi@ ] do-state ;
+: draw-line ( seq -- ) draw-lines ;
-
-: lines ( seq -- ) stroke-mode GL_LINES [ gl-vertices-2d ] do-state ;
-
-: line ( seq -- ) 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 -- )
+: draw-triangle ( seq -- ) draw-triangles ;
-  [ fill-mode   GL_TRIANGLES [ gl-vertices-2d ] do-state ]
-  [ stroke-mode GL_TRIANGLES [ gl-vertices-2d ] do-state ] bi ;
 
-: 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 ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+:: draw-rectangle ( loc dim -- )
-
-: polygon ( seq -- )
-  [ fill-mode   GL_POLYGON [ gl-vertices-2d ] do-state ]
-  [ stroke-mode GL_POLYGON [ gl-vertices-2d ] do-state ] bi ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: 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 ;
+    draw-polygon ;
 
-: rectangle* ( x y width height -- ) [ 2array ] 2bi@ rectangle ;
+: 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 ;
+    GL_LINE_WIDTH 0 double <ref> tuck glGetDoublev double deref ;
 
-: ellipse ( center dim -- )
+: draw-ellipse ( center dim -- )
-  GL_FRONT_AND_BACK GL_FILL glPolygonMode
+    GL_FRONT_AND_BACK GL_FILL glPolygonMode
-  [ stroke-color get gl-color                                 gl-ellipse ]
+    [ stroke-color get gl-color                                 gl-ellipse ]
-  [ fill-color get gl-color gl-get-line-width 2 * dup 2array v- gl-ellipse ] 2bi ;
+    [ fill-color get gl-color gl-get-line-width 2 * dup 2array v- gl-ellipse ] 2bi ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: draw-circle ( center size -- ) dup 2array draw-ellipse ;
-
-: circle ( center size -- ) dup 2array ellipse ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

extra/trails/trails.factor

@@ -1,100 +1,60 @@
-USING: accessors calendar circular colors colors.constants
+USING: accessors arrays calendar circular colors
-kernel locals math math.order math.vectors namespaces opengl
+colors.constants fry kernel locals math math.order math.vectors
-processing.shapes sequences threads ui ui.gadgets ui.gestures
+namespaces opengl processing.shapes sequences threads ui
-ui.render ;
+ui.gadgets ui.gestures ui.render ;
 
 IN: trails
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 ! Example 33-15 from the Processing book
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: mouse ( -- point )
+    ! Return the mouse location relative to the current gadget
+    hand-loc get hand-gadget get screen-loc v- ;
 
-! Return the mouse location relative to the current gadget
+: point-list ( n -- seq ) { 0 0 } <array> <circular> ;
-
-: mouse ( -- point ) hand-loc get  hand-gadget get screen-loc  v- ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: point-list ( n -- seq ) [ { 0 0 } ] replicate <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
-  ! Add a valid point if the mouse is in the gadget
+    ! Otherwise, add an "invisible" point
-  ! Otherwise, add an "invisible" point
+    hand-gadget get GADGET = [ mouse ] [ { -10 -10 } ] if
-
+    GADGET points>> circular-push ;
-  hand-gadget get GADGET =
-    [ mouse       GADGET points>> circular-push ]
-    [ { -10 -10 } GADGET points>> circular-push ]
-  if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 :: start-trails-thread ( GADGET -- )
-  GADGET f >>paused drop
+    GADGET f >>paused drop
-  [
     [
-      GADGET paused>>
+        [
-        [ f ]
+            GADGET paused>>
-        [ GADGET iterate-system GADGET relayout-1 1 milliseconds sleep t ]
+            [ f ]
-      if
+            [ GADGET iterate-system GADGET relayout-1 1 milliseconds sleep t ]
-    ]
+            if
-    loop
+        ]
-  ]
+        loop
-  "trails" spawn drop ;
+    ] "trails" spawn drop ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+M: trails-gadget ungraft* t >>paused drop ;
 
-M: trails-gadget ungraft* ( trails-gadget -- ) t >>paused drop ;
+M: trails-gadget pref-dim* drop { 500 500 } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: trails-gadget pref-dim* ( trails-gadget -- dim ) drop { 500 500 } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : each-percent ( seq quot -- )
-  [
+    [ dup length ] dip '[ 1 + _ / @ ] each-index ; inline
-    dup length
-    [ iota ] [ [ / ] curry ] bi
-    [ 1 + ] prepose
-  ] dip compose
-  2each ;                       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
-  trails-gadget new
+        300 point-list >>points
-
+        t >>clipped?
-    300 point-list >>points
+    dup start-trails-thread ;
-
-    t >>clipped?
-
-  dup start-trails-thread ;
 
 MAIN-WINDOW: trails-window
     { { title "Trails" } }