TileMain.hs

-- SVGutils
-- Copyright (c) 2010, Neil Brown
--
-- 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 Neil Brown 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.

import Control.Applicative ((<$>), (<*>))
import Control.Exception (IOException, try)
import Control.Monad (zipWithM_)
import Data.Either (lefts, rights)
import Data.List (minimumBy, sortBy)
import Data.Ord (comparing)
import Data.SVG.Internal.Fail
import Data.SVG.Paper
import Data.SVG.SVG
import Data.SVG.Tile
import System.Console.GetOpt
import System.Environment (getArgs)
import System.FilePath ((<.>), takeBaseName)
import System.IO (hPutStrLn, stderr)
import System.Exit (exitWith, ExitCode(..))

data Raw a b = Raw { r :: a }
data Processed a b = Processed { p :: b }

data Settings f = Settings
  { tryPaperRotate :: Bool
  , trySortingBySize :: Bool
  , help :: Bool
  , ignoreConflictingNamespaces :: Bool
  , dpi :: f String DPI
  , paperSize :: f String Size
  , margin :: f String MM
  , gap :: f String MM
  }

processSettings :: Settings Raw -> Either String (Settings Processed)
processSettings (Settings rt s h i d ps m g)
  = runFail $ do
      d' <- maybeFail ("Could not parse DPI: " ++ r d) (DPI <$> maybeRead (r d)) 
      Settings rt s h i (Processed d')
       <$> proc ("Unknown paper size: " ++ r ps) (parsePaperSize (r ps))
       <*> proc ("Could not parse margin: " ++ r m) (parseCoord d' (r m))
       <*> proc ("Could not parse gap: " ++ r g) (parseCoord d' (r g))
  where
    proc u x = Processed <$> maybeFail u x

defaultSettings :: Settings Raw
defaultSettings = Settings False False False False (Raw "90") (Raw "a4") (Raw "20mm") (Raw "0mm")

options :: [OptDescr (Settings Raw -> Settings Raw)]
options =
 [Option "h" ["help"] (NoArg $ \s -> s {help = True}) "This help"
 ,Option "d" ["dpi"] (ReqArg (\d s -> s {dpi = Raw d}) "DPI")
   "Sets the DPI (Dots-Per-Inch) assumed; default is 90"
 ,Option "r" ["rotate"] (NoArg $ \s -> s {tryPaperRotate = True})
   "Try rotating the paper to see if less pages are needed"
 ,Option "s" ["sort"] (NoArg $ \s -> s {trySortingBySize = True})
   "Try sorting the items by height to see if less pages are needed"
 ,Option "z" ["size"] (ReqArg (\z s -> s {paperSize = Raw z}) "SIZE")
   "Paper size (e.g. \"a4\", \"letter\", \"10cm*10cm\"); default is a4"
 ,Option "m" ["margin"] (ReqArg (\m s -> s {margin = Raw m}) "MARGIN")
   "Margin (e.g. 3cm), default is 20mm"
 ,Option "g" ["gap"] (ReqArg (\g s -> s {gap = Raw g}) "GAP")
   "Gap between tiled items (e.g. 1cm), default is 0cm"
 ,Option "i" ["ignore-ns-conflicts"] (NoArg $ \s -> s {ignoreConflictingNamespaces = True})
   "Ignore conflicting namespaces in SVG files"
 ]

processArgs :: IO (Settings Processed, [String])
processArgs = do (fs, files, errs) <- getOpt Permute options <$> getArgs
                 if null errs
                   then let s = foldr (.) id fs $ defaultSettings
                        in if help s || null files
                             then do putStrLn $ usageInfo "SVGtile <file1.svg> <file2.svg> ... <fileN.svg>" options
                                     exitWith (if help s then ExitSuccess else ExitFailure 1)
                             else case processSettings s of
                               Left err -> quitWith err
                               Right s' -> return (s', files)
                   else quitWith (unlines errs)
                   
makeParams :: Settings Processed -> [(String, SVG, Maybe SVG)] -> [(TileSettings, [TileItem])]
makeParams s svgs
  = [ (TileSettings paper (p $ margin s) (p $ gap s) (ignoreConflictingNamespaces s), map (uncurry3 TileItem) items)
    | paper <- (p $ paperSize s) : [rotate (p $ paperSize s) | tryPaperRotate s]
    , items <- svgs : [map snd $ sortBy cmp svgsWithSize
                      | cmp <- [comparing height, flip (comparing height)]
                      , trySortingBySize s]
    ]
  where
    rotate (Size w h) = Size h w

    uncurry3 f (x, y, z) = f x y z

    svgsWithSize :: [(Maybe Size, (String, SVG, Maybe SVG))]
    svgsWithSize = [(getSVGSize (p $ dpi s) front, (l, front, back)) | (l, front, back) <- svgs]

    height :: (Maybe Size, a) -> Maybe MM
    height = fmap mmHeight . fst

output :: [(SVG, Maybe SVG)] -> IO ()
output = zipWithM_ write [1..]
  where
    write :: Int -> (SVG, Maybe SVG) -> IO ()
    write n (front, mback)
      = do writeFile ("TiledFront-" ++ show n ++ ".svg") (show front)
           case mback of
             Nothing -> return ()
             Just back -> writeFile ("TiledBack-" ++ show n ++ ".svg") (show back)

loadSVG :: FilePath -> IO (String, SVG, Maybe SVG)
loadSVG fullName
  = do mfront <- parseSVG <$> readFile fullName
       case mfront of
         Nothing -> quitWith ("Could not parse SVG file: " ++ fullName)
         Just front -> do mend <- either ioNothing parseSVG <$> try (readFile backName)
                          return (fullName, front, mend)
  where
    ioNothing :: IOException -> Maybe a
    ioNothing _ = Nothing

    backName = (takeBaseName fullName ++ "-front") <.> "svg"

quitWith :: String -> IO a
quitWith msg = hPutStrLn stderr msg >> exitWith (ExitFailure 1)

main :: IO ()
main = do (s, fileNames) <- processArgs
          svgs <- mapM loadSVG fileNames
          let ps = makeParams s svgs
          let rs = map (uncurry $ tileSVGs (p $ dpi s)) ps
          case rights rs of
            [] -> quitWith $ head (lefts rs)
            rrs -> output $ minimumBy (comparing length) rrs