Solved problem 2.9: added stateful reflex agent

chapter2/.gitignore

@@ -1,2 +1,3 @@
 build
 ReflexAgent
+StatefulReflexAgent

chapter2/AI/Vacuum/Cleaner.hs

@@ -5,6 +5,7 @@ module AI.Vacuum.Cleaner where
 import AI.Vacuum.Grid
 import qualified Data.Map as M
 import qualified Data.Set as S
+import qualified Data.List as L
 import Control.Monad.State
 import Data.Ix (range)
 import Data.Maybe (fromJust, fromMaybe)
@@ -111,13 +112,31 @@ printPath cleaner grid = do
   let height = gridHeight grid
   let points = S.fromList $ cleaner^.path
 
-  forM_ (range (0, width - 1)) $ \x -> do
-    forM_ (range (0, height - 1)) $ \y -> do
+  forM_ (range (0, height - 1)) $ \y -> do
+    forM_ (range (0, width - 1)) $ \x -> do
       let cell = fromJust . lookupCell (x,y) $ grid
       if S.member (cell^.point) points
-        then putStr "- "
+        then putStr $ showPoint (cell^.point)
         else putStr . showCell $ cell
     putStrLn ""
+  where
+    cleanerPath = cleaner^.path
+    nextPoint p =
+      case L.elemIndex p $ cleanerPath of
+        Nothing -> Nothing
+        Just i | i == 0 -> Nothing
+        Just i -> Just $ cleanerPath !! (i - 1)
+    showPoint p =
+      case nextPoint p of
+        Nothing -> "- "
+        Just np ->
+          case orientation p np of
+            (Nothing, Nothing) -> "- "
+            (Just East, Nothing) -> "> "
+            (Just West, Nothing) -> "< "
+            (Nothing, Just South) -> "v "
+            (Nothing, Just North) -> "^ "
+            _ -> "- "
 
 printRunStats :: Cleaner -> Grid -> IO ()
 printRunStats cleaner grid = do

chapter2/AI/Vacuum/Grid.hs

@@ -3,6 +3,7 @@
 module AI.Vacuum.Grid where
 
 import qualified Data.Map as M
+import qualified Data.List as L
 import Data.Maybe (fromJust)
 import Data.Ix (range)
 import Control.Monad (forM_)
@@ -19,6 +20,7 @@ trace string expr = unsafePerformIO $ do
 data Direction = North | East | South | West deriving (Eq, Show, Enum, Bounded)
 data CellType = Empty | Furniture | Dirt | Home deriving (Eq, Show, Ord)
 type Point = (Int, Int)
+type Path = [Point]
 data Cell = Cell { _point :: Point, _cellType :: CellType } deriving (Eq, Show)
 type Grid = M.Map Point Cell
 
@@ -45,6 +47,12 @@ forwardPoint (x, y) East = (x + 1, y)
 forwardPoint (x, y) South = (x, y + 1)
 forwardPoint (x, y) West = (x - 1, y)
 
+backwardPoint :: Point -> Direction -> Point
+backwardPoint (x, y) North = (x, y + 1)
+backwardPoint (x, y) East = (x - 1, y)
+backwardPoint (x, y) South = (x, y - 1)
+backwardPoint (x, y) West = (x + 1, y)
+
 rightPoint :: Point -> Direction -> Point
 rightPoint (x, y) North = (x + 1, y)
 rightPoint (x, y) East = (x, y + 1)
@@ -57,6 +65,52 @@ leftPoint (x, y) East = (x, y - 1)
 leftPoint (x, y) South = (x + 1, y)
 leftPoint (x, y) West = (x, y + 1)
 
