Solutions to Problem Set 8
==========================

Written by Paul Hudak in literate Haskell style.
November 5, 2004

> module PS8 where
> import Monad
> import Robot
> import SOEGraphics

1. The state monad can be made polymorphic in the state in the
   following way:

      data SM s a = SM (s -> (s, a))

      instance Monad (SM s) where
           return a        = SM $ \s  -> (s,a)
           SM sm0 >>= fsm1 = SM $ \s0 ->
              let (s1,a1) = sm0 s0
                  SM sm1  = fsm1 a1
                  (s2,a2) = sm1 s1
              in (s2,a2)

   Note the "partial application" of SM to s in the instance declaration.

   The state monad can also be combined with the Maybe monad to yield
   a state monad that permits failure and back-tracking.  In particular:

      data SME s a = SME (s -> Maybe (s, a))

   Provide an instance declaration for SME not just in class Monad,
   but also in class MonadPlus.

   Note: The significance of MonadPlus for SME is that an expression
   such as "e1 `mplus` e2" means "try e1, and if it succeeds, we are
   done; but if it fails, try e2".  Since e1 can be arbitrarily complex,
   this is, in essence, a form of back-tracking.

Solution:

> data SME s a = SME (s -> Maybe (s, a))
> 
> instance Monad (SME s) where
>    return a = SME $ \s -> Just (s,a)
>    SME sm0 >>= fsm1 = SME $ \s0 ->
>        do (s1,a1) <- sm0 s0
>           let SME sm1 = fsm1 a1
>           (s2,a2) <- sm1 s1
>           return (s2,a2)
>
> instance MonadPlus (SME s) where
>    mzero = SME $ \s -> Nothing
>    SME sm0 `mplus` SME sm1 = SME $ \s0 ->
>        case sm0 s0 of
>          Just r  -> Just r 
>          Nothing -> sm1 s0


2. Use SME and its monadic instances to devise a solution to the
   n-queens problem.

Solution:

> type Board = [Int]            -- list of board placements
>
> getPlaces :: SME Board [Int]
> getPlaces = SME $ \ps -> Just (ps,ps)
> 
> place :: Int -> SME Board ()
> place i = SME $ \ps -> if safe i ps 1 then Just (i:ps,())
>                                       else Nothing
> 
> safe :: Int -> [Int] -> Int -> Bool
> safe p [] n = True
> safe p (y:ys) n = and [ p/=y, p/=y+n, p/=y-n, safe p ys (n+1)]
> 
> nQueens :: Int -> SME Board [Int]
> nQueens n = do loop n
>                getPlaces
>   where loop 0 = return ()
>         loop m = foldr mplus mzero
>                        [ place i >> loop (m-1) | i <- [1..n] ]
>
> runSME :: SME s a -> s -> Maybe a
> runSME (SME f) s = case f s of
>                      Just (s,a) -> Just a
>                      Nothing    -> Nothing
>
> test n = runSME (nQueens n) []

By the way, here's a non-monadic version that generates ALL the solutions:

> queens :: Int -> [[Int]]
> queens n = loop n
>   where loop 0 = [[]]
>         loop m = [ p : ys | ys <- loop (m-1), p <- [1..n], safe' p ys 1]
>
> safe' :: Int -> [Int] -> Int -> Bool
> safe' p [] n = True
> safe' p (y:ys) n = and [ p/=y, p/=y+n, p/=y-n, safe' p ys (n+1)]

How can we generate all solutions using a monad?  Stated another way, why 
is the first solution generated, instead of some other?  (To generate any
solution would amount to non-determinism.)

Whether we think of all of the solutions or any of them, we can simulate
the effect by using a LIST of results instead of using the Maybe type.

> data SMN s a = SMN ( s -> [(s,a)] )
> 
> instance Monad (SMN s) where
>    return a = SMN $ \s -> [(s,a)]
>    SMN sm0 >>= fsm1 = SMN $ \s0 ->
>        do (s1,a1) <- sm0 s0           -- this code is exactly the same as
>           let SMN sm1 = fsm1 a1   -- for SME, except that we are in the
>           (s2,a2) <- sm1 s1       -- LIST monad instead of Maybe.
>           return (s2,a2)
>
> instance MonadPlus (SMN s) where
>    mzero = SMN $ \s -> []             -- no solution
>    SMN sm0 `mplus` SMN sm1 = SMN $ \s0 ->
>            sm0 s0 ++ sm1 s0           -- we want all of the solutions

This then leads to a version of n-Queens that returns ALL of the
solutions:

