{-# LANGUAGE DeriveGeneric #-}
module Graphics.SVGFonts.ReadFont
       (
         FontData(..)

       , bbox_dy
       , bbox_lx, bbox_ly

       , underlinePosition
       , underlineThickness

       , horizontalAdvance
       , kernAdvance
       , Kern(..)

       , OutlineMap
       , PreparedFont
       , loadFont
       , loadFont'
       ) where

import           Control.Monad                   (when)
import           Data.Char                       (isSpace)
import           Data.List                       (intersect, sortBy)
import           Data.List.Split                 (splitOn, splitWhen)
import qualified Data.Map                        as Map
import           Data.Maybe                      (catMaybes, fromJust,
                                                  fromMaybe, isJust, isNothing,
                                                  maybeToList)
import qualified Data.Vector                     as V
import           Diagrams.Path
import           Diagrams.Prelude                hiding (font)
import           Text.XML.Light
import           Text.XML.Light.Lexer (XmlSource)

import           Graphics.SVGFonts.CharReference (charsFromFullName)
import           Graphics.SVGFonts.ReadPath      (PathCommand (..),
                                                  pathFromString)

import           GHC.Generics                    (Generic)
import           Data.Serialize                  (Serialize)
import           Data.Vector.Serialize           ()

-- | This type contains everything that a typical SVG font file produced
--   by fontforge contains.
data FontData n = FontData
  { FontData n -> SvgGlyphs n
fontDataGlyphs                 :: SvgGlyphs n
  , FontData n -> Kern n
fontDataKerning                :: Kern n
  , FontData n -> [n]
fontDataBoundingBox            :: [n]
  , FontData n -> String
fontDataFileName               :: String
  , FontData n -> n
fontDataUnderlinePos           :: n
  , FontData n -> n
fontDataUnderlineThickness     :: n
  , FontData n -> Maybe n
fontDataOverlinePos            :: Maybe n
  , FontData n -> Maybe n
fontDataOverlineThickness      :: Maybe n
  , FontData n -> Maybe n
fontDataStrikethroughPos       :: Maybe n
  , FontData n -> Maybe n
fontDataStrikethroughThickness :: Maybe n
  , FontData n -> n
fontDataHorizontalAdvance      :: n
  , FontData n -> String
fontDataFamily                 :: String
  , FontData n -> String
fontDataStyle                  :: String
  , FontData n -> String
fontDataWeight                 :: String
  , FontData n -> String
fontDataVariant                :: String
  , FontData n -> String
fontDataStretch                :: String
  , FontData n -> Maybe String
fontDataSize                   :: Maybe String
  , FontData n -> n
fontDataUnitsPerEm             :: n
  , FontData n -> String
fontDataPanose                 :: String
  , FontData n -> Maybe n
fontDataSlope                  :: Maybe n
  , FontData n -> n
fontDataAscent                 :: n
  , FontData n -> n
fontDataDescent                :: n
  , FontData n -> n
fontDataXHeight                :: n
  , FontData n -> n
fontDataCapHeight              :: n
  , FontData n -> Maybe n
fontDataAccentHeight           :: Maybe n
  , FontData n -> Maybe String
fontDataWidths                 :: Maybe String
  , FontData n -> Maybe n
fontDataHorizontalStem         :: Maybe n
    -- ^ This data is not available in some fonts (e.g. Source Code Pro)
  , FontData n -> Maybe n
fontDataVerticalStem           :: Maybe n
    -- ^ This data is not available in some fonts (e.g. Source Code Pro)
  , FontData n -> String
fontDataUnicodeRange           :: String
  , FontData n -> [(String, [String], [String], [String], [String])]
fontDataRawKernings            :: [(String, [String], [String], [String], [String])]
  , FontData n -> Maybe n
fontDataIdeographicBaseline    :: Maybe n
  , FontData n -> Maybe n
fontDataAlphabeticBaseline     :: Maybe n
  , FontData n -> Maybe n
fontDataMathematicalBaseline   :: Maybe n
  , FontData n -> Maybe n
fontDataHangingBaseline        :: Maybe n
  , FontData n -> Maybe n
fontDataVIdeographicBaseline   :: Maybe n
  , FontData n -> Maybe n
fontDataVAlphabeticBaseline    :: Maybe n
  , FontData n -> Maybe n
fontDataVMathematicalBaseline  :: Maybe n
  , FontData n -> Maybe n
fontDataVHangingBaseline       :: Maybe n
  } deriving ((forall x. FontData n -> Rep (FontData n) x)
-> (forall x. Rep (FontData n) x -> FontData n)
-> Generic (FontData n)
forall x. Rep (FontData n) x -> FontData n
forall x. FontData n -> Rep (FontData n) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall n x. Rep (FontData n) x -> FontData n
forall n x. FontData n -> Rep (FontData n) x
$cto :: forall n x. Rep (FontData n) x -> FontData n
$cfrom :: forall n x. FontData n -> Rep (FontData n) x
Generic)

instance Serialize n => Serialize (FontData n)

-- | Open an SVG-Font File and extract the data
parseFont :: (XmlSource s, Read n, RealFloat n) => FilePath -> s -> FontData n
parseFont :: String -> s -> FontData n
parseFont String
basename s
contents = Element -> String -> FontData n
forall n. (Read n, RealFloat n) => Element -> String -> FontData n
readFontData Element
fontElement String
basename
  where
    xml :: [Element]
xml = [Content] -> [Element]
onlyElems ([Content] -> [Element]) -> [Content] -> [Element]
forall a b. (a -> b) -> a -> b
$ s -> [Content]
forall s. XmlSource s => s -> [Content]
parseXML (s -> [Content]) -> s -> [Content]
forall a b. (a -> b) -> a -> b
$ s
contents
    fontElement :: Element
fontElement | [Maybe Element] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Maybe Element]
fontElements = String -> Element
forall a. HasCallStack => String -> a
error (String
"no <font>-tag found in SVG file using SVGFonts library." String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                             String
"Most likely wrong namespace in <svg>-tag. Please delete xmlns=...")
                | Bool
otherwise = [Element] -> Element
forall a. [a] -> a
head ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ [Maybe Element] -> [Element]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Element] -> [Element]) -> [Maybe Element] -> [Element]
forall a b. (a -> b) -> a -> b
$ [Maybe Element]
fontElements

    fontElements :: [Maybe Element]
fontElements = (Element -> Maybe Element) -> [Element] -> [Maybe Element]
forall a b. (a -> b) -> [a] -> [b]
map (QName -> Element -> Maybe Element
findElement (String -> QName
qTag String
"font")) [Element]
xml [Maybe Element] -> [Maybe Element] -> [Maybe Element]
forall a. [a] -> [a] -> [a]
++ -- sometimes there is a namespace given with <svg xmlns=...
                   (Element -> Maybe Element) -> [Element] -> [Maybe Element]
forall a b. (a -> b) -> [a] -> [b]
map (QName -> Element -> Maybe Element
findElement (String -> QName
unqual String
"font")) [Element]
xml -- sometimes not: <svg>

qTag :: String -> QName
qTag :: String -> QName
qTag String
name = QName :: String -> Maybe String -> Maybe String -> QName
QName {qName :: String
qName = String
name, qURI :: Maybe String
qURI = String -> Maybe String
forall a. a -> Maybe a
Just String
"http://www.w3.org/2000/svg", qPrefix :: Maybe String
qPrefix = Maybe String
forall a. Maybe a
Nothing}

