module Diagrams.SVG.Fonts.ReadFont
       (
         FontData(..)
       , FontFace(..)
       , Kern(..)
       , KernDir(..)
       , FontContent(..)

       , parseBBox
--       , bbox_dy
--       , bbox_lx, bbox_ly

--       , underlinePosition
--       , underlineThickness

       , kernMap
       , horizontalAdvance
--       , kernAdvance

       , OutlineMap
       , PreparedFont
       ) where

import           Data.Char         (isSpace)
import           Data.List        (intersect, sortBy)
import           Data.List.Split  (splitOn, splitWhen)
import qualified Data.HashMap.Strict as H
import           Data.Maybe       (catMaybes, fromJust, fromMaybe, 
                                  isJust, isNothing, maybeToList)
import qualified Data.Text           as T
import           Data.Text        (Text(..), pack, unpack, empty, words)
import           Data.Text.Read   (double)
import           Data.Vector      (Vector)
import qualified Data.Vector      as V
import           Diagrams.Path
import           Diagrams.Prelude hiding (font)

import           Diagrams.SVG.Fonts.CharReference (charsFromFullName)
import           Diagrams.SVG.Path
import           Diagrams.SVG.Tree

kernMap :: [Kern n] -> KernMaps n
kernMap :: [Kern n] -> KernMaps n
kernMap [Kern n]
kernlist = [KernDir]
-> HashMap Text [Int]
-> HashMap Text [Int]
-> HashMap Text [Int]
-> HashMap Text [Int]
-> Vector n
-> KernMaps n
forall n.
[KernDir]
-> HashMap Text [Int]
-> HashMap Text [Int]
-> HashMap Text [Int]
-> HashMap Text [Int]
-> Vector n
-> KernMaps n
KernMaps [] HashMap Text [Int]
forall k v. HashMap k v
H.empty HashMap Text [Int]
forall k v. HashMap k v
H.empty HashMap Text [Int]
forall k v. HashMap k v
H.empty HashMap Text [Int]
forall k v. HashMap k v
H.empty Vector n
forall a. Vector a
V.empty -- (transformChars (map kernU1)
  where
    transformChars :: [[[Char]]] -> HashMap [Char] [a]
transformChars [[[Char]]]
chars = [([Char], [a])] -> HashMap [Char] [a]
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList ([([Char], [a])] -> HashMap [Char] [a])
-> [([Char], [a])] -> HashMap [Char] [a]
forall a b. (a -> b) -> a -> b
$ (([Char], [a]) -> ([Char], [a]))
-> [([Char], [a])] -> [([Char], [a])]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], [a]) -> ([Char], [a])
forall b. ([Char], b) -> ([Char], b)
ch ([([Char], [a])] -> [([Char], [a])])
-> [([Char], [a])] -> [([Char], [a])]
forall a b. (a -> b) -> a -> b
$ [([Char], [a])] -> [([Char], [a])]
forall a a. Eq a => [(a, [a])] -> [(a, [a])]
multiSet ([([Char], [a])] -> [([Char], [a])])
-> [([Char], [a])] -> [([Char], [a])]
forall a b. (a -> b) -> a -> b
$ (([Char], a) -> ([Char], [a])) -> [([Char], a)] -> [([Char], [a])]
forall a b. (a -> b) -> [a] -> [b]
map (\([Char]
x,a
y) -> ([Char]
x,[a
y])) ([([Char], a)] -> [([Char], [a])])
-> [([Char], a)] -> [([Char], [a])]
forall a b. (a -> b) -> a -> b
$ (([Char], a) -> [Char]) -> [([Char], a)] -> [([Char], a)]
forall a t. Ord a => (t -> a) -> [t] -> [t]
sort ([Char], a) -> [Char]
forall a b. (a, b) -> a
fst ([([Char], a)] -> [([Char], a)]) -> [([Char], a)] -> [([Char], a)]
forall a b. (a -> b) -> a -> b
$ 
                           [[([Char], a)]] -> [([Char], a)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[([Char], a)]] -> [([Char], a)])
