wxFruit-0.1.2: paddle.hs

-----------------------------------------------------------
-- PaddleBall in wxFruit.
--   Adapted from paddleball sample in the original Fruit.
--   Adds a slider controlling the velocity of the ball
--   and a restart button.
-----------------------------------------------------------

{-# LANGUAGE Arrows #-}

module Main where

import WXFruit
import FRP.Yampa hiding (left, right, next)
import Control.Arrow hiding (left, right)
import qualified Graphics.UI.WX as WX

-- Elements of the game.

bg :: WXPicture
bg = wxWithColor WX.white wxfill

walls :: WXPicture
walls = let upper = wxPicFill (wxrect (WX.rect (WX.point 10 10)  (WX.sz 200 10)))
            left  = wxPicFill (wxrect (WX.rect (WX.point 10 10)  (WX.sz 10 200)))
            right = wxPicFill (wxrect (WX.rect (WX.point 200 10) (WX.sz 10 200)))
        in wxWithColor WX.red (upper `wxPicOver` left `wxPicOver` right)

paddle :: Int -> WX.Rect
paddle xpos = WX.rect (WX.Point (xpos - 25) 200) (WX.sz 50 10)

gameBox :: (Num t) => WX.Size2D t
gameBox = WX.sz 215 215

-- The game screen: takes signals for the velocity of the
-- ball and the current mouse position; outputs a picture
-- of the game and a game-over event.
pball :: SF (Double,WX.Point) (WXPicture,Event ())
pball = proc (vel,mpos) -> do
  rec xi <- integral -< xvel
      yi <- integral -< yvel
      let xpos = 30 + xi
      let ypos = 30 + yi
      let ballS = WX.rect (WX.point (round (xpos - 12.5)) (round (ypos - 12.5)))
                          (WX.sz 25 25)
      let ballPicS = wxWithColor WX.yellow $ wxPicFill $ wxellipse ballS
      xbounce <- edge -< ((xpos > 175) || (xpos < 45))
      ybounce <- edge -< ((ypos < 45) || hitPaddle)
      let hitPaddle = WX.rectOverlaps ballS paddleS
      xdir <- accumHold 1 -< xbounce `tag` negate
      ydir <- accumHold 1 -< ybounce `tag` negate
      let xvel = xdir * vel
      let yvel = ydir * vel
      let paddleS = paddle (WX.pointX mpos)
      let paddlePicS = wxWithColor WX.green $ wxPicFill $ wxrect paddleS
      gameOver <- edge -< ypos > 250
      let gamePic = walls `wxPicOver` paddlePicS `wxPicOver` ballPicS `wxPicOver` bg
  returnA -< (gamePic,gameOver)

-- The game-over screen.
death :: SF a (WXPicture,Event b)
death = proc _ -> do
  returnA -< (deathPic,noEvent)
    where deathPic = wxwrite "Game Over!" (WX.Point 70 100)

-- The game GUI: wrapper around the game-on and
-- and game-over screens.
pbgame :: WXGUI (Double,Event ()) (Event ())
pbgame = wxHBox $ proc (vel,restart) -> do
  rec let next = (gameOver `tag` death) `merge` (restart `tag` pball)
      mpos <- wxmouse -< ()
      (gamePic,gameOver) <- wxBoxSF (drSwitch pball) -< ((vel,mpos),next)
  _ <- wxpicture (psize gameBox) -< ppic gamePic
  returnA -< gameOver

-- The game-control GUI: widgets for controlling
-- the speed of the ball and restarting the game.
pbcontrol :: WXGUI (Event ()) (Double,Event ())
pbcontrol = wxVBox $ proc gameOver -> do
  rec _ <- wxtext id -< (ttext ("Speed: " ++ (show vel))) 
      v <- wxslider Vert 5 15 (sselection 10) -< id
      let vel = v * 10
      stopped <- wxBoxSF (hold False)
        -< (playAgain `tag` False) `merge` (gameOver `tag` True)
      playAgain <- wxbutton (btext "Play Again") -< benabled stopped
  returnA -< (fromIntegral vel,playAgain)

-- The top-level GUI: puts it all together.
paddleBall :: WXGUI () ()
paddleBall = wxHBox $ proc _ -> do
  rec gameOver <- wxBox pbgame -< (vel,playAgain)
      (vel,playAgain) <- wxBox pbcontrol -< gameOver
  returnA -< ()

main :: IO ()
main = startGUI "PaddleBall" paddleBall