-- | Read font data from an XML font element.
readFontData :: (Read n, RealFloat n) => Element -> String -> FontData n
readFontData :: Element -> String -> FontData n
readFontData Element
fontElement String
basename = FontData :: forall n.
SvgGlyphs n
-> Kern n
-> [n]
-> String
-> n
-> n
-> Maybe n
-> Maybe n
-> Maybe n
-> Maybe n
-> n
-> String
-> String
-> String
-> String
-> String
-> Maybe String
-> n
-> String
-> Maybe n
-> n
-> n
-> n
-> n
-> Maybe n
-> Maybe String
-> Maybe n
-> Maybe n
-> String
-> [(String, [String], [String], [String], [String])]
-> Maybe n
-> Maybe n
-> Maybe n
-> Maybe n
-> Maybe n
-> Maybe n
-> Maybe n
-> Maybe n
-> FontData n
FontData
  { fontDataGlyphs :: SvgGlyphs n
fontDataGlyphs      = [(String, (String, n, String))] -> SvgGlyphs n
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String, (String, n, String))]
glyphs
  , fontDataKerning :: Kern n
fontDataKerning     = Kern :: forall n.
Map String [Int]
-> Map String [Int]
-> Map String [Int]
-> Map String [Int]
-> Vector n
-> Kern n
Kern
    { kernU1S :: Map String [Int]
kernU1S = [String] -> Map String [Int]
forall a. (Num a, Enum a) => [String] -> Map String [a]
transformChars [String]
u1s
    , kernU2S :: Map String [Int]
kernU2S = [String] -> Map String [Int]
forall a. (Num a, Enum a) => [String] -> Map String [a]
transformChars [String]
u2s
    , kernG1S :: Map String [Int]
kernG1S = [String] -> Map String [Int]
forall a. (Num a, Enum a) => [String] -> Map String [a]
transformChars [String]
g1s
    , kernG2S :: Map String [Int]
kernG2S = [String] -> Map String [Int]
forall a. (Num a, Enum a) => [String] -> Map String [a]
transformChars [String]
g2s
    , kernK :: Vector n
kernK = Vector n
kAr
    }
  , fontDataBoundingBox :: [n]
fontDataBoundingBox = [n]
forall n. Read n => [n]
parsedBBox
  , fontDataFileName :: String
fontDataFileName    = String
basename
  , fontDataUnderlinePos :: n
fontDataUnderlinePos       = Element
fontface Element -> String -> n
forall a. Read a => Element -> String -> a
`readAttr` String
"underline-position"
  , fontDataUnderlineThickness :: n
fontDataUnderlineThickness = Element
fontface Element -> String -> n
forall a. Read a => Element -> String -> a
`readAttr` String
"underline-thickness"
  , fontDataHorizontalAdvance :: n
fontDataHorizontalAdvance  = n
fontHadv
  , fontDataFamily :: String
fontDataFamily     = Element -> String -> String -> String
readString Element
fontface String
"font-family" String
""
  , fontDataStyle :: String
fontDataStyle      = Element -> String -> String -> String
readString Element
fontface String
"font-style" String
"all"
  , fontDataWeight :: String
fontDataWeight     = Element -> String -> String -> String
readString Element
fontface String
"font-weight" String
"all"
  , fontDataVariant :: String
fontDataVariant    = Element -> String -> String -> String
readString Element
fontface String
"font-variant" String
"normal"
  , fontDataStretch :: String
fontDataStretch    = Element -> String -> String -> String
readString Element
fontface String
"font-stretch" String
"normal"
  , fontDataSize :: Maybe String
fontDataSize       = Element
fontface Element -> String -> Maybe String
`readStringM` String
"font-size"
  , fontDataUnitsPerEm :: n
fontDataUnitsPerEm = Element
fontface Element -> String -> n
forall a. Read a => Element -> String -> a
`readAttr` String
"units-per-em"
  , fontDataSlope :: Maybe n
fontDataSlope      = Element
fontface Element -> String -> Maybe n
forall a. Read a => Element -> String -> Maybe a
`readAttrM` String
"slope"
  , fontDataPanose :: String
fontDataPanose     = Element -> String -> String -> String
readString Element
fontface String
"panose-1" String
"0 0 0 0 0 0 0 0 0 0"
  , fontDataAscent :: n
fontDataAscent     = Element
fontface Element -> String -> n
forall a. Read a => Element -> String -> a
`readAttr` String
"ascent"
  , fontDataDescent :: n
fontDataDescent    = Element
fontface Element -> String -> n
forall a. Read a => Element -> String -> a
`readAttr` String
"descent"
  , fontDataXHeight :: n
fontDataXHeight    = Element
fontface Element -> String -> n
forall a. Read a => Element -> String -> a
`readAttr` String
"x-height"
  , fontDataCapHeight :: n
fontDataCapHeight  = Element
fontface Element -> String -> n
forall a. Read a => Element -> String -> a
`readAttr` String
"cap-height"
  , fontDataAccentHeight :: Maybe n
fontDataAccentHeight = Element
fontface Element -> String -> Maybe n
forall a. Read a => Element -> String -> Maybe a
`readAttrM` String
"accent-height"
  , fontDataWidths :: Maybe String
fontDataWidths  = Element
fontface Element -> String -> Maybe String
`readStringM` String
"widths"
  , fontDataHorizontalStem :: Maybe n
fontDataHorizontalStem = Element
fontface Element -> String -> Maybe n
forall a. Read a => Element -> String -> Maybe a
`readAttrM` String
"stemh"
  , fontDataVerticalStem :: Maybe n
fontDataVerticalStem   = Element
fontface Element -> String -> Maybe n
forall a. Read a => Element -> String -> Maybe a
`readAttrM` String
"stemv"
  , fontDataUnicodeRange :: String
fontDataUnicodeRange = Element -> String -> String -> String
readString Element
fontface String
"unicode-range" String
"U+0-10FFFF"
  , fontDataRawKernings :: [(String, [String], [String], [String], [String])]
fontDataRawKernings = [(String, [String], [String], [String], [String])]
rawKerns
  , fontDataIdeographicBaseline :: Maybe n
fontDataIdeographicBaseline   = Element
fontface Element -> String -> Maybe n
forall a. Read a => Element -> String -> Maybe a
`readAttrM` String
"ideographic"
  , fontDataAlphabeticBaseline :: Maybe n
fontDataAlphabeticBaseline    = Element
fontface Element -> String -> Maybe n
forall a. Read a => Element -> String -> Maybe a
`readAttrM` String
"alphabetic"
  , fontDataMathematicalBaseline :: Maybe n
fontDataMathematicalBaseline  = Element
fontface Element -> String -> Maybe n
forall a. Read a => Element -> String -> Maybe a
`readAttrM` String
"mathematical"
  , fontDataHangingBaseline :: Maybe n
fontDataHangingBaseline       = Element
fontface Element -> String -> Maybe n
forall a. Read a => Element -> String -> Maybe a
`readAttrM` String
"hanging"
  , fontDataVIdeographicBaseline :: Maybe n
fontDataVIdeographicBaseline  = Element
fontface Element -> String -> Maybe n
forall a. Read a => Element -> String -> Maybe a
`readAttrM` String
"v-ideographic"
  , fontDataVAlphabeticBaseline :: Maybe n
fontDataVAlphabeticBaseline   = Element
fontface Element -> String -> Maybe n
forall a. Read a => Element -> String -> Maybe a
`readAttrM` String
"v-alphabetic"
  , fontDataVMathematicalBaseline :: Maybe n
fontDataVMathematicalBaseline = Element
fontface Element -> String -> Maybe n
forall a. Read a => Element -> String -> Maybe a
`readAttrM` String
"v-mathematical"
  , fontDataVHangingBaseline :: Maybe n
fontDataVHangingBaseline      = Element
fontface Element -> String -> Maybe n
forall a. Read a => Element -> String -> Maybe a
`readAttrM` String
"v-hanging"
  , fontDataOverlinePos :: Maybe n
fontDataOverlinePos            = Element
fontface Element -> String -> Maybe n
forall a. Read a => Element -> String -> Maybe a
`readAttrM` String
"overline-position"
  , fontDataOverlineThickness :: Maybe n
