refactored to use Data.Lens

chapter2/prob26.hs

@@ -1,9 +1,12 @@
+module AI.Vacuum.TableLookupAgent where
+
 import AI.Vacuum
 import Control.Monad.State
+import Data.Lens.Common
 import Data.Maybe (isJust, isNothing, fromJust)
 
 -- Problem 2.6
-  
+
 possiblePerceptsHistories :: [PerceptsHistory]
 possiblePerceptsHistories = takeWhile ((<= 9) . length) $
   [[]] : [[PhotoSensor]] : concatMap (\s -> [[] : s, [PhotoSensor] : s]) possiblePerceptsHistories
@@ -16,19 +19,19 @@ possiblePerceptsHistories = takeWhile ((<= 9) . length) $
 -- X -> X
 
 chooseAction :: PerceptsHistory -> Maybe Action
-chooseAction ph = 
+chooseAction ph =
   case ph of
     [] -> Just GoForward
     [[]] -> Just TurnRight
     [[PhotoSensor]] -> Just SuckDirt
-    (p:ps) -> 
+    (p:ps) ->
       case lookup ps perceptsHistoryToActionMap of
         Just (Just prevAction) -> chooseAction' ph prevAction
-        _ -> Nothing                             
+        _ -> Nothing
 
 chooseAction' :: PerceptsHistory -> Action -> Maybe Action
 chooseAction' ph prevAction
-  | prevAction == TurnRight || prevAction == TurnLeft = 
+  | prevAction == TurnRight || prevAction == TurnLeft =
     case head ph of
       [] -> Just GoForward
       [PhotoSensor] -> Nothing
@@ -41,58 +44,57 @@ chooseAction' ph prevAction
       [] -> 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, 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, 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, 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, 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, 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, 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, 0) Home, Cell (1, 0) Dirt,
   Cell (0, 1) Empty, Cell (1, 1) Dirt
   ]
 
 runCleaner :: Cleaner -> State Grid Cleaner
-runCleaner cleaner@(Cleaner _ _ _ ph _) = do
+runCleaner cleaner = do
-  case chooseAction ph of
+  case chooseAction $ cleaner^.perceptsHist of
     Just action -> do
