Tile.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.

-- | A module with a helper function for tiling several SVG files (which can vary
-- in size) into a group of SVG files of a specific size.
module Data.SVG.Tile (TileItem(..), tileSVGs, TileSettings(..)) where

import Control.Applicative ((<$>))
import Control.Arrow ((***), (&&&))
import Control.Monad (liftM)
import Data.Function (on)
import Data.List (groupBy, nub, sortBy)
import Data.Maybe (fromJust, fromMaybe)
import Data.Ord (comparing)
import Data.SVG.SVG
import Data.SVG.Internal.Fail
import Text.XML.Light (unqual, Element(..), Content(..), Attr(..), QName(..))

-- | The settings for tiling: the paper size, margin (same on all sides) and gap (between tiled items)
data TileSettings = TileSettings
    { tilePaperSize :: Size
    , tileMargin :: MM
    , tileGap :: MM
    , ignoreNamespaceConflicts :: Bool
    }
    deriving (Show, Eq)

-- | An item to be tiled, with an SVG image for the front, and an optional SVG
-- for the back.  If the two images are different sizes, the smallest size that
-- can accommodate both is used for tiling.  This means that if you have a larger
-- back image, the front will have enough space left to match up with the back
-- (and vice versa).
--
-- The label is currently only used for error reporting.
data TileItem = TileItem { tileLabel :: String, tileFront :: SVG, tileBack :: Maybe SVG }

sizeAfterMargin :: TileSettings -> Size
sizeAfterMargin (TileSettings (Size pw ph) m _ _)
  = Size (pw - m - m) (ph - m - m)

data RowInfo = RowInfo {_curX :: MM, _curY :: MM, _rowHeight :: MM }

getTileSize :: DPI -> TileItem -> FailM Size
getTileSize dpi t
  = do frontSize <- maybeFail "SVG file has no size" $ getSVGSize dpi (tileFront t)
       case tileBack t of
         Nothing -> return frontSize
         Just back -> do backSize <- maybeFail "SVG file has no size" $ getSVGSize dpi back
                         return (frontSize `maxSize` backSize)

-- Smallest size that can fit both
maxSize :: Size -> Size -> Size
maxSize (Size w h) (Size w' h') = Size (w `max` w') (h `max` h')

type Tiled = ([(QName, String)], [Content])

