From 2b425ec62d3799fb1f11fcd3e6fe55eda38cdecb Mon Sep 17 00:00:00 2001
From: Abhinav Sarkar <abhinav.sarkar@gmail.com>
Date: Tue, 4 Oct 2011 17:04:22 +0530
Subject: [PATCH] Solved problem 2.6

---
 chapter2/prob26.hs |  98 +++++++++++++++++++++++++++++++++++
 chapter2/vacuum.hs | 125 +++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 223 insertions(+)
 create mode 100644 chapter2/prob26.hs
 create mode 100644 chapter2/vacuum.hs

diff --git a/chapter2/prob26.hs b/chapter2/prob26.hs
new file mode 100644
index 0000000..3784e2f
--- /dev/null
+++ b/chapter2/prob26.hs
@@ -0,0 +1,98 @@
+import AI.Vacuum
+import Control.Monad.State
+import Data.Maybe (isJust, isNothing, fromJust)
+
+-- Problem 2.6
+  
+possiblePerceptsHistories :: [PerceptsHistory]
+possiblePerceptsHistories = takeWhile ((<= 9) . length) $
+  [[]] : [[PhotoSensor]] : concatMap (\s -> [[] : s, [PhotoSensor] : s]) possiblePerceptsHistories
+
+-- 0 -> t
+-- 1 -> s
+-- t -> 0 -> m | 1 -> X
+-- s -> 0 -> t | 1 -> X
+-- m -> 0 -> t | 1 -> s
+-- X -> X
+
+chooseAction :: PerceptsHistory -> Maybe Action
+chooseAction ph = 
+  case ph of
+    [] -> Just GoForward
+    [[]] -> Just TurnRight
+    [[PhotoSensor]] -> Just SuckDirt
+    (p:ps) -> 
+      case lookup ps perceptsHistoryToActionMap of
+        Just (Just prevAction) -> chooseAction' ph prevAction
+        _ -> Nothing                             
+
+chooseAction' :: PerceptsHistory -> Action -> Maybe Action
+chooseAction' ph prevAction
+  | prevAction == TurnRight || prevAction == TurnLeft = 
+    case head ph of
+      [] -> Just GoForward
+      [PhotoSensor] -> Nothing
+  | prevAction == SuckDirt =
+    case head ph of
+      [] -> Just TurnRight
+      [PhotoSensor] -> Nothing
+  | prevAction == GoForward =
+    case head ph of
+      [] -> Just TurnRight
+      [PhotoSensor] -> Just SuckDirt
+  | prevAction == TurnOff = error "Cannot move after turnoff"
+                  
+perceptsHistoryToActionMap :: [(PerceptsHistory, Maybe Action)]
+perceptsHistoryToActionMap =
+  map (\ph -> (ph, chooseAction ph)) possiblePerceptsHistories
+
+grid1 = gridFromCellList [
+  Cell (0, 0) Home, Cell (1, 0) Empty, 
+  Cell (0, 1) Empty, Cell (1, 1) Empty
+  ]
+
+grid2 = gridFromCellList [
+  Cell (0, 0) Home, Cell (1, 0) Dirt, 
+  Cell (0, 1) Empty, Cell (1, 1) Empty
+  ]
+
+grid3 = gridFromCellList [
+  Cell (0, 0) Home, Cell (1, 0) Empty, 
+  Cell (0, 1) Dirt, Cell (1, 1) Empty
+  ]
+
+grid4 = gridFromCellList [
+  Cell (0, 0) Home, Cell (1, 0) Empty, 
+  Cell (0, 1) Empty, Cell (1, 1) Dirt
+  ]
+
+grid5 = gridFromCellList [
+  Cell (0, 0) Home, Cell (1, 0) Dirt, 
+  Cell (0, 1) Dirt, Cell (1, 1) Empty
+  ]
+
+grid6 = gridFromCellList [
+  Cell (0, 0) Home, Cell (1, 0) Empty, 
+  Cell (0, 1) Dirt, Cell (1, 1) Dirt
+  ]
+
+grid7 = gridFromCellList [
+  Cell (0, 0) Home, Cell (1, 0) Dirt, 
+  Cell (0, 1) Empty, Cell (1, 1) Dirt
+  ]
+
+runCleaner :: Cleaner -> State Grid Cleaner
+runCleaner cleaner@(Cleaner _ _ _ ph _) = do
+  case chooseAction ph of
+    Just action -> do
+      cleaner <- doAction action cleaner
+      let ph = clPrcptsHist cleaner
+      if InfraredSensor `elem` (head ph)
+        then doAction TurnOff cleaner
+        else runCleaner cleaner
+    _ -> doAction TurnOff cleaner
+      
+simulateOnGrid :: Grid -> (Cleaner, Grid)
+simulateOnGrid grid = 
+  runState (runCleaner cleaner) grid
+  where cleaner = createCleaner (fromJust $ cell (0, 0) grid) East
\ No newline at end of file
diff --git a/chapter2/vacuum.hs b/chapter2/vacuum.hs
new file mode 100644
index 0000000..7caf5e1
--- /dev/null
+++ b/chapter2/vacuum.hs
@@ -0,0 +1,125 @@
+module AI.Vacuum where
+
+import qualified Data.Map as M
+import Control.Monad.State
+import Data.Maybe (isJust, isNothing, fromJust)
+import System.IO.Unsafe (unsafePerformIO)
+import Debug.Trace (putTraceMsg)
+
+trace :: String -> a -> a
+trace string expr = unsafePerformIO $ do
+    putTraceMsg string
+    return expr
+
+data Direction = North | East | South | West deriving (Eq, Show, Enum, Bounded)
+data Percept = TouchSensor | PhotoSensor | InfraredSensor deriving (Eq, Ord, Show)
+type Percepts = [Percept]
+type PerceptsHistory = [Percepts]
+data Action = GoForward | TurnRight | TurnLeft | SuckDirt | TurnOff deriving (Eq, Show)
+data CellType = Empty | Furniture | Dirt | Home deriving (Eq, Show)
+
+type Point = (Int, Int)
+data Cell = Cell Point CellType deriving (Eq, Show)
+type Grid = M.Map Point Cell
+
+data CleanerState = On | Off deriving (Eq, Show)
+type Score = Int
+data Cleaner = 
+  Cleaner { 
+    clState :: CleanerState, 
+    clCell :: Cell, 
+    clDir :: Direction, 
+    clPrcptsHist :: PerceptsHistory, 
+    clScore :: Score 
+    } deriving (Show)
+
+class (Enum a, Eq a, Bounded a) => WrappedBoundedEnum a where
+  next :: a -> a
+  prev :: a -> a
+
+  next x = if (maxBound == x) then minBound else succ x
+  prev x = if (minBound == x) then maxBound else pred x
+
+instance WrappedBoundedEnum Direction
+
+right :: Direction -> Direction
+right = next
+
+left :: Direction -> Direction
+left = prev
+
+forwardPoint :: Point -> Direction -> Point
+forwardPoint (x, y) North = (x, y - 1)
+forwardPoint (x, y) East = (x + 1, y)
+forwardPoint (x, y) South = (x, y + 1)
+forwardPoint (x, y) West = (x - 1, y)
+
+rightPoint :: Point -> Direction -> Point
+rightPoint (x, y) North = (x + 1, y)
+rightPoint (x, y) East = (x, y + 1)
+rightPoint (x, y) South = (x - 1, y)
+rightPoint (x, y) West = (x, y - 1)
+
+leftPoint :: Point -> Direction -> Point
+leftPoint (x, y) North = (x -1, y)
+leftPoint (x, y) East = (x, y - 1)
+leftPoint (x, y) South = (x + 1, y)
+leftPoint (x, y) West = (x, y + 1)
+
+cell :: Point -> Grid -> Maybe Cell
+cell = M.lookup
+
+forwardCell :: Cell -> Direction -> Grid -> Maybe Cell
+forwardCell (Cell point _) dir grid = cell (forwardPoint point dir) grid
+
+rightCell :: Cell -> Direction -> Grid -> Maybe Cell
+rightCell (Cell point _) dir grid = cell (rightPoint point dir) grid
+
+leftCell :: Cell -> Direction -> Grid -> Maybe Cell
+leftCell (Cell point _) dir grid = cell (leftPoint point dir) grid
+
+gridFromCellList :: [Cell] -> Grid
+gridFromCellList = foldl (\m cell@(Cell p _) -> M.insert p cell m) M.empty
+
+createCleaner :: Cell -> Direction -> Cleaner
+createCleaner cell dir = Cleaner On cell dir [] 0
+
+turnRight :: Cleaner -> State Grid Cleaner
+turnRight (Cleaner state cell dir ph score) =
+  return $ Cleaner state cell (right dir) ([] : ph) score
+
+turnLeft :: Cleaner -> State Grid Cleaner
+turnLeft (Cleaner state cell dir ph score) =
+  return $ Cleaner state cell (left dir) ([] : ph) score
+
+moveForward :: Cleaner -> State Grid Cleaner
+moveForward cleaner@(Cleaner state cell@(Cell _ cellType) dir ph score) = do
+  grid <- get
+  return $
+    case forwardCell cell dir grid of
+      Nothing -> Cleaner state cell dir ([TouchSensor] : ph) score
+      Just nextCell@(Cell _ nextCellType) ->
+        case nextCellType of
+          Empty -> Cleaner state nextCell dir ([] : ph) score
+          Furniture -> Cleaner state cell dir ([TouchSensor] : ph) score
+          Dirt -> Cleaner state nextCell dir ([PhotoSensor] : ph) score
+          Home -> Cleaner state nextCell dir ([InfraredSensor] : ph) score
+
+doAction :: Action -> Cleaner -> State Grid Cleaner
+doAction action cleaner@(Cleaner state cell@(Cell point cellType) dir ph score) =
+  case action of
+    GoForward -> moveForward $ Cleaner state cell dir ph (score - 1)
+    TurnRight -> turnRight $ Cleaner state cell dir ph (score - 1)
+    TurnLeft -> turnLeft $ Cleaner state cell dir ph (score - 1)
+    SuckDirt ->
+      case cellType of
+        Dirt -> do
+          grid <- get
+          put $ M.insert point (Cell point Empty) grid
+          return $ Cleaner state cell dir ([] : ph) (score + 99)
+        otherwise -> return $ Cleaner state cell dir ([] : ph) (score - 1)
+    TurnOff ->
+      case cellType of
+        Home -> return $ Cleaner Off cell dir ([] : ph) score
+        otherwise -> return $ Cleaner state cell dir ([] : ph) (score - 1000)
+