{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleContexts #-}
module Graphics.SVGFonts.RasterFont
 (raster, withCheckImage, createTexture, texData,
  bitmask, line, bitSum, endBits, bits,
  F2P, AA(..), Bitmask,
  ) where

import Data.Array.MArray
import Data.Array.ST (STArray,STUArray)
import Data.Array hiding (elems,array,bounds)
import Data.Array.Unboxed
import Data.Bits ( (.&.), testBit )
import Data.Word
import Data.Bits (testBit,setBit, shiftL, bit, shiftR)
import Data.STRef
import Data.Maybe
import Data.List
import Control.Monad (when, forM_, forM)
import Control.Monad.ST
import Graphics.Rendering.OpenGL hiding (get)
import Foreign (mallocBytes, withArray)
import Debug.Trace
import Graphics.Formats.TGA.TGA
import qualified Data.ByteString as B
import System.IO.Unsafe (unsafePerformIO)

var = Data.STRef.newSTRef
get = Data.STRef.readSTRef
sett = Data.STRef.writeSTRef
mutate = Data.STRef.modifySTRef

type F2P = (X, Y, AA)
data AA = NB | -- no bitmask
          B Bitmask
type Bitmask = UArray Int Word16
type X = Float
type Y = Float
type F2 = (X,Y)

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

raster (dx,dy) xs = -- trace (" xs " ++ show (map (\(x,y,_)->(round x, round y)) (rasterr (dx,dy) xs))) $
                    -- trace (" xs " ++ show (map (\(x,y,b) -> b) (rasterr (dx,dy) xs))) $
                    rasterr (dx,dy) xs

rasterr :: (X,Y) -> [F2] -> [F2P]
rasterr _ [a] = []
rasterr (dx,dy) ((p0x,p0y):((p1x,p1y):bs)) | (abs (p1x-p0x)) < dx && (abs (p1y-p0y)) < dy =
                                                div22 ++ rest -- line that is at most one pixel long
                                           | (abs (p1x-p0x)) < dx = rasterStraightLine True  ++ rest -- vertical line
                                           | (abs (p1y-p0y)) < dy = rasterStraightLine False ++ rest -- horizontal line
                                           | otherwise = trace "test" rest -- should not happen
  where  rest = rasterr (dx,dy) ((p1x, p1y):bs)
         (p0x_int, p0y_int) | p0y < p1y = (truncate p0x, truncate p0y)
                            | otherwise = (truncate p1x, truncate p1y)
         (p1x_int, p1y_int) | p0y < p1y = (truncate p1x, truncate p1y)
                            | otherwise = (truncate p0x, truncate p0y)

         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 (ex+x), fromIntegral (ey+y), B (bitmask ex ey a)) | -- (mark (ey*nx+ex))) | -- (bitmask ex ey a)) |
		                                                         ey <- [0..(ny-1)], ex <- [0..(nx-1)] ]
         div22 = divide 2 2 p0x_int p0y_int (line 2 2 pixP4 pixP5) -- (array ((0,0),(0,15)) [])
         -- mark n = array (0,15) [ (i,32) | i <- [0..15] ] -- bitmask ex ey a
         len_x = abs (p1x_int - p0x_int)
         len_y = p1y_int - p0y_int
         smallerX = truncate $ if (p0x < p1x) then p0x else p1x

         pixP0 | p0y < p1y = (truncate $ (frac p0x)*16, truncate $ (frac p0y)*16)
               | otherwise = (truncate $ (frac p1x)*16, truncate $ (frac p1y)*16)
         pixP1 | p0y < p1y = (truncate $ (frac p1x)*16, truncate $ (frac p1y + fromIntegral (p1y_int-p0y_int))*16)
               | otherwise = (truncate $ (frac p0x)*16, truncate $ (frac p0y + fromIntegral (p1y_int-p0y_int))*16)
         pixP2 | p0x < p1x = (truncate $ (frac p0x)*16, truncate $ (frac p0y)*16)
               | otherwise = (truncate $ (frac p1x)*16, truncate $ (frac p1y)*16)
         pixP3 | p0x < p1x = (truncate $ (frac p1x+ fromIntegral (abs (p1x_int-p0x_int)))*16, truncate $ (frac p1y)*16)
               | otherwise = (truncate $ (frac p0x+ fromIntegral (abs (p1x_int-p0x_int)))*16, truncate $ (frac p0y)*16)
         pixP4 | p0y < p1y = (truncate $ (frac p0x)*16, truncate $ (frac p0y)*16)
               | otherwise = (truncate $ (frac p1x)*16, truncate $ (frac p1y)*16)
         pixP5 | p0y < p1y = (truncate $ (frac p1x)*16, truncate $ (frac p1y)*16)
               | otherwise = (truncate $ (frac p0x)*16, truncate $ (frac p0y)*16)

         frac = snd.properFraction

