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)
import qualified Data.Map as Map
import qualified Data.Text as T
import Data.Monoid (mconcat)
import Data.Tuple.Select (sel1, sel2, sel3, sel4, sel5)
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.Directory
import System.IO.Unsafe (unsafePerformIO)
import Text.XML.Light
type Kern = ( Map.Map String [Int],
Map.Map String [Int],
Map.Map String [Int],
Map.Map String [Int], Vector Double )
type SvgGlyph = Map.Map String (String, Double, String)
type FontData = (SvgGlyph, Kern, [Double], String)
openFont :: FilePath -> FontData
openFont file = ( Map.fromList (myZip4 (unicodes, glyphNames, horiz, ds)),
(transform u1s, transform u2s, transform g1s, transform g2s, kAr),
parsedBBox,
fname file
)
where
myZip4 (a:as, b:bs, c:cs, d:ds) | c == [] = (a, (b, (parsedBBox!!2) (parsedBBox!!0), d)) :
(myZip4 (as,bs,cs,ds))
| otherwise = (a, (b, read c, d)) : (myZip4 (as,bs,cs,ds))
myZip4 _ = []
xml = onlyElems $ parseXML $ unsafePerformIO $ readFile $ file
selectFontface = concat $ map (findElements (unqual "font-face")) xml
selectGlyphs = concat $ map (findElements (unqual "glyph")) xml
selectKerns = concat $ map (findElements (unqual "hkern")) xml
bbox = fromMaybe "" $ head $ map (findAttr (unqual "bbox")) selectFontface
parsedBBox = map read $ splitWhen isSpace bbox
glyphNames = map (fromMaybe "") $ map (findAttr (unqual "glyph-name")) selectGlyphs
unicodes = map charsFromFullName $ map (findAttr (unqual "unicode")) selectGlyphs
horiz = map (fromMaybe "") $ map (findAttr (unqual "horiz-adv-x")) selectGlyphs
ds = map (fromMaybe "") $ map (findAttr (unqual "d")) selectGlyphs
u1s = map (fromMaybe "") $ map (findAttr (unqual "u1")) selectKerns
u2s = map (fromMaybe "") $ map (findAttr (unqual "u2")) selectKerns
g1s = map (fromMaybe "") $ map (findAttr (unqual "g1")) selectKerns
g2s = map (fromMaybe "") $ map (findAttr (unqual "g2")) selectKerns
ks = map (fromMaybe "") $ map (findAttr (unqual "k")) selectKerns
kAr = V.fromList (map read ks)
transform 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 (f x) y)) [0..] qs
f = \index char -> (char,index)
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))
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 ch fontD | isJust lookup = sel2 (fromJust (Map.lookup ch (sel1 fontD)))
| otherwise = 0
where lookup = Map.lookup ch (sel1 fontD)
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_WH
| INSIDE_W
| INSIDE_H
mWH INSIDE_WH = True
mWH _ = False
mW INSIDE_W = True
mW _ = False
mH INSIDE_H = True
mH _ = False
data Spacing = KERN
| HADV
isKern KERN = True
isKern _ = False
type FileName = String
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
, textWidth :: Double
, textHeight :: Double
}
ro = unsafePerformIO . getDataFileName
bit = outlMap (ro "src/Test/Bitstream.svg")
lin = outlMap (ro "src/Test/LinLibertine.svg")
instance Default TextOpts where
def = TextOpts "text" lin INSIDE_H KERN 1 1
textSVG_ :: TextOpts -> Path R2
textSVG_ to | mWH (mode to) = makeString (textWidth to) (textHeight to)
| mW (mode to) = makeString (textWidth to) ((textWidth to) * maxY / sumh)
| mH (mode to) = makeString ((textHeight to) * sumh / maxY) (textHeight to)
where
makeString w h =
scaleY (h/maxY) $ scaleX (w/sumh) $
translate (0, bbox_ly fontD) $
mconcat $
zipWith translate horPos
(map (polygonChar outl) str)
(fontD,outl) = (fdo to)
polygonChar outl ch = fromJust (Map.lookup ch outl)
horPos = reverse $ added ( (0,0) : (map ((1,0) ^*) hs) )
hs = horizontalAdvances str fontD (isKern (spacing to))
sumh = sum hs
added = snd.(foldl (\(h,l) (b,_) -> (h ^+^ b, (h ^+^ b):l))
((0,0),[])). (map (\x->(x,[])))
maxY = bbox_dy fontD
ligatures = ((filter ((>1).length)).(Map.keys).sel1) fontD
str = map T.unpack $ characterStrings (txt to) ligatures
bbox_dy fontData = (bbox!!3) (bbox!!1)
where bbox = sel3 fontData
bbox_lx fontData = (sel3 fontData) !! 0
bbox_ly fontData = (sel3 fontData) !! 1
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)) [] (0,0) (0,0) (0,0)
fontD = openFont str
commandsToTrails :: [PathCommand] -> [Segment R2] -> R2 -> R2 -> R2 -> [Path R2]
commandsToTrails [] _ _ _ _ = []
commandsToTrails (c:cs) segments (lx,ly) lastContr beginPoint
| isNothing nextSegment = (translate beginPoint (pathFromTrail $ fromSegments segments)) :
( commandsToTrails cs [] (lx+x0, ly+y0) (contr c) (beginP c) )
| otherwise = commandsToTrails cs (segments ++ [fromJust nextSegment])
(lx+x0, ly+y0) (contr c) (beginP c)
where nextSegment = go c
(x0,y0) | isJust nextSegment = segOffset (fromJust nextSegment)
| otherwise = (0,0)
(cx,cy) = lastContr
beginP ( M_abs (x,y) ) = (x,y)
beginP ( M_rel (x,y) ) = (lx+x, ly+y)
beginP _ = beginPoint
contr ( C_abs (x1,y1,x2,y2,x,y) ) = (x0+xx2, y0+yy2 )
contr ( C_rel (x1,y1,x2,y2,x,y) ) = ( xx2, yy2 )
contr ( S_abs (x2,y2,x,y) ) = (x0+xx2, y0+yy2 )
contr ( S_rel (x2,y2,x,y) ) = ( xx2, yy2 )
contr ( Q_abs (x1,y1,x,y) ) = (x0+xx1, y0+yy1 )
contr ( Q_rel (x1,y1,x,y) ) = ( xx1, yy1 )
contr ( T_abs (x,y) ) = (2*x0cx, 2*y0cy )
contr ( T_rel (x,y) ) = ( xcx, ycy )
contr ( L_abs (x,y) ) = (x0, y0)
contr ( L_rel (x,y) ) = ( 0, 0)
contr ( M_abs (x,y) ) = (x0, y0)
contr ( M_rel (x,y) ) = ( 0, 0)
contr ( H_abs x ) = (x0, y0)
contr ( H_rel x ) = ( 0, y0)
contr ( V_abs y ) = (x0, y0)
contr ( V_rel y ) = (x0, 0)
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 + x1, y0 + y1) (x0 + x, y0 + y)
go ( Q_rel (x1,y1,x,y) ) = Just $ bezier3 (x1, y1) (x1, y1) (x, y)
go ( T_abs (x,y) ) = Just $ bezier3 (cx, cy) (cx, cy) (x0 + x, y0 + y)
go ( T_rel (x,y) ) = Just $ bezier3 (cx, cy) (cx, cy) (x, y)
go ( Z ) = Nothing
commands :: String -> SvgGlyph -> [PathCommand]
commands ch glyph | isJust element = unsafePerformIO $ pathFromString $ sel3 $ fromJust element
| otherwise = []
where element = Map.lookup ch glyph