From: John Benediktsson Date: Sat, 25 Oct 2014 05:29:44 +0000 (-0700) Subject: unmaintained: restore pong. X-Git-Tag: 0.97~43 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=00ff4cd2bcd1dda1a52ce9e1a80f451b326effb3 unmaintained: restore pong. --- diff --git a/extra/flatland/flatland.factor b/extra/flatland/flatland.factor new file mode 100644 index 0000000000..d47ec32e3e --- /dev/null +++ b/extra/flatland/flatland.factor @@ -0,0 +1,228 @@ + +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 ; + +METHOD: x { } pos>> first ; +METHOD: y { } pos>> second ; + +METHOD: (x!) { number } pos>> set-first ; +METHOD: (y!) { number } pos>> set-second ; + +METHOD: to-the-left-of? { number } [ x ] dip < ; +METHOD: to-the-right-of? { number } [ x ] dip > ; + +METHOD: move-left-by { number } [ pos>> ] dip move-left-by ; +METHOD: move-right-by { number } [ pos>> ] dip move-right-by ; + +METHOD: above? { number } [ y ] dip > ; +METHOD: below? { number } [ y ] dip < ; + +METHOD: move-by { sequence } '[ _ v+ ] change-pos drop ; + +METHOD: distance { } [ pos>> ] bi@ distance ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! A class for objects with velocity. It inherits from . Hey, if +! it's moving it has a position right? Unless it's some alternate universe... + +TUPLE: < 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: < dim ; + +METHOD: width { } dim>> first ; +METHOD: height { } dim>> second ; + +METHOD: left { } x ; +METHOD: right { } [ x ] [ width ] bi + ; +METHOD: bottom { } y ; +METHOD: top { } [ 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? { } [ x ] [ left ] bi* < ; +METHOD: to-the-right-of? { } [ x ] [ right ] bi* > ; + +METHOD: below? { } [ y ] [ bottom ] bi* < ; +METHOD: above? { } [ y ] [ top ] bi* > ; + +METHOD: horizontal-interval { } + [ left ] [ right ] bi [a,b] ; + +METHOD: in-between-horizontally? { } + [ x ] [ horizontal-interval ] bi* interval-contains? ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: left right bottom top ; + +METHOD: left { } left>> ; +METHOD: right { } right>> ; +METHOD: bottom { } bottom>> ; +METHOD: top { } top>> ; + +METHOD: width { } [ right>> ] [ left>> ] bi - ; +METHOD: height { } [ top>> ] [ bottom>> ] bi - ; + +! METHOD: to-extent ( -- ) +! { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave boa ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: to-the-left-of? { sequence } [ x ] [ left ] bi* < ; +METHOD: to-the-right-of? { sequence } [ x ] [ right ] bi* > ; + +METHOD: below? { sequence } [ y ] [ bottom ] bi* < ; +METHOD: above? { sequence } [ 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? { } + { + [ left to-the-right-of? ] + [ right to-the-left-of? ] + [ bottom above? ] + [ top below? ] + } + 2&& ; diff --git a/extra/pong/pong.factor b/extra/pong/pong.factor new file mode 100644 index 0000000000..e7e6c47002 --- /dev/null +++ b/extra/pong/pong.factor @@ -0,0 +1,172 @@ +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: < ; +TUPLE: < ; + +TUPLE: < { speed initial: 10 } ; + +: computer-move-left ( computer -- ) dup speed>> move-left-by ; +: computer-move-right ( computer -- ) dup speed>> move-right-by ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: < + { 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 { } [ bottom-left ] [ dim>> ] bi rectangle ; +METHOD: draw { } [ pos>> ] [ diameter>> 2 / ] bi circle ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: < 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 ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M:: 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 diff --git a/unmaintained/flatland/flatland.factor b/unmaintained/flatland/flatland.factor deleted file mode 100644 index 72d9e50a9d..0000000000 --- a/unmaintained/flatland/flatland.factor +++ /dev/null @@ -1,234 +0,0 @@ - -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 ; - -METHOD: x ( -- x ) pos>> first ; -METHOD: y ( -- y ) pos>> second ; - -METHOD: (x!) ( number -- ) pos>> set-first ; -METHOD: (y!) ( number -- ) pos>> set-second ; - -METHOD: to-the-left-of? ( number -- ? ) [ x ] dip < ; -METHOD: to-the-right-of? ( number -- ? ) [ x ] dip > ; - -METHOD: move-left-by ( number -- ) [ pos>> ] dip move-left-by ; -METHOD: move-right-by ( number -- ) [ pos>> ] dip move-right-by ; - -METHOD: above? ( number -- ? ) [ y ] dip > ; -METHOD: below? ( number -- ? ) [ y ] dip < ; - -METHOD: move-by ( sequence -- ) '[ _ v+ ] change-pos drop ; - -METHOD: distance ( -- dist ) [ pos>> ] bi@ distance ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! A class for objects with velocity. It inherits from . Hey, if -! it's moving it has a position right? Unless it's some alternate universe... - -TUPLE: < 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: < dim ; - -METHOD: width ( -- width ) dim>> first ; -METHOD: height ( -- height ) dim>> second ; - -METHOD: left ( -- x ) x ; -METHOD: right ( -- x ) \\ x width bi + ; -METHOD: bottom ( -- y ) y ; -METHOD: top ( -- 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? ( -- ? ) \\ x left bi* < ; -METHOD: to-the-right-of? ( -- ? ) \\ x right bi* > ; - -METHOD: below? ( -- ? ) \\ y bottom bi* < ; -METHOD: above? ( -- ? ) \\ y top bi* > ; - -METHOD: horizontal-interval ( -- interval ) - \\ left right bi [a,b] ; - -METHOD: in-between-horizontally? ( -- ? ) - \\ x horizontal-interval bi* interval-contains? ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -TUPLE: left right bottom top ; - -METHOD: left ( -- left ) left>> ; -METHOD: right ( -- right ) right>> ; -METHOD: bottom ( -- bottom ) bottom>> ; -METHOD: top ( -- top ) top>> ; - -METHOD: width ( -- width ) \\ right>> left>> bi - ; -METHOD: height ( -- height ) \\ top>> bottom>> bi - ; - -! METHOD: to-extent ( -- ) -! { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave boa ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -METHOD: to-the-left-of? ( sequence -- ? ) \\ x left bi* < ; -METHOD: to-the-right-of? ( sequence -- ? ) \\ x right bi* > ; - -METHOD: below? ( sequence -- ? ) \\ y bottom bi* < ; -METHOD: above? ( sequence -- ? ) \\ 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? ( -- ? ) - { - [ left to-the-right-of? ] - [ right to-the-left-of? ] - [ bottom above? ] - [ top below? ] - } - 2&& ; diff --git a/unmaintained/pong/pong.factor b/unmaintained/pong/pong.factor deleted file mode 100644 index ed80b03260..0000000000 --- a/unmaintained/pong/pong.factor +++ /dev/null @@ -1,194 +0,0 @@ - -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: < ; -TUPLE: < ; - -TUPLE: < { speed initial: 10 } ; - -: computer-move-left ( computer -- ) dup speed>> move-left-by ; -: computer-move-right ( computer -- ) dup speed>> move-right-by ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -TUPLE: < - { 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 ( -- ) [ bottom-left ] [ dim>> ] bi rectangle ; -METHOD: draw ( -- ) [ pos>> ] [ diameter>> 2 / ] bi circle ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -USE: syntax ! Switch back to core 'TUPLE:' instead of the one provided - ! by multi-methods - -TUPLE: < gadget paused field ball player computer ; - -: pong ( -- gadget ) - new-gadget - 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 ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -M:: 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