+orientation :: Point -> Point -> (Maybe Direction, Maybe Direction)
+orientation from@(x1, y1) to@(x2, y2)
+  | from == to = (Nothing, Nothing)
+  | y1 == y2 && x2 > x1 = (Just East, Nothing)
+  | y1 == y2 && x2 < x1 = (Just West, Nothing)
+  | x1 == x2 && y2 > y1 = (Nothing, Just South)
+  | x1 == x2 && y2 < y1 = (Nothing, Just North)
+  | y2 < y1 && x2 > x1 = (Just East, Just North)
+  | y2 < y1 && x2 < x1 = (Just West, Just North)
+  | y2 > y1 && x2 > x1 = (Just East, Just South)
+  | y2 > y1 && x2 < x1 = (Just West, Just South)
+
+horzPath :: Point -> Point -> [Point]
+horzPath p1@(x1, y1) p2@(x2, _)
+  | x1 <= x2 = map (\x -> (x, y1)) $ range (x1, x2)
+  | otherwise = reverse . map (\x -> (x, y1)) $ range (x2, x1)
+
+vertPath :: Point -> Point -> [Point]
+vertPath p1@(x1, y1) p2@(_, y2)
+  | y1 <= y2 = map (\y -> (x1, y)) $ range (y1, y2)
+  | otherwise = reverse . map (\y -> (x1, y)) $ range (y2, y1)
+
+manhattanPaths :: Point -> Point -> [[Point]]
+manhattanPaths p1@(x1,y1) p2@(x2,y2)
+  | p1 == p2 = []
+  | otherwise = [L.nub (hp1 ++ vp1), L.nub (vp2 ++ hp2)]
+    where
+      hp1 = horzPath p1 p2
+      vp1 = vertPath (last hp1) p2
+      vp2 = vertPath p1 p2
+      hp2 = horzPath (last vp2) p2
+
+cornerPoints :: Point -> Int -> [Point]
+cornerPoints (x,y) distance =
+  [(x + distance, y + distance),
+   (x - distance, y + distance),
+   (x - distance, y - distance),
+   (x + distance, y - distance)]
+
+borderingPoints :: Point -> Int -> [Point]
+borderingPoints point distance =
+  L.nub . concat
+  . map (\(p1@(_,y1), p2@(_,y2)) ->
+          if y1 == y2 then horzPath p1 p2 else vertPath p1 p2)
+  . pairs . take 5 . cycle $ cornerPoints point distance
+
 lookupCell :: Point -> Grid -> Maybe Cell
 lookupCell = M.lookup
 
@@ -75,6 +129,11 @@ gridFromCellList = foldl (\m cell@(Cell p _) -> M.insert p cell m) M.empty
 freqMap :: (Ord a) => [a] -> [(a, Int)]
 freqMap = M.toList . foldl (\m t -> M.insertWith (+) t 1 m) M.empty
 
+pairs :: [a] -> [(a,a)]
+pairs [] = []
+pairs [_] = []
+pairs (x1 : x2 : xs) = (x1, x2) : pairs (x2 : xs)
+
 gridWidth :: Grid -> Int
 gridWidth = (+ 1) . maximum . map fst . M.keys
 
@@ -97,7 +156,7 @@ printGrid grid = do
   let width = gridWidth grid
   let height = gridHeight grid
 
-  forM_ (range (0, width - 1)) $ \x -> do
-    forM_ (range (0, height - 1)) $ \y ->
+  forM_ (range (0, height - 1)) $ \y -> do
+    forM_ (range (0, width - 1)) $ \x ->
       putStr . showCell . fromJust . lookupCell (x,y) $ grid
     putStrLn ""

chapter2/AI/Vacuum/ReflexAgent.hs

@@ -1,4 +1,4 @@
-module AI.Vacuum.ReflexAgent where
+module AI.Vacuum.ReflexAgent (simulateOnGrid, printSimulation) where
 
 import AI.Vacuum.Cleaner
 import AI.Vacuum.Grid
@@ -35,36 +35,27 @@ runCleaner turnsLeft cleaner =
     return cleaner'
     else do
       let ph = cleaner^.perceptsHist
-      cleaner'' <- case ph of
-        [] -> do
-          cleaner' <- doAction GoForward cleaner
-          return cleaner'
+      cleaner' <- case ph of
+        [] -> doAction GoForward cleaner
         _ -> do
           action <- lift $ chooseAction (head ph)
-          cleaner' <- doAction action cleaner
-          return cleaner'
-
-      case cleaner''^.state of
-        Off -> return cleaner''
-        On -> runCleaner (turnsLeft - 1) cleaner''
+          doAction action cleaner
+      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 $ lookupCell (0,0) grid) East
 
