{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleContexts #-}
module Graphics.SVGFonts.ReadFont
(displayString,
 makeOutlMap, makeTexMap,
 openFont,
 Mode(..), Spacing(..), CharProp(..)
)
where

import Data.Array hiding (elems,array,bounds)
import Data.Char
import Data.List
import Data.List.Split
import Data.Maybe
import qualified Data.Map as Map
import Data.Tuple.Select
import Debug.Trace
import Graphics.Formats.Collada.ColladaTypes
import Graphics.Formats.Collada.GenerateObjects (cube, blue, obj, makeScene, get_name)
import Graphics.Formats.TGA.TGA
import Graphics.Rendering.OpenGL hiding (Triangle)
import Graphics.SVGFonts.RasterFont (raster,F2P,Bitmask,AA(..),createTexture,texData)
import Graphics.SVG.ReadPath
import Graphics.Triangulation.Triangulation(polygonDirection, alternate)
import List(intersect,sortBy)
import System.Directory
import System.IO.Unsafe (unsafePerformIO)
import Text.XML.Light

-- http://www.w3.org/TR/SVG/fonts.html#KernElements
type Kern = ( Map.Map Char [Int], Map.Map Char [Int], Map.Map Char [Int], Map.Map Char [Int], Array Int X )
type SvgGlyph = Map.Map Char (String, X, String)
type FontData = (SvgGlyph, Kern, String, String)
type X = Float
type Y = Float
type F2 = (X,Y)

-- | Open an SVG-Font File and extract the data
--
-- Some explanation how kerning(<http://en.wikipedia.org/wiki/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. 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 (zip4 (unicodes, glyphNames, horiz, ds)), -- sort after unicode
                   (transform u1s, transform u2s, transform g1s, transform g2s, kAr), bbox, fname file )

  where 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
        glyphNames  = map (fromMaybe "") $ map (findAttr (unqual "glyph-name"))  selectGlyphs
        unicodes    = map (fromMaybe "") $ 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     = Data.Array.listArray (0,(length ks)-1) (map read ks)

        transform chars = Map.fromList $ map ch $ multiSet $ map (\(x,y) -> (x,[y])) $ sort fst $ concat $ index chars
        ch = \(x,y) -> (myHead x,y)
        index u = addIndex (map (splitWhen isColon) u) -- ie ["aa,b","c,d"] to [["aa","b"],["c","d"]]
                                                       --                   to [("aa",0),("b",0)],[("c",1), ("d",1)]
        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] -- 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))

        myHead a | length a == 0 = ' '
                 | otherwise = head a
        fname f = last $ init $ concat (map (splitOn "/") (splitOn "." f))
        zip4 (a:as, b:bs, c:cs, d:ds) = (myHead a, (b, read c, d)) : (zip4 (as,bs,cs,ds))
        zip4 _ = []

-- type Kern = ( Map.Map Char [Int], Map.Map Char [Int], Map.Map Char [Int], Map.Map Char [Int], Array Int X)
-- |horizontal advances of characters inside a string
horizontalAdvances :: [(Char,FontData)] -> Bool -> [X]
horizontalAdvances strfont kerning = hlist strfont
  where hlist :: [(Char,FontData)] -> [X]
        hlist [] = []
        hlist [(ch0,fd0)] = [ha ch0 fd0]
        hlist ((ch0,fd0):(ch1,fd1):s) = ((ha ch0 fd0) + (ka ch0 ch1 fd0 fd1 (sel2 fd0))) : (hlist ((ch1,fd1):s))
        ka :: Char -> Char -> FontData -> FontData -> Kern -> Float
        ka ch0 ch1 fd0 fd1 kern | (sel4 fd0) == (sel4 fd1) && kerning =
               (kernAdvance ch0 ch1 kern True) + (kernAdvance ch0 ch1 kern False) -- no kerning when different fonts
                                | otherwise = 0
        ha ch fd = sel2 $ fromJust $ Map.lookup ch (sel1 fd)

