craftwerk (empty) → 0.1
raw patch · 15 files changed
+1194/−0 lines, 15 filesdep +HUnitdep +QuickCheckdep +basebuild-type:Customsetup-changed
Dependencies added: HUnit, QuickCheck, base, colour, craftwerk, mtl, test-framework, test-framework-hunit, test-framework-quickcheck2, test-framework-th, vector-space
Files
- LICENSE +19/−0
- README +15/−0
- Setup.hs +59/−0
- craftwerk.cabal +96/−0
- examples/Example1.hs +25/−0
- examples/Example2.hs +32/−0
- examples/Example3.hs +43/−0
- src/Graphics/Craftwerk/Core.hs +28/−0
- src/Graphics/Craftwerk/Core/Color.hs +45/−0
- src/Graphics/Craftwerk/Core/Driver/Generic.hs +96/−0
- src/Graphics/Craftwerk/Core/Driver/Tikz.hs +286/−0
- src/Graphics/Craftwerk/Core/Figure.hs +177/−0
- src/Graphics/Craftwerk/Core/Style.hs +229/−0
- test/Graphics/Craftwerk/Core/Test.hs +38/−0
- test/Test.hs +6/−0
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2011 Malte Harder++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ README view
@@ -0,0 +1,15 @@+A high-level and easy to use graphics library with integrated TikZ+output.++Craftwerk is a high-level 2D vector graphics library for output of+TikZ pictures that can be typeset using (pdf)LaTeX. The TikZ library+and documentation can be found at: http://sourceforge.net/projects/pgf++Craftwerk tries to encapsulate the graphics backend such that figures+can also be rendered with a Cairo backend and quickly displayed in a+Gtk window. The aim is to support TikZ and Cairo seamlessly as+possible, meaning that graphics produced with either backend should+look as similar as possible. Other backends are easily written and the+aim is to provide generic fallback functions for features that are not+natively supported by some backend.+
+ Setup.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE CPP #-}++import Control.Monad (when, unless, mplus)++import Data.Maybe (listToMaybe, fromMaybe)+import Distribution.PackageDescription + ( PackageDescription, buildable, exeName, buildInfo, + executables, customFieldsBI, BuildInfo)++import Distribution.Verbosity (normal)+import Distribution.Simple.Build (build)+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))+import Distribution.Simple.PreProcess (knownSuffixHandlers)+import Distribution.Simple.Setup (defaultBuildFlags)+import Distribution.Simple + ( Args, defaultMainWithHooks, UserHooks(..), simpleUserHooks) ++import System.Exit (ExitCode(..))+import System.FilePath ( (</>), splitDirectories, isAbsolute )+import System.IO (openFile, IOMode (..))+import System.Process +import System.Directory + ( getCurrentDirectory, createDirectoryIfMissing+ , setCurrentDirectory, findExecutable, canonicalizePath+ , removeFile, doesDirectoryExist+ )++main :: IO ()+main = defaultMainWithHooks hooks+ where hooks = simpleUserHooks { runTests = runTests' } ++testCraftwerk :: a -> (BuildInfo -> a) -> PackageDescription -> a+testCraftwerk dflt f pd = + fromMaybe dflt $ listToMaybe + [ f (buildInfo exe)+ | exe <- executables pd+ , exeName exe == "test-craftwerk" ]++runTests' :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO ()+runTests' args0 _unknown pd lbi = do+ let args = if null args0 then [] else "-t" : args0+ + let testDir = buildDir lbi </> "test-craftwerk"+ baseDir <- getCurrentDirectory+ canonicalBuildDir <- canonicalizePath (buildDir lbi)+ t <- doesDirectoryExist testDir++ unless t $ do+ unless (testCraftwerk False buildable pd) $ do+ fail "Reconfigure with 'cabal configure -ftests' or 'cabal install -ftests' and try again."+ putStrLn "---[ Building Tests ]---"+ build pd lbi defaultBuildFlags knownSuffixHandlers+ putStrLn "---[ Tests Built ]---"++ setCurrentDirectory testDir++ exitcode <- system $ unwords $ ("./test-craftwerk") : args+ unless (exitcode == ExitSuccess) $ + fail "Test Failed"
+ craftwerk.cabal view
@@ -0,0 +1,96 @@+Name: craftwerk+Version: 0.1+License: MIT+License-file: LICENSE+Author: Malte Harder <malte.harder@gmail.com>+Maintainer: Malte Harder <malte.harder@gmail.com>+Category: Graphics+Homepage: http://mahrz.github.com/craftwerk.html+Synopsis: 2D graphics library with integrated TikZ output.+Description: A high-level and easy to use graphics library+ with integrated TikZ output.+ .+ Craftwerk is a high-level 2D vector graphics library for output of+ TikZ pictures that can be typeset using (pdf)LaTeX. The TikZ library+ and documentation can be found at: <http://sourceforge.net/projects/pgf>.+ .+ Craftwerk tries to encapsulate the graphics backend such that figures+ can also be rendered with a Cairo backend and quickly displayed in a+ Gtk window. The aim is to support TikZ and Cairo seamlessly as+ possible, meaning that graphics produced with either backend should+ look as similar as possible. Other backends are easily written and the+ aim is to provide generic fallback functions for features that are not+ natively supported by some backend.+ .+ Thanks to Jannis Harder for some contributions and ideas to the + library.++Stability: experimental+Build-Type: Custom+Cabal-Version: >=1.8++Extra-Source-Files: LICENSE,+ README,+ examples/Example1.hs+Flag tests+ Description: Build the tests+ Default: False++Flag examples+ Description: Build the examples+ Default: False++Library+ Hs-Source-Dirs: src+ Build-Depends: base >= 3 && < 5, mtl, vector-space >= 0.7 && < 0.8, colour >= 2.1 && < 2.4+ Exposed-Modules: Graphics.Craftwerk.Core,+ Graphics.Craftwerk.Core.Color,+ Graphics.Craftwerk.Core.Style,+ Graphics.Craftwerk.Core.Figure,+ Graphics.Craftwerk.Core.Driver.Tikz,+ Graphics.Craftwerk.Core.Driver.Generic++Executable example1+ Hs-Source-Dirs: examples+ if !flag(examples)+ Buildable: False+ else+ Build-Depends: base >= 3 && < 5, craftwerk+ Main-Is: Example1.hs++Executable example2+ Hs-Source-Dirs: examples+ if !flag(examples)+ Buildable: False+ else+ Build-Depends: base >= 3 && < 5, craftwerk+ Main-Is: Example2.hs++Executable example3+ Hs-Source-Dirs: examples+ if !flag(examples)+ Buildable: False+ else+ Build-Depends: base >= 3 && < 5, craftwerk+ Main-Is: Example3.hs++Executable test-craftwerk+ Hs-Source-Dirs: test+ Main-Is: Test.hs+ Other-Modules: Graphics.Craftwerk.Core.Test+ if !flag(tests)+ Buildable: False+ else+ Build-Depends: base >= 3 && < 5,+ craftwerk,+ test-framework,+ test-framework-th,+ test-framework-hunit,+ test-framework-quickcheck2,+ QuickCheck,+ HUnit++source-repository head+ type: git+ location: git://github.com/mahrz/Craftwerk.git+
+ examples/Example1.hs view
@@ -0,0 +1,25 @@+module Main where++import Graphics.Craftwerk.Core++-- A simple example that displays lines of differend widths+main = putStrLn . figureToTikzPicture+ $ style newStyle { closePath = no+ , stroke = yes }+ $ composition+ [+ line [(5,0),(5,10)]+ , style (setLineWidth verythin) $ line [(1,1),(9,1)]+ , style (setLineWidth thin) $ line [(1,2),(9,2)]+ , style (setLineWidth semithick) $ line [(1,3),(9,3)]+ , style (setLineWidth thick) $ line [(1,4),(9,4)]+ , style newStyle { arrowTips = arrow (<=>)} $+ translate (0,4) $ composition+ [+ style (setLineWidth verythin) $ line [(1,1),(9,1)]+ , style (setLineWidth thin) $ line [(1,2),(9,2)]+ , style (setLineWidth semithick) $ line [(1,3),(9,3)]+ , style (setLineWidth thick) $ line [(1,4),(9,4)]+ ]+ ]+
+ examples/Example2.hs view
@@ -0,0 +1,32 @@+module Main where++import Graphics.Craftwerk.Core++-- A simple example that displays the craftwerk logo+main = putStrLn . figureToTikzPicture+ $ style newStyle { closePath = yes+ , fillColor = rgb 0.6 0.2 0.1+ , lineWidth = width 2.0+ , stroke = yes + , fill = yes }+ $ composition+ [+ path + [+ moveTo (-0.02,0)+ , lineTo (1.1,0)+ , lineTo (1.1,0.35)+ , lineTo (1.07,0.5)+ , lineTo (1.06,0.8)+ , lineTo (0.86,0.8)+ , lineTo (0.85,0.5)+ , lineTo (0.65,0.35)+ , lineTo (0.65,0.5)+ , lineTo (0.45,0.35)+ , lineTo (0.45,0.5)+ , lineTo (0.25,0.35)+ , lineTo (0.25,0.5)+ , lineTo (0.05,0.35)+ , lineTo (-0.02,0.35)+ ]+ ]
+ examples/Example3.hs view
@@ -0,0 +1,43 @@+module Main where++import Graphics.Craftwerk.Core++-- A simple example of some primitives+main = putStrLn . figureToTikzPicture+ $ style newStyle { lineWidth = width 2.0+ , closePath = yes+ , fillColor = Just beige+ , fill = yes }+ $ composition+ [+ scale (10,10) $ line unitRectangle+ , style newStyle { clip = yes } $ Circle (5,5) 5+ , Circle (0,0) 5+ , style newStyle { closePath = no, fill=no, arrowTips = arrow (<=>) } + $ path [MoveTo (3,2), CurveSegment (4,4) (1,5) (5,1)]+ , style newStyle { closePath = no, fill=no, arrowTips = arrow (<=>) } + $ path [MoveTo (3,5), LineSegment (4,5), LineSegment (4.5,6)]+ , style newStyle { closePath = no+ , fill=no+ , lineWidth = Just 1+ , arrowTips = arrow (<=>) } + $ path [MoveTo (1,5), LineSegment (2,5), LineSegment (2.5,6)]+ , path [MoveTo (6,2), ArcSegment (6,2) 160 45 2]+ , path [MoveTo (6,2), ArcSegment (6,2) 45 160 2]++ , style newStyle { lineWidth = Just $ 1, fill = no } + $ Grid (10,10) 1.0 1.0+ , canvas . (scale (1.5,2)) $ + canvas . (rotate 20) $ + canvas . (translate (3,0.5)) $ + composition + [+ translate (2,0) $ rotate 45 $ + style newStyle {fillColor = Just red} $ line unitRectangle+ , scale (2,2) $ translate (0.5,0.5) $ + style newStyle {fillColor = Just blue} $ line unitRectangle+ , translate (0,2) $ canvas . (scale (2,2)) $ + style newStyle {fillColor = Just green} $ line unitRectangle+ + ]+ ]
+ src/Graphics/Craftwerk/Core.hs view
@@ -0,0 +1,28 @@+-- |+-- Module : Graphics.Craftwerk.Core+-- Copyright : (c) Malte Harder 2011+-- License : MIT+-- Maintainer : Malte Harder <malte.harder@gmail.com>+--+-- A high-level and easy to use graphics library with several backends,+-- currently including TikZ, Cairo (craftwerk-cairo) with Gtk UI (craftwerk-gtk)+-- and Gloss (craftwerk-gloss).+++module Graphics.Craftwerk.Core+ (+ module Graphics.Craftwerk.Core.Color+ , module Graphics.Craftwerk.Core.Style+ , module Graphics.Craftwerk.Core.Figure++ , module Graphics.Craftwerk.Core.Driver.Tikz+ , module Graphics.Craftwerk.Core.Driver.Generic+ ) where++import Graphics.Craftwerk.Core.Color+import Graphics.Craftwerk.Core.Style+import Graphics.Craftwerk.Core.Figure++import Graphics.Craftwerk.Core.Driver.Tikz+import Graphics.Craftwerk.Core.Driver.Generic+
+ src/Graphics/Craftwerk/Core/Color.hs view
@@ -0,0 +1,45 @@+-- |+-- Module : Graphics.Craftwerk.Core.Color+-- Copyright : (c) Malte Harder 2011+-- License : MIT+-- Maintainer : Malte Harder <malte.harder@gmail.com>+--+-- Craftwerk uses the "Data.Colour" package to represent colours in styles.++module Graphics.Craftwerk.Core.Color+ ( module Data.Colour.SRGB+ , module Data.Colour.Names++ , FigureColor++ , integralColor+ ) where++import Data.Colour.SRGB+import Data.Colour.Names++-- | The colour type used by Craftwerk+type FigureColor = Colour Double++-- | Returns the i-th of 16 basic named colours (i % 16 to be precise).+integralColor :: Integral a => a -> FigureColor+integralColor i = concat (repeat stdColors) !! fromIntegral i++stdColors = [ white+ , silver+ , gray+ , black+ , red+ , maroon+ , yellow+ , olive+ , lime+ , green+ , aqua+ , teal+ , blue+ , navy+ , fuchsia+ , purple] :: [FigureColor]++
+ src/Graphics/Craftwerk/Core/Driver/Generic.hs view
@@ -0,0 +1,96 @@+-- |+-- Module : Graphics.Craftwerk.Core.Driver.Generic+-- Copyright : (c) Malte Harder 2011+-- License : MIT+-- Maintainer : Malte Harder <malte.harder@gmail.com>+--+-- Functions that convert figures into figures that use less+-- primitives such that drivers only need to implement basic+-- functionalities.++module Graphics.Craftwerk.Core.Driver.Generic (+ -- * Internal conversion to simpler primitives+ genericFigure+ , arrowTipsForPath+ , radians+ , degree+ ) where++import Graphics.Craftwerk.Core.Figure+import Graphics.Craftwerk.Core.Color+import Graphics.Craftwerk.Core.Style++import Data.VectorSpace++-- | At the moment only 'Circle' and 'Grid' figures are converted to paths.+genericFigure :: Figure -> Figure+genericFigure (Circle (x,y) r) =+ Path [ArcSegment (x+r,y) 0 360 r]++genericFigure (Grid (x,y) xs ys) =+ composition $+ [line [(0,fromIntegral i * ys),(x,fromIntegral i * ys)] | i <- [0 .. floor (y/ys)]] +++ [line [(fromIntegral i *xs,0),(fromIntegral i * xs,y)] | i <- [0 .. floor (x/xs)]]++-- Avoid exceptions+genericFigure _ = Blank++-- | Creates arrow tip figure for a given path+arrowTipsForPath :: [Segment] -> Double -> (ArrowTip, ArrowTip) -> Figure+arrowTipsForPath p lw at =+ NoDecorations $ composition $ foldr (tipForSegment lw at) []+ (adjacent $ MoveTo (0,0):p ++ [MoveTo (0,0)])++tipForSegment lw (l,r) (s1,s2,s3) ats =+ ats ++ leftTipForSegment lw l s1 s2 ++ rightTipForSegment lw r s1 s2 s3++leftTipForSegment _ _ (MoveTo _) (MoveTo _) = []+leftTipForSegment lw l s1@(MoveTo p) s2 = arrowTipForTangent lw l (leftTangent s1 s2)+leftTipForSegment _ _ _ _ = []++rightTipForSegment _ _ _ (MoveTo _) (MoveTo _) = []+rightTipForSegment lw r s1 s2 (MoveTo p) = arrowTipForTangent lw r (rightTangent s1 s2)+rightTipForSegment _ _ _ _ _ = []++data Tangent = NoTangent | Tangent Point Point deriving (Eq, Show)+++tangent p1 p2 = if p1 == p2 then+ NoTangent+ else Tangent p1 (normalized (p1 ^-^ p2))++leftTangent (MoveTo p1) (LineSegment p2) = tangent p1 p2+leftTangent (MoveTo p1) (CurveSegment _ p2 _) = tangent p1 p2+leftTangent (MoveTo p1) (ArcSegment p2 _ _ _) = tangent p1 p2+leftTangent _ _ = NoTangent++rightTangent (MoveTo p1) (LineSegment p2) = tangent p2 p1+rightTangent (LineSegment p1) (LineSegment p2) = tangent p2 p1+rightTangent (CurveSegment p1 _ _) (LineSegment p2) = tangent p2 p1+rightTangent _ (CurveSegment p1 _ p2) = tangent p1 p2+rightTangent _ _ = NoTangent++arrowTipForTangent _ _ NoTangent = []+arrowTipForTangent _ TipNone _ = []+arrowTipForTangent lw TipDefault t =+ let arrowsize = 0.06 + 0.04*lw+ in arrowTip t $ style newStyle { lineCap = Just CapRound } $ composition+ [ path [ArcSegment (0,0) 90 180 arrowsize]+ , path [ArcSegment (0,0) 270 180 arrowsize]]+++arrowTip (Tangent p (x,y)) f =+ [translate p $ rotate (degree $ atan2 y x) f]++adjacent :: [a] -> [(a,a,a)]+adjacent xs = zipWith3 triple xs (tail xs) (tail $ tail xs)+ where triple a b c = (a,b,c)++-- | Angle conversion+radians :: (Floating a) => a -> a+radians n = n / (360 / (2 * pi))++-- | Angle conversion+degree :: (Floating a) => a -> a+degree n = n / ((2*pi) / 360)+
+ src/Graphics/Craftwerk/Core/Driver/Tikz.hs view
@@ -0,0 +1,286 @@+-- |+-- Module : Graphics.Craftwerk.Core.Driver.Tikz+-- Copyright : (c) Malte Harder 2011+-- License : MIT+-- Maintainer : Malte Harder <malte.harder@gmail.com>+--+-- Convert a figure to a LaTeX TikZ +-- (<http://sourceforge.net/projects/pgf/develop>) string.++module Graphics.Craftwerk.Core.Driver.Tikz (+ -- * TikZ conversion+ figureToTikzPicture+ ) where++import Graphics.Craftwerk.Core.Figure+import Graphics.Craftwerk.Core.Color+import Graphics.Craftwerk.Core.Style++import Data.Maybe+import Data.List+import Text.Printf++import Control.Monad+import Control.Monad.Reader++data Context = Context { styleP :: StyleProperties + , fillDepth :: Int+ , strokeDepth :: Int+ , coordinateMatrix :: String+ , inverseCoordinateMatrix :: String+ }++-- | Convert a Craftwerk 'Figure' to a TikZ picture environment string+figureToTikzPicture :: Figure -> String+figureToTikzPicture f =+ environment "tikzpicture" (styleArguments defaultStyle) $+ xcolor "linec" (getProperty defaultStyle lineColor) +++ xcolor "fillc" (getProperty defaultStyle fillColor) +++ runReader (figureToTikzPictureWithStyle f)+ Context { styleP = defaultStyle+ , fillDepth = 0+ , strokeDepth = 0+ , coordinateMatrix = ""+ , inverseCoordinateMatrix = ""}++figureToTikzPictureWithStyle :: Figure -> Reader Context String+figureToTikzPictureWithStyle Blank = return ""++figureToTikzPictureWithStyle (Style ns a) = + local (\c -> c { styleP = mergeProperties (styleP c) ns+ , fillDepth = fillDepth c + maybeToInt (fillColor ns)+ , strokeDepth = strokeDepth c + maybeToInt (lineColor ns)+ }) (do c <- ask+ prependColor (scopePrefix (strokeDepth c) ++ "linec") + ns lineColor + $ prependColor (scopePrefix (fillDepth c) ++ "fillc") + ns fillColor + $ liftM (scope $ styleArguments ns) + (figureToTikzPictureWithStyle a))+++figureToTikzPictureWithStyle (Canvas (Rotate r) a) = ask >>= \c ->+ liftM+ (scope [] .+ (++)+ (coordinateMatrix c +++ pgfLowLevel "rotate" (printNum r) +++ inverseCoordinateMatrix c))+ (figureToTikzPictureWithStyle a)++figureToTikzPictureWithStyle (Canvas (Scale (x,y)) a) = ask >>= \c ->+ liftM+ (scope [] .+ (++)+ (coordinateMatrix c +++ pgfLowLevel "xscale" (printNum x) +++ pgfLowLevel "yscale" (printNum y) +++ inverseCoordinateMatrix c))+ (figureToTikzPictureWithStyle a)++figureToTikzPictureWithStyle (Canvas (Translate (x,y)) a) = ask >>= \c ->+ liftM+ (scope [] .+ (++)+ (coordinateMatrix c +++ pgfLowLevel "xshift" ((printNum x) ++ "cm") +++ pgfLowLevel "yshift" ((printNum y) ++ "cm") +++ inverseCoordinateMatrix c))+ (figureToTikzPictureWithStyle a)++figureToTikzPictureWithStyle (Transform (Rotate r) a) =+ local (\c -> c { coordinateMatrix = + coordinateMatrix c ++ + pgfLowLevel "rotate" (printNum r)+ , inverseCoordinateMatrix =+ pgfLowLevel "rotate" (printNum $ -r) +++ inverseCoordinateMatrix c + }) $+ liftM (scope (numArgumentList [("rotate",r,"")]))+ (figureToTikzPictureWithStyle a)++figureToTikzPictureWithStyle (Transform (Scale (x,y)) a) =+ local (\c -> c { coordinateMatrix = + coordinateMatrix c ++ + pgfLowLevel "xscale" (printNum x) +++ pgfLowLevel "yscale" (printNum y)+ , inverseCoordinateMatrix =+ pgfLowLevel "xscale" (printNum $ 1/x) +++ pgfLowLevel "yscale" (printNum $ 1/y) +++ inverseCoordinateMatrix c + }) $+ liftM (scope (numArgumentList [("xscale",x,""),("yscale",y,"")]))+ (figureToTikzPictureWithStyle a)++figureToTikzPictureWithStyle (Transform (Translate (x,y)) a) =+ local (\c -> c { coordinateMatrix = + coordinateMatrix c ++ + pgfLowLevel "xshift" (printNum x ++ "cm") +++ pgfLowLevel "yshift" (printNum y ++ "cm")+ , inverseCoordinateMatrix =+ pgfLowLevel "xshift" (printNum (-x) ++ "cm") +++ pgfLowLevel "yshift" (printNum (-y) ++ "cm") +++ inverseCoordinateMatrix c+ }) $+ liftM (scope (numArgumentList [("xshift",x,"cm"),("yshift",y,"cm")]))+ (figureToTikzPictureWithStyle a)++figureToTikzPictureWithStyle (Composition a) =+ concat `liftM` mapM figureToTikzPictureWithStyle a++figureToTikzPictureWithStyle (Text a) = return $ node a++figureToTikzPictureWithStyle (Path a) = ask >>= \c ->+ let sp = getProperty (styleP c)+ in figurePath (pathToString a ++ + (if sp closePath then " -- cycle" else ""))++figureToTikzPictureWithStyle (Circle ctr r) = + figurePath $ pointToString ctr ++ " circle (" ++ printNum r ++ "cm)"+ +figureToTikzPictureWithStyle (Grid v stepx stepy) = + figurePath $ "(0,0) grid[xstep=" + ++ printNum stepx ++ "cm,ystep=" + ++ printNum stepy ++ "]" + ++ pointToString v++-- * Drawing helpers++figurePath p = ask >>= \c ->+ let sp = getProperty (styleP c)+ fc = (scopePrefix (fillDepth c) ++ "fillc")+ lc = (scopePrefix (strokeDepth c) ++ "linec")+ at = (sp arrowTips)+ in return $ tikzCommand "path" (lineColorArgs sp fc lc at) p++-- * Style related commands++lineColorArgs sp fc lc at =+ arrowTipToArg at +++ if sp clip then ["clip"] else+ if sp fill && sp stroke then ["fill=" ++ fc,"draw=" ++ lc]+ else if sp fill then ["fill="++fc] else ["draw="++lc] + +arrowTipToArg (TipNone,TipNone) = []+arrowTipToArg (l,r) = [leftTip l ++ "-" ++ rightTip r]++leftTip TipDefault = "<"+leftTip TipNone = ""+rightTip TipDefault = ">"+rightTip TipNone = ""++styleArguments :: StyleProperties -> [String]+styleArguments s =+ let sp = getProperty s+ in argumentList + ( extract lineCap (\p -> [("line cap", tikzLineCap p)]) ++ + extract lineJoin (\p -> [("line join", tikzLineJoin p)]) +++ extract miterLimit (\p -> [("miter limit", printNum p)]) +++ extract lineWidth (\p -> [("line width", printNum p)]) +++ extract dashPhase (\p -> [("dash phase", printNum p)]) + )+ ++ maybe [] (\p ->+ if length p > 0 then+ argumentList [("dash pattern", dashPattern True p)]+ else+ ["solid"]) (dashes s)+ where extract prop f = maybe [] f (prop s)++tikzLineCap lc = case lc of+ CapRect -> "rect"+ CapButt -> "butt"+ CapRound -> "round"++tikzLineJoin lj = case lj of+ JoinRound -> "round"+ JoinBevel -> "bevel"+ JoinMiter -> "miter"++dashPattern :: Bool -> [Double] -> String+dashPattern b (x:xs) = (if b then "on " else "off ") ++ printNum x ++ " "+ ++ dashPattern (not b) xs+dashPattern _ _ = ""++-- * TikZ/PGF & xcolor Commands++xcolor :: String -> FigureColor -> String+xcolor name color =+ let rgb = toSRGB color+ in texCommand "definecolor"+ [ name+ , "rgb"+ , printf "%.2f,%.2f,%.2f" + (channelRed rgb) + (channelGreen rgb) + (channelBlue rgb)]++prependColor name style prop =+ maybe (liftM id) (\p -> liftM (xcolor name p ++)) (prop style)++scope [] body = body+scope args body = environment "scope" args body++node n = texCommand "node" [n]++pathToString = foldr ((++) . segmentToString) ""++segmentToString (MoveTo p) = + pointToString p+segmentToString (LineSegment p) = + " -- " ++ pointToString p+segmentToString (ArcSegment p sa ea r) = + -- This needs to be fixed, the point is only connected when there is a current point+ " -- " ++ pointToString p ++ " arc " ++ printf "(%f:%f:%fcm)" sa ea r+segmentToString (CurveSegment p c1 c2) =+ " .. controls " ++ pointToString c1 ++ "and " + ++ pointToString c2 ++ ".. " ++ pointToString p++pointToString (x,y) = "(" ++ printNum x ++ "," ++ printNum y ++ ") "++canvasTransform argList = + ["transform canvas=" ++ tikzSubArguments (numArgumentList argList)]++scopePrefix n = replicate n 'T'++pgfLowLevel t p = + texCommand "pgflowlevel" [texCommand' ("pgftransform" ++ t) [p]]++-- * TeX Output++printNum = printf "%f"++argumentList =+ map (\(l,n) -> l ++ "=" ++ n)++numArgumentList =+ map (\(l,n,u) -> l ++ "=" ++ printNum n ++ u)+ +tikzSubArguments :: [String] -> String+tikzSubArguments [] = ""+tikzSubArguments args = "{" ++ intercalate "," args ++ "}"++tikzArguments :: [String] -> String+tikzArguments [] = ""+tikzArguments args = "[" ++ intercalate "," args ++ "]"++texArguments :: [String] -> String+texArguments = concatMap (\s -> "{" ++ s ++ "}")++texCommand cmd args =+ "\\" ++ cmd ++ texArguments args ++ "\n"++texCommand' cmd args =+ "\\" ++ cmd ++ texArguments args++tikzCommand cmd args body =+ "\\" ++ cmd ++ tikzArguments args+ ++ " " ++ body ++ ";\n"++environment env args body =+ "\\begin{" ++ env ++ "}" ++ tikzArguments args ++ "\n"+ ++ body+ ++ "\\end{" ++ env ++ "}\n"++-- * Other helpers+maybeToInt = maybe 0 (const 1)+
+ src/Graphics/Craftwerk/Core/Figure.hs view
@@ -0,0 +1,177 @@+-- |+-- Module : Graphics.Craftwerk.Core.Figure+-- Copyright : (c) Malte Harder 2011+-- License : MIT+-- Maintainer : Malte Harder <malte.harder@gmail.com>+--+-- A 'Figure' is a description of a 2D vector graphic. Affine transformations+-- and styles apply to all subfigures. When a subfigure of a style node contains+-- another style node the style properties will be overwritten where the deeper+-- node specifies it.+--+module Graphics.Craftwerk.Core.Figure (+ -- * Types and data types+ Point+ , Vector+ , Line+ , Path+ , Segment(..)+ , Figure(..)+ , Transform(..)++ -- * Primitive wrappers+ , blank+ , canvas+ , rotate+ , scale+ , translate+ , composition+ , style+ , path+ , moveTo+ , lineTo+ , arc+ , curveTo+ , line+ , circle+ , grid+ , text++ -- * Point generation+ , point++ -- * Path generation+ , lineToPath+ , rectangle+ , unitRectangle+ ) where++import Graphics.Craftwerk.Core.Style+import Graphics.Craftwerk.Core.Color+import Data.Monoid++type Point = (Double, Double)+type Vector = Point++-- | Path creation+data Segment = MoveTo Point+ | LineSegment Point+ | ArcSegment Point Double Double Double+ | CurveSegment Point Point Point+ deriving (Show, Eq)++type Line = [Point]+type Path = [Segment]++-- | The main datatype describing an arbitrary figure.+data Figure = Blank+ | Transform Transform Figure+ | Canvas Transform Figure+ | Composition [Figure]+ | Style StyleProperties Figure+ | Path Path+ | Circle Point Double+ | Grid Vector Double Double+ | Text String+ | NoDecorations Figure+ deriving (Show, Eq)++data Transform = Rotate Double+ | Scale Vector+ | Translate Vector+ deriving (Show, Eq)++instance Monoid Figure where+ mempty = Blank+ mappend a b = Composition [a, b]+ mconcat = Composition++blank :: Figure+blank = Blank++-- | Transforms a coordinate transformation 'Transform t f' into+-- a canvas transformation 'Canvas t f'.+canvas :: Figure -> Figure+canvas (Transform t f) = Canvas t f+canvas f = f++-- | Applies a coordinate rotation.+rotate :: Double -> Figure -> Figure+rotate r = Transform (Rotate r)++-- | Applies a coordinate scaling.+scale :: Vector -> Figure -> Figure+scale v = Transform (Scale v)++-- | Applies a coordinate translation.+translate :: Vector -> Figure -> Figure+translate v = Transform (Translate v)++-- | Combines figures which are drawn in the order of the figures in the list.+composition :: [Figure] -> Figure+composition = Composition++-- | Applies a style to the given figure+style :: StyleProperties -> Figure -> Figure+style = Style++-- | Converts a line to a figure+line :: Line -> Figure+line l = Path (lineToPath l)++-- | Generates a 'MoveTo' segment+moveTo :: Point -> Segment+moveTo = MoveTo++-- | Generates a 'LineSegment' segment.+lineTo :: Point -> Segment+lineTo = LineSegment++-- | Generates an 'ArcSegment' segment.+arc :: Point -- ^ Draws a line to this point unless segment is the first element in the path.+ -> Double -- ^ Start angle+ -> Double -- ^ End angle+ -> Double -- ^ Radius+ -> Segment+arc = ArcSegment++-- | Generates a 'CurveSegment' segment.+curveTo :: Point -- ^ End point of the segment.+ -> Point -- ^ Control point 1.+ -> Point -- ^ Control point 2.+ -> Segment+curveTo = CurveSegment++-- | Generate a figure from a path.+path :: Path -> Figure+path = Path++-- | Generate a circle figure at a point with given radius.+circle :: Point -> Double -> Figure+circle = Circle++-- | Generate a grid spanning from (0,0) to (x,y) taking steps (xs,ys).+grid :: Vector -- ^ x,y+ -> Vector -- ^ xs,ys+ -> Figure+grid v (x,y) = Grid v x y++-- | Generate a text at (0,0)+text :: String -> Figure+text = Text++point :: Double -> Double -> Point+point x y = (x,y)++lineToPath :: Line -> Path+lineToPath (p:ps) = MoveTo p:map LineSegment ps++-- | Construct a rectangle path from origin and extent.+rectangle :: Point -- ^ Origin+ -> Vector -- ^ Extent+ -> Line+rectangle (x,y) (w,h) = [(x,y),(x+w,y),(x+w,y+h),(x,y+h)]++-- | Rectangle with origin (0,0) and extent (1,1)+unitRectangle :: Line+unitRectangle = rectangle (0,0) (1,1)
+ src/Graphics/Craftwerk/Core/Style.hs view
@@ -0,0 +1,229 @@+-- |+-- Module : Graphics.Craftwerk.Core.Style+-- Copyright : (c) Malte Harder 2011+-- License : MIT+-- Maintainer : Malte Harder <malte.harder@gmail.com>+--+-- Styles in craftwerk are nodes in the figure tree and the style at the node is+-- applied to all subnodes. If a field of a style is empty (i.e its value+-- is 'Nothing') the value of the next parent style node is applied.++module Graphics.Craftwerk.Core.Style (+ -- * Data types+ StyleProperties(..)+ , LineCap(..)+ , LineJoin(..)+ , ArrowTip(..)++ -- * Named styles+ , emptyStyle+ , newStyle+ , defaultStyle+ , setLineWidth+ , fillOnly+ , strokeOnly++ -- * Property values+ , yes+ , no+ , rgb+ , width+ , verythin+ , thin+ , semithick+ , thick+ , verythick+ , ultrathick+ , limit+ , phase++ -- * Property access and merging+ , getProperty+ , mergeProperties++ -- * Arrow functions+ , arrow+ , (<=>)+ , (===)+ , (==>)+ , (<==)++ ) where++import Graphics.Craftwerk.Core.Color++import Data.Maybe++data ArrowDummy = ArrowDummy deriving Show+data ArrowTip = TipNone | TipDefault deriving (Show,Eq)++type ArrowTips = (ArrowTip, ArrowTip)++data LineCap = CapRect | CapButt | CapRound deriving (Show,Eq)+data LineJoin = JoinRound | JoinBevel | JoinMiter deriving (Show,Eq)++-- | A record holding all possible properties.+data StyleProperties =+ StyleProperties { lineWidth :: Maybe Double+ , lineColor :: Maybe FigureColor+ , fillColor :: Maybe FigureColor+ , fill :: Maybe Bool+ , stroke :: Maybe Bool+ , clip :: Maybe Bool+ , closePath :: Maybe Bool+ , dashes :: Maybe [Double]+ , dashPhase :: Maybe Double+ , lineCap :: Maybe LineCap+ , lineJoin :: Maybe LineJoin+ , miterLimit :: Maybe Double+ , arrowTips :: Maybe ArrowTips+ } deriving (Show, Eq)+++-- | A style where no property has been set.+emptyStyle :: StyleProperties+emptyStyle = StyleProperties+ Nothing+ Nothing+ Nothing+ Nothing+ Nothing+ Nothing+ Nothing+ Nothing+ Nothing+ Nothing+ Nothing+ Nothing+ Nothing++-- | Alias for empty style, makes style construction nicer.+newStyle :: StyleProperties+newStyle = emptyStyle++-- | The default style used at the root node of any 'Figure'.+defaultStyle :: StyleProperties+defaultStyle =+ StyleProperties { lineWidth = Just 1.0+ , lineColor = Just black+ , fillColor = Just white+ , stroke = Just True+ , fill = Just False+ , clip = Just False+ , closePath = Just False+ , dashes = Just [] :: Maybe [Double]+ , dashPhase = Just 0.0+ , lineCap = Just CapButt+ , lineJoin = Just JoinMiter+ , miterLimit = Just 10.0+ , arrowTips = Just (TipNone, TipNone)+ }++setLineWidth :: Maybe Double -> StyleProperties+setLineWidth a = newStyle { lineWidth = a }++fillOnly :: StyleProperties+fillOnly = newStyle { fill = yes, stroke = no }++strokeOnly :: StyleProperties+strokeOnly = newStyle { fill = no, stroke = yes}++-- | Alias for 'Just True' to make style specification more convenient.+yes :: Maybe Bool+yes = Just True++-- | Alias for 'Just False' to make style specification more convenient.+no :: Maybe Bool+no = Just False++-- | Make a rgb color property.+rgb :: Double -> Double -> Double -> Maybe FigureColor+rgb r g b = Just $ sRGB r g b++-- | Alias for 'Just'+width :: Double -> Maybe Double+width = Just++-- | Width 0.2.+verythin :: Maybe Double+verythin = width 0.2++-- | Width 0.4.+thin :: Maybe Double+thin = width 0.4++-- | Width 0.6.+semithick :: Maybe Double+semithick = width 0.6++-- | Width 0.8.+thick :: Maybe Double+thick = width 0.8++-- | Width 1.2.+verythick :: Maybe Double+verythick = width 1.2++-- | Width 1.6.+ultrathick :: Maybe Double+ultrathick = width 1.6++-- | Alias for 'Just'.+limit :: Double -> Maybe Double+limit = width++-- | Alias for 'Just'.+phase :: Double -> Maybe Double+phase = width++-- | Read a property from a style property record returning the value of+-- the default style if the value is 'Nothing'.+getProperty :: StyleProperties -> (StyleProperties -> Maybe a) -> a+getProperty s f = fromMaybe (fromJust $ f defaultStyle) (f s)++mergeProperty :: StyleProperties ->+ StyleProperties ->+ (StyleProperties -> Maybe a) ->+ Maybe a+mergeProperty s t f = case f t of+ Nothing -> f s+ x -> x++-- | Merge two property records, where the second argument overwrites fields of+-- the first unless a field is 'Nothing'.+mergeProperties :: StyleProperties ->+ StyleProperties ->+ StyleProperties+mergeProperties s t =+ StyleProperties { lineWidth = mergeProperty s t lineWidth+ , lineColor = mergeProperty s t lineColor+ , fillColor = mergeProperty s t fillColor+ , fill = mergeProperty s t fill+ , stroke = mergeProperty s t stroke+ , clip = mergeProperty s t clip+ , closePath = mergeProperty s t closePath+ , dashes = mergeProperty s t dashes+ , dashPhase = mergeProperty s t dashPhase+ , lineCap = mergeProperty s t lineCap+ , lineJoin = mergeProperty s t lineJoin+ , miterLimit = mergeProperty s t miterLimit+ , arrowTips = mergeProperty s t arrowTips+ }++-- * Arrow styles++-- | Arrow tip styles can be specified by using the notation 'arrow (<==)'+arrow :: (ArrowDummy -> ArrowTips) -> Maybe ArrowTips+arrow f = Just (f ArrowDummy)++(<=>) :: ArrowDummy -> ArrowTips+(<=>) _ = (TipDefault, TipDefault)++(===) :: ArrowDummy -> ArrowTips+(===) _ = (TipNone, TipNone)++(==>) :: ArrowDummy -> ArrowTips+(==>) _ = (TipNone, TipDefault)++(<==) :: ArrowDummy -> ArrowTips+(<==) _ = (TipDefault, TipNone)
+ test/Graphics/Craftwerk/Core/Test.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE TemplateHaskell #-}+module Graphics.Craftwerk.Core.Test (main) where++import Test.Framework.TH+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+import Test.HUnit+import Test.QuickCheck++import qualified Graphics.Craftwerk.Core.Color as Color+import Graphics.Craftwerk.Core.Style++import Data.Maybe++main = $(defaultMainGenerator)++prop_cap_pos x = Color.cap x >= 0+prop_cap_lim x = Color.cap x <= 1++case_style_get_lineWidth =+ getProperty emptyStyle lineWidth @=? fromJust (lineWidth defaultStyle)++case_style_get_lineColor =+ getProperty emptyStyle lineColor @=? fromJust (lineColor defaultStyle)++case_style_get_fillColor =+ getProperty emptyStyle fillColor @=? fromJust (fillColor defaultStyle)++case_style_get_stroke =+ getProperty emptyStyle stroke @=? fromJust (stroke defaultStyle)++case_style_get_fill =+ getProperty emptyStyle fill @=? fromJust (fill defaultStyle)++case_style_get_closePath =+ getProperty emptyStyle closePath @=? fromJust (closePath defaultStyle)+
+ test/Test.hs view
@@ -0,0 +1,6 @@+module Main where++import qualified Graphics.Craftwerk.Core.Test as Test++main = Test.main+