-main :: IO ()
-main = do
+printSimulation :: Int -> Int -> Int -> Float -> Bool -> IO ()
+printSimulation
+  minSize maxSize maxTurns dirtProb toPrintGrid = do
   gen <- newStdGen
-  args <- getArgs
-  let minSize = (read $ args !! 0) :: Int
-  let maxSize = (read $ args !! 1) :: Int
-  let dirtProb = (read $ args !! 2) :: Float
-  let maxTurns = (read $ args !! 3) :: Int
-  let toPrintGrid = (read $ args !! 4) :: Bool
-
   let grid = evalState
-             (makeRandomGrid (minSize,maxSize) (minSize,maxSize) dirtProb 0.0) gen
+             (makeRandomGrid (minSize,maxSize) (minSize,maxSize) dirtProb 0.0)
+             gen
 
   when toPrintGrid $ do
     putStrLn "Grid before traversal"
@@ -79,3 +70,14 @@ main = do
     putStrLn ""
 
   printRunStats cleaner grid
+
+main :: IO ()
+main = do
+  args <- getArgs
+  let minSize = (read $ args !! 0) :: Int
+  let maxSize = (read $ args !! 1) :: Int
+  let dirtProb = (read $ args !! 2) :: Float
+  let maxTurns = (read $ args !! 3) :: Int
+  let toPrintGrid = (read $ args !! 4) :: Bool
+
+  printSimulation minSize maxSize maxTurns dirtProb toPrintGrid

chapter2/AI/Vacuum/StatefulReflexAgent.hs

