Commits

Bryan O'Sullivan committed 041f6eb

Further progress

  • Participants
  • Parent commits 1419581

Comments (0)

Files changed (3)

     (
       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
                           " " ++ 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
 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
+    where jm = j .&. notMask
 
-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)
+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

Data/Vectro/Vect.hs

     (
       Vect(..)
     , empty
+    , length
     , fromList
     , toList
     , fromVector
 
 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)
 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) ()
 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
   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

tests/Properties.hs

-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 "v_isSane" v_isSane,
+   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_isSane" v_isSane,
-   testProperty "v_snoc_sane" v_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
  ]