{-# LANGUAGE CPP, FlexibleContexts #-}
module Graphics.SVGFonts.RasterFont
(
 commandsToRasterPoints, bitmasks, line, bitmask, borderToTex, sortSpans, overlaps, orBm, fillSpans, fillBitmask,
 bitSum, endBits, bits, showBits, createTexture, F2P(..), AA(..), Bitmask, ftrace
)
where

import Data.Array.MArray
import Data.Array.ST (STArray,STUArray)
import Data.Array.Unboxed (elems, amap, UArray, IArray, listArray)
import Data.Bits ( (.&.), (.|.), testBit, setBit, clearBit, shiftL, bit, shiftR, complement)
import Data.Maybe (isJust)
import Data.Word (Word8, Word16)
import Data.Tuple.Select
import Graphics.Formats.Collada.Vector2D3D (V4(..))
import Graphics.Formats.TGA.TGA -- (TGAData, Picture (..))
import Graphics.SVG.ReadPath (PathCommand, ctp)
import Graphics.Rendering.OpenGL
import List (sortBy)
import qualified Data.STRef
import Control.Monad (when, forM_)
import Control.Monad.ST
import Foreign (withArray)
import Debug.Trace
import System.IO.Unsafe
import qualified Data.ByteString.Lazy as B

var = Data.STRef.newSTRef
gett = Data.STRef.readSTRef
mutate = Data.STRef.modifySTRef

type X = Float
type Y = Float
type F2 = (X,Y)
type F2P = (X, Y, AA)
data AA = NB | -- ^ No Bitmask
          B Bitmask
type Bitmask = UArray Int Word16 -- ^ A Bitmask contains 256 values: An Array of 16 Word16

-- | Convert path-commands to outline points, which consist of bitmaps (resolution 16x16) of lines that go through
--   the pixel (subpixel rasterization)
commandsToRasterPoints :: [PathCommand] -> F2 -> F2 -> [[F2P]]
commandsToRasterPoints commands (dx, dy) (offsetX, offsetY)
    | null points = []
    | otherwise = map (bitmasks (dx, dy)) (map (\r -> r ++ [head r]) points)
  where points = ctp commands [(0,0)] (0,0) True (dx,dy) (offsetX, offsetY)

-----------------------------------------------------------------------------------------------------------------
-- generating bitmasks for rasterization

-- | Every tuple of consecutive outline points builds a line that is rasterized and cut into little bitmasks
bitmasks :: (X,Y) -> [F2] -> [F2P]
bitmasks _ [a] = []
bitmasks (dx,dy) ((p0x,p0y):((p1x,p1y):bs))
     | p0x_int == p1x_int = -- ftrace ((show p0x) ++ " " ++ (show p0y) ++ " " ++ " vert\n" ++ (concat (map showF2P (rasterStraightLine True)) ) ++ "\n\n\n" ) $
                            (rasterStraightLine True) ++
                            rest -- vertical line
     | p0y_int == p1y_int = -- ftrace ((show p0x) ++ " " ++ (show p0y) ++ " " ++ " hor\n" ++ (concat (map showF2P (rasterStraightLine False)) ) ++ "\n\n\n" ) $
                            (rasterStraightLine False) ++
                            rest -- horizontal line
     | ( (abs (p1x_int-p0x_int)) == 1 && (abs (p1y_int-p0y_int)) == 1 ) || (abs (p1x-p0x)) < dx && (abs (p1y-p0y)) < dy = 
 -- ftrace ((show p0x) ++ " " ++ (show p0y) ++ " " ++ " div22\n" ++ (concat (map showF2P div22) ) ++ "\n\n\n" ) $
                                                      div22 ++
                                                      rest -- line that is at most one pixel long
     | otherwise = rest -- trace (show (p1x_int-p0x_int) ++ " " ++ show (p1y_int-p0y_int) ++ " error in RasterFont.hs") rest -- should not happen
  where  rest = bitmasks (dx,dy) ((p1x, p1y):bs)
         (p0x_int, p0y_int) | p0y < p1y = (truncate $ p0x/dx, truncate $ p0y/dy)
                            | otherwise = (truncate $ p1x/dx, truncate $ p1y/dy)
         (p1x_int, p1y_int) | p0y < p1y = (truncate $ p1x/dx, truncate $ p1y/dy)
                            | otherwise = (truncate $ p0x/dx, truncate $ p0y/dy)

         rasterStraightLine up | up        = (divide 1 len_y smallerX p0y_int (line 1 len_y pixP0 pixP1)) -- up
                               | otherwise = (divide len_x 1 smallerX p0y_int (line len_x 1 pixP2 pixP3)) -- right
         divide :: Int -> Int -> Int -> Int -> UArray (Int,Int) Word16 -> [F2P]
         divide nx ny x y a = [ (fromIntegral (x+ex), fromIntegral (y+ey), B (bitmask ex ey a)) |
		                                                         ey <- [0..(ny-1)], ex <- [0..(nx-1)] ]
         div22 = divide 2 2 smallerX p0y_int (line 2 2 pixP4 pixP5)
         len_x = abs (p1x_int - p0x_int) + 1
         len_y = p1y_int - p0y_int + 1
         smallerX = truncate $ if (p0x < p1x) then p0x/dx else p1x/dx

         pixP0 | p0y < p1y =  (fracX p0x, fracY p0y)
               | otherwise =  (fracX p1x, fracY p1y)
         pixP1 | p0y < p1y =  (fracX p1x,(fracY p1y) + (p1y_int-p0y_int) * 16)
               | otherwise =  (fracX p0x,(fracY p0y) + (p1y_int-p0y_int) * 16)
         pixP2 | p0x < p1x =  (fracX p0x, fracY p0y)
               | otherwise =  (fracX p1x, fracY p1y)
         pixP3 | p0x < p1x = ((fracX p1x) + (abs (p1x_int-p0x_int)) * 16, fracY p1y)
               | otherwise = ((fracX p0x) + (abs (p1x_int-p0x_int)) * 16, fracY p0y)
         pixP4 | p0y < p1y = ((fracX p0x) + if p0x<p1x then 0 else 16, fracY p0y)
               | otherwise = ((fracX p1x) + if p0x<p1x then 16 else 0, fracY p1y)
         pixP5 | p0y < p1y = ((fracX p1x) + if p0x<p1x then 16 else 0, (fracY p1y) + 16)
               | otherwise = ((fracX p0x) + if p0x<p1x then 0 else 16, (fracY p0y) + 16)

         fracX = truncate.(*16).snd.properFraction.(/dx)
         fracY = truncate.(*16).snd.properFraction.(/dy)


thawSTU :: (IArray UArray e, MArray (STUArray s) e (ST s)) => UArray (Int,Int) e -> ST s (STUArray s (Int,Int) e)
thawSTU = thaw

-- | Bresenham line algorithm, adjusted to produce only one y value per row
-- The data structure for the line is a 2d array of bits, in x-direction a sequence of word16s
-- nx,ny are the size as multiples of 16,  draw line from (xa, ya) to (xb, yb)
line :: Int -> Int -> (Int,Int) -> (Int,Int) -> UArray (Int,Int) Word16
line nx ny (xa, ya) (xb, yb) = runST $ do
    a <- newArray ((0,0),(nx-1,ny*16-1)) (0 :: Word16) :: ST s (STUArray s (Int,Int) Word16)
    yV <- var y1
    errorV <- var $ deltax `div` 2
    forM_ [x1 .. x2] (\x -> do
        y <- gett yV
        mutate errorV $ subtract deltay
        error <- gett errorV
        when steep (setPix (a, y, x))
        when (not steep && (error < 0)) (setPix (a, x, y))
        when (error < 0) (do
            mutate yV (+ ystep)
            mutate errorV (+ deltax)))
    a' <- unsafeFreeze a
    return (a' :: UArray (Int,Int) Word16)
  where steep = abs (yb - ya) > abs (xb - xa)
        (xa', ya', xb', yb') = if steep
          then (ya, xa, yb, xb)
          else (xa, ya, xb, yb)
        (x1, y1, x2, y2) = if xa' > xb'
          then (xb', yb', xa', ya')
          else (xa', ya', xb', yb')
        deltax = x2 - x1
        deltay = abs $ y2 - y1
        ystep = if y1 < y2 then 1 else -1
        setPix (a, x, y) =
          when (x<nx*16 && y<ny*16 && x>=0 && y>=0)
          (writeArray a ((x `div` 16), y) (setBit (0::Word16) (x `mod` 16)))

-- | Slice out a single bitmask from an array of bitmasks
-- (this should be an unboxed array of unboxed arrays,
--  but since this is not so easy in Haskell, one 2d-array with a supersampled y-coordinate (*16) is used)
-- the x-supersampling are the bits in the Word16
bitmask :: Int -> Int -> UArray (Int,Int) Word16 -> Bitmask
bitmask ix iy mask = runST $ do
  ar <- thawSTU mask
  m <- newArray (0,15) (0::Word16) :: ST s (STUArray s Int Word16)
  forM_ [iy*16..iy*16+15] $ \y -> do
    e <- readArray ar (ix,y)
    writeArray m (y-iy*16) e
  m' <- unsafeFreeze m
  return (m' :: Bitmask)


-----------------------------------------------------------------------------------------------------
-- rasterization

alpha (V4 _ _ _ a) = a

-- | Border points to texture
borderToTex :: (Int,Int) -> [(Int, Int, Bitmask)] -> (V4,V4) -> TGAData
borderToTex (rx,ry) borderPoints (col, bgCol) | (alpha col) == 1 && (alpha bgCol) == 1
                         = TGAData (B.empty) (RGB24 (tgaRGB24 (col,bgCol) tgaData)) 0 0 rx ry
       | otherwise       = TGAData (B.empty) (RGB32 (tgaRGB32  col        tgaData)) 0 0 rx ry
  where
  tgaData = lines fs -- traceBitmask (overlaps $ sortSpans borderPoints) -- Caution! only small resolutions, i.e. 27x50, or you wait forever
  lines bs | B.null bs = B.empty
           | otherwise = B.append (B.reverse (B.take (fromIntegral rx) bs)) (lines (B.drop (fromIntegral rx) bs))

  fs = fillSpans (rx,ry) $ overlaps $ sortSpans borderPoints

tgaRGB32 col@(V4 r g b a) bs
    | isJust (B.uncons bs) = B.cons (m b) $
                             B.cons (m g) $
                             B.cons (m r) $
                             B.cons x (tgaRGB32 col (B.tail bs))
    | otherwise = B.empty
  where x = B.head bs
        m c = if (truncate (c*256)) == 0 then 0 else (truncate (c*256)) - 1

tgaRGB24 ( col@(V4 r g b _), bgCol@(V4 br bg bb _)) bs
    | isJust (B.uncons bs) = B.cons (m (sel3 color)) $
                             B.cons (m (sel2 color)) $
                             B.cons (m (sel1 color)) (tgaRGB24 (col,bgCol) (B.tail bs))
    | otherwise = B.empty
  where color = ( r*x + br*(256-x), g*x + bg*(256-x), b*x + bb*(256-x) )
        x = fromIntegral $ B.head bs
        m c = if (truncate c) == 0 then 0 else (truncate c) - 1


-- | Sorting so that the lowest y comes first, equal ys then the lowest x comes first
sortSpans :: [(Int,Int,Bitmask)] -> [(Int,Int,Bitmask)]
sortSpans pixels = sortBy sxy pixels 
  where sxy (x0,y0,b0) (x1,y1,b1) | y0 < y1 || (y0 == y1 && x0 < x1) = LT
                                  | y0 == y1 && x0 == x1 = EQ
                                  | otherwise = GT

-- | Assuming the list of bitmasks is sorted, two consecutive bitmasks can be on the same position
--   this happens if a line ends in pixel and a new line starts in the same pixel
overlaps :: [(Int,Int,Bitmask)] -> [(Int,Int,Bitmask)]
overlaps [] = []
overlaps [(x0,y0,b0)] = [(x0,y0,b0)]
overlaps ((x0,y0,b0):(x1,y1,b1):cs) | x0 == x1 && y0 == y1 = overlaps ( (x0,y0,b0 `orBm` b1) : cs )
                                    | otherwise            = (x0,y0,b0) : (overlaps ((x1,y1,b1):cs))

-- | Bitwise oring two Bitmasks
orBm :: Bitmask -> Bitmask -> Bitmask
orBm b0 b1 = listArray (0,15) $ zipWith (.|.) (elems b0) (elems b1)

-- | Fill a bitmask with 1s if the bit/subpixel is inside a polygon, (the bitmask was filled before with
-- subpixels of outline drawing of the polygon). The bitmask is an array of 16 word16 where the
-- x-direction are the bit position in the word16s. Horizontal(x-direction) lines are drawn if the
-- line is inside the polygon, called a span (see Jordan curve theorem).
-- A subpixel marks the beginnig or the end of a span depending on the state of the line.
-- At the beginning all lines are white, if one intersects a subpixel it becomes black until it
-- hits a subpixel again. The states at the end of the lines are stored for the next pixel in fillSpans.
-- If these state bits are all one or all zero and the next bitmask is completely zero then fewer
-- calculations need to be done.
fillSpans :: (Int, Int) -> [(Int,Int,Bitmask)] -> B.ByteString
fillSpans (rx,ry) [] = B.replicate (fromIntegral (rx*ry)) 0
fillSpans (rx,ry) ((x0,y0,b0):cs) = B.reverse $ B.append (B.replicate (fromIntegral (rx*y0+x0)) 0)
                                                         ( fillSp (rx,ry) 0 ((x0,y0,b0):cs) )

fillSp :: (Int, Int) -> Word16 -> [(Int,Int,Bitmask)] -> B.ByteString
fillSp (rx,ry) endbs ((x0,y0,b0):(x1,y1,b1):cs)
    | y0 /= y1 = B.append
    -- filling the end of a line (rx-x0) and the room between two shapes and the beginning of a new one (x1)
                 (B.cons (toC (bitSum fbm)) (B.replicate (fromIntegral (rx-x0-1+x1+linesBetween)) 0))
                 ( fillSp (rx,ry) 0 ((x1,y1,b1):cs) )

    | otherwise =    -- between two border points
        ( B.append (B.cons (toC (bitSum fbm)) (B.replicate (fromIntegral (x1-x0-1)) c))
                   (fillSp (rx,ry) eb ((x1,y1,b1):cs))
        )
  where fbm = fillBitmask b0 endbs
        eb  = endBits fbm
        beb = bits eb
        c = toC beb*16
        toC c | c /= 0 = fromIntegral $ c-1   -- because 256 is not a Byte
              | otherwise = fromIntegral c
        newl x y = x ++ "\n" ++ y
        linesBetween = (y1-y0-1)*rx -- the room between two shapes

--ftrace (if (y0==36) then (show x0 ++ " " ++ show y0 ++ " " ++ show endbs ++ " " ++ show (x1-x0) ++
--                  " " ++ show eb ++ " " ++ "\n" ++ (foldr newl "" $ map showBits $ elems b0) ++ (foldr newl "" $
--                  map showBits $ elems fbm) ++ "$\n" ) else [])

fillSp (rx,ry) _ [(x0,y0,b0)] =
    B.replicate (fromIntegral (rx-x0+(ry-y0-1)*rx)) 0 -- filling after the last border point


-- | Assuming a single line passes through a Bitmask, set all points right to this line to 1
fillBitmask :: Bitmask -> Word16 -> Bitmask
fillBitmask mask endbs =  listArray (0,15) $
                          zipWith (\x y -> if testBit endbs x then fillBefore y else fillAfter y)
                                 [0..15]
                                 (elems mask)

fillWord w16 i b | i == 15 = if tb then (if b then clearBit w16 i else setBit w16 i)
                                   else (if b then setBit w16 i   else clearBit w16 i)
                 | b && not tb = fillWord (setBit w16 i) (i+1) True  --  filling
                 | b &&     tb = fillWord  w16           (i+1) False -- no filling
                 | not b && not tb = fillWord  w16       (i+1) False -- no filling
                 | not b &&     tb = fillWord  w16       (i+1) True  --  filling
  where tb = testBit w16 i

-- | Before the first occurrance of a 1 set all bits to 1 example: 00001000 ~> 11110000
fillBefore :: Word16 -> Word16
fillBefore w16 = fillWord w16 0 True

-- | After the first occurrance of a 1 set all bits to 1 example: 00001000 ~> 00001111
fillAfter :: Word16 -> Word16
fillAfter w16 = fillWord w16 0 False

-- fillBefore w16 | w16 /= 0  = w16 + w16 - 1
--               | otherwise = -1  -- 00xFF
-- not always correct, but fast
-- fillAfter w16 | w16 /= 0  = complement (w16 + w16 - 1)
--               | otherwise = 0

-- | The sum of all bits in a Bitmask, 16 rows with 16 bits each => between 0 and 255
bitSum :: Bitmask -> Word16
bitSum mask = foldr (+) 0 $ elems $ amap bits mask

-- | Return the the rightmost column of a bitmask
endBits :: Bitmask -> Word16
endBits mask = sum $ zipWith shiftR (map lastBit (elems mask)) (reverse [0..15])
lastBit x = x .&. bit 15

-- | Count the number of 1-bits with divide and conquer
-- it can be done a little bit faster, but for the beginning it should just be correct
-- see "Hacker's Delight by Henry S. Warren, Addison Wesley" for bit counting
-- fst line: starting to count the 1's in 2-tuples: 0x55 = 01010101
-- 2nd line: 4 tuples:  0x33 = 0011001100
bits :: Word16 -> Word16
bits w16 = d8
  where d  = w16 .&. 0x5555 + (shiftR w16 1) .&. 0x5555
        d2 = d   .&. 0x3333 + (shiftR d  2)  .&. 0x3333
        d4 = d2  .&. 0x0F0F + (shiftR d2 4)  .&. 0x0F0F
        d8 = d4  .&. 0x00FF + (shiftR d4 8)


--------------------------------------------------------------------------------------------------------------

-- | OpenGL specific texture
createTexture :: (Int,Int) -> TGAData -> String -> IO (TextureObject, String)
createTexture (rx,ry) (TGAData _ (RGB24 picture) _ _ w h) fileName = tex fileName (rx,ry) (B.unpack picture)
createTexture (rx,ry) (TGAData _ (RGB32 picture) _ _ w h) fileName = tex fileName (rx,ry) (B.unpack picture)

tex :: String -> (Int,Int) -> [Word8] -> IO (TextureObject,String)
tex fileName (rx,ry) xs = do
  [texName] <- genObjectNames 1
  textureBinding Texture2D $= Just texName
  textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
  let imageSize = TextureSize2D (fromIntegral rx) (fromIntegral ry)
  withCheckImage xs imageSize f $
    texImage2D Nothing NoProxy 0  RGBA' imageSize 0
  return (texName, fileName)
 where
  f (a:(b:(c:(d:ds)))) = (Color4 (fromIntegral a) (fromIntegral b) (fromIntegral c) 255) : (f ds)
  f _ = []

withCheckImage :: [Word8] -> TextureSize2D ->
                  ([Word8] -> [(Color4 GLubyte)]) ->
                  (PixelData (Color4 GLubyte) -> IO ()) ->
                  IO ()
withCheckImage xs (TextureSize2D w h) f act =
  withArray (f xs)
  $ act. PixelData RGBA UnsignedByte


-------------------------------------------------------------------------------------------------------------
-- show / debugging functions

instance Show AA
  where show (NB) = "NB"
        show (B bits) = "B " ++ show (elems bits)

-- | Show a binary representation of a Word16
showBits :: Word16 -> String
showBits w16 = map ((\x -> if x then '1' else '0').(testBit w16)) (reverse [0..15])

showBitmask :: Bitmask -> String
showBitmask b = foldr newl "" (map showBits (elems b))
  where newl x y = x ++ "\n" ++ y

showF2P :: F2P -> String
showF2P (x,y,B b)  = show (truncate x) ++ " " ++ show (truncate y) ++ "\n" ++ (showBitmask b)

-- | Like trace from Debug.Trace but into a file
ftrace :: String -> a -> a
ftrace string expr = unsafePerformIO $ do
    appendFile "debug.txt" string
    return expr

traceBitmask :: [(Int,Int,Bitmask)] -> a -> a
traceBitmask bms expr = unsafePerformIO $ do
    writeFile "bitmasks.txt" (unlines (mergeBitmasks bms []))
    return expr

-- | Insert every Bitmask in a x,y-position to generate an ASCII picture in a text file
mergeBitmasks :: [(Int,Int,Bitmask)] -> [String] -> [String]
mergeBitmasks [] res = res
mergeBitmasks ((x,y,b):bs) ls = mergeBitmasks bs newPic
  where newPic = (take (y*16) ls) ++  -- copy lines until y-position
                 -- if an y-position is accessed that is bigger than ever before, write empty lines
                 (replicate (y*16-(length ls)) []) ++ 
                 insertedBitmasks ++ -- 16 lines where the bitmask is located
                 (drop ((y+1)*16) ls)
        insertLines = take 16 $ (drop (y*16) ls) ++ (replicate ((y+1)*16-(length ls)) [])
        insertedBitmasks = zipWith (\line bmLine-> (take (x*16) line) ++ (replicate (x*16- (length line)) '.' ) ++
                                                    bmLine ++ (drop ((x+1)*16) line))
                                   insertLines
                                   (map (reverse.showBits) (elems b))