Browse Source

Solved problem 2.9: added stateful reflex agent

Abhinav Sarkar 9 years ago
parent
commit
643a75deb0

+ 1
- 0
chapter2/.gitignore View File

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

+ 22
- 3
chapter2/AI/Vacuum/Cleaner.hs View File

@@ -5,6 +5,7 @@ module AI.Vacuum.Cleaner where
5 5
 import AI.Vacuum.Grid
6 6
 import qualified Data.Map as M
7 7
 import qualified Data.Set as S
8
+import qualified Data.List as L
8 9
 import Control.Monad.State
9 10
 import Data.Ix (range)
10 11
 import Data.Maybe (fromJust, fromMaybe)
@@ -111,13 +112,31 @@ printPath cleaner grid = do
111 112
   let height = gridHeight grid
112 113
   let points = S.fromList $ cleaner^.path
113 114
 
114
-  forM_ (range (0, width - 1)) $ \x -> do
115
-    forM_ (range (0, height - 1)) $ \y -> do
115
+  forM_ (range (0, height - 1)) $ \y -> do
116
+    forM_ (range (0, width - 1)) $ \x -> do
116 117
       let cell = fromJust . lookupCell (x,y) $ grid
117 118
       if S.member (cell^.point) points
118
-        then putStr "- "
119
+        then putStr $ showPoint (cell^.point)
119 120
         else putStr . showCell $ cell
120 121
     putStrLn ""
122
+  where
123
+    cleanerPath = cleaner^.path
124
+    nextPoint p =
125
+      case L.elemIndex p $ cleanerPath of
126
+        Nothing -> Nothing
127
+        Just i | i == 0 -> Nothing
128
+        Just i -> Just $ cleanerPath !! (i - 1)
129
+    showPoint p =
130
+      case nextPoint p of
131
+        Nothing -> "- "
132
+        Just np ->
133
+          case orientation p np of
134
+            (Nothing, Nothing) -> "- "
135
+            (Just East, Nothing) -> "> "
136
+            (Just West, Nothing) -> "< "
137
+            (Nothing, Just South) -> "v "
138
+            (Nothing, Just North) -> "^ "
139
+            _ -> "- "
121 140
 
122 141
 printRunStats :: Cleaner -> Grid -> IO ()
123 142
 printRunStats cleaner grid = do

+ 61
- 2
chapter2/AI/Vacuum/Grid.hs View File

@@ -3,6 +3,7 @@
3 3
 module AI.Vacuum.Grid where
4 4
 
5 5
 import qualified Data.Map as M
6
+import qualified Data.List as L
6 7
 import Data.Maybe (fromJust)
7 8
 import Data.Ix (range)
8 9
 import Control.Monad (forM_)
@@ -19,6 +20,7 @@ trace string expr = unsafePerformIO $ do
19 20
 data Direction = North | East | South | West deriving (Eq, Show, Enum, Bounded)
20 21
 data CellType = Empty | Furniture | Dirt | Home deriving (Eq, Show, Ord)
21 22
 type Point = (Int, Int)
23
+type Path = [Point]
22 24
 data Cell = Cell { _point :: Point, _cellType :: CellType } deriving (Eq, Show)
23 25
 type Grid = M.Map Point Cell
24 26
 
@@ -45,6 +47,12 @@ forwardPoint (x, y) East = (x + 1, y)
45 47
 forwardPoint (x, y) South = (x, y + 1)
46 48
 forwardPoint (x, y) West = (x - 1, y)
47 49
 
50
+backwardPoint :: Point -> Direction -> Point
51
+backwardPoint (x, y) North = (x, y + 1)
52
+backwardPoint (x, y) East = (x - 1, y)
53
+backwardPoint (x, y) South = (x, y - 1)
54
+backwardPoint (x, y) West = (x + 1, y)
55
+
48 56
 rightPoint :: Point -> Direction -> Point
49 57
 rightPoint (x, y) North = (x + 1, y)
