module Graphics.Shine (
toContext,
fullScreenCanvas,
fixedSizeCanvas,
animate,
animateIO,
play,
playIO
) where
import GHCJS.DOM.Document (getBody)
import GHCJS.DOM.NonElementParentNode (getElementById)
import GHCJS.DOM.EventM (on, mouseButton, mouseCtrlKey, mouseAltKey, mouseShiftKey, mouseMetaKey, mouseOffsetXY, uiKeyCode, event)
import GHCJS.DOM.GlobalEventHandlers (mouseDown, mouseUp, mouseMove, wheel, keyUp, keyDown)
import GHCJS.DOM.EventTarget (IsEventTarget)
import GHCJS.DOM.WheelEvent (getDeltaX, getDeltaY)
import GHCJS.DOM.KeyboardEvent (KeyboardEvent, getCtrlKey, getShiftKey, getAltKey, getMetaKey)
import GHCJS.DOM.Element (setInnerHTML)
import GHCJS.DOM.HTMLCanvasElement (getContext)
import GHCJS.DOM.CanvasRenderingContext2D
import GHCJS.DOM.Types (JSM, Element, MouseEvent, IsDocument, Document)
import Web.KeyCode (keyCodeLookup)
import Unsafe.Coerce (unsafeCoerce)
import Control.Concurrent (threadDelay)
import Control.Concurrent.MVar (newMVar, modifyMVar, modifyMVar_)
import Control.Monad (when)
import Control.Monad.Trans (liftIO)
import Control.Monad.Trans.Reader (ReaderT)
import Data.Foldable (foldrM)
import Data.Time.Clock (getCurrentTime, diffUTCTime)
import Data.Maybe (isJust, fromJust)
import Graphics.Shine.Input
import Graphics.Shine.Picture
import Graphics.Shine.Render
toContext :: Element
-> JSM CanvasRenderingContext2D
toContext c = do
Just ctx <- getContext (unsafeCoerce c) "2d" ["2d"]
return $ unsafeCoerce ctx
customAttributesCanvas :: Document -> String -> JSM CanvasRenderingContext2D
customAttributesCanvas doc attrs = do
Just body <- getBody doc
setInnerHTML body canvasHtml
Just c <- getElementById doc "canvas"
toContext c
where canvasHtml :: String
canvasHtml = "<canvas id=\"canvas\" " ++ attrs ++ " </canvas> "
fullScreenCanvas :: Document -> JSM CanvasRenderingContext2D
fullScreenCanvas doc = customAttributesCanvas doc attributes
where attributes :: String
attributes = "style=\"border:1px \
\solid #000000; \
\top:0px;bottom:0px;left:0px;right:0px;\""
fixedSizeCanvas :: Document -> Int -> Int -> JSM CanvasRenderingContext2D
fixedSizeCanvas doc x y = customAttributesCanvas doc $ attributes x y
where attributes :: Int -> Int -> String
attributes x' y' = "width=\""++ show x' ++ "\" \
\height=\""++ show y' ++ "\" \
\style=\"border:1px \
\solid #000000;\""
animate :: CanvasRenderingContext2D
-> Double
-> (Double -> Picture)
-> JSM ()
animate ctx fps f = animateIO ctx fps $ return . f
animateIO :: CanvasRenderingContext2D
-> Double
-> (Double -> IO Picture)
-> JSM ()
animateIO ctx fps f = do
initialTime <- getCurrentTime
let loop = do
stamp <- getCurrentTime
clearRect ctx (-10000) (-10000) 20000 20000
setTransform ctx 1 0 0 1 0 0
let t = realToFrac $ diffUTCTime stamp initialTime
pic <- f t
render ctx pic
now <- getCurrentTime
let td = diffUTCTime now stamp
when (realToFrac td <= 1 / fps) $
threadDelay $ floor $ (*1000000) (1 / fps - realToFrac td)
loop
in
loop
getModifiersMouse :: ReaderT MouseEvent JSM Modifiers
getModifiersMouse = Modifiers
<$> fmap toKeyState mouseCtrlKey
<*> fmap toKeyState mouseAltKey
<*> fmap toKeyState mouseShiftKey
<*> fmap toKeyState mouseMetaKey
getModifiersKeyboard :: ReaderT KeyboardEvent JSM Modifiers
getModifiersKeyboard = Modifiers
<$> fmap toKeyState (event >>= getCtrlKey)
<*> fmap toKeyState (event >>= getAltKey)
<*> fmap toKeyState (event >>= getShiftKey)
<*> fmap toKeyState (event >>= getMetaKey)
play :: (IsEventTarget eventElement, IsDocument eventElement)
=> CanvasRenderingContext2D
-> eventElement
-> Double
-> state
-> (state -> Picture)
-> (Input -> state -> state)
-> (Double -> state -> state)
-> JSM ()
play ctx doc fps initialState draw handleInput step =
playIO
ctx
doc
fps
initialState
(return . draw)
(\s i -> return $ handleInput s i)
(\s t -> return $ step s t)
playIO :: (IsEventTarget eventElement, IsDocument eventElement)
=> CanvasRenderingContext2D
-> eventElement
-> Double
-> state
-> (state -> IO Picture)
-> (Input -> state -> IO state)
-> (Double -> state -> IO state)
-> JSM ()
playIO ctx doc fps initialState draw handleInput step = do
inputM <- newMVar []
_ <- on doc mouseDown $ do
btn <- fmap toMouseBtn mouseButton
modifiers <- getModifiersMouse
when (isJust btn) $
liftIO $ modifyMVar_ inputM $ fmap return (MouseBtn (fromJust btn) Down modifiers :)
_ <- on doc mouseUp $ do
btn <- fmap toMouseBtn mouseButton
modifiers <- getModifiersMouse
when (isJust btn) $
liftIO $ modifyMVar_ inputM $ fmap return (MouseBtn (fromJust btn) Up modifiers :)
_ <- on doc mouseMove $ do
coords <- mouseOffsetXY
liftIO $ modifyMVar_ inputM $ fmap return (MouseMove coords :)
_ <- on doc wheel $ do
delta <- (,) <$> (event >>= getDeltaX) <*> (event >>= getDeltaY)
liftIO $ modifyMVar_ inputM $ fmap return (MouseWheel delta :)
_ <- on doc keyDown $ do
key <- uiKeyCode
modifiers <- getModifiersKeyboard
liftIO $ modifyMVar_ inputM $ fmap return (Keyboard (keyCodeLookup $ fromIntegral key) Down modifiers :)
_ <- on doc keyUp $ do
key <- uiKeyCode
modifiers <- getModifiersKeyboard
liftIO $ modifyMVar_ inputM $ fmap return (Keyboard (keyCodeLookup $ fromIntegral key) Up modifiers :)
initialTime <- getCurrentTime
let loop state previousTime = do
inputs <- modifyMVar inputM $ \xs -> return ([], xs)
state' <- foldrM handleInput state inputs
beforeRendering <- getCurrentTime
let td = diffUTCTime beforeRendering previousTime
state'' <- step (realToFrac td) state'
clearRect ctx (-10000) (-10000) 20000 20000
setTransform ctx 1 0 0 1 0 0
pic <- draw state''
render ctx pic
afterRendering <- getCurrentTime
let renderingTime = diffUTCTime afterRendering beforeRendering
when (realToFrac renderingTime <= 1 / fps) $
threadDelay $ floor $ (*1000000) (1 / fps - realToFrac renderingTime)
loop state'' beforeRendering
in
loop initialState initialTime