minesweeper 0.8.9 → 0.9
raw patch · 37 files changed
+1242/−1102 lines, 37 filesdep +binary-genericdep +bytestringdep −derivedep ~basedep ~binarydep ~cairo
Dependencies added: binary-generic, bytestring
Dependencies removed: derive
Dependency ranges changed: base, binary, cairo, containers, directory, filepath, glade, gtk, random, time
Files
- Configuration.hs +59/−39
- Core/BitField.lhs +0/−96
- Core/Constraint.lhs +15/−59
- Core/Constraints.lhs +136/−44
- Core/SetContainer.lhs +21/−33
- Core/Square.hs +62/−49
- Core/SquareConstraints.lhs +64/−0
- Data/ChangeMap.hs +5/−26
- Data/ChangeSet.hs +16/−22
- Data/Domain.hs +16/−0
- Data/SetClass.lhs +5/−5
- Driver.hs +0/−1
- Driver/Log.hs +2/−0
- Event.hs +62/−15
- GTK.hs +23/−23
- GTK/Preferences.hs +25/−28
- GTK/Score.hs +9/−7
- Log.hs +3/−3
- Minesweeper.hs +49/−20
- Preferences.hs +47/−0
- Random.hs +50/−0
- Scores.hs +0/−22
- State.hs +46/−65
- State/Functions.hs +44/−95
- Step.hs +15/−25
- System/Random/Instances.hs +0/−19
- Table.hs +168/−0
- Transition.hs +14/−9
- Transition/Action.hs +12/−10
- Transition/Graphics.hs +19/−42
- Transition/Managed.hs +12/−15
- Transition/Response.hs +15/−12
- Transition/State.hs +187/−290
- When.hs +2/−0
- minesweeper.cabal +35/−24
- ms.glade +3/−3
- runInGHCi +1/−1
Configuration.hs view
@@ -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<b esetén életben maradunk- - , allowedDeaths :: Int- , recursiveReveal :: Bool-- , undoAllowed :: Bool- , hintAllowed :: Maybe HintType }- deriving (Eq, Ord, Show)+ deriving (Eq, Ord, Show, Typeable, Data) data Strategy = Random | HighestProb- deriving (Eq, Ord, Show, Enum)--data HintType- = NormalHint - | FullHint- deriving (Eq, Ord, Show, Enum)+ deriving (Eq, Ord, Show, Enum, Typeable, Data) type Probability = Rational@@ -64,16 +59,41 @@ --------------------------------- numOfSolutions :: Configuration -> 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<b esetén életben maradunk+
− Core/BitField.lhs
@@ -1,96 +0,0 @@--> {-# 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)---
Core/Constraint.lhs view
@@ -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
Core/Constraints.lhs view
@@ -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 ]
Core/SetContainer.lhs view
@@ -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)]
Core/Square.hs view
@@ -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) ]
+ Core/SquareConstraints.lhs view
@@ -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) (:)++
Data/ChangeMap.hs view
@@ -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--
Data/ChangeSet.hs view
@@ -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 )
+ Data/Domain.hs view
@@ -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+
Data/SetClass.lhs view
@@ -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)
Driver.hs view
@@ -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()
Driver/Log.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE PatternGuards #-}+ module Driver.Log ( Result (..) , Transition
Event.hs view
@@ -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
GTK.hs view
@@ -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
GTK/Preferences.hs view
@@ -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 } _ ->
GTK/Score.hs view
@@ -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
Log.hs view
@@ -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
Minesweeper.hs view
@@ -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
+ Preferences.hs view
@@ -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+-}+
+ Random.hs view
@@ -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 (<y) sis++ (x, r'') + | head sis == sl = (0, r)+ | otherwise = (j, r')+++++
− Scores.hs
@@ -1,22 +0,0 @@-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)--
State.hs view
@@ -1,50 +1,41 @@-{-# LANGUAGE TemplateHaskell #-}- module State where -import Configuration+import Configuration (Probability)+import Preferences import Core.Square-import Core.Constraints-import Step+import Table -import Data.ChangeMap-import Data.ChangeSet-import Control.Monad+import Random+import qualified Data.Map as MM+import Data.Data+ import Data.Binary-import Data.DeriveTH-import Data.Derive.Binary-import System.Random-import System.Random.Instances-import qualified Data.Map+import Data.Binary.Generic ------------------------------- --- 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+-- game state+data State = State+ { preferences :: Preferences -- scores state- , scores :: Data.Map.Map Configuration [ScoreEntry] -- normál map+ , userName :: String+ , scores :: MM.Map Preferences{-x-} [ScoreEntry] , sortOrder :: [ScoreAttr] + -- game+ , initialSeed :: RandomSeed+ , undo :: [Step]+ , redo :: [CompressedStep]+ , game :: GameState -- cached+ -- status- , hint :: Maybe HintType , timer :: Maybe Int+ , hint :: Maybe HintType - -- state- , revealing :: Maybe Revealing+ -- volatile state+ , revealing :: [Revealing] -- , hinting :: Maybe Hinting , interrupt :: Maybe (Bool, Interrupt) -- visible @@ -54,7 +45,7 @@ , redness :: [(Square, Int)] -- 0-100 }- deriving (Show)+ deriving (Show, Typeable, Data) ------------------------------@@ -62,17 +53,15 @@ data Revealing = Revealing { recursive :: Bool , revSquare :: Square- , revResult :: Maybe RevealResult -- maybe for easier saving -- keep lazy!- , recRevealing :: [Square] , busyAnimation :: Maybe Int }- deriving (Show)+ deriving (Show, Typeable, Data) data Hinting = Hinting { hintResult :: Maybe Int , hintAnimation :: Maybe Int }- deriving (Show)+ deriving (Show, Typeable, Data) ---------------------------- @@ -81,54 +70,46 @@ , se_time :: Int , se_alive :: Probability , se_deaths :: Int- , se_history :: [Step]+ , se_history :: [CompressedStep] }- deriving (Eq, Ord, Show)+ deriving (Eq, Ord, Show, Typeable, Data) +instance Binary ScoreEntry where+ put = putGeneric+ get = getGeneric+ 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)+ deriving (Eq, Ord, Show, Enum, Typeable, Data) ------------------------------ -data Step - = Reveal StdGen [Square]+data GenStep a+ = Reveal Square | Mark Square- deriving (Eq, Ord, Show)+ | CachedState a+ deriving (Eq, Ord, Show, Typeable, Data) +type Step = GenStep GameState -- cached gamestate before the step++type CompressedStep = GenStep ()++instance Functor GenStep where+ fmap f (CachedState a) = CachedState (f a)+ fmap _ (Mark s) = Mark s+ fmap _ (Reveal s) = Reveal s+ --------------------------- data Interrupt = ModifyPreferences | ViewScore | OtherApp- deriving (Eq, Show)+ deriving (Eq, Show, Typeable, Data) ---------------------- -$( derive makeBinary ''Interrupt )-$( derive makeBinary ''Revealing )-$( derive makeBinary ''ScoreAttr )-$( derive makeBinary ''ScoreEntry )-$( derive makeBinary ''Step )-$( derive makeBinary ''GameState )-$( derive makeBinary ''State )
State/Functions.hs view
@@ -3,53 +3,36 @@ module State.Functions where import Configuration+import Preferences import State import Core.Square-import Core.Constraints+--import Core.SquareConstraints+import Table import Data.Maybe-import Data.SetClass (toList)+--import Data.SetClass (toList) import Control.Monad-import System.Random +import Random import Data.List import Data.Function-import qualified Data.ChangeMap as M+--import qualified Data.ChangeMap as M import qualified Data.Map as MM-import qualified Data.ChangeSet as S+--import qualified Data.ChangeSet as S --------------------------------------------- -resetHiddenProbs c gs = gs- { maxHiddenProb = Nothing- , hiddenProbs = M.empty- , noHiddenProbs = toList (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 :: 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<b esetén életben maradunk-+-} {- , c_allowedDeaths :: Int , c_recursiveReveal :: Bool@@ -250,13 +199,13 @@ scoreEntry :: State -> 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 }-+-}
Step.hs view
@@ -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 (<x) $ scanl1 (+) l
− System/Random/Instances.hs
@@ -1,19 +0,0 @@--- missing StdGen instances-module System.Random.Instances where--import System.Random-import Data.Binary-----------------------------------instance Eq StdGen where - _ == _ = True -- error "Eq StdGen instance not defined"--instance Ord StdGen where - _ < _ = error "Ord StdGen instance not defined"--instance Binary StdGen where- put = put . show- get = fmap read get--
+ Table.hs view
@@ -0,0 +1,168 @@+module Table + ( GameState+ , aliveness+ , appRevResult+ , initGameState+ , isFinished, playerWins+ , msize, mines_left, information+ , luck, luckFunction, free, isMarked, isRevealed, revealResult+ , probability, maxHiddenProb_, gameSeed+ , toggleMark+ , forgetChanges + , buildGameHint+ , gameStep+ , allChanges+ ) where++import Configuration+import Core.Square+import Core.SquareConstraints+import Step++import qualified Data.ChangeMap as M+import qualified Data.ChangeSet as S+import Data.SetClass (toList)+import Data.List+import Random+import Data.Data++----------------------------------------------------------------------++aliveness = alive+gameSeed = currentSeed++allChanges g = S.changes (marked g)+ ++ M.changes (revealResults g)+ ++ M.changes (hiddenProbs g)+++data GameState = GameState+ { constraints :: SquareConstraints+ , marked :: S.Set Square+ , revealResults :: M.Map Square (Maybe Int) -- partially cached (a set of squares would be enough) + -- cached+ , constraintsProb :: Probability -- information+ , maxHiddenProb :: Maybe Int -- 0-100+ , hiddenProbs :: M.Map Square Int -- 0-100+ , noHiddenProbs :: [Square] -- empty squares to be hinted+ -- other info+ , alive :: Probability+ , currentSeed :: RandomSeed+ }+ deriving (Show, Typeable, Data)++appRevResult c s rr g = resetHiddenProbs c $ g + { constraints = rrConstraints rr+ , revealResults = M.insert s (squareState rr) $ revealResults g+ , alive = safety rr * alive g + , currentSeed = rrSeed rr+ }+++resetHiddenProbs c gs = gs+ { maxHiddenProb = Nothing+ , hiddenProbs = M.empty+ , noHiddenProbs = toList (squares (size c)) \\ M.keys (revealResults gs)+ }++initGameState :: Configuration -> 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)+++
Transition.hs view
@@ -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 ]-+-}
Transition/Action.hs view
@@ -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
Transition/Graphics.hs view
@@ -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
Transition/Managed.hs view
@@ -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 )
Transition/Response.hs view
@@ -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
Transition/State.hs view
@@ -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
When.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ExistentialQuantification #-}+ module When ( Timed , When (Now, At, Later, AfterEval)
minesweeper.cabal view
@@ -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,
ms.glade view
@@ -570,7 +570,7 @@ <property name="visible">True</property> <property name="can_focus">True</property> <property name="invisible_char">●</property>- <property name="adjustment">1 0 1 0.01 0.10000000000000001 0</property>+ <property name="adjustment">1 0 1 0.01 0.1 0</property> <property name="digits">2</property> </widget> <packing>@@ -591,7 +591,7 @@ <property name="visible">True</property> <property name="can_focus">True</property> <property name="invisible_char">●</property>- <property name="adjustment">1 0 1 0.01 0.10000000000000001 0</property>+ <property name="adjustment">1 0 1 0.01 0.1 0</property> <property name="digits">2</property> </widget> <packing>@@ -611,7 +611,7 @@ <property name="visible">True</property> <property name="can_focus">True</property> <property name="invisible_char">●</property>- <property name="adjustment">1 1 10000 1 10 10</property>+ <property name="adjustment">1 1 10000 1 10 0</property> </widget> <packing> <property name="left_attach">1</property>
runInGHCi view
@@ -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 $@