50 58
 rightPoint (x, y) East = (x, y + 1)
@@ -57,6 +65,52 @@ leftPoint (x, y) East = (x, y - 1)
57 65
 leftPoint (x, y) South = (x + 1, y)
58 66
 leftPoint (x, y) West = (x, y + 1)
59 67
 
68
+orientation :: Point -> Point -> (Maybe Direction, Maybe Direction)
69
+orientation from@(x1, y1) to@(x2, y2)
70
+  | from == to = (Nothing, Nothing)
71
+  | y1 == y2 && x2 > x1 = (Just East, Nothing)
72
+  | y1 == y2 && x2 < x1 = (Just West, Nothing)
73
+  | x1 == x2 && y2 > y1 = (Nothing, Just South)
74
+  | x1 == x2 && y2 < y1 = (Nothing, Just North)
75
+  | y2 < y1 && x2 > x1 = (Just East, Just North)
76
+  | y2 < y1 && x2 < x1 = (Just West, Just North)
77
+  | y2 > y1 && x2 > x1 = (Just East, Just South)
78
+  | y2 > y1 && x2 < x1 = (Just West, Just South)
79
+
80
+horzPath :: Point -> Point -> [Point]
81
+horzPath p1@(x1, y1) p2@(x2, _)
82
+  | x1 <= x2 = map (\x -> (x, y1)) $ range (x1, x2)
83
+  | otherwise = reverse . map (\x -> (x, y1)) $ range (x2, x1)
84
+
85
+vertPath :: Point -> Point -> [Point]
86
+vertPath p1@(x1, y1) p2@(_, y2)
87
+  | y1 <= y2 = map (\y -> (x1, y)) $ range (y1, y2)
88
+  | otherwise = reverse . map (\y -> (x1, y)) $ range (y2, y1)
89
+
90
+manhattanPaths :: Point -> Point -> [[Point]]
91
+manhattanPaths p1@(x1,y1) p2@(x2,y2)
92
+  | p1 == p2 = []
93
+  | otherwise = [L.nub (hp1 ++ vp1), L.nub (vp2 ++ hp2)]
94
+    where
95
+      hp1 = horzPath p1 p2
96
+      vp1 = vertPath (last hp1) p2
97
+      vp2 = vertPath p1 p2
98
+      hp2 = horzPath (last vp2) p2
99
+
100
+cornerPoints :: Point -> Int -> [Point]
101
+cornerPoints (x,y) distance =
102
+  [(x + distance, y + distance),
103
+   (x - distance, y + distance),
104
+   (x - distance, y - distance),
105
+   (x + distance, y - distance)]
106
+
107
+borderingPoints :: Point -> Int -> [Point]
108
+borderingPoints point distance =
109
+  L.nub . concat
110
+  . map (\(p1@(_,y1), p2@(_,y2)) ->
111
+          if y1 == y2 then horzPath p1 p2 else vertPath p1 p2)
112
+  . pairs . take 5 . cycle $ cornerPoints point distance
113
+
60 114
 lookupCell :: Point -> Grid -> Maybe Cell
61 115
 lookupCell = M.lookup
62 116
 
@@ -75,6 +129,11 @@ gridFromCellList = foldl (\m cell@(Cell p _) -> M.insert p cell m) M.empty
75 129
 freqMap :: (Ord a) => [a] -> [(a, Int)]
76 130
 freqMap = M.toList . foldl (\m t -> M.insertWith (+) t 1 m) M.empty
77 131
 
132
+pairs :: [a] -> [(a,a)]
133
+pairs [] = []
134
+pairs [_] = []
135
+pairs (x1 : x2 : xs) = (x1, x2) : pairs (x2 : xs)
136
+
78 137
 gridWidth :: Grid -> Int
79 138
 gridWidth = (+ 1) . maximum . map fst . M.keys
80 139
 
@@ -97,7 +156,7 @@ printGrid grid = do
97 156
   let width = gridWidth grid
