1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
|
import Graphics.UI.Gtk hiding (fill, rectangle)
import Graphics.UI.Gtk.Gdk.EventM (EventM, EButton)
import Graphics.Rendering.Cairo
import Control.Monad (liftM, when, forM_, replicateM)
import Data.Array.IO (IOUArray, newArray, readArray, writeArray, getBounds, range)
import System.Environment (getArgs)
import System.Random (randomRIO)
type Board = IOUArray (Int, Int) Bool
size :: Board -> IO Int
size = liftM (succ.fst.snd).getBounds
inBoard :: Board -> (Int, Int) -> IO Bool
inBoard board (x, y) = do
n <- size board
return $ 0 <= x && x < n && 0 <= y && y < n
whenM :: Monad m => m Bool -> m () -> m ()
whenM b f = b >>= flip when f
ifM :: Monad m => m Bool -> m b -> m b -> m b
ifM b t f = do _b <- b
if _b then t else f
flipPanel :: Board -> (Int, Int) -> IO ()
flipPanel board (x, y) =
whenM (inBoard board (x, y)) $
forM_ [(x, y), (x+1, y), (x, y+1), (x-1, y), (x, y-1)] $ \ix ->
whenM (inBoard board ix) $
writeArray board ix.not =<< readArray board ix
reset :: Board -> IO ()
reset board = do
bounds <- getBounds board
forM_ (range bounds) $ \ix -> writeArray board ix False
shuffle :: Board -> IO ()
shuffle board = do
n <- size board
r <- randomRIO (n, n*n)
[xs, ys] <- replicateM 2.replicateM r $ randomRIO (0, n-1)
mapM_ (flipPanel board) $ zip xs ys
updateCanvas :: DrawingArea -> Board -> EventM any Bool
updateCanvas area board = do
liftIO $ do win <- widgetGetDrawWindow area
renderWithDrawable win $ drawBoard area board
return True
updateBoard :: DrawingArea -> Board -> EventM EButton Bool
updateBoard area board = do
liftIO $ do (x, y) <- widgetGetPointer area
(sw, sh, pw, ph) <- boardGetLength area board
flipPanel board (div x (floor $ sw + pw), div y (floor $ sh + ph))
updateCanvas area board
drawBoard :: DrawingArea -> Board -> Render ()
drawBoard area board = do
setSourceRGB 0.5 0.5 0.5
paint
(sw, sh, pw, ph) <- liftIO $ boardGetLength area board
n <- liftIO $ size board
forM_ (sequence $ replicate 2 [0..n-1]) $ \[i', j'] ->
do let [i, j] = map fromIntegral [i', j']
ifM (liftIO.readArray board $ (i', j')) (setSourceRGB 0 0 0) (setSourceRGB 1 1 1)
rectangle (sw * (i+1) + pw * i) (sh * (j+1) + ph * j) pw ph
fill
boardGetLength :: DrawingArea -> Board -> IO (Double, Double, Double, Double)
boardGetLength area board = do
(_w, _h) <- widgetGetSize area
n <- liftM fromIntegral $ size board
let w = fromIntegral _w
h = fromIntegral _h
panel = (1 - (n + 1) * space) / n
return (space * w, space * h, panel * w, panel * h)
where space = 0.01
run n = do
initGUI
-- win (Window)
-- +--- vbox (VBox)
-- +--- can (DrawingArea)
-- +--- hbox (HBox)
-- +-- cls (Button)
-- +-- rst (Button)
-- +-- shf (Button)
win <- windowNew
win `set` [windowTitle := "FlipIt!",
windowDefaultWidth := n * 50,
windowDefaultHeight := n * 50 + 40,
containerBorderWidth := 0]
win `onDestroy` mainQuit
vbox <- vBoxNew False 0
can <- drawingAreaNew
hbox <- hBoxNew False 0
cls <- buttonNewWithLabel "Close"
rst <- buttonNewWithLabel "Reset"
shf <- buttonNewWithLabel "Shuffle"
containerAdd win vbox
boxPackStart vbox can PackGrow 0
boxPackStart vbox hbox PackNatural 5
boxPackStart hbox cls PackGrow 0
boxPackStart hbox rst PackGrow 0
boxPackStart hbox shf PackGrow 0
widgetShowAll win
board <- newArray ((0, 0), (n-1, n-1)) False
on can exposeEvent $ updateCanvas can board
on can buttonPressEvent $ updateBoard can board
on cls buttonPressEvent $ liftIO mainQuit >> return True
on rst buttonPressEvent $ liftIO (reset board) >> updateBoard can board
on shf buttonPressEvent $ liftIO (shuffle board) >> updateBoard can board
mainGUI
main = do
args <- getArgs
if length args > 0 then run.read.head $ args else run 5
|
