Ο κώδικας υπάρχει στο Info (δες Setup). Εδώ μπήκε ως αναφορά. Είναι το μεγαλύτερο πρόγραμμα στο info, με 1042 γραμμές.
\\ George Karras, 2020
\\ Chess Example (a big one)
\\ Example Using sprites
\\ Rev. 6
\\ to add a chess engine:
\\ at m2000 console type: win dir$
\\ paste to that folder the engine.exe
\\ this engine is an executable file like stockfish_20090216_x64_modern.exe
\\ from https://stockfishchess.org/
\\ so get the proper exe file, copy to m2000 user folder (use win dir$ from m2000 console)
\\ then rename it as engine.exe
enginepath$=dir$+"engine"
blackComputer=exist(enginepath$+".exe")
gosub initengine
chessfont$="Arial Unicode MS"
Font chessfont$
if not Fontname$="Arial Unicode MS" then
chessfont$="DejaVu Sans"
end if
Font "Verdana"
Thread.plan sequential
Set Fast
Hide
window 12, window
if random(1, 3)=1 then
window 12, scale.x*random(6,9)/10,scale.y*random(6,9)/10;
end if
form 48,34
def thismode
thismode=mode
global const NoSound = False
Module NothingToMove {
Layer {Print $(4)," Nothing to move",$(0);}
}
Module Proper {
Layer {Print $(4)," Wrong color",$(0);}
}
Module Beep {
Layer {Print $(4)," Not Possible",$(0);}
if NoSound Else Beep
}
back {
\\ we use a switch to alter the return code in Input ! variant, when we press Enter key
\\ normally "-inp" return in Field read only variable 1 when we press enter or down arrow
\\ using "+inp" we can get 13 for enter and 1 for down arrow
Cls 0,0
font "Times"
Pen 15
Mode thismode*5
cursor 0,height div 2
Report 2, "Wait...."
refresh 10000
Mode thismode
set switches "+inp"
Fkey Clear
Escape off
Cls #FFA000,0
Pen 14
bold 1
mode thismode
Def White$="PNBRQK", Black$="pnbrqk", WhiteDisp$="♙♘♗♖♕♔"
Def BlackDisp$="♟♞♝♜♛♚", empty$="12345678", disp$
disp$=WhiteDisp$+BlackDisp$
Def White_♔_file, White_♔_rank, Black_♚_rank, Black_♚_file
Def boolean White_♔_no_roke, Black_♚_no_roke
Def boolean White_no_left_roke, Black_no_left_roke
Def boolean White_no_right_roke, Black_no_right_roke
Def Halfmove_clock, Fullmove_number, threat, Clip$
Dim emptydisp$(1 to 8), BoardSq(1 to 8, 1 to 8)=(,)
Def en_passant_rank=0, en_passant_file=0
for i=1 to 8 :emptydisp$(i)=string$(" ",i):next i
Def board$, status$, oldI, color1, color2, C=14
color2=Color(209, 139, 71)
color1=Color(255, 206,158)
dim line$()
Def flashtime=300
Dim PastGames$(1 to 200)
Def freeSlot=0, cur=0, ok=true, k$, condition$
Def double ip, jp, ip1, jp1, si, sj, getone as boolean
Def st, fig$, tr, mx, my, lx,ly, key=0, mmx,mmy, mmb
Def movelogic as boolean=false, mvx, mvy
sa=(,) : sb=each(sa)
Double
OldI=Italic
Italic 1
Def upperlimit
Cursor 0,0
Pen 15 {Report 2, "Chess Game "+if$(blackComputer->"UCI Engine", "for two")}
Italic OldI
Normal
Move ! ' Move graphic cursor to character cursor - Cursor ! the other way
upperlimit=pos.y*1.6
move 0, upperlimit*6/8
Fill scale.x,scale.y-upperlimit*6/8, 3,5,1
Set Fast !
\\ calc based to height
HalfWidth=(scale.y*.65) div 16
def downlimit=0, White as boolean=True, fw
DrawEmptyBoard((scale.x/2-HalfWidth*8),upperlimit, HalfWidth, 15)
fw=HalfWidth*2-60
\\ hold
\\ set new game
\\ -1 for no FEN
def NoFEN(aGame$)=len(aGame$)<>len(filter$(aGame$,"/"))+7
Inventory OnBoard
Const NewGame$="rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1"
Def ThisGame$
\\ CHECK IF A STRING IS IN STACK (SO THIS MAYBE A FEN NOTATION FOR A STARTING POSITION)
if match("S") then
For this {
\\block for temporary definitions
Local row$(), i, nok, m
Read ThisGame$
row$()=piece$(ThisGame$, chr$(13)+chr$(10))
\\ we drop lines by redim the array (dim also is a "dim preserve")
while len(row$())>1
if row$(len(row$())-1)="" then dim row$(len(row$())-1) else exit
end while
if len(row$())>0 then
m=each(row$())
while m
if NoFEN(array$(m)) Then nok=true: exit
end while
End if
if nok then Push ThisGame$ : ThisGame$=NewGame$ : exit
PastGames$()=row$()
Dim PastGames$(1 to 200)
freeSlot=len(row$())
ThisGame$=PastGames$(freeSlot)
}
else
ThisGame$=NewGame$
End if
SetBoard(ThisGame$)
RedrawBoard(True)
sx=scale.x
sy=scale.y-downlimit
move 0,downlimit
fill sx,sy, 5
Layer {
font "Verdanal"
mode thismode, sx,sy
motion center
motion, downlimit
Cls 5,0
Pen 14
}
Refresh 60
flush
move$=""
refresh
\\ ctrl+F1 help
About ! "How to play", 14000,9000,{Give one or more moves in one input line.
Each move has a letter a number a letter and final a number
so:
e2e4 or e2-e4 or e2..e4
(symbols other than aebcdefgh and 123456789 are white space)
move something from e2 to e4, but this
e2e3e7e5
give two moves (so we can paste a number of moves)
before a move a new FEN string compiled and copied to clipboard.
if nothing exist in e2 then we get a beep sound. If a move break a rule then no move happen and we get a beep. If King have a threat then we have to do a proper move to eliminate threat otherwise we get a beep.
We can press enter without giving a move, so we asked for ending the game or not.
If we press Y then a new input start to get a FEN board notation, so we can use ctrl+V to paste the string and pressing enter we get the new boad.
* Castling work automatic. So if rules are ok wen can give a e1c1 for queen side castling for white king.
* En passant works fine
* A pawn at last rank turn to Queen
You can call this module passing a FEN string as parameter.
George Karras
}
Thread {
if control$<>"MAIN" then continue
mmb=mouse
If mmb=0 then continue
mmy=mouse.y : mmx=mouse.x
if mmy>downlimit then
if mmx<scale.x*.8 then
if mmb=2 then Field New 99 : Input End
else
if mmb=1 then Input End
end if
else.if mmy<downlimit and mmy>upperlimit then
Field New if(mmy>((downlimit+upperlimit)/2)->1,-1)
Input End
end if
} as Handler interval 100
Thread Handler Hold
Thread {
if control$<>"MAIN" then continue
if getone then
move lx, ly
Refresh 100
sprite sprite$
mx=mouse.x : my=mouse.y :mmb=mouse
sb=each(BoardSq())
St=(,)
While sb
sa=array(sb)
if sa#val(3)-twipsX<=mx and sa#val(5)+twipsX>=mx and sa#val(4)-twipsY<=my and sa#val(6)+twipsY>=my then St=sa : exit
End While
if len(st)>0 then
si=st#val(10) : sj=st#val(11)
if mmb=0 then
keyboard chr$(ip+96)+chr$(jp+48)+chr$(si+96)+chr$(sj+48)+chr$(13)
getone=false: refresh 100 : mouse.icon show
else
lx=mx : ly=my
move lx, ly
if st#val$(8)=" " or (si=ip and sj=jp) then
sprite fig$, tr
else
sprite fig$, tr,-10,,80
end if
refresh 100
end if
else.if mmb=0 then
RedrawBoard(?)
getone=false
mouse.icon show
Thread Sp restart
end if
if not getone then Thread this hold
} as pSp interval 1000/30
Thread pSp hold
Thread {
if control$<>"MAIN" then continue
if mouse=0 and movelogic then movelogic=false
if mouse.y<upperlimit then mouse.icon 15 else mouse.icon 1
if not movelogic then if mouse.y<upperlimit and mouse=1 then movelogic=true: mvx=mousea.x : mvy=mousea.y:continue
if movelogic then if mouse=1 then motion motion.wx- mvx+mousea.x, motion.wy-mvy+mousea.y : continue
mx=mouse.x : my=mouse.y
if mouse=1 and my>downlimit then input end : Thread this hold
if mouse=1 and not getone then{
move mx, my
if point=0 or point=#FFFFFF else exit
sb=each(OnBoard)
St=(,)
While sb
sa=eval(sb)
if sa#val(3)<mx and sa#val(5)>mx and sa#val(4)<my and sa#val(6)>my then St=sa : exit
End While
if len(st)=0 then exit
move st#val(3)+30, st#val(4)+30
refresh 1000
tr=point
copy fw,fw to fig$
Image fig$ to fig$,120,120
fill fw,fw, tr
move mx, my
lx=mx:ly=my
ip=st#val(10):jp=st#val(11)
sprite fig$, tr
mouse.icon hide
getone=true
Thread pSp restart
Thread this hold
}
} as Sp interval 100
mouse.icon show
isok=true
{
{
if white then
CheckThreat(white, White_♔_file, White_♔_rank, &threat)
else
CheckThreat(white, Black_♚_file, Black_♚_rank, &threat)
end if
if isok then
freeSlot++
GetBoard(&Clip$)
if freeSlot>Len(PastGames$()) then Dim PastGame$(1 to 2*Len(PastGames$()))
PastGames$(freeSlot)=Clip$
end if
\\\test
condition$=if$(White->"White move", "Black move") + if$(threat->" (check)","")+ if$(Halfmove_clock>50->"(You can draw)","")+":"
Layer {
Print Part $(4,5), right$(string$(chrcode$(8199), 3)+str$(Fullmove_number,""),3)+".", $(7,12),condition$,
}
if blackComputer then
if not White then mymove$=@GetMove$(PastGames$(freeSlot)): keyboard left$(mymove$,4)+chr$(13)
end if
White~
if empty then
Layer {
Pen 15 {Input "",move$;}
}
\\\test !
Thread Sp hold
Thread pSp Hold
mouse.icon 1
getone=false
if move$="" then
Layer {
wait 100
Refresh 60
profiler
Every 1000/60 {
if timecount>flashtime then
profiler
Cls
Pen C {Double : Report 2,"End this Game ?" : Normal}
C=20-C
Cursor width, Height
Move ! \\ copy character cursor to graphic cursor
Legend "Use Y or Left Mouse Click to exit | Right Mouse Click or N to continue", FontName$, Mode*.7, 0,1, 1,twipsX
end if
k$=""
if keypress(0x1B) then k$="Y":exit
if keypress(0x4E) then exit
if keypress(0x59) then k$="Y":exit
if keypress(1) then k$="Y": exit
if keypress(2) then exit
}
}
while not inkey$ ="" {Wait 1} 'drop key any
If k$="Y" else
\\ if stack has something then RedrawBoard mey use it (because read for optional variable)
\\ we can be sure we set the optional value using ?
White~ :RedrawBoard(?): Layer {Cls}
getone=false
Thread Sp restart
flush ' make empty true (so stack is empty for sure)
loop ' set a flag for restart at end bracket of current block
end if
else
move$=lcase$(move$)
while len(move$)>0
select case left$(move$,1)
case "1" to "8"
data asc(move$)-48
case "a" to "h"
data asc(move$)-96
end select
insert 1,1 move$=""
end while
end if
isok=false
end if
if not empty then
if stack.size mod 4 = 0 then
try ok {
MakeAmove(&isok)
if not isok then flush : White~: exit
if not empty then
white~: refresh : wait 500 : loop
end if
}
Layer {Print}
getone=false
if isok else RedrawBoard(?)
if ok then loop : Thread Sp restart
else
flush : White~ : loop : Thread Sp restart' loop processed at the end of the block, so only a flag raised here
end if
end if
}
Thread Sp Hold
Thread pSp Hold
cur=freeSlot
Clip$=PastGames$(cur)
Layer {
if cur=0 then cur=1
if cur>freeSlot then cur=freeSlot
if Clip$<>PastGames$(cur) then
Clip$=PastGames$(cur)
if len(Clip$)=len(filter$(Clip$,"/"))+7 and trim$(Clip$)<>"" then Back {SetBoard(Clip$) :RedrawBoard(?)}
end if
Refresh 60
Cls
Cursor width, Height
Move !
Legend "Right Mouse Click or Esc to Quit | Left Mouse Click right of the FEN to continue play | About Ctrl+F1", FontName$, Mode*.7, 0,1, 1,twipsX
Cursor 0,0
Report 2, "Replay the Game,(arrows u/d) or Start a new one setting a new FEN"
Print Part $(7,7), "Board FEN: "
Field New 13
Thread Handler Restart
Pen 15 {Input ! Clip$, width-7 len=100}
Thread Handler Hold
Report Clip$
refresh 60
if field=13 then exit
if field=-1then cur-- : loop
if field=99 then Clip$="": exit
if field=1 then cur++ : loop
}
if len(Clip$)<>len(filter$(Clip$,"/"))+7 or trim$(Clip$)="" then SaveGame():Layer {Cls} : exit
if Clip$<>PastGames$(cur) then
SaveGame()
PastGames$(1)=Clip$:cur=1
end if
freeSlot=cur
SetBoard(Clip$)
RedrawBoard(?)
Layer {Cls}
Thread Sp restart
Loop
}
Cls 0,0
}
hide
threads erase
declare Engine nothing
wait 200
about ""
if module(info) then keyboard "info"+chr$(13)
Flush
set switches "-inp"
escape off
Window 12, window
form
form ;
About ! ""
end
Sub SaveGame()
if freeSlot=1 then exit sub
Local Out$
Document Out$ ' upgrade to Document
layer {
Cls
if ask("Copy the game to clipboard?","Finish","*Yes","No")=1 then
Report "Wait..."
for i=1 to freeSlot
Out$+=PastGames$(i)
if i<freeSlot then
Out$={
}
end if
next
Clipboard Out$
Save.Doc Out$, "LastGame.chess"
Report "Done..."
wait 300
end if
}
end sub
Sub SaveGame1()
local Out$, i
Document Out$ ' upgrate to document
layer {
}
End Sub
Sub DrawEmptyBoard(leftmargin, topmargin, squarewidth, labelcolor)
Local a=true, z=bold : bold 0
Local l=squarewidth, k=2*l, k1=k*.85, N1=6, N=6, M=4, B=k*8, B1
Local d=0, im=0, jm=0
Repeat
N=N1
N1+=.25
Until K1<size.Y("A",chessfont$, N1)
topmargin-=l
leftmargin-=l
move leftmargin+l,topmargin+l
B1=(l div 300)*twipsX
step -B1,-B1
B+=B1*2
Pen 0 {
Width b1 div 2+1 {
color color1 , 1{Polygon 0, B, 0, 0, B, -B, 0, 0, -B}
}
M=N*.65
For i=1 to 9
d=leftmargin
move d, topmargin
if i<9 then
step 0, k
Pen labelcolor{Legend str$(9-i,""), chessfont$, M,0,2}
step 0, -k
else
N=M
end if
for j=1 to 8
If i<9 then
step l, l
color color1,1 {fill k,k, if(a->color1,color2)}
step -l, -l
BoardSq(j, 9-i)=(N, pos.x, pos.y, pos.x-l+twipsX, pos.y-l+twipsX, pos.x+l-twipsX, pos.y+l-twipsX, k-twipsX*2, " ", a, j,9-i)
a~
else
step k, k
pen labelcolor {
Legend mid$("abcdefgh",j,1), chessfont$, N, 0, 2
}
end If
d+=k
move d, topmargin
next
a~ : topmargin+=k
next
}
bold z
downlimit=topmargin+500
end sub
Sub MakeAmove( &ok, i, j, i1, j1)
Local z=bold, p$, p1$ : bold 0
Local t,t1, N=BoardSq(1,1)#val(0), again as boolean, playroke as boolean
ok=false
Local rule=true, threat as boolean
refresh 10000
Pen 0 {
again=false
t=BoardSq(i,j)
t1=BoardSq(i1, j1)
p$=t#val$(8)
p1$=t1#val$(8)
if p$=" " then NothingToMove : exit
if t is t1 then NothingToMove : exit
if p1$<>" " then if p1$<"♚" and p$<"♚" then Proper : exit
if p1$<>" " then if p1$>="♚" and p$>="♚" then Proper : exit
\\ white change logic here
if not white and instr(WhiteDisp$, p$)=0 then Proper : exit
if white and instr(BlackDisp$, p$)=0 then Proper :exit
select case p$
case "♔"
{
If not White_♔_no_roke then
CheckThreat(not white, White_♔_file, White_♔_rank, &threat)
if not threat then
if i1=3 and j1=1 then
if p1$=" " and BoardSq(2,1)#val$(8)=" " and BoardSq(4,1)#val$(8)=" " and not White_no_left_roke then
CheckThreat(not white, 4, 1, &threat)
if not threat then push 1, 4, 1, 1 : again=true : playroke=true
end if
else.if i1=7 and j1=1 then
if p1$=" " and BoardSq(6,1)#val$(8)=" " and not White_no_right_roke then
CheckThreat(not white, 6, 1, &threat)
if not threat then push 1, 6, 1, 8 : again=true : playroke=true
end if
end if
end if
end if
if not playroke Then
if abs(i-i1)>1 then rule=false: exit
if abs(j-j1)>1 then rule=false: exit
White_♔_no_roke=true
White_no_right_roke=True
White_no_left_roke=true
end if
CheckKing()
if threat then
rule=false
if playroke then drop 4
else
White_♔_rank=j1
White_♔_file=i1
end if
}
case "♚"
{
If not Black_♚_no_roke then
CheckThreat(not white, Black_♚_file, Black_♚_rank, &threat)
if not threat then
if i1=3 and j1=8 then
if p1$=" " and BoardSq(2,8)#val$(8)=" " and BoardSq(4,8)#val$(8)=" " and not Black_no_left_roke then
CheckThreat(not white, 4, 8, &threat)
if not threat then push 8, 4, 8, 1 : again=true : playroke=true
end if
else.if i1=7 and j1=8 then
if p1$=" " and BoardSq(6,8)#val$(8)=" " and not Black_no_right_roke then
CheckThreat(not white, 6, 8, &threat)
if not threat then push 8, 6, 8, 8 : again=true : playroke=true
end if
end if
end if
end if
if not playroke Then
if abs(i-i1)>1 then rule=false: exit
if abs(j-j1)>1 then rule=false: exit
Black_♚_no_roke=true
Black_no_right_roke=true
Black_no_left_roke=true
end if
CheckKing()
if threat then
rule=false
if playroke then drop 4
else
Black_♚_rank=j1
Black_♚_file=i1
end if
}
case "♕","♛"
{
if i1<>i and j1<>j then
if abs(i1-i)<>abs(j1-j) then rule=false: exit
jm=0
if abs(i1-i)>1 then
jm=j+sgn(j1-j)
for im=i+sgn(i1-i) to i1-sgn(i1-i)
if BoardSq(im,jm)#val$(8)<>" " then jm=-1: exit for
jm+=sgn(j1-j)
next
end if
else
jm=0:im=0
if abs(i1-i)>1 then
for im=i+sgn(i1-i) to i1-sgn(i1-i)
if BoardSq(im,j)#val$(8)<>" " then jm=-1: exit for
next
else.if abs(j1-j)>1 then
for jm=j+sgn(j1-j) to j1-sgn(j1-j)
if BoardSq(i,jm)#val$(8)<>" " then im=-1 :exit for
next
end if
if im=-1 or jm=-1 then rule=false:exit
end if
CheckIt()
}
case "♜"
{
If playroke then Black_no_right_roke=true : Black_no_left_roke=true : Black_♚_no_roke=True : exit
if i1<>i and j1<>j then rule=false: exit
jm=0:im=0
if abs(i1-i)>1 then
for im=i+sgn(i1-i) to i1-sgn(i1-i)
if BoardSq(im,j)#val$(8)<>" " then jm=-1: exit for
next
else.if abs(j1-j)>1 then
for jm=j+sgn(j1-j) to j1-sgn(j1-j)
if BoardSq(i,jm)#val$(8)<>" " then im=-1 :exit for
next
end if
if im=-1 or jm=-1 then rule=false:exit
CheckIt()
if not rule then exit
if i=1 and j=8 then Black_no_left_roke=true
if i=8 and j=8 then Black_no_right_roke=true
}
case "♖"
{
If playroke then White_no_right_roke=true : White_no_left_roke=true : White_♔_no_roke=True : exit
if i1<>i and j1<>j then rule=false: exit
jm=0:im=0
if abs(i1-i)>1 then
for im=i+sgn(i1-i) to i1-sgn(i1-i)
if BoardSq(im,j)#val$(8)<>" " then jm=-1: exit for
next
else.if abs(j1-j)>1 then
for jm=j+sgn(j1-j) to j1-sgn(j1-j)
if BoardSq(i,jm)#val$(8)<>" " then im=-1 :exit for
next
end if
if im=-1 or jm=-1 then rule=false:exit
CheckIt()
if not rule then exit
if i=1 and j=1 then White_no_left_roke=true
if i=8 and j=1 then White_no_right_roke=true
}
case "♗","♝"
{
if i1=i or j1=j then rule=false: exit
if abs(i1-i)<>abs(j1-j) then rule=false: exit
jm=0
if abs(i1-i)>1 then
jm=j+sgn(j1-j)
for im=i+sgn(i1-i) to i1-sgn(i1-i)
if BoardSq(im,jm)#val$(8)<>" " then jm=-1: exit for
jm+=sgn(j1-j)
next
end if
if jm=-1 then rule=false:exit
Checkit()
}
case "♘","♞"
{
if abs(i1-i)=abs(j1-j) then rule=false: exit
if abs(i1-i)=0 or abs(j1-j)=0 then rule=false: exit
if abs(i1-i)+abs(j1-j)<>3 then rule=false: exit
Checkit()
}
case "♙"
{
if j1<=j then rule=false:exit
if i<>i1 then if i1<i-1 or i1>i+1 then rule=false: exit
if j>2 then if j1>j+1 then rule=false:exit
if j=2 and j1>j+2 then rule=false:exit
if i=i1 and p1$<>" " then rule=false:exit
if i<>i1 and p1$=" "and not (en_passant_file=i1 and en_passant_rank=j1-1) then rule=false:exit
if i<>i1 and j1>j+1 then rule=false exit
if en_passant_file=i1 and en_passant_rank=j1-1 then
Checkit2()
else
Checkit()
End if
en_passant_file=0
en_passant_rank=0
if j1=8 then p$="♕" else if j1=j+2 then en_passant_file=i1:en_passant_rank=j1
}
case "♟"
{
if j1>=j then rule=false:exit
if i<>i1 then if i1<i-1 or i1>i+1 then rule=false: exit
if j<7 then if j1<j-1 then rule=false:exit
if j=7 and j1<j-2 then rule=false:exit
if i=i1 and p1$<>" " then rule=false:exit
if i<>i1 and p1$=" " and not (en_passant_file=i1 and en_passant_rank=j1+1) then rule=false:exit
if i<>i1 and j1<j-1 then rule=false:exit
if en_passant_file=i1 and en_passant_rank=j1+1 then
Checkit2()
else
Checkit()
End if
en_passant_file=0
en_passant_rank=0
if j1=1 then p$="♛" else if j1=j-2 then en_passant_file=i1:en_passant_rank=j1
}
end select
If not rule then beep : exit
move t#val(3), t#val(4)
return t, 8:=" "
delete OnBoard, i*9+j
if t#val(9) then fill t#val(7), t#val(7),color1 else fill t#val(7), t#val(7), color2
t=t1
move t#val(3), t#val(4)
fill t#val(7), t#val(7),15
if p1$<>" " then
Halfmove_clock=0
Return OnBoard, i1*9+j1:=t
else
Halfmove_clock++
Append OnBoard, i1*9+j1:=t
end if
return t, 8:=p$
move t#val(1), t#val(2): Legend p$, chessfont$, N, 0, 2,0
move t#val(3)+twipsx*2, t#val(4)+twipsy*2
if t#val(9) then floodfill ,,color1 else floodfill , , color2
if again then read i, j, i1, j1 : Restart
if p$<>"♙" and p$<>"♟" then en_passant_file=0 : en_passant_rank=0
if white then Fullmove_number++
Ok=true
}
bold z
refresh 10000
end Sub
Sub RedrawBoard(NoRefresh as boolean=False)
Local z=bold, p$ : bold 0
Local t, N=BoardSq(1,1)#val(0)
If NoRefresh Else refresh 10000
Pen 0 {
For j=1 to 8
For i=1 to 8
t=BoardSq(i,j)
move t#val(3), t#val(4)
fill t#val(7), t#val(7),15
p$=t#val$(8)
if p$=" " else move t#val(1), t#val(2): Legend p$, chessfont$, N, 0, 2,0
move t#val(3)+twipsx*2, t#val(4)+twipsy*2
if t#val(9) then floodfill ,,color1 else floodfill , , color2
Next
Next
}
bold z
If NoRefresh Else refresh 60
end Sub
Sub GetBoard(&chessboard$)
chessboard$=""
local i, j,a$, spc, line$
for j=8 to 1
line$=""
for i=1 to 8
a$=BoardSq(i,j)#val$(8)
if a$<>" " then
if spc>0 then line$+=str$(spc,""): spc=0
line$+=mid$("PNBRQKpnbrqk", instr("♙♘♗♖♕♔♟♞♝♜♛♚", a$),1)
else
spc++
end if
next
if spc>0 then line$+=str$(spc,""): spc=0
if j>1 then chessboard$+=line$+"/" else chessboard$+=line$+" "
next
if white then chessboard$+="w " else chessboard$+="b "
if White_♔_no_roke and Black_♚_no_roke then
chessboard$+="-"
else
if White_no_right_roke else chessboard$+="K"
if White_no_left_roke else chessboard$+="Q"
if Black_no_right_roke else chessboard$+="k"
if Black_no_left_roke else chessboard$+="q"
end if
if not en_passant_file=0 then
chessboard$+=" "+chr$(96+en_passant_file)+chr$(48+en_passant_rank)
else
chessboard$+=" -"
end if
chessboard$+=str$(Halfmove_clock)
chessboard$+=str$(Fullmove_number)
End Sub
Sub SetBoard(chessboard$)
Rem https://en.wikipedia.org/wiki/Forsyth–Edwards_Notation
Clear OnBoard
board$=leftpart$(chessboard$," ")
if len(filter$(board$,"K"))<>len(board$)-1 Then Error "Problem with White King"
if len(filter$(board$,"k"))<>len(board$)-1 Then Error "Problem with Black King"
status$=ltrim$(rightpart$(chessboard$," "))
white=left$(status$,1)="w"
status$=ltrim$(mid$(status$,2))
if left$(status$,1)="-" then
White_no_right_roke=True
White_no_left_roke=True
White_♔_no_roke =True
Black_no_right_roke=True
Black_no_left_roke=True
Black_♚_no_roke=True
status$=ltrim$(mid$(status$,2))
else
local L=len(status$)
status$=filter$(status$,"K")
White_no_right_roke= len(status$)=L
L=len(status$) : status$=filter$(status$,"Q")
White_no_left_roke= len(status$)=L
White_♔_no_roke = White_no_right_roke and White_no_left_roke
L=len(status$) : status$=filter$(status$,"k")
Black_no_right_roke= len(status$)=L
L=len(status$) : status$=filter$(status$,"q")
Black_no_left_roke= len(status$)=L
Black_♚_no_roke=Black_no_right_roke and Black_no_left_roke
status$=ltrim$(status$)
End if
if left$(status$,1)="-" then
en_passant_file=0
en_passant_rank=0
status$=mid$(status$,2)
else
en_passant_file=Asc(left$(status$,1))-96
en_passant_rank=Asc(Mid$(status$,2,1))-48
if en_passant_rank=3 then en_passant_rank=4 else en_passant_rank=5
status$=mid$(status$,3)
end if
Local m
Halfmove_clock=val(status$, "int", &m)
status$=mid$(status$,m)
Fullmove_number=max.data(val(status$, "int", &m), 1)
nl$={
}
for i=1 to 6
board$=replace$(mid$(White$,i,1),mid$(WhiteDisp$,i,1), board$)
board$=replace$(mid$(Black$,i,1),mid$(BlackDisp$,i,1), board$)
next
for j=1 to 8
board$=replace$(str$(j,""),emptydisp$(j), board$)
next
line$()=piece$(board$,"/")
local t
dim line$(1 to 8)
For j=1 to 8: For i=1 to 8
t=BoardSq(i,j)
return t, 8:=mid$(line$(9-j), i, 1)
if t#val$(8)<>" " then Append OnBoard, i*9+j:=t
if t#val$(8)="♔" then
White_♔_rank=j
White_♔_file=i
if i<>5 and j<>1 then White_♔_no_roke=True : White_no_left_roke=true : White_no_right_roke=true
else.if t#val$(8)="♚" then
Black_♚_rank=j
Black_♚_file=i
if i<>5 and j<>8 then Black_♚_no_roke=True: Black_no_left_roke=true : Black_no_right_roke=true
end if
next : next
end Sub
Sub CheckIt()
return t, 8:=" "
return t1, 8:=p$
if not white then
CheckThreat(not white, White_♔_file, White_♔_rank, &threat)
else
CheckThreat(not white, Black_♚_file, Black_♚_rank, &threat)
end if
if threat then rule=false
return t, 8:=p$
return t1, 8:=p1$
end Sub
Sub CheckIt2()
return t, 8:=" "
return t1, 8:=p$
local t2=BoardSq(en_passant_file, en_passant_rank)
local p2$=t2#val$(8)
return t2, 8:=" "
if not white then
CheckThreat(not white, White_♔_file, White_♔_rank, &threat)
else
CheckThreat(not white, Black_♚_file, Black_♚_rank, &threat)
end if
if threat then rule=false
return t, 8:=p$
return t1, 8:=p1$
if threat then
return t2, 6:=p2$
else
move t2#val(3), t2#val(4)
if t2#val(9) then
fill t2#val(7), t2#val(7),color1
else
fill t2#val(7), t2#val(7), color2
end if
Halfmove_clock=-1
end if
end Sub
Sub CheckKing()
return t, 8:=" "
return t1, 8:=p$
CheckThreat(not white, i1, j1,&threat)
if threat then rule=false
return t, 8:=p$
return t1, 8:=p1$
end Sub
Sub CheckThreat(White as boolean, c, c1, &Yes)
local i=1, i1=8, j=1, j1=8, k=c, k1=c1
if white then
local oKin$="♚",hor$="♜♛", dia$="♝♛", Kni$="♞"
else
local oKin$="♔",hor$="♖♕", dia$="♗♕", Kni$="♘"
end if
' WhiteDisp$="♙♘♗♖♕♔"
' BlackDisp$="♟♞♝♜♛♚"
Yes=false
if c1<7 and white then
if c>1 then
if BoardSq(c-1, c1+1)#val$(8)="♟" then Yes=True :exit sub
end if
if c<8 then
if BoardSq(c+1, c1+1)#val$(8)="♟" then Yes=True :exit sub
end If
else.if c1>1 and not white then
if c>1 then
if BoardSq(c-1, c1-1)#val$(8)="♙" then Yes=True :exit sub
end if
if c<8 then
if BoardSq(c+1, c1-1)#val$(8)="♙" then Yes=True :exit sub
end If
end if
for k=max.data(c-1, 1) to min.data(c+1, 8)
for k1=max.data(c1-1, 1) to min.data(c1+1, 8)
if k1=c1 and k=c else if BoardSq(k, k1)#val$(8) =oKin$ then Yes=True : Exit Sub
next
next
for k=c to i
if Instr(hor$,BoardSq(k,c1)#val$(8))>0 then Yes=True :exit sub
if k<>c then if Instr(disp$,BoardSq(k,c1)#val$(8))>0 then exit for
next
if c>1 and c1<8 then {
k1=c1+1
for k=c-1 to i \\ look up left
if Instr(Dia$,BoardSq(k,k1)#val$(8))>0 then Yes=True :exit sub
if k<>c then if Instr(disp$,BoardSq(k,k1)#val$(8))>0 then exit for
K1++
if k1>8 then exit for
next
}
for k=c to i1
if Instr(hor$,BoardSq(k,c1)#val$(8))>0 then Yes=True :exit sub
if k<>c then if Instr(disp$,BoardSq(k,c1)#val$(8))>0 then exit for
next
if c<i1 and c1>1 then {
k1=c1-1
for k=c+1 to i1 \\ look down right
if Instr(Dia$,BoardSq(k,k1)#val$(8))>0 then Yes=True :exit sub
if Instr(disp$,BoardSq(k,k1)#val$(8))>0 then exit for
K1--
if k1<1 then exit for
next
}
for k1=c1 to j
if Instr(hor$,BoardSq(c,k1)#val$(8))>0 then Yes=True :exit sub
if k1<>c1 then if Instr(disp$,BoardSq(c,k1)#val$(8))>0 then exit for
next
if c1>j and c>1 then {
k=c-1
for k1=c1-1 to j \\ look down left
if Instr(Dia$,BoardSq(k,k1)#val$(8))>0 then Yes=True :exit sub
if Instr(disp$,BoardSq(k,k1)#val$(8))>0 then exit for
k--
if k<1 then exit for
next
}
for k1=c1 to j1
if Instr(hor$,BoardSq(c,k1)#val$(8))>0 then Yes=True :exit sub
if k1<>c1 then if Instr(disp$,BoardSq(c,k1)#val$(8))>0 then exit for
next
if c1<j1 and c<8 then {
k=c+1
for k1=c1+1 to j1 \\ look up right
if Instr(Dia$,BoardSq(k,k1)#val$(8))>0 then Yes=True :exit sub
if Instr(disp$,BoardSq(k,k1)#val$(8))>0 then exit for
k++
if k>8 then exit for
next
}
rem test "here"
for k=max.data(c-2,i) to min.data(c+2, i1)
for k1=max.data(c1-2,j) to min.data(c1+2, j1)
if Abs(k-c)+Abs(k1-c1)=3 then if BoardSq(k,k1)#val$(8)=Kni$ then Yes=True :exit sub
next
next
end Sub
\\ new from revision 5
Function GetMove$(Fen$)
local aLine$
method Engine, "SendLine" , "position fen "+Fen$
method Engine, "SendLine" ,"go movetime"+str$(random(50, 200))
every 50 {
Method Engine, "ProcessLoop"
if not Engine.Active then exit
while Engine.HasLine
method Engine, "GetLine" as aLine$
if left$(aLine$,8)="bestmove" then exit
End While
if left$(aLine$,8)="bestmove" then =piece$(aLine$," ", 2) : exit
}
End Function
initengine:
declare Engine SHELLPIPE
with Engine, "Active" as Engine.Active, "Hasline" as Engine.HasLine
Method Engine, "Run", enginepath$ as OkEngine
if OkEngine=0 then Method Engine, "SendLine", "ucinewgame"
Return