-      cleaner <- doAction action cleaner
+      cleaner' <- doAction action cleaner
-      let ph = clPrcptsHist cleaner
+      if InfraredSensor `elem` (head $ cleaner'^.perceptsHist)
-      if InfraredSensor `elem` (head ph)
+        then doAction TurnOff cleaner'
-        then doAction TurnOff cleaner
+        else runCleaner cleaner'
-        else runCleaner cleaner
     _ -> doAction TurnOff cleaner
-      
+
 simulateOnGrid :: Grid -> (Cleaner, Grid)
-simulateOnGrid grid = 
+simulateOnGrid grid =
   runState (runCleaner cleaner) grid
-  where cleaner = createCleaner (fromJust $ cell (0, 0) grid) East
+  where cleaner = createCleaner (fromJust $ lookupCell (0, 0) grid) East

chapter2/prob27.hs

@@ -33,4 +33,3 @@ makeGrid minMaxWidth minMaxHeight dirtProb = do
     (\m p -> makeCell p dirtProb >>= \c -> return $ M.insert p c m)
     (M.singleton (0,0) (Cell (0,0) Home))
     [(x,y) | x <- range (0, width - 1), y <- range (0, height -1), (x,y) /= (0,0)]
-

chapter2/prob28.hs

@@ -1,5 +1,8 @@
+module AI.Vacuum.ReflexAgent where
+
 import AI.Vacuum
 import AI.Vacuum.RandomGrid
+import Data.Lens.Common
 import Control.Monad.State
 import Control.Monad.Identity
 import System.Random
@@ -24,12 +27,13 @@ chooseAction percepts
         | otherwise = return GoForward
 
 runCleaner :: Int -> Cleaner -> StateT Grid RandomState Cleaner
-runCleaner turnsLeft cleaner@(Cleaner _ _ _ ph _) =
+runCleaner turnsLeft cleaner =
   if turnsLeft == 1
     then do
     cleaner' <- doAction TurnOff cleaner
     return cleaner'
     else do
+      let ph = cleaner^.perceptsHist
       cleaner'' <- case ph of
         [] -> do
           cleaner' <- doAction GoForward cleaner
@@ -39,11 +43,11 @@ runCleaner turnsLeft cleaner@(Cleaner _ _ _ ph _) =
           cleaner' <- doAction action cleaner
           return cleaner'
 
-      case clState cleaner'' of
+      case cleaner''^.state of
         Off -> return cleaner''
         On -> runCleaner (turnsLeft - 1) cleaner''
 
 simulateOnGrid :: Int -> Grid -> StdGen -> (Cleaner, Grid)
 simulateOnGrid maxTurns grid gen =
   evalState (runStateT (runCleaner maxTurns cleaner) grid) gen
-  where cleaner = createCleaner (fromJust $ cell (0,0) grid) East
+  where cleaner = createCleaner (fromJust $ lookupCell (0,0) grid) East

chapter2/vacuum.hs

@@ -1,10 +1,14 @@
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleContexts, TemplateHaskell #-}
 
 module AI.Vacuum where
 
 import qualified Data.Map as M
 import Control.Monad.State
+import Prelude hiding (id, (.))
+import Control.Category
 import Data.Maybe (isJust, isNothing, fromJust)
+import Data.Lens.Common
+import Data.Lens.Template
 import System.IO.Unsafe (unsafePerformIO)
 import Debug.Trace (putTraceMsg)
 
@@ -21,20 +25,24 @@ data Action = GoForward | TurnRight | TurnLeft | SuckDirt | TurnOff deriving (Eq
 data CellType = Empty | Furniture | Dirt | Home deriving (Eq, Show)
 
 type Point = (Int, Int)
-data Cell = Cell Point CellType deriving (Eq, Show)
+data Cell = Cell { _point :: Point, _cellType :: 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,
+    _state :: CleanerState,
-    clCell :: Cell,
+    _cell :: Cell,
-    clDir :: Direction,
+    _direction :: Direction,
-    clPrcptsHist :: PerceptsHistory,
+    _path :: [Point],
-    clScore :: Score
+    _perceptsHist :: PerceptsHistory,
+    _actionHist :: [Action],
+    _score :: Score
     } deriving (Show)
 
+makeLenses [''Cell, ''Cleaner]
+
 class (Enum a, Eq a, Bounded a) => WrappedBoundedEnum a where
   next :: a -> a
   prev :: a -> a
@@ -68,60 +76,68 @@ 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
+lookupCell :: Point -> Grid -> Maybe Cell
-cell = M.lookup
+lookupCell = M.lookup
 
 forwardCell :: Cell -> Direction -> Grid -> Maybe Cell
-forwardCell (Cell point _) dir grid = cell (forwardPoint point dir) grid
+forwardCell (Cell point _) = lookupCell . (forwardPoint point)
 
 rightCell :: Cell -> Direction -> Grid -> Maybe Cell
-rightCell (Cell point _) dir grid = cell (rightPoint point dir) grid
+rightCell (Cell point _) = lookupCell . (rightPoint point)
 
 leftCell :: Cell -> Direction -> Grid -> Maybe Cell
-leftCell (Cell point _) dir grid = cell (leftPoint point dir) grid
+leftCell (Cell point _) = lookupCell . (leftPoint point)
 
 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
+createCleaner cell dir = Cleaner On cell dir [cell^.point] [] [] 0
+
+setPercepts percepts = perceptsHist ^%= (percepts :)
 
 turnRight :: (MonadState Grid m) => Cleaner -> m Cleaner
-turnRight (Cleaner state cell dir ph score) =
+turnRight = return . (direction ^%= right) . (setPercepts [])
-  return $ Cleaner state cell (right dir) ([] : ph) score
 
 turnLeft :: (MonadState Grid m) => Cleaner -> m Cleaner
-turnLeft (Cleaner state cell dir ph score) =
+turnLeft = return . (direction ^%= left) . (setPercepts [])
-  return $ Cleaner state cell (left dir) ([] : ph) score
 
 moveForward :: (MonadState Grid m) => Cleaner -> m Cleaner
-moveForward cleaner@(Cleaner state cell@(Cell _ cellType) dir ph score) = do
+moveForward cleaner = do
   grid <- get
-  return $
+  return .
-    case forwardCell cell dir grid of
+    case forwardCell (cleaner^.cell) (cleaner^.direction) grid of
-      Nothing -> Cleaner state cell dir ([TouchSensor] : ph) score
+      Nothing -> setPercepts [TouchSensor]
-      Just nextCell@(Cell _ nextCellType) ->
+      Just nextCell@(Cell nextPoint nextCellType) ->
+        let setNextCellPoint = (cell ^= nextCell) . (path ^%= (nextPoint :)) in
         case nextCellType of
-          Empty -> Cleaner state nextCell dir ([] : ph) score
+          Empty -> setNextCellPoint . (setPercepts [])
-          Furniture -> Cleaner state cell dir ([TouchSensor] : ph) score
+          Furniture -> setPercepts [TouchSensor]
-          Dirt -> Cleaner state nextCell dir ([PhotoSensor] : ph) score
+          Dirt -> setNextCellPoint . (setPercepts [PhotoSensor])
-          Home -> Cleaner state nextCell dir ([InfraredSensor] : ph) score
+          Home -> setNextCellPoint . (setPercepts [InfraredSensor])
+    $ cleaner
+
+suckDirt :: (MonadState Grid m) => Cleaner -> m Cleaner
+suckDirt cleaner = do
+  let point' = (cleaner^.cell)^.point
+  grid <- get
+  put $ M.insert point' (Cell point' Empty) grid
+  return cleaner
 
 doAction :: (MonadState Grid m) => Action -> Cleaner -> m Cleaner
-doAction action cleaner@(Cleaner state cell@(Cell point cellType) dir ph score) =
+doAction action cleaner = do
   case action of
-    GoForward -> moveForward $ Cleaner state cell dir ph (score - 1)
+    GoForward -> moveForward
-    TurnRight -> turnRight $ Cleaner state cell dir ph (score - 1)
+    TurnRight -> turnRight
-    TurnLeft -> turnLeft $ Cleaner state cell dir ph (score - 1)
+    TurnLeft -> turnLeft
     SuckDirt ->
-      case cellType of
+      (if cellType' == Dirt then suckDirt . (score ^%= (+ 100)) else return)
-        Dirt -> do
+      . (setPercepts [])
-          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
+      return . (state ^= Off) . (setPercepts [])
-        Home -> return $ Cleaner Off cell dir ([] : ph) score
+      . (if cellType' == Home then id else score ^%= (subtract 1000))
-        otherwise -> return $ Cleaner Off cell dir ([] : ph) (score - 1000)
+  . (score ^%= subtract 1)
-
+  . (actionHist ^%= (action :))
+  $ cleaner
+  where
+    cellType' = (cleaner^.cell)^.cellType