Buchempfehlung
MySQL kurz & gut
MySQL kurz & gut
Das preiswerte Taschen- buch stellt MySQL-rele- vante Inhalte systematisch und knapp dar, sodass es sich optimal zum Nach- schlagen beim Pro- grammieren eignet. [Mehr Infos...]
FreeBASIC-Chat
Es sind Benutzer im FreeBASIC-Chat online.
(Stand:  )
FreeBASIC bei Twitter
Twitter FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!

fb:porticula NoPaste

Info
Info / Hilfe
Liste
Übersicht / Liste
Neu
Datei hochladen
Suche
Quellcode suchen
Download
Dateidownload

Colochessum human interface 0.1

Uploader:Mitgliedgrindstone
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