-
Notifications
You must be signed in to change notification settings - Fork 34
/
Main.hs
192 lines (164 loc) · 6.09 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
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DataKinds #-}
module Frontend.Examples.PegSolitaire.Main
(app)
where
import Control.Arrow ((&&&))
import Data.Array.IArray as A
import Data.Monoid ((<>))
import qualified Data.Text as T
import Reflex.Dom
import Obelisk.Generated.Static
import Control.Monad.Fix (MonadFix)
--------------------------------------------------------------------------------
-- Model
--------------------------------------------------------------------------------
type Point = (Int, Int)
-- | Idk : I don't know.
data Trool = Yes | Idk | No deriving (Eq)
type Board = Array Point Trool
-- | If the user chooses an amibuous starting point we need to remember it
-- so that when the destination is chosen we know what the move was.
data GameState = GameState {board :: Board, start :: Maybe Point}
-- | The "English" board.
initialBoard :: Board
initialBoard = A.array ((-3, -3), (3, 3))
[((i, j),valid i j) | i <- [(-3)..3], j <-[(-3)..3]]
where
valid 0 0 = No
valid i j = if abs i < 2 || abs j < 2 then Yes else No
initialState :: GameState
initialState = GameState initialBoard Nothing
data Compass = North | East | South | West deriving (Enum)
--------------------------------------------------------------------------------
-- View
--------------------------------------------------------------------------------
app
:: ( DomBuilder t m
, MonadFix m
, MonadHold t m
, PostBuild t m
)
=> m ()
app = divClass "container" $ do
el "br" blank
elAttr "h1" ("style" =: "text-align: center") $ text "PEG SOLITAIRE"
el "div" $ do
el "br" blank
el "div" $ do
rec
gs <- foldDyn move initialState pos
pos <- mkBoard gs
elAttr "h3" ("style" =: "text-align: center") $
dynText $ fmap (\g -> "Score: " <> (T.pack . show . score) g) gs
return ()
-- | This is slightly complicated by the fact that some moves are not uniquely
-- determined by there starting position. In this case we need to remember
-- the starting point so that when the player disambiguates by clicking the
-- destination square we know what move was made.
move :: Point -> GameState -> GameState
move p gs = case (start gs, length lm) of
-- If start is a Just value the player needs to chosse the destination.
(Just s, _ ) -> if p `elem` cs
-- A legal destination was chosen so make the move and clean up
-- the board.
then game $ b // map (\q -> (q, No)) cs
// [(p, Yes), (s, No), (middle p s , No)]
else GameState b (Just s)
-- No legal moves, try again.
(Nothing, 0) -> game b
-- One legal move so execute it.
(Nothing, 1) -> game $ b // [(p, No), (fst $ head lm, No), (snd $ head lm, Yes)]
-- Several legal moves so highlight the choices.
_ -> GameState (b // map (\m -> (snd m, Idk)) lm) (Just p)
where
game brd = GameState brd Nothing
b = board gs
lm = legalMoves b p
cs = idks b
-- | Create a game cell that returns it's coordinates when clicked.
cell
:: ( DomBuilder t m
, MonadFix m
, PostBuild t m
)
=> Dynamic t GameState -> Point -> m (Event t Point)
cell gs p = el "td" $ do
rec (e, _) <- elDynAttr' "img" attrs (return ())
attrs <- (return . fmap (square p . board)) gs
return $ p <$ domEvent Click e
where
square pos bd
| not $ onBoard pos = off
| bd A.! pos == Yes = yes
| bd A.! pos == Idk = idk
| otherwise = no
yes = "src"=: static @"peg-solitaire/images/ball.svg"
<> "style" =: "display: block"
<> "draggable" =: "false"
no = "src"=: static @"peg-solitaire/images/square.svg"
<> "style" =: "display: block"
<> "draggable" =: "false"
idk = "src"=: static @"peg-solitaire/images/ball.svg"
<> "style" =: "display: block; opacity: 0.35"
<> "draggable" =: "false"
off = "src"=: "static/images/square.svg"
<> "style" =: "display: block; opacity: 0"
<> "draggable" =: "false"
-- | Row j of cells.
row
:: ( DomBuilder t m
, MonadFix m
, PostBuild t m
)
=> Dynamic t GameState -> Int -> m (Event t Point)
row gs j =
el "tr" $ do
cells <- mapM (cell gs) [(i, j) | i <- [-3..3]]
return $ leftmost cells
-- The game board, returns the coordinates of the clicked cell.
mkBoard
:: ( DomBuilder t m
, MonadFix m
, PostBuild t m
)
=> Dynamic t GameState -> m (Event t Point)
mkBoard gs =
elAttr "table" ("style" =: "margin-left: auto; margin-right: auto") $ do
rows <- mapM (row gs) [-3..3]
return $ leftmost rows
--------------------------------------------------------------------------------
-- Game Logic
--------------------------------------------------------------------------------
legalMoves :: Board -> Point -> [(Point, Point)]
legalMoves b p = map snd . filter fst $ moves
where
legal = map (legalMove b p) [North .. West]
pos = map (position 1 p &&& position 2 p) [North .. West]
moves = zip legal pos
legalMove :: Board -> Point -> Compass -> Bool
legalMove b p d = onBoard (position 1 p d)
&& onBoard (position 2 p d)
&& b A.! p == Yes
&& b A.! position 1 p d == Yes
&& b A.! position 2 p d == No
onBoard :: Point -> Bool
onBoard (x, y) = (abs x < 2 || abs y < 2) && (abs x < 4 && abs y < 4)
position :: Int -> Point -> Compass -> Point
position n (x, y) dir = case dir of
North -> (x, y-n)
East -> (x+n, y)
South -> (x, y+n)
West -> (x-n, y)
score :: GameState -> Int
score = sum . map (\x -> if x == Yes then 1 else 0) . elems . board
idks :: Board -> [Point]
idks = map fst . filter (\e -> snd e == Idk) . assocs
middle :: Point -> Point -> Point
middle (x1, y1) (x2, y2) = ((x1 + x2) `div` 2, (y1 + y2) `div` 2)