texData :: (Int,Int) -> [(Int, Int, Bitmask)] -> TGAData
texData (rx,ry) border_points = tga $ fillSpace (rx,ry) border_points
  where
  tga t = (TGAData (B.empty)
                   (RGB32 (color t))
                   0 0
                   rx ry)
  color x | b == Nothing = B.empty
          | otherwise    = B.cons c $ B.cons c $ B.cons c $ B.cons c (color xs)
    where b = B.uncons x
          c = fst (fromJust b)
          xs = snd (fromJust b)

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

createTexture :: (Int,Int) -> TGAData -> String -> IO (TextureObject, String)
createTexture (rx,ry) (TGAData _ (RGB32 picture) _ _ w h) fileName = tex (B.unpack picture)
  where
  tex :: [Word8] -> IO (TextureObject,String)
  tex 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)

  f (a:(b:(c:(d:ds)))) = (Color4 (fromIntegral a) (fromIntegral b) (fromIntegral c) 255) : (f ds)
  f _ = []


fillSpace :: (Int, Int) -> [(Int,Int,Bitmask)] -> B.ByteString
fillSpace (rx,ry) pixels = fill (rx,ry) (sortBy sxy pixels) False
  where sxy (x0,y0,b0) (x1,y1,b1) | y0 < y1 || (y0 == y1 && x0 < x1) = LT
                                  | y0 == y1 && x0 == x1 = EQ
                                  | otherwise = GT

fill :: (Int,Int) -> [(Int,Int,Bitmask)] -> Bool -> B.ByteString
fill (rx,ry) ((x0,y0,b0):(x1,y1,b1):cs) inside | y0 == y1 && inside == False
   = B.cons (bitSum fbm) $ if ((x1-x0)>1) then B.append (B.replicate (x1-x0) ((endBits fbm)*16)) (fill (rx,ry) ((x1,y1,b1):cs) True)
                                          else (fill (rx,ry) ((x1,y1,b1):cs) True)
                                               | y0 == y1 && inside == True
   = B.cons (256-(bitSum fbm)) $ if ((x1-x0)>1) then B.append (B.replicate (x1-x0) ((16-(endBits fbm))*16)) (fill (rx,ry) ((x1,y1,b1):cs) False)
                                                else (fill (rx,ry) ((x1,y1,b1):cs) False)
                                               | y0 /= y1 =  B.append (B.append (B.replicate (rx-x0) ((16-(endBits fbm))*16))
									                                  (B.replicate (x1+(y1-y0)*rx) 0)) (fill (rx,ry) ((x1,y1,b1):cs) True)
  where
    fbm = fillBitmask b0

fill _ ((x0,y0,b0):cs) _ = B.empty

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

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

-- |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 -- trace ("x,y "++ show ix ++ "," ++ show iy ++ " ar ") (runST $ do
  ar <- thaw2 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)


