module Graphics.SVGFonts.ReadFont
where
import Data.Char (isSpace)
import Data.Default
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
}
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).sel1) 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).sel1) fontD
str = map T.unpack $ characterStrings (txt to) ligatures
type FontData = (SvgGlyph, Kern, [Double], String, (Double, Double),
(Double,String,String,String,String,String,String,String,String,String,String,String,String))
openFont :: FilePath -> FontData
openFont file = ( Map.fromList glyphs,
(transformChars u1s, transformChars u2s, transformChars g1s, transformChars g2s, kAr),
parsedBBox,
fname file,
(underlinePos, underlineThick),
(fontHadv, fontFamily, fontWeight, fontStretch, unitsPerEm, panose,
ascent, descent, xHeight, capHeight, stemh, stemv, unicodeRange)
)
where
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 = fromMaybe "" $ findAttr (unqual "bbox") fontface
parsedBBox :: [Double]
parsedBBox = map read $ splitWhen isSpace bbox
underlineThick = read $ fromMaybe "" $ findAttr (unqual "underline-thickness") fontface
underlinePos = read $ fromMaybe "" $ findAttr (unqual "underline-position") fontface
fontFamily = read $ fromMaybe "" $ findAttr (unqual "font-family") fontface
fontWeight = read $ fromMaybe "" $ findAttr (unqual "font-weight") fontface
fontStretch = read $ fromMaybe "" $ findAttr (unqual "font-stretch") fontface
unitsPerEm = read $ fromMaybe "" $ findAttr (unqual "units-per-em") fontface
panose = read $ fromMaybe "" $ findAttr (unqual "panose") fontface
ascent = read $ fromMaybe "" $ findAttr (unqual "ascent") fontface
descent = read $ fromMaybe "" $ findAttr (unqual "descent") fontface
xHeight = read $ fromMaybe "" $ findAttr (unqual "xHeight") fontface
capHeight = read $ fromMaybe "" $ findAttr (unqual "capHeight") fontface
stemh = read $ fromMaybe "" $ findAttr (unqual "stemh") fontface
stemv = read $ fromMaybe "" $ findAttr (unqual "stemv") fontface
unicodeRange = read $ fromMaybe "" $ findAttr (unqual "unicode-range") fontface
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)
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 SvgGlyph = 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 (sel2 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 = sel1 (sel6 fontD)
where char = (Map.lookup ch (sel1 fontD))
type Kern = ( Map.Map String [Int],
Map.Map String [Int],
Map.Map String [Int],
Map.Map String [Int], Vector Double )
kernAdvance :: String -> String -> Kern -> Bool -> Double
kernAdvance ch0 ch1 kern u | u && not (null s0) = (sel5 kern) V.! (head s0)
| not u && not (null s1) = (sel5 kern) V.! (head s1)
| otherwise = 0
where s0 = intersect (s sel1 ch0) (s sel2 ch1)
s1 = intersect (s sel3 ch0) (s sel4 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
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
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 = sel3 fontData
bbox_lx :: FontData -> Double
bbox_lx fontData = (sel3 fontData) !! 0
bbox_ly :: FontData -> Double
bbox_ly fontData = (sel3 fontData) !! 1
underlinePosition :: FontData -> Double
underlinePosition fontData = fst $ sel5 fontData
underlineThickness :: FontData -> Double
underlineThickness fontData = snd $ sel5 fontData
outlMap :: String -> (FontData, OutlineMap)
outlMap str = ( fontD, Map.fromList [ (ch, outlines ch) | ch <- allUnicodes ] )
where
allUnicodes = Map.keys (sel1 fontD)
outlines ch = mconcat $ commandsToTrails (commands ch (sel1 fontD)) [] zeroV zeroV zeroV
fontD = openFont str
commandsToTrails :: [PathCommand] -> [Segment R2] -> R2 -> R2 -> R2 -> [Path R2]
commandsToTrails [] _ _ _ _ = []
commandsToTrails (c:cs) segments l lastContr beginPoint
| isNothing nextSegment = (translate beginPoint (pathFromTrail . close $ fromSegments 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 -> SvgGlyph -> [PathCommand]
commands ch glyph | isJust element = unsafePerformIO $ pathFromString $ sel3 $ fromJust element
| 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")