fontDataOverlineThickness      = Element
fontface Element -> String -> Maybe n
forall a. Read a => Element -> String -> Maybe a
`readAttrM` String
"overline-thickness"
  , fontDataStrikethroughPos :: Maybe n
fontDataStrikethroughPos       = Element
fontface Element -> String -> Maybe n
forall a. Read a => Element -> String -> Maybe a
`readAttrM` String
"strikethrough-position"
  , fontDataStrikethroughThickness :: Maybe n
fontDataStrikethroughThickness = Element
fontface Element -> String -> Maybe n
forall a. Read a => Element -> String -> Maybe a
`readAttrM` String
"strikethrough-thickness"
  }
  where
    findAttr' :: String -> Element -> Maybe String
findAttr' String
attr Element
e | Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
uq = Maybe String
uq
                     | Bool
otherwise = Maybe String
q
      where uq :: Maybe String
uq = QName -> Element -> Maybe String
findAttr (String -> QName
unqual String
attr) Element
e
            q :: Maybe String
q  = QName -> Element -> Maybe String
findAttr (String -> QName
qTag String
attr) Element
e

    readAttr :: (Read a) => Element -> String -> a
    readAttr :: Element -> String -> a
readAttr Element
e String
attr = Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe a -> a) -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$ (String -> a) -> Maybe String -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> a
forall a. Read a => String -> a
read (Maybe String -> Maybe a) -> Maybe String -> Maybe a
forall a b. (a -> b) -> a -> b
$ String -> Element -> Maybe String
findAttr' String
attr Element
e

    readAttrM :: (Read a) => Element -> String -> Maybe a
    readAttrM :: Element -> String -> Maybe a
readAttrM Element
e String
attr = (String -> a) -> Maybe String -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> a
forall a. Read a => String -> a
read (Maybe String -> Maybe a) -> Maybe String -> Maybe a
forall a b. (a -> b) -> a -> b
$ String -> Element -> Maybe String
findAttr' String
attr Element
e

    -- | @readString e a d@ : @e@ element to read from; @a@ attribute to read; @d@ default value.
    readString :: Element -> String -> String -> String
    readString :: Element -> String -> String -> String
readString Element
e String
attr String
d = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
d (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> Element -> Maybe String
findAttr' String
attr Element
e

    readStringM :: Element -> String -> Maybe String
    readStringM :: Element -> String -> Maybe String
readStringM Element
e String
attr = String -> Element -> Maybe String
findAttr' String
attr Element
e

    fontHadv :: n
fontHadv = n -> Maybe n -> n
forall a. a -> Maybe a -> a
fromMaybe (([n]
forall n. Read n => [n]
parsedBBox[n] -> Int -> n
forall a. [a] -> Int -> a
!!Int
2) n -> n -> n
forall a. Num a => a -> a -> a
- ([n]
forall n. Read n => [n]
parsedBBox[n] -> Int -> n
forall a. [a] -> Int -> a
!!Int
0)) -- BBox is used if there is no "horiz-adv-x" attribute
                         ((String -> n) -> Maybe String -> Maybe n
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> n
forall a. Read a => String -> a
read (String -> Element -> Maybe String
findAttr' String
"horiz-adv-x" Element
fontElement) )
    fontface :: Element
fontface | Maybe Element -> Bool
forall a. Maybe a -> Bool
isJust Maybe Element
uq = Maybe Element -> Element
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Element
uq
             | Maybe Element -> Bool
forall a. Maybe a -> Bool
isJust Maybe Element
q  = Maybe Element -> Element
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Element
q
             | Bool
otherwise = String -> Element
forall a. HasCallStack => String -> a
error String
"no fontface tag found in SVGFonts library" -- there is always a font-face node
      where uq :: Maybe Element
uq = QName -> Element -> Maybe Element
findElement (String -> QName
unqual String
"font-face") Element
fontElement
            q :: Maybe Element
q  = QName -> Element -> Maybe Element
findElement (String -> QName
qTag   String
"font-face") Element
fontElement
    bbox :: String
bbox     = Element -> String -> String -> String
readString Element
fontface String
"bbox" String
""
    parsedBBox :: Read n => [n]
    parsedBBox :: [n]
parsedBBox = (String -> n) -> [String] -> [n]
forall a b. (a -> b) -> [a] -> [b]
map String -> n
forall a. Read a => String -> a
read ([String] -> [n]) -> [String] -> [n]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> [String]
forall a. (a -> Bool) -> [a] -> [[a]]
splitWhen Char -> Bool
isSpace String
bbox

    glyphElements :: [Element]
glyphElements = QName -> Element -> [Element]
findChildren (String -> QName
unqual String
"glyph") Element
fontElement [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++
                    QName -> Element -> [Element]
findChildren (String -> QName
qTag String
"glyph") Element
fontElement
    kernings :: [Element]
kernings      = QName -> Element -> [Element]
findChildren (String -> QName
unqual String
"hkern") Element
fontElement [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++
                    QName -> Element -> [Element]
findChildren (String -> QName
qTag String
"hkern") Element
fontElement

    glyphs :: [(String, (String, n, String))]
glyphs = (Element -> (String, (String, n, String)))
-> [Element] -> [(String, (String, n, String))]
forall a b. (a -> b) -> [a] -> [b]
map Element -> (String, (String, n, String))
glyphsWithDefaults [Element]
glyphElements

    -- monospaced fonts sometimes don't have a "horiz-adv-x="-value , replace with "horiz-adv-x=" in <font>
    glyphsWithDefaults :: Element -> (String, (String, n, String))
glyphsWithDefaults Element
g =
      (String -> String
charsFromFullName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
gname (String -> Element -> Maybe String
findAttr' String
"unicode" Element
g), -- there is always a name or unicode
        (
          String
gname,
          n -> Maybe n -> n
forall a. a -> Maybe a -> a
fromMaybe n
fontHadv ((String -> n) -> Maybe String -> Maybe n
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> n
forall a. Read a => String -> a
read (String -> Element -> Maybe String
findAttr' String
"horiz-adv-x" Element
g)),
          String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (String -> Element -> Maybe String
findAttr' String
"d" Element
g)
        )
      )
      where gname :: String
gname = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (String -> Element -> Maybe String
findAttr' String
"glyph-name" Element
g)

    u1s :: [String]
u1s         = (Maybe String -> String) -> [Maybe String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"") ([Maybe String] -> [String]) -> [Maybe String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Element -> Maybe String) -> [Element] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Element -> Maybe String
findAttr' String
"u1")  [Element]
kernings
    u2s :: [String]
u2s         = (Maybe String -> String) -> [Maybe String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"") ([Maybe String] -> [String]) -> [Maybe String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Element -> Maybe String) -> [Element] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Element -> Maybe String
findAttr' String
"u2")  [Element]
kernings
    g1s :: [String]
g1s         = (Maybe String -> String) -> [Maybe String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"") ([Maybe String] -> [String]) -> [Maybe String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Element -> Maybe String) -> [Element] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Element -> Maybe String
findAttr' String
"g1")  [Element]
kernings
    g2s :: [String]
g2s         = (Maybe String -> String) -> [Maybe String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"") ([Maybe String] -> [String]) -> [Maybe String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Element -> Maybe String) -> [Element] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Element -> Maybe String
findAttr' String
"g2")  [Element]
kernings
    ks :: [String]
ks          = (Maybe String -> String) -> [Maybe String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"") ([Maybe String] -> [String]) -> [Maybe String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Element -> Maybe String) -> [Element] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Element -> Maybe String
findAttr' String
"k")   [Element]
kernings
    kAr :: Vector n
kAr     = [n] -> Vector n
forall a. [a] -> Vector a
V.fromList ((String -> n) -> [String] -> [n]
forall a b. (a -> b) -> [a] -> [b]
map String -> n
forall a. Read a => String -> a
read [String]
ks)

    rawKerns :: [(String, [String], [String], [String], [String])]
