{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-- avoid a flood of warnings
{-|

Module      :  Codec.Image.PBM
Copyright   :  (c) Claude Heiland-Allen 2012,2018
License     :  BSD3

Maintainer  :  claude@mathr.co.uk
Stability   :  unstable
Portability :  portable

Encode and decode both versions (binary P4 and plain P1) of PBM: the
portable bitmap lowest common denominator monochrome image file format.

References:

  * pbm(5)

  * The PBM Format <http://netpbm.sourceforge.net/doc/pbm.html>

Bugs:

  * This implementation is not fully compliant with the PBM specification,
    with respect to point 8 in the second reference above which states that
    /a comment can actually be in the middle of what you might consider a token/
    Such a pathological PBM file might be rejected by 'decodePBM', but
    may instead be wrongly decoded if (for example) the comment were in
    the middle of the image width token, leading to it being interpreted
    as a (smaller) width and height.

-}
module Codec.Image.PBM
  ( PBM(..)
  -- * Encoding PBM images.
  , encodePBM
  , encodePlainPBM
  , EncodeError(..)
  , encodePBM'
  -- * Decoding PBM images.
  , DecodeError(..)
  , decodePBM
  , decodePlainPBM
  , decodePBMs
  -- * Padding and trimming PBM images.
  , padPBM
  , trimPBM
  , repadPBM
  ) where

import Data.Bits (shiftL, shiftR, (.&.))
import Data.Ix (range)
import Data.Word (Word8)
import qualified Data.Array.Unboxed as U
import qualified Data.ByteString as BS

import Data.Bits.Bitwise (fromListBE, toListLE)
import Data.Array.BitArray (BitArray, bounds, elems, listArray, false, (//), assocs, ixmap)
import Data.Array.BitArray.ByteString (toByteString, fromByteString)

-- | A decoded PBM image.  'pbmWidth' must be less or equal to the
--   width of the 'pbmPixels' array (which has its first index in Y
--   and the second in X, with lowest coordinates at the top left).
--
--   False pixels are white, True pixels are black.  Pixels to the
--   right of 'pbmWidth' are don't care padding bits.  However, these
--   padding bits are likely to invalidate aggregrate 'BitArray.fold'
--   operations.  See 'trimPBM'.
--
data PBM = PBM{ PBM -> Int
pbmWidth :: !Int, PBM -> BitArray (Int, Int)
pbmPixels :: !(BitArray (Int, Int)) }

-- | Encode a binary PBM (P4) image, padding rows to multiples of 8
--   bits as necessary.
--
encodePBM :: BitArray (Int, Int) {- ^ pixels -} -> BS.ByteString
encodePBM :: BitArray (Int, Int) -> ByteString
encodePBM BitArray (Int, Int)
pixels = case PBM -> Either EncodeError ByteString
encodePBM' PBM
pbm of
  Right ByteString
string -> ByteString
string
  Either EncodeError ByteString
_ -> [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"Codec.Image.PBM.encodePBM: internal error"
  where
    ((Int
_, Int
xlo), (Int
_, Int
xhi)) = BitArray (Int, Int) -> ((Int, Int), (Int, Int))
forall i. Ix i => BitArray i -> (i, i)
bounds BitArray (Int, Int)
pixels
    width :: Int
width  = Int
xhi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
xlo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    pbm :: PBM
pbm = PBM -> PBM
padPBM PBM{ pbmWidth :: Int
pbmWidth = Int
width, pbmPixels :: BitArray (Int, Int)
pbmPixels = BitArray (Int, Int)
pixels }

-- | Possible reasons for encoding to fail.
data EncodeError
  = BadPixelWidth{ EncodeError -> PBM
encErrPBM :: PBM } -- ^ array width is not a multiple of 8 bits
  | BadSmallWidth{ encErrPBM :: PBM } -- ^ image width is too smaller than array width
  | BadLargeWidth{ encErrPBM :: PBM } -- ^ image width is larger than array width

-- | Encode a plain PBM (P1) image.
--
--   No restrictions on pixels array size, but the file format is
--   exceedingly wasteful of space.
--
encodePlainPBM :: BitArray (Int, Int) {- ^ pixels -} -> String
encodePlainPBM :: BitArray (Int, Int) -> [Char]
encodePlainPBM BitArray (Int, Int)
pixels = [[Char]] -> [Char]
unlines ([Char]
header [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
raster)
  where
    ((Int
ylo, Int
xlo), (Int
yhi, Int
xhi)) = BitArray (Int, Int) -> ((Int, Int), (Int, Int))
forall i. Ix i => BitArray i -> (i, i)
bounds BitArray (Int, Int)
pixels
    width :: Int
width  = Int
xhi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
xlo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    height :: Int
height = Int
yhi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ylo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    header :: [Char]
header = [Char]
"P1\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
width [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
height
    raster :: [[Char]]
raster = ([Char] -> [[Char]]) -> [[Char]] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> [Char] -> [[Char]]
forall {a}. Int -> [a] -> [[a]]
chunk Int
64) ([[Char]] -> [[Char]])
-> (BitArray (Int, Int) -> [[Char]])
-> BitArray (Int, Int)
-> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char] -> [[Char]]
forall {a}. Int -> [a] -> [[a]]
chunk Int
width ([Char] -> [[Char]])
-> (BitArray (Int, Int) -> [Char])
-> BitArray (Int, Int)
-> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Char) -> [Bool] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Bool -> Char
char ([Bool] -> [Char])
-> (BitArray (Int, Int) -> [Bool]) -> BitArray (Int, Int) -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BitArray (Int, Int) -> [Bool]
forall i. Ix i => BitArray i -> [Bool]
elems (BitArray (Int, Int) -> [[Char]])
-> BitArray (Int, Int) -> [[Char]]
forall a b. (a -> b) -> a -> b
$ BitArray (Int, Int)
pixels
    char :: Bool -> Char
char Bool
False = Char
'0'
    char Bool
True  = Char
'1'
    chunk :: Int -> [a] -> [[a]]
chunk Int
n [a]
_ | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = [Char] -> [[a]]
forall a. HasCallStack => [Char] -> a
error [Char]
"Codec.Image.PBM.encodePlainPBM: internal error"
    chunk Int
_ [] = []
    chunk Int
n [a]
xs = let ([a]
ys, [a]
zs) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
xs in [a]
ys [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: Int -> [a] -> [[a]]
chunk Int
n [a]
zs

-- | Encode a pre-padded 'PBM' to a binary PBM (P4) image.
--
--   The pixels array must have a multiple of 8 bits per row.  The image
--   width may be less than the pixel array width, with up to 7 padding
--   bits at the end of each row.
--
encodePBM' :: PBM -> Either EncodeError BS.ByteString
encodePBM' :: PBM -> Either EncodeError ByteString
encodePBM' PBM
pbm
  | (Int
pixelWidth Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
7) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 = EncodeError -> Either EncodeError ByteString
forall a b. a -> Either a b
Left (PBM -> EncodeError
BadPixelWidth PBM
pbm)
  | Int
width Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
pixelWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
8 = EncodeError -> Either EncodeError ByteString
forall a b. a -> Either a b
Left (PBM -> EncodeError
BadSmallWidth PBM
pbm)
  | Int
width Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>  Int
pixelWidth     = EncodeError -> Either EncodeError ByteString
forall a b. a -> Either a b
Left (PBM -> EncodeError
BadLargeWidth PBM
pbm)
  | Bool
otherwise = ByteString -> Either EncodeError ByteString
forall a b. b -> Either a b
Right (ByteString
header ByteString -> ByteString -> ByteString
`BS.append` ByteString
raster)
  where
    width :: Int
width = PBM -> Int
pbmWidth PBM
pbm
    pixels :: BitArray (Int, Int)
pixels = PBM -> BitArray (Int, Int)
pbmPixels PBM
pbm
    ((Int
ylo, Int
xlo), (Int
yhi, Int
xhi)) = BitArray (Int, Int) -> ((Int, Int), (Int, Int))
forall i. Ix i => BitArray i -> (i, i)
bounds BitArray (Int, Int)
pixels
    pixelWidth :: Int
pixelWidth  = Int
xhi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
xlo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    pixelHeight :: Int
pixelHeight = Int
yhi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ylo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    height :: Int
height = Int
pixelHeight
    header :: ByteString
header = [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Char -> Word8) -> [Char] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Word8
forall a. Enum a => Int -> a
toEnum (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum) [Char]
headerStr
    headerStr :: [Char]
headerStr = [Char]
"P4\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
width [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
height [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
    raster :: ByteString
raster = ByteString -> ByteString
reverseByteBits (BitArray (Int, Int) -> ByteString
forall i. Ix i => BitArray i -> ByteString
toByteString BitArray (Int, Int)
pixels)

-- | Possible reasons for decoding to fail, with the input that failed.
data DecodeError a
  = BadMagicP a -- ^ First character was not P.
  | BadMagicN a -- ^ Second character was not 4 (binary) or 1 (plain).
  | BadWidth  a -- ^ The width could not be parsed, or was non-positive.
  | BadHeight a -- ^ The height could not be parsed, or was non-positive.
  | BadSpace  a -- ^ Parsing failed at the space before the pixel data.
  | BadPixels a -- ^ There weren't enough bytes of pixel data.
  deriving (DecodeError a -> DecodeError a -> Bool
(DecodeError a -> DecodeError a -> Bool)
-> (DecodeError a -> DecodeError a -> Bool) -> Eq (DecodeError a)
forall a. Eq a => DecodeError a -> DecodeError a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => DecodeError a -> DecodeError a -> Bool
== :: DecodeError a -> DecodeError a -> Bool
$c/= :: forall a. Eq a => DecodeError a -> DecodeError a -> Bool
/= :: DecodeError a -> DecodeError a -> Bool
Eq, Eq (DecodeError a)
Eq (DecodeError a)
-> (DecodeError a -> DecodeError a -> Ordering)
-> (DecodeError a -> DecodeError a -> Bool)
-> (DecodeError a -> DecodeError a -> Bool)
-> (DecodeError a -> DecodeError a -> Bool)
-> (DecodeError a -> DecodeError a -> Bool)
-> (DecodeError a -> DecodeError a -> DecodeError a)
-> (DecodeError a -> DecodeError a -> DecodeError a)
-> Ord (DecodeError a)
DecodeError a -> DecodeError a -> Bool
DecodeError a -> DecodeError a -> Ordering
DecodeError a -> DecodeError a -> DecodeError a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (DecodeError a)
forall a. Ord a => DecodeError a -> DecodeError a -> Bool
forall a. Ord a => DecodeError a -> DecodeError a -> Ordering
forall a. Ord a => DecodeError a -> DecodeError a -> DecodeError a
$ccompare :: forall a. Ord a => DecodeError a -> DecodeError a -> Ordering
compare :: DecodeError a -> DecodeError a -> Ordering
$c< :: forall a. Ord a => DecodeError a -> DecodeError a -> Bool
< :: DecodeError a -> DecodeError a -> Bool
$c<= :: forall a. Ord a => DecodeError a -> DecodeError a -> Bool
<= :: DecodeError a -> DecodeError a -> Bool
$c> :: forall a. Ord a => DecodeError a -> DecodeError a -> Bool
> :: DecodeError a -> DecodeError a -> Bool
$c>= :: forall a. Ord a => DecodeError a -> DecodeError a -> Bool
>= :: DecodeError a -> DecodeError a -> Bool
$cmax :: forall a. Ord a => DecodeError a -> DecodeError a -> DecodeError a
max :: DecodeError a -> DecodeError a -> DecodeError a
$cmin :: forall a. Ord a => DecodeError a -> DecodeError a -> DecodeError a
min :: DecodeError a -> DecodeError a -> DecodeError a
Ord, ReadPrec [DecodeError a]
ReadPrec (DecodeError a)
Int -> ReadS (DecodeError a)
ReadS [DecodeError a]
(Int -> ReadS (DecodeError a))
-> ReadS [DecodeError a]
-> ReadPrec (DecodeError a)
-> ReadPrec [DecodeError a]
-> Read (DecodeError a)
forall a. Read a => ReadPrec [DecodeError a]
forall a. Read a => ReadPrec (DecodeError a)
forall a. Read a => Int -> ReadS (DecodeError a)
forall a. Read a => ReadS [DecodeError a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Read a => Int -> ReadS (DecodeError a)
readsPrec :: Int -> ReadS (DecodeError a)
$creadList :: forall a. Read a => ReadS [DecodeError a]
readList :: ReadS [DecodeError a]
$creadPrec :: forall a. Read a => ReadPrec (DecodeError a)
readPrec :: ReadPrec (DecodeError a)
$creadListPrec :: forall a. Read a => ReadPrec [DecodeError a]
readListPrec :: ReadPrec [DecodeError a]
Read, Int -> DecodeError a -> [Char] -> [Char]
[DecodeError a] -> [Char] -> [Char]
DecodeError a -> [Char]
(Int -> DecodeError a -> [Char] -> [Char])
-> (DecodeError a -> [Char])
-> ([DecodeError a] -> [Char] -> [Char])
-> Show (DecodeError a)
forall a. Show a => Int -> DecodeError a -> [Char] -> [Char]
forall a. Show a => [DecodeError a] -> [Char] -> [Char]
forall a. Show a => DecodeError a -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: forall a. Show a => Int -> DecodeError a -> [Char] -> [Char]
showsPrec :: Int -> DecodeError a -> [Char] -> [Char]
$cshow :: forall a. Show a => DecodeError a -> [Char]
show :: DecodeError a -> [Char]
$cshowList :: forall a. Show a => [DecodeError a] -> [Char] -> [Char]
showList :: [DecodeError a] -> [Char] -> [Char]
Show)

-- | Decode a binary PBM (P4) image.
decodePBM :: BS.ByteString -> Either (DecodeError BS.ByteString) (PBM, BS.ByteString)
decodePBM :: ByteString -> Either (DecodeError ByteString) (PBM, ByteString)
decodePBM ByteString
s =                    case ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
s of
  Just (Word8
cP, ByteString
s) | Word8
cP Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Word8
char Char
'P' -> case ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
s of
    Just (Word8
c4, ByteString
s) | Word8
c4 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Word8
char Char
'4' -> case Either (DecodeError ByteString) ByteString
-> Maybe (Int, ByteString)
forall {a} {a}.
Read a =>
Either a ByteString -> Maybe (a, ByteString)
int (ByteString -> Either (DecodeError ByteString) ByteString
skipSpaceComment ByteString
s) of
      Just (Int
iw, ByteString
s) | Int
iw Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0         -> case Either (DecodeError ByteString) ByteString
-> Maybe (Int, ByteString)
forall {a} {a}.
Read a =>
Either a ByteString -> Maybe (a, ByteString)
int (ByteString -> Either (DecodeError ByteString) ByteString
skipSpaceComment ByteString
s) of
        Just (Int
ih, ByteString
s) | Int
ih Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0         -> case ByteString -> Maybe ByteString
skipSingleSpace ByteString
s of
          Just ByteString
s                        ->
            let rowBytes :: Int
rowBytes = (Int
iw Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
3
                imgBytes :: Int
imgBytes = Int
ih Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
rowBytes
            in                             case Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
imgBytes ByteString
s of
            (ByteString
raster, ByteString
s) | ByteString -> Int
BS.length ByteString
raster Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
imgBytes ->
              let ibs :: ((Int, Int), (Int, Int))
ibs = ((Int
0, Int
0), (Int
ih Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, (Int
rowBytes Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
3) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
              in  (PBM, ByteString)
-> Either (DecodeError ByteString) (PBM, ByteString)
forall a b. b -> Either a b
Right (PBM{ pbmWidth :: Int
pbmWidth = Int
iw, pbmPixels :: BitArray (Int, Int)
pbmPixels = ((Int, Int), (Int, Int)) -> ByteString -> BitArray (Int, Int)
forall i. Ix i => (i, i) -> ByteString -> BitArray i
fromByteString ((Int, Int), (Int, Int))
ibs (ByteString -> ByteString
reverseByteBits ByteString
raster) }, ByteString
s)
            (ByteString, ByteString)
_ -> DecodeError ByteString
-> Either (DecodeError ByteString) (PBM, ByteString)
forall a b. a -> Either a b
Left (ByteString -> DecodeError ByteString
forall a. a -> DecodeError a
BadPixels ByteString
s)
          Maybe ByteString
_ -> DecodeError ByteString
-> Either (DecodeError ByteString) (PBM, ByteString)
forall a b. a -> Either a b
Left (ByteString -> DecodeError ByteString
forall a. a -> DecodeError a
BadSpace ByteString
s)
        Maybe (Int, ByteString)
_ -> DecodeError ByteString
-> Either (DecodeError ByteString) (PBM, ByteString)
forall a b. a -> Either a b
Left (ByteString -> DecodeError ByteString
forall a. a -> DecodeError a
BadHeight ByteString
s)
      Maybe (Int, ByteString)
_ -> DecodeError ByteString
-> Either (DecodeError ByteString) (PBM, ByteString)
forall a b. a -> Either a b
Left (ByteString -> DecodeError ByteString
forall a. a -> DecodeError a
BadWidth ByteString
s)
    Maybe (Word8, ByteString)
_ -> DecodeError ByteString
-> Either (DecodeError ByteString) (PBM, ByteString)
forall a b. a -> Either a b
Left (ByteString -> DecodeError ByteString
forall a. a -> DecodeError a
BadMagicN ByteString
s)
  Maybe (Word8, ByteString)
_ -> DecodeError ByteString
-> Either (DecodeError ByteString) (PBM, ByteString)
forall a b. a -> Either a b
Left (ByteString -> DecodeError ByteString
forall a. a -> DecodeError a
BadMagicP ByteString
s)
  where
    skipSpaceComment :: ByteString -> Either (DecodeError ByteString) ByteString
skipSpaceComment ByteString
t = case (\ByteString
t -> (ByteString
t, ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
t)) ((Word8 -> Bool) -> ByteString -> ByteString
BS.dropWhile Word8 -> Bool
isSpace ByteString
t) of
      (ByteString
_, Just (Word8
cH, ByteString
t)) | Word8
cH Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Word8
char Char
'#' -> case ByteString -> Maybe (Word8, ByteString)
BS.uncons ((Word8 -> Bool) -> ByteString -> ByteString
BS.dropWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Char -> Word8
char Char
'\n') ByteString
t) of
        Just (Word8
cL, ByteString
t) | Word8
cL Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Word8
char Char
'\n' -> ByteString -> Either (DecodeError ByteString) ByteString
skipSpaceComment ByteString
t
        Maybe (Word8, ByteString)
_ -> DecodeError ByteString
-> Either (DecodeError ByteString) ByteString
forall a b. a -> Either a b
Left (ByteString -> DecodeError ByteString
forall a. a -> DecodeError a
BadSpace ByteString
t)
      (ByteString
t, Maybe (Word8, ByteString)
_) -> ByteString -> Either (DecodeError ByteString) ByteString
forall a b. b -> Either a b
Right ByteString
t
    skipSingleSpace :: ByteString -> Maybe ByteString
skipSingleSpace ByteString
t = case ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
t of
      Just (Word8
cS, ByteString
t) | Word8 -> Bool
isSpace Word8
cS -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
t
      Maybe (Word8, ByteString)
_ -> Maybe ByteString
forall a. Maybe a
Nothing
    int :: Either a ByteString -> Maybe (a, ByteString)
int (Left a
_) = Maybe (a, ByteString)
forall a. Maybe a
Nothing
    int (Right ByteString
t) = case (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
BS.span Word8 -> Bool
isDigit ByteString
t of
      (ByteString
d, ByteString
t)
        | ByteString -> Int
BS.length ByteString
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&&
          ((Word8, ByteString) -> Bool)
-> Maybe (Word8, ByteString) -> Maybe Bool
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Char -> Word8
char Char
'0') (Word8 -> Bool)
-> ((Word8, ByteString) -> Word8) -> (Word8, ByteString) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8, ByteString) -> Word8
forall a b. (a, b) -> a
fst) (ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
d) Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True -> case ReadS a
forall a. Read a => ReadS a
reads ((Word8 -> Char) -> [Word8] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Char
unchar ([Word8] -> [Char]) -> [Word8] -> [Char]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
BS.unpack ByteString
d) of
            [(a
d, [Char]
"")] -> (a, ByteString) -> Maybe (a, ByteString)
forall a. a -> Maybe a
Just (a
d, ByteString
t)
            [(a, [Char])]
_ -> Maybe (a, ByteString)
forall a. Maybe a
Nothing
      (ByteString, ByteString)
_ -> Maybe (a, ByteString)
forall a. Maybe a
Nothing
    isSpace :: Word8 -> Bool
isSpace Word8
c = Word8
c Word8 -> [Word8] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Char -> Word8) -> [Char] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Word8
char [Char]
pbmSpace
    isDigit :: Word8 -> Bool
isDigit Word8
c = Word8
c Word8 -> [Word8] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Char -> Word8) -> [Char] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Word8
char [Char]
"0123456789"
    char :: Char -> Word8
char = Int -> Word8
forall a. Enum a => Int -> a
toEnum (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum
    unchar :: Word8 -> Char
unchar = Int -> Char
forall a. Enum a => Int -> a
toEnum (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a. Enum a => a -> Int
fromEnum

-- | Decode a sequence of binary PBM (P4) images.
--
--   Keeps decoding until end of input (in which case the 'snd' of the
--   result is 'Nothing') or an error occurred.
--
decodePBMs :: BS.ByteString -> ([PBM], Maybe (DecodeError BS.ByteString))
decodePBMs :: ByteString -> ([PBM], Maybe (DecodeError ByteString))
decodePBMs ByteString
s
  | ByteString -> Bool
BS.null ByteString
s = ([], Maybe (DecodeError ByteString)
forall a. Maybe a
Nothing)
  | Bool
otherwise = case ByteString -> Either (DecodeError ByteString) (PBM, ByteString)
decodePBM ByteString
s of
      Left DecodeError ByteString
err -> ([], DecodeError ByteString -> Maybe (DecodeError ByteString)
forall a. a -> Maybe a
Just DecodeError ByteString
err)
      Right (PBM
pbm, ByteString
s) -> PBM
-> ([PBM], Maybe (DecodeError ByteString))
-> ([PBM], Maybe (DecodeError ByteString))
forall {a} {b}. a -> ([a], b) -> ([a], b)
prepend PBM
pbm (ByteString -> ([PBM], Maybe (DecodeError ByteString))
decodePBMs ByteString
s)
  where
    prepend :: a -> ([a], b) -> ([a], b)
prepend a
pbm ([a]
pbms, b
merr) = (a
pbma -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
pbms, b
merr)

-- | Decode a plain PBM (P1) image.
--
--   Note that the pixel array size is kept as-is (with the width not
--   necessarily a multiple of 8 bits).
--
decodePlainPBM :: String -> Either (DecodeError String) (PBM, String)
decodePlainPBM :: [Char] -> Either (DecodeError [Char]) (PBM, [Char])
decodePlainPBM [Char]
s = case [Char]
s of
  (Char
'P':[Char]
s) -> case [Char]
s of
    (Char
'1':[Char]
s) -> case Either (DecodeError [Char]) [Char] -> Maybe (Int, [Char])
forall {a} {a}. Read a => Either a [Char] -> Maybe (a, [Char])
int ([Char] -> Either (DecodeError [Char]) [Char]
skipSpaceComment [Char]
s) of
      Just (Int
iw, [Char]
s) | Int
iw Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> case Either (DecodeError [Char]) [Char] -> Maybe (Int, [Char])
forall {a} {a}. Read a => Either a [Char] -> Maybe (a, [Char])
int ([Char] -> Either (DecodeError [Char]) [Char]
skipSpaceComment [Char]
s) of
        Just (Int
ih, [Char]
s) | Int
ih Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> case Int -> [Char] -> Maybe ([Bool], [Char])
forall {t}. (Eq t, Num t) => t -> [Char] -> Maybe ([Bool], [Char])
collapseRaster (Int
iw Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
ih) [Char]
s of
          Just ([Bool]
raster, [Char]
s) ->
            let ibs :: ((Int, Int), (Int, Int))
ibs = ((Int
0, Int
0), (Int
ih Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
iw Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
            in  (PBM, [Char]) -> Either (DecodeError [Char]) (PBM, [Char])
forall a b. b -> Either a b
Right (PBM{ pbmWidth :: Int
pbmWidth = Int
iw, pbmPixels :: BitArray (Int, Int)
pbmPixels = ((Int, Int), (Int, Int)) -> [Bool] -> BitArray (Int, Int)
forall i. Ix i => (i, i) -> [Bool] -> BitArray i
listArray ((Int, Int), (Int, Int))
ibs [Bool]
raster }, [Char]
s)
          Maybe ([Bool], [Char])
_ -> DecodeError [Char] -> Either (DecodeError [Char]) (PBM, [Char])
forall a b. a -> Either a b
Left ([Char] -> DecodeError [Char]
forall a. a -> DecodeError a
BadPixels [Char]
s)
        Maybe (Int, [Char])
_ -> DecodeError [Char] -> Either (DecodeError [Char]) (PBM, [Char])
forall a b. a -> Either a b
Left ([Char] -> DecodeError [Char]
forall a. a -> DecodeError a
BadHeight [Char]
s)
      Maybe (Int, [Char])
_ -> DecodeError [Char] -> Either (DecodeError [Char]) (PBM, [Char])
forall a b. a -> Either a b
Left ([Char] -> DecodeError [Char]
forall a. a -> DecodeError a
BadWidth [Char]
s)
    [Char]
_ -> DecodeError [Char] -> Either (DecodeError [Char]) (PBM, [Char])
forall a b. a -> Either a b
Left ([Char] -> DecodeError [Char]
forall a. a -> DecodeError a
BadMagicN [Char]
s)
  [Char]
_ -> DecodeError [Char] -> Either (DecodeError [Char]) (PBM, [Char])
forall a b. a -> Either a b
Left ([Char] -> DecodeError [Char]
forall a. a -> DecodeError a
BadMagicP [Char]
s)
  where
    skipSpaceComment :: [Char] -> Either (DecodeError [Char]) [Char]
skipSpaceComment [Char]
t = case (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace [Char]
t of
      (Char
'#':[Char]
t) -> case (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') [Char]
t of
        (Char
'\n':[Char]
t) -> [Char] -> Either (DecodeError [Char]) [Char]
skipSpaceComment [Char]
t
        [Char]
_ -> DecodeError [Char] -> Either (DecodeError [Char]) [Char]
forall a b. a -> Either a b
Left ([Char] -> DecodeError [Char]
forall a. a -> DecodeError a
BadSpace [Char]
t)
      [Char]
t -> [Char] -> Either (DecodeError [Char]) [Char]
forall a b. b -> Either a b
Right [Char]
t
    int :: Either a [Char] -> Maybe (a, [Char])
int (Left a
_) = Maybe (a, [Char])
forall a. Maybe a
Nothing
    int (Right [Char]
t) = case (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit [Char]
t of
      (d :: [Char]
d@(Char
d0:[Char]
_), [Char]
t) | Char
d0 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'0' -> case ReadS a
forall a. Read a => ReadS a
reads [Char]
d of
        [(a
d, [Char]
"")] -> (a, [Char]) -> Maybe (a, [Char])
forall a. a -> Maybe a
Just (a
d, [Char]
t)
        [(a, [Char])]
_ -> Maybe (a, [Char])
forall a. Maybe a
Nothing
      ([Char], [Char])
_ -> Maybe (a, [Char])
forall a. Maybe a
Nothing
    collapseRaster :: t -> [Char] -> Maybe ([Bool], [Char])
collapseRaster t
0 [Char]
t = ([Bool], [Char]) -> Maybe ([Bool], [Char])
forall a. a -> Maybe a
Just ([], [Char]
t)
    collapseRaster t
n [Char]
t = case (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace [Char]
t of
      (Char
'0':[Char]
t) -> Bool -> Maybe ([Bool], [Char]) -> Maybe ([Bool], [Char])
forall {a} {b}. a -> Maybe ([a], b) -> Maybe ([a], b)
prepend Bool
False (t -> [Char] -> Maybe ([Bool], [Char])
collapseRaster (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1) [Char]
t)
      (Char
'1':[Char]
t) -> Bool -> Maybe ([Bool], [Char]) -> Maybe ([Bool], [Char])
forall {a} {b}. a -> Maybe ([a], b) -> Maybe ([a], b)
prepend Bool
True  (t -> [Char] -> Maybe ([Bool], [Char])
collapseRaster (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1) [Char]
t)
      [Char]
_ -> Maybe ([Bool], [Char])
forall a. Maybe a
Nothing
    prepend :: a -> Maybe ([a], b) -> Maybe ([a], b)
prepend a
_ Maybe ([a], b)
Nothing = Maybe ([a], b)
forall a. Maybe a
Nothing
    prepend a
b (Just ([a]
bs, b
t)) = ([a], b) -> Maybe ([a], b)
forall a. a -> Maybe a
Just (a
ba -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
bs, b
t)
    isSpace :: Char -> Bool
isSpace Char
c = Char
c Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
pbmSpace
    isDigit :: Char -> Bool
isDigit Char
c = Char
c Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
"0123456789"

-- | Add padding bits at the end of each row to make the array width a
--   multiple of 8 bits, required for binary PBM (P4) encoding.
--
padPBM :: PBM -> PBM
padPBM :: PBM -> PBM
padPBM PBM
pbm
  | (Int
pixelWidth Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
7) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = PBM
pbm
  | Bool
otherwise = PBM
pbm{ pbmPixels :: BitArray (Int, Int)
pbmPixels = ((Int, Int), (Int, Int)) -> BitArray (Int, Int)
forall i. Ix i => (i, i) -> BitArray i
false ((Int, Int), (Int, Int))
paddedBounds BitArray (Int, Int) -> [((Int, Int), Bool)] -> BitArray (Int, Int)
forall i. Ix i => BitArray i -> [(i, Bool)] -> BitArray i
// BitArray (Int, Int) -> [((Int, Int), Bool)]
forall i. Ix i => BitArray i -> [(i, Bool)]
assocs (PBM -> BitArray (Int, Int)
pbmPixels PBM
pbm) }
  where
    ((Int
ylo, Int
xlo), (Int
yhi, Int
xhi)) = BitArray (Int, Int) -> ((Int, Int), (Int, Int))
forall i. Ix i => BitArray i -> (i, i)
bounds (PBM -> BitArray (Int, Int)
pbmPixels PBM
pbm)
    pixelWidth :: Int
pixelWidth = Int
xhi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
xlo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    rowBytes :: Int
rowBytes = (Int
pixelWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
3
    paddedWidth :: Int
paddedWidth = Int
rowBytes Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
3
    paddedBounds :: ((Int, Int), (Int, Int))
paddedBounds = ((Int
ylo, Int
xlo), (Int
yhi, Int
xhi'))
    xhi' :: Int
xhi' = Int
paddedWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
xlo Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

-- | Trim any padding bits, required for 'fold' operations to give
--   meaningful results.
--
--   Fails for invalid 'PBM' with image width greater than array width.
--
trimPBM :: PBM -> Maybe PBM
trimPBM :: PBM -> Maybe PBM
trimPBM PBM
pbm
  | PBM -> Int
pbmWidth PBM
pbm Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
pixelWidth = Maybe PBM
forall a. Maybe a
Nothing
  | PBM -> Int
pbmWidth PBM
pbm Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
pixelWidth = PBM -> Maybe PBM
forall a. a -> Maybe a
Just PBM
pbm
  | Bool
otherwise = PBM -> Maybe PBM
forall a. a -> Maybe a
Just PBM
pbm{ pbmPixels :: BitArray (Int, Int)
pbmPixels = ((Int, Int), (Int, Int))
-> ((Int, Int) -> (Int, Int))
-> BitArray (Int, Int)
-> BitArray (Int, Int)
forall i j.
(Ix i, Ix j) =>
(i, i) -> (i -> j) -> BitArray j -> BitArray i
ixmap ((Int, Int), (Int, Int))
trimmedBounds (Int, Int) -> (Int, Int)
forall a. a -> a
id (PBM -> BitArray (Int, Int)
pbmPixels PBM
pbm) }
  where
    ((Int
ylo, Int
xlo), (Int
yhi, Int
xhi)) = BitArray (Int, Int) -> ((Int, Int), (Int, Int))
forall i. Ix i => BitArray i -> (i, i)
bounds (PBM -> BitArray (Int, Int)
pbmPixels PBM
pbm)
    pixelWidth :: Int
pixelWidth = Int
xhi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
xlo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    trimmedBounds :: ((Int, Int), (Int, Int))
trimmedBounds = ((Int
ylo, Int
xlo), (Int
yhi, Int
xhi'))
    xhi' :: Int
xhi' = PBM -> Int
pbmWidth PBM
pbm Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
xlo Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

-- | Trim then pad.  The resulting 'PBM' (if any) is suitable for
--   encoding to binary PBM (P4), moreover its padding bits will
--   be cleared.
repadPBM :: PBM -> Maybe PBM
repadPBM :: PBM -> Maybe PBM
repadPBM PBM
pbm = PBM -> PBM
padPBM (PBM -> PBM) -> Maybe PBM -> Maybe PBM
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` PBM -> Maybe PBM
trimPBM PBM
pbm

-- | Reverse the bit order of all bytes.
--
--   PBM specifies that the most significant bit is leftmost, which is
--   opposite to the convention used by BitArray.
--
reverseByteBits :: BS.ByteString -> BS.ByteString
reverseByteBits :: ByteString -> ByteString
reverseByteBits = (Word8 -> Word8) -> ByteString -> ByteString
BS.map Word8 -> Word8
reverseBits

-- | Fast reversal of the bit order of a byte using a lookup table.
reverseBits :: Word8 -> Word8
reverseBits :: Word8 -> Word8
reverseBits Word8
w = UArray Word8 Word8
bitReversed UArray Word8 Word8 -> Word8 -> Word8
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
U.! Word8
w

-- | A lookup table for bit order reversal.
bitReversed :: U.UArray Word8 Word8
bitReversed :: UArray Word8 Word8
bitReversed = (Word8, Word8) -> [Word8] -> UArray Word8 Word8
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
U.listArray (Word8, Word8)
bs [ Word8 -> Word8
bitReverse Word8
w | Word8
w <- (Word8, Word8) -> [Word8]
forall a. Ix a => (a, a) -> [a]
range (Word8, Word8)
bs ]
  where bs :: (Word8, Word8)
bs = (Word8
forall a. Bounded a => a
minBound, Word8
forall a. Bounded a => a
maxBound)

-- | A slow way to reverse bit order.
bitReverse :: Word8 -> Word8
bitReverse :: Word8 -> Word8
bitReverse = [Bool] -> Word8
forall b. Bits b => [Bool] -> b
fromListBE ([Bool] -> Word8) -> (Word8 -> [Bool]) -> Word8 -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> [Bool]
forall b. Bits b => b -> [Bool]
toListLE

-- | White space characters as defined by the PBM specification.
pbmSpace :: String
pbmSpace :: [Char]
pbmSpace = [Char]
" \t\n\v\f\r"