module CodeWorld.Driver (
drawingOf,
animationOf,
simulationOf,
interactionOf,
collaborationOf,
unsafeCollaborationOf,
trace
) where
import CodeWorld.Color
import CodeWorld.Event
import CodeWorld.Picture
import CodeWorld.CollaborationUI (SetupPhase(..), Step(..), UIState)
import qualified CodeWorld.CollaborationUI as CUI
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Concurrent.Chan
import Control.Exception
import Control.Monad
import Control.Monad.Trans (liftIO)
import Data.Char (chr)
import Data.List (zip4)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Monoid
import Data.Serialize
import Data.Serialize.Text
import qualified Data.Text as T
import Data.Text (Text, singleton, pack)
import GHC.Fingerprint.Type
import GHC.Generics
import GHC.StaticPtr
import Numeric
import System.Environment
import System.Mem.StableName
import Text.Read
import System.Random
#ifdef ghcjs_HOST_OS
import CodeWorld.Prediction
import CodeWorld.Message
import Data.Hashable
import Data.IORef
import Data.JSString.Text
import qualified Data.JSString
import Data.Time.Clock
import Data.Word
import GHCJS.DOM
import GHCJS.DOM.NonElementParentNode
import GHCJS.DOM.GlobalEventHandlers
import GHCJS.DOM.Window as Window
import GHCJS.DOM.Document
import qualified GHCJS.DOM.ClientRect as ClientRect
import GHCJS.DOM.Element
import GHCJS.DOM.EventM
import GHCJS.DOM.MouseEvent
import GHCJS.DOM.Types (Element, unElement)
import GHCJS.Foreign
import GHCJS.Marshal
import GHCJS.Marshal.Pure
import GHCJS.Types
import JavaScript.Web.AnimationFrame
import qualified JavaScript.Web.Canvas as Canvas
import qualified JavaScript.Web.Canvas.Internal as Canvas
import qualified JavaScript.Web.Location as Loc
import qualified JavaScript.Web.MessageEvent as WS
import qualified JavaScript.Web.WebSocket as WS
import System.IO.Unsafe
#else
import Data.Time.Clock
import qualified Debug.Trace
import qualified Graphics.Blank as Canvas
import Graphics.Blank (Canvas)
import System.IO
import Text.Printf
#endif
drawingOf :: Picture -> IO ()
animationOf :: (Double -> Picture) -> IO ()
simulationOf :: world -> (Double -> world -> world) -> (world -> Picture) -> IO ()
interactionOf :: world
-> (Double -> world -> world)
-> (Event -> world -> world)
-> (world -> Picture)
-> IO ()
collaborationOf :: Int
-> StaticPtr (StdGen -> world)
-> StaticPtr (Double -> world -> world)
-> StaticPtr (Int -> Event -> world -> world)
-> StaticPtr (Int -> world -> Picture)
-> IO ()
unsafeCollaborationOf :: Int
-> (StdGen -> world)
-> (Double -> world -> world)
-> (Int -> Event -> world -> world)
-> (Int -> world -> Picture)
-> IO ()
trace :: Text -> a -> a
type DrawState = (Double, Double, Double, Double, Double, Double, Maybe Color)
initialDS :: DrawState
initialDS = (1, 0, 0, 1, 0, 0, Nothing)
translateDS :: Double -> Double -> DrawState -> DrawState
translateDS x y (a,b,c,d,e,f,hc) =
(a, b, c, d, a*25*x + c*25*y + e, b*25*x + d*25*y + f, hc)
scaleDS :: Double -> Double -> DrawState -> DrawState
scaleDS x y (a,b,c,d,e,f,hc) =
(x*a, x*b, y*c, y*d, e, f, hc)
rotateDS :: Double -> DrawState -> DrawState
rotateDS r (a,b,c,d,e,f,hc) =
(a * cos r + c * sin r,
b * cos r + d * sin r,
c * cos r a * sin r,
d * cos r b * sin r,
e, f, hc)
setColorDS :: Color -> DrawState -> DrawState
setColorDS col (a,b,c,d,e,f,Nothing) = (a,b,c,d,e,f,Just col)
setColorDS _ (a,b,c,d,e,f,Just col) = (a,b,c,d,e,f,Just col)
getColorDS :: DrawState -> Maybe Color
getColorDS (a,b,c,d,e,f,col) = col
#ifdef ghcjs_HOST_OS
foreign import javascript unsafe "$1.drawImage($2, $3, $4, $5, $6);"
js_canvasDrawImage :: Canvas.Context -> Element -> Int -> Int -> Int -> Int -> IO ()
foreign import javascript unsafe "$1.getContext('2d', { alpha: false })"
js_getCodeWorldContext :: Canvas.Canvas -> IO Canvas.Context
foreign import javascript unsafe "performance.now()"
js_getHighResTimestamp :: IO Double
canvasFromElement :: Element -> Canvas.Canvas
canvasFromElement = Canvas.Canvas . unElement
elementFromCanvas :: Canvas.Canvas -> Element
elementFromCanvas = pFromJSVal . jsval
getTime :: IO Double
getTime = (/ 1000) <$> js_getHighResTimestamp
nextFrame :: IO Double
nextFrame = waitForAnimationFrame >> getTime
withDS :: Canvas.Context -> DrawState -> IO () -> IO ()
withDS ctx (ta,tb,tc,td,te,tf,col) action = do
Canvas.save ctx
Canvas.transform ta tb tc td te tf ctx
Canvas.beginPath ctx
action
Canvas.restore ctx
applyColor :: Canvas.Context -> DrawState -> IO ()
applyColor ctx ds = case getColorDS ds of
Nothing -> do
Canvas.strokeStyle 0 0 0 1 ctx
Canvas.fillStyle 0 0 0 1 ctx
Just (RGBA r g b a) -> do
Canvas.strokeStyle (round $ r * 255)
(round $ g * 255)
(round $ b * 255)
a ctx
Canvas.fillStyle (round $ r * 255)
(round $ g * 255)
(round $ b * 255)
a ctx
foreign import javascript unsafe "$1.globalCompositeOperation = $2"
js_setGlobalCompositeOperation :: Canvas.Context -> JSString -> IO ()
drawCodeWorldLogo :: Canvas.Context -> DrawState -> Int -> Int -> Int -> Int -> IO ()
drawCodeWorldLogo ctx ds x y w h = do
Just doc <- currentDocument
Just canvas <- getElementById doc ("cwlogo" :: JSString)
case getColorDS ds of
Nothing -> js_canvasDrawImage ctx canvas x y w h
Just (RGBA r g b a) -> do
buf <- Canvas.create w h
bufctx <- js_getCodeWorldContext buf
applyColor bufctx ds
Canvas.fillRect 0 0 (fromIntegral w) (fromIntegral h) bufctx
js_setGlobalCompositeOperation bufctx "destination-in"
js_canvasDrawImage bufctx canvas 0 0 w h
js_canvasDrawImage ctx (elementFromCanvas buf) x y w h
followPath :: Canvas.Context -> [Point] -> Bool -> Bool -> IO ()
followPath ctx [] closed _ = return ()
followPath ctx [p1] closed _ = return ()
followPath ctx ((sx,sy):ps) closed False = do
Canvas.moveTo (25 * sx) (25 * sy) ctx
forM_ ps $ \(x,y) -> Canvas.lineTo (25 * x) (25 * y) ctx
when closed $ Canvas.closePath ctx
followPath ctx [p1, p2] False True = followPath ctx [p1, p2] False False
followPath ctx ps False True = do
let [(x1,y1), (x2,y2), (x3,y3)] = take 3 ps
dprev = sqrt ((x2 x1)^2 + (y2 y1)^2)
dnext = sqrt ((x3 x2)^2 + (y3 y2)^2)
p = dprev / (dprev + dnext)
cx = x2 + p * (x1 x3) / 2
cy = y2 + p * (y1 y3) / 2
in do Canvas.moveTo (25 * x1) (25 * y1) ctx
Canvas.quadraticCurveTo (25 * cx) (25 * cy) (25 * x2) (25 * y2) ctx
forM_ (zip4 ps (tail ps) (tail $ tail ps) (tail $ tail $ tail ps)) $
\((x1,y1),(x2,y2),(x3,y3),(x4,y4)) ->
let dp = sqrt ((x2 x1)^2 + (y2 y1)^2)
d1 = sqrt ((x3 x2)^2 + (y3 y2)^2)
d2 = sqrt ((x4 x3)^2 + (y4 y3)^2)
p = d1 / (d1 + d2)
r = d1 / (dp + d1)
cx1 = x2 + r * (x3 x1) / 2
cy1 = y2 + r * (y3 y1) / 2
cx2 = x3 + p * (x2 x4) / 2
cy2 = y3 + p * (y2 y4) / 2
in Canvas.bezierCurveTo (25 * cx1) (25 * cy1) (25 * cx2) (25 * cy2)
(25 * x3) (25 * y3) ctx
let [(x1,y1), (x2,y2), (x3,y3)] = reverse $ take 3 $ reverse ps
dp = sqrt ((x2 x1)^2 + (y2 y1)^2)
d1 = sqrt ((x3 x2)^2 + (y3 y2)^2)
r = d1 / (dp + d1)
cx = x2 + r * (x3 x1) / 2
cy = y2 + r * (y3 y1) / 2
in Canvas.quadraticCurveTo (25 * cx) (25 * cy) (25 * x3) (25 * y3) ctx
followPath ctx ps@(_:(sx,sy):_) True True = do
Canvas.moveTo (25 * sx) (25 * sy) ctx
let rep = cycle ps
forM_ (zip4 ps (tail rep) (tail $ tail rep) (tail $ tail $ tail rep)) $
\((x1,y1),(x2,y2),(x3,y3),(x4,y4)) ->
let dp = sqrt ((x2 x1)^2 + (y2 y1)^2)
d1 = sqrt ((x3 x2)^2 + (y3 y2)^2)
d2 = sqrt ((x4 x3)^2 + (y4 y3)^2)
p = d1 / (d1 + d2)
r = d1 / (dp + d1)
cx1 = x2 + r * (x3 x1) / 2
cy1 = y2 + r * (y3 y1) / 2
cx2 = x3 + p * (x2 x4) / 2
cy2 = y3 + p * (y2 y4) / 2
in Canvas.bezierCurveTo (25 * cx1) (25 * cy1) (25 * cx2) (25 * cy2)
(25 * x3) (25 * y3) ctx
Canvas.closePath ctx
drawFigure :: Canvas.Context -> DrawState -> Double -> IO () -> IO ()
drawFigure ctx ds w figure = do
withDS ctx ds $ do
figure
when (w /= 0) $ do
Canvas.lineWidth (25 * w) ctx
applyColor ctx ds
Canvas.stroke ctx
when (w == 0) $ do
Canvas.lineWidth 1 ctx
applyColor ctx ds
Canvas.stroke ctx
fontString :: TextStyle -> Font -> JSString
fontString style font = stylePrefix style <> "25px " <> fontName font
where stylePrefix Plain = ""
stylePrefix Bold = "bold "
stylePrefix Italic = "italic "
fontName SansSerif = "sans-serif"
fontName Serif = "serif"
fontName Monospace = "monospace"
fontName Handwriting = "cursive"
fontName Fancy = "fantasy"
fontName (NamedFont txt) = "\"" <> textToJSString (T.filter (/= '"') txt) <> "\""
drawPicture :: Canvas.Context -> DrawState -> Picture -> IO ()
drawPicture ctx ds (Polygon ps smooth) = do
withDS ctx ds $ followPath ctx ps True smooth
applyColor ctx ds
Canvas.fill ctx
drawPicture ctx ds (Path ps w closed smooth) = do
drawFigure ctx ds w $ followPath ctx ps closed smooth
drawPicture ctx ds (Sector b e r) = withDS ctx ds $ do
Canvas.arc 0 0 (25 * abs r) b e (b > e) ctx
Canvas.lineTo 0 0 ctx
applyColor ctx ds
Canvas.fill ctx
drawPicture ctx ds (Arc b e r w) = do
drawFigure ctx ds w $ do
Canvas.arc 0 0 (25 * abs r) b e (b > e) ctx
drawPicture ctx ds (Text sty fnt txt) = withDS ctx ds $ do
Canvas.scale 1 (1) ctx
applyColor ctx ds
Canvas.font (fontString sty fnt) ctx
Canvas.fillText (textToJSString txt) 0 0 ctx
drawPicture ctx ds Logo = withDS ctx ds $ do
Canvas.scale 1 (1) ctx
drawCodeWorldLogo ctx ds (225) (50) 450 100
drawPicture ctx ds (Color col p) = drawPicture ctx (setColorDS col ds) p
drawPicture ctx ds (Translate x y p) = drawPicture ctx (translateDS x y ds) p
drawPicture ctx ds (Scale x y p) = drawPicture ctx (scaleDS x y ds) p
drawPicture ctx ds (Rotate r p) = drawPicture ctx (rotateDS r ds) p
drawPicture ctx ds (Pictures ps) = mapM_ (drawPicture ctx ds) (reverse ps)
drawFrame :: Canvas.Context -> Picture -> IO ()
drawFrame ctx pic = do
Canvas.fillStyle 255 255 255 1 ctx
Canvas.fillRect (250) (250) 500 500 ctx
drawPicture ctx initialDS pic
setupScreenContext :: Element -> ClientRect.ClientRect -> IO Canvas.Context
setupScreenContext canvas rect = do
cw <- ClientRect.getWidth rect
ch <- ClientRect.getHeight rect
ctx <- js_getCodeWorldContext (canvasFromElement canvas)
Canvas.save ctx
Canvas.translate (realToFrac cw / 2) (realToFrac ch / 2) ctx
Canvas.scale (realToFrac cw / 500) ( realToFrac ch / 500) ctx
Canvas.lineWidth 0 ctx
Canvas.textAlign Canvas.Center ctx
Canvas.textBaseline Canvas.Middle ctx
return ctx
setCanvasSize :: Element -> Element -> IO ()
setCanvasSize target canvas = do
rect <- getBoundingClientRect canvas
cx <- ClientRect.getWidth rect
cy <- ClientRect.getHeight rect
setAttribute target ("width" :: JSString) (show (round cx))
setAttribute target ("height" :: JSString) (show (round cy))
display :: Picture -> IO ()
display pic = do
Just window <- currentWindow
Just doc <- currentDocument
Just canvas <- getElementById doc ("screen" :: JSString)
on window resize $ liftIO (draw canvas)
draw canvas
where
draw canvas = do
setCanvasSize canvas canvas
rect <- getBoundingClientRect canvas
ctx <- setupScreenContext canvas rect
drawFrame ctx pic
Canvas.restore ctx
drawingOf pic = display pic `catch` reportError
#else
withDS :: DrawState -> Canvas () -> Canvas ()
withDS (ta,tb,tc,td,te,tf,col) action =
Canvas.saveRestore $ do
Canvas.transform (ta, tb, tc, td, te, tf)
Canvas.beginPath ()
action
applyColor :: DrawState -> Canvas ()
applyColor ds = case getColorDS ds of
Nothing -> do
Canvas.strokeStyle "black"
Canvas.fillStyle "black"
Just (RGBA r g b a) -> do
let style = pack $ printf "rgba(%.0f,%.0f,%.0f,%f)" (r*255) (g*255) (b*255) a
Canvas.strokeStyle style
Canvas.fillStyle style
drawFigure :: DrawState -> Double -> Canvas () -> Canvas ()
drawFigure ds w figure = do
withDS ds $ do
figure
when (w /= 0) $ do
Canvas.lineWidth (25 * w)
applyColor ds
Canvas.stroke ()
when (w == 0) $ do
Canvas.lineWidth 1
applyColor ds
Canvas.stroke ()
followPath :: [Point] -> Bool -> Bool -> Canvas ()
followPath [] closed _ = return ()
followPath [p1] closed _ = return ()
followPath ((sx,sy):ps) closed False = do
Canvas.moveTo (25 * sx, 25 * sy)
forM_ ps $ \(x,y) -> Canvas.lineTo (25 * x, 25 * y)
when closed $ Canvas.closePath ()
followPath [p1, p2] False True = followPath [p1, p2] False False
followPath ps False True = do
let [(x1,y1), (x2,y2), (x3,y3)] = take 3 ps
dprev = sqrt ((x2 x1)^2 + (y2 y1)^2)
dnext = sqrt ((x3 x2)^2 + (y3 y2)^2)
p = dprev / (dprev + dnext)
cx = x2 + p * (x1 x3) / 2
cy = y2 + p * (y1 y3) / 2
in do Canvas.moveTo (25 * x1, 25 * y1)
Canvas.quadraticCurveTo (25 * cx, 25 * cy, 25 * x2, 25 * y2)
forM_ (zip4 ps (tail ps) (tail $ tail ps) (tail $ tail $ tail ps)) $
\((x1,y1),(x2,y2),(x3,y3),(x4,y4)) ->
let dp = sqrt ((x2 x1)^2 + (y2 y1)^2)
d1 = sqrt ((x3 x2)^2 + (y3 y2)^2)
d2 = sqrt ((x4 x3)^2 + (y4 y3)^2)
p = d1 / (d1 + d2)
r = d1 / (dp + d1)
cx1 = x2 + r * (x3 x1) / 2
cy1 = y2 + r * (y3 y1) / 2
cx2 = x3 + p * (x2 x4) / 2
cy2 = y3 + p * (y2 y4) / 2
in Canvas.bezierCurveTo ( 25 * cx1, 25 * cy1, 25 * cx2, 25 * cy2
, 25 * x3, 25 * y3)
let [(x1,y1), (x2,y2), (x3,y3)] = reverse $ take 3 $ reverse ps
dp = sqrt ((x2 x1)^2 + (y2 y1)^2)
d1 = sqrt ((x3 x2)^2 + (y3 y2)^2)
r = d1 / (dp + d1)
cx = x2 + r * (x3 x1) / 2
cy = y2 + r * (y3 y1) / 2
in Canvas.quadraticCurveTo (25 * cx, 25 * cy, 25 * x3, 25 * y3)
followPath ps@(_:(sx,sy):_) True True = do
Canvas.moveTo (25 * sx, 25 * sy)
let rep = cycle ps
forM_ (zip4 ps (tail rep) (tail $ tail rep) (tail $ tail $ tail rep)) $
\((x1,y1),(x2,y2),(x3,y3),(x4,y4)) ->
let dp = sqrt ((x2 x1)^2 + (y2 y1)^2)
d1 = sqrt ((x3 x2)^2 + (y3 y2)^2)
d2 = sqrt ((x4 x3)^2 + (y4 y3)^2)
p = d1 / (d1 + d2)
r = d1 / (dp + d1)
cx1 = x2 + r * (x3 x1) / 2
cy1 = y2 + r * (y3 y1) / 2
cx2 = x3 + p * (x2 x4) / 2
cy2 = y3 + p * (y2 y4) / 2
in Canvas.bezierCurveTo ( 25 * cx1, 25 * cy1, 25 * cx2, 25 * cy2
, 25 * x3, 25 * y3)
Canvas.closePath ()
fontString :: TextStyle -> Font -> Text
fontString style font = stylePrefix style <> "25px " <> fontName font
where stylePrefix Plain = ""
stylePrefix Bold = "bold "
stylePrefix Italic = "italic "
fontName SansSerif = "sans-serif"
fontName Serif = "serif"
fontName Monospace = "monospace"
fontName Handwriting = "cursive"
fontName Fancy = "fantasy"
fontName (NamedFont txt) = "\"" <> T.filter (/= '"') txt <> "\""
drawPicture :: DrawState -> Picture -> Canvas ()
drawPicture ds (Polygon ps smooth) = do
withDS ds $ followPath ps True smooth
applyColor ds
Canvas.fill ()
drawPicture ds (Path ps w closed smooth) = do
drawFigure ds w $ followPath ps closed smooth
drawPicture ds (Sector b e r) = withDS ds $ do
Canvas.arc (0, 0, 25 * abs r, b, e, b > e)
Canvas.lineTo (0, 0)
applyColor ds
Canvas.fill ()
drawPicture ds (Arc b e r w) = do
drawFigure ds w $ do
Canvas.arc (0, 0, 25 * abs r, b, e, b > e)
drawPicture ds (Text sty fnt txt) = withDS ds $ do
Canvas.scale (1, 1)
applyColor ds
Canvas.font (fontString sty fnt)
Canvas.fillText (txt, 0, 0)
drawPicture ds Logo = return ()
drawPicture ds (Color col p) = drawPicture (setColorDS col ds) p
drawPicture ds (Translate x y p) = drawPicture (translateDS x y ds) p
drawPicture ds (Scale x y p) = drawPicture (scaleDS x y ds) p
drawPicture ds (Rotate r p) = drawPicture (rotateDS r ds) p
drawPicture ds (Pictures ps) = mapM_ (drawPicture ds) (reverse ps)
setupScreenContext :: (Int, Int) -> Canvas ()
setupScreenContext (cw, ch) = do
Canvas.fillStyle "white"
Canvas.fillRect (0,0,fromIntegral cw,fromIntegral ch)
Canvas.translate (realToFrac cw / 2, realToFrac ch / 2)
let s = min (realToFrac cw / 500) (realToFrac ch / 500)
Canvas.scale (s, s)
Canvas.lineWidth 0
Canvas.textAlign Canvas.CenterAnchor
Canvas.textBaseline Canvas.MiddleBaseline
type Port = Int
readPortFromEnv :: String -> Port -> IO Port
readPortFromEnv envName defaultPort = do
ms <- lookupEnv envName
return (fromMaybe defaultPort (ms >>= readMaybe))
runBlankCanvas :: (Canvas.DeviceContext -> IO ()) -> IO ()
runBlankCanvas act = do
port <- readPortFromEnv "CODEWORLD_API_PORT" 3000
let options = (fromIntegral port) { Canvas.events =
[ "mousedown", "mouseup", "mousemove", "keydown", "keyup"]
}
putStrLn $ printf "Open me on http://127.0.0.1:%d/" (Canvas.port options)
Canvas.blankCanvas options $ \context -> do
putStrLn "Program is starting..."
act context
display :: Picture -> IO ()
display pic = runBlankCanvas $ \context ->
Canvas.send context $ Canvas.saveRestore $ do
let rect = (Canvas.width context, Canvas.height context)
setupScreenContext rect
drawPicture initialDS pic
drawingOf pic = display pic `catch` reportError
#endif
keyCodeToText :: Word -> Text
keyCodeToText n = case n of
_ | n >= 47 && n <= 90 -> fromAscii n
_ | n >= 96 && n <= 105 -> fromNum (n 96)
_ | n >= 112 && n <= 135 -> "F" <> fromNum (n 111)
3 -> "Cancel"
6 -> "Help"
8 -> "Backspace"
9 -> "Tab"
12 -> "5"
13 -> "Enter"
16 -> "Shift"
17 -> "Ctrl"
18 -> "Alt"
19 -> "Break"
20 -> "CapsLock"
27 -> "Esc"
32 -> " "
33 -> "PageUp"
34 -> "PageDown"
35 -> "End"
36 -> "Home"
37 -> "Left"
38 -> "Up"
39 -> "Right"
40 -> "Down"
42 -> "*"
43 -> "+"
44 -> "PrintScreen"
45 -> "Insert"
46 -> "Delete"
106 -> "*"
107 -> "+"
108 -> "Separator"
109 -> "-"
110 -> "."
111 -> "/"
144 -> "NumLock"
145 -> "ScrollLock"
186 -> ";"
187 -> "="
188 -> ","
189 -> "-"
190 -> "."
191 -> "/"
192 -> "`"
219 -> "["
220 -> "\\"
221 -> "]"
222 -> "'"
_ -> "Unknown:" <> fromNum n
where fromAscii n = singleton (chr (fromIntegral n))
fromNum n = pack (show (fromIntegral n))
isUniversallyConstant :: (a -> s -> s) -> s -> IO Bool
isUniversallyConstant f old = falseOr $ do
oldName <- makeStableName old
genName <- makeStableName $! (f undefined old)
return (genName == oldName)
where falseOr x = x `catch` \(e :: SomeException) -> return False
applyIfModifying :: (s -> IO s) -> s -> IO (Maybe s)
applyIfModifying f s0 = do
oldName <- makeStableName $! s0
s1 <- f s0
newName <- makeStableName $! s1
if newName /= oldName then return (Just s1)
else return Nothing
modifyMVarIfNeeded :: MVar s -> (s -> IO s) -> IO Bool
modifyMVarIfNeeded var f = modifyMVar var $ \s0 -> do
ms1 <- applyIfModifying f s0
case ms1 of Nothing -> return (s0, False)
Just s1 -> return (s1, True)
data GameToken
= FullToken {
tokenDeployHash :: Text,
tokenNumPlayers :: Int,
tokenInitial :: StaticKey,
tokenStep :: StaticKey,
tokenEvent :: StaticKey,
tokenDraw :: StaticKey
}
| PartialToken {
tokenDeployHash :: Text
}
| NoToken
deriving Generic
deriving instance Generic Fingerprint
instance Serialize Fingerprint
instance Serialize GameToken
#ifdef ghcjs_HOST_OS
getMousePos :: IsMouseEvent e => Element -> EventM w e Point
getMousePos canvas = do
(ix, iy) <- mouseClientXY
liftIO $ do
rect <- getBoundingClientRect canvas
cx <- ClientRect.getLeft rect
cy <- ClientRect.getTop rect
cw <- ClientRect.getWidth rect
ch <- ClientRect.getHeight rect
return (20 * fromIntegral (ix round cx) / realToFrac cw 10,
20 * fromIntegral (round cy iy) / realToFrac cw + 10)
fromButtonNum :: Word -> Maybe MouseButton
fromButtonNum 0 = Just LeftButton
fromButtonNum 1 = Just MiddleButton
fromButtonNum 2 = Just RightButton
fromButtonNum _ = Nothing
onEvents :: Element -> (Event -> IO ()) -> IO ()
onEvents canvas handler = do
Just window <- currentWindow
on window keyDown $ do
code <- uiKeyCode
let keyName = keyCodeToText code
when (keyName /= "") $ do
liftIO $ handler (KeyPress keyName)
preventDefault
stopPropagation
on window keyUp $ do
code <- uiKeyCode
let keyName = keyCodeToText code
when (keyName /= "") $ do
liftIO $ handler (KeyRelease keyName)
preventDefault
stopPropagation
on window mouseDown $ do
button <- mouseButton
case fromButtonNum button of
Nothing -> return ()
Just btn -> do
pos <- getMousePos canvas
liftIO $ handler (MousePress btn pos)
on window mouseUp $ do
button <- mouseButton
case fromButtonNum button of
Nothing -> return ()
Just btn -> do
pos <- getMousePos canvas
liftIO $ handler (MouseRelease btn pos)
on window mouseMove $ do
pos <- getMousePos canvas
liftIO $ handler (MouseMovement pos)
return ()
encodeEvent :: (Timestamp, Maybe Event) -> String
encodeEvent = show
decodeEvent :: String -> Maybe (Timestamp, Maybe Event)
decodeEvent = readMaybe
data GameState s
= Main (UIState SMain)
| Connecting WS.WebSocket (UIState SConnect)
| Waiting WS.WebSocket GameId PlayerId (UIState SWait)
| Running WS.WebSocket GameId Timestamp PlayerId (Future s)
isRunning :: GameState s -> Bool
isRunning Running{} = True
isRunning _ = False
gameTime :: GameState s -> Timestamp -> Double
gameTime (Running _ _ tstart _ _) t = t tstart
gameTime _ _ = 0
gameRate :: Double
gameRate = 1/16
gameStep :: (Double -> s -> s) -> Double -> GameState s -> GameState s
gameStep _ t (Main s)
= Main (CUI.step t s)
gameStep _ t (Connecting ws s)
= Connecting ws (CUI.step t s)
gameStep _ t (Waiting ws gid pid s)
= Waiting ws gid pid (CUI.step t s)
gameStep step t (Running ws gid tstart pid s)
= Running ws gid tstart pid (currentTimePasses step gameRate (t tstart) s)
gameDraw :: (Double -> s -> s)
-> (PlayerId -> s -> Picture)
-> GameState s
-> Timestamp
-> Picture
gameDraw _ _ (Main s) _ = CUI.picture s
gameDraw _ _ (Connecting _ s) _ = CUI.picture s
gameDraw _ _ (Waiting _ _ _ s) _ = CUI.picture s
gameDraw step draw (Running _ _ tstart pid s) t = draw pid (currentState step gameRate (t tstart) s)
handleServerMessage :: Int
-> (StdGen -> s)
-> (Double -> s -> s)
-> (PlayerId -> Event -> s -> s)
-> MVar (GameState s)
-> ServerMessage
-> IO ()
handleServerMessage numPlayers initial stepHandler eventHandler gsm sm = do
modifyMVar_ gsm $ \gs -> do
t <- getTime
case (sm, gs) of
(GameAborted, _) ->
return initialGameState
(JoinedAs pid gid, Connecting ws s) ->
return (Waiting ws gid pid (CUI.startWaiting gid s))
(PlayersWaiting m n, Waiting ws gid pid s) ->
return (Waiting ws gid pid (CUI.updatePlayers n m s))
(Started, Waiting ws gid pid _) ->
return (Running ws gid t pid (initFuture (initial (mkStdGen (hash gid))) numPlayers))
(OutEvent pid eo, Running ws gid tstart mypid s) ->
case decodeEvent eo of
Just (t',event) ->
let ours = pid == mypid
func = eventHandler pid <$> event
result | ours = s
| otherwise = addEvent stepHandler gameRate mypid t' func s
in return (Running ws gid tstart mypid result)
Nothing -> return (Running ws gid tstart mypid s)
_ -> return gs
return ()
gameHandle :: Int
-> (StdGen -> s)
-> (Double -> s -> s)
-> (PlayerId -> Event -> s -> s)
-> GameToken
-> MVar (GameState s)
-> Event
-> IO ()
gameHandle numPlayers initial stepHandler eventHandler token gsm event = do
gs <- takeMVar gsm
case gs of
Main s -> case CUI.event event s of
ContinueMain s' -> do
putMVar gsm (Main s')
Create s' -> do
ws <- connectToGameServer (handleServerMessage numPlayers initial stepHandler eventHandler gsm)
sendClientMessage ws (NewGame numPlayers (encode token))
putMVar gsm (Connecting ws s')
Join gid s' -> do
ws <- connectToGameServer (handleServerMessage numPlayers initial stepHandler eventHandler gsm)
sendClientMessage ws (JoinGame gid (encode token))
putMVar gsm (Connecting ws s')
Connecting ws s -> case CUI.event event s of
ContinueConnect s' -> do
putMVar gsm (Connecting ws s')
CancelConnect s' -> do
WS.close Nothing Nothing ws
putMVar gsm (Main s')
Waiting ws gid pid s -> case CUI.event event s of
ContinueWait s' -> do
putMVar gsm (Waiting ws gid pid s')
CancelWait s' -> do
WS.close Nothing Nothing ws
putMVar gsm (Main s')
Running ws gid tstart pid f -> do
t <- getTime
let gameState0 = currentState stepHandler gameRate (t tstart) f
let eventFun = eventHandler pid event
ms1 <- (return . eventFun) `applyIfModifying` gameState0
case ms1 of
Nothing -> do
putMVar gsm gs
Just s1 -> do
sendClientMessage ws (InEvent (encodeEvent (gameTime gs t, Just event)))
let f1 = addEvent stepHandler gameRate pid (t tstart) (Just eventFun) f
putMVar gsm (Running ws gid tstart pid f1)
getWebSocketURL :: IO JSString
getWebSocketURL = do
loc <- Loc.getWindowLocation
proto <- Loc.getProtocol loc
hostname <- Loc.getHostname loc
let url = case proto of
"http:" -> "ws://" <> hostname <> ":9160/gameserver"
"https:" -> "wss://" <> hostname <> "/gameserver"
return url
connectToGameServer :: (ServerMessage -> IO ()) -> IO WS.WebSocket
connectToGameServer handleServerMessage = do
let handleWSRequest m = do
maybeSM <- decodeServerMessage m
case maybeSM of
Nothing -> return ()
Just sm -> handleServerMessage sm
wsURL <- getWebSocketURL
let req = WS.WebSocketRequest
{ url = wsURL
, protocols = []
, onClose = Just $ \_ -> handleServerMessage GameAborted
, onMessage = Just handleWSRequest
}
WS.connect req
where
decodeServerMessage :: WS.MessageEvent -> IO (Maybe ServerMessage)
decodeServerMessage m = case WS.getData m of
WS.StringData str -> do
return $ readMaybe (Data.JSString.unpack str)
_ -> return Nothing
encodeClientMessage :: ClientMessage -> JSString
encodeClientMessage m = Data.JSString.pack (show m)
sendClientMessage :: WS.WebSocket -> ClientMessage -> IO ()
sendClientMessage ws msg = WS.send (encodeClientMessage msg) ws
where
encodeClientMessage :: ClientMessage -> JSString
encodeClientMessage m = Data.JSString.pack (show m)
initialGameState :: GameState s
initialGameState = Main CUI.initial
runGame :: GameToken
-> Int
-> (StdGen -> s)
-> (Double -> s -> s)
-> (Int -> Event -> s -> s)
-> (Int -> s -> Picture)
-> IO ()
runGame token numPlayers initial stepHandler eventHandler drawHandler = do
Just window <- currentWindow
Just doc <- currentDocument
Just canvas <- getElementById doc ("screen" :: JSString)
offscreenCanvas <- Canvas.create 500 500
setCanvasSize canvas canvas
setCanvasSize (elementFromCanvas offscreenCanvas) canvas
on window resize $ do
liftIO $ setCanvasSize canvas canvas
liftIO $ setCanvasSize (elementFromCanvas offscreenCanvas) canvas
currentGameState <- newMVar initialGameState
onEvents canvas $ gameHandle numPlayers initial stepHandler eventHandler token currentGameState
screen <- js_getCodeWorldContext (canvasFromElement canvas)
let go t0 lastFrame = do
gs <- readMVar currentGameState
let pic = gameDraw stepHandler drawHandler gs t0
picFrame <- makeStableName $! pic
when (picFrame /= lastFrame) $ do
rect <- getBoundingClientRect canvas
buffer <- setupScreenContext (elementFromCanvas offscreenCanvas)
rect
drawFrame buffer pic
Canvas.restore buffer
rect <- getBoundingClientRect canvas
cw <- ClientRect.getWidth rect
ch <- ClientRect.getHeight rect
js_canvasDrawImage screen (elementFromCanvas offscreenCanvas)
0 0 (round cw) (round ch)
t1 <- nextFrame
modifyMVar_ currentGameState $ return . gameStep stepHandler t1
go t1 picFrame
t0 <- getTime
nullFrame <- makeStableName undefined
initialStateName <- makeStableName $! initialGameState
go t0 nullFrame
run :: s -> (Double -> s -> s) -> (Event -> s -> s) -> (s -> Picture) -> IO ()
run initial stepHandler eventHandler drawHandler = do
Just window <- currentWindow
Just doc <- currentDocument
Just canvas <- getElementById doc ("screen" :: JSString)
offscreenCanvas <- Canvas.create 500 500
setCanvasSize canvas canvas
setCanvasSize (elementFromCanvas offscreenCanvas) canvas
on window resize $ do
liftIO $ setCanvasSize canvas canvas
liftIO $ setCanvasSize (elementFromCanvas offscreenCanvas) canvas
currentState <- newMVar initial
eventHappened <- newMVar ()
onEvents canvas $ \event -> do
changed <- modifyMVarIfNeeded currentState (return . eventHandler event)
when changed $ void $ tryPutMVar eventHappened ()
screen <- js_getCodeWorldContext (canvasFromElement canvas)
let go t0 lastFrame lastStateName needsTime = do
pic <- drawHandler <$> readMVar currentState
picFrame <- makeStableName $! pic
when (picFrame /= lastFrame) $ do
rect <- getBoundingClientRect canvas
buffer <- setupScreenContext (elementFromCanvas offscreenCanvas)
rect
drawFrame buffer pic
Canvas.restore buffer
rect <- getBoundingClientRect canvas
cw <- ClientRect.getWidth rect
ch <- ClientRect.getHeight rect
js_canvasDrawImage screen (elementFromCanvas offscreenCanvas)
0 0 (round cw) (round ch)
t1 <- if
| needsTime -> do
t1 <- nextFrame
let dt = min (t1 t0) 0.25
modifyMVar_ currentState (return . stepHandler dt)
return t1
| otherwise -> do
takeMVar eventHappened
getTime
nextState <- readMVar currentState
nextStateName <- makeStableName $! nextState
nextNeedsTime <- if
| nextStateName /= lastStateName -> return True
| not needsTime -> return False
| otherwise -> not <$> isUniversallyConstant stepHandler nextState
go t1 picFrame nextStateName nextNeedsTime
t0 <- getTime
nullFrame <- makeStableName undefined
initialStateName <- makeStableName $! initial
go t0 nullFrame initialStateName True
#else
fromButtonNum :: Int -> Maybe MouseButton
fromButtonNum 1 = Just LeftButton
fromButtonNum 2 = Just MiddleButton
fromButtonNum 3 = Just RightButton
fromButtonNum _ = Nothing
getMousePos :: (Int, Int) -> (Double, Double) -> (Double, Double)
getMousePos (w,h) (x,y) = ((x fromIntegral w / 2)/s, (y fromIntegral h / 2)/s)
where
s = min (realToFrac w / 20) (realToFrac h / 20)
toEvent :: (Int, Int) -> Canvas.Event -> Maybe Event
toEvent rect Canvas.Event {..}
| eType == "keydown"
, Just code <- eWhich
= Just $ KeyPress (keyCodeToText (fromIntegral code))
| eType == "keyup"
, Just code <- eWhich
= Just $ KeyRelease (keyCodeToText (fromIntegral code))
| eType == "mousedown"
, Just button <- eWhich >>= fromButtonNum
, Just pos <- getMousePos rect <$> ePageXY
= Just $ MousePress button pos
| eType == "mouseup"
, Just button <- eWhich >>= fromButtonNum
, Just pos <- getMousePos rect <$> ePageXY
= Just $ MouseRelease button pos
| eType == "mousemove"
, Just pos <- getMousePos rect <$> ePageXY
= Just $ MouseMovement pos
| otherwise
= Nothing
onEvents :: Canvas.DeviceContext -> (Int, Int) -> (Event -> IO ()) -> IO ()
onEvents context rect handler = void $ forkIO $ forever $ do
maybeEvent <- toEvent rect <$> Canvas.wait context
case maybeEvent of
Nothing -> return ()
Just event -> handler event
run :: s -> (Double -> s -> s) -> (Event -> s -> s) -> (s -> Picture) -> IO ()
run initial stepHandler eventHandler drawHandler = runBlankCanvas $ \context -> do
let rect = (Canvas.width context, Canvas.height context)
offscreenCanvas <- Canvas.send context $ Canvas.newCanvas rect
currentState <- newMVar initial
eventHappened <- newMVar ()
onEvents context rect $ \event -> do
modifyMVar_ currentState (return . eventHandler event)
tryPutMVar eventHappened ()
return ()
let go t0 lastFrame lastStateName needsTime = do
pic <- drawHandler <$> readMVar currentState
picFrame <- makeStableName $! pic
when (picFrame /= lastFrame) $ do
Canvas.send context $ do
Canvas.with offscreenCanvas $
Canvas.saveRestore $ do
setupScreenContext rect
drawPicture initialDS pic
Canvas.drawImageAt (offscreenCanvas, 0, 0)
t1 <- if
| needsTime -> do
tn <- getCurrentTime
threadDelay $ max 0 (50000 (round ((tn `diffUTCTime` t0) * 1000000)))
t1 <- getCurrentTime
let dt = realToFrac (t1 `diffUTCTime` t0)
modifyMVar_ currentState (return . stepHandler dt)
return t1
| otherwise -> do
takeMVar eventHappened
getCurrentTime
nextState <- readMVar currentState
nextStateName <- makeStableName $! nextState
nextNeedsTime <- if nextStateName == lastStateName
then not <$> isUniversallyConstant stepHandler nextState
else return True
go t1 picFrame nextStateName nextNeedsTime
t0 <- getCurrentTime
nullFrame <- makeStableName undefined
initialStateName <- makeStableName $! initial
go t0 nullFrame initialStateName True
getDeployHash :: IO Text
getDeployHash = error "game API unimplemented in stand-alone interface mode"
runGame :: GameToken
-> Int
-> (StdGen -> s)
-> (Double -> s -> s)
-> (Int -> Event -> s -> s)
-> (Int -> s -> Picture)
-> IO ()
runGame = error "game API unimplemented in stand-alone interface mode"
#endif
unsafeCollaborationOf numPlayers initial step event draw = do
dhash <- getDeployHash
let token = PartialToken dhash
runGame token numPlayers initial step event draw `catch` reportError
where token = NoToken
collaborationOf numPlayers initial step event draw = do
dhash <- getDeployHash
let token = FullToken {
tokenDeployHash = dhash,
tokenNumPlayers = numPlayers,
tokenInitial = staticKey initial,
tokenStep = staticKey step,
tokenEvent = staticKey event,
tokenDraw = staticKey draw
}
runGame token numPlayers (deRefStaticPtr initial) (deRefStaticPtr step)
(deRefStaticPtr event) (deRefStaticPtr draw)
interactionOf initial step event draw =
run initial step event draw `catch` reportError
data Wrapped a = Wrapped {
state :: a,
paused :: Bool,
mouseMovedTime :: Double
} deriving Show
data Control :: * -> * where
PlayButton :: Control a
PauseButton :: Control a
StepButton :: Control a
RestartButton :: Control Double
BackButton :: Control Double
TimeLabel :: Control Double
wrappedStep :: (Double -> a -> a) -> Double -> Wrapped a -> Wrapped a
wrappedStep f dt w = w {
state = if paused w then state w else f dt (state w),
mouseMovedTime = mouseMovedTime w + dt
}
wrappedEvent :: (Wrapped a -> [Control a])
-> (Double -> a -> a)
-> Event -> Wrapped a -> Wrapped a
wrappedEvent _ _ (MouseMovement _) w
= w { mouseMovedTime = 0 }
wrappedEvent ctrls f (MousePress LeftButton p) w
= (foldr (handleControl f p) w (ctrls w)) { mouseMovedTime = 0 }
wrappedEvent _ _ _ w = w
handleControl :: (Double -> a -> a)
-> Point
-> Control a
-> Wrapped a
-> Wrapped a
handleControl _ (x,y) RestartButton w
| 9.4 < x && x < 8.6 && 9.4 < y && y < 8.6
= w { state = 0 }
handleControl _ (x,y) PlayButton w
| 8.4 < x && x < 7.6 && 9.4 < y && y < 8.6
= w { paused = False }
handleControl _ (x,y) PauseButton w
| 8.4 < x && x < 7.6 && 9.4 < y && y < 8.6
= w { paused = True }
handleControl _ (x,y) BackButton w
| 7.4 < x && x < 6.6 && 9.4 < y && y < 8.6
= w { state = max 0 (state w 0.1) }
handleControl f (x,y) StepButton w
| 6.4 < x && x < 5.6 && 9.4 < y && y < 8.6
= w { state = f 0.1 (state w) }
handleControl _ _ _ w = w
wrappedDraw :: (Wrapped a -> [Control a])
-> (a -> Picture)
-> Wrapped a -> Picture
wrappedDraw ctrls f w = drawControlPanel ctrls w <> f (state w)
drawControlPanel :: (Wrapped a -> [Control a]) -> Wrapped a -> Picture
drawControlPanel ctrls w
| alpha > 0 = pictures [ drawControl w alpha c | c <- ctrls w ]
| otherwise = blank
where alpha | mouseMovedTime w < 4.5 = 1
| mouseMovedTime w < 5.0 = 10 2 * mouseMovedTime w
| otherwise = 0
drawControl :: Wrapped a -> Double -> Control a -> Picture
drawControl _ alpha RestartButton = translated (9) (9) p
where p = colored (RGBA 0 0 0 alpha)
(thickArc 0.1 (pi / 6) (11 * pi / 6) 0.2 <>
translated 0.173 (0.1) (solidRectangle 0.17 0.17))
<> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8)
<> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)
drawControl _ alpha PlayButton = translated (8) (9) p
where p = colored (RGBA 0 0 0 alpha)
(solidPolygon [ (0.2, 0.25), (0.2, 0.25), (0.2, 0) ])
<> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8)
<> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)
drawControl _ alpha PauseButton = translated (8) (9) p
where p = colored (RGBA 0 0 0 alpha)
(translated (0.15) 0 (solidRectangle 0.2 0.6) <>
translated ( 0.15) 0 (solidRectangle 0.2 0.6))
<> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8)
<> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)
drawControl _ alpha BackButton = translated (7) (9) p
where p = colored (RGBA 0 0 0 alpha)
(translated 0.15 0 (solidRectangle 0.2 0.5) <>
solidPolygon [ (0.05, 0.25), (0.05, 0.25), (0.3, 0) ])
<> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8)
<> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)
drawControl _ alpha StepButton = translated (6) (9) p
where p = colored (RGBA 0 0 0 alpha)
(translated (0.15) 0 (solidRectangle 0.2 0.5) <>
solidPolygon [ (0.05, 0.25), (0.05, 0.25), (0.3, 0) ])
<> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8)
<> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)
drawControl w alpha TimeLabel = translated (8) (9) p
where p = colored (RGBA 0 0 0 alpha)
(scaled 0.5 0.5 $
text (pack (showFFloatAlt (Just 4) (state w) "s")))
<> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 3.0 0.8)
<> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 3.0 0.8)
animationControls :: Wrapped Double -> [Control Double]
animationControls w
| mouseMovedTime w > 5 = []
| paused w && state w > 0 = [ RestartButton, PlayButton, StepButton,
BackButton, TimeLabel ]
| paused w = [ RestartButton, PlayButton, StepButton,
TimeLabel ]
| otherwise = [ RestartButton, PauseButton, TimeLabel ]
animationOf f =
interactionOf initial
(wrappedStep (+))
(wrappedEvent animationControls (+))
(wrappedDraw animationControls f)
where initial = Wrapped {
state = 0,
paused = False,
mouseMovedTime = 1000
}
simulationControls :: Wrapped w -> [Control w]
simulationControls w
| mouseMovedTime w > 5 = []
| paused w = [ PlayButton, StepButton ]
| otherwise = [ PauseButton ]
simulationOf simInitial simStep simDraw =
interactionOf initial
(wrappedStep simStep)
(wrappedEvent simulationControls simStep)
(wrappedDraw simulationControls simDraw)
where initial = Wrapped {
state = simInitial,
paused = False,
mouseMovedTime = 1000
}
#ifdef ghcjs_HOST_OS
foreign import javascript unsafe "window.reportRuntimeError($1, $2);"
js_reportRuntimeError :: Bool -> JSString -> IO ()
trace msg x = unsafePerformIO $ do
js_reportRuntimeError False (textToJSString msg)
return x
reportError :: SomeException -> IO ()
reportError e = js_reportRuntimeError True (textToJSString (pack (show e)))
foreign import javascript "/[&?]dhash=(.{22})/.exec(window.location.search)[1]"
js_deployHash :: IO JSVal
getDeployHash :: IO Text
getDeployHash = pFromJSVal <$> js_deployHash
#else
trace = Debug.Trace.trace . T.unpack
reportError :: SomeException -> IO ()
reportError e = hPrint stderr e
#endif