rawKerns = (Element -> (String, [String], [String], [String], [String]))
-> [Element] -> [(String, [String], [String], [String], [String])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Element -> (String, [String], [String], [String], [String])
getRawKern [Element]
kernings
    getRawKern :: Element -> (String, [String], [String], [String], [String])
getRawKern Element
kerning =
      let u1 :: [String]
u1 = (Char -> Bool) -> String -> [String]
forall a. (a -> Bool) -> [a] -> [[a]]
splitWhen (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
',') (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> Element -> Maybe String
findAttr' String
"u1" (Element -> Maybe String) -> Element -> Maybe String
forall a b. (a -> b) -> a -> b
$ Element
kerning
          u2 :: [String]
u2 = (Char -> Bool) -> String -> [String]
forall a. (a -> Bool) -> [a] -> [[a]]
splitWhen (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
',') (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> Element -> Maybe String
findAttr' String
"u2" (Element -> Maybe String) -> Element -> Maybe String
forall a b. (a -> b) -> a -> b
$ Element
kerning
          g1 :: [String]
g1 = (Char -> Bool) -> String -> [String]
forall a. (a -> Bool) -> [a] -> [[a]]
splitWhen (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
',') (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> Element -> Maybe String
findAttr' String
"g1" (Element -> Maybe String) -> Element -> Maybe String
forall a b. (a -> b) -> a -> b
$ Element
kerning
          g2 :: [String]
g2 = (Char -> Bool) -> String -> [String]
forall a. (a -> Bool) -> [a] -> [[a]]
splitWhen (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
',') (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> Element -> Maybe String
findAttr' String
"g2" (Element -> Maybe String) -> Element -> Maybe String
forall a b. (a -> b) -> a -> b
$ Element
kerning
          k :: String
k  =                     String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> Element -> Maybe String
findAttr' String
"k"  (Element -> Maybe String) -> Element -> Maybe String
forall a b. (a -> b) -> a -> b
$ Element
kerning
      in (String
k, [String]
g1, [String]
g2, [String]
u1, [String]
u2)

    transformChars :: [String] -> Map String [a]
transformChars [String]
chars = [(String, [a])] -> Map String [a]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(String, [a])] -> Map String [a])
-> [(String, [a])] -> Map String [a]
forall a b. (a -> b) -> a -> b
$ ((String, [a]) -> (String, [a]))
-> [(String, [a])] -> [(String, [a])]
forall a b. (a -> b) -> [a] -> [b]
map (String, [a]) -> (String, [a])
forall b. (String, b) -> (String, b)
ch ([(String, [a])] -> [(String, [a])])
-> [(String, [a])] -> [(String, [a])]
forall a b. (a -> b) -> a -> b
$ [(String, [a])] -> [(String, [a])]
forall a a. Eq a => [(a, [a])] -> [(a, [a])]
multiSet ([(String, [a])] -> [(String, [a])])
-> [(String, [a])] -> [(String, [a])]
forall a b. (a -> b) -> a -> b
$
                                          ((String, a) -> (String, [a])) -> [(String, a)] -> [(String, [a])]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
x,a
y) -> (String
x,[a
y])) ([(String, a)] -> [(String, [a])])
-> [(String, a)] -> [(String, [a])]
forall a b. (a -> b) -> a -> b
$ ((String, a) -> String) -> [(String, a)] -> [(String, a)]
forall a t. Ord a => (t -> a) -> [t] -> [t]
sort (String, a) -> String
forall a b. (a, b) -> a
fst ([(String, a)] -> [(String, a)]) -> [(String, a)] -> [(String, a)]
forall a b. (a -> b) -> a -> b
$ [[(String, a)]] -> [(String, a)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(String, a)]] -> [(String, a)])
-> [[(String, a)]] -> [(String, a)]
forall a b. (a -> b) -> a -> b
$ [String] -> [[(String, a)]]
forall b. (Num b, Enum b) => [String] -> [[(String, b)]]
indexList [String]
chars
    ch :: (String, b) -> (String, b)
ch (String
x,b
y) | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
x = (String
"",b
y)
             | Bool
otherwise = (String
x,b
y)

    indexList :: [String] -> [[(String, b)]]
indexList [String]
u = [[String]] -> [[(String, b)]]
forall b a. (Num b, Enum b) => [[a]] -> [[(a, b)]]
addIndex ((String -> [String]) -> [String] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Bool) -> String -> [String]
forall a. (a -> Bool) -> [a] -> [[a]]
splitWhen Char -> Bool
isColon) [String]
u) -- ie ["aa,b","c,d"] to [["aa","b"],["c","d"]]
    isColon :: Char -> Bool
isColon = (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',')                             -- to [("aa",0),("b",0)],[("c",1), ("d",1)]

    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))



type SvgGlyphs n = Map.Map String (String, n, String)
-- ^ \[ (unicode, (glyph_name, horiz_advance, ds)) \]

-- | Horizontal advance of a character consisting of its width and spacing, extracted out of the font data
horizontalAdvance :: String -> FontData n -> n
horizontalAdvance :: String -> FontData n -> n
horizontalAdvance String
ch FontData n
fontD
    | Maybe (String, n, String) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (String, n, String)
char = (String, n, String) -> n
forall a b c. (a, b, c) -> b
sel2 (Maybe (String, n, String) -> (String, n, String)
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (String, n, String)
char)
    | Bool
otherwise   = FontData n -> n
forall n. FontData n -> n
fontDataHorizontalAdvance FontData n
fontD
  where
    char :: Maybe (String, n, String)
char = (String
-> Map String (String, n, String) -> Maybe (String, n, String)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
ch (FontData n -> Map String (String, n, String)
forall n. FontData n -> SvgGlyphs n
fontDataGlyphs FontData n
fontD))
    sel2 :: (a, b, c) -> b
sel2 (a
_, b
x, c
_) = b
x

-- | 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
data Kern n = Kern
  { Kern n -> Map String [Int]
kernU1S :: Map.Map String [Int]
  , Kern n -> Map String [Int]
kernU2S :: Map.Map String [Int]
  , Kern n -> Map String [Int]
kernG1S :: Map.Map String [Int]
  , Kern n -> Map String [Int]
kernG2S :: Map.Map String [Int]
  , Kern n -> Vector n
kernK   :: V.Vector n
  } deriving (Int -> Kern n -> String -> String
[Kern n] -> String -> String
Kern n -> String
(Int -> Kern n -> String -> String)
-> (Kern n -> String)
-> ([Kern n] -> String -> String)
-> Show (Kern n)
forall n. Show n => Int -> Kern n -> String -> String
forall n. Show n => [Kern n] -> String -> String
forall n. Show n => Kern n -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Kern n] -> String -> String
$cshowList :: forall n. Show n => [Kern n] -> String -> String
show :: Kern n -> String
$cshow :: forall n. Show n => Kern n -> String
showsPrec :: Int -> Kern n -> String -> String
$cshowsPrec :: forall n. Show n => Int -> Kern n -> String -> String
Show, (forall x. Kern n -> Rep (Kern n) x)
-> (forall x. Rep (Kern n) x -> Kern n) -> Generic (Kern n)
forall x. Rep (Kern n) x -> Kern n
forall x. Kern n -> Rep (Kern n) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall n x. Rep (Kern n) x -> Kern n
forall n x. Kern n -> Rep (Kern n) x
$cto :: forall n x. Rep (Kern n) x -> Kern n
$cfrom :: forall n x. Kern n -> Rep (Kern n) x
Generic)

instance Serialize n => Serialize (Kern n)

