module Data.List.Tree (
Tree, dfs, bfs, bfsLayers, bestFirstSearchOn,
prune, bestFirstSearchSortedChildrenOn
) where
import Control.Monad (MonadPlus(..), guard, join, liftM)
import Control.Monad.ListT (ListT(..), ListItem(..))
import Data.List.Class (
List(..), cons, foldlL, sequence,
transformListMonad, transpose)
import Prelude hiding (sequence)
class (List l k, List k m) => Tree l k m
instance (List l k, List k m) => Tree l k m
search :: (List l m, MonadPlus m) => (m (m a) -> m a) -> l a -> m a
search merge =
merge . foldrL step mzero
where
step a = return . cons a . merge
dfs :: (List l m, MonadPlus m) => l a -> m a
dfs = search join
toListTree :: Tree l k m => l a -> ListT (ListT m) a
toListTree = transformListMonad toListT
bfsLayers :: Tree l k m => l a -> k (k a)
bfsLayers =
fromListT . liftM fromListT .
search (liftM join . transpose) . liftM return .
toListTree
bfs :: Tree l k m => l a -> k a
bfs = join . bfsLayers
mergeOn :: (Ord b, Monad m) => (a -> b) -> ListT m (ListT m a) -> ListT m a
mergeOn f =
joinL . foldlL merge2 mzero
where
merge2 xx yy =
joinL $ do
xi <- runListT xx
yi <- runListT yy
return $ case (xi, yi) of
(Cons x xs, Cons y ys)
| f y > f x -> cons x . merge2 xs $ cons y ys
| otherwise -> cons y $ merge2 (cons x xs) ys
(x, y) -> mplus (t x) (t y)
t Nil = mzero
t (Cons x xs) = cons x xs
bestFirstSearchOn ::
(Ord b, Tree l k m) => (a -> b) -> l a -> k a
bestFirstSearchOn func =
fromListT . search (mergeOn func) . toListTree
mergeOnSortedHeads ::
(Ord b, Monad m) => (a -> b) -> ListT m (ListT m a) -> ListT m a
mergeOnSortedHeads f list =
joinL $ do
item <- runListT list
case item of
Nil -> return mzero
Cons xx yys -> do
xi <- runListT xx
return $ case xi of
Nil -> mergeOnSortedHeads f yys
Cons x xs ->
cons x . mergeOnSortedHeads f $ bury xs yys
where
bury xx yyy =
joinL $ do
xi <- runListT xx
case xi of
Nil -> return yyy
Cons x xs -> bury' x xs yyy
bury' x xs yyy = do
yyi <- runListT yyy
case yyi of
Nil -> return . return $ cons x xs
Cons yy yys -> do
yi <- runListT yy
case yi of
Nil -> bury' x xs yys
Cons y ys
| f x <= f y -> return . cons (cons x xs) $ cons (cons y ys) yys
| otherwise -> return . cons (cons y ys) =<< bury' x xs yys
bestFirstSearchSortedChildrenOn ::
(Ord b, Tree l k m) => (a -> b) -> l a -> k a
bestFirstSearchSortedChildrenOn func =
fromListT . search (mergeOnSortedHeads func) . toListTree
prune :: (List l m, MonadPlus m) => (a -> Bool) -> l a -> l a
prune cond =
joinL . sequence . liftM r
where
r x = do
guard $ cond x
return x