-
Notifications
You must be signed in to change notification settings - Fork 0
/
Main.hs
148 lines (130 loc) · 4.55 KB
/
Main.hs
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
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MonoLocalBinds #-}
import Control.Monad.Random (RandomGen, getStdGen, runRand, split)
import Control.Monad.State (runState)
import Data.List (unfoldr)
import Data.Map (Map, elems, fromList)
import Data.Text (Text, pack)
import Reflex
import Reflex.Dom
import Board
import Flag
import Mine
import Msg
import Pos
import Smiley
import Svg
cellSize :: Int
cellSize = 20
getColor :: Cell -> String
getColor (Cell _ exposed _ _) =
if exposed
then "#909090"
else "#CCCCCC"
squareAttrs :: Cell -> Map Text Text
squareAttrs cell =
fromList
[ ("x", "0.05")
, ("y", "0.05")
, ("width", "0.9")
, ("height", "0.9")
, ("style", pack $ "fill:" ++ getColor cell)
]
showSquare :: MonadWidget t m => Cell -> m [El t]
showSquare cell = do
(rEl, _) <- elSvgns "rect" (constDyn $ squareAttrs cell) $ return ()
return [rEl]
textAttrs :: Int -> Map Text Text
textAttrs count =
let textColor :: Text =
case count of
1 -> "blue"
2 -> "green"
3 -> "red"
4 -> "brown"
_ -> "purple"
in fromList
[ ("x", "0.5")
, ("y", "0.87")
, ("font-size", "1.0")
, ("fill", textColor)
, ("text-anchor", "middle")
]
showText :: MonadWidget t m => Int -> m [El t]
showText count = do
elSvgns "text" (constDyn $ textAttrs count) $ text $ pack $ show count
return []
showCellDetail :: MonadWidget t m => Pos -> Cell -> m [El t]
showCellDetail pos (Cell mined exposed flagged mineCount) =
case ( flagged, mined, exposed, 0 /= mineCount) of
( True, _, _, _) -> showFlag pos
( _, True, True, _) -> showMine pos
( _, _, True, True) -> showText mineCount
( _, _, _, _) -> return []
mouseEv :: Reflex t => Pos -> El t -> [Event t Msg]
mouseEv pos el =
let r_rEv = RightPick pos <$ domEvent Contextmenu el
l_rEv = LeftPick pos <$ domEvent Click el
in [l_rEv, r_rEv]
groupAttrs :: Pos -> Map Text Text
groupAttrs (x, y) =
let scale = show cellSize
in fromList
[ ( "transform"
, pack $ "scale (" ++ scale ++ ", " ++ scale ++ ") "
++ "translate (" ++ show x ++ ", " ++ show y ++ ")")
]
showCell :: MonadWidget t m => Pos -> Cell -> m (Event t Msg)
showCell pos cell =
fmap snd $
elSvgns "g" (constDyn $ groupAttrs pos) $ do
rEl <- showSquare cell
dEl <- showCellDetail pos cell
return $ leftmost $ concatMap (mouseEv pos) (rEl ++ dEl)
showAndReturnCell :: MonadWidget t m => Pos -> Cell -> m (Event t Msg, Cell)
showAndReturnCell pos cell = do
ev <- showCell pos cell
return (ev, cell)
boardAttrs :: Map Text Text
boardAttrs =
fromList
[ ("width", pack $ show $ w * cellSize)
, ("height", pack $ show $ h * cellSize)
, ("style", "border:solid")
]
centerStyle =
fromList [("style", "width: 75%; margin: 0 auto;text-align:center;")]
reactToPick :: (Board, Msg) -> Map Pos (Maybe Cell)
reactToPick (b, msg) =
let (resultList, _) = runState (updateBoard msg) b
in fromList resultList
boardWidget :: (RandomGen g) => (MonadWidget t m) => g -> m ()
boardWidget g = do
let (initial, _) = runRand mkBoard g
rec elAttr "div" centerStyle $ dyn (fmap (showFace . gameOver) board)
elAttr "div" centerStyle $ text "Implemented using Reflex"
let pick = switch $ (leftmost . elems) <$> current eventMap
pickWithCells = attachPromptlyDynWith (,) board pick
updateEv = fmap reactToPick pickWithCells
(_, eventAndCellMap) <-
elAttr "div" centerStyle $
elSvgns "svg" (constDyn boardAttrs) $
listHoldWithKey initial updateEv showAndReturnCell
let board = fmap (fmap snd) eventAndCellMap
eventMap = fmap (fmap fst) eventAndCellMap
return ()
main :: IO ()
main = do
g <- getStdGen
let (gh:gs) = unfoldr (Just . split) g -- list of generators
mainWidget $
do
-- 'rec' only here to get reset below board
rec bEv <- zipListWithEvent const (fmap boardWidget gs) rEv
widgetHold (boardWidget gh) bEv
let btnElement = fst <$> (el' "button" $ text "Reset")
let btnEvent = domEvent Click <$> btnElement
rEv <- elAttr "div" centerStyle btnEvent
return ()