diff --git a/enumset.cabal b/enumset.cabal --- a/enumset.cabal +++ b/enumset.cabal @@ -1,6 +1,6 @@ -- would also be useful as type-safe alternative in wx, wxcore Name: enumset -Version: 0.0.2 +Version: 0.0.3 License: BSD3 License-File: LICENSE Author: Henning Thielemann @@ -23,11 +23,6 @@ Tested-With: GHC==6.10.4, GHC==6.12.3 Build-Type: Simple -Source-Repository this - Tag: 0.0.2 - Type: darcs - Location: http://code.haskell.org/~thielema/enumset/ - Source-Repository head Type: darcs Location: http://code.haskell.org/~thielema/enumset/ @@ -45,3 +40,6 @@ Data.EnumSet Data.EnumSet.PackedEnum Data.FlagSet + Data.FlagSet.PackedRecord + Other-Modules: + Data.EnumSet.Utility diff --git a/src/Data/EnumSet.hs b/src/Data/EnumSet.hs --- a/src/Data/EnumSet.hs +++ b/src/Data/EnumSet.hs @@ -18,6 +18,7 @@ empty, singleton, disjoint, + subset, (.&.), (.-.), (.|.), @@ -74,13 +75,15 @@ toEnums :: (Enum a, Bits w) => T w a -> [a] toEnums = map fst . filter (P.flip B.testBit 0 . snd) . - zip [P.toEnum 0 ..] . iterate (P.flip B.shiftR 1) . + zip [P.toEnum 0 ..] . + takeWhile (0/=) . iterate (P.flip B.shiftR 1) . decons intToEnums :: (Enum a, Integral w) => T w a -> [a] intToEnums = map fst . filter (odd . snd) . - zip [P.toEnum 0 ..] . iterate (P.flip div 2) . + zip [P.toEnum 0 ..] . + takeWhile (0/=) . iterate (P.flip div 2) . decons @@ -124,7 +127,13 @@ disjoint :: (Enum a, Bits w) => T w a -> T w a -> Bool disjoint x y = null (x .&. y) +{- | +@subset a b@ is 'True' if @a@ is a subset of @b@. +-} +subset :: (Enum a, Bits w) => T w a -> T w a -> Bool +subset x y = null (x .-. y) + {-# INLINE lift2 #-} lift2 :: (w -> w -> w) -> (T w a -> T w a -> T w a) lift2 f (Cons x) (Cons y) = Cons (f x y) @@ -143,6 +152,7 @@ unions = foldl (.|.) empty +-- | could also be named @member@ like in @Set@ or @elem@ as in '[]' get :: (Enum a, Bits w) => a -> T w a -> Bool get n = P.flip B.testBit (P.fromEnum n) . decons @@ -163,9 +173,11 @@ singleton :: (Enum a, Bits w) => a -> T w a singleton = P.flip set empty +-- | could also be named @insert@ like in @Set@ set :: (Enum a, Bits w) => a -> T w a -> T w a set = lift1 B.setBit +-- | could also be named @delete@ like in @Set@ clear :: (Enum a, Bits w) => a -> T w a -> T w a clear = lift1 B.clearBit diff --git a/src/Data/EnumSet/Utility.hs b/src/Data/EnumSet/Utility.hs new file mode 100644 --- /dev/null +++ b/src/Data/EnumSet/Utility.hs @@ -0,0 +1,11 @@ +module Data.EnumSet.Utility where + +import qualified Data.Bits as B +import Data.Bits (Bits, (.&.), ) + + +-- fixity like .&. +infixl 7 .-. + +(.-.) :: (Bits w) => w -> w -> w +x .-. y = x .&. B.complement y diff --git a/src/Data/FlagSet.hs b/src/Data/FlagSet.hs --- a/src/Data/FlagSet.hs +++ b/src/Data/FlagSet.hs @@ -12,7 +12,6 @@ get, put, accessor, ) where -import qualified Data.Bits as B import Data.Bits (Bits, (.&.), (.|.), ) import Data.Monoid (Monoid(mempty, mappend, mconcat), ) @@ -22,6 +21,8 @@ import qualified Data.Accessor.Basic as Acc +import Data.EnumSet.Utility ((.-.), ) + import qualified Prelude as P import Prelude hiding (Enum, fromEnum, toEnum, null, flip, ) @@ -58,6 +59,11 @@ newtype Mask w a b = Mask {unmask :: w} deriving (Eq, Show) +{- | +The type parameter @w@ is the type of the underlying bit vector. +The type parameter @b@ is a phantom type, +that is specific for a certain range of bits. +-} newtype Value w b = Value {unvalue :: w} deriving (Eq, Show) @@ -65,6 +71,15 @@ get :: (Enum a, Bits w) => Mask w a b -> T w a -> Value w b get (Mask m) (Cons fs) = Value (m .&. fs) +{- | +All bits in Value must be contained in the mask. +This condition is not checked by 'put'. + +According to names in "Data.Accessor" it should be called @set@, +but in "Data.Bits" and thus "Data.EnumSet" +this is already used in the pair @set@/@clear@. +@put@/@get@ resembles the pair in "Control.Monad.State" in the @mtl@ package. +-} put :: (Enum a, Bits w) => Mask w a b -> Value w b -> T w a -> T w a put (Mask m) (Value v) (Cons fs) = Cons $ (fs .-. m) .|. v @@ -132,11 +147,3 @@ compose :: (Enum a, P.Enum a, Bits w) => [a] -> T w a compose xs = fromMaskedValue $ mconcat $ map fromEnum xs - - - --- fixity like .&. -infixl 7 .-. - -(.-.) :: (Bits w) => w -> w -> w -x .-. y = x .&. B.complement y diff --git a/src/Data/FlagSet/PackedRecord.hs b/src/Data/FlagSet/PackedRecord.hs new file mode 100644 --- /dev/null +++ b/src/Data/FlagSet/PackedRecord.hs @@ -0,0 +1,64 @@ +module Data.FlagSet.PackedRecord ( + getIntByMask, putIntByMask, accessorIntByMask, + getIntByRange, putIntByRange, accessorIntByRange, + ) where + +import Data.FlagSet (T(Cons), Mask(Mask), ) + +import qualified Data.Bits as B +import Data.Bits (Bits, (.&.), (.|.), ) + +import qualified Data.Accessor.Basic as Acc + +import Data.EnumSet.Utility ((.-.), ) + + +leastSigBit :: Bits w => w -> w +leastSigBit m = (-m) .&. m + +getIntByMask :: + (Bits w, Integral w, Integral i) => + Mask w a b -> T w a -> i +getIntByMask (Mask m) (Cons fs) = + -- I hope that the division is converted to a shift + fromIntegral $ div (m .&. fs) (leastSigBit m) + +putIntByMask :: + (Bits w, Integral w, Integral i) => + Mask w a b -> i -> T w a -> T w a +putIntByMask (Mask m) i (Cons fs) = + Cons $ (fs .-. m) .|. (fromIntegral i * leastSigBit m) + +accessorIntByMask :: + (Bits w, Integral w, Integral i) => + Mask w a b -> Acc.T (T w a) i +accessorIntByMask m = + Acc.fromSetGet (putIntByMask m) (getIntByMask m) + + +maskFromNumber :: + (Bits w) => + Int -> w +maskFromNumber number = + B.shiftL 1 number - 1 + +getIntByRange :: + (Bits w, Integral w, Integral i) => + Int -> Int -> T w a -> i +getIntByRange number start (Cons fs) = + fromIntegral $ B.shiftR fs start .&. maskFromNumber number + +putIntByRange :: + (Bits w, Integral w, Integral i) => + Int -> Int -> i -> T w a -> T w a +putIntByRange number start i (Cons fs) = + Cons $ + (fs .-. B.shiftL (maskFromNumber number) start) + .|. + B.shiftL (fromIntegral i) start + +accessorIntByRange :: + (Bits w, Integral w, Integral i) => + Int -> Int -> Acc.T (T w a) i +accessorIntByRange number start = + Acc.fromSetGet (putIntByRange number start) (getIntByRange number start)