-
Notifications
You must be signed in to change notification settings - Fork 7
/
Legality.hs
101 lines (95 loc) · 4.98 KB
/
Legality.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
module Main where
import System.Environment
import Chess.Position
import Data.Maybe
import Data.Char
import Data.List
import qualified Data.Map as M
import Data.Array
-- the dark colored squares
darkSquares :: [Square]
darkSquares = filter isDark boardSquares where
isDark c = let (y,x) = c `divMod` 8 in odd x /= odd y
-- spare room for promotions
spareProms :: Diagram -> (Int, String)
spareProms diag = let
nkSymbols = "PQRBNpqrbn" -- non king squares
zerocnts = zip nkSymbols (repeat 0)
cnts = M.fromListWith (+) $ zerocnts ++ zip (elems diag) (repeat 1)
nkcnts = map (cnts M.!) nkSymbols
[wp,wq,wr,wb,wn,bp,bq,br,bb,bn] = nkcnts
darkcnts = M.fromListWith (+) $ zerocnts ++ zip (map (diag!) darkSquares) (repeat 1)
(pwb,pbb) = (bishopProms wb (darkcnts M.! 'B'), bishopProms bb (darkcnts M.! 'b')) where
bishopProms tot dark = if dark > 0 && tot-dark > 0 then tot-2 else tot-1
wproms = sum . map (max 0) $ [wq-1,wr-2,pwb,wn-2]
bproms = sum . map (max 0) $ [bq-1,br-2,pbb,bn-2]
tot = 2 + sum nkcnts -- add kings back
wx = 15 - sum (take 5 nkcnts)
bx = 15 - sum (drop 5 nkcnts)
wpx = 8 - wp - wproms -- white pawns captured
bpx = 8 - bp - bproms -- black pawns captured
caps = 32 - tot
maxuwp = bpx + caps - wproms
maxubp = wpx + caps - bproms
minopp = wp - maxuwp
nOppFiles = length . filter (not . null) . mkOpps $ diag
spare = if wpx >= 0 && bpx >= 0 then nOppFiles - minopp else -1
stats = "\t wx " ++ show wx ++ " wp " ++ show wp ++ " wpr " ++ show wproms ++ " wpx " ++ show wpx ++ " maxuwp " ++ show maxuwp ++ " minopp " ++ show minopp ++
"\t bx " ++ show bx ++ " bp " ++ show bp ++ " bpr " ++ show bproms ++ " bpx " ++ show bpx ++ " maxubp " ++ show maxubp ++ " minopp " ++ show minopp
in (spare, stats)
-- list opponent pieces checking target coord
checks :: Diagram -> Square -> [(Symbol, (Int, Int))]
checks diag king = let
(ky, kx) = king `divMod` 8
onW = isUpper (diag!king)
dP = if onW then [(-1,-1),(1,-1)] else [(1,1),(-1,1)]
dN = [(2,1),(1,2),(-1,2),(-2,1),(-2,-1),(-1,-2),(1,-2),(2,-1)]
dBQ = [(1,1),(-1,1),(-1,-1),(1,-1)]
dRQ = [(1,0),(0,1),(-1,0),(0,-1)]
toSquare (x,y) = y * 8 + x
inRange x = x >= 0 && x < 8
onBoard (x,y) = inRange x && inRange y
ray (dx,dy) = map (\xy -> (diag!toSquare xy, xy)) . takeWhile onBoard . map (\i -> (kx+i*dx, ky+i*dy)) $ [1..]
neray = filter ((/= emptySymbol) . fst) . ray -- non empty ray
toOpp = if onW then toLower else toUpper
in [ x | (x@(sq,_):_) <- map ray dP , sq == toOpp 'p'] ++
[ x | (x@(sq,_):_) <- map ray dN , sq == toOpp 'n'] ++
[ x | (x@(sq,_):_) <- map neray dBQ, sq == toOpp 'b' || sq == toOpp 'q'] ++
[ x | (x@(sq,_):_) <- map neray dRQ, sq == toOpp 'r' || sq == toOpp 'q']
-- research legality
research :: Position -> String
research (Position { diagram = diag, sideToMove = stm, castlings = c, enPassant = ep }) = let
[wk, bk] = map (\sq -> fst . fromJust . find (\(i,x)-> x==sq) . assocs $ diag) "Kk"
wtm = stm == 'w'
(ktm,kntm) = if wtm then (wk,bk) else (bk,wk) -- to move or not to move
[(yktm, xktm), (ykntm, xkntm)] = map (`divMod` 8) [ktm, kntm]
adjacentKings = abs (xktm - xkntm) <= 1 && abs (yktm - ykntm) <= 1
(checksOnTM, checksOnNTM) = (checks diag ktm, checks diag kntm)
(tmInCheck, ntmInCheck) = (not (null checksOnTM), not (null checksOnNTM))
checkingpcs = sort . map (toLower . fst) $ checksOnTM
[(x0,y0),(x1,y1)] = map (\(_,(x,y)) -> (x-xktm, y-yktm)) checksOnTM
(innerProd, taxiCab) = (x0*x1 + y0*y1, sum (map abs [x0,y0,x1,y1]))
(sharpAngle, rightAngle) = (innerProd > 0, innerProd == 0)
minDist = M.fromList [("bb",99),("bn",7),("bp",99),("bq",5),("br",5),("nn",99),("np",99),("nq",6),("nr",6),("pp",99),("pq",5),("pr",5),("qq",99),("qr",5),("rr",99)]
discoverable = taxiCab >= minDist M.! checkingpcs
promRowCheckers = filter (\(_,(_,y)) -> y == if wtm then 7 else 0) checksOnTM
kDistToPromRow = if wtm then 7-yktm else yktm
(slack, stats) = spareProms diag
promRowLegal = case length promRowCheckers of
0 -> sharpAngle && discoverable
1 -> (rightAngle && taxiCab > 2 && kDistToPromRow <= 1 && slack > 0)
|| (sharpAngle && (discoverable || kDistToPromRow == 1))
2 -> sharpAngle && (discoverable || (kDistToPromRow == 2 && slack > 0))
doubleCheck = if checkingpcs == "nn" then "Illegal Double Knight Check"
else if promRowLegal then ("Discovered Double Check" ++ stats)
else "Illegal Double Check"
in if adjacentKings then "Illegal Adjacent Kings" else
if tmInCheck && ntmInCheck then "Illegal Both Kings in Check" else
if ntmInCheck then "Illegal Side not to move in Check" else
if length checkingpcs > 2 then "Illegal Triple Check" else
if slack < 0 then ("Illegal Bishops Too Monochromatic" ++ stats) else
if length checkingpcs == 2 then doubleCheck else
(if length checkingpcs == 1 then "Single Check" else "No Checks") ++ stats
main = do
let legality = map (\fen -> fen ++ "\t " ++ research (readFEN fen))
getContents >>= mapM_ putStrLn . legality . filter (not . null) . lines