content: {-# 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 ++ ")"
  