diff --git a/Graphics/Blank.hs b/Graphics/Blank.hs --- a/Graphics/Blank.hs +++ b/Graphics/Blank.hs @@ -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 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 + diff --git a/Graphics/Blank/Canvas.hs b/Graphics/Blank/Canvas.hs --- a/Graphics/Blank/Canvas.hs +++ b/Graphics/Blank/Canvas.hs @@ -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 () -- . + Command :: Command -> Canvas () -- + 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 diff --git a/Graphics/Blank/Context.hs b/Graphics/Blank/Context.hs deleted file mode 100644 --- a/Graphics/Blank/Context.hs +++ /dev/null @@ -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 "}" diff --git a/Graphics/Blank/DeviceContext.hs b/Graphics/Blank/DeviceContext.hs new file mode 100644 --- /dev/null +++ b/Graphics/Blank/DeviceContext.hs @@ -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) diff --git a/Graphics/Blank/Events.hs b/Graphics/Blank/Events.hs --- a/Graphics/Blank/Events.hs +++ b/Graphics/Blank/Events.hs @@ -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 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 diff --git a/Graphics/Blank/GHCi.hs b/Graphics/Blank/GHCi.hs new file mode 100644 --- /dev/null +++ b/Graphics/Blank/GHCi.hs @@ -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 [] + diff --git a/Graphics/Blank/Generated.hs b/Graphics/Blank/Generated.hs --- a/Graphics/Blank/Generated.hs +++ b/Graphics/Blank/Generated.hs @@ -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 diff --git a/Graphics/Blank/JavaScript.hs b/Graphics/Blank/JavaScript.hs new file mode 100644 --- /dev/null +++ b/Graphics/Blank/JavaScript.hs @@ -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 diff --git a/Graphics/Blank/Style.hs b/Graphics/Blank/Style.hs new file mode 100644 --- /dev/null +++ b/Graphics/Blank/Style.hs @@ -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 + + + diff --git a/Graphics/Blank/Utils.hs b/Graphics/Blank/Utils.hs new file mode 100644 --- /dev/null +++ b/Graphics/Blank/Utils.hs @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c)2012, The University of Kansas +Copyright (c)2014, The University of Kansas All rights reserved. diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -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 - diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 gives + +![images/Red_Line.png](https://github.com/ku-fpg/blank-canvas/wiki/images/Red_Line.png) + +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 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 + + * + * + +### 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 <.> This picture allows sharing, under the [creative commons license](https://creativecommons.org/licenses/by-nc-sa/2.0/). diff --git a/blank-canvas.cabal b/blank-canvas.cabal --- a/blank-canvas.cabal +++ b/blank-canvas.cabal @@ -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 + @ + . + <> + . + For more details, read the . + . 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 + diff --git a/examples/Makefile b/examples/Makefile deleted file mode 100644 --- a/examples/Makefile +++ /dev/null @@ -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) diff --git a/examples/html5canvastutorial/Main.hs b/examples/html5canvastutorial/Main.hs deleted file mode 100644 --- a/examples/html5canvastutorial/Main.hs +++ /dev/null @@ -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() diff --git a/examples/html5canvastutorial/Makefile b/examples/html5canvastutorial/Makefile deleted file mode 100644 --- a/examples/html5canvastutorial/Makefile +++ /dev/null @@ -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 - diff --git a/examples/keyread/Main.hs b/examples/keyread/Main.hs deleted file mode 100644 --- a/examples/keyread/Main.hs +++ /dev/null @@ -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 - - diff --git a/examples/keyread/Makefile b/examples/keyread/Makefile deleted file mode 100644 --- a/examples/keyread/Makefile +++ /dev/null @@ -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 - diff --git a/examples/rotate-square/Main.hs b/examples/rotate-square/Main.hs deleted file mode 100644 --- a/examples/rotate-square/Main.hs +++ /dev/null @@ -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) - diff --git a/examples/rotate-square/Makefile b/examples/rotate-square/Makefile deleted file mode 100644 --- a/examples/rotate-square/Makefile +++ /dev/null @@ -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 - diff --git a/examples/square/Main.hs b/examples/square/Main.hs deleted file mode 100644 --- a/examples/square/Main.hs +++ /dev/null @@ -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"]) - - - - diff --git a/examples/square/Makefile b/examples/square/Makefile deleted file mode 100644 --- a/examples/square/Makefile +++ /dev/null @@ -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 - diff --git a/examples/tictactoe/Main.hs b/examples/tictactoe/Main.hs deleted file mode 100644 --- a/examples/tictactoe/Main.hs +++ /dev/null @@ -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() - diff --git a/examples/tictactoe/Makefile b/examples/tictactoe/Makefile deleted file mode 100644 --- a/examples/tictactoe/Makefile +++ /dev/null @@ -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 - diff --git a/examples/trivial/Main.hs b/examples/trivial/Main.hs deleted file mode 100644 --- a/examples/trivial/Main.hs +++ /dev/null @@ -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() - diff --git a/examples/trivial/Makefile b/examples/trivial/Makefile deleted file mode 100644 --- a/examples/trivial/Makefile +++ /dev/null @@ -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 - diff --git a/static/index.html b/static/index.html --- a/static/index.html +++ b/static/index.html @@ -1,27 +1,132 @@ - Blank Canvas + + Blank Canvas +