diff --git a/Graphics/Blank.hs b/Graphics/Blank.hs --- a/Graphics/Blank.hs +++ b/Graphics/Blank.hs @@ -12,11 +12,14 @@ , Canvas -- abstact , module Graphics.Blank.Generated , readEvent + , readEvents , tryReadEvent + , tryReadEvents , size -- * Events , Event(..) , EventName(..) + , NamedEvent(..) , EventQueue , readEventQueue , tryReadEventQueue @@ -34,6 +37,7 @@ import qualified Data.Text.Lazy as T import qualified Data.Map as Map +import qualified Data.Set as Set import Graphics.Blank.Events import Graphics.Blank.Context @@ -75,8 +79,9 @@ newContext (w,h) = do uq <- getUniq picture <- newEmptyMVar - callbacks <- newMVar $ Map.empty - let cxt = Context (w,h) picture callbacks uq + callbacks <- newMVar $ Set.empty + queue <- newEventQueue + let cxt = Context (w,h) picture callbacks queue uq db <- takeMVar contextDB putMVar contextDB $ Map.insert uq cxt db -- Here is where we actually spawn the user code @@ -101,18 +106,13 @@ post "/event/:num" $ do addHeader "Cache-Control" "max-age=0, no-cache, private, no-store, must-revalidate" num <- param "num" --- liftIO $ print (num :: Int) - NamedEvent nm event <- jsonData + ne <- jsonData db <- liftIO $ readMVar contextDB case Map.lookup num db of Nothing -> json () - Just (Context _ _ callbacks _) -> do - db' <- liftIO $ readMVar callbacks --- liftIO $ print (nm,event) - case Map.lookup nm db' of - Nothing -> json () - Just var -> do liftIO $ writeEventQueue var event - json () + Just (Context _ _ _ q _) -> + do liftIO $ writeEventQueue q ne + json () get "/canvas/:num" $ do addHeader "Cache-Control" "max-age=0, no-cache, private, no-store, must-revalidate" @@ -136,14 +136,14 @@ db <- liftIO $ readMVar contextDB case Map.lookup num db of Nothing -> text (T.pack $ "alert('/canvas/, can not find " ++ show num ++ "');") - Just (Context _ pic _ _) -> tryPicture pic 10 + Just (Context _ pic _ _ _) -> tryPicture pic 10 run port app -- | Sends a set of Canvas commands to the canvas. Attempts -- to common up as many commands as possible. send :: Context -> Canvas a -> IO a -send cxt@(Context (h,w) _ _ _) commands = send' commands id +send cxt@(Context (h,w) _ _ _ _) commands = send' commands id where send' :: Canvas a -> (String -> String) -> IO a @@ -155,12 +155,13 @@ res <- send' other cmds send' (k res) id - send' (Get a op) cmds = do + send' (Get nms op) cmds = do -- clear the commands sendToCanvas cxt cmds - -- get the channel for this event - chan <- events cxt a - op chan + -- make sure these events are registered + register cxt nms + -- and apply the channel + op (eventQueue cxt) send' (Return a) cmds = do sendToCanvas cxt cmds diff --git a/Graphics/Blank/Canvas.hs b/Graphics/Blank/Canvas.hs --- a/Graphics/Blank/Canvas.hs +++ b/Graphics/Blank/Canvas.hs @@ -9,12 +9,14 @@ import Numeric data Canvas :: * -> * where - Command :: Command -> Canvas () - Bind :: Canvas a -> (a -> Canvas b) -> Canvas b - Return :: a -> Canvas a - Get :: EventName -> (EventQueue -> IO a) -> Canvas a - Size :: Canvas (Float,Float) + Command :: Command -> Canvas () + Bind :: Canvas a -> (a -> Canvas b) -> Canvas b + Return :: a -> Canvas a + Get :: [EventName] -> (EventQueue -> IO a) -> Canvas a + Size :: Canvas (Float,Float) + + instance Monad Canvas where return = Return (>>=) = Bind @@ -71,10 +73,34 @@ size = Size -- | read a specific event; wait for it if the event is not in queue. +-- **Thows away all other events while waiting.** readEvent :: EventName -> Canvas Event -readEvent nm = Get nm readEventQueue +readEvent nm = fmap (\ (NamedEvent _ e) -> e) (readEvents [nm]) --- | read a specific event; or return Nothing if the event is not in queue. +-- | read a specific set of events; wait for it if the event/events is not in queue. +-- **Throws away all other non-named events while waiting.** +readEvents :: [EventName] -> Canvas NamedEvent +readEvents nms = Get nms $ \ q -> do + let loop = do ne@(NamedEvent n _) <- readEventQueue q + if n `elem` nms + then return ne -- return if the event is one of the approved list + else loop + loop + +-- | read a specific event. **Throws away all events not named** tryReadEvent :: EventName -> Canvas (Maybe Event) -tryReadEvent nm = Get nm tryReadEventQueue +tryReadEvent nm = fmap (fmap (\ (NamedEvent _ e) -> e)) (tryReadEvents [nm]) + +-- | read a specific set of events. **Throws away all non-named events while waiting.** +tryReadEvents :: [EventName] -> Canvas (Maybe NamedEvent) +tryReadEvents nms = Get nms $ \ q -> do + let loop = do opt <- tryReadEventQueue q + case opt of + -- return if the event is one of the approved list + Just (NamedEvent n _) + | n `elem` nms -> return opt + | otherwise -> loop + Nothing -> return Nothing + loop + diff --git a/Graphics/Blank/Context.hs b/Graphics/Blank/Context.hs --- a/Graphics/Blank/Context.hs +++ b/Graphics/Blank/Context.hs @@ -1,8 +1,8 @@ module Graphics.Blank.Context where import Control.Concurrent -import qualified Data.Map as Map -import Data.Map (Map) +import qualified Data.Set as Set +import Data.Set (Set) import Data.Char import Graphics.Blank.Events @@ -11,24 +11,28 @@ data Context = Context { theSize :: (Float,Float) , theDraw :: MVar String - , eventHandle :: MVar (Map EventName EventQueue) + , eventRegs :: MVar (Set EventName) -- events that are registered + , eventQueue :: EventQueue -- now a single event queueMVar (Map EventName EventQueue) , sessionNo :: Int } --- | 'events' gets the raw event queue for a specific event type. -events :: Context -> EventName -> IO EventQueue -events cxt@(Context _ _ callbacks num) a = do - db <- takeMVar callbacks - case Map.lookup a db of - Just var -> do - putMVar callbacks db - return var - Nothing -> do - var <- newEventQueue - putMVar callbacks $ Map.insert a var db - sendToCanvas cxt (("register('" ++ map toLower (show a) ++ "'," ++ show num ++ ");") ++) - return var +-- 'events' gets a copy of the events Queue +events :: Context -> IO EventQueue +events = return . eventQueue + +-- | 'register' makes sure the named events are registered. +register :: Context -> [EventName] -> IO () +register cxt@(Context _ _ regs _ num) nms = do + db <- takeMVar regs + let new = Set.difference (Set.fromList nms) db + sequence_ [ sendToCanvas cxt (("register('" ++ map toLower (show nm) ++ "'," ++ show num ++ ");") ++) + | nm <- Set.toList new + ] + if Set.null new + then putMVar regs $ db + else putMVar regs $ (db `Set.union` new) + -- | internal command to send a message to the canvas. sendToCanvas :: Context -> ShowS -> IO () -sendToCanvas (Context _ var _ num) cmds = putMVar var $ "if (session == " ++ show num ++ "){var c = getContext();" ++ cmds "}" +sendToCanvas (Context _ var _ _ num) cmds = putMVar var $ "if (session == " ++ show num ++ "){var c = getContext();" ++ cmds "}" diff --git a/Graphics/Blank/Events.hs b/Graphics/Blank/Events.hs --- a/Graphics/Blank/Events.hs +++ b/Graphics/Blank/Events.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} module Graphics.Blank.Events ( -- * Events Event(..) @@ -11,11 +12,12 @@ , newEventQueue ) where -import Data.Aeson (FromJSON(..)) +import Data.Aeson (FromJSON(..), Value) import qualified Data.Map as Map import Data.Map (Map) import Data.Char import Control.Monad +import Control.Applicative((<|>)) import Control.Concurrent.STM -- | Basic Event from Browser, the code is event-type specific. @@ -31,14 +33,17 @@ instance FromJSON NamedEvent where parseJSON o = do - (str,code,x,y) <- parseJSON o + (str::String,_::Value,_::Value,_::Value) <- parseJSON o case Map.lookup str namedEventDB of - Just n -> return $ NamedEvent n (Event code (Just (x,y))) - Nothing -> do (str',code',(),()) <- parseJSON o - case Map.lookup str' namedEventDB of - Just n -> return $ NamedEvent n (Event code' Nothing) - Nothing -> fail "bad parse" + Just n -> fmap (NamedEvent n) (opt1 <|> opt2) + Nothing -> fail "bad parse" + where + opt1 = do (_::String,code,x,y) <- parseJSON o + return $ Event code (Just (x,y)) + opt2 = do (_::String,code,_::Value,_::Value) <- parseJSON o + return $ Event code Nothing + namedEventDB :: Map String EventName namedEventDB = Map.fromList [ (map toLower (show n),n) @@ -63,15 +68,15 @@ -- | EventQueue is a STM channel ('TChan') of 'Event's. -- Intentionally, 'EventQueue' is not abstract. -type EventQueue = TChan Event +type EventQueue = TChan NamedEvent -writeEventQueue :: EventQueue -> Event -> IO () +writeEventQueue :: EventQueue -> NamedEvent -> IO () writeEventQueue q e = atomically $ writeTChan q e -readEventQueue :: EventQueue -> IO Event +readEventQueue :: EventQueue -> IO NamedEvent readEventQueue q = atomically $ readTChan q -tryReadEventQueue :: EventQueue -> IO (Maybe Event) +tryReadEventQueue :: EventQueue -> IO (Maybe NamedEvent) tryReadEventQueue q = atomically $ do b <- isEmptyTChan q if b then return Nothing diff --git a/blank-canvas.cabal b/blank-canvas.cabal --- a/blank-canvas.cabal +++ b/blank-canvas.cabal @@ -1,5 +1,5 @@ Name: blank-canvas -Version: 0.2.3.2 +Version: 0.3.1 Synopsis: HTML5 Canvas Graphics Library Description: A Haskell port of the HTML5 Canvas API. blank-canvas works by providing a web service that @@ -30,6 +30,8 @@ examples/trivial/Makefile examples/rotate-square/Main.hs examples/rotate-square/Makefile + examples/keyread/Main.hs + examples/keyread/Makefile Library Exposed-modules: Graphics.Blank diff --git a/examples/Makefile b/examples/Makefile --- a/examples/Makefile +++ b/examples/Makefile @@ -6,6 +6,7 @@ (cd html5canvastutorial; make build) (cd square; make build) (cd tictactoe; make build) + (cd keyread; make build) # Make using source build-inplace:: @@ -14,3 +15,4 @@ (cd html5canvastutorial; make build-inplace) (cd square; make build-inplace) (cd tictactoe; make build-inplace) + (cd keyread; make build-inplace) diff --git a/examples/keyread/Main.hs b/examples/keyread/Main.hs new file mode 100644 --- /dev/null +++ b/examples/keyread/Main.hs @@ -0,0 +1,43 @@ +module Main where + +import Graphics.Blank +import Data.Map (Map) +import qualified Data.Map as Map +import Debug.Trace +import Control.Concurrent +import Data.List (nub) + +data State = State + { keys :: [Int] -- key *codes* for pressed keys + , step :: Int + } + deriving Show + +main = blankCanvas 3000 $ \ context -> loop context (State [] 0) + +loop context state = do +-- threadDelay (1 * 1000 * 10) -- remove if writing a game + send context $ do + (width,height) <- size + clearRect (0,0,width,height) + lineWidth 1 + strokeStyle "red" + font "30pt Calibri" + fillText("Keys currently pressed: " ++ show (keys state),50,50) + fillText("Counter: " ++ show (step state),50,150) + +-- print state + + control context state + +control context state = do + event <- send context $ tryReadEvents [KeyDown,KeyUp] + let down_keys = case event of { Just (NamedEvent KeyDown e) -> [jsCode e] ; _ -> [] } + let up_keys = case event of { Just (NamedEvent KeyUp e) -> [jsCode e] ; _ -> []} + let current_keys = [ k | k <- nub (keys state ++ down_keys), not (k `elem` up_keys) ] + let state' = state { step = step state + 1, keys = current_keys } + case event of + Nothing -> loop context state' + Just _ -> control context state' -- there may be more events to process + + diff --git a/examples/keyread/Makefile b/examples/keyread/Makefile new file mode 100644 --- /dev/null +++ b/examples/keyread/Makefile @@ -0,0 +1,18 @@ +BIN=eventread + +# Make using installed package +build:: + ghc --make Main.hs -o $(BIN) + +# execute +run:: + ./$(BIN) + +# Make using source +build-inplace:: + ghc --make Main.hs -i.:../..:../../dist/build/autogen/ -o $(BIN)-inplace + +# execute inplace +run-inplace:: + export blank_canvas_datadir=../.. ; ./$(BIN)-inplace +