module System.TPFS.Bitmap (module System.TPFS.SolidArray) where
import Control.Applicative
import Data.Bits
import qualified Data.ByteString.Lazy as B
import Data.List
import System.TPFS.Device
import System.TPFS.SolidArray
instance SolidArray Bool where
arrRead h a (s,e) = genericTake (e s + 1)
. genericDrop sb
. concatMap bits
. B.unpack <$> dGet h (a + fromIntegral sB) (eB sB + 1)
where (sB, sb) = s `divMod` 8
(eB, eb) = e `divMod` 8
arrWrite h a o l
= do
bs1 <- bits . head . B.unpack <$> dGet h (a + fromIntegral sB) 1
bs2 <- bits . head . B.unpack <$> dGet h (a + fromIntegral eB) 1
let (middle, rest) = bitsToString $ drop (8 fromIntegral sb) l
dPut h (a + fromIntegral sB) $ B.concat [B.pack [fromBits $ genericTake sb bs1 ++ genericTake (8 sb) l]
,middle
,if null rest
then B.empty
else B.pack [fromBits $ rest ++ genericDrop eb bs2]]
where (sB, sb) = o `divMod` 8
(eB, eb) = (o + genericLength l) `divMod` 8
bits :: Bits a => a -> [Bool]
bits n = map (testBit n) [0..bitSize n 1]
fromBits :: Bits a => [Bool] -> a
fromBits = fst . foldl (\(n,i) b -> ((if b then setBit else clearBit) n i, i + 1)) (0,0)
bitsToString :: [Bool] -> (B.ByteString, [Bool])
bitsToString l = (B.pack (bytes l), drop (length l length l `mod` 8) l)
where bytes l | length l >= 8 = fromBits (take 8 l) : bytes (drop 8 l)
| otherwise = []