-> [[([Char], a)]] -> [([Char], a)]
forall a b. (a -> b) -> a -> b
$ [[[Char]]] -> [[([Char], a)]]
forall b a. (Num b, Enum b) => [[a]] -> [[(a, b)]]
addIndex [[[Char]]]
chars -- e.g. [["aa","b"],["c","d"]] to [("aa",0),("b",0),("c",1), ("d",1)]
    ch :: ([Char], b) -> ([Char], b)
ch ([Char]
x,b
y) | [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
x = ([Char]
"",b
y)
             | Bool
otherwise = ([Char]
x,b
y)

    addIndex :: [[a]] -> [[(a, b)]]
addIndex [[a]]
qs = (b -> [a] -> [(a, b)]) -> [b] -> [[a]] -> [[(a, b)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\b
x [a]
y -> ((a -> (a, b)) -> [a] -> [(a, b)]
forall a b. (a -> b) -> [a] -> [b]
map (\a
z -> (a
z,b
x)) [a]
y)) [b
0..] [[a]]
qs
    sort :: (t -> a) -> [t] -> [t]
sort t -> a
f [t]
xs = (t -> t -> Ordering) -> [t] -> [t]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\t
x t
y -> a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (t -> a
f t
x) (t -> a
f t
y) ) [t]
xs

    multiSet :: [(a, [a])] -> [(a, [a])]
multiSet [] = []
    multiSet ((a, [a])
a:[]) = [(a, [a])
a] -- example: [("n1",[0]),("n1",[1]),("n2",[1])] to [("n1",[0,1]),("n2",[1])]
    multiSet ((a, [a])
a:(a, [a])
b:[(a, [a])]
bs) | (a, [a]) -> a
forall a b. (a, b) -> a
fst (a, [a])
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== (a, [a]) -> a
forall a b. (a, b) -> a
fst (a, [a])
b = [(a, [a])] -> [(a, [a])]
multiSet ( ((a, [a]) -> a
forall a b. (a, b) -> a
fst (a, [a])
a, ((a, [a]) -> [a]
forall a b. (a, b) -> b
snd (a, [a])
a) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ ((a, [a]) -> [a]
forall a b. (a, b) -> b
snd (a, [a])
b)) (a, [a]) -> [(a, [a])] -> [(a, [a])]
forall a. a -> [a] -> [a]
: [(a, [a])]
bs)
                      | Bool
otherwise = (a, [a])
a (a, [a]) -> [(a, [a])] -> [(a, [a])]
forall a. a -> [a] -> [a]
: ([(a, [a])] -> [(a, [a])]
multiSet ((a, [a])
b(a, [a]) -> [(a, [a])] -> [(a, [a])]
forall a. a -> [a] -> [a]
:[(a, [a])]
bs))

    fname :: [Char] -> [Char]
fname [Char]
f = [[Char]] -> [Char]
forall a. [a] -> a
last ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [[Char]]
forall a. [a] -> [a]
init ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (([Char] -> [[Char]]) -> [[Char]] -> [[[Char]]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> [Char] -> [[Char]]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn [Char]
"/") ([Char] -> [Char] -> [[Char]]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn [Char]
"." [Char]
f))


parseBBox :: (Read n, RealFloat n) => Maybe Text -> [n]
parseBBox :: Maybe Text -> [n]
parseBBox Maybe Text
bbox = [n] -> (Text -> [n]) -> Maybe Text -> [n]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (((Text -> n) -> [Text] -> [n]
forall a b. (a -> b) -> [a] -> [b]
map Text -> n
convertToN) ([Text] -> [n]) -> (Text -> [Text]) -> Text -> [n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.words) Maybe Text
bbox
  where convertToN :: Text -> n
convertToN = Rational -> n
forall a. Fractional a => Rational -> a
fromRational (Rational -> n) -> (Text -> Rational) -> Text -> n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Rational
forall a. Real a => a -> Rational
toRational (Double -> Rational) -> (Text -> Double) -> Text -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char] -> Double)
-> ((Double, Text) -> Double)
-> Either [Char] (Double, Text)
-> Double
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Double -> [Char] -> Double
forall a b. a -> b -> a
const Double
0) (Double, Text) -> Double
forall a b. (a, b) -> a
fst) (Either [Char] (Double, Text) -> Double)
-> (Text -> Either [Char] (Double, Text)) -> Text -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either [Char] (Double, Text)
double

