Mario.hs

-- This is an translation of http://elm-lang.org/edit/examples/Intermediate/Mario.elm
-- to Haskell using Helm game engine

-- This is WIP

import Prelude hiding (Either(..))
import FRP.Elerea.Simple
import FRP.Helm
import FRP.Helm.Time
import qualified FRP.Helm.Window as Window
import qualified FRP.Helm.Keyboard as Keyboard

data Direction = Left | Right

data Mario =
  Mario { mX :: Double, mY :: Double,
          vX :: Double, vY :: Double,
          dir :: Direction }

jump :: (Int, Int) -> Mario -> Mario
jump (_, y) m@(Mario mX1 mY1 vX1 vY1 dir1)
  | y < 0 && mY1 == 0 = Mario { mX = mX1, mY = mY1, vX = vX1, vY = 5, dir = dir1 }
  | otherwise = m 

gravity :: Time -> Mario -> Mario
gravity t m@(Mario mX1 mY1 vX1 vY1 dir1)
  | mY1 < 0 = Mario { mX = mX1, mY = mY1, vX = vX1, vY = vY1 - (t/4), dir = dir1 }
  | otherwise = m 

physics :: Time -> Mario -> Mario
physics t (Mario mX1 mY1 vX1 vY1 dir1)
  = Mario { mX = mX1 + (t*vX1), mY = min 0 (mY1 - (t*vY1)), vX = vX1, vY = vY1, dir = dir1 }

walk :: (Int, Int) -> Mario -> Mario
walk (x, _) (Mario mX1 mY1 vX1 vY1 dir1) =
  Mario { mX = mX1, mY = mY1, vX = fromIntegral x, vY = vY1, dir = whatDir x } 
  where
    whatDir x
      | x < 0 = Left
      | x > 0 = Right
      | otherwise = dir1

step :: (Time, (Int, Int)) -> Mario -> Mario
step (t, arrows) = physics t . walk arrows . gravity t . jump arrows

render :: (Int, Int) -> Mario -> Element
render (w, h) (Mario mX1 mY1 vX1 vY1 dir1) =
  collage w h [move (half w, half h) $ filled blue $ rect (fromIntegral w) (fromIntegral h), 
               move (half w, fromIntegral h - half 50) $ filled green $ rect (fromIntegral w) 50, 
               move (mX1, mY1 + fromIntegral h - 62) $ filled red $ rect 24 28] 
  where
    half n = fromIntegral $ n `div` 2

input :: SignalGen (Signal (Time, (Int, Int)))
input = lift2 (,) delta Keyboard.arrows

main :: IO ()
main = run defaultConfig $ lift2 render Window.dimensions $ foldp step mario input
  where
    mario = Mario { mX = 400, mY = 0,
                    vX = 0, vY = 0,
                    dir = Right }