module Data.Iteratee.Codecs.Tiff where
import Data.Iteratee.Base (StreamG (..), IterateeG (..), IterateeGM, EnumeratorGMM, EnumeratorN, bindm, liftI, (==<<), (>.), (>>==), iterErr, enumErr, convStream, iterReportError, enumEof)
import qualified Data.Iteratee.Base as Iter
import qualified Data.Iteratee.Base.StreamChunk as SC
import Data.Iteratee.Binary
import Control.Monad.State
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) ->
IterateeGM [] Word8 m (Maybe String)
process_tiff Nothing = return $ Just "No dictionary"
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]
iterReportError >>= maybe (return ()) error
note ["Verifying values of sample pixels"]
verify_pixel_vals dict [(0,255), (17,248)]
err <- iterReportError
maybe (return ()) error err
return err
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 ->
IterateeGM [] Word8 m (Int,IM.IntMap Int)
compute_hist dict = Iter.joinI $ pixel_matrix_enum dict ==<< compute_hist' 0 IM.empty
where
compute_hist' count = liftI . Cont .step count
step count hist (Chunk ch)
| SC.null ch = compute_hist' count hist
| otherwise = compute_hist' (count + SC.length ch) (foldr accum hist ch)
step count hist s = liftI $ Done (count,hist) s
accum e = IM.insertWith (+) (fromIntegral e) 1
verify_pixel_vals :: MonadIO m =>
TIFFDict -> [(IM.Key, Word8)] -> IterateeGM [] 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 = liftI $ Cont (step n m)
step n m (Chunk xs)
| SC.null xs = verify n m
| 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 iterErr $ unwords ["Pixel #",show n,
"expected:",show v,
"found", show h]
(Nothing,m')-> step (succ n) m' (Chunk t)
step _n _m s = liftI $ 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 :: IterateeGM [] Word8 IO (Maybe TIFFDict)
tiff_reader = do
endian <- read_magic
check_version
case endian of
Just e -> bindm (endian_read4 e) $ \dict_offset -> do
Iter.seek (fromIntegral dict_offset)
load_dict e
Nothing -> return Nothing
where
read_magic = do
c1 <- Iter.head
c2 <- Iter.head
case (c1,c2) of
(Just 0x4d, Just 0x4d) -> return $ Just MSB
(Just 0x49, Just 0x49) -> return $ Just LSB
_ -> (iterErr $ "Bad TIFF magic word: " ++ show [c1,c2])
>> return Nothing
tiff_version = 42
check_version = do
v <- endian_read2 MSB
case v of
Just v' | v' == tiff_version -> return ()
_ -> iterErr $ "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] -> IterateeGM [] el m ()
note = lift . liftIO . putStrLn . concat
load_dict :: MonadIO m => Endian -> IterateeGM [] Word8 m (Maybe TIFFDict)
load_dict e =
bindm (endian_read2 e) $ \nentries -> do
dict <- foldr (const read_entry) (return (Just IM.empty)) [1..nentries]
bindm (endian_read4 e) $ \next_dict -> do
when (next_dict > 0) $
note ["The TIFF file contains several images, ",
"only the first one will be considered"]
return dict
where
read_entry dictM =
bindm dictM $ \dict ->
bindm (endian_read2 e) $ \tag ->
bindm (endian_read2 e) $ \typ' ->
bindm (convert_type (fromIntegral typ')) $ \typ ->
bindm (endian_read4 e) $ \count -> do
note ["TIFFEntry: tag ",show . int_to_tag . fromIntegral $ tag,
" type ", show typ, " count ", show count]
enum_m <- read_value typ e (fromIntegral count)
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 -> IterateeGM [] el m (Maybe TIFF_TYPE)
convert_type typ | typ > 0 && typ <= fromEnum (maxBound::TIFF_TYPE)
= return . Just . toEnum $ typ
convert_type typ = do
iterErr $ "Bad type of entry: " ++ show typ
return Nothing
read_value :: MonadIO m => TIFF_TYPE -> Endian -> Int ->
IterateeGM [] Word8 m (Maybe TIFFDE_ENUM)
read_value typ e' 0 =
bindm (endian_read4 e') $ \_offset -> do
iterErr $ "Zero count in the entry of type: " ++ show typ
return Nothing
read_value TT_ascii e' count | count > 4 =
bindm (endian_read4 e') $ \offset ->
return . Just . TEN_CHAR $ \iter_char -> do
Iter.seek (fromIntegral offset)
let iter = convStream
(bindm Iter.head (return. 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 = bindm Iter.head (\v -> loop ((chr . fromIntegral $ v):acc)
(pred n))
bindm (loop [] len) $ \str -> do
Iter.drop (4len)
return . Just . TEN_CHAR $ immed_value str
read_value typ e' count | count > 4 && typ == TT_byte || typ == TT_sbyte =
bindm (endian_read4 e') $ \offset ->
return . Just . TEN_INT $ \iter_int -> do
Iter.seek (fromIntegral offset)
let iter = convStream
(bindm Iter.head (return . 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 = bindm Iter.head (\v -> loop (conv_byte typ v:acc)
(pred n))
bindm (loop [] count) $ \str -> do
Iter.drop (4count)
return . Just . TEN_INT $ immed_value str
read_value TT_undefined e' count | count > 4 =
bindm (endian_read4 e') $ \offset ->
return . Just . TEN_BYTE $ \iter -> 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 = bindm Iter.head (\v -> loop (v:acc) (pred n))
bindm (loop [] count) $ \str -> do
Iter.drop (4count)
return . Just . TEN_BYTE $ immed_value str
read_value typ e' 1 | typ == TT_short || typ == TT_sshort =
bindm (endian_read2 e') $ \item -> do
Iter.drop 2
return . Just . TEN_INT $ immed_value [conv_short typ item]
read_value typ e' 2 | typ == TT_short || typ == TT_sshort =
bindm (endian_read2 e') $ \i1 ->
bindm (endian_read2 e') $ \i2 ->
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 =
bindm (endian_read4 e') $ \offset ->
return . Just . TEN_INT $ \iter_int -> do
Iter.seek (fromIntegral offset)
let iter = convStream
(bindm (endian_read2 e')
(return . 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 =
bindm (endian_read4 e') $ \item ->
return . Just . TEN_INT $ immed_value [conv_long typ item]
read_value typ e' count | typ == TT_long || typ == TT_slong =
bindm (endian_read4 e') $ \offset ->
return . Just . TEN_INT $ \iter_int -> do
Iter.seek (fromIntegral offset)
let iter = convStream
(bindm (endian_read4 e')
(return . Just . (:[]) . conv_long typ))
iter_int
Iter.joinI $ Iter.joinI $ Iter.takeR (4*count) ==<< iter
read_value typ e' count =
bindm (endian_read4 e') $ \_offset -> do
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 =
(Iter.enumPure1Chunk item >. enumEof) iter >>== Iter.joinI . return
conv_byte :: TIFF_TYPE -> Word8 -> Int
conv_byte TT_byte = fromIntegral
conv_byte TT_sbyte = fromIntegral . u8_to_s8
conv_byte _ = error "This should never happen"
conv_short :: TIFF_TYPE -> Word16 -> Int
conv_short TT_short = fromIntegral
conv_short TT_sshort = fromIntegral . u16_to_s16
conv_short _ = error "This should never happen"
conv_long :: TIFF_TYPE -> Word32 -> Int
conv_long TT_long = fromIntegral
conv_long TT_slong = fromIntegral . u32_to_s32
conv_long _ = error "This should never happen"
pixel_matrix_enum :: MonadIO m => TIFFDict -> EnumeratorN [] Word8 [] Word8 m a
pixel_matrix_enum dict iter = validate_dict >>= proceed
where
validate_dict =
dict_assert TG_COMPRESSION 1 `bindm` \() ->
dict_assert TG_SAMPLESPERPIXEL 1 `bindm` \() ->
dict_assert TG_BITSPERSAMPLE 8 `bindm` \() ->
dict_read_int TG_IMAGEWIDTH dict `bindm` \ncols ->
dict_read_int TG_IMAGELENGTH dict `bindm` \nrows ->
dict_read_ints TG_STRIPOFFSETS dict `bindm` \strip_offsets -> do
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 ()
_ -> iterErr (unwords ["dict_assert: tag:", show tag,
"expected:", show v, "found:", show vfound]) >>
return Nothing
proceed Nothing = enumErr "Can't handle this TIFF" iter >>== return
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'@Done{} = return iter'
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 ->
IterateeGM [] 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 ->
IterateeGM [] 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 <- enum ==<< Iter.stream2list
return (Just e)
_ -> return Nothing
dict_read_rat :: Monad m => TIFF_TAG -> TIFFDict ->
IterateeGM [] 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] <- enum ==<< Iter.stream2list
return (Just e)
_ -> return Nothing
dict_read_string :: Monad m => TIFF_TAG -> TIFFDict ->
IterateeGM [] 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 <- enum ==<< Iter.stream2list
return (Just e)
_ -> return Nothing