> getPlacesN :: SMN Board [Int]
> getPlacesN = SMN $ \ps -> [(ps,ps)]
> 
> placeN :: Int -> SMN Board ()
> placeN i = SMN $ \ps -> if safe i ps 1 then [(i:ps,())]
>                                        else []
> 
> nQueensN :: Int -> SMN Board [Int]
> nQueensN n = do loop n
>                 getPlacesN
>   where loop 0 = return ()
>         loop m = foldr mplus mzero
>                        [ placeN i >> loop (m-1) | i <- [1..n] ]
>
> runSMN :: SMN s a -> s -> [a]
> runSMN (SMN f) s = snd (unzip (f s))
>
> testN n = runSMN (nQueensN n) []


3. Exercise 19.2 in SOE.

   Define the following useful commands, not as extensions to the
   underlying implementation, but in terms of exsiting IRL commands:

   repeat :: Robot Bool -> Robot () -> Robot ()
   is just like "while", except that it executes its second argument
   at least once before checking the conditional.

   blockedLeft, blockedRight, blockedBehind :: Robot Bool
   that determine if the robot is blocked to the left, to the right,
   and behind, respectively.

   wallFollowLeft, wallFollowRight :: Robot ()
   that cause the robot to follow a wall that is immediately to the left
   or right, respectively.  If the robot becomes blocked or the wall
   dissappears, it should stop at that point.

Solution:

> repeat :: Robot Bool -> Robot () -> Robot ()
> repeat p b = b >> while p b
> 
> blockedLeft :: Robot Bool
> blockedLeft = do
>   turnLeft
>   b <- blocked
>   turnRight
>   return b
> 
> blockedRight' :: Robot Bool
> blockedRight' = do
>   turnRight
>   b <- blocked
>   turnLeft
>   return b
>
> blockedBehind :: Robot Bool
> blockedBehind = do
>   turnRight; turnRight
>   b <- blocked
>   turnLeft; turnLeft
>   return b
> 
> wallFollowLeft :: Robot ()
> wallFollowLeft =
>   cond1 blockedLeft $
>     do move
>        wallFollowLeft
> 
> wallFollowRight' :: Robot ()
> wallFollowRight' =
>   cond1 blockedRight $
>     do move
>        wallFollowRight'


4. Exercise 19.3 in SOE.

   Implement the following commands as primitives:

   getPosition :: Robot Point
   returns the current position of the robot.

   goToPosition :: Point -> Robot ()
   causes the robot to be "teleported" immediately to the given position.

   blockedLeft, blockedRight, blockedBehind :: Robot Bool
   as described in the previous exercise.

Solution:

> getPosition :: Robot Position
> getPosition = queryState position
>
> goToPosition :: Position -> Robot ()
> goToPosition p = updateState (\s -> s { position = p })

> primBlockedLeft :: Robot Bool
> primBlockedLeft = Robot $ \s g _ ->
>                     return (s, left (facing s) `notElem` 
>                                     (g `at` position s))
> 
> primBlockedRight :: Robot Bool
> primBlockedRight = Robot $ \s g _ ->
>                      return (s, right (facing s) `notElem`
>                                       (g `at` position s))
>
> primBlockedBehind :: Robot Bool
> primBlockedBehind = Robot $ \s g _ ->
>                     return (s, left (left (facing s)) `notElem`
>                                     (g `at` position s))


5. Exercise 19.4, part 1.
       
   Modify the `spiral` program given at the beginning of this chapter
   so that it picks up coins as it finds them, and then distributes
   them evenly along the top of the grid once the spiral is complete.
   Create a grid with a number of gold coins scattered about, and test
   your program on it.

Solution:

> tidyUp :: Robot ()
> tidyUp = do
>   getAllCoins
>   goToPosition (-20,20)
>   setPenColor Red
>   distributeCoins East
> 
> getAllCoins :: Robot ()
> getAllCoins = penDown >> pickCoin >> loop 1
>   where loop n =
>           let twice = do turnRight
>                          movePickn n
>                          turnRight
>                          movePickn n
>           in cond blocked 
>                (twice >> turnRight >> moven n)
>                (twice >> loop (n+1))
> 
> movePickn :: Int -> Robot ()
> movePickn n = mapM_ (const (move >> pickCoin)) [1..n]
>
> distributeCoins :: Direction -> Robot ()
> distributeCoins d = do
>   turnTo d
>   while ((coins >* return 0) &&* isnt blocked)
>         (dropCoin >> move)
>   dropCoin
>   turnTo South
>   move
>   cond1 (coins >* return 0) (distributeCoins (left (left d)))

> main = runRobot tidyUp s g0
>
> s :: RobotState
> s = RobotState { position = (0,0)
>                , pen      = False
>                , color    = Blue
>                , facing   = North
>                , treasure = tr0
>                , pocket   = 0
>                }
>
> tr0 :: [Position]
> tr0 = tr ++ map (\(x,y)->(-x,-y)) tr