blank-canvas 0.2.3.2 → 0.3.1
raw patch · 8 files changed
+155/−54 lines, 8 files
Files
- Graphics/Blank.hs +18/−17
- Graphics/Blank/Canvas.hs +34/−8
- Graphics/Blank/Context.hs +21/−17
- Graphics/Blank/Events.hs +16/−11
- blank-canvas.cabal +3/−1
- examples/Makefile +2/−0
- examples/keyread/Main.hs +43/−0
- examples/keyread/Makefile +18/−0
Graphics/Blank.hs view
@@ -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
Graphics/Blank/Canvas.hs view
@@ -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+
Graphics/Blank/Context.hs view
@@ -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 "}"
Graphics/Blank/Events.hs view
@@ -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
blank-canvas.cabal view
@@ -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
examples/Makefile view
@@ -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)
+ examples/keyread/Main.hs view
@@ -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++
+ examples/keyread/Makefile view
@@ -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+