diff --git a/codeworld-api.cabal b/codeworld-api.cabal --- a/codeworld-api.cabal +++ b/codeworld-api.cabal @@ -1,5 +1,5 @@ Name: codeworld-api -Version: 0.2.0.0 +Version: 0.2.1.0 Synopsis: Graphics library for CodeWorld License: Apache License-file: LICENSE @@ -25,17 +25,26 @@ CodeWorld.Picture, CodeWorld.Event, CodeWorld.Driver - Build-depends: base < 5, - mtl, - random, - text, - time + CodeWorld.CollaborationUI + Build-depends: base >= 4.8 && < 5, + containers >= 0.5.7 && < 0.6, + hashable >= 1.2.4 && < 1.3, + text >= 1.2.2 && < 1.3, + mtl >= 2.2.1 && < 2.3, + time >= 1.6.0 && < 1.7, + random >= 1.1 && < 1.2, + cereal >= 0.5.4 && < 0.6, + cereal-text >= 0.1.0 && < 0.2 + if impl(ghcjs) Build-depends: ghcjs-base, - ghcjs-dom + ghcjs-dom, + ghcjs-prim, + codeworld-game-api, + codeworld-prediction else - Build-depends: blank-canvas + Build-depends: blank-canvas >= 0.6 && < 0.7 Exposed: True Ghc-options: -O2 diff --git a/src/CodeWorld.hs b/src/CodeWorld.hs --- a/src/CodeWorld.hs +++ b/src/CodeWorld.hs @@ -20,6 +20,8 @@ animationOf, simulationOf, interactionOf, + collaborationOf, + unsafeCollaborationOf, -- * Pictures Picture, diff --git a/src/CodeWorld/CollaborationUI.hs b/src/CodeWorld/CollaborationUI.hs new file mode 100644 --- /dev/null +++ b/src/CodeWorld/CollaborationUI.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +{- + Copyright 2017 The CodeWorld Authors. All rights reserved. + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-} + +module CodeWorld.CollaborationUI + ( UIState + , SetupPhase(..) + , Step(..) + , initial + , step + , event + , picture + , startWaiting + , updatePlayers + ) where + +import CodeWorld.Color +import CodeWorld.Picture +import CodeWorld.Event + +import Data.Char +import qualified Data.Text as T +import Data.Text (Text) +import Data.Monoid + +-- | The enumeration type contains all the high-level states that the game UI +-- can be in. It is used as a type-index to 'UIState' to ensure that the UI +-- state matches the abstract state. +-- +-- The possible UI-triggered transitions of this state are described by +-- 'Step'. +data SetupPhase = SMain | SConnect | SWait + + +-- | Possible steps taken from a given setup phase +data family Step :: (SetupPhase -> *) -> SetupPhase -> * +data instance Step f SMain + = ContinueMain (f SMain) + | Create (f SConnect) + | Join Text (f SConnect) +data instance Step f SConnect + = ContinueConnect (f SConnect) + | CancelConnect (f SMain) +data instance Step f SWait + = ContinueWait (f SWait) + | CancelWait (f SMain) + +-- | The UI state, indexed by the 'SetupPhase' +data UIState (s :: SetupPhase) where + MainMenu :: Double -> Point + -> UIState SMain + Joining :: Double -> Point + -> Text + -> UIState SMain + Connecting :: Double + -> Point + -> UIState SConnect + Waiting :: Double -> Point + -> Text -> {- numPlayers :: -} Int -> {- present -} Int + -> UIState SWait + +continueUIState :: UIState s -> Step UIState s +continueUIState s@(MainMenu {}) = ContinueMain s +continueUIState s@(Joining {}) = ContinueMain s +continueUIState s@(Connecting {}) = ContinueConnect s +continueUIState s@(Waiting {}) = ContinueWait s + + +time :: UIState s -> Double +time (MainMenu t _) = t +time (Joining t _ _) = t +time (Connecting t _) = t +time (Waiting t _ _ _ _) = t + +mousePos :: UIState s -> Point +mousePos (MainMenu _ p) = p +mousePos (Joining _ p _) = p +mousePos (Connecting _ p) = p +mousePos (Waiting _ p _ _ _) = p + +-- Takes an absolute time, not a delta. A bit easier. +step :: Double -> UIState s -> UIState s +step t (MainMenu _ p) = MainMenu t p +step t (Joining _ p c) = Joining t p c +step t (Connecting _ p) = Connecting t p +step t (Waiting _ p c n m) = Waiting t p c n m + +setMousePos :: Point -> UIState s -> UIState s +setMousePos p (MainMenu t _) = MainMenu t p +setMousePos p (Joining t _ c) = Joining t p c +setMousePos p (Connecting t _) = Connecting t p +setMousePos p (Waiting t _ c n m) = Waiting t p c n m + + +initial :: UIState SMain +initial = MainMenu 0 (0,0) + +startWaiting :: Text -> UIState a -> UIState SWait +startWaiting code s = Waiting (time s) (mousePos s) code 0 0 + +updatePlayers :: Int -> Int -> UIState SWait -> UIState SWait +updatePlayers n m (Waiting time mousePos code _ _) + = Waiting time mousePos code n m + +-- | Handling a UI event. May change the phase. +event :: Event -> UIState s -> Step UIState s +event (MouseMovement p) s = continueUIState (setMousePos p s) +event CreateClick (MainMenu t p) = Create (Connecting t p) +event JoinClick (MainMenu t p) = ContinueMain (Joining t p "") +event (LetterPress k) (Joining t p code) | T.length code < 4 = ContinueMain (Joining t p (code <> k)) +event BackSpace (Joining t p code) | T.length code > 0 = ContinueMain (Joining t p (T.init code)) +event ConnectClick (Joining t p code) | T.length code == 4 = Join code (Connecting t p) +event CancelClick (Joining t p code) = ContinueMain (MainMenu t p) +event CancelClick (Connecting t p) = CancelConnect (MainMenu t p) +event CancelClick (Waiting t p c n m) = CancelWait (MainMenu t p) +event _ s = continueUIState s + +pattern CreateClick <- MousePress LeftButton (inButton 0 ( 1.5) 8 2 -> True) +pattern JoinClick <- MousePress LeftButton (inButton 0 (-1.5) 8 2 -> True) +pattern ConnectClick <- MousePress LeftButton (inButton 0 (- 3) 8 2 -> True) +pattern LetterPress c <- (isLetterPress -> Just c) +pattern BackSpace <- KeyPress "Backspace" +pattern CancelClick <- (isCancelClick -> True) + +isLetterPress :: Event -> Maybe Text +isLetterPress (KeyPress k) | T.length k == 1, isLetter (T.head k) = Just (T.toUpper k) +isLetterPress _ = Nothing + +isCancelClick :: Event -> Bool +isCancelClick (KeyPress "Esc") = True +isCancelClick (MousePress LeftButton point) = inButton 0 (-3) 8 2 point +isCancelClick _ = False + + +picture :: UIState s -> Picture +picture (MainMenu time mousePos) + = button "New" (dull green) 0 ( 1.5) 8 2 mousePos + & button "Join" (dull green) 0 (-1.5) 8 2 mousePos + & connectScreen "Main Menu" time + +picture (Joining time mousePos code) + = translated 0 2 (text "Enter the game key:") + & letterBoxes white code + & (if T.length code < 4 + then button "Cancel" (dull yellow) 0 (-3) 8 2 mousePos + else button "Join" (dull green) 0 (-3) 8 2 mousePos) + & connectScreen "Join Game" time + +picture (Connecting time mousePos) + = button "Cancel" (dull yellow) 0 (-3) 8 2 mousePos + & connectScreen "Connecting..." time + +picture (Waiting time mousePos code numPlayers present) + = translated 0 2 (text "Share this key with other players:") + & translated 0 4 (playerDots numPlayers present) + & letterBoxes (gray 0.8) code + & button "Cancel" (dull yellow) 0 (-3) 8 2 mousePos + & connectScreen "Waiting" time + +letterBoxes :: Color -> Text -> Picture +letterBoxes color txt = pictures + [ translated x 0 (letterBox color (T.singleton c)) + | c <- pad 4 ' ' (take 4 (T.unpack txt)) + | x <- [-3, -1, 1, 3] ] + +letterBox :: Color -> Text -> Picture +letterBox c t = thickRectangle 0.1 1.5 1.5 + & text t + & colored c (solidRectangle 1.5 1.5) + +pad :: Int -> a -> [a] -> [a] +pad 0 _ xs = xs +pad n v (x:xs) = x : pad (n - 1) v xs +pad n v [] = v : pad (n - 1) v [] + +inButton :: Double -> Double -> Double -> Double -> Point -> Bool +inButton x y w h (mx, my) = + mx >= x - w / 2 && + mx <= x + w / 2 && + my >= y - h / 2 && + my <= y + h / 2 + +button :: Text -> Color -> Double -> Double -> Double -> Double -> Point -> Picture +button txt btnColor x y w h (mx, my) = translated x y $ + colored white (styledText Plain SansSerif txt) & + colored color (roundRect w h) + where color | inButton x y w h (mx, my) = btnColor + | otherwise = dark btnColor + +roundRect :: Double -> Double -> Picture +roundRect w h = solidRectangle w (h - 0.5) + & solidRectangle (w - 0.5) h + & pictures [ translated x y (solidCircle 0.25) + | x <- [ -w / 2 + 0.25, w / 2 - 0.25 ] + , y <- [ -h / 2 + 0.25, h / 2 - 0.25 ] ] + +playerDots n m | n > 8 = text $ T.pack $ show m ++" / "++ show n +playerDots n m = pictures + [ translated (size*fromIntegral i - size*fromIntegral n/2) 0 (dot (i <= m)) + | i <- [1..n] + ] + where dot True = solidCircle (0.4*size) + dot False = circle (0.4*size) + size = 1 + + + +connectScreen :: Text -> Double -> Picture +connectScreen hdr t = translated 0 7 connectBox + & translated 0 (-7) codeWorldLogo + & colored (RGBA 0.85 0.86 0.9 1) (solidRectangle 20 20) + where + connectBox = scaled 2 2 (text hdr) + & rectangle 14 3 + & colored connectColor (solidRectangle 14 3) + connectColor = let k = (1 + sin (3 * t)) / 5 + in fromHSL (k + 0.5) 0.8 0.7 + + + + diff --git a/src/CodeWorld/Driver.hs b/src/CodeWorld/Driver.hs --- a/src/CodeWorld/Driver.hs +++ b/src/CodeWorld/Driver.hs @@ -1,11 +1,18 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE JavaScriptFFI #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DataKinds #-} {- Copyright 2016 The CodeWorld Authors. All rights reserved. @@ -28,33 +35,52 @@ 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 (mapMaybe) +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 @@ -63,13 +89,16 @@ 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 -import System.Random #else @@ -82,11 +111,10 @@ #endif - -------------------------------------------------------------------------------- -- The common interface, provided by both implementations below. --- | Draws a `Picture`. This is the simplest CodeWorld entry point. +-- | Draws a 'Picture'. This is the simplest CodeWorld entry point. drawingOf :: Picture -> IO () -- | Shows an animation, with a picture for each time given by the parameter. @@ -96,21 +124,38 @@ -- system described by an initial value and step function. simulationOf :: world -> (Double -> world -> world) -> (world -> Picture) -> IO () --- | Runs an interactive event-driven CodeWorld program. This is the most --- advanced CodeWorld entry point. +-- | Runs an interactive event-driven CodeWorld program. This is a +-- generalization of simulations that can respond to events like key presses +-- and mouse movement. interactionOf :: world -> (Double -> world -> world) -> (Event -> world -> world) -> (world -> Picture) -> IO () +-- | Runs an interactive multi-user CodeWorld program, involving multiple +-- participants over the internet. +collaborationOf :: Int + -> StaticPtr (StdGen -> world) + -> StaticPtr (Double -> world -> world) + -> StaticPtr (Int -> Event -> world -> world) + -> StaticPtr (Int -> world -> Picture) + -> IO () + +-- | A version of 'collaborationOf' that avoids static pointers, and does not +-- check for consistent parameters. +unsafeCollaborationOf :: Int + -> (StdGen -> world) + -> (Double -> world -> world) + -> (Int -> Event -> world -> world) + -> (Int -> world -> Picture) + -> IO () + -- | Prints a debug message to the CodeWorld console when a value is forced. -- This is equivalent to the similarly named function in `Debug.Trace`, except -- that it uses the CodeWorld console instead of standard output. trace :: Text -> a -> a - - -------------------------------------------------------------------------------- -- Draw state. An affine transformation matrix, plus a Bool indicating whether -- a color has been chosen yet. @@ -154,13 +199,21 @@ 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 @@ -334,7 +387,7 @@ setCanvasSize :: Element -> Element -> IO () setCanvasSize target canvas = do - Just rect <- getBoundingClientRect canvas + rect <- getBoundingClientRect canvas cx <- ClientRect.getWidth rect cy <- ClientRect.getHeight rect setAttribute target ("width" :: JSString) (show (round cx)) @@ -345,12 +398,12 @@ Just window <- currentWindow Just doc <- currentDocument Just canvas <- getElementById doc ("screen" :: JSString) - on window Window.resize $ liftIO (draw canvas) + on window resize $ liftIO (draw canvas) draw canvas where draw canvas = do setCanvasSize canvas canvas - Just rect <- getBoundingClientRect canvas + rect <- getBoundingClientRect canvas ctx <- setupScreenContext canvas rect drawFrame ctx pic Canvas.restore ctx @@ -502,16 +555,23 @@ 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 - where - options = 3000 { Canvas.events = - [ "mousedown", "mouseup", "mousemove", "keydown", "keyup"] - } display :: Picture -> IO () display pic = runBlankCanvas $ \context -> @@ -523,29 +583,11 @@ drawingOf pic = display pic `catch` reportError #endif --------------------------------------------------------------------------------- --- Common activity managing code - -data Activity = Activity { - activityStep :: Double -> Activity, - activityEvent :: Event -> Activity, - activityDraw :: Picture - } - -handleEvent :: Event -> MVar Activity -> IO () -handleEvent event activity = - modifyMVar_ activity $ \a0 -> return (activityEvent a0 event) - -passTime :: Double -> MVar Activity -> IO Activity -passTime dt activity = modifyMVar activity $ \a0 -> do - let a1 = activityStep a0 (realToFrac (min dt 0.25)) - return (a1, a1) - -------------------------------------------------------------------------------- --- Common event handling code +-- Common event handling and core interaction code -keyCodeToText :: Int -> Text +keyCodeToText :: Word -> Text keyCodeToText n = case n of _ | n >= 47 && n <= 90 -> fromAscii n _ | n >= 96 && n <= 105 -> fromNum (n - 96) @@ -596,10 +638,49 @@ 221 -> "]" 222 -> "'" _ -> "Unknown:" <> fromNum n - where fromAscii n = singleton (chr 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 + -------------------------------------------------------------------------------- -- GHCJS event handling and core interaction code @@ -609,7 +690,7 @@ getMousePos canvas = do (ix, iy) <- mouseClientXY liftIO $ do - Just rect <- getBoundingClientRect canvas + rect <- getBoundingClientRect canvas cx <- ClientRect.getLeft rect cy <- ClientRect.getTop rect cw <- ClientRect.getWidth rect @@ -623,44 +704,221 @@ fromButtonNum 2 = Just RightButton fromButtonNum _ = Nothing -setupEvents :: MVar Activity -> Element -> Element -> IO () -setupEvents currentActivity canvas offscreen = do +onEvents :: Element -> (Event -> IO ()) -> IO () +onEvents canvas handler = do Just window <- currentWindow - on window Window.keyDown $ do + on window keyDown $ do code <- uiKeyCode let keyName = keyCodeToText code when (keyName /= "") $ do - liftIO $ handleEvent (KeyPress keyName) currentActivity + liftIO $ handler (KeyPress keyName) preventDefault stopPropagation - on window Window.keyUp $ do + on window keyUp $ do code <- uiKeyCode let keyName = keyCodeToText code when (keyName /= "") $ do - liftIO $ handleEvent (KeyRelease keyName) currentActivity + liftIO $ handler (KeyRelease keyName) preventDefault stopPropagation - on window Window.mouseDown $ do + on window mouseDown $ do button <- mouseButton case fromButtonNum button of Nothing -> return () Just btn -> do pos <- getMousePos canvas - liftIO $ handleEvent (MousePress btn pos) currentActivity - on window Window.mouseUp $ do + liftIO $ handler (MousePress btn pos) + on window mouseUp $ do button <- mouseButton case fromButtonNum button of Nothing -> return () Just btn -> do pos <- getMousePos canvas - liftIO $ handleEvent (MouseRelease btn pos) currentActivity - on window Window.mouseMove $ do + liftIO $ handler (MouseRelease btn pos) + on window mouseMove $ do pos <- getMousePos canvas - liftIO $ handleEvent (MouseMovement pos) currentActivity + liftIO $ handler (MouseMovement pos) return () -run :: Activity -> IO () -run startActivity = do +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 + +-- It's worth trying to keep the canonical animation rate exactly representable +-- as a float, to minimize the chance of divergence due to rounding error. +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 -- might be a ping (Nothing) + result | ours = s -- we already took care of our events + | 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) @@ -668,35 +926,104 @@ setCanvasSize canvas canvas setCanvasSize (elementFromCanvas offscreenCanvas) canvas - on window Window.resize $ do + on window resize $ do liftIO $ setCanvasSize canvas canvas liftIO $ setCanvasSize (elementFromCanvas offscreenCanvas) canvas - currentActivity <- newMVar startActivity - setupEvents currentActivity canvas (elementFromCanvas offscreenCanvas) + currentGameState <- newMVar initialGameState + onEvents canvas $ gameHandle numPlayers initial stepHandler eventHandler token currentGameState + screen <- js_getCodeWorldContext (canvasFromElement canvas) - let go t0 a0 = do - Just rect <- getBoundingClientRect canvas - buffer <- setupScreenContext (elementFromCanvas offscreenCanvas) rect - drawFrame buffer (activityDraw a0) - Canvas.restore buffer + 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 - t1 <- waitForAnimationFrame + rect <- getBoundingClientRect canvas + cw <- ClientRect.getWidth rect + ch <- ClientRect.getHeight rect + js_canvasDrawImage screen (elementFromCanvas offscreenCanvas) + 0 0 (round cw) (round ch) - Just rect <- getBoundingClientRect canvas - cw <- ClientRect.getWidth rect - ch <- ClientRect.getHeight rect + t1 <- nextFrame + modifyMVar_ currentGameState $ return . gameStep stepHandler t1 + go t1 picFrame - Canvas.clearRect 0 0 (realToFrac cw) (realToFrac ch) screen - js_canvasDrawImage screen (elementFromCanvas offscreenCanvas) 0 0 (round cw) (round ch) - a1 <- passTime ((t1 - t0) / 1000) currentActivity - go t1 a1 + t0 <- getTime + nullFrame <- makeStableName undefined + initialStateName <- makeStableName $! initialGameState + go t0 nullFrame - t0 <- waitForAnimationFrame - go t0 startActivity `catch` reportError +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 + -------------------------------------------------------------------------------- -- Stand-Alone event handling and core interaction code @@ -717,10 +1044,10 @@ toEvent rect Canvas.Event {..} | eType == "keydown" , Just code <- eWhich - = Just $ KeyPress (keyCodeToText code) + = Just $ KeyPress (keyCodeToText (fromIntegral code)) | eType == "keyup" , Just code <- eWhich - = Just $ KeyRelease (keyCodeToText code) + = Just $ KeyRelease (keyCodeToText (fromIntegral code)) | eType == "mousedown" , Just button <- eWhich >>= fromButtonNum , Just pos <- getMousePos rect <$> ePageXY @@ -735,55 +1062,109 @@ | otherwise = Nothing -run :: Activity -> IO () -run startActivity = runBlankCanvas $ \context -> do - let rect = (Canvas.width context, Canvas.height context) +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 - currentActivity <- newMVar startActivity + currentState <- newMVar initial + eventHappened <- newMVar () - let go t0 a0 = do - Canvas.send context $ - Canvas.with offscreenCanvas $ - Canvas.saveRestore $ do - setupScreenContext rect - drawPicture initialDS (activityDraw a0) - tn <- getCurrentTime + onEvents context rect $ \event -> do + modifyMVar_ currentState (return . eventHandler event) + tryPutMVar eventHappened () + return () - threadDelay $ max 0 (50000 - (round ((tn `diffUTCTime` t0) * 1000000))) - t1 <- getCurrentTime + 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) - Canvas.send context $ Canvas.drawImageAt (offscreenCanvas, 0, 0) - a1 <- passTime (realToFrac (t1 `diffUTCTime` t0)) currentActivity + 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 - -- Handle events now - events <- mapMaybe (toEvent rect) <$> Canvas.flush context - mapM_ (\e -> handleEvent e currentActivity) events + nextState <- readMVar currentState + nextStateName <- makeStableName $! nextState + nextNeedsTime <- if nextStateName == lastStateName + then not <$> isUniversallyConstant stepHandler nextState + else return True - go t1 a1 + go t1 picFrame nextStateName nextNeedsTime t0 <- getCurrentTime - go t0 startActivity `catch` reportError + 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 + -------------------------------------------------------------------------------- +-- Common code for game interface + +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) + +-------------------------------------------------------------------------------- -- Common code for interaction, animation and simulation interfaces -interactionOf initial step event draw = go `catch` reportError - where go = run (activity initial) - activity x = Activity { - activityStep = (\dt -> activity (step dt x)), - activityEvent = (\ev -> activity (event ev x)), - activityDraw = draw x - } +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 @@ -822,12 +1203,12 @@ handleControl _ (x,y) PauseButton w | -8.4 < x && x < -7.6 && -9.4 < y && y < -8.6 = w { paused = True } -handleControl f (x,y) StepButton w - | -7.4 < x && x < -6.6 && -9.4 < y && y < -8.6 - = w { state = f 0.1 (state w) } handleControl _ (x,y) BackButton w - | -6.4 < x && x < -5.6 && -9.4 < y && y < -8.6 + | -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]) @@ -836,7 +1217,9 @@ wrappedDraw ctrls f w = drawControlPanel ctrls w <> f (state w) drawControlPanel :: (Wrapped a -> [Control a]) -> Wrapped a -> Picture -drawControlPanel ctrls w = pictures [ drawControl w alpha c | c <- ctrls w ] +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 @@ -862,17 +1245,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 StepButton = translated (-7) (-9) p +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) ]) + (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 BackButton = translated (-6) (-9) p +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) ]) + (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) @@ -934,6 +1317,12 @@ 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 -------------------------------------------------------------------------------- --- Stand-alone implementation of tracing and error handling diff --git a/src/CodeWorld/Event.hs b/src/CodeWorld/Event.hs --- a/src/CodeWorld/Event.hs +++ b/src/CodeWorld/Event.hs @@ -14,6 +14,7 @@ limitations under the License. -} +{-# LANGUAGE DeriveGeneric #-} module CodeWorld.Event where import CodeWorld.Picture (Point) @@ -59,6 +60,6 @@ | MousePress !MouseButton !Point | MouseRelease !MouseButton Point | MouseMovement !Point - deriving (Eq, Show) + deriving (Eq, Show, Read) -data MouseButton = LeftButton | MiddleButton | RightButton deriving (Eq, Show) +data MouseButton = LeftButton | MiddleButton | RightButton deriving (Eq, Show, Read) diff --git a/src/CodeWorld/Picture.hs b/src/CodeWorld/Picture.hs --- a/src/CodeWorld/Picture.hs +++ b/src/CodeWorld/Picture.hs @@ -121,11 +121,11 @@ -- | A thin circle, with this radius circle :: Double -> Picture -circle = arc 0 360 +circle = arc 0 (2*pi) -- | A thick circle, with this line width and radius thickCircle :: Double -> Double -> Picture -thickCircle w = thickArc w 0 360 +thickCircle w = thickArc w 0 (2*pi) -- | A thin arc, starting and ending at these angles, with this radius -- @@ -142,7 +142,7 @@ -- | A solid circle, with this radius solidCircle :: Double -> Picture -solidCircle = sector 0 360 +solidCircle = sector 0 (2*pi) -- | A solid sector of a circle (i.e., a pie slice) starting and ending at these -- angles, with this radius @@ -162,9 +162,9 @@ colored :: Color -> Picture -> Picture colored = Color --- | A picture drawn entirely in this color. +-- | A picture drawn entirely in this colour. coloured :: Color -> Picture -> Picture -coloured = Color +coloured = colored -- | A picture drawn translated in these directions. translated :: Double -> Double -> Picture -> Picture @@ -176,7 +176,7 @@ -- | A picture scaled by these factors. dilated :: Double -> Double -> Picture -> Picture -dilated = Scale +dilated = scaled -- | A picture rotated by this angle. -- @@ -189,10 +189,10 @@ pictures = Pictures instance Monoid Picture where - mempty = blank - mappend a (Pictures bs) = Pictures (a:bs) - mappend a b = Pictures [a, b] - mconcat = pictures + mempty = blank + mappend a (Pictures bs) = Pictures (a:bs) + mappend a b = Pictures [a, b] + mconcat = pictures -- | Binary composition of pictures. (&) :: Picture -> Picture -> Picture @@ -208,11 +208,10 @@ -- myPicture = ... coordinatePlane :: Picture coordinatePlane = axes <> numbers <> guidelines - where xline y = path [(-10, y), (10, y)] - xaxis = colored (RGBA 0 0 0 0.75) (xline 0) + where xline y = thickPath 0.01 [(-10, y), (10, y)] + xaxis = thickPath 0.03 [(-10, 0), (10, 0)] axes = xaxis <> rotated (pi/2) xaxis - xguidelines = pictures - [colored (RGBA 0 0 0 0.25) (xline k) | k <- [-10, -9 .. 10]] + xguidelines = pictures [ xline k | k <- [-10, -9 .. 10] ] guidelines = xguidelines <> rotated (pi/2) xguidelines numbers = xnumbers <> ynumbers xnumbers = pictures