abhin4v
/
russel-norvig-ai-problems
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

refactored to use Data.Lens

master
Abhinav Sarkar 2011-10-05 19:35:14 +05:30
parent bfa77fc13d
commit 82361f606a
4 changed files with 88 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
chapter2/prob26.hs
View File

@ -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
where cleaner = createCleaner (fromJust $ lookupCell (0, 0) grid) East

1
chapter2/prob27.hs
View File

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

10
chapter2/prob28.hs
View File

@ -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
where cleaner = createCleaner (fromJust $ lookupCell (0,0) grid) East

96
chapter2/vacuum.hs
View File

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