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 )
colors = 49
graphic = 515
xlocation = 521
ylocation = 523
stitchLocation = 533
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
if x .&. 2048 == 0x800 then (x 4096) else x
| otherwise =
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)
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
case (is12bit val3) of
True -> do
val4 <- getWord8
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)))
(254,176) -> do skip 3
parseStitches (DL.snoc blocks (DL.toList currentBlock ) ) DL.empty
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