-- | Change the horizontal advance of two consective chars (kerning)
kernAdvance :: RealFloat n => String -> String -> Kern n -> Bool -> n
kernAdvance :: String -> String -> Kern n -> Bool -> n
kernAdvance String
ch0 String
ch1 Kern n
kern Bool
u |     Bool
u Bool -> Bool -> Bool
&& Bool -> Bool
not ([Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
s0) = (Kern n -> Vector n
forall n. Kern n -> Vector n
kernK Kern n
kern) Vector n -> Int -> n
forall a. Vector a -> Int -> a
V.! ([Int] -> Int
forall a. [a] -> a
head [Int]
s0)
                           | Bool -> Bool
not Bool
u Bool -> Bool -> Bool
&& Bool -> Bool
not ([Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
s1) = (Kern n -> Vector n
forall n. Kern n -> Vector n
kernK Kern n
kern) Vector n -> Int -> n
forall a. Vector a -> Int -> a
V.! ([Int] -> Int
forall a. [a] -> a
head [Int]
s1)
                           | Bool
otherwise = n
0
  where s0 :: [Int]
s0 = [Int] -> [Int] -> [Int]
forall a. Eq a => [a] -> [a] -> [a]
intersect ((Kern n -> Map String [Int]) -> String -> [Int]
forall k a. Ord k => (Kern n -> Map k [a]) -> k -> [a]
s Kern n -> Map String [Int]
forall n. Kern n -> Map String [Int]
kernU1S String
ch0) ((Kern n -> Map String [Int]) -> String -> [Int]
forall k a. Ord k => (Kern n -> Map k [a]) -> k -> [a]
s Kern n -> Map String [Int]
forall n. Kern n -> Map String [Int]
kernU2S String
ch1)
        s1 :: [Int]
s1 = [Int] -> [Int] -> [Int]
forall a. Eq a => [a] -> [a] -> [a]
intersect ((Kern n -> Map String [Int]) -> String -> [Int]
forall k a. Ord k => (Kern n -> Map k [a]) -> k -> [a]
s Kern n -> Map String [Int]
forall n. Kern n -> Map String [Int]
kernG1S String
ch0) ((Kern n -> Map String [Int]) -> String -> [Int]
forall k a. Ord k => (Kern n -> Map k [a]) -> k -> [a]
s Kern n -> Map String [Int]
forall n. Kern n -> Map String [Int]
kernG2S String
ch1)
        s :: (Kern n -> Map k [a]) -> k -> [a]
s Kern n -> Map k [a]
sel k
ch = [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Maybe [a] -> [[a]]
forall a. Maybe a -> [a]
maybeToList (k -> Map k [a] -> Maybe [a]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
ch (Kern n -> Map k [a]
sel Kern n
kern)))

-- > import Graphics.SVGFonts.ReadFont
-- > linL <- loadDataFont "fonts/LinLibertine.svg"
-- > textWH0 = (rect 8 1) # alignBL <> ((textSVG_ $ TextOpts "SPACES" linL 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." linL 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." linL 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" linL INSIDE_W KERN False 3 1 )
-- >              # fc blue # lc blue # bg lightgrey # fillRule EvenOdd ) # alignBL
-- > textW1 = (rect 10 1) # alignBL <> ( (textSVG_ $ TextOpts "HEADLINE" linL 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" linL 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" linL 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" linL INSIDE_H HADV False 10 1 )
-- >              # fc blue # lc blue # bg lightgrey # fillRule EvenOdd

-- > import Graphics.SVGFonts.ReadFont
-- > textKern = (textSVG_ $ TextOpts "AVENGERS" linL 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 n -> n
bbox_dy FontData n
fontData = ([n]
bbox[n] -> Int -> n
forall a. [a] -> Int -> a
!!Int
3) n -> n -> n
forall a. Num a => a -> a -> a
- ([n]
bbox[n] -> Int -> n
forall a. [a] -> Int -> a
!!Int
1)
  where bbox :: [n]
bbox = FontData n -> [n]
forall n. FontData n -> [n]
fontDataBoundingBox FontData n
fontData -- bbox = [lowest x, lowest y, highest x, highest y]

-- | Lowest x-value of bounding box
bbox_lx :: FontData n -> n
bbox_lx :: FontData n -> n
bbox_lx FontData n
fontData   = (FontData n -> [n]
forall n. FontData n -> [n]
fontDataBoundingBox FontData n
fontData) [n] -> Int -> n
forall a. [a] -> Int -> a
!! Int
0

-- | Lowest y-value of bounding box
bbox_ly :: FontData n -> n
bbox_ly :: FontData n -> n
bbox_ly FontData n
fontData   = (FontData n -> [n]
forall n. FontData n -> [n]
fontDataBoundingBox FontData n
fontData) [n] -> Int -> n
forall a. [a] -> Int -> a
!! Int
1

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

-- | Thickness of the underline bar
underlineThickness :: FontData n -> n
underlineThickness :: FontData n -> n
underlineThickness FontData n
fontData = FontData n -> n
forall n. FontData n -> n
fontDataUnderlineThickness FontData n
fontData

-- | A map of unicode characters to outline paths.
type OutlineMap n = Map.Map String (Path V2 n)

-- | A map of unicode characters to parsing errors.
type ErrorMap = Map.Map String String

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

-- | Compute a font's outline map, collecting errors in a second map.
outlineMap :: RealFloat n => FontData n -> (OutlineMap n, ErrorMap)
outlineMap :: FontData n -> (OutlineMap n, ErrorMap)
outlineMap FontData n
fontData =
    ( [(String, Path V2 n)] -> OutlineMap n
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String
ch, Path V2 n
outl) | (String
ch, Right Path V2 n
outl) <- [(String, Either String (Path V2 n))]
allOutlines]
    , [(String, String)] -> ErrorMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String
ch, String
err)  | (String
ch, Left String
err)   <- [(String, Either String (Path V2 n))]
allOutlines]
    )
  where
    allUnicodes :: [String]
allUnicodes = Map String (String, n, String) -> [String]
forall k a. Map k a -> [k]
Map.keys (FontData n -> Map String (String, n, String)
forall n. FontData n -> SvgGlyphs n
fontDataGlyphs FontData n
fontData)
    outlines :: String -> Either String (Path V2 n)
outlines String
ch = do
        [PathCommand n]
cmds <- String
-> Map String (String, n, String) -> Either String [PathCommand n]
forall n.
RealFloat n =>
String -> SvgGlyphs n -> Either String [PathCommand n]
commands String
ch (FontData n -> Map String (String, n, String)
forall n. FontData n -> SvgGlyphs n
fontDataGlyphs FontData n
fontData)
        Path V2 n -> Either String (Path V2 n)
forall (m :: * -> *) a. Monad m => a -> m a
return (Path V2 n -> Either String (Path V2 n))
-> Path V2 n -> Either String (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]
-> [Segment Closed V2 n] -> V2 n -> V2 n -> V2 n -> [Path V2 n]
forall n.
RealFloat n =>
[PathCommand n]
-> [Segment Closed V2 n] -> V2 n -> V2 n -> V2 n -> [Path V2 n]
commandsToTrails [PathCommand n]
cmds [] V2 n
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero V2 n
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero V2 n
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero
    allOutlines :: [(String, Either String (Path V2 n))]
allOutlines = [(String
ch, String -> Either String (Path V2 n)
outlines String
ch) | String
ch <- [String]
allUnicodes]

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

-- | Read font data from font file, and compute its outline map.
loadFont :: (Read n, RealFloat n) => FilePath -> IO (PreparedFont n)
loadFont :: String -> IO (PreparedFont n)
loadFont String
filename = do
  String
s <- String -> IO String
readFile String
filename
  let
    basename :: String
basename = [String] -> String
forall a. [a] -> a
last ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
init ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((String -> [String]) -> [String] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"/") (String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"." String
filename))
    (String
errors, PreparedFont n
font) = String -> String -> (String, PreparedFont n)
forall s n.
(XmlSource s, Read n, RealFloat n) =>
String -> s -> (String, PreparedFont n)
loadFont' String
basename String
s
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
errors String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"") (String -> IO ()
putStrLn String
errors)
  PreparedFont n -> IO (PreparedFont n)
