-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathMoveEval.bs
284 lines (251 loc) · 13.2 KB
/
MoveEval.bs
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
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
package MoveEval where
import Vector
import ChessState
import GetPut
import FIFO
import BuildVector
dispInBounds :: Position -> (Integer, Integer) -> Bool
dispInBounds pos (x, y) =
(if x > 0 then pos.rank <= 7 - fromInteger x else pos.rank >= fromInteger (negate x)) &&
(if y > 0 then pos.file <= 7 - fromInteger y else pos.file >= fromInteger (negate y))
dispPos :: Position -> (Integer, Integer) -> Position
dispPos pos (x, y) = Position {
rank = if x > 0 then pos.rank + fromInteger x else pos.rank - fromInteger (negate x);
file = if y > 0 then pos.file + fromInteger y else pos.file - fromInteger (negate y);
}
trace :: Board -> Position -> (Integer -> (Integer, Integer)) -> Maybe Piece
trace board pos disp =
foldr
(\ i res ->
let (x, y) = disp i
in
if dispInBounds pos (x, y)
then
case selectPos board $ dispPos pos (x, y) of
Just p -> Just p
Nothing -> res
else Nothing)
Nothing (genVector :: Vector 7 Integer)
whitePawnMoves :: Vector 2 (Integer, Integer)
whitePawnMoves = vec (negate 1, 1) (negate 1, negate 1)
blackPawnMoves :: Vector 2 (Integer, Integer)
blackPawnMoves = vec (1, 1) (1, negate 1)
kingMoves :: Vector 8 (Integer, Integer)
kingMoves = vec (negate 1, 1) (0, 1) (1, 1) (negate 1, 0) (1, 0) (negate 1, negate 1) (0, negate 1) (1, negate 1)
knightMoves :: Vector 8 (Integer, Integer)
knightMoves = vec (1, 2) (1, negate 2) (2, 1) (2, negate 1) (negate 1, 2) (negate 1, negate 2) (negate 2, 1) (negate 2, negate 1)
rankFileDisps :: Vector 4 (Integer -> (Integer, Integer))
rankFileDisps = vec (\ i -> (0, i + 1)) (\ i -> (0, negate i - 1)) (\ i -> (i + 1, 0)) (\ i -> (negate i - 1, 0))
diagonalDisps :: Vector 4 (Integer -> (Integer, Integer))
diagonalDisps = vec (\ i -> (i + 1, i + 1)) (\ i -> (i + 1, negate i - 1)) (\ i -> (negate i - 1, i + 1)) (\ i -> (negate i - 1, negate i - 1))
-- Note that this does not handle en passant, however it is currently only used
-- to determine if a King is in check or if the center is threatened,
-- thus it doesn't matter in practice.
isThreatened :: Board -> Color -> Position -> Bool
isThreatened board player pos =
let traceRankFile = map (trace board pos) rankFileDisps
traceDiagonal = map (trace board pos) diagonalDisps
isEnemyPiece piece kind = piece == Just (Piece {color=otherColor player; kind=kind;})
hasDispMove kind = any (\ d -> dispInBounds pos d && isEnemyPiece (selectPos board (dispPos pos d)) kind)
in
(case player of
-- Moves *to* the selected by the *other player*
White -> hasDispMove Pawn whitePawnMoves
Black -> hasDispMove Pawn blackPawnMoves
) ||
hasDispMove King kingMoves ||
hasDispMove Knight knightMoves ||
any (\ p -> isEnemyPiece p Queen || isEnemyPiece p Rook) traceRankFile ||
any (\ p -> isEnemyPiece p Queen || isEnemyPiece p Bishop) traceDiagonal
numThreats :: Board -> Color -> Position -> UInt 4
numThreats board player pos =
let traceRankFile = map (trace board pos) rankFileDisps
traceDiagonal = map (trace board pos) diagonalDisps
isEnemyPiece piece kind = piece == Just (Piece {color=otherColor player; kind=kind;})
countDispMove kind disp = if dispInBounds pos disp && isEnemyPiece (selectPos board (dispPos pos disp)) kind then 1 else 0
numDispMoves kind = foldr1 (+) `compose` map (countDispMove kind)
in
(case player of
-- Moves *to* the selected by the *other player*
White -> numDispMoves Pawn whitePawnMoves
Black -> numDispMoves Pawn blackPawnMoves
) +
numDispMoves King kingMoves +
numDispMoves Knight knightMoves +
foldr1 (+) (map (\ p -> if isEnemyPiece p Queen || isEnemyPiece p Rook then 1 else 0) traceRankFile) +
foldr1 (+) (map (\ p -> if isEnemyPiece p Queen || isEnemyPiece p Bishop then 1 else 0) traceDiagonal)
kingPos :: Board -> Color -> Position
kingPos board player =
let combine :: (Integer, Maybe (UInt 3)) -> Position -> Position
combine (rank, f) rest =
case f of
Just file -> Position {rank=fromInteger rank; file=file;}
Nothing -> rest
in foldr combine (Position {rank=0; file=0;}) $ zip genVector $ map (findElem (Just (Piece {color=player; kind=King;}))) board
inCheck :: Board -> Color -> Bool
inCheck board player = isThreatened board player $ kingPos board player
isOccupied :: Board -> Color -> Position -> Bool
isOccupied board player pos =
case selectPos board pos of
Just (Piece {color=p}) -> player == p
Nothing -> False
promoKinds :: Vector 4 PieceKind
promoKinds = vec Knight Bishop Rook Queen
interface MoveRule =
moveRules :: (Move -> Action) -> Rules
finished :: Bool
reset :: Action
mkMoveRule :: String -> Bool -> Move -> Module MoveRule
mkMoveRule name cond m = module
done <- mkReg False
interface
moveRules enq =
rules
name: when cond && not done ==> do
-- $display "move " (cshow m)
enq m
done := True
finished = done || not cond
reset = done := False
joinMoveRule :: MoveRule -> MoveRule -> MoveRule
joinMoveRule m1 m2 =
interface MoveRule
moveRules enq = m1.moveRules enq <+ m2.moveRules enq
finished = m1.finished && m2.finished
reset = do m1.reset
m2.reset
data MoveResponse = NextMove Move
| NoMove
deriving (Eq, Bits)
interface MoveEval =
state :: Put State
move :: GetS MoveResponse
clear :: Action
{-# verilog mkMoveEval #-}
mkMoveEval :: Module MoveEval
mkMoveEval = module
states :: FIFO State <- mkFIFO
moves :: FIFO MoveResponse <- mkFIFO
clearCommand :: PulseWire <- mkPulseWire
let state = states.first
board = state.board
turn = state.turn
hist = if turn == White then state.whiteHist else state.blackHist
otherHist = if turn == Black then state.whiteHist else state.blackHist
evalPos <- mkReg $ Position {rank=0; file=0;}
let evalPiece = selectPos board evalPos
evalPieceIs kind = evalPiece == Just (Piece {color=turn; kind=kind;})
nextFile =
foldr (\ f rest ->
let file = fromInteger f + 1
in
if file > evalPos.file
then case selectPos board $ Position {rank=evalPos.rank; file=file;} of
Just piece -> if piece.color == turn then Just $ fromInteger file else rest
Nothing -> rest
else rest
) Nothing (genVector :: Vector 7 Integer)
let pawnDirection = if turn == White then (-) else (+)
homeRank = if turn == White then 7 else 0
pawnHomeRank = if turn == White then 6 else 1
enPassantRank = if turn == White then 3 else 4
promoRank = if turn == White then 0 else 7
kingStartPos = Position {rank=homeRank; file=4;}
open :: Position -> Bool
open pos =
case selectPos board pos of
Just _ -> False
Nothing -> True
capturable :: Position -> Bool
capturable pos =
case selectPos board pos of
Just p -> p.color /= turn
Nothing -> False
moveRules =
concat (map (\ kind -> vec
(let pos = Position {rank=evalPos.rank `pawnDirection` 1; file=evalPos.file}
in mkMoveRule "pawn_promo" (evalPieceIs Pawn && pos.rank == promoRank && open pos) $ Promote {kind=kind; from=evalPos; to=pos;})
(let pos = Position {rank=evalPos.rank `pawnDirection` 1; file=evalPos.file - 1}
in mkMoveRule "pawn_promo_capture_left" (evalPieceIs Pawn && pos.rank == promoRank && evalPos.file > 0 && capturable pos) $ Promote {kind=kind; from=evalPos; to=pos;})
(let pos = Position {rank=evalPos.rank `pawnDirection` 1; file=evalPos.file + 1}
in mkMoveRule "pawn_promo_capture_right" (evalPieceIs Pawn && pos.rank == promoRank && evalPos.file < 7 && capturable pos) $ Promote {kind=kind; from=evalPos; to=pos;})) promoKinds)
`append` vec
(let pos = Position {rank=evalPos.rank `pawnDirection` 1; file=evalPos.file}
in mkMoveRule "pawn_advance" (evalPieceIs Pawn && pos.rank /= promoRank && open pos) $ Move {from=evalPos; to=pos;})
(let pos1 = Position {rank=evalPos.rank `pawnDirection` 1; file=evalPos.file}
pos2 = Position {rank=evalPos.rank `pawnDirection` 2; file=evalPos.file}
in mkMoveRule "pawn_advance_2" (evalPieceIs Pawn && evalPos.rank == pawnHomeRank && open pos1 && open pos2) $ Move {from=evalPos; to=pos2;})
(let pos = Position {rank=evalPos.rank `pawnDirection` 1; file=evalPos.file - 1}
in mkMoveRule "pawn_capture_left" (evalPieceIs Pawn && pos.rank /= promoRank && evalPos.file > 0 && capturable pos) $ Move {from=evalPos; to=pos;})
(let pos = Position {rank=evalPos.rank `pawnDirection` 1; file=evalPos.file + 1}
in mkMoveRule "pawn_capture_right" (evalPieceIs Pawn && pos.rank /= promoRank && evalPos.file < 7 && capturable pos) $ Move {from=evalPos; to=pos;})
(let capturePos = Position {rank=evalPos.rank; file=evalPos.file - 1}
movePos = Position {rank=evalPos.rank `pawnDirection` 1; file=evalPos.file - 1}
in mkMoveRule "pawn_enpassant_left" (evalPieceIs Pawn && evalPos.rank == enPassantRank && otherHist.pawnMoved2 == Just movePos.file && evalPos.file > 0 && capturable capturePos) $ EnPassant {from=evalPos; to=movePos;})
(let capturePos = Position {rank=evalPos.rank; file=evalPos.file + 1}
movePos = Position {rank=evalPos.rank `pawnDirection` 1; file=evalPos.file + 1}
in mkMoveRule "pawn_enpassant_right" (evalPieceIs Pawn && evalPos.rank == enPassantRank && otherHist.pawnMoved2 == Just movePos.file && evalPos.file > 0 && capturable capturePos) $ EnPassant {from=evalPos; to=movePos;})
`append` map (\ d ->
let pos = dispPos evalPos d
in mkMoveRule "king_move" (evalPieceIs King && dispInBounds evalPos d && (open pos || capturable pos)) $ Move {from=evalPos; to=pos;}) kingMoves
`append` map (\ d ->
let pos = dispPos evalPos d
in mkMoveRule "knight_move" (evalPieceIs Knight && dispInBounds evalPos d && (open pos || capturable pos)) $ Move {from=evalPos; to=pos;}) knightMoves
`append` concat (map (\ df -> map (\ i ->
let d = df i
pos = dispPos evalPos $ d
reachable = List.all (\ j -> open $ dispPos evalPos $ df j) $ List.upto 0 (i - 1)
cond = (evalPieceIs Rook || evalPieceIs Queen) && dispInBounds evalPos d && (open pos || capturable pos) && reachable
in mkMoveRule "rank_file_move" cond $ Move {from=evalPos; to=pos;})
(genVector :: Vector 7 Integer)) rankFileDisps)
`append` concat (map (\ df -> map (\ i ->
let d = df i
pos = dispPos evalPos $ d
reachable = List.all (\ j -> open $ dispPos evalPos $ df j) $ List.upto 0 (i - 1)
cond = (evalPieceIs Bishop || evalPieceIs Queen) && dispInBounds evalPos d && (open pos || capturable pos) && reachable
in mkMoveRule "diagonal_move" cond $ Move {from=evalPos; to=pos;})
(genVector :: Vector 7 Integer)) diagonalDisps)
`append` vec
(let kingPath = vec kingStartPos (Position {rank=homeRank; file=3;}) (Position {rank=homeRank; file=2;})
between = vec (Position {rank=homeRank; file=1;}) (Position {rank=homeRank; file=2;}) (Position {rank=homeRank; file=3;})
threat = any (isThreatened state.board state.turn) kingPath
clear = all open between
in mkMoveRule "castle_queenside" (evalPos == kingStartPos && not hist.kingMoved && not hist.qRookMoved && not threat && clear) $ Castle {kingSide=False})
(let kingPath = vec kingStartPos (Position {rank=homeRank; file=5;}) (Position {rank=homeRank; file=6;})
between = vec (Position {rank=homeRank; file=5;}) (Position {rank=homeRank; file=6;})
threat = any (isThreatened state.board state.turn) kingPath
clear = all open between
in mkMoveRule "castle_kingside" (evalPos == kingStartPos && not hist.kingMoved && not hist.kRookMoved && not threat && clear) $ Castle {kingSide=True})
moveEval <- liftM (foldr1 joinMoveRule) $ sequence moveRules
addRules $
(rules
"clear": when clearCommand ==> do
states.clear
moves.clear
evalPos := Position {rank = 0; file = 0;}
moveEval.reset
) <+
moveEval.moveRules (moves.enq `compose` NextMove) <+
rules
when moveEval.finished
rules
"next_file": when Just file <- nextFile ==> do
-- $display "next_file " file
evalPos := Position {rank=evalPos.rank; file=file;}
moveEval.reset
when Nothing <- nextFile
rules
"next_rank": when evalPos.rank < 7 ==> do
-- $display "next_rank " (evalPos.rank + 1)
evalPos := Position {rank = evalPos.rank + 1; file = 0;}
moveEval.reset
"reset": when evalPos.rank == 7 ==> do
-- $display "reset"
evalPos := Position {rank = 0; file = 0;}
moveEval.reset
moves.enq NoMove
states.deq
interface
state = toPut states
move = fifoToGetS moves
clear = clearCommand.send