diff --git a/Configuration.hs b/Configuration.hs new file mode 100644 --- /dev/null +++ b/Configuration.hs @@ -0,0 +1,77 @@ +module Configuration + ( Configuration + ( Configuration + , size + , mines + , strategy + , deathProbRange + , allowedDeaths + , recursiveReveal + , undoAllowed + , hintAllowed + ) + , numOfSolutions + , Strategy (..) + , HintType (..) + , Probability + , configuration' + ) where + +import Core.Square +import Core.Constraints + +import Control.Monad +import Data.Binary +import Data.DeriveTH +import Data.Derive.Binary + +---------------------------------- + +data Configuration + = Configuration + { size :: Board + , mines :: Int + , numOfSolutions_ :: Integer -- cached, determined by size and mines + + , strategy :: Strategy + , deathProbRange :: (Probability, Probability) + -- (a, b): ha p valséggel halnánk meg, akkor p>a esetén meghalunk, p Integer +numOfSolutions = numOfSolutions_ + +configuration' :: Configuration -> Configuration +configuration' c + = c { numOfSolutions_ = solutions $ initConstraints (size c) (mines c) } + +------------------------ + +$( derive makeBinary ''HintType ) +$( derive makeBinary ''Strategy ) +$( derive makeBinary ''Configuration ) + + diff --git a/Core.hs b/Core.hs deleted file mode 100644 --- a/Core.hs +++ /dev/null @@ -1,247 +0,0 @@ --- | Core data types and functions for the game. -module Core - ( MMap - , emptyMMap - , setSum - , solutions' - ) where - -------------------------------------------- - -import Place -import PlaceSet -import qualified PlaceMap as M - -import Data.Function -import Data.Maybe -import Data.List hiding ((\\), insert, delete) -import qualified Data.List as List - - -------------------------------------------- - -data Constraint - = Constraint - { places_ :: PlaceSet - , value :: Int - } - - deriving Eq - -data ConstraintView - = BigConstraint PlaceSet Int - | SmallConstraint PlaceSet Int - | Clear Place - | Mine Place - -view :: Constraint -> ConstraintView -view (Constraint ps v) - | size ps == 1 && v == 1 = Mine $ head $ placeSetToList ps - | size ps == 1 && v == 0 = Clear $ head $ placeSetToList ps - | size ps > big = BigConstraint ps v - | otherwise = SmallConstraint ps v - -big :: Int -big = 10 - - ---------------------------------------- - -constraint :: [Place] -> Int -> Constraint -constraint ps v - = Constraint (listToPlaceSet ps) v - -subConstraint :: Constraint -> Constraint -> Bool -subConstraint a b = places_ a `isSubsetOf` places_ b - -similarConstraint :: Constraint -> Constraint -> Bool -similarConstraint a b = places_ a == places_ b - - --- csak akkor, ha subConstraint! -(.-.) :: Constraint -> Constraint -> Constraint -Constraint ps v .-. Constraint ps' v' = Constraint (ps \\ ps') (v-v') - -connectionStrength :: Constraint -> Constraint -> [Constraint] -connectionStrength (Constraint ps v) (Constraint ps' v') = [Constraint l i | i<-[min_ .. max_]] where - - min_ = maximum [0, v - (size ps - m), v' - (size ps' - m)] - max_ = minimum [m, v, v'] - - m = size l - l = intersection ps ps' - -constraintSolutions :: Constraint -> Integer -constraintSolutions (Constraint ps v) = binom (size ps) v - - -binom :: Int -> Int -> Integer -binom m n = binoms !! m !! min n (m-n) - -binoms :: [[Integer]] -binoms = iterate f [1] where f l = zipWith (+) (l++[0]) ([0]++l) - - -------------------------------------------- - - -data Constraints - = Unsolvable - | Solvable - [Constraint] -- big constraints (usually one) - PlaceSet -- cleared places - PlaceSet -- places with mines - (M.PlaceMap [Constraint]) -- other constraints - ---------------------------------------- - -addConstraintSimple :: Constraint -> Constraints -> Constraints -addConstraintSimple _ Unsolvable = Unsolvable -addConstraintSimple c (Solvable bc cl mi m) = case view c of - Clear p -> Solvable bc (insert p cl) mi m - Mine p -> Solvable bc cl (insert p mi) m - BigConstraint _ _ -> Solvable (c:bc) cl mi m - SmallConstraint ps _-> Solvable bc cl mi $ foldr f m $ placeSetToList ps - where - - f p m' = case M.lookup p m' of - Nothing -> M.insert p [c] m' - Just cs -> M.insert p (c:cs) m' - -deleteConstraint :: Constraint -> Constraints -> Constraints -deleteConstraint _ Unsolvable = Unsolvable -deleteConstraint c (Solvable bc cl mi m) = case view c of - Clear p -> Solvable bc (delete p cl) mi m - Mine p -> Solvable bc cl (delete p mi) m - BigConstraint _ _ -> Solvable (deleteBy similarConstraint c bc) cl mi m - SmallConstraint ps _-> Solvable bc cl mi $ foldr f m $ placeSetToList ps - where - - f p m' = case M.lookup p m' of - Just cs -> case deleteBy similarConstraint c cs of - [] -> M.delete p m' - l -> M.insert p l m' - -deleteConstraints :: [Constraint] -> Constraints -> Constraints -deleteConstraints cs m = foldr deleteConstraint m cs - -dependentConstraints :: Constraint -> Constraints -> [Constraint] -dependentConstraints c@(Constraint ps _) (Solvable bc cl mi m) - = List.delete c $ l ++ filter (not . disjunct ps . places_) bc - where - l = map toClear (placeSetToList $ intersection cl ps) - ++ map toMine (placeSetToList $ intersection mi ps) - ++ nub (concatMap f $ placeSetToList ps) - - toClear p = constraint [p] 0 - toMine p = constraint [p] 1 - - f p = case M.lookup p m of - Just cs -> cs - Nothing -> [] - ---------------------------------------- - --- calculate number of different solutions -solutions :: Constraints -> Integer -solutions Unsolvable = 0 -solutions (Solvable bc _ _ cs) = product (map (constraintSolutions . fst) indep) * case dep of - [] -> 1 - ((c, xs): _) -> let - cs' = minimumBy (compare `on` length) $ map (connectionStrength c) xs - in sum [solutions (addConstraint y s'') | y<-cs'] - where - s' = Solvable bc empty empty cs - s'' = deleteConstraints (map fst indep) s' - - (indep, dep) = partition (null . snd) $ map (`dependentConstraints_` s') $ nub (concatMap snd $ M.toList cs) ++ bc - -dependentConstraints_ c cs = (c, dependentConstraints c cs) - -solvable :: Constraints -> Bool -solvable Unsolvable = False -solvable (Solvable bc _ _ cs) = case concatMap snd (M.toList cs) ++ bc of - [] -> True - (c: _) -> case dependentConstraints c s' of - [] -> solvable (deleteConstraint c s') - (x:_) -> let - cs' = connectionStrength c x - in or [solvable (addConstraint y s') | y<-cs'] - where - s' = Solvable bc empty empty cs - --- may be faster? -omittable :: Constraint -> Constraints -> Bool -omittable c@(Constraint ps v) cs = all (not . solvable) [addConstraint (Constraint ps i) cs | i <- [v-1,v-2..0] ++ [v+1..size ps]] -{- - - if p1 + ... + pI = n has no solution except for n = n0, then p1 + ... + pI = n0 is not needed: - pA + pB = 1, pB + pC = 1, pC + pD = 1, pD + pA = 1 - --> pA + pB = 1, pB + pC = 1, pC + pD = 1 - - ... --} - ---------------------------------------- - -addConstraintSmart :: Constraint -> Constraints -> Constraints -addConstraintSmart c cs - | not (solvable cs') = Unsolvable --- | omittable c cs = cs -- not really needed - | otherwise = cs' - where - cs' = addConstraint c cs - - -addConstraint :: Constraint -> Constraints -> Constraints -addConstraint _ Unsolvable = Unsolvable -addConstraint n@(Constraint ps v) c - | v<0 || v>s = Unsolvable - | s==0 = c - | s>1 && v==0 = addConstraints [constraint [p] 0 | p<- placeSetToList ps] c - | s>1 && v==s = addConstraints [constraint [p] 1 | p<- placeSetToList ps] c - | any ((/= v) . value) similar = Unsolvable - | not (null similar) = c - | any (==0) str = Unsolvable - | ((x, [y]): _) <- oneStrength - = addConstraints [n .-. y, x .-. y, y] $ deleteConstraint x c - | otherwise = addConstraints [x .-. n | x <- supDomains] $ addConstraintSimple n $ deleteConstraints supDomains c - where - s = size ps - - supDomains = [x | x <- dep, n `subConstraint` x] - - oneStrength = filter ((==1) . length . snd) strength - str = map (length . snd) strength - - strength = [(x, connectionStrength n x) | x <- dep, x `subConstraint` n] - - (similar, dep) = partition (similarConstraint n) $ dependentConstraints n c - - -addConstraints :: [Constraint] -> Constraints -> Constraints -addConstraints l c = foldr addConstraint c l - - - ------------------------------------------------ - -data MMap = MMap Constraints Integer - -emptyMMap :: MMap -emptyMMap = mkMMap $ Solvable [] empty empty M.empty - -mkMMap :: Constraints -> MMap -mkMMap c = MMap (if s==0 then Unsolvable else c) s - where - s = solutions c - -solutions' :: MMap -> Integer -solutions' (MMap _ i) = i - -setSum :: PlaceSet -> Int -> MMap -> MMap -setSum ps v (MMap c _) = mkMMap $ addConstraint (Constraint ps v) c - ---------------------------------------- - - - - diff --git a/Core/BitField.lhs b/Core/BitField.lhs new file mode 100644 --- /dev/null +++ b/Core/BitField.lhs @@ -0,0 +1,453 @@ + +> {-# LANGUAGE FlexibleInstances #-} +> {-# LANGUAGE UndecidableInstances #-} + +| Core data type for the game. + +> module Core.BitField +> where + + +Import List +----------- + +> import Data.PContainer + +> import Test.LazySmallCheck hiding (empty) +> import Number.Peano +> 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 +--------------------- + +| Subset of all subsets of a given set. + +> data SimpleSubsets a +> = SimpleSubsets (Set a) [Set a] +> deriving (Show) + +> instance Ord a => Eq (SimpleSubsets a) where +> +> SimpleSubsets da sa == SimpleSubsets db sb +> = da == db && sort sa == sort sb + +> 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) + +| This property states that @Simple@ is universal. + +> 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) + +| 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]) + + +Derived Instances +----------------- + +> $( derive makeBinary ''CachedSize ) +> $( derive makeBinary ''Tr ) + + + + diff --git a/Core/Constraints.lhs b/Core/Constraints.lhs new file mode 100644 --- /dev/null +++ b/Core/Constraints.lhs @@ -0,0 +1,64 @@ +-- | Core data type for the game. + +> module Core.Constraints +> ( Constraints +> , initConstraints +> , setSum +> , solutions +> , distribution +> , clearProb +> ) where + +> import Core.Square +> import Core.BitField +> import Data.PContainer +> import qualified Data.Set as S + +-------------------------------- + +> type Constraints +> = CachedSize +> (Maybe +> (EitherC (EmptyEqual Square) +> (Tr (S.Set Square) (SetAsEmptyEqual Square)) +> (EitherC (SmallStuff (Equal Square)) +> (Index (Equal Square)) +> [Equal Square] +> ) +> ) +> ) + +> solutions :: Constraints -> Integer +> solutions = subsetsNum + +> setSum :: [Square] -> Int -> Constraints -> Constraints +> setSum ps v c +> = setSum' (Equal (S.fromList ps) v) c + + +> initConstraints :: Board -> Int -> Constraints +> initConstraints s m +> = setSum (squares s) m $ emptySubsets S.empty + +> clearProb :: Square -> Constraints -> Rational +> clearProb p g +> = fromIntegral (solutions $ setSum [p] 0 g) / fromIntegral (solutions g) + +> distribution :: [Square] -> Constraints -> [Constraints] +> distribution ps cs +> = at ((/=0) . solutions) +> (takeWhile ((/=0) . solutions)) +> [setSum ps i cs | i<-[0..length 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 + +> at :: (a -> Bool) -> ([a] -> [a]) -> [a] -> [a] +> at p = foldrTill (not . p) (:) + + diff --git a/Core/Square.hs b/Core/Square.hs new file mode 100644 --- /dev/null +++ b/Core/Square.hs @@ -0,0 +1,96 @@ + +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Squares. +module Core.Square + ( + -- * Types + Board + , board + , xSize + , ySize + + , Square + , coords + , square + , restrictSquare + , squares + , neighbours + ) where + +import Control.Monad +import Data.Binary +import Data.DeriveTH +import Data.Derive.Binary +import Data.Bits +import Data.Maybe + +----------- + +-- | Board of a board. +newtype Board + = S { unS :: Int } + deriving (Eq, Ord) + +instance Show Board where + show = show . unS + +xSize, ySize :: Board -> Int +xSize = fst . unpack . unS +ySize = snd . unpack . unS + +board :: Int -> Int -> Board +board i j | i `between` (1, 255) && j `between` (1, 255) = S $ pack i j + +-------------------------- + +-- | Square on a board. +newtype Square + = P Int + deriving (Eq, Ord) + +instance Show Square where + show = show . coords + +coords :: Square -> (Int, Int) +coords (P i) = unpack i + +square :: Board -> Int -> Int -> Maybe Square +square s i j + | i `between` (1, xSize s) && j `between` (1, ySize s) = Just $ P $ pack i j + | otherwise = Nothing + +restrictSquare :: Board -> Square -> Square +restrictSquare s (coords -> (i, j)) + = P $ pack (max 1 $ min (xSize s) i) (max 1 $ min (ySize s) j) + +----------------------------------- + +-- | Squares of a board. +squares :: Board -> [Square] +squares s = [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 s (coords -> (i, j)) + = 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 + +infix 4 `between` +a `between` (b, c) = b <= a && a <= c + +unpack :: Int -> (Int, Int) +unpack i = (shiftR i 8, i .&. 255) + +pack :: Int -> Int -> Int +pack i j = shiftL i 8 .|. j + + +--------------------------------- + +$( derive makeBinary ''Square ) +$( derive makeBinary ''Board ) + diff --git a/Data/ChangeMap.hs b/Data/ChangeMap.hs new file mode 100644 --- /dev/null +++ b/Data/ChangeMap.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE NoMonomorphismRestriction, TemplateHaskell #-} +module Data.ChangeMap + ( Map + , changes + , forget + , insert + , delete + , lookup + , size + , empty + , keys + , member + , notMember + , alter + , fromList + , null + , adjust + ) where + +import qualified Data.Map as M +import Prelude hiding (lookup, null) + +import Data.Binary +{- +import Control.Monad +import Data.DeriveTH +import Data.Derive.Binary + +--import Data.Binary +import Generics.MultiRec.Base +import Generics.MultiRec.Binary +-} + +-------------------- + +data Ord k => Map k a = ChangeMap + { toMap :: M.Map k a + , changes :: [k] + } + deriving (Show, Read) + +forget (ChangeMap m _) = ChangeMap m [] + +fromMap m = ChangeMap m (M.keys m) + +--------------------------- + +insert k a (ChangeMap m c) = ChangeMap (M.insert k a m) (k: c) + +delete k (ChangeMap m c) = ChangeMap (M.delete k m) (k: c) + +alter f k (ChangeMap m c) = ChangeMap (M.alter f k m) (k: c) + +adjust f k (ChangeMap m c) = ChangeMap (M.adjust f k m) (k: c) + + +lookup k = M.lookup k . toMap + +member k = M.member k . toMap + +notMember k = M.notMember k . toMap + +size = M.size . toMap + +keys = M.keys . toMap + +null = M.null . toMap + + +empty = fromMap $ M.empty + +fromList = fromMap . M.fromList + + + + + + + + +-- $( derive makeBinary ''Map ) + + + + +instance (Ord k, Binary k, Binary a) => Binary (Map k a) where + put = put . toMap + get = fmap fromMap get +-- put = gput undefined +-- get = gget undefined + + + + diff --git a/Data/ChangeSet.hs b/Data/ChangeSet.hs new file mode 100644 --- /dev/null +++ b/Data/ChangeSet.hs @@ -0,0 +1,70 @@ +module Data.ChangeSet + ( Set + , changes + , forget + , insert + , delete + , size + , empty + , member + , notMember + , fromList + , fromDistinctAscList + , toList + , (\\) + ) where + +import qualified Data.Set as M + +import Data.Binary +{- +import Control.Monad +import Data.DeriveTH +import Data.Derive.Binary +-} +------------------------------ + +data Set k = ChangeSet + { toSet :: M.Set k + , changes :: [k] + } + deriving (Show, Read) + +forget (ChangeSet m _) = ChangeSet m [] + +fromSet s = ChangeSet s (M.toList s) + +---------------------- + +insert k (ChangeSet m c) = ChangeSet (M.insert k m) (k: c) + +delete k (ChangeSet m c) = ChangeSet (M.delete k m) (k: c) + + +size = M.size . toSet + +member k = M.member k . toSet + +notMember k = M.notMember k . toSet + +toList = M.toList . toSet + + +empty = fromSet $ M.empty + +fromList = fromSet . M.fromList + +fromDistinctAscList = fromSet . M.fromDistinctAscList + + +a \\ b = fromSet (toSet a M.\\ toSet b) + + +instance (Ord k, Binary k) => Binary (Set k) where + put = put . toSet + get = fmap fromSet get + + +-- $( derive makeBinary ''Set ) + + diff --git a/Data/PContainer.lhs b/Data/PContainer.lhs new file mode 100644 --- /dev/null +++ b/Data/PContainer.lhs @@ -0,0 +1,263 @@ + +> {-# LANGUAGE UndecidableInstances #-} + +| Core data type for the game. + +> module Data.PContainer +> where + + +Import List +----------- + +> import Test.LazySmallCheck hiding (empty) +> import Number.Peano + + 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 ) + diff --git a/Delay.hs b/Delay.hs deleted file mode 100644 --- a/Delay.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Delay - ( doLater - , cancelAction - , newCancelVar - , CancelVar - ) where - -import Control.Concurrent -import Control.Concurrent.MVar - --------------------- - -newtype CancelVar = C (MVar (Maybe ThreadId)) - -newCancelVar :: IO CancelVar -newCancelVar = fmap C $ newMVar Nothing - -cancelAction :: CancelVar -> IO () -cancelAction (C v) = do - swapMVar v Nothing - return () - -doLater :: RealFrac t => CancelVar -> t -> IO () -> IO () -doLater (C v) t action = do - tid <- forkIO $ do - threadDelay $ round $ 1000000 * t - mytid <- myThreadId - b <- readMVar v - case b of - Just tid | tid == mytid -> action - _ -> return () - swapMVar v (Just tid) - return () - - diff --git a/Driver.hs b/Driver.hs new file mode 100644 --- /dev/null +++ b/Driver.hs @@ -0,0 +1,82 @@ +module Driver + ( Transition + , DriverState + , applyTransition + , initDriverState + , takeState + ) where + +import When + +import Control.Concurrent +import Control.Concurrent.MVar +import Data.Maybe (catMaybes) +import Data.Time.Clock +import Data.Time.Format() +import qualified Data.Map as M + +-------------- + +type Transition st a + = st -> ([a], [Timed a], UTCTime -> IO (), st) + +newtype DriverState st a + = DriverState (MVar (M.Map a ThreadId, st)) + +----------------- + +initDriverState :: st -> IO (DriverState st a) +initDriverState st = do + state <- newMVar (M.empty, st) + return $ DriverState state + +takeState :: DriverState st a -> IO ([a], 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 + -> IO () + +applyTransition (DriverState dst) action transition = appTransition Nothing transition + where + appTransition this_action tr = do + time <- getCurrentTime + res <- modifyMVar dst $ \(am, st) -> do + + let (cs, as, res, new_st) = tr st + + let am' = maybe am (`M.delete` am) this_action + + mapM_ killThread $ catMaybes $ map (`M.lookup` am') $ cs ++ map snd as + + let am'' = foldl (flip M.delete) am' cs + + tids <- mapM (forkIO . initAction time) as + + let am''' = M.fromList (zip (map snd as) tids) `M.union` am'' + + return ((am''', new_st), res) + + res time + + initAction time (when, a) = do + case when of + Now -> return () + AfterEval x -> x `seq` return () + At t -> waitTill t + Later dt -> waitTill (addUTCTime dt time) + appTransition (Just a) (action a) + + +waitTill time = do + time' <- getCurrentTime + case round $ 1000000 * (time `diffUTCTime` time') of + n | n > 0 -> threadDelay n + _ -> return () + + diff --git a/Driver/Log.hs b/Driver/Log.hs new file mode 100644 --- /dev/null +++ b/Driver/Log.hs @@ -0,0 +1,80 @@ +module Driver.Log + ( Result (..) + , Transition + , DriverState + , applyTransition + , initDriverState + , takeState + ) where + +import When +import Log +import Driver (DriverState, initDriverState) +import qualified Driver as D + +import Data.Time.Clock +import Data.List + +-------------- + +type Transition st a b + = st -> Maybe (Result a b, st) + +data Result a b + = Result + { result :: b + , triggered :: [Timed a] + , cancelled :: [a] + } + + +----------------- + +takeState :: DriverState st a -> IO st +takeState = fmap snd . D.takeState + +applyTransition + :: (Eq a, Ord a, Show a, Show b) + => LogState + -> DriverState st a + -> (UTCTime -> b -> IO ()) + -> (a -> Transition st a b) + -> a + -> IO () + +applyTransition logState dst handleResponse transition a + = D.applyTransition dst tr (tr a) + + where + tr e st + | Just (res, new_st) <- transition e st + = (cancelled res, triggered res, f2 e res, new_st) + | otherwise + = ([], [], f1 e, st) + + f1 e _time + = writeLog logState [{-"Event " ++ -} show e ++ {- " at " ++ show time ++ -} " was ignored."] + + f2 e res time = do + writeLog logState $ ({-"Event " ++ -} show e {- ++ " at " ++ show time ++ " results:" -}) : map (" " ++) (showResult res) + handleResponse time $ result res + + +------------------------ logging -------------------- + +showResult :: (Show a, Show b) => Result a b -> [String] +showResult r = filter (not . null) + [ sh " cancelled" $ map show $ cancelled r + , sh " triggered" $ map f $ triggered r + , sh " result " $ [show $ result r] + ] + + where + sh :: String -> [String] -> String + sh _ [] = "" + sh s l = s ++ ": " ++ intercalate ", " l + + f (w, e) = show w ++ ": " ++ show e + + + diff --git a/Driver/Simplified.hs b/Driver/Simplified.hs new file mode 100644 --- /dev/null +++ b/Driver/Simplified.hs @@ -0,0 +1,46 @@ +module Driver.Simplified + ( Transition + , DriverState + , applyTransition + , initDriverState + , takeState + ) where + +import When +import Log (DriverState, initDriverState, takeState) +import qualified Log as D + +import Data.Time.Clock +import Data.List + +-------------- + +type Transition st + = st -> Maybe st + +----------------- + +applyTransition + :: (Eq a, Ord a, Show a, Show b) + => LogState + -> DriverState st a + -> [(st -> Bool, a, st -> When)] + -> (UTCTime -> b -> IO ()) + -> (a -> Transition st) + -> a + -> IO () + +applyTransition logState dst triggers handleResponse transition a + = D.applyTransition logState dst handleResponse tr a + where + tr e st + | Just (res, new_st) <- transition e st + = (cancelled res, triggered res, f2 e res, new_st) + | otherwise + = ([], [], f1 e, st) + + + + + + diff --git a/Event.hs b/Event.hs new file mode 100644 --- /dev/null +++ b/Event.hs @@ -0,0 +1,85 @@ +module Event where + +import Core.Square +import Configuration (Configuration) +import State (ScoreAttr, ScoreEntry) + +-------------------------------------- input ------------- + +type MousePos = Maybe Square + +data Event + = RevealEvent MousePos -- Nothing: by keyboard + | MarkEvent MousePos -- Nothing: by keyboard + | MouseMotion MousePos -- Nothing: mouse is outside + | NewEvent + | LeftEvent + | RightEvent + | UpEvent + | DownEvent + | UndoEvent + | RedoEvent + | HintEvent + | FullHintEvent + | ShowScores + | OpenPreferences + | PreferencesClosed (Maybe Configuration) + | NewScoreClosed (Maybe String) [ScoreAttr] + | FocusOut + | FocusIn MousePos -- Nothing: mouse is outside + + | UpdateTable + + -- jóváhagyások (legyen mindenről?) + | DrawingDone + | InfoDrawingDone + + | Init -- triggered? + + | Triggered Triggered -- nem kéne beágyazni ide + deriving (Eq, Ord, Show) + +data Triggered + = RevealDone + | SquareHintDone + | Tick + | FadeTick + | BusyTick + | InterruptVisible -- better name: LongInterrupt + deriving (Eq, Ord, Show) + + +---------------------------- output -------------------- + +type Responses = [Response] + +data Response + = DrawSquares Board [(Square, (Bool, BackGround, Sign))] + | ShowTime String -- gyorsulna szerkezetváltással + | ShowInfo String -- gyorsulna szerkezetváltással + | PopUpPreferences Configuration + | PopUpNewScore Configuration (Maybe Int) [ScoreEntry] [ScoreAttr] + deriving (Eq, Ord, Show) + +data BackGround + = Blue + | BlueGreen + | Green + | Reddish Int -- ^ 0-100 + deriving (Eq, Ord, Show) + +data Sign + = NoSign + | Bomb + | Death + | Clear Int -- ^ 0-8 + | Hint Int -- ^ 0-100 + | HintedBomb Int -- ^ 0-100 + | BusySign Int -- ^ phase 0-100 + deriving (Eq, Ord, Show) + + +isBomb Bomb = True +isBomb (HintedBomb _) = True +isBomb _ = False + diff --git a/GTK.hs b/GTK.hs new file mode 100644 --- /dev/null +++ b/GTK.hs @@ -0,0 +1,256 @@ +module GTK + ( GUIState + , guiState + , startGUI + , handleResponses + ) where + +import Configuration +import State +import Event +import Core.Square +import GTK.Square +import GTK.Preferences +import GTK.Score +import Paths_minesweeper + +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Glade +import Graphics.UI.Gtk.Gdk.EventM +import Graphics.Rendering.Cairo (liftIO) -- ??? + +import Data.Char +import Data.Maybe +import Data.Time.Clock +import Control.Concurrent + + +------------------------------------------------------ + +data GUIState = GUIState + { infoLabel :: Label + , timeLabel :: Label + , frame :: AspectFrame + , table :: DrawingArea + , window :: Window + , event :: Event -> IO () + , tSize :: MVar Board + + , setPref :: Configuration -> IO (Maybe Configuration) + , newScore :: Configuration -> Maybe Int -> [ScoreEntry] -> [ScoreAttr] -> IO (Maybe String, [ScoreAttr]) + } + +------------------------------------------------------ + +guiState :: (Event -> IO ()) -> IO () -> IO GUIState +guiState event saveState = do + unsafeInitGUIForThreadedRTS + + xml <- msglade + window <- xmlGetWidget xml castToWindow "window" + infoLabel <- xmlGetWidget xml castToLabel "infolabel" + timeLabel <- xmlGetWidget xml castToLabel "timelabel" + frame <- xmlGetWidget xml castToAspectFrame "frame" + table <- xmlGetWidget xml castToDrawingArea "drawingarea" + tSize <- newMVar $ board 1 1 -- $ error "module GTK: tSize was not defined" + setPref <- setPreferences xml + newScore <- newScore_ xml +-- showScores <- showScores_ xml + + let gst = GUIState + { timeLabel = timeLabel + , infoLabel = infoLabel + , frame = frame + , table = table + , event = event + , window = window + , tSize = tSize + , setPref = setPref + , newScore = newScore +-- , showScores= showScores + } + + table `on` leaveNotifyEvent $ alwaysTrue $ eventCrossing gst + table `on` motionNotifyEvent $ alwaysTrue $ eventMotion gst + table `on` buttonPressEvent $ alwaysTrue $ eventButt gst + table `on` keyPressEvent $ eventKey gst + table `on` exposeEvent $ alwaysTrue $ redrawCanvas gst + + onDestroy window $ saveState >> mainQuit + onFocusOut window $ const $ alwaysTrue $ event FocusOut + onFocusIn window $ const $ alwaysTrue $ eventFocusIn' gst + + mapM_ (addMenuItem xml) + [ ("quit", widgetDestroy window) + , ("new", event NewEvent) + , ("pref", event OpenPreferences) + , ("scores", event ShowScores) + , ("reveal", event $ RevealEvent Nothing) + , ("mark", event $ MarkEvent Nothing) + , ("undo", event UndoEvent) + , ("redo", event RedoEvent) + , ("hint", event HintEvent) + , ("fullhint",event FullHintEvent) + , ("help", popUpHelp) + , ("about", popUpAbout) + ] + + return gst + +startGUI :: GUIState -> IO () +startGUI gst = do + widgetShowAll $ window gst + mainGUI + + +------------------- input ------------------------- + +eventFocusIn' gst = do + pos <- getPosition gst + event gst $ FocusIn pos + +getPosition g = do + (x, y) <- widgetGetPointer (table g) + calculatePosition (realToFrac x, realToFrac y) g + +eventKey :: GUIState -> EventM EKey Bool +eventKey gst = do + k <- eventKeyName + liftIO $ case k of + "Right" -> alwaysTrue $ event gst RightEvent + "Left" -> alwaysTrue $ event gst LeftEvent + "Up" -> alwaysTrue $ event gst UpEvent + "Down" -> alwaysTrue $ event gst DownEvent + _ -> return False + +eventMotion :: GUIState -> EventM EMotion () +eventMotion gst = do + pos <- eventCoordinates + liftIO $ do + n <- calculatePosition pos gst + event gst $ MouseMotion n + +eventCrossing :: GUIState -> EventM ECrossing () +eventCrossing gst = + liftIO $ event gst $ MouseMotion Nothing + +eventButt :: GUIState -> EventM EButton () +eventButt gst = do + pos <- eventCoordinates + b <- eventButton + liftIO $ do + n <- calculatePosition pos gst + case (n, b) of + (Just _, LeftButton) -> event gst $ RevealEvent n + (Just _, RightButton) -> event gst $ MarkEvent n + _ -> return () + +redrawCanvas :: GUIState -> EventM EExpose () +redrawCanvas gst + = liftIO $ event gst UpdateTable + + +calculatePosition :: (Double, Double) -> GUIState -> IO (Maybe Square) +calculatePosition (x, y) g = do + win <- widgetGetDrawWindow $ table g + (width, height) <- drawableGetSize win + let (a, b) = (x / fromIntegral width, y / fromIntegral height) + s <- readMVar $ tSize g + return $ square s (ceiling (a * fromIntegral (xSize s))) (ceiling (b * fromIntegral (ySize s))) + + +----------------------- output -------------------- + +handleResponses :: GUIState -> UTCTime -> Responses -> IO () +handleResponses gui t + = mapM_ (forkIO . handleResponse gui t) + +handleResponse :: GUIState -> UTCTime -> Response -> IO () +handleResponse gst time e = case e of + DrawSquares size sl -> do + swapMVar (tSize gst) size -- ha megváltozott törölni a képernyőt!! + postGUISync $ redrawSigns gst size sl + waitTill (addUTCTime 0.02 time) + event gst DrawingDone + + ShowTime s -> do + postGUISync $ labelSetText (timeLabel gst) s + + ShowInfo s -> do + postGUISync $ labelSetText (infoLabel gst) s + waitTill (addUTCTime 0.02 time) + event gst InfoDrawingDone +{- + PopUpScores c es attrs -> do + attrs' <- postGUISync $ showScores gst c es attrs + event gst $ ScoresClosed attrs' +-} + PopUpNewScore c e es attrs -> do + (name, attrs') <- postGUISync $ newScore gst c e es attrs + event gst $ NewScoreClosed name attrs' + + PopUpPreferences c -> do + mc <- postGUISync $ setPref gst c + event gst $ PreferencesClosed mc + + +popUpHelp = do + xml <- msglade + a <- xmlGetWidget xml castToDialog "helpdialog" + dialogRun a + widgetDestroy a + +popUpAbout = do + xml <- msglade + a <- xmlGetWidget xml castToDialog "aboutdialog" + dialogRun a + widgetDestroy a + + +redrawSigns :: GUIState -> Board -> [(Square, (Bool, BackGround, Sign))] -> IO () +redrawSigns _ _ [] = return () +redrawSigns gst s l = do + win <- widgetGetDrawWindow $ table gst + (width, height) <- drawableGetSize win + let ss = (fromIntegral width / fromIntegral (xSize s), fromIntegral height / fromIntegral (ySize s)) + mapM_ (drawSquare win ss) l + + +drawSquare win (a, b) (p, xx) = do + let (x, y) = coords p + drawWindowBeginPaintRect win $ Rectangle (round $ a*fromIntegral (x-1)) (round $ b*fromIntegral (y-1)) (ceiling a) (ceiling b) + renderWithDrawable win $ renderSquare (a, b) (x, y) xx + drawWindowEndPaint win + + +-------------------------------------------------- helper + +msglade :: IO GladeXML +msglade = do + f <- getDataFileName "ms.glade" + Just xml <- xmlNew f + return xml + +addMenuItem :: GladeXML -> (String, IO ()) -> IO (ConnectId MenuItem) +addMenuItem xml (str, response) = do + m <- xmlGetWidget xml castToMenuItem str + onActivateLeaf m response + +waitTill :: UTCTime -> IO () +waitTill time = do + time' <- getCurrentTime + case round $ 1000000 * (time `diffUTCTime` time') of + n | n > 0 -> threadDelay n + _ -> return () + +alwaysTrue :: Functor m => m a -> m Bool +alwaysTrue = fmap (const True) + + + + + + + + + diff --git a/GTK/Preferences.hs b/GTK/Preferences.hs new file mode 100644 --- /dev/null +++ b/GTK/Preferences.hs @@ -0,0 +1,144 @@ +module GTK.Preferences + ( setPreferences + ) where + +import Core.Square +import Configuration +--import State +--import State.Functions + +import Control.Monad +import Graphics.UI.Gtk hiding (Clear) +import Graphics.UI.Gtk.Glade +import Data.List + +----------------------- + +getSize c + = (size c, mines c) + +sizeTable = + [ (board 5 5, 5) + , (board 10 10, 20) + , (board 15 15, 45) + ] + +getStyle c + = (strategy c, deathProbRange c, allowedDeaths c, recursiveReveal c, undoAllowed c, hintAllowed c) + +styleTable = + [ (Random, (0,1), 0, True, False, Nothing) + , (Random, (1,1), 0, True, False, Nothing) + , (HighestProb, (1,1), 0, False, True, Just FullHint) + ] + +----------------------- + +setPreferences :: GladeXML -> IO (Configuration -> IO (Maybe Configuration)) +setPreferences xml = do + + dialog <- xmlGetWidget xml castToDialog "prefdialog" + predefsize <- xmlGetWidget xml castToComboBox "predefsize" + gamestyle <- xmlGetWidget xml castToComboBox "gamestyle" + sizex <- xmlGetWidget xml castToSpinButton "sizex" + sizey <- xmlGetWidget xml castToSpinButton "sizey" + mines' <- xmlGetWidget xml castToSpinButton "mines" + strategy' <- xmlGetWidget xml castToComboBox "strategy" + deathlow <- xmlGetWidget xml castToSpinButton "deathlow" + deathhigh <- xmlGetWidget xml castToSpinButton "deathhigh" + lifes <- xmlGetWidget xml castToSpinButton "lifes" + recreveal <- xmlGetWidget xml castToCheckButton "recreveal" + undoallowed <- xmlGetWidget xml castToCheckButton "undoallowed" + hintallowed <- xmlGetWidget xml castToComboBox "hintallowed" + + let setPS :: (Board, Int) -> IO () + setPS (s, m) = do + set sizex [spinButtonValue := fromIntegral (xSize s)] + set sizey [spinButtonValue := fromIntegral (ySize s)] + set mines' [spinButtonValue := fromIntegral m] + + setGS :: (Strategy, (Probability, Probability), Int, Bool, Bool, Maybe HintType) -> IO () + setGS (str, (dl, dh), ad, rec, un, hi) = do + set strategy' [comboBoxActive := fromEnum str] + set deathlow [spinButtonValue := realToFrac dl] + set deathhigh [spinButtonValue := realToFrac dh] + set lifes [spinButtonValue := 1 + fromIntegral ad] + set recreveal [toggleButtonActive := rec] + set undoallowed [toggleButtonActive := un] + set hintallowed [comboBoxActive := case hi of Nothing -> 0; Just i -> 1 + fromEnum i] + + setSensS = do + psize <- get predefsize comboBoxActive + let b = psize == 3 + widgetSetSensitivity sizex b + widgetSetSensitivity sizey b + widgetSetSensitivity mines' b + unless b $ setPS $ sizeTable !! toEnum psize + + setSensG = do + gstyle <- get gamestyle comboBoxActive + let b = gstyle == 3 + widgetSetSensitivity strategy' b + widgetSetSensitivity deathlow b + widgetSetSensitivity deathhigh b + widgetSetSensitivity lifes b + widgetSetSensitivity recreveal b + widgetSetSensitivity undoallowed b + widgetSetSensitivity hintallowed b + unless b $ setGS $ styleTable !! toEnum gstyle + + setRange = do + x <- get sizex spinButtonValue + y <- get sizey spinButtonValue + spinButtonSetRange mines' 0 (x*y) + + predefsize `on` changed $ setSensS + gamestyle `on` changed $ setSensG + onValueSpinned sizex setRange + onValueSpinned sizey setRange + + return $ \c -> do + + set predefsize [comboBoxActive := maybe 3 id (elemIndex (getSize c) sizeTable)] + setPS $ getSize c + setSensS + + set gamestyle [comboBoxActive := maybe 3 id (elemIndex (getStyle c) styleTable)] + setGS $ getStyle c + setSensG + + setRange + + r <- dialogRun dialog + widgetHide dialog + + case r of + ResponseOk -> do + x <- get sizex spinButtonValue + y <- get sizey spinButtonValue + m <- get mines' spinButtonValue + s <- get strategy' comboBoxActive + dl <- get deathlow spinButtonValue + dh <- get deathhigh spinButtonValue + l <- get lifes spinButtonValue + rr <- get recreveal toggleButtonActive + ua <- get undoallowed toggleButtonActive + ha <- get hintallowed comboBoxActive + + return $ Just $ configuration' $ Configuration + { size = board (round x) (round y) + , mines = round m + , strategy = toEnum s + , deathProbRange = (realToFrac dl, realToFrac dh) + , allowedDeaths = round l - 1 + , recursiveReveal = rr + , undoAllowed = ua + , hintAllowed = if ha == 0 then Nothing else Just (toEnum $ ha-1) +-- , numOfSolutions = undefined + } + + _ -> + return Nothing + + + diff --git a/GTK/Score.hs b/GTK/Score.hs new file mode 100644 --- /dev/null +++ b/GTK/Score.hs @@ -0,0 +1,151 @@ +module GTK.Score + ( newScore_ + ) where + +import Configuration +import State + +import State.Functions + +import Graphics.UI.Gtk hiding (Clear, Size, on) +import Graphics.UI.Gtk.Glade + +import Control.Concurrent.MVar +import Control.Monad +import Data.List +import Data.Maybe +import Data.Function +import Numeric + +------------------------------------------- + +attrs_ = [SA_Alive, SA_Time, SA_Success] + +setIndex i s = show i ++ ". " ++ f s where + f (_:'.':' ':s) = s + f s = s + + + +newScore_ :: GladeXML -> IO (Configuration -> Maybe Int -> [ScoreEntry] -> [ScoreAttr] -> IO (Maybe String, [ScoreAttr])) +newScore_ xml = do + + dialog <- xmlGetWidget xml castToDialog "scoredialog" + table <- xmlGetWidget xml castToTable "scoretable" + configLabel <- xmlGetWidget xml castToLabel "configurationlabel" + + buttons <- mapM (xmlGetWidget xml castToButton) ["sortbyluckiness", "sortbytime", "sortbysuccess"] + + scoreState <- newEmptyMVar :: IO (MVar ([ScoreAttr], Maybe Int, [ScoreEntry])) + + entry <- entryNew + set entry [ entryHasFrame := False, entryMaxLength := 15, entryWidthChars := 10 ] + widgetShow entry + + -- create entry labels + lss <- replicateM maxEntries $ do + labs@(l:ls) <- replicateM 4 (labelNew Nothing) + set l [miscXalign := 0] + sequence_ [set x [miscXalign := 1] | x<- ls] + mapM_ widgetShow labs + return labs + + + let + attachLabels n = do + tableResize table (1 + n) 4 + sequence_ [tableAttachDefaults table x j (j+1) i (i+1) | (i,labs) <- zip [1..n] lss, (j,x) <- zip [0..] labs] + + removeLabels n = + mapM_ (containerRemove table) $ concat $ take n lss + + showEntry ls e + = zipWithM_ labelSetText ls + [ se_name e + , show_ 2 $ luckFunction $ se_alive e + , showTime $ se_time e + , show_ 2 $ realToFrac $ successFunction (se_time e) (se_alive e) + ] + + addEntry i = do + containerRemove table (head $ lss !! i) + tableAttachDefaults table entry 0 1 (i+1) (i+2) + + removeEntry i = do + containerRemove table entry + tableAttachDefaults table (head $ lss !! i) 0 1 (i+1) (i+2) + + showEntries = do + (sl, e, es) <- takeMVar scoreState + let es' = sortByAttr sl es + e' = join $ fmap (\i -> elemIndex (es !! i) es') e + putMVar scoreState (sl, e', es') + + sequence_ [set b [buttonLabel :~ setIndex i] | (a, b) <- zip attrs_ buttons, (i, a') <- zip [1::Int ..] sl, a == a'] + ff removeEntry e + ff addEntry e' + zipWithM_ showEntry lss es' + + sortScoresBy sa = do + (sl_old, e, es) <- takeMVar scoreState + let sl = sa: filter (/=sa) sl_old + putMVar scoreState (sl, e, es) + when (sl /= sl_old) showEntries + + initSort b sa = do + onButtonActivate b $ sortScoresBy sa + onPressed b $ sortScoresBy sa + + zipWithM_ initSort buttons attrs_ + + return $ \c i es attrs -> do + + labelSetText configLabel $ showConfiguration c + + maybe (return ()) (entrySetText entry . se_name . (es!!)) i + + putMVar scoreState (attrs, i, es) + + attachLabels $ length es + ff addEntry i + + showEntries + + r <- dialogRun dialog + + (attrs', i', _) <- takeMVar scoreState + + widgetHide dialog + ff removeEntry i' + removeLabels $ length es + + case r of + ResponseOk -> do + n <- entryGetText entry + return (fmap (const n) i', attrs') + + _ -> return (Nothing, attrs) + + +ff f (Just i) = f i +ff _ Nothing = return () + + +showTime :: Int -> String +showTime x = "" .++ day .+ 'd' .++ h .+ 'h' .++ dm .++ m .+ 'm' .++ ds ++ s ++ "s" where + (day: h: dm: m: ds: s: _) = map show (d:l) + (d, l) = mapAccumR divMod x [24,6,10,6,10] + + infixl 6 .++, .+ + + "" .+ _ = "" + s .+ c = s ++ [c] + + "" .++ "0" = "" + a .++ b = a ++ b + + +--show_ :: RealFloat a => Int -> a -> String +show_ :: Int -> Double -> String +show_ i x = showFFloat (Just i) x "" + diff --git a/GTK/Square.hs b/GTK/Square.hs new file mode 100644 --- /dev/null +++ b/GTK/Square.hs @@ -0,0 +1,167 @@ +module GTK.Square + ( renderSquare + ) where + +import Event + +import Graphics.Rendering.Cairo +import Control.Monad + +----------------------------------------- + +renderSquare :: (Double, Double) -> (Int, Int) -> (Bool, BackGround, Sign) -> Render () +renderSquare (a, b) (x, y) (focused, bg, sign) = do + + scale a b + translate (fromIntegral x - 0.5) (fromIntegral y - 0.5) + + setLineCap LineCapSquare + + rectangle (-0.4) (-0.4) 0.8 0.8 + setLineWidth 0.03 + setSourceRGB' background + strokePreserve + unless (isBomb sign) $ setSourceRGB' $ toColor bg + fill + + setSourceRGB' black + + when focused $ do + setLineWidth 0.02 + rectangle (-0.35) (-0.35) 0.7 0.7 + setDash [0.1, 0.1] 0 + stroke + setDash [] 0 + + setLineWidth 0.03 + + case sign of + + NoSign -> return () + + BusySign i -> do + setLineCap LineCapSquare + setSourceRGB' $ Color 1 0.9 0.7 -- between 0.6 white black + setLineWidth 0.05 + let f j = do + let phi = j/5*pi + fromIntegral i/200*2*pi + (x, y) = (0.25* sin phi, 0.25* cos phi) + moveTo x y + lineTo (-x) (-y) + stroke + mapM_ f [1..5] + + Bomb -> do + arc 0 0 0.25 0 (2*pi) + setSourceRGB' $ toColor bg + fillPreserve + setSourceRGB' black + stroke + + Hint d -> do + let (r1, r2) = radians d + arc 0 0 0.25 r1 r2 + setSourceRGB' $ between 0.5 black blue + stroke + arc 0 0 0.25 r2 (r1 + 2*pi) + setSourceRGB' white + stroke + + HintedBomb d -> do + let (r1, r2) = radians d + arc 0 0 0.25 0 (2*pi) + setSourceRGB' $ toColor bg + fill + arc 0 0 0.25 r2 (r1 + 2*pi) + setSourceRGB' white + fill + arc 0 0 0.25 0 (2*pi) + setSourceRGB' black + stroke + + Death -> do + moveTo (-0.25) (-0.25) + lineTo 0.25 0.25 + stroke + moveTo 0.25 (-0.25) + lineTo (-0.25) 0.25 + stroke + + Clear 0 -> do + setLineWidth 0.03 + moveTo (-0.2) 0 + lineTo 0.2 0 + stroke + + Clear n -> do + setLineWidth 0.1 + setLineCap LineCapRound + + sequence_ $ case n of + 1 -> [p5] + + 2 -> [p4, p6] + + 3 -> [p2, p7', p9'] + + 4 -> [ p1, p3 + , p7, p9 ] + + 5 -> [ p1, p3 + , p5 + , p7, p9 ] + + 6 -> [ p1, p3 + , p4, p6 + , p7, p9 ] + + 7 -> [ p1, p3 + , p4, p5, p6 + , p7, p9 ] + + 8 -> [ p1, p2, p3 + , p4, p6 + , p7, p8, p9 ] + + + +------------------ + +[p1, p2, p3, p4, p5, p6, p7, p8, p9] = [point i j | j<-[-0.2, 0, 0.2], i<-[-0.2, 0, 0.2]] +p7' = point (-0.2) 0.14 +p9' = point 0.2 0.14 + +point :: Double -> Double -> Render () +point x y = do + moveTo x y + relLineTo 0 0 + stroke + +radians d = (pi / 2 - d', pi / 2 + d') + where + d' = pi * (1 - fromIntegral d / 100) + +data Color = Color Double Double Double + +background, blue, black, white :: Color +blue = Color 0.65 0.8 1 +green = Color 0.65 0.8 0.6 +black = Color 0 0 0 +white = Color 1 1 1 +background = between 0.9 black white + +toColor (Reddish r) = between (realToFrac r / 100) background (Color 1 0.3 0) +toColor Blue = blue +toColor BlueGreen = between 0.5 green blue +toColor Green = green + + +between :: Double -> Color -> Color -> Color +between pr (Color a b c) (Color a' b' c') = Color (f a a') (f b b') (f c c') where + + f i j = max 0 $ min 1 $ i + pr * (j - i) + +setSourceRGB' :: Color -> Render () +setSourceRGB' (Color r g b) = setSourceRGB r g b + + diff --git a/Game.hs b/Game.hs deleted file mode 100644 --- a/Game.hs +++ /dev/null @@ -1,253 +0,0 @@ - -module Game - ( GState - , size - , board - , Board - , initGState - , deservesUndo - , revealRec - , flag - , info - , isEnd - , isWin - , State (..) - , getP - , mines - , reveal' --- , diff - ) where - -import Place -import PlaceSet hiding (size, empty, insert, delete) -import qualified PlaceSet -import Core - -import Numeric -import Data.Maybe -import Data.List hiding (delete, insert) -import qualified Data.List as List -import Data.Map hiding (size, singleton, map) -import qualified Data.Map as Map - -import System.Random - ----------------------------------------- - -isNotMineAt :: Place -> MMap -> (Rational, MMap) -isNotMineAt p m - = (fromIntegral (solutions' m') / fromIntegral (solutions' m), m') - where - m' = setSum (singleton p) 0 m - -degree :: Size -> Place -> MMap -> StdGen -> (Int, MMap, StdGen) -degree s p m r = (x, l !! x, r') - where - ps = listToPlaceSet $ neighbours s p - - (x, r') = integerDomino (map solutions' l) r - - l = [setSum ps i m | i<-[0..PlaceSet.size ps]] - ------------------------------ - -data State - = Hidden !Bool (Maybe Rational) - | Death - | Clear Rational !Int -- veszélyesség; szomszédos aknák száma - deriving (Eq, Show) - ------ - -type Board = Map Place State - -get :: Place -> Board -> State -get p b = case Map.lookup p b of - Just s -> s --- _ -> Hidden - -set :: Place -> State -> Board -> Board -set p s b = insert p s b - ------------------------------ - -data GState = GS - { field :: MMap - , board_ :: Board - , flagged :: Int - , cleared :: Int - , alive :: Rational - , mines :: Int - , size :: Size ------------ - , revMod :: Maybe Rational - } - -deservesUndo g (g':_) | board_ g == board_ g' = 1 -deservesUndo g (_:g':_) | board_ g == board_ g' = 2 -deservesUndo _ _ = 0 - -initGState :: Size -> Int -> GState -initGState s mines_ = GS - { field = setSum (places s) mines_ emptyMMap - , board_ = Map.fromList $ zip (placeSetToList $ places s) $ repeat $ Hidden False Nothing - , flagged = 0 - , cleared = 0 - , alive = 1 - , mines = mines_ - , size = s - , revMod = Nothing - } - -reveal' :: Bool -> GState -> GState -reveal' all gs - = case revMod gs of - Just 0 | all -> unreveal gs - Just i | i > 0 && not all -> unreveal gs - _ -> revealBoard all gs - -unreveal gs | isJust (revMod gs) - = gs { revMod = Nothing, board_ = Map.map f $ board_ gs } where - - f (Hidden fl _) = Hidden fl Nothing - f x = x -unreveal gs = gs - -revealBoard all gs -- | revMod gs - | solutions' (field gs) == 0 = gs - | otherwise - = gs { board_ = foldr (uncurry Map.insert) (board_ gs) b, revMod = Just $ if all then 0 else mi } where - - b = concatMap h $ Map.toList $ board_ gs - - mi = maximum $ map (k . snd) b where k (Hidden _ (Just i)) = i - - h (p, Hidden fl _) = [(p, Hidden fl $ Just $ fst $ isNotMineAt p (field gs))] - h _ = [] - -board gs - = case revMod gs of - Just i | i /= 0 -> Map.map (f i) $ board_ gs - _ -> board_ gs - where - f i (Hidden False (Just j)) | j /= 0 && j < i = Hidden False Nothing - f _ x = x - - -isHidden (Hidden False x) = True -isHidden _ = False - -reveal :: Place -> GState -> StdGen -> (GState, StdGen) -reveal p g r - | not $ isHidden (get p (board_ g)) = (g, r) - | pr == 0 = (g { field = f, alive = 0, board_ = insert p Death (board_ g) }, r) - | otherwise = (g { field = f', board_ = insert p (Clear pr d) (board_ g), alive = pr * alive g, cleared = 1 + cleared g }, r') - where - (pr, f) = isNotMineAt p (field g) - (d, f', r')= degree (size g) p f r - -flag :: Place -> GState -> ([(Place, State)], GState) -flag p g = case get p $ board_ g of - Hidden True r -> h (Hidden False r) (-1) - Hidden False r | flagged g < mines g -> h (Hidden True r) 1 - _ -> ([], g) - where - h x c = ([(p, x)], g { flagged = flagged g + c, board_ = set p x $ board_ g }) - -getP :: Place -> GState -> State -getP p g = get p (board_ g) - - -------------- - -data Report - = Report Int Int Rational Double - deriving Eq - -instance Show Report where - show (Report _ _ 0 _) = "Sorry, you died of necessity." - show (Report 0 0 x y) = "Congratulations! You won with " ++ show_ 2 (luckinessFunction x) ++ " luckyness." - show (Report i _ x y) = "Mines left: " ++ show i ++ " Information: " ++ show_ 1 (100*y) ++ "%" ++ " Luckyness: " ++ show_ 2 (luckinessFunction x) - -luckinessFunction :: Rational -> Double -luckinessFunction x = max (- log (realToFrac x) / log 4) 0 - -show_ :: Int -> Double -> [Char] -show_ i x = showFFloat (Just i) x "" - -eval :: GState -> Report -eval g@(GS {size= s@(xS, yS)}) - = Report (mines g - flagged g) (xS*yS - cleared g - flagged g) (alive g) y - where - i = solutions' $ setSum (places s) (mines g) emptyMMap - - a = fromIntegral (solutions' $ field g) / fromIntegral i - b = 1 / fromIntegral i - - y - | b == 1 = 1 - | otherwise = luckinessFunction a / luckinessFunction b - -isEnd :: GState -> Bool -isEnd g = case eval g of - Report _ _ 0 _ -> True - Report 0 0 _ _ -> True - _ -> False - -isWin :: GState -> Bool -isWin g = case eval g of - Report 0 0 _ _ -> True - _ -> False - -info :: GState -> String -info = show . eval - ------------------------------ -fff ~(x,g,r) = (x, unreveal g,r) - -isFlagged (Hidden True _) = True -isFlagged _ = False - -revealRec :: Place -> GState -> StdGen -> ([(Place, State)], GState, StdGen) -revealRec p g r = fff $ case getP p g of - Clear _ x | x == sum [1 | q <- neighbours (size g) p, isFlagged (getP q g) ] - -> revRecL (neighbours (size g) p) g r - _ -> revealRecS p g r - -revealRecS :: Place -> GState -> StdGen -> ([(Place, State)], GState, StdGen) -revealRecS p g r = case getP p g of - Hidden False _ -> revRec p $ reveal p g r - _ -> ([], g, r) - - -revRec :: Place -> (GState, StdGen) -> ([(Place, State)], GState, StdGen) -revRec p (g, r) = strictT2 p gp .: case gp of - Clear _ 0 -> revRecL (neighbours (size g) p) g r - _ -> ([], g, r) - where - gp = getP p g - -revRecL :: [Place] -> GState -> StdGen -> ([(Place, State)], GState, StdGen) -revRecL [] g r = ([], g, r) -revRecL (p:ps) g r = l .++ revRecL ps g' r' where - - ~(l, g', r') = revealRecS p g r - -strictT2 a b = a `seq` b `seq` (a, b) - -p .: ~(ps, g, r) = (p: ps, g, r) - -l .++ ~(l', g, r) = (l ++ l', g, r) - ----------- - --- | Get a value from a discrete distribution with the domino algorithm. -integerDomino :: [Integer] -> StdGen -> (Int, StdGen) -integerDomino [_] r = (0, r) -integerDomino l r = (j, r') - where - (x, r') = randomR (1, sum l) r - - j = length $ takeWhile ( [String] -> IO () +writeLog _ [] + = return () +writeLog NoLog _ + = return () +writeLog (FileLog m) s + = modifyMVar_ m $ \fn -> do + time <- getCurrentTime + appendFile fn $ unlines s +-- appendFile fn $ unlines $ ("----- " ++ show time ++ " -----"): s + return fn +writeLog StdOutLog s = do + time <- getCurrentTime + putStrLn $ unlines s +-- appendFile fn $ unlines $ ("----- " ++ show time ++ " -----"): s + + diff --git a/Minesweeper.hs b/Minesweeper.hs --- a/Minesweeper.hs +++ b/Minesweeper.hs @@ -1,252 +1,82 @@ -import Table -import Delay -import Timer -import Game -import Place - -import Paths_minesweeper - -import Graphics.UI.Gtk hiding (Clear) -import Graphics.UI.Gtk.Glade +import Log +import Driver.Log +import Event +import Transition.Managed +import GTK import Control.Concurrent -import Control.Concurrent.MVar -import Control.Monad (when) - +import Control.Monad +import Control.Monad.Fix +import System.FilePath ((), takeDirectory) +import System.Directory +import System.Environment import System.Random +--import Data.Time.Clock +--import Data.Time.Format() +import Data.Char +import Data.List +import Data.Binary -------------------------------------- -type UGState = ([GState], [GState]) - --- | Program state -data ProgramState = ProgramState - { timer :: Tim -- ^ timer state - , label :: Label -- ^ label component (constant) - , gstate :: MVar UGState -- ^ game state (model) - , table :: GameTable -- ^ table state (view) - , seed :: MVar StdGen - } - - -msglade :: IO GladeXML -msglade = do - f <- getDataFileName "ms.glade" - Just xml <- xmlNew f - return xml - main :: IO () -main = mdo - initGUI - timeoutAddFull (yield >> return True) priorityDefaultIdle 50 - - xml <- msglade - window <- xmlGetWidget xml castToWindow "window1" - lab <- xmlGetWidget xml castToLabel "label1" - timeLabel <- xmlGetWidget xml castToLabel "label7" - asp_ <- xmlGetWidget xml castToAspectFrame "aspectframe1" - - asp <- newTable asp_ (checkWin pst . flag') (checkWin pst . revealRec) - - se <- newStdGen - ss <- newMVar se - - let pst = ProgramState tim lab gst asp ss - - mapM_ (addMenuItem xml) - [ ("imagemenuitem5", widgetDestroy window) - , ("imagemenuitem1", newGame pst) - , ("imagemenuitem6", preferences pst) - , ("imagemenuitem3", helpDialog) - , ("imagemenuitem10", aboutDialog) - , ("imagemenuitem9", clear pst $ checkWin pst . revealRec) - , ("imagemenuitem11", clear pst $ checkWin pst . flag') - , ("imagemenuitem12", undo pst) - , ("imagemenuitem15", redo pst) - , ("menuitem2", reveal False pst) - , ("menuitem6", reveal True pst) - ] - - onDestroy window mainQuit - - gst <- newMVar ([initGState (10,10) 20], []) - tim <- newTimer (labelSetText timeLabel) - - hideTableVar <- newCancelVar - showTableVar <- newCancelVar - - onFocusOut window $ \_ -> do - when' (isActiveTimer tim) $ do - stopTimer True tim - doLater hideTableVar (1::Double) (stopTable asp) - return False - - onFocusIn window $ \_ -> do - when' (fmap not $ isActiveTimer tim) $ do - cancelAction hideTableVar - resumeTable asp - startTimer True tim - return False - - widgetShowAll window - resizeTable_ pst - - mainGUI - -flag' a b r = (c, d, r) where (c, d) = flag a b - -clear :: ProgramState -> (Place -> IO ()) -> IO () -clear pst m = do - p <- getFocusPos (table pst) - m p - -reveal :: Bool -> ProgramState -> IO () -reveal all pst = withUState pst f where - f s@(g: _, _) = do - startTimer False (timer pst) - stopTimer False (timer pst) - return $ smartUndo (reveal' all g) s - -undo :: ProgramState -> IO () -undo pst = withUState pst f where - f (g:g':gs, redos) = do - stopTimer False (timer pst) - return (g':gs, g:redos) - f x = return x - -redo :: ProgramState -> IO () -redo pst = withUState pst f where - f (gs, g:redos) = return (g:gs, redos) - f x = return x - -newGame :: ProgramState -> IO () -newGame pst = withUState pst f where - f (as, _) = do - resetTimer (timer pst) - return ([last as], []) - -resizeTable_ :: ProgramState -> IO () -resizeTable_ pst = do - - (g:_, _) <- readMVar (gstate pst) - resizeTable (size g) (table pst) - newGame pst - - -addMenuItem - :: GladeXML - -> (String, IO ()) - -> IO (ConnectId MenuItem) - -addMenuItem xml (str, action) = do - m <- xmlGetWidget xml castToMenuItem str - onActivateLeaf m action - - -preferences :: ProgramState -> IO () -preferences pst = do - xml <- msglade - a <- xmlGetWidget xml castToDialog "dialog1" - sx <- xmlGetWidget xml castToSpinButton "spinbutton3" - sy <- xmlGetWidget xml castToSpinButton "spinbutton1" - ms <- xmlGetWidget xml castToSpinButton "spinbutton4" - - al@(g:_, _) <- takeMVar $ gstate pst - let (xS,yS) = size g - set sx [spinButtonValue := fromIntegral xS] - set sy [spinButtonValue := fromIntegral yS] - set ms [spinButtonValue := fromIntegral $ mines g] - - let setRange = do - x <- get sx spinButtonValue - y <- get sy spinButtonValue - spinButtonSetRange ms 0 (x*y) - - onValueSpinned sx setRange - onValueSpinned sy setRange - - setRange +main = getArgs >>= mainWithArgs - r <- dialogRun a - case r of - ResponseOk -> do - x <- get sx spinButtonValue - y <- get sy spinButtonValue - mines_ <- get ms spinButtonValue - putMVar (gstate pst) ([initGState (round x, round y) (round mines_)], []) - resizeTable_ pst +mainWithArgs :: [String] -> IO () +mainWithArgs args = do - _ -> - putMVar (gstate pst) al + -- init logging + logState <- case args of + ["-"] -> return stdOutLog + [fn] -> fileLog fn + _ -> return noLog - widgetDestroy a - return () + -- find preferences file + dir <- getAppUserDataDirectory "minesweeper" + let prefFile = dir "preferences" + -- init program state + userName <- getEnv "USER" + seed <- newStdGen + b <- doesFileExist prefFile + st <- if b + then do + decodeFile prefFile +{- + str <- readFile prefFile + case reads str of + [(st, s)] | all (==' ') s -> return st + _ -> error $ "The file " ++ prefFile ++ " is corrupted. Try to delete it." +-} + else do + return $ initState userName seed + -- init driver state + dst <- initDriverState st -checkWin :: ProgramState -> (GState -> StdGen -> ([(Place, State)], GState, StdGen)) -> IO () -checkWin pst f = withUState pst $ \x -> case x of - s@(g:gs, redo) | not (isEnd g) -> do - startTimer False $ timer pst - r <- takeMVar $ seed pst - let (ps, g', r') = f g r - adjustButtsInc (table pst) ps - putMVar (seed pst) r' - when (isEnd g') $ do - _ti <- stopTimer False $ timer pst - return () - return $ smartUndo g' s + -- init GUI state + gui <- mfix $ \gui -> guiState (handleEvent logState gui dst) (writeState prefFile dst) - _ -> return x + -- wake up the program + let initActions = [Init] + mapM_ (forkIO . handleEvent logState gui dst) initActions -smartUndo g' (gs, redo) = (g': drop x gs, if x==1 then redo else []) - where - x = deservesUndo g' gs + -- start GUI + startGUI gui --------------------------- - -aboutDialog :: IO () -aboutDialog = do - xml <- msglade - a <- xmlGetWidget xml castToAboutDialog "aboutdialog1" - dialogRun a - widgetDestroy a - return () - -helpDialog :: IO () -helpDialog = do - xml <- msglade - a <- xmlGetWidget xml castToDialog "dialog2" - dialogRun a - widgetDestroy a - return () +handleEvent :: LogState -> GUIState -> DriverState State Event -> Event -> IO () +handleEvent logState gui dst e = + applyTransition logState dst (handleResponses gui) transition e -withUState pst f = modifyMVarInSeparateThread (gstate pst) (\x -> f x >>= h) where - h s@(g: gs, redos) = do - adjustButts (table pst) (board g) - setFixTable (table pst) (isEnd g) - labelSetText (label pst) $ info g - return s - -------------------- - -when' :: Monad m => m Bool -> m a -> m () -when' f g = f >>= \b -> if b then g >> return () else return () - --- | modifies an mvar if it is not taken already -modifyMVarInSeparateThread :: MVar a -> (a -> IO a) -> IO () -modifyMVarInSeparateThread v f = do - b <- isEmptyMVar v - if not b - then do - forkIO (modifyMVar_ v f) - return () - else - return () +writeState :: FilePath -> DriverState State a -> IO () +writeState prefFile dst = do + st <- takeState dst + createDirectoryIfMissing True $ takeDirectory prefFile + encodeFile prefFile $ stopState st +-- writeFile prefFile $ show $ stopState st ------------- diff --git a/Place.hs b/Place.hs deleted file mode 100644 --- a/Place.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} --- | Places. -module Place - ( - -- * Size - Size - - -- * Place - , Place - , place - , coords - - -- * For performance - , hashPlace - , unHashPlace - , placesInAColumn - - -- * Useful functions - , neighbours - - ) where - -import Data.Bits - ------------ - --- | Size of a board. -type Size = (Int, Int) - - --- | Place on a board (with fixed width). --- --- Simpler but slower implementation: --- --- > data Place = P !Int !Int --- > deriving (Eq, Ord, Show) - -newtype Place = P Int deriving (Eq, Ord) - -instance Show Place where - show (coords -> (x, y)) = "place " ++ show x ++ " " ++ show y - -place :: Int -> Int -> Place -place i j = P $ shiftL i 8 .|. j - -coords :: Place -> (Int, Int) -coords (P i) = (shiftR i 8, i .&. 255) - --- | Perfect hash function. -hashPlace :: Place -> Int -hashPlace (P i) = i - -unHashPlace :: Int -> Place -unHashPlace = P - -placesInAColumn :: Int -> (Int, Int) -> [Place] -placesInAColumn i (j1, j2) = map P $ [i' + j1 .. i' + j2] where i' = shiftL i 8 - --- | Neighbours of a place. --- --- Examples: --- --- > neighbours (8, 8) (place 2 3) --- > == [place 1 2, place 1 3, place 1 4, place 2 2, place 2 4, place 3 2, place 3 3, place 3 4] --- --- > neighbours (8, 8) (place 2 1) --- > == [place 1 1, place 1 2, place 2 2, place 3 1, place 3 2] -neighbours :: Size -> Place -> [Place] -neighbours (xS, yS) p@(P q) = f' q ++ (if j > 1 then f (q-1) else []) ++ (if j < yS then f (q+1) else []) - where - (i, j) = coords p - - f r = P r: (if i > 1 then [P (r - 256)] else []) ++ (if i < xS then [P (r + 256)] else []) - f' r = (if i > 1 then [P (r - 256)] else []) ++ (if i < xS then [P (r + 256)] else []) - - diff --git a/PlaceMap.hs b/PlaceMap.hs deleted file mode 100644 --- a/PlaceMap.hs +++ /dev/null @@ -1,39 +0,0 @@ --- | Maps of places -module PlaceMap - ( PlaceMap - , fromList - , toList - , empty - , lookup - , insert - , delete - ) where - -import Place - -import qualified Data.IntMap as M -import Prelude hiding (lookup) - -------------- - --- | Map of places. -type PlaceMap = M.IntMap - -fromList :: [(Place, a)] -> PlaceMap a -fromList = M.fromList . map (\(p, a) -> (hashPlace p, a)) - -toList :: PlaceMap a -> [(Place, a)] -toList = map (\(p, a)-> (unHashPlace p, a)) . M.toList - -empty :: PlaceMap a -empty = M.empty - -lookup :: Place -> PlaceMap a -> Maybe a -lookup p m = M.lookup (hashPlace p) m - -insert :: Place -> a -> PlaceMap a -> PlaceMap a -insert p a m = M.insert (hashPlace p) a m - -delete :: Place -> PlaceMap a -> PlaceMap a -delete p m = M.delete (hashPlace p) m - diff --git a/PlaceSet.hs b/PlaceSet.hs deleted file mode 100644 --- a/PlaceSet.hs +++ /dev/null @@ -1,86 +0,0 @@ --- | Sets of places -module PlaceSet - ( PlaceSet - , listToPlaceSet - , placeSetToList - , singleton - , empty - , nullPS - , insert - , delete - , member - , size - , (\\) - , unions - , intersection - , disjunct - , isSubsetOf - - -- * Useful functions - , places - - ) where - -import Place - -import qualified Data.IntSet as S - -------------- - --- | Set of places. -type PlaceSet = S.IntSet - -listToPlaceSet :: [Place] -> PlaceSet -listToPlaceSet = S.fromList . map hashPlace - -placeSetToList :: PlaceSet -> [Place] -placeSetToList = map unHashPlace . S.toList - -singleton :: Place -> PlaceSet -singleton = S.singleton . hashPlace - --- | The empty PlaceSet. -empty :: PlaceSet -empty = S.empty - -insert :: Place -> PlaceSet -> PlaceSet -insert p ps = S.insert (hashPlace p) ps - -delete :: Place -> PlaceSet -> PlaceSet -delete p ps = S.delete (hashPlace p) ps - --- | True if the PlaceSet is empty. -nullPS :: PlaceSet -> Bool -nullPS = S.null - -member :: Place -> PlaceSet -> Bool -member p = S.member (hashPlace p) - -size :: PlaceSet -> Int -size = S.size - --- | Difference. -(\\) :: PlaceSet -> PlaceSet -> PlaceSet -(\\) = (S.\\) - -unions :: [PlaceSet] -> PlaceSet -unions = S.unions - -disjunct :: PlaceSet -> PlaceSet -> Bool -disjunct a b = S.null (S.intersection a b) - -intersection :: PlaceSet -> PlaceSet -> PlaceSet -intersection = S.intersection - -isSubsetOf :: PlaceSet -> PlaceSet -> Bool -isSubsetOf = S.isSubsetOf - ----------------------- - --- | All places at a board. -places :: Size -> PlaceSet -places (xS, yS) = listToPlaceSet [p | x<-[1..xS], p <- placesInAColumn x (1, yS)] - - - - diff --git a/Scores.hs b/Scores.hs new file mode 100644 --- /dev/null +++ b/Scores.hs @@ -0,0 +1,22 @@ +module Scores where + + + +data ScoreEntry = ScoreEntry + { se_name :: String + , se_time :: Int + , se_alive :: Rational + , se_deaths :: Int + -- , se_success :: Double -- könnyen számolható + , se_history :: [Step] + } + deriving (Eq, Ord, Read, Show) + +data ScoreAttr + = SA_Time + | SA_Alive + | SA_Success + | SA_Deaths + deriving (Eq, Ord, Show, Read, Enum) + + diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,5 +1,2 @@ - import Distribution.Simple - -main = defaultMainWithHooks defaultUserHooks - +main = defaultMain diff --git a/State.hs b/State.hs new file mode 100644 --- /dev/null +++ b/State.hs @@ -0,0 +1,132 @@ +module State where + +import Configuration +import Core.Square +import Core.Constraints +import Step + +import Data.ChangeMap +import Data.ChangeSet +import Control.Monad +import Data.Binary +import Data.DeriveTH +import Data.Derive.Binary +import System.Random +import System.Random.Instances +import qualified Data.Map + +------------------------------- + +-- játékállapot +data State = State + { + -- + configuration :: Configuration + + -- game + , seed :: StdGen + , game :: GameState -- cached + , undo :: [(GameState, Step)] + , redo :: [Step] + + -- preferences + , userName :: String + , undoChangesSeed :: Bool + + -- scores state + , scores :: Data.Map.Map Configuration [ScoreEntry] -- normál map + , sortOrder :: [ScoreAttr] + + -- status + , hint :: Maybe HintType + , timer :: Maybe Int + + -- state + , revealing :: Maybe Revealing +-- , hinting :: Maybe Hinting + , interrupt :: Maybe (Bool, Interrupt) -- visible + + -- GUI state + , focus :: Square + , mouseFocus :: Maybe Square -- Nothing: mouse is outside + , redness :: [(Square, Int)] -- 0-100 + + } + deriving (Show) + + +------------------------------ + +data Revealing = Revealing + { recursive :: Bool + , revSquare :: Square + , revResult :: Maybe RevealResult -- maybe for easier saving -- keep lazy! + , recRevealing :: [Square] + , busyAnimation :: Maybe Int + } + deriving (Show) + +data Hinting = Hinting + { hintResult :: Maybe Int + , hintAnimation :: Maybe Int + } + deriving (Show) + +---------------------------- + +data ScoreEntry = ScoreEntry + { se_name :: String + , se_time :: Int + , se_alive :: Probability + , se_deaths :: Int + , se_history :: [Step] + } + deriving (Eq, Ord, Show) + +data ScoreAttr + = SA_Time + | SA_Alive + | SA_Success + | SA_Deaths + deriving (Eq, Ord, Show, Enum) + +---------------------------- + +data GameState = GameState + { constraints :: Constraints + , marked :: Set Square + , alive :: Probability + , revealResults :: Map Square (Maybe Int) -- a tartalom cachelve van + -- cached + , constraintsProb :: Probability -- ebből lesz information + , maxHiddenProb :: Maybe Int -- 0-100 + , hiddenProbs :: Map Square Int -- 0-100 + , noHiddenProbs :: [Square] -- empty squares to be hinted + } + deriving (Show) + +------------------------------ + +data Step + = Reveal StdGen [Square] + | Mark Square + deriving (Eq, Ord, Show) + +--------------------------- + +data Interrupt + = ModifyPreferences + | ViewScore + | OtherApp + deriving (Eq, Show) + +---------------------- + +$( derive makeBinary ''Interrupt ) +$( derive makeBinary ''Revealing ) +$( derive makeBinary ''ScoreAttr ) +$( derive makeBinary ''ScoreEntry ) +$( derive makeBinary ''Step ) +$( derive makeBinary ''GameState ) +$( derive makeBinary ''State ) + diff --git a/State/Functions.hs b/State/Functions.hs new file mode 100644 --- /dev/null +++ b/State/Functions.hs @@ -0,0 +1,303 @@ +module State.Functions where + +import Configuration +import State +import Core.Square +import Core.Constraints + +import Data.Maybe +import Control.Monad +import System.Random +import Data.List +import Data.Function +import qualified Data.ChangeMap as M +import qualified Data.Map as MM +import qualified Data.ChangeSet as S + +--------------------------------------------- + +resetHiddenProbs c gs = gs + { maxHiddenProb = Nothing + , hiddenProbs = M.empty + , noHiddenProbs = squares (size c) \\ M.keys (revealResults gs) + } + + +initGameState :: Configuration -> GameState +initGameState c = resetHiddenProbs c $ GameState + { constraints = initConstraints (size c) (mines c) + , marked = S.empty + , alive = 1 + , constraintsProb = 1 + , revealResults = M.empty + , maxHiddenProb = undefined + , hiddenProbs = undefined + , noHiddenProbs = undefined + } + +initState :: String -> StdGen -> State +initState userName seed = loadState $ State + { userName = userName + , undoChangesSeed = True + + , configuration = c + , seed = seed + + , undo = [] + , redo = [] + + , focus = fromJust $ square (size c) 1 1 + , mouseFocus = Nothing + , redness = [] + + , scores = MM.empty + , sortOrder = [SA_Time, SA_Alive, SA_Success] + + , timer = Nothing + , revealing = Nothing + , interrupt = Nothing + , hint = Nothing +-- , hinting = Nothing + + , game = error "module State.Functions: game was not defined" + } + where + c = configuration' $ Configuration + { size = board 10 10 + , mines = 20 + , strategy = Random + , deathProbRange = (1,1) + , allowedDeaths = 0 + , recursiveReveal = True + , undoAllowed = False + , hintAllowed = Nothing +-- , numOfSolutions = undefined + } + +loadState st = st + { game = initGameState (configuration st) + } + +{- +readState a b s = case reads s of + [(st, s)] | all (==' ') s -> (True, st) + _ -> (False, initState a b) + +showState = show . stopState +-} + +stopState st = f st { mouseFocus = Nothing } + where + f st + | Just r <- revealing st + = st { revealing = Just $ r { revResult = Nothing }} + | otherwise = st + +------------------------------------------ configuration + + +----------------------- phases + +-- the game is finised +isFinished st + = S.size (marked g) + M.size (revealResults g) == msize st + || alive g == 0 + where g = game st + +-- winning position (the timer may be stopped) +playerWins st + = isFinished st + && alive (game st) > 0 + +-- the game is not yet started (new) +isNew + = null . undo + +longInterrupt st + | Just (b, _) <- interrupt st = b + | otherwise = False + +-- the table is hidden +hiddenTable st + = longInterrupt st + && isJust (timer st) + && not (isFinished st) + +-- the focus can be moved +focusMoves st + = not (longInterrupt st) + && not (isFinished st) + +-- the mouse focus is shown +mouseFocusShown st + = focusMoves st +-- && isNothing (busyAnimation_ st) + || interrupt st == Just (True, OtherApp) + +-- reveal / mark / hint can be done +revealCanBeDone st + = markCanBeDone st + && isNothing (revealing st) + +-- mark can be done +markCanBeDone st + = isNothing (interrupt st) + && not (isFinished st) + +-- the timer is active +isActive st + = isNothing (busyAnimation_ st) + && isNothing (interrupt st) + && isJust (timer st) + && not (isFinished st) + + +-------------- attributes + +allSolutions = numOfSolutions . configuration + +busyAnimation_ = join . fmap busyAnimation . revealing + +revSquare_ = fmap revSquare . revealing + +size_ = size . configuration + +msize g = xSize s * ySize s where s = size_ g + +mines_left st + = mines (configuration st) - S.size (marked $ game st) + +information :: State -> Double +information st + | b == 1 = 1 + | otherwise = luckFunction a / luckFunction b + where + i = fromIntegral $ allSolutions st + a = fromIntegral (solutions $ constraints $ game st) / i + b = 1 / i + +allSquares + = squares . size . configuration + +luck :: State -> Double +luck = luckFunction . alive . game + +-------------- other + +free g p + = not (isRevealed g p) && S.notMember p (marked g) + +isRevealed g p + = M.member p (revealResults g) + +---------------------------------------- + + +eventPos st m + = maybe (focus st) (calcSquare st) m + +calcSquare = restrictSquare . size_ + +--------------------------------------- + +showConfiguration c + = unlines $ filter (not . null) + [ unwords [show (xSize s) ++ "×" ++ show (ySize s), "table,", show $ mines c, "mines"] + , showStrategy $ strategy c + , showDPR $ deathProbRange c + ] + where + s = size c + + showStrategy Random = "" + showStrategy HighestProb = "least information game" + + showDPR (0,1) = "" + showDPR (1,1) = "lucky game" + showDPR _ = "" + -- (a, b): ha p valséggel halnánk meg, akkor p>a esetén meghalunk, p Maybe ScoreEntry +scoreEntry st + | Just t <- timer st + , playerWins st + = Just $ ScoreEntry + { se_name = userName st + , se_time = t + 1 -- felfelé kerekítünk + , se_alive = alive $ game st + , se_deaths = 0 + , se_history = reverse $ map snd $ undo st + } + | otherwise + = Nothing + + +maxEntries = 10 + +currentScores :: State -> [ScoreEntry] +currentScores st + = ff $ MM.lookup (configuration st) (scores st) + where + ff (Just l) = l + ff Nothing = [] + + +addScore st + | Just e <- scoreEntry st + , st' <- st { scores = MM.alter (Just . maybe [e] (e:)) (configuration st) (scores st) } + , e `elem` cutScores st' + = Just $ st' { interrupt = Just (False, ViewScore) } + | otherwise + = Nothing + + where + cutScores :: State -> [ScoreEntry] + cutScores st + = take maxEntries $ nub $ concat $ transpose [sortByAttr as $ currentScores st | as <- ass] + where + ass = [l2 ++ l1 | i <- [1..length (sortOrder st)], let (l1, l2)= splitAt (i-1) (sortOrder st)] + + + +sortByAttr :: [ScoreAttr] -> [ScoreEntry] -> [ScoreEntry] +sortByAttr as = sortBy (flip compare `on` createRank as) + where + createRank :: [ScoreAttr] -> ScoreEntry -> [Double] + createRank sl e + = [f | x <- sl, (a, f) <- l, a==x] + where + l :: [(ScoreAttr, Double)] + l = [ (SA_Alive, realToFrac (se_alive e)) + , (SA_Time, - fromIntegral (se_time e)) + , (SA_Success, realToFrac $ successFunction (se_time e) (se_alive e)) + ] + + + +----------------------- + +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 +successFunction time{-in sec-} alive{-probability-} + = 3600 / fromIntegral time * alive -- 1s 0.5valség + +----------------- + +forgetChanges x = x + { marked = S.forget $ marked x + , revealResults = M.forget $ revealResults x + , hiddenProbs = M.forget $ hiddenProbs x + } + diff --git a/Step.hs b/Step.hs new file mode 100644 --- /dev/null +++ b/Step.hs @@ -0,0 +1,84 @@ +module Step + ( step + , RevealResult (..) + ) where + +------------------------------------------- + +import Configuration +import Core.Square +import Core.Constraints + +import Data.Ratio +import Data.List +import Data.Maybe +import System.Random +import Data.Binary + + +------------------------------------------- + +data RevealResult = RevealResult + { safety :: !Probability + , squareState :: !(Maybe Int) + , rrConstraints :: !Constraints + , rrSeed :: !StdGen + } + deriving (Show) + +instance Binary RevealResult where + put = error "put on RevealResult" + get = error "get on RevealResult" + +------------------------------------------- + + + +step :: Configuration -> Square -> Constraints -> StdGen -> RevealResult +step conf p cs r + | dead = RevealResult prob Nothing (setSum [p] 1 cs) r_ + | otherwise = x `seq` RevealResult prob (Just x) (l !! x) r' + where + cs' = setSum [p] 0 cs + + l = distribution (neighbours (size conf) p) cs' + + (dead, r_) = appDeath (deathProbRange conf) (1-prob) r + (x, r') = appStrat (strategy conf) (map solutions l) r_ + + prob = fromIntegral (solutions cs') / fromIntegral (solutions cs) + + +appDeath _ 0 r = (False, r) +appDeath _ 1 r = (True, r) +appDeath (a, _) p r | p <= a = (False, r) +appDeath (_, b) p r | p >= b = (True, r) +appDeath (a, b) p r = (i==0, r') where + (i, r') = integerDomino [c, d] r + (c, d) = ff (p - a, b - p) + + ff (x, y) = (numerator (d*x), numerator (d*y)) where d = fromInteger $ denominator (x*y) + + +appStrat Random l r + = integerDomino l r +appStrat HighestProb l r + = (fromJust $ findIndex (==y) l, r) where + y = maximum l + + +---------------------- + +-- | Get a value from a discrete distribution with the domino algorithm. +integerDomino :: [Integer] -> StdGen -> (Int, StdGen) +integerDomino (0: is) r = (x + 1, r') where (x, r') = integerDomino is r +integerDomino l@(i: _) r + | i == sl = (0, r) + | otherwise = (j, r') + where + sl = sum l + (x, r') = randomR (1, sl) r + + j = length $ takeWhile ( IO () - , reveal :: Place -> IO () - } - ---------------------- - -newTable :: AspectFrame -> (Place -> IO ()) -> (Place -> IO ()) -> IO GameTable -newTable asp fA rA = do - canvas <- drawingAreaNew - m <- newMVar undefined - let g = T asp canvas m fA rA - - containerAdd asp canvas - set canvas [widgetCanFocus := True] - widgetAddEvents canvas [LeaveNotifyMask, PointerMotionMask, KeyPressMask] - - canvas `on` exposeEvent $ updateCanvas g - canvas `on` leaveNotifyEvent $ changeCanvas_ g - canvas `on` motionNotifyEvent $ changeCanvas g - canvas `on` buttonPressEvent $ changeCanvas' g - canvas `on` keyPressEvent $ changeCanvasKey g - return g - -getFocusPos :: GameTable -> IO Place -getFocusPos g = fmap focusPos $ readMVar (states g) - -stopTable g = setTableSt g $ \s -> if s == Fixed then s else Stopped -resumeTable g = setTableSt g $ \s -> if s == Fixed then s else Normal Nothing -setFixTable g b = setTableSt g f where - - f _ | b = Fixed - f Fixed | not b = Normal Nothing - f x = x - - -setTableSt :: GameTable -> (St -> St) -> IO () -setTableSt g fx = redrawButts_ g f where - f ss - | x == x' = ([], ss) - | Stopped `elem` [x, x'] - = (M.toList $ board_ ss, ss') - | otherwise - = ([(p, board_ ss M.! p) | p <- focusPos ss: ff x ++ ff x'], ss') - where - ss' = ss { workState = x' } - - x = workState ss - x' = fx x - - ff (Normal (Just x)) = [x] - ff _ = [] - - -resizeTable :: (Int, Int) -> GameTable -> IO () -resizeTable s@(xS, yS) g = do - - set (frame g) [aspectFrameRatio := fromIntegral xS / fromIntegral yS] - - swapMVar (states g) $ IState - { size_ = s - , board_ = M.fromList $ zip (placeSetToList $ places s) $ repeat $ Hidden False Nothing - , focusPos = place 1 1 - , workState = Normal Nothing - } - - win <- drawingAreaGetDrawWindow' g - drawWindowClear win - updateCanvas' g - ------------------- - -updateCanvas :: GameTable -> EventM EExpose Bool -updateCanvas g = do - liftIO $ updateCanvas' g - return True - -updateCanvas' g = do - redrawButts_ g $ \ss -> (M.toList $ board_ ss, ss) - -adjustButts :: GameTable -> Board -> IO () -adjustButts g b = - redrawButts_ g $ \ss -> ([p | (p,y) <- zip (M.assocs b) (M.elems $ board_ ss), snd p /= y], ss { board_ = b }) - - -adjustButtsInc :: GameTable -> [(Place, State)] -> IO () -adjustButtsInc g [] = return () -adjustButtsInc g ((p, s):ps) = do - - redrawButts_ g $ \ss -> ([(p, s)], ss { board_ = M.insert p s $ board_ ss }) - adjustButtsInc g ps - -redrawButts :: GameTable -> [Place] -> IO () -redrawButts g l - = redrawButts_ g $ \ss -> ([(p, board_ ss M.! p)| p <- l], ss) - - -redrawButts_ :: GameTable -> (IState -> ([(Place, State)], IState)) -> IO () -redrawButts_ g f = do - - ss <- takeMVar (states g) - let (ps, ss') = f ss - redrawButts__ g ss' ps - putMVar (states g) $ ss' - - -redrawButts__ :: GameTable -> IState -> [(Place, State)] -> IO () -redrawButts__ gg g l = do - win <- drawingAreaGetDrawWindow' gg - let - size = size_ g - m = board_ g - b = workState g - pp = case b of - Normal x -> x - _ -> Nothing - foc = focusPos g - let f (p, s) = do - renderWithDrawable' p size win $ drawPlace (b == Stopped) (isNormal b && pp == Just p) (p == foc && isNormal b) p s - mapM_ f l - -isNormal (Normal _) = True -isNormal _ = False - -renderWithDrawable' (coords -> (x,y)) (xx, yy) win m = do - (width, height) <- drawableGetSize_ win - let - a = width/fromIntegral xx - b = height/fromIntegral yy - drawWindowBeginPaintRect win $ Rectangle (round $ a*fromIntegral (x-1)) (round $ b*fromIntegral (y-1)) (round a) (round b) - renderWithDrawable win $ do - scale a b - translate (fromIntegral x - 0.5) (fromIntegral y - 0.5) - m - drawWindowEndPaint win - - -drawableGetSize_ win = do - (width, height) <- drawableGetSize win - return (realToFrac width, realToFrac height) - -changeCanvas :: GameTable -> EventM EMotion Bool -changeCanvas g = do - pos <- eventCoordinates - liftIO $ do - n <- calcPos_ pos g - changeC n g - - -changeCanvas_ :: GameTable -> EventM ECrossing Bool -changeCanvas_ g = liftIO $ do - let n = Nothing - changeC n g - -changeC n g = do - ss <- readMVar (states g) - case workState ss of - Normal m -> do - ss <- takeMVar (states g) - putMVar (states g) $ ss { workState = Normal n } - - if m /= n - then redrawButts g $ catMaybes [m, n] - else return () - _ -> return () - return True - - -changeCanvas' :: GameTable -> EventM EButton Bool -changeCanvas' g = do - pos <- eventCoordinates - b <- eventButton - liftIO $ do - ss <- readMVar (states g) - when (isNormal (workState ss)) $ do - n <- calcPos_ pos g - case (n, b) of - (Just p, LeftButton) -> reveal g p - (Just p, RightButton) -> flag_ g p - _ -> return () - return True - - - -changeCanvasKey :: GameTable -> EventM EKey Bool -changeCanvasKey g = do - k <- eventKeyName - liftIO $ do - case k of - "Right" -> moveFocus ( 1, 0) - "Left" -> moveFocus (-1, 0) - "Down" -> moveFocus ( 0, 1) - "Up" -> moveFocus ( 0,-1) - _ -> return False - where - moveFocus (dx, dy) = do - ss <- readMVar (states g) - when (isNormal (workState ss)) $ do - ss <- takeMVar (states g) - let - foc@(coords -> (x, y)) = focusPos ss - (sx, sy) = size_ ss - foc' = place (max 1 $ min sx $ dx + x) (max 1 $ min sy $ dy + y) - putMVar (states g) $ ss { focusPos = foc' } - if foc /= foc' - then redrawButts g [foc, foc'] - else return () - return True - - -drawingAreaGetDrawWindow' = widgetGetDrawWindow . area - -calcPos_ pos g = do - win <- drawingAreaGetDrawWindow' g - ss <- readMVar (states g) - - (width, height) <- drawableGetSize_ win - return $ calcPos (size_ ss) (width, height) pos - -calcPos (xx, yy) (width, height) (x,y) - | i + 1 `between` (1, xx) && j + 1 `between` (1, yy) {- && ii>0 && ii<9 && jj>0 && jj<9 -} - = Just $ place (i+1) (j+1) - | otherwise = Nothing - where - a = floor (x/width*10* fromIntegral xx) - b = floor (y/height*10* fromIntegral yy) - - (i,_ii) = a `divMod` 10 - (j,_jj) = b `divMod` 10 - -infix 4 `between` -a `between` (b, c) = b <= a && a <= c - - - - diff --git a/TableGraphics.hs b/TableGraphics.hs deleted file mode 100644 --- a/TableGraphics.hs +++ /dev/null @@ -1,168 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} -module TableGraphics - ( drawPlace - ) where - -import Place -import Game (State (..)) - -import Graphics.Rendering.Cairo - -import Control.Monad (when) - ------------------------------------------ - - -drawPlace - :: Bool -- ^ signs are not shown - -> Bool -- ^ highlighted - -> Bool -- ^ focused - -> Place - -> State - -> Render () - -drawPlace bb b foc (coords -> (i,j)) st = do - - - - rectangle (-0.4) (-0.4) 0.8 0.8 - setLineWidth 0.03 - setSourceRGB' bg - strokePreserve - setSourceRGB' $ case st of - Clear _ _ -> bg - Hidden True _ -> bg - Death -> bg - _ -> if b then bg else blue - - fill - setSourceRGB' black - if foc - then do - rectangle (-0.35) (-0.35) 0.7 0.7 - setLineWidth 0.02 - setDash [0.1,0.1] (if even (i + j) then 0 else 0.1) - stroke - setDash [] 0 - else return () - setLineCap LineCapRound - setLineWidth 0.1 - - if bb - then return () - else case st of - Death -> do - setLineCap LineCapSquare - moveTo (-0.25) (-0.25) - lineTo 0.25 0.25 - stroke - moveTo 0.25 (-0.25) - lineTo (-0.25) 0.25 - stroke - - Hidden False (Just d) -> do - setLineWidth 0.03 - arc 0 0 0.25 0 (2*pi*(1- realToFrac d)) - setSourceRGB' $ Color_ 0.3 0.4 0.5 - stroke - arc 0 0 0.25 (2*pi*(1- realToFrac d)) (2*pi) - setSourceRGB' $ Color_ 1 1 1 - stroke - - Hidden True bbb -> do - setLineWidth 0.03 - arc 0 0 0.25 0 (2*pi) - setSourceRGB' $ if b then bg else blue - fillPreserve - setSourceRGB' black - stroke - when (maybe False (/=0) bbb) $ do - setLineCap LineCapSquare - moveTo (-0.25) (-0.25) - lineTo 0.25 0.25 - stroke - moveTo 0.25 (-0.25) - lineTo (-0.25) 0.25 - stroke - Clear _ n -> do - case n of - 0 -> do - setLineCap LineCapSquare - setLineWidth 0.03 - moveTo (-0.2) 0 - lineTo 0.2 0 - stroke - 1 -> do - point 0 0 - 2 -> do - point (-0.2) 0 - point 0.2 0 - 3 -> do - point 0 (-0.20) - point (-0.2) 0.14 - point 0.2 0.14 - 4 -> do - point (-0.2) 0.2 - point 0.2 0.2 - point (-0.2) (-0.2) - point 0.2 (-0.2) - 5 -> do - point 0 0 - point (-0.2) 0.2 - point 0.2 0.2 - point (-0.2) (-0.2) - point 0.2 (-0.2) - 6 -> do - point (-0.2) 0 - point 0.2 0 - point (-0.2) 0.2 - point 0.2 0.2 - point (-0.2) (-0.2) - point 0.2 (-0.2) - 7 -> do - point 0 0 - point (-0.2) 0 - point 0.2 0 - point (-0.2) 0.2 - point 0.2 0.2 - point (-0.2) (-0.2) - point 0.2 (-0.2) - 8 -> do - point (-0.2) 0 - point 0.2 0 - point 0 (-0.2) - point 0 0.2 - point (-0.2) 0.2 - point 0.2 0.2 - point (-0.2) (-0.2) - point 0.2 (-0.2) - return () - _ -> return () - - -point :: Double -> Double -> Render () -point x y = do - moveTo x y - relLineTo 0 0 - stroke - - -data Color_ = Color_ Double Double Double - -bg, blue, black, white :: Color_ -blue = Color_ 0.65 0.8 1 -black = Color_ 0 0 0 -white = Color_ 1 1 1 -bg = Color_ 0.9 0.9 0.9 - -setSourceRGB' :: Color_ -> Render () -setSourceRGB' (Color_ r g b) = setSourceRGB r g b - - -betw :: - Double -> Color_ -> Color_ -> Color_ -betw pr (Color_ a b c) (Color_ a' b' c') = Color_ (f a a') (f b b') (f c c') where - - f i j = max 0 $ min 1 $ i + pr * (j - i) - - diff --git a/Timer.hs b/Timer.hs deleted file mode 100644 --- a/Timer.hs +++ /dev/null @@ -1,117 +0,0 @@ -module Timer - ( Tim - , newTimer - , startTimer - , stopTimer - , resetTimer - , isActiveTimer - - , showSeconds - ) where - -import Control.Concurrent -import Control.Concurrent.MVar - -import Data.Time.Clock - -------------------------------------------- - -data StoppedTimerState - = Initial | Stopped | Halted - deriving Eq - -data Timer - = ActiveTimer - ThreadId -- which thread is responsible for the updating of the timer - UTCTime - | StoppedTimer - StoppedTimerState - NominalDiffTime - -type Action = String -> IO () - -type Tim = MVar - ( Action -- this is global for this module, but Haskell has no parameterized modules.. - , Timer) - -------------------- - -newTimer :: Action -> IO Tim -newTimer action - = newMVar (action, StoppedTimer Initial 0) - -startTimer :: Bool -> Tim -> IO () -startTimer b tim = do - a@(timeL, xx) <- takeMVar tim - case xx of - StoppedTimer x s | b && x == Stopped || not b && x /= Halted -> do - tid <- forkIO $ modTime tim - ti <- getCurrentTime - putMVar tim (timeL, ActiveTimer tid $ addUTCTime (-s) ti) - _ -> do - putMVar tim a - -stopTimer :: Bool -> Tim -> IO NominalDiffTime -stopTimer b tim = do - a@(timeL, x) <- takeMVar tim - case x of - ActiveTimer _ ti -> do - ti' <- getCurrentTime - let d = diffUTCTime ti' ti - putMVar tim (timeL, StoppedTimer xx d) - timeL $ (if b then "Stopped at " else "Halted at ") ++ showSeconds (round d) - return d - StoppedTimer _ d -> do - putMVar tim (timeL, StoppedTimer xx d) - return d - where - xx = if b then Stopped else Halted - -resetTimer :: Tim -> IO () -resetTimer tim = do - (timeL, _) <- takeMVar tim - timeL "Timer will start" - putMVar tim (timeL, StoppedTimer Initial 0) - return () - -isActiveTimer :: Tim -> IO Bool -isActiveTimer tim = do - (_, x) <- readMVar tim - return $ case x of - ActiveTimer _ _ -> True - _ -> False - - ------------------ - -modTime :: Tim -> IO () -modTime tim = do - tid <- myThreadId - (timeL, x) <- readMVar tim - case x of - ActiveTimer tid' ti | tid == tid' -> do - ti' <- getCurrentTime - let diff = diffUTCTime ti' ti - timeL $ "Time: " ++ showSeconds (round diff) - threadDelay (computeWaitTime diff) - modTime tim - _ -> - return () - -computeWaitTime :: NominalDiffTime -> Int {-milliseconds-} -computeWaitTime x = 1000000 * (1 + round y) - round (1000000 * y) - 100000 where (_, y) = properFraction x :: (Integer, NominalDiffTime) - -------------- - -showSeconds :: Integer -> String -showSeconds s = f h ++ ":" ++ f m' ++ ":" ++ f s' where - - (m, s') = divMod s 60 - (h, m') = divMod m 60 - - f :: Integer -> String - f i = reverse $ take 2 $ reverse $ "0" ++ show i - - - - diff --git a/Transition.hs b/Transition.hs new file mode 100644 --- /dev/null +++ b/Transition.hs @@ -0,0 +1,62 @@ +module Transition + ( buildTransition + ) where + +import When +import Driver.Log + +--------------------------------------------------- +{- +transition :: Event -> Transition State Event Responses +transition e ost + = buildTransition (==Init) triggers' nextState responses e ost +-} +------------------------------ + +buildTransition + :: Eq e + => (e -> Bool) -- event is initial + -> [(st -> Bool, e, st -> When)] -- trigger table + -> (e -> st -> Maybe st) -- transition + -> (e -> st -> st -> r) -- response + -> e -- event + -> Transition st e r + +buildTransition isInit triggers nextState responses e ost + | Just st <- nextState e ost + = Just (Result + { cancelled = cancelled_ e ost st + , triggered = reactions e ost st + , result = responses e ost st + } + , st) + | otherwise + = Nothing + where + + reactions e ost st + + = [ (wh st, t) + | (p, t, wh) <- triggers + , p st + , e == t || isInit e || not (p ost) + ] + + cancelled_ e ost st + + = [ t + | (p, t, _) <- triggers + , not (p st) + , p ost + , e /= t + ] + + + initReactions st + + = [ (wh st, t) + | (p, t, wh) <- triggers + , p st + ] + + diff --git a/Transition/Action.hs b/Transition/Action.hs new file mode 100644 --- /dev/null +++ b/Transition/Action.hs @@ -0,0 +1,36 @@ +module Transition.Action + ( triggers + , triggers' + ) where + +import When +import Event +import State +import State.Functions + +import Data.Maybe +import Data.List + +----------------------------- + +triggers' = [(p, Triggered t, w) | (p, t, w) <- triggers] + +triggers :: [(State -> Bool, Triggered, State -> When)] +triggers = + [ (isActive, Tick, const $ Later 1) + , (interruptWillShown, InterruptVisible, const $ Later 0.5) + , (fade, FadeTick, const $ Later 0.1) + , (revealInProgress, BusyTick, const $ Later 0.1) + , (revealInProgress, RevealDone, AfterEval . fromJust . revResult . fromJust . revealing) + ] + + +interruptWillShown st + | Just (False, _) <- interrupt st = True + | otherwise = False + +revealInProgress = isJust . revealing + +fade = not . null . redness + + diff --git a/Transition/Graphics.hs b/Transition/Graphics.hs new file mode 100644 --- /dev/null +++ b/Transition/Graphics.hs @@ -0,0 +1,96 @@ +module Transition.Graphics where + +import State +import Configuration +import State.Functions +import Event +import Core.Square + +import Numeric +import Data.Maybe +import qualified Data.ChangeMap as M +import qualified Data.ChangeSet as S + +------------------------------------------------------------- + +renderSquare :: State -> Square -> (Bool, BackGround, Sign) +renderSquare st p = (hasFocus, bg, sign) where + + g = game st + + hasFocus = p == focus st && focusMoves st + hasMouseFocus = maybe False (== p) (mouseFocus st) + revealed = M.lookup p $ revealResults g + marked' = S.member p $ marked g + + hint' + | Just h <- hint st + , Just max <- maxHiddenProb g + , Just x <- M.lookup p $ hiddenProbs g + , h == FullHint || x == max || x == 0 || marked' + = Just x + | otherwise + = Nothing + + sign + | Just r <- revealing st + , p == revSquare r + , Just i <- busyAnimation r + = BusySign i + | hiddenTable st + = NoSign + | Just x <- hint' + = if marked' then HintedBomb x else Hint x + | marked' + = Bomb + | Just Nothing <- revealed + = Death + | Just (Just i) <- revealed + = Clear i + | otherwise + = NoSign + + bg | isJust revealed || hiddenTable st && marked' + = Reddish $ head $ [x | (q,x)<-redness st, q==p] ++ [0] + | hasMouseFocus && mouseFocusShown st + = Green +-- | hasMouseFocus +-- = BlueGreen + | otherwise + = Blue + + +infoString st + | playerWins st + = "Congratulations! You won with " ++ show_ 2 (luck st) ++ " luck." + | alive (game st) == 0 + = "Sorry, you died of necessity." + | isFinished st + = "Sorry, you died by accident." + | otherwise + = "Mines left: " ++ show (mines_left st) ++ " " + ++ "Information: " ++ show_ 1 (100 * information st) ++ "%" ++ " " + ++ "Luck: " ++ show_ 2 (luck st) + where + show_ :: RealFloat a => Int -> a -> [Char] + show_ i x = showFFloat (Just i) x "" + + +timeString st + | Just t <- timer st + = showSeconds t + | isNew st + = "Timer will start" + | otherwise + = "Timer stopped" + where + showSeconds :: Int -> String + showSeconds s = f h ++ ":" ++ f m' ++ ":" ++ f s' where + + (m, s') = divMod s 60 + (h, m') = divMod m 60 + + f :: Int -> String + f i = reverse $ take 2 $ reverse $ "0" ++ show i + + diff --git a/Transition/Managed.hs b/Transition/Managed.hs new file mode 100644 --- /dev/null +++ b/Transition/Managed.hs @@ -0,0 +1,119 @@ +module Transition.Managed + ( initState + , stopState + , transition + , Transition + , State + ) where + +import Transition.Graphics +import Core.Square +import State.Functions hiding (initState, stopState) +import qualified State.Functions as F +import Transition +import Transition.Action +import Transition.State +import Transition.Response +import Event +import qualified State as S +import Driver.Log + +import Data.List +import Data.Maybe + +import Control.Monad +import Data.Binary +import Data.DeriveTH +import Data.Derive.Binary + +--------------------------------------------------- main + +data State = State + { drawing :: Bool + , changes :: Maybe (S.State, [Square]) -- Nothing: update needed + , state :: S.State + } + deriving (Show) + +---------------- + + +initState a b = State + { drawing = False + , changes = Nothing + , state = F.initState a b + } + +stopState st = st + { drawing = False + , changes = Nothing + , state = F.stopState $ state st + } + +------------------------------------------------ + +transition :: Event -> Transition State Event [Response] +transition = buildTransition (==Init) triggers'' (\e -> fmap initDrawing . nextState' e) responses + +triggers'' = [(p . state, e, w . state) | (p, e, w) <- triggers'] + + +nextState' InfoDrawingDone _ + = Nothing + +nextState' DrawingDone st + = Just $ st { drawing = False } + +nextState' UpdateTable st + = Just $ st { changes = Nothing } + +nextState' e@(PreferencesClosed (Just _)) st -- elég lenne csak a nagyon megváltozottra + = lift nextState e $ st { changes = Nothing } + +nextState' e st + = lift nextState e st + + +initDrawing st + | Just (_, []) <- changes st = st + | drawing st = st + | otherwise = st { drawing = True, changes = Just (state st, []) } + + +lift f e ost + | Just st <- f e $ state ost + = Just $ ost { changes = fmap (mapSnd (changedSquares e (state ost) st ++)) $ changes ost, state = st } + | otherwise + = Nothing + +mapSnd f (a, b) = (a, f b) + +------------------------------------ + +responses' e ost st + | drawing st && (not (drawing ost) || e == DrawingDone) + = [DrawSquares (size_ $ state st) ch] + | otherwise + = [] + where + ch | isNothing (changes ost) || e == UpdateTable + = [(p, f p) | p <- squares . size_ . state $ st] + | Just (ost', l) <- changes ost + , f' <- renderSquare ost' + = [(p, q) | p <- nub $ newChanges ++ l, let q = f p, q /= f' p] + + newChanges = changedSquares e (state ost) (state st) + + f = renderSquare $ state st + + +responses :: Event -> State -> State -> [Response] +responses e ost st + = buildContResponse (==Init) [f . state | f <- contResponses] e ost st + ++ buildTickResponse (==Init) [(p . state, f . state) | (p, f) <- tickResponses] e ost st + ++ responses' e ost st +-- ++ buildTickResponse (==DrawingDone) [(drawing, drawSquares)] e ost st + + +$( derive makeBinary ''State ) + diff --git a/Transition/Response.hs b/Transition/Response.hs new file mode 100644 --- /dev/null +++ b/Transition/Response.hs @@ -0,0 +1,95 @@ +module Transition.Response + ( buildContResponse + , buildTickResponse + , contResponses + , tickResponses + , changedSquares + ) where + +import Core.Square +import Event +import State +import State.Functions +import Transition.Graphics + +import Data.Maybe +import Data.List +import qualified Data.ChangeMap as M +import qualified Data.ChangeSet as S + +--------------------------------------------------- main + +buildContResponse :: Eq r => (e -> Bool) -> [st -> r] -> e -> st -> st -> [r] +buildContResponse isInit resp e ost st + = [ x + | f <- resp + , let x = f st + , isInit e || x /= f ost + ] + +contResponses = + [ ShowInfo . infoString + , ShowTime . timeString + ] + +buildTickResponse :: (e -> Bool) -> [(st -> Bool, st -> r)] -> e -> st -> st -> [r] +buildTickResponse isInit triggers e ost st + = [ f st + | (p, f) <- triggers + , p st + , isInit e || not (p ost) + ] + +tickResponses = + [ (prefInterrupt, PopUpPreferences . configuration) + , (scoreInterrupt, popUpNewScore) + ] + +prefInterrupt st + = fmap snd (interrupt st) == Just ModifyPreferences + +scoreInterrupt st + = fmap snd (interrupt st) == Just ViewScore + + +popUpNewScore st + = PopUpNewScore (configuration st) e l (sortOrder st) + where + l = currentScores st + e | Just e <- scoreEntry st + , Just i <- elemIndex e l + = Just i + | otherwise + = Nothing + +-------------------------------------------------------- + + +changedSquares :: Event -> State -> State -> [Square] +changedSquares e ost st = case e of + + Triggered BusyTick -> maybeToList $ revSquare_ ost + Triggered FadeTick -> map fst $ redness ost + + _ | hiddenTable st /= hiddenTable ost + || hint st /= hint ost + -- new table simptoms: + || length (undo st) < length (undo ost) + || size_ st /= size_ ost + -> allSquares st + + _ -> concat -- nub lesz később + [ catMaybes $ diff [mouseFocus ost, mouseFocus st] + , diff [focus ost, focus st] + , S.changes (marked g) + , M.changes (revealResults g) + , M.changes (hiddenProbs g) + ] + where + g = game st + + diff [x, y] | x == y = [] + diff l = l + + + diff --git a/Transition/State.hs b/Transition/State.hs new file mode 100644 --- /dev/null +++ b/Transition/State.hs @@ -0,0 +1,460 @@ +module Transition.State + ( nextState + ) where + +import Configuration +import Event +import State +import State.Functions +import Step +import Core.Square +import Core.Constraints + +import Data.Maybe +import Data.List +import Control.Monad (join) +import qualified Data.ChangeMap as M +import qualified Data.Map as MM +import qualified Data.ChangeSet as S + +--------------------------------------------------- + +type TrState = State -> State + + + +nextState e = dispatchEvent e . fc + +fc st = st { game = forgetChanges $ game st } + + +dispatchEvent :: Event -> State -> Maybe State +dispatchEvent e = case e of + Init -> initEvent + FocusIn m -> focusIn m + FocusOut -> focusOut + MouseMotion m -> mouseMotion m + UpEvent -> moveFocus_ (0, -1) + DownEvent -> moveFocus_ (0, 1) + LeftEvent -> moveFocus_ (-1, 0) + RightEvent -> moveFocus_ (1, 0) + HintEvent -> hintEvent + FullHintEvent -> fullHintEvent + NewEvent -> newEvent + UndoEvent -> undoEvent + RedoEvent -> redoEvent + MarkEvent m -> markEvent m + RevealEvent m -> revealEvent m + OpenPreferences -> openPreferences + PreferencesClosed m -> preferencesClosed m + ShowScores -> showScores + NewScoreClosed m a -> newScoreClosed m a + Triggered t -> dispatchTrigger t + _ -> error $ "dispatchEvent: " ++ show e + +dispatchTrigger t = case t of + Tick -> tick + BusyTick -> busyTick + FadeTick -> fadeTick + InterruptVisible -> interruptVisible + RevealDone -> revealDone + +------------------------------------------------------------------- +------------------------------------------------------------------- + +may True x = Just x +may False _ = Nothing + + +------------------------------------ Init + +initEvent st + | Just r <- revealing st + = Just + $ st { revealing = Just $ r + { revResult = Just $ step (configuration st) (revSquare r) (constraints $ game st) (seed st) + } + } + | otherwise + = Just st + +------------------------------------ Ticks + +tick st + | Just t <- timer st + = Just + $ st { timer = Just $ t+1 } + | otherwise = Nothing + +busyTick st + | Just rev <- revealing st + = Just + $ st { revealing = Just $ rev { busyAnimation = Just $ maybe 0 (+1) $ busyAnimation rev }} + | otherwise = Nothing + +fadeTick st + = Just + $ st { redness = [(s, p') | (s, p) <- redness st, let p' = p-1, p'>0] } + +------------------------------------ Focus in/out + +focusIn m st + | Just (_, OtherApp) <- interrupt st + = Just + $ st { interrupt = Nothing + , mouseFocus = calcFocus m st + } + | otherwise + = Just + $ st { mouseFocus = calcFocus m st + } + +focusOut st + | isNothing $ interrupt st + = Just + $ st { interrupt = Just (False, OtherApp) } + | otherwise = Nothing + +interruptVisible st + | Just (False, x) <- interrupt st + = Just + $ st { interrupt = Just (True, x) } + | otherwise = Nothing + +------------------------------------ Mouse and keyboard focus + +mouseMotion m st -- we should always follow the motion of the mouse + | f <- calcFocus m st + , f /= mouseFocus st + = Just + $ st { mouseFocus = f } + | otherwise = Nothing + +moveFocus_ d st + | Just f <- moveFocus d st + = Just + $ st { focus = f } + | otherwise = Nothing + +hintEvent st + | revealCanBeDone st + = Just + . buildHint + . stopTimer (isNothing $ hintAllowed $ configuration $ st) + $ st + { hint = if hint st /= Just NormalHint then Just NormalHint else Nothing + } + | otherwise = Nothing + +fullHintEvent st + | revealCanBeDone st + = Just + . buildHint + . stopTimer (hintAllowed (configuration $ st) /= Just FullHint) + $ st + { hint = if hint st /= Just FullHint then Just FullHint else Nothing + } + | otherwise = Nothing + +------------------------------------ New + +newEvent st + | not $ isNew st + = Just $ new st + | otherwise = Nothing + +------------------------------------ Undo / redo + +undoEvent st + | Nothing <- interrupt st + , ((g, s): gs) <- undo st + = Just + . stopTimer (not $ undoAllowed $ configuration $ st) + $ st + { undo = gs + , redo = s: redo st + , game = g + , revealing = Nothing + } + | otherwise = Nothing + +redoEvent st + | revealCanBeDone st + , (s: ss) <- redo st + = Just + . makeStep s + $ st { redo = ss } + | otherwise = Nothing + +------------------------------------ Mark + +markEvent m st + | markCanBeDone st + , p <- eventPos st m + , M.notMember p $ revealResults $ game st + = Just + . mb addScore + . markEv p + . startTimerIfNew + $ st { redo = takeWhile (compatible p) $ filter (/= Mark p) $ redo st } + | otherwise = Nothing + where + compatible p (Reveal _ ps) = p `notElem` ps + compatible _ _ = True + +------------------------------------ Reveal + +revealEvent m st + | revealCanBeDone st + , p <- eventPos st m + , (p: ps) <- revTarget p st + = Just + . revEv (recursiveReveal $ configuration st) (p: ps) + . startTimerIfNew + . degradeHint + $ st { redo = [] } + | otherwise = Nothing + + +------------------------------------ Preferences + +openPreferences st + | Nothing <- interrupt st + = Just + $ st { interrupt = Just (False, ModifyPreferences) } + | otherwise = Nothing + +preferencesClosed Nothing st + | Just (_, ModifyPreferences) <- interrupt st + = Just + $ st { interrupt = Nothing } + | otherwise = Nothing +preferencesClosed (Just c) st + | Just (_, ModifyPreferences) <- interrupt st + , c == configuration st + = Just + $ st { interrupt = Nothing } + | Just (_, ModifyPreferences) <- interrupt st + , size c == size (configuration st) + , mines c == mines (configuration st) + = Just + . stopTimer True + $ st { interrupt = Nothing + , configuration = c + } + | Just (_, ModifyPreferences) <- interrupt st + = Just + . new + $ st { interrupt = Nothing + , configuration = c + , undo = [] + , redo = [] + , focus = restrictSquare (size c) $ focus st + } + | otherwise = Nothing + +------------------------------------ Scores + +showScores st + | Nothing <- interrupt st + = Just + $ st { interrupt = Just (False, ViewScore) } + | otherwise = Nothing + +newScoreClosed (Just n) attr st + | Just (_, ViewScore) <- interrupt st + , Just e <- scoreEntry st + = Just + $ st + { interrupt = Nothing + , sortOrder = attr + , userName = n + , scores = MM.adjust (\l -> e { se_name = n }: delete e l) (configuration st) (scores st) + } +newScoreClosed _ attr st + | Just (_, ViewScore) <- interrupt st + = Just + $ st { interrupt = Nothing, sortOrder = attr } + | otherwise = Nothing + + + +------------------------------------------------------------------- + +mb :: (a -> Maybe a) -> (a -> a) +mb f x = maybe x id (f x) + + +new st + = buildHint + . loadState + $ st + { undo = [] + , redo = reverse (map snd $ undo st) ++ redo st + , redness = [] + , timer = Nothing + , revealing = Nothing + , hint = Nothing +-- , interrupt = Nothing -- ??? + } + +----------------------------------------------------- Hint + +buildHint st + | isJust (hint st) + , M.null (hiddenProbs $ game st) + , isNothing (revealing st){- !!! -} + = st { game = f (game st) } + | otherwise + = st + where + 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) + + +degradeHint st = st { hint = f $ hint st } where + f (Just FullHint) = Just FullHint + f _ = Nothing + +------------------------------------------------------------------- Mark + +makeStep :: Step -> TrState +makeStep (Reveal seed ps) = revEv False (reverse ps) . changeSeed seed +makeStep (Mark p) = markEv p + +changeSeed s st = st { seed = s } + + + +markEv :: Square -> TrState +markEv p st + | S.member p $ marked g + = st + { game = f g + , undo = [(f g, s) | (g, s) <- undo st, s /= Mark p] + } + | Just q <- revSquare_ st + , p == q + , Just (_, u) <- find' (isReveal . snd) $ undo st + = st + { game = g { marked = S.insert p $ marked g } + , undo = (g, Mark p): u + , revealing = Nothing + } + | otherwise + = st + { game = g { marked = S.insert p $ marked g } + , undo = (g, Mark p): undo st + } + where + g = game st + f g = g { marked = S.delete p $ marked g } + +------------------------------------------------------------------- Reveal + +revEv rec ps st + = revAction rec ps + $ st { undo = (game st, Reveal (seed st) []): undo st } + + +revTarget p st + | M.notMember p $ revealResults $ game st + , S.notMember p $ marked $ game st + = [p] +revTarget p st + | Just (Just n) <- M.lookup p $ revealResults $ game st + , ng <- neighbours (size_ st) p + , n == length [x | x <- ng, S.member x $ marked $ game st ] + = filter (free $ game st) ng +revTarget _ _ + = [] + +revAction _ [] st + = st { revealing = Nothing } +revAction r (x: xs) st + = st + { revealing = Just $ Revealing + { revSquare = x + , revResult = Just $ step (configuration st) x (constraints $ game st) (seed st) + , recRevealing = xs + , busyAnimation = Nothing + , recursive = r + } + } + +revealDone st + | Just ((ust, Reveal se l), us) <- find' (isReveal . snd) $ undo st + = Just + . mb addScore + . buildHint + . revAction (recursive rev) (neigh ++ recRevealing rev) + $ st { seed = seed + , game = g + , redness = [(fo, re) | re/=0] ++ filter ((/=fo) . fst) (redness st) + , undo = (ust, Reveal se (fo:l)): us + } + where + Just rev = revealing st + + (Just (RevealResult al mi cs seed)) = revResult rev + + fo = revSquare rev + + re = round $ 100*(1-al) + + g_ = game st + g = resetHiddenProbs (configuration st) $ g_ + { constraints = cs + , revealResults = M.insert fo mi $ revealResults g_ + , alive = al * alive g_ + } + + neigh + | Just 0 <- mi + , recursive rev + = [p | p<- neighbours (size_ st) fo, free g p, p `notElem` recRevealing rev] + | otherwise + = [] + + +isReveal (Reveal _ _) = True +isReveal _ = False + +find' _ [] = Nothing +find' p (x:xs) + | p x = Just (x, xs) + | otherwise = case find' p xs of + Nothing -> Nothing + Just (y, ys) -> Just (y, x:ys) + + + +---------------------------- timer + +startTimerIfNew st + | isNew st = st { timer = Just 0 } + | otherwise = st + +stopTimer True st = st { timer = Nothing } +stopTimer _ st = st + +----------------------------------------------- focus + +moveFocus (dx, dy) st + | focusMoves st + , (x, y) <- coords $ focus st + , Just f <- square (size $ configuration st) (x+dx) (y+dy) + , f /= focus st + = Just f + | otherwise + = Nothing + + +calcFocus m st + = fmap (calcSquare st) m + + + + diff --git a/When.hs b/When.hs new file mode 100644 --- /dev/null +++ b/When.hs @@ -0,0 +1,26 @@ +module When + ( Timed + , When (Now, At, Later, AfterEval) + ) where + +import Data.Time.Clock +import Data.Time.Format() + +-------------- + +type Timed e + = (When, e) + +data When + = Now + | At UTCTime + | Later NominalDiffTime + | forall a . AfterEval a + +instance Show When where + show Now = "Now" + show (At t) = "At " ++ show t + show (Later t) = "Later " ++ show t + show (AfterEval _) = "AfterEval _" + + diff --git a/minesweeper.cabal b/minesweeper.cabal --- a/minesweeper.cabal +++ b/minesweeper.cabal @@ -1,49 +1,108 @@ name: minesweeper -version: 0.4.1 +version: 0.8.8 category: Game synopsis: Minesweeper game which is always solvable without guessing description: Minesweeper game which is always solvable without guessing. - . - TODO list: - . - * Source code documentation and improvement - . - * Implement the score table. stability: alpha license: BSD3 license-file: LICENSE author: Péter Diviánszky maintainer: divip@aszt.inf.elte.hu -data-files: ms.glade cabal-version: >=1.4 build-type: Simple +data-files: ms.glade +extra-source-files: runInGHCi -executable minesweeper - ghc-options: -Wall -fno-warn-incomplete-patterns -fno-warn-name-shadowing -fno-warn-missing-signatures - build-depends: base >= 3.0, - containers, - random, - time, - glade, - gtk >= 0.10, - cairo >= 0.10 +Flag tests + Description: Enable inner project testing + Default: False - main-is: Minesweeper.hs +executable minesweeper + extensions: + NoMonomorphismRestriction, +-- NoNPlusKPatterns, + EmptyDataDecls, + ScopedTypeVariables, + ExistentialQuantification, + Rank2Types, + MultiParamTypeClasses, + TypeFamilies, + NamedFieldPuns, + PatternGuards, + ViewPatterns, + FlexibleContexts, + TemplateHaskell, + CPP - other-modules: Place, - PlaceSet, - PlaceMap, - Delay, - Core, - Game, - Table, - TableGraphics, - Timer + build-depends: + base >= 3.0 && < 5.0, + numeric-prelude, + containers, + time, + random, + directory, + filepath, + binary, + derive, + lazysmallcheck, + gtk >= 0.10, + cairo >= 0.10, + glade - extensions: RecursiveDo, - NamedFieldPuns, - ViewPatterns, - PatternGuards + if flag(tests) + build-depends: + numeric-prelude, + lazysmallcheck + + CPP-Options: -DTEST + + main-is: + Minesweeper.hs + + other-modules: + Data.ChangeMap, + Data.ChangeSet, + Data.PContainer, + System.Random.Instances, + + Core.Square, + Core.BitField, + Core.Constraints, + + Configuration, + Step, + + Scores, + State, + State.Functions, + + Event, + When, + + GTK, + GTK.Square, + GTK.Preferences, + GTK.Score, + + Transition, + Transition.State, + Transition.Action, + Transition.Response, + Transition.Graphics, + Transition.Managed, + + Log, + + Driver, + Driver.Log + Driver.Simplified + + ghc-options: + -threaded + -Wall + -fno-warn-incomplete-patterns + -fno-warn-name-shadowing + -fno-warn-missing-signatures diff --git a/ms.glade b/ms.glade --- a/ms.glade +++ b/ms.glade @@ -4,7 +4,7 @@ - + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK The Lucky Minesweeper center @@ -29,7 +29,7 @@ True GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK - + gtk-new True GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK @@ -44,13 +44,20 @@ + + True + _Scores + True + + + True GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK - + gtk-quit True GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK @@ -73,7 +80,7 @@ True GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK - + True GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK _Clear @@ -82,7 +89,7 @@ - + True GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK _Flag @@ -91,7 +98,7 @@ - + True _Hint True @@ -99,7 +106,7 @@ - + True _Probabilities True @@ -113,7 +120,7 @@ - + gtk-undo True GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK @@ -123,7 +130,7 @@ - + gtk-redo True GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK @@ -147,7 +154,7 @@ True GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK - + gtk-preferences True GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK @@ -170,7 +177,7 @@ True GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK - + gtk-help True GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK @@ -179,7 +186,7 @@ - + gtk-about True GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK @@ -198,10 +205,10 @@ - + True GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK - x + xxxxxxxxxxxxxxxxxx center True @@ -222,14 +229,19 @@ - + True GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK 0 none False - + + True + True + True + GDK_POINTER_MOTION_MASK | GDK_KEY_PRESS_MASK | GDK_STRUCTURE_MASK + @@ -249,10 +261,10 @@ - + True GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK - x + xxxxxxxxx False @@ -264,7 +276,7 @@ - + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK 5 About The Lucky Minesweeper @@ -329,7 +341,7 @@ - + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK 5 Preferences @@ -339,26 +351,30 @@ True GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK - 2 + 8 True GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK 3 2 + 10 + 5 True GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK - Rows + 0 + Game Size - + True - True - GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK - 10 1 15 1 10 0 + Small +Medium +Large +Custom 1 @@ -366,35 +382,128 @@ - + True + 0 + Mines + + + 2 + 3 + + + + + True True - GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK - 10 1 15 1 10 0 + ● + 1 0 10000 1 10 0 1 2 + 2 + 3 + + + + + True + 0 + Table Size + + 1 2 + + True + + + True + True + ● + 30 1 40 1 10 0 + + + 0 + + + + + True + x + + + 1 + + + + + True + True + ● + 1 1 40 1 10 0 + + + 2 + + + + + 1 + 2 + 1 + 2 + + + + + 2 + + + + + True + + + False + 3 + + + + + True + 7 + 2 + 10 + 5 + True GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK - Columns + 0 + Game Style + + + + True + 0 + Strategy + 1 2 - + True - GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK - Mines + 0 + Death Prob. Range 2 @@ -402,23 +511,165 @@ - + True - True - GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK - 20 0 100 1 10 0 - True + 0 + Lifes + 3 + 4 + + + + + True + 0 + Hint Allowed + + + 6 + 7 + + + + + True + Classic +Lucky +Deterministic +Custom + + 1 2 + + + + + True + Random +Highest Prob. +Uniform Prob. + + + 1 + 2 + 1 + 2 + + + + + True + + + True + True + ● + 1 0 1 0.01 0.10000000000000001 0 + 2 + + + 0 + + + + + True + - + + + 1 + + + + + True + True + ● + 1 0 1 0.01 0.10000000000000001 0 + 2 + + + 2 + + + + + 1 + 2 2 3 + + + True + True + ● + 1 1 10000 1 10 10 + + + 1 + 2 + 3 + 4 + + + + + Recursive Reveal + True + True + False + True + + + 1 + 2 + 4 + 5 + + + + + Undo Allowed + True + True + False + True + + + 1 + 2 + 5 + 6 + + + + + True + None +Normal +Full + + + 1 + 2 + 6 + 7 + + + + + + + + - 2 + 4 @@ -468,7 +719,7 @@ - + 450 GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK 5 @@ -492,13 +743,9 @@ 10 False Minesweeper game which is always solvable without guessing. -The luck of the gamer is measured with 'luckiness'. -Luckiness = -1/2 * log2 p, where p is the probability of that the player would be alive if the game was a normal minesweeper game. -For example, luckiness = 10 means that since the game start the player cleared 20 positions where a mine was with 50% probability, so in a normal game the player probably would die 10 times. - -Known bugs: -* There is no score table. -* The game may slow down at larger tables. +The luck of the player is measured. +Luck is the expected value of deaths in a classical minesweeper game where multiple deaths are allowed. +For example, if the player reveals 10 times a position where the mine probability is 50% then luck = 5. @@ -567,6 +814,197 @@ False end 1 + + + + + + + 5 + Scores + center-on-parent + dialog + False + + + True + vertical + 2 + + + True + Configuration: +... + center + + + 1 + + + + + True + 7 + 4 + 10 + 5 + + + True + 0 + 5 + Player + True + + + + + _Luck + True + False + True + none + True + False + 1 + + + 1 + 2 + + + + + _Time + True + False + True + none + True + 1 + + + 2 + 3 + + + + + _Success + True + False + True + none + True + 1 + + + 3 + 4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + False + 2 + + + + + True + end + + + gtk-ok + -5 + True + True + True + True + + + False + False + 1 + + + + + False + end + 0 diff --git a/runInGHCi b/runInGHCi new file mode 100644 --- /dev/null +++ b/runInGHCi @@ -0,0 +1,4 @@ +!#/bin/sh + +ghci -XNoMonomorphismRestriction -XNoNPlusKPatterns -XEmptyDataDecls -XScopedTypeVariables -XExistentialQuantification -XRank2Types -XMultiParamTypeClasses -XTypeFamilies -XNamedFieldPuns -XPatternGuards -XViewPatterns -XFlexibleContexts -XTemplateHaskell -XCPP $@ +