TikZBase.hs

{-# 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 ++ ")"