From 82361f606abee83cee4dfebb9515b0a2d8734ce8 Mon Sep 17 00:00:00 2001 From: Abhinav Sarkar Date: Wed, 5 Oct 2011 19:35:14 +0530 Subject: [PATCH] refactored to use Data.Lens --- chapter2/prob26.hs | 48 ++++++++++++----------- chapter2/prob27.hs | 1 - chapter2/prob28.hs | 10 +++-- chapter2/vacuum.hs | 96 +++++++++++++++++++++++++++------------------- 4 files changed, 88 insertions(+), 67 deletions(-) diff --git a/chapter2/prob26.hs b/chapter2/prob26.hs index 3784e2f..3cb32d6 100644 --- a/chapter2/prob26.hs +++ b/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 - case chooseAction ph of +runCleaner cleaner = do + case chooseAction $ cleaner^.perceptsHist of Just action -> do - cleaner <- doAction action cleaner - let ph = clPrcptsHist cleaner - if InfraredSensor `elem` (head ph) - then doAction TurnOff cleaner - else runCleaner cleaner + cleaner' <- doAction action cleaner + if InfraredSensor `elem` (head $ cleaner'^.perceptsHist) + then doAction TurnOff 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 \ No newline at end of file + where cleaner = createCleaner (fromJust $ lookupCell (0, 0) grid) East diff --git a/chapter2/prob27.hs b/chapter2/prob27.hs index d2410d1..496881a 100644 --- a/chapter2/prob27.hs +++ b/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)] - diff --git a/chapter2/prob28.hs b/chapter2/prob28.hs index cc601da..db6c03e 100644 --- a/chapter2/prob28.hs +++ b/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 \ No newline at end of file + where cleaner = createCleaner (fromJust $ lookupCell (0,0) grid) East diff --git a/chapter2/vacuum.hs b/chapter2/vacuum.hs index 031e8e3..c14762d 100644 --- a/chapter2/vacuum.hs +++ b/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, - clCell :: Cell, - clDir :: Direction, - clPrcptsHist :: PerceptsHistory, - clScore :: Score + _state :: CleanerState, + _cell :: Cell, + _direction :: Direction, + _path :: [Point], + _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 -cell = M.lookup +lookupCell :: Point -> Grid -> Maybe Cell +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) = - return $ Cleaner state cell (right dir) ([] : ph) score +turnRight = return . (direction ^%= right) . (setPercepts []) turnLeft :: (MonadState Grid m) => Cleaner -> m Cleaner -turnLeft (Cleaner state cell dir ph score) = - return $ Cleaner state cell (left dir) ([] : ph) score +turnLeft = return . (direction ^%= left) . (setPercepts []) moveForward :: (MonadState Grid m) => Cleaner -> m Cleaner -moveForward cleaner@(Cleaner state cell@(Cell _ cellType) dir ph score) = do +moveForward cleaner = do grid <- get - return $ - case forwardCell cell dir grid of - Nothing -> Cleaner state cell dir ([TouchSensor] : ph) score - Just nextCell@(Cell _ nextCellType) -> + return . + case forwardCell (cleaner^.cell) (cleaner^.direction) grid of + Nothing -> setPercepts [TouchSensor] + Just nextCell@(Cell nextPoint nextCellType) -> + let setNextCellPoint = (cell ^= nextCell) . (path ^%= (nextPoint :)) in case nextCellType of - Empty -> Cleaner state nextCell dir ([] : ph) score - Furniture -> Cleaner state cell dir ([TouchSensor] : ph) score - Dirt -> Cleaner state nextCell dir ([PhotoSensor] : ph) score - Home -> Cleaner state nextCell dir ([InfraredSensor] : ph) score + Empty -> setNextCellPoint . (setPercepts []) + Furniture -> setPercepts [TouchSensor] + Dirt -> setNextCellPoint . (setPercepts [PhotoSensor]) + 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) - TurnRight -> turnRight $ Cleaner state cell dir ph (score - 1) - TurnLeft -> turnLeft $ Cleaner state cell dir ph (score - 1) + GoForward -> moveForward + TurnRight -> turnRight + TurnLeft -> turnLeft SuckDirt -> - case cellType of - Dirt -> do - 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) + (if cellType' == Dirt then suckDirt . (score ^%= (+ 100)) else return) + . (setPercepts []) TurnOff -> - case cellType of - Home -> return $ Cleaner Off cell dir ([] : ph) score - otherwise -> return $ Cleaner Off cell dir ([] : ph) (score - 1000) - + return . (state ^= Off) . (setPercepts []) + . (if cellType' == Home then id else score ^%= (subtract 1000)) + . (score ^%= subtract 1) + . (actionHist ^%= (action :)) + $ cleaner + where + cellType' = (cleaner^.cell)^.cellType