{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Diagrams.Backend.Cairo.CmdLine
(
mainWith
, defaultMain
, multiMain
, animMain
, gifMain
, GifOpts(..)
, gifRender
, Cairo
, B
) where
import Codec.Picture
import Codec.Picture.ColorQuant (defaultPaletteOptions)
import qualified Data.ByteString.Lazy as L (ByteString, writeFile)
import Data.Vector.Storable (unsafeFromForeignPtr0)
import Data.Word (Word8)
import Options.Applicative
import Diagrams.Backend.Cairo
import Diagrams.Backend.Cairo.Ptr (renderForeignPtrOpaque)
import Diagrams.Backend.CmdLine
import Diagrams.Prelude hiding (height, interval,
option, output, width)
#if __GLASGOW_HASKELL__ < 702 || __GLASGOW_HASKELL__ >= 704
import Diagrams.Backend.Cairo.Internal
#endif
#if __GLASGOW_HASKELL__ < 710
import Foreign.ForeignPtr.Safe (ForeignPtr)
#else
import Foreign.ForeignPtr (ForeignPtr)
#endif
import Data.List.Split
data GifOpts = GifOpts { GifOpts -> Bool
_dither :: Bool
, GifOpts -> Bool
_noLooping :: Bool
, GifOpts -> Maybe Int
_loopRepeat :: Maybe Int}
makeLenses ''GifOpts
defaultMain :: QDiagram Cairo V2 Double Any -> IO ()
defaultMain :: QDiagram Cairo V2 Double Any -> IO ()
defaultMain = QDiagram Cairo V2 Double Any -> IO ()
forall d. (Mainable d, Parseable (MainOpts d)) => d -> IO ()
mainWith
instance Mainable (QDiagram Cairo V2 Double Any) where
type MainOpts (QDiagram Cairo V2 Double Any) = (DiagramOpts, DiagramLoopOpts)
mainRender :: MainOpts (QDiagram Cairo V2 Double Any)
-> QDiagram Cairo V2 Double Any -> IO ()
mainRender (DiagramOpts
opts, DiagramLoopOpts
l) QDiagram Cairo V2 Double Any
d = DiagramOpts -> QDiagram Cairo V2 Double Any -> IO ()
chooseRender DiagramOpts
opts QDiagram Cairo V2 Double Any
d IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DiagramLoopOpts -> IO ()
defaultLoopRender DiagramLoopOpts
l
chooseRender :: DiagramOpts -> QDiagram Cairo V2 Double Any -> IO ()
chooseRender :: DiagramOpts -> QDiagram Cairo V2 Double Any -> IO ()
chooseRender DiagramOpts
opts QDiagram Cairo V2 Double Any
d =
case String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"." (DiagramOpts
opts DiagramOpts -> Getting String DiagramOpts String -> String
forall s a. s -> Getting a s a -> a
^. Getting String DiagramOpts String
Lens' DiagramOpts String
output) of
[String
""] -> String -> IO ()
putStrLn String
"No output file given."
[String]
ps | [String] -> String
forall a. HasCallStack => [a] -> a
last [String]
ps String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"png", String
"ps", String
"pdf", String
"svg"] -> do
let outTy :: OutputType
outTy = case [String] -> String
forall a. HasCallStack => [a] -> a
last [String]
ps of
String
"png" -> OutputType
PNG
String
"ps" -> OutputType
PS
String
"pdf" -> OutputType
PDF
String
"svg" -> OutputType
SVG
String
_ -> OutputType
PDF
(IO (), Render ()) -> IO ()
forall a b. (a, b) -> a
fst ((IO (), Render ()) -> IO ()) -> (IO (), Render ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Cairo
-> Options Cairo V2 Double
-> QDiagram Cairo V2 Double Any
-> Result Cairo V2 Double
forall b (v :: * -> *) n m.
(Backend b v n, HasLinearMap v, Metric v, Typeable n,
OrderedField n, Monoid' m) =>
b -> Options b v n -> QDiagram b v n m -> Result b v n
renderDia
Cairo
Cairo
( String
-> SizeSpec V2 Double
-> OutputType
-> Bool
-> Options Cairo V2 Double
CairoOptions
(DiagramOpts
optsDiagramOpts -> Getting String DiagramOpts String -> String
forall s a. s -> Getting a s a -> a
^.Getting String DiagramOpts String
Lens' DiagramOpts String
output)
(Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> SizeSpec V2 Int -> SizeSpec V2 Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int -> Maybe Int -> SizeSpec V2 Int
forall n. Num n => Maybe n -> Maybe n -> SizeSpec V2 n
mkSizeSpec2D
(DiagramOpts
opts DiagramOpts
-> Getting (Maybe Int) DiagramOpts (Maybe Int) -> Maybe Int
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Int) DiagramOpts (Maybe Int)
Lens' DiagramOpts (Maybe Int)
width )
(DiagramOpts
opts DiagramOpts
-> Getting (Maybe Int) DiagramOpts (Maybe Int) -> Maybe Int
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Int) DiagramOpts (Maybe Int)
Lens' DiagramOpts (Maybe Int)
height)
)
OutputType
outTy
Bool
False
)
QDiagram Cairo V2 Double Any
d
| Bool
otherwise -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Unknown file type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. HasCallStack => [a] -> a
last [String]
ps
multiMain :: [(String, QDiagram Cairo V2 Double Any)] -> IO ()
multiMain :: [(String, QDiagram Cairo V2 Double Any)] -> IO ()
multiMain = [(String, QDiagram Cairo V2 Double Any)] -> IO ()
forall d. (Mainable d, Parseable (MainOpts d)) => d -> IO ()
mainWith
instance Mainable [(String, QDiagram Cairo V2 Double Any)] where
type MainOpts [(String, QDiagram Cairo V2 Double Any)]
= (MainOpts (QDiagram Cairo V2 Double Any), DiagramMultiOpts)
mainRender :: MainOpts [(String, QDiagram Cairo V2 Double Any)]
-> [(String, QDiagram Cairo V2 Double Any)] -> IO ()
mainRender = (MainOpts (QDiagram Cairo V2 Double Any), DiagramMultiOpts)
-> [(String, QDiagram Cairo V2 Double Any)] -> IO ()
MainOpts [(String, QDiagram Cairo V2 Double Any)]
-> [(String, QDiagram Cairo V2 Double Any)] -> IO ()
forall d.
Mainable d =>
(MainOpts d, DiagramMultiOpts) -> [(String, d)] -> IO ()
defaultMultiMainRender
animMain :: Animation Cairo V2 Double -> IO ()
animMain :: Animation Cairo V2 Double -> IO ()
animMain = Animation Cairo V2 Double -> IO ()
forall d. (Mainable d, Parseable (MainOpts d)) => d -> IO ()
mainWith
instance Mainable (Animation Cairo V2 Double) where
type MainOpts (Animation Cairo V2 Double) = ((DiagramOpts, DiagramAnimOpts), DiagramLoopOpts)
mainRender :: MainOpts (Animation Cairo V2 Double)
-> Animation Cairo V2 Double -> IO ()
mainRender ((DiagramOpts, DiagramAnimOpts)
opts, DiagramLoopOpts
l) Animation Cairo V2 Double
d = (DiagramOpts -> QDiagram Cairo V2 Double Any -> IO ())
-> Lens' DiagramOpts String
-> (DiagramOpts, DiagramAnimOpts)
-> Animation Cairo V2 Double
-> IO ()
forall opts b (v :: * -> *) n.
(opts -> QDiagram b v n Any -> IO ())
-> Lens' opts String
-> (opts, DiagramAnimOpts)
-> Animation b v n
-> IO ()
defaultAnimMainRender DiagramOpts -> QDiagram Cairo V2 Double Any -> IO ()
chooseRender (String -> f String) -> DiagramOpts -> f DiagramOpts
Lens' DiagramOpts String
output (DiagramOpts, DiagramAnimOpts)
opts Animation Cairo V2 Double
d IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DiagramLoopOpts -> IO ()
defaultLoopRender DiagramLoopOpts
l
gifMain :: [(QDiagram Cairo V2 Double Any, GifDelay)] -> IO ()
gifMain :: [(QDiagram Cairo V2 Double Any, Int)] -> IO ()
gifMain = [(QDiagram Cairo V2 Double Any, Int)] -> IO ()
forall d. (Mainable d, Parseable (MainOpts d)) => d -> IO ()
mainWith
instance Parseable GifOpts where
parser :: Parser GifOpts
parser = Bool -> Bool -> Maybe Int -> GifOpts
GifOpts (Bool -> Bool -> Maybe Int -> GifOpts)
-> Parser Bool -> Parser (Bool -> Maybe Int -> GifOpts)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod FlagFields Bool -> Parser Bool
switch
( String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"dither"
Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Turn on dithering." )
Parser (Bool -> Maybe Int -> GifOpts)
-> Parser Bool -> Parser (Maybe Int -> GifOpts)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch
( String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"looping-off"
Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Turn looping off" )
Parser (Maybe Int -> GifOpts)
-> Parser (Maybe Int) -> Parser GifOpts
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ( Parser Int -> Parser (Maybe Int)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser Int -> Parser (Maybe Int))
-> (Mod OptionFields Int -> Parser Int)
-> Mod OptionFields Int
-> Parser (Maybe Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadM Int -> Mod OptionFields Int -> Parser Int
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Int
forall a. Read a => ReadM a
auto )
( String -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"loop-repeat"
Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Int
forall (f :: * -> *) a. String -> Mod f a
help String
"Number of times to repeat" )
instance Mainable [(QDiagram Cairo V2 Double Any, GifDelay)] where
type MainOpts [(QDiagram Cairo V2 Double Any, GifDelay)] = (DiagramOpts, GifOpts)
mainRender :: MainOpts [(QDiagram Cairo V2 Double Any, Int)]
-> [(QDiagram Cairo V2 Double Any, Int)] -> IO ()
mainRender (DiagramOpts
dOpts, GifOpts
gOpts) [(QDiagram Cairo V2 Double Any, Int)]
ds = (DiagramOpts, GifOpts)
-> [(QDiagram Cairo V2 Double Any, Int)] -> IO ()
gifRender (DiagramOpts
dOpts, GifOpts
gOpts) [(QDiagram Cairo V2 Double Any, Int)]
ds
imageRGB8FromUnsafePtr :: Int -> Int -> ForeignPtr Word8 -> Image PixelRGB8
imageRGB8FromUnsafePtr :: Int -> Int -> ForeignPtr Word8 -> Image PixelRGB8
imageRGB8FromUnsafePtr Int
w Int
h ForeignPtr Word8
ptr = (PixelRGBA8 -> PixelRGB8) -> Image PixelRGBA8 -> Image PixelRGB8
forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap PixelRGBA8 -> PixelRGB8
f Image PixelRGBA8
cImg
where
f :: PixelRGBA8 -> PixelRGB8
f (PixelRGBA8 Word8
b Word8
g Word8
r Word8
_) = Word8 -> Word8 -> Word8 -> PixelRGB8
PixelRGB8 Word8
r Word8
g Word8
b
cImg :: Image PixelRGBA8
cImg = Int
-> Int
-> Vector (PixelBaseComponent PixelRGBA8)
-> Image PixelRGBA8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h (Vector (PixelBaseComponent PixelRGBA8) -> Image PixelRGBA8)
-> Vector (PixelBaseComponent PixelRGBA8) -> Image PixelRGBA8
forall a b. (a -> b) -> a -> b
$ ForeignPtr Word8 -> Int -> Vector Word8
forall a. ForeignPtr a -> Int -> Vector a
unsafeFromForeignPtr0 ForeignPtr Word8
ptr (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4)
encodeGifAnimation' :: [GifDelay] -> GifLooping -> Bool
-> [Image PixelRGB8] -> Either String L.ByteString
encodeGifAnimation' :: [Int]
-> GifLooping
-> Bool
-> [Image PixelRGB8]
-> Either String ByteString
encodeGifAnimation' [Int]
delays GifLooping
looping Bool
dithering [Image PixelRGB8]
lst =
GifLooping
-> [(Image PixelRGB8, Int, Image Word8)]
-> Either String ByteString
encodeGifImages GifLooping
looping [(Image PixelRGB8, Int, Image Word8)]
triples
where
triples :: [(Image PixelRGB8, Int, Image Word8)]
triples = ((Image PixelRGB8, Image Word8)
-> Int -> (Image PixelRGB8, Int, Image Word8))
-> [(Image PixelRGB8, Image Word8)]
-> [Int]
-> [(Image PixelRGB8, Int, Image Word8)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(Image PixelRGB8
x,Image Word8
z) Int
y -> (Image PixelRGB8
x, Int
y, Image Word8
z)) [(Image PixelRGB8, Image Word8)]
doubles [Int]
delays
doubles :: [(Image PixelRGB8, Image Word8)]
doubles = [(Image PixelRGB8
pal, Image Word8
img)
| (Image Word8
img, Image PixelRGB8
pal) <- PaletteOptions -> Image PixelRGB8 -> (Image Word8, Image PixelRGB8)
palettize
PaletteOptions
defaultPaletteOptions {enableImageDithering=dithering} (Image PixelRGB8 -> (Image Word8, Image PixelRGB8))
-> [Image PixelRGB8] -> [(Image Word8, Image PixelRGB8)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Image PixelRGB8]
lst]
writeGifAnimation' :: FilePath -> [GifDelay] -> GifLooping -> Bool
-> [Image PixelRGB8] -> Either String (IO ())
writeGifAnimation' :: String
-> [Int]
-> GifLooping
-> Bool
-> [Image PixelRGB8]
-> Either String (IO ())
writeGifAnimation' String
path [Int]
delays GifLooping
looping Bool
dithering [Image PixelRGB8]
img =
String -> ByteString -> IO ()
L.writeFile String
path (ByteString -> IO ())
-> Either String ByteString -> Either String (IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
-> GifLooping
-> Bool
-> [Image PixelRGB8]
-> Either String ByteString
encodeGifAnimation' [Int]
delays GifLooping
looping Bool
dithering [Image PixelRGB8]
img
scaleInt :: Int -> Double -> Double -> Int
scaleInt :: Int -> Double -> Double -> Int
scaleInt Int
i Double
num Double
denom
| Double
num Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0 Bool -> Bool -> Bool
|| Double
denom Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0 = Int
i
| Bool
otherwise = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
num Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
denom Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)
gifRender :: (DiagramOpts, GifOpts) -> [(QDiagram Cairo V2 Double Any, GifDelay)] -> IO ()
gifRender :: (DiagramOpts, GifOpts)
-> [(QDiagram Cairo V2 Double Any, Int)] -> IO ()
gifRender (DiagramOpts
dOpts, GifOpts
gOpts) [(QDiagram Cairo V2 Double Any, Int)]
lst =
case String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"." (DiagramOpts
dOptsDiagramOpts -> Getting String DiagramOpts String -> String
forall s a. s -> Getting a s a -> a
^.Getting String DiagramOpts String
Lens' DiagramOpts String
output) of
[String
""] -> String -> IO ()
putStrLn String
"No output file given"
[String]
ps | [String] -> String
forall a. HasCallStack => [a] -> a
last [String]
ps String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"gif" -> do
let (Int
w, Int
h) = case (DiagramOpts
dOptsDiagramOpts
-> Getting (Maybe Int) DiagramOpts (Maybe Int) -> Maybe Int
forall s a. s -> Getting a s a -> a
^.Getting (Maybe Int) DiagramOpts (Maybe Int)
Lens' DiagramOpts (Maybe Int)
width, DiagramOpts
dOptsDiagramOpts
-> Getting (Maybe Int) DiagramOpts (Maybe Int) -> Maybe Int
forall s a. s -> Getting a s a -> a
^.Getting (Maybe Int) DiagramOpts (Maybe Int)
Lens' DiagramOpts (Maybe Int)
height) of
(Just Int
w', Just Int
h') -> (Int
w', Int
h')
(Just Int
w', Maybe Int
Nothing) -> (Int
w', Int -> Double -> Double -> Int
scaleInt Int
w' Double
diaHeight Double
diaWidth)
(Maybe Int
Nothing, Just Int
h') -> (Int -> Double -> Double -> Int
scaleInt Int
h' Double
diaWidth Double
diaHeight, Int
h')
(Maybe Int
Nothing, Maybe Int
Nothing) -> (Int
100, Int
100)
looping :: GifLooping
looping = if GifOpts
gOptsGifOpts -> Getting Bool GifOpts Bool -> Bool
forall s a. s -> Getting a s a -> a
^.Getting Bool GifOpts Bool
Lens' GifOpts Bool
noLooping
then GifLooping
LoopingNever
else case GifOpts
gOptsGifOpts -> Getting (Maybe Int) GifOpts (Maybe Int) -> Maybe Int
forall s a. s -> Getting a s a -> a
^.Getting (Maybe Int) GifOpts (Maybe Int)
Lens' GifOpts (Maybe Int)
loopRepeat of
Maybe Int
Nothing -> GifLooping
LoopingForever
Just Int
n -> Word16 -> GifLooping
LoopingRepeat (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
dias :: [QDiagram Cairo V2 Double Any]
dias = ((QDiagram Cairo V2 Double Any, Int)
-> QDiagram Cairo V2 Double Any)
-> [(QDiagram Cairo V2 Double Any, Int)]
-> [QDiagram Cairo V2 Double Any]
forall a b. (a -> b) -> [a] -> [b]
map (QDiagram Cairo V2 Double Any, Int) -> QDiagram Cairo V2 Double Any
forall a b. (a, b) -> a
fst [(QDiagram Cairo V2 Double Any, Int)]
lst
delays :: [Int]
delays = ((QDiagram Cairo V2 Double Any, Int) -> Int)
-> [(QDiagram Cairo V2 Double Any, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (QDiagram Cairo V2 Double Any, Int) -> Int
forall a b. (a, b) -> b
snd [(QDiagram Cairo V2 Double Any, Int)]
lst
V2 Double
diaWidth Double
diaHeight = QDiagram Cairo V2 Double Any -> V2 Double
forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, Enveloped a, HasBasis v) =>
a -> v n
size ([QDiagram Cairo V2 Double Any] -> QDiagram Cairo V2 Double Any
forall a. HasCallStack => [a] -> a
head [QDiagram Cairo V2 Double Any]
dias)
[ForeignPtr Word8]
fPtrs <- (QDiagram Cairo V2 Double Any -> IO (ForeignPtr Word8))
-> [QDiagram Cairo V2 Double Any] -> IO [ForeignPtr Word8]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Int -> Int -> QDiagram Cairo V2 Double Any -> IO (ForeignPtr Word8)
renderForeignPtrOpaque Int
w Int
h) [QDiagram Cairo V2 Double Any]
dias
let imageRGB8s :: [Image PixelRGB8]
imageRGB8s = (ForeignPtr Word8 -> Image PixelRGB8)
-> [ForeignPtr Word8] -> [Image PixelRGB8]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> ForeignPtr Word8 -> Image PixelRGB8
imageRGB8FromUnsafePtr Int
w Int
h) [ForeignPtr Word8]
fPtrs
result :: Either String (IO ())
result = String
-> [Int]
-> GifLooping
-> Bool
-> [Image PixelRGB8]
-> Either String (IO ())
writeGifAnimation'
(DiagramOpts
dOptsDiagramOpts -> Getting String DiagramOpts String -> String
forall s a. s -> Getting a s a -> a
^.Getting String DiagramOpts String
Lens' DiagramOpts String
output)
[Int]
delays
GifLooping
looping
(GifOpts
gOptsGifOpts -> Getting Bool GifOpts Bool -> Bool
forall s a. s -> Getting a s a -> a
^.Getting Bool GifOpts Bool
Lens' GifOpts Bool
dither)
[Image PixelRGB8]
imageRGB8s
case Either String (IO ())
result of
Left String
s -> String -> IO ()
putStrLn String
s
Right IO ()
io -> IO ()
io
| Bool
otherwise -> String -> IO ()
putStrLn String
"File name must end with .gif"