-- | Translations between integer or string values and data types.
--
-- This (internal) module converts between the character encodings of the FIG
-- files and the primitive types of "Graphics.Fig.Syntax" ('PaperSize',
-- 'CoordinateSystem', etc.).
module Graphics.Fig.Values where

import Graphics.Fig.Syntax

import qualified Data.Map as FM
import Maybe
import List

----------------------------------------------------------------------
-- Begin/end string codes for objects
----------------------------------------------------------------------

begin_color = "0"
begin_ellipse = "1"
begin_polyline = "2"
begin_spline = "3"
begin_text = "4"
begin_arc = "5"
begin_compound = "6"
begin_comment = "#"

end_compound = "-6"

----------------------------------------------------------------------
-- Header elements
----------------------------------------------------------------------

header_version = "#FIG 3.2"

(toOrientation, fromOrientation) = toFromValue list
    where
    list =
        [ ("Landscape", Landscape)
        , ("Portrait", Portrait)
        ]

(toUnits, fromUnits) = toFromValue list
    where
    list =
        [ ("Metric", Metric)
        , ("Inches", Inches)
        ]

(toPaperSize, fromPaperSize) = toFromValue list
    where
    list =
        [ ("Letter", Letter)
        , ("Legal", Legal)
        , ("Ledger", Ledger)
        , ("Tabloid", Tabloid)
        , ("A", A)
        , ("B", B)
        , ("C", C)
        , ("D", D)
        , ("E", E)
        , ("A4", A4)
        , ("A3", A3)
        , ("A2", A2)
        , ("A1", A1)
        , ("A0", A0)
        , ("B5", B5)
        ]

(toMultiplePage, fromMultiplePage) = toFromValue list
    where
    list =
        [ ("Single", Single)
        , ("Multiple", Multiple)
        ]

(toTransparent, fromTransparent) = (to, from)
    where
    to (-3) = Right Background
    to (-2) = Right None
    to (-1) = Right TransparentDefault
    to n =
        either
            (const (Left ("Transparency value `" ++ show n ++ "' out of range")))
            (Right . Transparent) (toColorSpec n)

    from Background = -3
    from None = -2
    from TransparentDefault = -1
    from (Transparent spec) = fromColorSpec spec

(toCoordinateSystem, fromCoordinateSystem) = toFromValue list
    where
    list = [(1, LowerLeft), (2, UpperLeft)]

----------------------------------------------------------------------
-- Fonts
----------------------------------------------------------------------

(toFontFlags, fromFontFlags) = (to, from)
    where
    to n
        | n < 0 || n > 15 = Left ("Font flag `" ++ show n ++ "' out of range")
        | otherwise = Right (FontFlags b3 b1 b0, b2)
        where
        [b0, b1, b2, b3] =
            let xs = toBitList n in xs ++ replicate (4 - length xs) False

    from ps (FontFlags b3 b1 b0) = fromBitList [b0, b1, b2, b3]
        where
        b2 = case ps of Ps _ -> True ; Latex _ -> False

    fromBitList bs =
        foldr
            (\x acc -> (if x then 1 else 0) + 2 * acc)
            0
        bs

    toBitList n = unfoldr f n
        where
        f 0 = Nothing
        f n = let (rest, bit) = divMod n 2 in Just (bit == 1, rest)

(toFont, fromFont) = (to, from)
    where
    to ps n =
        if ps
            then either Left (Right . Ps) (toPsFont n)
            else either Left (Right . Latex) (toLatexFont n)

    from (Ps font) = fromPsFont font
    from (Latex font) = fromLatexFont font

(toPsFont, fromPsFont) = toFromValue list
    where
    list =
        [ (-1, PsDefault)
        , (0, TimesRoman)
        , (1, TimesItalic)
        , (2, TimesBold)
        , (3, TimesBoldItalic)
        , (4, AvantGardeBook)
        , (5, AvantGardeBookOblique)
        , (6, AvantGardeDemi)
        , (7, AvantGardeDemiOblique)
        , (8, BookmanLight)
        , (9, BookmanLightItalic)
        , (10, BookmanDemi)
        , (11, BookmanDemiItalic)
        , (12, Courier)
        , (13, CourierOblique)
        , (14, CourierBold)
        , (15, CourierBoldOblique)
        , (16, Helvetica)
        , (17, HelveticaOblique)
        , (18, HelveticaBold)
        , (19, HelveticaBoldOblique)
        , (20, HelveticaNarrow)
        , (21, HelveticaNarrowOblique)
        , (22, HelveticaNarrowBold)
        , (23, HelveticaNarrowBoldOblique)
        , (24, NewCenturySchoolbookRoman)
        , (25, NewCenturySchoolbookItalic)
        , (26, NewCenturySchoolbookBold)
        , (27, NewCenturySchoolbookBoldItalic)
        , (28, PalatinoRoman)
        , (29, PalatinoItalic)
        , (30, PalatinoBold)
        , (31, PalatinoBoldItalic)
        , (32, Symbol)
        , (33, ZapfChanceryMediumItalic)
        , (34, ZapfDingbats)
        ]

