blank-canvas 0.3.1 → 0.4.0
raw patch · 28 files changed
+1113/−920 lines, 28 filesdep +bytestringdep +kansas-cometdep +vectordep ~aesondep ~basedep ~network
Dependencies added: bytestring, kansas-comet, vector
Dependency ranges changed: aeson, base, network, scotty, text, transformers, wai, wai-extra, warp
Files
- Graphics/Blank.hs +258/−117
- Graphics/Blank/Canvas.hs +170/−55
- Graphics/Blank/Context.hs +0/−38
- Graphics/Blank/DeviceContext.hs +59/−0
- Graphics/Blank/Events.hs +36/−73
- Graphics/Blank/GHCi.hs +44/−0
- Graphics/Blank/Generated.hs +119/−68
- Graphics/Blank/JavaScript.hs +131/−0
- Graphics/Blank/Style.hs +13/−0
- Graphics/Blank/Utils.hs +31/−0
- LICENSE +1/−1
- README +0/−13
- README.md +52/−0
- blank-canvas.cabal +53/−33
- examples/Makefile +0/−18
- examples/html5canvastutorial/Main.hs +0/−153
- examples/html5canvastutorial/Makefile +0/−18
- examples/keyread/Main.hs +0/−43
- examples/keyread/Makefile +0/−18
- examples/rotate-square/Main.hs +0/−26
- examples/rotate-square/Makefile +0/−18
- examples/square/Main.hs +0/−32
- examples/square/Makefile +0/−18
- examples/tictactoe/Main.hs +0/−109
- examples/tictactoe/Makefile +0/−18
- examples/trivial/Main.hs +0/−12
- examples/trivial/Makefile +0/−18
- static/index.html +146/−21
Graphics/Blank.hs view
@@ -1,53 +1,156 @@-{-# LANGUAGE OverloadedStrings, TemplateHaskell, GADTs, KindSignatures, CPP #-}+{-# LANGUAGE OverloadedStrings, TemplateHaskell, GADTs, KindSignatures, CPP, BangPatterns, ScopedTypeVariables #-} +-- | blank-canvas is a Haskell binding to the complete HTML5 Canvas+-- API. blank-canvas allows Haskell users to write, in Haskell,+-- interactive images onto their web browsers. blank-canvas gives+-- the users a single full-window canvas, and provides many+-- well-documented functions for rendering images.+ module Graphics.Blank ( -- * Starting blank-canvas blankCanvas- -- * Graphics 'Context'- , Context -- abstact+ , Options(..)+ -- ** 'send'ing to the Graphics 'DeviceContext'+ , DeviceContext -- abstact , send- , events- -- * Drawing pictures using the Canvas DSL+ -- * HTML5 Canvas API+ -- | See <http://www.nihilogic.dk/labs/canvas_sheet/HTML5_Canvas_Cheat_Sheet.pdf> for the JavaScript + -- version of this API. , Canvas -- abstact- , module Graphics.Blank.Generated- , readEvent- , readEvents- , tryReadEvent- , tryReadEvents- , size- -- * Events+ -- ** Canvas element+ , height+ , width+ , toDataURL+ -- ** 2D Context+ , save+ , restore+ -- ** Transformation+ , scale+ , rotate+ , translate+ , transform+ , setTransform+ -- ** Image drawing+ , Image -- abstract class+ , drawImage+ -- ** Compositing+ , globalAlpha+ , globalCompositeOperation+ -- ** Line styles+ , lineWidth+ , lineCap+ , lineJoin+ , miterLimit+ -- ** Colors, styles and shadows+ , strokeStyle+ , fillStyle+ , shadowOffsetX+ , shadowOffsetY+ , shadowBlur+ , shadowColor+ , createLinearGradient+ , createRadialGradient+ , createPattern+ , addColorStop+ , CanvasGradient+ , CanvasPattern+ -- ** Paths+ , beginPath+ , closePath+ , fill+ , stroke+ , clip+ , moveTo+ , lineTo+ , quadraticCurveTo+ , bezierCurveTo+ , arcTo+ , arc+ , rect+ , isPointInPath+ -- ** Text+ , font + , textAlign+ , textBaseline+ , fillText+ , strokeText+ , measureText+ , TextMetrics(..)+ -- ** Rectangles+ , clearRect+ , fillRect+ , strokeRect+ -- ** Pixel manipulation+ , getImageData+ , putImageData+ , ImageData(..)+ -- * blank-canvas Extensions+ -- ** Reading from 'Canvas'+ , newImage+ , CanvasImage -- abstract+ -- ** 'DeviceContext' attributes+ , devicePixelRatio+ -- ** 'CanvasContext', and off-screen Canvas.+ , CanvasContext+ , newCanvas+ , with+ , myCanvasContext+ , deviceCanvasContext+ -- ** Debugging+ , console_log+ , eval+ , JSArg(..)+ -- ** Drawing Utilities+ , module Graphics.Blank.Utils+ -- ** Events+ , trigger + , eventQueue+ , wait+ , flush , Event(..)- , EventName(..)- , NamedEvent(..)+ , EventName , EventQueue- , readEventQueue- , tryReadEventQueue+ -- ** Middleware+ , local_only ) where import Control.Concurrent-import Control.Monad.IO.Class (liftIO)+import Control.Concurrent.STM+import Control.Monad+import Control.Exception import Network.Wai.Handler.Warp (run) import Network.Wai (Middleware,remoteHost, responseLBS) import qualified Network.HTTP.Types as H import Network.Socket (SockAddr(..))-import Web.Scotty as S+import System.IO.Unsafe (unsafePerformIO)+--import System.Mem.StableName+import Web.Scotty (scottyApp, get, file)+import qualified Web.Scotty as Scotty --import Network.Wai.Middleware.RequestLogger -- Used when debugging --import Network.Wai.Middleware.Static-import qualified Data.Text.Lazy as T--import qualified Data.Map as Map-import qualified Data.Set as Set+import qualified Web.Scotty.Comet as KC+import Data.Aeson+import Data.Aeson.Types (parse)+import Data.String+import qualified Data.Text as T+import Data.Text (Text)+import Data.Monoid((<>)) import Graphics.Blank.Events-import Graphics.Blank.Context+import Graphics.Blank.DeviceContext import Graphics.Blank.Canvas-import Graphics.Blank.Generated+import Graphics.Blank.Generated hiding (fillStyle,strokeStyle)+import qualified Graphics.Blank.Generated as Generated+import qualified Graphics.Blank.JavaScript as JavaScript+import Graphics.Blank.JavaScript hiding (width, height)+import Graphics.Blank.Utils import Paths_blank_canvas -- | blankCanvas is the main entry point into blank-canvas. -- A typical invocation would be --+-- >{-# LANGUAGE OverloadedStrings #-} -- >module Main where -- > -- >import Graphics.Blank@@ -62,123 +165,161 @@ -- > -blankCanvas :: Int -> (Context -> IO ()) -> IO ()-blankCanvas port actions = do+blankCanvas :: Options -> (DeviceContext -> IO ()) -> IO ()+blankCanvas opts actions = do dataDir <- getDataDir--- print dataDir - uVar <- newMVar 0- let getUniq :: IO Int- getUniq = do- u <- takeMVar uVar- putMVar uVar (u + 1)- return u+ kComet <- KC.kCometPlugin - contextDB <- newMVar $ (Map.empty :: Map.Map Int Context)- let newContext :: (Float,Float) -> IO Int- newContext (w,h) = do- uq <- getUniq- picture <- newEmptyMVar- 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- _ <- forkIO $ actions cxt- return uq +-- print dataDir+ app <- scottyApp $ do -- middleware logStdoutDev- middleware local_only---- middleware $ staticRoot $ TS.pack $ (dataDir ++ "/static")+ sequence_ [ Scotty.middleware ware + | ware <- middleware opts + ]+ -- use the comet+ let kc_opts :: KC.Options+ kc_opts = KC.Options { KC.prefix = "/blank", KC.verbose = if debug opts then 3 else 0 } - get "/" $ file $ dataDir ++ "/static/index.html"- get "/jquery.js" $ file $ dataDir ++ "/static/jquery.js"- get "/jquery-json.js" $ file $ dataDir ++ "/static/jquery-json.js"+ KC.connect kc_opts $ \ kc_doc -> do+ -- register the events we want to watch for+ KC.send kc_doc $ T.unlines+ [ "register(" <> T.pack(show nm) <> ");"+ | nm <- events opts+ ] - post "/start" $ do- req <- jsonData- uq <- liftIO $ newContext req- text (T.pack $ "session = " ++ show uq ++ ";redraw();")+ queue <- atomically newTChan+ _ <- forkIO $ forever $ do+ val <- atomically $ readTChan $ KC.eventQueue $ kc_doc+ case fromJSON val of+ Success (event :: Event) -> do+ atomically $ writeTChan queue event+ _ -> return () - post "/event/:num" $ do- addHeader "Cache-Control" "max-age=0, no-cache, private, no-store, must-revalidate"- num <- param "num"- ne <- jsonData- db <- liftIO $ readMVar contextDB- case Map.lookup num db of- Nothing -> json ()- Just (Context _ _ _ q _) ->- do liftIO $ writeEventQueue q ne- json ()+ let cxt0 = DeviceContext kc_doc queue 300 300 1+ + -- A bit of bootstrapping + DeviceAttributes w h dpr <- send cxt0 device+ -- print (DeviceAttributes w h dpr) - get "/canvas/:num" $ do- addHeader "Cache-Control" "max-age=0, no-cache, private, no-store, must-revalidate"- -- do something and return a new list of commands to the client- num <- param "num"--- liftIO $ print (num :: Int)- let tryPicture picture n = do- res <- liftIO $ tryTakeMVar picture- case res of- Just js -> do--- liftIO $ print js- text $ T.pack js- Nothing | n == 0 ->- -- give the browser something to do (approx every second)- text (T.pack "")- Nothing -> do- -- hack, wait a 1/10 of a second- liftIO $ threadDelay (100 * 1000)- tryPicture picture (n - 1 :: Int)+ let cxt1 = cxt0 + { ctx_width = w+ , ctx_height = h+ , ctx_devicePixelRatio = dpr+ }+ + (actions $ cxt1) `catch` \ (e :: SomeException) -> do+ print ("Exception in blank-canvas application:" :: String)+ print e+ throw e - 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+ get "/" $ file $ dataDir ++ "/static/index.html"+ get "/jquery.js" $ file $ dataDir ++ "/static/jquery.js"+ get "/jquery-json.js" $ file $ dataDir ++ "/static/jquery-json.js"+ get "/kansas-comet.js" $ file $ kComet+ sequence_ [ get (fromString ("/" ++ nm)) $ file $ (root opts ++ "/" ++ nm) | nm <- static opts ]+ return () - run port app+ run (port opts) 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- where- send' :: Canvas a -> (String -> String) -> IO a-- send' (Bind (Return a) k) cmds = send' (k a) cmds- send' (Bind (Bind m k1) k2) cmds = send' (Bind m (\ r -> Bind (k1 r) k2)) cmds- send' (Bind (Command cmd) k) cmds = send' (k ()) (cmds . shows cmd)- send' (Bind Size k) cmds = send' (k (h,w)) cmds- send' (Bind other k) cmds = do- res <- send' other cmds- send' (k res) id+-- to common up as many commands as possible. Should not crash. - send' (Get nms op) cmds = do- -- clear the commands- sendToCanvas cxt cmds- -- make sure these events are registered- register cxt nms- -- and apply the channel- op (eventQueue cxt)+send :: DeviceContext -> Canvas a -> IO a+send cxt commands = + send' (deviceCanvasContext cxt) commands id + where+ send' :: CanvasContext -> Canvas a -> (String -> String) -> IO a+ send' c (Bind (Return a) k) cmds = send' c (k a) cmds+ send' c (Bind (Bind m k1) k2) cmds = send' c (Bind m (\ r -> Bind (k1 r) k2)) cmds+ send' c (Bind (Method cmd) k) cmds = send' c (k ()) (cmds . ((showJS c ++ ".") ++) . shows cmd . (";" ++))+ send' c (Bind (Command cmd) k) cmds = send' c (k ()) (cmds . shows cmd . (";" ++))+ send' c (Bind (Query query) k) cmds = do+ -- send the com+ uq <- atomically $ getUniq+ -- The query function returns a function takes the unique port number of the reply.+ sendToCanvas cxt (cmds . ((show query ++ "(" ++ show uq ++ "," ++ showJS c ++ ");") ++))+ v <- KC.getReply (theComet cxt) uq+ case parse (parseQueryResult query) v of+ Error msg -> fail msg+ Success a -> do+ send' c (k a) id+ send' c (Bind (With c' m) k) cmds = send' c' (Bind m (With c . k)) cmds+ send' c (Bind MyContext k) cmds = send' c (k c) cmds - send' (Return a) cmds = do+ send' _ (With c m) cmds = send' c m cmds+ send' c MyContext cmds = send' c (Return c) cmds+ send' _ (Return a) cmds = do sendToCanvas cxt cmds return a- send' other cmds = send' (Bind other Return) cmds+ send' c cmd cmds = send' c (Bind cmd Return) cmds local_only :: Middleware-local_only f r = case remoteHost r of+local_only f r k = case remoteHost r of SockAddrInet _ h | h == fromIntegral home- -> f r+ -> f r k #if !defined(mingw32_HOST_OS) && !defined(_WIN32)- SockAddrUnix _ -> f r+ SockAddrUnix _ -> f r k #endif- _ -> return $ responseLBS H.status403- [("Content-Type", "text/plain")]- "local access only"+ _ -> k $ responseLBS H.status403+ [("Content-Type", "text/plain")]+ "local access only" where home :: Integer home = 127 + (256 * 256 * 256) * 1+++{-# NOINLINE uniqVar #-}+uniqVar :: TVar Int+uniqVar = unsafePerformIO $ newTVarIO 0++getUniq :: STM Int+getUniq = do+ u <- readTVar uniqVar+ writeTVar uniqVar (u + 1)+ return u++-------------------------------------------------++data Options = Options + { port :: Int -- ^ which port do we issue the blank canvas using+ , events :: [EventName] -- ^ which events does the canvas listen to+ , debug :: Bool -- ^ turn on debugging (default False)+ , static :: [String] -- ^ path to images, and other static artifacts+ , root :: String -- ^ location of the static files (default .)+ , middleware :: [Middleware] -- ^ extra middleware(s) to be executed. (default [local_only])+ }+ +instance Num Options where+ (+) = error "no arithmetic for Blank Canvas Options"+ (-) = error "no arithmetic for Blank Canvas Options"+ (*) = error "no arithmetic for Blank Canvas Options"+ abs = error "no arithmetic for Blank Canvas Options"+ signum = error "no arithmetic for Blank Canvas Options"+ fromInteger n = Options { port = fromInteger n+ , events = []+ , debug = False+ , static = []+ , root = "."+ , middleware = [local_only]+ }+++-------------------------------------------------+-- This is the monomorphic version, to stop "ambiguous" errors.++fillStyle :: Text -> Canvas ()+fillStyle = Generated.fillStyle++strokeStyle :: Text -> Canvas ()+strokeStyle = Generated.strokeStyle++height :: (Image image, Num a) => image -> a+height = JavaScript.height++width :: (Image image, Num a) => image -> a+width = JavaScript.width+
Graphics/Blank/Canvas.hs view
@@ -1,22 +1,30 @@-{-# LANGUAGE TemplateHaskell, GADTs, KindSignatures #-}+{-# LANGUAGE TemplateHaskell, GADTs, KindSignatures, ScopedTypeVariables, OverloadedStrings, FlexibleInstances, OverlappingInstances #-} module Graphics.Blank.Canvas where import Graphics.Blank.Events+import Graphics.Blank.JavaScript -import Control.Applicative (Applicative(..))-import Control.Monad (ap)-import Numeric+import Data.Aeson (FromJSON(..),Value(..),encode)+import Data.Aeson.Types (Parser, (.:))+import Data.Char (chr)+import Control.Monad (ap, liftM2)+import Control.Applicative+import Data.Monoid+import qualified Data.ByteString.Lazy as DBL+import qualified Data.Text as Text+import Data.Text (Text) + data Canvas :: * -> * where- Command :: Command -> Canvas ()+ Method :: Method -> Canvas () -- <context>.<method>+ Command :: Command -> Canvas () -- <command>+ Query :: (Show a) => Query a -> Canvas a+ With :: CanvasContext -> Canvas a -> Canvas a+ MyContext :: Canvas CanvasContext 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@@ -28,79 +36,186 @@ instance Functor Canvas where fmap f c = c >>= return . f --- HTML5 Canvas assignments: FillStyle, Font, GlobalAlpha, LineCap, LineJoin, LineWidth, MiterLimit, StrokeStyle, TextAlign, TextBaseline-data Command+instance Monoid a => Monoid (Canvas a) where+ mappend = liftM2 mappend+ mempty = return mempty++-- HTML5 Canvas assignments: FillStyle, Font, GlobalAlpha, GlobalCompositeOperation, LineCap, LineJoin, LineWidth, MiterLimit, ShadowBlur, ShadowColor, ShadowOffsetX, ShadowOffsetY, StrokeStyle, TextAlign, TextBaseline+data Method -- regular HTML5 canvas commands = Arc (Float,Float,Float,Float,Float,Bool)+ | ArcTo (Float,Float,Float,Float,Float) | BeginPath | BezierCurveTo (Float,Float,Float,Float,Float,Float)+ | forall image . Image image => DrawImage (image,[Float]) -- 'drawImage' takes 2, 4 or 8 floats arguments | ClearRect (Float,Float,Float,Float)+ | Clip | ClosePath | Fill | FillRect (Float,Float,Float,Float)- | FillStyle String- | FillText (String,Float,Float)- | Font String+ | forall style . Style style => FillStyle style+ | FillText (Text,Float,Float)+ | Font Text | GlobalAlpha Float- | LineCap String- | LineJoin String+ | GlobalCompositeOperation Text+ | LineCap Text+ | LineJoin Text | LineTo (Float,Float) | LineWidth Float | MiterLimit Float | MoveTo (Float,Float)+ | PutImageData (ImageData,[Float])+ | QuadraticCurveTo (Float,Float,Float,Float)+ | Rect (Float,Float,Float,Float) | Restore | Rotate Float | Scale (Float,Float) | Save+ | SetTransform (Float,Float,Float,Float,Float,Float) | Stroke | StrokeRect (Float,Float,Float,Float)- | StrokeText (String,Float,Float)- | StrokeStyle String- | TextAlign String- | TextBaseline String+ | StrokeText (Text,Float,Float)+ | forall style . Style style => StrokeStyle style+ | ShadowBlur Float+ | ShadowColor Text+ | ShadowOffsetX Float+ | ShadowOffsetY Float+ | TextAlign Text+ | TextBaseline Text | Transform (Float,Float,Float,Float,Float,Float) | Translate (Float,Float) -showJ :: Float -> String-showJ a = showFFloat (Just 3) a ""+data Command+ = Trigger Event+ | AddColorStop (Float,Text) CanvasGradient+ | forall msg . JSArg msg => Log msg+ | Eval Text -showB :: Bool -> String-showB True = "true"-showB False = "false"+instance Show Command where+ show (Trigger e) = "Trigger(" ++ map (chr . fromEnum) (DBL.unpack (encode e)) ++ ")"+ show (AddColorStop (off,rep) g)+ = showJS g ++ ".addColorStop(" ++ showJS off ++ "," ++ showJS rep ++ ")"+ show (Log msg) = "console.log(" ++ showJS msg ++ ")" + show (Eval cmd) = Text.unpack cmd -- no escaping or interpretation --- | size of the canvas-size :: Canvas (Float,Float)-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 = fmap (\ (NamedEvent _ e) -> e) (readEvents [nm])+-- | 'with' runs a set of canvas commands in the context+-- of a specific canvas buffer.+with :: CanvasContext -> Canvas a -> Canvas a+with = With --- | 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+-- | 'myCanvasContext' returns the current 'CanvasContent'.+myCanvasContext :: Canvas CanvasContext+myCanvasContext = MyContext --- | read a specific event. **Throws away all events not named**-tryReadEvent :: EventName -> Canvas (Maybe Event)-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+-- | trigger a specific named event, please.+trigger :: Event -> Canvas ()+trigger = Command . Trigger +-- | add a Color stop to a Canvas Gradient.+addColorStop :: (Float,Text) -> CanvasGradient -> Canvas ()+addColorStop (off,rep) = Command . AddColorStop (off,rep)++-- | 'console_log' aids debugging by sending the argument to the browser console.log.+console_log :: JSArg msg => msg -> Canvas ()+console_log = Command . Log++-- | 'eval' executes the argument in JavaScript directly.+eval :: Text -> Canvas ()+eval = Command . Eval++-----------------------------------------------------------------------------+data Query :: * -> * where+ Device :: Query DeviceAttributes+ ToDataURL :: Query Text+ MeasureText :: Text -> Query TextMetrics+ IsPointInPath :: (Float,Float) -> Query Bool+ NewImage :: Text -> Query CanvasImage+ CreateLinearGradient :: (Float,Float,Float,Float) -> Query CanvasGradient+ CreateRadialGradient :: (Float,Float,Float,Float,Float,Float) -> Query CanvasGradient+ CreatePattern :: Image image => (image,Text) -> Query CanvasPattern+ NewCanvas :: (Int,Int) -> Query CanvasContext+ GetImageData :: (Float,Float,Float,Float) -> Query ImageData++data DeviceAttributes = DeviceAttributes Int Int Float + deriving Show+ +-- | The 'width' argument of 'TextMetrics' can trivially be projected out.+data TextMetrics = TextMetrics Float+ deriving Show++instance Show (Query a) where+ show Device = "Device"+ show ToDataURL = "ToDataURL"+ show (MeasureText txt) = "MeasureText(" ++ showJS txt ++ ")"+ show (IsPointInPath (x,y)) = "IsPointInPath(" ++ showJS x ++ "," ++ showJS y ++ ")"+ show (NewImage url) = "NewImage(" ++ showJS url ++ ")"+ show (CreateLinearGradient (x0,y0,x1,y1)) = "CreateLinearGradient(" ++ showJS x0 ++ "," ++ showJS y0 ++ "," ++ showJS x1 ++ "," ++ showJS y1 ++ ")"+ show (CreateRadialGradient (x0,y0,r0,x1,y1,r1)) = "CreateRadialGradient(" ++ showJS x0 ++ "," ++ showJS y0 ++ "," ++ showJS r0 ++ "," ++ showJS x1 ++ "," ++ showJS y1 ++ "," ++ showJS r1 ++ ")"+ show (CreatePattern (img,str)) = "CreatePattern(" ++ jsImage img ++ "," ++ showJS str ++ ")"+ show (NewCanvas (x,y)) = "NewCanvas(" ++ showJS x ++ "," ++ showJS y ++ ")"+ show (GetImageData (sx,sy,sw,sh)) + = "GetImageData(" ++ showJS sx ++ "," ++ showJS sy ++ "," ++ showJS sw ++ "," ++ showJS sh ++ ")"++-- This is how we take our value to bits+parseQueryResult :: Query a -> Value -> Parser a+parseQueryResult (Device {}) o = uncurry3 DeviceAttributes <$> parseJSON o+parseQueryResult (ToDataURL {}) o = parseJSON o+parseQueryResult (MeasureText {}) (Object v) = TextMetrics <$> v .: "width"+parseQueryResult (IsPointInPath {}) o = parseJSON o+parseQueryResult (NewImage {}) o = uncurry3 CanvasImage <$> parseJSON o+parseQueryResult (CreateLinearGradient {}) o = CanvasGradient <$> parseJSON o+parseQueryResult (CreateRadialGradient {}) o = CanvasGradient <$> parseJSON o+parseQueryResult (CreatePattern {}) o = CanvasPattern <$> parseJSON o+parseQueryResult (NewCanvas {}) o = uncurry3 CanvasContext <$> parseJSON o+parseQueryResult (GetImageData {}) (Object o) = ImageData + <$> (o .: "width")+ <*> (o .: "height")+ <*> (o .: "data")+parseQueryResult _ _ = fail "no parse in blank-canvas server (internal error)"++uncurry3 :: (t0 -> t1 -> t2 -> t3) -> (t0, t1, t2) -> t3+uncurry3 f (a,b,c) = f a b c ++device :: Canvas DeviceAttributes+device = Query Device++-- | Turn the canvas into a png data stream / data URL.+-- +-- > "data:image/png;base64,iVBORw0KGgo.."+--+toDataURL :: () -> Canvas Text+toDataURL () = Query ToDataURL++measureText :: Text -> Canvas TextMetrics+measureText = Query . MeasureText++isPointInPath :: (Float,Float) -> Canvas Bool+isPointInPath = Query . IsPointInPath++-- | 'image' takes a URL (perhaps a data URL), and returns the 'CanvasImage' handle, +-- _after_ loading.+-- The assumption is you are using local images, so loading should be near instant.+newImage :: Text -> Canvas CanvasImage+newImage = Query . NewImage ++createLinearGradient :: (Float,Float,Float,Float) -> Canvas CanvasGradient+createLinearGradient = Query . CreateLinearGradient++createRadialGradient :: (Float,Float,Float,Float,Float,Float) -> Canvas CanvasGradient+createRadialGradient = Query . CreateRadialGradient++createPattern :: (CanvasImage, Text) -> Canvas CanvasPattern+createPattern = Query . CreatePattern++-- | Create a new, off-screen canvas buffer. Takes width and height.+newCanvas :: (Int,Int) -> Canvas CanvasContext+newCanvas = Query . NewCanvas++-- | Capture ImageDate from the Canvas.+getImageData :: (Float,Float,Float,Float) -> Canvas ImageData+getImageData = Query . GetImageData
− Graphics/Blank/Context.hs
@@ -1,38 +0,0 @@-module Graphics.Blank.Context where--import Control.Concurrent-import qualified Data.Set as Set-import Data.Set (Set)-import Data.Char--import Graphics.Blank.Events---- | 'Context' is our abstact handle into a specific 2d-context inside a browser.-data Context = Context- { theSize :: (Float,Float)- , theDraw :: MVar String- , eventRegs :: MVar (Set EventName) -- events that are registered- , eventQueue :: EventQueue -- now a single event queueMVar (Map EventName EventQueue)- , sessionNo :: Int- }---- '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 "}"
+ Graphics/Blank/DeviceContext.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedStrings #-}+module Graphics.Blank.DeviceContext where++import Graphics.Blank.JavaScript+import Control.Concurrent.STM++import qualified Web.Scotty.Comet as KC++import Graphics.Blank.Events+import Data.Monoid((<>))+import qualified Data.Text as T++-- | 'Context' is our abstact handle into a specific 2d-context inside a browser.+-- Note that the JavaScript API concepts of 2D-Context and Canvas+-- are conflated in blank-canvas. Therefore, there is no 'getContext' method,+-- rather 'getContext' is implied (when using 'send').++data DeviceContext = DeviceContext+ { theComet :: KC.Document -- ^ The mechansims for sending commands+ , eventQueue :: EventQueue -- ^ A single (typed) event queue+ , ctx_width :: !Int+ , ctx_height :: !Int+ , ctx_devicePixelRatio :: !Float+ }++instance Image DeviceContext where + jsImage = jsImage . deviceCanvasContext+ width = fromIntegral . ctx_width+ height = fromIntegral . ctx_height++deviceCanvasContext :: DeviceContext -> CanvasContext+deviceCanvasContext cxt = CanvasContext 0 (ctx_width cxt) (ctx_height cxt)++-- ** 'devicePixelRatio' returns the Device Pixel Ratio as used. Typically, the browser ignore devicePixelRatio in the canvas,+-- which can make fine details and text look fuzzy. Using the query "?hd" on the URL, blank-canvas attempts+-- to use the native devicePixelRatio, and if successful, 'devicePixelRatio' will return a number other than 1.+-- You can think of devicePixelRatio as the line width to use to make lines look one pixel wide.++devicePixelRatio :: DeviceContext -> Float+devicePixelRatio = ctx_devicePixelRatio++-- | internal command to send a message to the canvas.+sendToCanvas :: DeviceContext -> ShowS -> IO ()+sendToCanvas cxt cmds = do+ KC.send (theComet cxt) $ "try{" <> T.pack (cmds "}catch(e){alert('JavaScript Failure: '+e.message);}")++-- | wait for any event. blocks.+wait :: DeviceContext -> IO Event+wait c = atomically $ readTChan (eventQueue c)++-- | 'flush' all the current events, returning them all to the user. Never blocks.+flush :: DeviceContext -> IO [Event]+flush cxt = atomically $ loop+ where loop = do + b <- isEmptyTChan (eventQueue cxt)+ if b then return [] else do+ e <- readTChan (eventQueue cxt)+ es <- loop+ return (e : es)
Graphics/Blank/Events.hs view
@@ -1,87 +1,50 @@-{-# LANGUAGE ScopedTypeVariables #-}-module Graphics.Blank.Events- ( -- * Events- Event(..)- , NamedEvent(..)- , EventName(..)- -- * Event Queue- , EventQueue -- not abstract- , writeEventQueue- , readEventQueue- , tryReadEventQueue- , newEventQueue- ) where+{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}+module Graphics.Blank.Events where -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 Data.Aeson (FromJSON(..), Value(..), ToJSON(..))+import Data.Aeson.Types ((.:), (.=), object)+import Control.Applicative((<|>),(<$>),(<*>)) import Control.Concurrent.STM+import Data.Text (Text) --- | Basic Event from Browser, the code is event-type specific.+-- | Basic Event from Browser; see <http://api.jquery.com/category/events/event-object/> for details. data Event = Event- { jsCode :: Int- , jsMouse :: Maybe (Int,Int)+ { eMetaKey :: Bool+ , ePageXY :: Maybe (Float,Float)+ , eType :: EventName -- "Describes the nature of the event." jquery+ , eWhich :: Maybe Int -- magic code for key presses } deriving (Show) --- | When an event is sent to the application, it always has a name.-data NamedEvent = NamedEvent EventName Event- deriving (Show) -instance FromJSON NamedEvent where- parseJSON o = do- (str::String,_::Value,_::Value,_::Value) <- parseJSON o- case Map.lookup str namedEventDB of- 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-+instance FromJSON Event where+ parseJSON (Object v) = Event <$> ((v .: "eMetaKey") <|> return False)+ <*> (Just <$> (v .: "ePageXY") <|> return Nothing)+ <*> (v .: "eType")+ <*> (Just <$> (v .: "eWhich") <|> return Nothing)+ parseJSON _ = fail "no parse of Event" -namedEventDB :: Map String EventName-namedEventDB = Map.fromList- [ (map toLower (show n),n)- | n <- [minBound..maxBound]- ]+instance ToJSON Event where+ toJSON e = object + $ ((:) ("eMetaKey" .= eMetaKey e))+ $ (case ePageXY e of+ Nothing -> id+ Just (x,y) -> (:) ("ePageXY" .= (x,y)))+ $ ((:) ("eType" .= eType e))+ $ (case eWhich e of+ Nothing -> id+ Just w -> (:) ("eWhich" .= w))+ $ [] --- | 'EventName' mirrors event names from jquery, where 'map toLower (show name)' gives--- the jquery event name.-data EventName- -- Keys- = KeyPress- | KeyDown- | KeyUp- -- Mouse- | MouseDown- | MouseEnter- | MouseMove- | MouseOut- | MouseOver- | MouseUp- deriving (Eq, Ord, Show, Enum, Bounded)+-- | 'EventName' mirrors event names from jquery, and use lower case.+-- Possible named events+--+-- * keypress, keydown, keyup+-- * mouseDown, mouseenter, mousemove, mouseout, mouseover, mouseup+-- +type EventName = Text -- | EventQueue is a STM channel ('TChan') of 'Event's. -- Intentionally, 'EventQueue' is not abstract.-type EventQueue = TChan NamedEvent--writeEventQueue :: EventQueue -> NamedEvent -> IO ()-writeEventQueue q e = atomically $ writeTChan q e--readEventQueue :: EventQueue -> IO NamedEvent-readEventQueue q = atomically $ readTChan q--tryReadEventQueue :: EventQueue -> IO (Maybe NamedEvent)-tryReadEventQueue q = atomically $ do- b <- isEmptyTChan q- if b then return Nothing- else liftM Just (readTChan q)--newEventQueue :: IO EventQueue-newEventQueue = atomically newTChan+type EventQueue = TChan Event
+ Graphics/Blank/GHCi.hs view
@@ -0,0 +1,44 @@+module Graphics.Blank.GHCi (splatCanvas) where+ +import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad+import System.IO.Unsafe (unsafePerformIO)++import Graphics.Blank (Options(..),port,send, Canvas, blankCanvas)++-- | splitCanvas is the GHCi entry point into blank-canvas.+-- A typical invocation would be+--+-- >GHCi> import Graphics.Blank+-- >GHCi> import Graphics.Blank.GHCi+-- >+-- >-- Adding commands to the canvas buffer+-- >GHCi> splatCanvas 3000 $ ( .. canvas commands .. )+--+-- The system remembers if it has been called on a specific port before,+-- and if so, uses the previous session.++splatCanvas :: Options -> Canvas () -> IO ()+splatCanvas opts cmds = do+ optCh <- atomically $ do+ ports <- readTVar usedPorts+ case lookup (port opts) ports of+ Just ch -> do putTMVar ch cmds+ return Nothing+ Nothing -> do ch <- newTMVar cmds+ writeTVar usedPorts ((port opts,ch):ports)+ return (Just ch)++ case optCh of+ Nothing -> return ()+ Just ch -> do _ <- forkIO $ blankCanvas opts $ \ cxt -> forever $ do+ cmd <- atomically $ takeTMVar ch+ send cxt cmd -- run the command+ return ()++-- common TVar for all ports in use.+{-# NOINLINE usedPorts #-}+usedPorts :: TVar [(Int,TMVar (Canvas ()))]+usedPorts = unsafePerformIO $ newTVarIO []+
Graphics/Blank/Generated.hs view
@@ -2,124 +2,175 @@ module Graphics.Blank.Generated where import Graphics.Blank.Canvas+import Graphics.Blank.JavaScript+import Data.Text (Text) -instance Show Command where- show (Arc (a1,a2,a3,a4,a5,a6)) = "c.arc(" ++ showJ a1 ++ "," ++ showJ a2 ++ "," ++ showJ a3 ++ "," ++ showJ a4 ++ "," ++ showJ a5 ++ "," ++ showB a6 ++ ");"- show BeginPath = "c.beginPath();"- show (BezierCurveTo (a1,a2,a3,a4,a5,a6)) = "c.bezierCurveTo(" ++ showJ a1 ++ "," ++ showJ a2 ++ "," ++ showJ a3 ++ "," ++ showJ a4 ++ "," ++ showJ a5 ++ "," ++ showJ a6 ++ ");"- show (ClearRect (a1,a2,a3,a4)) = "c.clearRect(" ++ showJ a1 ++ "," ++ showJ a2 ++ "," ++ showJ a3 ++ "," ++ showJ a4 ++ ");"- show ClosePath = "c.closePath();"- show Fill = "c.fill();"- show (FillRect (a1,a2,a3,a4)) = "c.fillRect(" ++ showJ a1 ++ "," ++ showJ a2 ++ "," ++ showJ a3 ++ "," ++ showJ a4 ++ ");"- show (FillStyle (a1)) = "c.fillStyle = (" ++ show a1 ++ ");"- show (FillText (a1,a2,a3)) = "c.fillText(" ++ show a1 ++ "," ++ showJ a2 ++ "," ++ showJ a3 ++ ");"- show (Font (a1)) = "c.font = (" ++ show a1 ++ ");"- show (GlobalAlpha (a1)) = "c.globalAlpha = (" ++ showJ a1 ++ ");"- show (LineCap (a1)) = "c.lineCap = (" ++ show a1 ++ ");"- show (LineJoin (a1)) = "c.lineJoin = (" ++ show a1 ++ ");"- show (LineTo (a1,a2)) = "c.lineTo(" ++ showJ a1 ++ "," ++ showJ a2 ++ ");"- show (LineWidth (a1)) = "c.lineWidth = (" ++ showJ a1 ++ ");"- show (MiterLimit (a1)) = "c.miterLimit = (" ++ showJ a1 ++ ");"- show (MoveTo (a1,a2)) = "c.moveTo(" ++ showJ a1 ++ "," ++ showJ a2 ++ ");"- show Restore = "c.restore();"- show (Rotate (a1)) = "c.rotate(" ++ showJ a1 ++ ");"- show (Scale (a1,a2)) = "c.scale(" ++ showJ a1 ++ "," ++ showJ a2 ++ ");"- show Save = "c.save();"- show Stroke = "c.stroke();"- show (StrokeRect (a1,a2,a3,a4)) = "c.strokeRect(" ++ showJ a1 ++ "," ++ showJ a2 ++ "," ++ showJ a3 ++ "," ++ showJ a4 ++ ");"- show (StrokeText (a1,a2,a3)) = "c.strokeText(" ++ show a1 ++ "," ++ showJ a2 ++ "," ++ showJ a3 ++ ");"- show (StrokeStyle (a1)) = "c.strokeStyle = (" ++ show a1 ++ ");"- show (TextAlign (a1)) = "c.textAlign = (" ++ show a1 ++ ");"- show (TextBaseline (a1)) = "c.textBaseline = (" ++ show a1 ++ ");"- show (Transform (a1,a2,a3,a4,a5,a6)) = "c.transform(" ++ showJ a1 ++ "," ++ showJ a2 ++ "," ++ showJ a3 ++ "," ++ showJ a4 ++ "," ++ showJ a5 ++ "," ++ showJ a6 ++ ");"- show (Translate (a1,a2)) = "c.translate(" ++ showJ a1 ++ "," ++ showJ a2 ++ ");"+instance Show Method where+ show (Arc (a1,a2,a3,a4,a5,a6)) = "arc(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ "," ++ jsFloat a5 ++ "," ++ jsBool a6 ++ ")"+ show (ArcTo (a1,a2,a3,a4,a5)) = "arcTo(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ "," ++ jsFloat a5 ++ ")"+ show BeginPath = "beginPath()"+ show (BezierCurveTo (a1,a2,a3,a4,a5,a6)) = "bezierCurveTo(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ "," ++ jsFloat a5 ++ "," ++ jsFloat a6 ++ ")"+ show (DrawImage (a1,a2)) = "drawImage(" ++ jsImage a1 ++ "," ++ jsList jsFloat a2 ++ ")"+ show (ClearRect (a1,a2,a3,a4)) = "clearRect(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ ")"+ show Clip = "clip()"+ show ClosePath = "closePath()"+ show Fill = "fill()"+ show (FillRect (a1,a2,a3,a4)) = "fillRect(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ ")"+ show (FillStyle (a1)) = "fillStyle = (" ++ jsStyle a1 ++ ")"+ show (FillText (a1,a2,a3)) = "fillText(" ++ jsText a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ ")"+ show (Font (a1)) = "font = (" ++ jsText a1 ++ ")"+ show (GlobalAlpha (a1)) = "globalAlpha = (" ++ jsFloat a1 ++ ")"+ show (GlobalCompositeOperation (a1)) = "globalCompositeOperation = (" ++ jsText a1 ++ ")"+ show (LineCap (a1)) = "lineCap = (" ++ jsText a1 ++ ")"+ show (LineJoin (a1)) = "lineJoin = (" ++ jsText a1 ++ ")"+ show (LineTo (a1,a2)) = "lineTo(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ ")"+ show (LineWidth (a1)) = "lineWidth = (" ++ jsFloat a1 ++ ")"+ show (MiterLimit (a1)) = "miterLimit = (" ++ jsFloat a1 ++ ")"+ show (MoveTo (a1,a2)) = "moveTo(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ ")"+ show (PutImageData (a1,a2)) = "putImageData(" ++ jsImageData a1 ++ "," ++ jsList jsFloat a2 ++ ")"+ show (QuadraticCurveTo (a1,a2,a3,a4)) = "quadraticCurveTo(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ ")"+ show (Rect (a1,a2,a3,a4)) = "rect(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ ")"+ show Restore = "restore()"+ show (Rotate (a1)) = "rotate(" ++ jsFloat a1 ++ ")"+ show (Scale (a1,a2)) = "scale(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ ")"+ show Save = "save()"+ show (SetTransform (a1,a2,a3,a4,a5,a6)) = "setTransform(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ "," ++ jsFloat a5 ++ "," ++ jsFloat a6 ++ ")"+ show Stroke = "stroke()"+ show (StrokeRect (a1,a2,a3,a4)) = "strokeRect(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ ")"+ show (StrokeText (a1,a2,a3)) = "strokeText(" ++ jsText a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ ")"+ show (StrokeStyle (a1)) = "strokeStyle = (" ++ jsStyle a1 ++ ")"+ show (ShadowBlur (a1)) = "shadowBlur = (" ++ jsFloat a1 ++ ")"+ show (ShadowColor (a1)) = "shadowColor = (" ++ jsText a1 ++ ")"+ show (ShadowOffsetX (a1)) = "shadowOffsetX = (" ++ jsFloat a1 ++ ")"+ show (ShadowOffsetY (a1)) = "shadowOffsetY = (" ++ jsFloat a1 ++ ")"+ show (TextAlign (a1)) = "textAlign = (" ++ jsText a1 ++ ")"+ show (TextBaseline (a1)) = "textBaseline = (" ++ jsText a1 ++ ")"+ show (Transform (a1,a2,a3,a4,a5,a6)) = "transform(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ "," ++ jsFloat a3 ++ "," ++ jsFloat a4 ++ "," ++ jsFloat a5 ++ "," ++ jsFloat a6 ++ ")"+ show (Translate (a1,a2)) = "translate(" ++ jsFloat a1 ++ "," ++ jsFloat a2 ++ ")" -- DSL arc :: (Float,Float,Float,Float,Float,Bool) -> Canvas ()-arc = Command . Arc+arc = Method . Arc +arcTo :: (Float,Float,Float,Float,Float) -> Canvas ()+arcTo = Method . ArcTo+ beginPath :: () -> Canvas ()-beginPath () = Command BeginPath+beginPath () = Method BeginPath bezierCurveTo :: (Float,Float,Float,Float,Float,Float) -> Canvas ()-bezierCurveTo = Command . BezierCurveTo+bezierCurveTo = Method . BezierCurveTo +-- | 'drawImage' takes 2, 4 or 8 floats arguments+drawImage :: Image image => (image,[Float]) -> Canvas ()+drawImage = Method . DrawImage+ clearRect :: (Float,Float,Float,Float) -> Canvas ()-clearRect = Command . ClearRect+clearRect = Method . ClearRect +clip :: () -> Canvas ()+clip () = Method Clip+ closePath :: () -> Canvas ()-closePath () = Command ClosePath+closePath () = Method ClosePath fill :: () -> Canvas ()-fill () = Command Fill+fill () = Method Fill fillRect :: (Float,Float,Float,Float) -> Canvas ()-fillRect = Command . FillRect+fillRect = Method . FillRect -fillStyle :: String -> Canvas ()-fillStyle = Command . FillStyle+fillStyle :: Style style => style -> Canvas ()+fillStyle = Method . FillStyle -fillText :: (String,Float,Float) -> Canvas ()-fillText = Command . FillText+fillText :: (Text,Float,Float) -> Canvas ()+fillText = Method . FillText -font :: String -> Canvas ()-font = Command . Font+font :: Text -> Canvas ()+font = Method . Font globalAlpha :: Float -> Canvas ()-globalAlpha = Command . GlobalAlpha+globalAlpha = Method . GlobalAlpha -lineCap :: String -> Canvas ()-lineCap = Command . LineCap+globalCompositeOperation :: Text -> Canvas ()+globalCompositeOperation = Method . GlobalCompositeOperation -lineJoin :: String -> Canvas ()-lineJoin = Command . LineJoin+lineCap :: Text -> Canvas ()+lineCap = Method . LineCap +lineJoin :: Text -> Canvas ()+lineJoin = Method . LineJoin+ lineTo :: (Float,Float) -> Canvas ()-lineTo = Command . LineTo+lineTo = Method . LineTo lineWidth :: Float -> Canvas ()-lineWidth = Command . LineWidth+lineWidth = Method . LineWidth miterLimit :: Float -> Canvas ()-miterLimit = Command . MiterLimit+miterLimit = Method . MiterLimit moveTo :: (Float,Float) -> Canvas ()-moveTo = Command . MoveTo+moveTo = Method . MoveTo +putImageData :: (ImageData,[Float]) -> Canvas ()+putImageData = Method . PutImageData++quadraticCurveTo :: (Float,Float,Float,Float) -> Canvas ()+quadraticCurveTo = Method . QuadraticCurveTo++rect :: (Float,Float,Float,Float) -> Canvas ()+rect = Method . Rect+ restore :: () -> Canvas ()-restore () = Command Restore+restore () = Method Restore rotate :: Float -> Canvas ()-rotate = Command . Rotate+rotate = Method . Rotate scale :: (Float,Float) -> Canvas ()-scale = Command . Scale+scale = Method . Scale save :: () -> Canvas ()-save () = Command Save+save () = Method Save +setTransform :: (Float,Float,Float,Float,Float,Float) -> Canvas ()+setTransform = Method . SetTransform+ stroke :: () -> Canvas ()-stroke () = Command Stroke+stroke () = Method Stroke strokeRect :: (Float,Float,Float,Float) -> Canvas ()-strokeRect = Command . StrokeRect+strokeRect = Method . StrokeRect -strokeText :: (String,Float,Float) -> Canvas ()-strokeText = Command . StrokeText+strokeText :: (Text,Float,Float) -> Canvas ()+strokeText = Method . StrokeText -strokeStyle :: String -> Canvas ()-strokeStyle = Command . StrokeStyle+strokeStyle :: Style style => style -> Canvas ()+strokeStyle = Method . StrokeStyle -textAlign :: String -> Canvas ()-textAlign = Command . TextAlign+shadowBlur :: Float -> Canvas ()+shadowBlur = Method . ShadowBlur -textBaseline :: String -> Canvas ()-textBaseline = Command . TextBaseline+shadowColor :: Text -> Canvas ()+shadowColor = Method . ShadowColor +shadowOffsetX :: Float -> Canvas ()+shadowOffsetX = Method . ShadowOffsetX++shadowOffsetY :: Float -> Canvas ()+shadowOffsetY = Method . ShadowOffsetY++textAlign :: Text -> Canvas ()+textAlign = Method . TextAlign++textBaseline :: Text -> Canvas ()+textBaseline = Method . TextBaseline+ transform :: (Float,Float,Float,Float,Float,Float) -> Canvas ()-transform = Command . Transform+transform = Method . Transform translate :: (Float,Float) -> Canvas ()-translate = Command . Translate+translate = Method . Translate
+ Graphics/Blank/JavaScript.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE FlexibleInstances, OverlappingInstances #-}++module Graphics.Blank.JavaScript where++import Data.List+import Data.Word (Word8)+import Numeric+import Data.Text (Text)++import qualified Data.Vector.Unboxed as V+import Data.Vector.Unboxed (Vector)++-------------------------------------------------------------++-- TODO: close off +class Image a where+ jsImage :: a -> String+ width :: Num b => a -> b+ height :: Num b => a -> b++instance Image CanvasImage where + jsImage = jsCanvasImage+ width (CanvasImage _ w _) = fromIntegral w + height (CanvasImage _ _ h) = fromIntegral h+ +-- The Image of a canvas is the the canvas context, not the DOM entry, so+-- you need to indirect back to the DOM here.+instance Image CanvasContext where+ jsImage = (++ ".canvas") . jsCanvasContext+ width (CanvasContext _ w _) = fromIntegral w + height (CanvasContext _ _ h) = fromIntegral h++-- instance Element Video -- Not supported++-----------------------------------------------------------------------------++-- TODO: close off +class Style a where+ jsStyle :: a -> String++instance Style Text where { jsStyle = jsText }+instance Style CanvasGradient where { jsStyle = jsCanvasGradient }+instance Style CanvasPattern where { jsStyle = jsCanvasPattern }++-------------------------------------------------------------++-- | A handle to an offscreen canvas. CanvasContext can not be destroyed.+data CanvasContext = CanvasContext Int Int Int+ deriving (Show,Eq,Ord) ++-- | A handle to the Image. CanvasImages can not be destroyed.+data CanvasImage = CanvasImage Int Int Int deriving (Show,Eq,Ord)++-- | A handle to the CanvasGradient. CanvasGradients can not be destroyed.+newtype CanvasGradient = CanvasGradient Int deriving (Show,Eq,Ord)++-- | A handle to the CanvasPattern. CanvasPatterns can not be destroyed.+newtype CanvasPattern = CanvasPattern Int deriving (Show,Eq,Ord)++-------------------------------------------------------------++-- | 'ImageData' is a transliteration of the JavaScript ImageData,+-- There are two 'Int's, and one (unboxed) 'Vector' of 'Word8's.+-- width, height, data can be projected from 'ImageData',+-- 'Vector.length' can be used to find the length.+-- +-- Note: 'ImageData' lives on the server, not the client.++data ImageData = ImageData !Int !Int !(Vector Word8) deriving (Show, Eq, Ord)++-------------------------------------------------------------++class JSArg a where+ showJS :: a -> String++instance JSArg Float where+ showJS a = showFFloat (Just 3) a "" ++jsFloat :: Float -> String+jsFloat = showJS ++instance JSArg Int where+ showJS a = show a++instance JSArg CanvasContext where+ showJS (CanvasContext n _ _) = "canvasbuffers[" ++ show n ++ "]"++jsCanvasContext :: CanvasContext -> String+jsCanvasContext = showJS ++instance JSArg CanvasImage where+ showJS (CanvasImage n _ _) = "images[" ++ show n ++ "]"++jsCanvasImage :: CanvasImage -> String+jsCanvasImage = showJS ++instance JSArg CanvasGradient where+ showJS (CanvasGradient n) = "gradients[" ++ show n ++ "]"++jsCanvasGradient :: CanvasGradient -> String+jsCanvasGradient = showJS ++instance JSArg CanvasPattern where+ showJS (CanvasPattern n) = "patterns[" ++ show n ++ "]"++jsCanvasPattern :: CanvasPattern -> String+jsCanvasPattern = showJS++instance JSArg ImageData where+ showJS (ImageData w h d) = "ImageData(" ++ show w ++ "," ++ show h ++ ",[" ++ vs ++ "])"+ where+ vs = jsList show $ V.toList d++jsImageData :: ImageData -> String+jsImageData = showJS++instance JSArg Bool where+ showJS True = "true"+ showJS False = "false"++jsBool :: Bool -> String+jsBool = showJS++instance JSArg Text where + showJS str = show str++jsText :: Text -> String+jsText = showJS++jsList :: (a -> String) -> [a] -> String+jsList js = concat . intersperse "," . map js
+ Graphics/Blank/Style.hs view
@@ -0,0 +1,13 @@+-- | These are overloaded versions of 'strokeStyle' and 'fillStyle'.++module Graphics.Blank.Style + ( strokeStyle+ , fillStyle+ , Style+ ) where++import Graphics.Blank.Generated+import Graphics.Blank.JavaScript+++
+ Graphics/Blank/Utils.hs view
@@ -0,0 +1,31 @@+module Graphics.Blank.Utils where++import Graphics.Blank.Canvas+import Graphics.Blank.Generated+import Graphics.Blank.JavaScript++-- | Clear the screen. Restores the default transformation matrix.+clearCanvas :: Canvas ()+clearCanvas = do+ setTransform (1, 0, 0, 1, 0, 0)+ me <- myCanvasContext+ clearRect (0,0,width me,height me)++-- | Wrap a canvas computation in 'save' / 'restore'.+saveRestore :: Canvas () -> Canvas ()+saveRestore m = do+ save ()+ m+ restore ()+ + +infixr 0 #++-- | The @#@-operator is the Haskell analog to the @.@-operator+-- in Javascript. Example:+--+-- > grd # addColorStop(0, "#8ED6FF");+--+-- This can be seen as equivalent of @document.addColorStop(0, "#8ED6FF")@.+(#) :: a -> (a -> Canvas b) -> Canvas b+(#) obj act = act obj
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c)2012, The University of Kansas+Copyright (c)2014, The University of Kansas All rights reserved.
− README
@@ -1,13 +0,0 @@-blank-canvas is a Haskell port of the HTML5 Canvas API.-Tutorials and examples for the HTML5 for the HTML5 Canvas-should be trivial to port to this library.--blank-canvas works by providing a web service, that-displays the users' Haskell commands inside a browser.--There are several examples inside the 'examples' directory.--Enjoy!----FPG @ KU-
+ README.md view
@@ -0,0 +1,52 @@+### Background++**blank-canvas** is a Haskell binding to the complete HTML5 Canvas+API. blank-canvas allows Haskell users to write, in Haskell,+interactive images onto their web browsers. blank-canvas gives the+user a single full-window canvas, and provides many well-documented+functions for rendering images.++### First Example++````Haskell+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Graphics.Blank -- import the blank canvas++main = blankCanvas 3000 $ \ context -> do -- start blank canvas on port 3000+ send context $ do -- send commands to this specific context+ moveTo(50,50)+ lineTo(200,100)+ lineWidth 10+ strokeStyle "red"+ stroke() -- this draws the ink into the canvas+````++Running this program, and going to <http://localhost:3000/> gives++++For more details about this example, see [Red Line](https://github.com/ku-fpg/blank-canvas/wiki/Red%20Line).++### Documentation++| Link | Notes |+|-------|-------|+| [Examples](https://github.com/ku-fpg/blank-canvas/wiki/Examples) | Various complete examples of using blank-canvas |+| [Installation](https://github.com/ku-fpg/blank-canvas/wiki/Installation) | How to install blank-canvas |+| [Hackage](https://hackage.haskell.org/package/blank-canvas) | Current release is 0.4.0 |+| [API](https://github.com/ku-fpg/blank-canvas/wiki/API) | Discussion of API, compared with the original JavaScript API |+| [Canvas Examples](https://github.com/ku-fpg/blank-canvas/wiki/Canvas%20Examples) | Transliterated from <http://www.html5canvastutorials.com/> into Haskell and blank-canvas, with kind permission of Eric Rowell, author of the JavaScript HTML5 Canvas Tutorial. |+| [FAQ](https://github.com/ku-fpg/blank-canvas/wiki/FAQ) | F.A.Q. |++#### Other Links++ * <http://www.html5canvastutorials.com/>+ * <http://www.webcodeapp.com/>++### Credits++Thank you to Eric Rowell, for allowing blank-canvas to base our Canvas examples on his JavaScript Canvas examples.++The "Haskell" picture is taken by [Mandy Lackey](https://www.flickr.com/photos/mandaloo/), from link <<http://www.flickr.com/photos/77649176@N00/3776224595/>.> This picture allows sharing, under the [creative commons license](https://creativecommons.org/licenses/by-nc-sa/2.0/).
blank-canvas.cabal view
@@ -1,62 +1,82 @@ Name: blank-canvas-Version: 0.3.1+Version: 0.4.0 Synopsis: HTML5 Canvas Graphics Library-Description: A Haskell port of the HTML5 Canvas API.- blank-canvas works by providing a web service that- displays the users' Haskell commands inside a browser. +Description: blank-canvas is a Haskell binding to the complete+ HTML5 Canvas API. blank-canvas allows Haskell+ users to write, in Haskell, interactive images+ onto their web browsers. blank-canvas gives the+ user a single full-window canvas, and provides+ many well-documented functions for rendering+ images.+ .+ @+ {-# LANGUAGE OverloadedStrings #-}+ module Main where+ import Graphics.Blank -- import the blank canvas+ .+ main = blankCanvas 3000 $ \\ context -> do -- start blank canvas on port 3000+   send context $ do -- send commands to this specific context+     moveTo(50,50)+     lineTo(200,100)+     lineWidth 10+     strokeStyle "red"+     stroke() -- this draws the ink into the canvas+ @+ .+ <<https://github.com/ku-fpg/blank-canvas/wiki/images/Red_Line.png>>+ .+ For more details, read the <https://github.com/ku-fpg/blank-canvas/wiki blank-canvas wiki>.+ . License: BSD3 License-file: LICENSE Author: Andy Gill Maintainer: andygill@ku.edu-Copyright: Copyright (c) 2013 The University of Kansas-Homepage: http://ittc.ku.edu/csdl/fpg/Tools/BlankCanvas+Copyright: Copyright (c) 2014 The University of Kansas+Homepage: https://github.com/ku-fpg/blank-canvas/wiki+Bug-reports: https://github.com/ku-fpg/blank-canvas/issues Category: Graphics Build-type: Simple-Extra-source-files: README+Stability: beta+Extra-source-files: README.md Cabal-version: >= 1.10 data-files: static/index.html static/jquery.js static/jquery-json.js- examples/Makefile- examples/square/Main.hs- examples/square/Makefile- examples/tictactoe/Main.hs- examples/tictactoe/Makefile- examples/html5canvastutorial/Main.hs- examples/html5canvastutorial/Makefile- examples/trivial/Main.hs- examples/trivial/Makefile- examples/rotate-square/Main.hs- examples/rotate-square/Makefile- examples/keyread/Main.hs- examples/keyread/Makefile Library- Exposed-modules: Graphics.Blank+ Exposed-modules: Graphics.Blank, + Graphics.Blank.GHCi,+ Graphics.Blank.Style other-modules: Graphics.Blank.Canvas,- Graphics.Blank.Context,+ Graphics.Blank.DeviceContext, Graphics.Blank.Events, Graphics.Blank.Generated,+ Graphics.Blank.JavaScript,+ Graphics.Blank.Utils, Paths_blank_canvas default-language: Haskell2010- build-depends: base >= 4.3.1 && < 5,- aeson == 0.6.*,+ build-depends: base >= 4.3.1 && < 4.8,+ bytestring == 0.10.*,+ aeson == 0.7.*, containers == 0.5.*,- scotty == 0.5.*,- wai == 1.4.*,+ kansas-comet == 0.3.*,+ scotty == 0.8.*, http-types == 0.8.*,- text == 0.11.*,- network == 2.4.*,- transformers == 0.3.*,- wai-extra == 1.3.*,- warp >= 1.3.1 && < 1.4,- stm >= 2.2 && < 2.5+ text >= 1.1 && < 1.2,+ network >= 2.4 && < 2.6,+ transformers >= 0.3 && < 0.5,+ wai == 3.*,+ wai-extra == 3.*,+ warp == 3.*,+ stm >= 2.2 && < 2.5,+ vector >= 0.10 && < 0.11 - GHC-options: -Wall -fno-warn-orphans+ GHC-options: -Wall -fno-warn-orphans -fno-warn-warnings-deprecations source-repository head type: git location: git://github.com/ku-fpg/blank-canvas.git+
− examples/Makefile
@@ -1,18 +0,0 @@--# Make using installed package-build::- (cd rotate-square; make build)- (cd trivial; make build)- (cd html5canvastutorial; make build)- (cd square; make build)- (cd tictactoe; make build)- (cd keyread; make build)--# Make using source-build-inplace::- (cd rotate-square; make build-inplace)- (cd trivial; make build-inplace)- (cd html5canvastutorial; make build-inplace)- (cd square; make build-inplace)- (cd tictactoe; make build-inplace)- (cd keyread; make build-inplace)
− examples/html5canvastutorial/Main.hs
@@ -1,153 +0,0 @@-module Main (main) where--import Graphics.Blank--main = blankCanvas 3000 $ \ canvas ->- sequence_ [ -- blank the screeen- do send canvas $ do- (width,height) <- size- clearRect (0,0,width,height)- beginPath()-- -- run this example- send canvas $ do- save()- example- restore()-- -- draw the watermark in corner- send canvas $ message name-- -- wait for a mouse press- send canvas $ readEvent MouseDown-- | (example,name) <- cycle examples- ]--examples =- [ (example_1_2_1,"1.2.1 Line")- , (example_1_2_2,"1.2.2 Line Width")- , (example_1_2_3,"1.2.3 Line Color")- , (example_1_2_4,"1.2.4 Line Cap")- , (example_1_3_1,"1.3.1 Arc")- , (example_1_5_4,"1.5.4 Circle")- , (example_1_8_1,"1.8.1 Text Font & Size")- , (example_1_8_2,"1.8.2 Text Color")- , (example_1_8_3,"1.8.3 Text Stroke")- , (example_1_8_4,"1.8.4 Text Align")- , (example_1_8_5,"1.8.5 Text Baseline")- ]---- Examples taken from http://www.html5canvastutorials.com/tutorials/html5-canvas-tutorials-introduction/--{- For example, here is the JavaScript for 1.2.1- context.moveTo(100, 150);- context.lineTo(450, 50);- context.stroke();--}-example_1_2_1 = do- moveTo(100,150)- lineTo(450,50)- stroke()--example_1_2_2 = do- moveTo(100,150)- lineTo(450,50)- lineWidth 15- stroke()--example_1_2_3 = do- moveTo(100,150)- lineTo(450,50)- lineWidth 5- strokeStyle "#ff0000"- stroke()--example_1_2_4 = do- (width,height) <- size-- sequence_- [ do beginPath()- moveTo(200, height / 2 + n)- lineTo(width - 200, height / 2 + n)- lineWidth 20- strokeStyle "#0000ff"- lineCap cap- stroke()- | (cap,n) <- zip ["butt","round","square"] [-50,0,50]- ]--example_1_3_1 = do- (width,height) <- size- let centerX = width / 2;- let centerY = height / 2;- let radius = 75;- let startingAngle = 1.1 * pi- let endingAngle = 1.9 * pi- let counterclockwise = False- arc(centerX, centerY, radius, startingAngle, endingAngle, counterclockwise)- lineWidth 15- strokeStyle "black"- stroke()--example_1_5_4 = do- (width,height) <- size- let centerX = width / 2- let centerY = height / 2- let radius = 70-- beginPath()- arc(centerX, centerY, radius, 0, 2 * pi, False)- fillStyle "#8ED6FF"- fill()- lineWidth 5- strokeStyle "black"- stroke()--example_1_8_1 = do- font "40pt Calibri"- fillText("Hello World!", 150, 100)--example_1_8_2 = do- font "40pt Calibri"- fillStyle "#0000ff"- fillText("Hello World!", 150, 100)--example_1_8_3 = do- font "60pt Calibri"- lineWidth 3- strokeStyle "blue"- strokeText("Hello World!", 80, 110)--example_1_8_4 = do- (width,height) <- size- let x = width / 2- let y = height / 2- font "30pt Calibri"- textAlign "center"- fillStyle "blue"- fillText("Hello World!", x, y)--example_1_8_5 = do- (width,height) <- size- let x = width / 2- let y = height / 2- font "30pt Calibri"- textAlign "center"- textBaseline "middle"- fillStyle "blue"- fillText("Hello World!", x, y)---------------------------------------------------------------------------------- Small "watermark-like text in the bottom corner"-message :: String -> Canvas ()-message msg = do- save()- (width,height) <- size- font "30pt Calibri"- textAlign "left"- fillStyle "#8090a0"- fillText(msg, 10, height - 10)- restore()
− examples/html5canvastutorial/Makefile
@@ -1,18 +0,0 @@-BIN=tutorial--# 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-
− examples/keyread/Main.hs
@@ -1,43 +0,0 @@-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
@@ -1,18 +0,0 @@-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-
− examples/rotate-square/Main.hs
@@ -1,26 +0,0 @@-module Main where--import Graphics.Blank--main = blankCanvas 3000 $ \ context -> loop context (0 :: Float)--loop context n = do- send context $ do- (width,height) <- size- clearRect (0,0,width,height)- beginPath()- save()- translate (width / 2,height / 2)- rotate (pi * n)- beginPath()- moveTo(-100,-100)- lineTo(-100,100)- lineTo(100,100)- lineTo(100,-100)- closePath()- lineWidth 10- strokeStyle "green"- stroke()- restore()- loop context (n + 0.01)-
− examples/rotate-square/Makefile
@@ -1,18 +0,0 @@-BIN=rotate-square--# 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-
− examples/square/Main.hs
@@ -1,32 +0,0 @@-module Main where--import Graphics.Blank--main = blankCanvas 3000 $ \ context -> do- let loop (x,y) (color:colors) = do- send context $ do- save()- translate (x,y)- beginPath()- moveTo(-100,-100)- lineTo(-100,100)- lineTo(100,100)- lineTo(100,-100)- closePath()- lineWidth 10- strokeStyle color- stroke()- restore()-- event <- send context $ readEvent MouseDown- case jsMouse event of- Nothing -> loop (x,y) colors- Just (x',y') -> loop (fromIntegral x',fromIntegral y') colors-- (width,height) <- send context size- loop (width / 2,height / 2)- (cycle [ "#749871", "#1887f2", "#808080", "f01234"])----
− examples/square/Makefile
@@ -1,18 +0,0 @@-BIN=square--# 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-
− examples/tictactoe/Main.hs
@@ -1,109 +0,0 @@-module Main where--import Graphics.Blank-import Data.Map (Map)-import qualified Data.Map as Map-import Debug.Trace--main = blankCanvas 3000 $ \ context -> loop context Map.empty X-data XO = X | O- deriving (Eq,Ord,Show)--swap :: XO -> XO-swap X = O-swap O = X--loop :: Context -> Map (Int,Int) XO -> XO -> IO ()-loop context board turn = do--- print board--- print turn- (width,height,sz) <- send context $ do- (width,height) <- size- clearRect (0,0,width,height)- beginPath()-- let sz = min width height- save()- translate (width / 2,height / 2)- sequence_ [ do bigLine (-sz * 0.45,n) (sz * 0.45,n)- bigLine (n,-sz * 0.45) (n,sz * 0.45)- | n <- [-sz * 0.15,sz * 0.15]- ]--- sequence_ [ do save()- translate (fromIntegral x * sz * 0.3,fromIntegral y * sz * 0.3)- case Map.lookup (x,y) board of- Just X -> drawX (sz * 0.1)- Just O -> drawO (sz * 0.1)- Nothing -> return ()- restore()- | x <- [-1,0,1]- , y <- [-1,0,1]- ]- restore()- return (width,height,sz)-- let pointToSq :: (Float,Float) -> Maybe (Int,Int)- pointToSq (x,y) = do- x' <- fd ((x - width / 2) / sz)- y' <- fd ((y - height / 2) / sz)- return (x',y')-- fd x = --- trace (show ("fx",x,r)) $- if r `elem` [-1..1] then Just (signum r) else Nothing- where r = round (x * 3.3333)-- event <- send context $ readEvent MouseDown--- print event- case jsMouse event of- -- if no mouse location, ignore, and redraw- Nothing -> loop context board turn- Just (x',y') -> case pointToSq (fromIntegral x',fromIntegral y') of- Nothing -> loop context board turn- Just pos -> case Map.lookup pos board of- Nothing -> loop context- (Map.insert pos turn board)- (swap turn)- -- already something here- Just _ -> loop context board turn---xColor = "#ff0000"-oColor = "#00a000"-boardColor = "#000080"--drawX :: Float -> Canvas ()-drawX size = do- strokeStyle xColor- lineCap "butt"- beginPath()- moveTo(-size,-size)- lineTo(size,size)- lineWidth 10- stroke()- beginPath()- moveTo(-size,size)- lineTo(size,-size)- lineWidth 10- stroke()--drawO :: Float -> Canvas ()-drawO radius = do- beginPath()- arc(0, 0, radius, 0, 2 * pi, False)- lineWidth 10- strokeStyle oColor- stroke()--bigLine :: (Float,Float) -> (Float,Float) -> Canvas ()-bigLine (x,y) (x',y') = do- beginPath()- moveTo(x,y)- lineTo(x',y')- lineWidth 20- strokeStyle boardColor- lineCap "round"- stroke()-
− examples/tictactoe/Makefile
@@ -1,18 +0,0 @@-BIN=tictactoe--# 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-
− examples/trivial/Main.hs
@@ -1,12 +0,0 @@-module Main where--import Graphics.Blank--main = blankCanvas 3000 $ \ context -> do- send context $ do- moveTo(50,50)- lineTo(200,100)- lineWidth 10- strokeStyle "red"- stroke()-
− examples/trivial/Makefile
@@ -1,18 +0,0 @@-BIN=trivial--# 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-
static/index.html view
@@ -1,27 +1,132 @@ <html> <head>- <title>Blank Canvas</title>+ <link rel="icon" type="image/png" href="data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAABxUlEQVRYR+1WPU/CUBQ9r8ENIiNs1dlEGJmssxL5Hy46GN2Uf4KJBhMHSOQH6OYmJA5Otk7qJCQshvqur6YWXmnLayGwtGuTe887H/dehhV/bMX9kQJIGfAYeEfW0ICdSVNy2JdFvdmHljkCNPL+cd6DVW0vwsAegC8g/42cJYqujwvTfQHDXWx02sKuB1JDzsqw9rrzgpA88IlcTTyzJRflxwX9qgFtTQZH6MLcLy8UgFPsA1lBLZt8bZ8wKhf12xI05gNHdbxWL+YBMZWCZUsRGMNlShE6B+JKQTdnbXDtSUkOojqrPP9JFwogiRTUPK2BsfOZIFQAOEWSSEGPWyKabDsShCqAJKmg65MGkNGjWbAtVnlxYj17GwZ4YSBiWQqOpagoBhS1Di2McuEs/IzelABESsAyptA7P/VSd0BFSqEigWtCUzTwmhDooYihETiaJSRUj0yFCoCY1A/kHeJKEZaKWQBiUU/UA9lG0l0RNorVqf/fivpdLcmumAIQj3rfMkqwttXXsd/1DvVmtSR5T2/l40rhP0jiU+/PYUwppJNM1DLkenZjfJJN/OHiGIk6yTY74oQjeUaE3A3pVZwykDLwC4/VJDBDudEqAAAAAElFTkSuQmCC"/>+ <title>Blank Canvas</title> <script type="text/javascript" src="jquery.js"></script> <script type="text/javascript" src="jquery-json.js"></script>+ <script type="text/javascript" src="kansas-comet.js"></script> </head> <body style="padding: 0px; margin: 0px; border:0px"> <div id="canvas"></div> <script type="text/javascript"> var session = 0; // global session number+ var images = [];+ var gradients = [];+ var patterns = [];+ var canvasbuffers = [];+ var c = null;+ var myDevicePixelRatio = 1; // "my" because this would nameclass with the window.* version++ var urlQuery = {};+ // From http://stackoverflow.com/questions/901115/how-can-i-get-query-string-values-in-javascript+ location.search.substr(1).split("&").forEach(function(item) {+ urlQuery[item.split("=")[0]] = item.split("=")[1];+ });++ function reply(e) {+ return function(u) { return $.kc.reply(u,e); }+ } function getContext() {- var canvas = document.getElementById("canvas");- if (canvas.getContext) {- return canvas.getContext("2d");+ var canvas = document.getElementById("canvas");+ if (canvas.getContext) {+ return canvas.getContext("2d");+ }+ alert("no canvas");+ }+ // These are the Queries++ function Device(u,c) {+ $.kc.reply(u,[c.canvas.width, c.canvas.height,myDevicePixelRatio]);+ }+ function Size(u,c) {+ $.kc.reply(u,[c.canvas.width, c.canvas.height]);+ }+ function ToDataURL(u,c) {+ $.kc.reply(u,c.canvas.toDataURL());+ + }+ function NewImage(src) { + return function (u,c) {+ var img = new Image();+ var count = images.push(img);+ img.onload = function() {+ $.kc.reply(u,[count - 1,img.width,img.height]);+ };+ img.onerror = function() { alert("Image " + src + " not found.\nAdd as a static file to fix this."); };+ img.src = src;+ } + }++ function CreateLinearGradient(x0,y0,x1,y1) { + return function (u,c) {+ var count = gradients.push(c.createLinearGradient(x0,y0,x1,y1));+ $.kc.reply(u,count - 1);+ } + }++ function CreateRadialGradient(x0,y0,r0,x1,y1,r1) { + return function (u,c) {+ var count = gradients.push(c.createRadialGradient(x0,y0,r0,x1,y1,r1));+ $.kc.reply(u,count - 1);+ } + }++ function CreatePattern(img,src) { + return function (u,c) {+ var count = patterns.push(c.createPattern(img,src));+ $.kc.reply(u,count - 1);+ } + }++ function MeasureText(txt) { + return function (u,c) {+ $.kc.reply(u,c.measureText(txt));+ } + }+ function IsPointInPath(x,y) { + return function (u,c) {+ $.kc.reply(u,c.isPointInPath(x,y));+ } + }++ function NewCanvas(w,h) { + return function (u,c) {+ var canvas = document.createElement('canvas');+ canvas.width = w;+ canvas.height = h;+ var count = canvasbuffers.push(canvas.getContext("2d"));+ $.kc.reply(u,[count - 1,w,h]); + } + }++ function GetImageData(sx,sy,sw,sh) { + return function (u,c) {+ var img = c.getImageData(sx,sy,sw,sh);+ var arr = [];+ for(var i = 0;i < img.data.length;i++) {+ arr[i] = img.data[i]; }- alert("no canvas");+ $.kc.reply(u,{ width: img.width+ , height: img.height+ , data: arr+ });+ } }- function register(name,mysession) {++ function Trigger(e) { + $.kc.event({ eMetaKey: e.eMetaKey,+ ePageXY : e.ePageXY,+ eType : e.eType,+ eWhich : e.eWhich+ });+ }+ function register(name) { $(document).bind(name,function (e){- $.ajax({ url: "/event/" + mysession,- type: "POST",- data: $.toJSON([name,e.which,e.pageX, e.pageY]),- contentType: "application/json; charset=utf-8",- dataType: "json"});+ $.kc.event({ eMetaKey: e.metaKey,+ ePageXY : [e.pageX,e.pageY],+ eType : e.type,+ eWhich : e.which+ }); }); } function redraw() {@@ -34,21 +139,41 @@ }); } + function ImageData(w,h,dat) { + var imgData = canvasbuffers[0].createImageData(w,h);+ for(var i = 0;i < dat.length;i ++) {+ imgData.data[i] = dat[i];+ }+ return imgData;+ }+ $(document).ready(function() { // Make the canvas the size of the window var w = $(window).width(); var h = $(window).height();-+ var b = "0";+ if (urlQuery.border && !isNaN(parseInt(urlQuery.border))) {+ b = parseInt(urlQuery.border);+ w -= b * 2;+ h -= b * 2;+ }+ if (urlQuery.width) {+ w = urlQuery.width;+ }+ if (urlQuery.height) {+ h = urlQuery.height;+ }+ if ('hd' in urlQuery && 'devicePixelRatio' in window) {+ myDevicePixelRatio = window.devicePixelRatio;+ } $("#canvas").replaceWith(- '<canvas id="canvas" width="' + w + '" height="' + h +- '" style="border: blue solid 0px; padding: 0px; margin: 0px"></canvas>');-- // start the server-side- $.ajax({ url: "/start",- type: "POST",- contentType: "application/json; charset=utf-8",- data: $.toJSON([w,h]),- dataType: "script"}); + '<canvas id="canvas" width="' + (w * myDevicePixelRatio) + '" height="' + (h * myDevicePixelRatio) ++ '" style="border: black solid ' + b + 'px; padding: 0px; margin: 0px"></canvas>');+ $("#canvas").css("width",w + "px"); + $("#canvas").css("height",h + "px"); + c = getContext("2d");+ canvasbuffers.push(c);+ $.kc.connect("/blank"); }); </script> </body>