Solved problem 2.9: added stateful reflex agent

master
Abhinav Sarkar 2011-10-08 10:42:46 +05:30
Parent 5d4e23f5e5
révision 643a75deb0
6 fichiers modifiés avec 350 ajouts et 26 suppressions

Voir le fichier

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

Voir le fichier

@ -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

Voir le fichier

@ -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 ""

Voir le fichier

@ -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

Voir le fichier

@ -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

Voir le fichier

@ -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