diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Christopher Chalmers + +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 Christopher Chalmers 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,105 @@ +## PGF diagrams backend + +`diagrams-pgf` is a [PGF] backend for [diagrams]. Diagrams is a powerful, flexible, declarative domain-specific language for creating vector graphics, using the [Haskell programming language][haskell]. + +[PGF]: http://sourceforge.net/projects/pgf/ +[diagrams]: http://projects.haskell.org/diagrams/ +[haskell]: http://www.haskell.org/haskellwiki/Haskell + +PGF is a TeX macro package for generating graphics. It is platform- and format-independent and works together with the most important TeX backend drivers, including pdftex and dvips. + +`diagrams-pgf` is a work in progress, it supports the basic features of diagrams with the following features: + +- LaTeX, ConTeXt and plain TeX support +- direct PDF generation using a TeX distribution (e.g. [texlive](https://www.tug.org/texlive/)) via [texrunner]. + +### Usage + +A simple example that uses diagrams-pgf to draw a square. + +```haskell +import Diagrams.Prelude +import Diagrams.Backend.PGF.CmdLine + +b1 = square 20 # lwG 0.05 + +main = defaultMain (pad 1.1 b1) +``` + +Save this to file named `square.hs` and compile this program: + +``` +ghc --make square.hs +``` + +This will generate an executable which, when run produces a TeX (or PDF) file. Run the +executable with the `--help` option to find out more about how to call it. + +``` +$ ./square --help +square + +Usage: square [-?|--help] [-w|--width WIDTH] [-h|--height HEIGHT] + [-o|--output OUTPUT] [-f|--format FORMAT] [-a|--standalone] + [-r|--readable] [-l|--loop] [-s|--src ARG] + [-i|--interval INTERVAL] + Command-line diagram generation. + +Available options: + -?,--help Show this help text + -w,--width WIDTH Desired WIDTH of the output image + -h,--height HEIGHT Desired HEIGHT of the output image + -o,--output OUTPUT OUTPUT file + -f,--format FORMAT l for LaTeX, c for ConTeXt, p for plain + TeX (default: LaTeX) + -a,--standalone Produce standalone .tex output + -r,--readable Indent lines + -l,--loop Run in a self-recompiling loop + -s,--src ARG Source file to watch + -i,--interval INTERVAL When running in a loop, check for changes every + INTERVAL seconds. +``` + +If no output file is given, output is send to `stdout`. Supported outputs are `.tex` and `.pdf`. PDF generation is done using [texrunner]. + +[texrunner]: http://www.github.com/cchalmers/texrunner + +``` +$ ./Square -o square.tex +$ cat ./square.tex +\begin{pgfpicture} + \pgfpathrectangle{\pgfpointorigin}{\pgfqpoint{22.0000px}{22.0000px}} + \pgfusepath{use as bounding box} + \begin{pgfscope} + \begin{pgfscope} + \pgfpathmoveto{\pgfqpoint{21.0000px}{1.0000px}} + \pgfpathlineto{\pgfqpoint{21.0000px}{21.0000px}} + \pgfpathlineto{\pgfqpoint{1.0000px}{21.0000px}} + \pgfpathlineto{\pgfqpoint{1.0000px}{1.0000px}} + \pgfpathlineto{\pgfqpoint{21.0000px}{1.0000px}} + \pgfpathclose + \definecolor{sc}{rgb}{0.0000,0.0000,0.0000} + \pgfsetstrokecolor{sc} + \pgfsetlinewidth{0.0132mm} + \pgfusepath{stroke} + \end{pgfscope} + \end{pgfscope} +\end{pgfpicture} +``` + +### Typesetting + +`pgf-diagrams` allows typesetting TeX commands and can calculate the corresponding envelope. See the [hbox example] to see how get envelopes of text: + +[hbox example]: examples/hbox.hs + +![hbox](https://rawgit.com/cchalmers/texrunner/master/diagrams/hbox.svg) + + +### Missing features + +The following features are not currently supported: + +- selecting fonts (italic and bold work) +- gradients + 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-pgf.cabal b/diagrams-pgf.cabal new file mode 100644 --- /dev/null +++ b/diagrams-pgf.cabal @@ -0,0 +1,56 @@ +name: diagrams-pgf +version: 0.1.0.0 +synopsis: PGF backend for diagrams drawing EDSL. +license: BSD3 +license-file: LICENSE +author: Christopher Chalmers +maintainer: c.chalmers@me.com +homepage: http://github.com/cchalmers/diagrams-pgf +bug-reports: http://github.com/cchalmers/diagrams-pgf/issues +stability: Experimental +category: Graphics +build-type: Simple +cabal-version: >=1.10 +extra-source-files: README.md, diagrams/*.svg +extra-doc-files: diagrams/*.svg +description: + This package provides a modular backend for rendering diagrams created + with the diagrams EDSL using the TeX library PGF. + . + Support for rendering LaTeX, ConTeXt and plain TeX files. +source-repository head + type: git + location: http://github.com/cchalmers/diagrams-pgf + +library + exposed-modules: + Diagrams.Backend.PGF + Diagrams.Backend.PGF.CmdLine + Diagrams.Backend.PGF.Surface + Diagrams.Backend.PGF.Render + Diagrams.Backend.PGF.Hbox + Graphics.Rendering.PGF + hs-source-dirs: src + build-depends: + base >= 4.4 && < 4.9, + bytestring >= 0.9 && < 1.1, + containers >= 0.3 && < 0.6, + colour, + diagrams-core >= 1.3 && < 1.4, + diagrams-lib >= 1.3 && < 1.4, + directory >= 1.0 && < 1.4, + filepath >= 1.2 && < 1.5, + hashable >= 1.1 && < 1.3, + mtl >= 2.1 && < 3.0, + optparse-applicative >= 0.11 && < 0.12, + process >= 1.0 && < 1.3, + split >= 0.1.2 && < 0.3, + texrunner <= 0.0.2, + time >= 1.2 && < 1.6, + JuicyPixels, + vector, + zlib + + ghc-options: -Wall + default-language: Haskell2010 + diff --git a/diagrams/hbox.svg b/diagrams/hbox.svg new file mode 100644 --- /dev/null +++ b/diagrams/hbox.svg @@ -0,0 +1,98 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/Diagrams/Backend/PGF.hs b/src/Diagrams/Backend/PGF.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Backend/PGF.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Backend.PGF +-- Copyright : (c) 2015 Christopher Chalmers +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- A full-featured PGF backend for diagrams producing PGF code +-- suitable for LaTeX, ConTeXt or plain TeX consumption. +-- +-- To invoke the PGF backend, you have a number of options. +-- +-- * You can use 'renderPGF' or 'renderPGF'' to render a 'Diagram' to a +-- ".tex" or ".pdf" file; +-- +-- * You can use the most flexible 'renderDia' function to access the +-- resulting PGF code directly in memory as a bytestring 'Builder'. +-- +-- * Use 'Diagrams.Backend.PGF.CmdLine.mainWith' or +-- 'Diagrams.Backend.PGF.CmdLine.defaultMain' to make a command line +-- application. See 'Diagrams.Backend.PGF.CmdLine' for more info. +-- +-- The 'Surface' provides the necessary information for rendering PGF code and +-- building a PDF using "texrunner". See 'Diagrams.Backend.PGF.Surface' +-- for more info. +-- + +module Diagrams.Backend.PGF + ( -- * Rendering token & options + PGF (..) + , B + + -- * Rendering functions + , renderPGF + , renderPGF' + , renderPGFSurf + + -- * Options + -- | Options for changing how the diagram is rendered. 'Options' + -- 'PGF' is an instance of 'Default': + -- + -- @ + -- def = PGFOptions { + -- _surface = 'latexSurface' + -- _sizeSpec = 'absolute' + -- _readable = 'True' + -- _standalone = 'False' + -- } + -- @ + -- + -- You can edit the default options using lenses. + , readable + , sizeSpec + , surface + , standalone + + -- * Surfaces + -- | These surfaces should be suitable for basic diagrams. For more + -- complicated options see 'Diagrams.Backend.PGF.Surface'. + , Surface + , surfOnlineTex + + -- ** Predefined surfaces + , latexSurface + , contextSurface + , plaintexSurface + + -- ** Lenses + , command + , arguments + , preamble + + -- * Online TeX + -- | By using 'OnlineTex', diagrams is able to query tex for sizes + -- of hboxs and give them the corresponding envelopes. These can + -- then be used as any other diagram with the correct size. + -- + -- Online diagrams use the 'Surface' to run tex in online mode and + -- get feedback for hbox sizes. To run it you can use + -- 'renderOnlinePGF', 'renderOnlinePGF'' or 'onlineMain' from + -- 'Diagrams.Backend.PGF.CmdLine'. + -- + -- See + -- + -- for examples. + , OnlineTex + , renderOnlinePGF + , renderOnlinePGF' + + -- ** Hbox + , Hbox + , hboxOnline + , hboxPoint + , hboxSurf + ) where + +import Data.ByteString.Builder +import System.Directory hiding (readable) +import System.FilePath +import System.IO +import System.Texrunner +import System.Texrunner.Online hiding (hbox) + +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB + +import Diagrams.Backend.PGF.Hbox +import Diagrams.Backend.PGF.Render +import Diagrams.Backend.PGF.Surface +import Diagrams.Size +import Diagrams.Prelude hiding (r2) + +type B = PGF + +type instance V PGF = V2 +type instance N PGF = Double + +-- | Render a pgf diagram and write it to the given filepath. Same as +-- 'renderPGF'' but uses the default options. +renderPGF :: (TypeableFloat n, Monoid' m) + => FilePath -- ^ path to output + -> SizeSpec V2 n -- ^ size of output + -> QDiagram PGF V2 n m -- ^ 'Diagram' to render + -> IO () +renderPGF outFile sizeSp = renderPGFSurf outFile sizeSp def + +-- | Render a pgf diagram and write it to the given filepath. Same as +-- 'renderPGF' but takes a 'Surface'. +renderPGFSurf :: (TypeableFloat n, Monoid' m) + => FilePath -- ^ path to output + -> SizeSpec V2 n -- ^ size of output + -> Surface -- ^ surface to render with + -> QDiagram PGF V2 n m -- ^ diagram to render + -> IO () +renderPGFSurf outFile sizeSp surf = + renderPGF' outFile $ + def & sizeSpec .~ sizeSp + & surface .~ surf + +-- | Render a pgf diagram and write it to the given filepath. If the file has +-- the extension @.pdf@, a PDF is generated in a temporary directory using +-- options from the given surface, otherwise, the tex output is saved +-- using the surface's 'TexFormat'. +renderPGF' :: (TypeableFloat n, Monoid' m) + => FilePath -> Options PGF V2 n -> QDiagram PGF V2 n m -> IO () +renderPGF' outFile opts d = case takeExtension outFile of + ".pdf" -> do + let rendered = renderDia PGF (opts & standalone .~ True & readable .~ False) d + + currentDir <- getCurrentDirectory + targetDir <- canonicalizePath (takeDirectory outFile) + + let source = toLazyByteString rendered + + (_, texLog, mPDF) <- runTex (opts^.surface.command) + (opts^.surface.arguments) + [currentDir, targetDir] + source + + case mPDF of + Nothing -> putStrLn "Error, no PDF found:" + >> B.putStrLn (prettyPrintLog texLog) + Just pdf -> LB.writeFile outFile pdf + + -- tex output + _ -> writeTexFile outFile opts d + +-- | Render an online 'PGF' diagram and save it. Same as +-- 'renderOnlinePGF'' using default options. +renderOnlinePGF :: (TypeableFloat n, Monoid' m) + => FilePath + -> SizeSpec V2 n + -> OnlineTex (QDiagram PGF V2 n m) + -> IO () +renderOnlinePGF outFile sizeSp = renderOnlinePGF' outFile (def & sizeSpec .~ sizeSp) + +-- | Same as 'renderOnlinePDF' but takes 'Options' 'PGF'. +renderOnlinePGF' :: (TypeableFloat n, Monoid' m) + => FilePath + -> Options PGF V2 n + -> OnlineTex (QDiagram PGF V2 n m) + -> IO () +renderOnlinePGF' outFile opts dOL = case takeExtension outFile of + ".pdf" -> do + + ((), texLog, mPDF) <- + runOnlineTex' + (surf^.command) + (surf^.arguments) + (toByteString . stringUtf8 $ surf ^. (preamble <> beginDoc)) $ do + + d <- dOL + + -- we've already output the preamble so don't do it again + let opts' = opts & surface %~ set beginDoc "" . set preamble "" + & readable .~ False + & standalone .~ True + + rendered = renderDia PGF opts' d + + texPutStrLn $ toByteString rendered + + case mPDF of + Nothing -> putStrLn "Error, no PDF found:" + >> print texLog + Just pdf -> LB.writeFile outFile pdf + + -- tex output + _ -> surfOnlineTexIO surf dOL >>= writeTexFile outFile opts + where + surf = opts ^. surface + toByteString = LB.toStrict . toLazyByteString + +-- | Write the rendered diagram to a text file, ignoring the extension. +writeTexFile :: (TypeableFloat n, Monoid' m) + => FilePath -> Options PGF V2 n -> QDiagram PGF V2 n m -> IO () +writeTexFile outFile opts d = do + h <- openFile outFile WriteMode + hPutBuilder h $ renderDia PGF opts d + hClose h + diff --git a/src/Diagrams/Backend/PGF/CmdLine.hs b/src/Diagrams/Backend/PGF/CmdLine.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Backend/PGF/CmdLine.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Backend.PGF.CmdLine +-- Copyright : (c) 2015 Diagrams team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Convenient creation of command-line-driven executables for +-- rendering diagrams using the PGF backend. +-- +----------------------------------------------------------------------------- + +module Diagrams.Backend.PGF.CmdLine + ( -- * General form of @main@ + -- $mainwith + + mainWith + + -- * Supported forms of @main@ + + , defaultMain + , mainWithSurf + , onlineMain + , onlineMainWithSurf + , multiMain + + , module Diagrams.Backend.PGF + ) where + +import Data.ByteString.Builder +import Options.Applicative as OP + +import System.IO (stdout) + +import Diagrams.Backend.CmdLine +import Diagrams.Prelude hiding (height, interval, output, + width, (<>)) + +import Diagrams.Backend.PGF +import Diagrams.Backend.PGF.Surface + +-- pgf specific stuff + +data PGFCmdLineOpts = PGFCmdLineOpts + { _cmdStandalone :: Bool + , _cmdReadable :: Bool + } + +makeLenses ''PGFCmdLineOpts + +instance Parseable PGFCmdLineOpts where + parser = PGFCmdLineOpts + <$> switch + ( long "standalone" + <> short 'a' + <> help "Produce standalone .tex output" + ) + <*> switch + ( long "readable" + <> short 'r' + <> help "Indent lines" + ) + +-- not sure if this is of any use +instance ToResult d => ToResult (OnlineTex d) where + type Args (OnlineTex d) = (Surface, Args d) + type ResultOf (OnlineTex d) = IO (ResultOf d) + + toResult d (surf, args) = flip toResult args <$> surfOnlineTexIO surf d + +-- $mainwith +-- The 'mainWith' method unifies all of the other forms of @main@ and is +-- now the recommended way to build a command-line diagrams program. It +-- works as a direct replacement for 'defaultMain' or 'multiMain' as well +-- as allowing more general arguments. For example, given a function that +-- produces a diagram when given an @Int@ and a @'Colour' Double@, 'mainWith' +-- will produce a program that looks for additional number and color arguments. +-- +-- > ... definitions ... +-- > f :: Int -> Colour Double -> Diagram PGF +-- > f i c = ... +-- > +-- > main = mainWith f +-- +-- We can run this program as follows: +-- +-- > $ ghc --make mydiagram +-- > +-- > # output image.tex built by `f 20 red` +-- > $ ./MyDiagram -o image.tex -w 200 20 red + + +-- | This is the simplest way to render diagrams, and is intended to +-- be used like so: +-- +-- > ... definitions ... +-- > +-- > main = defaultMain myDiagram +-- +-- Compiling this file will result in an executable which takes +-- various command-line options for setting the size, output file, +-- and so on, and renders @myDiagram@ with the specified options. +-- +-- Pass @--help@ to the generated executable to see all available +-- options. Currently it looks something like +-- +-- @ +-- mydiagram +-- +-- Usage: mydiagram [-?|--help] [-w|--width WIDTH] [-h|--height HEIGHT] +-- [-o|--output OUTPUT] [-f|--format FORMAT] [-a|--standalone] +-- [-r|--readable] [-l|--loop] [-s|--src ARG] +-- [-i|--interval INTERVAL] +-- Command-line diagram generation. +-- +-- Available options: +-- -?,--help Show this help text +-- -w,--width WIDTH Desired WIDTH of the output image +-- -h,--height HEIGHT Desired HEIGHT of the output image +-- -o,--output OUTPUT OUTPUT file +-- -f,--format FORMAT l for LaTeX, c for ConTeXt, p for plain +-- TeX (default: LaTeX) +-- -a,--standalone Produce standalone .tex output +-- -r,--readable Indent lines +-- -l,--loop Run in a self-recompiling loop +-- -s,--src ARG Source file to watch +-- -i,--interval INTERVAL When running in a loop, check for changes every +-- INTERVAL seconds. +-- @ +-- +-- For example, a common scenario is +-- +-- @ +-- $ ghc --make mydiagram +-- +-- # output image.tex with a width of 400bp (and auto-determined height) +-- # (bp = big point = 1px at 72dpi) +-- $ ./mydiagram -o image.tex -w 400 +-- @ + +defaultMain :: Diagram PGF -> IO () +defaultMain = mainWith + +-- | Allows you to pick a surface the diagram will be rendered with. +-- (This +mainWithSurf :: Surface -> Diagram PGF -> IO () +mainWithSurf = curry mainWith + +-- For online diagrams. + +-- | Same as @defaultMain@ but takes an online pgf diagram. +onlineMain :: OnlineTex (Diagram PGF) -> IO () +onlineMain = mainWith + +-- | Same as @mainWithSurf@ but takes an online pgf diagram. +onlineMainWithSurf :: Surface -> OnlineTex (Diagram PGF) -> IO () +onlineMainWithSurf = curry mainWith + +-- Mainable instances + +instance TypeableFloat n => Mainable (QDiagram PGF V2 n Any) where + type MainOpts (QDiagram PGF V2 n Any) = + (DiagramOpts, DiagramLoopOpts, PGFCmdLineOpts, TexFormat) + mainRender (diaOpts, loopOpts, pgfOpts, format) d = do + chooseRender diaOpts pgfOpts (formatToSurf format) d + defaultLoopRender loopOpts + +instance TypeableFloat n => Mainable (Surface, QDiagram PGF V2 n Any) where + type MainOpts (Surface, QDiagram PGF V2 n Any) = + (DiagramOpts, DiagramLoopOpts, PGFCmdLineOpts) + mainRender (diaOpts, loopOpts, pgfOpts) (surf,d) = do + chooseRender diaOpts pgfOpts surf d + defaultLoopRender loopOpts + +-- Online diagrams +instance TypeableFloat n => Mainable (OnlineTex (QDiagram PGF V2 n Any)) where + type MainOpts (OnlineTex (QDiagram PGF V2 n Any)) + = (DiagramOpts, DiagramLoopOpts, PGFCmdLineOpts, TexFormat) + mainRender (diaOpts, loopOpts, pgfOpts, format) d = do + chooseOnlineRender diaOpts pgfOpts (formatToSurf format) d + defaultLoopRender loopOpts + +instance TypeableFloat n => Mainable (Surface, OnlineTex (QDiagram PGF V2 n Any)) where + type MainOpts (Surface, OnlineTex (QDiagram PGF V2 n Any)) + = (DiagramOpts, DiagramLoopOpts, PGFCmdLineOpts) + mainRender (diaOpts, loopOpts, pgfOpts) (surf, d) = do + chooseOnlineRender diaOpts pgfOpts surf d + defaultLoopRender loopOpts + +formatToSurf :: TexFormat -> Surface +formatToSurf format = case format of + LaTeX -> latexSurface + ConTeXt -> contextSurface + PlainTeX -> plaintexSurface + +cmdLineOpts :: TypeableFloat n + => DiagramOpts -> Surface -> PGFCmdLineOpts -> Options PGF V2 n +cmdLineOpts opts surf pgf + = def & surface .~ surf + & sizeSpec .~ sz + & readable .~ pgf^.cmdReadable + & standalone .~ pgf^.cmdStandalone + where + sz = fromIntegral <$> mkSizeSpec2D (opts^.width) (opts^.height) + +chooseRender :: TypeableFloat n + => DiagramOpts -> PGFCmdLineOpts -> Surface -> QDiagram PGF V2 n Any -> IO () +chooseRender diaOpts pgfOpts surf d = + case diaOpts^.output of + "" -> hPutBuilder stdout $ renderDia PGF opts d + out -> renderPGF' out opts d + where + opts = cmdLineOpts diaOpts surf pgfOpts + +chooseOnlineRender :: TypeableFloat n + => DiagramOpts -> PGFCmdLineOpts -> Surface -> OnlineTex (QDiagram PGF V2 n Any) -> IO () +chooseOnlineRender diaOpts pgfOpts surf d = + case diaOpts^.output of + "" -> surfOnlineTexIO surf d >>= hPutBuilder stdout . renderDia PGF opts + out -> renderOnlinePGF' out opts d + where + opts = cmdLineOpts diaOpts surf pgfOpts + + +-- | @multiMain@ is like 'defaultMain', except instead of a single +-- diagram it takes a list of diagrams paired with names as input. +-- The generated executable then takes a @--selection@ option +-- specifying the name of the diagram that should be rendered. The +-- list of available diagrams may also be printed by passing the +-- option @--list@. +-- +-- Example usage: +-- +-- @ +-- $ ghc --make MultiTest +-- [1 of 1] Compiling Main ( MultiTest.hs, MultiTest.o ) +-- Linking MultiTest ... +-- $ ./MultiTest --list +-- Available diagrams: +-- foo bar +-- $ ./MultiTest --selection bar -o Bar.tex -w 200 +-- @ + +multiMain :: [(String, Diagram PGF)] -> IO () +multiMain = mainWith + +instance TypeableFloat n => Mainable [(String,QDiagram PGF V2 n Any)] where + type MainOpts [(String,QDiagram PGF V2 n Any)] + = (MainOpts (QDiagram PGF V2 n Any), DiagramMultiOpts) + + mainRender = defaultMultiMainRender + +instance Parseable TexFormat where + parser = OP.option (eitherReader parseFormat) + $ short 'f' + <> long "format" + <> help "l for LaTeX, c for ConTeXt, p for plain TeX" + <> metavar "FORMAT" + <> OP.value LaTeX + <> showDefault + +parseFormat :: String -> Either String TexFormat +parseFormat ('l':_) = Right LaTeX +parseFormat ('c':_) = Right ConTeXt +parseFormat ('p':_) = Right PlainTeX +parseFormat ('t':_) = Right PlainTeX +parseFormat x = Left $ "Unknown format" ++ x + diff --git a/src/Diagrams/Backend/PGF/Hbox.hs b/src/Diagrams/Backend/PGF/Hbox.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Backend/PGF/Hbox.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Backend.PGF +-- Copyright : (c) 2014 Christopher Chalmers +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- A hbox a primitive Tex box, typically used for holding text and +-- formulas but can hold anything. This module provides functions for +-- retrieving the dimensions of these boxes to give diagrams the correct +-- envelopes. +----------------------------------------------------------------------------- +module Diagrams.Backend.PGF.Hbox + ( Hbox (..) + + -- * Enveloped diagrams + -- | The dimensions of a hbox can be recovered by calling Tex. The + -- resulting envelope has its origin at the baseline of the text. + -- + -- <> + , hboxOnline + + -- ** Non-Online version + -- | These versions bypass 'OnlineTex' by just running a whole tex + -- program just to get the size of a single hbox. This is not + -- recommended but because it is slow, but can be convientient if + -- you only need one or two hbox sizes. + , hboxSurf + , hboxSurfIO + + -- * Point envelope diagrams + , hboxPoint + + ) where + +import Data.ByteString.Char8 (pack) +import Data.Monoid +import Data.Typeable +import System.IO.Unsafe +import System.Texrunner.Online hiding (hbox) +import qualified System.Texrunner.Online as Online +import System.Texrunner.Parse + +import Diagrams.Core.Envelope (pointEnvelope) +import Diagrams.Prelude hiding (Box, (<>)) + +import Diagrams.Backend.PGF.Surface + +-- | Primitive for placing raw Tex commands in a hbox. +data Hbox n = Hbox (Transformation V2 n) String + deriving Typeable + +type instance V (Hbox n) = V2 +type instance N (Hbox n) = n + +instance Fractional n => Transformable (Hbox n) where + transform t (Hbox tt str) = Hbox (t <> tt) str + +instance Fractional n => Renderable (Hbox n) NullBackend where + render _ _ = mempty + +-- | Raw Tex commands in a hbox with no envelope. Transformations are +-- applied normally. This primitive ignores +-- 'Diagrams.TwoD.Text.FontSize'. +hboxPoint :: (OrderedField n, Typeable n, Renderable (Hbox n) b) + => String -> QDiagram b V2 n Any +hboxPoint raw = mkQD (Prim (Hbox mempty raw)) + (pointEnvelope origin) + mempty + mempty + mempty + +-- | Hbox with bounding box envelope. Note that each box requires a call to +-- Tex. For multiple boxes consider using 'onlineHbox' to get multiple boxes +-- from a single call. (uses unsafePerformIO) +hboxSurf :: (TypeableFloat n, Renderable (Hbox n) b) + => Surface -> String -> QDiagram b V2 n Any +hboxSurf surf txt = unsafePerformIO (hboxSurfIO surf txt) +{-# NOINLINE hboxSurf #-} + +-- | Hbox with bounding box envelope. Note that each box requires a call to +-- Tex. For multiple boxes consider using 'onlineHbox' to get multiple boxes +-- from a single call. +hboxSurfIO :: (TypeableFloat n, Renderable (Hbox n) b) + => Surface -> String -> IO (QDiagram b V2 n Any) +hboxSurfIO surf txt = surfOnlineTexIO surf (hboxOnline txt) + +-- | Hbox with bounding box envelope. +hboxOnline :: (TypeableFloat n, Renderable (Hbox n) b) + => String -> OnlineTex (QDiagram b V2 n Any) +hboxOnline txt = do + Box h d w <- Online.hbox (pack txt) + + let bb = fromCorners (P $ V2 0 (-d)) + (P $ V2 w h) + + return $ mkQD (Prim (Hbox mempty txt)) + (getEnvelope bb) + (getTrace bb) + mempty + (boundingBoxQuery bb) + diff --git a/src/Diagrams/Backend/PGF/Render.hs b/src/Diagrams/Backend/PGF/Render.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Backend/PGF/Render.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Backend.PGF.Render +-- Copyright : (c) 2015 Christopher Chalmers +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- This is an internal module exposeing internals for rendering a +-- diagram. This is for advanced use only. 'Diagrams.Backend.PGF' +-- has enought for general use. +-- +module Diagrams.Backend.PGF.Render + ( PGF (..) + , Options (..) + , Render (..) + + -- * Lenses + , surface + , sizeSpec + , readable + , standalone + + -- * Utilities + , escapeString + ) where + +import Control.Monad (when) +import Data.ByteString.Builder + +import qualified Data.Foldable as F (foldMap) +import Data.Functor +import Data.Hashable (Hashable (..)) +import Data.Tree (Tree (Node)) + +import Diagrams.Core.Types +import Diagrams.Prelude hiding ((<~)) + +import Diagrams.Backend.PGF.Hbox (Hbox (..)) +import Diagrams.Backend.PGF.Surface (Surface) +import Diagrams.TwoD.Adjust (adjustDia2D) +import Diagrams.TwoD.Path +import Diagrams.TwoD.Text (Text (..), TextAlignment (..), getFontSize, + getFontSlant, getFontWeight) +import Data.Typeable +import qualified Graphics.Rendering.PGF as P + +import Prelude + +-- | This data declaration is simply used as a token to distinguish +-- this rendering engine. +data PGF = PGF + deriving (Show, Typeable) + +instance TypeableFloat n => Backend PGF V2 n where + newtype Render PGF V2 n = R (P.Render n) + type Result PGF V2 n = Builder + data Options PGF V2 n = PGFOptions + { _surface :: Surface -- ^ Surface you want to use. + , _sizeSpec :: SizeSpec V2 n -- ^ The requested size. + , _readable :: Bool -- ^ Indented lines for @.tex@ output. + , _standalone :: Bool -- ^ Should @.tex@ output be standalone. + } + + renderRTree _ ops (toRender -> R r) = + P.renderWith (ops^.surface) (ops^.readable) (ops^.standalone) bounds r + where + bounds = specToSize 100 (ops^.sizeSpec) + + adjustDia = adjustDia2D sizeSpec + +toRender :: TypeableFloat n => RTree PGF V2 n Annotation -> Render PGF V2 n +toRender (Node n rs) = case n of + RPrim p -> render PGF p + RStyle sty' -> R $ do + sty <- P.style <<<>= sty' -- mappend old style + clips <- use (P.style . _clip) + clip clips r <* (P.style .= sty) -- render then revert to old style + RAnnot (OpacityGroup x) -> R $ P.opacityGroup x r + _ -> R r + where R r = F.foldMap toRender rs + +instance Fractional n => Default (Options PGF V2 n) where + def = PGFOptions + { _surface = def + , _sizeSpec = absolute + , _readable = True + , _standalone = False + } + +instance Monoid (Render PGF V2 n) where + mempty = R $ return () + R ra `mappend` R rb = R $ ra >> rb + +-- | Lens onto the surface used to render. +surface :: Lens' (Options PGF V2 n) Surface +surface = lens _surface (\o s -> o {_surface = s}) + +-- | Lens onto whether a standalone TeX document should be produced. +standalone :: Lens' (Options PGF V2 n) Bool +standalone = lens _standalone (\o s -> o {_standalone = s}) + +-- | Lens onto the 'SizeSpec2D'. +sizeSpec :: Lens' (Options PGF V2 n) (SizeSpec V2 n) +sizeSpec = lens _sizeSpec (\o s -> o {_sizeSpec = s}) + +-- | Lens onto whether the lines of the TeX output are indented. +readable :: Lens' (Options PGF V2 n) Bool +readable = lens _readable (\o b -> o {_readable = b}) + +-- helper function to easily get options and set them +(<~) :: AttributeClass a => (b -> P.Render n) -> (a -> b) -> P.Render n +renderF <~ getF = do + s <- uses P.style (fmap getF . getAttr) + maybe (return ()) renderF s + +infixr 2 <~ + +-- | Fade a colour with the opacity from the style. +fade :: Color c => c -> P.RenderM n (AlphaColour Double) +fade c = flip dissolve (toAlphaColour c) <$> use (P.style . _opacity) + +-- The Path is necessary so we can clip/workout gradients. +setFillTexture :: RealFloat n => Path V2 n -> Texture n -> P.Render n +setFillTexture p t = case t of + SC (SomeColor c) -> fade c >>= P.setFillColor + LG g -> P.linearGradient p g + RG g -> P.radialGradient p g + +setLineTexture :: RealFloat n => Texture n -> P.Render n +setLineTexture (SC (SomeColor c)) = fade c >>= P.setLineColor +setLineTexture _ = return () + +clip :: TypeableFloat n => [Path V2 n] -> P.Render n -> P.Render n +clip paths r = go paths + where + go [] = r + go (p:ps) = P.scope $ P.path p >> P.clip >> go ps + +-- | Escapes some common characters in a string. Note that this does not +-- mean the string can't create an error, it mearly escapes common +-- characters. +escapeString :: String -> String +escapeString = concatMap escapeChar + where + escapeChar ch = case ch of + '$' -> "\\$" + '%' -> "\\letterpercent{}" + '&' -> "\\&" + '#' -> "\\#" + '_' -> "\\_" + '{' -> "$\\{$" + '}' -> "$\\}$" + '\\'-> "$\\backslash{}$" + '~' -> "\\~{}" + '^' -> "\\^{}" + '[' -> "{[}" + ']' -> "{]}" + x -> [x] + +-- Renderable instances ------------------------------------------------ + +instance TypeableFloat n => Renderable (Path V2 n) PGF where + render _ path = R . P.scope $ do + -- lines and loops are separated when stroking so we only need to + -- check the first one + let canFill = noneOf (_head . located) isLine path + -- solid colours need to be filled with usePath + doFill <- if canFill + then do + mFillTexture <- preuse (P.style . _fillTexture) + case mFillTexture of + Nothing -> return False + Just t -> do + setFillTexture path t + P.setFillRule <~ getFillRule + return (has _SC t) + else return False + -- + w <- use (P.style . _lineWidthU . non 0) + let doStroke = w > 0.0001 + when doStroke $ do + P.setLineWidth w + setLineTexture <~ getLineTexture + P.setLineJoin <~ getLineJoin + P.setLineCap <~ getLineCap + P.setDash <~ getDashing + -- + P.path path + P.usePath doFill doStroke + +-- | Does not support full alignment. Text is not escaped. +instance TypeableFloat n => Renderable (Text n) PGF where + render _ (Text tt txtAlign str) = R . P.scope $ do + setFillTexture mempty <~ getFillTexture + -- + P.applyTransform tt + (P.applyScale . (/8)) <~ getFontSize + -- (/8) was obtained from trail and error + -- + P.renderText (P.setTextAlign txtAlign) $ do + P.setFontWeight <~ getFontWeight + P.setFontSlant <~ getFontSlant + P.rawString str + +instance TypeableFloat n => Renderable (Hbox n) PGF where + render _ (Hbox tt str) = R . P.scope $ do + P.applyTransform tt + P.renderText (P.setTextAlign BaselineText) (P.rawString str) + +-- | Supported: @.pdf@, @.jpg@, @.png@. +instance RealFloat n => Renderable (DImage n External) PGF where + render _ = R . P.image + +-- | Supported: 'ImageRGB8'. (Other types from 'DynamicImage' will +-- error) +instance RealFloat n => Renderable (DImage n Embedded) PGF where + render _ = R . P.embeddedImage + +------------------------------------------------------------------------ +-- Hashable instances + +instance Hashable n => Hashable (Options PGF V2 n) where + hashWithSalt s (PGFOptions sf sz rd st) + = s `hashWithSalt` + sf `hashWithSalt` + sz `hashWithSalt` + rd `hashWithSalt` + st + diff --git a/src/Diagrams/Backend/PGF/Surface.hs b/src/Diagrams/Backend/PGF/Surface.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Backend/PGF/Surface.hs @@ -0,0 +1,301 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Backend.PGF.Surface +-- Copyright : (c) 2015 Christopher Chalmers +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- A 'Surface' defines how a pgfpicture should be placed and compiled. Surfaces +-- are used for rendering a @.tex@ or @.pdf@ using functions from +-- 'Diagrams.Backend.PGF'. +-- +-- Surfaces are also used in 'Diagrams.Backend.PGF.Hbox' for querying +-- envelopes of text. +-- +-- Surfaces for Latex, Context and plain Tex are provided and reexported by +-- Diagrams.Backend.PGF. Lenses here allow these to be adjusted as required. +----------------------------------------------------------------------------- + +module Diagrams.Backend.PGF.Surface + ( -- * Surface definition + Surface(..) + , TexFormat(..) + + -- * Online rendering with surfaces + , surfOnlineTex + , surfOnlineTexIO + + -- * Predefined surfaces + , latexSurface + , contextSurface + , plaintexSurface + , sampleSurfaceOutput + + -- * Lenses + , texFormat + , command + , arguments + , pageSize + , preamble + , beginDoc + , endDoc + ) where + +import Data.ByteString.Builder +import Data.Hashable (Hashable (..)) +import Data.Typeable (Typeable) +import System.IO.Unsafe +import System.Texrunner.Online + + +import Diagrams.Prelude +import Prelude + +-- | The 'TexFormat' is used to choose the different PGF commands nessesary for +-- that format. +data TexFormat = LaTeX | ConTeXt | PlainTeX + deriving (Show, Read, Eq, Typeable) + -- These names are only captialised so Context doesn't conflict with + -- lens's Context. + +data Surface = Surface + { _texFormat :: TexFormat -- ^ Format for the PGF commands + , _command :: String -- ^ System command to be called. + , _arguments :: [String] -- ^ Auguments for command. + , _pageSize :: Maybe (V2 Int -> String) + -- ^ Command to change page size from dimensions of image. + -- (in bp) + , _preamble :: String -- ^ Preamble for document, should import pgfcore. + , _beginDoc :: String -- ^ Begin document. + , _endDoc :: String -- ^ End document. + } + +makeLensesWith (lensRules & generateSignatures .~ False) ''Surface + +-- | Format for the PGF commands. +texFormat :: Lens' Surface TexFormat + +-- | System command to call for rendering PDFs for 'OnlineTex'. +command :: Lens' Surface String + +-- | List of arguments for the 'command'. +arguments :: Lens' Surface [String] + +-- | Preamble for the tex document. This should at least import +-- @pgfcore@. +preamble :: Lens' Surface String + +-- | Specify the page size for the tex file. +pageSize :: Lens' Surface (Maybe (V2 Int -> String)) + +-- | Command to begin the document. (This normally doesn't need to +-- change) +beginDoc :: Lens' Surface String + +-- | Command to end the document. (This normally doesn't need to +-- change) +endDoc :: Lens' Surface String + +-- Predefined surfaces ------------------------------------------------- + +-- | Default surface for latex files by calling @pdflatex@. +-- +-- ==== __Sample output__ +-- +-- @ +-- 'command': pdflatex +-- +-- % 'preamble' +-- \documentclass{article} +-- \usepackage{pgfcore} +-- \pagenumbering{gobble} +-- +-- % 'pageSize' +-- \pdfpagewidth=100bp +-- \pdfpageheight=80bp +-- \textheight=80bp +-- \pdfhorigin=-76.6bp +-- \pdfvorigin=-52.8bp +-- +-- % 'beginDoc' +-- \begin{document} +-- +-- \ +-- +-- % 'endDoc' +-- \end{document} +-- @ +-- +latexSurface :: Surface +latexSurface = Surface + { _texFormat = LaTeX + , _command = "pdflatex" + , _arguments = [] + , _pageSize = Just $ \(V2 w h) -> + "\\pdfpagewidth=" ++ show w ++ "bp\n" + ++ "\\pdfpageheight=" ++ show h ++ "bp\n" + ++ "\\textheight=" ++ show h ++ "bp\n" + ++ "\\pdfhorigin=-76.6bp\n" + ++ "\\pdfvorigin=-52.8bp" + , _preamble = "\\documentclass{article}\n" + ++ "\\usepackage{pgfcore}\n" + ++ "\\pagenumbering{gobble}" + , _beginDoc = "\\begin{document}" + , _endDoc = "\\end{document}" + } + +-- | Default surface for latex files by calling @pdflatex@. +-- +-- ==== __Sample output__ +-- +-- @ +-- 'command': context --pipe --once + +-- % 'preamble' +-- \usemodule[pgf] +-- \setuppagenumbering[location=] +-- +-- % 'pageSize' +-- \definepapersize[diagram][width=100bp,height=80bp] +-- \setuppapersize[diagram][diagram] +-- \setuplayout +-- [ topspace=0bp +-- , backspace=0bp +-- , header=0bp +-- , footer=0bp +-- , width=100bp +-- , height=80bp +-- ] +-- +-- % 'beginDoc' +-- \starttext +-- +-- \ +-- +-- % 'endDoc' +-- \stoptext +-- @ +-- +contextSurface :: Surface +contextSurface = Surface + { _texFormat = ConTeXt + , _command = "context" + , _arguments = ["--pipe", "--once"] + , _pageSize = Just $ \(V2 w h) -> + "\\definepapersize[diagram][width="++ show w ++"bp,height="++ show h ++"bp]\n" + ++ "\\setuppapersize[diagram][diagram]\n" + ++ "\\setuplayout\n" + ++ " [ topspace=0bp\n" + ++ " , backspace=0bp\n" + ++ " , header=0bp\n" + ++ " , footer=0bp\n" + ++ " , width=" ++ show w ++ "bp\n" + ++ " , height=" ++ show h ++ "bp\n" + ++ " ]" + , _preamble = "\\usemodule[pgf]\n" -- pgfcore doesn't work + ++ "\\setuppagenumbering[location=]" + , _beginDoc = "\\starttext" + , _endDoc = "\\stoptext" + } + +-- | Default surface for latex files by calling @pdflatex@. +-- +-- ==== __Sample output__ +-- +-- @ +-- 'command': pdftex +-- +-- % 'preamble' +-- \input eplain +-- \beginpackages +-- \usepackage{color} +-- \endpackages +-- \input pgfcore +-- \def\frac#1#2{{\begingroup #1\endgroup\over #2}}\nopagenumbers +-- +-- % 'pageSize' +-- \pdfpagewidth=100bp +-- \pdfpageheight=80bp +-- \pdfhorigin=-20bp +-- \pdfvorigin=0bp +-- +-- % 'beginDoc' +-- +-- +-- +-- +-- % 'endDoc' +-- \bye +-- @ +-- +plaintexSurface :: Surface +plaintexSurface = Surface + { _texFormat = PlainTeX + , _command = "pdftex" + , _arguments = [] + , _pageSize = Just $ \(V2 w h) -> + "\\pdfpagewidth=" ++ show w ++ "bp\n" + ++ "\\pdfpageheight=" ++ show h ++ "bp\n" + ++ "\\pdfhorigin=-20bp\n" + ++ "\\pdfvorigin=0bp" + , _preamble = "\\input eplain\n" + ++ "\\beginpackages\n\\usepackage{color}\n\\endpackages\n" + ++ "\\input pgfcore\n" + ++ "\\def\\frac#1#2{{\\begingroup #1\\endgroup\\over #2}}" + ++ "\\nopagenumbers" + , _beginDoc = "" + , _endDoc = "\\bye" + } + +-- | Latex is the default surface. +instance Default Surface where + def = latexSurface + +sampleSurfaceOutput :: Surface -> String +sampleSurfaceOutput surf = unlines + [ "command: " ++ surf ^. command ++ " " ++ unwords (surf ^. arguments) + , "\n% preamble" + , surf ^. preamble + , "\n% pageSize" + , view _Just $ surf ^. pageSize <*> Just (V2 100 80) + , "\n% beginDoc" + , surf ^. beginDoc + , "\n<" ++ show (surf ^. texFormat) ++ " pgf code>" + , "\n% endDoc" + , surf ^. endDoc + ] + +-- OnlineTex functions ------------------------------------------------- + +-- | Get the result of an OnlineTex using the given surface. +surfOnlineTex :: Surface -> OnlineTex a -> a +surfOnlineTex surf a = unsafePerformIO (surfOnlineTexIO surf a) +{-# NOINLINE surfOnlineTex #-} + +-- | Get the result of an OnlineTex using the given surface. +surfOnlineTexIO :: Surface -> OnlineTex a -> IO a +surfOnlineTexIO surf = runOnlineTex (surf^.command) (surf^.arguments) begin + where + begin = view strict . toLazyByteString . stringUtf8 + $ surf ^. (preamble <> beginDoc) + +-- Hashable instances -------------------------------------------------- + +instance Hashable TexFormat where + hashWithSalt s LaTeX = s `hashWithSalt` (1::Int) + hashWithSalt s ConTeXt = s `hashWithSalt` (2::Int) + hashWithSalt s PlainTeX = s `hashWithSalt` (3::Int) + +instance Hashable Surface where + hashWithSalt s (Surface tf cm ar ps p bd ed) + = s `hashWithSalt` + tf `hashWithSalt` + cm `hashWithSalt` + ar `hashWithSalt` + ps <*> Just (V2 1 2) `hashWithSalt` + p `hashWithSalt` + bd `hashWithSalt` + ed + diff --git a/src/Graphics/Rendering/PGF.hs b/src/Graphics/Rendering/PGF.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rendering/PGF.hs @@ -0,0 +1,927 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.PGF +-- Copyright : (c) 2015 Christopher Chalmers +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Interface to PGF. See the manual http://www.ctan.org/pkg/pgf for details. +-- +------------------------------------------------------------------------------ +module Graphics.Rendering.PGF + ( renderWith + , RenderM + , Render + , initialState + -- * Environments + , scope + -- , scopeHeader + -- , resetState + -- , scopeFooter + , epsilon + -- * Lenses + -- , fillRule + , style + -- * units + , bp + , pt + , mm + , px + -- * RenderM commands + , ln + , raw + , rawString + , pgf + , bracers + , brackets + -- * Paths + , path + , trail + , segment + , usePath + , lineTo + , curveTo + , moveTo + , closePath + , clip + , stroke + , fill + , asBoundingBox + -- , rectangleBoundingBox + -- * Strokeing Options + , setDash + , setLineWidth + , setLineCap + , setLineJoin + , setMiterLimit + , setLineColor + , setLineOpacity + -- * Fill Options + , setFillColor + , setFillRule + , setFillOpacity + -- * Transformations + , setTransform + , applyTransform + , baseTransform + , applyScale + , resetNonTranslations + -- * Shading + , linearGradient + , radialGradient + , colorSpec + , shadePath + , opacityGroup + -- * images + , image + , embeddedImage + , embeddedImage' + -- * Text + , renderText + , setTextAlign + , setTextRotation + , setFontWeight + , setFontSlant + ) where + +import Codec.Compression.Zlib +import Codec.Picture +import Control.Monad.RWS +import Data.ByteString.Builder +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B (replicate) +import Data.ByteString.Internal (fromForeignPtr) +import qualified Data.ByteString.Lazy as LB +import qualified Data.Foldable as F (foldMap) +import Data.List (intersperse) +import Data.Maybe (catMaybes) +import Data.Typeable +import qualified Data.Vector.Storable as S +import Numeric + +import Diagrams.Core.Transform +import Diagrams.Prelude hiding (Render, image, moveTo, + opacity, opacityGroup, stroke, + (<>)) +import Diagrams.TwoD.Text (FontSlant (..), FontWeight (..), + TextAlignment (..)) + +import Diagrams.Backend.PGF.Surface + + +-- * Types, lenses & runners + +-- | Render state, mainly to be used for convenience when build, this module +-- only uses the indent properly. +data RenderState n = RenderState + { _pos :: P2 n -- ^ Current position + , _indent :: Int -- ^ Current indentation + , _style :: Style V2 n + } + +makeLenses ''RenderState + +data RenderInfo = RenderInfo + { _format :: TexFormat + , _pprint :: Bool + } + +makeLenses ''RenderInfo + +-- | Type for render monad. +type RenderM n m = RWS RenderInfo Builder (RenderState n) m + +-- | Convenient type for building. +type Render n = RenderM n () + +-- | Starting state for running the builder. +initialState :: (Typeable n, Floating n) => RenderState n +initialState = RenderState + { _pos = origin + , _indent = 0 + , _style = lc black mempty -- Until I think of something better: + -- (square 1 # opacity 0.5) doesn't work otherwise + } + +renderWith :: (RealFloat n, Typeable n) + => Surface -> Bool -> Bool -> V2 n -> Render n -> Builder +renderWith s readable standalone bounds r = builder + where + bounds' = fmap (fromInteger . floor) bounds + (_,builder) = evalRWS r' + (RenderInfo (s^.texFormat) readable) + initialState + r' = do + when standalone $ do + ln . rawString $ s^.preamble + maybe (return ()) + (ln . rawString . ($ fmap ceiling bounds')) + (s^.pageSize) + ln . rawString $ s^.beginDoc + picture $ rectangleBoundingBox bounds' >> r + when standalone $ rawString $ s^.endDoc + +-- low level utilities ------------------------------------------------- + +-- builder functions +raw :: Builder -> Render n +raw = tell +{-# INLINE raw #-} + +rawByteString :: ByteString -> Render n +rawByteString = tell . byteString +{-# INLINE rawByteString #-} + +rawString :: String -> Render n +rawString = tell . string8 +{-# INLINE rawString #-} + +pgf :: Builder -> Render n +pgf c = raw $ "\\pgf" <> c +{-# INLINE pgf #-} + +rawChar :: Char -> Render n +rawChar = tell . char8 +{-# INLINE rawChar #-} + +-- | Emit the indentation when 'pprint' is True. +emit :: Render n +emit = do + pp <- view pprint + when pp $ do + tab <- use indent + rawByteString $ B.replicate tab ' ' +{-# INLINE emit #-} + +ln :: Render n -> Render n +ln r = do + emit + r + rawChar '\n' +{-# INLINE ln #-} + +-- | Wrap a `Render n` in { .. }. +bracers :: Render n -> Render n +bracers r = do + rawChar '{' + r + rawChar '}' +{-# INLINE bracers #-} + +bracersBlock :: Render n -> Render n +bracersBlock rs = do + raw "{\n" + inBlock rs + emit + rawChar '}' + +-- | Wrap a `Render n` in [ .. ]. +brackets :: Render n -> Render n +brackets r = do + rawChar '[' + r + rawChar ']' +{-# INLINE brackets #-} + +parens :: Render n -> Render n +parens r = do + rawChar '(' + r + rawChar ')' +{-# INLINE parens #-} + +-- | Intersperse list of Render ns with commas. +commaIntersperce :: [Render n] -> Render n +commaIntersperce = sequence_ . intersperse (rawChar ',') + +-- | Place a Render n in an indented block +inBlock :: Render n -> Render n +inBlock r = do + indent += 2 + r + indent -= 2 + +-- numbers and points -------------------------------------------------- + +-- | Render a point. +point :: RealFloat n => P2 n -> Render a +point = tuplePoint . unp2 + +bracerPoint :: RealFloat n => P2 n -> Render a +bracerPoint (P (V2 x y)) = do + bracers (bp x) + bracers (bp y) + +-- | Render n a tuple as a point. +tuplePoint :: RealFloat n => (n,n) -> Render a +tuplePoint (x,y) = do + pgf "qpoint" + bracers (bp x) + bracers (bp y) + +-- | Render n a n to four decimal places. +n :: RealFloat a => a -> Render n +n x = rawString $ showFFloat (Just 4) x "" + +-- | Render n length with bp (big point = 1 px at 72 dpi) units. +bp :: RealFloat a => a -> Render n +bp = (>> raw "bp") . n + +-- | Render n length with px units. +px :: RealFloat a => a -> Render n +px = (>> raw "px") . n + +-- | Render n length with mm units. +mm :: RealFloat a => a -> Render n +mm = (>> raw "mm") . n -- . (*0.35278) + +-- | Render n length with pt units. +pt :: RealFloat a => a -> Render n +pt = (>> raw "pt") . n -- . (*1.00375) + +-- | ε = 0.0001 is the limit at which lines are no longer stroked. +epsilon :: Fractional n => n +epsilon = 0.0001 + +-- environments -------------------------------------------------------- + +picture :: Render n -> Render n +picture r = do + f <- view format + ln . raw $ case f of + LaTeX -> "\\begin{pgfpicture}" + ConTeXt -> "\\startpgfpicture" + PlainTeX -> "\\pgfpicture" + inBlock r + ln . raw $ case f of + LaTeX -> "\\end{pgfpicture}" + ConTeXt -> "\\stoppgfpicture" + PlainTeX -> "\\endpgfpicture" + +rectangleBoundingBox :: RealFloat n => V2 n -> Render n +rectangleBoundingBox bounds = do + ln $ do + pgf "pathrectangle" + bracers $ pgf "pointorigin" + bracers $ tuplePoint (unr2 bounds) + ln $ do + pgf "usepath" + bracers $ raw "use as bounding box" + +-- | Wrap the rendering in a scope. +scope :: Render n -> Render n +scope r = do + f <- view format + ln . raw $ case f of + LaTeX -> "\\begin{pgfscope}" + ConTeXt -> "\\startpgfscope" + PlainTeX -> "\\pgfscope" + inBlock r + ln . raw $ case f of + LaTeX -> "\\end{pgfscope}" + ConTeXt -> "\\stoppgfscope" + PlainTeX -> "\\endpgfscope" + +-- opacity groups ------------------------------------------------------ + +transparencyGroup :: Render n -> Render n +transparencyGroup r = do + f <- view format + ln . raw $ case f of + LaTeX -> "\\begin{pgftransparencygroup}" + ConTeXt -> "\\startpgftransparencygroup" + PlainTeX -> "\\pgftransparencygroup" + inBlock r + ln . raw $ case f of + LaTeX -> "\\end{pgftransparencygroup}" + ConTeXt -> "\\stoppgftransparencygroup" + PlainTeX -> "\\endpgftransparencygroup" + +opacityGroup :: RealFloat a => a -> Render n -> Render n +opacityGroup x r = scope $ do + setFillOpacity x + transparencyGroup r + +-- colours ------------------------------------------------------------- + +texColor :: RealFloat a => a -> a -> a -> Render n +texColor r g b = do + n r + rawChar ',' + n g + rawChar ',' + n b + +contextColor :: RealFloat a => a -> a -> a -> Render n +contextColor r g b = do + raw "r=" >> n r + rawChar ',' + raw "g=" >> n g + rawChar ',' + raw "b=" >> n b + +-- | Defines an RGB colour with the given name, using the Tex format. +defineColour :: RealFloat a => ByteString -> a -> a -> a -> Render n +defineColour name r g b = do + f <- view format + ln $ case f of + ConTeXt -> do + raw "\\definecolor" + brackets $ rawByteString name + brackets $ contextColor r g b + _ -> do + raw "\\definecolor" + bracers $ rawByteString name + bracers $ raw "rgb" + bracers $ texColor r g b + +parensColor :: Color c => c -> Render n +parensColor c = parens $ texColor r g b + where (r,g,b,_) = colorToSRGBA c + + +-- paths --------------------------------------------------------------- + +-- | Close the current path. +closePath :: Render n +closePath = ln $ pgf "pathclose" + +-- | Move path to point. +moveTo :: RealFloat n => P2 n -> Render n +moveTo v = ln $ do + pos .= v + pgf "pathqmoveto" + bracerPoint v + +-- | Move path by vector. +lineTo :: RealFloat n => V2 n -> Render n +lineTo v = ln $ do + p <- use pos + let v' = p .+^ v + pos .= v' + pgf "pathqlineto" + bracerPoint v' + +-- | Make curved path from vectors. +curveTo :: RealFloat n => V2 n -> V2 n -> V2 n -> Render n +curveTo v2 v3 v4 = ln $ do + p <- use pos + let [v2',v3',v4'] = map (p .+^) [v2,v3,v4] + pos .= v4' + pgf "pathqcurveto" + mapM_ bracerPoint [v2', v3', v4'] + +-- | Stroke the defined path using parameters from current scope. +stroke :: Render n +stroke = ln $ pgf "usepathqstroke" + +-- | Fill the defined path using parameters from current scope. +fill :: Render n +fill = ln $ pgf "usepathqfill" + +-- | Use the defined path a clip for everything that follows in the current +-- scope. Stacks. +clip :: Render n +clip = ln $ pgf "usepathqclip" + +path :: RealFloat n => Path V2 n -> Render n +path (Path trs) = do + mapM_ renderTrail trs + where + renderTrail (viewLoc -> (p, tr)) = do + moveTo p + trail tr + +trail :: RealFloat n => Trail V2 n -> Render n +trail t = withLine (render' . lineSegments) t + where + render' segs = do + mapM_ segment segs + when (isLoop t) closePath + +segment :: RealFloat n => Segment Closed V2 n -> Render n +segment (Linear (OffsetClosed v)) = lineTo v +segment (Cubic v1 v2 (OffsetClosed v3)) = curveTo v1 v2 v3 + +-- | @usePath fill stroke@ combined in one function. +usePath :: Bool -> Bool -> Render n +usePath False False = return () +usePath doFill doStroke = ln $ do + pgf "usepathq" + when doFill $ raw "fill" + when doStroke $ raw "stroke" + +-- | Uses the current path as the bounding box for whole picture. +asBoundingBox :: Render n +asBoundingBox = ln $ do + pgf "usepath" + bracers $ raw "use as bounding box" + +-- rectangleBoundingBox :: (n,n) -> Render n +-- rectangleBoundingBox xy = do +-- ln $ do +-- pgf "pathrectangle" +-- bracers $ pgf "pointorigin" +-- bracers $ tuplePoint xy +-- asBoundingBox + +-- stroke properties + +-- | Sets the line width in current scope. Must be done before stroking. +setLineWidth :: RealFloat n => n -> Render n +setLineWidth w = ln $ do + pgf "setlinewidth" + bracers $ bp w + +-- | Sets the line cap in current scope. Must be done before stroking. +setLineCap :: LineCap -> Render n +setLineCap cap = ln . pgf $ case cap of + LineCapButt -> "setbuttcap" + LineCapRound -> "setroundcap" + LineCapSquare -> "setrectcap" + +-- | Sets the line join in current scope. Must be done before stroking. +setLineJoin :: LineJoin -> Render n +setLineJoin lJoin = ln . pgf $ case lJoin of + LineJoinBevel -> "setbeveljoin" + LineJoinRound -> "setroundjoin" + LineJoinMiter -> "setmiterjoin" + +-- | Sets the miter limit in the current scope. Must be done before stroking. +setMiterLimit :: RealFloat n => n -> Render n +setMiterLimit l = do + pgf "setmiterlimit" + bracers $ bp l + +-- stroke parameters --------------------------------------------------- + +-- | Sets the dash for the current scope. Must be done before stroking. +setDash :: RealFloat n => Dashing n -> Render n +setDash (Dashing ds offs) = setDash' ds offs + +-- \pgfsetdash{{0.5cm}{0.5cm}{0.1cm}{0.2cm}}{0cm} +-- | Takes the dash distances and offset, must be done before stroking. +setDash' :: RealFloat n => [n] -> n -> Render n +setDash' ds off = ln $ do + pgf "setdash" + bracers $ mapM_ (bracers . bp) ds + bracers $ bp off + +-- | Sets the stroke colour in current scope. If colour has opacity < 1, the +-- scope opacity is set accordingly. Must be done before stroking. +setLineColor :: (RealFloat a, Color c) => c -> Render a +setLineColor c = do + defineColour "sc" r g b + ln $ pgf "setstrokecolor{sc}" + -- + when (a /= 1) $ setLineOpacity (realToFrac a) + where + (r,g,b,a) = colorToSRGBA c + +-- | Sets the stroke opacity for the current scope. Should be a value between 0 +-- and 1. Must be done before stroking. +setLineOpacity :: RealFloat n => n -> Render n +setLineOpacity a = ln $ do + pgf "setstrokeopacity" + bracers $ n a + +-- filling ------------------------------------------------------------- + +-- | Set the fill rule to winding or even-odd for current scope. Must be done +-- before filling. +setFillRule :: FillRule -> Render n +setFillRule rule = ln $ case rule of + Winding -> pgf "setnonzerorule" + EvenOdd -> pgf "seteorule" + +-- | Sets the fill colour for current scope. If an alpha colour is used, the +-- fill opacity is set accordingly. Must be done before filling. +setFillColor :: (RealFloat n, Color c) => c -> Render n +setFillColor (colorToSRGBA -> (r,g,b,a)) = do + defineColour "fc" r g b + ln $ pgf "setfillcolor{fc}" + -- + when (a /= 1) $ setFillOpacity (realToFrac a :: Double) + +-- | Sets the stroke opacity for the current scope. Should be a value between 0 +-- and 1. Must be done before stroking. +setFillOpacity :: RealFloat a => a -> Render n +setFillOpacity a = ln $ do + pgf "setfillopacity" + bracers $ n a + +-- transformations ----------------------------------------------------- + +getMatrix :: Num n => Transformation V2 n -> (n, n, n, n, n, n) +getMatrix t = (a1,a2,b1,b2,c1,c2) + where + [a1, a2, b1, b2, c1, c2] = concat $ matrixHomRep t + +-- \pgftransformcm{⟨a⟩}{⟨b⟩}{⟨c⟩}{⟨d⟩}{⟨pointa} + +-- | Applies a transformation to the current scope. This transformation only +-- effects coordinates and text, not line withs or dash spacing. (See +-- applyDeepTransform). Must be set before the path is used. +applyTransform :: RealFloat n => Transformation V2 n -> Render n +applyTransform t + | isID = return () + | shiftOnly = ln $ do + pgf "transformshift" + bracers p + | otherwise = ln $ do + pgf "transformcm" + mapM_ (bracers . n) [a, b, c, d] >> bracers p + where + (a,b,c,d,e,f) = getMatrix t + p = tuplePoint (e,f) + -- + shiftOnly = (a,b,c,d) == (1,0,0,1) + isID = shiftOnly && (e,f) == (0,0) + +-- | Resets the transform and sets it. Must be set before the path is used. +setTransform :: RealFloat n => Transformation V2 n -> Render n +setTransform t = do + pgf "settransformentries" + mapM_ (bracers . n) [a, b, c, d] >> mapM_ (bracers . bp) [e, f] + where + (a,b,c,d,e,f) = getMatrix t + +applyScale :: RealFloat n => n -> Render n +applyScale s = ln $ do + pgf "transformscale" + bracers $ n s + +resetNonTranslations :: Render n +resetNonTranslations = ln $ pgf "transformresetnontranslations" + +-- | Base transforms are applied by the document reader. +baseTransform :: RealFloat n => Transformation V2 n -> Render n +baseTransform t = ln $ do + pgf "lowlevel" + bracers $ setTransform t + +-- setShadetransform :: Transformation V2 -> Render n +-- setShadetransform (dropTransl -> t) = do +-- pgf "setadditionalshadetransform" +-- bracersBlock $ applyTransform t + +-- shading ------------------------------------------------------------- + +linearGradient :: RealFloat n => Path V2 n -> LGradient n -> Render n +linearGradient p lg = scope $ do + path p + let (stops', t) = calcLinearStops p lg + ln $ do + pgf "declarehorizontalshading" + bracers $ raw "ft" -- fill texture + bracers $ raw "100bp" -- gradient is always 100 x 100 square + bracersBlock $ colorSpec 1 stops' + clip + baseTransform t + useShading $ raw "ft" + +-- | Calculate the correct linear stops such that the path is completely +-- filled. PGF doesn't have spread methods so this has to be done +-- manually. +calcLinearStops :: RealFloat n + => Path V2 n -> LGradient n -> ([GradientStop n], T2 n) +calcLinearStops (Path []) _ = ([], mempty) +calcLinearStops pth (LGradient stops p0 p1 gt sm) + = (linearStops' x0 x1 stops sm, t <> ft) + where + -- Transform such that the transform t origin is start of the + -- gradient, transform t unitX is the end. + t = gt + -- encorperate the start and end points + <> translation (p0 ^. _Point) + <> scaling (norm (p1 .-. p0)) + <> rotationTo (dirBetween p1 p0) + + -- Use the inverse transformed path and make the pre-transformed + -- gradient fit to it. Then when we transform the gradient we know + -- it'll fit the path. + p' = transform (inv t) pth + Just (x0,x1) = extentX p' + Just (y0,y1) = extentY p' + + -- Final transform to fit the gradient to the path. The origin on + -- the gradient is its centre so we translate by - V2 50 50 to get + -- to the lower corner (because of this we set the size of the + -- gradient to always be 100 x 100 for simplicity). Then scales up + -- the gradient to cover the path and moves it into position. + ft = translation (V2 x0 y0) <> scalingV ((*0.01) . abs <$> V2 (x0 - x1) (y0 - y1)) <> translation 50 + +scalingV :: (Additive v, Fractional n) => v n -> Transformation v n +scalingV v = fromSymmetric $ liftU2 (*) v <-> liftU2 (flip (/)) v + +useShading :: Render n -> Render n +useShading nm = ln $ do + pgf "useshading" + bracers nm + + +_translation :: Lens' (Transformation v n) (v n) +_translation f (Transformation a b v) = f v <&> \v' -> Transformation a b v' + +linearStops' :: RealFloat n + => n -> n -> [GradientStop n] -> SpreadMethod -> [GradientStop n] +linearStops' x0 x1 stops sm = + GradientStop c1' 0 : filter (inRange . view stopFraction) stops' ++ [GradientStop c2' 100] + where + stops' = case sm of + GradPad -> over (each . stopFraction) normalise stops + GradRepeat -> flip F.foldMap [i0 .. i1] $ \i -> + increaseFirst $ + over (each . stopFraction) + (normalise . (+ fromIntegral i)) + stops + GradReflect -> flip F.foldMap [i0 .. i1] $ \i -> + over (each . stopFraction) + (normalise . (+ fromIntegral i)) + (reverseOdd i stops) + + -- for repeat it sometimes complains if two are exactly the same so + -- increase the first by a little + increaseFirst = over (_head . stopFraction) (+0.001) + reverseOdd i + | odd i = reverse . over (each . stopFraction) (1 -) + | otherwise = id + i0 = floor x0 :: Int + i1 = ceiling x1 + c1' = SomeColor $ colourInterp stops' 0 + c2' = SomeColor $ colourInterp stops' 100 + inRange x = x > 0 && x < 100 + normalise x = 100 * (x - x0) / (x1 - x0) + +colourInterp :: RealFloat n => [GradientStop n] -> n -> AlphaColour Double +colourInterp cs0 x = go cs0 + where + go (GradientStop c1 a : c@(GradientStop c2 b) : cs) + | x <= a = toAlphaColour c1 + | x > a && x < b = blend y (toAlphaColour c2) (toAlphaColour c1) + | otherwise = go (c : cs) + where + y = realToFrac $ (x - a) / (b - a) + go [GradientStop c2 _] = toAlphaColour c2 + go _ = transparent + +radialGradient :: RealFloat n => Path V2 n -> RGradient n -> Render n +radialGradient p rg = scope $ do + path p + let (stops', t, p0) = calcRadialStops p rg + ln $ do + pgf "declareradialshading" + bracers $ raw "ft" + bracers $ point p0 + bracersBlock $ colorSpec 1 stops' + clip + baseTransform t + useShading $ raw "ft" + +-- | Calculate the correct linear stops such that the path is completely +-- filled. PGF doesn't have spread methods so this has to be done +-- manually. +calcRadialStops :: RealFloat n + => Path V2 n -> RGradient n -> ([GradientStop n], T2 n, P2 n) +calcRadialStops (Path []) _ = ([], mempty, origin) +calcRadialStops pth (RGradient stops p0 r0 p1 r1 gt _sm) + = (stops', t <> ft, P cv) + where + cv = tp0 .-. tp1 + tp0 = papply gt p0 + tp1 = papply gt p1 + -- Transform such that the transform t origin is start of the + -- gradient, transform t unitX is the end. + t = gt + <> translation (p1 ^. _Point) + <> scaling r1 + + -- Similar to linear gradients but not so precise, d is a (bad and + -- probably incorrect) lower bound for the required radius of the + -- circle to cover the path. + p' = transform (inv t) pth + Just (x0,x1) = extentX p' + Just (y0,y1) = extentY p' + d = 2 * max (max (abs $ x0 - x1) (abs $ y0 - y1)) (lstop ^. stopFraction) + + -- Adjust for gradient size having radius 100 + ft = scaling 0.01 + + -- Stops are scaled to start at r0 and end at r1. The gradient is + -- extended to d to try to cover the path. + -- + -- The problem is extending the size of the gradient in this way + -- affects how the gradient scales if it is off-centre. This needs + -- to be fixed. + -- + -- Only the GradPad spread method is supported for now. + stops' = head stops : over (each . stopFraction) refrac stops ++ [lstop & stopFraction .~ 100*d] + refrac x = 100 * ((r0 + x * (r1 - r0)) / r1) -- start at r0, end at r1 + lstop = last stops + +-- Dirty adjustments for spread methods (PGF doesn't seem to have them). +-- adjustStops :: RealFloat n => [GradientStop n] -> SpreadMethod -> [GradientStop n] +-- adjustStops stops method = +-- case method of +-- GradPad -> (stopFraction .~ 0) (head stops) : map (stopFraction +~ 1) stops +-- ++ [(stopFraction +~ 2) (last stops)] +-- GradReflect -> correct . concat . replicate 10 +-- $ [stops, zipWith (\a b -> a & (stopColor .§ b)) stops (reverse stops)] +-- GradRepeat -> correct . replicate 10 $ stops + -- where + -- correct = ifoldMap (\i -> map (stopFraction +~ (lastStop * fromIntegral i)) ) + -- lastStop = last stops ^. stopFraction + +-- (.§) :: Lens s t b b -> s -> s -> t +-- (.§) l a b = b & l #~ (a ^# l) +-- {-# INLINE (.§) #-} + +colorSpec :: RealFloat n => n -> [GradientStop n] -> Render n +colorSpec d = mapM_ ln + . combinePairs + . intersperse (rawChar ';') + . map mkColor + where + mkColor (GradientStop c sf) = do + raw "rgb" + parens $ bp (d*sf) + raw "=" + parensColor c + +combinePairs :: Monad m => [m a] -> [m a] +combinePairs (x1:x2:xs) = (x1 >> x2) : combinePairs xs +combinePairs xs = xs + +shadePath :: RealFloat n => Angle n -> Render n -> Render n +shadePath (view deg -> θ) name = ln $ do + pgf "shadepath" + bracers name + bracers $ n θ + +-- external images ----------------------------------------------------- + +-- \pgfimage[⟨options ⟩]{⟨filename ⟩} + +-- | Images are wraped in a \pgftext. +image :: RealFloat n => DImage n External -> Render n +image (DImage (ImageRef ref) w h t2) = scope $ do + applyTransform t2 + ln $ do + pgf "text" + bracers $ do + pgf "image" + brackets $ do + raw "width=" >> bp (fromIntegral w :: Double) + rawChar ',' + raw "height=" >> bp (fromIntegral h :: Double) + bracers $ rawString ref + +-- embedded images ----------------------------------------------------- + +embeddedImage :: RealFloat n => DImage n Embedded -> Render n +embeddedImage (DImage (ImageRaster (ImageRGB8 img)) w h t) = + embeddedImage' (hexImage img) w h t + -- TODO: Support more formats (like grey scale and alpha channels) +embeddedImage _ = error "Unsupported embedded image. Only ImageRGB8 is currently supported." + +-- | Convert an 'Image' to a zlib compressed lazy 'ByteString' of the +-- raw image data. This is a suitable format for an embedded PDF image +-- stream. +hexImage :: Image PixelRGB8 -> LB.ByteString +hexImage (imageData -> v) = compress $ LB.fromStrict bs + where + bs = fromForeignPtr p i nn + (p, i, nn) = S.unsafeToForeignPtr v + +embeddedImage' :: RealFloat n => LB.ByteString -> Int -> Int -> T2 n -> Render n +embeddedImage' img w h t = scope $ do + baseTransform t + ln $ raw "\\immediate\\pdfliteral{" + rawLn "q" -- save state + + -- Scale the image to it's actual size and translate so the origin is + -- at the centre. + rawLn $ s w <> " 0 0 " <> s h <> " -" <> half w <> " -" <> half h <> " cm" + rawLn "BI" -- begin image + rawLn $ "/W " <> s w -- width in pixels + rawLn $ "/H " <> s h -- height in pixels + rawLn "/CS /RGB" -- RGB colour space + rawLn "/BPC 8" -- 8 bits per component + + -- Filters for the encoded image: + -- ASCIIHexDecode -- decode from hexadecimal to binary + -- FlateDecode -- decompress using zlib deflate compression + rawLn "/F [/AHx /Fl]" + + -- We use hex format for the image data so tex can output it without + -- any problems. Base85 might be possible and would be 2-3x smaller + -- but there's some problem chars tex complains about. Base64 would + -- be ideal but the pdf spec doesn't seem to support it. + -- + -- This is an inline image which is only really suitable for small + -- images. An XObject might be more appropriate. See + -- http://partners.adobe.com/public/developer/en/pdf/PDFReference.pdf + -- for more information. + rawLn "ID" -- image data + rawLn $ hexChunk img <> char8 '>' + rawLn "EI" -- end image + rawLn "Q" -- restore state + rawLn "}" + where + rawLn r = raw r >> rawChar '\n' + s = intDec + half x = s (x `div` 2) <> if odd x then ".5" else mempty + +-- | Insert hex encode and add a newline every 80 chars. This is useful for +-- readable output and stopping tex from choking when streaming. Note +-- that new-lines and spaces are ignored with the hex decode filter. +hexChunk :: LB.ByteString -> Builder +hexChunk (LB.splitAt 40 -> (a,b)) + | LB.null b = lazyByteStringHex a + | otherwise = lazyByteStringHex a <> char8 '\n' <> hexChunk b + +-- text ---------------------------------------------------------------- + +renderText :: [Render n] -> Render n -> Render n +renderText ops txt = ln $ do + pgf "text" + brackets . commaIntersperce $ ops + bracers txt + +-- | Returns a list of values to be put in square brackets like +-- @\pgftext[left,top]{txt}@. +setTextAlign :: RealFloat n => TextAlignment n -> [Render n] +setTextAlign a = case a of + BaselineText -> [raw "base", raw "left"] + BoxAlignedText xt yt -> catMaybes [xt', yt'] + where + xt' | xt > 0.75 = Just $ raw "right" + | xt < 0.25 = Just $ raw "left" + | otherwise = Nothing + yt' | yt > 0.75 = Just $ raw "top" + | yt < 0.25 = Just $ raw "bottom" + | otherwise = Nothing + +setTextRotation :: RealFloat n => Angle n -> [Render n] +setTextRotation a = case a^.deg of + 0 -> [] + θ -> [raw "rotate=" >> n θ] + +-- | Set the font weight by rendering @\bf @. Nothing is done for normal +-- weight. +setFontWeight :: FontWeight -> Render n +setFontWeight FontWeightNormal = return () +setFontWeight FontWeightBold = raw "\\bf " + +-- | Set the font slant by rendering @\bf @. Nothing is done for normal weight. +setFontSlant :: FontSlant -> Render n +setFontSlant FontSlantNormal = return () +setFontSlant FontSlantItalic = raw "\\it " +setFontSlant FontSlantOblique = raw "\\sl "