diff --git a/Core/BitField.lhs b/Core/BitField.lhs --- a/Core/BitField.lhs +++ b/Core/BitField.lhs @@ -13,8 +13,13 @@ > import Data.PContainer +#ifdef TEST + > import Test.LazySmallCheck hiding (empty) > import Number.Peano + +#endif + > import Control.Monad > import Data.Binary > import Data.DeriveTH diff --git a/Data/PContainer.lhs b/Data/PContainer.lhs --- a/Data/PContainer.lhs +++ b/Data/PContainer.lhs @@ -10,8 +10,12 @@ Import List ----------- +#ifdef TEST + > import Test.LazySmallCheck hiding (empty) > import Number.Peano + +#endif import Control.Monad diff --git a/Event.hs b/Event.hs --- a/Event.hs +++ b/Event.hs @@ -54,32 +54,50 @@ type Responses = [Response] data Response - = DrawSquares Board [(Square, (Bool, BackGround, Sign))] + = DrawSquares Board [(Square, SquareState)] | 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 +data SquareState + = HiddenSign | Death - | Clear Int -- ^ 0-8 - | Hint Int -- ^ 0-100 - | HintedBomb Int -- ^ 0-100 - | BusySign Int -- ^ phase 0-100 + | Clear Focused Int Dangerousness -- ^ 0-8 + | NoSign Focused Prelight + | Hint Focused Prelight Int -- ^ 0-100 + | BusySign Focused Prelight Int -- ^ phase 0-100 + | Bomb Focused Prelight + | HintedBomb Focused Prelight Int -- ^ 0-100 deriving (Eq, Ord, Show) +type Focused = Bool -isBomb Bomb = True -isBomb (HintedBomb _) = True -isBomb _ = False +type Prelight = Bool + +type Dangerousness = Int -- ^ 0-100 + +focused HiddenSign = False +focused Death = False +focused (Clear f _ _) = f +focused (NoSign f _) = f +focused (Hint f _ _) = f +focused (BusySign f _ _) = f +focused (Bomb f _) = f +focused (HintedBomb f _ _) = f + +prelight HiddenSign = False +prelight Death = False +prelight (Clear _ _ _) = False +prelight (NoSign _ p) = p +prelight (Hint _ p _) = p +prelight (BusySign _ p _) = p +prelight (Bomb _ p) = p +prelight (HintedBomb _ p _) = p + + +isBomb (Bomb _ _) = True +isBomb (HintedBomb _ _ _) = True +isBomb _ = False diff --git a/GTK.hs b/GTK.hs --- a/GTK.hs +++ b/GTK.hs @@ -14,7 +14,7 @@ import GTK.Score import Paths_minesweeper -import Graphics.UI.Gtk +import Graphics.UI.Gtk hiding (event) import Graphics.UI.Gtk.Glade import Graphics.UI.Gtk.Gdk.EventM import Graphics.Rendering.Cairo (liftIO) -- ??? @@ -207,21 +207,49 @@ widgetDestroy a -redrawSigns :: GUIState -> Board -> [(Square, (Bool, BackGround, Sign))] -> IO () +redrawSigns :: GUIState -> Board -> [(Square, SquareState)] -> IO () redrawSigns _ _ [] = return () redrawSigns gst s l = do win <- widgetGetDrawWindow $ table gst + style <- widgetGetStyle $ table gst + backgroundColor <- styleGetBackground style StateNormal (width, height) <- drawableGetSize win let ss = (fromIntegral width / fromIntegral (xSize s), fromIntegral height / fromIntegral (ySize s)) - mapM_ (drawSquare win ss) l + mapM_ (drawSquare win (backgroundColor, blue, green, dangerColor, black, white, between 0.5 black blue, color 1 0.9 0.7) ss) l -drawSquare win (a, b) (p, xx) = do +drawSquare win style (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 + renderWithDrawable win $ renderSquare style (a, b) (x, y) xx drawWindowEndPaint win +------------------------ + +dangerColor dangerousness = between (realToFrac dangerousness / 100) backgroundColor red + +backgroundColor, 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 +backgroundColor = white -- between 0.9 black white -- TODO: get real background +red = color 1 0.3 0 + +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') where + i' = ff i + j' = ff j + + +color :: Double -> Double -> Double -> Color +color r g b = Color (f r) (f g) (f b) where + + f x = round (65535*x) + +ff i = fromIntegral i / 65535 -------------------------------------------------- helper diff --git a/GTK/Square.hs b/GTK/Square.hs --- a/GTK/Square.hs +++ b/GTK/Square.hs @@ -5,28 +5,34 @@ import Event import Graphics.Rendering.Cairo +import Graphics.UI.Gtk.Gdk.GC (Color(..)) +--import Graphics.UI.Gtk.General.Style +--import Graphics.UI.Gtk.General.Enums (StateType(..)) import Control.Monad ----------------------------------------- -renderSquare :: (Double, Double) -> (Int, Int) -> (Bool, BackGround, Sign) -> Render () -renderSquare (a, b) (x, y) (focused, bg, sign) = do +renderSquare :: (Color, Color, Color, Int -> Color, Color, Color, Color, Color) -> + (Double, Double) -> (Int, Int) -> SquareState -> Render () +renderSquare (background, activeColor, prelightColor, dangerColor, black, white, darkblue, yellow) + (a, b) (x, y) squareState = 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 + rectangle (-0.5) (-0.5) 1 1 setSourceRGB' background - strokePreserve - unless (isBomb sign) $ setSourceRGB' $ toColor bg fill + unless (isBomb squareState) $ do + rectangle (-0.4) (-0.4) 0.8 0.8 + setSourceRGB' bg + fill setSourceRGB' black - when focused $ do + when (focused squareState) $ do setLineWidth 0.02 rectangle (-0.35) (-0.35) 0.7 0.7 setDash [0.1, 0.1] 0 @@ -35,13 +41,15 @@ setLineWidth 0.03 - case sign of + case squareState of - NoSign -> return () + NoSign _ _ -> return () - BusySign i -> do + HiddenSign -> return () + + BusySign _ _ i -> do setLineCap LineCapSquare - setSourceRGB' $ Color 1 0.9 0.7 -- between 0.6 white black + setSourceRGB' yellow setLineWidth 0.05 let f j = do let phi = j/5*pi + fromIntegral i/200*2*pi @@ -51,26 +59,26 @@ stroke mapM_ f [1..5] - Bomb -> do + Bomb _ _ -> do arc 0 0 0.25 0 (2*pi) - setSourceRGB' $ toColor bg + setSourceRGB' bg fillPreserve setSourceRGB' black stroke - Hint d -> do + Hint _ _ d -> do let (r1, r2) = radians d arc 0 0 0.25 r1 r2 - setSourceRGB' $ between 0.5 black blue + setSourceRGB' darkblue stroke arc 0 0 0.25 r2 (r1 + 2*pi) setSourceRGB' white stroke - HintedBomb d -> do + HintedBomb _ _ d -> do let (r1, r2) = radians d arc 0 0 0.25 0 (2*pi) - setSourceRGB' $ toColor bg + setSourceRGB' bg fill arc 0 0 0.25 r2 (r1 + 2*pi) setSourceRGB' white @@ -87,13 +95,13 @@ lineTo (-0.25) 0.25 stroke - Clear 0 -> do + Clear _ 0 _ -> do setLineWidth 0.03 moveTo (-0.2) 0 lineTo 0.2 0 stroke - Clear n -> do + Clear _ n _ -> do setLineWidth 0.1 setLineCap LineCapRound @@ -122,7 +130,16 @@ 8 -> [ p1, p2, p3 , p4, p6 , p7, p8, p9 ] + where + bg | prelight squareState + = prelightColor + | (Clear _ _ dangerousness) <- squareState + = dangerColor dangerousness + | Death <- squareState + = dangerColor 100 + | otherwise + = activeColor ------------------ @@ -141,27 +158,9 @@ 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 +setSourceRGB' (Color r g b) = setSourceRGB (ff r) (ff g) (ff b) +ff i = fromIntegral i / 65535 diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/Transition/Graphics.hs b/Transition/Graphics.hs --- a/Transition/Graphics.hs +++ b/Transition/Graphics.hs @@ -13,51 +13,34 @@ ------------------------------------------------------------- -renderSquare :: State -> Square -> (Bool, BackGround, Sign) -renderSquare st p = (hasFocus, bg, sign) where - +squareState :: State -> Square -> SquareState +squareState st p + | Just r <- revealing st + , p == revSquare r + , Just i <- busyAnimation r + = BusySign focused prelight i + | Just h <- hint st + , Just max <- maxHiddenProb g + , Just x <- M.lookup p $ hiddenProbs g + , h == FullHint || x == max || x == 0 || marked' + = (if marked' then HintedBomb else Hint) focused prelight x + | marked' + = Bomb focused prelight + | Just Nothing <- revealed + = Death + | Just (Just i) <- revealed + = if hiddenTable st then HiddenSign else Clear focused i dangerousness + | otherwise + = NoSign focused prelight + where g = game st - hasFocus = p == focus st && focusMoves st - hasMouseFocus = maybe False (== p) (mouseFocus st) + focused = p == focus st && focusMoves st + prelight = maybe False (== p) (mouseFocus st) && mouseFocusShown st revealed = M.lookup p $ revealResults g marked' = S.member p $ marked g - - 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 + dangerousness = head $ [x | (q,x)<-redness st, q==p] ++ [0] - 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 diff --git a/Transition/Managed.hs b/Transition/Managed.hs --- a/Transition/Managed.hs +++ b/Transition/Managed.hs @@ -99,12 +99,12 @@ ch | isNothing (changes ost) || e == UpdateTable = [(p, f p) | p <- squares . size_ . state $ st] | Just (ost', l) <- changes ost - , f' <- renderSquare ost' + , f' <- squareState 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 + f = squareState $ state st responses :: Event -> State -> State -> [Response] diff --git a/minesweeper.cabal b/minesweeper.cabal --- a/minesweeper.cabal +++ b/minesweeper.cabal @@ -1,5 +1,5 @@ name: minesweeper -version: 0.8.8.2 +version: 0.8.8.3 category: Game synopsis: Minesweeper game which is always solvable without guessing description: diff --git a/ms.glade b/ms.glade --- a/ms.glade +++ b/ms.glade @@ -14,6 +14,7 @@ True GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + vertical True @@ -325,6 +326,7 @@ True GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + vertical 2 @@ -351,6 +353,7 @@ True GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + vertical 8 @@ -679,7 +682,7 @@ end - gtk-cancel + gtk-cancel -6 True True @@ -695,7 +698,7 @@ - gtk-ok + gtk-ok -5 True True @@ -730,6 +733,7 @@ True GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK + vertical 2 @@ -796,7 +800,7 @@ end - gtk-ok + gtk-ok True True True @@ -987,7 +991,7 @@ end - gtk-ok + gtk-ok -5 True True