{-# LANGUAGE ScopedTypeVariables #-}
{-# Language DeriveDataTypeable #-}

module Codec.Binary.Embroidery.PCS (importFile,exportFile,displayRendering,parsePCS) where

import Data.Word
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as L
import Data.Binary.Put 
import Data.Int
import Data.Bits
import Data.ByteString.Parser
import qualified Data.DList as DL

import Graphics.Gloss

import Monad
import Control.Monad.State
import Debug.Trace

data StitchColor = StitchColor !Int !Int !Int deriving (Eq, Show )
data Stitch = Stitch !Int !Int deriving (Eq, Show )
data StitchBlock = MyStitchBlock [Stitch] deriving (Eq, Show )

data EmbFile = EmbFile {
     size :: Int
    ,numColors :: Int
    ,blocks :: [[Stitch]]
    ,colors :: [StitchColor]
    } deriving (Eq, Show )


mkPt :: Stitch -> (Float,Float)
mkPt (Stitch x y) = (fromIntegral x , fromIntegral (-y ))

buildStitch x y =
	Stitch (fromIntegral x) (fromIntegral y)

readColors :: DL.DList StitchColor -> Int -> Parser [StitchColor]
readColors colors 0 = return (DL.toList colors)
readColors colors count = do
        r <- getWord8
        g <- getWord8
        b <- getWord8
        end <- getWord8
        let c = StitchColor (fromIntegral r) (fromIntegral g) (fromIntegral b )
        readColors (DL.snoc colors c) (count-1)

serialiseCoord :: Int -> [Word8]
serialiseCoord n = 
    let three  = n `div` 65536
        two  = (n - (three * 65536)) `div` 256
        one  = n - (three * 65536) - (two * 256) in
     map fromIntegral [one,two,three, 0]
    
serialiseStitch :: Stitch -> Put
serialiseStitch (Stitch x y) = do
    let bytes = (serialiseCoord x) ++ (serialiseCoord y) in
        mapM_ putWord8 bytes

readStitchBytes :: Parser Int
readStitchBytes = do
        skip 1
        a <- getWord8
        b <- getWord8
        c <- getWord8
        let coord:: Int = fromIntegral a + (fromIntegral b `shiftL` 8 ) + (fromIntegral c `shiftL` 16)
        return (coord)


parseStitches :: DL.DList [Stitch] -> DL.DList Stitch -> Int -> Parser [[Stitch]]

parseStitches blocks currentBlock 0 = return (DL.toList (DL.snoc blocks (DL.toList currentBlock)))  {-done with the stitches -}

parseStitches blocks currentBlock scount = do
        x <- readStitchBytes
        y <- readStitchBytes
        skip 1
        parseStitches blocks ( DL.snoc currentBlock (buildStitch x y ) ) (scount-1)

parsePCS :: Parser EmbFile
parsePCS = do
	skip 1 
        size <- getWord8
	numcolors <- getWord16be
        colors <- readColors DL.empty 16
	numStitches <- getWord16le 
        let !bla = if (numStitches ==0 || trace (show numStitches) False ) then 1 else 0
	stitches <- parseStitches DL.empty DL.empty (fromIntegral numStitches ) 
	return (EmbFile (fromIntegral size) 16 stitches colors)

countStitches :: EmbFile -> Int 
countStitches e = length (concat (blocks e ))

serialiseColor :: StitchColor -> Put
serialiseColor (StitchColor r g b) = do
    putWord8 (fromIntegral r)
    putWord8 (fromIntegral g)
    putWord8 (fromIntegral b)
    putWord8 0

serialisePCS :: EmbFile -> Put
serialisePCS e = do
        putWord8 32  {- header byte -}
        putWord8 (fromIntegral (size e))  {- size of the hoop needed for design -}
        putWord8 16 {- number of colors - always 16 -}
        putWord8 0
        mapM_ serialiseColor (colors e)  {- hopefully this will write out each color -}
        putWord16be (fromIntegral (countStitches e))
        mapM_ serialiseStitch (concat (blocks e))

exportFile :: FilePath -> EmbFile -> IO ()
exportFile f e = L.writeFile f $ writePCS e
        where writePCS = runPut . serialisePCS

importFile :: FilePath -> IO (Either String EmbFile)
importFile n = do
	bs <- L.readFile n
	return $! runParser parsePCS bs


displayRendering = displayInWindow "My Window" (200, 200) (10, 10) white
                                               . Pictures
                                               . map (Line . map mkPt)
                                               . blocks