-- | Tiles the given items.
--
-- This function takes a list of front (and optional back) SVG images, then arranges
-- them using the given paper size, margin and gaps between items.
-- The return is a list of front images (with back images where needed).
--
-- This method is intended to be used to put multiple small SVG items onto a single
-- page for printing.
--
-- The layout algorithm is very simple.  It places the first item in the top-left,
-- then attempts to fill the rest of the row with the next items in the list.
-- Once a row is full, it moves down to make more rows, until the page is full.
--  Thus, list items will always appear in the order they are given, and you can
-- potentially get some wasted space, especially if the items vary wildly in size,
-- and are not sorted by size first.
--
-- This method can fail because it cannot get the sizes of the items to tile
-- using 'getSVGSize', because there are conflicts between the namespaces of
-- the files, or because there are one or more items in the list that cannot
-- fit on a single page by themselves.
tileSVGs :: DPI -> TileSettings -> [TileItem] -> Either String [(SVG, Maybe SVG)]
tileSVGs dpi ts toTile = runFail $
  do sizes <- mapM (getTileSize dpi) toTile
     let make = uncurry $ makeTileSVG dpi ts
     tiles <- filter nonBlank <$> tileRow (RowInfo 0 0 0) (zip sizes toTile)
     mapM (liftM (make *** fmap make) . doAttrs) tiles
  where
    merge = mergeAttrs (ignoreNamespaceConflicts ts)
    
    doAttrs :: (Tiled, Maybe Tiled) -> FailM (([Attr], [Content]), Maybe ([Attr], [Content]))
    doAttrs (x, Nothing) = flip (,) Nothing <$> merge x
    doAttrs (x, Just y) = do x' <- merge x
                             y' <- merge y
                             return (x', Just y')
    
    tileRow :: RowInfo -> [(Size, TileItem)] -> FailM [(Tiled, Maybe Tiled)]
      -- We must return a blank page when there is nothing to place, due to the
      -- way that the rest of the algorithm works:
    tileRow _ [] = return [(([], []), Nothing)]
    tileRow ri (svg:svgs)
      = case placeAcross ri svg of
          Just (ri', el) -> do (es:ess) <- tileRow ri' svgs
                               -- We get the rest of the page (head of the list)
                               -- and add ourselves to that (and still include
                               -- all other pages)
                               return ((el *:* es) : ess)
          Nothing -> case placeAcross (RowInfo 0 0 0) svg of
                       Just (ri', el) ->
                         do (es:ess) <- tileRow ri' svgs
                            -- We put the end of the previous page (a blank)
                            -- before adding ourselves to the next page (head of
                            -- the list) and include all the other pages
                            return ((([], []), Nothing) : (el *:* es) : ess)
                       Nothing -> Fail $ tileLabel (snd svg) ++ " won't fit on a sheet"
      where
        (*:*) :: (([a], b), Maybe ([a], b)) -> (([a], [b]), Maybe ([a], [b]))
                                            -> (([a], [b]), Maybe ([a], [b]))
        (*:*) (x, my) (xs, mys) = (x & xs, maybe mys (Just . (& fromMaybe ([],[]) mys)) my)
          where
            (&) (as, b) (as', bs') = (as ++ as', b : bs')

    Size pw ph = sizeAfterMargin ts
    gap = tileGap ts


    nonBlank (xs, mys) = not (nullTile xs) || maybe False (not . nullTile) mys
      where
        nullTile = null . snd
        
    -- Nothing if it won't fit on this sheet
    placeAcross :: RowInfo -> (Size, TileItem) ->
      Maybe (RowInfo, (([(QName, String)], Content), Maybe ([(QName, String)], Content)))
    placeAcross (RowInfo ox oy rh) (Size w h, t)
      | oy + h > ph -- Definitely too tall
         = Nothing
      -- So, not too tall:
      | ox + w <= pw -- Not too wide for this row; it fits
         = Just (RowInfo (ox + w + gap) oy (rh `max` h), placeFrontBack t w (ox, oy))
      -- Not too tall, but is too wide for this row; try next row:
      | (oy + rh + gap + h <= ph) && (w <= pw)
         -- Will fit on next row
         = Just (RowInfo (w + gap) (oy + rh + gap) h, placeFrontBack t w (0, oy + rh + gap))
      -- Didn't fit on next row either:
      | otherwise = Nothing

    placeFrontBack :: TileItem -> MM -> (MM, MM) ->
      (([(QName, String)], Content), Maybe ([(QName, String)], Content))
    placeFrontBack t w (x, y)
      = (namespaces &&& (Elem . placeAt dpi (x, y) . elContent . getSVGElement) $ tileFront t
        ,(namespaces &&& (Elem . placeAt dpi (flipHoriz w x, y) . elContent . getSVGElement)) <$> tileBack t
        )

    flipHoriz w x = pw - x - w

mergeAttrs :: Bool -> ([(QName, String)], a) -> FailM ([Attr], a)
mergeAttrs ignoreConflicts (attrs, x) = flip (,) x <$> mapM fromSingleton merged
  where
    merged :: [(QName, [String])]
    merged = map ((fst . head) &&& (nub . map snd)) $ groupBy ((==) `on` fst) $ sortBy (comparing fst) attrs

    fromSingleton :: (QName, [String]) -> FailM Attr
    fromSingleton (k, [v]) = return (Attr k v)
    fromSingleton (k, vs)
      | ignoreConflicts = return (Attr k (head vs))
      | otherwise = Fail $ concat
         ["Conflicting values for namespace "
         ,maybe "" (++ ":") (qPrefix k)
         ,qName k
         ,", values are: "
         ,show vs
         ]

makeTileSVG :: DPI -> TileSettings -> [Attr] -> [Content] -> SVG
makeTileSVG dpi (TileSettings (Size pw ph) margin _ _) attrs content 
  = fromJust . makeSVG $ Element (unqual "svg") (attrs ++
        [unqual "version" ~> "1.0"
        ,unqual "width" ~> show pw
        ,unqual "height" ~> show ph
        ])
        [Elem $ placeAt dpi (margin, margin) content]
        Nothing
  where
    a ~> b = Attr a b