-- glyphs = map glyphsWithDefaults glyphElements

    -- monospaced fonts sometimes don't have a "horiz-adv-x="-value , replace with "horiz-adv-x=" in <font>
-- glyphsWithDefaults g = (charsFromFullName $ fromMaybe gname (findAttr (unqual "unicode") g), -- there is always a name or unicode
--                         (
--                           gname,
--                           fromMaybe fontHadv (fmap read (findAttr (unqual "horiz-adv-x") g)),
--                           fromMaybe "" (findAttr (unqual "d") g)
--                         )
--                       )
--      where gname = fromMaybe "" (findAttr (unqual "glyph-name") g)

-- | Horizontal advance of a character consisting of its width and spacing, extracted out of the font data
horizontalAdvance :: RealFloat n => Text -> FontData b n -> n
horizontalAdvance :: Text -> FontData b n -> n
horizontalAdvance Text
ch FontData b n
fontD
    | Maybe (Maybe Text, n, Maybe Text) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Maybe Text, n, Maybe Text)
char = (\(Maybe Text
a,n
b,Maybe Text
c) -> n
b) (Maybe (Maybe Text, n, Maybe Text) -> (Maybe Text, n, Maybe Text)
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Maybe Text, n, Maybe Text)
char)
    | Bool
otherwise   = FontData b n -> n
forall b n. FontData b n -> n
fontDataHorizontalAdvance FontData b n
fontD
  where char :: Maybe (Maybe Text, n, Maybe Text)
char = (Text
-> HashMap Text (Maybe Text, n, Maybe Text)
-> Maybe (Maybe Text, n, Maybe Text)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
ch (FontData b n -> HashMap Text (Maybe Text, n, Maybe Text)
forall b n. FontData b n -> SvgGlyphs n
fontDataGlyphs FontData b n
fontD))

