module Graphics.SVGFonts.ReadFont
(openFont, makeOutlMaps, makeTexMap, Mode(..), Spacing(..), Rx(..), displayString,
Kern, SvgGlyph, FontData, OutlineMap, OutlineTexMap,
P, CharProp(..), Props, Transf, TexMap, X ,Y
)
where
import Data.Char (isSpace)
import Data.List (zip5)
import Data.List.Split (splitOn, splitWhen)
import Data.Maybe (fromMaybe, fromJust, isJust, maybeToList, catMaybes)
import qualified Data.Map as Map
import qualified Data.Text as T
import Data.Tuple.Select (sel1, sel2, sel3, sel4, sel5)
import Data.Vector (Vector)
import qualified Data.Vector as V
import Graphics.Formats.Collada.ColladaTypes
import Graphics.Formats.Collada.GenerateObjects (cube, blue, obj, makeScene, get_name, getDiffuseColor, getAmbientColor)
import Graphics.Formats.Collada.Vector2D3D (V3(..), V4(..), mul, divide, v_len, set_len, cross3)
import Graphics.Formats.TGA.TGA (readTGA, writeTGA)
import Graphics.Rendering.OpenGL (TextureObject)
import Graphics.SVGFonts.CharReference (charsFromFullName, characterStrings)
import Graphics.SVGFonts.RasterFont (createTexture, borderToTex, commandsToRasterPoints, AA(..), F2P(..), ftrace)
import Graphics.SVG.ReadPath (commandsToPoints, pathFromString)
import List (intersect,sortBy)
import System.Directory
import System.IO.Unsafe (unsafePerformIO)
import Text.XML.Light
import Debug.Trace
type Kern = ( Map.Map String [Int],
Map.Map String [Int],
Map.Map String [Int],
Map.Map String [Int], Vector X )
type SvgGlyph = Map.Map String (String, X, String)
type FontData = (SvgGlyph, Kern, [Float], String)
type X = Float
type Y = Float
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 -> [X]
horizontalAdvances [] _ = []
horizontalAdvances [(ch,fd)] _ = [hadv ch fd]
horizontalAdvances ((ch0,fd0):(ch1,fd1):s) kerning = ((hadv ch0 fd0) (ka (sel2 fd0)))
: (horizontalAdvances ((ch1,fd1):s) kerning)
where ka kern |(sel4 fd0) == (sel4 fd1) && 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 -> X
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 TexMap = Map.Map (String,String,String) (TextureObject, String)
type OutlineMap = Map.Map String [[(X,Y)]]
type OutlineTexMap = Map.Map String [[F2P]]
data Mode = INSIDE_V1_V2
| INSIDE_V1
| INSIDE_V2
mV1V2V3 INSIDE_V1_V2 = True
mV1V2V3 _ = False
mV1 INSIDE_V1 = True
mV1 _ = False
mV2 INSIDE_V2 = True
mV2 _ = False
data Spacing = KERN
| HADV
| MONO
isMono MONO = True
isMono _ = False
isKern KERN = True
isKern _ = False
data Rx = Exactly Int
| ConstDx
| XPowerOfTwo
| OneTexture
isExactly (Exactly _) = True
isExactly _ = False
isConstDx ConstDx = True
isConstDx _ = False
isXPowerOfTwo XPowerOfTwo = True
isXPowerOfTwo _ = False
getRx (Exactly rx) = Just rx
getRx _ = Nothing
type FileName = String
type P = [Char] -> [String]
data CharProp = Outl (FontData, OutlineMap, OutlineTexMap) String |
Tex (FontData, OutlineMap, OutlineTexMap) String
isTex :: CharProp -> Bool
isTex (Tex _ _) = True
isTex (Outl _ _) = False
getFont :: CharProp -> (FontData, OutlineMap, OutlineTexMap)
getFont (Outl font _) = font
getFont (Tex font _) = font
getTr (Outl _ tr) = tr
getTr (Tex _ tr) = tr
type Transf = Map.Map String (Geometry -> Geometry)
type Props = Map.Map String CharProp
displayString :: String -> String -> (Rx,Int) ->Mode->Spacing-> (V3,V3,V3) ->P->Props->Transf-> TexMap -> Scene
displayString txt sid (rx,ry) mode spacing (o,v1,v2) f props transf texmap | mV1V2V3 mode = makeString v1 v2
| mV1 mode = makeString v1 newV2
| mV2 mode = makeString newV1 v2
where
makeString u1 u2 = makeScene sid $ map (\(g,transl) -> obj (get_name (head g)) g transl) (withoutSpaces u1 u2)
withoutSpaces u1 u2 = filter ((not.null).fst) (geometrieVs u1 u2)
geometrieVs u1 u2 = map (getC u1 u2 sumh (rx,ry) texmap) (zip5 str horPos hs newProps newTrList)
sumh | isMono spacing = maxX * (fromIntegral (length str))
| otherwise = sum hs
horPos | isMono spacing = reverse $ added (o: (replicate (length str) (v1Advance * (V3 maxX maxX maxX))))
| otherwise = reverse $ added (o: stretch hs)
hs = horizontalAdvances (zip str newFontList) (isKern spacing)
stretch = map (v1Advance `mul`)
added = snd.(foldl (\(h,l) (b,_) -> (h + b, (h + b):l))
((V3 0 0 0),[])). (map (\x->(x,[])))
newV1 = set_len v1 ( (v_len v2) * (sumh/maxY) )
newV2 = set_len v2 ( (v_len v1) * (maxY/sumh) )
maxX = (sum (map maximum_x fontList)) /
(fromIntegral (length fontList))
maxY = (sum (map bbox_dy fontList)) / (fromIntegral (length fontList))
v1Advance | mV1V2V3 mode || mV1 mode = v1 `divide` sumh
| mV2 mode = newV1 `divide` sumh
properties = map (fromJust.((\x y -> Map.lookup y x) props)) (f txt)
fontList = map (sel1.getFont) properties
trList = map ((\x -> (x, fromJust (Map.lookup x transf))).getTr) properties
newProps = dropSome (map length str) properties
newFontList = dropSome (map length str) fontList
newTrList = dropSome (map length str) trList
dropSome [] _ = []
dropSome _ [] = []
dropSome (l:ls) ps = (head ps) : (dropSome ls (drop l ps))
ligaturesOfFontName = Map.fromList $ zip (map sel4 fontList)
(map ((filter ((>1).length)).(Map.keys).sel1) fontList)
constFontStrings :: String -> [String] -> [(Char,String)] -> [[(Char,String)]]
constFontStrings [c] [f] cc = [((c,f):cc)]
constFontStrings (c0:c1:cs) (f0:f1:fs) cc | f0 == f1 = constFontStrings (c1:cs) (f1:fs) ((c0,f0):cc)
| otherwise = ((c0,f0):cc) : constFontStrings (c1:cs) (f1:fs) []
str = map T.unpack $ concat $ map (characterStrings ligaturesOfFontName)
(map reverse (constFontStrings txt (map sel4 fontList) []))
type Glyphdata = (String,V3,Float,CharProp,(String,Geometry->Geometry))
getC :: V3 -> V3 -> Float -> (Rx,Int) -> TexMap -> Glyphdata -> ([Geometry],V3)
getC u1 u2 sh (rx,ry) tex (ch,h,h_ad,pr,tr) | isTex pr = texChar tex sfd u1 u2 sh (ch,h,h_ad,fst tr) (rx,ry)
| otherwise = (map (snd tr) (fst pc), snd pc)
where pc = polygonChar om sfd u1 u2 sh (rx,ry) (fst tr) (ch,h)
sfd = sel1 fd
fd = getFont pr
om = sel2 fd
bbox_dy fontData = (bbox!!3) (bbox!!1)
where bbox = sel3 fontData
bbox_lx fontData = (sel3 fontData) !! 0
bbox_ly fontData = (sel3 fontData) !! 1
maximum_x fontData = (sel3 fontData) !! 2
polygonChar :: OutlineMap -> FontData -> V3->V3->Float -> (Rx,Int) -> String -> (String,V3) -> ([Geometry],V3)
polygonChar outl fontD v1 v2 sum_of_hs (rx,ry) tr (ch,h) = (geometry,h)
where
resize (x,y) = (v1 `mul` (x / sum_of_hs)) + (v2 `mul` (y / (bbox_dy fontD) ))
out = fromMaybe [] (Map.lookup ch outl)
l = map (map resize) out
geometry | ch /= " " = [outline_geometry ch l fontD ("outline_" ++ ch ++ "_" ++ (sel4 fontD) ++ "_" ++ tr)]
| otherwise = []
outline_geometry ch l fontD name = Geometry name
[ LP (LinePrimitive indices indices V.empty [blue]) ]
(Vertices "outline_vertices" (V.fromList (concat l))
(V.replicate (length (concat l)) (V3 0 0 1)))
where
indices = parts 0 lengths
parts n (p:ps) = V.cons (V.fromList [n..(n+p1)]) (parts (n+p) ps)
parts _ [] = V.empty
lengths = map length l
texChar :: TexMap -> FontData -> V3 -> V3 -> Float -> (String,V3,Float,String) -> (Rx,Int) -> ([Geometry],V3)
texChar texmap fontD v1 v2 sum_of_hs (ch,h,h_ad,tr) (rx,ry) = (geometry,h)
where
fontName = sel4 fontD
cn | isJust $ Map.lookup ch (sel1 fontD) = sel1 $ fromJust $ Map.lookup ch (sel1 fontD)
| otherwise = ch
charName ch | length ch == 1 && (head ch) >= 'A' && (head ch) <= 'Z' = ch ++ "BIG"
| otherwise = ch
name = "tex_" ++ (charName cn) ++ "_" ++ fontName ++ "_" ++ tr
tex = Texture (name ++ "_im") fileName $! texObj
fileName = (charName cn) ++"_"++ fontName ++"_"++ tr ++ (show (getx ch fontD (rx,ry))) ++ "x" ++ (show ry) ++ ".tga"
geometry =
[Geometry name [PL (LinePrimitive (V.fromList [V.fromList [0,1,2,3]])
(V.fromList [V.fromList [0,0,0,0]])
(V.fromList [V.fromList [0,1,2,3]])
[("phong_" ++ name, COMMON "" NoParam
(PhongTex [(TDiffuse tex)]
[[0,0,1,0,1,1,0,1]]
) ""
)]
)]
(Vertices (name ++ "_vertices")
(V.fromList [res (n,n), res (v1,n), res (v1,v2), res (n,v2)])
(V.fromList [ cross3 v1 v2 ])
)
]
res (v,w) = (v `mul` (h_ad / sum_of_hs)) + w
texObj = case Map.lookup (ch,fontName,tr) texmap of
Just x -> Just $! (fst $! x)
Nothing -> Nothing
n = (V3 0 0 0)
makeOutlMaps :: String -> (Rx,Int) -> (FontData, OutlineMap, OutlineTexMap)
makeOutlMaps str (rx,ry) = ( fontD, Map.fromList [ (ch, outlines ch) | ch <- allUnicodes ],
Map.fromList [ (ch, outlinesTex ch) | ch <- allUnicodes ] )
where
allUnicodes = Map.keys (sel1 fontD)
outlines ch = commandsToPoints (cs ch) (ds ch) (0, (bbox_ly fontD))
outlinesTex ch = map positiveX ( commandsToRasterPoints (cs ch) (stretch ch (ds ch)) (0, (bbox_ly fontD)) )
positiveX = map ( \(x,y,b) -> (if x>0 then x else 0, y, b) )
stretch ch (x,y) = (x * (hadv ch fontD) / max_x, y)
max_x = maximum_x fontD
cs ch = commands ch (sel1 fontD)
ds ch = deltas ch fontD (rx, ry)
fontD = openFont str
deltas :: String -> FontData -> (Rx,Int) -> (Float,Float)
deltas ch fontD (rx, ry) = (max_x/(fromIntegral $ getx ch fontD (rx,ry) ), (bbox_dy fontD) / (fromIntegral ry))
where max_x = maximum_x fontD
getx :: String -> FontData -> (Rx,Int) -> Int
getx ch fontD (rx, ry) | isExactly rx = fromJust $ getRx rx
| isConstDx rx = round nrx
| isXPowerOfTwo rx = roundP2 nrx
where nrx = ((fromIntegral ry)*((hadv ch fontD)/ (bbox_dy fontD) ))
roundP2 :: Float -> Int
roundP2 a = round $ head $ filter (>a) (take 100 (power2s 1))
power2s a = a : (power2s (a*2))
commands ch glyph | isJust element = unsafePerformIO $ pathFromString $ sel3 $ fromJust element
| otherwise = []
where element = Map.lookup ch glyph
makeTexMap :: (Rx,Int) -> Props -> Transf -> TexMap
makeTexMap (rx,ry) ps trs = Map.fromList [ (getID ch p, (glyph ch p)) | p <- (Map.elems ps), isTex p,
ch <- (allUnicodes p) ]
where
allUnicodes (Tex (fontD,_,_) _) = Map.keys (sel1 fontD)
glyph ch (Tex (fontD,_,outl) tr) = trace ch $ unsafePerformIO $
getGlyphTexture ch fontD outl (tr,trs) (getx ch fontD (rx,ry), fromIntegral ry)
getID :: String -> CharProp -> (String, String, String)
getID ch (Tex (fontD, _, _) transformation) = (ch, sel4 fontD, transformation)
getGlyphTexture :: String -> FontData -> OutlineTexMap -> (String,Transf) -> (Int,Int) ->
IO (TextureObject,String)
getGlyphTexture ch fontD om (tr,trs) (rx,ry) =
(do fileExists <- doesFileExist fileName
if fileExists then do tga <- (readTGA fileName)
createTexture (rx,ry) tga fileName
else do (writeTGA fileName (borderToTex (rx,ry) borderPoints (color coloredDummyObj) ))
tga <- (readTGA fileName)
createTexture (rx,ry) tga fileName
)
where cn | isJust $ Map.lookup ch (sel1 fontD) = sel1 $ fromJust $ Map.lookup ch (sel1 fontD)
| otherwise = ch
charName ch | length ch == 1 && (head ch) >= 'A' && (head ch) <= 'Z' = ch ++ "BIG"
| otherwise = ch
fileName = (charName cn) ++ "_" ++ (sel4 fontD) ++ "_" ++ tr ++ (show rx) ++ "x" ++ (show ry) ++ ".tga"
f :: Geometry -> Geometry
f = fromJust $ Map.lookup tr trs
coloredDummyObj = f $ Geometry "" [ LP (LinePrimitive e e e [blue]) ] (Vertices "" e e)
e = V.empty
color (Geometry "" [ LP (LinePrimitive _ _ _ [ (_, COMMON "" NoParam (PhongCol cs) _) ])
] _) = ( head $ catMaybes (map getDiffuseColor cs),
head $ catMaybes (map getAmbientColor cs) )
borderPoints = map (\(x,y,B b) -> (truncate x, truncate y, b)) $ concat $ fromJust ( Map.lookup ch om )