[Haskell-cafe] Finger Tree without using Monoid

[Xinyu LIU]

Hi,

I was trying to implement MTF (move-to-front) algorithm, However, neither
Array nor List satisfied all aspects.
  Array: Although the random access is O(1), However, move an element to
front takes O(N) in average;
  List: Although move to front is O(1), However, random access takes O(N) in
average;

I dig out the paper [1] and find the Finger Tree solution. There is already
good Finger Tree implementation in Haskell as Data.Sequence [2] based on
[3].

I wrote a simple version based on the original paper, but avoid using Monoid
when augment (or cache) the size of the tree. The idea is to wrap every
element as a leaf of node.
This idea is similar to the Chris Okasaki's binary random access list [4].

As one test case, I tested move to front with Finger Tree.

Here is the code (sorry for a bit long):

>>>
module FingerTree where

import Test.QuickCheck

data Node a = Br Int [a] deriving (Show) -- size, branches

data Tree a = Empty
            | Lf a
            | Tr Int [a] (Tree (Node a)) [a] -- size, front, middle, rear
              deriving (Show)

type FList a = Tree (Node a)

-- Auxiliary functions for calculate size of node and tree

size :: Node a -> Int
size (Br s _) = s

sizeL :: [Node a] -> Int
sizeL = sum .(map size)

sizeT :: FList a -> Int
sizeT Empty = 0
sizeT (Lf a) = size a
sizeT (Tr s _ _ _) = s

-- Auxiliary functions for building and unboxing node(s)

wrap :: a -> Node a
wrap x = Br 1 [x]

unwrap :: Node a -> a
unwrap (Br 1 [x]) = x

wraps :: [Node a] -> Node (Node a)
wraps xs = Br (sizeL xs) xs

unwraps :: Node a -> [a]
unwraps (Br _ xs) = xs

-- Helper function for building tree

