module Diagrams.SVG.Fonts.ReadFont
(
FontData(..)
, FontFace(..)
, Kern(..)
, KernDir(..)
, FontContent(..)
, parseBBox
, kernMap
, horizontalAdvance
, 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
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
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]
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
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))
type OutlineMap n = H.HashMap Text (Path V2 n)
type ErrorMap = H.HashMap Text Text
type PreparedFont b n = (FontData b n, OutlineMap n)
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]
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
Maybe (Maybe Text, n, Maybe Text)
Nothing -> []