@@ -0,0 +1,242 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module AI.Vacuum.StatefulReflexAgent where
+
+import AI.Vacuum.Grid
+import AI.Vacuum.Cleaner hiding (doAction)
+import qualified AI.Vacuum.Cleaner (doAction)
+import AI.Vacuum.RandomGrid
+import qualified Data.Map as M
+import qualified Data.List as L
+import Data.Maybe (fromMaybe, fromJust)
+import Data.Lens.Common
+import Data.Ix (range)
+import Control.Monad.State
+import System.Random
+import System (getArgs)
+
+data PointState = Unreachable | Explored | Unexplored deriving (Eq, Ord, Show)
+type GridState = M.Map Point PointState
+
+updateGridState :: Point -> PointState -> GridState -> GridState
+updateGridState point pointState gridState =
+  let gridState' = M.insert point pointState gridState in
+  case point of
+    (0, 0) ->
+      foldl (\m p -> M.insert p Unreachable m) gridState' [(-1, 0), (0, -1), (-1, -1)]
+    (0, y) -> M.insert (-1, y) Unreachable gridState'
+    (x, 0) -> M.insert (x, -1) Unreachable gridState'
+    _ -> gridState'
+
+createGridState :: Cleaner -> GridState
+createGridState cleaner = updateGridState ((cleaner^.cell)^.point) Explored M.empty
+
+getPointState point = fromMaybe Unexplored . M.lookup point
+
+getCellState :: (Point -> Direction -> Point)
+                 -> Cell -> Direction -> GridState -> PointState
+getCellState pointFn cell direction = getPointState (pointFn (cell^.point) direction)
+
+leftCellState :: Cell -> Direction -> GridState -> PointState
+leftCellState = getCellState leftPoint
+
+rightCellState :: Cell -> Direction -> GridState -> PointState
+rightCellState = getCellState rightPoint
+
+forwardCellState :: Cell -> Direction -> GridState -> PointState
+forwardCellState = getCellState forwardPoint
+
+backwardCellState :: Cell -> Direction -> GridState -> PointState
+backwardCellState = getCellState backwardPoint
+
+doAction :: (MonadState Grid m) => Action -> Cleaner -> GridState -> m (Cleaner, GridState)
+doAction action cleaner gridState = do
+  cleaner' <- AI.Vacuum.Cleaner.doAction action cleaner
+  let gridState' =
+        if action == GoForward
+        then if TouchSensor `elem` (head (cleaner'^.perceptsHist))
+             then updateGridState (nextPoint cleaner') Unreachable gridState
+             else updateGridState ((cleaner'^.cell)^.point) Explored gridState
+        else gridState
+  return (cleaner', gridState')
+  where
+    nextPoint cl = forwardPoint ((cl^.cell)^.point) (cl^.direction)
+
+possibleManhattanPaths :: [Path] -> GridState -> [Path]
+possibleManhattanPaths paths gridState
+  | paths == [] = []
+  | otherwise =
+    filter (L.all (== Explored)
+            . map (\p -> getPointState p gridState)
+            . filter (\p -> p `notElem` [p1, p2]))
+    paths
+    where
+      p1 = head . head $ paths
+      p2 = last . head $ paths
+
+nearestUnexploredPoint :: Point -> Int -> GridState -> Maybe (Point, Path)
+nearestUnexploredPoint point maxDist gridState = do
+  np <- L.find (\(p,ps) -> ps == Unexplored && pathExists p)
+           $ map (\p -> (p, getPointState p gridState))
+           $ concatMap (borderingPoints point) [1..maxDist]
+  return ((fst np), (head . paths . fst $ np))
+  where
+    paths p = possibleManhattanPaths (manhattanPaths point p) gridState
+    pathExists p = (/= 0) . length . paths $ p
+
+actionsByRelDirection = [
+  ("f", [GoForward]),
+  ("l", [TurnLeft, GoForward]),
+  ("r", [TurnRight, GoForward]),
+  ("b", [TurnLeft, TurnLeft, GoForward])]
+
+relDirectionToDirection relDir dir =
+  case relDir of
+    "f" -> dir
+    "l" -> left dir
+    "r" -> right dir
+    "b" -> right . right $ dir
+
+moveActions :: (Point, Point) -> Direction -> ([Action], Direction)
+moveActions (p1, p2) dir =
+  (\rd ->
+    (fromJust . lookup rd $ actionsByRelDirection,
+     relDirectionToDirection rd dir))
+  $ fst
+  $ fromJust
+  $ L.find (\(d, p) -> p == p2)
+  $ zip ["f", "l", "r", "b"]
+  $ map (\pfn -> pfn p1 dir)
+  $ [forwardPoint, leftPoint, rightPoint, backwardPoint]
+
+pathActions :: Direction -> Path -> [Action]
+pathActions dir path =
+  fst
+  . foldl
+  (\(as, d) ps -> let (as', d') = moveActions ps d in (as ++ as', d'))
+  ([], dir)
+  . pairs
+  $ path
+
+chooseActions :: Cleaner -> GridState -> RandomState [Action]
+chooseActions cleaner gridState =
+  case cleaner^.perceptsHist of
+    [] -> return [GoForward]
+    (ps : _) | PhotoSensor `elem` ps -> return [SuckDirt]
+    (ps : _) | InfraredSensor `elem` ps -> return [TurnOff]
+    _ ->
+      if length unexplored == 0
+       then -- trace ("surrounded at " ++ show ((cleaner^.cell)^.point)) $
+        case nearestUnexploredPoint ((cleaner^.cell)^.point) 4 gridState of
+          Nothing -> do
+            r <- getRandomR ((0.0, 1.0) :: (Float, Float))
+            -- trace ("choosing on random: " ++ show r) $
+            case r of
+              r | r < 0.1 -> return [TurnRight]
+              r | r < 0.2 -> return [TurnLeft]
+              otherwise -> return [GoForward]
+          Just (nPoint, path) -> -- trace ("taking path: " ++ show path) $
+            return . pathActions (cleaner^.direction) $ path
+      else
+        return . fromJust . lookup (fst . head $ unexplored) $ actionsByRelDirection
+      where
+        gridStates =
+          zip ["f", "l", "r", "b"] $
+          map (\f -> f (cleaner^.cell) (cleaner^.direction) gridState)
+          [forwardCellState, leftCellState, rightCellState, backwardCellState]
+        unexplored = filter ((== Unexplored) . snd) gridStates
+
+runCleaner :: Int -> Cleaner -> GridState -> StateT Grid RandomState (Cleaner, GridState)
+runCleaner turnsLeft cleaner gridState =
+  if turnsLeft == 1
+    then do
+    (cleaner', gridState') <- doAction TurnOff cleaner gridState
+    return (cleaner', gridState')
+    else do
+    actions <- lift $ chooseActions cleaner gridState
+    (cleaner', gridState') <-
+      foldM
+      (\(cl, gs) a -> do
+          (cl', gs') <- doAction a cl gs
+          return (cl', gs'))
+      (cleaner, gridState)
+      actions
+
+    case cleaner'^.state of
+      Off -> return (cleaner', gridState')
+      On -> runCleaner (turnsLeft - (length actions)) cleaner' gridState'
+
+simulateOnGrid :: Int -> Grid -> StdGen -> (Cleaner, GridState, Grid)
+simulateOnGrid maxTurns grid gen =
+  let ((cleaner', gridState'), grid') =
+        evalState (runStateT (runCleaner maxTurns cleaner gridState) grid) gen in
+  (cleaner', gridState', grid')
+  where
+    cleaner = createCleaner (fromJust $ lookupCell (0,0) grid) East
+    gridState = createGridState cleaner
+
+printGridState :: GridState -> Grid -> IO ()
+printGridState gridState grid = do
+  let width = gridWidth grid
+  let height = gridHeight grid
+
+  forM_ (range (-1, height)) $ \y -> do
+    forM_ (range (-1, width)) $ \x -> do
+      case lookupCell (x,y) $ grid of
+        Nothing ->
+          case M.lookup (x,y) gridState of
+            Nothing -> putStr "! "
+            Just Unreachable -> putStr "/ "
+        Just cell ->
+          case M.lookup (cell^.point) gridState of
+            Nothing -> putStr "! "
+            Just pointState ->
+              case pointState of
+                Explored -> putStr "- "
+                Unexplored -> putStr "! "
+                Unreachable -> putStr "/ "
+    putStrLn ""
+
+printSimulation :: Int -> Int -> Int -> Float -> Float -> Bool -> IO ()
+printSimulation
+  minSize maxSize maxTurns dirtProb furnitureProb toPrintGrid = do
+  gen <- newStdGen
+  let grid = evalState
+             (makeRandomGrid (minSize,maxSize) (minSize,maxSize) dirtProb furnitureProb)
+             gen
+
+  when toPrintGrid $ do
+    putStrLn "Grid before traversal"
+    printGrid grid
+    putStrLn ""
+
+  let (cleaner, gridState', grid') = simulateOnGrid maxTurns grid gen
+
+  when toPrintGrid $ do
+    putStrLn "Grid after traversal"
+    printPath cleaner grid'
+    putStrLn ""
+
+  when toPrintGrid $ do
+    putStrLn "Grid state"
+    printGridState gridState' grid
+    putStrLn ""
+
+  printRunStats cleaner grid
+  putStrLn ("Grid Exploration stats = "
+            ++ (show . freqMap $
+                [fromMaybe Unexplored . M.lookup (x, y) $ gridState'
+                | x <- range (0, gridWidth grid - 1),
+                  y <- range(0, gridHeight grid - 1)]))
+
+main :: IO ()
+main = do
+  args <- getArgs
+  let minSize = (read $ args !! 0) :: Int
+  let maxSize = (read $ args !! 1) :: Int
+  let dirtProb = (read $ args !! 2) :: Float
+  let furnitureProb = (read $ args !! 3) :: Float
+  let maxTurns = (read $ args !! 4) :: Int
+  let toPrintGrid = (read $ args !! 5) :: Bool
+
+  printSimulation minSize maxSize maxTurns dirtProb furnitureProb toPrintGrid

chapter2/build-stateful-reflex-agent

@@ -0,0 +1 @@
+ghc -O2 -o StatefulReflexAgent --make -hidir build -odir build -main-is AI.Vacuum.StatefulReflexAgent AI/Vacuum/StatefulReflexAgent.hs AI/Vacuum/RandomGrid.hs AI/Vacuum/Cleaner.hs AI/Vacuum/Grid.hs