forall (m :: * -> *) a. Monad m => a -> m a
return PreparedFont n
font

-- | Read font data from an XmlSource, and compute its outline map.
loadFont' :: (XmlSource s, Read n, RealFloat n) => String -> s -> (String, PreparedFont n)
loadFont' :: String -> s -> (String, PreparedFont n)
loadFont' String
basename s
s =
  let
    fontData :: FontData n
fontData = String -> s -> FontData n
forall s n.
(XmlSource s, Read n, RealFloat n) =>
String -> s -> FontData n
parseFont String
basename s
s
    (PreparedFont n
font, ErrorMap
errs) = FontData n -> (PreparedFont n, ErrorMap)
forall n. RealFloat n => FontData n -> (PreparedFont n, ErrorMap)
prepareFont FontData n
fontData
    errors :: String
errors = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
ch, String
err) -> String
"error parsing character '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ch String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"': " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err) (ErrorMap -> [(String, String)]
forall k a. Map k a -> [(k, a)]
Map.toList ErrorMap
errs)
  in
    (String
errors, PreparedFont n
font)

commandsToTrails ::RealFloat n => [PathCommand n] -> [Segment Closed V2 n] -> V2 n -> V2 n -> V2 n -> [Path V2 n]
commandsToTrails :: [PathCommand n]
-> [Segment Closed V2 n] -> V2 n -> V2 n -> V2 n -> [Path V2 n]
commandsToTrails [] [Segment Closed V2 n]
_ V2 n
_ V2 n
_ V2 n
_ = []
commandsToTrails (PathCommand n
c:[PathCommand n]
cs) [Segment Closed V2 n]
segments V2 n
l V2 n
lastContr V2 n
beginPoint -- l is the endpoint of the last segment
      | Maybe (Segment Closed V2 n) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Segment Closed V2 n)
nextSegment =
        (Vn (Path V2 n) -> Path V2 n -> Path V2 n
forall t. Transformable t => Vn t -> t -> t
translate Vn (Path V2 n)
V2 n
beginPoint (Trail V2 n -> Path V2 n
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Trail v n -> Path v n
pathFromTrail (Trail V2 n -> Path V2 n)
-> (Trail' Line V2 n -> Trail V2 n)
-> Trail' Line V2 n
-> Path V2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trail' Loop V2 n -> Trail V2 n
forall l (v :: * -> *) n. Trail' l v n -> Trail v n
wrapTrail  (Trail' Loop V2 n -> Trail V2 n)
-> (Trail' Line V2 n -> Trail' Loop V2 n)
-> Trail' Line V2 n
-> Trail V2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trail' Line V2 n -> Trail' Loop V2 n
forall (v :: * -> *) n. Trail' Line v n -> Trail' Loop v n
closeLine (Trail' Line V2 n -> Path V2 n) -> Trail' Line V2 n -> Path V2 n
forall a b. (a -> b) -> a -> b
$ [Segment Closed V2 n] -> Trail' Line V2 n
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
[Segment Closed v n] -> Trail' Line v n
lineFromSegments [Segment Closed V2 n]
segments)) Path V2 n -> [Path V2 n] -> [Path V2 n]
forall a. a -> [a] -> [a]
:
                  ( [PathCommand n]
-> [Segment Closed V2 n] -> V2 n -> V2 n -> V2 n -> [Path V2 n]
forall n.
RealFloat n =>
[PathCommand n]
-> [Segment Closed V2 n] -> V2 n -> V2 n -> V2 n -> [Path V2 n]
commandsToTrails [PathCommand n]
cs [] (V2 n
l V2 n -> V2 n -> V2 n
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ V2 n
offs) (PathCommand n -> V2 n
contr PathCommand n
c) (PathCommand n -> V2 n
beginP PathCommand n
c) ) -- one outline completed
      | Bool
otherwise = [PathCommand n]
-> [Segment Closed V2 n] -> V2 n -> V2 n -> V2 n -> [Path V2 n]
forall n.
RealFloat n =>
[PathCommand n]
-> [Segment Closed V2 n] -> V2 n -> V2 n -> V2 n -> [Path V2 n]
commandsToTrails [PathCommand n]
cs ([Segment Closed V2 n]
segments [Segment Closed V2 n]
-> [Segment Closed V2 n] -> [Segment Closed V2 n]
forall a. [a] -> [a] -> [a]
++ [Maybe (Segment Closed V2 n) -> Segment Closed V2 n
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Segment Closed V2 n)
nextSegment])
                                           (V2 n
l V2 n -> V2 n -> V2 n
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ V2 n
offs) (PathCommand n -> V2 n
contr PathCommand n
c) (PathCommand n -> V2 n
beginP PathCommand n
c)   -- work on outline
  where nextSegment :: Maybe (Segment Closed V2 n)
nextSegment = PathCommand n -> Maybe (Segment Closed V2 n)
go PathCommand n
c
        offs :: V2 n
offs | Maybe (Segment Closed V2 n) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Segment Closed V2 n)
nextSegment
               = Segment Closed V2 n -> V2 n
forall (v :: * -> *) n. Segment Closed v n -> v n
segOffset (Maybe (Segment Closed V2 n) -> Segment Closed V2 n
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Segment Closed V2 n)
nextSegment)
             | Bool
otherwise = V2 n
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero
        (n
x0,n
y0) = V2 n -> (n, n)
forall n. V2 n -> (n, n)
unr2 V2 n
offs
        (n
cx,n
cy) = V2 n -> (n, n)
forall n. V2 n -> (n, n)
unr2 V2 n
lastContr -- last control point is always in absolute coordinates
        beginP :: PathCommand n -> V2 n
beginP ( M_abs (n
x,n
y) ) = (n, n) -> V2 n
forall n. (n, n) -> V2 n
r2 (n
x,n
y)
        beginP ( M_rel (n
x,n
y) ) = V2 n
l V2 n -> V2 n -> V2 n
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ (n, n) -> V2 n
forall n. (n, n) -> V2 n
r2 (n
x,n
y)
        beginP PathCommand n
_ = V2 n
beginPoint
        contr :: PathCommand n -> V2 n
