From 00ff4cd2bcd1dda1a52ce9e1a80f451b326effb3 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Fri, 24 Oct 2014 22:29:44 -0700 Subject: [PATCH] unmaintained: restore pong. --- .../flatland/flatland.factor | 118 +++++++++--------- {unmaintained => extra}/pong/pong.factor | 86 +++++-------- 2 files changed, 88 insertions(+), 116 deletions(-) rename {unmaintained => extra}/flatland/flatland.factor (56%) rename {unmaintained => extra}/pong/pong.factor (67%) diff --git a/unmaintained/flatland/flatland.factor b/extra/flatland/flatland.factor similarity index 56% rename from unmaintained/flatland/flatland.factor rename to extra/flatland/flatland.factor index 72d9e50a9d..d47ec32e3e 100644 --- a/unmaintained/flatland/flatland.factor +++ b/extra/flatland/flatland.factor @@ -1,11 +1,8 @@ -USING: accessors arrays fry kernel math math.vectors sequences - math.intervals - multi-methods - combinators.short-circuit - combinators.cleave.enhanced - multi-method-syntax ; - +USING: accessors arrays combinators combinators.short-circuit +fry kernel locals math math.intervals math.vectors multi-methods +sequences ; +FROM: multi-methods => GENERIC: ; 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: y ( sequence -- y ) second ; +METHOD: x { sequence } first ; +METHOD: y { sequence } second ; -METHOD: (x!) ( number sequence -- ) set-first ; -METHOD: (y!) ( number sequence -- ) set-second ; +METHOD: (x!) { number sequence } set-first ; +METHOD: (y!) { number sequence } set-second ; -METHOD: width ( sequence -- width ) first ; -METHOD: height ( sequence -- height ) 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-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 } '[ _ - ] 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 { 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 -- ) +! 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 ; -METHOD: x ( -- x ) pos>> first ; -METHOD: y ( -- y ) pos>> second ; +METHOD: x { } pos>> first ; +METHOD: y { } pos>> second ; -METHOD: (x!) ( number -- ) pos>> set-first ; -METHOD: (y!) ( number -- ) pos>> set-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: 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: 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: above? { number } [ y ] dip > ; +METHOD: below? { number } [ y ] dip < ; -METHOD: move-by ( sequence -- ) '[ _ v+ ] change-pos drop ; +METHOD: move-by { sequence } '[ _ v+ ] change-pos drop ; -METHOD: distance ( -- dist ) [ pos>> ] bi@ distance ; +METHOD: distance { } [ pos>> ] bi@ distance ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -135,55 +132,55 @@ TUPLE: < vel ; TUPLE: < dim ; -METHOD: width ( -- width ) dim>> first ; -METHOD: height ( -- height ) dim>> second ; +METHOD: width { } dim>> first ; +METHOD: height { } dim>> second ; -METHOD: left ( -- x ) x ; -METHOD: right ( -- x ) \\ x width bi + ; -METHOD: bottom ( -- y ) y ; -METHOD: top ( -- y ) \\ y height bi + ; +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 ; +: 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: 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: below? { } [ y ] [ bottom ] bi* < ; +METHOD: above? { } [ y ] [ top ] bi* > ; -METHOD: horizontal-interval ( -- interval ) - \\ left right bi [a,b] ; +METHOD: horizontal-interval { } + [ left ] [ right ] bi [a,b] ; -METHOD: in-between-horizontally? ( -- ? ) - \\ x horizontal-interval bi* interval-contains? ; +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: left { } left>> ; +METHOD: right { } right>> ; +METHOD: bottom { } bottom>> ; +METHOD: top { } top>> ; -METHOD: width ( -- width ) \\ right>> left>> bi - ; -METHOD: height ( -- height ) \\ top>> bottom>> bi - ; +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: 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* > ; +METHOD: below? { sequence } [ y ] [ bottom ] bi* < ; +METHOD: above? { sequence } [ y ] [ top ] bi* > ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -200,10 +197,7 @@ METHOD: above? ( sequence -- ? ) \\ 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? ( -- ? ) +METHOD: within? { } { [ left to-the-right-of? ] [ right to-the-left-of? ] diff --git a/unmaintained/pong/pong.factor b/extra/pong/pong.factor similarity index 67% rename from unmaintained/pong/pong.factor rename to extra/pong/pong.factor index ed80b03260..e7e6c47002 100644 --- a/unmaintained/pong/pong.factor +++ b/extra/pong/pong.factor @@ -1,18 +1,11 @@ - -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 ; - +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 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -51,7 +44,7 @@ TUPLE: < { [ above-lower-bound? ] [ below-upper-bound? ] - } && ; + } 2&& ; :: bounce-change-vertical-velocity ( BALL -- ) @@ -94,18 +87,15 @@ TUPLE: < GENERIC: draw ( obj -- ) -METHOD: draw ( -- ) [ bottom-left ] [ dim>> ] bi rectangle ; -METHOD: draw ( -- ) [ pos>> ] [ diameter>> 2 / ] bi circle ; +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 + 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 @@ -126,33 +116,16 @@ M:: draw-gadget* ( PONG -- ) :: 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? ] } && ] + GADGET field>> :> FIELD + GADGET ball>> :> BALL + GADGET player>> :> PLAYER + GADGET computer>> :> COMPUTER - bounce-off-wall? [ ( -- ? ) - BALL FIELD in-between-horizontally? not ] + BALL FIELD in-bounds? [ - stop-game [ ( -- ) t GADGET paused<< ] | + PLAYER FIELD align-paddle-with-mouse - BALL FIELD in-bounds? - [ - - align-player-with-mouse - - move-ball + BALL 1 move-for ! computer reaction @@ -160,15 +133,20 @@ M:: 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 ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -- 2.34.1