98 157
   let height = gridHeight grid
99 158
 
100
-  forM_ (range (0, width - 1)) $ \x -> do
101
-    forM_ (range (0, height - 1)) $ \y ->
159
+  forM_ (range (0, height - 1)) $ \y -> do
160
+    forM_ (range (0, width - 1)) $ \x ->
102 161
       putStr . showCell . fromJust . lookupCell (x,y) $ grid
103 162
     putStrLn ""

+ 23
- 21
chapter2/AI/Vacuum/ReflexAgent.hs View File

@@ -1,4 +1,4 @@
1
-module AI.Vacuum.ReflexAgent where
1
+module AI.Vacuum.ReflexAgent (simulateOnGrid, printSimulation) where
2 2
 
3 3
 import AI.Vacuum.Cleaner
4 4
 import AI.Vacuum.Grid
@@ -35,36 +35,27 @@ runCleaner turnsLeft cleaner =
35 35
     return cleaner'
36 36
     else do
37 37
       let ph = cleaner^.perceptsHist
38
-      cleaner'' <- case ph of
39
-        [] -> do
40
-          cleaner' <- doAction GoForward cleaner
41
-          return cleaner'
38
+      cleaner' <- case ph of
39
+        [] -> doAction GoForward cleaner
42 40
         _ -> do
43 41
           action <- lift $ chooseAction (head ph)
44
-          cleaner' <- doAction action cleaner
45
-          return cleaner'
46
-
47
-      case cleaner''^.state of
48
-        Off -> return cleaner''
49
-        On -> runCleaner (turnsLeft - 1) cleaner''
42
+          doAction action cleaner
43
+      case cleaner'^.state of
44
+        Off -> return cleaner'
45
+        On -> runCleaner (turnsLeft - 1) cleaner'
50 46
 
51 47
 simulateOnGrid :: Int -> Grid -> StdGen -> (Cleaner, Grid)
52 48
 simulateOnGrid maxTurns grid gen =
53 49
   evalState (runStateT (runCleaner maxTurns cleaner) grid) gen
54 50
   where cleaner = createCleaner (fromJust $ lookupCell (0,0) grid) East
55 51
 
56
-main :: IO ()
57
-main = do
52
+printSimulation :: Int -> Int -> Int -> Float -> Bool -> IO ()
53
+printSimulation
54
+  minSize maxSize maxTurns dirtProb toPrintGrid = do
58 55
   gen <- newStdGen
59
-  args <- getArgs
60
-  let minSize = (read $ args !! 0) :: Int
61
-  let maxSize = (read $ args !! 1) :: Int
62
-  let dirtProb = (read $ args !! 2) :: Float
63
-  let maxTurns = (read $ args !! 3) :: Int
64
-  let toPrintGrid = (read $ args !! 4) :: Bool
65
-
66 56
   let grid = evalState
67
-             (makeRandomGrid (minSize,maxSize) (minSize,maxSize) dirtProb 0.0) gen
57
+             (makeRandomGrid (minSize,maxSize) (minSize,maxSize) dirtProb 0.0)
58
+             gen
68 59
 
69 60
   when toPrintGrid $ do
70 61
     putStrLn "Grid before traversal"
@@ -79,3 +70,14 @@ main = do
79 70
     putStrLn ""
80 71
 
81 72
   printRunStats cleaner grid
73
+
74
+main :: IO ()
75
+main = do
76
+  args <- getArgs
77
+  let minSize = (read $ args !! 0) :: Int
78
+  let maxSize = (read $ args !! 1) :: Int
79
+  let dirtProb = (read $ args !! 2) :: Float
80
+  let maxTurns = (read $ args !! 3) :: Int
81
+  let toPrintGrid = (read $ args !! 4) :: Bool
82
+
83
+  printSimulation minSize maxSize maxTurns dirtProb toPrintGrid

