Mario.hs

{-# LANGUAGE MultiWayIf        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
module Main where

import           Control.Applicative          ((<|>))
import           Control.Monad                (forever, void)
import           Control.Monad.IO.Class       (liftIO)
import           Control.Monad.State          (StateT, execStateT, get, lift,
                                               modify)

import qualified Data.JSString                as JSS
import           Data.Time.Clock

import qualified GHCJS.VDOM.Attribute         as A
import qualified GHCJS.VDOM.Element           as E

import           Concur.Core                  (Widget)
import           Concur.VDOM                  (HTML, el, initConcur,
                                               interval, keyboardNotifications,
                                               runWidgetInBody)

import           Concur.Subscription.Keyboard (Arrows (Arrows, arrowX, arrowY),
                                               arrows)
import           Concur.Subscription.Window   (windowResize)

data Mario = Mario
  { x      :: !Double
  , y      :: !Double
  , vx     :: !Double
  , vy     :: !Double
  , time   :: !UTCTime
  , delta  :: !Double
  , arrow  :: !Arrows
  , dir    :: !Dir
  , window :: !(Int,Int)
  }
data Dir = L | R deriving (Show, Eq)
type MarioWidget = StateT Mario (Widget HTML) ()

initMario :: UTCTime -> Mario
initMario now = Mario 0 0 0 0 now 0 (Arrows 0 0) R (0,0)

main :: IO ()
main = do
  -- This needs to be called once at the very beginning
  initConcur
  -- Run widget
  void $ runWidgetInBody mario

mario :: Widget HTML ()
mario = do
  now <- liftIO getCurrentTime
  void $ flip execStateT (initMario now) $ do
    -- Install an arrow key handler
    arrowKeys <- liftIO arrows
    -- Install a ticker that fires every 50 ms
    every50ms <- liftIO $ interval 50
    -- Install a listener for window resize events
    windowResizes <- liftIO windowResize
    -- Forever - draw mario, handle user input, and update physics
    forever $     (get >>= lift . drawMario)
              <|> (lift every50ms >>= modify . step)
              <|> (lift arrowKeys >>= modify . handleArrows)
              <|> (lift windowResizes >>= modify . resizeWindow)

handleArrows :: Arrows -> Mario -> Mario
handleArrows arrows m = m { arrow = arrows }

step :: UTCTime -> Mario -> Mario
step newTime m@Mario{..} =
  physics delta
  . jump arrow
  . walk arrow
  . gravity delta
  . updateTime newTime
  $ m
  where
    updateTime :: UTCTime -> Mario -> Mario
    updateTime newTime m@Mario{..} =
      m { delta = realToFrac $ newTime `diffUTCTime` time
        , time = newTime
        }

    gravity :: Double -> Mario -> Mario
    gravity dt m@Mario{..} =
      m { vy = if y > 0 then vy - dt*500 else 0 }

    walk :: Arrows -> Mario -> Mario
    walk Arrows{..} m@Mario{..} =
      m { vx = fromIntegral arrowX * 50
        , dir = if | arrowX < 0 -> L
                   | arrowX > 0 -> R
                   | otherwise -> dir
        }

    jump :: Arrows -> Mario -> Mario
    jump Arrows{..} m@Mario{..} =
        if arrowY > 0 && vy == 0
         then m { vy = 200 }
         else m

    physics :: Double -> Mario -> Mario
    physics dt m@Mario{..} =
      m { x = x + dt * vx
        , y = max 0 (y + dt * vy)
        }

resizeWindow :: (Int, Int) -> Mario -> Mario
resizeWindow dims m = m { window = dims }

drawMario :: Mario -> Widget HTML ()
drawMario m@Mario{..} = el E.div [ A.height h, A.width w ]
  [ el E.img
    [ A.height 37, A.width 37, A.src src, A.style marioStyle ]
    []
  ]
  where
    (w,h) = window
    verb = if | y > 0 -> "jump"
              | vx /= 0 -> "walk"
              | otherwise -> "stand"
    d = case dir of
      L -> "left"
      R -> "right"
    src = JSS.pack $ "../imgs/" ++ verb ++ "/" ++ d ++ ".gif"
    gy = 62 - (fromIntegral w / 2)
    marioStyle = JSS.pack $ "display:block; transform: " ++ matrix x (abs (y + gy))
    matrix x y = "matrix(1,0,0,1," ++ show x ++ "," ++ show y ++ ")"