extra/pong/pong.factor

   1 USING: accessors arrays calendar colors.constants
   2 combinators.short-circuit fonts fry kernel literals locals math
   3 math.order math.ranges math.vectors namespaces opengl random
   4 sequences timers ui ui.commands ui.gadgets ui.gadgets.worlds
   5 ui.gestures ui.pens.solid ui.render ui.text ;
   6
   7 IN: pong
   8
   9 CONSTANT: BOUNCE 6/5
  10 CONSTANT: MAX-SPEED 6
  11 CONSTANT: BALL-SIZE 10
  12 CONSTANT: BALL-DIM ${ BALL-SIZE BALL-SIZE }
  13 CONSTANT: PADDLE-SIZE 80
  14 CONSTANT: PADDLE-DIM ${ PADDLE-SIZE 10 }
  15 CONSTANT: FONT $[
  16     monospace-font
  17         t >>bold?
  18         COLOR: red >>foreground
  19         COLOR: gray95 >>background
  20     ]
  21
  22 TUPLE: ball pos vel ;
  23
  24 TUPLE: pong-gadget < gadget timer ball player computer game-over? ;
  25
  26 : initial-state ( gadget -- gadget )
  27     T{ ball { pos { 50 50 } } { vel { 3 4 } } } clone >>ball
  28     200 >>player
  29     200 >>computer
  30     f >>game-over? ;
  31
  32 DEFER: on-tick
  33
  34 : <pong-gadget> ( -- gadget )
  35     pong-gadget new initial-state
  36         COLOR: gray95 <solid> >>interior
  37         dup '[ _ on-tick ] f 16 milliseconds <timer> >>timer ;
  38
  39 M: pong-gadget pref-dim* drop { 400 400 } ;
  40
  41 M: pong-gadget ungraft*
  42     [ timer>> stop-timer ] [ call-next-method ] bi ;
  43
  44 M:: pong-gadget draw-gadget* ( PONG -- )
  45     COLOR: gray80 gl-color
  46     15 390 20 <range> [
  47         197 2array { 10 6 } gl-fill-rect
  48     ] each
  49
  50     COLOR: black gl-color
  51     { 0 0 } { 10 400 } gl-fill-rect
  52     { 390 0 } { 10 400 } gl-fill-rect
  53
  54     PONG computer>> 0 2array PADDLE-DIM gl-fill-rect
  55     PONG player>> 390 2array PADDLE-DIM gl-fill-rect
  56     PONG ball>> pos>> BALL-DIM gl-fill-rect
  57
  58     PONG game-over?>> [
  59         FONT 48 >>size
  60         PONG ball>> pos>> second 200 <
  61         "YOU WIN!" "YOU LOSE!" ?
  62         [ text-width 390 swap - 2 / 100 2array ]
  63         [ '[ _ _ draw-text ] with-translation ] 2bi
  64     ] [
  65         PONG timer>> thread>> [
  66             FONT 24 >>size
  67             { "    N - New Game" "SPACE - Pause" }
  68             [ text-width 390 swap - 2 / 100 2array ]
  69             [ '[ _ _ draw-text ] with-translation ] 2bi
  70         ] unless
  71     ] if ;
  72
  73 :: move-player ( GADGET -- )
  74     hand-loc get first PADDLE-SIZE 2 / -
  75     10 390 PADDLE-SIZE - clamp GADGET player<< ;
  76
  77 :: move-ball ( GADGET -- )
  78     GADGET ball>> :> BALL
  79
  80     ! minimum movement to hit wall or paddle
  81     BALL vel>> first dup 0 > 380 10 ?
  82     BALL pos>> first - swap / 1 min
  83     BALL vel>> second dup 0 > 380 10 ?
  84     BALL pos>> second - swap / 1 min min :> movement
  85
  86     movement 0 > [ movement throw ] unless
  87     BALL pos>> BALL vel>> movement v*n v+ BALL pos<< ;
  88
  89 : move-computer-by ( GADGET N -- )
  90     '[ _ + 10 390 PADDLE-SIZE - clamp ] change-computer drop ;
  91
  92 :: move-computer ( GADGET -- )
  93     GADGET ball>> pos>> first :> X
  94     GADGET computer>> PADDLE-SIZE 2/ + :> COMPUTER
  95
  96     ! ball on the left
  97     X BALL-SIZE + COMPUTER - dup 0 < [
  98         >integer -10 max 0 [a..b] random
  99         GADGET swap move-computer-by
 100     ] [ drop ] if
 101
 102     ! ball on the right
 103     X COMPUTER - dup 0 > [
 104         >integer 10 min [0..b] random
 105         GADGET swap move-computer-by
 106     ] [ drop ] if ;
 107
 108 :: bounce-off-paddle ( BALL PADDLE -- )
 109     BALL pos>> first BALL-SIZE 2 / +
 110     PADDLE PADDLE-SIZE 2 / + - 1/4 *
 111     BALL vel>> second neg BOUNCE * MAX-SPEED min 2array
 112     BALL vel<< ;
 113
 114 :: ?bounce-off-paddle ( BALL GADGET PADDLE -- )
 115     BALL pos>> first dup BALL-SIZE +
 116     PADDLE dup PADDLE-SIZE + '[ _ _ between? ] either? [
 117         BALL PADDLE bounce-off-paddle
 118     ] [
 119         GADGET t >>game-over? timer>> stop-timer
 120     ] if ;
 121
 122 : bounce-off-wall ( BALL -- )
 123     0 swap vel>> [ neg ] change-nth ;
 124
 125 :: on-tick ( GADGET -- )
 126     GADGET move-player
 127     GADGET move-ball
 128     GADGET move-computer
 129
 130     GADGET ball>>     :> BALL
 131     GADGET player>>   :> PLAYER
 132     GADGET computer>> :> COMPUTER
 133
 134     BALL pos>> first2 :> ( X Y )
 135     BALL vel>> first2 :> ( DX DY )
 136
 137     { [ DY 0 > ] [ Y 380 >= ] } 0&&
 138     [ BALL GADGET PLAYER ?bounce-off-paddle ] when
 139
 140     { [ DY 0 < ] [ Y 10 <= ] } 0&&
 141     [ BALL GADGET COMPUTER ?bounce-off-paddle ] when
 142
 143     X { [ 10 <= ] [ 380 >= ] } 1||
 144     [ BALL bounce-off-wall ] when
 145
 146     GADGET relayout-1 ;
 147
 148 : com-new-game ( gadget -- )
 149     initial-state timer>> start-timer ;
 150
 151 : com-pause ( gadget -- )
 152     dup game-over?>> [
 153         dup timer>> dup thread>>
 154         [ stop-timer ] [ restart-timer ] if
 155     ] unless relayout-1 ;
 156
 157 pong-gadget "gestures" f {
 158     { T{ key-down { sym "n" } } com-new-game }
 159     { T{ key-down { sym " " } } com-pause }
 160 } define-command-map
 161
 162 MAIN-WINDOW: pong-window {
 163     { title "PONG" }
 164     { window-controls
 165         { normal-title-bar close-button minimize-button } }
 166     } <pong-gadget> >>gadgets ;