stat_moves_white <- function(moves){
x <- gsub("([0-9+]{0,}\\.)","",moves,perl = T)
x <- trimws(gsub(" "," ",x))
sx <- strsplit(x," ")
r <- data.frame(t(sapply(sx,function(i){
li <- length(i)
if(li>0) return(as.vector(unlist(table(substr(i[seq(1,li,by = 2)],1,1))[c("B","K","N","O","Q","R")])))
else return(rep(0, times = 6))
} )),row.names = NULL)
r[is.na(r)]<-0
colnames(r) <- paste0(c("B","K","N","O","Q","R"),"_moves")
r$R_moves <- r$R_moves + r$O_moves
r$K_moves <- r$K_moves + r$O_moves
colnames(r) <- paste0("W_",colnames(r))
return(r)
}
stat_moves_black <- function(moves){
x <- gsub("([0-9+]{0,}\\.)","",moves,perl = T)
x <- trimws(gsub(" "," ",x))
sx <- strsplit(x," ")
r <- data.frame(t(sapply(sx,function(i){
li <- length(i)
if(li>1) sli <- seq(2,li,by = 2)
else sli <- 0
if(li>1) return(as.vector(unlist(table(substr(i[sli],1,1))[c("B","K","N","O","Q","R")])))
else return(rep(0, times = 6))
} )),row.names = NULL)
r[is.na(r)]<-0
colnames(r) <- paste0(c("B","K","N","O","Q","R"),"_moves")
r$R_moves <- r$R_moves + r$O_moves
r$K_moves <- r$K_moves + r$O_moves
colnames(r) <- paste0("B_",colnames(r))
return(r)
}
#### SAN2LAN & LAN2SAN
position.move <- function(position,r1,c1,r2,c2,p = NA){
p1 <- position[r1,c1]
p2 <- position[r2,c2]
position[r2,c2] <- position[r1,c1]
position[r1,c1] <- 0
# castling
if(abs(p1)==6 & abs(c1-c2)>1){
# short castling
if(c2 == 7) {
position[r1,6] <- position[r1,8]
position[r1,8] <- 0
}
# long castling
if(c2 == 3) {
position[r1,4] <- position[r1,1]
position[r1,1] <- 0
}
}
# en passant
if(abs(p1)==1 & abs(c1-c2)>0 & p2==0){
position[r1,c2] <-0
}
# promotion
if(!is.na(p)) position[r2,c2] <- p*p1
return(position)
}
position.start <- function(){
pstns <- matrix(data = rep(0,times = 64),ncol = 8,nrow = 8,dimnames = list(8:1,letters[1:8]))
# 1 pawns
pstns["2",] <- 1
# 4 rook
# 3 knight
# 2 bishop
# 5 queen
# 6 king
pstns["1",] <- c(4,3,2,5,6,2,3,4)
# the same story for black with minus sign
pstns["7",] <- -1
pstns["8",] <- -c(4,3,2,5,6,2,3,4)
return(pstns)
}
print.pos <- function(position){
white_ucode <- c('\U2659','\U2657','\U2658','\U2656','\U2655','\U2654')
black_ucode <- c('\U265F','\U265D','\U265E','\U265C','\U265B','\U265A')
for(fr in 1:8){
rslt <- NULL
for(fc in 1:8){
pff <- position[fr,fc]
if(pff>0) tmp <- white_ucode[pff]
if(pff<0) tmp <- black_ucode[-pff]
if(pff == 0) tmp <- '\U26DD'
rslt <- paste0(rslt,tmp)
}
cat(paste0(rslt,'\n'))
}
}
string.lan.move2move <- function(slm){
lslm <- strsplit(slm,"")[[1]]
rslm <- NULL
rslm[2] <- cn[lslm[1]]
rslm[1] <- rn[lslm[2]]
rslm[4] <- cn[lslm[3]]
rslm[3] <- rn[lslm[4]]
rslm[5] <- figs[casefold(lslm[5])]
return(rslm)
}
internal <- function(vec,xp){ # internal function for computing possible piece xp moves in vector vec
rslt <- NULL
if(xp<length(vec)){ # moves to the right
wvx <- which(vec[(xp+1):(length(vec))]!=0)
if(length(wvx)>0) { # are there other pieces?
mwvx <- min(wvx)
if(vec[xp+mwvx]*vec[xp]>0) mwvx <- mwvx-1 # if this piece could not be taken then remove it from possible moves
if(mwvx>0) rslt <- c(rslt,(xp+1):(xp+mwvx))
}
else {
rslt <- c(rslt,(xp+1):length(vec))
}
}
if(xp>1){ # moves to the left
wvx <- which(vec[1:(xp-1)]!=0)
if(length(wvx)>0) { # are there other pieces?
mwvx <- max(wvx)
if(vec[mwvx]*vec[xp]>0) mwvx <- mwvx+1 # if this piece could not be taken then remove it
if(mwvx<xp) rslt <- c(rslt,(mwvx):(xp-1))
}
else {
rslt <- c(rslt,1:(xp-1))
}
}
return(rslt)
}
checking.moves <- function(position,r1,c1){
p1 <- position[r1,c1]
ap1 <- abs(p1)
pm <- matrix(ncol = 2)[-1,]
if(ap1 == 4 || ap1 == 5){ # rook and queen
ipr1 <- internal(position[r1,],c1)
if(length(ipr1)>0) pm <- rbind(pm,cbind(r1,ipr1))
ipc1 <- internal(position[,c1],r1)
if(length(ipc1)>0) pm <- rbind(pm,cbind(ipc1,c1))
}
if(ap1 == 2 || ap1 == 5){ # bishop and queen
d1rc <- diag1[r1,c1]
spd1 <- split(position,diag1)[[as.character(d1rc)]]
if(length(spd1)>1){
md1rc <- min(d1rc,0)
is1 <- internal(spd1,c1+md1rc)
if(length(is1)>0)
pm <- rbind(pm,cbind(r1+is1-c1-md1rc,is1-md1rc))
}
d2rc <- diag2[r1,c1]
spd2 <- split(position,diag2)[[as.character(diag2[r1,c1])]]
if(length(spd2)>1){
md2rc <- min(d2rc,0)
is2 <- internal(spd2,c1+md2rc)
if(length(is2)>0)
pm <- rbind(pm,cbind(r1-is2+c1+md2rc,is2-md2rc))
}
}
if(ap1 == 3){ # knight
pm <- kni
pm[,1] <- pm[,1]+r1
pm[,2] <- pm[,2]+c1
pm <- pm[pm[,1]>0 & pm[,1]<9 & pm[,2]>0 & pm[,2]<9,]
pm <- pm[position[pm]*p1<=0,]
}
if(ap1 == 1){ #pawn
if(position[r1-p1,c1]==0) pm <- rbind(pm,c(r1-p1,c1)) #typical pawn move
if((p1 == 1 & r1 == 7)||(p1 == -1 & r1 == 2))
if(position[r1-2*p1,c1] == 0 & position[r1-p1,c1] == 0)
pm <- rbind(pm,c(r1-2*p1,c1)) # first doubled move
#capturing:
if(c1>1)
if(position[r1-p1,c1-1]*p1<0)
pm <- rbind(pm,c(r1-p1,c1-1))
if(c1<8)
if(position[r1-p1,c1+1]*p1<0)
pm <- rbind(pm,c(r1-p1,c1+1))
}
if(ap1 == 6){ # king
pm <- kin
pm[,1] <- pm[,1]+r1
pm[,2] <- pm[,2]+c1
pm <- pm[pm[,1]>0 & pm[,1]<9 & pm[,2]>0 & pm[,2]<9,]
pm <- pm[position[pm]*p1<=0,]
}
return(matrix(pm,ncol = 2))
}
possible.move <- function(position,r1,c1,r2,c2){ # return TRUE if [r1,c1] -> [r2,c2] is possible, FALSE otherwise
pmp <- possible.moves(position,r1,c1)
if(nrow(pmp)>0)
return(sum(pmp[,1]==r2 & pmp[,2]==c2)>0)
else return(FALSE)
}
is.check <- function(position,p){ # is p pieces checking -p king?
rslt <- FALSE
kp <- which(position == -p*6,arr.ind = T) # kingposition
kp1 <- kp[,1]
kp2 <- kp[,2]
for(fr in 1:8){
for(fc in 1:8){
if(position[fr,fc]*p>0){
pm <- checking.moves(position,fr,fc)
if(nrow(pm)>0)
if(sum(pm[,1]==kp1 & pm[,2]==kp2)>0)
rslt <- TRUE
}
if(rslt) break()
}
if(rslt) break()
}
return(rslt)
}
is.mate <- function(position,p){ # is p pieces mating -p king?
rslt <- TRUE
for(fr in 1:8){
for(fc in 1:8){
if(position[fr,fc]*p<0){
pm <- possible.moves(position,fr,fc)
if(nrow(pm)>0) rslt <- FALSE
}
if(!rslt) break()
}
if(!rslt) break()
}
return(rslt)
}
possible.moves <- function(position,r1,c1){
# ep wsc wlc bsc blc should be defined
p1 <- position[r1,c1]
ap1 <- abs(p1)
psmv <- matrix(ncol = 2)[-1,]
if(ap1 < 7){ #
rslt <- checking.moves(position,r1,c1)
if(nrow(rslt)>0)
for(ff in 1:nrow(rslt)){
tmpp <- position.move(position,r1,c1,rslt[ff,1],rslt[ff,2])
if(!is.check(tmpp,sign(-p1))) psmv <- rbind(psmv,rslt[ff,])
}
}
return(psmv)
}
disambiguating.move <- function(position,r1,c1,r2,c2){
p1 <- position[r1,c1]
ap1 <- abs(p1)
tsr <- FALSE # the same rank
tsf <- FALSE # the same file
oth <- FALSE # other cases
dsmb <- ""
if(abs(p1)==4){ # rook
wpp <- which(position == p1,arr.ind = T)
wppp <- matrix(wpp[!(wpp[,1]==r1 & wpp[,2]==c1),],ncol = 2)
nw <- nrow(wppp)
if(nw>0){
for(ff in 1:nw){
dr <- wppp[ff,]
if(possible.move(position,dr[1],dr[2],r2,c2))
{if(dr[1]==r1) {
dsmb <- letters[c1]
break()
}
else{ dsmb <- as.character(9-r1)}}
}
}
}
if(abs(p1)>1 & abs(p1)<6){ # bishop, knight and queen
wpp <- which(position == p1,arr.ind = T)
wppp <- matrix(wpp[!(wpp[,1]==r1 & wpp[,2]==c1),],ncol = 2)
nw <- nrow(wppp)
if(nw>0){
for(ff in 1:nw){
dr <- wppp[ff,]
if(possible.move(position,dr[1],dr[2],r2,c2)){
if(dr[1]==r1) tsr <- TRUE
else if(dr[2]==c1) tsf <- TRUE
else oth <- TRUE
}
}
if(tsr & tsf) dsmb <- paste0(letters[c1],9-r1)
else if(tsr & !tsf) dsmb <- letters[c1]
else if(tsf) dsmb <- as.character(9-r1)
else if(oth) dsmb <- letters[c1]
}
}
return(dsmb)
}
cleanup_san <- function(movetext.san){
rslt <- gsub("[0-9]+\\.","",movetext.san)
rslt <- gsub(" "," ",rslt)
rslt <- gsub("[#x\\+]","",rslt)
return(trimws(rslt))
}
move2san <- function(position,r1,c1,r2,c2,p){
p1 <- position[r1,c1]
# capture
if(abs(position[r2,c2])>0) { # if there is a capture
capt <- "x"
if(abs(p1)==1) # capture by a pawn
{capt <- paste0(letters[c1],"x")}
}
else{capt <- ""}
sc2 <- letters[c2] # file of a destination
sr2 <- c(8:1)[r2] # row of a destination
m2s <- paste0(casefold(names(figs[abs(p1)]),upper = T),disambiguating.move(position,r1,c1,r2,c2),capt,sc2,sr2)
# castling
if(abs(p1)==6 & abs(c1-c2)>1){
# short castling
if(c2 == 7) m2s <- "O-O"
# long castling
if(c2 == 3) m2s <- "O-O-O"
}
# en passant
if(abs(p1)==1 & abs(c1-c2)>0 & position[r2,c2]==0) m2s <- paste0(letters[c1],"x",sc2,sr2)
# promotion
if(!is.na(p)) {
m2s <- paste0(capt,sc2,sr2,"=",casefold(names(figs[p]),upper = T))
}
return(m2s)
}
san.move2move <- function(position, san.move,p){
ptrns <- c("[a-z]+[0-9]","[A-Z][a-z]+[0-9]","[A-Z][0-9][a-z][0-9]","[A-Z][a-z][0-9][a-z][0-9]","O-O","O-O-O","[a-z]+[0-9]=[A-Z]") # san.move2move
for(fp in 1:length(ptrns)){
m <- gregexpr(paste0("^",ptrns[fp],"$"),san.move)
if(length(regmatches(san.move,m)[[1]])>0) break()
}
sm <- strsplit(san.move,"")[[1]]
lsm <- length(sm)
pr <- NULL
switch(fp,
'1' = { # pawn
if(lsm == 2){
r2 <- rn[sm[2]]
c2 <- cn[sm[1]]
wp <- which(position == p,arr.ind = T)
wpp <- matrix(wp[wp[,2]==c2,],ncol = 2)
for(fr in 1:nrow(wpp))
if(possible.move(position,wpp[fr,1],wpp[fr,2],r2,c2)) break()
r1 <- wpp[fr,1]
c1 <- wpp[fr,2]
}
if(lsm == 3){ # pawn with capture
r2 <- rn[sm[3]]
c2 <- cn[sm[2]]
c1 <- cn[sm[1]]
#wp <- which(position == p,arr.ind = T)
#wpp <- matrix(wp[wp[,2]==c1,],ncol = 2)
#for(fr in 1:nrow(wpp))
#if(possible.move(position,wpp[fr,1],c1,r2,c2)) break()
#r1 <- wpp[fr,1]
r1 <- r2+p
#c1 <- wpp[fr,2]
}
},
'2' = { # figure
if(lsm == 3){ # without dsmb moves
r2 <- rn[sm[3]]
c2 <- cn[sm[2]]
fig <- figs[casefold(sm[1])]*p
wp <- which(position == fig,arr.ind = T)
for(fr in 1:nrow(wp))
if(possible.move(position,wp[fr,1],wp[fr,2],r2,c2)) break()
r1 <- wp[fr,1]
c1 <- wp[fr,2]
}
if(lsm == 4){ # dsmb move with file info
r2 <- rn[sm[4]]
c2 <- cn[sm[3]]
c1 <- cn[sm[2]]
fig <- figs[casefold(sm[1])]*p
wp <- which(position == fig,arr.ind = T)
wpp <- matrix(wp[wp[,2]==c1,],ncol = 2)
for(fr in 1:nrow(wpp))
if(possible.move(position,wpp[fr,1],c1,r2,c2)) break()
r1 <- wpp[fr,1]
}
},
'3' = {
if(lsm == 4){ # dsmb move with range info
r2 <- rn[sm[4]]
c2 <- cn[sm[3]]
r1 <- rn[sm[2]]
fig <- figs[casefold(sm[1])]*p
wp <- which(position == fig,arr.ind = T)
wpp <- matrix(wp[wp[,1]==r1,],ncol = 2)
for(fr in 1:nrow(wpp))
if(possible.move(position,r1,wpp[fr,2],r2,c2)) break()
c1 <- wpp[fr,2]
}
},
'4' = { # rare case dsmb move with file and range info
r2 <- rn[sm[5]]
c2 <- cn[sm[4]]
r1 <- rn[sm[3]]
c1 <- cn[sm[2]]
},
'5' = { # short castling
c2 <- 7
if(p == 1) r1 <- r2 <- 8
if(p == -1) r1 <- r2 <- 1
c1 <- 5
},
'6' = { # long castling
c2 <- 3
if(p == 1) r1 <- r2 <- 8
if(p == -1) r1 <- r2 <- 1
c1 <- 5
},
'7' = { # promotion
if(lsm == 4){ # without capture
pr = figs[casefold(sm[4])]
r2 <- rn[sm[2]]
c1 <- c2 <- cn[sm[1]]
}
if(lsm == 5){ # with capture
pr = figs[casefold(sm[5])]
r2 <- rn[sm[3]]
c2 <- cn[sm[2]]
c1 <- cn[sm[1]]
}
if(p == 1) r1 <- 2
if(p == -1) r1 <- 7
}
)
return(c(r1,c1,r2,c2,pr))
}
move2lan <- function(r1,c1,r2,c2,pr){
rslt <- paste0(letters[c1],9-r1,letters[c2],9-r2)
if(!is.na(pr)) rslt <- paste0(rslt,casefold(names(figs)[abs(pr)],upper = T))
return(rslt)
}
rn <- 1:8
names(rn) <- 8:1
figs <- 1:6
names(figs) <- c("","b","n","r","q","k")
ps <- position.start()
diag1 <- row(ps)-col(ps) # possible moves for bishop
cn <- 1:8
names(cn) <- letters[1:8]
diag2 <- -diag1[,8:1]
kni <- matrix(data = c(-1,-1,-2,-2,1,1,2,2,2,-2,1,-1,2,-2,1,-1),nrow = 8,ncol = 2) # possible moves for knight
kin <- matrix(data = c(-1,-1,-1,0,0,1,1,1,-1,0,1,-1,1,-1,0,1),nrow = 8,ncol = 2) # possible moves for king
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.