GeBoP-1.7.5: Game.hs
{-# LANGUAGE ExistentialQuantification #-}
module Game where
import Graphics.UI.WX hiding (children, value)
import Data.Array
import Tools
----------------
-- class Game --
----------------
type Player = Int
type Move g = (Player, g) -> (Player, g)
type Value = [Float]
data Properties
= Properties { players :: Int
, boardsize :: Int
, human :: [Bool]
}
deriving Show
data PropertyRange
= PropertyRange { playersrange :: [Int]
, boardsizerange :: [Int]
}
class (Eq g, Show g) => Game g where
name :: g -> String
--{ rules :: g -> String
--{ information :: g -> String
standard :: g -> Properties
possible :: g -> PropertyRange
new :: Properties -> g
moves :: Properties -> Player -> g -> [Move g]
showmove :: Properties -> Player -> g -> Int -> String
value :: Properties -> Player -> g -> Value
board :: Panel () -> Properties -> Var (Tree g) -> Bool -> (Int -> IO ()) -> IO ()
data GeneralGame = forall g. Game g => Game g
---------------
-- data Tree --
---------------
data Game g => Tree g
= Node { player :: Player
, state :: g
, movesnr :: Int
, childid :: Int
, mov :: Array Int (Move g) --{ onnodig?
, children :: Array Int (Tree g)
, val :: Value -- should be equally good for the current player
--{ misschien handig om een set te nemen ipv list?
--{ maar: voor gemiddeldes juist weer niet! (ook in algoritme?)
--{ in dat geval: maar een entry per zet! (dus length best = length val)
--{ > nee! we doen gewoon 1 value, het gemiddelde van alle bests
--{ val = average $ map val best
, best :: [Int]
, filled :: Bool
, closed :: Bool
, mind :: Inf Int
, maxd :: Int
, volume :: Int
}
buildtree :: Game g => Properties -> Player -> g -> Tree g
buildtree prop p g = let ms = moves prop p g
nr = length ms
in Node { player = p
, state = g
, movesnr = nr
, childid = 0
, mov = array (0, nr - 1) $ zip [0 ..] $ ms
, children = array (0, nr - 1) $ map (\(i, m) -> (i, (child m) {childid = i})) $ zip [0 ..] ms
, val = value prop p g
, best = []
, filled = False
, closed = False
, mind = 0
, maxd = 0
, volume = 0
}
where
-- child :: Move g -> Tree g
child m = uncurry (buildtree prop) (m (p, g))
createtree :: Game g => g -> Properties -> Tree g
createtree _ p = buildtree p 0 $ new p
-----------------------
-- Tree manipulation --
-----------------------
better :: Player -> Value -> Value -> Ordering
better p v w | p < 0 || p >= length v || p >= length w = error $ "Game.better: index " ++ show p ++ " out of bounds"
| otherwise = compare (v !! p) (w !! p)
computeVal :: Game g => Tree g -> Tree g
computeVal t = let kids = assocs $ children t
vals = map (\(i, k) -> (i, val k)) kids
good = maximumWith (\(_,v) (_,w) -> better (player t) v w) vals
in t { best = map fst good
, val = zipWithn average $ map snd good --{ veranderen als val set is ipv list
}
-- shear cuts a branch off and makes it the new tree
shear :: Game g => Int -> Tree g -> Tree g
shear i t = children t ! i
-- grow makes the tree grow at its root (which should be a leaf)
grow :: Game g => Tree g -> Tree g
grow t | movesnr t == 0 = t {closed = True, filled = True, mind = inf, maxd = 1, volume = 1}
| otherwise = computeVal $ t {filled = True, mind = 1 , maxd = 1, volume = 1}
-- update recomputes val, best, mind and maxd given the index of the altered child
--{ update moet efficienter dan altijd computeVal!
update :: Game g => Int -> Tree g -> Tree g
update _i t = computeVal
$ t { closed = and $ map closed $ elems $ children t
, mind = case filter (not . closed) $ elems $ children t
of [] -> inf
kids -> minimum $ map ((+ 1) . mind) kids
, maxd = maximum $ map ((+ 1) . maxd) $ elems $ children t
, volume = 1 + sum (map volume $ elems $ children t)
}
-- path computes a path to a leaf to update, given a leaf-choosing algorithm f
path :: Game g => (Tree g -> [Int]) -> [Int] -> Tree g -> [Int]
path f (j:js) t = case f t of [] -> []
is -> let i = is !! (j `mod` length is)
in i : path f js (children t ! i)
path _ [] _ = error "path: empty list"
-- step makes the tree grow at exactly one leaf, given a path
step :: Game g => [Int] -> Tree g -> Tree g
step [] t = grow t
step (i:is) t
| filled t = let u = step is (children t ! i)
in Game.update i $ t {children = children t // [(i, u)]}
| otherwise = grow t
followcombination :: Game g => Tree g -> [Int]
followcombination t = followshortest t ++ followbest t
followshortest :: Game g => Tree g -> [Int]
followshortest t | not $ filled t = []
| closed t = []
| otherwise = let open = filter (\(_i, k) -> not $ closed k) $ assocs $ children t
minds = map (\(i, k) -> (i, mind k)) open
in map fst $ minimumWith (\(_, p) (_, q) -> compare p q) minds
followbest :: Game g => Tree g -> [Int]
followbest t = case filter (\i -> not $ closed $ children t ! i) $ best t of
[] -> followopen t
b -> b
followopen :: Game g => Tree g -> [Int]
followopen t = map fst $ filter (not.closed.snd) $ assocs $ children t