diff --git a/Configuration.hs b/Configuration.hs --- a/Configuration.hs +++ b/Configuration.hs @@ -1,61 +1,56 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Configuration +module Configuration ( Configuration ( Configuration - , size - , mines + , tableConfig , strategy , deathProbRange - , allowedDeaths - , recursiveReveal - , undoAllowed - , hintAllowed ) + , TableConfig + , tConfig + , size + , mines , numOfSolutions , Strategy (..) - , HintType (..) , Probability - , configuration' + , defaultConfiguration + , showConfiguration ) where import Core.Square -import Core.Constraints +import Core.SquareConstraints +import Data.Data -import Control.Monad -import Data.Binary -import Data.DeriveTH -import Data.Derive.Binary +--import Control.Monad ---------------------------------- +data TableConfig + = TableConfig + { tsize :: BoardSize + , tmines :: Int + , numOfSolutions_ :: Integer -- cached + } + deriving (Eq, Ord, Show, Typeable, Data) + +tConfig :: BoardSize -> Int -> TableConfig +tConfig s m = TableConfig s m (solutions $ initConstraints s m) + +----------------- + data Configuration = Configuration - { size :: Board - , mines :: Int - , numOfSolutions_ :: Integer -- cached, determined by size and mines + { tableConfig :: TableConfig , strategy :: Strategy , deathProbRange :: (Probability, Probability) -- (a, b): ha p valséggel halnánk meg, akkor p>a esetén meghalunk, p Integer -numOfSolutions = numOfSolutions_ +numOfSolutions = numOfSolutions_ . tableConfig -configuration' :: Configuration -> Configuration -configuration' c - = c { numOfSolutions_ = solutions $ initConstraints (size c) (mines c) } +size :: Configuration -> BoardSize +size = tsize . tableConfig +mines :: Configuration -> Int +mines = tmines . tableConfig + ------------------------ -$( derive makeBinary ''HintType ) -$( derive makeBinary ''Strategy ) -$( derive makeBinary ''Configuration ) +defaultConfiguration :: Configuration +defaultConfiguration = Configuration + { tableConfig = tConfig (boardSize 10 10) 20 + , strategy = Random + , deathProbRange = (1,1) + } + +------------------------- + +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 {-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, ScopedTypeVariables, UndecidableInstances, PatternGuards, TemplateHaskell, EmptyDataDecls, GADTs, GeneralizedNewtypeDeriving #-} - -| Core data type for the game. - -> module Core.BitField -> where - - -Import List ------------ - -> import Core.SetContainer -> import Core.Constraint (Constraint, constraint, sizeConstraint, intersectionC) - -> import Data.Binary - -> -- import Data.Maybe -> --import Data.List -> import Data.SetClass hiding (null) - -------------------------------------------------------- - -> class Layouts a where -> -> type BitFieldElem a -> -> numOfLayouts :: a -> Integer -> newLayout :: BitFieldElem a -> Int -> a -> addConstraint :: BitFieldElem a -> Int -> a -> a -> impossible :: a - -> instance (SetContainer a, SetContainerElem a ~ Constraint b, Set b) => Layouts (Maybe a) where -> -> type BitFieldElem (Maybe a) = Domain (SetContainerElem a) -> -> newLayout = curry $ Just . (`insertL` emptyC) . uncurry constraint -> -> numOfLayouts Nothing = 0 -> numOfLayouts (Just x) = product $ map f $ decomp x where -> f :: Decomp (SetContainerElem a) -> Integer -> f (OneElem x) -> = sizeConstraint x -> f (Dependents c d y) -> = sum [ numOfLayouts $ foldr addConstraint' (Just y) e | e <- intersectionC c d ] -> -> addConstraint = curry $ addConstraint' . uncurry constraint -> -> impossible = Nothing - - -> addConstraint' n Nothing = Nothing -- nincs megoldás -> addConstraint' n (Just c) -> | any (null . thd) strength -> = Nothing -> | (x, c', [y]): _ <- filter (null . tail . thd) strength -> = foldr addConstraint' (Just c') y -> | otherwise -> = Just (insertL n c) -> where -> strength = -> [ (x, c', intersectionC n x) -> | (x, c') <- relatedElems n c -> ] - -> thd :: (a,b,c) -> c -> thd (_,_,x) = x - - -Cached Size Implementation --------------------------- - -> newtype CachedSize a -> = CachedSize (Integer, a) -> deriving (Read, Show, Binary) - -| smart constructor - -> cachedSize :: Layouts c => c -> CachedSize c -> cachedSize c = cachedSize_ (numOfLayouts c) c - -> cachedSize_ 0 c = impossible -> cachedSize_ n c = CachedSize (n, c) - -> instance Layouts c => Layouts (CachedSize c) where - -> type BitFieldElem (CachedSize c) = BitFieldElem c - -> numOfLayouts (CachedSize (i, _)) = i -> newLayout = curry $ cachedSize . uncurry newLayout -> addConstraint e f x@(CachedSize (n, c)) = if n == numOfLayouts y then x else y -> where y = cachedSize $ addConstraint e f c -> impossible = CachedSize (0, impossible) - - - diff --git a/Core/Constraint.lhs b/Core/Constraint.lhs --- a/Core/Constraint.lhs +++ b/Core/Constraint.lhs @@ -10,15 +10,14 @@ Import List ----------- -> import Core.SetContainer -> import Core.Square - -> import Data.Binary -> import Data.SetClass - -> --import Data.List hiding (null, union, (\\)) > import Prelude hiding (null) +> import Data.Binary +> import Data.Domain +> import Data.SetClass hiding (intersection) +> import qualified Data.SetClass as S +> -- import Core.SetContainer hiding (empty, intersection) +> import Data.Data ------------------------------------- @@ -26,7 +25,7 @@ > data Constraint c > = Constraint c Int -> deriving (Eq, Read, Show) +> deriving (Eq, Read, Show, Typeable, Data) > -- should always hold > constraint_invariant :: Set a => Constraint a -> Bool @@ -46,18 +45,20 @@ > type Domain (Constraint a) = a -> domain (Constraint a b) = a +> domain (Constraint a _) = a + > constraint :: Set a => a -> Int -> Constraint a > constraint d i > | constraint_invariant c = c > | otherwise = error $ "makeConstraint: " ++ show (size d, i) > where > c = Constraint d i -> -> intersectionC :: Set a => Constraint a -> Constraint a -> [[Constraint a]] -> Constraint a av `intersectionC` Constraint b bv -> = [ filter valid + + +> intersection :: Set a => Constraint a -> Constraint a -> [[Constraint a]] +> Constraint a av `intersection` Constraint b bv +> = [ filter (not . null . domain) > [ Constraint (a `fastMinus` c) (av - cv) > , Constraint c cv > , Constraint (b `fastMinus` c) (bv - cv) @@ -65,60 +66,15 @@ > | cv <- [min' .. max'] ] > where > -> c = intersection a b +> c = S.intersection a b > > min' = 0 `max` (av - (size a - size c)) `max` (bv - (size b - size c)) > > max' = size c `min` av `min` bv > -> valid (Constraint d n) = not (null d) -> > x `fastMinus` y > | size x == size y = empty > | otherwise = x \\ y - ------------------------------------------ - -> data Clear -> data Bomb - -> class Decide a where -> num :: Set b => a -> b -> Int - -> instance Decide Bomb where num _ = size -> instance Decide Clear where num _ = const 0 - -> data (SetContainer a) => EitherC x a -> = EitherC (Domain (SetContainerElem a)) a -> -- deriving (Show) - -> instance Show (EitherC x a) where - -> instance (SetContainer a, Binary (Domain (SetContainerElem a)), Binary a) => Binary (EitherC x a) where -> -> put (EitherC a b) = put (a, b) -> get = do (a,b) <- get -> return (EitherC a b) - - -> instance (SetContainer a, SetContainerElem a ~ Constraint b, Set b, Decide x) -> => SetContainer (EitherC x a) where - -> type SetContainerElem (EitherC x a) = SetContainerElem a - -> emptyC = EitherC empty emptyC - -> decomp (EitherC i o) = [OneElem (Constraint i (num (undefined :: x) i)) | not (null i)] ++ decomp o - -> insertL c@(Constraint s n) (EitherC i o) -> | n == num (undefined :: x) s = EitherC (i `union` s) o -> | otherwise = EitherC i (insertL c o) - -> relatedElems c@(Constraint s _) (EitherC i o) -> = [ (Constraint e (num (undefined :: x) e), EitherC (i \\ e) o) -> | let e = s `intersection` i, not (null e) ] -> ++ [ (x, EitherC i o') | (x, o') <- relatedElems c o ] - Auxiliary Definitions diff --git a/Core/Constraints.lhs b/Core/Constraints.lhs --- a/Core/Constraints.lhs +++ b/Core/Constraints.lhs @@ -1,64 +1,156 @@ --- | Core data type for the game. +> {-# LANGUAGE TypeFamilies, FlexibleContexts, UndecidableInstances, ScopedTypeVariables, EmptyDataDecls, GeneralizedNewtypeDeriving, GADTs, PatternGuards #-} + +| Core data type for the game. + > module Core.Constraints -> ( Constraints -> , initConstraints -> , setSum -> , solutions -> , distribution -> , clearProb -> ) where +> where -> import Data.SetClass (fromList, size) -> import Core.Square -> import Core.BitField +Import List +----------- + +> import Data.SetClass hiding (null, empty, intersection) +> import qualified Data.SetClass as S +> import Data.Domain + > import Core.SetContainer -> import Core.Constraint +> import Core.Constraint +> import Data.Binary +> import Data.Data + +------------------------------------------------------- + +> class Constraints a where + +> type ConstraintDomain a + +> emptyConstraints :: a +> impossible :: a +> solutions :: a -> Integer +> addConstraint :: Constraint (ConstraintDomain a) -> a -> a + -------------------------------- -> type Constraints -> = CachedSize -> (Maybe -> (EitherC Clear -> (EitherC Bomb -> [Constraint SquareSet] -> ) -> ) -> ) +> instance (SetContainer a, SetContainerElem a ~ Constraint b, Set b) => Constraints (Maybe a) where -> solutions :: Constraints -> Integer -> solutions = numOfLayouts +> type ConstraintDomain (Maybe a) = Domain (SetContainerElem a) -> setSum :: SquareSet -> Int -> Constraints -> Constraints -> setSum ps v c -> = addConstraint ps v c +> emptyConstraints = Just empty +> impossible = Nothing -> initConstraints :: Board -> Int -> Constraints -> initConstraints s m -> = newLayout (squares s) m +> solutions Nothing = 0 +> solutions (Just x) = product $ map f $ components x where +> +> f :: Component (SetContainerElem a) -> Integer +> f (OneElem x) +> = sizeConstraint x +> f (TwoElems c d y) +> = sum [ solutions $ foldr addConstraint (Just y) e | e <- intersection c d ] -> clearProb :: Square -> Constraints -> Rational -> clearProb p g -> = fromIntegral (solutions $ setSum (fromList [p]) 0 g) / fromIntegral (solutions g) +> addConstraint _ Nothing = Nothing -- nincs megoldás +> addConstraint n (Just c) +> | any (null . snd) strength +> = Nothing +> | (c', [y]): _ <- filter (null . tail . snd) strength +> = foldr addConstraint (Just c') y +> | otherwise +> = Just (insert n c) +> where +> strength = +> [ (c', intersection n x) +> | (x, c') <- relatedElems n c +> ] -> distribution :: SquareSet -> Constraints -> [Constraints] -> distribution ps cs -> = at ((/=0) . solutions) -> (takeWhile ((/=0) . solutions)) -> [setSum ps i cs | i<-[0..size ps]] +Cached Size Implementation +-------------------------- -Auxiliary ---------- +> newtype CachedSize a +> = CachedSize (Integer, a) +> deriving (Read, Show, Binary, Typeable, Data) -> foldrUntil :: (a -> Bool) -> (a -> b -> b) -> ([a] -> b) -> [a] -> b -> foldrUntil p c n (x:xs) | p x = x `c` foldrUntil p c n xs -> foldrUntil _ _ n xs = n xs +| smart constructor -> at :: (a -> Bool) -> ([a] -> [a]) -> [a] -> [a] -> at p = foldrUntil (not . p) (:) +> cachedSize :: Constraints c => c -> CachedSize c +> cachedSize c = cachedSize_ (solutions c) c + +> cachedSize_ 0 _ = impossible +> cachedSize_ n c = CachedSize (n, c) + + +> instance Constraints c => Constraints (CachedSize c) where + +> type ConstraintDomain (CachedSize c) = ConstraintDomain c + +> solutions (CachedSize (i, _)) = i + +> emptyConstraints = cachedSize emptyConstraints + +> addConstraint z x@(CachedSize (n, c)) +> = if n == solutions y then x else y +> where y = cachedSize $ addConstraint z c + +> impossible = CachedSize (0, impossible) + + +------------------------------------------- + +> class IntFunction a where +> intFunction :: a -> Int -> Int + +> data Const0Fun deriving (Typeable) +> data IdFun deriving (Typeable) + +> instance IntFunction IdFun where intFunction _ = id +> instance IntFunction Const0Fun where intFunction _ = const 0 + +--------------------------------------- + +> data (IntFunction x, SetContainer a) => DetachExtreme x a +> = DetachExtreme (Domain (SetContainerElem a)) a +> deriving (Typeable) + +> appFunction :: forall x a. IntFunction x => DetachExtreme x a -> Int -> Int +> appFunction _ = intFunction (undefined :: x) + +> instance Show (DetachExtreme x a) where +> show = error "show not defined on DetachExtreme" + +> instance (SetContainer a, Binary (Domain (SetContainerElem a)), Binary a) => Binary (DetachExtreme x a) where + +> put (DetachExtreme a b) = put (a, b) +> get = do (a,b) <- get +> return (DetachExtreme a b) + +> instance (SetContainer a, Data (Domain (SetContainerElem a)), Data a, Typeable x) => Data (DetachExtreme x a) where +> gunfold = error "gunfold not defined for DetachExtreme" +> toConstr = error "toConstr not defined for DetachExtreme" +> dataTypeOf = error "dataTypeOf not defined for DetachExtreme" + + +> instance (SetContainer a, SetContainerElem a ~ Constraint b, Set b, IntFunction x) +> => SetContainer (DetachExtreme x a) where + +> type SetContainerElem (DetachExtreme x a) = SetContainerElem a + +> empty = DetachExtreme S.empty empty + +> components d@(DetachExtreme ex o) +> = [OneElem (Constraint ex (appFunction d (size ex))) | not (S.null ex)] +> ++ components o + +> insert c@(Constraint s n) d@(DetachExtreme ex o) +> | n == appFunction d (size s) +> = DetachExtreme (ex `union` s) o +> | otherwise +> = DetachExtreme ex (insert c o) + +> relatedElems c@(Constraint s _) d@(DetachExtreme ex o) +> = [ (Constraint e (appFunction d (size e)), DetachExtreme (ex \\ e) o) +> | let e = s `S.intersection` ex, not (S.null e) ] +> ++ [ (x, DetachExtreme ex o') | (x, o') <- relatedElems c o ] diff --git a/Core/SetContainer.lhs b/Core/SetContainer.lhs --- a/Core/SetContainer.lhs +++ b/Core/SetContainer.lhs @@ -1,7 +1,5 @@ -> {-# LANGUAGE TypeFamilies, FlexibleContexts, UndecidableInstances, ScopedTypeVariables, EmptyDataDecls, RankNTypes, ExistentialQuantification #-} - -| Core data type for the game. +> {-# LANGUAGE TypeFamilies, FlexibleContexts, UndecidableInstances, ScopedTypeVariables, RankNTypes, ExistentialQuantification #-} > module Core.SetContainer > where @@ -10,24 +8,10 @@ Import List ----------- -> import Data.Binary -> import Data.DeriveTH -> import Data.Derive.Binary -> import Data.Derive.Functor - -> import Data.SetClass - -> import Data.Maybe > import Data.List - ------------------------------- - -> class Set (Domain a) => HasDomain a where - -> type Domain a - -> domain :: a -> Domain a +> import Data.SetClass +> import Data.Domain ------------------------------ @@ -35,28 +19,32 @@ > > type SetContainerElem c > -> emptyC :: c -> decomp :: c -> [Decomp (SetContainerElem c)] -> insertL :: SetContainerElem c -> c -> c +> empty :: c +> components :: c -> [Component (SetContainerElem c)] +> insert :: SetContainerElem c -> c -> c > relatedElems :: SetContainerElem c -> c -> [(SetContainerElem c, c)] -> data Decomp e +> data Component e > = OneElem e -> | forall b. (SetContainer b, SetContainerElem b ~ e) => Dependents (SetContainerElem b) (SetContainerElem b) b +> | forall b. (SetContainer b, SetContainerElem b ~ e) => +> TwoElems (SetContainerElem b) (SetContainerElem b) b ------------------------------------- > instance HasDomain a => SetContainer [a] where -> + > type SetContainerElem [a] = a -> -> emptyC = [] -> insertL = (:) -> decomp [] = [] -> decomp [a] = [OneElem a] -> decomp (a:as) = case relatedElems a as of -> [] -> OneElem a: decomp as -> (b, c): _ -> [Dependents a b c] + +> empty = [] + +> insert = (:) + +> components [] = [] +> components [a] = [OneElem a] +> components (a:as) = case relatedElems a as of +> [] -> OneElem a: components as +> (b, c): _ -> [TwoElems a b c] + > relatedElems x l = [(y, d) | (y, d) <- takeOut l, not (domain x `disjunct` domain y)] diff --git a/Core/Square.hs b/Core/Square.hs --- a/Core/Square.hs +++ b/Core/Square.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -8,8 +7,8 @@ module Core.Square ( -- * Types - Board - , board + BoardSize + , boardSize , xSize , ySize @@ -26,82 +25,80 @@ import Data.Binary import Data.Bits import Data.Maybe +import Data.Function import Data.SetClass import qualified Data.IntSet as IS import Prelude hiding (null) +import Data.Data +----------------------- auxiliary functions + +infix 4 `between` +a `between` (b, c) = b <= a && a <= c + +packable :: Int -> Bool +packable i = i `between` (0, 255) + +pack :: Int -> Int -> Int +pack i j = shiftL i 8 .|. j + +unpack :: Int -> (Int, Int) +unpack i = (shiftR i 8, i .&. 255) + ----------- --- | Board of a board. -newtype Board - = S { unS :: Int } - deriving (Eq, Ord, Binary) +-- | Size of a board. +newtype BoardSize + = BS { unBS :: Int } + deriving (Eq, Ord, Binary, Typeable, Data) -instance Show Board where - show = show . unS +instance Show BoardSize where + show = show . unBS -xSize, ySize :: Board -> Int -xSize = fst . unpack . unS -ySize = snd . unpack . unS +xSize, ySize :: BoardSize -> Int +xSize = fst . unpack . unBS +ySize = snd . unpack . unBS -board :: Int -> Int -> Board -board i j | i `between` (1, 255) && j `between` (1, 255) = S $ pack i j +boardSize :: Int -> Int -> BoardSize +boardSize i j | packable i && packable j + = BS $ pack i j -------------------------- -- | Square on a board. newtype Square - = P { unP :: Int } - deriving (Eq, Ord, Binary) + = S { unS :: Int } + deriving (Eq, Ord, Binary, Typeable, Data) instance Show Square where show = show . coords coords :: Square -> (Int, Int) -coords (P i) = unpack i +coords (S i) = unpack i -square :: Board -> Int -> Int -> Maybe Square +square :: BoardSize -> 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 + | i `between` (1, xSize s) && j `between` (1, ySize s) + = Just $ S $ pack i j + | otherwise + = Nothing -restrictSquare :: Board -> Square -> Square +restrictSquare :: BoardSize -> 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 -> SquareSet -squares s = fromList [P p | x <- [1..xSize s], p <- take (ySize s) [pack x 1 ..]] - --- | Neighbours of a square on a board. -neighbours :: Board -> Square -> SquareSet -neighbours s (coords -> (i, j)) - = fromList $ catMaybes - [square s (i+a) (j+b) | (a, b) <- [(-1,0),(-1,-1),(0,-1),(1,-1),(1,0),(1,1),(0,1),(-1,1)]] - ------------------------ auxiliary functions - -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 + = S $ pack (max 1 $ min (xSize s) i) (max 1 $ min (ySize s) j) --------------------------------- -newtype SquareSet = SS { unSS :: IS.IntSet } deriving (Show, Binary) +newtype SquareSet + = SS { unSS :: IS.IntSet } + deriving (Show, Binary, Typeable, Data) instance Set SquareSet where type SetElem SquareSet = Square - toList = map P . toList . unSS - fromList = SS . fromList . map unP + toList = map S . toList . unSS + fromList = SS . fromList . map unS size = size . unSS intersection = bi intersection (\\) = bi (\\) @@ -109,6 +106,22 @@ null = null . unSS empty = SS empty -bi f a b = SS $ f (unSS a) (unSS b) +bi f = ((.) SS . f) `on` unSS + +----------------------------------- + +-- | Squares of a board. +squares :: BoardSize -> SquareSet +squares s + = SS $ IS.fromDistinctAscList + [p | x <- [1..xSize s], p <- take (ySize s) [pack x 1 ..]] + +-- | Neighbours of a square on a boardSize. +neighbours :: BoardSize -> Square -> SquareSet +neighbours s (coords -> (i, j)) + = SS $ IS.fromDistinctAscList + [pack x y | x<-[max 1 (i-1)..min (xSize s) (i+1)] + , y<-[max 1 (j-1)..min (ySize s) (j+1)] + , (x,y)/=(i,j) ] diff --git a/Core/SquareConstraints.lhs b/Core/SquareConstraints.lhs new file mode 100644 --- /dev/null +++ b/Core/SquareConstraints.lhs @@ -0,0 +1,64 @@ +> {-# LANGUAGE TypeFamilies, FlexibleContexts, UndecidableInstances, ScopedTypeVariables, EmptyDataDecls #-} + +-- | Core data type for the game. + +> module Core.SquareConstraints +> ( SquareConstraints +> , initConstraints +> , setSum +> , solutions +> , distribution +> , clearProb +> ) where + +> import Data.SetClass +> import Core.Square +> import Core.Constraint +> import qualified Core.Constraints as B + +> import Prelude hiding (null) + +-------------------------------- + +> type SquareConstraints +> = B.CachedSize +> (Maybe +> (B.DetachExtreme B.Const0Fun +> (B.DetachExtreme B.IdFun +> [Constraint SquareSet] +> ) +> ) +> ) + +> solutions :: SquareConstraints -> Integer +> solutions = B.solutions + +> setSum :: SquareSet -> Int -> SquareConstraints -> SquareConstraints +> setSum s i = B.addConstraint $ constraint s i + +> initConstraints :: BoardSize -> Int -> SquareConstraints +> initConstraints s m +> = setSum (squares s) m B.emptyConstraints + +> clearProb :: Square -> SquareConstraints -> Rational +> clearProb p g +> = fromIntegral (solutions $ setSum (fromList [p]) 0 g) / fromIntegral (solutions g) + +> distribution :: SquareSet -> SquareConstraints -> [SquareConstraints] +> distribution ps cs +> = at ((/=0) . solutions) +> (takeWhile ((/=0) . solutions)) +> [setSum ps i cs | i<-[0..size ps]] + + +Auxiliary +--------- + +> foldrUntil :: (a -> Bool) -> (a -> b -> b) -> ([a] -> b) -> [a] -> b +> foldrUntil p c n (x:xs) | p x = x `c` foldrUntil p c n xs +> foldrUntil _ _ n xs = n xs + +> at :: (a -> Bool) -> ([a] -> [a]) -> [a] -> [a] +> at p = foldrUntil (not . p) (:) + + diff --git a/Data/ChangeMap.hs b/Data/ChangeMap.hs --- a/Data/ChangeMap.hs +++ b/Data/ChangeMap.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NoMonomorphismRestriction, TemplateHaskell #-} module Data.ChangeMap ( Map , changes @@ -13,6 +12,7 @@ , notMember , alter , fromList + , toList , null , adjust ) where @@ -21,15 +21,7 @@ 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 --} +import Data.Data -------------------- @@ -37,7 +29,7 @@ { toMap :: M.Map k a , changes :: [k] } - deriving (Show, Read) + deriving (Show, Read, Typeable, Data) forget (ChangeMap m _) = ChangeMap m [] @@ -67,28 +59,15 @@ null = M.null . toMap -empty = fromMap $ M.empty +empty = fromMap M.empty fromList = fromMap . M.fromList - - - - - - - --- $( derive makeBinary ''Map ) - - +toList = M.toList . toMap 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 --- a/Data/ChangeSet.hs +++ b/Data/ChangeSet.hs @@ -16,57 +16,51 @@ , (\\) ) where -import qualified Data.Set as M +import qualified Data.Set as S import Data.Binary -{- -import Control.Monad -import Data.DeriveTH -import Data.Derive.Binary --} +import Data.Data + ------------------------------ data Set k = ChangeSet - { toSet :: M.Set k + { toSet :: S.Set k , changes :: [k] } - deriving (Show, Read) + deriving (Show, Read, Typeable, Data) forget (ChangeSet m _) = ChangeSet m [] -fromSet s = ChangeSet s (M.toList s) +fromSet s = ChangeSet s (S.toList s) ---------------------- -insert k (ChangeSet m c) = ChangeSet (M.insert k m) (k: c) +insert k (ChangeSet m c) = ChangeSet (S.insert k m) (k: c) -delete k (ChangeSet m c) = ChangeSet (M.delete k m) (k: c) +delete k (ChangeSet m c) = ChangeSet (S.delete k m) (k: c) -size = M.size . toSet +size = S.size . toSet -member k = M.member k . toSet +member k = S.member k . toSet -notMember k = M.notMember k . toSet +notMember k = S.notMember k . toSet -toList = M.toList . toSet +toList = S.toList . toSet -empty = fromSet $ M.empty +empty = fromSet $ S.empty -fromList = fromSet . M.fromList +fromList = fromSet . S.fromList -fromDistinctAscList = fromSet . M.fromDistinctAscList +fromDistinctAscList = fromSet . S.fromDistinctAscList -a \\ b = fromSet (toSet a M.\\ toSet b) +a \\ b = fromSet (toSet a S.\\ 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/Domain.hs b/Data/Domain.hs new file mode 100644 --- /dev/null +++ b/Data/Domain.hs @@ -0,0 +1,16 @@ + +{-# LANGUAGE TypeFamilies, FlexibleContexts #-} + +module Data.Domain + where + + +import Data.SetClass + + +class Set (Domain a) => HasDomain a where + + type Domain a + + domain :: a -> Domain a + diff --git a/Data/SetClass.lhs b/Data/SetClass.lhs --- a/Data/SetClass.lhs +++ b/Data/SetClass.lhs @@ -23,13 +23,17 @@ > toList :: a -> [SetElem a] > fromList :: [SetElem a] -> a > size :: a -> Int -> intersection :: a -> a -> a +> intersection :: a -> a -> a > (\\) :: a -> a -> a > union :: a -> a -> a > null :: a -> Bool > empty :: a +> disjunct :: a -> a -> Bool +> disjunct a b = null (intersection a b) +--------------------------- + > instance Ord a => Set (S.Set a) where > type SetElem (S.Set a) = a @@ -56,9 +60,5 @@ > union = IS.union > null = IS.null > empty = IS.empty - - -> disjunct :: Set a => a -> a -> Bool -> disjunct a b = null (intersection a b) diff --git a/Driver.hs b/Driver.hs --- a/Driver.hs +++ b/Driver.hs @@ -9,7 +9,6 @@ import When import Control.Concurrent -import Control.Concurrent.MVar import Data.Maybe (catMaybes) import Data.Time.Clock import Data.Time.Format() diff --git a/Driver/Log.hs b/Driver/Log.hs --- a/Driver/Log.hs +++ b/Driver/Log.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PatternGuards #-} + module Driver.Log ( Result (..) , Transition diff --git a/Event.hs b/Event.hs --- a/Event.hs +++ b/Event.hs @@ -1,7 +1,9 @@ module Event where +import Numeric import Core.Square -import Configuration (Configuration) +import Step (RevealResult) +import Preferences (Preferences) import State (ScoreAttr, ScoreEntry) -------------------------------------- input ------------- @@ -9,22 +11,28 @@ type MousePos = Maybe Square data Event - = RevealEvent MousePos -- Nothing: by keyboard + = NewEvent -- new game + + | 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) + | PreferencesClosed (Maybe Preferences) | NewScoreClosed (Maybe String) [ScoreAttr] + + | MouseMotion MousePos -- Nothing: mouse is outside + | LeftEvent + | RightEvent + | UpEvent + | DownEvent + | FocusOut | FocusIn MousePos -- Nothing: mouse is outside @@ -40,8 +48,9 @@ deriving (Eq, Ord, Show) data Triggered - = RevealDone + = RevealDone RevealResult | SquareHintDone + | Tick | FadeTick | BusyTick @@ -54,12 +63,50 @@ type Responses = [Response] data Response - = DrawSquares Board [(Square, SquareState)] - | ShowTime String -- gyorsulna szerkezetváltással - | ShowInfo String -- gyorsulna szerkezetváltással - | PopUpPreferences Configuration - | PopUpNewScore Configuration (Maybe Int) [ScoreEntry] [ScoreAttr] + = DrawSquares BoardSize [(Square, SquareState)] + | ShowTime TimeInfo + | ShowInfo Info + | PopUpPreferences Preferences + | PopUpNewScore Preferences (Maybe Int) [ScoreEntry] [ScoreAttr] deriving (Eq, Ord, Show) + + +data Info + = InfoWin Double + | InfoLoose Bool -- True: of necessity, False: by accident + | InfoPlay Int{-mines-} Double{-information-} Double{-luck-} + deriving (Eq, Ord) + +instance Show Info where + show (InfoWin luck) = "Congratulations! You won with " ++ show_ 2 luck ++ " luck." + show (InfoLoose n) = "Sorry, you died " ++ if n then "of necessity." else "by accident." + show (InfoPlay m i l) + = "Mines left: " ++ show m ++ " " + ++ "Information: " ++ show_ 1 (100 * i) ++ "%" ++ " " + ++ "Luck: " ++ show_ 2 l + +show_ :: RealFloat a => Int -> a -> [Char] +show_ i x = showFFloat (Just i) x "" + +data TimeInfo + = TimerInit + | TimerStopped + | TimerAt Int + deriving (Eq, Ord) + +instance Show TimeInfo where + show TimerInit = "Timer will start" + show TimerStopped = "Timer stopped" + show (TimerAt 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 + + + data SquareState = HiddenSign diff --git a/GTK.hs b/GTK.hs --- a/GTK.hs +++ b/GTK.hs @@ -5,7 +5,7 @@ , handleResponses ) where -import Configuration +import Preferences import State import Event import Core.Square @@ -16,11 +16,11 @@ import Graphics.UI.Gtk import Graphics.UI.Gtk.Glade -import Graphics.UI.Gtk.Gdk.EventM +--import Graphics.UI.Gtk.Gdk.EventM import Graphics.Rendering.Cairo (liftIO) -- ??? -import Data.Char -import Data.Maybe +--import Data.Char +--import Data.Maybe import Data.Time.Clock import Control.Concurrent @@ -34,17 +34,17 @@ , table :: DrawingArea , window :: Window , event_ :: Event -> IO () - , tSize :: MVar Board + , tSize :: MVar BoardSize - , setPref :: Configuration -> IO (Maybe Configuration) - , newScore :: Configuration -> Maybe Int -> [ScoreEntry] -> [ScoreAttr] -> IO (Maybe String, [ScoreAttr]) + , setPref :: Preferences -> IO (Maybe Preferences) + , newScore :: Preferences -> Maybe Int -> [ScoreEntry] -> [ScoreAttr] -> IO (Maybe String, [ScoreAttr]) } ------------------------------------------------------ guiState :: (Event -> IO ()) -> IO () -> IO GUIState guiState event_ saveState = do - unsafeInitGUIForThreadedRTS + _ <- unsafeInitGUIForThreadedRTS xml <- msglade window <- xmlGetWidget xml castToWindow "window" @@ -52,7 +52,7 @@ 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" + tSize <- newMVar $ boardSize 1 1 -- $ error "module GTK: tSize was not defined" setPref <- setPreferences xml newScore <- newScore_ xml -- showScores <- showScores_ xml @@ -70,15 +70,15 @@ -- , 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 + _ <- 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 + _ <- onDestroy window $ saveState >> mainQuit + _ <- onFocusOut window $ const $ alwaysTrue $ event_ FocusOut + _ <- onFocusIn window $ const $ alwaysTrue $ eventFocusIn' gst mapM_ (addMenuItem xml) [ ("quit", widgetDestroy window) @@ -168,16 +168,16 @@ 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!! + _ <- 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 + postGUISync $ labelSetText (timeLabel gst) $ show s ShowInfo s -> do - postGUISync $ labelSetText (infoLabel gst) s + postGUISync $ labelSetText (infoLabel gst) $ show s waitTill (addUTCTime 0.02 time) event_ gst InfoDrawingDone {- @@ -197,17 +197,17 @@ popUpHelp = do xml <- msglade a <- xmlGetWidget xml castToDialog "helpdialog" - dialogRun a + _ <- dialogRun a widgetDestroy a popUpAbout = do xml <- msglade a <- xmlGetWidget xml castToDialog "aboutdialog" - dialogRun a + _ <- dialogRun a widgetDestroy a -redrawSigns :: GUIState -> Board -> [(Square, SquareState)] -> IO () +redrawSigns :: GUIState -> BoardSize -> [(Square, SquareState)] -> IO () redrawSigns _ _ [] = return () redrawSigns gst s l = do win <- widgetGetDrawWindow $ table gst diff --git a/GTK/Preferences.hs b/GTK/Preferences.hs --- a/GTK/Preferences.hs +++ b/GTK/Preferences.hs @@ -4,37 +4,37 @@ import Core.Square import Configuration ---import State +import Preferences --import State.Functions import Control.Monad -import Graphics.UI.Gtk hiding (Clear) +import Graphics.UI.Gtk import Graphics.UI.Gtk.Glade import Data.List ----------------------- getSize c - = (size c, mines c) + = (size . configuration $ c, mines . configuration $ c) sizeTable = - [ (board 5 5, 5) - , (board 10 10, 20) - , (board 15 15, 45) + [ (boardSize 5 5, 5) + , (boardSize 10 10, 20) + , (boardSize 15 15, 45) ] getStyle c - = (strategy c, deathProbRange c, allowedDeaths c, recursiveReveal c, undoAllowed c, hintAllowed c) + = (strategy . configuration $ c, deathProbRange . configuration $ 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) + [ (Random, (0,1), True, False, Nothing) + , (Random, (1,1), True, False, Nothing) + , (HighestProb, (1,1), False, True, Just FullHint) ] ----------------------- -setPreferences :: GladeXML -> IO (Configuration -> IO (Maybe Configuration)) +setPreferences :: GladeXML -> IO (Preferences -> IO (Maybe Preferences)) setPreferences xml = do dialog <- xmlGetWidget xml castToDialog "prefdialog" @@ -51,18 +51,17 @@ undoallowed <- xmlGetWidget xml castToCheckButton "undoallowed" hintallowed <- xmlGetWidget xml castToComboBox "hintallowed" - let setPS :: (Board, Int) -> IO () + let setPS :: (BoardSize, 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 + setGS :: (Strategy, (Probability, Probability), Bool, Bool, Maybe HintType) -> IO () + setGS (str, (dl, dh), 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] @@ -92,10 +91,10 @@ y <- get sizey spinButtonValue spinButtonSetRange mines' 0 (x*y) - predefsize `on` changed $ setSensS - gamestyle `on` changed $ setSensG - onValueSpinned sizex setRange - onValueSpinned sizey setRange + _ <- predefsize `on` changed $ setSensS + _ <- gamestyle `on` changed $ setSensG + _ <- onValueSpinned sizex setRange + _ <- onValueSpinned sizey setRange return $ \c -> do @@ -108,7 +107,7 @@ setSensG setRange - + r <- dialogRun dialog widgetHide dialog @@ -120,21 +119,19 @@ 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 + return $ Just $ c + { configuration = (configuration c) + { tableConfig = tConfig (boardSize (round x) (round y)) (round m) + , strategy = toEnum s + , deathProbRange = (realToFrac dl, realToFrac dh) + } , recursiveReveal = rr , undoAllowed = ua , hintAllowed = if ha == 0 then Nothing else Just (toEnum $ ha-1) --- , numOfSolutions = undefined } _ -> diff --git a/GTK/Score.hs b/GTK/Score.hs --- a/GTK/Score.hs +++ b/GTK/Score.hs @@ -2,19 +2,21 @@ ( newScore_ ) where -import Configuration +import Preferences +import Table (luckFunction) +import Configuration (showConfiguration) import State import State.Functions -import Graphics.UI.Gtk hiding (Clear, Size, on) +import Graphics.UI.Gtk hiding (Size, on) import Graphics.UI.Gtk.Glade import Control.Concurrent.MVar import Control.Monad import Data.List -import Data.Maybe -import Data.Function +--import Data.Maybe +--import Data.Function import Numeric ------------------------------------------- @@ -27,7 +29,7 @@ -newScore_ :: GladeXML -> IO (Configuration -> Maybe Int -> [ScoreEntry] -> [ScoreAttr] -> IO (Maybe String, [ScoreAttr])) +newScore_ :: GladeXML -> IO (Preferences -> Maybe Int -> [ScoreEntry] -> [ScoreAttr] -> IO (Maybe String, [ScoreAttr])) newScore_ xml = do dialog <- xmlGetWidget xml castToDialog "scoredialog" @@ -93,14 +95,14 @@ when (sl /= sl_old) showEntries initSort b sa = do - onButtonActivate b $ sortScoresBy sa + _ <- onButtonActivate b $ sortScoresBy sa onPressed b $ sortScoresBy sa zipWithM_ initSort buttons attrs_ return $ \c i es attrs -> do - labelSetText configLabel $ showConfiguration c + labelSetText configLabel $ showConfiguration $ configuration c maybe (return ()) (entrySetText entry . se_name . (es!!)) i diff --git a/Log.hs b/Log.hs --- a/Log.hs +++ b/Log.hs @@ -7,7 +7,7 @@ ) where import Control.Concurrent.MVar -import Data.Time.Clock +--import Data.Time.Clock import Data.Time.Format() data LogState @@ -30,12 +30,12 @@ = return () writeLog (FileLog m) s = modifyMVar_ m $ \fn -> do - time <- getCurrentTime +-- time <- getCurrentTime appendFile fn $ unlines s -- appendFile fn $ unlines $ ("----- " ++ show time ++ " -----"): s return fn writeLog StdOutLog s = do - time <- getCurrentTime +-- 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,4 +1,4 @@ - +{-# LANGUAGE RankNTypes #-} import Log import Driver.Log import Event @@ -6,17 +6,29 @@ import GTK import Control.Concurrent -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 Random () +import qualified Data.ByteString.Lazy as B + +import Data.ChangeMap +import qualified Data.Map as MM +import Data.ChangeSet +import Core.Square +import Preferences +import State (ScoreEntry) +import Step +import Random + +import Data.Data + import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Data.Binary.Generic +import Data.Binary.Generic.Extensions -------------------------------------- @@ -38,19 +50,11 @@ -- init program state userName <- getEnv "USER" - seed <- newStdGen + seed <- newRandomSeed 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 + then fmap (runGet myGet) $ B.readFile prefFile + else return $ initState userName seed -- init driver state dst <- initDriverState st @@ -75,8 +79,33 @@ writeState prefFile dst = do st <- takeState dst createDirectoryIfMissing True $ takeDirectory prefFile - encodeFile prefFile $ stopState st --- writeFile prefFile $ show $ stopState st + B.writeFile prefFile $ runPut $ myPut $ stopState st +-- encodeFile prefFile $ stopState st +--------------------------- + +myPut :: Data a => a -> Put +myPut = putExtDef (putGenericByCallback myPut) + +myGet :: Data a => Get a +myGet = getExtDef (getGenericByCallback myGet) + +getExtDef :: Typeable a => Get a -> Get a +getExtDef = extGet (get :: Get (MM.Map Preferences [ScoreEntry])) + . extGet (get :: Get (Set Square)) + . extGet (get :: Get (Map Square (Maybe Int))) + . extGet (get :: Get (Map Square Int)) + . extGet (get :: Get (RandomSeed)) + . extGet (get :: Get (SquareConstraints)) + . getExtDefault + +putExtDef :: Typeable a => (a -> Put) -> a -> Put +putExtDef = extPut (put :: MM.Map Preferences [ScoreEntry] -> Put) + . extPut (put :: Set Square -> Put) + . extPut (put :: Map Square (Maybe Int) -> Put) + . extPut (put :: Map Square Int -> Put) + . extPut (put :: RandomSeed -> Put) + . extPut (put :: SquareConstraints -> Put) + . putExtDefault diff --git a/Preferences.hs b/Preferences.hs new file mode 100644 --- /dev/null +++ b/Preferences.hs @@ -0,0 +1,47 @@ + +module Preferences where + +import Configuration +import Data.Data + +import Data.Binary +import Data.Binary.Generic + + +------------------ + +data Preferences = Preferences + { configuration :: Configuration + + , recursiveReveal :: Bool -- nem kell a scoreba? + + , undoChangesSeed :: Bool -- nem kell a scoreba + , undoAllowed :: Bool + + , hintAllowed :: Maybe HintType + } + deriving (Eq, Ord, Show, Typeable, Data) + +defaultPreferences = Preferences + { configuration = defaultConfiguration + + , undoChangesSeed = True + , recursiveReveal = True + , undoAllowed = False + , hintAllowed = Nothing + } + +data HintType + = NormalHint + | FullHint + deriving (Eq, Ord, Show, Enum, Typeable, Data) + +instance Binary Preferences where + put = putGeneric + get = getGeneric +{- +instance Binary HintType where + put = putGeneric + get = getGeneric +-} + diff --git a/Random.hs b/Random.hs new file mode 100644 --- /dev/null +++ b/Random.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE StandaloneDeriving, GeneralizedNewtypeDeriving #-} +module Random + ( RandomSeed + , newRandomSeed + , integerDomino + ) where + +import System.Random +import Data.Binary +import Data.Data + +newtype RandomSeed + = RS StdGen + deriving (Read, Show, Typeable, Data) + +instance Data StdGen where + gunfold = error "gunfold not defined for StdGen" + toConstr = error "toConstr not defined for StdGen" + dataTypeOf = error "dataTypeOf not defined for StdGen" + +deriving instance Typeable StdGen + + +newRandomSeed :: IO RandomSeed +newRandomSeed = fmap RS newStdGen + +instance Binary RandomSeed where + put = put . show + get = fmap read get + + +-- | Get a value from a discrete distribution with the domino algorithm. +integerDomino :: [Integer] -> RandomSeed -> (Int, RandomSeed) +integerDomino is (RS r) = (length zeros + x, RS r'') + where + (zeros, is') = span (==0) is + sis = scanl1 (+) is' + sl = last sis -- sum is + + (y, r') = randomR (1, sl) r + j = length $ takeWhile ( 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 :: String -> RandomSeed -> State initState userName seed = loadState $ State { userName = userName - , undoChangesSeed = True - , configuration = c - , seed = seed + , preferences = defaultPreferences + , initialSeed = seed , undo = [] , redo = [] - , focus = fromJust $ square (size c) 1 1 + , focus = fromJust $ square (size defaultConfiguration) 1 1 , mouseFocus = Nothing , redness = [] @@ -57,61 +40,26 @@ , sortOrder = [SA_Time, SA_Alive, SA_Success] , timer = Nothing - , revealing = Nothing + , revealing = [] , 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) + { game = initGameState (configuration $ preferences st) (initialSeed 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 +stopState st = st { mouseFocus = Nothing } +revResult st + | (x:_) <- revealing st + = cAndG (gameStep $ revSquare x) st ----------------------- 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 @@ -124,12 +72,14 @@ hiddenTable st = longInterrupt st && isJust (timer st) - && not (isFinished st) + && not (cAndG isFinished st) +cAndG f st = f (configuration $ preferences st) (game st) + -- the focus can be moved focusMoves st = not (longInterrupt st) - && not (isFinished st) + && not (cAndG isFinished st) -- the mouse focus is shown mouseFocusShown st @@ -140,33 +90,36 @@ -- reveal / mark / hint can be done revealCanBeDone st = isNothing (interrupt st) - && not (isFinished st) - && isNothing (revealing st) + && not (cAndG isFinished st) + && null (revealing st) -- mark can be done markCanBeDone st = isNothing (interrupt st) - && mines_left st > 0 - && not (isFinished st) + && cAndG mines_left st > 0 + && not (cAndG isFinished st) -- the timer is active isActive st = isNothing (busyAnimation_ st) && isNothing (interrupt st) && isJust (timer st) - && not (isFinished st) + && not (cAndG isFinished st) -------------- attributes -allSolutions = numOfSolutions . configuration +-- seed = currentSeed . game -busyAnimation_ = join . fmap busyAnimation . revealing +-- allSolutions = numOfSolutions . configuration -revSquare_ = fmap revSquare . revealing +busyAnimation_ = join . fmap busyAnimation . l2m . revealing -size_ = size . configuration +l2m (x:_) = Just x +l2m [] = Nothing +size_ = size . configuration . preferences +{- msize g = xSize s * ySize s where s = size_ g mines_left st @@ -180,7 +133,6 @@ all = allSolutions st s = solutions $ constraints $ game st - prec = 100 -- base 2 logarithm for large numbers log2 :: (Ord a, Num a) => Int -> a -> Double @@ -193,9 +145,6 @@ _ -> fromIntegral a / fromIntegral b -allSquares - = squares . size . configuration - luck :: State -> Double luck = luckFunction . alive . game @@ -211,7 +160,7 @@ isRevealed g p = M.member p (revealResults g) - +-} ---------------------------------------- @@ -221,7 +170,7 @@ calcSquare = restrictSquare . size_ --------------------------------------- - +{- showConfiguration c = unlines $ filter (not . null) [ unwords [show (xSize s) ++ "×" ++ show (ySize s), "table,", show $ mines c, "mines"] @@ -238,7 +187,7 @@ 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 + , cAndG playerWins st = Just $ ScoreEntry { se_name = userName st - , se_time = t + 1 -- felfelé kerekítünk - , se_alive = alive $ game st + , se_time = t + 1 + , se_alive = aliveness $ game st , se_deaths = 0 - , se_history = reverse $ map snd $ undo st + , se_history = map (fmap (const ())) $ reverse $ undo st } | otherwise = Nothing @@ -266,7 +215,7 @@ currentScores :: State -> [ScoreEntry] currentScores st - = ff $ MM.lookup (configuration st) (scores st) + = ff $ MM.lookup (preferences st) (scores st) where ff (Just l) = l ff Nothing = [] @@ -274,7 +223,7 @@ addScore st | Just e <- scoreEntry st - , st' <- st { scores = MM.alter (Just . maybe [e] (e:)) (configuration st) (scores st) } + , st' <- st { scores = MM.alter (Just . maybe [e] (e:)) (preferences st) (scores st) } , e `elem` cutScores st' = Just $ st' { interrupt = Just (False, ViewScore) } | otherwise @@ -312,10 +261,10 @@ = 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 --- a/Step.hs +++ b/Step.hs @@ -1,19 +1,20 @@ module Step ( step , RevealResult (..) + , SquareConstraints ) where ------------------------------------------- import Configuration import Core.Square -import Core.Constraints +import Core.SquareConstraints import Data.Ratio import Data.List import Data.SetClass (fromList) import Data.Maybe -import System.Random +import Random import Data.Binary @@ -22,30 +23,32 @@ data RevealResult = RevealResult { safety :: !Probability , squareState :: !(Maybe Int) - , rrConstraints :: !Constraints - , rrSeed :: !StdGen + , rrConstraints :: !SquareConstraints + , rrSeed :: !RandomSeed } deriving (Show) +instance Eq RevealResult where _ == _ = True +instance Ord RevealResult where _ `compare` _ = EQ + + instance Binary RevealResult where put = error "put on RevealResult" get = error "get on RevealResult" ------------------------------------------- - - -step :: Configuration -> Square -> Constraints -> StdGen -> RevealResult +step :: Configuration -> Square -> SquareConstraints -> RandomSeed -> RevealResult step conf p cs r - | dead = RevealResult prob Nothing (setSum (fromList [p]) 1 cs) r_ - | otherwise = x `seq` RevealResult prob (Just x) (l !! x) r' + | dead = RevealResult prob Nothing (setSum (fromList [p]) 1 cs) r' + | otherwise = x `seq` RevealResult prob (Just x) (l !! x) r'' where cs' = setSum (fromList [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_ + (dead, r') = appDeath (deathProbRange conf) (1-prob) r + (x, r'') = appStrat (strategy conf) (map solutions l) r' prob = fromIntegral (solutions cs') / fromIntegral (solutions cs) @@ -60,7 +63,7 @@ ff (x, y) = (numerator (d*x), numerator (d*y)) where d = fromInteger $ denominator (x*y) - +-- appStrat _ l r = (0, r) appStrat Random l r = integerDomino l r appStrat HighestProb l r @@ -68,18 +71,5 @@ 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 ( RandomSeed -> GameState +initGameState c seed = resetHiddenProbs c $ GameState + { constraints = initConstraints (size c) (mines c) + , marked = S.empty + , alive = 1 + , currentSeed = seed + , constraintsProb = 1 + , revealResults = M.empty + , maxHiddenProb = undefined + , hiddenProbs = undefined + , noHiddenProbs = undefined + } + + +isFinished c g + = S.size (marked g) + M.size (revealResults g) == msize c + || alive g == 0 + +-- winning position (the timer may be stopped) +playerWins c g + = alive g > 0 && isFinished c g + +----------- + +msize c = xSize s * ySize s where s = size c + +mines_left c g + = mines c - S.size (marked g) + +information :: Configuration -> GameState -> Double +information c g + | all == 1 || s == 1 = 1 + | otherwise = 1 - logBase 2 (fromIntegral s) / logBase 2 (fromIntegral all) + where + all = numOfSolutions c + s = solutions $ constraints g + +{- +-- base 2 logarithm for large numbers +log2 :: (Ord a, Num a) => Int -> a -> Double +log2 prec n = f 0 1 1 1 n where + + f :: (Ord a, Num a) => Int -> Int -> a -> a -> a -> Double + f a b twoa twoam1 nb = case twoa `compare` nb of + LT -> f (a+1) b (2*twoa) twoa nb + GT | b < prec -> f (2*a-1) (2*b) (twoam1 * twoa) (twoam1 * twoam1) (nb*nb) + _ -> fromIntegral a / fromIntegral b +-} + +--allSquares +-- = squares . size . configuration + +luck :: GameState -> Double +luck = luckFunction . alive + +luckFunction :: Rational -> Double +luckFunction x + = max (- 1/2 * logBase 2 (realToFrac x)) 0 + + +-------------- other + +isMarked p g + = S.member p $ marked g + +isRevealed g p + = M.member p (revealResults g) + +revealResult g p + = M.lookup p (revealResults g) + +free g p + = not (isRevealed g p) && not (isMarked p g) + +probability p g + = M.lookup p $ hiddenProbs g + +maxHiddenProb_ = maxHiddenProb + +forgetChanges x + = x { marked = S.forget $ marked x + , revealResults = M.forget $ revealResults x + , hiddenProbs = M.forget $ hiddenProbs x + } + +---------------------------- + +toggleMark :: Square -> GameState -> GameState +toggleMark p g + = g { marked = (if S.member p $ marked g then S.delete else S.insert) p $ marked g } + +buildGameHint c 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 $ toList (squares $ size c) \\ M.keys (revealResults g) + +gameStep x c g + = step c x (constraints g) (currentSeed g) + + + diff --git a/Transition.hs b/Transition.hs --- a/Transition.hs +++ b/Transition.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PatternGuards #-} + module Transition ( buildTransition ) where @@ -16,7 +18,7 @@ buildTransition :: Eq e => (e -> Bool) -- event is initial - -> [(st -> Bool, e, st -> When)] -- trigger table + -> [(st -> Bool, st -> (e, When))] -- trigger table -> (e -> st -> Maybe st) -- transition -> (e -> st -> st -> r) -- response -> e -- event @@ -36,27 +38,30 @@ reactions e ost st - = [ (wh st, t) - | (p, t, wh) <- triggers + = [ (w, t) + | (p, tw) <- triggers , p st + , let (t, w) = tw st , e == t || isInit e || not (p ost) ] cancelled_ e ost st - = [ t - | (p, t, _) <- triggers + = [ t + | (p, tw) <- triggers , not (p st) , p ost + , let (t, _) = tw st , e /= t ] - +{- initReactions st - = [ (wh st, t) - | (p, t, wh) <- triggers + = [ (w, t) + | (p, tw) <- triggers , p st + , let (t, w) = tw st ] - +-} diff --git a/Transition/Action.hs b/Transition/Action.hs --- a/Transition/Action.hs +++ b/Transition/Action.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PatternGuards #-} + module Transition.Action ( triggers , triggers' @@ -8,20 +10,20 @@ import State import State.Functions -import Data.Maybe -import Data.List +--import Data.Maybe +--import Data.List ----------------------------- -triggers' = [(p, Triggered t, w) | (p, t, w) <- triggers] +triggers' = [(p, \st -> case tw st of (t, w) -> (Triggered t, w)) | (p, tw) <- triggers] -triggers :: [(State -> Bool, Triggered, State -> When)] +triggers :: [(State -> Bool, State -> (Triggered, 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) + [ (isActive, const (Tick, Later 1)) + , (interruptWillShown, const (InterruptVisible, Later 0.5)) + , (fade, const (FadeTick, Later 0.1)) + , (revealInProgress, const (BusyTick, Later 0.1)) + , (revealInProgress, \st -> let x = revResult st in (RevealDone x, AfterEval x)) ] @@ -29,7 +31,7 @@ | Just (False, _) <- interrupt st = True | otherwise = False -revealInProgress = isJust . revealing +revealInProgress = not . null . revealing fade = not . null . redness diff --git a/Transition/Graphics.hs b/Transition/Graphics.hs --- a/Transition/Graphics.hs +++ b/Transition/Graphics.hs @@ -1,27 +1,26 @@ +{-# LANGUAGE PatternGuards #-} + module Transition.Graphics where import State -import Configuration +--import Configuration +import Preferences +import Table 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 - ------------------------------------------------------------- squareState :: State -> Square -> SquareState squareState st p - | Just r <- revealing st + | (r:_) <- revealing st , p == revSquare r , Just i <- busyAnimation r = BusySign focused prelight i | Just h <- hint st - , Just max <- maxHiddenProb g - , Just x <- M.lookup p $ hiddenProbs g + , Just max <- maxHiddenProb_ g + , Just x <- probability p g , h == FullHint || x == max || x == 0 || marked' = (if marked' then HintedBomb else Hint) focused prelight x | marked' @@ -37,43 +36,21 @@ focused = p == focus st && focusMoves st prelight = maybe False (== p) (mouseFocus st) && mouseFocusShown st - revealed = M.lookup p $ revealResults g - marked' = S.member p $ marked g + revealed = revealResult g p + marked' = isMarked p g dangerousness = head $ [x | (q,x)<-redness st, q==p] ++ [0] - -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 "" +getInfo st + | cAndG playerWins st = InfoWin $ luck $ game st + | aliveness (game st) == 0 = InfoLoose True + | cAndG isFinished st = InfoLoose False + | otherwise = InfoPlay (cAndG mines_left st) (cAndG information st) (luck $ game st) -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 +getTimeInfo st + | Just t <- timer st = TimerAt t + | isNew st = TimerInit + | otherwise = TimerStopped diff --git a/Transition/Managed.hs b/Transition/Managed.hs --- a/Transition/Managed.hs +++ b/Transition/Managed.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PatternGuards #-} + module Transition.Managed ( initState , stopState @@ -22,10 +24,8 @@ import Data.List import Data.Maybe -import Control.Monad -import Data.Binary -import Data.DeriveTH -import Data.Derive.Binary +--import Control.Monad +import Data.Data --------------------------------------------------- main @@ -34,7 +34,7 @@ , changes :: Maybe (S.State, [Square]) -- Nothing: update needed , state :: S.State } - deriving (Show) + deriving (Show, Typeable, Data) ---------------- @@ -56,7 +56,7 @@ 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'] +triggers'' = [(p . state, tw . state) | (p, tw) <- triggers'] nextState' InfoDrawingDone _ @@ -67,12 +67,12 @@ nextState' UpdateTable st = Just $ st { changes = Nothing } - +---- ez kiszedni nextState' e@(PreferencesClosed (Just _)) st -- elég lenne csak a nagyon megváltozottra - = lift nextState e $ st { changes = Nothing } + = Just $ lift nextState e $ st { changes = Nothing } nextState' e st - = lift nextState e st + = Just $ lift nextState e st initDrawing st @@ -82,10 +82,9 @@ 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 + = ost { changes = fmap (mapSnd (changedSquares e (state ost) st ++)) $ changes ost, state = st } + where + st = f e $ state ost mapSnd f (a, b) = (a, f b) @@ -115,6 +114,4 @@ ++ responses' e ost st -- ++ buildTickResponse (==DrawingDone) [(drawing, drawSquares)] e ost st - -$( derive makeBinary ''State ) diff --git a/Transition/Response.hs b/Transition/Response.hs --- a/Transition/Response.hs +++ b/Transition/Response.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PatternGuards #-} + module Transition.Response ( buildContResponse , buildTickResponse @@ -8,6 +10,9 @@ import Core.Square import Event +import Configuration +import Preferences +import Table import State import State.Functions import Transition.Graphics @@ -15,8 +20,6 @@ import Data.Maybe import Data.SetClass (toList) import Data.List -import qualified Data.ChangeMap as M -import qualified Data.ChangeSet as S --------------------------------------------------- main @@ -29,8 +32,8 @@ ] contResponses = - [ ShowInfo . infoString - , ShowTime . timeString + [ ShowInfo . getInfo + , ShowTime . getTimeInfo ] buildTickResponse :: (e -> Bool) -> [(st -> Bool, st -> r)] -> e -> st -> st -> [r] @@ -42,7 +45,7 @@ ] tickResponses = - [ (prefInterrupt, PopUpPreferences . configuration) + [ (prefInterrupt, PopUpPreferences . preferences) , (scoreInterrupt, popUpNewScore) ] @@ -54,7 +57,7 @@ popUpNewScore st - = PopUpNewScore (configuration st) e l (sortOrder st) + = PopUpNewScore (preferences st) e l (sortOrder st) where l = currentScores st e | Just e <- scoreEntry st @@ -63,13 +66,16 @@ | otherwise = Nothing +allSquares + = squares . size . configuration . preferences + -------------------------------------------------------- changedSquares :: Event -> State -> State -> [Square] changedSquares e ost st = case e of - Triggered BusyTick -> maybeToList $ revSquare_ ost + Triggered BusyTick -> map revSquare $ take 1 $ revealing ost Triggered FadeTick -> map fst $ redness ost _ | hiddenTable st /= hiddenTable ost @@ -79,13 +85,10 @@ || size_ st /= size_ ost -> toList $ allSquares st - _ -> concat -- nub lesz később + _ -> concat -- nub not necessary [ catMaybes $ diff [mouseFocus ost, mouseFocus st] , diff [focus ost, focus st] - , S.changes (marked g) - , M.changes (revealResults g) - , M.changes (hiddenProbs g) - ] + ] ++ allChanges g where g = game st diff --git a/Transition/State.hs b/Transition/State.hs --- a/Transition/State.hs +++ b/Transition/State.hs @@ -1,282 +1,232 @@ +{-# LANGUAGE PatternGuards #-} + module Transition.State ( nextState ) where import Configuration +import Preferences +import Table import Event import State import State.Functions import Step import Core.Square -import Core.Constraints import Data.Maybe import Data.SetClass (toList) 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 +dispatchEvent :: Event -> State -> State +dispatchEvent e st = ($ st) $ case e of + MouseMotion m -> moveMouseFocus m + UpEvent | focusMoves st -> moveFocus (0, -1) + DownEvent | focusMoves st -> moveFocus (0, 1) + LeftEvent | focusMoves st -> moveFocus (-1, 0) + RightEvent | focusMoves st -> moveFocus (1, 0) + HintEvent | revealCanBeDone st -> hintEvent + FullHintEvent | revealCanBeDone st -> fullHintEvent + NewEvent -> newGame + UndoEvent | noInterrupt st && not (null $ undo st) -> undoEvent + RedoEvent | revealCanBeDone st && not (null $ redo st) -> redoEvent + MarkEvent m | markCanBeDone st -> markEvent m + RevealEvent m | revealCanBeDone st -> revealEvent m + FocusOut | noInterrupt st -> setInterrupt OtherApp + OpenPreferences | noInterrupt st -> setInterrupt ModifyPreferences + ShowScores | noInterrupt st -> setInterrupt ViewScore + FocusIn m | noInterrupt st -> moveMouseFocus m + FocusIn m | checkInterrupt OtherApp st -> clearInterrupt . moveMouseFocus m + PreferencesClosed m | checkInterrupt ModifyPreferences st -> clearInterrupt . preferencesClosed m + NewScoreClosed m a | checkInterrupt ViewScore st -> clearInterrupt . newScoreClosed m a Triggered t -> dispatchTrigger t - _ -> error $ "dispatchEvent: " ++ show e + _ -> id 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 + RevealDone res -> revealDone res ------------------------------------ Ticks tick st - | Just t <- timer st - = Just - $ st { timer = Just $ t+1 } - | otherwise = Nothing + = st { timer = fmap (+1) $ timer st } busyTick st - | Just rev <- revealing st - = Just - $ st { revealing = Just $ rev { busyAnimation = Just $ maybe 0 (+1) $ busyAnimation rev }} - | otherwise = Nothing + = st { revealing = mapHead f $ revealing st } where + f rev = rev { busyAnimation = Just $ maybe 0 (+1) $ busyAnimation rev } fadeTick st - = Just - $ st { redness = [(s, p') | (s, p) <- redness st, let p' = p-1, p'>0] } - ------------------------------------- Focus in/out + = st { redness = [(s, p') | (s, p) <- redness st, let p' = p-1, p'>0] } -focusIn m st - | Just (_, OtherApp) <- interrupt st - = Just - $ st { interrupt = Nothing - , mouseFocus = calcFocus m st - } - | otherwise - = Just - $ st { mouseFocus = calcFocus m st - } +mapHead f (x:xs) = f x: xs +mapHead _ [] = [] -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 +interruptVisible st + = st { interrupt = fmap (\(False, x) -> (True, x)) $ interrupt st } ------------------------------------ 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 +moveMouseFocus m st + = st { mouseFocus = fmap (calcSquare st) m } -moveFocus_ d st - | Just f <- moveFocus d st - = Just - $ st { focus = f } - | otherwise = Nothing +moveFocus (dx, dy) st + = st { focus = maybe (focus st) id $ square (size $ configuration $ preferences st) (x+dx) (y+dy) } + where + (x, y) = coords $ focus st -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 +hintEvent st + = buildHint + . stopTimerIf (isNothing $ hintAllowed $ preferences st) + $ st { hint = if hint st /= Just NormalHint then Just NormalHint else Nothing + } -newEvent st - | not $ isNew st - = Just $ new st - | otherwise = Nothing +fullHintEvent st + = buildHint + . stopTimerIf (hintAllowed (preferences st) /= Just FullHint) + $ st { hint = if hint st /= Just FullHint then Just FullHint else 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 + = stopTimerIf (not $ undoAllowed $ preferences $ st) + . makeUndo + . stopRevealing + $ st +stopRevealing st = st { revealing = [] } + +makeUndo st + | (Mark s: ss) <- undo st + = st { undo = ss + , redo = Mark s: redo st + , game = toggleMark s (game st) + } + | otherwise + = st { undo = u + , redo = r + , game = g + } + where + (r, u, g) = undoEvents (redo st) (undo st) (game $ loadState st) + +undoEvents r [] g = (r, [], g) +undoEvents r (Reveal s: es) g = undoEvents (Reveal s: r) es g +undoEvents r (Mark s: es) g = undoEvents (Mark s: r) es g +undoEvents r (CachedState g: es) _ = (CachedState (): r, es, g) + redoEvent st - | revealCanBeDone st - , (s: ss) <- redo st - = Just - . makeStep s - $ st { redo = ss } - | otherwise = Nothing + | (Mark s: ss) <- redo st + = markEv s + $ st { redo = ss } + | (CachedState _: ss) <- redo st + , (x, y) <- span isReveal ss + = revEv False [s | Reveal s <- x] + $ st { redo = y } + | ss <- redo st + , (x, y) <- span isReveal ss + = revEv False [s | Reveal s <- x] + $ st { redo = y } ------------------------------------ Mark markEvent m st - | markCanBeDone st - , p <- eventPos st m - , M.notMember p $ revealResults $ game st - = Just - . mb addScore + | p <- eventPos st m + , not (isRevealed (game st) p) + = mb addScore . markEv p . startTimerIfNew $ st { redo = takeWhile (compatible p) $ filter (/= Mark p) $ redo st } - | otherwise = Nothing + | otherwise = st where - compatible p (Reveal _ ps) = p `notElem` ps + compatible p (Reveal q) = p /= q compatible _ _ = True ------------------------------------ Reveal revealEvent m st - | revealCanBeDone st - , p <- eventPos st m + | p <- eventPos st m , (p: ps) <- revTarget p st - = Just - . revEv (recursiveReveal $ configuration st) (p: ps) + = revEv (recursiveReveal $ preferences st) (p: ps) . startTimerIfNew . degradeHint $ st { redo = [] } - | otherwise = Nothing + | otherwise = st +revTarget p st + | free (game st) p + = [p] + | Just (Just n) <- revealResult (game st) p + , ng <- toList $ neighbours (size_ st) p + , n == length [x | x <- ng, isMarked x $ game st ] + = ng + | otherwise + = [] ------------------------------------- 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 +--------------------------- + +setInterrupt i st = st { interrupt = Just (False, i) } + +clearInterrupt st = st { interrupt = Nothing } + +noInterrupt = isNothing . interrupt + +checkInterrupt i st + | Just (_, j) <- interrupt st + = i == j +checkInterrupt _ _ + = False + + +------------------------------------ Preferences + +preferencesClosed Nothing st = st 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 + | c == preferences st + = st + | {- tableConfig ( -} configuration c == configuration (preferences st) + = stopTimerIf True + $ st { preferences = c } - | Just (_, ModifyPreferences) <- interrupt st - = Just - . new - $ st { interrupt = Nothing - , configuration = c - , undo = [] - , redo = [] - , focus = restrictSquare (size c) $ focus st + | otherwise + = newGame + $ st { preferences = c +-- , undo = [] +-- , redo = [] + , focus = restrictSquare (size $ configuration 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 + | Just e <- scoreEntry st + = st + { sortOrder = attr , userName = n - , scores = MM.adjust (\l -> e { se_name = n }: delete e l) (configuration st) (scores st) + , scores = MM.adjust (\l -> e { se_name = n }: delete e l) (preferences st) (scores st) } -newScoreClosed _ attr st - | Just (_, ViewScore) <- interrupt st - = Just - $ st { interrupt = Nothing, sortOrder = attr } - | otherwise = Nothing +newScoreClosed Nothing attr st + = st { sortOrder = attr } @@ -285,142 +235,107 @@ mb :: (a -> Maybe a) -> (a -> a) mb f x = maybe x id (f x) - -new st +newGame st = buildHint . loadState + . stopRevealing $ st { undo = [] - , redo = reverse (map snd $ undo st) ++ redo st + , redo = [] -- reverse (map (fmap (const ())) $ undo st) ++ redo st , redness = [] , timer = Nothing - , revealing = Nothing , hint = Nothing --- , interrupt = Nothing -- ??? + , initialSeed = gameSeed (game st) } ----------------------------------------------------- Hint buildHint st | isJust (hint st) - , M.null (hiddenProbs $ game st) - , isNothing (revealing st){- !!! -} - = st { game = f (game st) } +-- , M.null (hiddenProbs $ game st) + , null (revealing st){- !!! -} + = st { game = cAndG buildGameHint 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 $ toList (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 } +notMark p (Mark q) = p /= q +notMark _ _ = True +markEv :: Square -> TrState +markEv p st = appGame (toggleMark p) $ mm p st +appGame f st = st { game = f (game st) } -markEv :: Square -> TrState -markEv p st - | S.member p $ marked g +mm p st + | isMarked p g = st - { game = f g - , undo = [(f g, s) | (g, s) <- undo st, s /= Mark p] + { undo = map (fmap $ toggleMark p) ua ++ ub } - | 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 + | (q:_) <- revealing st + , p == revSquare q + , Just (_, u) <- find' isReveal $ undo st + = stopRevealing st + { undo = Mark p: u } | otherwise = st - { game = g { marked = S.insert p $ marked g } - , undo = (g, Mark p): undo st + { undo = Mark p: undo st } where + (ua, _: ub) = span (notMark p) (undo st) + 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 <- toList $ neighbours (size_ st) p - , n == length [x | x <- ng, S.member x $ marked $ game st ] - = filter (free $ game st) ng -revTarget _ _ - = [] + $ st { undo = CachedState (game st): undo st } -revAction _ [] st - = st { revealing = Nothing } -revAction r (x: xs) st +revAction r xs st = st - { revealing = Just $ Revealing + { revealing = dropWhile (not . free (game st) . revSquare) + $ map buildRev xs ++ revealing st + } + where + buildRev x = 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 + +revealDone rr st + = 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 + . revAction (recursive rev) neigh + $ st { game = appRevResult (configuration $ preferences st) fo rr (game st) + , redness = [(fo, re) | re/= 0] ++ filter ((/=fo) . fst) (redness st) + , undo = Reveal fo: undo st + , revealing = revs } where - Just rev = revealing st - - (Just (RevealResult al mi cs seed)) = revResult rev + (rev: revs) = revealing st 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_ - } + re = round $ 100 * (1 - safety rr) :: Int neigh - | Just 0 <- mi - , recursive rev - = [p | p<- toList $ neighbours (size_ st) fo, free g p, p `notElem` recRevealing rev] + | recursive rev + , Just 0 <- squareState rr + = toList $ neighbours (size_ st) fo | otherwise = [] -isReveal (Reveal _ _) = True +isReveal (Reveal _) = True isReveal _ = False find' _ [] = Nothing @@ -430,32 +345,14 @@ 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 - +stopTimerIf True st = st { timer = Nothing } +stopTimerIf False st = st diff --git a/When.hs b/When.hs --- a/When.hs +++ b/When.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ExistentialQuantification #-} + module When ( Timed , When (Now, At, Later, AfterEval) diff --git a/minesweeper.cabal b/minesweeper.cabal --- a/minesweeper.cabal +++ b/minesweeper.cabal @@ -1,9 +1,9 @@ name: minesweeper -version: 0.8.9 +version: 0.9 category: Game synopsis: Minesweeper game which is always solvable without guessing -description: - Minesweeper game which is always solvable without guessing. +description: + Minesweeper game which is always solvable without guessing. stability: alpha license: BSD3 license-file: LICENSE @@ -19,9 +19,8 @@ Default: False executable minesweeper - extensions: + extensions: NoMonomorphismRestriction, --- NoNPlusKPatterns, EmptyDataDecls, ScopedTypeVariables, ExistentialQuantification, @@ -32,21 +31,24 @@ PatternGuards, ViewPatterns, FlexibleContexts, - TemplateHaskell, + DeriveDataTypeable, CPP build-depends: - base >= 3.0 && < 5.0, - containers, - time, - random, - directory, - filepath, - binary, - derive, - gtk >= 0.10, - cairo >= 0.10, - glade >= 0.10 + base >= 3 && < 5, + containers >= 0.3 && < 0.4, + time >= 1.2 && < 1.3, + random >= 1.0 && < 1.1, + -- mersenne-random-pure64 == 0.2.*, + directory >= 1.0 && < 1.1, + filepath >= 1.1 && < 1.2, + binary >= 0.5 && < 0.6, + binary-generic >= 0.2 && < 0.3, + bytestring >= 0.9 && < 0.10, + -- derive , + gtk >= 0.11 && < 0.12, + cairo >= 0.11 && < 0.12, + glade >= 0.11 && < 0.12 if flag(tests) build-depends: @@ -55,25 +57,34 @@ CPP-Options: -DTEST - main-is: + main-is: Minesweeper.hs - other-modules: + other-modules: + Data.ChangeMap, Data.ChangeSet, Data.SetClass, - System.Random.Instances, + Data.Domain, - Core.Square, Core.SetContainer, Core.Constraint, - Core.BitField, Core.Constraints, - Configuration, + Core.Square, + Core.SquareConstraints, + + Configuration, + Random, Step, - Scores, +-- with marks + Table, + + Preferences, +-- with undo / redo +-- Game, + State, State.Functions, diff --git a/ms.glade b/ms.glade --- a/ms.glade +++ b/ms.glade @@ -570,7 +570,7 @@ True True ● - 1 0 1 0.01 0.10000000000000001 0 + 1 0 1 0.01 0.1 0 2 @@ -591,7 +591,7 @@ True True ● - 1 0 1 0.01 0.10000000000000001 0 + 1 0 1 0.01 0.1 0 2 @@ -611,7 +611,7 @@ True True ● - 1 1 10000 1 10 10 + 1 1 10000 1 10 0 1 diff --git a/runInGHCi b/runInGHCi --- a/runInGHCi +++ b/runInGHCi @@ -1,4 +1,4 @@ !#/bin/sh -ghci -XNoMonomorphismRestriction -XNoNPlusKPatterns -XEmptyDataDecls -XScopedTypeVariables -XExistentialQuantification -XRank2Types -XMultiParamTypeClasses -XTypeFamilies -XNamedFieldPuns -XPatternGuards -XViewPatterns -XFlexibleContexts -XTemplateHaskell -XCPP $@ +ghci -Wall -fno-warn-incomplete-patterns -fno-warn-name-shadowing -fno-warn-missing-signatures -idist/build/autogen -XNoMonomorphismRestriction -XNoNPlusKPatterns -XEmptyDataDecls -XScopedTypeVariables -XExistentialQuantification -XRank2Types -XMultiParamTypeClasses -XTypeFamilies -XNamedFieldPuns -XPatternGuards -XViewPatterns -XFlexibleContexts -XDeriveDataTypeable -XCPP $@