unmaintained: restore pong.

extra/flatland/flatland.factor

@@ -1,11 +1,8 @@
 
-USING: accessors arrays fry kernel math math.vectors sequences
+USING: accessors arrays combinators combinators.short-circuit
-       math.intervals
+fry kernel locals math math.intervals math.vectors multi-methods
-       multi-methods
+sequences ;
-       combinators.short-circuit
+FROM: multi-methods => GENERIC: ;
-       combinators.cleave.enhanced
-       multi-method-syntax ;
-
 IN: flatland
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -62,31 +59,31 @@ GENERIC: distance ( a b -- c )
 ! A two element sequence may represent a point in space or describe
 ! width and height.
 
-METHOD: x ( sequence -- x ) first  ;
+METHOD: x { sequence } first  ;
-METHOD: y ( sequence -- y ) second ;
+METHOD: y { sequence } second ;
 
-METHOD: (x!) ( number sequence -- ) set-first  ;
+METHOD: (x!) { number sequence } set-first  ;
-METHOD: (y!) ( number sequence -- ) set-second ;
+METHOD: (y!) { number sequence } set-second ;
 
-METHOD: width  ( sequence -- width  ) first  ;
+METHOD: width  { sequence } first  ;
-METHOD: height ( sequence -- height ) second ;
+METHOD: height { sequence } second ;
 
 : changed-x ( seq quot -- ) over [ [ x ] dip call ] dip (x!) ; inline
 : changed-y ( seq quot -- ) over [ [ y ] dip call ] dip (y!) ; inline
 
-METHOD: move-to ( sequence sequence -- )         [ x x! ] [ y y! ] bi drop ;
+METHOD: move-to { sequence sequence }         [ x x! ] [ y y! ] bi drop ;
-METHOD: move-by ( sequence sequence -- ) dupd v+ [ x x! ] [ y y! ] bi drop ;
+METHOD: move-by { sequence sequence } dupd v+ [ x x! ] [ y y! ] bi drop ;
 
-METHOD: move-left-by  ( sequence number -- ) '[ _ - ] changed-x ;
+METHOD: move-left-by  { sequence number } '[ _ - ] changed-x ;
-METHOD: move-right-by ( sequence number -- ) '[ _ + ] changed-x ;
+METHOD: move-right-by { sequence number } '[ _ + ] changed-x ;
 
-! METHOD: move-left-by  ( sequence number -- ) neg 0 2array move-by ;
+! METHOD: move-left-by  { sequence number } neg 0 2array move-by ;
-! METHOD: move-right-by ( sequence number -- )     0 2array move-by ;
+! METHOD: move-right-by { sequence number }     0 2array move-by ;
 
-! METHOD:: move-left-by  ( SEQ:sequence X:number -- )
+! METHOD:: move-left-by  { SEQ:sequence X:number -- )
 !   SEQ { X 0 } { -1 0 } v* move-by ;
 
-METHOD: distance ( sequence sequence -- dist ) v- norm ;
+METHOD: distance { sequence sequence } v- norm ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -94,24 +91,24 @@ METHOD: distance ( sequence sequence -- dist ) v- norm ;
 
 TUPLE: <pos> pos ;
 
-METHOD: x ( <pos> -- x ) pos>> first  ;
+METHOD: x { <pos> } pos>> first  ;
-METHOD: y ( <pos> -- y ) 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> -- dist ) [ pos>> ] bi@ distance ;
+METHOD: distance { <pos> <pos> } [ pos>> ] bi@ distance ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -135,55 +132,55 @@ TUPLE: <vel> < <pos> vel ;
 
 TUPLE: <rectangle> < <pos> dim ;
 
-METHOD: width  ( <rectangle> -- width  ) dim>> first  ;
+METHOD: width  { <rectangle> } dim>> first  ;
-METHOD: height ( <rectangle> -- height ) dim>> second ;
+METHOD: height { <rectangle> } dim>> second ;
 
-METHOD: left   ( <rectangle> -- x )    x             ;
+METHOD: left   { <rectangle> }    x             ;
-METHOD: right  ( <rectangle> -- x ) \\ x width  bi + ;
+METHOD: right  { <rectangle> } [ x ] [ width ] bi + ;
-METHOD: bottom ( <rectangle> -- y )    y             ;
+METHOD: bottom { <rectangle> }    y             ;
-METHOD: top    ( <rectangle> -- y ) \\ y height bi + ;
+METHOD: top    { <rectangle> } [ y ] [ height ] bi + ;
 
 : bottom-left ( rectangle -- pos ) pos>> ;
 
 : center-x ( rectangle -- x ) [ left   ] [ width  2 / ] bi + ;
 : center-y ( rectangle -- y ) [ bottom ] [ height 2 / ] bi + ;
 
-: center ( rectangle -- seq ) \\ center-x center-y bi 2array ;
+: 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> -- interval )
+METHOD: horizontal-interval { <rectangle> }
-  \\ left right bi [a,b] ;
+  [ left ] [ right ] bi [a,b] ;
 
-METHOD: in-between-horizontally? ( <pos> <rectangle> -- ? )
+METHOD: in-between-horizontally? { <pos> <rectangle> }
-  \\ x horizontal-interval bi* interval-contains? ;
+  [ x ] [ horizontal-interval ] bi* interval-contains? ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 TUPLE: <extent> left right bottom top ;
 
