[Haskell-cafe] Finger Tree without using Monoid
Xinyu LIU
liuxinyu95 at gmail.com
Thu Sep 1 11:49:04 CEST 2011
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>
More information about the Haskell-Cafe
mailing list