operational-0.2.0.0: docs/web/examples/LogicT.hs.html
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html>
<head>
<!-- Generated by HsColour, http://www.cs.york.ac.uk/fp/darcs/hscolour/ -->
<title>examples/LogicT.hs</title>
<link type='text/css' rel='stylesheet' href='hscolour.css' />
</head>
<body>
<pre><span class='hs-comment'>{------------------------------------------------------------------------------
Control.Monad.Operational
Example:
Oleg's LogicT monad transformer
Functions to implement are taken from the corresponding paper
<a href="http://okmij.org/ftp/papers/LogicT.pdf">http://okmij.org/ftp/papers/LogicT.pdf</a>
------------------------------------------------------------------------------}</span>
<span class='hs-comment'>{-# LANGUAGE GADTs, Rank2Types #-}</span>
<span class='hs-keyword'>module</span> <span class='hs-conid'>LogicT</span> <span class='hs-layout'>(</span><span class='hs-conid'>LogicT</span><span class='hs-layout'>,</span> <span class='hs-varid'>msplit</span><span class='hs-layout'>,</span> <span class='hs-varid'>observe</span><span class='hs-layout'>,</span> <span class='hs-varid'>bagOfN</span><span class='hs-layout'>,</span> <span class='hs-varid'>interleave</span><span class='hs-layout'>)</span> <span class='hs-keyword'>where</span>
<span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span>
<span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span><span class='hs-varop'>.</span><span class='hs-conid'>Operational</span>
<span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span><span class='hs-varop'>.</span><span class='hs-conid'>Trans</span>
<span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Maybe</span>
<span class='hs-comment'>{------------------------------------------------------------------------------
LogicT
= A MonadPlus with an additional operation
msplit
which returns the first result and a computation to
produce the remaining results.
For example, the function msplit satisfies the laws
msplit mzero ~> return Nothing
msplit (return a `mplus` m) ~> return (Just (a,m))
It turns out that we don't have to make msplit a primitive,
we can implement it by inspection on the argument. In other
words, LogicT will be the same as the ListT monad transformer
------------------------------------------------------------------------------}</span>
<span class='hs-keyword'>import</span> <span class='hs-conid'>ListT</span>
<span class='hs-keyword'>type</span> <span class='hs-conid'>LogicT</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ListT</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span>
<span class='hs-comment'>-- msplit is the lift of a function split in the base monad</span>
<span class='hs-definition'>msplit</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Monad</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>LogicT</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LogicT</span> <span class='hs-varid'>m</span> <span class='hs-layout'>(</span><span class='hs-conid'>Maybe</span> <span class='hs-layout'>(</span><span class='hs-varid'>a</span><span class='hs-layout'>,</span> <span class='hs-conid'>LogicT</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<span class='hs-definition'>msplit</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>lift</span> <span class='hs-varop'>.</span> <span class='hs-varid'>split</span>
<span class='hs-comment'>-- split in the base monad</span>
<span class='hs-definition'>split</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Monad</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>LogicT</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>m</span> <span class='hs-layout'>(</span><span class='hs-conid'>Maybe</span> <span class='hs-layout'>(</span><span class='hs-varid'>a</span><span class='hs-layout'>,</span> <span class='hs-conid'>LogicT</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<span class='hs-definition'>split</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>eval</span> <span class='hs-varop'><=<</span> <span class='hs-varid'>viewT</span>
<span class='hs-keyword'>where</span>
<span class='hs-comment'>-- apply the laws for msplit</span>
<span class='hs-varid'>eval</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Monad</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>ProgramViewT</span> <span class='hs-layout'>(</span><span class='hs-conid'>MPlus</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>m</span> <span class='hs-layout'>(</span><span class='hs-conid'>Maybe</span> <span class='hs-layout'>(</span><span class='hs-varid'>a</span><span class='hs-layout'>,</span> <span class='hs-conid'>LogicT</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<span class='hs-varid'>eval</span> <span class='hs-layout'>(</span><span class='hs-conid'>MZero</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-conid'>Nothing</span>
<span class='hs-varid'>eval</span> <span class='hs-layout'>(</span><span class='hs-conid'>MPlus</span> <span class='hs-varid'>m</span> <span class='hs-varid'>n</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<span class='hs-varid'>ma</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>split</span> <span class='hs-layout'>(</span><span class='hs-varid'>m</span> <span class='hs-varop'>>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span>
<span class='hs-keyword'>case</span> <span class='hs-varid'>ma</span> <span class='hs-keyword'>of</span>
<span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>split</span> <span class='hs-layout'>(</span><span class='hs-varid'>n</span> <span class='hs-varop'>>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span>
<span class='hs-conid'>Just</span> <span class='hs-layout'>(</span><span class='hs-varid'>a</span><span class='hs-layout'>,</span><span class='hs-varid'>m'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-conid'>Just</span> <span class='hs-layout'>(</span><span class='hs-varid'>a</span><span class='hs-layout'>,</span> <span class='hs-varid'>m'</span> <span class='hs-varop'>`mplus`</span> <span class='hs-layout'>(</span><span class='hs-varid'>n</span> <span class='hs-varop'>>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<span class='hs-comment'>-- inefficient!</span>
<span class='hs-comment'>-- `mplus` will add another (>>= return)</span>
<span class='hs-comment'>-- to n each time it's called.</span>
<span class='hs-comment'>-- Curing this is not easy.</span>
<span class='hs-comment'>-- main interpreter, section 6 in the paper</span>
<span class='hs-comment'>-- returns the first result, if any; may fail</span>
<span class='hs-definition'>observe</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Monad</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>LogicT</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span>
<span class='hs-definition'>observe</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>fst</span> <span class='hs-varop'>.</span> <span class='hs-varid'>fromJust</span><span class='hs-layout'>)</span> <span class='hs-varop'>`liftM`</span> <span class='hs-varid'>split</span> <span class='hs-varid'>m</span>
<span class='hs-comment'>{------------------------------------------------------------------------------
Derived functions from the paper
------------------------------------------------------------------------------}</span>
<span class='hs-comment'>-- return the first n results, section 6</span>
<span class='hs-definition'>bagOfN</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Monad</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>Maybe</span> <span class='hs-conid'>Int</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LogicT</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LogicT</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span>
<span class='hs-definition'>bagOfN</span> <span class='hs-layout'>(</span><span class='hs-conid'>Just</span> <span class='hs-varid'>n</span><span class='hs-layout'>)</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>n</span> <span class='hs-varop'><=</span> <span class='hs-num'>0</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-conid'>[]</span>
<span class='hs-definition'>bagOfN</span> <span class='hs-varid'>n</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>msplit</span> <span class='hs-varid'>m</span> <span class='hs-varop'>>>=</span> <span class='hs-varid'>bagofN'</span>
<span class='hs-keyword'>where</span>
<span class='hs-varid'>bagofN'</span> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-conid'>[]</span>
<span class='hs-varid'>bagofN'</span> <span class='hs-layout'>(</span><span class='hs-conid'>Just</span> <span class='hs-layout'>(</span><span class='hs-varid'>x</span><span class='hs-layout'>,</span><span class='hs-varid'>m'</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>x</span><span class='hs-conop'>:</span><span class='hs-layout'>)</span> <span class='hs-varop'>`liftM`</span> <span class='hs-varid'>bagOfN</span> <span class='hs-layout'>(</span><span class='hs-varid'>fmap</span> <span class='hs-varid'>pred</span> <span class='hs-varid'>n</span><span class='hs-layout'>)</span> <span class='hs-varid'>m'</span>
<span class='hs-keyword'>where</span> <span class='hs-varid'>pred</span> <span class='hs-varid'>n</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>n</span><span class='hs-comment'>-</span><span class='hs-num'>1</span>
<span class='hs-comment'>-- interleave</span>
<span class='hs-definition'>interleave</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Monad</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>LogicT</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LogicT</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LogicT</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span>
<span class='hs-definition'>interleave</span> <span class='hs-varid'>m1</span> <span class='hs-varid'>m2</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<span class='hs-varid'>r</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>msplit</span> <span class='hs-varid'>m1</span>
<span class='hs-keyword'>case</span> <span class='hs-varid'>r</span> <span class='hs-keyword'>of</span>
<span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>m2</span>
<span class='hs-conid'>Just</span> <span class='hs-layout'>(</span><span class='hs-varid'>a</span><span class='hs-layout'>,</span><span class='hs-varid'>m1'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-varid'>a</span> <span class='hs-varop'>`mplus`</span> <span class='hs-varid'>interleave</span> <span class='hs-varid'>m2</span> <span class='hs-varid'>m1'</span>
</pre></body>
</html>