Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Colochessum human interface 0.1
| Uploader: |  grindstone |
| Datum/Zeit: | 29.01.2014 08:23:25 |
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"
Const As String w = "white", b = "black"
Randomize Timer
Type direction
col As Integer
row As Integer
End Type
Dim Shared As direction north, northeast, east, southeast, south, southwest, west, northwest, _
knightpattern(8)
'set direction offsets
north.col = 0
north.row = -1
northeast.col = 1
northeast.row = -1
east.col = 1
east.row = 0
southeast.col = 1
southeast.row = 1
south.col = 0
south.row = 1
southwest.col = -1
southwest.row = 1
west.col = -1
west.row = 0
northwest.col = -1
northwest.row = -1
'set knight movement pattern
Restore kpat
For x As Integer = 1 To 8
Read knightpattern(x).col
Read knightpattern(x).row
Next
kpat:
Data -1,-2, 1,-2, 2,-1, 2,1, 1,2, -1,2, -2,1, -2,-1
Dim Shared As HANDLE hReadChildPipe, hWriteChildPipe, hReadPipe, hWritePipe, hWndThisWindow
Dim Shared As Integer board(12,12), sBoard(12,12)
ReDim Shared As String legalMove(16 * 63)
Dim Shared As String fenBoard, fenOpponent, fenCastling, fenEnPassant, fenHalfmoves, _
fenMoves, opponent, castlingFlag, currentFen
Dim Shared As Integer count50, moveCount, legalMoveCount, mx, my, mw, mb
Dim As STARTUPINFO si
Dim As PROCESS_INFORMATION pi
Dim As SECURITY_ATTRIBUTES sa
Dim As OVERLAPPED ol
Dim As Integer iTotalBytesAvail, iNumberOfBytesWritten, iBytesToRead, x, y
Dim As String sRet = "", sBuf, g, fieldfrom, fieldto, mousefield
Declare Sub fenToBoard(fen As String)
Declare Sub parseFen(fen As String)
Declare Sub showInternalBoard()
Declare Function StringNextItem(text As String = "") As String
Declare Sub setMove(move As String, opp As String = "")
Declare Function testForCheck(opp As String) As Integer
Declare Sub saveBoard
Declare Sub restoreBoard
Declare Sub legalMoves(opp As String)
Declare Function iMove(colfrom As Integer, rowfrom As Integer, colto As Integer, rowto As Integer) As String
Declare Sub explore(col As Integer, row As Integer, d As direction, opp As String, kingflag As Integer = 0)
Declare Function deleteFromString(text As String, del As String) As String
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 "author grindstone"
Print "version 0.1 2014
Print "uciok"
Exit Do
Case "debug"
Select Case StringNextItem() '2nd item
Case"on"
Case "off"
End Select
Case "isready"
Print "readyok"
Case "setoption"
Select Case StringNextItem() '2nd item
Case "name"
End Select
Case "ucinewgame"
Case "position"
Select Case StringNextItem() '2nd item
Case "startpos"
currentFen = "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1" 'startposition
fenToBoard(currentFen)
Print "startpos OK"
Case "fen"
currentFen = StringNextItem() 'board setup
currentFen += " " + StringNextItem() 'opponent
currentFen += " " + StringNextItem() 'castling flag
currentFen += " " + StringNextItem() 'en passant
currentFen += " " + StringNextItem() 'halfmove counter
currentFen += " " + StringNextItem() 'move counter
fenToBoard(currentFen)
Case Else
'error
End Select
Select Case StringNextItem() '3rd item
Case "moves"
g = StringNextItem()
'showInternalBoard
Do While Len(g) 'do moves
If opponent = w Then 'toggle opponent
opponent = b
Else
opponent = w
EndIf
setMove(g)
'showInternalBoard
g = StringNextItem() 'get next move
Loop
Exit Do
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(opponent)
If legalMoveCount Then 'manual move input
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 choosen move is legal
If legalMove(x) = fieldfrom + fieldto Then
Print "bestmove " + fieldfrom + fieldto + " ponder (none)" 'send move message to GUI
fieldfrom = "" 'reset field variables
mousefield = ""
Exit Do
EndIf
Next
EndIf
End Select
Loop
Else 'no legal moves --> mate
Print "bestmove (mate) ponder (none)" 'send mate message to GUI
EndIf
Case "stop"
Case "ponderhit"
Case "quit"
End Select
Loop Until 1 'always leave the loop
Sleep 1
Loop
Sub fenToBoard(fen As String)
Dim As Integer x, y, i, row, col
Dim As String opp, g
'preset board
For col = 0 To 11
For row = 0 To 11
board(col,row) = 7 'border
Next
Next
row = 2
col = 1
parseFen(fen)
'setup board
For x = 1 To InStr(fen," ") - 1
Select Case Mid(fen,x,1)
Case "1" To "8" 'empty field(s)
i = Val(Mid(fen,x,1))
For y = 1 To i
board(col + y, row) = 0 'empty field
Next
col += i
Case "/" 'next row
row += 1
col = 1
Case Else
col += 1 'next column
board(col,row) = InStr("PRNBQKprnbqk",Mid(fen,x,1)) 'put piece to field
If board(col,row) > 6 Then 'black piece
board(col,row) = -1 * (board(col,row) - 6) 'convert sign
EndIf
End Select
Next
If fenOpponent = "w" Then
opponent = w
Else
opponent = b
EndIf
castlingFlag = fenCastling
count50 = ValInt(fenHalfmoves)
moveCount = ValInt(fenMoves)
'Open ExePath + "\hdmoves.txt" For Output As #1
' Print #1, " "
' For i1 As Integer = 0 To 12
' For i2 As Integer = 0 To 12
' Print #1, board(i2,i1);
' Next
' Print #1, ""
' Next
' Close #1
End Sub
Sub parseFen(fen As String)
Dim As Integer ptr1, ptr2
ptr1 = InStr(fen," ")
fenBoard = Left(fen,ptr1 - 1)
ptr2 = InStr(ptr1 + 1,fen," ")
fenOpponent = Mid(fen,ptr1 + 1,ptr2 - ptr1 - 1)
ptr1 = InStr(ptr2 + 1,fen," ")
fenCastling = Mid(fen,ptr2 + 1,ptr1 - ptr2 - 1)
ptr2 = InStr(ptr1 + 1,fen," ")
fenEnPassant = Mid(fen,ptr1 + 1,ptr2 - ptr1 - 1)
ptr1 = InStr(ptr2 + 1,fen," ")
fenHalfmoves = Mid(fen,ptr2 + 1,ptr1 - ptr2 - 1)
fenMoves = Mid(fen,ptr1 + 1)
End Sub
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")
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
Function iMove(colfrom As Integer, rowfrom As Integer, colto As Integer, rowto As Integer) As String
'translate internal format to move
Return Mid(" abcdefgh",colfrom,1) + Str(10 - rowfrom) + _
Mid(" abcdefgh",colto,1) + Str(10 - rowto)
End Function
Sub setMove(move As String, opp As String = "")
Dim As Integer rowfrom, rowto, colfrom, colto, x
Dim As String promote
Static As String enPassant
If Len(move) = 5 Then
promote = Right(move,1)
move = Left(move,4)
ElseIf Len(move) <> 4 Then
Return
EndIf
'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))
board(colto,rowto) = board(colfrom,rowfrom)
board(colfrom,rowfrom) = 0
If opp <> "" Then
If fenEnPassant = "-" Then
enPassant = ""
Else
enPassant = fenEnPassant
EndIf
EndIf
'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
fenCastling = deleteFromString(fenCastling,"Q")
Case "h1" 'right white rook
fenCastling = deleteFromString(fenCastling,"K")
Case "e1" 'white king
fenCastling = deleteFromString(fenCastling,"QK")
Case "a8" 'left black rook
fenCastling = deleteFromString(fenCastling,"q")
Case "h8" 'right black rook
fenCastling = deleteFromString(fenCastling,"k")
Case "e8" 'black king
fenCastling = deleteFromString(fenCastling,"qk")
End Select
EndIf
'en passant
If (Abs(board(colto,rowto)) = 1) And (colto <> colfrom) And (Mid(move,3,2) = enPassant) Then
Select Case Right(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
If (Abs(board(colto,rowto)) = 1) And (Abs(rowfrom - rowto) = 2) Then 'en passant
enPassant = Mid(move,3,1)
Select Case Mid(move,4,1)
Case "4"
enPassant += "3"
Case "5"
enPassant += "6"
End Select
Else
If opp = "" Then
enPassant = ""
EndIf
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
If testForCheck(opp) = 0 Then
legalMoveCount += 1
legalMove(legalMoveCount) = move
EndIf
restoreBoard
EndIf
End Sub
Function testForCheck(opp As String) As Integer
Dim As Integer x, col, row, drow, dcol, kingrow, kingcol, kingsig
'set Sgn of the king
If opp = w Then
kingsig = 1
Else
kingsig = -1
EndIf
'get the internal coordinates of the king
For row = 2 To 9
For col = 2 To 9
If board(col,row) = kingsig * 6 Then 'king found
kingrow = row
kingcol = col
Exit For,For 'terminate searching
EndIf
Next
Next
'let the king look around
For dcol = -1 To 1 'left -> rest -> right
For drow = -1 To 1 'up -> rest -> down
col = kingcol 'start at king coordinates
row = kingrow
Do 'look along the desired direction
col += dcol 'next field
row += drow
If board(col,row) Then 'field not empty
If (board(col,row) = 7) Or (Sgn(board(col,row)) = kingsig) Then 'border or piece of own colour
Exit Do 'next direction
EndIf
Select Case Abs(board(col,row)) 'kind of piece
Case 1 'pawn
If (Abs(kingcol - col) = 1) And ((kingrow - row) = kingsig) Then 'check by pawn
Return 1
Else
Exit Do 'next direction
EndIf
Case 2 'rook
If (dcol = 0) Or (drow = 0) Then 'king is looking straight
Return 1
EndIf
Case 4 'bishop
If (dcol <> 0) And (drow <> 0) Then 'king is looking diagonal
Return 1
EndIf
Case 5 'queen
Return 1
Case 6 'king
If (Abs(kingcol - col) < 2) Or (Abs(kingrow - row) < 2) Then
Return 1
EndIf
End Select
EndIf
Loop
Next
Next
Restore knightCheck
For x = 1 To 8
Read dcol, drow
If board(kingcol + dcol, kingrow + drow) = kingsig * -3 Then 'knight
Return 1
EndIf
Next
Return 0 'no check
End Function
knightCheck:
Data -1,-2, 1,-2, 2,-1, 2,1, 1,2, -1,2, -2,1, -2,-1
Sub saveBoard
Dim As Integer col, row
For row = 0 To 12
For col = 0 To 12
sBoard(col,row) = board(col,row)
Next
Next
End Sub
Sub restoreBoard
Dim As Integer col, row
For row = 0 To 12
For col = 0 To 12
Board(col,row) = sBoard(col,row)
Next
Next
End Sub
Sub legalMoves(opp As String)
Dim As Integer col, row, mcol, mrow, dcol, drow, oppsig, piece, x, epcol, eprow
saveBoard
ReDim legalMove(16 * 63)
legalMoveCount = 0
'set Sgn of the opponent
If opp = w Then
oppsig = 1
Else
oppsig = -1
EndIf
'translate en passant sign
If fenEnPassant <> "-" Then
epcol = Asc(Mid(fenEnPassant,1,1)) - Asc("a") + 2
eprow = 10 - Val(Mid(fenEnPassant,2,1))
EndIf
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
mcol = col
mrow = row - oppsig
If board(col,mrow) = 0 Then 'move
setMove(iMove(col,row,mcol,mrow),opp) 'test
EndIf
Select Case opp
Case w
If row = 8 Then 'base line
If (board(col,7) = 0) And (board(col,6) = 0) Then
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
setMove(iMove(col,3,col,5),opp)
EndIf
EndIf
End Select
mrow = row - oppsig
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
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
setMove(iMove(col,row,mcol,mrow),opp)
EndIf
Case 2 'rook
explore(col,row,north,opp)
explore(col,row,east,opp)
explore(col,row,south,opp)
explore(col,row,west,opp)
Case 3 'knight
For x = 1 To 8
mcol = col + knightpattern(x).col
mrow = row + knightpattern(x).row
piece = board(mcol,mrow)
If (piece <> 7) And ((piece = 0) Or (Sgn(piece) <> oppsig)) Then
setMove(iMove(col,row,mcol,mrow),opp)
EndIf
Next
'sleep
Case 4 'bishop
explore(col,row,northeast,opp)
explore(col,row,southeast,opp)
explore(col,row,northwest,opp)
explore(col,row,southwest,opp)
Case 5 'queen
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)
Case 6 'king
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)
End Select
EndIf
Next
'showInternalBoard
Next
Select Case opp 'test if castling is legal
Case w
If testForCheck(w) = 0 Then
If InStr(fenCastling,"K") Then
If (board(7,9) = 0) And (board(8,9) = 0) Then
explore(6,9,east,opp,2)
EndIf
EndIf
If InStr(fenCastling,"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(fenCastling,"k") Then
If (board(7,2) = 0) And (board(8,2) = 0) Then
explore(6,2,east,opp,2)
EndIf
EndIf
If InStr(fenCastling,"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
'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
Sub explore(col As Integer, row As Integer, d As direction, opp As String, kingflag As Integer = 0)
Dim As Integer x, mcol, mrow, oppsig
If opp = w Then
oppsig = 1
Else
oppsig = -1
EndIf
Do
x += 1
mcol = col + x * d.col
mrow = row + x * d.row
Select Case board(mcol,mrow) 'destination field
Case 0 'destination field is empty
setMove(iMove(col,row,mcol,mrow),opp) 'test
Case 7 'border
Return
Case Else
If Sgn(board(mcol,mrow)) = oppsig Then 'own piece
Return
Else
setMove(iMove(col,row,mcol,mrow),opp) 'test (capture)
Return
EndIf
End Select
Loop Until x = kingflag
End Sub
Function deleteFromString(text As String, del As String) As String
Dim As String g
Dim As Integer x, y
For x = 1 To Len(text)
If InStr(Mid(text,x,1), Any del) = 0 Then
g += Mid(text,x,1)
EndIf
Next
Return g
End Function