-
Notifications
You must be signed in to change notification settings - Fork 1
/
Reversi.hs
146 lines (123 loc) · 5.82 KB
/
Reversi.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
-------------
-- Reversi --
-------------
module Reversi (Reversi, reversi) where
import Game
import Data.Array
import Graphics.UI.WX hiding (border)
import Graphics.UI.WXCore
import Tools
data Reversi = Reversi (Array (Int, Int) (Maybe Player)) deriving (Eq, Show)
reversi :: Reversi
reversi = undefined
instance Game Reversi where
name _ = "reversi"
standard _ = Properties { players = 2, boardsize = 8, human = [True, False] }
possible _ = PropertyRange { playersrange = [2], boardsizerange = [6, 8, 10] }
new pr = let s = boardsize pr
h = s `div` 2
in Reversi $ array ((0, 0), (s - 1, s - 1))
[((x, y), Nothing) | x <- [0 .. s - 1], y <- [0 .. s - 1]]
// [ ((h - 1, h - 1), Just 0)
, ((h , h - 1), Just 1)
, ((h - 1, h ), Just 1)
, ((h , h ), Just 0)
]
moves pr p (Reversi s) = map (move $ boardsize pr) (allMoves (boardsize pr) p s)
showmove pr p (Reversi s) i = case allMoves (boardsize pr) p s !! i
of Nothing -> "skip turn"
Just (x, y) -> "abcdefghij" !! x : show (boardsize pr - y)
value pr p (Reversi s)
| null $ moves pr p (Reversi s) = (\i -> [i, -i]) $ (fromInteger . toInteger) $ signum $ count $ elems s
| otherwise = (\i -> let f = (fromInteger . toInteger) i / (fromInteger . toInteger) (sqr $ boardsize pr) in [f, -f]) $ count $ elems s
where
count :: [Maybe Player] -> Int
count [] = 0
count (Nothing : fs) = count fs
count (Just 0 : fs) = 1 + count fs
count (Just 1 : fs) = -1 + count fs
count _ = error "value: Unexpected value"
board p pr vart ia move' = do
marble <- bitmapCreateLoad "images\\marble.bmp" wxBITMAP_TYPE_ANY
varg <- varCreate $ grate rectZero 0 (0, 0) sizeZero
let
onpaint :: DC () -> Rect -> IO ()
onpaint dc r = do
t <- varGet vart
let Reversi st = state t
bsz = boardsize pr
b <- border dc (bsz, bsz)
let g = grate r b (bsz, bsz) (Size 1 1)
varSet varg g
tileBitmap dc r marble
for 0 (bsz - 1) (\i -> do
drawTextRect dc [['A' ..] !! i] $ edge g (i, -1)
drawTextRect dc [['A' ..] !! i] $ edge g (i, bsz)
drawTextRect dc (show (bsz - i)) $ edge g ( -1, i)
drawTextRect dc (show (bsz - i)) $ edge g (bsz, i)
)
drawGrate dc g [brushKind := BrushTransparent]
for 0 (bsz - 1) (\i -> for 0 (bsz - 1) (\j ->
case st ! (i, j) of Just p' -> drawPiece p' dc $ field g (i, j)
Nothing -> return ()
))
if human pr !! player t && allMoves (boardsize pr) (player t) st == [Nothing]
then wait p 1 $ do
when ia $ infoDialog p "You can't move!" "You have to skip this turn, since there are no possible moves."
move' 0
else return ()
onclick :: Point -> IO ()
onclick point' = do
t <- varGet vart
g <- varGet varg
let Reversi st = state t
n = Just $ locate g point'
case lookup n $ zip (allMoves (boardsize pr) (player t) st) [0..] of
Nothing -> return ()
Just i -> move' i
set p [ on click := onclick
, on paint := onpaint
, on resize ::= repaint
]
drawPiece :: Player -> DC () -> Rect -> IO ()
drawPiece p dc (Rect x y w h) = do
case p of 0 -> set dc [brushColor := rgb 96 16 (255 :: Int) ]
1 -> set dc [brushColor := rgb 192 64 (16 :: Int) ]
_ -> set dc [brushColor := white]
circle dc (pt (x + w `div` 2) (y + h `div` 2)) (2 * (min w h) `div` 5) []
(+-) :: Num a => (a, a) -> (a, a) -> (a, a)
(a, b) +- (c, d) = (a + c, b + d)
allMoves :: Int -> Player -> Array (Int, Int) (Maybe Player) -> [Maybe (Int, Int)]
allMoves _bsz p s
| (null $ valid p s) && (not $ null $ valid (1 - p) s) = [Nothing]
| otherwise = map Just $ valid p s
where
valid :: Player -> Array (Int, Int) (Maybe Player) -> [(Int, Int)]
valid p' s' = filter (\xy -> or $ map (scan xy) dirs) . filter ((== Nothing) . (s' !)) $ indices s'
where
dirs :: [(Int, Int)]
dirs = [(x, y) | x <- [-1 .. 1], y <- [-1 .. 1]]
scan :: (Int, Int) -> (Int, Int) -> Bool
scan xy dxy = check (xy +- dxy) (Just $ 1 - p') && scan1 (xy +- dxy) dxy
scan1 :: (Int, Int) -> (Int, Int) -> Bool
scan1 xy dxy = check (xy +- dxy) (Just p')
|| (check (xy +- dxy) (Just $ 1 - p') && scan1 (xy +- dxy) dxy)
check :: (Int, Int) -> Maybe Player -> Bool
check m f | not $ inRange (bounds s') m = False
| otherwise = s' ! m == f
move :: Int -> Maybe (Int, Int) -> (Player, Reversi) -> (Player, Reversi)
move _bsz (Just m) (p, Reversi s) = (1 - p, Reversi $ s // ((m, Just p) : concatMap (scan m) dirs))
where
dirs :: [(Int, Int)]
dirs = [(x, y) | x <- [-1 .. 1], y <- [-1 .. 1]]
scan :: (Int, Int) -> (Int, Int) -> [((Int, Int), Maybe Player)]
scan xy dxy | check (xy +- dxy) (Just $ 1 - p) = scan1 (xy +- dxy) dxy [(xy +- dxy, Just p)]
| otherwise = []
scan1 :: (Int, Int) -> (Int, Int) -> [((Int, Int), Maybe Player)] -> [((Int, Int), Maybe Player)]
scan1 xy dxy cs | check (xy +- dxy) (Just p) = cs
| check (xy +- dxy) (Just $ 1 - p) = scan1 (xy +- dxy) dxy $ (xy +- dxy, Just p) : cs
| otherwise = []
check :: (Int, Int) -> Maybe Player -> Bool
check m' f | not $ inRange (bounds s) m' = False
| otherwise = s ! m' == f
move _ Nothing (p, rs) = (1 - p, rs)