contr ( C_abs (n
_x1,n
_y1,n
x2,n
y2,n
x,n
y) ) = (n, n) -> V2 n
forall n. (n, n) -> V2 n
r2 (n
x0n -> n -> n
forall a. Num a => a -> a -> a
+n
x n -> n -> n
forall a. Num a => a -> a -> a
- n
x2, n
y0n -> n -> n
forall a. Num a => a -> a -> a
+n
y n -> n -> n
forall a. Num a => a -> a -> a
- n
y2 ) -- control point of bezier curve
        contr ( C_rel (n
_x1,n
_y1,n
x2,n
y2,n
x,n
y) ) = (n, n) -> V2 n
forall n. (n, n) -> V2 n
r2 (   n
x n -> n -> n
forall a. Num a => a -> a -> a
- n
x2,    n
y n -> n -> n
forall a. Num a => a -> a -> a
- n
y2 )
        contr ( S_abs (n
x2,n
y2,n
x,n
y) )         = (n, n) -> V2 n
forall n. (n, n) -> V2 n
r2 (n
x0n -> n -> n
forall a. Num a => a -> a -> a
+n
x n -> n -> n
forall a. Num a => a -> a -> a
- n
x2, n
y0n -> n -> n
forall a. Num a => a -> a -> a
+n
y n -> n -> n
forall a. Num a => a -> a -> a
- n
y2 )
        contr ( S_rel (n
x2,n
y2,n
x,n
y) )         = (n, n) -> V2 n
forall n. (n, n) -> V2 n
r2 (   n
x n -> n -> n
forall a. Num a => a -> a -> a
- n
x2,    n
y n -> n -> n
forall a. Num a => a -> a -> a
- n
y2 )
        contr ( Q_abs (n
x1,n
y1,n
x,n
y) ) = (n, n) -> V2 n
forall n. (n, n) -> V2 n
r2 (n
x0n -> n -> n
forall a. Num a => a -> a -> a
+n
x n -> n -> n
forall a. Num a => a -> a -> a
- n
x1, n
y0n -> n -> n
forall a. Num a => a -> a -> a
+n
y n -> n -> n
forall a. Num a => a -> a -> a
- n
y1 )
        contr ( Q_rel (n
x1,n
y1,n
x,n
y) ) = (n, n) -> V2 n
forall n. (n, n) -> V2 n
r2 (   n
x n -> n -> n
forall a. Num a => a -> a -> a
- n
x1,    n
y n -> n -> n
forall a. Num a => a -> a -> a
- n
y1 )
        contr ( T_abs (n
_x,n
_y) )     = (n, n) -> V2 n
forall n. (n, n) -> V2 n
r2 (n
2n -> n -> n
forall a. Num a => a -> a -> a
*n
x0 n -> n -> n
forall a. Num a => a -> a -> a
- n
cx, n
2n -> n -> n
forall a. Num a => a -> a -> a
*n
y0 n -> n -> n
forall a. Num a => a -> a -> a
- n
cy )
        contr ( T_rel (n
x,n
y) )       = (n, n) -> V2 n
forall n. (n, n) -> V2 n
r2 (   n
x n -> n -> n
forall a. Num a => a -> a -> a
- n
cx,    n
y n -> n -> n
forall a. Num a => a -> a -> a
- n
cy )
        contr ( L_abs (n
_x,n
_y) ) = (n, n) -> V2 n
forall n. (n, n) -> V2 n
r2 (n
x0, n
y0)
        contr ( L_rel (n
_x,n
_y) ) = (n, n) -> V2 n
forall n. (n, n) -> V2 n
r2 ( n
0,  n
0)
        contr ( M_abs (n
_x,n
_y) ) = (n, n) -> V2 n
forall n. (n, n) -> V2 n
r2 (n
x0, n
y0)
        contr ( M_rel (n
_x,n
_y) ) = (n, n) -> V2 n
forall n. (n, n) -> V2 n
r2 ( n
0,  n
0)
        contr ( H_abs n
_x ) = (n, n) -> V2 n
forall n. (n, n) -> V2 n
r2 (n
x0, n
y0)
        contr ( H_rel n
_x ) = (n, n) -> V2 n
forall n. (n, n) -> V2 n
r2 ( n
0, n
y0)
        contr ( V_abs n
_y ) = (n, n) -> V2 n
forall n. (n, n) -> V2 n
r2 (n
x0, n
y0)
        contr ( V_rel n
_y ) = (n, n) -> V2 n
forall n. (n, n) -> V2 n
r2 (n
x0,  n
0)
        contr ( PathCommand n
Z ) = (n, n) -> V2 n
forall n. (n, n) -> V2 n
r2 (n
0, n
0) -- to get rid of warnings
        contr ( PathCommand n
A_abs ) = (n, n) -> V2 n
forall n. (n, n) -> V2 n
r2 (n
0, n
0) -- to get rid of warnings
        contr ( PathCommand n
A_rel ) = (n, n) -> V2 n
forall n. (n, n) -> V2 n
r2 (n
0, n
0) -- to get rid of warnings

        straight' :: (n, n) -> Segment Closed V2 n
straight' = V2 n -> Segment Closed V2 n
forall (v :: * -> *) n. v n -> Segment Closed v n
straight (V2 n -> Segment Closed V2 n)
-> ((n, n) -> V2 n) -> (n, n) -> Segment Closed V2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n, n) -> V2 n
forall n. (n, n) -> V2 n
r2
        bezier3' :: (n, n) -> (n, n) -> (n, n) -> Segment Closed V2 n
bezier3' (n, n)
point1 (n, n)
point2 (n, n)
point3 = V2 n -> V2 n -> V2 n -> Segment Closed V2 n
forall (v :: * -> *) n. v n -> v n -> v n -> Segment Closed v n
bezier3 ((n, n) -> V2 n
forall n. (n, n) -> V2 n
r2 (n, n)
point1) ((n, n) -> V2 n
forall n. (n, n) -> V2 n
r2 (n, n)
point2) ((n, n) -> V2 n
forall n. (n, n) -> V2 n
r2 (n, n)
point3)

        go :: PathCommand n -> Maybe (Segment Closed V2 n)
