diff --git a/Data/SequentialIndex.hs b/Data/SequentialIndex.hs --- a/Data/SequentialIndex.hs +++ b/Data/SequentialIndex.hs @@ -5,8 +5,16 @@ , exponent , zero , one +, root , sequentialIndex +, unsafeSequentialIndex +, tryFromBools , between +, prefixBits +, build +, buildBits +, leftChild +, rightChild , toByteString , fromByteString ) @@ -28,11 +36,14 @@ exponent (SI _ e) = e zero :: SequentialIndex -zero = SI 0 0 +zero = SI 0 1 one :: SequentialIndex -one = SI 1 0 +one = SI 1 1 +root :: SequentialIndex +root = between zero one + commonBase :: SequentialIndex -> SequentialIndex -> (Integer, Integer, Int) commonBase (SI m1 e1) (SI m2 e2) = (m1', m2', e) where e = max e1 e2 @@ -42,14 +53,67 @@ sequentialIndex :: Integer -> Int -> SequentialIndex sequentialIndex 0 _ = zero sequentialIndex mx ex - = case () of - _ | v < zero -> error "Invalid SequentialIndex: below zero" + = case unsafeSequentialIndex mx ex of + v | v < zero -> error "Invalid SequentialIndex: below zero" | v > one -> error "Invalid SequentialIndex: beyond one" | otherwise -> v - where v = until (\(SI m _) -> m `testBit` 0) - (\(SI m e) -> SI (m `shiftR` 1) (e - 1)) - (SI mx ex) +trySequentialIndex :: Integer -> Int -> Maybe SequentialIndex +trySequentialIndex 0 _ = Just zero +trySequentialIndex mx ex + = case unsafeSequentialIndex mx ex of + v | v < zero -> Nothing + | v > one -> Nothing + | otherwise -> Just v + +unsafeSequentialIndex :: Integer -> Int -> SequentialIndex +unsafeSequentialIndex mx ex + = until (\(SI m _) -> m `testBit` 0) + (\(SI m e) -> SI (m `shiftR` 1) (e - 1)) + (SI mx ex) + +tryFromBools :: [Bool] -> Maybe SequentialIndex +tryFromBools = uncurry trySequentialIndex . foldr (\x (s, n) -> ((s `shiftL` 1) .|. (if x then 1 else 0), n + 1)) (0, 0) + +between :: SequentialIndex -> SequentialIndex -> SequentialIndex +between a b = sequentialIndex (m1 + m2) (e + 1) + where (m1, m2, e) = commonBase a b + +prefixBits :: Int -> Integer -> SequentialIndex -> SequentialIndex +prefixBits _ _ (SI 0 1) = error "No meaningful prefix for 'zero' possible" +prefixBits eb mb (SI m e) = sequentialIndex ((mb `shiftL` e) + m) (eb + e + 1) + +build :: Int -> [Integer] -> SequentialIndex +build nbits xs = foldr (prefixBits nbits) one xs + +buildBits :: (Bits a, Integral a) => [a] -> SequentialIndex +buildBits xs = build (bitSize $ head xs) (map toInteger xs) + +leftChild :: SequentialIndex -> SequentialIndex +leftChild (SI 0 1) = error "'zero' has no left child" +leftChild (SI m e) = SI ((m `shiftR` 1) `shiftL` 2 .|. 1) (e + 1) + +rightChild :: SequentialIndex -> SequentialIndex +rightChild (SI 0 1) = error "'zero' has no real right child" +rightChild (SI 1 1) = error "'one' has no right child" +rightChild (SI m e) = SI ((m `shiftR` 1) `shiftL` 2 .|. 3) (e + 1) + +toByteString :: SequentialIndex -> B.ByteString +toByteString (SI m e) = B.unfoldr step (m', e') + where e' = ((e + 7) `div` 8) * 8 + m' = m `shift` (e' - e) + + step (_, 0) = Nothing + step (v, ex) = let (q, r) = v `divMod` 256 + in Just (fromInteger r, (q, ex - 8)) + +fromByteString :: B.ByteString -> Maybe SequentialIndex +fromByteString bs | B.null bs = Just zero + | otherwise = trySequentialIndex m e + where (m, e) = B.foldr step (0, 0) bs + step w (mx, ex) = (mx `shiftL` 8 + toInteger w, ex + 8) + + instance Bounded SequentialIndex where minBound = zero maxBound = one @@ -63,25 +127,7 @@ [] -> "0.0" [d1] -> d1 : ".0" (d1:ds) -> d1 : '.' : ds - where bits = map (testBit m) [e, e - 1 .. 0] + where bits = map (testBit m) [e - 1, e - 2 .. 0] sbit False = '0' sbit True = '1' - -between :: SequentialIndex -> SequentialIndex -> SequentialIndex -between a b = sequentialIndex (m1 + m2) (e + 1) - where (m1, m2, e) = commonBase a b - -toByteString :: SequentialIndex -> B.ByteString -toByteString (SI m e) = B.unfoldr step m' - where e' = (e `div` 8) * 8 + 7 - m' = m `shift` (e' - e) - - step 0 = Nothing - step v = let (q, r) = v `divMod` 256 - in Just (fromInteger r, q) - -fromByteString :: B.ByteString -> SequentialIndex -fromByteString bs = sequentialIndex m (max 0 $ e - 1) - where (m, e) = B.foldr step (0, 0) bs - step w (mx, ex) = (mx `shiftL` 8 + toInteger w, ex + 8) diff --git a/Data/SequentialIndex/Open.hs b/Data/SequentialIndex/Open.hs new file mode 100644 --- /dev/null +++ b/Data/SequentialIndex/Open.hs @@ -0,0 +1,66 @@ +module Data.SequentialIndex.Open +( + SequentialIndex +, mantissa +, exponent +, sequentialIndex +, toClosed +, fromClosed +, root +, leftChild +, rightChild +, prefixBits +, toByteString +, fromByteString +) +where + +import Control.Monad +import Data.Bits +import Prelude hiding (exponent) +import qualified Data.ByteString as B +import qualified Data.SequentialIndex as Closed + +newtype SequentialIndex = OSI Closed.SequentialIndex + deriving (Eq, Ord) + +mantissa :: SequentialIndex -> Integer +mantissa = Closed.mantissa . toClosed + +exponent :: SequentialIndex -> Int +exponent = Closed.exponent . toClosed + +sequentialIndex :: Int -> Integer -> SequentialIndex +sequentialIndex eb me = OSI $ Closed.prefixBits eb me Closed.one + +toClosed :: SequentialIndex -> Closed.SequentialIndex +toClosed (OSI si) = si + +fromClosed :: Closed.SequentialIndex -> Maybe SequentialIndex +fromClosed si = case () of + _ | si == Closed.zero -> Nothing + | si == Closed.one -> Nothing + | otherwise -> Just $ OSI si + +root :: SequentialIndex +root = OSI Closed.root + +leftChild :: SequentialIndex -> SequentialIndex +leftChild = OSI . Closed.leftChild . toClosed + +rightChild :: SequentialIndex -> SequentialIndex +rightChild = OSI . Closed.rightChild . toClosed + +prefixBits :: Int -> Integer -> SequentialIndex -> SequentialIndex +prefixBits eb mb = OSI . Closed.prefixBits eb mb . toClosed + +toByteString :: SequentialIndex -> B.ByteString +toByteString = Closed.toByteString . toClosed + +fromByteString :: B.ByteString -> Maybe SequentialIndex +fromByteString = fromClosed <=< Closed.fromByteString + +instance Show SequentialIndex where + show si = '*' : map (\i -> if testBit m i then 'R' else 'L') [e - 2, e - 3 .. 1] + where m = mantissa si + e = exponent si diff --git a/README b/README --- a/README +++ b/README @@ -1,4 +1,18 @@ Sequential index numbers between 0.0 and 1.0 that allow arbitrarily inserting new numbers in between. They can possibly used for disk-based and other special containers, where adding a new element without changing the indexes of the other elements is important. -Conceptually, SequentialIndex denotes a path to an element in an imaginary binary tree. +Conceptually, SequentialIndex denotes a path to an element in an imaginary binary tree, with a '1' at the end. Except for 0.0 and 1.0, which are logically on the left or on the right of the entire tree. +So logically, the tree looks roughly like this: + +0.0 1.0 + / + /----------/ + 0.1 + / \ + /--/ \--\ + / \ + 0.01 0.11 + / \ / \ + 0.001 0.011 ... + +Note that 0.0 is not connected to any other node, but it is still logically smaller than all nodes. diff --git a/Test/SequentialIndex.hs b/Test/SequentialIndex.hs new file mode 100644 --- /dev/null +++ b/Test/SequentialIndex.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Test.SequentialIndex +where + +import Data.Maybe +import Data.SequentialIndex +import Test.QuickCheck +import Test.QuickCheck.All + +instance Arbitrary SequentialIndex where + arbitrary = fmap fromJust (fmap tryFromBools arbitrary `suchThat` isJust) + +prop_sequentialIndexFromToByteString si = Just si == fromByteString (toByteString si) + +main = $(quickCheckAll) + +testWith = $(forAllProperties) diff --git a/sequential-index.cabal b/sequential-index.cabal --- a/sequential-index.cabal +++ b/sequential-index.cabal @@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented. -Version: 0.0 +Version: 0.1 -- A short (one-line) description of the package. Synopsis: Sequential index numbers between 0.0 and 1.0 that allow arbitrarily inserting new numbers in between (for special containers). @@ -15,7 +15,7 @@ -- A longer description of the package. Description: Sequential index numbers between 0.0 and 1.0 that allow arbitrarily inserting new numbers in between. They can possibly used for disk-based and other special containers, where adding a new element without changing the indexes of the other elements is important. - Conceptually, SequentialIndex denotes a path to an element in an imaginary binary tree. + Conceptually, SequentialIndex denotes a path to an element in an imaginary binary tree. However, leafs can only be on the right side of their parent. I.e. the path must end with a '1' (or be the path to the root node, 0.0). 1.0 denotes the invalid node. -- The license under which the package is released. License: BSD3 @@ -41,7 +41,8 @@ -- Extra files to be distributed with the package, such as examples or -- a README. -Extra-source-files: README +Extra-source-files: README, + Test/SequentialIndex.hs -- Constraint on the version of Cabal needed to build this package. Cabal-version: >=1.2 @@ -49,7 +50,8 @@ Library -- Modules exported by the library. - Exposed-modules: Data.SequentialIndex + Exposed-modules: Data.SequentialIndex, + Data.SequentialIndex.Open -- GHC Options. GHC-Options: -Wall