-- | -- Module : Graphics.Craftwerk.Core.Driver.Tikz -- Copyright : (c) Malte Harder 2011 -- License : MIT -- Maintainer : Malte Harder -- -- Convert a figure to a LaTeX TikZ -- () 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)