-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 ;
-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 ] [ to>> first ] bi clamp ;
+USING: accessors arrays calendar colors.constants
+combinators.short-circuit fonts fry kernel literals locals math
+math.order math.ranges math.vectors namespaces opengl random
+sequences timers ui ui.commands ui.gadgets ui.gadgets.worlds
+ui.gestures ui.pens.solid ui.render ui.text ;
-TUPLE: play-field < rectangle ;
+IN: pong
-TUPLE: paddle < rectangle ;
+CONSTANT: BOUNCE 6/5
+CONSTANT: MAX-SPEED 6
+CONSTANT: BALL-SIZE 10
+CONSTANT: BALL-DIM ${ BALL-SIZE BALL-SIZE }
+CONSTANT: PADDLE-SIZE 80
+CONSTANT: PADDLE-DIM ${ PADDLE-SIZE 10 }
+CONSTANT: FONT $[
+ monospace-font
+ t >>bold?
+ COLOR: red >>foreground
+ COLOR: white >>background
+ ]
-TUPLE: computer < paddle { speed initial: 10 } ;
+TUPLE: ball pos vel ;
-: computer-move-left ( computer -- ) dup speed>> move-left-by ;
+TUPLE: pong-gadget < gadget timer ball player computer game-over? ;
-: computer-move-right ( computer -- ) dup speed>> move-right-by ;
+: initial-state ( gadget -- gadget )
+ T{ ball { pos { 50 50 } } { vel { 3 4 } } } clone >>ball
+ 200 >>player
+ 200 >>computer
+ f >>game-over? ;
-TUPLE: ball < vel
- { diameter initial: 20 }
- { bounciness initial: 1.2 }
- { max-speed initial: 10 } ;
+DEFER: on-tick
-: above-lower-bound? ( ball field -- ? ) bottom 50 - above? ;
+: <pong-gadget> ( -- gadget )
+ pong-gadget new initial-state
+ COLOR: white <solid> >>interior
+ dup '[ _ on-tick ] f 16 milliseconds <timer> >>timer ;
-: below-upper-bound? ( ball field -- ? ) top 50 + below? ;
+M: pong-gadget pref-dim* drop { 400 400 } ;
-: in-bounds? ( ball field -- ? )
- {
- [ above-lower-bound? ]
- [ below-upper-bound? ]
- } 2&& ;
+M: pong-gadget ungraft*
+ [ timer>> stop-timer ] [ call-next-method ] bi ;
-:: bounce-change-vertical-velocity ( BALL -- )
- BALL vel>> y neg
- BALL bounciness>> *
- BALL max-speed>> min
- BALL vel>> (y!) ;
+M:: pong-gadget draw-gadget* ( PONG -- )
+ COLOR: dark-gray gl-color
+ 15 390 20 <range> [
+ 197 2array { 10 6 } gl-fill-rect
+ ] each
+
+ COLOR: black gl-color
+ { 0 0 } { 10 400 } gl-fill-rect
+ { 390 0 } { 10 400 } gl-fill-rect
+
+ PONG computer>> 0 2array PADDLE-DIM gl-fill-rect
+ PONG player>> 390 2array PADDLE-DIM gl-fill-rect
+ PONG ball>> pos>> BALL-DIM gl-fill-rect
+
+ PONG game-over?>> [
+ FONT 48 >>size
+ PONG ball>> pos>> second 200 <
+ "YOU WIN!" "YOU LOSE!" ?
+ [ text-width 390 swap - 2 / 100 2array ]
+ [ '[ _ _ draw-text ] with-translation ] 2bi
+ ] [
+ PONG timer>> thread>> [
+ FONT 24 >>size
+ { "N - New Game" "SPACE - Pause" }
+ [ text-width 390 swap - 2 / 100 2array ]
+ [ '[ _ _ draw-text ] with-translation ] 2bi
+ ] unless
+ ] if ;
+
+:: move-player ( GADGET -- )
+ hand-loc get first PADDLE-SIZE 2 / -
+ 10 390 PADDLE-SIZE - clamp GADGET player<< ;
+
+:: move-ball ( GADGET -- )
+ GADGET ball>> :> BALL
+
+ ! minimum movement to hit wall or paddle
+ BALL vel>> first dup 0 > 380 10 ?
+ BALL pos>> first - swap / 1 min
+ BALL vel>> second dup 0 > 380 10 ?
+ BALL pos>> second - swap / 1 min min :> movement
+
+ movement 0 > [ movement throw ] unless
+ BALL pos>> BALL vel>> movement v*n v+ BALL pos<< ;
+
+: move-computer-by ( GADGET N -- )
+ '[ _ + 10 390 PADDLE-SIZE - clamp ] change-computer drop ;
+
+:: move-computer ( GADGET -- )
+ GADGET ball>> pos>> first :> X
+ GADGET computer>> PADDLE-SIZE 2/ + :> COMPUTER
+
+ ! ball on the left
+ X BALL-SIZE + COMPUTER - dup 0 < [
+ >integer -10 max 0 [a,b] random
+ GADGET swap move-computer-by
+ ] [ drop ] if
+
+ ! ball on the right
+ X COMPUTER - dup 0 > [
+ >integer 10 min [0,b] random
+ GADGET swap move-computer-by
+ ] [ drop ] if ;
:: 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 -- )
-
-M: paddle draw [ bottom-left ] [ dim>> ] bi draw-rectangle ;
+ BALL pos>> first BALL-SIZE 2 / +
+ PADDLE PADDLE-SIZE 2 / + - 1/4 *
+ BALL vel>> second neg BOUNCE * MAX-SPEED min 2array
+ BALL vel<< ;
+
+:: ?bounce-off-paddle ( BALL GADGET PADDLE -- )
+ BALL pos>> first dup BALL-SIZE +
+ PADDLE dup PADDLE-SIZE + '[ _ _ between? ] either? [
+ BALL PADDLE bounce-off-paddle
+ ] [
+ GADGET t >>game-over? timer>> stop-timer
+ ] if ;
+
+: bounce-off-wall ( BALL -- )
+ 0 swap vel>> [ neg ] change-nth ;
+
+:: on-tick ( GADGET -- )
+ GADGET move-player
+ GADGET move-ball
+ GADGET move-computer
-M: ball draw [ pos>> ] [ diameter>> 2 / ] bi draw-circle ;
-
-TUPLE: pong-gadget < gadget paused field ball player computer ;
-
-: pong ( -- gadget )
- pong-gadget 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-gadget pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
-
-M: pong-gadget ungraft* ( <pong> -- ) t >>paused drop ;
-
-M:: pong-gadget 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 pos>> first2 :> ( X Y )
+ BALL vel>> first2 :> ( DX DY )
- BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when
- BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
+ { [ DY 0 > ] [ Y 380 >= ] } 0&&
+ [ BALL GADGET PLAYER ?bounce-off-paddle ] when
- ! check if ball bounced off something
+ { [ DY 0 < ] [ Y 10 <= ] } 0&&
+ [ BALL GADGET COMPUTER ?bounce-off-paddle ] when
- ! player-blocked-ball?
- BALL PLAYER { [ above? ] [ in-between-horizontally? ] } 2&&
- [ BALL PLAYER bounce-off-paddle ] when
+ X { [ 10 <= ] [ 380 >= ] } 1||
+ [ BALL bounce-off-wall ] when
- ! computer-blocked-ball?
- BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } 2&&
- [ BALL COMPUTER bounce-off-paddle ] when
+ GADGET relayout-1 ;
- ! bounced-off-wall?
- BALL FIELD in-between-horizontally? not
- [ BALL reverse-horizontal-velocity ] when
+: com-new-game ( gadget -- )
+ initial-state timer>> start-timer ;
- ] [ t GADGET paused<< ] if ;
+: com-pause ( gadget -- )
+ dup game-over?>> [
+ dup timer>> dup thread>>
+ [ stop-timer ] [ restart-timer ] if
+ ] unless relayout-1 ;
-:: 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-gadget "gestures" f {
+ { T{ key-down { sym "n" } } com-new-game }
+ { T{ key-down { sym " " } } com-pause }
+} define-command-map
-MAIN-WINDOW: pong-window
- { { title "PONG" } }
- pong [ >>gadgets ] [ start-pong-thread ] bi ;
+MAIN-WINDOW: pong-window {
+ { title "PONG" }
+ { window-controls
+ { normal-title-bar close-button minimize-button } }
+ } <pong-gadget> >>gadgets ;
projects / factor.git / commitdiff