-- -- Copyright (c) 2005 Don Stewart - http://www.cse.unsw.edu.au/~dons -- Sean Seefried -- Stefan Wehr -- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html) -- module AlphaBeta where import List ( elemIndex ) import Logging import KnowledgeBase import Graph data ABMove = CopMove [GNode] | RobberMove GNode data ABState = CopABState KnowledgeBase [GNode]{-possible robber positions-} | RobberABState KnowledgeBase abGetKB :: ABState -> KnowledgeBase abGetKB (CopABState kb _) = kb abGetKB (RobberABState kb) = kb -- move of a robber when AB is run for a robber robberABRobberMove :: ABState -> [(ABState, ABMove)] robberABRobberMove (RobberABState kb) = case kb_ownLoc kb of [(_,n)] -> map (\ (kb, m) -> (RobberABState kb, m)) $ moveRobber kb n l -> niceError ("robber cannot be at " ++ show (length l) ++ " different locations: " ++ show l) -- move of a robber when AB is run for a cop copABRobberMove :: ABState -> [(ABState, ABMove)] copABRobberMove (CopABState kb ns) = let nexts = concatMap (moveRobber kb) ns in map (\ (kb, m@(RobberMove n)) -> ((CopABState kb [n]), m)) nexts moveRobber :: KnowledgeBase -> GNode -> [(KnowledgeBase, ABMove)] moveRobber kb n = let -- dummy move first kb' = (robberMove kb n n) -- adjust worldCount kb'' = kb' { kb_dynamic = Just ((dynKB kb') { kbd_worldCount = kb_worldCount kb }) } moveTo n' = (robberMove kb'' n n', RobberMove n') succs = --n : gsucc (kb_footMap kb) n gsucc (kb_footMap kb) n in map moveTo succs allPossibilities :: [[a]] -> [[a]] allPossibilities [] = [] allPossibilities (l:[]) = [ [x] | x <- l ] allPossibilities (l1:ls) = let l2 = allPossibilities ls in [ x1:x2 | x1 <- l1, x2 <- l2 ] -- move of a cop when AB is run for a robber robberABCopMove :: ABState -> [(ABState, ABMove)] robberABCopMove (RobberABState kb) = let copSteps = map cop_node (kb_cops kb) in map (\ (kb, m) -> (RobberABState kb, m)) $ moveCop kb [copSteps] -- move of a cop when AB is run for a cop copABCopMove :: ABState -> [(ABState, ABMove)] copABCopMove (CopABState kb ns) = let copSteps = map cop_node (kb_cops kb) i = copIndex (kb_ownName kb) (kb_cops kb) myself = (kb_cops kb) !! i mySteps = --(cop_node myself) : copSuccs kb myself copSuccs kb myself allSteps = allPossibilities ((map mkList $ take i copSteps) ++ (mySteps : (map mkList $ drop (i+1) copSteps))) in map (\ (kb', m) -> ((CopABState kb' ns), m)) $ moveCop kb allSteps where mkList x = [x] moveCop :: KnowledgeBase -> [[GNode]]{- list of steps -} -> [(KnowledgeBase, ABMove)] moveCop kb allSteps = let moveTo targets = (copMove kb targets, CopMove targets) in map moveTo allSteps robberABSearch :: (Ord u, Bounded u) => KnowledgeBase -> Int -- cutoff depth -> (KnowledgeBase -> u) -- utility function -> GNode robberABSearch kb cutoff util = case alphaBetaSearch (RobberABState kb) cutoff (\ (RobberABState kb) -> util kb) robberABRobberMove robberABCopMove of RobberMove n -> n _ -> niceError ("robberABSearch: suggested move is a " ++ "cop move (should be a robber move)") copABSearch :: (Ord u, Bounded u) => KnowledgeBase -> [GNode] -- possible positions of the robber -> Int -- cutoff depth -> (KnowledgeBase -> u) -- utitlity function -> [GNode] copABSearch kb ns cutoff util = case alphaBetaSearch (CopABState kb ns) cutoff (\ (CopABState kb _) -> util kb) copABRobberMove copABCopMove of CopMove ns -> ns _ -> niceError ("robberABSearch: suggested move is a " ++ "robber move (should be a cop move)") alphaBetaSearch :: (Ord u, Bounded u) => ABState -> Int -- cutoff depth -> (ABState -> u) -- utitlity function -> (ABState -> [(ABState, ABMove)]) -- robber move function -> (ABState -> [(ABState, ABMove)]) -- cop move function -> ABMove alphaBetaSearch s cutoff utility rmove cmove = let initState = GenericAlphaBeta { state = s , genSuccs = genSuccs , cutoffTest = cutoffTest , utility = utility , alpha = minBound , beta = maxBound } in genericAlphaBetaSearch initState where genSuccs s = if even $ kb_worldCount (abGetKB s) -- robber move then rmove s else cmove s cutoffTest s' = let n = kb_worldCount (abGetKB s) n' = kb_worldCount (abGetKB s') res = n' - n >= cutoff copNodes = map cop_node (kb_cops $ abGetKB s') in --dtrace ("cutoffTest: initialWorldCount=" ++ show n ++ -- ", currentWorldCount=" ++ show n' ++ ", cutoff=" ++ -- show cutoff ++ ", result=" ++ show res) $ case kb_robber $ abGetKB s' of Nothing -> res Just n -> n `elem` copNodes || res data GenericAlphaBeta s{- state -} a{- action -} u{- utility value -} = GenericAlphaBeta { state :: s , genSuccs :: s -> [(s, a)] -- successor generation function -- (returns a state and an action) , cutoffTest :: s -> Bool -- cutoff test , utility :: s -> u -- utility of a state , alpha :: u -- initial value: -\inf , beta :: u -- initial value: +\inf } genericAlphaBetaSearch :: Ord u => GenericAlphaBeta s a u -> a genericAlphaBetaSearch x = --dtrace "genericAlphaBetaSearch" $ let (succStates, succActions) = unzip $ (genSuccs x) (state x) minVals = --dtrace (show (length succStates) ++ " successor states") $ map (\succ -> minValue (x { state = succ })) succStates m = maximum minVals in case elemIndex m minVals of Nothing -> niceError ("genericAlphaBeta: internal error") Just i -> succActions!!i minmaxValue :: Ord u => GenericAlphaBeta s a u -> (u -> u -> [s] -> u) -> u minmaxValue x loop = if (cutoffTest x) (state x) then --dtrace "minimaxValue: cutoffTest succeeded" $ (utility x) (state x) else --dtrace "minimaxValue: cutoffTest failed" $ let (succs, _) = unzip $ (genSuccs x) (state x) in loop (alpha x) (beta x) succs maxValue :: Ord u => GenericAlphaBeta s a u -> u maxValue x = --dtrace "maxValue" $ minmaxValue x loop where loop alpha _ [] = alpha loop alpha beta (s:ss) = let alpha' = max alpha (minValue (x { state = s, alpha = alpha })) in if alpha' >= beta then beta else loop alpha' beta ss minValue :: Ord u => GenericAlphaBeta s a u -> u minValue x = --dtrace "minValue" $ minmaxValue x loop where loop _ beta [] = beta loop alpha beta (s:ss) = let beta' = min beta (maxValue (x { state = s, beta = beta })) in if beta' <= alpha then alpha else loop alpha beta' ss