module Data.RandomAccessList
(
RandomAccessList
, (.!.), (.:.), (.+.)
, empty, singleton, replicate
, null, isEmpty, size, member, index
, head, tail, extractHead, cons, append, zip, zipWith
, lookup, update, adjust, adjustLookup
, fromList, toList, toIndexedList
, toMap, toIntMap
, fromArray, toArray
) where
import Data.Array.IArray (IArray, Ix, array, elems)
import Data.Foldable (Foldable(foldr), 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 (head, lookup, null, replicate, tail, 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 size1 list1) == (RandomAccessList size2 list2)
= size1 == size2
&& (map snd list1) == (map snd list2)
instance (Ord a) => Ord (RandomAccessList a) where
compare list1 list2
| isEmpty list1 = if isEmpty list2 then EQ else LT
| isEmpty list2 = GT
| otherwise = let
(h1, t1) = extractHead list1
(h2, t2) = extractHead list2
in
case compare h1 h2 of
EQ -> compare t1 t2
x -> x
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 (toList list)
data CBTree a
= Leaf a
| Node a !(CBTree a) !(CBTree a)
deriving (Eq)
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)
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) ++ "]")
(.!.) :: RandomAccessList a -> Int -> a
(.!.) = flip lookup
infixr 9 .!.
(.:.) :: a -> RandomAccessList a -> RandomAccessList a
(.:.) = cons
infixr 5 .:.
(.+.) :: RandomAccessList a -> RandomAccessList a -> RandomAccessList a
(.+.) = append
infixr 5 .+.
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
size :: RandomAccessList a -> Int
size (RandomAccessList s _) = s
member :: (Eq a) => a -> RandomAccessList a -> Bool
member x = isJust . (index x)
index :: (Eq a, Monad m) => a -> RandomAccessList a -> m Int
index x (RandomAccessList _ list) = index' 0 list
where
index' _ [] = fail "RandomAccessList: element not found"
index' accum ((weight, tree):trees) = maybe
(index' (accum + weight) trees)
(return . (+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 . extractHead
tail :: RandomAccessList a -> RandomAccessList a
tail = snd . extractHead
extractHead :: RandomAccessList a -> (a, RandomAccessList a)
extractHead (RandomAccessList s list) = case list of
[] -> error "RandomAccessList: empty list"
((_, Leaf x) : trees') -> (x, RandomAccessList (s 1) trees')
((weight, Node x left right) : trees') -> let
halfWeight = weight `div` 2
trees'' = (halfWeight, left) : (halfWeight, right) : trees'
in
(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))
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 $ zip' as bs
else fromList (Prelude.zipWith f (toList l1) (toList l2))
where
zip' [] [] = []
zip' ((weightA, treeA) : treesA) ((weightB, treeB) : treesB) = if weightA == weightB
then (weightA, zipWithTree f treeA treeB) : zip' treesA treesB
else error skewError
zip' _ _ = error skewError
skewError = "RandomAccessList: invalid skew binary number representation"
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"
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
fromList :: [a] -> RandomAccessList a
fromList = foldr' cons empty
toList :: RandomAccessList a -> [a]
toList list
| isEmpty list = []
| otherwise = let (x, xs) = extractHead list in x : toList xs
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, size list 1) (toIndexedList list)