fillBitmask :: Bitmask -> Bitmask
fillBitmask mask = runST $ do -- trace ("x,y "++ show ix ++ "," ++ show iy ++ " ar ") (runST $ do
  m <- newArray (0,15) (0::Word16) :: ST s (STUArray s Int Word16)
  ar <- thawSTU mask
  forM_ [0..15] $ \y -> do
    e <- readArray ar y
    writeArray m y (fillLine e)
  m' <- unsafeFreeze m
  return (m' :: Bitmask)

-- | after the first occurrance of a 1 set all bits to 1 example: 00001000 ~> 00001111
fillLine :: Word16 -> Word16
fillLine w16 = w16 + w16 - 1

-- | Bresenham line algorithm
--
-- the data structure for the line is a 2d array of bits, in x-direction a sequence of word16s
-- example: 
line :: Int -> Int -> (Int,Int) -> (Int,Int) -> UArray (Int,Int) Word16
line nx ny (xa, ya) (xb, yb) = runST $ do  -- nx,ny are the size as multiples of 16,  draw line from (xa, ya) to (xb, yb)
    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 <- get yV
        setPix $ if steep then (a, y, x) else (a, x, y)
        mutate errorV $ subtract deltay
        error <- get errorV
        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))) -- (x `mod` 16) can be replaced by x?


bitSum :: Bitmask -> Word8
bitSum mask = fromIntegral $ runST ( do
  s <- var $ 0
  ar <- thawSTU mask
  forM_ [0..15] $ \y -> do
    e <- readArray ar y
    mutate s (+ bits e)
  get s)

endBits :: Bitmask -> Word8
endBits mask = fromIntegral $ runST ( do
  s <- var $ 0
  ar <- thawSTU mask
  forM_ [0..15] $ \y -> do
    e <- readArray ar y
    mutate s (+ shiftL (e .&. (bit 15)) y)
  get s)

bits :: Word16 -> Word16
bits w16 = runST ( do
  s <- var $ w16
  -- fst line: starting to count the 1's in 2-tuples: 0x55 = 01010101
  -- 2nd line: 4 tuples:  0x33 = 0011001100
  sv <- get s
  sett s (sv .&. 0x5555 + (shiftR sv 1) .&. 0x5555)
  sv <- get s
  sett s (sv .&. 0x3333 + (shiftR sv 2) .&. 0x3333)
  sv <- get s
  sett s (sv .&. 0x0F0F + (shiftR sv 4) .&. 0x0F0F)
  sv <- get s
  sett s (sv .&. 0x00FF + (shiftR sv 8))
  get s )

-- | The sum of all bits in a Bitmask, 16 rows with 16 bits each => between 0 and 255
-- bitSum2 :: B.ByteString -> Word8 -- 8 bytes == 64 grey values
-- bitSum2 bs = B.foldl (+) 0 (B.take 8 (map bits2 bs))

-- | Return the the rightmost column of a bitmask
-- endBits2 :: B.ByteString -> Word8 -- 64 grey values
-- endBits2 bs = (B.foldl (+) 0 (B.take 8 (map (\x -> x .&. 1) bs))) * 8

tga_trace :: (UArray (Int,Int) Bool, UArray (Int,Int) Word16) -> (UArray (Int,Int) Bool, UArray (Int,Int) Word16)
tga_trace (a,b) = unsafePerformIO $
                  do writeTGA "test.tga" tga
                     return (a,b)
  where
    tga = trace ((show rx) ++ " " ++ (show ry)) (TGAData (B.empty)
                   (RGB32 $ B.concat $ map color $ concat $ map bits $ elems b)
                   0 0
                   (rx*16) ry)
    (_,(rx,ry)) = bounds b
    bits :: Word16 -> [Word8]
    bits a = map (\x -> if x==True then 255 else 0) (
               (testBit a 0) : (testBit a 1) : (testBit a 2) :
               (testBit a 3) : (testBit a 4) : (testBit a 5) :
               (testBit a 6) : (testBit a 7) : (testBit a 8) :
			   (testBit a 9) : (testBit a 10): (testBit a 11):
               (testBit a 12): (testBit a 13): (testBit a 14):
               [testBit a 15] )
    color x = B.cons x $ B.cons x $ B.cons x $ B.singleton x

  -- |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.