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