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.
-- \<hkern g1=\"f,longs,uni1E1F,f_f\" g2=\"parenright,bracketright,braceright\" k=\"-37\" />
-- 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 <http://en.wikipedia.org/wiki/Kerning>
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 )