/unmaintained/pong/pong.factor

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