-- | See <http://www.w3.org/TR/SVG/fonts.html#KernElements>
--
-- Some explanation how kerning is computed:
--
-- In Linlibertine.svg, there are two groups of chars: e.g.
-- \<hkern g1=\"f,longs,uni1E1F,f_f\" g2=\"parenright,bracketright,braceright\" k=\"-37\" />
-- This line means: If there is an f followed by parentright, reduce the horizontal advance by -37 (add 37).
-- Therefore to quickly check if two characters need kerning assign an index to the second group (g2 or u2)
-- and assign to every unicode in the first group (g1 or u1) this index, then sort these tuples after their
-- name (for binary search). Because the same unicode char can appear in several g1s, reduce this 'multiset',
-- ie all the (\"name1\",0) (\"name1\",1) to (\"name1\",[0,1]).
-- Now the g2s are converted in the same way as the g1s.
-- Whenever two consecutive chars are being printed try to find an
-- intersection of the list assigned to the first char and second char

-- | Change the horizontal advance of two consective chars (kerning)
{-
kernAdvance :: RealFloat n => String -> String -> KernMaps n -> Bool -> n
kernAdvance ch0 ch1 kern u |     u && not (null s0) = (kernK kern) V.! (head s0)
                           | not u && not (null s1) = (kernK kern) V.! (head s1)
                           | otherwise = 0
  where s0 = intersect (s kernU1S ch0) (s kernU2S ch1)
        s1 = intersect (s kernG1S ch0) (s kernG2S ch1)
        s sel ch = concat (maybeToList (Map.lookup ch (sel kern)))
-}
-- > import Graphics.SVGFonts.ReadFont
-- > textWH0 = (rect 8 1) # alignBL <> ((textSVG_ $ TextOpts "SPACES" lin INSIDE_WH KERN False 8 1 )
-- >              # fc blue # lc blue # bg lightgrey # fillRule EvenOdd) # alignBL
-- > textWH1 = (rect 8 1) # alignBL <> ((textSVG_ $ TextOpts "are sometimes better." lin INSIDE_WH KERN False 8 1 )
-- >              # fc blue # lc blue # bg lightgrey # fillRule EvenOdd) # alignBL
-- > textWH2 = (rect 8 1) # alignBL <> ((textSVG_ $ TextOpts "But too many chars are not good." lin INSIDE_WH KERN False 8 1 )
-- >              # fc blue # lc blue # bg lightgrey # fillRule EvenOdd) # alignBL
-- > textWH = textWH0 # alignBL === strutY 0.3 === textWH1 === strutY 0.3 === textWH2 # alignBL
-- > textW0 = (rect 3 1) # alignBL <> ( (textSVG_ $ TextOpts "HEADLINE" lin INSIDE_W KERN False 3 1 )
-- >              # fc blue # lc blue # bg lightgrey # fillRule EvenOdd ) # alignBL
-- > textW1 = (rect 10 1) # alignBL <> ( (textSVG_ $ TextOpts "HEADLINE" lin INSIDE_W KERN False 10 1 )
-- >              # fc blue # lc blue # bg lightgrey # fillRule EvenOdd ) # alignBL
-- > textW = textW0 # alignBL ||| strutX 1 ||| textW1 # alignBL
-- > textH0 = (rect 10 1) # alignBL <> ((textSVG_ $ TextOpts "Constant font size" lin INSIDE_H KERN False 10 1 )
-- >              # fc blue # lc blue # bg lightgrey # fillRule EvenOdd) # alignBL
-- > textH1 = (rect 3 1) # alignBL <> ((textSVG_ $ TextOpts "Constant font size" lin INSIDE_H KERN False 3 1 )
-- >              # fc blue # lc blue # bg lightgrey # fillRule EvenOdd) # alignBL
-- > textH = textH0 # alignBL === strutY 0.5 === textH1 # alignBL

-- > import Graphics.SVGFonts.ReadFont
-- > textHADV = (textSVG_ $ TextOpts "AVENGERS" lin INSIDE_H HADV False 10 1 )
-- >              # fc blue # lc blue # bg lightgrey # fillRule EvenOdd

-- > import Graphics.SVGFonts.ReadFont
-- > textKern = (textSVG_ $ TextOpts "AVENGERS" lin INSIDE_H KERN False 10 1 )
-- >              # fc blue # lc blue # bg lightgrey # fillRule EvenOdd

{-
-- | Difference between highest and lowest y-value of bounding box
bbox_dy :: RealFloat n => FontData n -> n
bbox_dy fontData = (bbox!!3) - (bbox!!1)
  where bbox = fontDataBoundingBox fontData -- bbox = [lowest x, lowest y, highest x, highest y]

-- | Lowest x-value of bounding box
bbox_lx :: RealFloat n => FontData n -> n
bbox_lx fontData   = (fontDataBoundingBox fontData) !! 0

-- | Lowest y-value of bounding box
bbox_ly :: RealFloat n => FontData n -> n
bbox_ly fontData   = (fontDataBoundingBox fontData) !! 1

-- | Position of the underline bar
underlinePosition :: RealFloat n => FontData n -> n
underlinePosition fontData = fontDataUnderlinePos fontData

-- | Thickness of the underline bar
underlineThickness :: RealFloat n => FontData n -> n
underlineThickness fontData = fontDataUnderlineThickness fontData
-}
-- | A map of unicode characters to outline paths.
type OutlineMap n = H.HashMap Text (Path V2 n)

-- | A map of unicode characters to parsing errors.
type ErrorMap = H.HashMap Text Text

-- | A font including its outline map.
type PreparedFont b n = (FontData b n, OutlineMap n)

-- | Compute a font's outline map, collecting errors in a second map.
outlineMap :: (Read n, Show n, RealFloat n) =>
              FontData b n -> (OutlineMap n, ErrorMap)
outlineMap :: FontData b n -> (OutlineMap n, ErrorMap)
outlineMap FontData b n
fontData =
    ( [(Text, Path V2 n)] -> OutlineMap n
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList [(Text
ch, Path V2 n
outl) | (Text
ch, Right Path V2 n
outl) <- [(Text, Either Text (Path V2 n))]
allOutlines]
    , [(Text, Text)] -> ErrorMap
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList [(Text
ch, Text
err)  | (Text
ch, Left Text
err)   <- [(Text, Either Text (Path V2 n))]
allOutlines]
    )
  where
    allUnicodes :: [Text]
allUnicodes = HashMap Text (Maybe Text, n, Maybe Text) -> [Text]
forall k v. HashMap k v -> [k]
H.keys (FontData b n -> HashMap Text (Maybe Text, n, Maybe Text)
forall b n. FontData b n -> SvgGlyphs n
fontDataGlyphs FontData b n
fontData)
    outlines :: Text -> m (Path V2 n)
outlines Text
ch = Path V2 n -> m (Path V2 n)
forall (m :: * -> *) a. Monad m => a -> m a
return (Path V2 n -> m (Path V2 n)) -> Path V2 n -> m (Path V2 n)
forall a b. (a -> b) -> a -> b
$ [Path V2 n] -> Path V2 n
forall a. Monoid a => [a] -> a
mconcat ([Path V2 n] -> Path V2 n) -> [Path V2 n] -> Path V2 n
forall a b. (a -> b) -> a -> b
$ [PathCommand n] -> [Path V2 n]
forall n. (RealFloat n, Show n) => [PathCommand n] -> [Path V2 n]
commandsToPaths (Text -> HashMap Text (Maybe Text, n, Maybe Text) -> [PathCommand n]
forall n. RealFloat n => Text -> SvgGlyphs n -> [PathCommand n]
commandsFromChar Text
ch (FontData b n -> HashMap Text (Maybe Text, n, Maybe Text)
forall b n. FontData b n -> SvgGlyphs n
fontDataGlyphs FontData b n
fontData))
    allOutlines :: [(Text, Either Text (Path V2 n))]
allOutlines = [(Text
ch, Text -> Either Text (Path V2 n)
forall (m :: * -> *). Monad m => Text -> m (Path V2 n)
outlines Text
ch) | Text
ch <- [Text]
allUnicodes]

-- | Prepare font for rendering, by determining its outline map.
prepareFont :: (Read n, Show n, RealFloat n) =>
               FontData b n -> (PreparedFont b n, ErrorMap)
prepareFont :: FontData b n -> (PreparedFont b n, ErrorMap)
prepareFont FontData b n
fontData = ((FontData b n
fontData, OutlineMap n
outlines), ErrorMap
errs)
  where
    (OutlineMap n
outlines, ErrorMap
errs) = FontData b n -> (OutlineMap n, ErrorMap)
forall n b.
(Read n, Show n, RealFloat n) =>
FontData b n -> (OutlineMap n, ErrorMap)
outlineMap FontData b n
fontData

commandsFromChar :: RealFloat n => Text -> SvgGlyphs n -> [PathCommand n]
commandsFromChar :: Text -> SvgGlyphs n -> [PathCommand n]
commandsFromChar Text
ch SvgGlyphs n
glyph = case Text -> SvgGlyphs n -> Maybe (Maybe Text, n, Maybe Text)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
ch SvgGlyphs n
glyph of
--    Just e  -> commands (Just $ pack $ (\(a,b,c) -> c) e)
    Maybe (Maybe Text, n, Maybe Text)
Nothing -> []