[Haskell] A MonadPlusT with fair operations and pruning

[ajb at spamcop.net]

G'day all.

Quoting oleg at pobox.com:

: Since Andrew Bromage wished for that interesting monad, perhaps he has
: in mind a good example of its use.  We are particularly interested in a
: short example illustrating soft-cut (and, perhaps, `once').

No obvious small examples of soft cut spring to mind.  (If Fergus is
listening, he might have a few suggestions...)

In Prolog parlance, there are three types of cut operation:

    - A "red cut" is anything which prunes away solutions.  Red cuts are
      usually considered bad style because they have no logical
      interpretation.

    - A "green cut" is any cut which does not prune solutions, but which
      may prune different proofs of the same solution.

    - A "blue cut" prunes neither solutions, nor proofs.  It's basically
      an efficiency hack, where the programmer inserts a cut to tell the
      Prolog implementation that some piece of code is deterministic when
      the implementation can't infer that.

Green and blue cuts are sometimes collectively called "grue cuts".

The most obvious use for "once" (which I may accidentally call "commit")
is for blue cuts.  This is not so useful in Haskell, but you never know.

The second most obvious use is for those times when some goal isn't
technically deterministic, but you never actually look at the "output".
Mercury automatically inserts these commit operations if it can tell that
the output of some goal is never consulted.

One situation where you might use this is in negation-as-failure:

    gnot :: (Logic m) => m a -> m ()
    gnot m = ifte (once m) (const gfail) (gsuccess ())

The point of the "once" is that when the "then" branch fails, the system
won't backtrack into m.  There's no point, since it's always going to fail.

Another example of pruning is any situation where you are doing some kind
of search which would normally be intractable, but you have a heuristic.
If the heuristic is "safe" (that is, if whenever it can be applied,
applying it results in no solutions being lost), then the cut is green.
Otherwise it's red.  (But that's sometimes okay; if it's an NP-hard
problem, for example, you just make do with the approximation provided
by the heuristic.)

With soft cuts, you can express it like this:

    optimise curState
        | isGoalState curState
            = gsuccess success
        | otherwise
            = ifte
                (tryHeuristic curState)
                (\h -> do                    -- "then" case
                    s <- nextStateWithHeuristic h curState
                    optimise s)
                (do                          -- "else" case
                    s <- nextState curState
                    optimise s)

The soft cut guarantees that you commit to the heuristic if it applies.

As an example, here's a simple (though not THAT short) tic-tac-toe game.
The solution is highly artificial, since the "next move" computation is
effectively deterministic.  A better example might be solving Sudoku
problems, but that's harder to set up than tic-tac-toe.

> {-# OPTIONS -fglasgow-exts #-}
> {-# OPTIONS -fallow-undecidable-instances #-}

The -fallow-undecidable-instances will be explained in a moment.

> module Main where
>
> import Control.Monad
> import Control.Monad.Trans
> import LogicT
> import SFKT
> import Data.List

OK, now the monad that most of the computation will be done in...

> class (Monad m, MonadIO (t m), LogicT t, MonadPlus (t m)) => MyMonT t m
> instance (Monad m, MonadIO (t m), LogicT t, MonadPlus (t m)) => MyMonT t m

This is the reason for -fallow-undecidable-instances.  To make the types
not so unwieldy, we would ideally like typeclass synonyms, but Haskell
doesn't support them.  So this will have to do.

> data Value = B | X | O deriving (Show, Eq, Ord)
> type Player = Value

We're going to overload the Value type with two meanings: It can either
mean a value on the tic-tac-toe board, or it can refer to a player (either
X or O).

Code to switch players:

> otherPlayer :: Player -> Player
> otherPlayer X = O
> otherPlayer O = X

Code to handle the board:

> data Board
>     = Board Value Value Value Value Value Value Value Value Value
>     deriving (Show, Eq, Ord)
>
> blankBoard :: Board
> blankBoard = Board B B B B B B B B B
>
> -- Return true if the board is a win for player p.
> win :: Value -> Board -> Bool
> win p (Board a b c d e f g h i)
>     =  (a == b && b == c && a == p)
>     || (d == e && e == f && d == p)
>     || (g == h && h == i && g == p)
>     || (a == d && d == g && a == p)
>     || (b == e && e == h && b == p)
>     || (c == f && f == i && c == p)
>     || (a == e && e == i && a == p)
>     || (c == e && e == g && c == p)
>
> draw :: Board -> Bool
> draw (Board a b c d e f g h i)
>     = not (any (==B) [a,b,c,d,e,f,g,h,i])

We also need to encode the desirability of a board state.  We do this
with an enum type such that more desirable states come first in Ord.

> data State = Win | Draw | Lose deriving (Show, Eq, Ord)
>
> otherState :: State -> State
> otherState Win = Lose
> otherState Lose = Win
> otherState Draw = Draw

A move is a number from 1 to 9 representing the cell to put your mark
in:

> type Move = Int
>
> move :: (MonadPlus m) => Move -> Player -> Board -> m Board
> move 1 p (Board B b c d e f g h i) = return $ Board p b c d e f g h i
> move 2 p (Board a B c d e f g h i) = return $ Board a p c d e f g h i
> move 3 p (Board a b B d e f g h i) = return $ Board a b p d e f g h i
> move 4 p (Board a b c B e f g h i) = return $ Board a b c p e f g h i
> move 5 p (Board a b c d B f g h i) = return $ Board a b c d p f g h i
> move 6 p (Board a b c d e B g h i) = return $ Board a b c d e p g h i
> move 7 p (Board a b c d e f B h i) = return $ Board a b c d e f p h i
> move 8 p (Board a b c d e f g B i) = return $ Board a b c d e f g p i
> move 9 p (Board a b c d e f g h B) = return $ Board a b c d e f g h p
> move _ _ _ = mzero

Utility "axiom of choice" function:

> choose :: (MonadPlus m) => [a] -> m a
> choose = msum . map return

Right, now on to the game.  Assume that there's a function:

  best :: (MyMonT t m) => Player -> Board -> t m (State, Board)

where best p b makes the best move for player p on board b, returning
the new board as well as an estimate about how good the position is
(i.e. whether it's a theoretical win, lose or draw for player p).  Then
here's how to play a game with the computer playing itself.  X moves
first.

> game :: (MyMonT t m) => t m ()
> game
>     = game' X blankBoard
>     where
>         game' p b
>             | win X b
>                 = liftIO (putStrLn "X wins!")
>             | win O b
>                 = liftIO (putStrLn "O wins!")
>             | draw b
>                 = liftIO (putStrLn "Draw!")
>             | otherwise
>                 = do
>                     (_,b') <- once (best p b)
>                     liftIO (putStrLn $ show b')
>                     game' (otherPlayer p) b'
>
> main
>     = observe game

Now all we need to do is write "best".

This is a simple problem in AI.  Basically, you're trying to do a minimax
search.  If this is a "goal state" (i.e. an ACTUAL win, lose or draw), then
we're done.  If not, we examine all of the successor states, assuming that
our opponent will make their best move, and we pick the one that's best
for us.

best :: (MyMonT t m) => Player -> Board -> t m (State, Board)
best p b
    | win p b
        = return (Win, b)
    | win (otherPlayer p) b
        = return (Lose, b)
    | draw b
        = return (Draw, b)
    | otherwise
        = do
            wbs <- runN Nothing (do
                m <- choose [1..9]
                b' <- move m p b
                (w,_) <- best (otherPlayer p) b'
                return (otherState w,b'))
            let (w,b') = minimum wbs
            return (w, b')

Unfortunately, this is too slow for interactive use.  Certainly, I ran
out of patience after a minute.  However, thankfully there are a couple
of safe heuristics which work just fine with tic-tac-toe.

The first is that if you can win in this move, you should do so.

The second is that if the first heuristic doesn't work, then you should
see if there is any move that your opponent could make where they could
win on the next move.  If so, you should move to block it.

The code looks like this:

> best :: (MyMonT t m) => Player -> Board -> t m (State, Board)
> best p b
>     | win p b
>         = return (Win, b)
>     | win (otherPlayer p) b
>         = return (Lose, b)
>     | draw b
>         = return (Draw, b)
>     | otherwise
>         = ifte (once (do
>             m <- choose [1..9]
>             b' <- move m p b
>             guard (win p b)
>             return (Win, b')))
>           return
>             (ifte (once (do
>                     m <- choose [1..9]
>                     b' <- move m (otherPlayer p) b
>                     guard (win (otherPlayer p) b')
>                     return m))
>              (\m -> do
>                 b' <- move m p b
>                 (w,_) <- best (otherPlayer p) b'
>                 return (w,b'))
>              (do
>                 wbs <- runN Nothing (do
>                     m <- choose [1..9]
>                     b' <- move m p b
>                     (w,_) <- best (otherPlayer p) b'
>                     return (otherState w,b'))
>                 let (w,b') = minimum wbs
>                 return (w, b')))

And we're done.  Runs nice and fast now.



Some of the interesting examples in Prolog are moot in Haskell by virtue
of the fact that Haskell is "strongly moded".

Having said that, there are three main areas where I find soft-cut useful.

The first is directing search.  People who liberally use <|> and <?> in
Parsec probably know exactly what I mean by this.

The second is tailoring failure.  A lot of Prolog programs just fail
without further comment.  There was once a logic language implementation
(which I won't name) whose front-end was implemented this way.  Imagine
if you fed your compiler a program, and the only diagnostic that you got
was "Your program contains one or more errors."

Soft cut gives you a logical way to specify _why_ some task failed.


Well first off, the combination of soft-cut and once gives you a logical
negation-as-failure:

    gnot :: (Logic m) => m a -> m ()
    gnot m = ifte (once m) (\_ -> gfail) (gsuccess ())

That's a useful alternative to "guard".

Cheers,
Andrew Bromage