module Data.Iteratee.Codecs.Tiff where
import Data.Iteratee
import qualified Data.Iteratee as Iter
import qualified Data.Iteratee.Base.StreamChunk as SC
import Data.Iteratee.Binary
import Control.Monad
import Control.Monad.Trans
import Data.Char (chr)
import Data.Int
import Data.Word
import Data.Ratio
import Data.Maybe
import qualified Data.IntMap as IM
process_tiff :: MonadIO m => Maybe (IM.IntMap TIFFDE) ->
IterateeG [] Word8 m ()
process_tiff Nothing = return ()
process_tiff (Just dict) = do
note ["dict size: ", show $ IM.size dict]
check_tag TG_IMAGEWIDTH (flip dict_read_int dict) 129
check_tag TG_IMAGELENGTH (flip dict_read_int dict) 122
check_tag TG_BITSPERSAMPLE (flip dict_read_int dict) 8
check_tag TG_IMAGEDESCRIPTION (flip dict_read_string dict)
"JPEG:gnu-head-sm.jpg 129x122"
check_tag TG_COMPRESSION (flip dict_read_int dict) 1
check_tag TG_SAMPLESPERPIXEL (flip dict_read_int dict) 1
check_tag TG_STRIPBYTECOUNTS (flip dict_read_int dict) 15738
check_tag TG_XRESOLUTION (flip dict_read_rat dict) (72%1)
check_tag TG_YRESOLUTION (flip dict_read_rat dict) (72%1)
(n,hist) <- compute_hist dict
note ["computed histogram over ", show n, " values\n", show hist]
note ["Verifying values of sample pixels"]
verify_pixel_vals dict [(0,255), (17,248)]
where check_tag tag action v = do
vc <- action tag
case vc of
Just v' | v' == v -> note ["Tag ",show tag, " value ", show v]
_ -> error $ unwords ["Tag", show tag, "unexpected:", show vc]
compute_hist :: MonadIO m =>
TIFFDict ->
IterateeG [] Word8 m (Int,IM.IntMap Int)
compute_hist dict = Iter.joinI $ pixel_matrix_enum dict $ compute_hist' 0 IM.empty
where
compute_hist' count hist = IterateeG (step count hist)
step count hist (Chunk ch)
| SC.null ch = return $ Cont (compute_hist' count hist) Nothing
| otherwise = return $ Cont
(compute_hist' (count + SC.length ch) (foldr accum hist ch))
Nothing
step count hist s = return $ Done (count,hist) s
accum e = IM.insertWith (+) (fromIntegral e) 1
verify_pixel_vals :: MonadIO m =>
TIFFDict -> [(IM.Key, Word8)] -> IterateeG [] Word8 m ()
verify_pixel_vals dict pixels = Iter.joinI $ pixel_matrix_enum dict $
verify 0 (IM.fromList pixels)
where
verify _ m | IM.null m = return ()
verify n m = IterateeG (step n m)
step n m (Chunk xs)
| SC.null xs = return $ Cont (verify n m) Nothing
| otherwise = let (h, t) = (SC.head xs, SC.tail xs) in
case IM.updateLookupWithKey (\_k _e -> Nothing) n m of
(Just v,m') -> if v == h then step (succ n) m' (Chunk t)
else let er = (unwords ["Pixel #",show n,
"expected:",show v,
"found", show h])
in return $ Cont (throwErr . Err $ er) (Just $ Err er)
(Nothing,m')-> step (succ n) m' (Chunk t)
step _n _m s = return $ Done () s
type TIFFDict = IM.IntMap TIFFDE
data TIFFDE = TIFFDE{tiffde_count :: Int,
tiffde_enum :: TIFFDE_ENUM
}
data TIFFDE_ENUM =
TEN_CHAR (forall a m. Monad m => EnumeratorGMM [] Word8 [] Char m a)
| TEN_BYTE (forall a m. Monad m => EnumeratorGMM [] Word8 [] Word8 m a)
| TEN_INT (forall a m. Monad m => EnumeratorGMM [] Word8 [] Int m a)
| TEN_RAT (forall a m. Monad m => EnumeratorGMM [] Word8 [] (Ratio Int) m a)
data TIFF_TYPE = TT_NONE
| TT_byte
| TT_ascii
| TT_short
| TT_long
| TT_rational
| TT_sbyte
| TT_undefined
| TT_sshort
| TT_slong
| TT_srational
| TT_float
| TT_double
deriving (Eq, Enum, Ord, Bounded, Show)
data TIFF_TAG = TG_other Int
| TG_SUBFILETYPE
| TG_OSUBFILETYPE
| TG_IMAGEWIDTH
| TG_IMAGELENGTH
| TG_BITSPERSAMPLE
| TG_COMPRESSION
| TG_PHOTOMETRIC
| TG_THRESHOLDING
| TG_CELLWIDTH
| TG_CELLLENGTH
| TG_FILLORDER
| TG_DOCUMENTNAME
| TG_IMAGEDESCRIPTION
| TG_MAKE
| TG_MODEL
| TG_STRIPOFFSETS
| TG_ORIENTATION
| TG_SAMPLESPERPIXEL
| TG_ROWSPERSTRIP
| TG_STRIPBYTECOUNTS
| TG_MINSAMPLEVALUE
| TG_MAXSAMPLEVALUE
| TG_XRESOLUTION
| TG_YRESOLUTION
| TG_PLANARCONFIG
| TG_PAGENAME
| TG_XPOSITION
| TG_YPOSITION
| TG_FREEOFFSETS
| TG_FREEBYTECOUNTS
| TG_GRAYRESPONSEUNIT
| TG_GRAYRESPONSECURVE
| TG_GROUP3OPTIONS
| TG_GROUP4OPTIONS
| TG_RESOLUTIONUNIT
| TG_PAGENUMBER
| TG_COLORRESPONSEUNIT
| TG_COLORRESPONSECURVE
| TG_SOFTWARE
| TG_DATETIME
| TG_ARTIST
| TG_HOSTCOMPUTER
| TG_PREDICTOR
| TG_WHITEPOINT
| TG_PRIMARYCHROMATICITIES
| TG_COLORMAP
| TG_BADFAXLINES
| TG_CLEANFAXDATA
| TG_CONSECUTIVEBADFAXLINES
| TG_MATTEING
deriving (Eq, Show)
tag_map :: Num t => [(TIFF_TAG, t)]
tag_map = [
(TG_SUBFILETYPE,254),
(TG_OSUBFILETYPE,255),
(TG_IMAGEWIDTH,256),
(TG_IMAGELENGTH,257),
(TG_BITSPERSAMPLE,258),
(TG_COMPRESSION,259),
(TG_PHOTOMETRIC,262),
(TG_THRESHOLDING,263),
(TG_CELLWIDTH,264),
(TG_CELLLENGTH,265),
(TG_FILLORDER,266),
(TG_DOCUMENTNAME,269),
(TG_IMAGEDESCRIPTION,270),
(TG_MAKE,271),
(TG_MODEL,272),
(TG_STRIPOFFSETS,273),
(TG_ORIENTATION,274),
(TG_SAMPLESPERPIXEL,277),
(TG_ROWSPERSTRIP,278),
(TG_STRIPBYTECOUNTS,279),
(TG_MINSAMPLEVALUE,280),
(TG_MAXSAMPLEVALUE,281),
(TG_XRESOLUTION,282),
(TG_YRESOLUTION,283),
(TG_PLANARCONFIG,284),
(TG_PAGENAME,285),
(TG_XPOSITION,286),
(TG_YPOSITION,287),
(TG_FREEOFFSETS,288),
(TG_FREEBYTECOUNTS,289),
(TG_GRAYRESPONSEUNIT,290),
(TG_GRAYRESPONSECURVE,291),
(TG_GROUP3OPTIONS,292),
(TG_GROUP4OPTIONS,293),
(TG_RESOLUTIONUNIT,296),
(TG_PAGENUMBER,297),
(TG_COLORRESPONSEUNIT,300),
(TG_COLORRESPONSECURVE,301),
(TG_SOFTWARE,305),
(TG_DATETIME,306),
(TG_ARTIST,315),
(TG_HOSTCOMPUTER,316),
(TG_PREDICTOR,317),
(TG_WHITEPOINT,318),
(TG_PRIMARYCHROMATICITIES,319),
(TG_COLORMAP,320),
(TG_BADFAXLINES,326),
(TG_CLEANFAXDATA,327),
(TG_CONSECUTIVEBADFAXLINES,328),
(TG_MATTEING,32995)
]
tag_map' :: IM.IntMap TIFF_TAG
tag_map' = IM.fromList $ map (\(tag,v) -> (v,tag)) tag_map
tag_to_int :: TIFF_TAG -> Int
tag_to_int (TG_other x) = x
tag_to_int x = fromMaybe (error $ "not found tag: " ++ show x) $ lookup x tag_map
int_to_tag :: Int -> TIFF_TAG
int_to_tag x = fromMaybe (TG_other x) $ IM.lookup x tag_map'
tiff_reader :: IterateeG [] Word8 IO (Maybe TIFFDict)
tiff_reader = do
endian <- read_magic
check_version
case endian of
Just e -> do
endianRead4 e >>= Iter.seek . fromIntegral
load_dict e
Nothing -> return Nothing
where
read_magic = do
c1 <- Iter.head
c2 <- Iter.head
case (c1,c2) of
(0x4d, 0x4d) -> return $ Just MSB
(0x49, 0x49) -> return $ Just LSB
_ -> (throwErr .Err $ "Bad TIFF magic word: " ++ show [c1,c2])
>> return Nothing
tiff_version = 42
check_version = do
v <- endianRead2 MSB
if v == tiff_version
then return ()
else throwErr (Err $ "Bad TIFF version: " ++ show v)
u32_to_float :: Word32 -> Double
u32_to_float _x =
error "u32->float is not yet implemented"
u32_to_s32 :: Word32 -> Int32
u32_to_s32 = fromIntegral
u16_to_s16 :: Word16 -> Int16
u16_to_s16 = fromIntegral
u8_to_s8 :: Word8 -> Int8
u8_to_s8 = fromIntegral
note :: (MonadIO m) => [String] -> IterateeG [] el m ()
note = liftIO . putStrLn . concat
load_dict :: MonadIO m => Endian -> IterateeG [] Word8 m (Maybe TIFFDict)
load_dict e = do
nentries <- endianRead2 e
dict <- foldr (const read_entry) (return (Just IM.empty)) [1..nentries]
next_dict <- endianRead4 e
when (next_dict > 0) $
note ["The TIFF file contains several images, ",
"only the first one will be considered"]
return dict
where
read_entry dictM = dictM >>=
maybe (return Nothing) (\dict -> do
tag <- endianRead2 e
typ' <- endianRead2 e
typ <- convert_type (fromIntegral typ')
count <- endianRead4 e
note ["TIFFEntry: tag ",show . int_to_tag . fromIntegral $ tag,
" type ", show typ, " count ", show count]
enum_m <- maybe (return Nothing)
(\t -> read_value t e (fromIntegral count)) typ
case enum_m of
Just enum ->
return . Just $ IM.insert (fromIntegral tag)
(TIFFDE (fromIntegral count) enum) dict
_ -> return (Just dict)
)
convert_type :: (Monad m) => Int -> IterateeG [] el m (Maybe TIFF_TYPE)
convert_type typ | typ > 0 && typ <= fromEnum (maxBound::TIFF_TYPE)
= return . Just . toEnum $ typ
convert_type typ = do
throwErr . Err $ "Bad type of entry: " ++ show typ
return Nothing
read_value :: MonadIO m => TIFF_TYPE -> Endian -> Int ->
IterateeG [] Word8 m (Maybe TIFFDE_ENUM)
read_value typ e' 0 = do
endianRead4 e'
throwErr . Err $ "Zero count in the entry of type: " ++ show typ
return Nothing
read_value TT_ascii e' count | count > 4 = do
offset <- endianRead4 e'
return . Just . TEN_CHAR $ \iter_char -> return $ do
Iter.seek (fromIntegral offset)
let iter = convStream
(checkErr Iter.head >>= return . either (const Nothing) (Just . (:[]) . chr . fromIntegral))
iter_char
Iter.joinI $ Iter.joinI $ Iter.takeR (pred count) iter
read_value TT_ascii _e count = do
let len = pred count
let loop acc 0 = return . Just . reverse $ acc
loop acc n = Iter.head >>= (\v -> loop ((chr . fromIntegral $ v):acc)
(pred n))
str <- loop [] len
Iter.drop (4len)
case str of
Just str' -> return . Just . TEN_CHAR $ immed_value str'
Nothing -> return Nothing
read_value typ e' count | count > 4 && typ == TT_byte || typ == TT_sbyte = do
offset <- endianRead4 e'
return . Just . TEN_INT $ \iter_int -> return $ do
Iter.seek (fromIntegral offset)
let iter = convStream
(checkErr Iter.head >>= return . either (const Nothing) (Just . (:[]) . conv_byte typ))
iter_int
Iter.joinI $ Iter.joinI $ Iter.takeR count iter
read_value typ _e count | typ == TT_byte || typ == TT_sbyte = do
let loop acc 0 = return . Just . reverse $ acc
loop acc n = Iter.head >>= (\v -> loop (conv_byte typ v:acc)
(pred n))
str <- (loop [] count)
Iter.drop (4count)
case str of
Just str' -> return . Just . TEN_INT $ immed_value str'
Nothing -> return Nothing
read_value TT_undefined e' count | count > 4 = do
offset <- endianRead4 e'
return . Just . TEN_BYTE $ \iter -> return $ do
Iter.seek (fromIntegral offset)
Iter.joinI $ Iter.takeR count iter
read_value TT_undefined _e count = do
let loop acc 0 = return . Just . reverse $ acc
loop acc n = Iter.head >>= (\v -> loop (v:acc) (pred n))
str <- loop [] count
Iter.drop (4count)
case str of
Just str' -> return . Just . TEN_BYTE $ immed_value str'
Nothing -> return Nothing
read_value typ e' 1 | typ == TT_short || typ == TT_sshort = do
item <- endianRead2 e'
Iter.drop 2
return . Just . TEN_INT $ immed_value [conv_short typ item]
read_value typ e' 2 | typ == TT_short || typ == TT_sshort = do
i1 <- endianRead2 e'
i2 <- endianRead2 e'
return . Just . TEN_INT $
immed_value [conv_short typ i1, conv_short typ i2]
read_value typ e' count | typ == TT_short || typ == TT_sshort = do
offset <- endianRead4 e'
return . Just . TEN_INT $ \iter_int -> return $ do
Iter.seek (fromIntegral offset)
let iter = convStream
(checkErr (endianRead2 e') >>=
return . either (const Nothing) (Just . (:[]) . conv_short typ))
iter_int
Iter.joinI $ Iter.joinI $ Iter.takeR (2*count) iter
read_value typ e' 1 | typ == TT_long || typ == TT_slong = do
item <- endianRead4 e'
return . Just . TEN_INT $ immed_value [conv_long typ item]
read_value typ e' count | typ == TT_long || typ == TT_slong = do
offset <- endianRead4 e'
return . Just . TEN_INT $ \iter_int -> return $ do
Iter.seek (fromIntegral offset)
let iter = convStream
(checkErr (endianRead4 e') >>=
return . either (const Nothing) (Just . (:[]) . conv_long typ))
iter_int
Iter.joinI $ Iter.joinI $ Iter.takeR (4*count) iter
read_value typ e' count = do
_offset <- endianRead4 e'
note ["unhandled type: ", show typ, " with count ", show count]
return Nothing
immed_value :: (Monad m) => [el] -> EnumeratorGMM [] Word8 [] el m a
immed_value item iter =
return . joinI . return . joinIM $ (enumPure1Chunk item >. enumEof) iter
conv_byte :: TIFF_TYPE -> Word8 -> Int
conv_byte TT_byte = fromIntegral
conv_byte TT_sbyte = fromIntegral . u8_to_s8
conv_byte _ = error "conv_byte called with non-byte type"
conv_short :: TIFF_TYPE -> Word16 -> Int
conv_short TT_short = fromIntegral
conv_short TT_sshort = fromIntegral . u16_to_s16
conv_short _ = error "conv_short called with non-short type"
conv_long :: TIFF_TYPE -> Word32 -> Int
conv_long TT_long = fromIntegral
conv_long TT_slong = fromIntegral . u32_to_s32
conv_long _ = error "conv_long called with non-long type"
pixel_matrix_enum :: MonadIO m => TIFFDict -> EnumeratorN [] Word8 [] Word8 m a
pixel_matrix_enum dict iter = validate_dict >>= proceed
where
validate_dict = do
dict_assert TG_COMPRESSION 1
dict_assert TG_SAMPLESPERPIXEL 1
dict_assert TG_BITSPERSAMPLE 8
ncols <- liftM (fromMaybe 0) $ dict_read_int TG_IMAGEWIDTH dict
nrows <- liftM (fromMaybe 0) $ dict_read_int TG_IMAGELENGTH dict
strip_offsets <- liftM (fromMaybe [0]) $
dict_read_ints TG_STRIPOFFSETS dict
rps <- liftM (fromMaybe nrows) (dict_read_int TG_ROWSPERSTRIP dict)
if ncols > 0 && nrows > 0 && rps > 0
then return $ Just (ncols,nrows,rps,strip_offsets)
else return Nothing
dict_assert tag v = do
vfound <- dict_read_int tag dict
case vfound of
Just v' | v' == v -> return $ Just ()
_ -> throwErr (Err (unwords ["dict_assert: tag:", show tag,
"expected:", show v, "found:", show vfound])) >>
return Nothing
proceed Nothing = throwErr $ Err "Can't handle this TIFF"
proceed (Just (ncols,nrows,rows_per_strip,strip_offsets)) = do
let strip_size = rows_per_strip * ncols
image_size = nrows * ncols
note ["Processing the pixel matrix, ", show image_size, " bytes"]
let loop _pos [] iter' = return iter'
loop pos (strip:strips) iter' = do
Iter.seek (fromIntegral strip)
let len = min strip_size (image_size pos)
iter'' <- Iter.takeR (fromIntegral len) iter'
loop (pos+len) strips iter''
loop 0 strip_offsets iter
dict_read_int :: Monad m => TIFF_TAG -> TIFFDict ->
IterateeG [] Word8 m (Maybe Int)
dict_read_int tag dict = do
els <- dict_read_ints tag dict
case els of
Just (e:_) -> return $ Just e
_ -> return Nothing
dict_read_ints :: Monad m => TIFF_TAG -> TIFFDict ->
IterateeG [] Word8 m (Maybe [Int])
dict_read_ints tag dict =
case IM.lookup (tag_to_int tag) dict of
Just (TIFFDE _ (TEN_INT enum)) -> do
e <- joinIM $ enum stream2list
return (Just e)
_ -> return Nothing
dict_read_rat :: Monad m => TIFF_TAG -> TIFFDict ->
IterateeG [] Word8 m (Maybe (Ratio Int))
dict_read_rat tag dict =
case IM.lookup (tag_to_int tag) dict of
Just (TIFFDE 1 (TEN_RAT enum)) -> do
[e] <- joinIM $ enum stream2list
return (Just e)
_ -> return Nothing
dict_read_string :: Monad m => TIFF_TAG -> TIFFDict ->
IterateeG [] Word8 m (Maybe String)
dict_read_string tag dict =
case IM.lookup (tag_to_int tag) dict of
Just (TIFFDE _ (TEN_CHAR enum)) -> do
e <- joinIM $ enum stream2list
return (Just e)
_ -> return Nothing