Skip to content

Commit

Permalink
Minor promotions + some refactor for them
Browse files Browse the repository at this point in the history
  • Loading branch information
@nionita
nionita committed May 3, 2024
1 parent 705a0f3 commit 3b8197b
Show file tree
Hide file tree
Showing 5 changed files with 108 additions and 138 deletions.
2 changes: 1 addition & 1 deletion Main/Barbarossa.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -39,7 +39,7 @@ progName, progVersion, progVerSuff, progAuthor :: String
progName = "Barbarossa"
progAuthor = "Nicu Ionita"
progVersion = "0.7.0"
progVerSuff = "defi2"
progVerSuff = "promo"

data Options = Options {
optConfFile :: Maybe String, -- config file
Expand Down
10 changes: 5 additions & 5 deletions Moves/Base.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -88,11 +88,11 @@ genMoves d = do
else do
h <- gets hist
let l0 = genMoveCast p
l1 = genMovePromo p
(l1q, l1r) = genMovePromo p
(l2w, l2l) = genMoveCaptWL p
l3 = histSortMoves d h $ genMoveNCapt p
-- Loosing captures after non-captures
return (l1 ++ l2w, l0 ++ l3 ++ l2l)
return (l1q ++ l2w, l1r ++ l0 ++ l3 ++ l2l)

-- Generate only tactical moves, i.e. promotions & captures
-- Needed only in QS, when we know we are not in check
Expand All @@ -101,12 +101,12 @@ genMoves d = do
genTactMoves :: Bool -> Game [Move]
genTactMoves front = do
p <- getPos
let l1 = genMovePromo p
let (l1q, _) = genMovePromo p
l2w = fst $ genMoveCaptWL p
l3 = genMoveNCaptToCheck p
if front
then return $ l1 ++ l2w ++ l3
else return $ l1 ++ l2w
then return $ l1q ++ l2w ++ l3
else return $ l1q ++ l2w

-- Generate only escape moves: needed only in QS when we know we have to escape
genEscapeMoves :: Game [Move]
Expand Down
153 changes: 70 additions & 83 deletions Moves/Board.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16,6 +16,7 @@ import Data.List (sort, foldl')
import Data.Word

import Struct.Struct
import Moves.Pattern
import Moves.Moves
import Moves.BitBoard
import Moves.ShowMe
Expand All @@ -36,14 +37,6 @@ isCheck p Black | check p .&. black p == 0 = False
inCheck :: MyPos -> Bool
inCheck = (/= 0) . check

{--
goPromo :: MyPos -> Move -> Bool
goPromo p m
| moveIsPromo m = True
| movePassed p m = True
| otherwise = False
--}

{-# INLINE movePassed #-}
movePassed :: MyPos -> Move -> Bool
movePassed p m = passed p .&. (uBit $ fromSquare m) /= 0
Expand All @@ -56,13 +49,11 @@ moveGenAscendent = True
genMoveNCapt :: MyPos -> [Move]
genMoveNCapt !p
| moveGenAscendent
= map (moveAddColor c) $ nGenNC ++ bGenNC ++ rGenNC ++ qGenNC ++ pGenNC1 ++ pGenNC2 ++ kGenNC
= map (moveAddColor c) $ nGenNC ++ bGenNC ++ rGenNC ++ qGenNC ++ pGenNC ++ kGenNC
| otherwise
= map (moveAddColor c) $ qGenNC ++ rGenNC ++ bGenNC ++ nGenNC ++ pGenNC1 ++ pGenNC2 ++ kGenNC
where pGenNC1 = map (moveAddPiece Pawn . uncurry moveFromTo)
$ pAll1Moves c (pawns p .&. me p .&. traR) (occup p)
pGenNC2 = map (moveAddPiece Pawn . uncurry moveFromTo)
$ pAll2Moves c (pawns p .&. me p) (occup p)
= map (moveAddColor c) $ qGenNC ++ rGenNC ++ bGenNC ++ nGenNC ++ pGenNC ++ kGenNC
where pGenNC = map (moveAddPiece Pawn . uncurry moveFromTo)
$ targetPawnMoves c (pawns p .&. me p) (occup p) regPawnsBB
nGenNC = map (moveAddPiece Knight . uncurry moveFromTo)
$ concatMap (srcDests (ncapt . nAttacs))
$ bbToSquares $ knights p .&. me p
Expand All @@ -82,20 +73,19 @@ genMoveNCapt !p
ncapt = ((.&.) noccup)
!nyoa = complement $ yoAttacs p
legal = ((.&.) nyoa)
!traR = complement $ if c == White then 0x00FF000000000000 else 0xFF00
c = moving p

-- Generate only promotions (now only to queen) non captures
-- Generate only non capture promotions
-- The promotion captures are generated together with the other captures
genMovePromo :: MyPos -> [Move]
genMovePromo !p = map (uncurry (makePromo Queen)) pGenNC
where -- pGenC = concatMap (srcDests (pcapt . pAttacs c))
-- $ bbToSquares $ pawns p .&. myfpc
pGenNC = pAll1Moves c (pawns p .&. myfpc) (occup p)
!myfpc = me p .&. traR
-- pcapt = (.&. yo p)
!traR = if c == White then 0x00FF000000000000 else 0xFF00
c = moving p
genMovePromo :: MyPos -> ([Move], [Move])
genMovePromo !p = (toQueen, toRook ++ toBishop ++ toKnight)
where toQueen = map (uncurry (makePromo Queen)) ftlist
toRook = map (uncurry (makePromo Rook)) ftlist
toBishop = map (uncurry (makePromo Bishop)) ftlist
toKnight = map (uncurry (makePromo Knight)) ftlist
ftlist = targetPawnMoves (moving p) (pawns p .&. me p) (occup p) promoline
!promoline | moving p == White = row8
| otherwise = row1

{-# INLINE srcDests #-}
srcDests :: (Square -> BBoard) -> Square -> [(Square, Square)]
Expand Down Expand Up @@ -145,21 +135,22 @@ data CheckInfo = NormalCheck Piece !Square

-- Finds pieces which check
findChecking :: MyPos -> [CheckInfo]
findChecking !pos = concat [ pChk, nChk, bChk, rChk, qbChk, qrChk ]
findChecking !pos = concat [pChk, nChk, bChk, rChk, qbChk, qrChk]
where pChk = map (NormalCheck Pawn) $ bbToSquares $ pAttacs (moving pos) ksq .&. p
nChk = map (NormalCheck Knight) $ bbToSquares $ nAttacs ksq .&. n
bChk = map (NormalCheck Bishop) $ bbToSquares $ bAttacs occ ksq .&. b
rChk = map (NormalCheck Rook) $ bbToSquares $ rAttacs occ ksq .&. r
qbChk = map (QueenCheck Bishop) $ bbToSquares $ bAttacs occ ksq .&. q
qrChk = map (QueenCheck Rook) $ bbToSquares $ rAttacs occ ksq .&. q
!myk = kings pos .&. me pos
!ksq = firstOne myk
!occ = occup pos
bChk = map (NormalCheck Bishop) $ bbToSquares $ ba .&. b
rChk = map (NormalCheck Rook) $ bbToSquares $ ra .&. r
qbChk = map (QueenCheck Bishop) $ bbToSquares $ ba .&. q
qrChk = map (QueenCheck Rook) $ bbToSquares $ ra .&. q
occ = occup pos
!ksq = firstOne $ kings pos .&. me pos
!b = bishops pos .&. yo pos
!r = rooks pos .&. yo pos
!q = queens pos .&. yo pos
!r = rooks pos .&. yo pos
!q = queens pos .&. yo pos
!n = knights pos .&. yo pos
!p = pawns pos .&. yo pos
!p = pawns pos .&. yo pos
ra = rAttacs occ ksq
ba = bAttacs occ ksq

-- Generate move when in check
genMoveFCheck :: MyPos -> [Move]
Expand All @@ -180,11 +171,11 @@ genMoveFCheck !p
chkAtt (QueenCheck f s) = fAttacs s f ocp1
-- This head is safe becase chklist is first checked in the pattern of the function
(r1, r2) = case head chklist of -- this is needed only when simple check
NormalCheck Pawn sq -> (beatAtP p (uBit sq), []) -- cannot block pawn
NormalCheck Pawn sq -> (beatAtP p (uBit sq), []) -- cannot block pawn
NormalCheck Knight sq -> (beatAt p (uBit sq), []) -- or knight check
NormalCheck Bishop sq -> beatOrBlock Bishop p sq
NormalCheck Rook sq -> beatOrBlock Rook p sq
QueenCheck pt sq -> beatOrBlock pt p sq
NormalCheck Rook sq -> beatOrBlock Rook p sq
QueenCheck pt sq -> beatOrBlock pt p sq
_ -> error "genMoveFCheck: what check?"

-- Generate moves ending on a given square (used to defend a check by capture or blocking)
Expand All @@ -206,42 +197,39 @@ defendAt p !bb = map (moveAddColor $ moving p) $ nGenC ++ bGenC ++ rGenC ++ qGen
target = (.&. bb)

-- Generate capture pawn moves ending on a given square (used to defend a check by capture)
-- The bitboard represents the piece which checks (only 1 bit set)
pawnBeatAt :: MyPos -> BBoard -> [Move]
pawnBeatAt !p bb = map (uncurry (makePromo Queen))
(concatMap
(srcDests (pcapt . pAttacs (moving p)))
(bbToSquares promo))
++ map (moveAddColor (moving p) . moveAddPiece Pawn . uncurry moveFromTo)
(concatMap
(srcDests (pcapt . pAttacs (moving p)))
(bbToSquares rest))
where !yopi = bb .&. yo p
pcapt = (.&. yopi)
(promo, rest) = promoRest p
pawnBeatAt !p !bb
| bb .&. myPAttacs p == 0 = [] -- none of my pawns attack the checking piece
| bb .&. lastline /= 0 -- pawn attacks on last line: generate promotions
= map (uncurry (makePromo Queen)) ftlist
++ map (uncurry (makePromo Rook)) ftlist
++ map (uncurry (makePromo Bishop)) ftlist
++ map (uncurry (makePromo Knight)) ftlist
| otherwise = map (moveAddColor (moving p) . moveAddPiece Pawn . uncurry moveFromTo) ftlist
where lastline | moving p == White = row8
| otherwise = row1
checksq = firstOne bb
attpwbb = pAttacs (other $ moving p) checksq .&. pawns p .&. me p
ftlist = map (\s -> (s, checksq)) $ bbToSquares attpwbb

-- Generate blocking pawn moves ending on given squares (used to defend a check by blocking)
-- The bitboard has one or more quares
-- The moves generated here cannot be captures!
-- When we block on the last line, we generate a promotion - in this case the whole blocking
-- line is on the last line - so we can have either promnotion blocks or normal ones,
-- but never both of them
pawnBlockAt :: MyPos -> BBoard -> [Move]
pawnBlockAt p !bb = map (uncurry (makePromo Queen))
(concatMap
(srcDests (block . \s -> pMovs s (moving p) (occup p)))
(bbToSquares promo))
++ map (moveAddColor (moving p) . moveAddPiece Pawn . uncurry moveFromTo)
(concatMap
(srcDests (block . \s -> pMovs s (moving p) (occup p)))
(bbToSquares rest))
where block = (.&. bb)
(promo, rest) = promoRest p

promoRest :: MyPos -> (BBoard, BBoard)
promoRest p
| moving p == White
= let prp = mypawns .&. 0x00FF000000000000
rea = mypawns `less` prp
in (prp, rea)
| otherwise = let prp = mypawns .&. 0xFF00
rea = mypawns `less` prp
in (prp, rea)
where !mypawns = pawns p .&. me p
pawnBlockAt p !bb
| bb .&. lastline /= 0
= map (uncurry (makePromo Queen)) ftlist
++ map (uncurry (makePromo Rook)) ftlist
++ map (uncurry (makePromo Bishop)) ftlist
++ map (uncurry (makePromo Knight)) ftlist
| otherwise = map (moveAddColor (moving p) . moveAddPiece Pawn . uncurry moveFromTo) ftlist
where lastline | moving p == White = row8
| otherwise = row1
ftlist = targetPawnMoves (moving p) (pawns p .&. me p) (occup p) bb

beatAt :: MyPos -> BBoard -> [Move]
beatAt p !bb = pawnBeatAt p bb ++ defendAt p bb
Expand All @@ -256,10 +244,10 @@ blockAt p !bb = pawnBlockAt p bb ++ defendAt p bb
-- Defend a check from a sliding piece: beat it or block it
beatOrBlock :: Piece -> MyPos -> Square -> ([Move], [Move])
beatOrBlock f !p sq = (beat, block)
where !beat = beatAt p $ uBit sq
!aksq = firstOne $ me p .&. kings p
!line = findLKA f aksq sq
!block = blockAt p line
where beat = beatAt p $ uBit sq
aksq = firstOne $ me p .&. kings p
line = findLKA f aksq sq
block = blockAt p line

genMoveNCaptToCheck :: MyPos -> [Move]
genMoveNCaptToCheck p = genMoveNCaptDirCheck p ++ genMoveNCaptIndirCheck p
Expand Down Expand Up @@ -461,11 +449,8 @@ moveIsCapture p m = occup p .&. (uBit (toSquare m)) /= 0

canMove :: Piece -> MyPos -> Square -> Square -> Bool
canMove Pawn p src dst
| (src - dst) .&. 0x7 == 0 = elem dst $
map snd $ pAll1Moves col pw (occup p) ++ pAll2Moves col pw (occup p)
| otherwise = pAttacs col src `uTestBit` dst
where col = moving p
pw = uBit src
= (not $ null $ targetPawnMoves (moving p) (uBit src) (occup p) (uBit dst))
|| pAttacs (moving p) src `uTestBit` dst
canMove fig p src dst = fAttacs src fig (occup p) `uTestBit` dst

-- See http://stackoverflow.com/questions/47981/how-do-you-set-clear-and-toggle-a-single-bit-in-c-c
Expand Down Expand Up @@ -627,7 +612,7 @@ reverseMoving p = updatePos p { epcas = tepcas, zobkey = z }
accumMoving p
]

-- find pinning lines for a piece type, given the king & piece squares
-- Find pinning lines for a piece type, given the king & piece squares
-- the queen is very hard, so we solve it as a composition of rook and bishop
-- and when we call findLKA we always know as which piece the queen checks
{-# INLINE findLKA #-}
Expand Down Expand Up @@ -843,14 +828,15 @@ approximateEasyCapts = True -- when capturing a better piece: no SEE, it is alwa
perCaptWL :: MyPos -> Attacks -> Bool -> Piece -> Int -> Square -> Square
-> ([LMove], [LMove]) -> ([LMove], [LMove])
perCaptWL !pos !attacks promo vict !gain0 !sq !sqfa (wsqs, lsqs)
| promo = ((moveToLMove Pawn vict $ makePromo Queen sqfa sq) : wsqs, lsqs)
| promo = (map (moveToLMove Pawn vict) promos ++ wsqs, lsqs)
| approx || adv <= gain0 = (ss:wsqs, lsqs)
| otherwise = (wsqs, ss:lsqs)
where ss = moveToLMove attc vict $ moveAddPiece attc $ moveFromTo sqfa sq
approx = approximateEasyCapts && gain0 >= v0
Busy _ attc = tabla pos sqfa
v0 = seeValue attc
adv = seeMoveValue pos attacks sqfa sq v0
promos = map (\p -> makePromo p sqfa sq) [Queen, Rook, Bishop, Knight]

-- Captures of hanging pieces are always winning
addHanging :: MyPos -> Piece -> Square -> Square -> ([LMove], [LMove]) -> ([LMove], [LMove])
Expand All @@ -859,7 +845,8 @@ addHanging pos vict to from (wsqs, lsqs)
where Busy _ apiece = tabla pos from

addHangingP :: Piece -> Square -> Square -> ([LMove], [LMove]) -> ([LMove], [LMove])
addHangingP vict to from (wsqs, lsqs) = ((moveToLMove Pawn vict $ makePromo Queen from to) : wsqs, lsqs)
addHangingP vict to from (wsqs, lsqs) = (map (moveToLMove Pawn vict) promos ++ wsqs, lsqs)
where promos = map (\p -> makePromo p from to) [Queen, Rook, Bishop, Knight]

filtQPSEE :: MyPos -> Piece -> [(Square, Square)] -> [(Square, Square)]
filtQPSEE !pos piece = filter (quietPositiveSEE pos v0)
Expand Down
76 changes: 28 additions & 48 deletions Moves/Moves.hs
View file
Original file line number Diff line number Diff line change
@@ -1,10 +1,7 @@
{-# LANGUAGE BangPatterns #-}
module Moves.Moves (
movesInit, pAttacs, pawnWhiteAttacks, pawnBlackAttacks,
fAttacs,
pMovs,
kAttacs, qAttacs, rAttacs, bAttacs, nAttacs,
pAll1Moves, pAll2Moves
movesInit, pAttacs, pawnWhiteAttacks, pawnBlackAttacks, targetPawnMoves,
fAttacs, kAttacs, qAttacs, rAttacs, bAttacs, nAttacs
) where

import Data.Array.Base
Expand Down Expand Up @@ -81,30 +78,6 @@ rAttacs = smoves rookMoves
bAttacs = smoves bishopMoves
qAttacs occ sq = smoves bishopMoves occ sq .|. smoves rookMoves occ sq

-- The moves of a white pawn (no captures)
pawnSlideW :: Square -> BBoard -> BBoard
pawnSlideW !sq oc
| bb1 .&. oc /= 0 = 0
| row /= sec || bb2 .&. oc /= 0 = bb1
| otherwise = bb12
where bb1 = 1 `unsafeShiftL` (sq + 8)
!bb2 = bb1 `unsafeShiftL` 8
!bb12 = bb1 .|. bb2
!row = sq `unsafeShiftR` 3
sec = 1

-- The moves of a black pawn (no captures)
pawnSlideB :: Square -> BBoard -> BBoard
pawnSlideB !sq oc
| bb1 .&. oc /= 0 = 0
| row /= sec || bb2 .&. oc /= 0 = bb1
| otherwise = bb12
where bb1 = 1 `unsafeShiftL` (sq - 8) -- here L is ok! Replaces a 'bit sq `shiftR` 8'
!bb2 = bb1 `unsafeShiftR` 8
!bb12 = bb1 .|. bb2
!row = sq `unsafeShiftR` 3
sec = 6

-- Pawn attacs
pawnWhiteAttacks, pawnBlackAttacks :: BBoard -> BBoard
pawnWhiteAttacks !b = (bbLeft b .|. bbRight b) `unsafeShiftL` 8
Expand All @@ -117,25 +90,32 @@ pAttacs White sq = pawnWhiteAttacks $ uBit sq
pAttacs Black sq = pawnBlackAttacks $ uBit sq
{-# INLINE pAttacs #-}

pMovs :: Square -> Color -> BBoard -> BBoard
pMovs s White o = pawnSlideW s o
pMovs s Black o = pawnSlideB s o

pAll1Moves :: Color -> BBoard -> BBoard -> [(Square, Square)]
pAll1Moves White !ps !occ = map f $ bbToSquares $ (ps `unsafeShiftL` 8) `less` occ
where f !x = (x - 8, x)
pAll1Moves Black !ps !occ = map f $ bbToSquares $ (ps `unsafeShiftR` 8) `less` occ
where f !x = (x + 8, x)

pAll2Moves :: Color -> BBoard -> BBoard -> [(Square, Square)]
pAll2Moves White ps occ = map f $ bbToSquares $ (ps2 `unsafeShiftL` 16) `less` occ2
where ps2 = ps .&. 0x000000000000FF00
occ2 = occ .|. (occ `unsafeShiftL` 8)
f !x = (x - 16, x)
pAll2Moves Black ps occ = map f $ bbToSquares $ (ps2 `unsafeShiftR` 16) `less` occ2
where ps2 = ps .&. 0x00FF000000000000
occ2 = occ .|. (occ `unsafeShiftR` 8)
f !x = (x + 16, x)
-- From / to regular pawn moves (no captures) to the given squares (bitboard)
-- Used to block a check by a pawn move
-- Because some pawns can be moved 2 squares, we must have the occupancy
-- We go back from the target squares to find the source squares
{-# INLINE targetPawnMoves #-}
targetPawnMoves :: Color -> BBoard -> BBoard -> BBoard -> [(Square, Square)]
targetPawnMoves White pws occ bb = pAll1Moves White (pws .&. bb1) ++ pAll2Moves White (pws .&. bb2)
where bb1 = (bb `less` occ) `unsafeShiftR` 8
bb2 = ((bb1 `less` occ) `unsafeShiftR` 8) .&. row2
targetPawnMoves Black pws occ bb = pAll1Moves Black (pws .&. bb1) ++ pAll2Moves Black (pws .&. bb2)
where bb1 = (bb `less` occ) `unsafeShiftL` 8
bb2 = ((bb1 `less` occ) `unsafeShiftL` 8) .&. row7

-- Generate from / to regular pawn moves with 1 step, given only pawns that are not blocked
-- This is not the general case! To generate all possible pawn moves, use targetPawnMoves with
-- whole board (0xFFFF...) as a target
pAll1Moves :: Color -> BBoard -> [(Square, Square)]
pAll1Moves White ps = map (\x -> (x - 8, x)) $ bbToSquares $ ps `unsafeShiftL` 8
pAll1Moves Black ps = map (\x -> (x + 8, x)) $ bbToSquares $ ps `unsafeShiftR` 8

-- Generate from / to regular pawn moves with 2 steps, given only pawns on second rank that are not blocked
-- This is not the general case! To generate all possible pawn moves, use targetPawnMoves with
-- whole board (0xFFFF...) as a target
pAll2Moves :: Color -> BBoard -> [(Square, Square)]
pAll2Moves White ps = map (\x -> (x - 16, x)) $ bbToSquares $ ps `unsafeShiftL` 16
pAll2Moves Black ps = map (\x -> (x + 16, x)) $ bbToSquares $ ps `unsafeShiftR` 16

{-# INLINE fAttacs #-}
fAttacs :: Square -> Piece -> BBoard -> BBoard -- piece attacs except pawn
Expand Down
Loading

0 comments on commit 3b8197b

Please sign in to comment.