Gif.hs

{-# Language NoMonomorphismRestriction #-}

module Export.Gif where

import Parse
import Config
import Terminal.Game

import Control.Exception
import System.Process
import System.FilePath
import System.Exit
import System.IO.Temp

import qualified System.Process.Internals as SPI
import qualified Data.Foldable as F


writeGif :: Integer -> FilePath -> (Colour, Colour) ->
            Animation -> IO (Maybe ExpExc)
writeGif fps fp clp fs = catcher
    where
          gifProcess :: FilePath -> [String] -> CreateProcess
          gifProcess d fas = shell . unwords $
                               ["convert -loop 0"] ++
                               fas                 ++
                               [fp]

          makeGif d = mapM (renderFrame d fps clp) (getFrames fs) >>= \fas ->
                      execProcess (gifProcess d fas)

          catcher :: IO (Maybe ExpExc)
          catcher = catch (withSystemTempDirectory "animascii" makeGif >>
                           return Nothing)
                          (return . Just)


------------
-- RENDER --
------------

-- will create an image in temporary folder and return the appropriate
-- argument for imagemagick's "convert" (e.g. -delay 300 10.png)
renderFrame :: FilePath -> Integer -> (Colour, Colour) ->
               Frame Plane Integer -> IO String
renderFrame d fps (fgc, bgc) (i, p) =
            writeTempFile d "frame.png" ""    >>= \tf ->
            let dtf = d </> tf                in
            execProcess (frameProcess dtf)    >>
            return (toReturn dtf)
    where
          frameProcess :: FilePath -> CreateProcess
          frameProcess f = shell . unwords $
                             ["convert",
                              "-background " ++ bgc,
                              "-fill " ++ fgc,
                              "-font Courier",
                              "-pointsize 18",
                              "label:" ++ pp,
                              f]

          pp = let x = init $ paperPlane p
                   y = case x of
                         (' ':xs) -> '\\' : imEscape x -- needed by imagemagick
                         as       -> imEscape as
               in SPI.translate y



          toReturn n = unwords ["-delay " ++ show i',
                                n]

          i' = round $ (fromIntegral i) * 100 / fromIntegral fps


-----------------
-- ANCILLARIES --
-----------------

-- exception type

type ErrMess = String
data ExpExc = ExpExc ExitCode ErrMess
            deriving (Show, Eq)
instance Exception ExpExc

makeExc :: ExitCode -> ErrMess -> ExpExc
makeExc ec em = ExpExc ec em

-- catch/throw, since we're using an external program
execProcess :: CreateProcess -> IO ()
execProcess cp = readCreateProcessWithExitCode cp "" >>= \(ec, so, se) ->
                 if ec == ExitSuccess
                   then return ()
                   else throwIO (makeExc ec se)

-- see https://github.com/haskell/process/issues/120
imEscape :: String -> String
imEscape cs = F.foldMap f cs
    where
          f '\\' = "\\\\"
          f c    = [c]