-- "src/Dao/Tree.hs" provides a fundamental data type used in the Dao
-- System, the "Tree", which is similar to the "Data.Map" data type.
--
-- Copyright (C) 2008-2014 Ramin Honary.
-- This file is part of the Dao System.
--
-- The Dao System is free software: you can redistribute it and/or
-- modify it under the terms of the GNU General Public License as
-- published by the Free Software Foundation, either version 3 of the
-- License, or (at your option) any later version.
--
-- The Dao System is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program (see the file called "LICENSE"). If not, see
-- .
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Dao.Tree where
import Dao.String (HasNullValue, nullValue, testNull) -- TODO: move the HasNullValue class to it's own module.
import Control.Applicative
import Control.DeepSeq
import Control.Monad
import Control.Monad.Identity
import Control.Monad.Trans
import Control.Monad.State
import Data.Typeable
import Data.Monoid
import Data.List (intercalate)
-- import Data.Binary
import qualified Data.Map as M
import Data.Word
----------------------------------------------------------------------------------------------------
data Tree p n
= Void
| Leaf { branchData :: n }
| Branch { branchMap :: M.Map p (Tree p n) }
| LeafBranch
{ branchData :: n
, branchMap :: M.Map p (Tree p n)
}
deriving Typeable
instance (Show p, Show n) => Show (Tree p n) where
show o = case o of
Void -> "voidTree"
Leaf o -> "(leaf "++show o++")"
Branch t -> "(branch ["++branch t++"])"
LeafBranch o t -> "(leaf "++show o++" branch ["++branch t++"])"
where { branch t = intercalate ", " (M.assocs t >>= \ (nm, o) -> [show nm++"="++show o]) }
instance (Eq p, Eq n) => Eq (Tree p n) where
(==) a b = case (a, b) of
(Void , Void ) -> True
(Leaf a , Leaf b ) -> a == b
(Branch a , Branch b ) -> a == b
(LeafBranch a aa, LeafBranch b bb) -> a == b && aa == bb
_ -> False
instance (Ord p, Ord n) => Ord (Tree p n) where
compare a b = case (a, b) of
(Void , Void ) -> EQ
(Leaf a , Leaf b ) -> compare a b
(Branch aa, Branch bb) -> compare aa bb
(LeafBranch a aa, LeafBranch b bb) -> case compare a b of
EQ -> compare aa bb
e -> e
(Void , _ ) -> LT
(_ , Void ) -> GT
(Leaf _ , _ ) -> LT
(_ , Leaf _ ) -> GT
(Branch _ , _ ) -> LT
(_ , Branch _ ) -> GT
instance Ord p => Functor (Tree p) where
fmap f tree = case tree of
Void -> Void
Leaf a -> Leaf (f a)
Branch m -> Branch (fmap (fmap f) m)
LeafBranch a m -> LeafBranch (f a) (fmap (fmap f) m)
instance (Ord p, Monoid n) => Monoid (Tree p n) where
mempty = Void
mappend = unionWith mappend
instance (NFData a, NFData b) => NFData (Tree a b) where
rnf Void = ()
rnf (Leaf a ) = deepseq a ()
rnf (Branch b) = deepseq b ()
rnf (LeafBranch a b) = deepseq a $! deepseq b ()
instance HasNullValue (Tree a b) where { nullValue = Void; testNull = Dao.Tree.null; }
-- | A combinator to modify the data in the 'Leaf' and 'LeafBranch' nodes of a tree when passed to
-- one of the functions below.
type ModLeaf n = Maybe n -> Maybe n
-- | A combinator to modify the data in the 'Branch' and 'LeafBranch' nodes of a tree when passed to
-- one of the functions below.
type ModBranch p n = Maybe (M.Map p (Tree p n)) -> Maybe (M.Map p (Tree p n))
-- | If a 'Tree' is 'Void' or a contains a branch that is equivalent to 'Data.Map.empty',
-- 'Data.Maybe.Nothing' is returned.
notVoid :: Tree p n -> Maybe (Tree p n)
notVoid t = case t of
Void -> Nothing
Branch b | M.null b -> Nothing
LeafBranch a b | M.null b -> Just (Leaf a)
_ -> Just t
-- | If the given node is a 'Leaf' or 'LeafBranch', returns the Leaf portion of the node.
getLeaf :: Tree p n -> Maybe n
getLeaf t = case t of { Leaf n -> Just n; LeafBranch n _ -> Just n; _ -> Nothing }
-- | If the given node is a 'Branch' or 'LeafBranch', returns the branch portion of the node.
getBranch :: Tree p a -> Maybe (M.Map p (Tree p a))
getBranch t = case t of { Branch b -> Just b; LeafBranch _ b -> Just b; _ -> Nothing }
-- | Use a 'ModLeaf' function to insert, update, or remove 'Leaf' and 'LeafBranch' nodes.
alterLeaf :: ModLeaf n -> Tree p n -> Tree p n
alterLeaf alt t = maybe Void id $ case t of
Void -> alt Nothing >>= \o -> Just (Leaf o)
Leaf o -> alt (Just o) >>= \o -> Just (Leaf o)
Branch b -> mplus (alt Nothing >>= \o -> Just (LeafBranch o b)) (Just (Branch b))
LeafBranch o b -> mplus (alt (Just o) >>= \o -> Just (LeafBranch o b)) (Just (Branch b))
alterBranch :: (Eq p, Ord p) => ModBranch p n -> Tree p n -> Tree p n
alterBranch alt t = maybe Void id $ case t of
Void -> alt Nothing >>= \b -> Just (Branch b)
Leaf o -> mplus (alt Nothing >>= \b -> Just (LeafBranch o b)) (Just (Leaf o))
Branch b -> alt (Just b) >>= \b -> Just (Branch b)
LeafBranch o b -> mplus (alt (Just b) >>= \b -> Just (LeafBranch o b)) (Just (Leaf o))
----------------------------------------------------------------------------------------------------
data ZipTree p n = ZipTree{ focus :: Tree p n, history :: [(p, Tree p n)] }
newtype UpdateTreeT p n m a = UpdateTreeT{ getUpdateTreeStateT :: StateT (ZipTree p n) m a }
type UpdateTree p n a = UpdateTreeT p n Identity a
instance Monad m =>
Monad (UpdateTreeT p n m) where
return = UpdateTreeT . return
(UpdateTreeT a) >>= b = UpdateTreeT (a >>= getUpdateTreeStateT . b)
instance Functor m =>
Functor (UpdateTreeT p n m) where { fmap f (UpdateTreeT m) = UpdateTreeT (fmap f m); }
instance (Monad m, Functor m) =>
Applicative (UpdateTreeT p n m) where { pure = return; (<*>) = ap; }
instance Monad m =>
MonadState (ZipTree p n) (UpdateTreeT p n m) where { state = UpdateTreeT . state; }
instance MonadTrans (UpdateTreeT p n) where { lift m = UpdateTreeT (lift m); }
-- | Like 'Control.Monad.State.runState', evaluates an 'UpdateTree' monad transformer lifting the
-- 'Control.Monad.Identity.Identity' monad, removing the identity monad after evaluation to give you
-- a pure function.
runUpdateTree :: Ord p => UpdateTree p n a -> Tree p n -> (a, Tree p n)
runUpdateTree updfn = runIdentity . runUpdateTreeT updfn
-- | Like 'Control.Monad.State.execState', disgards the value returned to the 'UpdateTree' monad and
-- only returns the 'Tree'.
execUpdateTree :: Ord p => UpdateTree p n a -> Tree p n -> Tree p n
execUpdateTree updfn = snd . runUpdateTree updfn
-- | Update a 'Tree' using an 'UpdateTreeT' monad, much like how 'Control.Monad.State.runStateT'
-- works. Evaluates to a monadic computation of the lifted type @m@ that 'Control.Monad.return's a
-- pair containing the value last 'Control.Monad.return'ed to the lifted monad and the updated
-- 'Tree'.
runUpdateTreeT :: (Ord p, Functor m, Monad m) => UpdateTreeT p n m a -> Tree p n -> m (a, Tree p n)
runUpdateTreeT updfn tree = fmap (fmap focus) $
runStateT (getUpdateTreeStateT (updfn >>= \a -> home >> return a)) (ZipTree{focus=tree, history=[]})
-- | Go to the node with the given path. If the path does not exist, it is created.
goto :: (Ord p, Monad m) => [p] -> UpdateTreeT p n m (Tree p n)
goto path = case path of
[] -> gets focus
(p:path) -> do
st <- get
let step tree = put $ st{focus=tree, history=(p, focus st):history st}
case getBranch (focus st) >>= M.lookup p of
Nothing -> step Void
Just tree -> step tree
goto path
-- | Go up one level in the tree, storing the current sub-tree into the upper tree, unless the
-- current tree is 'Void', in which case it is deleted from the upper tree.
back :: (Ord p, Monad m) => UpdateTreeT p n m ()
back = modify $ \st -> case history st of
[] -> st
(p, tree):hist ->
st{ history = hist
, focus = flip alterBranch tree $ \branch -> flip mplus (fmap (M.delete p) branch) $ do
subTree <- notVoid (focus st)
fmap (M.insert p subTree) (mplus branch (return mempty))
}
-- | Returns 'Prelude.True' if we are at the top level of the tree.
atTop :: (Functor m, Monad m) => UpdateTreeT p n m Bool
atTop = fmap Prelude.null (gets history)
-- | Go back to the top level of the tree.
home :: (Ord p, Functor m, Monad m) => UpdateTreeT p n m ()
home = atTop >>= flip unless (back >> home)
-- | Return the current path.
getPath :: (Ord p, Functor m, Monad m) => UpdateTreeT p n m [p]
getPath = fmap (reverse . fmap fst) (gets history)
-- | Modify the tree node at the current 'focus'. After the update, if there is a leaf attached at
-- the focus, the value of the leaf is returned.
modifyNode :: (Ord p, Functor m, Monad m) => (Tree p n -> Tree p n) -> UpdateTreeT p n m (Maybe n)
modifyNode mod = modify (\st -> st{focus=mod(focus st)}) >> fmap getLeaf (gets focus)
-- | Modify the tree node using a 'ModBranch' function which allows you to alter the 'Data.Map.Map'
-- object containing the branches of the current node.
modifyBranch :: (Ord p, Functor m, Monad m) => ModBranch p n -> UpdateTreeT p n m ()
modifyBranch mod = modifyNode (alterBranch mod) >> return ()
-- | Modify the tree node using a 'ModLeaf' function which allows you to alter the 'Data.Map.Map'
-- object containing the current of the current node.
modifyLeaf :: (Ord p, Functor m, Monad m) => ModLeaf n -> UpdateTreeT p n m (Maybe n)
modifyLeaf mod = modifyNode (alterLeaf mod)
----------------------------------------------------------------------------------------------------
-- $MapLikeFunctions
-- In this section I have made my best effor to create API functions as similar as possible to that
-- of the "Data.Map" module.
----------------------------------------------------------------------------------------------------
alter :: Ord p => (Tree p a -> Tree p a) -> [p] -> Tree p a -> Tree p a
alter mod path = execUpdateTree (goto path >> modifyNode mod)
--alterNode alt px t = runIdentity $ alterNodeM (return . alt) px t
-- | Insert a 'Leaf' at a given address.
insert :: Ord p => [p] -> n -> Tree p n -> Tree p n
insert path n = execUpdateTree (goto path >> modifyLeaf (const (Just n)))
--insert px a = alter (const (Just a)) (flip mplus (Just Void)) px
-- | Update a 'Leaf' at a given address.
update :: Ord p => [p] -> ModLeaf a -> Tree p a -> Tree p a
update path mod = execUpdateTree (goto path >> modifyLeaf mod)
--update path mod = alter mod (flip mplus (Just Void)) path
-- | Delete a 'Leaf' or 'Branch' at a given address.
delete :: Ord p => [p] -> Tree p a -> Tree p a
delete path = execUpdateTree (goto path >> modifyLeaf (const Nothing))
--delete px = alter (const Nothing) id px
-- | Create a 'Tree' from a list of associationes, the 'Prelude.fst' element containing the branch,
-- the 'Prelude.snd' element containing the leaf value. This is the inverse operation of 'assocs'.
fromList :: Ord p => [([p], a)] -> Tree p a
fromList = foldl (\ tree (px, a) -> insert px a tree) Void
-- | Lookup a 'Tree' value (the whole node, not just the data stored in the node) at given address.
-- NOTE: this may not be what you want. If you want return the data that is stored in a 'Leaf' or
-- 'LeafBranch', use 'lookup', or just do @'lookup' atBranch inTree >>= 'getLeaf'@.
lookupNode :: Ord p => [p] -> Tree p a -> Maybe (Tree p a)
lookupNode px t = case px of
[] -> Just t
p:px -> case t of
Branch t -> next p t
LeafBranch _ t -> next p t
_ -> Nothing
where { next p t = M.lookup p t >>= Dao.Tree.lookupNode px }
-- | This function analogous to the 'Data.Map.lookup' function, which returns a value stored in a
-- leaf, or nothing if there is no leaf at the given path.
lookup :: Ord p => [p] -> Tree p a -> Maybe a
lookup px t = lookupNode px t >>= getLeaf
-- | Using @[p]@ as a path, traverse the path through the given 'Tree' as far as possible, return
-- the last node that could be reached along with the remainder of the path that was not traversed.
-- This is used to lookup whether or not a leaf has been stored into the tree at the given path, or
-- at some sub-path of the given path.
partialLookup :: Ord p => [p] -> Tree p a -> Maybe ([p], Tree p a)
partialLookup px t = case px of
[] -> Just ([], t)
p:px -> mplus (getBranch t >>= M.lookup p >>= partialLookup px) $
(getLeaf t >>= \ _ -> return (p:px, t))
-- | Using @[p]@ as a path, traverse a tree and retrieve every leaf found along the path until
-- traversal cannot continue. Evaluates to the list of leaves retrieved, the portion of the path
-- that could not be traversed, and the node at which traversal stopped.
leavesAlongPath :: Ord p => [p] -> Tree p a -> ([a], ([p], Tree p a))
leavesAlongPath px t = maybe ([], (px, t)) id $ loop [] px t where
loop ax px t = return (ax ++ maybe [] (:[]) (getLeaf t)) >>= \ax -> case px of
[] -> return (ax, ([], t))
p:px -> mplus (getBranch t >>= M.lookup p >>= loop ax px) (return (ax, (p:px, t)))
-- | There are only two kinds values defined as a 'MergeType': 'union' and 'intersection.
type MergeType p a
= (Tree p a -> Tree p a -> Tree p a)
-> M.Map p (Tree p a)
-> M.Map p (Tree p a)
-> M.Map p (Tree p a)
-- | Merge two trees together.
mergeWithKey :: Ord p
=> ([p] -> Maybe a -> Maybe b -> Maybe c)
-> (Tree p a -> Tree p c)
-> (Tree p b -> Tree p c)
-> Tree p a -> Tree p b -> Tree p c
mergeWithKey overlap leftOnly rightOnly left right = loop [] left right where
-- loop :: Ord p => [p] -> Tree p a -> Tree p b -> Tree p c
loop px left right = case left of
Void -> case right of
Void -> Void
Leaf y -> rightOnly (Leaf y )
Branch b -> rightOnly (Branch b)
LeafBranch y b -> rightOnly (LeafBranch y b)
Leaf x -> case right of
Void -> leftOnly (Leaf x )
Leaf y -> maybe Void id (fmap Leaf (overlap px (Just x) (Just y)))
Branch b -> leafbranch (Just x) Nothing M.empty b
LeafBranch y b -> leafbranch (Just x) (Just y) M.empty b
Branch a -> case right of
Void -> leftOnly (Branch a)
Leaf y -> leafbranch Nothing (Just y) a M.empty
Branch b -> leafbranch Nothing Nothing a b
LeafBranch y b -> leafbranch Nothing (Just y) a b
LeafBranch x a -> case right of
Void -> leftOnly (LeafBranch x a)
Leaf y -> leafbranch (Just x) (Just y) a M.empty
Branch b -> leafbranch (Just x) Nothing a b
LeafBranch y b -> leafbranch (Just x) (Just y) a b
where
-- leafbranch :: Ord p => M.Map p (Tree p a) -> M.Map p (Tree p b) -> Maybe a -> Maybe b -> Tree p c
leafbranch x y left right =
let c = M.mergeWithKey both (bias leftOnly) (bias rightOnly) left right -- :: M.Map p (Tree p c)
in case overlap px x y of
Nothing -> notEmpty Branch c
Just z -> notEmpty (LeafBranch z) c
-- notEmpty :: Ord p => (M.Map p (Tree p a) -> Tree p a) -> M.Map p (Tree p a) -> Tree p a
notEmpty cons c = if M.null c then Void else cons c
-- both :: Ord p => p -> Tree p a -> Tree p b -> Maybe (Tree p c)
both p left right = notVoid (loop (px++[p]) left right)
-- bias :: Ord p => (Tree p a -> Tree p b) -> M.Map p (Tree p a) -> M.Map p (Tree p b)
bias fn = M.mapMaybe (notVoid . fn)
mergeWith :: Ord p => (Maybe a -> Maybe b -> Maybe c) -> (Tree p a -> Tree p c) -> (Tree p b -> Tree p c) -> Tree p a -> Tree p b -> Tree p c
mergeWith overlap = mergeWithKey (\ _ -> overlap)
unionWithKey :: Ord p => ([p] -> a -> a -> a) -> Tree p a -> Tree p a -> Tree p a
unionWithKey overlap = mergeWithKey (\k a b -> msum [liftM2 (overlap k) a b, a, b]) id id
unionWith :: Ord p => (a -> a -> a) -> Tree p a -> Tree p a -> Tree p a
unionWith overlap = unionWithKey (\ _ -> overlap)
union :: Ord p => Tree p a -> Tree p a -> Tree p a
union = unionWith const
unionsWith :: Ord p => (a -> a -> a) -> [Tree p a] -> Tree p a
unionsWith overlap = foldl (unionWith overlap) Void
unions :: Ord p => [Tree p a] -> Tree p a
unions = unionsWith (flip const)
intersectionWithKey :: Ord p => ([p] -> a -> a -> a) -> Tree p a -> Tree p a -> Tree p a
intersectionWithKey overlap = mergeWithKey (\k -> liftM2 (overlap k)) (const Void) (const Void)
intersectionWith :: Ord p => (a -> a -> a) -> Tree p a -> Tree p a -> Tree p a
intersectionWith overlap = intersectionWithKey (\ _ -> overlap)
intersection :: Ord p => Tree p a -> Tree p a -> Tree p a
intersection = intersectionWith const
intersectionsWith :: Ord p => (a -> a -> a) -> [Tree p a] -> Tree p a
intersectionsWith overlap = foldl (intersectionWith overlap) Void
intersections :: Ord p => [Tree p a] -> Tree p a
intersections = intersectionsWith (flip const)
differenceWithKey :: Ord p => ([p] -> a -> b -> Maybe a) -> Tree p a -> Tree p b -> Tree p a
differenceWithKey overlap = mergeWithKey (\k a b -> mplus (b >>= \b -> a >>= \a -> overlap k a b) a) id (const Void)
differenceWith :: Ord p => (a -> b -> Maybe a) -> Tree p a -> Tree p b -> Tree p a
differenceWith overlap = differenceWithKey (\ _ -> overlap)
difference :: Ord p => Tree p a -> Tree p b -> Tree p a
difference = differenceWith (\ _ _ -> Nothing)
-- | Get all items and their associated path.
assocs :: Tree p a -> [([p], a)]
assocs t = loop [] t where
recurs px b = M.assocs b >>= \ (p, t) -> loop (px++[p]) t
loop px t = case t of
Void -> []
Leaf a -> [(px, a)]
Branch b -> recurs px b
LeafBranch a b -> (px, a) : recurs px b
-- | Apply @'Prelude.map' 'Prelude.snd'@ to the result of 'assocs', behaves just like how
-- 'Data.Map.elems' or 'Data.Array.IArray.elems' works.
elems :: Tree p a -> [a]
elems t = fmap snd (assocs t)
-- | Counts the number of *nodes*, which includes the number of 'Branch'es and 'Leaf's.
size :: Tree p a -> Word64
size t = case t of
Void -> 0
Leaf _ -> 1
Branch m -> 0 + f m
LeafBranch _ m -> 1 + f m
where { f m = foldl (\sz tre -> sz + size tre) (fromIntegral (M.size m)) (M.elems m) }
branchCount :: Tree p a -> Int
branchCount = maybe 0 M.size . getBranch
null :: Tree p a -> Bool
null Void = True
null _ = False
----------------------------------------------------------------------------------------------------
data TreeDiff a b
= LeftOnly a -- something exists in the "left" branch but not in the "right" branch.
| RightOnly b -- something exists in the "right" branch but not in the "left" branch.
| TreeDiff a b -- something exists in the "left" and "right" branches but they are not equal
deriving (Eq, Typeable)
-- | Produce a difference report of two trees with the given comparison predicate. If the predicate
-- returns 'Prelude.True', the node is ignored, otherwise the differences is reported.
treeDiffWith :: Ord p => (a -> b -> Bool) -> Tree p a -> Tree p b -> Tree p (TreeDiff a b)
treeDiffWith compare = mergeWithKey leaf (fmap LeftOnly) (fmap RightOnly) where
leaf _ a b = msum $
[ a >>= \a -> b >>= \b -> if compare a b then Nothing else Just (TreeDiff a b)
, fmap LeftOnly a, fmap RightOnly b
]
-- | Call 'treeDiffWith' using 'Prelude.(==)' as the comparison predicate.
treeDiff :: (Eq a, Ord p) => Tree p a -> Tree p a -> Tree p (TreeDiff a a)
treeDiff = treeDiffWith (==)