--- /dev/null
+
+USING: accessors arrays combinators combinators.short-circuit
+fry kernel locals math math.intervals math.vectors multi-methods
+sequences ;
+FROM: multi-methods => GENERIC: ;
+IN: flatland
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Two dimensional world protocol
+
+GENERIC: x ( obj -- x )
+GENERIC: y ( obj -- y )
+
+GENERIC: (x!) ( x obj -- )
+GENERIC: (y!) ( y obj -- )
+
+: x! ( obj x -- obj ) over (x!) ;
+: y! ( obj y -- obj ) over (y!) ;
+
+GENERIC: width ( obj -- width )
+GENERIC: height ( obj -- height )
+
+GENERIC: (width!) ( width obj -- )
+GENERIC: (height!) ( height obj -- )
+
+: width! ( obj width -- obj ) over (width!) ;
+: height! ( obj height -- obj ) over (width!) ;
+
+! Predicates on relative placement
+
+GENERIC: to-the-left-of? ( obj obj -- ? )
+GENERIC: to-the-right-of? ( obj obj -- ? )
+
+GENERIC: below? ( obj obj -- ? )
+GENERIC: above? ( obj obj -- ? )
+
+GENERIC: in-between-horizontally? ( obj obj -- ? )
+
+GENERIC: horizontal-interval ( obj -- interval )
+
+GENERIC: move-to ( obj obj -- )
+
+GENERIC: move-by ( obj delta -- )
+
+GENERIC: move-left-by ( obj obj -- )
+GENERIC: move-right-by ( obj obj -- )
+
+GENERIC: left ( obj -- left )
+GENERIC: right ( obj -- right )
+GENERIC: bottom ( obj -- bottom )
+GENERIC: top ( obj -- top )
+
+GENERIC: distance ( a b -- c )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Some of the above methods work on two element sequences.
+! A two element sequence may represent a point in space or describe
+! width and height.
+
+METHOD: x { sequence } first ;
+METHOD: y { sequence } second ;
+
+METHOD: (x!) { number sequence } set-first ;
+METHOD: (y!) { number sequence } set-second ;
+
+METHOD: width { sequence } first ;
+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-by { sequence sequence } dupd v+ [ x x! ] [ y y! ] bi drop ;
+
+METHOD: move-left-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-right-by { sequence number } 0 2array move-by ;
+
+! METHOD:: move-left-by { SEQ:sequence X:number -- )
+! SEQ { X 0 } { -1 0 } v* move-by ;
+
+METHOD: distance { sequence sequence } v- norm ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! A class for objects with a position
+
+TUPLE: <pos> pos ;
+
+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: 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: above? { <pos> number } [ y ] dip > ;
+METHOD: below? { <pos> number } [ y ] dip < ;
+
+METHOD: move-by { <pos> sequence } '[ _ v+ ] change-pos drop ;
+
+METHOD: distance { <pos> <pos> } [ pos>> ] bi@ distance ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! 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 ;
+
+: moving-up? ( obj -- ? ) vel>> y 0 > ;
+: moving-down? ( obj -- ? ) vel>> y 0 < ;
+
+: step-size ( vel time -- dist ) [ vel>> ] dip v*n ;
+: move-for ( vel time -- ) dupd step-size move-by ;
+
+: reverse-horizontal-velocity ( vel -- ) vel>> [ x neg ] [ ] bi (x!) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! The 'pos' slot indicates the lower left hand corner of the
+! rectangle. The 'dim' is holds the width and height.
+
+TUPLE: <rectangle> < <pos> dim ;
+
+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 + ;
+
+: 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 ;
+
+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: horizontal-interval { <rectangle> }
+ [ left ] [ right ] bi [a,b] ;
+
+METHOD: in-between-horizontally? { <pos> <rectangle> }
+ [ x ] [ horizontal-interval ] bi* interval-contains? ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <extent> left right bottom 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: 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: below? { sequence <rectangle> } [ y ] [ bottom ] bi* < ;
+METHOD: above? { sequence <rectangle> } [ y ] [ top ] bi* > ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Some support for the' 'rect' class from math.geometry.rect'
+
+! METHOD: width ( rect -- width ) dim>> first ;
+! METHOD: height ( rect -- height ) dim>> second ;
+
+! METHOD: left ( rect -- left ) loc>> x
+! METHOD: right ( rect -- right ) [ loc>> x ] [ width ] bi + ;
+
+! METHOD: to-the-left-of? ( sequence rect -- ? ) [ x ] [ loc>> x ] bi* < ;
+! METHOD: to-the-right-of? ( sequence rect -- ? ) [ x ] [ loc>> x ] bi* > ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: wrap ( POINT RECT -- POINT )
+ {
+ { [ POINT RECT to-the-left-of? ] [ RECT right ] }
+ { [ POINT RECT to-the-right-of? ] [ RECT left ] }
+ { [ t ] [ POINT x ] }
+ }
+ cond
+
+ {
+ { [ POINT RECT below? ] [ RECT top ] }
+ { [ POINT RECT above? ] [ RECT bottom ] }
+ { [ t ] [ POINT y ] }
+ }
+ cond
+
+ 2array ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: within? ( a b -- ? )
+
+METHOD: within? { <pos> <rectangle> }
+ {
+ [ left to-the-right-of? ]
+ [ right to-the-left-of? ]
+ [ bottom above? ]
+ [ top below? ]
+ }
+ 2&& ;
--- /dev/null
+USING: accessors alien.c-types alien.data arrays calendar colors
+combinators combinators.short-circuit flatland generalizations
+grouping kernel locals math math.intervals math.order
+math.rectangles math.vectors namespaces opengl opengl.gl
+opengl.glu processing.shapes sequences sequences.generalizations
+shuffle threads ui ui.gadgets ui.gestures ui.render ;
+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 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <play-field> < <rectangle> ;
+TUPLE: <paddle> < <rectangle> ;
+
+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 }
+ { 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&& ;
+
+:: bounce-change-vertical-velocity ( BALL -- )
+
+ 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 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <pong> < 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 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <pong> draw-gadget* ( PONG -- )
+
+ PONG computer>> draw
+ PONG player>> draw
+ PONG ball>> draw ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: iterate-system ( GADGET -- )
+
+ GADGET field>> :> FIELD
+ GADGET ball>> :> BALL
+ GADGET player>> :> PLAYER
+ GADGET computer>> :> COMPUTER
+
+ BALL FIELD in-bounds? [
+
+ PLAYER FIELD align-paddle-with-mouse
+
+ BALL 1 move-for
+
+ ! computer reaction
+
+ BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when
+ BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
+
+ ! check if ball bounced off something
+
+ ! 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 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: start-pong-thread ( GADGET -- )
+ f GADGET paused<<
+ [
+ [
+ GADGET paused>>
+ [ f ]
+ [ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
+ if
+ ]
+ loop
+ ]
+ in-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pong-window ( -- ) pong [ "PONG" open-window ] [ start-pong-thread ] bi ;
+
+: pong-main ( -- ) [ pong-window ] with-ui ;
+
+MAIN: pong-window
+++ /dev/null
-
-USING: accessors arrays fry kernel math math.vectors sequences
- math.intervals
- multi-methods
- combinators.short-circuit
- combinators.cleave.enhanced
- multi-method-syntax ;
-
-IN: flatland
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Two dimensional world protocol
-
-GENERIC: x ( obj -- x )
-GENERIC: y ( obj -- y )
-
-GENERIC: (x!) ( x obj -- )
-GENERIC: (y!) ( y obj -- )
-
-: x! ( obj x -- obj ) over (x!) ;
-: y! ( obj y -- obj ) over (y!) ;
-
-GENERIC: width ( obj -- width )
-GENERIC: height ( obj -- height )
-
-GENERIC: (width!) ( width obj -- )
-GENERIC: (height!) ( height obj -- )
-
-: width! ( obj width -- obj ) over (width!) ;
-: height! ( obj height -- obj ) over (width!) ;
-
-! Predicates on relative placement
-
-GENERIC: to-the-left-of? ( obj obj -- ? )
-GENERIC: to-the-right-of? ( obj obj -- ? )
-
-GENERIC: below? ( obj obj -- ? )
-GENERIC: above? ( obj obj -- ? )
-
-GENERIC: in-between-horizontally? ( obj obj -- ? )
-
-GENERIC: horizontal-interval ( obj -- interval )
-
-GENERIC: move-to ( obj obj -- )
-
-GENERIC: move-by ( obj delta -- )
-
-GENERIC: move-left-by ( obj obj -- )
-GENERIC: move-right-by ( obj obj -- )
-
-GENERIC: left ( obj -- left )
-GENERIC: right ( obj -- right )
-GENERIC: bottom ( obj -- bottom )
-GENERIC: top ( obj -- top )
-
-GENERIC: distance ( a b -- c )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Some of the above methods work on two element sequences.
-! A two element sequence may represent a point in space or describe
-! width and height.
-
-METHOD: x ( sequence -- x ) first ;
-METHOD: y ( sequence -- y ) second ;
-
-METHOD: (x!) ( number sequence -- ) set-first ;
-METHOD: (y!) ( number sequence -- ) set-second ;
-
-METHOD: width ( sequence -- width ) first ;
-METHOD: height ( sequence -- height ) 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-by ( sequence sequence -- ) dupd v+ [ x x! ] [ y y! ] bi drop ;
-
-METHOD: move-left-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-right-by ( sequence number -- ) 0 2array move-by ;
-
-! METHOD:: move-left-by ( SEQ:sequence X:number -- )
-! SEQ { X 0 } { -1 0 } v* move-by ;
-
-METHOD: distance ( sequence sequence -- dist ) v- norm ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! A class for objects with a position
-
-TUPLE: <pos> pos ;
-
-METHOD: x ( <pos> -- x ) pos>> first ;
-METHOD: y ( <pos> -- y ) pos>> 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: 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: move-by ( <pos> sequence -- ) '[ _ v+ ] change-pos drop ;
-
-METHOD: distance ( <pos> <pos> -- dist ) [ pos>> ] bi@ distance ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! 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 ;
-
-: moving-up? ( obj -- ? ) vel>> y 0 > ;
-: moving-down? ( obj -- ? ) vel>> y 0 < ;
-
-: step-size ( vel time -- dist ) [ vel>> ] dip v*n ;
-: move-for ( vel time -- ) dupd step-size move-by ;
-
-: reverse-horizontal-velocity ( vel -- ) vel>> [ x neg ] [ ] bi (x!) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! The 'pos' slot indicates the lower left hand corner of the
-! rectangle. The 'dim' is holds the width and height.
-
-TUPLE: <rectangle> < <pos> dim ;
-
-METHOD: width ( <rectangle> -- width ) dim>> first ;
-METHOD: height ( <rectangle> -- height ) dim>> second ;
-
-METHOD: left ( <rectangle> -- x ) x ;
-METHOD: right ( <rectangle> -- x ) \\ x width bi + ;
-METHOD: bottom ( <rectangle> -- y ) y ;
-METHOD: top ( <rectangle> -- y ) \\ 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 ;
-
-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: horizontal-interval ( <rectangle> -- interval )
- \\ left right bi [a,b] ;
-
-METHOD: in-between-horizontally? ( <pos> <rectangle> -- ? )
- \\ x horizontal-interval bi* interval-contains? ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <extent> left right bottom top ;
-
-METHOD: left ( <extent> -- left ) left>> ;
-METHOD: right ( <extent> -- right ) right>> ;
-METHOD: bottom ( <extent> -- bottom ) bottom>> ;
-METHOD: top ( <extent> -- top ) top>> ;
-
-METHOD: width ( <extent> -- width ) \\ right>> left>> bi - ;
-METHOD: height ( <extent> -- height ) \\ 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-right-of? ( sequence <rectangle> -- ? ) \\ x right bi* > ;
-
-METHOD: below? ( sequence <rectangle> -- ? ) \\ y bottom bi* < ;
-METHOD: above? ( sequence <rectangle> -- ? ) \\ y top bi* > ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Some support for the' 'rect' class from math.geometry.rect'
-
-! METHOD: width ( rect -- width ) dim>> first ;
-! METHOD: height ( rect -- height ) dim>> second ;
-
-! METHOD: left ( rect -- left ) loc>> x
-! METHOD: right ( rect -- right ) [ loc>> x ] [ width ] bi + ;
-
-! METHOD: to-the-left-of? ( sequence rect -- ? ) [ x ] [ loc>> x ] bi* < ;
-! METHOD: to-the-right-of? ( sequence rect -- ? ) [ x ] [ loc>> x ] bi* > ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: locals combinators ;
-
-:: wrap ( POINT RECT -- POINT )
-
- {
- { [ POINT RECT to-the-left-of? ] [ RECT right ] }
- { [ POINT RECT to-the-right-of? ] [ RECT left ] }
- { [ t ] [ POINT x ] }
- }
- cond
-
- {
- { [ POINT RECT below? ] [ RECT top ] }
- { [ POINT RECT above? ] [ RECT bottom ] }
- { [ t ] [ POINT y ] }
- }
- cond
-
- 2array ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: within? ( a b -- ? )
-
-METHOD: within? ( <pos> <rectangle> -- ? )
- {
- [ left to-the-right-of? ]
- [ right to-the-left-of? ]
- [ bottom above? ]
- [ top below? ]
- }
- 2&& ;
+++ /dev/null
-
-USING: kernel accessors locals math math.intervals math.order
- namespaces sequences threads
- ui
- ui.gadgets
- ui.gestures
- ui.render
- calendar
- multi-methods
- multi-method-syntax
- combinators.short-circuit.smart
- combinators.cleave.enhanced
- processing.shapes
- flatland ;
-
-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 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <play-field> < <rectangle> ;
-TUPLE: <paddle> < <rectangle> ;
-
-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 }
- { 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? ]
- } && ;
-
-:: bounce-change-vertical-velocity ( BALL -- )
-
- 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 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-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
- 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 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M:: <pong> draw-gadget* ( PONG -- )
-
- PONG computer>> draw
- PONG player>> draw
- PONG ball>> draw ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: iterate-system ( GADGET -- )
-
- [let | FIELD [ GADGET field>> ]
- BALL [ GADGET ball>> ]
- PLAYER [ GADGET player>> ]
- COMPUTER [ GADGET computer>> ] |
-
- [wlet | align-player-with-mouse [ ( -- )
- PLAYER FIELD align-paddle-with-mouse ]
-
- move-ball [ ( -- ) BALL 1 move-for ]
-
- player-blocked-ball? [ ( -- ? )
- 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
-
- BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when
- 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 -- ) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: start-pong-thread ( GADGET -- )
- f GADGET paused<<
- [
- [
- GADGET paused>>
- [ f ]
- [ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
- if
- ]
- loop
- ]
- in-thread ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: pong-window ( -- ) pong [ "PONG" open-window ] [ start-pong-thread ] bi ;
-
-: pong-main ( -- ) [ pong-window ] with-ui ;
-
-MAIN: pong-window
projects / factor.git / commitdiff