# Commits

committed 041f6eb

Further progress

# Data/Vectro.hs

(
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))
+

# 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
]