+ 242
- 0
chapter2/AI/Vacuum/StatefulReflexAgent.hs View File

@@ -0,0 +1,242 @@
1
+{-# LANGUAGE FlexibleContexts #-}
2
+
3
+module AI.Vacuum.StatefulReflexAgent where
4
+
5
+import AI.Vacuum.Grid
6
+import AI.Vacuum.Cleaner hiding (doAction)
7
+import qualified AI.Vacuum.Cleaner (doAction)
8
+import AI.Vacuum.RandomGrid
9
+import qualified Data.Map as M
10
+import qualified Data.List as L
11
+import Data.Maybe (fromMaybe, fromJust)
12
+import Data.Lens.Common
13
+import Data.Ix (range)
14
+import Control.Monad.State
15
+import System.Random
16
+import System (getArgs)
17
+
18
+data PointState = Unreachable | Explored | Unexplored deriving (Eq, Ord, Show)
19
+type GridState = M.Map Point PointState
20
+
21
+updateGridState :: Point -> PointState -> GridState -> GridState
22
+updateGridState point pointState gridState =
23
+  let gridState' = M.insert point pointState gridState in
24
+  case point of
25
+    (0, 0) ->
26
+      foldl (\m p -> M.insert p Unreachable m) gridState' [(-1, 0), (0, -1), (-1, -1)]
27
+    (0, y) -> M.insert (-1, y) Unreachable gridState'
28
+    (x, 0) -> M.insert (x, -1) Unreachable gridState'
29
+    _ -> gridState'
30
+
31
+createGridState :: Cleaner -> GridState
32
+createGridState cleaner = updateGridState ((cleaner^.cell)^.point) Explored M.empty
33
+
34
+getPointState point = fromMaybe Unexplored . M.lookup point
35
+
36
+getCellState :: (Point -> Direction -> Point)
37
+                 -> Cell -> Direction -> GridState -> PointState
38
+getCellState pointFn cell direction = getPointState (pointFn (cell^.point) direction)
39
+
40
+leftCellState :: Cell -> Direction -> GridState -> PointState
41
+leftCellState = getCellState leftPoint
42
+
43
+rightCellState :: Cell -> Direction -> GridState -> PointState
44
+rightCellState = getCellState rightPoint
45
+
46
+forwardCellState :: Cell -> Direction -> GridState -> PointState
47
+forwardCellState = getCellState forwardPoint
48
+
49
+backwardCellState :: Cell -> Direction -> GridState -> PointState
50
+backwardCellState = getCellState backwardPoint
51
+
52
+doAction :: (MonadState Grid m) => Action -> Cleaner -> GridState -> m (Cleaner, GridState)
53
+doAction action cleaner gridState = do
54
+  cleaner' <- AI.Vacuum.Cleaner.doAction action cleaner
55
+  let gridState' =
56
+        if action == GoForward
57
+        then if TouchSensor `elem` (head (cleaner'^.perceptsHist))
58
+             then updateGridState (nextPoint cleaner') Unreachable gridState
59
+             else updateGridState ((cleaner'^.cell)^.point) Explored gridState
60
+        else gridState
61
+  return (cleaner', gridState')
62
+  where
63
+    nextPoint cl = forwardPoint ((cl^.cell)^.point) (cl^.direction)
64
+
65
+possibleManhattanPaths :: [Path] -> GridState -> [Path]
66
+possibleManhattanPaths paths gridState
67
+  | paths == [] = []
68
+  | otherwise =
69
+    filter (L.all (== Explored)
70
+            . map (\p -> getPointState p gridState)
71
+            . filter (\p -> p `notElem` [p1, p2]))
72
+    paths
73
+    where
74
+      p1 = head . head $ paths
75
+      p2 = last . head $ paths
76
+
77
+nearestUnexploredPoint :: Point -> Int -> GridState -> Maybe (Point, Path)
78
+nearestUnexploredPoint point maxDist gridState = do
79
+  np <- L.find (\(p,ps) -> ps == Unexplored && pathExists p)
80
+           $ map (\p -> (p, getPointState p gridState))
81
+           $ concatMap (borderingPoints point) [1..maxDist]
82
+  return ((fst np), (head . paths . fst $ np))
83
+  where
84
+    paths p = possibleManhattanPaths (manhattanPaths point p) gridState
85
+    pathExists p = (/= 0) . length . paths $ p
86
+
87
+actionsByRelDirection = [
88
+  ("f", [GoForward]),
89
+  ("l", [TurnLeft, GoForward]),
90
+  ("r", [TurnRight, GoForward]),
91
+  ("b", [TurnLeft, TurnLeft, GoForward])]
92
+
93
+relDirectionToDirection relDir dir =
94
+  case relDir of
95
+    "f" -> dir
96
+    "l" -> left dir
97
+    "r" -> right dir
98
+    "b" -> right . right $ dir
99
+
100
+moveActions :: (Point, Point) -> Direction -> ([Action], Direction)
101
+moveActions (p1, p2) dir =
102
+  (\rd ->
103
+    (fromJust . lookup rd $ actionsByRelDirection,
104
+     relDirectionToDirection rd dir))
105
+  $ fst
106
+  $ fromJust
107
+  $ L.find (\(d, p) -> p == p2)
108
+  $ zip ["f", "l", "r", "b"]
109
+  $ map (\pfn -> pfn p1 dir)
110
+  $ [forwardPoint, leftPoint, rightPoint, backwardPoint]
111
+
112
+pathActions :: Direction -> Path -> [Action]
113
+pathActions dir path =
114
+  fst
115
+  . foldl
116
+  (\(as, d) ps -> let (as', d') = moveActions ps d in (as ++ as', d'))
117
+  ([], dir)
118
+  . pairs
119
+  $ path
120
+
121
+chooseActions :: Cleaner -> GridState -> RandomState [Action]
122
+chooseActions cleaner gridState =
123
+  case cleaner^.perceptsHist of
124
+    [] -> return [GoForward]
125
+    (ps : _) | PhotoSensor `elem` ps -> return [SuckDirt]
126
+    (ps : _) | InfraredSensor `elem` ps -> return [TurnOff]
127
+    _ ->
128
+      if length unexplored == 0
129
+       then -- trace ("surrounded at " ++ show ((cleaner^.cell)^.point)) $
130
+        case nearestUnexploredPoint ((cleaner^.cell)^.point) 4 gridState of
131
+          Nothing -> do
132
+            r <- getRandomR ((0.0, 1.0) :: (Float, Float))
133
+            -- trace ("choosing on random: " ++ show r) $
134
+            case r of
135
+              r | r < 0.1 -> return [TurnRight]
136
+              r | r < 0.2 -> return [TurnLeft]
137
+              otherwise -> return [GoForward]
138
+          Just (nPoint, path) -> -- trace ("taking path: " ++ show path) $
139
+            return . pathActions (cleaner^.direction) $ path
140
+      else
141
+        return . fromJust . lookup (fst . head $ unexplored) $ actionsByRelDirection
142
+      where
143
+        gridStates =
144
+          zip ["f", "l", "r", "b"] $
145
+          map (\f -> f (cleaner^.cell) (cleaner^.direction) gridState)
146
+          [forwardCellState, leftCellState, rightCellState, backwardCellState]
147
+        unexplored = filter ((== Unexplored) . snd) gridStates
148
+
149
+runCleaner :: Int -> Cleaner -> GridState -> StateT Grid RandomState (Cleaner, GridState)
150
+runCleaner turnsLeft cleaner gridState =
151
+  if turnsLeft == 1
152
+    then do
153
+    (cleaner', gridState') <- doAction TurnOff cleaner gridState
154
+    return (cleaner', gridState')
155
+    else do
156
+    actions <- lift $ chooseActions cleaner gridState
157
+    (cleaner', gridState') <-
158
+      foldM
159
+      (\(cl, gs) a -> do
160
+          (cl', gs') <- doAction a cl gs
161
+          return (cl', gs'))
162
+      (cleaner, gridState)
163
+      actions
164
+
165
+    case cleaner'^.state of
166
+      Off -> return (cleaner', gridState')
167
+      On -> runCleaner (turnsLeft - (length actions)) cleaner' gridState'
168
+
169
+simulateOnGrid :: Int -> Grid -> StdGen -> (Cleaner, GridState, Grid)
170
+simulateOnGrid maxTurns grid gen =
171
+  let ((cleaner', gridState'), grid') =
172
+        evalState (runStateT (runCleaner maxTurns cleaner gridState) grid) gen in
173
+  (cleaner', gridState', grid')
174
+  where
175
+    cleaner = createCleaner (fromJust $ lookupCell (0,0) grid) East
176
+    gridState = createGridState cleaner
177
+
178
+printGridState :: GridState -> Grid -> IO ()
179
+printGridState gridState grid = do
180
+  let width = gridWidth grid
181
+  let height = gridHeight grid
182
+
183
+  forM_ (range (-1, height)) $ \y -> do
184
+    forM_ (range (-1, width)) $ \x -> do
185
+      case lookupCell (x,y) $ grid of
186
+        Nothing ->
187
+          case M.lookup (x,y) gridState of
188
+            Nothing -> putStr "! "
189
+            Just Unreachable -> putStr "/ "
190
+        Just cell ->
191
+          case M.lookup (cell^.point) gridState of
192
+            Nothing -> putStr "! "
193
+            Just pointState ->
194
+              case pointState of
195
+                Explored -> putStr "- "
196
+                Unexplored -> putStr "! "
197
+                Unreachable -> putStr "/ "
198
+    putStrLn ""
199
+
200
+printSimulation :: Int -> Int -> Int -> Float -> Float -> Bool -> IO ()
201
+printSimulation
202
+  minSize maxSize maxTurns dirtProb furnitureProb toPrintGrid = do
203
+  gen <- newStdGen
204
+  let grid = evalState
205
+             (makeRandomGrid (minSize,maxSize) (minSize,maxSize) dirtProb furnitureProb)
206
+             gen
207
+
208
+  when toPrintGrid $ do
209
+    putStrLn "Grid before traversal"
210
+    printGrid grid
211
+    putStrLn ""
212
+
213
+  let (cleaner, gridState', grid') = simulateOnGrid maxTurns grid gen
214
+
215
+  when toPrintGrid $ do
216
+    putStrLn "Grid after traversal"
217
+    printPath cleaner grid'
218
+    putStrLn ""
219
+
220
+  when toPrintGrid $ do
221
+    putStrLn "Grid state"
222
+    printGridState gridState' grid
223
+    putStrLn ""
224
+
225
+  printRunStats cleaner grid
226
+  putStrLn ("Grid Exploration stats = "
227
+            ++ (show . freqMap $
228
+                [fromMaybe Unexplored . M.lookup (x, y) $ gridState'
229
+                | x <- range (0, gridWidth grid - 1),
230
+                  y <- range(0, gridHeight grid - 1)]))
231
+
232
+main :: IO ()
233
+main = do
234
+  args <- getArgs
235
+  let minSize = (read $ args !! 0) :: Int
236
+  let maxSize = (read $ args !! 1) :: Int
237
+  let dirtProb = (read $ args !! 2) :: Float
238
+  let furnitureProb = (read $ args !! 3) :: Float
239
+  let maxTurns = (read $ args !! 4) :: Int
240
+  let toPrintGrid = (read $ args !! 5) :: Bool
241
+
242
+  printSimulation minSize maxSize maxTurns dirtProb furnitureProb toPrintGrid

+ 1
- 0
chapter2/build-stateful-reflex-agent View File

@@ -0,0 +1 @@
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

Loading…
Cancel
Save