go ( M_abs (n
_x,n
_y) ) = Maybe (Segment Closed V2 n)
forall a. Maybe a
Nothing
        go ( M_rel (n
_x,n
_y) ) = Maybe (Segment Closed V2 n)
forall a. Maybe a
Nothing
        go ( L_abs (n
x,n
y) ) = Segment Closed V2 n -> Maybe (Segment Closed V2 n)
forall a. a -> Maybe a
Just (Segment Closed V2 n -> Maybe (Segment Closed V2 n))
-> Segment Closed V2 n -> Maybe (Segment Closed V2 n)
forall a b. (a -> b) -> a -> b
$ (n, n) -> Segment Closed V2 n
forall n. (n, n) -> Segment Closed V2 n
straight' (n
x0n -> n -> n
forall a. Num a => a -> a -> a
+n
x, n
y0n -> n -> n
forall a. Num a => a -> a -> a
+n
y)
        go ( L_rel (n
x,n
y) ) = Segment Closed V2 n -> Maybe (Segment Closed V2 n)
forall a. a -> Maybe a
Just (Segment Closed V2 n -> Maybe (Segment Closed V2 n))
-> Segment Closed V2 n -> Maybe (Segment Closed V2 n)
forall a b. (a -> b) -> a -> b
$ (n, n) -> Segment Closed V2 n
forall n. (n, n) -> Segment Closed V2 n
straight' (n
x, n
y)
        go ( H_abs n
x) = Segment Closed V2 n -> Maybe (Segment Closed V2 n)
forall a. a -> Maybe a
Just (Segment Closed V2 n -> Maybe (Segment Closed V2 n))
-> Segment Closed V2 n -> Maybe (Segment Closed V2 n)
forall a b. (a -> b) -> a -> b
$ (n, n) -> Segment Closed V2 n
forall n. (n, n) -> Segment Closed V2 n
straight' (n
x0 n -> n -> n
forall a. Num a => a -> a -> a
+ n
x, n
y0)
        go ( H_rel n
x) = Segment Closed V2 n -> Maybe (Segment Closed V2 n)
forall a. a -> Maybe a
Just (Segment Closed V2 n -> Maybe (Segment Closed V2 n))
-> Segment Closed V2 n -> Maybe (Segment Closed V2 n)
forall a b. (a -> b) -> a -> b
$ (n, n) -> Segment Closed V2 n
forall n. (n, n) -> Segment Closed V2 n
straight' (n
x, n
0)
        go ( V_abs n
y) = Segment Closed V2 n -> Maybe (Segment Closed V2 n)
forall a. a -> Maybe a
Just (Segment Closed V2 n -> Maybe (Segment Closed V2 n))
-> Segment Closed V2 n -> Maybe (Segment Closed V2 n)
forall a b. (a -> b) -> a -> b
$ (n, n) -> Segment Closed V2 n
forall n. (n, n) -> Segment Closed V2 n
straight' (n
x0, n
y0 n -> n -> n
forall a. Num a => a -> a -> a
+ n
y)
        go ( V_rel n
y) = Segment Closed V2 n -> Maybe (Segment Closed V2 n)
forall a. a -> Maybe a
Just (Segment Closed V2 n -> Maybe (Segment Closed V2 n))
-> Segment Closed V2 n -> Maybe (Segment Closed V2 n)
forall a b. (a -> b) -> a -> b
$ (n, n) -> Segment Closed V2 n
forall n. (n, n) -> Segment Closed V2 n
straight' (n
0, n
y)
        go ( C_abs (n
x1,n
y1,n
x2,n
y2,n
x,n
y) ) = Segment Closed V2 n -> Maybe (Segment Closed V2 n)
forall a. a -> Maybe a
Just (Segment Closed V2 n -> Maybe (Segment Closed V2 n))
-> Segment Closed V2 n -> Maybe (Segment Closed V2 n)
forall a b. (a -> b) -> a -> b
$ (n, n) -> (n, n) -> (n, n) -> Segment Closed V2 n
forall n. (n, n) -> (n, n) -> (n, n) -> Segment Closed V2 n
bezier3' (n
x0n -> n -> n
forall a. Num a => a -> a -> a
+n
x1, n
y0n -> n -> n
forall a. Num a => a -> a -> a
+n
y1) (n
x0n -> n -> n
forall a. Num a => a -> a -> a
+n
x2,n
y0n -> n -> n
forall a. Num a => a -> a -> a
+n
y2) (n
x0n -> n -> n
forall a. Num a => a -> a -> a
+n
x,n
y0n -> n -> n
forall a. Num a => a -> a -> a
+n
y)
        go ( C_rel (n
x1,n
y1,n
x2,n
y2,n
x,n
y) ) = Segment Closed V2 n -> Maybe (Segment Closed V2 n)
forall a. a -> Maybe a
Just (Segment Closed V2 n -> Maybe (Segment Closed V2 n))
-> Segment Closed V2 n -> Maybe (Segment Closed V2 n)
forall a b. (a -> b) -> a -> b
$ (n, n) -> (n, n) -> (n, n) -> Segment Closed V2 n
forall n. (n, n) -> (n, n) -> (n, n) -> Segment Closed V2 n
bezier3' (n
x1, n
y1) (n
x2, n
y2) (n
x, n
y)
        go ( S_abs (      n
x2,n
y2,n
x,n
y) ) = Segment Closed V2 n -> Maybe (Segment Closed V2 n)
forall a. a -> Maybe a
Just (Segment Closed V2 n -> Maybe (Segment Closed V2 n))
-> Segment Closed V2 n -> Maybe (Segment Closed V2 n)
forall a b. (a -> b) -> a -> b
$ (n, n) -> (n, n) -> (n, n) -> Segment Closed V2 n
forall n. (n, n) -> (n, n) -> (n, n) -> Segment Closed V2 n
bezier3' (n
cx, n
cy) (n
x0n -> n -> n
forall a. Num a => a -> a -> a
+n
x2, n
y0n -> n -> n
forall a. Num a => a -> a -> a
+n
y2) (n
x0n -> n -> n
forall a. Num a => a -> a -> a
+n
x, n
y0n -> n -> n
forall a. Num a => a -> a -> a
+n
y)
        go ( S_rel (      n
x2,n
y2,n
x,n
y) ) = Segment Closed V2 n -> Maybe (Segment Closed V2 n)
forall a. a -> Maybe a
Just (Segment Closed V2 n -> Maybe (Segment Closed V2 n))
-> Segment Closed V2 n -> Maybe (Segment Closed V2 n)
forall a b. (a -> b) -> a -> b
$ (n, n) -> (n, n) -> (n, n) -> Segment Closed V2 n
forall n. (n, n) -> (n, n) -> (n, n) -> Segment Closed V2 n
bezier3' (n
cx, n
cy) (n
x2, n
y2) (n
x, n
y)
        go ( Q_abs (n
x1,n
y1,n
x,n
y) ) = Segment Closed V2 n -> Maybe (Segment Closed V2 n)
forall a. a -> Maybe a
Just (Segment Closed V2 n -> Maybe (Segment Closed V2 n))
-> Segment Closed V2 n -> Maybe (Segment Closed V2 n)
forall a b. (a -> b) -> a -> b
$ (n, n) -> (n, n) -> (n, n) -> Segment Closed V2 n
forall n. (n, n) -> (n, n) -> (n, n) -> Segment Closed V2 n
bezier3' (n
x0 n -> n -> n
forall a. Num a => a -> a -> a
+ n
x1, n
y0 n -> n -> n
forall a. Num a => a -> a -> a
+ n
y1) (n
x0 n -> n -> n
forall a. Num a => a -> a -> a
+ n
x, n
y0 n -> n -> n
forall a. Num a => a -> a -> a
+ n
y) (n
x0 n -> n -> n
forall a. Num a => a -> a -> a
+ n
x, n
y0 n -> n -> n
forall a. Num a => a -> a -> a
+ n
y)
        go ( Q_rel (n
x1,n
y1,n
x,n
y) ) = Segment Closed V2 n -> Maybe (Segment Closed V2 n)
forall a. a -> Maybe a
Just (Segment Closed V2 n -> Maybe (Segment Closed V2 n))
-> Segment Closed V2 n -> Maybe (Segment Closed V2 n)
forall a b. (a -> b) -> a -> b
$ (n, n) -> (n, n) -> (n, n) -> Segment Closed V2 n
forall n. (n, n) -> (n, n) -> (n, n) -> Segment Closed V2 n
bezier3' (n
x1, n
y1) (n
x, n
y) (n
x, n
y)
        go ( T_abs (n
x,n
y) ) = Segment Closed V2 n -> Maybe (Segment Closed V2 n)
forall a. a -> Maybe a
Just (Segment Closed V2 n -> Maybe (Segment Closed V2 n))
-> Segment Closed V2 n -> Maybe (Segment Closed V2 n)
forall a b. (a -> b) -> a -> b
$ (n, n) -> (n, n) -> (n, n) -> Segment Closed V2 n
forall n. (n, n) -> (n, n) -> (n, n) -> Segment Closed V2 n
bezier3' (n
cx, n
cy) (n
x0 n -> n -> n
forall a. Num a => a -> a -> a
+ n
x, n
y0 n -> n -> n
forall a. Num a => a -> a -> a
+ n
y) (n
x0 n -> n -> n
forall a. Num a => a -> a -> a
+ n
x, n
y0 n -> n -> n
forall a. Num a => a -> a -> a
+ n
y)
        go ( T_rel (n
x,n
y) ) = Segment Closed V2 n -> Maybe (Segment Closed V2 n)
forall a. a -> Maybe a
Just (Segment Closed V2 n -> Maybe (Segment Closed V2 n))
-> Segment Closed V2 n -> Maybe (Segment Closed V2 n)
forall a b. (a -> b) -> a -> b
$ (n, n) -> (n, n) -> (n, n) -> Segment Closed V2 n
forall n. (n, n) -> (n, n) -> (n, n) -> Segment Closed V2 n
bezier3' (n
cx, n
cy) (n
x, n
y) (n
x, n
y)
        go ( PathCommand n
Z ) = Maybe (Segment Closed V2 n)
forall a. Maybe a
Nothing
        go ( PathCommand n
A_abs ) = Maybe (Segment Closed V2 n)
forall a. Maybe a
Nothing
        go ( PathCommand n
A_rel ) = Maybe (Segment Closed V2 n)
forall a. Maybe a
Nothing

commands :: RealFloat n => String -> SvgGlyphs n -> Either String [PathCommand n]
commands :: String -> SvgGlyphs n -> Either String [PathCommand n]
commands String
ch SvgGlyphs n
glyph = case String -> SvgGlyphs n -> Maybe (String, n, String)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
ch SvgGlyphs n
glyph of
    Just (String, n, String)
e -> String -> Either String [PathCommand n]
forall n. Fractional n => String -> Either String [PathCommand n]
pathFromString ((String, n, String) -> String
forall a b c. (a, b, c) -> c
sel3 (String, n, String)
e)
    Maybe (String, n, String)
Nothing      -> [PathCommand n] -> Either String [PathCommand n]
forall a b. b -> Either a b
Right []
  where
    sel3 :: (a, b, c) -> c
sel3 (a
_, b
_, c
x) = c
x