shine-examples-0.1: mountaincar/Main.hs

import qualified Game as G
import qualified MountainCar as MC
import qualified Point as P

import qualified Graphics.Shine as S
import qualified Graphics.Shine.Input as S
import qualified Graphics.Shine.Picture as S
import qualified Web.KeyCode as W

import System.Random (newStdGen, randoms)
import GHCJS.DOM (currentDocumentUnchecked)

gameWidth :: Double
gameWidth = 800

gameHeight :: Double
gameHeight = 600

fps :: Double
fps = 30

minSpaceX :: Double
minSpaceX = MC.minPosition - 0.1

maxSpaceX :: Double
maxSpaceX = MC.maxPosition + 0.1

minSpaceY :: Double
minSpaceY = 0

maxSpaceY :: Double
maxSpaceY = 1.1

goalSpaceX :: Double
goalSpaceX = 0.5

goalSpaceY :: Double
goalSpaceY = MC.heightObs goalSpaceX

displayH :: G.Game -> S.Picture
displayH g = goalP <> carP <> episodeP <> nwinsP <> stepP <> actionP <> groundP
    where carP = mkCarP $ G._observation g
          episodeP = S.Translate 10 30 $ S.Text "20px Sans" S.LeftAlign Nothing $ "episode " ++ show (G._episode g)
          nwinsP = S.Translate 10 60 $ S.Text "20px Sans" S.LeftAlign Nothing $ "nwins " ++ show (G._nwins g)
          stepP = S.Translate 10 90 $ S.Text "20px Sans" S.LeftAlign Nothing $ "step " ++ show (G._step g) ++ " / " ++ show G.maxStep
          actionP = S.Translate 10 120 $ S.Text "20px Sans" S.LeftAlign Nothing $ "action " ++ show (G._lastAction g)

mkCarP :: MC.Observation -> S.Picture
mkCarP obs = S.Translate x y $ S.Colored (S.Color 0 0 255 1) $ S.CircleF 10
    where pos = MC._position obs
          (x,y) = spaceToScreen (pos, MC.heightObs pos)

goalP :: S.Picture
goalP = S.Translate x y $ S.Colored (S.Color 255 0 0 1) $ S.RectF 10 20
    where (x,y) = spaceToScreen (goalSpaceX, goalSpaceY)

groundP :: S.Picture
groundP = foldl (<>) S.Empty [S.Line x0 y0 x1 y1 | ((x0,y0), (x1,y1)) <- zip xys (tail xys)]
    where xys = [spaceToScreen (x, MC.heightObs x) 
                    | x<-[MC.minPosition, MC.minPosition+0.05 .. MC.maxPosition]]

spaceToScreen :: P.Point -> P.Point
spaceToScreen (x, y) = (xScreen, yScreen)
    where xScreen = gameWidth * (x - minSpaceX) / (maxSpaceX - minSpaceX)
          yScreen = gameHeight * (1 - (y - minSpaceY) / (maxSpaceY - minSpaceY))

eventH :: S.Input -> G.Game -> G.Game 
eventH (S.Keyboard W.ArrowLeft S.Down _)  g = g { G._inputLeft = True }
eventH (S.Keyboard W.ArrowLeft S.Up _)    g = g { G._inputLeft = False }
eventH (S.Keyboard W.ArrowRight S.Down _) g = g { G._inputRight = True }
eventH (S.Keyboard W.ArrowRight S.Up _)   g = g { G._inputRight = False }
eventH _ g = g

idleH :: Double -> G.Game -> G.Game
idleH _ = G.step
-- The mountain car problem is generally defined using a fixed time step,
-- so we ignore the time delta and just compute the next step.

main :: IO ()
main = do
    myRands <- randoms <$> newStdGen
    doc <- currentDocumentUnchecked
    ctx <- S.fixedSizeCanvas doc (floor gameWidth) (floor gameHeight)
    let myModel = G.createGame myRands
    S.play ctx doc fps myModel displayH eventH idleH