{-# 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 { fontDataGlyphs :: SvgGlyphs n , fontDataKerning :: Kern n , fontDataBoundingBox :: [n] , fontDataFileName :: String , fontDataUnderlinePos :: n , fontDataUnderlineThickness :: n , fontDataOverlinePos :: Maybe n , fontDataOverlineThickness :: Maybe n , fontDataStrikethroughPos :: Maybe n , fontDataStrikethroughThickness :: Maybe n , fontDataHorizontalAdvance :: n , fontDataFamily :: String , fontDataStyle :: String , fontDataWeight :: String , fontDataVariant :: String , fontDataStretch :: String , fontDataSize :: Maybe String , fontDataUnitsPerEm :: n , fontDataPanose :: String , fontDataSlope :: Maybe n , fontDataAscent :: n , fontDataDescent :: n , fontDataXHeight :: n , fontDataCapHeight :: n , fontDataAccentHeight :: Maybe n , fontDataWidths :: Maybe String , fontDataHorizontalStem :: Maybe n -- ^ This data is not available in some fonts (e.g. Source Code Pro) , fontDataVerticalStem :: Maybe n -- ^ This data is not available in some fonts (e.g. Source Code Pro) , fontDataUnicodeRange :: String , fontDataRawKernings :: [(String, [String], [String], [String], [String])] , fontDataIdeographicBaseline :: Maybe n , fontDataAlphabeticBaseline :: Maybe n , fontDataMathematicalBaseline :: Maybe n , fontDataHangingBaseline :: Maybe n , fontDataVIdeographicBaseline :: Maybe n , fontDataVAlphabeticBaseline :: Maybe n , fontDataVMathematicalBaseline :: Maybe n , fontDataVHangingBaseline :: Maybe n } deriving (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 basename contents = readFontData fontElement basename where xml = onlyElems $ parseXML $ contents fontElement | null fontElements = error ("no -tag found in SVG file using SVGFonts library." ++ "Most likely wrong namespace in -tag. Please delete xmlns=...") | otherwise = head $ catMaybes $ fontElements fontElements = map (findElement (qTag "font")) xml ++ -- sometimes there is a namespace given with qTag :: String -> QName qTag name = QName {qName = name, qURI = Just "http://www.w3.org/2000/svg", qPrefix = Nothing} -- | Read font data from an XML font element. readFontData :: (Read n, RealFloat n) => Element -> String -> FontData n readFontData fontElement basename = FontData { fontDataGlyphs = Map.fromList glyphs , fontDataKerning = Kern { kernU1S = transformChars u1s , kernU2S = transformChars u2s , kernG1S = transformChars g1s , kernG2S = transformChars g2s , kernK = kAr } , fontDataBoundingBox = parsedBBox , fontDataFileName = basename , 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 findAttr' attr e | isJust uq = uq | otherwise = q where uq = findAttr (unqual attr) e q = findAttr (qTag attr) e readAttr :: (Read a) => Element -> String -> a readAttr e attr = fromJust $ fmap read $ findAttr' attr e readAttrM :: (Read a) => Element -> String -> Maybe a readAttrM e attr = fmap read $ findAttr' attr e -- | @readString e a d@ : @e@ element to read from; @a@ attribute to read; @d@ default value. readString :: Element -> String -> String -> String readString e attr d = fromMaybe d $ findAttr' attr e readStringM :: Element -> String -> Maybe String readStringM e attr = findAttr' attr e fontHadv = fromMaybe ((parsedBBox!!2) - (parsedBBox!!0)) -- BBox is used if there is no "horiz-adv-x" attribute (fmap read (findAttr' "horiz-adv-x" fontElement) ) fontface | isJust uq = fromJust uq | isJust q = fromJust q | otherwise = error "no fontface tag found in SVGFonts library" -- there is always a font-face node where uq = findElement (unqual "font-face") fontElement q = findElement (qTag "font-face") fontElement bbox = readString fontface "bbox" "" parsedBBox :: Read n => [n] parsedBBox = map read $ splitWhen isSpace bbox glyphElements = findChildren (unqual "glyph") fontElement ++ findChildren (qTag "glyph") fontElement kernings = findChildren (unqual "hkern") fontElement ++ findChildren (qTag "hkern") fontElement glyphs = map glyphsWithDefaults glyphElements -- monospaced fonts sometimes don't have a "horiz-adv-x="-value , replace with "horiz-adv-x=" in glyphsWithDefaults g = (charsFromFullName $ fromMaybe gname (findAttr' "unicode" g), -- there is always a name or unicode ( gname, fromMaybe fontHadv (fmap read (findAttr' "horiz-adv-x" g)), fromMaybe "" (findAttr' "d" g) ) ) where gname = fromMaybe "" (findAttr' "glyph-name" g) u1s = map (fromMaybe "") $ map (findAttr' "u1") kernings u2s = map (fromMaybe "") $ map (findAttr' "u2") kernings g1s = map (fromMaybe "") $ map (findAttr' "g1") kernings g2s = map (fromMaybe "") $ map (findAttr' "g2") kernings ks = map (fromMaybe "") $ map (findAttr' "k") kernings kAr = V.fromList (map read ks) rawKerns = fmap getRawKern kernings getRawKern kerning = let u1 = splitWhen (==',') $ fromMaybe "" $ findAttr' "u1" $ kerning u2 = splitWhen (==',') $ fromMaybe "" $ findAttr' "u2" $ kerning g1 = splitWhen (==',') $ fromMaybe "" $ findAttr' "g1" $ kerning g2 = splitWhen (==',') $ fromMaybe "" $ findAttr' "g2" $ kerning k = fromMaybe "" $ findAttr' "k" $ kerning in (k, g1, g2, u1, u2) transformChars chars = Map.fromList $ map ch $ multiSet $ map (\(x,y) -> (x,[y])) $ sort fst $ concat $ indexList chars ch (x,y) | null x = ("",y) | otherwise = (x,y) indexList u = addIndex (map (splitWhen isColon) u) -- ie ["aa,b","c,d"] to [["aa","b"],["c","d"]] isColon = (== ',') -- to [("aa",0),("b",0)],[("c",1), ("d",1)] 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] -- example: [("n1",[0]),("n1",[1]),("n2",[1])] to [("n1",[0,1]),("n2",[1])] multiSet (a:b:bs) | fst a == fst b = multiSet ( (fst a, (snd a) ++ (snd b)) : bs) | otherwise = a : (multiSet (b: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 ch fontD | isJust char = sel2 (fromJust char) | otherwise = fontDataHorizontalAdvance fontD where char = (Map.lookup ch (fontDataGlyphs fontD)) sel2 (_, x, _) = x -- | See -- -- Some explanation how kerning is computed: -- -- In Linlibertine.svg, there are two groups of chars: e.g. -- \ -- 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 { kernU1S :: Map.Map String [Int] , kernU2S :: Map.Map String [Int] , kernG1S :: Map.Map String [Int] , kernG2S :: Map.Map String [Int] , kernK :: V.Vector n } deriving (Show, 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 ch0 ch1 kern u | u && not (null s0) = (kernK kern) V.! (head s0) | not u && not (null s1) = (kernK kern) V.! (head s1) | otherwise = 0 where s0 = intersect (s kernU1S ch0) (s kernU2S ch1) s1 = intersect (s kernG1S ch0) (s kernG2S ch1) s sel ch = concat (maybeToList (Map.lookup ch (sel kern))) -- > import Graphics.SVGFonts.ReadFont -- > 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 = (bbox!!3) - (bbox!!1) where bbox = fontDataBoundingBox fontData -- bbox = [lowest x, lowest y, highest x, highest y] -- | Lowest x-value of bounding box bbox_lx :: FontData n -> n bbox_lx fontData = (fontDataBoundingBox fontData) !! 0 -- | Lowest y-value of bounding box bbox_ly :: FontData n -> n bbox_ly fontData = (fontDataBoundingBox fontData) !! 1 -- | Position of the underline bar underlinePosition :: FontData n -> n underlinePosition fontData = fontDataUnderlinePos fontData -- | Thickness of the underline bar underlineThickness :: FontData n -> n underlineThickness fontData = fontDataUnderlineThickness 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 = ( Map.fromList [(ch, outl) | (ch, Right outl) <- allOutlines] , Map.fromList [(ch, err) | (ch, Left err) <- allOutlines] ) where allUnicodes = Map.keys (fontDataGlyphs fontData) outlines ch = do cmds <- commands ch (fontDataGlyphs fontData) return $ mconcat $ commandsToTrails cmds [] zero zero zero allOutlines = [(ch, outlines ch) | ch <- allUnicodes] -- | Prepare font for rendering, by determining its outline map. prepareFont :: RealFloat n => FontData n -> (PreparedFont n, ErrorMap) prepareFont fontData = ((fontData, outlines), errs) where (outlines, errs) = outlineMap fontData -- | Read font data from font file, and compute its outline map. loadFont :: (Read n, RealFloat n) => FilePath -> IO (PreparedFont n) loadFont filename = do s <- readFile filename let basename = last $ init $ concat (map (splitOn "/") (splitOn "." filename)) (errors, font) = loadFont' basename s when (errors /= "") (putStrLn errors) return 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' basename s = let fontData = parseFont basename s (font, errs) = prepareFont fontData errors = unlines $ map (\(ch, err) -> "error parsing character '" ++ ch ++ "': " ++ err) (Map.toList errs) in (errors, font) commandsToTrails ::RealFloat n => [PathCommand n] -> [Segment Closed V2 n] -> V2 n -> V2 n -> V2 n -> [Path V2 n] commandsToTrails [] _ _ _ _ = [] commandsToTrails (c:cs) segments l lastContr beginPoint -- l is the endpoint of the last segment | isNothing nextSegment = (translate beginPoint (pathFromTrail . wrapTrail . closeLine $ lineFromSegments segments)) : ( commandsToTrails cs [] (l ^+^ offs) (contr c) (beginP c) ) -- one outline completed | otherwise = commandsToTrails cs (segments ++ [fromJust nextSegment]) (l ^+^ offs) (contr c) (beginP c) -- work on outline where nextSegment = go c offs | isJust nextSegment = segOffset (fromJust nextSegment) | otherwise = zero (x0,y0) = unr2 offs (cx,cy) = unr2 lastContr -- last control point is always in absolute coordinates 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+x - x2, y0+y - y2 ) -- control point of bezier curve contr ( C_rel (_x1,_y1,x2,y2,x,y) ) = r2 ( x - x2, y - y2 ) contr ( S_abs (x2,y2,x,y) ) = r2 (x0+x - x2, y0+y - y2 ) contr ( S_rel (x2,y2,x,y) ) = r2 ( x - x2, y - y2 ) contr ( Q_abs (x1,y1,x,y) ) = r2 (x0+x - x1, y0+y - y1 ) contr ( Q_rel (x1,y1,x,y) ) = r2 ( x - x1, y - y1 ) contr ( T_abs (_x,_y) ) = r2 (2*x0 - cx, 2*y0 - cy ) contr ( T_rel (x,y) ) = r2 ( x - cx, y - cy ) 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) -- to get rid of warnings contr ( A_abs ) = r2 (0, 0) -- to get rid of warnings contr ( A_rel ) = r2 (0, 0) -- to get rid of warnings 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 :: RealFloat n => String -> SvgGlyphs n -> Either String [PathCommand n] commands ch glyph = case Map.lookup ch glyph of Just e -> pathFromString (sel3 e) Nothing -> Right [] where sel3 (_, _, x) = x