Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Loading…

Working diagrams-canvas based on blank-canvas! #1

Merged
merged 13 commits into from

2 participants

@byorgey

It now works on all the examples I've tried it on, with the caveats that

  • HTML5 canvas does not support drawing dashed lines, so neither does diagrams-canvas for now. Perhaps at some point we can write code to explicitly simulate dashed lines.
  • diagrams-canvas doesn't yet support text.

Next up is animation support.

@andygill andygill merged commit 1a26094 into from
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Commits on Apr 20, 2012
  1. update diagrams-canvas and port to blank-canvas

    Brent Yorgey authored
Commits on Apr 22, 2012
  1. fix color serialization bug (remove unnecessary quotes)

    Brent Yorgey authored
  2. Explicitly set transparent fill as the default (the canvas default is…

    Brent Yorgey authored
    … black).
  3. clean up trailing whitespace

    Brent Yorgey authored
  4. clean up warnings

    Brent Yorgey authored
  5. Set default line width to 0.01.

    Brent Yorgey authored
  6. clean up imports

    Brent Yorgey authored
  7. Canvas does not support line widths of 0, so simulate it by sending

    Brent Yorgey authored
    stroke commands only when the line width is positive.
  8. Handle opacity.

    Brent Yorgey authored
Commits on Sep 19, 2012
  1. import .gitignore

    Brent Yorgey authored
  2. bump cmdargs upper bound

    Brent Yorgey authored
  3. add simple example

    Brent Yorgey authored
