Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Colochessum human interface 0.2
| Uploader: |  grindstone |
| Datum/Zeit: | 12.01.2021 16:19:46 |
Hinweis: Dieser Quelltext ist Bestandteil des Projekts Colochessum, zu dem es auf FreeBASIC-Portal.de eine Projektseite gibt.
'*******************************************************************************************
' This "dummy chess engine" is meant to be used as human interface with the "Colochessum"
' engine vs. engine chess GUI. Please compile this source code with "fbc -s console", rename
' the compiled program "human.exe" and place it in the "engines" folder of Colochessum.
' Then you can play against any engine Colochessum can handle.
'*******************************************************************************************
#Include Once "windows.bi"
#Include "fbgfx.bi"
#Include "vbcompat.bi"
#Include "..\common.bi" 'contains subs/functions which are used identically in the
' colocessum main program as well as in the human interface
Dim Shared As Integer legalMoveCount
Dim Shared As HANDLE hWndThisWindow
Dim Shared As tFen currentFen
ReDim Shared As String legalMove(1)
Dim As Integer x, y, ff, mx, my, mw, mb, rndFlag
Dim As String g, fieldfrom, fieldto, mousefield
Dim As tBipdata Ptr pipeHuman
Declare Sub showInternalBoard()
'Declare Function StringNextItem(text As String = "") As String
Declare Sub legalMoves(opp As String)
Declare Sub setMove(move As String, opp As String = "")
Declare Sub explore(col As Integer, row As Integer, d As direction, opp As String, kingflag As Integer = 0)
Declare Function iMove(colfrom As Integer, rowfrom As Integer, colto As Integer = 1, rowto As Integer = 1) As String
Declare Sub printInternalBoard(move As String)
Randomize
gameStamp = Now
Do
Input g 'get message from GUI
Do
Select Case StringNextItem(g) '1st item
Case "uci" 'send startup message to GUI
Print "id name Colochessum human interface"
Print "id author grindstone"
Print "version 0.4 2017"
Print "option name random type combo default off var off var rightclick var auto"
Print "uciok"
Exit Do
Case "debug"
Select Case StringNextItem() '1st item
Case"on"
Case "off"
End Select
Case "isready"
Print "readyok"
Case "setoption"
Select Case StringNextItem() '1st item
Case "name"
Select Case StringNextItem() '2nd item
Case "random"
Select Case StringNextItem() '3rd item
Case "value"
Select Case StringNextItem() '4th item
Case "off"
rndFlag = 0
Case "rightclick"
rndFlag = 1
Case "auto"
rndFlag = 2
End Select
End Select
End Select
End Select
Case "ucinewgame"
Case "position"
Select Case StringNextItem() '2nd item
Case "startpos"
currentFen.fen = ("rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1", board()) 'startposition
Print "startpos OK"
Case "fen"
g = StringNextItem() _ 'board setup
+ " " + StringNextItem() _ 'opponent
+ " " + StringNextItem() _ 'castling flag
+ " " + StringNextItem() _ 'en passant
+ " " + StringNextItem() _ 'halfmove counter
+ " " + StringNextItem() 'move counter
currentFen.fen = (g, board())
Case Else
'error
End Select
Select Case StringNextItem() '3rd item
Case "moves"
g = StringNextItem()
'showInternalBoard
Do While Len(g) 'do moves
currentFen.opponent = IIf(currentFen.opponent = "w", "b", "w") 'toggle opponent
setMove(g)
'showInternalBoard
g = StringNextItem() 'get next move
Loop
Exit Do
Case "legal" 'generates a list of all possible legal moves. this is not an official
' uci keyword
'showInternalBoard
ff = FreeFile
Open ExePath + "\boardlog.txt" For Output As #11
Print #11, currentFen.fen
Print #11, currentFen.EnPassant
Close 11
Open ExePath + "\legalmoves2.txt" For Output As #10
Close 10
legalMoves(currentFen.opponent)
For x = 0 To legalMoveCount + 1
Print legalMove(x);" ";
Next
Print " uciok"
If testForCheck(currentFen.opponent) Then
Print #10, currentFen.opponent ;" check"
Print #10, currentFen.fen
EndIf
close 10
End Select
Case "go" '1st item
Select Case StringNextItem() '2nd item
Case "searchmoves"
Case "ponder"
Case "wtime"
Case "btime"
Case "winc"
Case "binc"
Case "movestogo"
Case "depth"
Case "nodes"
Case "mate"
Case "movetime"
Print "movetime OK"
Case "infinite"
End Select
'wait for human input
legalMoves(currentFen.opponent)
If legalMoveCount Then 'manual move input
Select Case rndFlag
Case 0 'no random play
Do 'mouse input loop
Input g 'get clicked field from GUI
Select Case StringNextItem(g)
Case "field"
mousefield = StringNextItem() 'field coordinates
If fieldfrom = "" Then 'no source field selected yet
For x = 1 To legalMoveCount
If Left(legalMove(x),2) = mousefield Then 'at least one legal move
fieldfrom = mousefield
Print "fieldset " + fieldfrom 'send source field to GUI
Exit Select
EndIf
Next
ElseIf mousefield = fieldfrom Then 'source filed already selected --> deselect source field
fieldfrom = ""
Print "fieldreset" 'send reset command to GUI
Else
fieldto = mousefield 'destination field
For x = 1 To legalMoveCount 'check if chosen move is legal
If Left(legalMove(x),4) = fieldfrom + fieldto Then
Print "bestmove " + legalMove(x) + " ponder (none)" 'send move message to GUI
fieldfrom = "" 'reset field variables
mousefield = ""
Exit Do
EndIf
Next
EndIf
End Select
Loop
Case 2 'auto random
'ff = FreeFile
'Open ExePath + "\legalmoves2.txt" For Output As #10
'For x As Integer = 1 To legalMoveCount
' Print #10, legalMove(x)
'Next
'close 10
Sleep 100
Print "bestmove " + legalMove(Int(Rnd * legalMoveCount) + 1) + " ponder (none)" 'send move message to GUI
End Select
Else 'no legal moves --> mate
Print "bestmove (mate) ponder (none)" 'send mate message to GUI
EndIf
Case "stop"
Case "ponderhit"
Case "quit"
Close
End
End Select
Loop Until 1 'always leave the loop
Sleep 1
Loop
Sub showInternalBoard()
Dim As Integer col, row, breit, hoch
ScreenRes 300,300,32
Sleep 100
ScreenInfo breit, hoch
Sleep 100
Width breit\8, hoch\16
Sleep 100
ShowWindow(hWndThisWindow,SW_SHOW)
Print " 2 3 4 5 6 7 8 9"
For row = 2 To 9 'row
Print 10-row;"|";
For col = 2 To 9 'column
If board(col,row) < 0 Then
Print " ";Mid(".prnbqk",Abs(board(col,row))+1,1);
Else
Print " ";Mid(".PRNBQK",board(col,row)+1,1);
EndIf
Next
Print "|";row
Next
Print " A B C D E F G H"
'Do
' Sleep 100
'Loop Until (Inkey = "c")
Sleep
Screen 0
ShowWindow(hWndThisWindow,SW_MINIMIZE)
End Sub
'Function StringNextItem(text As String = "") As String
' Static As Integer begptr, endptr
' Static As String strRem, g
'
' If Len(text) Then
' strRem = text + " "
' begptr = 1
' endptr = 1
' EndIf
' endptr = InStr(begptr,strRem," ")
' If endptr = 0 Then
' Return ""
' EndIf
' g = Mid(strRem,begptr, endptr - begptr)
' begptr = endptr + 1
' Return g
'
'End Function
Sub legalMoves(opp As String)
'make a list of all legal moves
Dim As Integer col, row, mcol, mrow, dcol, drow, oppsig, piece, x, epcol, eprow, ff
saveBoard
ReDim legalMove(16 * 63) 'reset list
legalMoveCount = 0
ff = FreeFile
Open ExePath + "\legalmoves.txt" For Output As #ff
Print #ff, gamestamp
oppsig = IIf(opp = "w", 1, -1) 'set Sgn of the opponent
'translate en passant sign
Print #ff, "en Passant field ";currentFen.EnPassant
Close ff
If currentFen.EnPassant <> "-" Then
epcol = Asc(Mid(currentFen.EnPassant,1,1)) - Asc("a") + 2
eprow = 10 - Val(Mid(currentFen.EnPassant,2,1))
EndIf
Open ExePath + "\legalmoves2.txt" For Append As #10
Print #10, "enPassant ";currentFen.EnPassant;"*"
Print #10, "epcol ";epcol
Print #10, "eprow ";eprow
For row = 2 To 9 'all rows
For col = 2 To 9 'all columns
If Sgn(board(col,row)) = oppsig Then 'own piece
Select Case Abs(board(col,row)) 'kind of piece
Case 1 'pawn
Print #10, "bauer ";iMove(col,row);" / ";
Select Case opp 'move pawn 2 fields
Case "w"
If row = 8 Then 'base line
If (board(col,7) = 0) And (board(col,6) = 0) Then
Print #10, iMove(col,6);
setMove(iMove(col,8,col,6),opp)
EndIf
EndIf
Case "b"
If row = 3 Then 'base line
If (board(col,4) = 0) And (board(col,5) = 0) Then
Print #10, iMove(col,5);
setMove(iMove(col,3,col,5),opp)
EndIf
EndIf
End Select
mrow = row - oppsig '1 row forward
If board(col,mrow) = 0 Then 'move pawn 1 field
Print #10, iMove(col,mrow);
setMove(iMove(col,row,col,mrow),opp)
EndIf
mcol = col + 1 'capture right
piece = board(mcol,mrow)
If ((piece <> 0) Or ((epcol = mcol) And (eprow = mrow))) And (Sgn(piece) <> oppsig) And (piece <> 7) Then
'field not empty \________ en passant _________/ \_not an own piece_/ not border
Print #10, iMove(mcol,mrow);
setMove(iMove(col,row,mcol,mrow),opp)
EndIf
mcol = col - 1 'capture left
piece = board(mcol,mrow)
If ((piece <> 0) Or ((epcol = mcol) And (eprow = mrow))) And (Sgn(piece) <> oppsig) And (piece <> 7) Then
Print #10, iMove(mcol,mrow);
setMove(iMove(col,row,mcol,mrow),opp)
EndIf
Print #10,
Case 2 'rook
Print #10, "turm ";iMove(col,row);" / ";
explore(col,row,north,opp)
explore(col,row,east,opp)
explore(col,row,south,opp)
explore(col,row,west,opp)
Print #10,
Case 3 'knight
Print #10, "springer ";iMove(col,row);" / ";
For x = 1 To 8
mcol = col + knightpattern(x).col
mrow = row + knightpattern(x).row
piece = board(mcol,mrow)
Print #10, iMove(mcol,mrow);
If (piece <> 7) And ((piece = 0) Or (Sgn(piece) <> oppsig)) Then
setMove(iMove(col,row,mcol,mrow),opp)
EndIf
Next
Print #10,
Case 4 'bishop
Print #10, "läufer ";iMove(col,row);" / ";
explore(col,row,northeast,opp)
explore(col,row,southeast,opp)
explore(col,row,northwest,opp)
explore(col,row,southwest,opp)
Print #10,
Case 5 'queen
Print #10, "dame ";iMove(col,row);" / ";
explore(col,row,north,opp)
explore(col,row,east,opp)
explore(col,row,south,opp)
explore(col,row,west,opp)
explore(col,row,northeast,opp)
explore(col,row,southeast,opp)
explore(col,row,northwest,opp)
explore(col,row,southwest,opp)
Print #10,
Case 6 'king
Print #10, "könig ";iMove(col,row);" / ";
explore(col,row,north,opp,1)
explore(col,row,east,opp,1)
explore(col,row,south,opp,1)
explore(col,row,west,opp,1)
explore(col,row,northeast,opp,1)
explore(col,row,southeast,opp,1)
explore(col,row,southwest,opp,1)
explore(col,row,northwest,opp,1)
Print #10,
End Select
EndIf
Next
'showInternalBoard
Next
Close 10
Select Case opp 'test if castling is legal
Case "w"
If testForCheck("w") = 0 Then
If InStr(currentFen.Castling,"K") Then
If (board(7,9) = 0) And (board(8,9) = 0) Then
explore(6,9,east,opp,2)
EndIf
EndIf
If InStr(currentFen.Castling,"Q") Then
If (board(5,9) = 0) And (board(4,9) = 0) And (board(3,9) = 0) Then
explore(6,9,west,opp,2)
EndIf
EndIf
EndIf
Case "b"
If testForCheck("b") = 0 Then
If InStr(currentFen.Castling,"k") Then
If (board(7,2) = 0) And (board(8,2) = 0) Then
explore(6,2,east,opp,2)
EndIf
EndIf
If InStr(currentFen.Castling,"q") Then
If (board(5,2) = 0) And (board(4,2) = 0) And (board(3,2) = 0) Then
explore(6,2,west,opp,2)
EndIf
EndIf
EndIf
End Select
End Sub
Sub setMove(move As String, opp As String = "")
Dim As Integer rowfrom, rowto, colfrom, colto, x, ff
Dim As String promote, legm
If Len(move) = 5 Then 'pawn promotion
promote = Right(move,1)
move = Left(move,4)
ElseIf Len(move) <> 4 Then 'error
Return
EndIf
'Print "setMove ";move
'translate move to internal format
colfrom = Asc(Mid(move,1,1)) - Asc("a") + 2
rowfrom = 10 - Val(Mid(move,2,1))
colto = Asc(Mid(move,3,1)) - Asc("a") + 2
rowto = 10 - Val(Mid(move,4,1))
legm = IIf(board(colto,rowto) = 0,"+/","c/")
board(colto,rowto) = board(colfrom,rowfrom) 'put piece to destination field
board(colfrom,rowfrom) = 0 'clear source field
'castling
If (move = "e1g1") And board(colto,rowto) = 6 Then
setMove("h1f1")
ElseIf (move = "e1c1") And board(colto,rowto) = 6 Then
setMove("a1d1")
ElseIf (move = "e8g8") And board(colto,rowto) = -6 Then
setMove("h8f8")
ElseIf (move = "e8c8") And board(colto,rowto) = -6 Then
setMove("a8d8")
EndIf
'update castlig flag
If opp = "" Then 'normal play
Select Case Left(move,2)
Case "a1" 'left white rook
currentFen.Castling = deleteFromString(currentFen.Castling,"Q")
Case "h1" 'right white rook
currentFen.Castling = deleteFromString(currentFen.Castling,"K")
Case "e1" 'white king
currentFen.Castling = deleteFromString(currentFen.Castling,"QK")
Case "a8" 'left black rook
currentFen.Castling = deleteFromString(currentFen.Castling,"q")
Case "h8" 'right black rook
currentFen.Castling = deleteFromString(currentFen.Castling,"k")
Case "e8" 'black king
currentFen.Castling = deleteFromString(currentFen.Castling,"qk")
End Select
EndIf
'en passant
If (Abs(board(colto,rowto)) = 1) And (Mid(move,3,2) = currentFen.EnPassant) Then
' \___________pawn__________/ \____________en passant____________/
Select Case Right(currentFen.EnPassant,1) 'remove captured pawn
Case "3"
board(colto,rowto - 1) = 0 'remove white pawn
Case "6"
board(colto,rowto + 1) = 0 'remove black pawn
End Select
EndIf
'pawn promotion
Select Case promote 'promote pawn to...
Case "q"
board(colto,rowto) *= 5 'queen
Case "b"
board(colto,rowto) *= 4 'bishop
Case "n"
board(colto,rowto) *= 3 'knight
Case "r"
board(colto,rowto) *= 2 'rook
End Select
If opp = "" Then 'no test mode --> set en passant field, otherwise don't change
If (Abs(board(colto,rowto)) = 1) And (Abs(rowfrom - rowto) = 2) Then
' \_________pawn____________/ \pawn was moved 2 rows_/
currentFen.EnPassant = Mid(move,3,1) 'column
Select Case Mid(move,4,1) 'row
Case "4"
currentFen.EnPassant += "3"
Case "5"
currentFen.EnPassant += "6"
End Select
Else 'no en passant
currentFen.EnPassant = "-" 'reset en passant field
EndIf
Else 'test mode
x = testForCheck(opp)
If x = 0 Then
If Abs(board(colto,rowto)) = 1 And (move[3] = Asc("1") Or move[3] = Asc("8")) Then 'pawn promotion
move += "q"
EndIf
'add move to the legal moves list
legalMoveCount += 1
legalMove(legalMoveCount) = move
ff = FreeFile
Open ExePath + "\legalmoves.txt" For Append As #ff
Print #ff, move
Close ff
Print #10,legm;
Else
Print #10,x;"i/";
printInternalBoard(move)
move = "" 'move is illegal
'sleep
EndIf
restoreBoard
EndIf
Return
End Sub
Sub explore(col As Integer, row As Integer, d As direction, opp As String, kingflag As Integer = 0)
'move the piece along the desired direction as far as possible
Dim As Integer x = 0, mcol, mrow, oppsig, ff
oppsig = IIf(opp = "w", 1, -1)
Do
x += 1
mcol = col + x * d.col
mrow = row + x * d.row
Print #10, iMove(mcol,mrow);
Select Case board(mcol,mrow) 'destination field
Case 0 'destination field is empty
'Print #10, "+/";
setMove(iMove(col,row,mcol,mrow),opp) 'test
Case 7 'border
Print #10, ":/";
Return
Case Else
If Sgn(board(mcol,mrow)) = oppsig Then 'own piece
Print #10, "o/";
Return
Else
'Print #10, "x/";
setMove(iMove(col,row,mcol,mrow),opp) 'test (capture)
Return
EndIf
End Select
Loop Until x = kingflag
End Sub
Function iMove(colfrom As Integer, rowfrom As Integer, colto As Integer = 1, rowto As Integer = 1) As String
'translate internal format to move
Return Mid(" abcdefgh",colfrom,1) + Mid(" 87654321",rowfrom,1) + _
Mid(" abcdefgh",colto,1) + Mid(" 87654321",rowto,1)
End Function
Sub printInternalBoard(move As String)
Dim As Integer col, row, ff
ff = FreeFile
Open ExePath + "\boardlog.txt" For Append As #11
Print #11, "*********************************************************"
Print #11, move
Print #11, " 2 3 4 5 6 7 8 9 "
For row = 2 To 9 'row
Print #11, 10-row;"|";
For col = 2 To 9 'column
Print #11, board(col,row);
Next
Print #11, "|";row;" "
Next
Print #11, " A B C D E F G H "
'Print "*********************************************************"
'Sleep 5000
Close 11
End Sub
'move a piece field by field along the desired direction as far as possible and check for every
' field if the move would be legal