From 643a75deb073872b96f7fd9f0253b023543750c1 Mon Sep 17 00:00:00 2001 From: Abhinav Sarkar Date: Sat, 8 Oct 2011 10:42:46 +0530 Subject: [PATCH] Solved problem 2.9: added stateful reflex agent --- chapter2/.gitignore | 1 + chapter2/AI/Vacuum/Cleaner.hs | 25 ++- chapter2/AI/Vacuum/Grid.hs | 63 +++++- chapter2/AI/Vacuum/ReflexAgent.hs | 44 ++-- chapter2/AI/Vacuum/StatefulReflexAgent.hs | 242 ++++++++++++++++++++++ chapter2/build-stateful-reflex-agent | 1 + 6 files changed, 350 insertions(+), 26 deletions(-) create mode 100644 chapter2/AI/Vacuum/StatefulReflexAgent.hs create mode 100755 chapter2/build-stateful-reflex-agent diff --git a/chapter2/.gitignore b/chapter2/.gitignore index 5992318..a3c88e1 100644 --- a/chapter2/.gitignore +++ b/chapter2/.gitignore @@ -1,2 +1,3 @@ build ReflexAgent +StatefulReflexAgent diff --git a/chapter2/AI/Vacuum/Cleaner.hs b/chapter2/AI/Vacuum/Cleaner.hs index 0d21faf..ddb1508 100644 --- a/chapter2/AI/Vacuum/Cleaner.hs +++ b/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 diff --git a/chapter2/AI/Vacuum/Grid.hs b/chapter2/AI/Vacuum/Grid.hs index a84e25f..769ffa7 100644 --- a/chapter2/AI/Vacuum/Grid.hs +++ b/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 "" diff --git a/chapter2/AI/Vacuum/ReflexAgent.hs b/chapter2/AI/Vacuum/ReflexAgent.hs index 2e3fb41..f117ab0 100644 --- a/chapter2/AI/Vacuum/ReflexAgent.hs +++ b/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 diff --git a/chapter2/AI/Vacuum/StatefulReflexAgent.hs b/chapter2/AI/Vacuum/StatefulReflexAgent.hs new file mode 100644 index 0000000..46e5e09 --- /dev/null +++ b/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 diff --git a/chapter2/build-stateful-reflex-agent b/chapter2/build-stateful-reflex-agent new file mode 100755 index 0000000..7c467bc --- /dev/null +++ b/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