/unmaintained/pong/pong.factor

http://github.com/abeaumont/factor · Factor · 194 lines · 109 code · 64 blank · 21 comment · 17 complexity · bb1c92b230fdf8e2a210bca88fa3e658 MD5 · raw file

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