packages feed

bitwise (empty) → 0.1

raw patch · 16 files changed

+1913/−0 lines, 16 filesdep +QuickCheckdep +arraydep +basesetup-changed

Dependencies added: QuickCheck, array, base, bitwise, bytestring, criterion

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2012, Claude Heiland-Allen++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Claude Heiland-Allen nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README view
@@ -0,0 +1,8 @@+Interactive interpreted usage without having installed first+requires adding a search path for the respective environment:++  hugs -98 -P:src:hugs98+  ghci-7.0.4 -isrc:ghc70+  ghci-7.4.1 -isrc:ghc74++ghc < 7 has not been tested, reports welcome.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bitwise.cabal view
@@ -0,0 +1,116 @@+Name:                bitwise+Version:             0.1+Synopsis:            fast multi-dimensional unboxed bit packed Bool arrays+Description:+  Unboxed multidimensional bit packed Bool arrays with fast aggregate+  operations based on lifting Bool operations to bitwise operations.+  .+  There are many other bit packed structures out there, but none met+  all of these requirements:+  .+    (1) unboxed bit packed Bool array,+  .+    (2) multi-dimensional indexing,+  .+    (3) fast (de)serialization, or interoperable with foreign code,+  .+    (4) fast aggregate operations (fold, map, zip).+  .+  Quick tour of the bitwise library:+  .+  [Data.Bits.Bitwise] Lift boolean operations on 'Bool' to bitwise+  operations on 'Data.Bits.Bits'.+  .+  [Data.Array.BitArray] Immutable bit arrays.+  .+  [Data.Array.BitArray.ST] Mutable bit arrays in 'Control.Monad.ST.ST'.+  .+  [Data.Array.BitArray.IO] Mutable bit arrays in 'IO'.+  .+  [Data.Array.BitArray.ByteString] (De)serialization.+  .+  [Codec.Image.PBM] Portable bitmap monochrome 2D image format.+  .+  Very rough performance benchmarks:+  .+    * immutable random access single bit reads:+      @BitArray ix@ is about 40% slower than @UArray ix Bool@,+  .+    * 'Control.Monad.ST.ST' mutable random access single bit reads:+      @STBitArray s ix@ is about the same as @STUArray s ix Bool@,+  .+    * immutable map @Bool -> Bool@:+      @BitArray ix@ is about 85x faster than @UArray ix Bool@,+  .+    * immutable zipWith @Bool -> Bool -> Bool@:+      @BitArray ix@ is about 1300x faster than @UArray ix Bool@.++Homepage:            https://gitorious.org/bitwise+License:             BSD3+License-file:        LICENSE+Author:              Claude Heiland-Allen+Maintainer:          claudiusmaximus@goto10.org+Copyright:           (c) 2012 Claude Heiland-Allen+Category:            Data, Data Structures, Bit Vectors+Build-type:          Simple++Cabal-version:       >= 1.9.2++Extra-source-files:  README hugs98/Compat.hs ghc70/Compat.hs ghc74/Compat.hs++Library+  Exposed-modules:+    Data.Bits.Bitwise+    Data.Array.BitArray+    Data.Array.BitArray.IO+    Data.Array.BitArray.ST+    Data.Array.BitArray.ByteString+    Codec.Image.PBM++  Other-modules:+    Data.Array.BitArray.Internal+    Compat++  Build-depends:+    base >= 2 && < 6++  if (impl(ghc >= 7.4))+    HS-source-dirs: src ghc74+    Build-depends:  bytestring, array++  if (impl(ghc < 7.4))+    HS-source-dirs: src ghc70+    Build-depends:  bytestring, array++  if (impl(hugs))+    HS-source-dirs: src hugs98++  GHC-Options:        -Wall+  GHC-Prof-Options:   -prof -auto-all -caf-all++Test-Suite bitwise-testsuite+  type:    exitcode-stdio-1.0+  main-is: extra/testsuite.hs+  build-depends:+    bitwise == 0.1,+    base >= 2 && < 6,+    QuickCheck >= 2.4 && < 2.5++Benchmark bitwise-benchmark+  type:   exitcode-stdio-1.0+  main-is: extra/benchmark.hs+  build-depends:+    bitwise == 0.1,+    base >= 2 && < 6,+    array,+    bytestring,+    criterion >= 0.6 && < 0.7++source-repository head+  type:     git+  location: git://gitorious.org/bitwise/bitwise.git++source-repository this+  type:     git+  location: git://gitorious.org/bitwise/bitwise.git+  tag:      v0.1
+ extra/benchmark.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE BangPatterns #-}+module Main(main) where++import Control.Exception (evaluate)+import Control.Monad.ST (runST, ST)+import Data.Bits (shiftR)+import Data.ByteString (ByteString, pack, unpack)+import Data.Ix (range)+import Data.List (foldl1')+import Data.Word (Word8)+import System.Environment (getArgs)++import Data.Bits.Bitwise (packWord8LE, unpackWord8LE)+import qualified Data.Array.Unboxed  as A+import qualified Data.Array.BitArray as B+import qualified Data.Array.ST as STA (STUArray, readArray)+import qualified Data.Array.Unsafe as STA (unsafeThaw)+import qualified Data.Array.BitArray.ST as STB++import qualified Data.Array.BitArray.ByteString as BSB++import Criterion.Main++type I = (Int, Int, Int, Int)+type A = A.UArray I Bool+type B = B.BitArray I++bs :: (I, I)+bs = ((0, 0, 0, 0), (na - 1, nb - 1, nc - 1, nd - 1))++na, nb, nc, nd, n :: Int+na = 13+nb = 17+nc = 19+nd = 11+n = na * nb * nc * nd++next :: I -> I+next !(!a, !b, !c, !d) = ((a + 1) `mod` na, (b + 1) `mod` nb, (c + 1) `mod` nc, (d + 1) `mod` nd)++aToB :: A -> B+aToB a = {-# SCC "aToB" #-} B.listArray (A.bounds a) (A.elems a)++bToA :: B -> A+bToA b = {-# SCC "bToA" #-} A.listArray (B.bounds b) (B.elems b)++aToBS :: A -> ByteString+aToBS a = {-# SCC "aToBS" #-} pack . toWord8sLE . A.elems $ a++bToBS :: B -> ByteString+bToBS b = {-# SCC "bToBS" #-} BSB.toByteString b++aFromBS :: ((I, I), ByteString) -> A+aFromBS (i, a) = {-# SCC "aFromBS" #-} A.listArray i . fromWord8sLE . unpack $ a++bFromBS :: ((I, I), ByteString) -> B+bFromBS (i, b) = {-# SCC "bFromBS" #-} BSB.fromByteString i b++aListArray :: [Bool] -> A+aListArray a = {-# SCC "aListArray" #-} A.listArray bs a++bListArray :: [Bool] -> B+bListArray b = {-# SCC "bListArray" #-} B.listArray bs b++aIndex :: A -> ()+aIndex !a = {-# SCC "aIndex" #-} loop (1, 1, 1, 1) (n `div` 3)+  where+    loop  _  0 = ()+    loop !i !m = (a A.! i) `seq` loop (next i) (m - 1)++bIndex :: B -> ()+bIndex !b = {-# SCC "bIndex" #-} loop (1, 1, 1, 1) (n `div` 3)+  where+    loop  _  0 = ()+    loop !i !m = (b B.! i) `seq` loop (next i) (m - 1)++bIndex' :: B -> ()+bIndex' !b = {-# SCC "bIndex'" #-} loop (1, 1, 1, 1) (n `div` 3)+  where+    loop  _  0 = ()+    loop !i !m = (b B.!!! i) `seq` loop (next i) (m - 1)++aIndexST :: A -> ()+aIndexST !a = {-# SCC "aIndexST" #-} runST $ do+  !a' <- STA.unsafeThaw a :: ST s (STA.STUArray s I Bool)+  loop a' (1, 1, 1, 1) (n `div` 3)+  where+    loop _ _  0 = return ()+    loop !a' !i !m = do+      !_ <- STA.readArray a' i+      loop a' (next i) (m - 1)++bIndexST :: B -> ()+bIndexST !b = {-# SCC "bIndexST" #-} runST $ do+  !b' <- STB.unsafeThaw b+  loop b' (1, 1, 1, 1) (n `div` 3)+  where+    loop _ _  0 = return ()+    loop !b' !i !m = do+      !_ <- STB.readArray b' i+      loop b' (next i) (m - 1)++bIndexST' :: B -> ()+bIndexST' !b = {-# SCC "bIndexST'" #-} runST $ do+  !b' <- STB.unsafeThaw b+  loop b' (1, 1, 1, 1) (n `div` 3)+  where+    loop _ _  0 = return ()+    loop !b' !i !m = do+      !_ <- STB.unsafeReadArray b' i+      loop b' (next i) (m - 1)++aUpdate :: A -> A+aUpdate !a = {-# SCC "aUpdate" #-} a A.// take (n `div` 3) (loop (1, 1, 1, 1) False)+  where+    loop (0, 0, 0, 0) _ = []+    loop !i !c = (i, c) : loop (next i) (not c)++bUpdate :: B -> B+bUpdate !b = {-# SCC "bUpdate" #-} b B.// take (n `div` 3) (loop (1, 1, 1, 1) False)+  where+    loop (0, 0, 0, 0) _ = []+    loop !i !c = (i, c) : loop (next i) (not c)++aElems :: A -> ()+aElems !a = {-# SCC "aElems" #-} seqList (A.elems a) ()++seqList :: [a] -> b -> b+seqList [] b = b+seqList (x:xs) b = x `seq` seqList xs b++bElems :: B -> ()+bElems b = {-# SCC "bElems" #-} seqList (B.elems b) ()++aMap :: A -> A+aMap !a = {-# SCC "aMap" #-} A.amap not a++bMap :: B -> B+bMap !b = {-# SCC "bMap" #-} B.amap not b++aZipWith :: (A, A) -> A+aZipWith (!a, !a') = {-# SCC "aZipWith" #-} A.listArray bs (map (\ !i -> a A.! i == a' A.! i) (range bs)) :: A++bZipWith :: (B, B) -> B+bZipWith (!b, !b') = {-# SCC "bZipWith" #-} B.zipWith (==) b b' :: B++aFold :: A -> Bool+aFold !a = {-# SCC "aFold" #-} foldl1' (/=) (A.elems a)++bFold :: B -> Bool+bFold !b = {-# SCC "bFold" #-} case B.fold (/=) b of+  Just !c -> c+  Nothing -> error "fold"++main :: IO ()+main = do+  let a  = A.listArray bs (take n         lorem ) :: A+      a' = A.listArray bs (take n (drop n lorem)) :: A+      b  = B.listArray bs (take n         lorem ) :: B+      b' = B.listArray bs (take n (drop n lorem)) :: B+      l  = take n lorem+  evaluate (l `seqList` a `seq` a' `seq` b `seq` b' `seq` ())+  defaultMain+    [ bgroup "listArray"+        [ bench "UArray"   $ whnf aListArray l+        , bench "BitArray" $ whnf bListArray l+        ]+    , bgroup "elems"+        [ bench "UArray"   $ whnf aElems a+        , bench "BitArray" $ whnf bElems b+        ]+    , bgroup "index I"+        [ bench "UArray"   $ whnf aIndex a+        , bench "BitArray" $ whnf bIndex b+        , bench "BitArray'"$ whnf bIndex' b+        ]+    , bgroup "index ST"+        [ bench "UArray"   $ whnf aIndexST a+        , bench "BitArray" $ whnf bIndexST b+        , bench "BitArray'"$ whnf bIndexST' b+        ]+    , bgroup "update"+        [ bench "UArray"   $ whnf aUpdate a+        , bench "BitArray" $ whnf bUpdate b+        ]+    , bgroup "map"+        [ bench "UArray"   $ whnf aMap a+        , bench "BitArray" $ whnf bMap b+        ]+    , bgroup "zipWith"+        [ bench "UArray"   $ whnf aZipWith (a, a')+        , bench "BitArray" $ whnf bZipWith (b, b')+        ]+    , bgroup "fold"+        [ bench "UArray"   $ whnf aFold a+        , bench "BitArray" $ whnf bFold b+        ]+    , bgroup "conversion"+        [ bench "U to Bit" $ whnf aToB a+        , bench "Bit to U" $ whnf bToA b+        ]+    , bgroup "serialize"+        [ bench "UArray"   $ whnf aToBS loremA+        , bench "BitArray" $ whnf bToBS loremB+        ]+    , bgroup "deserialize"+        [ bench "UArray"   $ whnf aFromBS (bs, loremBS)+        , bench "BitArray" $ whnf bFromBS (bs, loremBS)+        ]+    ]++loremA :: A+loremA = A.listArray bs (take n lorem)++loremB :: B+loremB = B.listArray bs (take n lorem)++lorem :: [Bool]+lorem = cycle . fromWord8sLE $ loremWS++loremBS :: ByteString+loremBS = pack . take ((n + 7) `shiftR` 3) . cycle $ loremWS++loremWS :: [Word8]+loremWS = map (toEnum . fromEnum) . unlines $+  [ "Lorem ipsum dolor sit amet, consectetur adipisicing elit, "+  , "sed do eiusmod tempor incididunt ut labore et dolore magna "+  , "aliqua. Ut enim ad minim veniam, quis nostrud exercitation "+  , "ullamco laboris nisi ut aliquip ex ea commodo consequat. "+  , "Duis aute irure dolor in reprehenderit in voluptate velit "+  , "esse cillum dolore eu fugiat nulla pariatur. Excepteur sint "+  , "occaecat cupidatat non proident, sunt in culpa qui officia "+  , "deserunt mollit anim id est laborum."+  ]++un8 :: (a, a, a, a, a, a, a, a) -> [a]+un8 (a, b, c, d, e, f, g, h) = [a, b, c, d, e, f, g, h]++fromWord8sLE :: [Word8] -> [Bool]+fromWord8sLE = concatMap (un8 . unpackWord8LE)++toWord8sLE :: [Bool] -> [Word8]+toWord8sLE [] = []+toWord8sLE (a:b:c:d:e:f:g:h:rest) = packWord8LE a b c d e f g h : toWord8sLE rest+toWord8sLE rest = toWord8sLE (take 8 (rest ++ repeat False))
+ extra/testsuite.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE TemplateHaskell #-}+module Main(main) where++import Prelude hiding (any, all, and, or, map, zipWith)+import qualified Prelude as P++import Data.Ix (inRange, range)+import Data.Function (on)+import Data.Word (Word8, Word16)+import System.Exit (exitSuccess, exitFailure)++import Data.Array.BitArray++import Test.QuickCheck+import Test.QuickCheck.All(quickCheckAll)++main :: IO ()+main = do+  r <- $quickCheckAll+  if r then exitSuccess else exitFailure++fromW :: Word16 -> Int+fromW = fromIntegral++fromW8 :: Word8 -> Int+fromW8 = fromIntegral++prop_bounds1 o w = let n = fromW w in (o, o + n) == bounds (listArray (o, o + n) (take (n + 1) (cycle [False, True, True])))++prop_bounds2 o1 w1 o2 w2 = let n1 = fromW8 w1 ; n2 = fromW8 w2 ; bs = ((o1, o2), (o1 + n1, o2 + n2)) in bs == bounds (listArray bs (take ((n1 + 1) * (n2 + 1)) (cycle [False, True, True])))++prop_index1 o es = let n = length es in n > 0 ==> P.and [es !! i == listArray (o, o + n - 1) es ! (o + i) | i <- [0 .. n - 1]]++prop_index2 o1 o2 es1 = let n2 = ceiling . sqrt . fromIntegral . length $ es1 in n2 > 0 ==>+  let es = init (chunk n2 es1)+      n1 = length es+      bs = ((o1, o2), (o1 + n1 - 1,o2 + n2 - 1))+  in  n1 > 0 ==> P.and [ es !! (i - o1) !! (j - o2) == listArray bs (concat es) ! (i, j) | (i, j) <- range bs ]++prop_indices1 o w = let n = fromW w ; bs = (o, o + n) in range bs == indices (listArray bs (cycle [False, True, True]))++prop_indices2 o1 w1 o2 w2 =+  let n1 = fromW8 w1+      n2 = fromW8 w2+      bs = ((o1, o2), (o1 + n1, o2 + n2))+  in  range bs == indices (listArray bs (cycle [False, True, True]))++prop_elems1 o es = es == (elems . listArray (o, o + length es - 1)) es++prop_assocs1 o es = zip [o..] es == (assocs . listArray (o, o + length es - 1)) es++prop_map1 (Blind f) o es = P.map f es == (elems . map f . listArray (o, o + length es - 1)) es++prop_zipWith1 (Blind f) o ees = P.map (uncurry f) ees == (elems . uncurry (zipWith f `on` listArray (o, o + length ees - 1)) . unzip) ees++prop_or1 o es = P.or es == (or . listArray (o, o + length es - 1)) es++prop_and1 o es = P.and es == (and . listArray (o, o + length es - 1)) es++prop_isUniform1 o es = not (null es) ==> listUniform es == (isUniform . listArray (o, o + length es - 1)) es++prop_fill1 o w b = let n = fromW w in Just b == isUniform (fill (o, o + n) b)++prop_true1 o w = let n = fromW w in Just True == isUniform (true (o, o + n))++prop_false1 o w = let n = fromW w in Just False == isUniform (false (o, o + n))++listUniform l+  | null l = Nothing+  | P.and l = Just True+  | not (P.or l) = Just False+  | otherwise = Nothing++chunk _ [] = []+chunk n xs = let (ys, zs) = splitAt n xs in ys : chunk n zs++{-+  , accumArray+  , (//)+  , accum+  , ixmap+  , (!?)+-}
+ ghc70/Compat.hs view
@@ -0,0 +1,10 @@+module Compat+  ( unsafeIOToST+  , uncons+  , packCStringLen+  , unsafeUseAsCStringLen+  ) where++import Control.Monad.ST (unsafeIOToST)+import Data.ByteString (uncons, packCStringLen)+import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
+ ghc74/Compat.hs view
@@ -0,0 +1,10 @@+module Compat+  ( unsafeIOToST+  , uncons+  , packCStringLen+  , unsafeUseAsCStringLen+  ) where++import Control.Monad.ST.Unsafe (unsafeIOToST)+import Data.ByteString (uncons, packCStringLen)+import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
+ hugs98/Compat.hs view
@@ -0,0 +1,20 @@+module Compat+  ( unsafeIOToST+  , uncons+  , packCStringLen+  , unsafeUseAsCStringLen+  ) where++import Control.Monad.ST (unsafeIOToST)+import qualified Data.ByteString as BS+import Data.Word (Word8)+import Foreign.C.String (CStringLen)++uncons :: BS.ByteString -> Maybe (Word8, BS.ByteString)+uncons s = if BS.null s then Nothing else Just (BS.head s, BS.tail s)++unsafeUseAsCStringLen :: BS.ByteString -> (CStringLen -> IO a) -> IO a+unsafeUseAsCStringLen = BS.useAsCStringLen++packCStringLen :: CStringLen -> IO BS.ByteString+packCStringLen = return . BS.packCStringLen
+ src/Codec/Image/PBM.hs view
@@ -0,0 +1,300 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+-- avoid a flood of warnings+{-|++Module      :  Codec.Image.PBM+Copyright   :  (c) Claude Heiland-Allen 2012+License     :  BSD3++Maintainer  :  claudiusmaximus@goto10.org+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 qualified Compat as BSC+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{ pbmWidth :: !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 pixels = case encodePBM' pbm of+  Right string -> string+  _ -> error "Codec.Image.PBM.encodePBM: internal error"+  where+    ((_, xlo), (_, xhi)) = bounds pixels+    width  = xhi - xlo + 1+    pbm = padPBM PBM{ pbmWidth = width, pbmPixels = pixels }++-- | Possible reasons for encoding to fail.+data EncodeError+  = BadPixelWidth{ 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 pixels = unlines (header : raster)+  where+    ((ylo, xlo), (yhi, xhi)) = bounds pixels+    width  = xhi - xlo + 1+    height = yhi - ylo + 1+    header = "P1\n" ++ show width ++ " " ++ show height+    raster = concatMap (chunk 64) . chunk width . map char . elems $ pixels+    char False = '0'+    char True  = '1'+    chunk n _ | n <= 0 = error "Codec.Image.PBM.encodePlainPBM: internal error"+    chunk _ [] = []+    chunk n xs = let (ys, zs) = splitAt n xs in ys : chunk n 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+  | (pixelWidth .&. 7) /= 0 = Left (BadPixelWidth pbm)+  | width <= pixelWidth - 8 = Left (BadSmallWidth pbm)+  | width >  pixelWidth     = Left (BadLargeWidth pbm)+  | otherwise = Right (header `BS.append` raster)+  where+    width = pbmWidth pbm+    pixels = pbmPixels pbm+    ((ylo, xlo), (yhi, xhi)) = bounds pixels+    pixelWidth  = xhi - xlo + 1+    pixelHeight = yhi - ylo + 1+    height = pixelHeight+    header = BS.pack $ map (toEnum . fromEnum) headerStr+    headerStr = "P4\n" ++ show width ++ " " ++ show height ++ "\n"+    raster = reverseByteBits (toByteString 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 (Eq, Ord, Read, Show)++-- | Decode a binary PBM (P4) image.+decodePBM :: BS.ByteString -> Either (DecodeError BS.ByteString) (PBM, BS.ByteString)+decodePBM s =                    case BSC.uncons s of+  Just (cP, s) | cP == char 'P' -> case BSC.uncons s of+    Just (c4, s) | c4 == char '4' -> case int (skipSpaceComment s) of+      Just (iw, s) | iw > 0         -> case int (skipSpaceComment s) of+        Just (ih, s) | ih > 0         -> case skipSingleSpace s of+          Just s                        ->+            let rowBytes = (iw + 7) `shiftR` 3+                imgBytes = ih * rowBytes+            in                             case BS.splitAt imgBytes s of+            (raster, s) | BS.length raster == imgBytes ->+              let ibs = ((0, 0), (ih - 1, (rowBytes `shiftL` 3) - 1))+              in  Right (PBM{ pbmWidth = iw, pbmPixels = fromByteString ibs (reverseByteBits raster) }, s)+            _ -> Left (BadPixels s)+          _ -> Left (BadSpace s)+        _ -> Left (BadHeight s)+      _ -> Left (BadWidth s)+    _ -> Left (BadMagicN s)+  _ -> Left (BadMagicP s)+  where+    skipSpaceComment t = case (\t -> (t, BSC.uncons t)) (BS.dropWhile isSpace t) of+      (_, Just (cH, t)) | cH == char '#' -> case BSC.uncons (BS.dropWhile (/= char '\n') t) of+        Just (cL, t) | cL == char '\n' -> skipSpaceComment t+        _ -> Left (BadSpace t)+      (t, _) -> Right t+    skipSingleSpace t = case BSC.uncons t of+      Just (cS, t) | isSpace cS -> Just t+      _ -> Nothing+    int (Left _) = Nothing+    int (Right t) = case BS.span isDigit t of+      (d, t)+        | BS.length d > 0 &&+          fmap ((/= char '0') . fst) (BSC.uncons d) == Just True -> case reads (map unchar $ BS.unpack d) of+            [(d, "")] -> Just (d, t)+            _ -> Nothing+      _ -> Nothing+    isSpace c = c `elem` map char pbmSpace+    isDigit c = c `elem` map char "0123456789"+    char = toEnum . fromEnum+    unchar = toEnum . 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 s+  | BS.null s = ([], Nothing)+  | otherwise = case decodePBM s of+      Left err -> ([], Just err)+      Right (pbm, s) -> prepend pbm (decodePBMs s)+  where+    prepend pbm (pbms, merr) = (pbm:pbms, 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 s = case s of+  ('P':s) -> case s of+    ('1':s) -> case int (skipSpaceComment s) of+      Just (iw, s) | iw > 0 -> case int (skipSpaceComment s) of+        Just (ih, s) | ih > 0 -> case collapseRaster (iw * ih) s of+          Just (raster, s) ->+            let ibs = ((0, 0), (ih - 1, iw - 1))+            in  Right (PBM{ pbmWidth = iw, pbmPixels = listArray ibs raster }, s)+          _ -> Left (BadPixels s)+        _ -> Left (BadHeight s)+      _ -> Left (BadWidth s)+    _ -> Left (BadMagicN s)+  _ -> Left (BadMagicP s)+  where+    skipSpaceComment t = case dropWhile isSpace t of+      ('#':t) -> case dropWhile (/= '\n') t of+        ('\n':t) -> skipSpaceComment t+        _ -> Left (BadSpace t)+      t -> Right t+    int (Left _) = Nothing+    int (Right t) = case span isDigit t of+      (d@(d0:_), t) | d0 /= '0' -> case reads d of+        [(d, "")] -> Just (d, t)+        _ -> Nothing+      _ -> Nothing+    collapseRaster 0 t = Just ([], t)+    collapseRaster n t = case dropWhile isSpace t of+      ('0':t) -> prepend False (collapseRaster (n - 1) t)+      ('1':t) -> prepend True  (collapseRaster (n - 1) t)+      _ -> Nothing+    prepend _ Nothing = Nothing+    prepend b (Just (bs, t)) = Just (b:bs, t)+    isSpace c = c `elem` pbmSpace+    isDigit c = c `elem` "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+  | (pixelWidth .&. 7) == 0 = pbm+  | otherwise = pbm{ pbmPixels = false paddedBounds // assocs (pbmPixels pbm) }+  where+    ((ylo, xlo), (yhi, xhi)) = bounds (pbmPixels pbm)+    pixelWidth = xhi - xlo + 1+    rowBytes = (pixelWidth + 7) `shiftR` 3+    paddedWidth = rowBytes `shiftL` 3+    paddedBounds = ((ylo, xlo), (yhi, xhi'))+    xhi' = paddedWidth + xlo - 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+  | pbmWidth pbm > pixelWidth = Nothing+  | pbmWidth pbm == pixelWidth = Just pbm+  | otherwise = Just pbm{ pbmPixels = ixmap trimmedBounds id (pbmPixels pbm) }+  where+    ((ylo, xlo), (yhi, xhi)) = bounds (pbmPixels pbm)+    pixelWidth = xhi - xlo + 1+    trimmedBounds = ((ylo, xlo), (yhi, xhi'))+    xhi' = pbmWidth pbm + xlo - 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 = padPBM `fmap` trimPBM 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 = BS.map reverseBits++-- | Fast reversal of the bit order of a byte using a lookup table.+reverseBits :: Word8 -> Word8+reverseBits w = bitReversed U.! w++-- | A lookup table for bit order reversal.+bitReversed :: U.UArray Word8 Word8+bitReversed = U.listArray bs [ bitReverse w | w <- range bs ]+  where bs = (minBound, maxBound)++-- | A slow way to reverse bit order.+bitReverse :: Word8 -> Word8+bitReverse = fromListBE . toListLE++-- | White space characters as defined by the PBM specification.+pbmSpace :: String+pbmSpace = " \t\n\v\f\r"
+ src/Data/Array/BitArray.hs view
@@ -0,0 +1,197 @@+{-|++Module      :  Data.Array.BitArray+Copyright   :  (c) Claude Heiland-Allen 2012+License     :  BSD3++Maintainer  :  claudiusmaximus@goto10.org+Stability   :  unstable+Portability :  portable++Immutable unboxed packed bit arrays using bitwise operations to+manipulate large chunks at a time much more quickly than individually+unpacking and repacking bits would allow.++-}+-- almost all is implemented with runST and the ST-based implementation+module Data.Array.BitArray+  ( BitArray()+  -- * IArray-like interface.+  , bounds+  , array+  , listArray+  , accumArray+  , (!)+  , indices+  , elems+  , assocs+  , (//)+  , accum+  , amap+  , ixmap+  -- * Constant arrays.+  , fill+  , false+  , true+  -- * Short-circuiting reductions.+  , or+  , and+  , isUniform+  -- * Aggregate operations.+  , fold+  , map+  , zipWith+  -- * Bounds-checked indexing.+  , (!?)+  -- * Unsafe.+  , (!!!)+  ) where++import Prelude hiding (and, or, map, zipWith)+import qualified Prelude as P++import Control.Monad (forM_)+import Control.Monad.ST (runST)+import Data.Ix (Ix, range, inRange)++import Data.Array.BitArray.Internal (BitArray)+import qualified Data.Array.BitArray.ST as ST++-- | The bounds of an array.+{-# INLINE bounds #-}+bounds :: Ix i => BitArray i -> (i, i)+bounds a = runST (ST.getBounds =<< ST.unsafeThaw a)++-- | Create an array from a list of (index, element) pairs.+{-# INLINE array #-}+array :: Ix i => (i, i) {- ^ bounds -} -> [(i, Bool)] {- ^ assocs -} -> BitArray i+array bs ies = false bs // ies++-- | Create an array from a list of elements.+{-# INLINE listArray #-}+listArray :: Ix i => (i, i) {- ^ bounds -} -> [Bool] {- ^ elems -} -> BitArray i+listArray bs es = runST (ST.unsafeFreeze =<< ST.newListArray bs es)++-- | Create an array by accumulating a list of (index, operand) pairs+--   from a default seed with an operation.+{-# INLINE accumArray #-}+accumArray :: Ix i => (Bool -> a -> Bool) {- ^ operation -} -> Bool {- ^ default -} -> (i, i) {- ^ bounds -} -> [(i, a)] {- ^ assocs -} -> BitArray i+accumArray f d bs = accum f (fill bs d)++-- | Bit array indexing.+{-# INLINE (!) #-}+(!) :: Ix i => BitArray i -> i -> Bool+a ! i = runST (do+  a' <- ST.unsafeThaw a+  ST.readArray a' i)++-- | Bit array indexing without bounds checking.  Unsafe.+{-# INLINE (!!!) #-}+(!!!) :: Ix i => BitArray i -> i -> Bool+a !!! i = runST (do+  a' <- ST.unsafeThaw a+  ST.unsafeReadArray a' i)++-- | A list of all the valid indices for this array.+{-# INLINE indices #-}+indices :: Ix i => BitArray i -> [i]+indices = range . bounds++-- | A list of the elements in this array.+{-# INLINE elems #-}+elems :: Ix i => BitArray i -> [Bool]+elems a = runST (ST.unsafeGetElems =<< ST.unsafeThaw a)+  -- P.map (a !!!) (indices a) -- very slow!++-- | A list of the (index, element) pairs in this array.+{-# INLINE assocs #-}+assocs :: Ix i => BitArray i -> [(i, Bool)]+assocs ba = P.map (\i -> (i, ba ! i)) (indices ba)++-- | A new array with updated values at the supplied indices.+{-# INLINE (//) #-}+(//) :: Ix i => BitArray i -> [(i, Bool)] {- ^ new assocs -} -> BitArray i+ba // ies = accum (\_ a -> a) ba ies++-- | Accumulate with an operation and a list of (index, operand).+{-# INLINE accum #-}+accum :: Ix i => (Bool -> a -> Bool) {- ^ operation -} -> BitArray i {- ^ source -} -> [(i, a)] {- ^ assocs -} -> BitArray i+accum f a ies = runST (do+  a' <- ST.thaw a+  forM_ ies $ \(i, x) -> do+    b <- ST.readArray a' i+    ST.writeArray a' i (f b x)+  ST.unsafeFreeze a')++-- | Alias for 'map'.+{-# INLINE amap #-}+amap :: Ix i => (Bool -> Bool) -> BitArray i -> BitArray i+amap = map++-- | Create a new array by mapping indices into a source array..+{-# INLINE ixmap #-}+ixmap :: (Ix i, Ix j) => (i, i) {- ^ new bounds -} -> (i -> j) {- ^ index transformation -} -> BitArray j {- ^ source array -} -> BitArray i+ixmap bs h ba = array bs (P.map (\i -> (i, ba ! h i)) (range bs))++-- | A uniform array of bits.+{-# INLINE fill #-}+fill :: Ix i => (i, i) {- ^ bounds -} -> Bool -> BitArray i+fill bs b = runST (ST.unsafeFreeze =<< ST.newArray bs b)++-- | A uniform array of 'False'.+{-# INLINE false #-}+false :: Ix i => (i, i) {- ^ bounds -} -> BitArray i+false bs = fill bs False++-- | A uniform array of 'True'.+{-# INLINE true #-}+true :: Ix i => (i, i) {- ^ bounds -} -> BitArray i+true bs = fill bs True++-- | Bounds checking combined with array indexing.+{-# INLINE (!?) #-}+(!?) :: Ix i => BitArray i -> i -> Maybe Bool+b !? i+  | inRange (bounds b) i = Just (b ! i)+  | otherwise = Nothing++-- | Short-circuit bitwise reduction: True if any bit is True.+{-# INLINE or #-}+or :: Ix i => BitArray i -> Bool+or a = runST (ST.or =<< ST.unsafeThaw a)++-- | Short-circuit bitwise reduction: False if any bit is False.+{-# INLINE and #-}+and :: Ix i => BitArray i -> Bool+and a = runST (ST.and =<< ST.unsafeThaw a)++-- | Short-circuit bitwise reduction: Nothing if any bits differ.+{-# INLINE isUniform #-}+isUniform :: Ix i => BitArray i -> Maybe Bool+isUniform a = runST (ST.isUniform =<< ST.unsafeThaw a)++-- | Bitwise reduction with an associative commutative boolean operator.+--   Implementation lifts from 'Bool' to 'Bits' and folds large chunks+--   at a time.  Each bit is used as a source exactly once.+{-# INLINE fold #-}+fold :: Ix i => (Bool -> Bool -> Bool) -> BitArray i -> Maybe Bool+fold f a = runST (ST.fold f =<< ST.unsafeThaw a)++-- | Bitwise map.  Implementation lifts from 'Bool' to 'Bits' and maps+--   large chunks at a time.+{-# INLINE map #-}+map :: Ix i => (Bool -> Bool) -> BitArray i -> BitArray i+map f a = runST (ST.unsafeFreeze =<< ST.map f =<< ST.unsafeThaw a)++-- | Bitwise zipWith.  Implementation lifts from 'Bool' to 'Bits' and+--   combines large chunks at a time.+--+--   The bounds of the source arrays must be identical.+{-# INLINE zipWith #-}+zipWith :: Ix i => (Bool -> Bool -> Bool) -> BitArray i -> BitArray i -> BitArray i+zipWith f a b+  | bounds a == bounds b = runST (do+      a' <- ST.unsafeThaw a+      b' <- ST.unsafeThaw b+      ST.unsafeFreeze =<< ST.zipWith f a' b')+  | otherwise = error "zipWith bounds mismatch"
+ src/Data/Array/BitArray/ByteString.hs view
@@ -0,0 +1,75 @@+{-|++Module      :  Data.Array.BitArray.ByteString+Copyright   :  (c) Claude Heiland-Allen 2012+License     :  BSD3++Maintainer  :  claudiusmaximus@goto10.org+Stability   :  unstable+Portability :  portable++Copy bit array data to and from ByteStrings.++-}+module Data.Array.BitArray.ByteString+  (+  -- * Immutable copying.+    toByteString+  , fromByteString+  -- * Mutable copying.+  , toByteStringIO+  , fromByteStringIO+  ) where++import Data.Bits (shiftR, (.&.))+import Data.ByteString (ByteString)+import Data.Ix (Ix, rangeSize)+import Data.Word (Word8)+import Control.Monad (when)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Marshal.Utils (copyBytes)+import Foreign.Ptr (castPtr)+import Foreign.Storable (peekByteOff, pokeByteOff)+import System.IO.Unsafe (unsafePerformIO)++import Compat (packCStringLen, unsafeUseAsCStringLen)+import Data.Bits.Bitwise (mask)+import Data.Array.BitArray (BitArray)+import Data.Array.BitArray.IO (IOBitArray)+import qualified Data.Array.BitArray.IO as IO+import Data.Array.BitArray.Internal (iobData)++-- | Copy to a ByteString.  The most significant bits of the last byte+--   are padded with 0 unless the array was a multiple of 8 bits in size.+toByteString :: Ix i => BitArray i -> ByteString+toByteString a = unsafePerformIO $ toByteStringIO =<< IO.unsafeThaw a++-- | Copy from a ByteString.  Much like 'listArray' but with packed bits.+fromByteString :: Ix i => (i, i) {- ^ bounds -} -> ByteString {- ^ packed elems -} -> BitArray i+fromByteString bs s = unsafePerformIO $ IO.unsafeFreeze =<< fromByteStringIO bs s++-- | Copy to a ByteString.  The most significant bits of the last byte+--   are padded with 0 unless the array was a multiple of 8 bits in size.+toByteStringIO :: Ix i => IOBitArray i -> IO ByteString+toByteStringIO a = do+  bs <- IO.getBounds a+  let rs = rangeSize bs+      bytes = (rs + 7) `shiftR` 3+      bits = rs .&. 7+      lastByte = bytes - 1+  withForeignPtr (iobData a) $ \p -> do+    when (bits /= 0) $ do+      b <- peekByteOff p lastByte+      pokeByteOff p lastByte (b .&. mask bits :: Word8)+    packCStringLen (castPtr p, bytes)++-- | Copy from a ByteString.  Much like 'newListArray' but with packed bits.+fromByteStringIO :: Ix i => (i, i) {- ^ bounds -} -> ByteString {- ^ packed elems -} -> IO (IOBitArray i)+fromByteStringIO bs s = do+  a <- IO.newArray bs False+  let rs = rangeSize bs+      bytes = (rs + 7) `shiftR` 3+  unsafeUseAsCStringLen s $ \(src, len) ->+    withForeignPtr (iobData a) $ \dst ->+      copyBytes dst (castPtr src) (bytes `min` len)+  return a
+ src/Data/Array/BitArray/IO.hs view
@@ -0,0 +1,348 @@+{-|++Module      :  Data.Array.BitArray.IO+Copyright   :  (c) Claude Heiland-Allen 2012+License     :  BSD3++Maintainer  :  claudiusmaximus@goto10.org+Stability   :  unstable+Portability :  portable++Unboxed mutable bit arrays in the 'IO' monad.++-}+module Data.Array.BitArray.IO+  ( IOBitArray()+  -- * MArray-like interface.+  , getBounds+  , newArray+  , newArray_+  , newListArray+  , readArray+  , writeArray+  , mapArray+  , mapIndices+  , getElems+  , getAssocs+  -- * Conversion to/from immutable bit arrays.+  , freeze+  , thaw+  -- * Construction+  , copy+  , fill+  -- * Short-circuiting reductions.+  , or+  , and+  , isUniform+  -- * Aggregate operations.+  , fold+  , map+  , zipWith+  -- * Unsafe.+  , unsafeReadArray+  , unsafeGetElems+  , unsafeFreeze+  , unsafeThaw+  ) where++import Prelude hiding (and, or, map, zipWith)++import Control.Monad (forM_, when)+import Data.Bits (shiftR, testBit, setBit, clearBit, (.&.), complement)+import Data.Ix (Ix, index, inRange, range, rangeSize)+import Data.List (foldl1')+import Data.Word (Word8, Word64)+import Foreign.ForeignPtr (withForeignPtr, touchForeignPtr)+import Foreign.Ptr (Ptr, plusPtr, castPtr)+import Foreign.Storable (poke, pokeByteOff, pokeElemOff, peekByteOff, peekElemOff)+import System.IO.Unsafe (unsafeInterleaveIO)++import Data.Bits.Bitwise (packWord8LE, mask)+import qualified Data.Bits.Bitwise as Bitwise++import Data.Array.BitArray.Internal+  ( IOBitArray(..)+  , getBounds+  , newArray_+  , freeze+  , unsafeFreeze+  , thaw+  , unsafeThaw+  , copy+  )++-- | Create a new array filled with an initial value.+{-# INLINE newArray #-}+newArray :: Ix i => (i, i) {- ^ bounds -} -> Bool {- ^ initial value -} -> IO (IOBitArray i)+newArray bs b = do+  a <- newArray_ bs+  fill a b+  return a++-- | Create a new array filled with values from a list.+{-# INLINE newListArray #-}+newListArray :: Ix i => (i, i) {- ^ bounds -} -> [Bool] {- ^ elems -} -> IO (IOBitArray i)+newListArray bs es = do+  a <- newArray_ bs+  let byteBits = 8+      writeBytes :: Ptr Word8 -> [Bool] -> IO ()+      writeBytes p (b0:b1:b2:b3:b4:b5:b6:b7:rest) = do+        poke p (packWord8LE b0 b1 b2 b3 b4 b5 b6 b7)+        writeBytes (plusPtr p 1) rest+      writeBytes _ [] = return ()+      writeBytes p rest = writeBytes p (take byteBits (rest ++ repeat False))+  withForeignPtr (iobData a) $ \p -> do+    writeBytes (castPtr p) (take (byteBits * iobBytes a) es)+  return a++-- | Read from an array at an index.+{-# INLINE readArray #-}+readArray :: Ix i => IOBitArray i -> i -> IO Bool+readArray a i = do+  bs <- getBounds a+  when (not (inRange bs i)) $ error "array index out of bounds"+  readArrayRaw a (index bs i)++-- | Read from an array at an index without bounds checking.  Unsafe.+{-# INLINE unsafeReadArray #-}+unsafeReadArray :: Ix i => IOBitArray i -> i -> IO Bool+unsafeReadArray a i = do+  bs <- getBounds a+  readArrayRaw a (index bs i)++{-# INLINE readArrayRaw #-}+readArrayRaw :: Ix i => IOBitArray i -> Int -> IO Bool+readArrayRaw a n = do+  let byte = n `shiftR` 3+      bit = n .&. 7+  withForeignPtr (iobData a) $ \p -> do+    b0 <- peekByteOff p byte+    return (testBit (b0 :: Word8) bit)++-- | Write to an array at an index.+{-# INLINE writeArray #-}+writeArray :: Ix i => IOBitArray i -> i -> Bool -> IO ()+writeArray a i b = do+  bs <- getBounds a+  when (not (inRange bs i)) $ error "array index out of bounds"+  let n = index bs i+      byte = n `shiftR` 3+      bit = n .&. 7+  withForeignPtr (iobData a) $ \p -> do+    b0 <- peekByteOff p byte+    let b1 = (if b then setBit else clearBit) (b0 :: Word8) bit+    pokeByteOff p byte b1++-- | Alias for 'map'.+{-# INLINE mapArray #-}+mapArray :: Ix i => (Bool -> Bool) -> IOBitArray i -> IO (IOBitArray i)+mapArray = map++-- unsafeInterleaveIO is used to avoid having to create the whole list in+-- memory before the function can return, but need to keep the ForeignPtr+-- alive to avoid GC stealing our data.+interleavedMapMThenTouch :: Ix i => IOBitArray i -> (a -> IO b) -> [a] -> IO [b]+interleavedMapMThenTouch a _ [] = touchForeignPtr (iobData a) >> return []+interleavedMapMThenTouch a f (x:xs) = unsafeInterleaveIO $ do+  y <- f x+  ys <- interleavedMapMThenTouch a f xs+  return (y:ys)++-- | Create a new array by reading from another.+{-# INLINE mapIndices #-}+mapIndices :: (Ix i, Ix j) => (i, i) {- ^ new bounds -} -> (i -> j) {- ^ index transformation -} -> IOBitArray j {- ^ source array -} -> IO (IOBitArray i)+mapIndices bs h a = newListArray bs =<< interleavedMapMThenTouch a (readArray a . h) (range bs)++-- | Get a list of all elements of an array.+{-# INLINE getElems #-}+getElems :: Ix i => IOBitArray i -> IO [Bool]+getElems a = unsafeGetElems =<< copy a++-- | Get a list of all elements of an array.  Unsafe when the source+--   array can be modified later.+{-# INLINE unsafeGetElems #-}+unsafeGetElems :: Ix i => IOBitArray i -> IO [Bool]+unsafeGetElems a' = do+  bs <- getBounds a'+  let r = rangeSize bs+      count = (r + 7) `shiftR` 3+  p <- withForeignPtr (iobData a') $ return+  bytes <- interleavedMapMThenTouch a' (peekByteOff p) [0 .. count - 1]+  return . take r . concatMap Bitwise.toListLE $ (bytes :: [Word8])++-- | Get a list of all (index, element) pairs.+{-# INLINE getAssocs #-}+getAssocs :: Ix i => IOBitArray i -> IO [(i, Bool)]+getAssocs a = do+  bs <- getBounds a+  zip (range bs) `fmap` getElems a+  +-- | Fill an array with a uniform value.+{-# INLINE fill #-}+fill :: Ix i => IOBitArray i -> Bool -> IO ()+fill a b = do+  let count = iobBytes a `shiftR` 3+      word :: Word64+      word = if b then complement 0 else 0+  withForeignPtr (iobData a) $ \p ->+    forM_ [0 .. count - 1] $ \i ->+      pokeElemOff p i word++-- | Short-circuit bitwise reduction: True when any bit is True.+{-# INLINE or #-}+or :: Ix i => IOBitArray i -> IO Bool+or a = do+  bs <- getBounds a+  let total = rangeSize bs+      full = total .&. complement (mask 6)+      count = full `shiftR` 6+      loop :: Ptr Word64 -> Int -> IO Bool+      loop p n+        | n < count = do+            w <- peekElemOff p n+            if w /= (0 :: Word64) then return True else loop p (n + 1)+        | otherwise = rest full+      rest m+        | m < total = do+            b <- readArrayRaw a m+            if b then return True else rest (m + 1)+        | otherwise = return False+  withForeignPtr (iobData a) $ \p -> loop p 0++-- | Short-circuit bitwise reduction: False when any bit is False.+{-# INLINE and #-}+and :: Ix i => IOBitArray i -> IO Bool+and a = do+  bs <- getBounds a+  let total = rangeSize bs+      full = total .&. complement (mask 6)+      count = full `shiftR` 6+      loop :: Ptr Word64 -> Int -> IO Bool+      loop p n+        | n < count = do+            w <- peekElemOff p n+            if w /= (complement 0 :: Word64) then return False else loop p (n + 1)+        | otherwise = rest full+      rest m+        | m < total = do+            b <- readArrayRaw a m+            if not b then return False else rest (m + 1)+        | otherwise = return True+  withForeignPtr (iobData a) $ \p -> loop p 0++-- | Short-circuit bitwise reduction: 'Nothing' when any bits differ,+--   'Just' when all bits are the same.+{-# INLINE isUniform #-}+isUniform :: Ix i => IOBitArray i -> IO (Maybe Bool)+isUniform a = do+  bs <- getBounds a+  let total = rangeSize bs+      full = total .&. complement (mask 6)+      count = full `shiftR` 6+      loop :: Ptr Word64 -> Int -> Bool -> Bool -> IO (Maybe Bool)+      loop p n st sf+        | n < count = do+            w <- peekElemOff p n+            let t = w /= (0 :: Word64)  || st+                f = w /= (complement 0) || sf+            if t && f then return Nothing else loop p (n + 1) t f+        | otherwise = rest full st sf+      rest m st sf+        | m < total = do+            b <- readArrayRaw a m+            let t =     b || st+                f = not b || sf+            if t && f then return Nothing else rest (m + 1) t f+        | st && not sf = return (Just True)+        | not st && sf = return (Just False)+        | otherwise = return Nothing+  withForeignPtr (iobData a) $ \p -> loop p 0 False False++-- | Bitwise reduction with an associative commutative boolean operator.+--   Implementation lifts from 'Bool' to 'Bits' and folds large chunks+--   at a time.  Each bit is used as a source exactly once.+{-# INLINE fold #-}+fold :: Ix i => (Bool -> Bool -> Bool) {- ^ operator -} -> IOBitArray i -> IO (Maybe Bool)+fold f a = do+  bs <- getBounds a+  let g = Bitwise.zipWith f+      total = rangeSize bs+      full = total .&. complement (mask 6)+      count = full `shiftR` 6+      loop :: Ptr Word64 -> Int -> Maybe Word64 -> IO (Maybe Bool)+      loop p n mw+        | n < count = do+            w <- peekElemOff p n+            case mw of+              Nothing -> loop p (n + 1) (Just $!      w)+              Just w0 -> loop p (n + 1) (Just $! g w0 w)+        | otherwise =+            case mw of+              Nothing -> rest full Nothing+              Just w0 -> rest full (Just $! foldl1' f (Bitwise.toListLE w0))+      rest m mb+        | m < total = do+            b <- readArrayRaw a m+            case mb of+              Nothing -> rest (m + 1) (Just $!      b)+              Just b0 -> rest (m + 1) (Just $! f b0 b)+        | otherwise = return mb+  withForeignPtr (iobData a) $ \p -> loop p 0 Nothing++-- | Bitwise map.  Implementation lifts from 'Bool' to 'Bits' and maps+--   large chunks at a time.+{-# INLINE map #-}+map :: Ix i => (Bool -> Bool) -> IOBitArray i -> IO (IOBitArray i)+map f a = do+  bs <- getBounds a+  b <- newArray_ bs+  mapTo b f a+  return b++{-# INLINE mapTo #-}+mapTo :: Ix i => IOBitArray i -> (Bool -> Bool) -> IOBitArray i -> IO ()+mapTo dst f src = do+  -- {+  sbs <- getBounds src+  dbs <- getBounds dst+  when (sbs /= dbs) $ error "mapTo mismatched bounds"+  -- }+  let count = iobBytes dst `shiftR` 3+      g :: Word64 -> Word64+      g = Bitwise.map f+  withForeignPtr (iobData src) $ \sp ->+    withForeignPtr (iobData dst) $ \dp ->+      forM_ [0 .. count - 1] $ \n -> do+        pokeElemOff dp n . g =<< peekElemOff sp n++-- | Bitwise zipWith.  Implementation lifts from 'Bool' to 'Bits' and+--   combines large chunks at a time.+--+--   The bounds of the source arrays must be identical.+{-# INLINE zipWith #-}+zipWith :: Ix i => (Bool -> Bool -> Bool) -> IOBitArray i -> IOBitArray i -> IO (IOBitArray i)+zipWith f l r = do+  lbs <- getBounds l+  rbs <- getBounds r+  when (lbs /= rbs) $ error "zipWith mismatched bounds"+  c <- newArray_ lbs+  zipWithTo c f l r+  return c++{-# INLINE zipWithTo #-}+zipWithTo :: Ix i => IOBitArray i -> (Bool -> Bool -> Bool) -> IOBitArray i -> IOBitArray i -> IO ()+zipWithTo dst f l r = do+  lbs <- getBounds l+  rbs <- getBounds r+  dbs <- getBounds dst+  when (lbs /= rbs || dbs /= lbs || dbs /= rbs) $ error "zipWithTo mismatched bounds"+  let count = iobBytes dst `shiftR` 3+      g :: Word64 -> Word64 -> Word64+      g = Bitwise.zipWith f+  withForeignPtr (iobData l) $ \lp ->+    withForeignPtr (iobData r) $ \rp ->+      withForeignPtr (iobData dst) $ \dp ->+          forM_ [0 .. count - 1] $ \n -> do+            p <- peekElemOff lp n+            q <- peekElemOff rp n+            pokeElemOff dp n (g p q)
+ src/Data/Array/BitArray/Internal.hs view
@@ -0,0 +1,84 @@+{-# OPTIONS_HADDOCK hide #-}+{-|++Module      :  Data.Array.BitArray.Internal+Copyright   :  (c) Claude Heiland-Allen 2012+License     :  BSD3++Maintainer  :  claudiusmaximus@goto10.org+Stability   :  unstable+Portability :  portable++Bit arrays internals.  Not exposed.++-}+module Data.Array.BitArray.Internal+  ( BitArray(..)+  , IOBitArray(..)+  , getBounds+  , newArray_+  , freeze+  , thaw+  , copy+  , unsafeFreeze+  , unsafeThaw+  ) where++import Data.Bits (shiftL, shiftR)+import Data.Ix (Ix, rangeSize)+import Data.Word (Word64)+import Foreign.Marshal.Utils (copyBytes)+import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtrBytes, withForeignPtr)++-- | The type of immutable bit arrays.+newtype BitArray i = B (IOBitArray i)++-- | The type of mutable bit arrays in the 'IO' monad.+data IOBitArray i = IOB{ iobBoundLo :: !i, iobBoundHi :: !i, iobBytes :: {-# UNPACK #-} !Int, iobData :: {-# UNPACK #-} !(ForeignPtr Word64) }++-- | Create a new array filled with unspecified initial values.+{-# INLINE newArray_ #-}+newArray_ :: Ix i => (i, i) {- ^ bounds -} -> IO (IOBitArray i)+newArray_ bs@(bl, bh) = do+  let bits = rangeSize bs+      nwords = (bits + 63) `shiftR` 6+      bytes = nwords `shiftL` 3+  p <- mallocForeignPtrBytes bytes+  return IOB{ iobBoundLo = bl, iobBoundHi = bh, iobBytes = bytes, iobData = p }++-- | Get the bounds of a bit array.+{-# INLINE getBounds #-}+getBounds :: Ix i => IOBitArray i -> IO (i, i)+getBounds a = return (iobBoundLo a, iobBoundHi a)++-- | Snapshot the array into an immutable form.+{-# INLINE freeze #-}+freeze :: Ix i => IOBitArray i -> IO (BitArray i)+freeze a = B `fmap` copy a++-- | Snapshot the array into an immutable form.  Unsafe when the source+--   array can be modified later.+{-# INLINE unsafeFreeze #-}+unsafeFreeze :: Ix i => IOBitArray i -> IO (BitArray i)+unsafeFreeze a = B `fmap` return a++-- | Convert an array from immutable form.+{-# INLINE thaw #-}+thaw :: Ix i => BitArray i -> IO (IOBitArray i)+thaw (B a) = copy a++-- | Convert an array from immutable form.  Unsafe to modify the result+--   unless the source array is never used later.+{-# INLINE unsafeThaw #-}+unsafeThaw :: Ix i => BitArray i -> IO (IOBitArray i)+unsafeThaw (B a) = return a++-- | Copy an array.+{-# INLINE copy #-}+copy :: Ix i => IOBitArray i -> IO (IOBitArray i)+copy a = do+  b <- newArray_ =<< getBounds a+  withForeignPtr (iobData a) $ \ap ->+    withForeignPtr (iobData b) $ \bp ->+      copyBytes bp ap (iobBytes b)+  return b
+ src/Data/Array/BitArray/ST.hs view
@@ -0,0 +1,189 @@+{-|++Module      :  Data.Array.BitArray.ST+Copyright   :  (c) Claude Heiland-Allen 2012+License     :  BSD3++Maintainer  :  claudiusmaximus@goto10.org+Stability   :  unstable+Portability :  uses ST++Unboxed mutable bit arrays in the 'ST' monad.++-}+-- almost all is implemented with unsafeIOToST and the IO-based implementation+module Data.Array.BitArray.ST+  ( STBitArray()+  -- * MArray-like interface.+  , getBounds+  , newArray+  , newArray_+  , newListArray+  , readArray+  , writeArray+  , mapArray+  , mapIndices+  , getElems+  , getAssocs+  -- * Conversion to/from immutable bit arrays.+  , freeze+  , thaw+  -- * Construction.+  , copy+  , fill+  -- * Short-circuiting reductions.+  , or+  , and+  , isUniform+  -- * Aggregate operations.+  , fold+  , map+  , zipWith+  -- * Unsafe.+  , unsafeReadArray+  , unsafeGetElems+  , unsafeFreeze+  , unsafeThaw+  ) where++import Prelude hiding (and, or, map, zipWith)+import Control.Monad.ST (ST)+import Data.Ix (Ix)++import Compat (unsafeIOToST)+import Data.Array.BitArray.Internal (BitArray)+import Data.Array.BitArray.IO (IOBitArray)+import qualified Data.Array.BitArray.IO as IO++-- | The type of mutable bit arrays.+newtype STBitArray s i = STB (IOBitArray i)++-- | Get the bounds of a bit array.+{-# INLINE getBounds #-}+getBounds :: Ix i => STBitArray s i -> ST s (i, i)+getBounds (STB a) = unsafeIOToST (IO.getBounds a)++-- | Create a new array filled with an initial value.+{-# INLINE newArray #-}+newArray :: Ix i => (i, i) {- ^ bounds -} -> Bool {- ^ initial value -} -> ST s (STBitArray s i)+newArray bs b = STB `fmap` unsafeIOToST (IO.newArray bs b)++-- | Create a new array filled with a default initial value ('False').+{-# INLINE newArray_ #-}+newArray_ :: Ix i => (i, i) {- ^ bounds -} -> ST s (STBitArray s i)+newArray_ bs = STB `fmap` unsafeIOToST (IO.newArray bs False)++-- | Create a new array filled with values from a list.+{-# INLINE newListArray #-}+newListArray :: Ix i => (i, i) {- ^ bounds -} -> [Bool] {- ^ elems -} -> ST s (STBitArray s i)+newListArray bs es = STB `fmap` unsafeIOToST (IO.newListArray bs es)++-- | Read from an array at an index.+{-# INLINE readArray #-}+readArray :: Ix i => STBitArray s i -> i -> ST s Bool+readArray (STB a) i = unsafeIOToST (IO.readArray a i)++-- | Read from an array at an index without bounds checking.  Unsafe.+{-# INLINE unsafeReadArray #-}+unsafeReadArray :: Ix i => STBitArray s i -> i -> ST s Bool+unsafeReadArray (STB a) i = unsafeIOToST (IO.unsafeReadArray a i)++-- | Write to an array at an index.+{-# INLINE writeArray #-}+writeArray :: Ix i => STBitArray s i -> i -> Bool -> ST s ()+writeArray (STB a) i b = unsafeIOToST (IO.writeArray a i b)++-- | Alias for 'map'.+{-# INLINE mapArray #-}+mapArray :: Ix i => (Bool -> Bool) -> STBitArray s i -> ST s (STBitArray s i)+mapArray = map++-- | Create a new array by reading from another.+{-# INLINE mapIndices #-}+mapIndices :: (Ix i, Ix j) => (i, i) {- ^ new bounds -} -> (i -> j) {- ^ index transformation -} -> STBitArray s j {- ^ source array -} -> ST s (STBitArray s i)+mapIndices bs h (STB a) = STB `fmap` unsafeIOToST (IO.mapIndices bs h a)++-- | Get a list of all elements of an array.+{-# INLINE getElems #-}+getElems :: Ix i => STBitArray s i -> ST s [Bool]+getElems (STB a) = unsafeIOToST (IO.getElems a)++-- | Get a list of all elements of an array without copying.  Unsafe when+--   the source array can be modified later.+{-# INLINE unsafeGetElems #-}+unsafeGetElems :: Ix i => STBitArray s i -> ST s [Bool]+unsafeGetElems (STB a) = unsafeIOToST (IO.unsafeGetElems a)++-- | Get a list of all (index, element) pairs.+{-# INLINE getAssocs #-}+getAssocs :: Ix i => STBitArray s i -> ST s [(i, Bool)]+getAssocs (STB a) = unsafeIOToST (IO.getAssocs a)++-- | Snapshot the array into an immutable form.+{-# INLINE freeze #-}+freeze :: Ix i => STBitArray s i -> ST s (BitArray i)+freeze (STB a) = unsafeIOToST (IO.freeze a)++-- | Snapshot the array into an immutable form.  Unsafe when the source+--   array can be modified later.+{-# INLINE unsafeFreeze #-}+unsafeFreeze :: Ix i => STBitArray s i -> ST s (BitArray i)+unsafeFreeze (STB a) = unsafeIOToST (IO.unsafeFreeze a)++-- | Convert an array from immutable form.+{-# INLINE thaw #-}+thaw :: Ix i => BitArray i -> ST s (STBitArray s i)+thaw a = STB `fmap` unsafeIOToST (IO.thaw a)++-- | Convert an array from immutable form.  Unsafe to modify the result+--   unless the source array is never used later.+{-# INLINE unsafeThaw #-}+unsafeThaw :: Ix i => BitArray i -> ST s (STBitArray s i)+unsafeThaw a = STB `fmap` unsafeIOToST (IO.unsafeThaw a)++-- | Copy an array.+{-# INLINE copy #-}+copy :: Ix i => STBitArray s i -> ST s (STBitArray s i)+copy (STB a) = STB `fmap` unsafeIOToST (IO.copy a)++-- | Fill an array with a uniform value.+{-# INLINE fill #-}+fill :: Ix i => STBitArray s i -> Bool -> ST s ()+fill (STB a) b = unsafeIOToST (IO.fill a b)++-- | Short-circuit bitwise reduction: True when any bit is True.+{-# INLINE or #-}+or :: Ix i => STBitArray s i -> ST s Bool+or (STB a) = unsafeIOToST (IO.or a)++-- | Short-circuit bitwise reduction: False when any bit is False.+{-# INLINE and #-}+and :: Ix i => STBitArray s i -> ST s Bool+and (STB a) = unsafeIOToST (IO.and a)++-- | Short-circuit bitwise reduction: 'Nothing' when any bits differ,+--   'Just' when all bits are the same.+{-# INLINE isUniform #-}+isUniform :: Ix i => STBitArray s i -> ST s (Maybe Bool)+isUniform (STB a) = unsafeIOToST (IO.isUniform a)++-- | Bitwise reduction with an associative commutative boolean operator.+--   Implementation lifts from 'Bool' to 'Bits' and folds large chunks+--   at a time.  Each bit is used as a source exactly once.+{-# INLINE fold #-}+fold :: Ix i => (Bool -> Bool -> Bool) {- ^ operator -} -> STBitArray s i -> ST s (Maybe Bool)+fold f (STB a) = unsafeIOToST (IO.fold f a)++-- | Bitwise map.  Implementation lifts from 'Bool' to 'Bits' and maps+--   large chunks at a time.+{-# INLINE map #-}+map :: Ix i => (Bool -> Bool) -> STBitArray s i -> ST s (STBitArray s i)+map f (STB a) = STB `fmap` unsafeIOToST (IO.map f a)++-- | Bitwise zipWith.  Implementation lifts from 'Bool' to 'Bits' and+--   combines large chunks at a time.+--+--   The bounds of the source arrays must be identical.+{-# INLINE zipWith #-}+zipWith :: Ix i => (Bool -> Bool -> Bool) -> STBitArray s i -> STBitArray s i -> ST s (STBitArray s i)+zipWith f (STB a) (STB b) = STB `fmap` unsafeIOToST (IO.zipWith f a b)
+ src/Data/Bits/Bitwise.hs view
@@ -0,0 +1,196 @@+{-|++Module      :  Data.Bits.Bitwise+Copyright   :  (c) Claude Heiland-Allen 2012+License     :  BSD3++Maintainer  :  claudiusmaximus@goto10.org+Stability   :  unstable+Portability :  portable++Lifting boolean operations on 'Bool' to bitwise operations on 'Bits'.++Packing bits into words, and unpacking words into bits.++-}+module Data.Bits.Bitwise+  (+  -- * Boolean operations lifted to bitwise operations.+    repeat+  , map+  , zipWith+  , or+  , and+  , any+  , all+  , isUniform+  -- * Splitting\/joining 'Bits' to\/from (lsb, msb).+  , mask+  , splitAt+  , joinAt+  , fromBool+  -- * (Un)packing 'Bits' to\/from lists of 'Bool'.+  , fromListLE+  , toListLE+  , fromListBE+  , toListBE+  -- * (Un)packing 'Word8' to\/from 8-tuples of 'Bool'.+  , packWord8LE+  , unpackWord8LE+  , packWord8BE+  , unpackWord8BE+  ) where++import Prelude hiding (repeat, map, zipWith, any, all, or, and, splitAt)+import qualified Prelude as P++import Data.Bits (Bits(complement, (.&.), (.|.), xor, bit, shiftL, shiftR, testBit, bitSize))+import Data.List (foldl')+import Data.Word (Word8)++-- | Lift a boolean constant to a bitwise constant.+{-# INLINE repeat #-}+repeat :: Bits b => Bool -> b+repeat False = 0+repeat True = complement 0++-- | Lift a unary boolean operation to a bitwise operation.+--+--   The implementation is by exhaustive input\/output case analysis:+--   thus the operation provided must be total.+--+{-# INLINE map #-}+map :: Bits b => (Bool -> Bool) {- ^ operation -} -> b -> b+map f = case (f False, f True) of+  (False, False) -> \_ -> 0+  (False, True ) -> id+  (True,  False) -> complement+  (True,  True ) -> \_ -> complement 0++-- | Lift a binary boolean operation to a bitwise operation.+--+--   The implementation is by exhaustive input\/output case analysis:+--   thus the operation provided must be total.+--+{-# INLINE zipWith #-}+zipWith :: Bits b => (Bool -> Bool -> Bool) {- ^ operation -} -> b -> b -> b+zipWith f = case (f False False, f False True, f True False, f True True) of+  (False, False, False, False) -> \_ _ -> 0+  (False, False, False, True ) -> (.&.)+  (False, False, True,  False) -> \x y -> x .&. complement y+  (False, False, True,  True ) -> \x _ -> x+  (False, True,  False, False) -> \x y -> complement x .&. y+  (False, True,  False, True ) -> \_ y -> y+  (False, True,  True,  False) -> xor+  (False, True,  True,  True ) -> (.|.)+  (True,  False, False, False) -> \x y -> complement (x .|. y)+  (True,  False, False, True ) -> \x y -> complement (x `xor` y)+  (True,  False, True,  False) -> \_ y -> complement y+  (True,  False, True,  True ) -> \x y -> x .|. complement y+  (True,  True,  False, False) -> \x _ -> complement x+  (True,  True,  False, True ) -> \x y -> complement x .|. y+  (True,  True,  True,  False) -> \x y -> complement (x .&. y)+  (True,  True,  True,  True ) -> \_ _ -> complement 0++-- zipWith3 would have 256 cases? not sure..++-- | True when any bit is set.+{-# INLINE or #-}+or  :: Bits b => b -> Bool+or  b = b /= 0++-- | True when all bits are set.+{-# INLINE and #-}+and :: Bits b => b -> Bool+and b = b == complement 0++-- | True when the predicate is true for any bit.+{-# INLINE any #-}+any :: Bits b => (Bool -> Bool) {- ^ predicate -} -> b -> Bool+any f = or  . map f++-- | True when the predicate is true for all bits.+{-# INLINE all #-}+all :: Bits b => (Bool -> Bool) {- ^ predicate -} -> b -> Bool+all f = and . map f++-- | Determine if a 'Bits' is all 1s, all 0s, or neither.+{-# INLINE isUniform #-}+isUniform :: Bits b => b -> Maybe Bool+isUniform b+  | b == 0            = Just False+  | b == complement 0 = Just True+  | otherwise         = Nothing++-- | A mask with count least significant bits set.+{-# INLINE mask #-}+mask :: Bits b => Int {- ^ count -} -> b+mask n = bit n - bit 0++-- | Split a word into (lsb, msb).  Ensures lsb has no set bits+--   above the split point.+{-# INLINE splitAt #-}+splitAt :: Bits b => Int {- ^ split point -} -> b {- ^ word -} -> (b, b) {- ^ (lsb, msb) -}+splitAt n b = (b .&. mask n, b `shiftR` n)++-- | Join lsb with msb to make a word.  Assumes lsb has no set bits+--   above the join point.+{-# INLINE joinAt #-}+joinAt :: Bits b => Int {- ^ join point -} -> b {- ^ least significant bits -} -> b {- ^ most significant bits -} -> b {- ^ word -}+joinAt n lsb msb = lsb .|. (msb `shiftL` n)++-- | Pack bits into a byte in little-endian order.+{-# INLINE packWord8LE #-}+packWord8LE :: Bool {- ^ least significant bit -} -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool {- ^ most significant bit -} -> Word8+packWord8LE  a b c d e f g h = z a 1 .|. z b 2 .|. z c 4 .|. z d 8 .|. z e 16 .|. z f 32 .|. z g 64 .|. z h 128+  where z False _ = 0+        z True  n = n++-- | Pack bits into a byte in big-endian order.+{-# INLINE packWord8BE #-}+packWord8BE :: Bool {- ^ most significant bit -} -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool {- ^ least significant bit -} -> Word8+packWord8BE a b c d e f g h = packWord8LE h g f e d c b a++-- | Extract the bits from a byte in little-endian order.+{-# INLINE unpackWord8LE #-}+unpackWord8LE :: Word8 -> (Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool) {- ^ (least significant bit, ..., most significant bit) -}+unpackWord8LE w = (b 1, b 2, b 4, b 8, b 16, b 32, b 64, b 128)+  where b z = w .&. z /= 0++-- | Extract the bits from a byte in big-endian order.+{-# INLINE unpackWord8BE #-}+unpackWord8BE :: Word8 -> (Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool) {- ^ (most significant bit, ..., least significant bit) -}+unpackWord8BE w = (b 128, b 64, b 32, b 16, b 8, b 4, b 2, b 1)+  where b z = w .&. z /= 0++-- | The least significant bit.+{-# INLINE fromBool #-}+fromBool :: Bits b => Bool -> b+fromBool False = 0+fromBool True  = bit 0++-- | Convert a little-endian list of bits to 'Bits'.+{-# INLINE fromListLE #-}+fromListLE :: Bits b => [Bool] {- ^ \[least significant bit, ..., most significant bit\] -} -> b+fromListLE = foldr f 0+  where+    f b i = fromBool b .|. (i `shiftL` 1)++-- | Convert a 'Bits' (with a defined 'bitSize') to a list of bits, in+--   little-endian order.+{-# INLINE toListLE #-}+toListLE :: Bits b => b -> [Bool] {- ^ \[least significant bit, ..., most significant bit\] -}+toListLE b = P.map (testBit b) [0 .. bitSize b - 1]++-- | Convert a big-endian list of bits to 'Bits'.+{-# INLINE fromListBE #-}+fromListBE :: Bits b => [Bool] {- ^ \[most significant bit, ..., least significant bit\] -} -> b+fromListBE = foldl' f 0+  where+    f i b = (i `shiftL` 1) .|. fromBool b++-- | Convert a 'Bits' (with a defined 'bitSize') to a list of bits, in+--   big-endian order.+{-# INLINE toListBE #-}+toListBE :: Bits b => b -> [Bool] {- ^ \[most significant bit, ..., least significant bit\] -}+toListBE b = P.map (testBit b) [bitSize b - 1, bitSize b - 2 .. 0]