module Data.AdobeSwatchExchange where
import Control.Applicative ((<$>))
import Control.Monad (replicateM)
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Lazy.Char8 as C
import Data.Char (chr, ord)
import Data.Data (Data, Typeable)
import Data.Word (Word16)
import Data.Binary.IEEE754 (getFloat32be, putFloat32be)
import Numeric (showHex)
import Data.Binary (Binary(..))
import Data.Binary.Get ( Get, getByteString, getWord8, getWord16be, getWord32be, runGet )
import Data.Binary.Put ( Put, putByteString, putWord8, putWord16be, putWord32be, runPut )
data Color
= CYMK Float Float Float Float
| RGB Float Float Float
| LAB Float Float Float
| Gray Float
deriving (Eq, Ord, Read, Show, Data, Typeable)
data ColorType
= Global
| Spot
| Normal
deriving (Eq, Ord, Read, Show, Data, Typeable)
data ColorEntry = ColorEntry
{ colorName :: String
, color :: Color
, colorType :: ColorType
}
deriving (Eq, Ord, Read, Show, Data, Typeable)
data ASEBlock
= GroupStart { groupName :: String }
| GroupEnd
| CE ColorEntry
deriving (Eq, Ord, Read, Show, Data, Typeable)
data AdobeSwatchExchange = AdobeSwatchExchange
{ version :: (Word16, Word16)
, blocks :: [ASEBlock]
}
deriving (Eq, Ord, Read, Show, Data, Typeable)
getFileSig :: Get ()
getFileSig =
do bs <- getByteString 4
case bs of
"ASEF" -> return ()
_ -> fail $ "Invalid file signature: " ++ show bs
putFileSig :: Put
putFileSig = putByteString "ASEF"
getVersion :: Get (Word16, Word16)
getVersion =
do maj <- getWord16be
min <- getWord16be
return (maj, min)
putVersion :: (Word16, Word16) -> Put
putVersion (maj, min) =
do putWord16be maj
putWord16be min
getBlock :: Get ASEBlock
getBlock =
do blockType <- getWord16be
case blockType of
0xc001 -> do bl <- getWord32be
n <- getName
return (GroupStart n)
0xc002 -> do bl <- getWord32be
return GroupEnd
0x0001 -> CE <$> getColorEntry
_ -> fail $ "Unknown block type: " ++ (showHex blockType "")
putBlock :: ASEBlock -> Put
putBlock (GroupStart groupName) =
do putWord16be 0xc001
putWord32be $ blName groupName
putName groupName
putBlock GroupEnd =
do putWord16be 0xc002
putWord32be 0
putBlock (CE colorEntry) =
do putWord16be 0x0001
putColorEntry colorEntry
getName :: Get String
getName =
do nameLength <- getWord16be
doubleChars <- replicateM ((fromIntegral nameLength) 1) getWord16be
_ <- getWord16be
return $ map (chr . fromIntegral) doubleChars
putName :: String -> Put
putName nm =
do putWord16be $ (fromIntegral (length nm) + 1)
mapM_ (putWord16be . fromIntegral . ord) nm
putWord16be 0
blName :: (Integral a) => String -> a
blName nm =
fromIntegral (2 + (length nm * 2) + 2)
getColor :: Get Color
getColor =
do modelString <- map (chr . fromIntegral) <$> replicateM 4 getWord8
case modelString of
"CYMK" -> do c <- getFloat32be
y <- getFloat32be
m <- getFloat32be
k <- getFloat32be
return $ CYMK c y m k
"RGB " -> do r <- getFloat32be
g <- getFloat32be
b <- getFloat32be
return $ RGB r g b
"LAB " -> do l <- getFloat32be
a <- getFloat32be
b <- getFloat32be
return $ LAB l a b
"Gray" -> do g <- getFloat32be
return $ Gray g
_ -> fail $ "Unknown color model: " ++ modelString
putColor :: Color -> Put
putColor (CYMK c y m k) =
do mapM_ (putWord8 . fromIntegral . ord) "CYMK"
putFloat32be c
putFloat32be y
putFloat32be m
putFloat32be k
putColor (RGB r g b) =
do mapM_ (putWord8 . fromIntegral . ord) "RGB "
putFloat32be r
putFloat32be g
putFloat32be b
putColor (LAB l a b) =
do mapM_ (putWord8 . fromIntegral . ord) "LAB "
putFloat32be l
putFloat32be a
putFloat32be b
putColor (Gray g) =
do mapM_ (putWord8 . fromIntegral . ord) "Gray"
putFloat32be g
blColor :: (Integral a) => Color -> a
blColor (CYMK {}) = 20
blColor (RGB {}) = 16
blColor (LAB {}) = 16
blColor (Gray {}) = 8
getColorType :: Get ColorType
getColorType =
do ct <- getWord16be
case ct of
0 -> return Global
1 -> return Spot
2 -> return Normal
_ -> fail $ "Unknown color type: " ++ show ct
putColorType :: ColorType -> Put
putColorType Global = putWord16be 0
putColorType Spot = putWord16be 1
putColorType Normal = putWord16be 2
instance Binary ColorType where
put = putColorType
get = getColorType
blColorType :: (Integral a) => a
blColorType = fromIntegral 2
getColorEntry :: Get ColorEntry
getColorEntry =
do bl <- getWord32be
nm <- getName
color <- getColor
typ <- getColorType
return $ ColorEntry { colorName = nm
, color = color
, colorType = typ
}
putColorEntry :: ColorEntry -> Put
putColorEntry (ColorEntry cn c ct) =
do putWord32be (blName cn + blColor c + blColorType)
putName cn
putColor c
putColorType ct
instance Binary ColorEntry where
put = putColorEntry
get = getColorEntry
getASE :: Get AdobeSwatchExchange
getASE =
do getFileSig
v <- getVersion
numBlocks <- getWord32be
bs <- replicateM (fromIntegral numBlocks) getBlock
return $ AdobeSwatchExchange { version = v
, blocks = bs
}
putASE :: AdobeSwatchExchange -> Put
putASE (AdobeSwatchExchange v blks) =
do putFileSig
putVersion v
putWord32be (fromIntegral $ length blks)
mapM_ putBlock blks
instance Binary AdobeSwatchExchange where
put = putASE
get = getASE
colorToHex :: Color -> String
colorToHex (RGB r g b) =
showString "#" .
showHex' (round (r * 255)) .
showHex' (round (g * 255)) .
showHex' (round (b * 255)) $ ""
where
showHex' n
| n < 10 = showString "0" . showHex n
| otherwise = showHex n
colorToHex c =
error $ "Alas! We have not written the code to convert " ++ show c ++ " to the RGB color space."