minesweeper 0.8.8.5 → 0.8.9
raw patch · 18 files changed
+457/−761 lines, 18 filesdep ~glade
Dependency ranges changed: glade
Files
- Configuration.hs +2/−0
- Core/BitField.lhs +60/−422
- Core/Constraint.lhs +144/−0
- Core/Constraints.lhs +23/−23
- Core/SetContainer.lhs +69/−0
- Core/Square.hs +31/−13
- Data/ChangeSet.hs +2/−0
- Data/PContainer.lhs +0/−267
- Data/SetClass.lhs +64/−0
- Driver.hs +10/−10
- Driver/Simplified.hs +5/−5
- State.hs +2/−0
- State/Functions.hs +29/−11
- Step.hs +3/−2
- Transition/Managed.hs +2/−1
- Transition/Response.hs +2/−1
- Transition/State.hs +4/−3
- minesweeper.cabal +5/−3
Configuration.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE TemplateHaskell #-}+ module Configuration ( Configuration ( Configuration
Core/BitField.lhs view
@@ -1,6 +1,5 @@ -> {-# LANGUAGE FlexibleInstances #-}-> {-# LANGUAGE UndecidableInstances #-}+> {-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, ScopedTypeVariables, UndecidableInstances, PatternGuards, TemplateHaskell, EmptyDataDecls, GADTs, GeneralizedNewtypeDeriving #-} | Core data type for the game. @@ -11,448 +10,87 @@ Import List ----------- -> import Data.PContainer--#ifdef TEST--> import Test.LazySmallCheck hiding (empty)-> import Number.Peano--#endif+> import Core.SetContainer+> import Core.Constraint (Constraint, constraint, sizeConstraint, intersectionC) -> import Control.Monad > import Data.Binary-> import Data.DeriveTH-> import Data.Derive.Binary-> import Data.Derive.Functor -> import qualified Data.Set as S--> import Data.Monoid-> import Data.Function-> import Data.Maybe-> import Data.List----> type Set a = S.Set a---Subset of Subsets---------------------| @Subsets c@: @c@ is a data structure which represents a subset of all subsets of a given set.--> class Ord (Elem c) => Subsets c where--> type Elem c--> domain :: c -> Set (Elem c)-#ifdef TEST-> subsets :: c -> [Set (Elem c)]-#endif-> subsetsNum :: c -> Integer--> empty :: Set (Elem c) -> c--| @isTriviallyEmpty@ should be fast but may give @False@ also for empty subsets.--> isTriviallyEmpty :: c -> Bool--| All subsets of the empty set.--> emptySubsets :: Set (Elem c) -> c----#ifdef TEST-Properties-------------all subsets ⊂ domain--> prop_subsetsNum :: Subsets c => c -> Bool-> prop_subsetsNum e-> = subsetsNum e == genericLength (subsets e)--> prop_empty :: Subsets a => a -> Set (Elem a) -> Bool-> prop_empty a d-> = subsetsNum (empty d `asTypeOf` a) == 0--isTriviallyEmpty ==> isEmpty--> prop_emptySubsets :: Subsets a => a -> Set (Elem a) -> Bool-> prop_emptySubsets a d-> = domain e == d && subsets e == [S.empty] where e = emptySubsets d `asTypeOf` a--| Test helper function.--> isEmpty :: Subsets c => c -> Bool-> isEmpty -> = null . subsets-#endif---#ifdef TEST-Simple Implementation----------------------+> -- import Data.Maybe+> --import Data.List+> import Data.SetClass hiding (null) -| Subset of all subsets of a given set.+------------------------------------------------------- -> data SimpleSubsets a -> = SimpleSubsets (Set a) [Set a]-> deriving (Show)+> class Layouts a where+>+> type BitFieldElem a +>+> numOfLayouts :: a -> Integer+> newLayout :: BitFieldElem a -> Int -> a+> addConstraint :: BitFieldElem a -> Int -> a -> a+> impossible :: a -> instance Ord a => Eq (SimpleSubsets a) where+> instance (SetContainer a, SetContainerElem a ~ Constraint b, Set b) => Layouts (Maybe a) where+>+> type BitFieldElem (Maybe a) = Domain (SetContainerElem a)+>+> newLayout = curry $ Just . (`insertL` emptyC) . uncurry constraint > -> SimpleSubsets da sa == SimpleSubsets db sb-> = da == db && sort sa == sort sb+> numOfLayouts Nothing = 0+> numOfLayouts (Just x) = product $ map f $ decomp x where+> f :: Decomp (SetContainerElem a) -> Integer+> f (OneElem x) +> = sizeConstraint x+> f (Dependents c d y)+> = sum [ numOfLayouts $ foldr addConstraint' (Just y) e | e <- intersectionC c d ]+>+> addConstraint = curry $ addConstraint' . uncurry constraint+>+> impossible = Nothing -> instance Ord a => Subsets (SimpleSubsets a) where-> -> type Elem (SimpleSubsets a) = a-> -> domain (SimpleSubsets d _) = d-> subsets (SimpleSubsets _ s) = s-> subsetsNum = genericLength . subsets-> empty d = SimpleSubsets d []-> isTriviallyEmpty = null . subsets-> emptySubsets d = SimpleSubsets d [S.empty] -> toSimple :: (Subsets c) => c -> SimpleSubsets (Elem c)-> toSimple x -> = SimpleSubsets (domain x) (subsets x)+> addConstraint' n Nothing = Nothing -- nincs megoldás+> addConstraint' n (Just c)+> | any (null . thd) strength +> = Nothing+> | (x, c', [y]): _ <- filter (null . tail . thd) strength+> = foldr addConstraint' (Just c') y+> | otherwise +> = Just (insertL n c)+> where+> strength = +> [ (x, c', intersectionC n x) +> | (x, c') <- relatedElems n c+> ] -| This property states that @Simple@ is universal.+> thd :: (a,b,c) -> c+> thd (_,_,x) = x -> prop_Simple :: Subsets c => (forall d. Subsets d => d -> Bool) -> c -> Bool-> prop_Simple p a-> = p a <==> p (toSimple a)-#endif Cached Size Implementation -------------------------- -> data CachedSize a-> = CachedSize a Integer-> deriving (Read, Show)+> newtype CachedSize a+> = CachedSize (Integer, a) +> deriving (Read, Show, Binary) | smart constructor -> cachedSize :: Subsets c => c -> CachedSize c-> cachedSize c -> | s == 0 = CachedSize (empty $ domain c) s-> | otherwise = CachedSize c s-> where-> s = subsetsNum c--> instance Subsets c => Subsets (CachedSize c) where--> type Elem (CachedSize c) = Elem c--#ifdef TEST-> subsets (CachedSize x _) = subsets x-#endif-> domain (CachedSize x _) = domain x-> subsetsNum (CachedSize _ i) = i-> emptySubsets = cachedSize . emptySubsets-> empty = cachedSize . empty-> isTriviallyEmpty c = subsetsNum c == 0--> instance SetSum a c => SetSum a (CachedSize c) where-> setSum' e (CachedSize c _) = cachedSize $ setSum' e c----#ifdef TEST-Combining Sets of Subsets----------------------------Definition:--> prop_mappend :: (Monoid c, Subsets c) => c -> c -> Bool-> prop_mappend a b-> = domain (a `mappend` b) == domain a `S.union` domain b-> && all (\s -> -> s `elem` subsets (a `mappend` b) -> <==> (s `S.intersection` domain a) `elem` subsets a -> && (s `S.intersection` domain b) `elem` subsets b -> ) (allSubsets $ domain $ a `mappend` b)--> allSubsets -> = map (S.fromList . concat) . sequence . map (\x -> [[],[x]]) . S.toList --Properties:--> prop_monoid :: (Eq c, Monoid c) => c -> c -> c -> Bool-> prop_monoid a b c-> = a `mappend` b == b `mappend` a-> && a `mappend` (b `mappend` c) == (a `mappend` b) `mappend` c-> && mempty `mappend` a == a-- isEmpty a ==> isEmpty (a `mappend` b)---Implementation for @SimpleSubsets@:--> instance (Ord a) => Monoid (SimpleSubsets a) where--> mempty -> = emptySubsets S.empty--> SimpleSubsets da sa `mappend` SimpleSubsets db sb -> = SimpleSubsets (da `S.union` db) -> [a `S.union` b | a <- sa, b <- sb, a `S.intersection` c == b `S.intersection` c, c S.\\ a == c S.\\ b]-> where-> c = da `S.intersection` db---> tests = do-> smallCheck 20 (prop_subsetsNum :: Equal Char -> Bool)-> -- smallCheck 5 (prop_mappend :: SimpleSubsets Char -> SimpleSubsets Char -> Bool)-#endif---> class Subsets c => Inters c where-> intersection :: c -> c -> [[c]]--#ifdef TEST-> prop_intersection a b -> = unions [mconcat $ map toSimple x | x <- a `intersection` b] == toSimple a `mappend` toSimple b--> unions l = SimpleSubsets (S.unions $ map domain l) (concat $ map subsets l)-#endif-------------------------------| @Equal a@ represents some subsets of a given set.--> data Equal a-> = Equal (Set a) Int-> deriving (Eq, Read, Show)--> instance (Ord a, Binary a) => Binary (Equal a) where-> -> put (Equal a b) = put (a, b)-> get = do (a,b) <- get-> return (Equal a b)--> instance Ord a => Particles (Equal a) where-> type P (Equal a) = a-> particles = domain----| Semantics--> instance Ord a => Subsets (Equal a) where--> type Elem (Equal a) -> = a--> domain (Equal d _) -> = d--#ifdef TEST-> subsets (Equal d n) -> = map S.fromDistinctAscList (f (S.toList d) n) where--> f as 0 = [[]]-> f as n = [x:bl | (x: xs) <- tails as, bl <- f xs (n-1)]-#endif--> subsetsNum (Equal d n) -> = binomial (S.size d) n--> emptySubsets d-> = Equal d 0--> empty d-> = Equal d (-1)--> isTriviallyEmpty (Equal d n)-> = n<0 || n> S.size d---#ifdef TEST-| For testing--> instance Serial (Equal Char) where-> series = cons1 f where--> f :: Nat -> Equal Char-> f i = Equal (S.fromList $ take n ['a'..]) m where--> (n, m) = [(n, m) | n <- [0..], m <- [0..n]] !! fromIntegral i-#endif----> instance Ord a => Inters (Equal a) where--> Equal a av `intersection` Equal b bv-> = [ [ Equal (a S.\\ c) (av - cv)-> , Equal c cv-> , Equal (b S.\\ c) (bv - cv) -> ] -> | cv <- [min' .. max'] ] where -> -> c = S.intersection a b -- a-> -> min' = 0 `max` (av - (S.size a - S.size c)) `max` (bv - (S.size b - S.size c)) -- av `max` (bv - (size b - size a))-> max' = S.size c `min` av `min` bv -- av `min` bv---> {--> prop_factor a b-> = b `subDomain` a -> ==> toSimple a `mappend` toSimple b == toSimple (a `factor` b) `mappend` toSimple b-> -}---------------------------------------------> class (Subsets a, Subsets c {-, Elem a ~ Elem c -}) => SetSum a c where-> -> setSum' :: a -> c -> c-----------------------------------------------------------------> a_limit = 3-> b_limit = 3---> subsetsNumStep -> :: (Container c, Subsets c, Inters (CElem c))-> => c -> Integer-> subsetsNumStep x | isTriviallyEmpty x = 0-> subsetsNumStep x = case fromC x of-> [] -> 1-> l -> snd $ minimumBy (compare `on` fst) $ take a_limit $ map cont l-> where-> cont c = case relatedElems c x' of-> [] -> (0, subsetsNum c * subsetsNum x' )-> b ->-> let ll = [ subsetsNum $ foldr addToContainer x'' y-> | let (d, ys) = minimumBy (compare `on` (length . snd)) $ take b_limit $ map (\d -> (d, intersection c d)) b-> , let x'' = deleteL d x'-> , y <- ys]-> in (length ll, sum ll) -> -> where x' = deleteL c x---> addToContainer -> :: (Container c, Subsets c, Inters (CElem c))-> => CElem c -> c -> c-> addToContainer n c-> | isTriviallyEmpty n-> || isTriviallyEmpty c-> || any (null . snd) strength -> = empty $ domain c-> | (x, y): _ <- [(x, y) | (x, [y]) <- strength]-> = foldr addToContainer (deleteL x c) y-> | otherwise -> = insertL n c -> where-> strength = [(x, intersection n x) | x <- relatedElems n c]--------------------------------------------------------------------------------------------------> instance (Container c, Inters (CElem c)) => Subsets (Maybe c) where-> type Elem (Maybe c) = Elem (CElem c)--> domain = maybe (error "domain vanished") (S.unions . map domain . fromC)-#ifdef TEST-> subsets = maybe [] (subsets . mconcat . map toSimple . fromC)-#endif-> empty _ = Nothing--> emptySubsets d -> | S.null d = Just emptyC-> | otherwise = Just $ insertL (emptySubsets d) emptyC--> subsetsNum = subsetsNumStep--> isTriviallyEmpty Nothing = True-> isTriviallyEmpty _ = False---> instance (Inters a, Container c, a ~ CElem c) => SetSum a (Maybe c) where-> setSum' = addToContainer----------------------------------------------------------------------> data EmptyEqual a--> instance Decision (EmptyEqual a) where-> type DecisionDomain (EmptyEqual a) = Equal a-> holds _ (Equal _ n) = n == 0--> data SetAsEmptyEqual a--> instance Ord a => Bijection (SetAsEmptyEqual a) where-> -> type From (SetAsEmptyEqual a) = S.Set a-> type To (SetAsEmptyEqual a) = Equal a-> -> fw _ d = Equal d 0-> bw _ (Equal d 0) = d-> bw _ _ = S.empty ---------------------------------------------------------------------Auxiliary Definitions-------------------------#ifdef TEST-| Natural number type with @Serial@ instance for testing.--> type Nat = Number.Peano.T--> instance Serial Number.Peano.T where-> series = cons0 Zero \/ cons1 Succ--> infix 1 <==>-> (<==>) :: Bool -> Bool -> Bool-> (<==>) = (==)-#endif----| Cached binomial numbers. The first arguent should be non-negative.--> binomial :: Int -> Int -> Integer-> binomial m n -> | n' < 0 = 0-> | otherwise = pascalsTriangle !! m !! n'-> where-> n' = min n (m-n)--| Pascal's triangle. It has to be a global constant to be cached.--> pascalsTriangle :: [[Integer]]-> pascalsTriangle -> = iterate nextRow [1] where nextRow r = zipWith (+) (0:r) (r++[0])+> cachedSize :: Layouts c => c -> CachedSize c+> cachedSize c = cachedSize_ (numOfLayouts c) c +> cachedSize_ 0 c = impossible+> cachedSize_ n c = CachedSize (n, c) -Derived Instances------------------+> instance Layouts c => Layouts (CachedSize c) where -> $( derive makeBinary ''CachedSize )-> $( derive makeBinary ''Tr )+> type BitFieldElem (CachedSize c) = BitFieldElem c +> numOfLayouts (CachedSize (i, _)) = i+> newLayout = curry $ cachedSize . uncurry newLayout+> addConstraint e f x@(CachedSize (n, c)) = if n == numOfLayouts y then x else y +> where y = cachedSize $ addConstraint e f c+> impossible = CachedSize (0, impossible)
+ Core/Constraint.lhs view
@@ -0,0 +1,144 @@++> {-# LANGUAGE TypeFamilies, FlexibleContexts, UndecidableInstances, ScopedTypeVariables, EmptyDataDecls #-}++| Core data type for the game.++> module Core.Constraint+> where+++Import List+-----------++> import Core.SetContainer+> import Core.Square++> import Data.Binary+> import Data.SetClass++> --import Data.List hiding (null, union, (\\))+> import Prelude hiding (null)+++-------------------------------------++| @Constraint a@ represents ...++> data Constraint c+> = Constraint c Int+> deriving (Eq, Read, Show)++> -- should always hold+> constraint_invariant :: Set a => Constraint a -> Bool+> constraint_invariant (Constraint d n) = n >= 0 && n <= size d && size d > 0++> sizeConstraint :: Set a => Constraint a -> Integer+> sizeConstraint (Constraint d n) = binomial (size d) n+++> instance Binary a => Binary (Constraint a) where+> +> put (Constraint a b) = put (a, b)+> get = do (a,b) <- get+> return (Constraint a b)++> instance Set a => HasDomain (Constraint a) where++> type Domain (Constraint a) = a++> domain (Constraint a b) = a++> constraint :: Set a => a -> Int -> Constraint a+> constraint d i +> | constraint_invariant c = c+> | otherwise = error $ "makeConstraint: " ++ show (size d, i)+> where +> c = Constraint d i+>+> intersectionC :: Set a => Constraint a -> Constraint a -> [[Constraint a]]+> Constraint a av `intersectionC` Constraint b bv+> = [ filter valid+> [ Constraint (a `fastMinus` c) (av - cv)+> , Constraint c cv+> , Constraint (b `fastMinus` c) (bv - cv) +> ] +> | cv <- [min' .. max'] ] +> where +> +> c = intersection a b +> +> min' = 0 `max` (av - (size a - size c)) `max` (bv - (size b - size c)) +>+> max' = size c `min` av `min` bv +>+> valid (Constraint d n) = not (null d)+>+> x `fastMinus` y +> | size x == size y = empty+> | otherwise = x \\ y++-----------------------------------------++> data Clear+> data Bomb++> class Decide a where+> num :: Set b => a -> b -> Int++> instance Decide Bomb where num _ = size+> instance Decide Clear where num _ = const 0++> data (SetContainer a) => EitherC x a+> = EitherC (Domain (SetContainerElem a)) a+> -- deriving (Show)++> instance Show (EitherC x a) where++> instance (SetContainer a, Binary (Domain (SetContainerElem a)), Binary a) => Binary (EitherC x a) where+> +> put (EitherC a b) = put (a, b)+> get = do (a,b) <- get+> return (EitherC a b)+++> instance (SetContainer a, SetContainerElem a ~ Constraint b, Set b, Decide x) +> => SetContainer (EitherC x a) where++> type SetContainerElem (EitherC x a) = SetContainerElem a++> emptyC = EitherC empty emptyC++> decomp (EitherC i o) = [OneElem (Constraint i (num (undefined :: x) i)) | not (null i)] ++ decomp o++> insertL c@(Constraint s n) (EitherC i o)+> | n == num (undefined :: x) s = EitherC (i `union` s) o+> | otherwise = EitherC i (insertL c o)++> relatedElems c@(Constraint s _) (EitherC i o)+> = [ (Constraint e (num (undefined :: x) e), EitherC (i \\ e) o) +> | let e = s `intersection` i, not (null e) ]+> ++ [ (x, EitherC i o') | (x, o') <- relatedElems c o ]++++Auxiliary Definitions+---------------------++| Cached binomial numbers. The first arguent should be non-negative.++> binomial :: Int -> Int -> Integer+> binomial m n +> | n' < 0 = 0+> | otherwise = pascalsTriangle !! m !! n'+> where+> n' = min n (m-n)++| Pascal's triangle. It has to be a global constant to be cached.++> pascalsTriangle :: [[Integer]]+> pascalsTriangle +> = iterate nextRow [1] where nextRow r = 1: zipWith (+) r (tail r) ++ [1]++++
Core/Constraints.lhs view
@@ -9,56 +9,56 @@ > , clearProb > ) where +> import Data.SetClass (fromList, size)+ > import Core.Square > import Core.BitField-> import Data.PContainer-> import qualified Data.Set as S+> import Core.SetContainer+> import Core.Constraint -------------------------------- > type Constraints -> = CachedSize -> (Maybe -> (EitherC (EmptyEqual Square)-> (Tr (S.Set Square) (SetAsEmptyEqual Square))-> (EitherC (SmallStuff (Equal Square))-> (Index (Equal Square))-> [Equal Square]-> )-> )-> )+> = CachedSize+> (Maybe +> (EitherC Clear+> (EitherC Bomb+> [Constraint SquareSet]+> )+> )+> ) > solutions :: Constraints -> Integer-> solutions = subsetsNum+> solutions = numOfLayouts -> setSum :: [Square] -> Int -> Constraints -> Constraints+> setSum :: SquareSet -> Int -> Constraints -> Constraints > setSum ps v c-> = setSum' (Equal (S.fromList ps) v) c+> = addConstraint ps v c > initConstraints :: Board -> Int -> Constraints > initConstraints s m -> = setSum (squares s) m $ emptySubsets S.empty+> = newLayout (squares s) m > clearProb :: Square -> Constraints -> Rational > clearProb p g-> = fromIntegral (solutions $ setSum [p] 0 g) / fromIntegral (solutions g)+> = fromIntegral (solutions $ setSum (fromList [p]) 0 g) / fromIntegral (solutions g) -> distribution :: [Square] -> Constraints -> [Constraints]+> distribution :: SquareSet -> Constraints -> [Constraints] > distribution ps cs > = at ((/=0) . solutions) > (takeWhile ((/=0) . solutions))-> [setSum ps i cs | i<-[0..length ps]]+> [setSum ps i cs | i<-[0..size ps]] Auxiliary --------- -> foldrTill :: (a -> Bool) -> (a -> b -> b) -> ([a] -> b) -> [a] -> b-> foldrTill p c n (x:xs) | p x = x `c` foldrTill p c n xs-> foldrTill _ _ n xs = n xs+> foldrUntil :: (a -> Bool) -> (a -> b -> b) -> ([a] -> b) -> [a] -> b+> foldrUntil p c n (x:xs) | p x = x `c` foldrUntil p c n xs+> foldrUntil _ _ n xs = n xs > at :: (a -> Bool) -> ([a] -> [a]) -> [a] -> [a]-> at p = foldrTill (not . p) (:)+> at p = foldrUntil (not . p) (:)
+ Core/SetContainer.lhs view
@@ -0,0 +1,69 @@++> {-# LANGUAGE TypeFamilies, FlexibleContexts, UndecidableInstances, ScopedTypeVariables, EmptyDataDecls, RankNTypes, ExistentialQuantification #-}++| Core data type for the game.++> module Core.SetContainer+> where+++Import List+-----------++> import Data.Binary+> import Data.DeriveTH+> import Data.Derive.Binary+> import Data.Derive.Functor++> import Data.SetClass++> import Data.Maybe+> import Data.List+++------------------------------++> class Set (Domain a) => HasDomain a where++> type Domain a++> domain :: a -> Domain a++------------------------------++> class HasDomain (SetContainerElem c) => SetContainer c where+>+> type SetContainerElem c +> +> emptyC :: c +> decomp :: c -> [Decomp (SetContainerElem c)]+> insertL :: SetContainerElem c -> c -> c +> relatedElems :: SetContainerElem c -> c -> [(SetContainerElem c, c)] ++> data Decomp e+> = OneElem e+> | forall b. (SetContainer b, SetContainerElem b ~ e) => Dependents (SetContainerElem b) (SetContainerElem b) b++-------------------------------------++> instance HasDomain a => SetContainer [a] where+>+> type SetContainerElem [a] = a+>+> emptyC = []+> insertL = (:)+> decomp [] = []+> decomp [a] = [OneElem a]+> decomp (a:as) = case relatedElems a as of+> [] -> OneElem a: decomp as+> (b, c): _ -> [Dependents a b c]+> relatedElems x l = [(y, d) | (y, d) <- takeOut l, not (domain x `disjunct` domain y)] +++> takeOut l = [(y, xs ++ ys) | (xs, y:ys) <- zip (inits l) (tails l)]++++++
Core/Square.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Squares. module Core.Square @@ -17,21 +19,23 @@ , restrictSquare , squares , neighbours++ , SquareSet ) where -import Control.Monad import Data.Binary-import Data.DeriveTH-import Data.Derive.Binary import Data.Bits import Data.Maybe+import Data.SetClass+import qualified Data.IntSet as IS+import Prelude hiding (null) ----------- -- | Board of a board. newtype Board = S { unS :: Int }- deriving (Eq, Ord)+ deriving (Eq, Ord, Binary) instance Show Board where show = show . unS@@ -47,8 +51,8 @@ -- | Square on a board. newtype Square - = P Int - deriving (Eq, Ord)+ = P { unP :: Int } + deriving (Eq, Ord, Binary) instance Show Square where show = show . coords @@ -68,13 +72,13 @@ ----------------------------------- -- | Squares of a board.-squares :: Board -> [Square]-squares s = [P p | x <- [1..xSize s], p <- take (ySize s) [pack x 1 ..]]+squares :: Board -> SquareSet+squares s = fromList [P p | x <- [1..xSize s], p <- take (ySize s) [pack x 1 ..]] -- | Neighbours of a square on a board.-neighbours :: Board -> Square -> [Square]+neighbours :: Board -> Square -> SquareSet neighbours s (coords -> (i, j))- = catMaybes + = fromList $ catMaybes [square s (i+a) (j+b) | (a, b) <- [(-1,0),(-1,-1),(0,-1),(1,-1),(1,0),(1,1),(0,1),(-1,1)]] ----------------------- auxiliary functions@@ -88,9 +92,23 @@ pack :: Int -> Int -> Int pack i j = shiftL i 8 .|. j - --------------------------------- -$( derive makeBinary ''Square )-$( derive makeBinary ''Board )+newtype SquareSet = SS { unSS :: IS.IntSet } deriving (Show, Binary)++instance Set SquareSet where++ type SetElem SquareSet = Square++ toList = map P . toList . unSS+ fromList = SS . fromList . map unP+ size = size . unSS+ intersection = bi intersection+ (\\) = bi (\\)+ union = bi union+ null = null . unSS+ empty = SS empty++bi f a b = SS $ f (unSS a) (unSS b)+
Data/ChangeSet.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+ module Data.ChangeSet ( Set , changes
− Data/PContainer.lhs
@@ -1,267 +0,0 @@--> {-# LANGUAGE UndecidableInstances #-}--| Core data type for the game.--> module Data.PContainer-> where---Import List-------------- #ifdef TEST-- > import Test.LazySmallCheck hiding (empty)- > import Number.Peano-- #endif-- import Control.Monad--> import Data.Binary-> import Data.DeriveTH-> import Data.Derive.Binary-> import Data.Derive.Functor--> import qualified Data.Map as M-> import qualified Data.Set as S-- import Data.Monoid- import Data.Function- import Data.Maybe--> import Data.List-----------------------------------------> class Ord (P a) => Particles a where--> type P a-> particles :: a -> S.Set (P a)---> class Particles (CElem c) => Container c where--> type CElem c-> -> emptyC :: c-> fromC :: c -> [CElem c]-> insertL :: CElem c -> c -> c-> deleteL :: CElem c -> c -> c-> relatedElems :: CElem c -> c -> [CElem c]-------------------------> instance (Eq a, Particles a) => Container [a] where--> type CElem [a] = a--> emptyC = []-> fromC = id-> insertL = (:)-> deleteL = delete-> relatedElems x l = [y | y<-l, not (particles x `disjunct` particles y)] ----------------------------------------------> -> class Decision a where-> type DecisionDomain a-> holds :: a -> DecisionDomain a -> Bool--> data SmallStuff a--> instance Particles a => Decision (SmallStuff a) where-> type DecisionDomain (SmallStuff a) = a-> holds _ x = S.size (particles x) <= limit--> limit :: Int-> limit = 8--> data {- (Decision p, Container a, Container b, ...) => -} EitherC p a b-> = EitherC a b-> deriving (Show)--> instance forall a b p. (Container a, Container b, CElem a ~ CElem b, Decision p, DecisionDomain p ~ CElem a) -> => Container (EitherC p a b) where--> type CElem (EitherC p a b) = CElem a--> emptyC = EitherC emptyC emptyC--> fromC (EitherC i o) = fromC i ++ fromC o--> insertL c (EitherC i o)-> | holds (undefined :: p) c = EitherC (insertL c i) o-> | otherwise = EitherC i (insertL c o)--> deleteL c (EitherC i o)-> | holds (undefined :: p) c = EitherC (deleteL c i) o-> | otherwise = EitherC i (deleteL c o)--> relatedElems c (EitherC i o) = relatedElems c i ++ relatedElems c o---------------------------------> class Bijection x where--> type From x-> type To x-> -> fw :: x -> From x -> To x-> bw :: x -> To x -> From x--> newtype Tr b x = Tr { unTr :: b }--> instance Show (Tr b x) where---> instance (Container b, Bijection x, CElem b ~ From x, Particles (To x)) => Container (Tr b x) where--> type CElem (Tr b x) = To x-> -> emptyC = Tr emptyC-> fromC = map (fw (undefined :: x)) . fromC . unTr-> insertL x = Tr . insertL (bw (undefined :: x) x) . unTr-> deleteL x = Tr . deleteL (bw (undefined :: x) x) . unTr-> relatedElems x = map (fw (undefined :: x)) . relatedElems (bw (undefined :: x) x) . unTr-> ---------------------------------------------------------------------------------------> {- class Fork a where-> type FromA a-> type FromB a-> type To a-> bw :: a -> To a -> (Maybe (FromA a), Maybe (FromB a))-> fw :: a -> Either (FromA a) (FromB a) -> To a---> data {- (Decision p, Container a, Container b, ...) => -} EitherC p a b-> = EitherC a b-> deriving (Show)--> instance forall a b p. (Container a, Container b, Fork p, CElem a ~ FromA p, CElem b ~ FromB p, Particles (To p)) -> => Container (EitherC p a b) where--> type CElem (EitherC p a b) = To p--> emptyC = EitherC emptyC emptyC--> fromC (EitherC i o) = map (fw (undefined :: p)) $ map Left (fromC i) ++ map Right (fromC o)--> insertL c (EitherC i o) = case bw (undefined :: p) c of-> Left x -> EitherC (insertL x i) o-> Right x -> EitherC i (insertL x o)--> deleteL c (EitherC i o) = case bw (undefined :: p) c of-> Left x -> EitherC (deleteL x i) o-> Right x -> EitherC i (deleteL x o)--> relatedElems c (EitherC i o) = map (fw (undefined :: p)) $ map Left (relatedElems c i) ++ map Right (relatedElems c o)----------------------------------------------------------------------> data SizeFork a--> instance Particles a => Fork (SizeFork a) where-> type FromA (SizeFork a) = a-> type FromB (SizeFork a) = a-> type To (SizeFork a) = a-> bw _ x = if S.size (particles x) <= limit then x else Right x-> fw (Left x) = x-> fw (Right x) = x---> limit :: Int-> limit = 8 -}-----------------------------------------------------------------------------> data Particles a => Index a-> = Index { unIndex :: M.Map (P a) [a] }--> instance Show (Index a) where---> instance (Binary a, Particles a, Binary (P a)) => Binary (Index a) where--> put = put . unIndex-> get = fmap Index get--> instance (Particles a, Ord (P a), Eq a) => Container (Index a) where--> type CElem (Index a) = a--> emptyC = Index M.empty--> fromC = nub . concat . M.elems . unIndex--> insertL c cs = Index $ foldr f (unIndex cs) $ S.toList $ particles c-> where-> f p m' = case M.lookup p m' of-> Nothing -> M.insert p [c] m'-> Just cs -> M.insert p (c:cs) m'--> deleteL c cs = Index $ foldr f (unIndex cs) $ S.toList $ particles c-> where-> f p m' = case M.lookup p m' of-> Just cs -> case delete c cs of-> [] -> M.delete p m'-> l -> M.insert p l m'--> relatedElems c cs = nub $ concatMap f $ S.toList $ particles c-> where -> f p = case M.lookup p (unIndex cs) of-> Just cs -> cs-> Nothing -> []------------------------------------> instance Container c => Container (Maybe c) where--> type CElem (Maybe c) = CElem c--> emptyC = Just emptyC-> fromC = maybe (error "fromC") fromC-> insertL e = fmap (insertL e)-> deleteL e = fmap (deleteL e)-> relatedElems e = maybe undefined (relatedElems e)-----------------------------> instance Ord a => Particles (S.Set a) where-> type P (S.Set a) = a-> particles = id---> instance Ord c => Container (S.Set c) where--> type CElem (S.Set c) = S.Set c-> -> emptyC = S.empty-> fromC d = [ d | not $ S.null d ]-> insertL c d = d `S.union` particles c -> deleteL c d = d S.\\ particles c -> relatedElems c d = [ e | let e = d `S.intersection` particles c, not $ S.null e ]---------------------------------------------------| Test whether two sets have common elements.--> disjunct :: Ord a => S.Set a -> S.Set a -> Bool-> disjunct a b = S.null (S.intersection a b)----> $( derive makeBinary ''EitherC )-
+ Data/SetClass.lhs view
@@ -0,0 +1,64 @@++> {-# LANGUAGE TypeFamilies #-}++> module Data.SetClass+> where+++Import List+-----------++> import qualified Data.Set as S+> import qualified Data.IntSet as IS++> import Prelude hiding (null)+++-------------------------------------++> class Set a where++> type SetElem a++> toList :: a -> [SetElem a]+> fromList :: [SetElem a] -> a+> size :: a -> Int+> intersection :: a -> a -> a+> (\\) :: a -> a -> a+> union :: a -> a -> a+> null :: a -> Bool+> empty :: a+++> instance Ord a => Set (S.Set a) where++> type SetElem (S.Set a) = a++> toList = S.toList+> fromList = S.fromList+> size = S.size+> intersection = S.intersection+> (\\) = (S.\\)+> union = S.union+> null = S.null+> empty = S.empty+++> instance Set IS.IntSet where++> type SetElem IS.IntSet = Int++> toList = IS.toList+> fromList = IS.fromList+> size = IS.size+> intersection = IS.intersection+> (\\) = (IS.\\)+> union = IS.union+> null = IS.null+> empty = IS.empty+++> disjunct :: Set a => a -> a -> Bool+> disjunct a b = null (intersection a b)++
Driver.hs view
@@ -17,29 +17,29 @@ -------------- -type Transition st a - = st -> ([a], [Timed a], UTCTime -> IO (), st)+type Transition st event + = st -> ([event], [Timed event], UTCTime -> IO (), st) -newtype DriverState st a - = DriverState (MVar (M.Map a ThreadId, st))+newtype DriverState st event+ = DriverState (MVar (M.Map event ThreadId, st)) ----------------- -initDriverState :: st -> IO (DriverState st a)+initDriverState :: st -> IO (DriverState st event) initDriverState st = do state <- newMVar (M.empty, st) return $ DriverState state -takeState :: DriverState st a -> IO ([a], st)+takeState :: DriverState st event -> IO ([event], st) takeState (DriverState dst) = do (ma, st) <- takeMVar dst return (M.keys ma, st) applyTransition- :: (Eq a, Ord a, Show a) - => DriverState st a- -> (a -> Transition st a) - -> Transition st a+ :: (Ord event, Show event) + => DriverState st event+ -> (event -> Transition st event) + -> Transition st event -> IO () applyTransition (DriverState dst) action transition = appTransition Nothing transition
Driver/Simplified.hs view
@@ -21,13 +21,13 @@ ----------------- applyTransition- :: (Eq a, Ord a, Show a, Show b) + :: (Ord event, Show event, Show b) => LogState- -> DriverState st a- -> [(st -> Bool, a, st -> When)]+ -> DriverState st event+ -> [(st -> Bool, event, st -> When)] -> (UTCTime -> b -> IO ())- -> (a -> Transition st) - -> a+ -> (event -> Transition st) + -> event -> IO () applyTransition logState dst triggers handleResponse transition a
State.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE TemplateHaskell #-}+ module State where import Configuration
State/Functions.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE PatternGuards #-}+ module State.Functions where import Configuration@@ -6,6 +8,7 @@ import Core.Constraints import Data.Maybe+import Data.SetClass (toList) import Control.Monad import System.Random import Data.List@@ -19,7 +22,7 @@ resetHiddenProbs c gs = gs { maxHiddenProb = Nothing , hiddenProbs = M.empty- , noHiddenProbs = squares (size c) \\ M.keys (revealResults gs)+ , noHiddenProbs = toList (squares (size c)) \\ M.keys (revealResults gs) } @@ -136,12 +139,14 @@ -- reveal / mark / hint can be done revealCanBeDone st- = markCanBeDone st+ = isNothing (interrupt st)+ && not (isFinished st) && isNothing (revealing st) -- mark can be done markCanBeDone st = isNothing (interrupt st)+ && mines_left st > 0 && not (isFinished st) -- the timer is active@@ -169,19 +174,36 @@ information :: State -> Double information st - | b == 1 = 1- | otherwise = luckFunction a / luckFunction b+ | all == 1 || s == 1 = 1+ | otherwise = 1 - logBase 2 (fromIntegral s) / logBase 2 (fromIntegral all) where- i = fromIntegral $ allSolutions st- a = fromIntegral (solutions $ constraints $ game st) / i- b = 1 / i+ all = allSolutions st+ s = solutions $ constraints $ game st + prec = 100++-- base 2 logarithm for large numbers+log2 :: (Ord a, Num a) => Int -> a -> Double+log2 prec n = f 0 1 1 1 n where++ f :: (Ord a, Num a) => Int -> Int -> a -> a -> a -> Double+ f a b twoa twoam1 nb = case twoa `compare` nb of+ LT -> f (a+1) b (2*twoa) twoa nb+ GT | b < prec -> f (2*a-1) (2*b) (twoam1 * twoa) (twoam1 * twoam1) (nb*nb)+ _ -> fromIntegral a / fromIntegral b++ allSquares = squares . size . configuration luck :: State -> Double luck = luckFunction . alive . game +luckFunction :: Rational -> Double+luckFunction x + = max (- 1/2 * logBase 2 (realToFrac x)) 0++ -------------- other free g p @@ -283,10 +305,6 @@ -------------------------luckFunction :: Rational -> Double-luckFunction x - = max (- 1/2 * logBase 2 (realToFrac x)) 0 -- megmondja hogy óránként várhatóan hányszor tudnánk teljesíteni egy klasszikus játékot successFunction :: Int -> Rational -> Rational
Step.hs view
@@ -11,6 +11,7 @@ import Data.Ratio import Data.List+import Data.SetClass (fromList) import Data.Maybe import System.Random import Data.Binary@@ -36,10 +37,10 @@ step :: Configuration -> Square -> Constraints -> StdGen -> RevealResult step conf p cs r - | dead = RevealResult prob Nothing (setSum [p] 1 cs) r_+ | dead = RevealResult prob Nothing (setSum (fromList [p]) 1 cs) r_ | otherwise = x `seq` RevealResult prob (Just x) (l !! x) r' where- cs' = setSum [p] 0 cs+ cs' = setSum (fromList [p]) 0 cs l = distribution (neighbours (size conf) p) cs'
Transition/Managed.hs view
@@ -18,6 +18,7 @@ import qualified State as S import Driver.Log +import Data.SetClass (toList) import Data.List import Data.Maybe @@ -97,7 +98,7 @@ = [] where ch | isNothing (changes ost) || e == UpdateTable- = [(p, f p) | p <- squares . size_ . state $ st]+ = [(p, f p) | p <- toList . squares . size_ . state $ st] | Just (ost', l) <- changes ost , f' <- squareState ost' = [(p, q) | p <- nub $ newChanges ++ l, let q = f p, q /= f' p]
Transition/Response.hs view
@@ -13,6 +13,7 @@ import Transition.Graphics import Data.Maybe+import Data.SetClass (toList) import Data.List import qualified Data.ChangeMap as M import qualified Data.ChangeSet as S@@ -76,7 +77,7 @@ -- new table simptoms: || length (undo st) < length (undo ost) || size_ st /= size_ ost- -> allSquares st+ -> toList $ allSquares st _ -> concat -- nub lesz később [ catMaybes $ diff [mouseFocus ost, mouseFocus st]
Transition/State.hs view
@@ -11,6 +11,7 @@ import Core.Constraints import Data.Maybe+import Data.SetClass (toList) import Data.List import Control.Monad (join) import qualified Data.ChangeMap as M@@ -311,7 +312,7 @@ f g = g { hiddenProbs = M.fromList l, noHiddenProbs = [], maxHiddenProb = Just (maximum $ map snd l) } where h p = (p, round $ 100 * clearProb p (constraints g))- l = map h $ allSquares st \\ M.keys (revealResults g)+ l = map h $ toList (allSquares st) \\ M.keys (revealResults g) degradeHint st = st { hint = f $ hint st } where@@ -365,7 +366,7 @@ = [p] revTarget p st | Just (Just n) <- M.lookup p $ revealResults $ game st- , ng <- neighbours (size_ st) p+ , ng <- toList $ neighbours (size_ st) p , n == length [x | x <- ng, S.member x $ marked $ game st ] = filter (free $ game st) ng revTarget _ _ @@ -414,7 +415,7 @@ neigh | Just 0 <- mi , recursive rev- = [p | p<- neighbours (size_ st) fo, free g p, p `notElem` recRevealing rev]+ = [p | p<- toList $ neighbours (size_ st) fo, free g p, p `notElem` recRevealing rev] | otherwise = []
minesweeper.cabal view
@@ -1,5 +1,5 @@ name: minesweeper-version: 0.8.8.5+version: 0.8.9 category: Game synopsis: Minesweeper game which is always solvable without guessing description: @@ -46,7 +46,7 @@ derive, gtk >= 0.10, cairo >= 0.10,- glade+ glade >= 0.10 if flag(tests) build-depends:@@ -61,10 +61,12 @@ other-modules: Data.ChangeMap, Data.ChangeSet,- Data.PContainer,+ Data.SetClass, System.Random.Instances, Core.Square,+ Core.SetContainer,+ Core.Constraint, Core.BitField, Core.Constraints,