kernAdvance :: Char -> Char -> Kern -> Bool -> X
kernAdvance ch0 ch1 kern u |     u && (length s0) > 0 = (sel5 kern)Data.Array.!(head s0)
                           | not u && (length s1) > 0 = (sel5 kern)Data.Array.!(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 V = (Float,Float,Float) -- x,y,z
type O = V -- position vector

set_len (x,y,z) l = (x*c*l, y*c*l, z*c*l) where c = 1 / v_len (x,y,z)
v_len (x,y,z) = sqrt (x*x+y*y+z*z)
divide (x,y,z) c = (x/c, y/c, z/c)
mul (x,y,z) c = (x*c, y*c, z*c)
add (x0,y0,z0) (x1,y1,z1) = (x0+x1, y0+y1, z0+z1)
n = (0,0,0)

type TexMap =  Map.Map (Char,String,String,Bool) (TextureObject, String)
type OutlineMap =  Map.Map Char [[F2]]
data Mode = INSIDE_V1_V2 -- ^The string is inside v1 v2 boundaries (height/length-relation not kept)
          | INSIDE_V1    -- ^Stay inside v1 boundary, size of v2 adjusted to height/length-relation
          | INSIDE_V2    -- ^Stay inside v2 boundary, size of v1 adjusted to height/length-relation

data Spacing = MONO   -- ^Use mono spacing between glyphs (used in programming)
             | HADV   -- ^Every glyph has a unique constant horiz. advance
             | KERN   -- ^Same as HADV but sometimes overridden by kerning: i.e. the horizontal advance in \"VV\" is bigger than in \"VA\"
			          --      <http://en.wikipedia.org/wiki/Kerning>

mV1V2V3 INSIDE_V1_V2 = True
mV1V2V3 _ = False
mV1 INSIDE_V1 = True
mV1 _ = False
mV2 INSIDE_V2 = True
mV2 _ = False

isMono MONO = True
isMono _    = False
isKern KERN = True
isKern _    = False

type FileName = String
type P = [Char] -> [String]
data CharProp = Prop (FontData, OutlineMap) String Bool
type Transf = Map.Map String (Geometry -> Geometry)
type Props = Map.Map String CharProp
-- | Main library function
--
-- The string to display, resolution: (Int,Int) , mode, spacing, position and size apply to a whole string and therefore
-- are given here. There are local properties that can be unique for every char like Font, Color, ... .   
-- These are given with a property function that assign a list of properties to every char: P

displayString :: String -> String -> (Int,Int) -> Props -> Transf -> Mode -> Spacing -> O -> V -> V -> P -> TexMap -> Scene
displayString str sid (rx,ry) props transf mode spacing o v1 v2 f tex | mV1V2V3 mode = make_string v1 v2
                                                                      | mV1 mode     = make_string v1 new_v2
                                                                      | mV2 mode     = make_string new_v1 v2
  where
    -- FontData = ([(glyph_names, unicodes, horiz_advance, ds)], Kern, bbox-string, filename)
    make_string u1 u2 = makeScene sid $ map (\(x,y) -> obj (get_name (head x)) x y) (geometrieVs u1 u2)
    geometrieVs u1 u2 = map (getC u1 u2 sumh (rx,ry) tex) (zip5 str hor_pos hs properties trList)
    sumh | isMono spacing = max_x * (fromIntegral (length str)) -- not meant to be monospaced, so this is just a hack
         | otherwise      = sum hs                              -- maybe a very long glyph can mess up a font
    hor_pos | isMono spacing = reverse $ added (o: (replicate (length str) (v1_advance `mul` max_x)))
            | otherwise      = reverse $ added (o: stretch hs)
    hs = horizontalAdvances (zip str fontList) (isKern spacing)
    properties = map (fromJust.((\x y -> Map.lookup y x) props)) (f str)
    fontList = map (sel1.getFont) properties
    trList = map (fromJust.((\x -> Map.lookup x transf).getTr)) properties
    stretch = map (v1_advance `mul`)
    added = snd.(foldl (\(h,l) (b,_) -> (h`add`b, (h`add`b):l)) ((0,0,0),[])).(map (\x->(x,[]))) -- [o,o+h0,o+h0+h1,..]
    new_v1 = set_len v1 ( (v_len v2) * (sumh/max_y) ) -- in case there are several fonts in a string
    new_v2 = set_len v2 ( (v_len v1) * (max_y/sumh) ) -- max_y is the average of max heights
    max_x = (sum (map maximum_x fontList)) / (fromIntegral (length fontList)) -- difficult to treat different fonts in one string
    max_y = (sum (map maximum_y fontList)) / (fromIntegral (length fontList)) -- max height of glyph
    v1_advance | mV1V2V3 mode || mV1 mode = v1     `divide` sumh
               | mV2 mode                 = new_v1 `divide` sumh
    zip5 (a:as) (b:bs) (c:cs) (d:ds) (e:es) = (a, b, c, d, e) : (zip5 as bs cs ds es)
    zip5 _ _ _ _ _ = []

getC u1 u2 sh (rx,ry) tex (ch,h,h_ad,pr,tr) | isTex pr =  texChar     (sel1 sfd) tex    u1 u2 sh    (ch,h,h_ad)
                                            | otherwise = (map tr (fst pc), snd pc)
  where pc = polygonChar (sel1 sfd) om sfd u1 u2 sh (rx,ry) (ch,h)
        isTex :: CharProp -> Bool
        isTex (Prop _ _ b) = b
        sfd = sel1 fd
        fd = getFont pr
        om = sel2 fd

-- data CharProp = Prop (FontData, OutlineMap) Bool (Geometry -> Geometry)
getFont :: CharProp -> (FontData, OutlineMap)
getFont (Prop pr _ _) = pr

getTr :: CharProp -> String
getTr (Prop _ tr _) = tr

maximum_y fontData = read (head (drop 3 bbox)) -- bbox lower left x, lower left y, upper right x, upper right y
  where bbox = splitWhen isSpace (sel3 fontData)
maximum_x fontData = read (head (drop 2 bbox))
  where bbox = splitWhen isSpace (sel3 fontData)

polygonChar :: SvgGlyph -> OutlineMap -> FontData -> V -> V -> Float -> (Int,Int) -> (Char,V) -> ([Geometry],V)
polygonChar g outl fontD v1 v2 sum_of_hs (rx,ry) (ch,h) = ([geometry],h)
  where  -- h `add`
  resize (x,y) = (v1 `mul` (x * (fst deltas) / sum_of_hs)) `add` (v2 `mul` (y * (snd deltas)/ max_y))
  deltas = (max_x/(fromIntegral rx), max_y/(fromIntegral ry))
  out = fromJust $ Map.lookup ch outl
  max_x = maximum_x fontD
  max_y = maximum_y fontD
  l = map (map resize) out
  geometry = Geometry ("outline_" ++ [ch])
             [ LP (LinePrimitive indices indices [] [blue]) ]
             (Vertices "cube_vertices" (concat l) -- vertices
                                       (replicate (length (concat l)) (0,0,1))  )-- normals
  indices = parts 0 lengths
  parts n (l:ls) = [n..(n+l-1)] : (parts (n+l) ls)
  parts _ [] = []
  lengths = map length l

texChar :: SvgGlyph -> TexMap -> V -> V -> Float -> (Char,V,Float) -> ([Geometry],V)
texChar g texmap v1 v2 sum_of_hs (ch,h,h_ad) = ([geometry],h)
--          [ Annotate [ res (n,v2), res (n,n), res (v1,n), res (v1,v2) ] (TexObj tex) ] -- n = (0,0,0)
  where
  geometry = Geometry "outline"
             [ LP (LinePrimitive indices indices [] [blue]) ]
             (Vertices "cube_vertices" l -- vertices
                                (replicate 4 (0,0,1)) ) -- normals
  l = [res (n,v2), res (n,n), res (v1,n), res (v1,v2)]
  indices = [[0,1,2,3]]
  res (v,w) = h `add` (v `mul` (h_ad / sum_of_hs)) `add` w
--  tex = fromJust (Map.lookup ch texmap)

-- | Avoid recalculation of font data, outlines and textures
--
-- a char like "i" has two outlines (one for the dot) and two triangulations
makeOutlMap :: String -> (Int,Int) -> (FontData, OutlineMap) -- type OutlineMap =  Map.Map Char [([F2], Prop)]
makeOutlMap str (rx,ry) = (fontD, Map.fromList [ (ch, outlines ch) | ch <- allUnicodes ] )
  where
  allUnicodes = Map.keys (sel1 fontD)
  max_x = maximum_x fontD
  max_y = maximum_y fontD
  deltas = (max_x/(fromIntegral rx), max_y/(fromIntegral ry))
  outlines ch = getGlyphPolygon ch (sel1 fontD) deltas
  fontD = openFont str


-- data CharProp = Prop (FontData, OutlineMap) String Bool  
makeTexMap :: (Int,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 (Prop (fontD,_) _ _) = Map.keys (sel1 fontD)
   max_x ch fontD = h ch fontD -- maximum_x fontD
   max_y fontD = maximum_y fontD
   nrx ch fontD = fromIntegral $ round ((fromIntegral ry)*((h ch fontD)/ (max_y fontD))) -- ry/rx * (h_ad/max_y) * rx
   h ch fontD = sel2 (fromJust (Map.lookup ch (sel1 fontD)))
   deltas ch fontD = ((max_x ch fontD)/(fromIntegral (nrx ch fontD)), (max_y fontD)/(fromIntegral ry))
   isTex (Prop _ _ tex) = tex
   glyph ch (Prop (fontD,outl) tr _) = unsafePerformIO $ getGlyphTexture ch fontD (nrx ch fontD, fromIntegral ry) (deltas ch fontD)
   getID :: Char -> CharProp -> (Char,String,String,Bool)
   getID ch (Prop (fontD, _) transformation tex) = (ch, sel4 fontD, transformation, tex)
--   trNames = zip trs (map (\(Geometry str _ _) -> str) $ map (f cube) trs)
--   f a b = b a

getGlyphPolygon :: Char -> SvgGlyph -> F2 -> [[F2]]
getGlyphPolygon ch glyph deltas = outlines -- the triangulation is a list of triangles(3 indices)
  where d = sel3 (fromJust element)        -- ie. a letter like 'i' consists of two lists of triangles
        element = Map.lookup ch glyph
        outlines = commandsToPoints commands deltas
        commands | (length d) == 0 = []
                 | otherwise       = unsafePerformIO ( pathFromString d )

getGlyphTexture :: Char -> FontData -> (Int,Int) -> F2 -> IO (TextureObject,String)
getGlyphTexture ch fontD (rx,ry) (dx,dy) = (do fileExists <- doesFileExist fileName
                                               if fileExists then do tga <- (readTGA fileName)
                                                                     createTexture (rx,ry) tga fileName
                                                             else do (writeTGA fileName (texData (rx,ry) border_points))
                                                                     tga <- (readTGA fileName)
                                                                     createTexture (rx,ry) tga fileName
                                           )
  where d = sel3 (fromJust element)
        fileName = [ch] ++ "_" ++ (sel4 fontD) ++ (show rx) ++ "x" ++ (show ry) ++ ".tga"
        element = Map.lookup ch (sel1 fontD)
        border_points = (map (\(x,y, bits) -> case bits of (B b) -> (round (if x <0 then 0 else x), round (if y<0 then 0 else y), b))
                             (concat (commandsToRasterPoints commands (dx,dy))) ) -- generate border points
        texturing = True
        commands | (length d) == 0 = []
                 | otherwise       = unsafePerformIO ( pathFromString d )

-- |convert path-commands to outline points, which consist of bitmaps (resolution 16x16) for subpixel rasterization
commandsToRasterPoints :: [PathCommand] -> F2 -> [[F2P]]
commandsToRasterPoints commands (dx, dy) | length result == 0 = []
                                         | otherwise = map (raster (dx, dy)) result
  where result = ctp commands [(0,0)] (0,0) True 255 (dx,dy)