diagrams-tikz (empty) → 0.1.1.0
raw patch · 8 files changed
+538/−0 lines, 8 filesdep +basedep +diagrams-coredep +diagrams-libsetup-changed
Dependencies added: base, diagrams-core, diagrams-lib, dlist, mtl
Files
- LICENSE +37/−0
- Setup.hs +3/−0
- diagrams-tikz.cabal +25/−0
- example/EField.hs +27/−0
- example/Hilbert.hs +26/−0
- example/Star.hs +26/−0
- src/Diagrams/Backend/TikZ.hs +173/−0
- src/Diagrams/Backend/TikZBase.hs +221/−0
+ LICENSE view
@@ -0,0 +1,37 @@+Copyright 2011 diagrams-tikz team:++ Sam Griffin <sam.griffin@gmail.com>+ Luite Stegeman <stegeman@gmail.com>+ Kanchalai Suveepattananont <ksuvee@seas.upenn.edu>+ Scott N. Walck <scott.n.walck@gmail.com>+ Ryan Yates <fryguybob@gmail.com>+ Brent Yorgey <byorgey@cis.upenn.edu>++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Brent Yorgey nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ diagrams-tikz.cabal view
@@ -0,0 +1,25 @@+Name: diagrams-tikz+Version: 0.1.1.0+Synopsis: TikZ backend for diagrams drawing EDSL+Description: This package provides a modular backend for rendering+ diagrams created with the diagrams EDSL using the + TikZ library.+Homepage: http://projects.haskell.org/diagrams+License: BSD3+License-file: LICENSE+Author: Scott N. Walck+Maintainer: diagrams-discuss@googlegroups.com+Category: Graphics+Build-type: Simple+Cabal-version: >=1.6+Tested-with: GHC == 7.4.1+Extra-source-files: example/*.hs+Library+ Exposed-modules: Diagrams.Backend.TikZ+ Diagrams.Backend.TikZBase+ Hs-source-dirs: src+ Build-depends: base >= 4.2 && < 4.6,+ mtl >= 2.0 && < 2.2,+ diagrams-core >= 0.5 && < 0.6,+ diagrams-lib >= 0.5 && < 0.6,+ dlist >=0.5 && < 0.6
+ example/EField.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE NoMonomorphismRestriction #-}++import Diagrams.Prelude+import Diagrams.Backend.TikZ++p = fromVertices $ map p2 [(-4,0),(0,0),(0,2)]++charge = circle 0.1 # fc black++fieldPoint = circle 0.05 # fc black++point1 = p2 ( 0,2)+point2 = p2 (-4,0)++d = position [(point1,charge)+ ,(point2,charge)+ ,(origin,fromVertices [origin,point1])+ ,(origin,fromVertices [origin,point2])+ ,(origin,fieldPoint)+ ,(p2 (0,2.3),text "$Q_1 = +4.0 \\mu\\rm C$")+ ,(p2 (-4,-0.3),text "$Q_2 = -8.0 \\mu\\rm C$")+ ,(p2 (0.2,-0.2),text "P")+ ,(p2 (0.5,1), text "2 cm")+ ,(p2 (-2,0.3), text "4 cm")+ ]++main = renderDia TikZ (TikZOptions "EField.tex" (TeX $ Dims 6 6)) d
+ example/Hilbert.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE NoMonomorphismRestriction #-}++import Diagrams.Prelude+import Diagrams.Backend.TikZ++hilbert :: [Trail R2]+hilbert = iterate genHilbert mempty+ where genHilbert t = let t' = reverseTrail t+ in mconcat [ rotateBy (-1/4) t'+ , fromOffsets [unitY]+ , t+ , fromOffsets [unitX]+ , t+ , fromOffsets [negateV unitY]+ , rotateBy (1/4) t'+ ]++d = (hilbert !! 6)+ # strokeT+ # lw (0.1*0.2)+ # fc red+ # centerXY+ # pad 1.1++--main = defaultMain d+main = renderDia TikZ (TikZOptions "Hilbert.tex" (TeX $ Dims 14 14)) d
+ example/Star.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE NoMonomorphismRestriction, TupleSections #-}++import Diagrams.Prelude+import Diagrams.Backend.TikZ++axes n = h <> v+ where p = fromOffsets . replicate n+ h = stroke' with {vertexNames = [map ("x",) [0..n]]} (p unitX)+ v = stroke' with {vertexNames = [map ("y",) [0..n]]} (p unitY)++connect n i = withAName ("x",i) $ \x ->+ withAName ("y", n - i) $ \y ->+ drawConnect [x,y]+ where drawConnect = atop . fromVertices+ withAName n f = withName (toName n) (f . location)++pic n = applyAll (map (connect n) [0..n]) (axes n) # centerXY -- # lw 0.05++d n = half === rotateBy (1/2) half+ where half = centerX $ rotateBy (1/4) (pic n) ||| pic n++unscaledDia = pad 1.1 $ d 20 # lc blue++--main = defaultMain (pad 1.1 $ d 20 # lc blue)+--main = renderDia TikZ (TikZOptions "Star.tex" (Tex)) (scale 0.3 unscaledDia)+main = renderDia TikZ (TikZOptions "Star.tex" (TeX $ Dims 14 14)) unscaledDia
+ src/Diagrams/Backend/TikZ.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , FlexibleContexts+ , TypeSynonymInstances+ , DeriveDataTypeable+ , ViewPatterns+ #-}+{-|+ A TikZ backend.+-}++module Diagrams.Backend.TikZ++ ( TikZ(..) -- rendering token+ , Options(..) -- for rendering options specific to TikZ+ , OutputFormat(..) -- output format options+ , absoluteTrail+ ) where++--import qualified Text.LaTeX as L+import qualified Diagrams.Backend.TikZBase as L++import Diagrams.Prelude+import Graphics.Rendering.Diagrams.Transform+import Diagrams.TwoD.Shapes+import Diagrams.TwoD.Adjust (adjustDia2D)+import Diagrams.TwoD.Text++import Control.Monad (when)+import Control.Monad.Identity+import Data.Maybe (catMaybes)+--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 TikZ = TikZ+ deriving Typeable++data OutputFormat+ = Tex+ | TeX { texSize :: SizeSpec2D -- ^ the size of the output is given in cm?+ }+ -- | DVI+ -- | PS { psSize :: (Double, Double) -- ^ the size of the output is given in points+ -- }+ -- | PDF { pdfSize :: (Double, Double) -- ^ the size of the output is given in points+ -- }++instance Monoid (Render TikZ R2) where+ mempty = T $ return ()+ (T r1) `mappend` (T r2) = T (r1 >> r2)++instance Backend TikZ R2 where+-- data Render TikZ R2 = T (L.LaTeX Identity)+ data Render TikZ R2 = T (L.Render ())+ type Result TikZ R2 = IO ()+ data Options TikZ R2 = TikZOptions+ { fileName :: String -- ^ the name of the file you want generated+ , outputFormat :: OutputFormat -- ^ the output format and associated options+ }++ withStyle _ s t (T r) = T $ do+ L.rawRenderTikZ "\\begin{scope}\n"+-- tikzTransf t+ tikzStyle s+ r+ tikzStylePost s+ drawOrNot s+ L.stroke+ L.rawRenderTikZ "\\end{scope}\n"++ doRender _ options (T r) =+ let surfaceF surface = L.renderWith surface r+ in case outputFormat options of+ Tex -> L.withTikZSurface (fileName options) surfaceF+-- TeX (w,h) -> L.withTikZSizeSurface (fileName options) w h surfaceF+ TeX _ -> L.withTikZSurface (fileName options) surfaceF++ adjustDia c opts d = if bypass (outputFormat opts)+ then (opts,d)+ else adjustDia2D (getSize . outputFormat) adjustSize c opts d+ where getSize (TeX sz) = sz+ adjustSize sz opts = opts { outputFormat = TeX { texSize = sz } }+ bypass Tex = True+ bypass _ = False++renderT :: (Renderable a TikZ, V a ~ R2) => a -> L.Render ()+renderT a = case (render TikZ a) of T r -> r++tikzStyle :: Style v -> L.Render ()+tikzStyle s = foldr (>>) (return ())+ . catMaybes $ [ handle fColor+ , handle lColor+ ]+ where handle :: (AttributeClass a) => (a -> L.Render ()) -> Maybe (L.Render ())+ handle f = f `fmap` getAttr s+ lColor = L.strokeColor . getLineColor+ fColor = L.fillColor . getFillColor++tikzStylePost :: Style v -> L.Render ()+tikzStylePost s = foldr (>>) (return ())+ . catMaybes $ [ handle lWidth+ , handle lJoin+ , handle lCap+ , handle lDashing+ , handle fCommand+ ]+ where handle :: (AttributeClass a) => (a -> L.Render ()) -> Maybe (L.Render ())+ handle f = f `fmap` getAttr s+ fCommand = L.fillCommand . getFillColor+ lWidth = L.lineWidth . getLineWidth+ lCap = L.lineCap . getLineCap+ lJoin = L.lineJoin . getLineJoin+ lDashing (getDashing -> Dashing ds offs) =+ L.setDash ds offs++isLineWidthSet :: Style v -> Bool+isLineWidthSet s = case (getAttr s :: Maybe LineWidth) of+ Nothing -> False+ Just _ -> True+ -- where+ -- getA :: Style v -> Maybe LineWidth+ -- getA = getAttr++drawOrNot :: Style v -> L.Render ()+drawOrNot s = case (fmap getLineWidth (getAttr s)) of+ Nothing -> L.rawRenderTikZ " [draw]"+ Just x -> case x < L.epsilon of+ True -> L.rawRenderTikZ ""+ False -> L.rawRenderTikZ " [draw]"++tikzTransf :: T2 -> L.Render ()+tikzTransf t = L.rawRenderTikZ m+ where m = "[cm={" ++ show a1 ++ "," ++ show b1 ++ "," ++ show a2 ++ "," ++ show b2 ++ "," ++ show (c1,c2) ++ "}]\n"+ (a1,a2) = unr2 $ apply t $ r2 (1,0)+ (b1,b2) = unr2 $ apply t $ r2 (0,1)+ (c1,c2) = unr2 $ transl t++instance Renderable (Segment R2) TikZ where+ render _ (Linear v) = T $ L.lineTo v+ render _ (Cubic v1 v2 v3) = T $ L.curveTo v1 v2 v3++instance Renderable (FixedSegment R2) TikZ where+ render _ (FLinear v1 v2) = T $ L.fixedSegment v1 v2+ render _ (FCubic v1 v2 v3 v4) = T $ L.curvedFixedSegment v1 v2 v3 v4++instance Renderable (Trail R2) TikZ where+ render _ (Trail segs c) = T $ do+ mapM_ renderT segs+ when c $ L.closePath++instance Renderable (Path R2) TikZ where+ render _ (Path trs) = T $ L.newPath >> F.mapM_ renderTrail trs+ where renderTrail (p, tr) = do+ let v = p .-. origin+ L.moveTo v+ renderT (absoluteTrail v 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))++instance Renderable Text TikZ where+ render _ (Text tr _alignment str) = T $ L.rawRenderTikZ $ " \\path " ++ show (unr2 $ transl tr) ++ " node {" ++ str ++ "} "
+ src/Diagrams/Backend/TikZBase.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE GeneralizedNewtypeDeriving,ViewPatterns #-}++--module Graphics.Rendering.Canvas +module Diagrams.Backend.TikZBase+ ( Render(..)+ , renderWith+ , withTikZSurface+ , renderTikZ+ , rawRenderTikZ+ , fixedSegment+ , curvedFixedSegment+ -- , withHTMLSurface+ , newPath+ , moveTo+ , lineTo+ , curveTo+ -- , arc+ , closePath+ , stroke+ -- , fill+ -- , transform+ -- , save+ -- , restore+ -- , translate+ -- , scale+ -- , rotate+ , setDash+ , fillColor+ , fillCommand+ , drawCommand+ , strokeColor+ , lineWidth+ , lineCap+ , lineJoin+ , epsilon+ ) where++import Diagrams.Attributes(Color(..),LineCap(..),LineJoin(..))+import Diagrams.TwoD.Types+import Control.Monad.Writer+import Data.List(intersperse)+import Data.DList(DList,toList,fromList)+import Data.Word(Word8)+import System.IO (openFile, hPutStr, IOMode(..), hClose)++newtype Render m = Render { runRender :: WriterT (DList String) IO m }+ deriving (Functor, Monad, MonadWriter (DList String))++data Surface = Surface { header :: String, footer :: String, width :: Int, height :: Int, fileName :: String } ++renderWith :: MonadIO m => Surface -> Render a -> m a+renderWith s r = liftIO $ do (v,ss) <- runWriterT $ (runRender r)+ h <- openFile (fileName s) WriteMode+ hPutStr h (header s)+ mapM_ (hPutStr h) (toList ss)+ hPutStr h (footer s)+ hClose h+ return v++withTikZSurface :: String -> (Surface -> IO a) -> IO a+withTikZSurface file f = f s+ where s = Surface tikzHeader tikzFooter 0 0 file++{-+withTikZSizeSurface :: String -> Double -> Double -> (Surface -> IO a) -> IO a+withTikZSizeSurface file w h f = f s+ where s = Surface (tikzSizeHeader w h) (tikzSizeFooter w h) +-}++{-+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+-}++rawRenderTikZ :: String -> Render ()+rawRenderTikZ s = tell $ fromList [s]++renderTikZ :: String -> Render ()+renderTikZ s = tell $ fromList [texPrefix, s, ";\n"]++newPath :: Render ()+newPath = rawRenderTikZ "\\path "++closePath :: Render ()+closePath = rawRenderTikZ " -- cycle "++moveTo :: R2 -> Render ()+moveTo v = rawRenderTikZ $ " " ++ showR2 v ++ " "++lineTo :: R2 -> Render ()+lineTo v = rawRenderTikZ $ " -- " ++ showR2 v ++ " "++curveTo :: R2 -> R2 -> R2 -> Render ()+curveTo v2 v3 v4 = rawRenderTikZ $ " .. controls " ++ showR2 v2 ++ " and " ++ showR2 v3 ++ " .. " ++ showR2 v4 ++ " "++stroke :: Render ()+stroke = rawRenderTikZ "; "++showColorTikZ :: (Color c) => c -> String+showColorTikZ c = showD4 r ++ "," ++ showD4 g ++ "," ++ showD4 b+ where (r,g,b,_a) = colorToRGBA c++-- setColor :: (Color c) => c -> Render ()+-- setColor c = rawRenderTikZ $ " \\color[rgb]{" ++ showColorTikZ c ++ "} "++fillColor :: (Color c) => c -> Render ()+fillColor c = rawRenderTikZ $ " \\definecolor{fc}{rgb}{" ++ showColorTikZ c ++ "} \\pgfsetfillcolor{fc}"++fillCommand :: (Color c) => c -> Render ()+fillCommand _c = rawRenderTikZ $ " [fill] "++drawCommand :: Double -> Render ()+drawCommand w+ | w < epsilon = rawRenderTikZ ""+ | otherwise = rawRenderTikZ " [draw]"++strokeColor :: (Color c) => c -> Render ()+strokeColor c = rawRenderTikZ $ " \\definecolor{sc}{rgb}{" ++ showColorTikZ c ++ "} \\pgfsetstrokecolor{sc}"++-- about 28.5pt = 1cm. Get the official value.+numPtsPerCm :: Double+numPtsPerCm = 28.5++-- a number (line width) below this is regarded as zero+epsilon :: Double+epsilon = 0.001++convertCmToPt :: Double -> Double+convertCmToPt x = numPtsPerCm * x++lineWidth :: Double -> Render ()+lineWidth w = rawRenderTikZ $+ "[line width=" ++ showD4 (convertCmToPt w) ++ "] "++setDash :: [Double] -> Double -> Render ()+setDash ds offs+ = rawRenderTikZ $ "[dash pattern="+ ++ concat (zipWith (++) (cycle [" on "," off "]) (map (show . convertCmToPt) ds))+ ++ "] [dash phase=" ++ show (convertCmToPt offs)+ ++ "] "++lineCap :: LineCap -> Render ()+lineCap lc = rawRenderTikZ $+ "[line cap=" ++ fromLineCap lc ++ "] "++lineJoin :: LineJoin -> Render ()+lineJoin lj = rawRenderTikZ $+ "[line join=" ++ fromLineJoin lj ++ "] "++fromLineCap :: LineCap -> String+fromLineCap LineCapRound = show "round"+fromLineCap LineCapSquare = show "rect"+fromLineCap _ = show "butt"++fromLineJoin :: LineJoin -> String+fromLineJoin LineJoinRound = show "round"+fromLineJoin LineJoinBevel = show "bevel"+fromLineJoin _ = show "miter"++fixedSegment :: P2 -> P2 -> Render ()+fixedSegment v1 v2 = rawRenderTikZ $ " " ++ showP2 v1 ++ " -- " ++ showP2 v2 ++ ";\n"++curvedFixedSegment :: P2 -> P2 -> P2 -> P2 -> Render ()+curvedFixedSegment v1 v2 v3 v4 = rawRenderTikZ $ "\\draw " ++ showP2 v1 ++ " .. controls " ++ showP2 v2 ++ " and " ++ showP2 v3 ++ " .. " ++ showP2 v4 ++ ";\n"++{-+arc :: Double -> Double -> Double -> Double -> Double -> Render ()+arc a b c d e = mkJSCall "arcTo" [a,b,c,d,e]++fill :: Render ()+fill = renderJS "fill()"++transform :: Double -> Double -> Double -> Double -> Double -> Double -> Render ()+transform ax ay bx by tx ty = + if vs /= [1.0,0.0,0.0,1.0,0.0,0.0]+ then mkJSCall "transform" vs+ else return ()+ where vs = [ax,ay,bx,by,tx,ty]++save :: Render ()+save = renderJS "save()"++restore :: Render ()+restore = renderJS "restore()"++translate :: Double -> Double -> Render ()+translate x y = mkJSCall "translate" [x,y]++scale :: Double -> Double -> Render ()+scale x y = mkJSCall "scale" [x,y]++rotate :: Double -> Render ()+rotate t = mkJSCall "rotate" [t]++-- TODO: Instead of always filling and stroking keep state +-- in Render that knows if it needs to fill or stroke.+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"+-}++texPrefix = "\\"++tikzHeader = "\\begin{tikzpicture}\n"++tikzFooter = "\\end{tikzpicture}\n"++showD :: Int -> Double -> String+showD n x = show $ fromIntegral (round (x * 10.0^n)) / 10.0^n++showD4 :: Double -> String+showD4 = showD 4++showR2 :: R2 -> String+showR2 (unr2 -> (x,y)) = "(" ++ showD4 x ++ "," ++ showD4 y ++ ")"++showP2 :: P2 -> String+showP2 (unp2 -> (x,y)) = "(" ++ showD4 x ++ "," ++ showD4 y ++ ")"