Paste: PONG: extreme factoring with internal words

USING: accessors kernel locals math math.order namespaces
       processing.shapes sequences threads ui ui.gadgets ui.gestures
       ui.render ;

IN: pong-internal

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

: mouse-x ( -- x ) hand-loc get first ;

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

TUPLE: <pong> < gadget draw closed ;

M: <pong> pref-dim*    ( <pong> -- dim ) drop { 400 400 } ;
M: <pong> draw-gadget* ( <pong> --     ) draw>> call ;
M: <pong> ungraft*     ( <pong> --     ) t >>closed drop ;

! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

: play-pong ( -- )

  [let | PONG [ <pong> new-gadget ] |

    PONG

    [let | WIDTH         [ 400   ]
           HEIGHT        [ 400   ]
           BALL-DIAMETER [  20   ]
           PADDLE-SIZE   [  75   ]
           VX!           [   3   ] ! BALL VELOCITY
           VY!           [   4   ]
           PX!           [  50   ] ! BALL POSITION
           PY!           [  50   ]
           BOUNCE        [   1.2 ]
           COMPUTER!     [ 200   ]
           COMPSPEED!    [  10   ]
           PLAYER!       [   f   ]
           MAX-VELOCITY  [  10   ] |

      [wlet | ball-to-left?  [ ( x -- ? ) PX > ]
              ball-to-right? [ ( x -- ? ) PX < ]
              ball-below?    [ ( y -- ? ) PY > ]
              ball-above?    [ ( y -- ? ) PY < ]

              ball-moving-up?   [ ( -- ? ) VY 0 > ]
              ball-moving-down? [ ( -- ? ) VY 0 < ]

              reverse-vertical-velocity   [ ( -- )   VY neg BOUNCE * MAX-VELOCITY min VY!   ]
              adjust-horizontal-velocity  [ ( x -- ) PADDLE-SIZE 2 / + PX swap - 0.25 * VX! ] |

        [wlet | ball-in-bounds? [ ( -- ? ) -50 ball-above?   HEIGHT 50 + ball-below?   and ]

                align-paddle-with-mouse [ ( -- ) mouse-x 0 max  WIDTH PADDLE-SIZE -  min  PLAYER! ]

                move-ball [ ( -- ) PX VX + PX!    PY VY + PY! ]

                computer-reaction [ ( -- )
                                    COMPUTER PADDLE-SIZE + ball-to-right? [ COMPUTER COMPSPEED + COMPUTER! ] when
                                    COMPUTER               ball-to-left?  [ COMPUTER COMPSPEED - COMPUTER! ] when ]

                player-blocked-ball? [ ( -- ? ) 
                                       HEIGHT               ball-above?
                                                            ball-moving-up?
                                       PLAYER               ball-to-right?
                                       PLAYER PADDLE-SIZE + ball-to-left?
                                       and and and ]

                computer-blocked-ball? [ ( -- ? )
                                         0                      ball-below?
                                                                ball-moving-down?
                                         COMPUTER               ball-to-right?
                                         COMPUTER PADDLE-SIZE + ball-to-left?
                                         and and and ]

                bounce-off-wall? [ ( -- ? ) 0 ball-to-left?   WIDTH ball-to-right?   or ]

                reverse-horizontal-velocity [ ( -- ) VX neg VX! ]

                draw-computer-paddle [ ( -- ) COMPUTER 0           PADDLE-SIZE 4 rectangle* ]
                draw-player-paddle   [ ( -- ) PLAYER   HEIGHT 4 -  PADDLE-SIZE 4 rectangle* ]
            
                draw-ball [ ( -- ) { PX PY } BALL-DIAMETER circle ]
                    

                bounce-off-paddle [ ( base-y paddle-x -- )
                                    reverse-vertical-velocity
                                    adjust-horizontal-velocity
                                    PY! ]                       |

          [wlet | bounce-off-player-paddle   [ HEIGHT PLAYER bounce-off-paddle ]
                  bounce-off-computer-paddle [ 0 COMPUTER bounce-off-paddle    ] |
          
          [
            ball-in-bounds?
              [
                align-paddle-with-mouse

                move-ball                
  
                computer-reaction
                
                player-blocked-ball?   [ bounce-off-player-paddle    ] when
                computer-blocked-ball? [ bounce-off-computer-paddle  ] when
                bounce-off-wall?       [ reverse-horizontal-velocity ] when
                
                draw-computer-paddle
                draw-player-paddle
                draw-ball
              ]
            when
          ] ] ] ] ]

    >>draw drop

    PONG "test" open-window

    [
      [
        PONG closed>>
          [ f ]
          [ PONG relayout-1 25 sleep t ]
        if
      ]
      loop
    ]
    in-thread

  ] ( -- ) ;