diff --git a/Core.hs b/Core.hs new file mode 100644 --- /dev/null +++ b/Core.hs @@ -0,0 +1,247 @@ +-- | Core data types and functions for the game. +module Core + ( MMap + , emptyMMap + , setSum + , solutions' + ) where + +------------------------------------------- + +import Place +import PlaceSet +import qualified PlaceMap as M + +import Data.Function +import Data.Maybe +import Data.List hiding ((\\), insert, delete) +import qualified Data.List as List + + +------------------------------------------- + +data Constraint + = Constraint + { places_ :: PlaceSet + , value :: Int + } + + deriving Eq + +data ConstraintView + = BigConstraint PlaceSet Int + | SmallConstraint PlaceSet Int + | Clear Place + | Mine Place + +view :: Constraint -> ConstraintView +view (Constraint ps v) + | size ps == 1 && v == 1 = Mine $ head $ placeSetToList ps + | size ps == 1 && v == 0 = Clear $ head $ placeSetToList ps + | size ps > big = BigConstraint ps v + | otherwise = SmallConstraint ps v + +big :: Int +big = 10 + + +--------------------------------------- + +constraint :: [Place] -> Int -> Constraint +constraint ps v + = Constraint (listToPlaceSet ps) v + +subConstraint :: Constraint -> Constraint -> Bool +subConstraint a b = places_ a `isSubsetOf` places_ b + +similarConstraint :: Constraint -> Constraint -> Bool +similarConstraint a b = places_ a == places_ b + + +-- csak akkor, ha subConstraint! +(.-.) :: Constraint -> Constraint -> Constraint +Constraint ps v .-. Constraint ps' v' = Constraint (ps \\ ps') (v-v') + +connectionStrength :: Constraint -> Constraint -> [Constraint] +connectionStrength (Constraint ps v) (Constraint ps' v') = [Constraint l i | i<-[min_ .. max_]] where + + min_ = maximum [0, v - (size ps - m), v' - (size ps' - m)] + max_ = minimum [m, v, v'] + + m = size l + l = intersection ps ps' + +constraintSolutions :: Constraint -> Integer +constraintSolutions (Constraint ps v) = binom (size ps) v + + +binom :: Int -> Int -> Integer +binom m n = binoms !! m !! min n (m-n) + +binoms :: [[Integer]] +binoms = iterate f [1] where f l = zipWith (+) (l++[0]) ([0]++l) + + +------------------------------------------- + + +data Constraints + = Unsolvable + | Solvable + [Constraint] -- big constraints (usually one) + PlaceSet -- cleared places + PlaceSet -- places with mines + (M.PlaceMap [Constraint]) -- other constraints + +--------------------------------------- + +addConstraintSimple :: Constraint -> Constraints -> Constraints +addConstraintSimple _ Unsolvable = Unsolvable +addConstraintSimple c (Solvable bc cl mi m) = case view c of + Clear p -> Solvable bc (insert p cl) mi m + Mine p -> Solvable bc cl (insert p mi) m + BigConstraint _ _ -> Solvable (c:bc) cl mi m + SmallConstraint ps _-> Solvable bc cl mi $ foldr f m $ placeSetToList ps + where + + f p m' = case M.lookup p m' of + Nothing -> M.insert p [c] m' + Just cs -> M.insert p (c:cs) m' + +deleteConstraint :: Constraint -> Constraints -> Constraints +deleteConstraint _ Unsolvable = Unsolvable +deleteConstraint c (Solvable bc cl mi m) = case view c of + Clear p -> Solvable bc (delete p cl) mi m + Mine p -> Solvable bc cl (delete p mi) m + BigConstraint _ _ -> Solvable (deleteBy similarConstraint c bc) cl mi m + SmallConstraint ps _-> Solvable bc cl mi $ foldr f m $ placeSetToList ps + where + + f p m' = case M.lookup p m' of + Just cs -> case deleteBy similarConstraint c cs of + [] -> M.delete p m' + l -> M.insert p l m' + +deleteConstraints :: [Constraint] -> Constraints -> Constraints +deleteConstraints cs m = foldr deleteConstraint m cs + +dependentConstraints :: Constraint -> Constraints -> [Constraint] +dependentConstraints c@(Constraint ps _) (Solvable bc cl mi m) + = List.delete c $ l ++ filter (not . disjunct ps . places_) bc + where + l = map toClear (placeSetToList $ intersection cl ps) + ++ map toMine (placeSetToList $ intersection mi ps) + ++ nub (concatMap f $ placeSetToList ps) + + toClear p = constraint [p] 0 + toMine p = constraint [p] 1 + + f p = case M.lookup p m of + Just cs -> cs + Nothing -> [] + +--------------------------------------- + +-- calculate number of different solutions +solutions :: Constraints -> Integer +solutions Unsolvable = 0 +solutions (Solvable bc _ _ cs) = product (map (constraintSolutions . fst) indep) * case dep of + [] -> 1 + ((c, xs): _) -> let + cs' = minimumBy (compare `on` length) $ map (connectionStrength c) xs + in sum [solutions (addConstraint y s'') | y<-cs'] + where + s' = Solvable bc empty empty cs + s'' = deleteConstraints (map fst indep) s' + + (indep, dep) = partition (null . snd) $ map (`dependentConstraints_` s') $ nub (concatMap snd $ M.toList cs) ++ bc + +dependentConstraints_ c cs = (c, dependentConstraints c cs) + +solvable :: Constraints -> Bool +solvable Unsolvable = False +solvable (Solvable bc _ _ cs) = case concatMap snd (M.toList cs) ++ bc of + [] -> True + (c: _) -> case dependentConstraints c s' of + [] -> solvable (deleteConstraint c s') + (x:_) -> let + cs' = connectionStrength c x + in or [solvable (addConstraint y s') | y<-cs'] + where + s' = Solvable bc empty empty cs + +-- may be faster? +omittable :: Constraint -> Constraints -> Bool +omittable c@(Constraint ps v) cs = all (not . solvable) [addConstraint (Constraint ps i) cs | i <- [v-1,v-2..0] ++ [v+1..size ps]] +{- + - if p1 + ... + pI = n has no solution except for n = n0, then p1 + ... + pI = n0 is not needed: + pA + pB = 1, pB + pC = 1, pC + pD = 1, pD + pA = 1 + --> pA + pB = 1, pB + pC = 1, pC + pD = 1 + - ... +-} + +--------------------------------------- + +addConstraintSmart :: Constraint -> Constraints -> Constraints +addConstraintSmart c cs + | not (solvable cs') = Unsolvable +-- | omittable c cs = cs -- not really needed + | otherwise = cs' + where + cs' = addConstraint c cs + + +addConstraint :: Constraint -> Constraints -> Constraints +addConstraint _ Unsolvable = Unsolvable +addConstraint n@(Constraint ps v) c + | v<0 || v>s = Unsolvable + | s==0 = c + | s>1 && v==0 = addConstraints [constraint [p] 0 | p<- placeSetToList ps] c + | s>1 && v==s = addConstraints [constraint [p] 1 | p<- placeSetToList ps] c + | any ((/= v) . value) similar = Unsolvable + | not (null similar) = c + | any (==0) str = Unsolvable + | ((x, [y]): _) <- oneStrength + = addConstraints [n .-. y, x .-. y, y] $ deleteConstraint x c + | otherwise = addConstraints [x .-. n | x <- supDomains] $ addConstraintSimple n $ deleteConstraints supDomains c + where + s = size ps + + supDomains = [x | x <- dep, n `subConstraint` x] + + oneStrength = filter ((==1) . length . snd) strength + str = map (length . snd) strength + + strength = [(x, connectionStrength n x) | x <- dep, x `subConstraint` n] + + (similar, dep) = partition (similarConstraint n) $ dependentConstraints n c + + +addConstraints :: [Constraint] -> Constraints -> Constraints +addConstraints l c = foldr addConstraint c l + + + +----------------------------------------------- + +data MMap = MMap Constraints Integer + +emptyMMap :: MMap +emptyMMap = mkMMap $ Solvable [] empty empty M.empty + +mkMMap :: Constraints -> MMap +mkMMap c = MMap (if s==0 then Unsolvable else c) s + where + s = solutions c + +solutions' :: MMap -> Integer +solutions' (MMap _ i) = i + +setSum :: PlaceSet -> Int -> MMap -> MMap +setSum ps v (MMap c _) = mkMMap $ addConstraint (Constraint ps v) c + +--------------------------------------- + + + + diff --git a/Delay.hs b/Delay.hs new file mode 100644 --- /dev/null +++ b/Delay.hs @@ -0,0 +1,35 @@ +module Delay + ( doLater + , cancelAction + , newCancelVar + , CancelVar + ) where + +import Control.Concurrent +import Control.Concurrent.MVar + +-------------------- + +newtype CancelVar = C (MVar (Maybe ThreadId)) + +newCancelVar :: IO CancelVar +newCancelVar = fmap C $ newMVar Nothing + +cancelAction :: CancelVar -> IO () +cancelAction (C v) = do + swapMVar v Nothing + return () + +doLater :: RealFrac t => CancelVar -> t -> IO () -> IO () +doLater (C v) t action = do + tid <- forkIO $ do + threadDelay $ round $ 1000000 * t + mytid <- myThreadId + b <- readMVar v + case b of + Just tid | tid == mytid -> action + _ -> return () + swapMVar v (Just tid) + return () + + diff --git a/Game.hs b/Game.hs new file mode 100644 --- /dev/null +++ b/Game.hs @@ -0,0 +1,253 @@ + +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 (> 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) (setTableSt asp $ \s -> if s == Fixed then s else Stopped) + return False + + onFocusIn window $ \_ -> do + when' (fmap not $ isActiveTimer tim) $ do + cancelAction hideTableVar + setTableSt asp $ \s -> if s == Fixed then s else Normal Nothing + 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 + + 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 + + _ -> + putMVar (gstate pst) al + + widgetDestroy a + return () + + + +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 + + _ -> return x + +smartUndo g' (gs, redo) = (g': drop x gs, if x==1 then redo else []) + where + x = deservesUndo g' gs + + +-------------------------- + +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 () + + +withUState pst f = modifyMVarInSeparateThread (gstate pst) (\x -> f x >>= h) where + h s@(g: gs, redos) = do + adjustButts (table pst) (board g) + setTableSt (table pst) $ if isEnd g then const Fixed else ff + labelSetText (label pst) $ info g + return s + + ff (Normal x) = Normal x + ff _ = Normal Nothing +------------------- + +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 () + + +------------ + diff --git a/Place.hs b/Place.hs new file mode 100644 --- /dev/null +++ b/Place.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE ViewPatterns #-} +-- | Places. +module Place + ( + -- * Size + Size + + -- * Place + , Place + , place + , coords + + -- * For performance + , hashPlace + , unHashPlace + , placesInAColumn + + -- * Useful functions + , neighbours + + ) where + +import Data.Bits + +----------- + +-- | Size of a board. +type Size = (Int, Int) + + +-- | Place on a board (with fixed width). +-- +-- Simpler but slower implementation: +-- +-- > data Place = P !Int !Int +-- > deriving (Eq, Ord, Show) + +newtype Place = P Int deriving (Eq, Ord) + +instance Show Place where + show (coords -> (x, y)) = "place " ++ show x ++ " " ++ show y + +place :: Int -> Int -> Place +place i j = P $ shiftL i 8 .|. j + +coords :: Place -> (Int, Int) +coords (P i) = (shiftR i 8, i .&. 255) + +-- | Perfect hash function. +hashPlace :: Place -> Int +hashPlace (P i) = i + +unHashPlace :: Int -> Place +unHashPlace = P + +placesInAColumn :: Int -> (Int, Int) -> [Place] +placesInAColumn i (j1, j2) = map P $ [i' + j1 .. i' + j2] where i' = shiftL i 8 + +-- | Neighbours of a place. +-- +-- Examples: +-- +-- > neighbours (8, 8) (place 2 3) +-- > == [place 1 2, place 1 3, place 1 4, place 2 2, place 2 4, place 3 2, place 3 3, place 3 4] +-- +-- > neighbours (8, 8) (place 2 1) +-- > == [place 1 1, place 1 2, place 2 2, place 3 1, place 3 2] +neighbours :: Size -> Place -> [Place] +neighbours (xS, yS) p@(P q) = f' q ++ (if j > 1 then f (q-1) else []) ++ (if j < yS then f (q+1) else []) + where + (i, j) = coords p + + f r = P r: (if i > 1 then [P (r - 256)] else []) ++ (if i < xS then [P (r + 256)] else []) + f' r = (if i > 1 then [P (r - 256)] else []) ++ (if i < xS then [P (r + 256)] else []) + + diff --git a/PlaceMap.hs b/PlaceMap.hs new file mode 100644 --- /dev/null +++ b/PlaceMap.hs @@ -0,0 +1,39 @@ +-- | Maps of places +module PlaceMap + ( PlaceMap + , fromList + , toList + , empty + , lookup + , insert + , delete + ) where + +import Place + +import qualified Data.IntMap as M +import Prelude hiding (lookup) + +------------- + +-- | Map of places. +type PlaceMap = M.IntMap + +fromList :: [(Place, a)] -> PlaceMap a +fromList = M.fromList . map (\(p, a) -> (hashPlace p, a)) + +toList :: PlaceMap a -> [(Place, a)] +toList = map (\(p, a)-> (unHashPlace p, a)) . M.toList + +empty :: PlaceMap a +empty = M.empty + +lookup :: Place -> PlaceMap a -> Maybe a +lookup p m = M.lookup (hashPlace p) m + +insert :: Place -> a -> PlaceMap a -> PlaceMap a +insert p a m = M.insert (hashPlace p) a m + +delete :: Place -> PlaceMap a -> PlaceMap a +delete p m = M.delete (hashPlace p) m + diff --git a/PlaceSet.hs b/PlaceSet.hs new file mode 100644 --- /dev/null +++ b/PlaceSet.hs @@ -0,0 +1,86 @@ +-- | Sets of places +module PlaceSet + ( PlaceSet + , listToPlaceSet + , placeSetToList + , singleton + , empty + , nullPS + , insert + , delete + , member + , size + , (\\) + , unions + , intersection + , disjunct + , isSubsetOf + + -- * Useful functions + , places + + ) where + +import Place + +import qualified Data.IntSet as S + +------------- + +-- | Set of places. +type PlaceSet = S.IntSet + +listToPlaceSet :: [Place] -> PlaceSet +listToPlaceSet = S.fromList . map hashPlace + +placeSetToList :: PlaceSet -> [Place] +placeSetToList = map unHashPlace . S.toList + +singleton :: Place -> PlaceSet +singleton = S.singleton . hashPlace + +-- | The empty PlaceSet. +empty :: PlaceSet +empty = S.empty + +insert :: Place -> PlaceSet -> PlaceSet +insert p ps = S.insert (hashPlace p) ps + +delete :: Place -> PlaceSet -> PlaceSet +delete p ps = S.delete (hashPlace p) ps + +-- | True if the PlaceSet is empty. +nullPS :: PlaceSet -> Bool +nullPS = S.null + +member :: Place -> PlaceSet -> Bool +member p = S.member (hashPlace p) + +size :: PlaceSet -> Int +size = S.size + +-- | Difference. +(\\) :: PlaceSet -> PlaceSet -> PlaceSet +(\\) = (S.\\) + +unions :: [PlaceSet] -> PlaceSet +unions = S.unions + +disjunct :: PlaceSet -> PlaceSet -> Bool +disjunct a b = S.null (S.intersection a b) + +intersection :: PlaceSet -> PlaceSet -> PlaceSet +intersection = S.intersection + +isSubsetOf :: PlaceSet -> PlaceSet -> Bool +isSubsetOf = S.isSubsetOf + +---------------------- + +-- | All places at a board. +places :: Size -> PlaceSet +places (xS, yS) = listToPlaceSet [p | x<-[1..xS], p <- placesInAColumn x (1, yS)] + + + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ + +import Distribution.Simple + +main = defaultMainWithHooks defaultUserHooks + diff --git a/Table.hs b/Table.hs new file mode 100644 --- /dev/null +++ b/Table.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE ViewPatterns #-} +module Table + ( GameTable + , newTable + , St (Stopped, Normal, Fixed) + , setTableSt + , 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 + , hidden :: 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) + +setTableSt :: GameTable -> (St -> St) -> IO () +setTableSt g fx = redrawButts_ g f where + f ss + | x == hh = ([], ss) + | Stopped `elem` [x, hh] + = (M.toList $ board_ ss, ss') + | otherwise + = (map h $ focusPos ss: ff hh ++ ff x, ss') + where + ss' = ss { hidden = x } + h p = (p, board_ ss M.! p) + x = fx hh + hh = hidden ss + 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 + , hidden = 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 = hidden 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 hidden ss of + Normal m -> do + ss <- takeMVar (states g) + putMVar (states g) $ ss { hidden = 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 (hidden 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 (hidden ss)) $ do + ss <- takeMVar (states g) + let + foc@(coords -> (x, y)) = focusPos ss + (sx, sy) = size_ ss + foc' = place (max 1 $ min sx $ dx + x) (max 1 $ min sy $ dy + y) + putMVar (states g) $ ss { focusPos = foc' } + if foc /= foc' + then redrawButts g [foc, foc'] + else return () + return True + + +drawingAreaGetDrawWindow' = widgetGetDrawWindow . area + +calcPos_ pos g = do + win <- drawingAreaGetDrawWindow' g + ss <- readMVar (states g) + + (width, height) <- drawableGetSize_ win + return $ calcPos (size_ ss) (width, height) pos + +calcPos (xx, yy) (width, height) (x,y) + | i + 1 `between` (1, xx) && j + 1 `between` (1, yy) {- && ii>0 && ii<9 && jj>0 && jj<9 -} + = Just $ place (i+1) (j+1) + | otherwise = Nothing + where + a = floor (x/width*10* fromIntegral xx) + b = floor (y/height*10* fromIntegral yy) + + (i,_ii) = a `divMod` 10 + (j,_jj) = b `divMod` 10 + +infix 4 `between` +a `between` (b, c) = b <= a && a <= c + + + + diff --git a/TableGraphics.hs b/TableGraphics.hs new file mode 100644 --- /dev/null +++ b/TableGraphics.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE ViewPatterns #-} +module TableGraphics + ( drawPlace + ) where + +import Place +import Game (State (..)) + +import Graphics.Rendering.Cairo + +import Control.Monad (when) + +----------------------------------------- + + +drawPlace + :: Bool -- ^ signs are not shown + -> Bool -- ^ highlighted + -> Bool -- ^ focused + -> Place + -> State + -> Render () + +drawPlace bb b foc (coords -> (i,j)) st = do + + + + rectangle (-0.4) (-0.4) 0.8 0.8 + setLineWidth 0.03 + setSourceRGB' bg + strokePreserve + setSourceRGB' $ case st of + Clear _ _ -> bg + Hidden True _ -> bg + Death -> bg + _ -> if b then bg else blue + + fill + setSourceRGB' black + if foc + then do + rectangle (-0.35) (-0.35) 0.7 0.7 + setLineWidth 0.02 + setDash [0.1,0.1] (if even (i + j) then 0 else 0.1) + stroke + setDash [] 0 + else return () + setLineCap LineCapRound + setLineWidth 0.1 + + if bb + then return () + else case st of + Death -> do + setLineCap LineCapSquare + moveTo (-0.25) (-0.25) + lineTo 0.25 0.25 + stroke + moveTo 0.25 (-0.25) + lineTo (-0.25) 0.25 + stroke + + Hidden False (Just d) -> do + setLineWidth 0.03 + arc 0 0 0.25 0 (2*pi*(1- realToFrac d)) + setSourceRGB' $ Color_ 0.3 0.4 0.5 + stroke + arc 0 0 0.25 (2*pi*(1- realToFrac d)) (2*pi) + setSourceRGB' $ Color_ 1 1 1 + stroke + + Hidden True bbb -> do + setLineWidth 0.03 + arc 0 0 0.25 0 (2*pi) + setSourceRGB' $ if b then bg else blue + fillPreserve + setSourceRGB' black + stroke + when (maybe False (/=0) bbb) $ do + setLineCap LineCapSquare + moveTo (-0.25) (-0.25) + lineTo 0.25 0.25 + stroke + moveTo 0.25 (-0.25) + lineTo (-0.25) 0.25 + stroke + Clear _ n -> do + case n of + 0 -> do + setLineCap LineCapSquare + setLineWidth 0.03 + moveTo (-0.2) 0 + lineTo 0.2 0 + stroke + 1 -> do + point 0 0 + 2 -> do + point (-0.2) 0 + point 0.2 0 + 3 -> do + point 0 (-0.20) + point (-0.2) 0.14 + point 0.2 0.14 + 4 -> do + point (-0.2) 0.2 + point 0.2 0.2 + point (-0.2) (-0.2) + point 0.2 (-0.2) + 5 -> do + point 0 0 + point (-0.2) 0.2 + point 0.2 0.2 + point (-0.2) (-0.2) + point 0.2 (-0.2) + 6 -> do + point (-0.2) 0 + point 0.2 0 + point (-0.2) 0.2 + point 0.2 0.2 + point (-0.2) (-0.2) + point 0.2 (-0.2) + 7 -> do + point 0 0 + point (-0.2) 0 + point 0.2 0 + point (-0.2) 0.2 + point 0.2 0.2 + point (-0.2) (-0.2) + point 0.2 (-0.2) + 8 -> do + point (-0.2) 0 + point 0.2 0 + point 0 (-0.2) + point 0 0.2 + point (-0.2) 0.2 + point 0.2 0.2 + point (-0.2) (-0.2) + point 0.2 (-0.2) + return () + _ -> return () + + +point :: Double -> Double -> Render () +point x y = do + moveTo x y + relLineTo 0 0 + stroke + + +data Color_ = Color_ Double Double Double + +bg, blue, black, white :: Color_ +blue = Color_ 0.65 0.8 1 +black = Color_ 0 0 0 +white = Color_ 1 1 1 +bg = Color_ 0.9 0.9 0.9 + +setSourceRGB' :: Color_ -> Render () +setSourceRGB' (Color_ r g b) = setSourceRGB r g b + + +betw :: + Double -> Color_ -> Color_ -> Color_ +betw pr (Color_ a b c) (Color_ a' b' c') = Color_ (f a a') (f b b') (f c c') where + + f i j = max 0 $ min 1 $ i + pr * (j - i) + + diff --git a/Timer.hs b/Timer.hs new file mode 100644 --- /dev/null +++ b/Timer.hs @@ -0,0 +1,117 @@ +module Timer + ( Tim + , newTimer + , startTimer + , stopTimer + , resetTimer + , isActiveTimer + + , showSeconds + ) where + +import Control.Concurrent +import Control.Concurrent.MVar + +import Data.Time.Clock + +------------------------------------------- + +data StoppedTimerState + = Initial | Stopped | Halted + deriving Eq + +data Timer + = ActiveTimer + ThreadId -- which thread is responsible for the updating of the timer + UTCTime + | StoppedTimer + StoppedTimerState + NominalDiffTime + +type Action = String -> IO () + +type Tim = MVar + ( Action -- this is global for this module, but Haskell has no parameterized modules.. + , Timer) + +------------------- + +newTimer :: Action -> IO Tim +newTimer action + = newMVar (action, StoppedTimer Initial 0) + +startTimer :: Bool -> Tim -> IO () +startTimer b tim = do + a@(timeL, xx) <- takeMVar tim + case xx of + StoppedTimer x s | b && x == Stopped || not b && x /= Halted -> do + tid <- forkIO $ modTime tim + ti <- getCurrentTime + putMVar tim (timeL, ActiveTimer tid $ addUTCTime (-s) ti) + _ -> do + putMVar tim a + +stopTimer :: Bool -> Tim -> IO NominalDiffTime +stopTimer b tim = do + a@(timeL, x) <- takeMVar tim + case x of + ActiveTimer _ ti -> do + ti' <- getCurrentTime + let d = diffUTCTime ti' ti + putMVar tim (timeL, StoppedTimer xx d) + timeL $ (if b then "Stopped at " else "Halted at ") ++ showSeconds (round d) + return d + StoppedTimer _ d -> do + putMVar tim (timeL, StoppedTimer xx d) + return d + where + xx = if b then Stopped else Halted + +resetTimer :: Tim -> IO () +resetTimer tim = do + (timeL, _) <- takeMVar tim + timeL "Timer will start" + putMVar tim (timeL, StoppedTimer Initial 0) + return () + +isActiveTimer :: Tim -> IO Bool +isActiveTimer tim = do + (_, x) <- readMVar tim + return $ case x of + ActiveTimer _ _ -> True + _ -> False + + +----------------- + +modTime :: Tim -> IO () +modTime tim = do + tid <- myThreadId + (timeL, x) <- readMVar tim + case x of + ActiveTimer tid' ti | tid == tid' -> do + ti' <- getCurrentTime + let diff = diffUTCTime ti' ti + timeL $ "Time: " ++ showSeconds (round diff) + threadDelay (computeWaitTime diff) + modTime tim + _ -> + return () + +computeWaitTime :: NominalDiffTime -> Int {-milliseconds-} +computeWaitTime x = 1000000 * (1 + round y) - round (1000000 * y) - 100000 where (_, y) = properFraction x :: (Integer, NominalDiffTime) + +------------- + +showSeconds :: Integer -> String +showSeconds s = f h ++ ":" ++ f m' ++ ":" ++ f s' where + + (m, s') = divMod s 60 + (h, m') = divMod m 60 + + f :: Integer -> String + f i = reverse $ take 2 $ reverse $ "0" ++ show i + + + + diff --git a/minesweeper.cabal b/minesweeper.cabal new file mode 100644 --- /dev/null +++ b/minesweeper.cabal @@ -0,0 +1,49 @@ +name: minesweeper +version: 0.4 +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 + +executable minesweeper + ghc-options: -Wall -fno-warn-incomplete-patterns -fno-warn-name-shadowing + build-depends: base >= 3.0, + containers, + random, + time, + glade, + gtk >= 0.10, + cairo >= 0.10 + + main-is: Minesweeper.hs + + other-modules: Place, + PlaceSet, + PlaceMap, + Delay, + Core, + Game, + Table, + TableGraphics, + Timer + + extensions: RecursiveDo, + NamedFieldPuns, + ViewPatterns, + PatternGuards + + diff --git a/ms.glade b/ms.glade new file mode 100644 --- /dev/null +++ b/ms.glade @@ -0,0 +1,575 @@ + + + + + + + + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + The Lucky Minesweeper + center + 500 + 590 + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + _File + True + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + + + gtk-new + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + True + True + + + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + + + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + + + + + gtk-quit + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + True + True + + + + + + + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + _Edit + True + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + _Clear + True + + + + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + _Flag + True + + + + + + True + _Hint + True + + + + + + True + _Probabilities + True + + + + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + + + + + gtk-undo + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + True + True + + + + + + gtk-redo + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + True + True + + + + + + + + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + _Preferences + True + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + + + gtk-preferences + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + True + True + + + + + + + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + _Help + True + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + + + gtk-help + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + True + True + + + + + gtk-about + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + True + True + + + + + + + + + False + 0 + + + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + x + center + True + + + False + 5 + 3 + + + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + + + False + 4 + + + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + 0 + none + False + + + + + + 5 + 5 + + + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + + + False + end + 2 + + + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + x + + + False + 5 + end + 1 + + + + + + + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + 5 + About The Lucky Minesweeper + False + center-on-parent + dialog + False + The Lucky Minesweeper + 0.1 + Péter Diviánszky © 2008 + Written in Haskell with GHC, Gtk2Hs and Glade + Copyright Péter Diviánszky 2008 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Péter Diviánszky nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + Péter Diviászky, divip aszt inf elte hu + + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + 2 + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + end + + + False + end + 0 + + + + + + + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + 5 + Preferences + center-on-parent + dialog + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + 2 + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + 3 + 2 + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + Rows + + + + + True + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + 10 1 15 1 10 0 + + + 1 + 2 + + + + + True + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + 10 1 15 1 10 0 + + + 1 + 2 + 1 + 2 + + + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + Columns + + + 1 + 2 + + + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + Mines + + + 2 + 3 + + + + + True + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + 20 0 100 1 10 0 + True + + + 1 + 2 + 2 + 3 + + + + + 2 + + + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + end + + + gtk-cancel + -6 + True + True + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + True + + + False + False + 0 + + + + + gtk-ok + -5 + True + True + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + True + + + False + False + 1 + + + + + False + end + 0 + + + + + + + 450 + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + 5 + center-on-parent + dialog + False + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + 2 + + + True + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + 10 + False + word + 10 + 10 + False + Minesweeper game which is always solvable without guessing. +The luck of the gamer is measured with 'luckiness'. +Luckiness = -1/2 * log2 p, where p is the probability of that the player would be alive if the game was a normal minesweeper game. +For example, luckiness = 10 means that since the game start the player cleared 20 positions where a mine was with 50% probability, so in a normal game the player probably would die 10 times. + +Known bugs: +* There is no score table. +* The game may slow down at larger tables. + + + + 1 + + + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + 5 + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + See also: + + + 0 + + + + + _Minesweeper (Wikipedia) + True + True + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + none + True + http://en.wikipedia.org/wiki/Minesweeper_(computer_game) + + + + 2 + + + + + False + 2 + + + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + end + + + gtk-ok + True + True + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + True + + + False + False + 0 + + + + + False + end + 1 + + + + + +