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

module Codec.Binary.Embroidery (importPES,displayRendering,parsePES) where

import Data.Word
import qualified Data.ByteString.Lazy as L
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


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

data EmbFile = EmbFile {
      pecstart :: Word32
    , width :: Word16
    , height :: Word16
    , numColors :: Int
    , header :: String 
    , blocks :: [[Stitch]]
    } deriving (Eq, Show )

{- offsets for PES format -}
colors = 49
graphic = 515
xlocation = 521
ylocation = 523
stitchLocation = 533

{-if the high bit is set, this indicates a 12bit value will be used-}
is12bit :: Word8 -> Bool
is12bit v = (v .&. 0x80 == 0x80) 

getD :: Word8 -> Word8 -> Int
getD val1 val2 
        | is12bit val1 = let x ::Int  = ( fromIntegral (val1 .&. 15) * 256 ) + fromIntegral val2 in {- Signed 12-bit arithmetic -}
                             if x .&. 2048 == 0x800 then (x - 4096) else x
        | otherwise =  {- 7 bit signed delta -}
                             if val1 .&. 64  /= 0 then 
                                (fromIntegral val1 - 128) else fromIntegral val1

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

splus (Stitch x1 y1) (Stitch x2 y2) = (  Stitch (x1+x2)  (y1+y2))

fabs :: [Stitch] -> State Stitch [Stitch]
fabs [] = return ([])
fabs (s:rst) = do
           last <- get
           let abs = (last `splus` s )
           put abs
           calcrest <- fabs rst
           return (abs : calcrest)

{- takes a list of stitch blocks in relative coordinates and finds the absolute coordinates. uses state monad to 
ensure that the next block starts where the last block ended
 -}
runFabs :: [[Stitch]] -> [[Stitch]]
runFabs stitches = evalState (do mapM fabs stitches ) (Stitch 0 0)



getDelta :: Parser (Int,Int)
getDelta = do
        val1 <- getWord8
        val2 <- getWord8
        let xval = getD val1 val2 in
		case is12bit val1 of 
                        True -> do 
                             val3 <- getWord8   {- get the next byte for the y value -}
                             case (is12bit val3) of
                               True -> do
                                        val4 <- getWord8  {- its a jump stitch, so we need two bytes. this still seems wrong - jumps are too big-}
                                        let yval = getD val3 val4 in
                                         return (xval,yval)
                               False-> let yval = getD val3 0 in
                                         return (xval,yval)

			False -> case is12bit val2 of
				 	True -> do
						val3 <- getWord8
						let yval = getD val2 val3 in
						    return (xval,yval)
		
					False -> let yval = getD val2 0 in
						     return (xval,yval)
						

getTwoBytes = do
		a <-getWord8
		b <-getWord8
		return (a,b)

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

parseStitches :: DL.DList [Stitch] -> DL.DList Stitch -> Parser [[Stitch]]
parseStitches blocks currentBlock = do
        bytes <- lookAhead getTwoBytes
        case bytes of
                (255,0)  -> return (DL.toList (DL.snoc blocks (DL.toList currentBlock)))  {-done with the stitches -}
                (254,176) -> do skip 3 {- skip two for the look ahead, one for the bogus stitch -}
                                parseStitches (DL.snoc blocks (DL.toList currentBlock ) ) DL.empty  {- this is a color switch so start a new block -}
                otherwise -> do (x,y) <- getDelta
                                parseStitches blocks ( DL.snoc currentBlock (buildStitch x y ) )
	

parsePES :: Parser EmbFile
parsePES = do
	header <- string "#PES"
	skip 4
	pecstart <- getWord24le
	bread <- bytesRead
	skip  ((fromIntegral pecstart) - (fromIntegral bread) - 1)
	skip xlocation
	width <- getWord16le
	height <- getWord16le
	skip 8
	stitches <- parseStitches DL.empty DL.empty
	return (EmbFile pecstart width height 4 header (runFabs stitches) )

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


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