Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Further progress

  • Loading branch information...
commit fc30cf38ceb6a771e3e20efec9f03d8fdaf8f245 1 parent e7f04a7
@bos authored
Showing with 97 additions and 31 deletions.
  1. +33 −12 Data/Vectro.hs
  2. +15 −11 Data/Vectro/Vect.hs
  3. +49 −8 tests/Properties.hs
View
45 Data/Vectro.hs
@@ -4,16 +4,18 @@ module Data.Vectro
(
Vect
, fromList
+ , toList
, fromVector
+ , toVector
, index
, isSane
, snoc
, update
, Vector
- , toVector
, showStructure
) where
+import Debug.Trace
import Control.DeepSeq
import Data.Bits hiding (shift)
import qualified Data.Vector as V
@@ -33,9 +35,12 @@ showStructure (Z t k c) = "Z (" ++ T.showStructure t ++ ") " ++ show k ++
" " ++ show (V.toList c)
toZ :: Int -> Vect a -> Vector a
-toZ k t = go t
- where go (Leaf v) = Z t (k .&. complement T.mask) v
+toZ k t
+ | k == l && l .&. T.mask == 0 = Z t k V.empty
+ | otherwise = go t
+ where go (Leaf v) = Z t (k .&. notMask) v
go (Node s v) = go (v V.! ((k `shiftR` s) .&. T.mask))
+ l = T.length t
fromList :: [a] -> Vector a
fromList = toZ 0 . T.fromList
@@ -50,26 +55,42 @@ toVector :: Vector a -> V.Vector a
toVector = T.toVector . fromZ
isSane :: Vector a -> Bool
-isSane (Z t _ c) = T.isSane t && V.length c <= T.factor
+isSane (Z t k c) = T.isSane t && k <= T.length t && V.length c <= T.factor
fromZ :: Vector a -> Vect a
-fromZ (Z t k c) = go t
+fromZ (Z t k c)
+ | k < (l .&. notMask) - 1 = go t
+ | l > 0 && l .&. T.mask == 0 = T.snocChunk t c
+ | otherwise = fixLast t c
where go (Leaf _) = Leaf c
go (Node s v) = Node s (v V.// [(j, go (v V.! j))])
where j = (k `shiftR` s) .&. T.mask
+ l = T.length t
-update :: Show a => Vector a -> Int -> a -> Vector a
+update :: Vector a -> Int -> a -> Vector a
update z@(Z t k c) j n
| jm == k = Z t k (c V.// [(j-jm,n)])
| otherwise = toZ j (T.update (fromZ z) j n)
- where jm = j .&. complement T.mask
+ where jm = j .&. notMask
index :: Vector a -> Int -> a
index (Z t k c) j
| jm == k = c V.! (j-jm)
| otherwise = T.index t j
- where jm = j .&. complement T.mask
-
-snoc :: Vector a -> a -> Vector a
-snoc (Z t k c) n | V.length c < T.factor = Z t k (V.snoc c n)
- | otherwise = Z (T.snocChunk t c) k (V.singleton n)
+ where jm = j .&. notMask
+
+snoc :: Show a => Vector a -> a -> Vector a
+snoc z@(Z t k c) n
+ | k < (l.&.notMask) - 1 = snoc (toZ (T.length t') t') n
+ | V.length c < T.factor = Z t k (V.snoc c n)
+ | l > 0 && l.&.T.mask == 0 = Z (T.snocChunk t c) (k+T.factor) (V.singleton n)
+ | otherwise = Z (fixLast t c) (k+T.factor) (V.singleton n)
+ where t' = fromZ z
+ l = T.length t
+
+fixLast t c = go t
+ where go (Leaf _) = Leaf c
+ go (Node s v) = Node s (V.init v `V.snoc` go (V.last v))
+
+notMask :: Int
+notMask = complement T.mask
View
26 Data/Vectro/Vect.hs
@@ -5,6 +5,7 @@ module Data.Vectro.Vect
(
Vect(..)
, empty
+ , length
, fromList
, toList
, fromVector
@@ -21,8 +22,9 @@ module Data.Vectro.Vect
import Control.DeepSeq (NFData(rnf))
import Data.Bits hiding (shift)
-import Data.List (intersperse)
+import qualified Data.List as L
import qualified Data.Vector as V
+import Prelude hiding (length)
data Vect a = Node !Int !(V.Vector (Vect a))
| Leaf !(V.Vector a)
@@ -31,7 +33,7 @@ data Vect a = Node !Int !(V.Vector (Vect a))
showStructure :: Show a => Vect a -> String
showStructure (Leaf l) = show $ V.toList l
showStructure (Node s v) = "Node " ++ show s ++ " (" ++ tidy ++ ")"
- where tidy = concat . intersperse "," . map showStructure . V.toList $ v
+ where tidy = concat . L.intersperse "," . map showStructure . V.toList $ v
instance NFData a => NFData (V.Vector a) where
rnf = V.foldl' (\_ v -> rnf v) ()
@@ -71,7 +73,7 @@ fromList :: [a] -> Vect a
fromList xs = case map (Leaf . V.fromList) . chunksOf factor $ xs of
[] -> Leaf V.empty
[l] -> l
- ls -> toTree shift (length ls) ls
+ ls -> toTree shift (L.length ls) ls
toTree :: Int -> Int -> [Vect a] -> Vect a
toTree !h len ns
@@ -153,16 +155,18 @@ snocChunk t c = case go t of
where
go (Leaf _) = Right l
go (Node s v)
- | s == shift = if V.length v < factor
- then Left $! Node s (v `V.snoc` l)
- else Right $! Node (shift+s) (V.singleton l)
- | otherwise = case go (V.last v) of
- Left n' -> Left $! Node s (V.init v `V.snoc` n')
- Right n'
- | V.length v < factor -> Left $! Node s (v `V.snoc` n')
- | otherwise -> Right $! Node s (V.singleton n')
+ = case go (V.last v) of
+ Left n' -> Left $! Node s (V.init v `V.snoc` n')
+ Right n'
+ | V.length v < factor -> Left $! Node s (v `V.snoc` n')
+ | otherwise -> Right $! Node s (V.singleton n')
l = Leaf c
+length :: Vect a -> Int
+length (Leaf l) = V.length l
+length (Node _ v) = V.foldl' add 0 v
+ where add n c = n + length c
+
mapVect :: (a -> b) -> Vect a -> Vect b
mapVect f = go
where
View
57 tests/Properties.hs
@@ -1,32 +1,73 @@
-import Data.Vectro.Vect as T
-import Data.Vectro as V
+{-# LANGUAGE ScopedTypeVariables #-}
+
+import qualified Data.Vectro.Vect as T
+import qualified Data.Vectro as V
+import qualified Data.Vector as Vector
+import Data.List (foldl')
import Test.Framework (defaultMain, testGroup)
import Test.QuickCheck
import Test.Framework.Providers.QuickCheck2 (testProperty)
-vints :: Vector Int -> Vector Int
+type L = [Int]
+type VV = Vector.Vector Int
+type T = T.Vect Int
+type V = V.Vector Int
+
+vints :: V.Vector Int -> V.Vector Int
vints a = a
-tints :: Vect Int -> Vect Int
+tints :: T.Vect Int -> T.Vect Int
tints a = a
-instance Arbitrary a => Arbitrary (Vect a) where
+instance Arbitrary a => Arbitrary (T.Vect a) where
arbitrary = T.fromList `fmap` arbitrary
-instance Arbitrary a => Arbitrary (Vector a) where
+instance Arbitrary a => Arbitrary (V.Vector a) where
arbitrary = V.fromList `fmap` arbitrary
+instance Arbitrary a => Arbitrary (Vector.Vector a) where
+ arbitrary = Vector.fromList `fmap` arbitrary
+
t_isSane = T.isSane . tints
v_isSane = V.isSane . vints
+t_list_id l = (T.toList . T.fromList $ l) == (l::L)
+v_list_id l = (V.toList . V.fromList $ l) == (l::L)
+t_vector_id v = (T.toVector . T.fromVector $ v) == (v::VV)
+v_vector_id v = (V.toVector . V.fromVector $ v) == (v::VV)
+
+snoc :: [a] -> a -> [a]
+snoc xs x = xs ++ [x]
+
+t_snoc (l::L) x = T.toList (T.snoc (T.fromList l) x) == snoc l x
+v_snoc (l::L) x = V.toList (V.snoc (V.fromList l) x) == snoc l x
+
t_snoc_sane a = T.isSane . (`T.snoc` a) . tints
v_snoc_sane a = V.isSane . (`V.snoc` a) . vints
+t_snocs (l::L) xs = T.toList (foldl' T.snoc (T.fromList l) xs) ==
+ foldl' snoc l xs
+v_snocs (l::L) xs = V.toList (foldl' V.snoc (V.fromList l) xs) ==
+ foldl' snoc l xs
+
+t_snocs_sane (t::T) = T.isSane . foldl' T.snoc t
+v_snocs_sane (v::V) = V.isSane . foldl' V.snoc v
+
main = defaultMain tests
tests = [
testProperty "t_isSane" t_isSane,
- testProperty "t_snoc_sane" t_snoc_sane,
testProperty "v_isSane" v_isSane,
- testProperty "v_snoc_sane" v_snoc_sane
+ testProperty "t_list_id" t_list_id,
+ testProperty "v_list_id" v_list_id,
+ testProperty "t_vector_id" t_vector_id,
+ testProperty "v_vector_id" v_vector_id,
+ testProperty "t_snoc" t_snoc,
+ testProperty "v_snoc" v_snoc,
+ testProperty "t_snoc_sane" t_snoc_sane,
+ testProperty "v_snoc_sane" v_snoc_sane,
+ testProperty "t_snocs" t_snocs,
+ testProperty "v_snocs" v_snocs,
+ testProperty "t_snocs_sane" t_snocs_sane,
+ testProperty "v_snocs_sane" v_snocs_sane
]
Please sign in to comment.
Something went wrong with that request. Please try again.