extra/pong/pong.factor

   1 USING: accessors alien.c-types alien.data arrays calendar colors
   2 combinators combinators.short-circuit flatland generalizations
   3 grouping kernel locals math math.intervals math.order
   4 math.rectangles math.vectors namespaces opengl opengl.gl
   5 opengl.glu processing.shapes sequences sequences.generalizations
   6 shuffle threads ui ui.gadgets ui.gestures ui.render ;
   7 FROM: multi-methods => GENERIC: METHOD: ;
   8 FROM: syntax => M: ;
   9 IN: pong
  10
  11 ! Inspired by this Ruby/Shoes version by why: http://gist.github.com/26431
  12 !
  13 ! Which was based on this Nodebox version: http://billmill.org/pong.html
  14 ! by Bill Mill.
  15
  16 : clamp-to-interval ( x interval -- x )
  17     [ from>> first max ] [ to>> first min ] bi ;
  18
  19 TUPLE: play-field < rectangle ;
  20
  21 TUPLE: paddle < rectangle ;
  22
  23 TUPLE: computer < paddle { speed initial: 10 } ;
  24
  25 : computer-move-left  ( computer -- ) dup speed>> move-left-by  ;
  26
  27 : computer-move-right ( computer -- ) dup speed>> move-right-by ;
  28
  29 TUPLE: ball < vel
  30     { diameter   initial: 20   }
  31     { bounciness initial:  1.2 }
  32     { max-speed  initial: 10   } ;
  33
  34 : above-lower-bound? ( ball field -- ? ) bottom 50 - above? ;
  35
  36 : below-upper-bound? ( ball field -- ? ) top    50 + below? ;
  37
  38 : in-bounds? ( ball field -- ? )
  39     {
  40         [ above-lower-bound? ]
  41         [ below-upper-bound? ]
  42     } 2&& ;
  43
  44 :: bounce-change-vertical-velocity ( BALL -- )
  45     BALL vel>> y neg
  46     BALL bounciness>> *
  47     BALL max-speed>> min
  48     BALL vel>> (y!) ;
  49
  50 :: bounce-off-paddle ( BALL PADDLE -- )
  51    BALL bounce-change-vertical-velocity
  52    BALL x   PADDLE center x   -   0.25 *   BALL vel>> (x!)
  53    PADDLE top   BALL pos>> (y!) ;
  54
  55 : mouse-x ( -- x ) hand-loc get first ;
  56
  57 :: valid-paddle-interval ( PADDLE PLAY-FIELD -- interval )
  58    PLAY-FIELD [ left ] [ right ] bi PADDLE width - [a,b] ;
  59
  60 :: align-paddle-with-mouse ( PADDLE PLAY-FIELD -- )
  61    mouse-x
  62    PADDLE PLAY-FIELD valid-paddle-interval
  63    clamp-to-interval
  64    PADDLE pos>> (x!) ;
  65
  66 ! Protocol for drawing PONG objects
  67
  68 GENERIC: draw ( obj -- )
  69
  70 METHOD: draw { paddle } [ bottom-left ] [ dim>> ] bi draw-rectangle ;
  71
  72 METHOD: draw { ball } [ pos>> ] [ diameter>> 2 / ] bi draw-circle ;
  73
  74 TUPLE: pong-gadget < gadget paused field ball player computer ;
  75
  76 : pong ( -- gadget )
  77     pong-gadget new
  78         T{ play-field { pos {   0   0 } } { dim { 400 400 } } } clone >>field
  79         T{ ball       { pos {  50  50 } } { vel {   3   4 } } } clone >>ball
  80         T{ paddle     { pos { 200 396 } } { dim {  75   4 } } } clone >>player
  81         T{ computer   { pos { 200   0 } } { dim {  75   4 } } } clone >>computer ;
  82
  83 M: pong-gadget pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
  84
  85 M: pong-gadget ungraft*  ( <pong> --     ) t >>paused drop  ;
  86
  87 M:: pong-gadget draw-gadget* ( PONG -- )
  88     PONG computer>> draw
  89     PONG player>>   draw
  90     PONG ball>>     draw ;
  91
  92 :: iterate-system ( GADGET -- )
  93     GADGET field>>    :> FIELD
  94     GADGET ball>>     :> BALL
  95     GADGET player>>   :> PLAYER
  96     GADGET computer>> :> COMPUTER
  97
  98     BALL FIELD in-bounds? [
  99
 100         PLAYER FIELD align-paddle-with-mouse
 101
 102         BALL 1 move-for
 103
 104         ! computer reaction
 105
 106         BALL COMPUTER to-the-left-of?  [ COMPUTER computer-move-left  ] when
 107         BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
 108
 109         ! check if ball bounced off something
 110
 111         ! player-blocked-ball?
 112         BALL PLAYER { [ above? ] [ in-between-horizontally? ] } 2&&
 113         [ BALL PLAYER   bounce-off-paddle  ] when
 114
 115         ! computer-blocked-ball?
 116         BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } 2&&
 117         [ BALL COMPUTER bounce-off-paddle  ] when
 118
 119         ! bounced-off-wall?
 120         BALL FIELD in-between-horizontally? not
 121         [ BALL reverse-horizontal-velocity ] when
 122
 123     ] [ t GADGET paused<< ] if ;
 124
 125 :: start-pong-thread ( GADGET -- )
 126     f GADGET paused<< [
 127         [
 128             GADGET paused>>
 129             [ f ]
 130             [ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
 131             if
 132         ] loop
 133     ] in-thread ;
 134
 135 MAIN-WINDOW: pong-window
 136     { { title "PONG" } }
 137     pong [ >>gadgets ] [ start-pong-thread ] bi ;