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 :: forall n. [Kern n] -> KernMaps n
kernMap [Kern n]
kernlist = forall n.
[KernDir]
-> HashMap Text [Int]
-> HashMap Text [Int]
-> HashMap Text [Int]
-> HashMap Text [Int]
-> Vector n
-> KernMaps n
KernMaps [] forall k v. HashMap k v
H.empty forall k v. HashMap k v
H.empty forall k v. HashMap k v
H.empty forall k v. HashMap k v
H.empty forall a. Vector a
V.empty -- (transformChars (map kernU1)
  where
    transformChars :: [[[Char]]] -> HashMap [Char] [a]
transformChars [[[Char]]]
chars = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {b}. ([Char], b) -> ([Char], b)
ch forall a b. (a -> b) -> a -> b
$ forall {a} {a}. Eq a => [(a, [a])] -> [(a, [a])]
multiSet forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\([Char]
x,a
y) -> ([Char]
x,[a
y])) forall a b. (a -> b) -> a -> b
$ forall {a} {t}. Ord a => (t -> a) -> [t] -> [t]
sort forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ 
                           forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ 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) | 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 = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\b
x [a]
y -> (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 = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\t
x t
y -> 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) | forall a b. (a, b) -> a
fst (a, [a])
a forall a. Eq a => a -> a -> Bool
== forall a b. (a, b) -> a
fst (a, [a])
b = [(a, [a])] -> [(a, [a])]
multiSet ( (forall a b. (a, b) -> a
fst (a, [a])
a, (forall a b. (a, b) -> b
snd (a, [a])
a) forall a. [a] -> [a] -> [a]
++ (forall a b. (a, b) -> b
snd (a, [a])
b)) forall a. a -> [a] -> [a]
: [(a, [a])]
bs)
                      | Bool
otherwise = (a, [a])
a forall a. a -> [a] -> [a]
: ([(a, [a])] -> [(a, [a])]
multiSet ((a, [a])
bforall a. a -> [a] -> [a]
:[(a, [a])]
bs))

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


parseBBox :: (Read n, RealFloat n) => Maybe Text -> [n]
parseBBox :: forall n. (Read n, RealFloat n) => Maybe Text -> [n]
parseBBox Maybe Text
bbox = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((forall a b. (a -> b) -> [a] -> [b]
map Text -> n
convertToN) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.words) Maybe Text
bbox
  where convertToN :: Text -> n
convertToN = forall a. Fractional a => Rational -> a
fromRational forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Real a => a -> Rational
toRational forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const Double
0) forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reader Double
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 :: forall n b. RealFloat n => Text -> FontData b n -> n
horizontalAdvance Text
ch FontData b n
fontD
    | forall a. Maybe a -> Bool
isJust Maybe (Maybe Text, n, Maybe Text)
char = (\(Maybe Text
a,n
b,Maybe Text
c) -> n
b) (forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Maybe Text, n, Maybe Text)
char)
    | Bool
otherwise   = forall b n. FontData b n -> n
fontDataHorizontalAdvance FontData b n
fontD
  where char :: Maybe (Maybe Text, n, Maybe Text)
char = (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
ch (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 :: forall n b.
(Read n, Show n, RealFloat n) =>
FontData b n -> (OutlineMap n, ErrorMap)
outlineMap FontData b n
fontData =
    ( 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]
    , 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 = forall k v. HashMap k v -> [k]
H.keys (forall b n. FontData b n -> SvgGlyphs n
fontDataGlyphs FontData b n
fontData)
    outlines :: Text -> m (Path V2 n)
outlines Text
ch = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall n. (RealFloat n, Show n) => [PathCommand n] -> [Path V2 n]
commandsToPaths (forall n. RealFloat n => Text -> SvgGlyphs n -> [PathCommand n]
commandsFromChar Text
ch (forall b n. FontData b n -> SvgGlyphs n
fontDataGlyphs FontData b n
fontData))
    allOutlines :: [(Text, Either Text (Path V2 n))]
allOutlines = [(Text
ch, 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 :: forall n b.
(Read n, Show n, RealFloat n) =>
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) = 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 :: forall n. RealFloat n => Text -> SvgGlyphs n -> [PathCommand n]
commandsFromChar Text
ch SvgGlyphs n
glyph = case 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 -> []