module Graphics.SVGFonts.ReadFont
where
import Data.Char (isSpace)
import Data.Default.Class
import Data.List (intersect,sortBy)
import Data.List.Split (splitOn, splitWhen)
import Data.Maybe (fromMaybe, fromJust, isJust, isNothing, maybeToList, catMaybes)
import qualified Data.Map as Map
import qualified Data.Text as T
import Data.Tuple.Select
import Data.Vector (Vector)
import Data.VectorSpace
import Diagrams.Path
import Diagrams.Segment
import Diagrams.TwoD.Types
import Diagrams.Prelude
import qualified Data.Vector as V
import Graphics.SVGFonts.CharReference (charsFromFullName, characterStrings)
import Graphics.SVGFonts.ReadPath (pathFromString, PathCommand(..))
import Paths_SVGFonts(getDataFileName)
import System.IO.Unsafe (unsafePerformIO)
import Text.XML.Light
instance Default TextOpts where
def = TextOpts "text" lin INSIDE_H KERN False 1 1
textSVG :: String -> Double -> Path R2
textSVG t h = textSVG' with { txt = t, textHeight = h }
data TextOpts = TextOpts
{ txt :: String
, fdo :: (FontData, OutlineMap)
, mode :: Mode
, spacing :: Spacing
, underline :: Bool
, textWidth :: Double
, textHeight :: Double
} deriving Show
textSVG' :: TextOpts -> Path R2
textSVG' to =
case mode to of
INSIDE_WH -> makeString (textHeight to * sumh / maxY) (textHeight to) ((textWidth to) / (textHeight to * sumh / maxY))
INSIDE_W -> makeString (textWidth to) (textWidth to * maxY / sumh) 1
INSIDE_H -> makeString (textHeight to * sumh / maxY) (textHeight to) 1
where
makeString w h space = (scaleY (h/maxY) $ scaleX (w/sumh) $
mconcat $
zipWith translate (horPos space)
(map polygonChar (zip str (adjusted_hs space))) ) # centerXY
(fontD,outl) = (fdo to)
polygonChar (ch,a) = (fromMaybe mempty (Map.lookup ch outl)) <> (underlineChar a)
underlineChar a | underline to = translateY ulinePos (rect a ulineThickness)
| otherwise = mempty
ulinePos = underlinePosition fontD
ulineThickness = underlineThickness fontD
horPos space = reverse $ added ( zeroV : (map (unitX ^*) (adjusted_hs space)) )
adjusted_hs space = map (*space) hs
hs = horizontalAdvances str fontD (isKern (spacing to))
sumh = sum hs
added = snd.(foldl (\(h,l) (b,_) -> (h ^+^ b, (h ^+^ b):l))
(zeroV,[])). (map (\x->(x,[])))
maxY = bbox_dy fontD
ligatures = ((filter ((>1) . length)) . (Map.keys) . fontDataGlyphs) fontD
str = map T.unpack $ characterStrings (txt to) ligatures
textSVG_ :: forall b . Renderable (Path R2) b => TextOpts -> QDiagram b R2 Any
textSVG_ to =
case mode to of
INSIDE_WH -> makeString (textHeight to * sumh / maxY) (textHeight to) ((textWidth to) / (textHeight to * sumh / maxY))
INSIDE_W -> makeString (textWidth to) (textWidth to * maxY / sumh) 1
INSIDE_H -> makeString (textHeight to * sumh / maxY) (textHeight to) 1
where
makeString w h space =( ( translate (r2 (w*space/2,h/2)) $
scaleY (h/maxY) $ scaleX (w/sumh) $
translateY ( bbox_ly fontD) $
mconcat $
zipWith translate (horPos space)
(map polygonChar (zip str (adjusted_hs space))) ) # stroke # withEnvelope ((rect (w*space) h) :: D R2)
) # alignBL # translateY (bbox_ly fontD*h/maxY)
(fontD,outl) = (fdo to)
polygonChar (ch,a) = (fromMaybe mempty (Map.lookup ch outl)) <> (underlineChar a)
underlineChar a | underline to = translateX (a/2) $ translateY ulinePos (rect a ulineThickness)
| otherwise = mempty
ulinePos = underlinePosition fontD
ulineThickness = underlineThickness fontD
horPos space = reverse $ added ( zeroV : (map (unitX ^*) (adjusted_hs space)) )
hs = horizontalAdvances str fontD (isKern (spacing to))
adjusted_hs space = map (*space) hs
sumh = sum hs
added = snd.(foldl (\(h,l) (b,_) -> (h ^+^ b, (h ^+^ b):l))
(zeroV,[])). (map (\x->(x,[])))
maxY = bbox_dy fontD
ligatures = ((filter ((>1) . length)) . (Map.keys) . fontDataGlyphs) fontD
str = map T.unpack $ characterStrings (txt to) ligatures
data FontData = FontData
{ fontDataGlyphs :: SvgGlyphs
, fontDataKerning :: Kern
, fontDataBoundingBox :: [Double]
, fontDataFileName :: String
, fontDataUnderlinePos :: Double
, fontDataUnderlineThickness :: Double
, fontDataOverlinePos :: Maybe Double
, fontDataOverlineThickness :: Maybe Double
, fontDataStrikethroughPos :: Maybe Double
, fontDataStrikethroughThickness :: Maybe Double
, fontDataHorizontalAdvance :: Double
, fontDataFamily :: String
, fontDataStyle :: String
, fontDataWeight :: String
, fontDataVariant :: String
, fontDataStretch :: String
, fontDataSize :: Maybe String
, fontDataUnitsPerEm :: Double
, fontDataPanose :: String
, fontDataSlope :: Maybe Double
, fontDataAscent :: Double
, fontDataDescent :: Double
, fontDataXHeight :: Double
, fontDataCapHeight :: Double
, fontDataAccentHeight :: Maybe Double
, fontDataWidths :: Maybe String
, fontDataHorizontalStem :: Maybe Double
, fontDataVerticalStem :: Maybe Double
, fontDataUnicodeRange :: String
, fontDataRawKernings :: [(String, [String], [String], [String], [String])]
, fontDataIdeographicBaseline :: Maybe Double
, fontDataAlphabeticBaseline :: Maybe Double
, fontDataMathematicalBaseline :: Maybe Double
, fontDataHangingBaseline :: Maybe Double
, fontDataVIdeographicBaseline :: Maybe Double
, fontDataVAlphabeticBaseline :: Maybe Double
, fontDataVMathematicalBaseline :: Maybe Double
, fontDataVHangingBaseline :: Maybe Double
} deriving Show
openFont :: FilePath -> FontData
openFont file = FontData
{ fontDataGlyphs = Map.fromList glyphs
, fontDataKerning = Kern
{ kernU1S = transformChars u1s
, kernU2S = transformChars u2s
, kernG1S = transformChars g1s
, kernG2S = transformChars g2s
, kernK = kAr
}
, fontDataBoundingBox = parsedBBox
, fontDataFileName = fname file
, fontDataUnderlinePos = fontface `readAttr` "underline-position"
, fontDataUnderlineThickness = fontface `readAttr` "underline-thickness"
, fontDataHorizontalAdvance = fontHadv
, fontDataFamily = readString fontface "font-family" ""
, fontDataStyle = readString fontface "font-style" "all"
, fontDataWeight = readString fontface "font-weight" "all"
, fontDataVariant = readString fontface "font-variant" "normal"
, fontDataStretch = readString fontface "font-stretch" "normal"
, fontDataSize = fontface `readStringM` "font-size"
, fontDataUnitsPerEm = fontface `readAttr` "units-per-em"
, fontDataSlope = fontface `readAttrM` "slope"
, fontDataPanose = readString fontface "panose-1" "0 0 0 0 0 0 0 0 0 0"
, fontDataAscent = fontface `readAttr` "ascent"
, fontDataDescent = fontface `readAttr` "descent"
, fontDataXHeight = fontface `readAttr` "x-height"
, fontDataCapHeight = fontface `readAttr` "cap-height"
, fontDataAccentHeight = fontface `readAttrM` "accent-height"
, fontDataWidths = fontface `readStringM` "widths"
, fontDataHorizontalStem = fontface `readAttrM` "stemh"
, fontDataVerticalStem = fontface `readAttrM` "stemv"
, fontDataUnicodeRange = readString fontface "unicode-range" "U+0-10FFFF"
, fontDataRawKernings = rawKerns
, fontDataIdeographicBaseline = fontface `readAttrM` "ideographic"
, fontDataAlphabeticBaseline = fontface `readAttrM` "alphabetic"
, fontDataMathematicalBaseline = fontface `readAttrM` "mathematical"
, fontDataHangingBaseline = fontface `readAttrM` "hanging"
, fontDataVIdeographicBaseline = fontface `readAttrM` "v-ideographic"
, fontDataVAlphabeticBaseline = fontface `readAttrM` "v-alphabetic"
, fontDataVMathematicalBaseline = fontface `readAttrM` "v-mathematical"
, fontDataVHangingBaseline = fontface `readAttrM` "v-hanging"
, fontDataOverlinePos = fontface `readAttrM` "overline-position"
, fontDataOverlineThickness = fontface `readAttrM` "overline-thickness"
, fontDataStrikethroughPos = fontface `readAttrM` "strikethrough-position"
, fontDataStrikethroughThickness = fontface `readAttrM` "strikethrough-thickness"
}
where
readAttr :: (Read a) => Element -> String -> a
readAttr element attr = fromJust $ fmap read $ findAttr (unqual attr) element
readAttrM :: (Read a) => Element -> String -> Maybe a
readAttrM element attr = fmap read $ findAttr (unqual attr) element
readString :: Element -> String -> String -> String
readString element attr d = fromMaybe d $ findAttr (unqual attr) element
readStringM :: Element -> String -> Maybe String
readStringM element attr = findAttr (unqual attr) element
xml = onlyElems $ parseXML $ unsafePerformIO $ readFile file
fontElement = head $ catMaybes $ map (findElement (unqual "font")) xml
fontHadv = fromMaybe ((parsedBBox!!2) (parsedBBox!!0))
(fmap read (findAttr (unqual "horiz-adv-x") fontElement) )
fontface = fromJust $ findElement (unqual "font-face") fontElement
bbox = readString fontface "bbox" ""
parsedBBox :: [Double]
parsedBBox = map read $ splitWhen isSpace bbox
glyphElements = findChildren (unqual "glyph") fontElement
kernings = findChildren (unqual "hkern") fontElement
glyphs = map glyphsWithDefaults glyphElements
glyphsWithDefaults g = (charsFromFullName $ fromMaybe gname (findAttr (unqual "unicode") g),
(
gname,
fromMaybe fontHadv (fmap read (findAttr (unqual "horiz-adv-x") g)),
fromMaybe "" (findAttr (unqual "d") g)
)
)
where gname = fromMaybe "" (findAttr (unqual "glyph-name") g)
u1s = map (fromMaybe "") $ map (findAttr (unqual "u1")) kernings
u2s = map (fromMaybe "") $ map (findAttr (unqual "u2")) kernings
g1s = map (fromMaybe "") $ map (findAttr (unqual "g1")) kernings
g2s = map (fromMaybe "") $ map (findAttr (unqual "g2")) kernings
ks = map (fromMaybe "") $ map (findAttr (unqual "k")) kernings
kAr = V.fromList (map read ks)
rawKerns = fmap getRawKern kernings
getRawKern kerning =
let u1 = splitWhen (==',') $ fromMaybe "" $ findAttr (unqual "u1") $ kerning
u2 = splitWhen (==',') $ fromMaybe "" $ findAttr (unqual "u2") $ kerning
g1 = splitWhen (==',') $ fromMaybe "" $ findAttr (unqual "g1") $ kerning
g2 = splitWhen (==',') $ fromMaybe "" $ findAttr (unqual "g2") $ kerning
k = fromMaybe "" $ findAttr (unqual "k") $ kerning
in (k, g1, g2, u1, u2)
transformChars chars = Map.fromList $ map ch $ multiSet $
map (\(x,y) -> (x,[y])) $ sort fst $ concat $ index chars
ch (x,y) | null x = ("",y)
| otherwise = (x,y)
index u = addIndex (map (splitWhen isColon) u)
isColon = (== ',')
addIndex qs = zipWith (\x y -> (map (\z -> (z,x)) y)) [0..] qs
sort f xs = sortBy (\x y -> compare (f x) (f y) ) xs
multiSet [] = []
multiSet (a:[]) = [a]
multiSet (a:b:bs) | fst a == fst b = multiSet ( (fst a, (snd a) ++ (snd b)) : bs)
| otherwise = a : (multiSet (b:bs))
fname f = last $ init $ concat (map (splitOn "/") (splitOn "." f))
type SvgGlyphs = Map.Map String (String, Double, String)
horizontalAdvances :: [String] -> FontData -> Bool -> [Double]
horizontalAdvances [] _ _ = []
horizontalAdvances [ch] fd _ = [hadv ch fd]
horizontalAdvances (ch0:ch1:s) fd kerning = ((hadv ch0 fd) (ka (fontDataKerning fd))) :
(horizontalAdvances (ch1:s) fd kerning)
where ka kern | kerning = (kernAdvance ch0 ch1 kern True) + (kernAdvance ch0 ch1 kern False)
| otherwise = 0
hadv :: String -> FontData -> Double
hadv ch fontD | isJust char = sel2 (fromJust char)
| otherwise = fontDataHorizontalAdvance fontD
where char = (Map.lookup ch (fontDataGlyphs fontD))
data Kern = Kern
{ kernU1S :: Map.Map String [Int]
, kernU2S :: Map.Map String [Int]
, kernG1S :: Map.Map String [Int]
, kernG2S :: Map.Map String [Int]
, kernK :: Vector Double
} deriving Show
kernAdvance :: String -> String -> Kern -> Bool -> Double
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)))
type OutlineMap = Map.Map String (Path R2)
data Mode = INSIDE_H
| INSIDE_W
| INSIDE_WH
deriving Show
mWH :: Mode -> Bool
mWH INSIDE_WH = True
mWH _ = False
mW :: Mode -> Bool
mW INSIDE_W = True
mW _ = False
mH :: Mode -> Bool
mH INSIDE_H = True
mH _ = False
data Spacing = HADV
| KERN
deriving Show
isKern :: Spacing -> Bool
isKern KERN = True
isKern _ = False
type FileName = String
ro :: FilePath -> FilePath
ro = unsafePerformIO . getDataFileName
bbox_dy :: FontData -> Double
bbox_dy fontData = (bbox!!3) (bbox!!1)
where bbox = fontDataBoundingBox fontData
bbox_lx :: FontData -> Double
bbox_lx fontData = (fontDataBoundingBox fontData) !! 0
bbox_ly :: FontData -> Double
bbox_ly fontData = (fontDataBoundingBox fontData) !! 1
underlinePosition :: FontData -> Double
underlinePosition fontData = fontDataUnderlinePos fontData
underlineThickness :: FontData -> Double
underlineThickness fontData = fontDataUnderlineThickness fontData
outlMap :: String -> (FontData, OutlineMap)
outlMap str = ( fontD, Map.fromList [ (ch, outlines ch) | ch <- allUnicodes ] )
where
allUnicodes = Map.keys (fontDataGlyphs fontD)
outlines ch = mconcat $ commandsToTrails (commands ch (fontDataGlyphs fontD)) [] zeroV zeroV zeroV
fontD = openFont str
commandsToTrails :: [PathCommand] -> [Segment Closed R2] -> R2 -> R2 -> R2 -> [Path R2]
commandsToTrails [] _ _ _ _ = []
commandsToTrails (c:cs) segments l lastContr beginPoint
| isNothing nextSegment = (translate beginPoint (pathFromTrail . wrapTrail . closeLine $ lineFromSegments segments)) :
( commandsToTrails cs [] (l ^+^ offs) (contr c) (beginP c) )
| otherwise = commandsToTrails cs (segments ++ [fromJust nextSegment])
(l ^+^ offs) (contr c) (beginP c)
where nextSegment = go c
offs | isJust nextSegment
= segOffset (fromJust nextSegment)
| otherwise = zeroV
(x0,y0) = unr2 offs
(cx,cy) = unr2 lastContr
beginP ( M_abs (x,y) ) = r2 (x,y)
beginP ( M_rel (x,y) ) = l ^+^ r2 (x,y)
beginP _ = beginPoint
contr ( C_abs (_x1,_y1,x2,y2,x,y) ) = r2 (x0+xx2, y0+yy2 )
contr ( C_rel (_x1,_y1,x2,y2,x,y) ) = r2 ( xx2, yy2 )
contr ( S_abs (x2,y2,x,y) ) = r2 (x0+xx2, y0+yy2 )
contr ( S_rel (x2,y2,x,y) ) = r2 ( xx2, yy2 )
contr ( Q_abs (x1,y1,x,y) ) = r2 (x0+xx1, y0+yy1 )
contr ( Q_rel (x1,y1,x,y) ) = r2 ( xx1, yy1 )
contr ( T_abs (_x,_y) ) = r2 (2*x0cx, 2*y0cy )
contr ( T_rel (x,y) ) = r2 ( xcx, ycy )
contr ( L_abs (_x,_y) ) = r2 (x0, y0)
contr ( L_rel (_x,_y) ) = r2 ( 0, 0)
contr ( M_abs (_x,_y) ) = r2 (x0, y0)
contr ( M_rel (_x,_y) ) = r2 ( 0, 0)
contr ( H_abs _x ) = r2 (x0, y0)
contr ( H_rel _x ) = r2 ( 0, y0)
contr ( V_abs _y ) = r2 (x0, y0)
contr ( V_rel _y ) = r2 (x0, 0)
contr ( Z ) = r2 (0, 0)
contr ( A_abs ) = r2 (0, 0)
contr ( A_rel ) = r2 (0, 0)
straight' = straight . r2
bezier3' point1 point2 point3 = bezier3 (r2 point1) (r2 point2) (r2 point3)
go ( M_abs (_x,_y) ) = Nothing
go ( M_rel (_x,_y) ) = Nothing
go ( L_abs (x,y) ) = Just $ straight' (x0+x, y0+y)
go ( L_rel (x,y) ) = Just $ straight' (x, y)
go ( H_abs x) = Just $ straight' (x0 + x, y0)
go ( H_rel x) = Just $ straight' (x, 0)
go ( V_abs y) = Just $ straight' (x0, y0 + y)
go ( V_rel y) = Just $ straight' (0, y)
go ( C_abs (x1,y1,x2,y2,x,y) ) = Just $ bezier3' (x0+x1, y0+y1) (x0+x2,y0+y2) (x0+x,y0+y)
go ( C_rel (x1,y1,x2,y2,x,y) ) = Just $ bezier3' (x1, y1) (x2, y2) (x, y)
go ( S_abs ( x2,y2,x,y) ) = Just $ bezier3' (cx, cy) (x0+x2, y0+y2) (x0+x, y0+y)
go ( S_rel ( x2,y2,x,y) ) = Just $ bezier3' (cx, cy) (x2, y2) (x, y)
go ( Q_abs (x1,y1,x,y) ) = Just $ bezier3' (x0 + x1, y0 + y1) (x0 + x, y0 + y) (x0 + x, y0 + y)
go ( Q_rel (x1,y1,x,y) ) = Just $ bezier3' (x1, y1) (x, y) (x, y)
go ( T_abs (x,y) ) = Just $ bezier3' (cx, cy) (x0 + x, y0 + y) (x0 + x, y0 + y)
go ( T_rel (x,y) ) = Just $ bezier3' (cx, cy) (x, y) (x, y)
go ( Z ) = Nothing
go ( A_abs ) = Nothing
go ( A_rel ) = Nothing
commands :: String -> SvgGlyphs -> [PathCommand]
commands ch glyph | isJust element = case pathFromString (sel3 $ fromJust element) of
Left err -> unsafePerformIO $ do
putStr "parse error at "
print err
return []
Right p -> p
| otherwise = []
where element = Map.lookup ch glyph
bit :: (FontData, OutlineMap)
bit = outlMap (ro "fonts/Bitstream.svg")
lin :: (FontData, OutlineMap)
lin = outlMap (ro "fonts/LinLibertine.svg")
lin2 :: (FontData, OutlineMap)
lin2 = outlMap (ro "fonts/LinLibertineCut.svg")