codeworld-api 0.2.0.0 → 0.2.1.0
raw patch · 6 files changed
+779/−136 lines, 6 filesdep +cerealdep +cereal-textdep +codeworld-game-apidep ~blank-canvasdep ~mtldep ~randomPVP ok
version bump matches the API change (PVP)
Dependencies added: cereal, cereal-text, codeworld-game-api, codeworld-prediction, containers, ghcjs-prim, hashable
Dependency ranges changed: blank-canvas, mtl, random, text, time
API changes (from Hackage documentation)
+ CodeWorld: collaborationOf :: Int -> StaticPtr (StdGen -> world) -> StaticPtr (Double -> world -> world) -> StaticPtr (Int -> Event -> world -> world) -> StaticPtr (Int -> world -> Picture) -> IO ()
+ CodeWorld: unsafeCollaborationOf :: Int -> (StdGen -> world) -> (Double -> world -> world) -> (Int -> Event -> world -> world) -> (Int -> world -> Picture) -> IO ()
Files
- codeworld-api.cabal +17/−8
- src/CodeWorld.hs +2/−0
- src/CodeWorld/CollaborationUI.hs +243/−0
- src/CodeWorld/Driver.hs +501/−112
- src/CodeWorld/Event.hs +3/−2
- src/CodeWorld/Picture.hs +13/−14
codeworld-api.cabal view
@@ -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
src/CodeWorld.hs view
@@ -20,6 +20,8 @@ animationOf, simulationOf, interactionOf,+ collaborationOf,+ unsafeCollaborationOf, -- * Pictures Picture,
+ src/CodeWorld/CollaborationUI.hs view
@@ -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++++
src/CodeWorld/Driver.hs view
@@ -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
src/CodeWorld/Event.hs view
@@ -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)
src/CodeWorld/Picture.hs view
@@ -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