extra/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 : 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   } && ;
  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 USE: syntax ! Switch back to core 'TUPLE:' instead of the one provided
  96             ! by multi-methods
  97
  98 TUPLE: <pong> < gadget draw closed ;
  99
 100 M: <pong> pref-dim*    ( <pong> -- dim ) drop { 400 400 } ;
 101 M: <pong> draw-gadget* ( <pong> --     ) draw>> call      ;
 102 M: <pong> ungraft*     ( <pong> --     ) t >>closed drop  ;
 103
 104 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 105
 106 : make-draw-closure ( -- closure )
 107
 108   ! Establish some bindings
 109
 110   [let | PLAY-FIELD [ T{ <play-field> { pos {  0  0 } } { dim { 400 400 } } } ]
 111          BALL       [ T{ <ball>       { pos { 50 50 } } { vel {   3   4 } } } ]
 112
 113          PLAYER   [ T{ <paddle>   { pos { 200 396 } } { dim { 75 4 } } } ]
 114          COMPUTER [ T{ <computer> { pos { 200   0 } } { dim { 75 4 } } } ] |
 115
 116     ! Define some internal words in terms of those bindings ...
 117
 118     [wlet | align-player-with-mouse [ ( -- )
 119               PLAYER PLAY-FIELD align-paddle-with-mouse ]
 120
 121             move-ball [ ( -- ) BALL 1 move-for ]
 122
 123             player-blocked-ball? [ ( -- ? )
 124               BALL PLAYER { [ above? ] [ in-between-horizontally? ] } && ]
 125
 126             computer-blocked-ball? [ ( -- ? )
 127               BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } && ]
 128
 129             bounce-off-wall? [ ( -- ? )
 130               BALL PLAY-FIELD in-between-horizontally? not ] |
 131
 132       ! Note, we're returning a quotation.
 133       ! The quotation closes over the bindings established by the 'let'.
 134       ! Thus the name of the word 'make-draw-closure'.
 135       ! This closure is intended to be placed in the 'draw' slot of a
 136       ! <pong> gadget.
 137
 138       [
 139
 140         BALL PLAY-FIELD in-bounds?
 141           [
 142             align-player-with-mouse
 143
 144             move-ball
 145
 146             ! computer reaction
 147
 148             BALL COMPUTER to-the-left-of?  [ COMPUTER computer-move-left  ] when
 149             BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
 150
 151             ! check if ball bounced off something
 152
 153             player-blocked-ball?   [ BALL PLAYER   bounce-off-paddle  ] when
 154             computer-blocked-ball? [ BALL COMPUTER bounce-off-paddle  ] when
 155             bounce-off-wall?       [ BALL reverse-horizontal-velocity ] when
 156
 157             ! draw the objects
 158
 159             COMPUTER draw
 160             PLAYER   draw
 161             BALL     draw
 162
 163           ]
 164         when
 165
 166       ] ] ] ( -- closure ) ; ! The trailing stack effect here is a workaround.
 167                              ! The stack effects in the wlet expression throw
 168                              ! off the effect for the whole word, so we reset
 169                              ! it to the correct one here.
 170
 171 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 172
 173 :: pong-loop-step ( PONG -- ? )
 174   PONG closed>>
 175     [ f ]
 176     [ PONG relayout-1 25 milliseconds sleep t ]
 177   if ;
 178
 179 :: start-pong-thread ( PONG -- ) [ [ PONG pong-loop-step ] loop ] in-thread ;
 180
 181 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 182
 183 : play-pong ( -- )
 184
 185   <pong> new-gadget
 186     make-draw-closure >>draw
 187   dup "PONG" open-window
 188
 189   start-pong-thread ;
 190
 191 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 192
 193 : play-pong-main ( -- ) [ play-pong ] with-ui ;
 194
 195 MAIN: play-pong-main