packages feed

generator (empty) → 0.5

raw patch · 9 files changed

+766/−0 lines, 9 filesdep +MaybeTdep +basedep +mtlsetup-changed

Dependencies added: MaybeT, base, mtl

Files

+ LICENSE view
@@ -0,0 +1,32 @@+Copyright Yair Chuchem 2009.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Yair Chuchem nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ generator.cabal view
@@ -0,0 +1,41 @@+Name:                generator+Version:             0.5+Category:            Control+Synopsis:            A list monad transformer and related functions.+Description:+    A list monad transformer and a generic List class.++    Consumer and Generator monad transformers to create+    and iterate 'ListT's in a manner similar to+    Python generators.++    A Tree module for searching and pruning+    trees expressed as 'List's whose underlying monad+    is also a List.+License:             BSD3+License-file:        LICENSE+Author:              Yair Chuchem+Maintainer:          yairchu@gmail.com+Homepage:            http://github.com/yairchu/generator/tree+Cabal-Version:       >= 1.2+Stability:           experiemental+Build-type:          Simple++Library+  hs-Source-Dirs:      src+  Extensions:+  Build-Depends:       base >= 3 && < 5, mtl, MaybeT+  Exposed-modules:     Control.Monad.ListT,+                       Control.Monad.DList,+                       Control.Monad.Consumer,+                       Control.Monad.Generator,+                       Data.List.Class,+                       Data.List.Tree+  Ghc-Options:         -O2 -Wall+  Extensions:          FlexibleContexts,+                       FlexibleInstances,+                       FunctionalDependencies,+                       MultiParamTypeClasses,+                       RankNTypes,+                       UndecidableInstances+
+ src/Control/Monad/Consumer.hs view
@@ -0,0 +1,73 @@+-- | A monad transformer for the [partial] consumption of 'List's.+-- The interface closely mimics iterators in languages such as Python.+--+-- It is often nicer to avoid using Consumer and to use+-- folds and higher-order functions instead.+module Control.Monad.Consumer (+  ConsumerT, evalConsumerT, next, consumeRestM+  ) where++import Control.Applicative (Applicative(..))+import Control.Monad (MonadPlus(..), ap)+import Control.Monad.ListT (ListT(..), ListItem(..))+import Control.Monad.Maybe (MaybeT(..))+import Control.Monad.State (StateT, evalStateT, get, put)+import Control.Monad.Trans (MonadTrans(..), MonadIO(..))+import Data.List.Class (List(..))+import Data.Maybe (fromMaybe)++-- | A monad tranformer for consuming 'List's.+newtype ConsumerT v m a = ConsumerT { runConsumerT :: StateT (Maybe (ListT m v)) m a }++instance Monad m => Functor (ConsumerT v m) where+  fmap f = ConsumerT . fmap f . runConsumerT++instance Monad m => Monad (ConsumerT v m) where+  return = ConsumerT . return+  fail = ConsumerT . fail+  a >>= b = ConsumerT $ runConsumerT a >>= runConsumerT . b++instance Monad m => Applicative (ConsumerT v m) where+  pure = return+  (<*>) = ap++instance MonadTrans (ConsumerT v) where+  lift = ConsumerT . lift++instance MonadIO m => MonadIO (ConsumerT v m) where+  liftIO = lift . liftIO++-- | Consume a 'ListT'+evalConsumerT :: List l m => ConsumerT v m a -> l v -> m a+evalConsumerT (ConsumerT i) = evalStateT i . Just . toListT++-- Consumer no longer has a producer left...+putNoProducer :: List l m => StateT (Maybe (l v)) m ()+putNoProducer = put Nothing++-- | Consume/get the next value+next :: Monad m => ConsumerT v m (Maybe v)+next =+  ConsumerT . runMaybeT $ do+  list <- MaybeT get+  item <- lift . lift $ runListT list+  case item of+    Nil -> do+      lift putNoProducer+      mzero+    Cons x xs -> do+      putProducer xs+      return x+  where+    putProducer = put . Just++-- | Return an instance of the underlying monad that will use the given 'ConsumerT' to consume the remaining values.+-- After this action there are no more items to consume (they belong to the given ConsumerT now)+consumeRestM :: Monad m => ConsumerT a m b -> ConsumerT a m (m b)+consumeRestM consume =+  ConsumerT $ do+    mRest <- get+    let rest = fromMaybe mzero mRest+    putNoProducer+    return $ evalConsumerT consume rest+
+ src/Control/Monad/DList.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}++-- | A difference-list monad transformer / a monadic difference-list.+--+-- Difference lists are lists with /O(1)/ append (instead of /O(N)/).+--+-- Transforming a difference list to a list is /O(1)/,+-- a must be done to access a difference list.+-- The transformation from a list to a difference list is /O(N)/.++module Control.Monad.DList (+  DListT (..)+  ) where++import Control.Applicative (Applicative(..))+import Control.Monad (MonadPlus(..), liftM, ap)+import Control.Monad.ListT (ListT)+import Control.Monad.Trans (MonadTrans(..))+import Data.List.Class (List(..), cons)+import Data.Monoid (Monoid(..))++-- | A monadic difference-list+newtype DListT m a = DListT { runDListT :: ListT m a -> ListT m a }++instance Monoid (DListT l a) where+  mempty = DListT id+  mappend (DListT a) (DListT b) = DListT $ a . b++instance Monad m => Functor (DListT m) where+  fmap func = DListT . mplus . liftM func . toListT++instance Monad m => Monad (DListT m) where+  return = DListT . cons+  a >>= b = DListT . mplus $ toListT a >>= liftM toListT b++instance Monad m => Applicative (DListT m) where+  pure = return+  (<*>) = ap++instance Monad m => MonadPlus (DListT m) where+  mzero = mempty+  mplus = mappend++instance Monad m => List (DListT m) m where+  joinL action =+    DListT $ \rest -> joinL $+    liftM (`runDListT` rest) action+  toListT = (`runDListT` mzero)++instance MonadTrans DListT where+  lift = DListT . mappend . lift+
+ src/Control/Monad/Generator.hs view
@@ -0,0 +1,63 @@+-- | A monad transformer for the creation of Lists.+-- Similar to Python's generators.+--+-- > import Data.List.Class (convList)+-- >+-- > hanoi 0 _ _ _ = mempty+-- > hanoi n from to other =+-- >   generate $ do+-- >     yields $ hanoi (n-1) from other to+-- >     yield (from, to)+-- >     yields $ hanoi (n-1) other to from+-- >+-- > > convList (hanoi 3 'A' 'B' 'C') :: [(Char, Char)]+-- > [('A','B'),('A','C'),('B','C'),('A','B'),('C','A'),('C','B'),('A','B')]+--++module Control.Monad.Generator (+  GeneratorT, generate, yield, yields+  ) where++import Control.Applicative (Applicative(..))+import Control.Monad (liftM, ap)+import Control.Monad.Cont (Cont (..))+import Control.Monad.DList (DListT)+import Control.Monad.Trans (MonadTrans(..), MonadIO(..))+import Data.List.Class (cons, joinL)+import Data.Monoid (Monoid(..))++-- | A monad transformer to create 'List's.+-- 'generate' transforms a "GeneratorT v m a" to a "DListT m a".+newtype GeneratorT v m a =+  GeneratorT { runGeneratorT :: Cont (DListT m v) a }++instance Monad m => Functor (GeneratorT v m) where+  fmap = liftM++instance Monad m => Monad (GeneratorT v m) where+  return = GeneratorT . return+  GeneratorT a >>= f = GeneratorT $ a >>= runGeneratorT . f+  fail = lift . fail++instance Monad m => Applicative (GeneratorT v m) where+  pure = return+  (<*>) = ap++instance MonadTrans (GeneratorT v) where+  lift m = GeneratorT . Cont $ joinL . (`liftM` m)++instance MonadIO m => MonadIO (GeneratorT v m) where+  liftIO = lift . liftIO++-- | /O(1)/, Transform a GeneratorT to a 'DListT'+generate :: Monad m => GeneratorT v m () -> DListT m v+generate = ($ const mempty) . runCont . runGeneratorT++-- | /O(1)/, Output a result value+yield :: Monad m => v -> GeneratorT v m ()+yield x = GeneratorT . Cont $ cons x . ($ ())++-- | /O(1)/, Output all the values of a 'DListT'.+yields :: Monad m => DListT m v -> GeneratorT v m ()+yields xs = GeneratorT . Cont $ mappend xs . ($ ())+
+ src/Control/Monad/ListT.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}++-- Module is called ListT because List is taken by mtl++-- | A list monad transformer / a monadic list.+--+-- Monadic list example:+--   A program which reads numbers from the user and accumulates them.+--+-- > import Control.Monad.ListT (ListT)+-- > import Data.List.Class (joinL, repeat, scanl, sequence, sequence_, takeWhile)+-- > import Prelude hiding (repeat, scanl, sequence, sequence_, takeWhile)+-- >+-- > main =+-- >   sequence_ .+-- >   fmap print .+-- >   scanl (+) 0 .+-- >   fmap (fst . head) .+-- >   takeWhile (not . null) .+-- >   fmap reads .+-- >   joinL . sequence $+-- >   (repeat getLine :: ListT IO (IO String))++module Control.Monad.ListT (+  ListItem(..), ListT(..), foldrListT+) where++import Control.Applicative (Applicative(..))+import Control.Monad (MonadPlus(..), ap, liftM)+-- import Control.Monad.Cont.Class (MonadCont(..))+import Control.Monad.Error.Class (MonadError(..))+import Control.Monad.Reader.Class (MonadReader(..))+import Control.Monad.State.Class (MonadState(..))+import Control.Monad.Trans (MonadTrans(..), MonadIO(..))+import Data.Monoid (Monoid(..))++data ListItem l a =+  Nil |+  Cons { headL :: a, tailL :: l a }++data ListT m a = ListT { runListT :: m (ListItem (ListT m) a) }++-- | foldr for ListT+foldrListT :: Monad m => (a -> m b -> m b) -> m b -> ListT m a -> m b+foldrListT consFunc nilFunc list = do+  item <- runListT list+  case item of+    Nil -> nilFunc+    Cons x xs -> consFunc x $ foldrListT consFunc nilFunc xs++-- for mappend, fmap, bind+foldrListT' :: Monad m =>+  (a -> ListT m b -> ListT m b) -> ListT m b -> ListT m a -> ListT m b+foldrListT' consFunc nilFunc =+  ListT . foldrListT step (runListT nilFunc)+  where+    step x = runListT . consFunc x . ListT++-- like generic cons except using that one+-- would cause an infinite loop+cons :: Monad m => a -> ListT m a -> ListT m a+cons x = ListT . return . Cons x++instance Monad m => Monoid (ListT m a) where+  mempty = ListT $ return Nil+  mappend = flip (foldrListT' cons)++instance Monad m => Functor (ListT m) where+  fmap func = foldrListT' (cons . func) mempty++instance Monad m => Monad (ListT m) where+  return = ListT . return . (`Cons` mempty)+  a >>= b = foldrListT' mappend mempty $ fmap b a++instance Monad m => Applicative (ListT m) where+  pure = return+  (<*>) = ap++instance Monad m => MonadPlus (ListT m) where+  mzero = mempty+  mplus = mappend++instance MonadTrans ListT where+  lift = ListT . liftM (`Cons` mempty)++-- YUCK:+-- I can't believe I'm doing this,+-- for compatability with mtl's ListT.+-- I hate the O(N^2) code length auto-lifts. DRY!!++instance MonadIO m => MonadIO (ListT m) where+  liftIO = lift . liftIO++{-+-- TODO: understand and verify this instance :)+instance MonadCont m => MonadCont (ListT m) where+  callCC f =+    ListT $ callCC thing+    where+      thing c = runListT . f $ ListT . c . (`Cons` mempty)+-}++instance MonadError e m => MonadError e (ListT m) where+  throwError = lift . throwError+  catchError m = ListT . catchError (runListT m) . (runListT .)++instance MonadReader s m => MonadReader s (ListT m) where+  ask = lift ask+  local f = ListT . local f . runListT++instance MonadState s m => MonadState s (ListT m) where+  get = lift get+  put = lift . put+
+ src/Data/List/Class.hs view
@@ -0,0 +1,234 @@+{-# LANGUAGE FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, RankNTypes, UndecidableInstances #-}++-- | The 'List' class and actions for lists++module Data.List.Class (+  -- | The List typeclass+  List (..),+  -- | List operations for MonadPlus+  cons, fromList, filter, repeat,+  -- | Standard list operations+  takeWhile, genericTake, scanl,+  sequence, sequence_, transpose,+  zip, zipWith,+  -- | Non standard List operations+  foldlL, toList, execute, lengthL, lastL,+  -- | Convert between List types+  convList, transformListMonad, liftListMonad+  ) where++import Control.Monad (MonadPlus(..), ap, join, liftM)+import Control.Monad.Identity (Identity(..))+import Control.Monad.ListT (ListT(..), ListItem(..), foldrListT)+import Control.Monad.Trans (MonadTrans(..))+import Data.Function (fix)+import Prelude hiding (+  filter, repeat, scanl, sequence, sequence_, takeWhile, zip, zipWith)++-- | A class for list types.+-- Every list has an underlying monad.+class (MonadPlus l, Monad m) => List l m | l -> m where+  -- | Transform an action returning a list to the returned list+  --+  -- > > joinL $ Identity "hello"+  -- > "hello"+  joinL :: m (l b) -> l b+  -- | foldr for 'List's.+  -- the result and 'right side' values are monadic actions.+  foldrL :: (a -> m b -> m b) -> m b -> l a -> m b+  foldrL consFunc nilFunc = foldrL consFunc nilFunc . toListT+  -- | Convert to a 'ListT'.+  --+  -- Can be done with a foldrL but included in type-class for efficiency.+  toListT :: l a -> ListT m a+  toListT = convList+  -- | Convert from a 'ListT'.+  --+  -- Can be done with a foldrL but included in type-class for efficiency.+  fromListT :: ListT m a -> l a+  fromListT = convList++instance List [] Identity where+  joinL = runIdentity+  foldrL = foldr+  toListT = fromList++instance Monad m => List (ListT m) m where+  joinL = ListT . (>>= runListT)+  foldrL = foldrListT+  toListT = id+  fromListT = id++-- | Prepend an item to a 'MonadPlus'+cons :: MonadPlus m => a -> m a -> m a+cons = mplus . return++-- | Convert a list to a 'MonadPlus'+--+-- > > fromList [] :: Maybe Int+-- > Nothing+-- > > fromList [5] :: Maybe Int+-- > Just 5+fromList :: MonadPlus m => [a] -> m a+fromList = foldr (mplus . return) mzero++-- | Convert between lists with the same underlying monad+convList :: (List l m, List k m) => l a -> k a+convList =+  joinL . foldrL step (return mzero)+  where+    step x = return . cons x . joinL++-- | filter for any MonadPlus+--+-- > > filter (> 5) (Just 3)+-- > Nothing+filter :: MonadPlus m => (a -> Bool) -> m a -> m a+filter cond =+  (>>= f)+  where+    f x+      | cond x = return x+      | otherwise = mzero++-- for foldlL and scanl+foldlL' :: List l m =>+  (a -> m c -> c) -> (a -> c) -> (a -> b -> a) -> a -> l b -> c+foldlL' joinVals atEnd step startVal =+  t startVal . foldrL astep (return atEnd)+  where+    astep x rest = return $ (`t` rest) . (`step` x)+    t cur = joinVals cur . (`ap` return cur)++-- | An action to do foldl for 'List's+foldlL :: List l m => (a -> b -> a) -> a -> l b -> m a+foldlL step startVal =+  foldlL' (const join) id astep (return startVal)+  where+    astep rest x = liftM (`step` x) rest++scanl :: List l m => (a -> b -> a) -> a -> l b -> l a+scanl =+  foldlL' consJoin $ const mzero+  where+    consJoin cur = cons cur . joinL++genericTake :: (Integral i, List l m) => i -> l a -> l a+genericTake count+  | count <= 0 = const mzero+  | otherwise = foldlL' joinStep (const mzero) next Nothing+  where+    next Nothing x = Just (count, x)+    next (Just (i, _)) y = Just (i - 1, y)+    joinStep Nothing = joinL+    joinStep (Just (1, x)) = const $ return x+    joinStep (Just (_, x)) = cons x . joinL++-- | Execute the monadic actions in a 'List'+execute :: List l m => l a -> m ()+execute = foldlL const ()++sequence :: List l m => l (m a) -> m (l a)+sequence =+  foldrL consFunc (return mzero)+  where+    consFunc action rest = do+      x <- action+      return . cons x . joinL $ rest++sequence_ :: List l m => l (m a) -> m ()+sequence_ = execute . joinL . sequence++takeWhile :: List l m => (a -> Bool) -> l a -> l a+takeWhile cond =+  joinL . foldrL step (return mzero)+  where+    step x+      | cond x = return . cons x . joinL+      | otherwise = const $ return mzero++-- | An action to transform a 'List' to a list+--+-- > > runIdentity $ toList "hello!"+-- > "hello!"+toList :: List l m => l a -> m [a]+toList =+  foldrL step $ return []+  where+    step = liftM . (:)++-- | Consume a list (execute its actions) and return its length+--+-- > > runIdentity $ lengthL [1,2,3]+-- > 3+lengthL :: (Integral i, List l m) => l a -> m i+lengthL = foldlL (const . (+ 1)) 0++-- | Transform the underlying monad of a list given a way to transform the monad+--+-- > > import Data.List.Tree (bfs)+-- > > bfs (transformListMonad (\(Identity x) -> [x, x]) "hey" :: ListT [] Char)+-- > "hheeeeyyyyyyyy"+transformListMonad :: (List l m, List k s) =>+  (forall x. m x -> s x) -> l a -> k a+transformListMonad trans =+  t . foldrL step (return mzero)+  where+    t = joinL . trans+    step x = return . cons x . t++-- | Lift the underlying monad of a list and transform it to a ListT.+--+-- Doing plain 'transformListMonad lift' instead doesn't give the compiler+-- the same knowledge about the types.+liftListMonad ::+  (MonadTrans t, Monad (t m), List l m) =>+  l a -> ListT (t m) a+liftListMonad = transformListMonad lift++zip :: List l m => l a -> l b -> l (a, b)+zip as bs =+  r0 (toListT as) (toListT bs)+  where+    r0 xx yy =+      joinL $ do+        xi <- runListT xx+        case xi of+          Nil -> return mzero+          Cons x xs -> r1 x xs yy+    r1 x xs yy = do+      yi <- runListT yy+      return $ case yi of+        Nil -> mzero+        Cons y ys ->+          cons (x, y) $ r0 xs ys++-- zipWith based on zip and not vice versa,+-- because the other way around hlint compains "use zip".+zipWith :: List l m => (a -> b -> c) -> l a -> l b -> l c+zipWith func as = liftM (uncurry func) . zip as++-- | Consume all items and return the last one+--+-- > > runIdentity $ lastL "hello"+-- > 'o'+lastL :: List l m => l a -> m a+lastL = foldlL (const id) undefined++repeat :: MonadPlus m => a -> m a+repeat = fix . cons++transpose :: List l m => l (l a) -> l (l a)+transpose matrix =+  joinL $ toList matrix >>= r . map toListT+  where+    r xs = do+      items <- mapM runListT xs+      return $ case filter isCons items of+        [] -> mzero+        citems ->+          cons (fromList (map headL citems)) .+          joinL . r $ map tailL citems+    isCons Nil = False+    isCons _ = True+
+ src/Data/List/Tree.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}++-- | Functions for iterating trees.+-- A 'List' whose underlying monad is also a 'List' is a tree.+--+-- It's nodes are accessible, in contrast to the list monad,+-- which can also be seen as a tree, except only its leafs+-- are accessible and only in "dfs order".+--+-- > import Control.Monad.Generator+-- > import Data.List.Class (genericTake, takeWhile, toList, lastL)+-- >+-- > bits = t ""+-- > t prev =+-- >   generate $ do+-- >     yield prev+-- >     x <- lift "01"+-- >     yields $ t (prev ++ [x])+-- >+-- > > take 3 (bfsLayers bits)+-- > [[""],["0","1"],["00","01","10","11"]]+-- >+-- > > take 10 (bfs bits)+-- > ["","0","1","00","01","10","11","000","001","010"]+-- >+-- > > dfs (genericTake 4 bits)+-- > ["","0","00","000","001","01","010","011","1","10","100","101","11","110","111"]+-- >+-- > > toList $ genericTake 3 bits+-- > [["","0","00"],["","0","01"],["","1","10"],["","1","11"]]+--+-- Examples of pruning with 'prune' and 'takeWhile':+--+-- > > dfs . takeWhile (not . isSuffixOf "11") $ genericTake 4 bits+-- > ["","0","00","000","001","01","010","1","10","100","101"]+-- >+-- > > lastL . takeWhile (not . isSuffixOf "11") $ genericTake 4 bits+-- > ["000","001","010","01","100","101","1"]+-- >+-- > > lastL . prune (not . isSuffixOf "11") $ genericTake 4 bits+-- > ["000","001","010","100","101"]+--+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)++-- | A 'type-class synonym' for Trees.+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++-- | Iterate a tree in DFS pre-order. (Depth First Search)+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++-- | Transform a tree into lists of the items in its different layers+bfsLayers :: Tree l k m => l a -> k (k a)+bfsLayers =+  fromListT . liftM fromListT .+  search (liftM join . transpose) . liftM return .+  toListTree++-- | Iterate a tree in BFS order. (Breadth First Search)+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++-- | Best First Search given a scoring function.+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++-- | Best-First-Search given that a node's children are in sorted order (best first) and given a scoring function.+-- Especially useful for trees where nodes have an infinite amount of children, where 'bestFirstSearchOn' will get stuck.+bestFirstSearchSortedChildrenOn ::+  (Ord b, Tree l k m) => (a -> b) -> l a -> k a+bestFirstSearchSortedChildrenOn func =+  fromListT . search (mergeOnSortedHeads func) . toListTree++-- | Prune a tree or list given a predicate.+-- Unlike 'takeWhile' which stops a branch where the condition doesn't hold,+-- prune "cuts" the whole branch (the underlying MonadPlus's mzero).+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+