unmaintained/pong/pong.factor

   1
   2 USING: 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
  16 IN: 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
  32 TUPLE: <play-field> < <rectangle>    ;
  33 TUPLE: <paddle>     < <rectangle>    ;
  34
  35 TUPLE: <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
  42 TUPLE: <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
  95 GENERIC: draw ( obj -- )
  96
  97 METHOD: draw ( <paddle> -- ) [ bottom-left ] [ dim>>          ] bi rectangle ;
  98 METHOD: draw ( <ball>   -- ) [ pos>>       ] [ diameter>> 2 / ] bi circle    ;
  99
 100 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 101
 102 USE: syntax ! Switch back to core 'TUPLE:' instead of the one provided
 103             ! by multi-methods
 104
 105 TUPLE: <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
 114 M: <pong> pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
 115 M: <pong> ungraft*  ( <pong> --     ) t >>paused drop  ;
 116
 117 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 118
 119 M:: <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
 194 MAIN: pong-window