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
-- http://www.w3.org/TR/SVG/fonts.html#KernElements
type Kern = ( Map.Map String [Int],
Map.Map String [Int],
Map.Map String [Int],
Map.Map String [Int], Vector X ) -- ^ u1s, u2s, g1s, g2s, k
type SvgGlyph = Map.Map String (String, X, String) -- ^ \[ (unicode, (glyph_name, horiz_advance, ds)) \]
type FontData = (SvgGlyph, Kern, [Float], String) -- ^ (SvgGlyph, Kern, bbox-string, filename)
type X = Float
type Y = Float
-- | Open an SVG-Font File and extract the data
--
-- Some explanation how kerning is computed:
--
-- In Linlibertine.svg, there are two groups of chars: i.e.
-- \
-- 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
openFont :: FilePath -> FontData
openFont file = ( Map.fromList (myZip4 (unicodes, glyphNames, horiz, ds)), -- Map with unicode keys
(transform u1s, transform u2s, transform g1s, transform g2s, kAr), -- kerning data
parsedBBox,
fname file
)
where
-- monospaced fonts sometimes don't have a "horiz-adv-x="-value , replace with bbox value
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) -- 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 (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] -- 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))
fname f = last $ init $ concat (map (splitOn "/") (splitOn "." f))
-- | horizontal advances of characters inside a string
-- a character is stored with a string (originally because of ligatures)
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) -- no kerning when different fonts
| 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_V2: The string is inside v1 v2 boundaries (height/length-relation not kept)
| INSIDE_V1 -- ^ INSIDE_V1: Stay inside v1 boundary, size of v2 adjusted to height/length-relation
| INSIDE_V2 -- ^ INSIDE_V2: Stay inside v2 boundary, size of v1 adjusted to height/length-relation
mV1V2V3 INSIDE_V1_V2 = True
mV1V2V3 _ = False
mV1 INSIDE_V1 = True
mV1 _ = False
mV2 INSIDE_V2 = True
mV2 _ = False
-- | See
data Spacing = KERN -- ^ Recommended, same as HADV but sometimes overridden by kerning:
-- i.e. the horizontal advance in "VV" is bigger than in "VA"
| HADV -- ^ Every glyph has a unique constant horiz. advance
| MONO -- ^ Mono spacing between glyphs. Experimental.
-- Better use a monospaced font from the beginning.
-- The longest glyph influences the bbox that is used.
isMono MONO = True
isMono _ = False
isKern KERN = True
isKern _ = False
-- | The y resolution is constant. The x resolution of a glyph changes in non-mono-spaced fonts.
data Rx = Exactly Int
| ConstDx -- ^ The x-resolution of a single glvph is chosen so that all pixels
-- from several glyphs have the same size
| XPowerOfTwo -- ^ With this option the resolution nearest of a power of two is chosen
-- i.e. "l" would have (256,512), while "w" would have (512,512)
| OneTexture -- ^ The whole string as one texture (not implemented yet)
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
-- | Main library function, explained with an example (that is also in Fonts.hs):
--
-- @
-- main = do
-- args <- getArgs
-- let str = if null args then \"Haskell\"
-- else head args
-- resolution = (400, 400)
-- @
--
-- The resolution is used for textures but also for outlines.
-- Every outline point is placed in one grid position
--
-- @
-- mode = INSIDE_V2
-- spacing = KERN
-- tex = ConstDx
-- bit = makeOutlMaps \"../../../src/Test/Bitstream.svg\" resolution
-- lin = makeOutlMap \"..\/..\/../src\/Test\/LinLibertine.svg\" resolution
-- @
--
-- Several different fonts can be used. They are stored in Data.Map structures to avoid recalculation.
-- Lazy Evaluation ensures that outlines are only calculated if needed.
--
-- @
-- o = V3 0 0 0 -- origin
-- v1 = V3 (-5) 0 0 -- direction of char-advance
-- v2 = V3 0 0 1 -- height direction
-- v3 = V3 0 0.1 0 -- extrusion
-- @
--
-- The position and size of the string
--
-- @
-- f :: String -> [String]
-- f str = take (length str) (concat (repeat [\"p\",\"q\"]))
-- @
--
-- Assigning a property to every character by a string. Here an alternation of 3d and textured characters
--
-- @
-- props :: Props
-- props = Map.fromList [("p", Outl bit "to3d"), ("q", Outl bit "to3d2"),
-- ("r", Tex bit "red"), ("s", Tex bit "blue") ]
-- @
--
-- Finite data structures are assigned to every property string.
-- This is needed to lazily make a Data.Map with every possible representation of a character.
-- A textured character needs an unchanged (maybe colored) outline. Thats why \"q\" uses the id function.
-- If several fonts are used, kerning is disabled between every two characters that are from different fonts.
--
-- @
-- transf :: Transf
-- transf = Map.fromList [("to3d",to3d), ("to3d2",to3d2), ("red", red.bgWhite), ("blue",blue.bgWhite), ("id",id)]
-- @
--
-- Although there might be finitely many functions that make sense it is still to much and we need
-- a small finite list for Data.Map. The number of combinations is ((Number of chars in font0) +
-- (Number of chars in font1) + ...) * (number of transformation functions) and every of these
-- combinations is built (but only evaluated if needed because of lazy evaluation)
-- Example: (font1: 40 chars + font2: 1000 chars) X (5 colors (transformation functions))
-- 5200 key-value-pairs (assuming all colors are used in both fonts).
--
-- @
-- to3d geom = red $ ( ((extrude v3).deleteHoles) geom ) \`atop\` ( tri ((translate v3) geom) )
-- to3d2 geom = blue $ ( ((extrude (0,0.2,0)).deleteHoles) geom ) `atop` ( tri ((translate (0,0.2,0)) geom) )
-- tri = (triangulate ketTri).deleteHoles -- openglTriangulation
-- red = changeDiffuseColor "red" (1,0,0,1) -- if used with textures diffuse is interpreted as foreground color
-- blue = changeDiffuseColor "blue" (0,0,1,1)
-- bgWhite = changeAmbientColor "white" (1,1,1,1) -- if used with textures interpreted as background color
-- @
--
-- The functions can be anything like extrusion, triangulation, color
--
-- @
-- texmap = makeTexMap resolution props transf
-- @
--
-- Again a Data.Map-structure to avoid recalculation of textures.
-- This has been separated from the outlineMap because it may one day also store
-- the transformations applied to the outlines and maybe not every char is a texture
--
-- @
-- node = displayString str "node" resolution mode spacing (o,v1,v2) f props transf texmap
-- genCollada (lightedScene node) emptyAnim
-- putStrLn \"Collada File generated\"
-- @
--
-- node is a Node in a Scenegraph, that is inserted into a lighted scene
-- and written into file that can be viewed in Blender
--
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)) -- a hack, not meant to be monospaced
| otherwise = sum hs -- maybe a very long glyph can mess up a font
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,[]))) -- [o,o+h0,o+h0+h1,..]
newV1 = set_len v1 ( (v_len v2) * (sumh/maxY) ) -- in case there are several fonts in a string
newV2 = set_len v2 ( (v_len v1) * (maxY/sumh) ) -- maxY is the average of max heights
maxX = (sum (map maximum_x fontList)) /
(fromIntegral (length fontList)) -- difficult to treat different fonts in one string
maxY = (sum (map bbox_dy fontList)) / (fromIntegral (length fontList)) -- max height of glyph
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
-- because of ligatures, str may contain fewer glyphs, properties, fontList and trList have to be adjsuted
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)] -- group characters that have consecutively the same font
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 = [lower left x, lower left y, upper right x, upper right y]
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)) -- vertices
(V.replicate (length (concat l)) (V3 0 0 1))) -- normals
where
indices = parts 0 lengths
parts n (p:ps) = V.cons (V.fromList [n..(n+p-1)]) (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) -- description of the char (with a word)
| otherwise = ch
charName ch | length ch == 1 && (head ch) >= 'A' && (head ch) <= 'Z' = ch ++ "BIG" -- for Windows
| otherwise = ch
name = "tex_" ++ (charName cn) ++ "_" ++ fontName ++ "_" ++ tr
tex = Texture (name ++ "_im") fileName $! texObj -- force texObj to be evaluated because it produces a file
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]]) -- indices to vertices
(V.fromList [V.fromList [0,0,0,0]]) -- indices to normals
(V.fromList [V.fromList [0,1,2,3]]) -- indices to texture coordinates
[("phong_" ++ name, COMMON "" NoParam
(PhongTex [(TDiffuse tex)]
[[0,0,1,0,1,1,0,1]] -- [u0,v0,u1,v1,..] coordinates (Floats betw. 0 and 1)
-- that point into the texture
) ""
)]
)]
(Vertices (name ++ "_vertices")
(V.fromList [res (n,n), res (v1,n), res (v1,v2), res (n,v2)]) -- vertices
(V.fromList [ cross3 v1 v2 ]) -- normals
)
]
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)
-- | Generate a map of lists of outlines
-- i.e. the letter 'i' consists of two lists.
--
-- Two different kinds of outlines are produced because:
--
-- * 'OutlineMap': There are non-equally-spaced points possible (for outlines)
--
-- * 'OutlineTexMap': There are only equally spaced points (for spans in rasterization)
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))
-- TO DO: screws up rasterization in LinLibertine
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) )) -- ry/rx * (h_ad/max_y) * rx
-- | Round to the Power of two, i.e. roundP2 110 == 128, roundP2 130 == 256
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
-- | Texture images for all combinations of characters, fonts and transformations
-- for combinations of fonts and transformations only those are used that exist in this combination in the
-- property list while every character is used that exists in the svg-font file.
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) -- description of the char (with a word)
| otherwise = ch
charName ch | length ch == 1 && (head ch) >= 'A' && (head ch) <= 'Z' = ch ++ "BIG" -- for Windows
| 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 )