(toLatexFont, fromLatexFont) = toFromValue list
    where
    list =
        [ (0, LatexDefault)
        , (1, Roman)
        , (2, Bold)
        , (3, Italic)
        , (4, SansSerif)
        , (5, Typewriter)
        ]

----------------------------------------------------------------------
-- Pictures
----------------------------------------------------------------------

(toFlipped, fromFlipped) = toFromValue list
    where
    list = [(0, Normal), (1, Flipped)]

----------------------------------------------------------------------
-- Arrows
----------------------------------------------------------------------

(toArrowStyle, fromArrowStyle) = toFromValue list
    where
    list = [(0, HollowArrow), (1, FilledArrow)]

(toArrowType, fromArrowType) = toFromValue list
    where
    list = [(0, Stick), (1, Closed), (2, Indented), (3, Pointed)]

----------------------------------------------------------------------
-- Lines styles
----------------------------------------------------------------------

(toCapStyle, fromCapStyle) = toFromValue list
    where
    list = [(0, Butt), (1, CapRound), (2, Projecting)]

(toJoinStyle, fromJoinStyle) = toFromValue list
    where
    list = [(0, Miter), (1, JoinRound), (2, Bevel)]

(toLineStyle, fromLineStyle) = toFromValue list
    where
    list =
        [ (-1, LineStyleDefault)
        , (0, Solid)
        , (1, Dashed)
        , (2, Dotted)
        , (3, DashDotted)
        , (4, DashDoubleDotted)
        , (5, DashTripleDotted)
        ]

----------------------------------------------------------------------
-- Pen and fill colors
----------------------------------------------------------------------

(toColorSpec, fromColorSpec) = (to, from)
    where
    to n
        | -1 <= n && n <= 31 = toColorSpec' n
        | 32 <= n && n <= 543 = Right (UserDefined n)
        | otherwise = Left ("Color value `" ++ show n ++ "' out of range")

    from (UserDefined n) = n
    from spec = fromColorSpec' spec

    (toColorSpec', fromColorSpec') = toFromValue list
        where
        list =
            [ (-1, ColorSpecDefault)
            , (0, Black)
            , (1, Blue)
            , (2, Green)
            , (3, Cyan)
            , (4, Red)
            , (5, Magenta)
            , (6, Yellow)
            , (7, White)
            , (8, Blue4)
            , (9, Blue3)
            , (10, Blue2)
            , (11, LtBlue)
            , (12, Green4)
            , (13, Green3)
            , (14, Green2)
            , (15, Cyan4)
            , (16, Cyan3)
            , (17, Cyan2)
            , (18, Red4)
            , (19, Red3)
            , (20, Red2)
            , (21, Magenta4)
            , (22, Magenta3)
            , (23, Magenta2)
            , (24, Brown4)
            , (25, Brown3)
            , (26, Brown2)
            , (27, Pink4)
            , (28, Pink3)
            , (29, Pink2)
            , (30, Pink)
            , (31, Gold)
            ]

----------------------------------------------------------------------
-- Area fill
----------------------------------------------------------------------

(toAreaFill, fromAreaFill) = (to, from)
    where
    to n
        | n == -1 = Right NoFill
        | 0 <= n && n <= 40 = Right (Filled (n * 5))
        | 41 <= n && n <= 62 = Right (Pattern (n - 41))
        | otherwise = Left ("Area fill value `" ++ show n ++ "' out of range")

    from NoFill = -1
    from (Filled n) = n `div` 5
    from (Pattern n) = n + 41

----------------------------------------------------------------------
-- Utilities
----------------------------------------------------------------------

toFromValue list = (toValue, fromValue)
    where
    toValue x =
        case FM.lookup x toFM of
            Nothing -> Left (error x)
            Just y -> Right y

    fromValue x = fromJust (FM.lookup x fromFM)

    toFM = FM.fromList list

    fromFM = FM.fromList (map inv list)

    inv (x, y) = (y, x)

    error x =
        "expecting one of " ++
        concat
            (intersperse " "
                (map show (FM.keys toFM))) ++ "\n" ++
        "got " ++ show x