module Data.RandomAccessList
(
RandomAccessList, View(..)
, empty, singleton, replicate
, null, isEmpty, length, size, member, index
, head, tail, uncons, view, cons, append
, lookup, update, adjust, adjustLookup
, filter, partition, zip, zipWith, unzip
, fromList, toList, toIndexedList
, toMap, toIntMap
, fromArray, toArray
) where
import Data.Array.IArray (IArray, Ix, array, elems)
import Data.Foldable (Foldable(..), foldr')
import Data.IntMap as IMap (IntMap, fromDistinctAscList)
import Data.Map as Map (Map, fromDistinctAscList)
import Data.Maybe
import Data.Monoid
import qualified Prelude (replicate, zip, zipWith)
import Prelude hiding
( filter, foldl, foldl1, foldr, foldr1
, head, length, lookup, null
, replicate, tail, unzip, zip, zipWith
)
import Text.Read
data RandomAccessList a
= RandomAccessList !Int [(Int, CBTree a)]
instance (Show a) => Show (RandomAccessList a) where
show list = "fromList " ++ show (toList list)
instance (Read a) => Read (RandomAccessList a) where
#ifdef __GLASGOW_HASKELL__
readPrec = parens $ prec 10 $ do
Ident "fromList" <- lexP
xs <- readPrec
return (fromList xs)
readListPrec = readListPrecDefault
#else
readsPrec p = readParen (p > 10) $ \r -> do
("fromList", s) <- lex r
(xs, t) <- reads s
return (fromList xs, t)
#endif
instance (Eq a) => Eq (RandomAccessList a) where
(RandomAccessList s1 l1) == (RandomAccessList s2 l2)
= s1 == s2 && (map snd l1) == (map snd l2)
instance (Ord a) => Ord (RandomAccessList a) where
compare xs ys = fold (Prelude.zipWith compare (toList xs) (toList ys))
instance Monoid (RandomAccessList a) where
mempty = empty
mappend = append
instance Functor RandomAccessList where
fmap f (RandomAccessList s list) = RandomAccessList s
(fmap (\(weight, tree) -> (weight, fmap f tree)) list)
instance Foldable RandomAccessList where
foldr f zero list = foldr f zero (view list)
foldl f zero list = foldl f zero (view list)
foldr1 f list = foldr1 f $ toList list
foldl1 f list = foldl1 f (view list)
data CBTree a
= Leaf a
| Node a !(CBTree a) !(CBTree a)
#ifndef __HADDOCK
deriving (Eq)
#else
instance (Eq a) => Eq (CBTree a)
#endif
instance Functor CBTree where
fmap f (Leaf x) = Leaf (f x)
fmap f (Node x left right) = Node (f x) (fmap f left) (fmap f right)
data View a
= Empty
| Cons a (RandomAccessList a)
#ifndef __HADDOCK__
deriving (Show, Read, Eq, Ord)
#else
instance (Show a) => Show (View a)
instance (Read a) => Read (View a)
instance (Eq a) => Eq (View a)
instance (Ord a) => Ord (View a)
#endif
instance Functor View where
fmap _ Empty = Empty
fmap f (Cons x xs) = Cons (f x) (fmap f xs)
instance Foldable View where
foldr _ zero Empty = zero
foldr f zero (Cons x xs) = f x (foldr f zero xs)
foldl _ zero Empty = zero
foldl f zero (Cons x xs) = foldl f (f zero x) xs
foldr1 _ Empty = error "foldr1: empty View"
foldr1 f (Cons x xs) = f x (foldr1 f xs)
foldl1 _ Empty = error "foldl1: empty View"
foldl1 f (Cons x xs) = foldl f x xs
indexErrorMessage :: Maybe (Int, Int)
-> String
indexErrorMessage = maybe
"RandomAccessList: index out of range"
(\(i, s) -> "RandomAccessList: index " ++ show i
++ " out of range [0.." ++ show (s 1) ++ "]")
empty :: RandomAccessList a
empty = RandomAccessList 0 []
singleton :: a -> RandomAccessList a
singleton x = RandomAccessList 1 [(1, Leaf x)]
replicate :: Int -> a -> RandomAccessList a
replicate n = fromList . (Prelude.replicate n)
null :: RandomAccessList a -> Bool
null = isEmpty
isEmpty :: RandomAccessList a -> Bool
isEmpty (RandomAccessList 0 _) = True
isEmpty _ = False
length :: RandomAccessList a -> Int
length = size
size :: RandomAccessList a -> Int
size (RandomAccessList s _) = s
member :: (Eq a) => a -> RandomAccessList a -> Bool
member x = isJust . (index x)
index :: (Eq a) => a -> RandomAccessList a -> Maybe Int
index x (RandomAccessList _ list) = index' 0 list
where
index' _ [] = Nothing
index' accum ((weight, tree):trees) = maybe
(index' (accum + weight) trees)
(Just . (+accum))
(indexTree weight x tree)
indexTree :: (Eq a) => Int -> a -> CBTree a -> Maybe Int
indexTree _ x (Leaf e) = if x == e then Just 0 else Nothing
indexTree weight x (Node e left right) = if x == e
then Just 0
else case indexTree halfWeight x left of
Just i -> Just (i + 1)
Nothing -> case indexTree halfWeight x right of
Just index' -> Just (index' + 1 + halfWeight)
Nothing -> Nothing
where
halfWeight = weight `div` 2
head :: RandomAccessList a -> a
head = fst . uncons
tail :: RandomAccessList a -> RandomAccessList a
tail = snd . uncons
uncons :: RandomAccessList a -> (a, RandomAccessList a)
uncons list = case view list of
Empty -> error "RandomAccessList: empty list"
Cons x xs -> (x, xs)
view :: RandomAccessList a -> View a
view (RandomAccessList s list) = case list of
[] -> Empty
((_, Leaf x) : trees') -> Cons x (RandomAccessList (s 1) trees')
((weight, Node x left right) : trees') -> let
halfWeight = weight `div` 2
trees'' = (halfWeight, left) : (halfWeight, right) : trees'
in
Cons x (RandomAccessList (s 1) trees'')
cons :: a -> RandomAccessList a -> RandomAccessList a
cons x (RandomAccessList s list) = RandomAccessList (s + 1) (case list of
xss@((size1, tree1) : (size2, tree2) : xs) -> if size1 == size2
then (1 + 2 * size1, Node x tree1 tree2) : xs
else (1, Leaf x) : xss
xs -> (1, Leaf x) : xs)
append :: RandomAccessList a -> RandomAccessList a -> RandomAccessList a
append = (flip (foldr cons))
lookup :: Int -> RandomAccessList a -> a
lookup i = fst . (adjustLookup undefined i)
update :: Int -> a -> RandomAccessList a -> RandomAccessList a
update i x = snd . (adjustLookup (const x) i)
adjust :: (a -> a) -> Int -> RandomAccessList a -> RandomAccessList a
adjust f i = snd . (adjustLookup f i)
adjustLookup :: (a -> a)
-> Int
-> RandomAccessList a
-> (a, RandomAccessList a)
adjustLookup f i (RandomAccessList s list) = let
(x, list') = updateLookup' i list
in
(x, RandomAccessList s list')
where
updateLookup' _ [] =
error $ indexErrorMessage (Just (i, s))
updateLookup' i' ((weight, tree) : xs) = if i' < weight
then let
(x, tree') = adjustLookupTree f weight i' tree
in
(x, (weight, tree') : xs)
else let (x, trees) = updateLookup' (i' weight) xs
in
(x, (weight, tree) : trees)
adjustLookupTree :: (a -> a)
-> Int
-> Int
-> CBTree a
-> (a, CBTree a)
adjustLookupTree f 1 0 (Leaf x) = (x, Leaf (f x))
adjustLookupTree _ _ _ (Leaf _) = error (indexErrorMessage Nothing)
adjustLookupTree f weight i (Node x left right)
| i == 0 = (x, Node (f x) left right)
| i <= halfWeight = let
(x', left') = adjustLookupTree f halfWeight (i 1) left
in
(x', Node x left' right)
| otherwise = let
(x', right') = adjustLookupTree f halfWeight (i 1 halfWeight) right
in
(x', Node x left right')
where
halfWeight = weight `div` 2
filter :: (a -> Bool) -> RandomAccessList a -> RandomAccessList a
filter p = fst . (partition p)
partition :: (a -> Bool) -> RandomAccessList a -> (RandomAccessList a, RandomAccessList a)
partition p list = case view list of
Empty -> (empty, empty)
Cons x xs -> let (yes, no) = partition p xs in if p x
then (x `cons` yes, no)
else ( yes, x `cons` no)
zip :: RandomAccessList a -> RandomAccessList b -> RandomAccessList (a, b)
zip = zipWith (,)
zipWith :: (a -> b -> c) -> RandomAccessList a -> RandomAccessList b -> RandomAccessList c
zipWith f l1@(RandomAccessList size1 as) l2@(RandomAccessList size2 bs) = if size1 == size2
then RandomAccessList size1 $ Prelude.zipWith
(\(w, xs) (_, ys) -> (w, zipWithTree f xs ys)) as bs
else case (view l1, view l2) of
(Cons x xs, Cons y ys) -> f x y `cons` zipWith f xs ys
_ -> empty
zipWithTree :: (a -> b -> c) -> CBTree a -> CBTree b -> CBTree c
zipWithTree f (Leaf x1) (Leaf x2) = Leaf (f x1 x2)
zipWithTree f (Node x1 left1 right1) (Node x2 left2 right2) = Node
(f x1 x2)
(zipWithTree f left1 left2)
(zipWithTree f right1 right2)
zipWithTree _ _ _ = error
"RandomAccessList: invalid skew binary number representation"
unzip :: RandomAccessList (a, b) -> (RandomAccessList a, RandomAccessList b)
unzip (RandomAccessList s xs) = let (as, bs) = unzip' xs
in
(RandomAccessList s as, RandomAccessList s bs)
where
unzip' [] = ([], [])
unzip' ((weight, tree) : trees) = let
(treeA, treeB) = unzipTree tree
(treesA, treesB) = unzip' trees
in
((weight, treeA) : treesA, (weight, treeB) : treesB)
unzipTree :: CBTree (a, b) -> (CBTree a, CBTree b)
unzipTree (Leaf (x, y)) = (Leaf x, Leaf y)
unzipTree (Node (x, y) left right) = (Node x xLeft xRight, Node y yLeft yRight)
where
(xLeft, yLeft) = unzipTree left
(xRight, yRight) = unzipTree right
fromList :: [a] -> RandomAccessList a
fromList = foldr' cons empty
toList :: RandomAccessList a -> [a]
toList = foldr (:) []
toIndexedList :: RandomAccessList a -> [(Int, a)]
toIndexedList list = Prelude.zip [0..] (toList list)
toMap :: RandomAccessList a -> Map Int a
toMap = Map.fromDistinctAscList . toIndexedList
toIntMap :: RandomAccessList a -> IntMap a
toIntMap = IMap.fromDistinctAscList . toIndexedList
fromArray :: (IArray a e, Ix i) => a i e -> RandomAccessList e
fromArray = fromList . elems
toArray :: (IArray a e) => RandomAccessList e -> a Int e
toArray list = array (0, length list 1) (toIndexedList list)