-METHOD: left   ( <extent> -- left   ) left>>   ;
+METHOD: left   { <extent> } left>>   ;
-METHOD: right  ( <extent> -- right  ) right>>  ;
+METHOD: right  { <extent> } right>>  ;
-METHOD: bottom ( <extent> -- bottom ) bottom>> ;
+METHOD: bottom { <extent> } bottom>> ;
-METHOD: top    ( <extent> -- top    ) top>>    ;
+METHOD: top    { <extent> } top>>    ;
 
-METHOD: width  ( <extent> -- width  ) \\ right>> left>>   bi - ;
+METHOD: width  { <extent> } [ right>> ] [ left>>   ] bi - ;
-METHOD: height ( <extent> -- height ) \\ top>>   bottom>> bi - ;
+METHOD: height { <extent> } [ top>>   ] [ bottom>> ] bi - ;
 
 ! 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-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* > ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -200,10 +197,7 @@ METHOD: above? ( sequence <rectangle> -- ? ) \\ y top    bi* > ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-USING: locals combinators ; 
-
 :: wrap ( POINT RECT -- POINT )
-    
   {
       { [ POINT RECT to-the-left-of?  ] [ RECT right ] }
       { [ POINT RECT to-the-right-of? ] [ RECT left  ] }
@@ -224,7 +218,7 @@ USING: locals combinators ;
 
 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

@@ -1,18 +1,11 @@
-
+USING: accessors alien.c-types alien.data arrays calendar colors
-USING: kernel accessors locals math math.intervals math.order
+combinators combinators.short-circuit flatland generalizations
-       namespaces sequences threads
+grouping kernel locals math math.intervals math.order
-       ui
+math.rectangles math.vectors namespaces opengl opengl.gl
-       ui.gadgets
+opengl.glu processing.shapes sequences sequences.generalizations
-       ui.gestures
+shuffle threads ui ui.gadgets ui.gestures ui.render ;
-       ui.render
+FROM: multi-methods => GENERIC: METHOD: ;
-       calendar
+FROM: syntax => M: ;
-       multi-methods
-       multi-method-syntax
-       combinators.short-circuit.smart
-       combinators.cleave.enhanced
-       processing.shapes
-       flatland ;
-
 IN: pong
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -51,7 +44,7 @@ TUPLE: <ball> < <vel>
   {
     [ above-lower-bound? ]
     [ below-upper-bound? ]
-  } && ;
+  } 2&& ;
 
 :: bounce-change-vertical-velocity ( BALL -- )
 
@@ -94,18 +87,15 @@ TUPLE: <ball> < <vel>
 
 GENERIC: draw ( obj -- )
 
-METHOD: draw ( <paddle> -- ) [ bottom-left ] [ dim>>          ] bi rectangle ;
+METHOD: draw { <paddle> } [ bottom-left ] [ dim>>          ] bi rectangle ;
-METHOD: draw ( <ball>   -- ) [ pos>>       ] [ diameter>> 2 / ] bi circle    ;
+METHOD: draw { <ball>   } [ pos>>       ] [ diameter>> 2 / ] bi circle    ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-USE: syntax ! Switch back to core 'TUPLE:' instead of the one provided
-            ! by multi-methods
-
 TUPLE: <pong> < gadget paused field ball player computer ;
 
 : pong ( -- gadget )
-  <pong> new-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
@@ -126,33 +116,16 @@ M:: <pong> draw-gadget* ( PONG -- )
 
 :: iterate-system ( GADGET -- )
 
-  [let | FIELD    [ GADGET field>>    ]
+    GADGET field>>    :> FIELD
-         BALL     [ GADGET ball>>     ]
+    GADGET ball>>     :> BALL
-         PLAYER   [ GADGET player>>   ]
+    GADGET player>>   :> PLAYER
-         COMPUTER [ GADGET computer>> ] |
+    GADGET computer>> :> COMPUTER
 
-    [wlet | align-player-with-mouse [ ( -- )
+    BALL FIELD in-bounds? [
-              PLAYER FIELD align-paddle-with-mouse ]
 
-            move-ball [ ( -- ) BALL 1 move-for ]
+        PLAYER FIELD align-paddle-with-mouse
 
-            player-blocked-ball? [ ( -- ? )
+        BALL 1 move-for
-              BALL PLAYER { [ above? ] [ in-between-horizontally? ] } && ]
-
-            computer-blocked-ball? [ ( -- ? )
-              BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } && ]
-
-            bounce-off-wall? [ ( -- ? )
-              BALL FIELD in-between-horizontally? not ]
-
-            stop-game [ ( -- ) t GADGET paused<< ] |
-
-      BALL FIELD in-bounds?
-      [
-
-        align-player-with-mouse
-
-        move-ball
 
         ! computer reaction
 
@@ -160,15 +133,20 @@ M:: <pong> draw-gadget* ( PONG -- )
         BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
 
         ! check if ball bounced off something
-              
-        player-blocked-ball?   [ BALL PLAYER   bounce-off-paddle  ] when
-        computer-blocked-ball? [ BALL COMPUTER bounce-off-paddle  ] when
-        bounce-off-wall?       [ BALL reverse-horizontal-velocity ] when
-      ]
-      [ stop-game ]
-      if
 
-  ] ] ( gadget -- ) ;
+        ! player-blocked-ball?
+        BALL PLAYER { [ above? ] [ in-between-horizontally? ] } 2&&
+        [ BALL PLAYER   bounce-off-paddle  ] when
+
+        ! computer-blocked-ball?
+        BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } 2&&
+        [ BALL COMPUTER bounce-off-paddle  ] when
+
+        ! bounced-off-wall?
+        BALL FIELD in-between-horizontally? not
+        [ BALL reverse-horizontal-velocity ] when
+
+    ] [ t GADGET paused<< ] if ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!