diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,37 @@ +Copyright 2011 diagrams-tikz team: + + Sam Griffin + Luite Stegeman + Kanchalai Suveepattananont + Scott N. Walck + Ryan Yates + Brent Yorgey + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/diagrams-tikz.cabal b/diagrams-tikz.cabal new file mode 100644 --- /dev/null +++ b/diagrams-tikz.cabal @@ -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 diff --git a/example/EField.hs b/example/EField.hs new file mode 100644 --- /dev/null +++ b/example/EField.hs @@ -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 diff --git a/example/Hilbert.hs b/example/Hilbert.hs new file mode 100644 --- /dev/null +++ b/example/Hilbert.hs @@ -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 diff --git a/example/Star.hs b/example/Star.hs new file mode 100644 --- /dev/null +++ b/example/Star.hs @@ -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 diff --git a/src/Diagrams/Backend/TikZ.hs b/src/Diagrams/Backend/TikZ.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Backend/TikZ.hs @@ -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 ++ "} " diff --git a/src/Diagrams/Backend/TikZBase.hs b/src/Diagrams/Backend/TikZBase.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Backend/TikZBase.hs @@ -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 ++ ")"