This page is out of date. Refresh to see the latest.
View
12 .gitignore
@@ -0,0 +1,12 @@
+dist
+cabal-dev
+*.o
+*.hi
+*.chi
+*.chs.h
+.virthualenv
+*~
+.hsenv_*
+dist_*
+history
+TAGS
View
3  Setup.hs
@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+import Distribution.Simple
+main = defaultMain
View
40 diagrams-canvas.cabal
@@ -1,54 +1,32 @@
Name: diagrams-canvas
-Version: 0.1
+Version: 0.2
Synopsis: HTML5 canvas backend for diagrams drawing EDSL
Description: This package provides a modular backend for rendering
diagrams created with the diagrams EDSL using an
HTML5 canvas.
-Homepage: http://code.haskell.org/diagrams/
+Homepage: http://projects.haskell.org/diagrams/
License: BSD3
License-file: LICENSE
Author: Ryan Yates
-Maintainer: fryguybob@gmail.com
+Maintainer: byorgey@cis.upenn.edu
Stability: Experimental
Category: Graphics
Build-type: Simple
Cabal-version: >=1.8
Source-repository head
- type: darcs
- location: http://patch-tag.com/r/fryguybob/diagrams-canvas
+ type: git
+ location: https://github.com/ku-fpg/diagrams-canvas.git
Library
Exposed-modules: Diagrams.Backend.Canvas
Diagrams.Backend.Canvas.CmdLine
Graphics.Rendering.Canvas
Hs-source-dirs: src
- Build-depends: base >= 4.3 && < 4.5,
+ Build-depends: base >= 4.3 && < 4.6,
mtl >= 2.0 && < 3.0,
- process >= 1.0 && < 1.2,
- directory >= 1.0 && < 1.2,
- old-time >= 1.0 && < 1.1,
- dlist >= 0.5 && < 0.6,
- vector-space >= 0.7 && < 0.8,
+ vector-space >= 0.7 && < 0.9,
NumInstances >= 1.0 && < 1.1,
diagrams-core >= 0.5 && < 0.6,
diagrams-lib >= 0.5 && < 0.6,
- cmdargs >= 0.6 && < 0.9,
- split >= 0.1.2 && < 0.2
- if !os(windows)
- cpp-options: -DCMDLINELOOP
- Build-depends: unix >= 2.4 && < 2.6
-
-test-suite active-tests
- type: exitcode-stdio-1.0
- main-is: active-tests.hs
- build-depends: base >= 4.0 && < 4.6,
- array >= 0.3 && < 0.5,
- semigroups >= 0.1 && < 0.9,
- semigroupoids >= 1.2 && < 1.3,
- vector-space >= 0.8 && < 0.9,
- newtype >= 0.2 && < 0.3,
-
- QuickCheck >= 2.4.2 && < 2.5
- hs-source-dirs: src, test
-
-
+ cmdargs >= 0.6 && < 0.11,
+ blank-canvas >= 0.2.1 && < 0.3
View
21 example/Sierpinski.hs
@@ -0,0 +1,21 @@
+{- 1. Compile
+ 2. Run with a size parameter, e.g.
+
+ ./Sierpinski -w 400
+
+ 3. Visit localhost:3000 in your browser
+-}
+
+{-# LANGUAGE NoMonomorphismRestriction #-}
+import Diagrams.Prelude
+import Diagrams.Backend.Canvas.CmdLine
+
+sierpinski 1 = eqTriangle 1
+sierpinski n = s
+ ===
+ (s ||| s) # centerX
+ where s = sierpinski (n-1)
+
+example = pad 1.1 $ sierpinski 7 # centerXY # lw 0 # fc black
+
+main = defaultMain example
View
85 src/Diagrams/Backend/Canvas.hs
@@ -4,6 +4,7 @@
, FlexibleContexts
, TypeSynonymInstances
, DeriveDataTypeable
+ , ViewPatterns
#-}
{-|
The Canvas backend.
@@ -13,68 +14,41 @@ module Diagrams.Backend.Canvas
( Canvas(..) -- rendering token
, Options(..) -- for rendering options specific to Canvas
- , OutputFormat(..) -- output format options
) where
-import qualified Graphics.Rendering.Canvas as C
-
-import Diagrams.Prelude
-
-import Graphics.Rendering.Diagrams.Transform
-
-import Diagrams.TwoD.Shapes
-import Diagrams.TwoD.Adjust (adjustDia2D, adjustSize)
+import Control.Monad (when)
+import qualified Data.Foldable as F
+import Data.Maybe (catMaybes)
+import Data.Typeable
-import Control.Monad (when)
-import Data.Maybe (catMaybes)
+import Diagrams.Prelude
+import Diagrams.TwoD.Adjust (adjustDia2D)
+import qualified Graphics.Blank as BC
+import qualified Graphics.Rendering.Canvas as C
-import Data.VectorSpace
-
-import Data.Monoid
-import qualified Data.Foldable as F
-import Data.Typeable
-- | This data declaration is simply used as a token to distinguish this rendering engine.
data Canvas = Canvas
deriving Typeable
--- | Canvas is able to output to several file formats, which each have their own associated properties that affect the output.
-data OutputFormat = JS | HTML
-
instance Monoid (Render Canvas R2) where
mempty = C $ return ()
- (C r1) `mappend` (C r2) = C (r1 >> r2)
-
+ (C c1) `mappend` (C c2) = C (c1 >> c2)
instance Backend Canvas R2 where
data Render Canvas R2 = C (C.Render ())
- type Result Canvas R2 = IO ()
+ type Result Canvas R2 = BC.Canvas ()
data Options Canvas R2 = CanvasOptions
- { fileName :: String -- ^ the name of the file you want generated
- , canvasSize :: SizeSpec2D -- ^ the requested size
- , outputFormat :: OutputFormat -- ^ the output format and associated options
+ { canvasSize :: SizeSpec2D -- ^ the requested size
}
withStyle _ s t (C r) = C $ do
C.withStyle (canvasTransf t) (canvasStyle s) r
- doRender _ (CanvasOptions file size out) (C r) =
- let surfaceF surface = C.renderWith surface r
- -- Everything except Dims is arbitrary. The backend
- -- should have first run 'adjustDia' to update the
- -- final size of the diagram with explicit dimensions,
- -- so normally we would only expect to get Dims anyway.
- (w,h) = case size of
- Width w' -> (w',w')
- Height h' -> (h',h')
- Dims w' h' -> (w',h')
- Absolute -> (100,100)
-
- in case out of
- JS -> C.withJSSurface file (round w) (round h) surfaceF
- HTML -> C.withHTMLSurface file (round w) (round h) surfaceF
-
- adjustDia c opts d = adjustDia2D canvasSize setCanvasSize c opts (reflectY d)
+ doRender _ (CanvasOptions _) (C r) = C.doRender r
+
+ adjustDia c opts d = adjustDia2D canvasSize setCanvasSize c opts
+ (d # reflectY # fcA transparent # lw 0.01)
where setCanvasSize sz o = o { canvasSize = sz }
renderC :: (Renderable a Canvas, V a ~ R2) => a -> C.Render ()
@@ -87,6 +61,7 @@ canvasStyle s = foldr (>>) (return ())
, handle lWidth
, handle lJoin
, handle lCap
+ , handle opacity_
]
where handle :: (AttributeClass a) => (a -> C.Render ()) -> Maybe (C.Render ())
handle f = f `fmap` getAttr s
@@ -95,16 +70,20 @@ canvasStyle s = foldr (>>) (return ())
lWidth = C.lineWidth . getLineWidth
lCap = C.lineCap . getLineCap
lJoin = C.lineJoin . getLineJoin
+ opacity_ = C.globalAlpha . getOpacity
canvasTransf :: Transformation R2 -> C.Render ()
canvasTransf t = C.transform a1 a2 b1 b2 c1 c2
- where (a1,a2) = apply t (1,0)
- (b1,b2) = apply t (0,1)
- (c1,c2) = transl t
+ where (unr2 -> (a1,a2)) = apply t unitX
+ (unr2 -> (b1,b2)) = apply t unitY
+ (unr2 -> (c1,c2)) = transl t
instance Renderable (Segment R2) Canvas where
- render _ (Linear v) = C $ uncurry C.lineTo v
- render _ (Cubic (x1,y1) (x2,y2) (x3,y3)) = C $ C.curveTo x1 y1 x2 y2 x3 y3
+ render _ (Linear v) = C $ uncurry C.relLineTo (unr2 v)
+ render _ (Cubic (unr2 -> (x1,y1))
+ (unr2 -> (x2,y2))
+ (unr2 -> (x3,y3)))
+ = C $ C.relCurveTo x1 y1 x2 y2 x3 y3
instance Renderable (Trail R2) Canvas where
render _ (Trail segs c) = C $ do
@@ -113,16 +92,6 @@ instance Renderable (Trail R2) Canvas where
instance Renderable (Path R2) Canvas where
render _ (Path trs) = C $ C.newPath >> F.mapM_ renderTrail trs
- where renderTrail (P p, tr) = do
+ where renderTrail (unp2 -> p, tr) = do
uncurry C.moveTo p
renderC tr
-
-absoluteTrail :: R2 -> Trail R2 -> Trail R2
-absoluteTrail v (Trail segs c) = Trail (absolute v segs) c
-
-absolute :: R2 -> [Segment R2] -> [Segment R2]
-absolute _ [] = []
-absolute v (s:ss) = s' : absolute v' ss
- where (v',s') = addV s
- addV (Linear a) = (\p -> (p, Linear p)) (a ^+^ v)
- addV (Cubic a b c) = (c ^+^ v, Cubic (a ^+^ v) (b ^+^ v) (c ^+^ v))
View
143 src/Diagrams/Backend/Canvas/CmdLine.hs
@@ -18,42 +18,19 @@ module Diagrams.Backend.Canvas.CmdLine
, Canvas
) where
-import Diagrams.Prelude hiding (width, height)
-import Diagrams.Backend.Canvas
-
import System.Console.CmdArgs.Implicit hiding (args)
+import System.Environment (getProgName)
-import Prelude hiding (catch)
-
-import Data.Maybe (fromMaybe)
-import Control.Applicative ((<$>))
-import Control.Monad (when)
-import Data.List.Split
-
-import System.Environment (getArgs, getProgName)
-import System.Directory (getModificationTime)
-import System.Process (runProcess, waitForProcess)
-import System.IO (openFile, hClose, IOMode(..),
- hSetBuffering, BufferMode(..), stdout)
-import System.Exit (ExitCode(..))
-import System.Time (ClockTime, getClockTime)
-import Control.Concurrent (threadDelay)
-import Control.Exception (catch, SomeException(..), bracket)
+import Diagrams.Prelude hiding (width, height)
+import Diagrams.Backend.Canvas
+import qualified Graphics.Blank as BC
-#ifdef CMDLINELOOP
-import System.Posix.Process (executeFile)
-#endif
data DiagramOpts = DiagramOpts
{ width :: Maybe Int
, height :: Maybe Int
- , output :: FilePath
+ , port :: Int
, selection :: Maybe String
-#ifdef CMDLINELOOP
- , loop :: Bool
- , src :: Maybe String
- , interval :: Int
-#endif
}
deriving (Show, Data, Typeable)
@@ -61,28 +38,23 @@ diagramOpts :: String -> Bool -> DiagramOpts
diagramOpts prog sel = DiagramOpts
{ width = def
&= typ "INT"
- &= help "Desired width of the output image (default 400)"
+ &= help "Desired width of the output image"
, height = def
&= typ "INT"
- &= help "Desired height of the output image (default 400)"
+ &= help "Desired height of the output image"
- , output = def
- &= typFile
- &= help "Output file"
+ -- , output = def
+ -- &= typFile
+ -- &= help "Output file"
+ , port = 3000
+ &= typ "PORT"
+ &= help "Port on which to start the web server (default 3000)"
+
, selection = def
&= help "Name of the diagram to render"
&= (if sel then typ "NAME" else ignore)
-#ifdef CMDLINELOOP
- , loop = False
- &= help "Run in a self-recompiling loop"
- , src = def
- &= typFile
- &= help "Source file to watch"
- , interval = 1 &= typ "SECONDS"
- &= help "When running in a loop, check for changes every n seconds."
-#endif
}
&= summary "Command-line diagram generation."
&= program prog
@@ -90,30 +62,22 @@ diagramOpts prog sel = DiagramOpts
defaultMain :: Diagram Canvas R2 -> IO ()
defaultMain d = do
prog <- getProgName
- args <- getArgs
opts <- cmdArgs (diagramOpts prog False)
- chooseRender opts d
-#ifdef CMDLINELOOP
- when (loop opts) (waitForChange Nothing opts prog args)
-#endif
-
-chooseRender :: DiagramOpts -> Diagram Canvas R2 -> IO ()
-chooseRender opts d =
- case splitOn "." (output opts) of
- [""] -> putStrLn "No output file given."
- ps | last ps `elem` ["html","js"] -> do
- let outfmt = case last ps of
- "html" -> HTML
- _ -> JS
- sizeSpec = case (width opts, height opts) of
- (Nothing, Nothing) -> Absolute
- (Just w, Nothing) -> Width (fromIntegral w)
- (Nothing, Just h) -> Height (fromIntegral h)
- (Just w, Just h) -> Dims (fromIntegral w)
- (fromIntegral h)
-
- renderDia Canvas (CanvasOptions (output opts) sizeSpec outfmt) d
- | otherwise -> putStrLn $ "Unknown file type: " ++ last ps
+ canvasRender opts d
+
+canvasRender :: DiagramOpts -> Diagram Canvas R2 -> IO ()
+canvasRender opts d = BC.blankCanvas (port opts) (canvasDia opts d)
+
+canvasDia :: DiagramOpts -> Diagram Canvas R2 -> BC.Context -> IO ()
+canvasDia opts d context = do
+ BC.send context $
+ renderDia
+ Canvas
+ (CanvasOptions
+ (mkSizeSpec
+ (fromIntegral <$> width opts)
+ (fromIntegral <$> height opts)))
+ d
multiMain :: [(String, Diagram Canvas R2)] -> IO ()
multiMain ds = do
@@ -123,51 +87,4 @@ multiMain ds = do
Nothing -> putStrLn "No diagram selected."
Just sel -> case lookup sel ds of
Nothing -> putStrLn $ "Unknown diagram: " ++ sel
- Just d -> chooseRender opts d
-
-#ifdef CMDLINELOOP
-waitForChange :: Maybe ClockTime -> DiagramOpts -> String -> [String] -> IO ()
-waitForChange lastAttempt opts prog args = do
- hSetBuffering stdout NoBuffering
- go lastAttempt
- where go lastAtt = do
- threadDelay (1000000 * interval opts)
- -- putStrLn $ "Checking... (last attempt = " ++ show lastAttempt ++ ")"
- (newBin, newAttempt) <- recompile lastAtt prog (src opts)
- if newBin
- then executeFile prog False args Nothing
- else go $ getFirst (First newAttempt <> First lastAtt)
-
--- | @recompile t prog@ attempts to recompile @prog@, assuming the
--- last attempt was made at time @t@. If @t@ is @Nothing@ assume
--- the last attempt time is the same as the modification time of the
--- binary. If the source file modification time is later than the
--- last attempt time, then attempt to recompile, and return the time
--- of this attempt. Otherwise (if nothing has changed since the
--- last attempt), return @Nothing@. Also return a Bool saying
--- whether a successful recompilation happened.
-recompile :: Maybe ClockTime -> String -> Maybe String -> IO (Bool, Maybe ClockTime)
-recompile lastAttempt prog mSrc = do
- let errFile = prog ++ ".errors"
- srcFile = fromMaybe (prog ++ ".hs") mSrc
- binT <- maybe (getModTime prog) (return . Just) lastAttempt
- srcT <- getModTime srcFile
- if (srcT > binT)
- then do
- putStr "Recompiling..."
- status <- bracket (openFile errFile WriteMode) hClose $ \h ->
- waitForProcess =<< runProcess "ghc" ["--make", srcFile]
- Nothing Nothing Nothing Nothing (Just h)
-
- if (status /= ExitSuccess)
- then putStrLn "" >> putStrLn (replicate 75 '-') >> readFile errFile >>= putStr
- else putStrLn "done."
-
- curTime <- getClockTime
- return (status == ExitSuccess, Just curTime)
-
- else return (False, Nothing)
-
- where getModTime f = catch (Just <$> getModificationTime f)
- (\(SomeException _) -> return Nothing)
-#endif
View
196 src/Graphics/Rendering/Canvas.hs
@@ -2,13 +2,12 @@
module Graphics.Rendering.Canvas
( Render(..)
- , renderWith
- , withJSSurface
- , withHTMLSurface
+ , doRender
+
, newPath
, moveTo
- , lineTo
- , curveTo
+ , relLineTo
+ , relCurveTo
, arc
, closePath
, stroke
@@ -24,53 +23,52 @@ module Graphics.Rendering.Canvas
, lineWidth
, lineCap
, lineJoin
+ , globalAlpha
, withStyle
) where
-import Diagrams.Attributes(Color(..),LineCap(..),LineJoin(..))
-import Diagrams.TwoD(R2(..))
-import Control.Monad.State
-import Control.Applicative((<$>))
-import Data.List(intersperse)
-import Data.DList(DList,toList,fromList,append)
-import Data.Word(Word8)
-import Data.Monoid
-import Data.NumInstances
-import System.IO (openFile, hPutStr, IOMode(..), hClose)
+import Control.Applicative((<$>))
+import Control.Arrow ((***))
+import Control.Monad.State
+import Data.NumInstances ()
+import Data.Word(Word8)
+import Diagrams.Attributes(Color(..),LineCap(..),LineJoin(..))
+import qualified Graphics.Blank as C
type RGBA = (Double, Double, Double, Double)
data DrawState = DS
- { dsPos :: R2
+ { dsPos :: (Float,Float)
, dsFill :: RGBA
, dsStroke :: RGBA
, dsCap :: LineCap
, dsJoin :: LineJoin
- , dsWidth :: Double
- , dsTransform :: [Double]
+ , dsWidth :: Float
+ , dsAlpha :: Float
+ , dsTransform :: (Float,Float,Float,Float,Float,Float)
} deriving (Eq)
emptyDS :: DrawState
-emptyDS = DS 0 (0,0,0,1) 0 LineCapButt LineJoinMiter 0 []
+emptyDS = DS 0 (0,0,0,1) 0 LineCapButt LineJoinMiter 0 1 (1,0,0,1,0,0)
data RenderState = RS
{ drawState :: DrawState
, saved :: [DrawState]
- , result :: DList String
}
emptyRS :: RenderState
-emptyRS = RS emptyDS [] mempty
+emptyRS = RS emptyDS []
-newtype Render m = Render { runRender :: StateT RenderState IO m }
+newtype Render m = Render { runRender :: StateT RenderState C.Canvas m }
deriving (Functor, Monad, MonadState RenderState)
-data Surface = Surface { header :: String, footer :: String, width :: Int, height :: Int, fileName :: String }
+doRender :: Render a -> C.Canvas a
+doRender r = evalStateT (runRender r) emptyRS
-write :: DList String -> Render ()
-write s = modify $ \rs@(RS{..}) -> rs { result = result `append` s }
+canvas :: C.Canvas a -> Render a
+canvas = Render . lift
-move :: R2 -> Render ()
+move :: (Float,Float) -> Render ()
move p = modify $ \rs@(RS{..}) -> rs { drawState = drawState { dsPos = p } }
setDS :: DrawState -> Render ()
@@ -79,90 +77,81 @@ setDS d = modify $ (\rs -> rs { drawState = d })
saveRS :: Render ()
saveRS = modify $ \rs@(RS{..}) -> rs { saved = drawState : saved }
+restoreRS :: Render ()
restoreRS = modify go
where
- go rs@(RS{saved = d:ds, ..}) = rs { drawState = d, saved = ds }
+ go rs@(RS{saved = d:ds}) = rs { drawState = d, saved = ds }
go rs = rs
-at :: Render R2
+at :: Render (Float,Float)
at = (dsPos . drawState) <$> get
-renderWith :: MonadIO m => Surface -> Render a -> m a
-renderWith s r = liftIO $ do
- (v,rs) <- runStateT (runRender r) emptyRS
- h <- openFile (fileName s) WriteMode
- hPutStr h (header s)
- mapM_ (hPutStr h) (toList (result rs))
- hPutStr h (footer s)
- hClose h
- return v
-
-withJSSurface :: String -> Int -> Int -> (Surface -> IO a) -> IO a
-withJSSurface file w h f = f s
- where s = Surface jsHeader jsFooter w h file
-
-withHTMLSurface :: String -> Int -> Int -> (Surface -> IO a) -> IO a
-withHTMLSurface file w h f = f s
- where s = Surface htmlHeader (htmlFooter w h) w h file
-
-renderJS :: String -> Render ()
-renderJS s = write $ fromList [jsPrefix, s, ";\n"]
-
-mkJSCall :: Show a => String -> [a] -> Render()
-mkJSCall n vs = renderJS . concat $ [n, "("] ++ intersperse "," (map show vs) ++ [")"]
-
newPath :: Render ()
-newPath = renderJS "beginPath()"
+newPath = canvas $ C.beginPath ()
closePath :: Render ()
-closePath = renderJS "closePath()"
+closePath = canvas $ C.closePath ()
arc :: Double -> Double -> Double -> Double -> Double -> Render ()
-arc a b c d e = mkJSCall "arcTo" [a,b,c,d,e]
+arc a b c d e = canvas $ C.arc (realToFrac a, realToFrac b, realToFrac c, realToFrac d, realToFrac e,True)
moveTo :: Double -> Double -> Render ()
moveTo x y = do
- mkJSCall "moveTo" [x,y]
- move (x,y)
+ let x' = realToFrac x
+ y' = realToFrac y
+ canvas $ C.moveTo (x', y')
+ move (x', y')
-lineTo :: Double -> Double -> Render ()
-lineTo x y = do
+relLineTo :: Double -> Double -> Render ()
+relLineTo x y = do
p <- at
- let p'@(x',y') = p + (x,y)
- mkJSCall "lineTo" [x',y']
+ let p' = p + (realToFrac x, realToFrac y)
+ canvas $ C.lineTo p'
move p'
-curveTo :: Double -> Double -> Double -> Double -> Double -> Double -> Render ()
-curveTo ax ay bx by cx cy = do
--- lineTo cx cy
+relCurveTo :: Double -> Double -> Double -> Double -> Double -> Double -> Render ()
+relCurveTo ax ay bx by cx cy = do
p <- at
- let ps = map (p +) [(ax,ay),(bx,by),(cx,cy)]
- mkJSCall "bezierCurveTo" (concatMap (\(a,b) -> [a,b]) ps)
- move (last ps)
+ let [(ax',ay'),(bx',by'),(cx',cy')] = map ((p +) . (realToFrac *** realToFrac))
+ [(ax,ay),(bx,by),(cx,cy)]
+ canvas $ C.bezierCurveTo (ax',ay',bx',by',cx',cy')
+ move (cx',cy')
stroke :: Render ()
-stroke = renderJS "stroke()"
+stroke = do
+
+ -- From the HTML5 canvas specification regarding line width:
+ --
+ -- "On setting, zero, negative, infinite, and NaN values must be
+ -- ignored, leaving the value unchanged; other values must change
+ -- the current value to the new value.
+ --
+ -- Hence we must implement a line width of zero by simply not
+ -- sending a stroke command.
+
+ w <- gets (dsWidth . drawState)
+ when (w > 0) (canvas $ C.stroke ())
fill :: Render ()
-fill = renderJS "fill()"
+fill = canvas $ C.fill ()
save :: Render ()
-save = saveRS >> renderJS "save()"
+save = saveRS >> canvas (C.save ())
restore :: Render ()
-restore = restoreRS >> renderJS "restore()"
+restore = restoreRS >> canvas (C.restore ())
byteRange :: Double -> Word8
byteRange d = floor (d * 255)
showColorJS :: (Color c) => c -> String
showColorJS c = concat
- [ "\"rgba("
+ [ "rgba("
, s r, ","
, s g, ","
, s b, ","
, show a
- , ")\""
+ , ")"
]
where s = show . byteRange
(r,g,b,a) = colorToRGBA c
@@ -176,33 +165,34 @@ setDSWhen f r = do
transform :: Double -> Double -> Double -> Double -> Double -> Double -> Render ()
transform ax ay bx by tx ty = setDSWhen
(\ds -> ds { dsTransform = vs })
- (mkJSCall "transform" vs)
- where vs = [ax,ay,bx,by,tx,ty]
+ (canvas $ C.transform vs)
+ where vs = (realToFrac ax,realToFrac ay,realToFrac bx,realToFrac by,realToFrac tx,realToFrac ty)
strokeColor :: (Color c) => c -> Render ()
strokeColor c = setDSWhen
(\ds -> ds { dsStroke = colorToRGBA c})
- (renderJS $ "strokeStyle = " ++ showColorJS c)
+ (canvas $ C.strokeStyle (showColorJS c))
fillColor :: (Color c) => c -> Render ()
fillColor c = setDSWhen
(\ds -> ds { dsFill = colorToRGBA c })
- (renderJS $ "fillStyle = " ++ showColorJS c)
+ (canvas $ C.fillStyle (showColorJS c))
lineWidth :: Double -> Render ()
lineWidth w = setDSWhen
- (\ds -> ds { dsWidth = w })
- (renderJS $ "lineWidth = " ++ show w)
+ (\ds -> ds { dsWidth = w' })
+ (canvas $ C.lineWidth w')
+ where w' = realToFrac w
lineCap :: LineCap -> Render ()
lineCap lc = setDSWhen
(\ds -> ds { dsCap = lc })
- (renderJS $ "lineCap = " ++ fromLineCap lc)
+ (canvas $ C.lineCap (fromLineCap lc))
lineJoin :: LineJoin -> Render ()
lineJoin lj = setDSWhen
(\ds -> ds { dsJoin = lj })
- (renderJS $ "lineJoin = " ++ fromLineJoin lj)
+ (canvas $ C.lineJoin (fromLineJoin lj))
fromLineCap :: LineCap -> String
fromLineCap LineCapRound = show "round"
@@ -214,15 +204,21 @@ fromLineJoin LineJoinRound = show "round"
fromLineJoin LineJoinBevel = show "bevel"
fromLineJoin _ = show "miter"
+globalAlpha :: Double -> Render ()
+globalAlpha a = setDSWhen
+ (\ds -> ds { dsAlpha = a' })
+ (canvas $ C.globalAlpha a')
+ where a' = realToFrac a
+
-- TODO: update the transform's state for translate, scale, and rotate
translate :: Double -> Double -> Render ()
-translate x y = mkJSCall "translate" [x,y]
+translate x y = canvas $ C.translate (realToFrac x,realToFrac y)
scale :: Double -> Double -> Render ()
-scale x y = mkJSCall "scale" [x,y]
+scale x y = canvas $ C.scale (realToFrac x,realToFrac y)
rotate :: Double -> Render ()
-rotate t = mkJSCall "rotate" [t]
+rotate t = canvas $ C.rotate (realToFrac t)
withStyle :: Render () -> Render () -> Render () -> Render ()
withStyle t s r = do
@@ -231,35 +227,3 @@ withStyle t s r = do
stroke
fill
restore
-
-jsHeader = " function renderDiagram(c) {\n"
- ++ jsPrefix ++ "fillStyle = \"rgba(0,0,0,0.0)\";\n"
- ++ jsPrefix ++ "strokeStyle = \"rgba(0,0,0,1.0)\";\n"
- ++ jsPrefix ++ "miterLimit = 10;\n"
-jsFooter = " }\n"
-
-jsPrefix = " c."
-
-htmlHeader = concat
- [ "<!DOCTYPE HTML>\n\
- \<html>\n\
- \ <head>\n\
- \ <script type=\"application/javascript\">\n\
- \ function draw() { \n\
- \ var canvas = document.getElementById(\"canvas\");\n\
- \ if (canvas.getContext) {\n\
- \ var context = canvas.getContext(\"2d\");\n\
- \ renderDiagram(context);\n\
- \ }\n\
- \ }\n\n"
- , jsHeader
- ]
-htmlFooter w h = concat
- [ jsFooter
- , " </script>\n\
- \ </head>\n\
- \ <body onload=\"draw();\">\n\
- \ <canvas id=\"canvas\" width=\"", show w, "\" height=\"", show h, "\"></canvas>\n\
- \ </body>\n\
- \</html>"
- ]
Something went wrong with that request. Please try again.