194 lines
5.2 KiB
Factor
194 lines
5.2 KiB
Factor
|
|
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 |