--
-- Copyright (c) 2010 Anders Lau Olsen.
-- See LICENSE file for terms and conditions.
--

-- | The example below illustrates the typical use of the Fig library. The
-- program parses a FIG file read from stdin, applies a transformation to the
-- figure, and emits the result to stdout.
--
-- @
--module Main where
-- 
-- import Graphics.Fig
-- 
-- main = do
--     input <- getContents
--     either fail succeed
--         (parse \"stdin\" input)
--     where
--     succeed = putStr . pretty . process
-- 
-- process = applyReplaceDef replaceDef
-- 
-- replaceDef =
--     emptyDef
--         { linePenColor = const Magenta
--         , arrowWidth = (* 1.5)
--         , areaFillColor = \x ->
--             case x of
--                 Green4 -> LtBlue
--                 LtBlue -> Green4
--                 _ -> x
--         }
-- @
module Graphics.Fig
    ( ReplaceDef (..)
    , emptyDef
    , applyReplaceDef
    , parse
    , pretty
    , module Graphics.Fig.Syntax
    ) where

--
-- Top level functions for replacing attributes of FIG files
--

import Graphics.Fig.Printer (pretty)
import Graphics.Fig.Parser (parse)
import Graphics.Fig.Syntax

import Control.Monad

----------------------------------------------------------------------
-- Type declarations of exported functions
----------------------------------------------------------------------

-- | The empty replacement operation: All functions of the 'ReplaceDef' record
-- are equal to the identity function.
emptyDef :: ReplaceDef

-- | Apply a replacement operation to a figure.
applyReplaceDef
    :: ReplaceDef -- ^The replacements to perform.
    -> Fig -- ^A figure.
    -> Fig -- ^The figure with replacements applied.

----------------------------------------------------------------------
-- The data type of a replacement
----------------------------------------------------------------------

-- | Replacement operations for a figure.
--
-- A 'ReplaceDef' value is a record of functions to apply to the leaf elements
-- of a 'Fig' syntax tree (see 'applyReplaceDef').
data ReplaceDef =
    ReplaceDef
        { headerOrientation :: Orientation -> Orientation
        , headerJustification :: Justification -> Justification
        , headerUnits :: Units -> Units
        , headerPapersize :: PaperSize -> PaperSize
        , headerMagnification :: Double -> Double
        , headerMultiplePage :: MultiplePage -> MultiplePage
        , headerTransparentColor :: Transparent -> Transparent
        , headerResolution :: Integer -> Integer
        , textColor :: ColorSpec -> ColorSpec
        , textFontSize :: Double -> Double
        , textFont :: Font -> Font
        , textFontFlags :: FontFlags -> FontFlags
        , picFlipped :: Flipped -> Flipped
        , picFile :: FilePath -> FilePath
        , arrowType :: ArrowType -> ArrowType
        , arrowStyle :: ArrowStyle -> ArrowStyle
        , arrowThickness :: Double -> Double
        , arrowWidth :: Double -> Double
        , arrowHeight :: Double -> Double
        , areaFill :: AreaFill -> AreaFill
        , areaFillColor :: ColorSpec -> ColorSpec
        , lineStyle :: LineStyle -> LineStyle
        , lineThickness :: Integer -> Integer
        , linePenColor :: ColorSpec -> ColorSpec
        , lineStyleVal :: Double -> Double
        , lineCapStyle :: CapStyle -> CapStyle
        , lineJoinStyle :: JoinStyle -> JoinStyle
        }

emptyDef =
    ReplaceDef
        id id id id id id id id id id id id id id
        id id id id id id id id id id id id id

----------------------------------------------------------------------
-- Applying a replacement definition to a Fig syntax tree
----------------------------------------------------------------------

applyReplaceDef funs = mapFig headerF colorF objF
    where
    headerF header =
        header
            { header_orientation =
                headerOrientation funs (header_orientation header)
            , header_justification =
                headerJustification funs (header_justification header)
            , header_units = headerUnits funs (header_units header)
            , header_papersize =
                headerPapersize funs (header_papersize header)
            , header_magnification =
                headerMagnification funs (header_magnification header)
            , header_multiple_page =
                headerMultiplePage funs (header_multiple_page header)
            , header_transparent_color =
                headerTransparentColor funs (header_transparent_color header)
            , header_resolution = headerResolution funs (header_resolution header)
            }

    colorF = id

    objF = objF' . mapObject commonF arrF picF

    objF' obj =
        case obj of
            Arc line fw bw ->
                Arc
                    line
                        { arc_cap_style =
                            lineCapStyle funs (arc_cap_style line)
                        }
                    fw
                    bw
            Polyline line fw bw pic pts ->
                Polyline
                    line
                        { polyline_join_style =
                            lineJoinStyle funs (polyline_join_style line)
                        , polyline_cap_style =
                            lineCapStyle funs (polyline_cap_style line)
                        }
                    fw
                    bw
                    pic
                    pts
            Spline line fw bw pts ctrl ->
                Spline
                    line
                        { spline_cap_style =
                            lineCapStyle funs (spline_cap_style line)
                        }
                    fw
                    bw
                    pts
                    ctrl
            line @ Text {} ->
                line
                    { text_color = textColor funs (text_color line)
                    , text_font = textFont funs (text_font line)
                    , text_font_size =
                        textFontSize funs (text_font_size line)
                    , text_font_flags =
                        textFontFlags funs (text_font_flags line)
                    }
            _ -> obj

    commonF common =
        common
            { line_style = lineStyle funs (line_style common)
            , line_thickness = lineThickness funs (line_thickness common)
            , pen_color = linePenColor funs (pen_color common)
            , fill_color = areaFillColor funs (fill_color common)
            , area_fill = areaFill funs (area_fill common)
            , style_val = lineStyleVal funs (style_val common)
            }

    arrF (Arrow ty st th wi he) =
        Arrow
            (arrowType funs ty)
            (arrowStyle funs st)
            (arrowThickness funs th)
            (arrowWidth funs wi)
            (arrowHeight funs he)

    picF (Pic flipped file) =
        Pic (picFlipped funs flipped) (picFile funs file)

commented f (Comment cs obj) = Comment cs (f obj)

mapFig headerF colorF objF (Fig header cls objs) =
    Fig
        (headerF header)
        (map (commented colorF) cls)
        (map (commented objF) objs)

mapObject commonF arrF picF = object
    where
    object obj =
        case obj of
            Arc line fw bw ->
                Arc
                    line { arc_common = commonF (arc_common line) }
                    (arrow fw)
                    (arrow bw)
            Polyline line fw bw pic pts ->
                Polyline
                    line { polyline_common = commonF (polyline_common line) }
                    (arrow fw)
                    (arrow bw)
                    (liftM picF pic)
                    pts
            Spline line fw bw pts ctrl ->
                Spline
                    line { spline_common = commonF (spline_common line) }
                    (arrow fw)
                    (arrow bw)
                    pts
                    ctrl
            Compound line objs ->
                Compound line (objects objs)
            line @ Ellipse {} ->
                line { ellipse_common = commonF (ellipse_common line) }
            _ -> obj

    arrow = liftM arrF

    objects objs = map (commented object) objs