module Graphics.Image.ColorSpace.Binary (
Binary(..), Bit(..), on, off, isOn, isOff, fromBool,
module Data.Bits
) where
import Prelude hiding (map)
import Data.Bits
import Data.Word (Word8)
import Graphics.Image.Interface
import Data.Typeable (Typeable)
import Foreign.Ptr
import Foreign.Storable
data Binary = Binary deriving (Eq, Enum, Bounded, Show, Typeable)
newtype Bit = Bit Word8 deriving (Ord, Eq, Typeable)
data instance Pixel Binary Bit = PixelBinary !Bit deriving (Ord, Eq)
instance Show (Pixel Binary Bit) where
show (PixelBinary (Bit 0)) = "<Binary:(0)>"
show _ = "<Binary:(1)>"
instance Bits Bit where
(.&.) = (*)
(.|.) = (+)
(Bit 0) `xor` (Bit 0) = Bit 0
(Bit 1) `xor` (Bit 1) = Bit 0
_ `xor` _ = Bit 1
complement (Bit 0) = Bit 1
complement _ = Bit 0
shift !b 0 = b
shift _ _ = Bit 0
rotate !b _ = b
zeroBits = Bit 0
bit 0 = Bit 1
bit _ = Bit 0
testBit (Bit 1) 0 = True
testBit _ _ = False
bitSizeMaybe _ = Just 1
bitSize _ = 1
isSigned _ = False
popCount (Bit 0) = 0
popCount _ = 1
instance Bits (Pixel Binary Bit) where
(.&.) = liftPx2 (.&.)
(.|.) = liftPx2 (.|.)
xor = liftPx2 xor
complement = liftPx complement
shift !b !n = liftPx (`shift` n) b
rotate !b !n = liftPx (`rotate` n) b
zeroBits = promote zeroBits
bit = promote . bit
testBit (PixelBinary (Bit 1)) 0 = True
testBit _ _ = False
bitSizeMaybe _ = Just 1
bitSize _ = 1
isSigned _ = False
popCount (PixelBinary (Bit 0)) = 0
popCount _ = 1
on :: Pixel Binary Bit
on = PixelBinary (Bit 1)
off :: Pixel Binary Bit
off = PixelBinary (Bit 0)
fromBool :: Bool -> Pixel Binary Bit
fromBool False = off
fromBool True = on
isOn :: Pixel Binary Bit -> Bool
isOn (PixelBinary (Bit 0)) = False
isOn _ = True
isOff :: Pixel Binary Bit -> Bool
isOff = not . isOn
instance ColorSpace Binary Bit where
type Components Binary Bit = Bit
promote = PixelBinary
fromComponents = PixelBinary
toComponents (PixelBinary b) = b
getPxC (PixelBinary b) _ = b
setPxC (PixelBinary _) _ b = PixelBinary b
mapPxC f (PixelBinary b) = PixelBinary (f Binary b)
liftPx f (PixelBinary b) = PixelBinary (f b)
liftPx2 f (PixelBinary b1) (PixelBinary b2) = PixelBinary (f b1 b2)
foldrPx f z (PixelBinary b) = f b z
foldlPx2 f !z (PixelBinary b1) (PixelBinary b2) = f z b1 b2
instance Elevator Bit where
toWord8 (Bit 0) = 0
toWord8 _ = maxBound
toWord16 (Bit 0) = 0
toWord16 _ = maxBound
toWord32 (Bit 0) = 0
toWord32 _ = maxBound
toWord64 (Bit 0) = 0
toWord64 _ = maxBound
toFloat (Bit 0) = 0
toFloat _ = 1
toDouble (Bit 0) = 0
toDouble _ = 1
fromDouble 0 = Bit 0
fromDouble _ = Bit 1
instance Num Bit where
(Bit 0) + (Bit 0) = Bit 0
_ + _ = Bit 1
_ (Bit 1) = Bit 0
_ _ = Bit 1
_ * (Bit 0) = Bit 0
(Bit 0) * _ = Bit 0
_ * _ = Bit 1
abs = id
signum = id
fromInteger 0 = Bit 0
fromInteger _ = Bit 1
instance Num (Pixel Binary Bit) where
(+) = liftPx2 (+)
() = liftPx2 ()
(*) = liftPx2 (*)
abs = liftPx abs
signum = liftPx signum
fromInteger = promote . fromInteger
instance Storable Bit where
sizeOf _ = sizeOf (undefined :: Word8)
alignment _ = alignment (undefined :: Word8)
peek p = do
q <- return $ castPtr p
b <- peek q
return (Bit b)
poke p (Bit b) = do
q <- return $ castPtr p
poke q b
instance Storable (Pixel Binary Bit) where
sizeOf _ = sizeOf (undefined :: Bit)
alignment _ = alignment (undefined :: Bit)
peek p = do
q <- return $ castPtr p
b <- peek q
return (PixelBinary b)
poke p (PixelBinary b) = do
q <- return $ castPtr p
poke q b