diagrams-tikz-0.6: src/Diagrams/Backend/TikZ.hs

{-# LANGUAGE TypeFamilies
           , MultiParamTypeClasses
           , FlexibleInstances
           , FlexibleContexts
           , TypeSynonymInstances
           , DeriveDataTypeable
           , ViewPatterns
  #-}
{-|
  A TikZ backend.
  
  Some features are not implemented:
  
  * text alignment (from @Diagrams.TwoD.Text@);
  
  * @clipBy@ (from @Diagrams.TwoD.Path@).
-}

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 Diagrams.Core.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 ++ "} "