{-# options_ghc -XEmptyDataDecls -XOverlappingInstances -XScopedTypeVariables #-} module SetGames where import Data.Maybe import Iso import Games import BasicGames import List getRight (Right x) = x getLeft (Left x) = x nonemptyIso = Iso (\(x:xs) -> (x,xs)) (\(x,xs) -> x:xs) -- Diff functions used for representations of sets and multisets -- /diff/ diff minus [] = [] diff minus (x:xs) = x : diff' x xs where diff' base [] = [] diff' base (x:xs) = minus x base : diff' x xs undiff plus [] = [] undiff plus (x:xs) = x : undiff' x xs where undiff' base [] = [] undiff' base (x:xs) = base' : undiff' base' xs where base' = plus base x -- /End/ -- Makes use of isomorphism between [Nat] and { xs:[Nat] | sorted xs } -- /natMultisetGame/ natMultisetGame :: Game Nat -> Game [Nat] natMultisetGame g = listGame g +> Iso (diff (-) . sort) (undiff (+)) -- /End/ -- Makes use of isomorphism between [Nat] and { xs:[Nat] | sorted xs && distinct xs } -- /natSetGame/ natSetGame :: Game Nat -> Game [Nat] natSetGame g = listGame g +> Iso (diff (\ x y -> x-y-1) . sort) (undiff (\ x y -> x+y+1)) -- /End/ -- Comparison of two elements based on their games -- /compareByGame/ compareByGame :: Game a -> (a -> a -> Ordering) compareByGame (Single _) x y = EQ compareByGame (Split (Iso ask bld) g1 g2) x y = case (ask x, ask y) of (Left x1 , Left y1) -> compareByGame g1 x1 y1 (Right x2, Right y2) -> compareByGame g2 x2 y2 (Left x1, Right y2) -> LT (Right x2, Left y1) -> GT sortByGame :: Game a -> [a] -> [a] sortByGame g = sortBy (compareByGame g) -- /End/ -- Remove an element from a game, returning Nothing if the game was a singleton removeEQ :: Game a -> a -> Maybe (Game a) removeEQ (Single _) x = Nothing removeEQ (Split (Iso ask bld) g1 g2) x = case ask x of Left x1 -> Just $ case removeEQ g1 x1 of Nothing -> g2 +> rightI Just g1' -> Split (Iso ask bld) g1' g2 Right x2 -> Just $ case removeEQ g2 x2 of Nothing -> g1 +> leftI Just g2' -> Split (Iso ask bld) g1 g2' where rightI = Iso (getRight . ask) (bld . Right) leftI = Iso (getLeft . ask) (bld . Left) -- Remove every element less than or equal to an element according to -- the ordering induced by the game, returning Nothing if no elements would remain -- /removeLE/ removeLE :: Game a -> a -> Maybe (Game a) removeLE (Single _) x = Nothing removeLE (Split (Iso ask bld) g1 g2) x = case ask x of Left x1 -> Just $ case removeLE g1 x1 of Nothing -> g2 +> rightI Just g1' -> Split (Iso ask bld) g1' g2 Right x2 -> case removeLE g2 x2 of Nothing -> Nothing Just g2' -> Just (g2' +> rightI) where rightI = Iso (getRight . ask) (bld . Right) -- /End/ -- /removeLT/ -- Remove every element less than an element according to -- the ordering induced by the game -- Don't think this one works!!! removeLT :: Game a -> a -> Game a removeLT (Single iso) x = Single iso removeLT (Split (Iso ask bld) g1 g2) x = case ask x of Left x1 -> Split (Iso ask bld) (removeLT g1 x1) g2 Right x2 -> g2 +> Iso (getRight . ask) (bld . Right) -- /End/ -- /setGame/ setGame :: Game a -> Game [a] setGame g = setGame' g +> Iso (sortByGame g) id where setGame' g = Split listIso unitGame $ depGame g $ \x -> case removeLE g x of Just g' -> setGame' g' Nothing -> constGame [] -- /End/ -- /multisetGame/ multisetGame :: Game a -> Game [a] multisetGame g = multisetGame' g +> Iso (sortByGame g) id where multisetGame' g = Split listIso unitGame (depGame g (\x -> multisetGame' (removeLT g x))) -- /End/