Merge branch ghcjs into faeture-sage. Closes #38.

README.md

@@ -93,6 +93,16 @@ explanation.
    $ sudo apt-get install freenect
    ```
 
+## Compilation of GHCJS branch
+
+This game works on browsers (sound and kinect/wiimote are not supported).  To
+compile it with GHCJS, you need to have GHCJS installed and compile haskanoid
+with the following line:
+
+```
+$ cabal install --ghcjs -fghcjs -f-sdl -f-kinect -f-wiimote
+```
+
 # Documentation
 
 To try and make things as clear as possible, the code includes a much haddock

haskanoid.cabal

@@ -45,7 +45,7 @@ category:            Game, Reactivity, FRP
 build-type:          Simple
 
 -- Constraint on the version of Cabal needed to build this package.
-cabal-version:       >=1.8
+cabal-version:       >=1.10
 
 data-files: data/*.png data/*.wav data/*.mp3 data/*.ttf
 
@@ -57,6 +57,15 @@ Flag kinect
   Description: Enable Kinect support (with freenect)
   Default: True
 
+Flag sdl
+  Description: Enable SDL multimedia
+  Default: True
+
+Flag ghcjs
+  Description: Enable compilation using GHCJS and HTML5 Canvas
+  Default: False
+
+
 executable haskanoid
   -- .hs or .lhs file containing the Main module.
   main-is: Main.hs
@@ -88,22 +97,33 @@ executable haskanoid
                        mtl,
                        MissingH,
                        Yampa >= 0.9.6 && < 0.11,
-                       SDL, SDL-image, SDL-mixer, SDL-ttf,
                        IfElse,
                        sage-assetmanager,
-                       sage-backends-sdl1-audio,
-                       sage-backends-sdl1-clock,
                        sage-data-extra,
                        sage-data-identity-list,
                        sage-physics-2d-rectangles,
                        sage-yampa-extra
 
+  if flag(sdl)
+    cpp-options: -Dsdl
+    build-depends: SDL, SDL-image, SDL-mixer, SDL-ttf,
+                   sage-backends-sdl1-audio,
+                   sage-backends-sdl1-clock
+
+  if flag(ghcjs)
+    cpp-options: -Dghcjs
+    other-extensions: JavaScriptFFI, CPP, OverloadedStrings
+    other-modules: GHCJSNow JsImports
+    build-depends: ghcjs-dom, ghcjs-base, linear, semigroups, time
+
   if flag(wiimote)
     build-depends: hcwiid
 
   if flag(kinect)
     build-depends: freenect, vector
 
+  default-language: Haskell2010
+
 source-repository head
   type:     git
   location: git://github.com/ivanperez-keera/haskanoid.git

src/DisplayGHCJS.hs

@@ -0,0 +1,297 @@
+module DisplayGHCJS where
+
+import Control.Monad
+import Control.Monad.IfElse
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Maybe
+import Control.Monad.IO.Class
+import Data.IORef
+import Data.Maybe
+import Data.String (fromString)
+import           Data.Coerce
+import           GHCJS.Concurrent              ( synchronously )
+import           GHCJS.DOM                     ( currentDocument
+                                               , currentWindow )
+import           GHCJS.DOM.Document            ( getBody
+                                               , getElementById )
+import           GHCJS.DOM.Element             ( getOffsetLeft
+                                               , getOffsetTop
+                                               , getInnerHTML )
+import           GHCJS.DOM.Element             ( setInnerHTML )
+import           GHCJS.DOM.EventTarget         ( addEventListener )
+import           GHCJS.DOM.EventTargetClosures ( eventListenerNew )
+import           GHCJS.DOM.Types               ( Element(..), IsDocument
+                                               , MouseEvent, unElement )
+import           GHCJS.DOM.UIEvent             ( getPageX, getPageY )
+import           GHCJS.Foreign
+import           GHCJS.Types
+import qualified JavaScript.Web.Canvas         as C
+import qualified JavaScript.Web.Canvas.Internal as C
+import           JsImports                     (now)
+
+
+import           Control.Applicative
+import           Control.Concurrent
+import           Control.Concurrent.MVar
+import           Control.Monad                 hiding (sequence_)
+import           Data.Foldable                 (minimumBy)
+import           Data.Ord
+import           Data.Semigroup
+import           Linear
+
+
+import Constants
+import GameState
+import Objects
+import Resources hiding (audio)
+import Levels
+import Paths_haskanoid
+
+-- | Ad-hoc resource loading
+-- This function is ad-hoc in two senses: first, because it
+-- has the paths to the files hard-coded inside. And second,
+-- because it loads the specific resources that are needed,
+-- not a general 
+--
+loadResources :: IO (Maybe ResourceMgr)
+loadResources = runMaybeT $ do
+  ---- Font initialization
+  --ttfOk <- lift TTF.init
+  --
+  --gameFont <- liftIO $ getDataFileName "data/lacuna.ttf"
+  ---- Load the fonts we need
+  --font  <- liftIO $ TTF.tryOpenFont gameFont 32 -- What does the 32 do?
+  --let myFont = fmap (Font gameFont) font
+
+  --blockHit <- liftIO $ loadAudio =<< getDataFileName "data/196106_aiwha_ding-cc-by.wav"
+
+  ---- bgM <- liftIO $ loadMusic "Ckotty_-_Game_Loop_11.ogg"
+  ---- bgM <- liftIO $ loadMusic "data/level0.mp3"
+
+  ---- let levelBg = "data/level0.png"
+  ---- img <- lift $ fmap (Image levelBg) $ load levelBg
+
+  --ballImg <- liftIO $ getDataFileName "data/ball2.png"
+  --ball <- lift $ fmap (Image ballImg) $ load ballImg
+
+  --b1Img <- liftIO $ getDataFileName "data/block1.png"
+  --b1 <- lift $ fmap (Image b1Img) $ load b1Img
+
+  --b2Img <- liftIO $ getDataFileName "data/block2.png"
+  --b2 <- lift $ fmap (Image b2Img) $ load b2Img
+
+  --b3Img <- liftIO $ getDataFileName "data/block3.png"
+  --b3 <- lift $ fmap (Image b3Img) $ load b3Img
+
+  --paddleImg <- liftIO $ getDataFileName "data/paddleBlu.png"
+  --paddle <- lift $ fmap (Image paddleImg) $ load paddleImg
+
+  ---- Start playing music
+  ---- when (isJust bgM) $ lift (playMusic (fromJust bgM))
+
+  ---- Return Nothing or embed in Resources
+  --res <- case (myFont, blockHit) of
+  --         (Just f, Just b) -> let 
+  --                             in return (Resources f b Nothing ball b1 b2 b3 paddle Nothing)
+  --         _                        -> do liftIO $ putStrLn "Some resources could not be loaded"
+  --                                        mzero
+
+  liftIO $ fmap ResourceMgr $
+    newIORef (ResourceManager (GameStarted) Resources)
+
+initializeDisplay :: IO ()
+initializeDisplay = do
+  -- get Canvas context
+  Just doc <- currentDocument
+  Just body <- getBody doc
+  setInnerHTML body (Just initialHtml)
+
+initialHtml :: String
+initialHtml = "<canvas id=\"dia\" width=\"" ++ show (round width)
+              ++ "\" height=\"" ++ show (round height)
+              ++ "\" style=\"border: 1px solid\"></canvas>"
+
+initGraphs :: IO ()
+initGraphs = do
+  return () 
+  -- -- Create window
+  -- screen <- SDL.setVideoMode (round width) (round height) 32 [SWSurface]
+  -- SDL.setCaption "Test" ""
+
+  -- -- Important if we want the keyboard to work right (I don't know
+  -- -- how to make it work otherwise)
+  -- SDL.enableUnicode True
+
+  -- -- Hide mouse
+  -- SDL.showCursor False
+
+
+render :: ResourceMgr -> GameState -> IO()
+render resourceManager shownState = do
+  -- resources <- loadNewResources resourceManager shownState
+  let resources = Resources
+  audio   resources shownState
+  display resources shownState
+
+audio :: Resources -> GameState -> IO()
+audio resources shownState = do
+  return ()
+  -- Start bg music if necessary
+  -- playing <- musicPlaying
+  -- unless playing $ awhen (bgMusic resources) playMusic 
+
+  -- -- Play object hits
+  -- mapM_ (audioObject resources) $ gameObjects shownState
+
+-- audioObject resources object = when (objectHit object) $
+--   case objectKind object of
+--     (Block _ _) -> playFile (blockHitSnd resources) 3000
+--     _           -> return ()
+
+display :: Resources -> GameState -> IO()
+display resources shownState = synchronously $ do 
+  -- Obtain surface
+  Just doc <- currentDocument
+  Just canvas <- getElementById doc "dia"
+  ctx <- getContext canvas
+
+  -- Paint background
+  C.fillStyle 252 235 182 1.0 ctx
+  C.fillRect 0 0 width height ctx
+
+  mapM_ (paintObject (gameLeft, gameTop) resources ctx) $ gameObjects shownState
+
+  -- HUD
+  paintGeneral ctx resources (gameInfo shownState)
+  paintGeneralMsg ctx resources (gameStatus (gameInfo shownState))
+
+  -- Double buffering
+  -- C.fill ctx
+
+paintGeneralMsg screen resources GamePlaying     = return ()
+paintGeneralMsg screen resources GamePaused      = paintGeneralMsg' screen resources "Paused"
+paintGeneralMsg screen resources (GameLoading n) = paintGeneralMsg' screen resources ("Level " ++ show n)
+paintGeneralMsg screen resources GameOver        = paintGeneralMsg' screen resources "GAME OVER!!!"
+paintGeneralMsg screen resources GameFinished    = paintGeneralMsg' screen resources "You won!!! Well done :)"
+
+paintGeneralMsg' screen resources msg = void $ do
+  C.fillStyle 94 65 47 1 screen
+  C.font (fromString "34px Arial") screen
+  C.textBaseline C.Top screen
+  C.textAlign C.Center screen
+  C.fillText (fromString msg) (width / 2) (height / 2) screen
+
+paintGeneral screen resources over = void $ do
+  -- Paint background
+  C.fillStyle 94 65 47 1 screen
+  C.fillRect 0 0 width gameTop screen
+  -- Paint HUG
+  paintGeneralHUD screen resources over
+
+paintGeneralHUD screen resources over = void $ do
+  C.fillStyle 252 235 182 1.0 screen
+  C.font (fromString "34px Arial") screen
+  C.textBaseline C.Top screen
+  C.textAlign C.Left screen
+  C.fillText (fromString $ "Level: " ++ show (gameLevel over)) 10 10 screen
+  C.fillText (fromString $ "Points: " ++ show (gamePoints over)) 10 50 screen
+  C.textAlign C.Right screen
+  C.fillText (fromString $ "Lives: " ++ show (gameLives over)) (width-10) 10 screen
+
+paintObject (bx, by) resources screen object = do
+  case objectKind object of
+    (Paddle (w,h))  -> void $ do C.fillStyle 120 192 168 1.0 screen
+                                 C.fillRect x y w h screen
+    (Block e (w,h)) -> void $ do case e of
+                                   3 -> C.fillStyle 240 120 24 1.0 screen
+                                   2 -> C.fillStyle 220 108 21 1.0 screen
+                                   n -> C.fillStyle 200  99 19 1.0 screen
+                                 C.fillRect x y w h screen
+    (Ball r)        -> void $ do C.beginPath screen
+                                 C.arc x y r 0 (2*pi) False screen
+                                 C.fillStyle 240 168 48 1.0 screen
+                                 C.fill screen
+    _               -> return ()
+  where p = objectPos object
+        x = bx + fst p
+        y = by + snd p
+
+newtype ResourceMgr = ResourceMgr { unResMgr :: IORef ResourceManager }
+
+data ResourceManager = ResourceManager
+  { lastKnownStatus :: GameStatus
+  , resources       :: Resources
+  }
+
+data Resources = Resources
+  -- { resFont     :: Font
+  -- , blockHitSnd :: Audio
+  -- , bgImage     :: Maybe Image
+  -- , ballImg     :: Image
+  -- , block1Img   :: Image
+  -- , block2Img   :: Image
+  -- , block3Img   :: Image
+  -- , paddleImg   :: Image
+  -- , bgMusic     :: Maybe Music
+  -- }
+
+getContext :: Element -> IO C.Context
+getContext = C.getContext . coerce
+
+
+-- data Image = Image { imgName  :: String, imgSurface :: Surface }
+-- data Font  = Font  { fontName :: String, unFont :: TTF.Font }
+
+--loadNewResources :: ResourceMgr ->  GameState -> IO Resources
+--loadNewResources mgr state = do
+--  manager <- readIORef (unResMgr mgr)
+--  let oldState = lastKnownStatus manager
+--      newState = gameStatus (gameInfo state)
+--      oldResources = resources manager
+--
+--  newResources <- case newState of
+--                    (GameLoading _) | (newState /= oldState)
+--                                    -> updateAllResources oldResources newState
+--                    _               -> return oldResources 
+--
+--  let manager' = ResourceManager { lastKnownStatus = newState
+--                                 , resources       = newResources
+--                                 }
+--
+--  writeIORef (unResMgr mgr) manager'
+--  return newResources
+
+-- updateAllResources :: Resources -> GameStatus -> IO Resources
+-- updateAllResources res (GameLoading n) = do
+--   -- Load new music
+--   let newMusicFP' = _resourceFP $ levelMusic $ levels !! n
+--   newMusicFP <- getDataFileName newMusicFP'
+-- 
+--   let oldMusic   = bgMusic res
+--       oldMusicFP = maybe "" musicName oldMusic
+-- 
+--   newMusic <- if (oldMusicFP == newMusicFP)
+--               then return oldMusic
+--               else do -- Loading can fail, in which case we continue
+--                       -- with the old music
+--                       bgM <- loadMusic newMusicFP
+--                       if isNothing bgM
+--                        then do putStrLn $ "Could not load resource " ++ newMusicFP
+--                                return oldMusic
+--                        else do stopMusic
+--                                return bgM
+-- 
+--   -- Load new background
+--   let newBgFP' = _resourceFP $ levelBg $ levels !! n
+-- 
+--   newBgFP <- getDataFileName newBgFP'
+-- 
+--   let oldBg   = bgImage res
+--       oldBgFP = maybe "" imgName oldBg
+-- 
+--   newBg <- if oldBgFP == newBgFP
+--              then return oldBg
+--              else do img' <- load newBgFP
+--                      return $ Just (Image newBgFP img')
+-- 
+--   return (res { bgImage = newBg, bgMusic = newMusic })