packages feed

minesweeper 0.4.1 → 0.8.8

raw patch · 42 files changed

+4263/−1618 lines, 42 filesdep +binarydep +derivedep +directorydep ~basesetup-changed

Dependencies added: binary, derive, directory, filepath, lazysmallcheck, numeric-prelude

Dependency ranges changed: base

Files

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