Commits

committed 041f6eb

Further progress

• Participants
• Parent commits 1419581

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))`
`+`
`+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`
`  ]`