diff --git a/README.md b/README.md index 43c11ee..10e70a3 100644 --- a/README.md +++ b/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 diff --git a/haskanoid.cabal b/haskanoid.cabal index 1d2c9e6..9a01358 100644 --- a/haskanoid.cabal +++ b/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 diff --git a/src/DisplayGHCJS.hs b/src/DisplayGHCJS.hs new file mode 100644 index 0000000..8299dae --- /dev/null +++ b/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 = "" + +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 }) diff --git a/src/GHCJSNow.hs b/src/GHCJSNow.hs new file mode 100644 index 0000000..4ec8ae6 --- /dev/null +++ b/src/GHCJSNow.hs @@ -0,0 +1,35 @@ +module GHCJSNow where + +import Data.IORef +import Data.Time.Clock.POSIX (getPOSIXTime) +-- import JsImports (now) + +initializeTimeRef :: IO (IORef Int) +initializeTimeRef = do + -- Weird shit I have to do to get accurate time! + timeRef <- newIORef (0 :: Int) + _ <- senseTimeRef timeRef + + return timeRef + +senseTimeRef :: IORef Int -> IO Int +senseTimeRef timeRef = do + -- Get time passed since SDL init + newTime <- fmap secsToMilisecs getPOSIXTime + + -- Obtain time difference + dt <- updateTime timeRef newTime + return dt + +-- | Updates the time in an IO Ref and returns the time difference +updateTime :: IORef Int -> Int -> IO Int +updateTime timeRef newTime = do + previousTime <- readIORef timeRef + writeIORef timeRef newTime + return (newTime - previousTime) + +secsToMilisecs :: RealFrac a => a -> Int +secsToMilisecs m = round (m * 1000) + +milisecsToSecs :: Int -> Double +milisecsToSecs m = fromIntegral m / 1000 diff --git a/src/Input.hs b/src/Input.hs index 8611a30..444eda1 100644 --- a/src/Input.hs +++ b/src/Input.hs @@ -32,8 +32,47 @@ module Input where -- External imports import Data.IORef -import Graphics.UI.SDL as SDL import Control.Monad +import Control.Extra.Monad + +-- External imports (SDL) +#ifdef sdl +import Graphics.UI.SDL as SDL +import Graphics.UI.Extra.SDL +#endif + +-- External imports (GHCJS) +#ifdef ghcjs +import Data.Coerce +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 ( eventListenerNewSync ) +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 +#endif -- External imports (Wiimote) #ifdef wiimote @@ -54,8 +93,7 @@ import qualified Data.Vector.Storable as V #endif -- Internal imports -import Control.Extra.Monad -import Graphics.UI.Extra.SDL + import Constants @@ -82,7 +120,12 @@ newtype ControllerRef = -- not provide any information about its nature, abilities, etc. initializeInputDevices :: IO ControllerRef initializeInputDevices = do + +#ifdef sdl let baseDev = sdlGetController +#elif ghcjs + baseDev <- ghcjsController +#endif -- Fall back to mouse/kb is no kinect is present #ifdef kinect @@ -199,6 +242,7 @@ senseWiimote wmdev controller = do #endif -- * SDL API (mid-level) +#ifdef sdl -- ** Initialization @@ -230,8 +274,62 @@ handleEvent c e = KeyDown Keysym { symKey = SDLK_SPACE } -> c { controllerClick = True } KeyUp Keysym { symKey = SDLK_SPACE } -> c { controllerClick = False } _ -> c +#endif + +#ifdef ghcjs +type GHCJSController = IORef (Double, Double, Bool) + +ghcjsController :: IO (Controller -> IO Controller) +ghcjsController = do + cvs <- initializeCanvasSense (width, height) + return $ ghcjsGetController cvs + +initializeCanvasSense :: (Double, Double) -> IO GHCJSController +initializeCanvasSense dim = do + ref <- newIORef (0, 0, False) + + Just doc <- currentDocument + Just canvas <- getElementById doc "dia" + ctx <- getContext canvas + + listenerM <- eventListenerNewSync (updateMove dim ref canvas) + listenerC <- eventListenerNewSync (updateClick ref canvas) + listenerR <- eventListenerNewSync (updateRelease ref canvas) + addEventListener canvas "mousemove" (Just listenerM) False + addEventListener canvas "mousedown" (Just listenerC) False + addEventListener canvas "mouseup" (Just listenerR) False + + return ref + where updateMove :: (Double, Double) -> GHCJSController -> Element -> MouseEvent -> IO () + updateMove (w, h) ref canvas ev = do + x <- fromIntegral <$> getPageX ev + y <- fromIntegral <$> getPageY ev + x0 <- getOffsetLeft canvas + y0 <- getOffsetTop canvas + let x' = min (max 0 (x - x0)) w + let y' = min (max 0 (y - y0)) h + x' `seq` y' `seq` modifyIORef' ref (\(_,_,click) -> (x', y', click)) + return () + + updateClick :: GHCJSController -> Element -> MouseEvent -> IO () + updateClick ref canvas _ = + modifyIORef' ref (\(x,y,_) -> (x, y, True)) + + updateRelease :: GHCJSController -> Element -> MouseEvent -> IO () + updateRelease ref canvas _ = + modifyIORef' ref (\(x,y,_) -> (x, y, False)) + +ghcjsGetController ref co = do + (px,py,c) <- readIORef ref + let c' = co { controllerPos = (px, py), controllerClick = c } + return c' + +getContext :: Element -> IO C.Context +getContext = C.getContext . coerce +#endif + -- Kinect #ifdef kinect diff --git a/src/JsImports.hs b/src/JsImports.hs new file mode 100644 index 0000000..041fcb6 --- /dev/null +++ b/src/JsImports.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE JavaScriptFFI, CPP #-} + +-- | Misc FFI imports from JS. + +module JsImports where + +import GHCJS.Types + +#ifdef __GHCJS__ +foreign import javascript unsafe "$r = Date.now();" now :: IO Double +#else +now = error "now: only available from JavaScript" +#endif diff --git a/src/Main.hs b/src/Main.hs index c671e5b..f2e1aab 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,11 +1,19 @@ +{-# LANGUAGE CPP #-} import Control.Applicative ((<$>)) import Control.Monad.IfElse import FRP.Yampa as Yampa import Game -import Display import Input +#ifdef sdl +import Display import Graphics.UI.Extra.SDL +#elif ghcjs +import Control.Concurrent +import DisplayGHCJS +import GHCJSNow +import System.Mem +#endif -- TODO: Use MaybeT or ErrorT to report errors main :: IO () @@ -25,6 +33,6 @@ main = do mInput <- senseInput controllerRef return (dtSecs, Just mInput) ) - (\_ e -> render res' e >> return False) + (\_ e -> render res' e >> return False) -- GHCJS: (\_ e -> render res' e >> threadDelay 1000 >> return False) wholeGame