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 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  12 !
  13 ! Inspired by this Ruby/Shoes version by why: http://gist.github.com/26431
  14 !
  15 ! Which was based on this Nodebox version: http://billmill.org/pong.html
  16 ! by Bill Mill.
  17 !
  18 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  19
  20 : clamp-to-interval ( x interval -- x )
  21   [ from>> first max ] [ to>> first min ] bi ;
  22
  23 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  24
  25 TUPLE: <play-field> < <rectangle>    ;
  26 TUPLE: <paddle>     < <rectangle>    ;
  27
  28 TUPLE: <computer>   < <paddle> { speed initial: 10 } ;
  29
  30 : computer-move-left  ( computer -- ) dup speed>> move-left-by  ;
  31 : computer-move-right ( computer -- ) dup speed>> move-right-by ;
  32
  33 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  34
  35 TUPLE: <ball> < <vel>
  36   { diameter   initial: 20   }
  37   { bounciness initial:  1.2 }
  38   { max-speed  initial: 10   } ;
  39
  40 : above-lower-bound? ( ball field -- ? ) bottom 50 - above? ;
  41 : below-upper-bound? ( ball field -- ? ) top    50 + below? ;
  42
  43 : in-bounds? ( ball field -- ? )
  44   {
  45     [ above-lower-bound? ]
  46     [ below-upper-bound? ]
  47   } 2&& ;
  48
  49 :: bounce-change-vertical-velocity ( BALL -- )
  50
  51   BALL vel>> y neg
  52   BALL bounciness>> *
  53
  54   BALL max-speed>> min
  55
  56   BALL vel>> (y!) ;
  57
  58 :: bounce-off-paddle ( BALL PADDLE -- )
  59
  60    BALL bounce-change-vertical-velocity
  61
  62    BALL x   PADDLE center x   -   0.25 *   BALL vel>> (x!)
  63
  64    PADDLE top   BALL pos>> (y!) ;
  65
  66 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  67
  68 : mouse-x ( -- x ) hand-loc get first ;
  69
  70 :: valid-paddle-interval ( PADDLE PLAY-FIELD -- interval )
  71
  72    PLAY-FIELD [ left ] [ right ] bi PADDLE width - [a,b] ;
  73
  74 :: align-paddle-with-mouse ( PADDLE PLAY-FIELD -- )
  75
  76    mouse-x
  77
  78    PADDLE PLAY-FIELD valid-paddle-interval
  79
  80    clamp-to-interval
  81
  82    PADDLE pos>> (x!) ;
  83
  84 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  85
  86 ! Protocol for drawing PONG objects
  87
  88 GENERIC: draw ( obj -- )
  89
  90 METHOD: draw { <paddle> } [ bottom-left ] [ dim>>          ] bi rectangle ;
  91 METHOD: draw { <ball>   } [ pos>>       ] [ diameter>> 2 / ] bi circle    ;
  92
  93 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  94
  95 TUPLE: <pong> < gadget paused field ball player computer ;
  96
  97 : pong ( -- gadget )
  98   <pong> new
  99   T{ <play-field> { pos {   0   0 } } { dim { 400 400 } } } clone >>field
 100   T{ <ball>       { pos {  50  50 } } { vel {   3   4 } } } clone >>ball
 101   T{ <paddle>     { pos { 200 396 } } { dim {  75   4 } } } clone >>player
 102   T{ <computer>   { pos { 200   0 } } { dim {  75   4 } } } clone >>computer ;
 103
 104 M: <pong> pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
 105 M: <pong> ungraft*  ( <pong> --     ) t >>paused drop  ;
 106
 107 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 108
 109 M:: <pong> draw-gadget* ( PONG -- )
 110
 111   PONG computer>> draw
 112   PONG player>>   draw
 113   PONG ball>>     draw ;
 114
 115 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 116
 117 :: iterate-system ( GADGET -- )
 118
 119     GADGET field>>    :> FIELD
 120     GADGET ball>>     :> BALL
 121     GADGET player>>   :> PLAYER
 122     GADGET computer>> :> COMPUTER
 123
 124     BALL FIELD in-bounds? [
 125
 126         PLAYER FIELD align-paddle-with-mouse
 127
 128         BALL 1 move-for
 129
 130         ! computer reaction
 131
 132         BALL COMPUTER to-the-left-of?  [ COMPUTER computer-move-left  ] when
 133         BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
 134
 135         ! check if ball bounced off something
 136
 137         ! player-blocked-ball?
 138         BALL PLAYER { [ above? ] [ in-between-horizontally? ] } 2&&
 139         [ BALL PLAYER   bounce-off-paddle  ] when
 140
 141         ! computer-blocked-ball?
 142         BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } 2&&
 143         [ BALL COMPUTER bounce-off-paddle  ] when
 144
 145         ! bounced-off-wall?
 146         BALL FIELD in-between-horizontally? not
 147         [ BALL reverse-horizontal-velocity ] when
 148
 149     ] [ t GADGET paused<< ] if ;
 150
 151 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 152
 153 :: start-pong-thread ( GADGET -- )
 154   f GADGET paused<<
 155   [
 156     [
 157       GADGET paused>>
 158       [ f ]
 159       [ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
 160       if
 161     ]
 162     loop
 163   ]
 164   in-thread ;
 165
 166 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 167
 168 : pong-window ( -- ) pong [ "PONG" open-window ] [ start-pong-thread ] bi ;
 169
 170 : pong-main ( -- ) [ pong-window ] with-ui ;
 171
 172 MAIN: pong-window