{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module Codec.Image.PBM
( PBM(..)
, encodePBM
, encodePlainPBM
, EncodeError(..)
, encodePBM'
, DecodeError(..)
, decodePBM
, decodePlainPBM
, decodePBMs
, 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)
data PBM = PBM{ PBM -> Int
pbmWidth :: !Int, PBM -> BitArray (Int, Int)
pbmPixels :: !(BitArray (Int, Int)) }
encodePBM :: BitArray (Int, Int) -> 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 }
data EncodeError
= BadPixelWidth{ EncodeError -> PBM
encErrPBM :: PBM }
| BadSmallWidth{ encErrPBM :: PBM }
| BadLargeWidth{ encErrPBM :: PBM }
encodePlainPBM :: BitArray (Int, Int) -> 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
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)
data DecodeError a
= BadMagicP a
| BadMagicN a
| BadWidth a
| BadHeight a
| BadSpace a
| BadPixels a
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)
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
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)
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"
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
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
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
reverseByteBits :: BS.ByteString -> BS.ByteString
reverseByteBits :: ByteString -> ByteString
reverseByteBits = (Word8 -> Word8) -> ByteString -> ByteString
BS.map Word8 -> Word8
reverseBits
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
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)
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
pbmSpace :: String
pbmSpace :: [Char]
pbmSpace = [Char]
" \t\n\v\f\r"