tree :: [Node a] -> FList (Node a) -> [Node a] -> FList a
tree f Empty [] = foldr cons' Empty f
tree [] Empty r = foldr cons' Empty r
tree [] m r = let (f, m') = uncons' m in tree (unwraps f) m' r
tree f m [] = let (m', r) = unsnoc' m in tree f m' (unwraps r)
tree f m r = Tr (sizeL f + sizeT m + sizeL r) f m r

-- Operations at the front of the sequence

cons :: a -> FList a -> FList a
cons a t = cons' (wrap a) t

cons' :: (Node a) -> FList a -> FList a
cons' a Empty = Lf a
cons' a (Lf b) = tree [a] Empty [b]
cons' a (Tr _ [b, c, d, e] m r) = tree [a, b] (cons' (wraps [c, d, e]) m) r
cons' a (Tr _ f m r) = tree (a:f) m r

uncons :: FList a -> (a, FList a)
uncons ts = let (t, ts') = uncons' ts in (unwrap t, ts')

uncons' :: FList a -> ((Node a), FList a)
uncons' (Lf a) = (a, Empty)
uncons' (Tr _ [a] Empty [b]) = (a, Lf b)
uncons' (Tr _ [a] Empty (r:rs)) = (a, tree [r] Empty rs)
uncons' (Tr _ [a] m r) = (a, tree (unwraps f) m' r) where (f, m') = uncons'
m
uncons' (Tr _ (a:f) m r) = (a, tree f m r)

head' :: FList a -> a
head' = fst . uncons

tail' :: FList a -> FList a
tail' = snd . uncons

-- Operations at the rear of the sequence

snoc :: FList a -> a -> FList a
snoc t a = snoc' t (wrap a)

snoc' :: FList a -> Node a -> FList a
snoc' Empty a = Lf a
snoc' (Lf a) b = tree [a] Empty [b]
snoc' (Tr _ f m [a, b, c, d]) e = tree f (snoc' m (wraps [a, b, c])) [d, e]
snoc' (Tr _ f m r) a = tree f m (r++[a])

unsnoc :: FList a -> (FList a, a)
unsnoc ts = let (ts', t) = unsnoc' ts in (ts', unwrap t)

unsnoc' :: FList a -> (FList a, (Node a))
unsnoc' (Lf a) = (Empty, a)
unsnoc' (Tr _ [a] Empty [b]) = (Lf a, b)
unsnoc' (Tr _ f@(_:_) Empty [a]) = (tree (init f) Empty [last f], a)
unsnoc' (Tr _ f m [a]) = (tree f m' (unwraps r), a) where (m', r) = unsnoc'
m
unsnoc' (Tr _ f m r) = (tree f m (init r), (last r))

last' :: FList a -> a
last' = snd . unsnoc

init' :: FList a -> FList a
init' = fst . unsnoc

-- Concatenation

concat' :: FList a -> FList a -> FList a
concat' t1 t2 = merge t1 [] t2

merge :: FList a -> [Node a] -> FList a -> FList a
merge Empty ts t2 = foldr cons' t2 ts
merge t1 ts Empty = foldl snoc' t1 ts
merge (Lf a) ts t2 = merge Empty (a:ts) t2
merge t1 ts (Lf a) = merge t1 (ts++[a]) Empty
merge (Tr s1 f1 m1 r1) ts (Tr s2 f2 m2 r2) =
    Tr (s1 + s2 + (sizeL ts)) f1 (merge m1 (nodes (r1 ++ ts ++ f2)) m2) r2

nodes :: [Node a] -> [Node (Node a)]
nodes [a, b] = [wraps [a, b]]
nodes [a, b, c] = [wraps [a, b, c]]
nodes [a, b, c, d] = [wraps [a, b], wraps [c, d]]
nodes (a:b:c:xs) = (wraps [a, b, c]):nodes xs

-- Splitting

splitAt' :: Int -> FList a -> (FList a, Node a, FList a)
splitAt' _ (Lf x) = (Empty, x, Empty)
splitAt' i (Tr _ f m r)
    | i < szf = let (xs, y, ys) = splitNodesAt i f
                in ((foldr cons' Empty xs), y, tree ys m r)
    | i < szf + szm = let (m1, t, m2) = splitAt' (i-szf) m
                          (xs, y, ys) = splitNodesAt (i-szf - sizeT m1)
(unwraps t)
                      in (tree f m1 xs, y, tree ys m2 r)
    | otherwise = let (xs, y, ys) = splitNodesAt (i-szf -szm) r
                  in (tree f m xs, y, foldr cons' Empty ys)
    where
      szf = sizeL f
      szm = sizeT m

splitNodesAt :: Int -> [Node a] -> ([Node a], Node a, [Node a])
splitNodesAt 0 [x] = ([], x, [])
splitNodesAt i (x:xs) | i < size x = ([], x, xs)
                      | otherwise = let (xs', y, ys) = splitNodesAt (i-size
x) xs
                                    in (x:xs', y, ys)

-- Random access operations

getAt :: FList a -> Int -> a
getAt t i = unwrap x where (_, x, _) = splitAt' i t

extractAt :: FList a -> Int -> (a, FList a)
extractAt t i = let (l, x, r) = splitAt' i t in (unwrap x, concat' l r)

setAt :: FList a -> Int -> a -> FList a
setAt t i x = let (l, _, r) = splitAt' i t in concat' l (cons x r)

-- move the i-th element to front
moveToFront :: FList a -> Int -> FList a
moveToFront t i = let (a, t') = extractAt t i in cons a t'

-- auxiliary functions

fromList :: [a] -> FList a
fromList = foldr cons Empty

toList :: FList a -> [a]
toList Empty = []
toList t = (head' t):(toList $ tail' t)

-- testing

prop_cons :: [Int] -> Bool
prop_cons xs = xs == (toList $ fromList xs)

prop_snoc :: [Int] -> Bool
prop_snoc xs = xs == (toList' $ foldl snoc Empty xs) where
    toList' Empty = []
    toList' t = (toList' $ init' t)++[last' t]

prop_concat :: [Int]->[Int]->Bool
prop_concat xs ys = (xs ++ ys) == (toList $ concat' (fromList xs) (fromList
ys))

prop_lookup :: [Int] -> Int -> Property
prop_lookup xs i = (0 <=i && i < length xs) ==> (getAt (fromList xs) i) ==
(xs !! i)

prop_update :: [Int] -> Int -> Int -> Property
prop_update xs i y = (0 <=i && i < length xs) ==> toList (setAt (fromList
xs) i y) == xs' where
    xs' = as ++ [y] ++ bs
    (as, (_:bs)) = splitAt i xs

prop_mtf :: [Int] -> Int -> Property
prop_mtf xs i = (0 <=i && i < length xs) ==> (toList $ moveToFront (fromList
xs) i) == mtf
    where
      mtf = b : as ++ bs
      (as, (b:bs)) = splitAt i xs

<<<

It can be found at:
https://github.com/liuxinyu95/AlgoXY/blob/algoxy/datastruct/elementary/array/src/FingerTree.hs

[Reference]
[1]. Jon Bentley, Daniel Sleator, Robert Tarjan, Victor Wei. "A locally
adaptive data compression scheme." Communication of the ACM.1986.
[2].
http://hackage.haskell.org/packages/archive/fingertree/0.0/doc/html/Data-FingerTree.html
[3]. Ralf Hinze and Ross Paterson, "Finger trees: a simple general-purpose
data structure", *Journal of Functional Programming* 16:2 (2006) pp 197-217.
http://www.soi.city.ac.uk/~ross/papers/FingerTree.html
[4]. Purely Functional Random-Access Lists by Chris Okasaki. Functional
Programming Languages and Computer Architecutre, June 1995, pages 86-95.

-- 
Larry, LIU Xinyu
https://sites.google.com/site/algoxy/
https://github.com/liuxinyu95/AlgoXY
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://www.haskell.org/pipermail/haskell-cafe/attachments/20110901/d8b19ca1/attachment-0001.htm>