fb:porticula NoPaste
Colochessum_0.4
Uploader: | grindstone |
Datum/Zeit: | 29.01.2014 08:05:25 |
Hinweis: Dieser Quelltext ist Bestandteil des Projekts Colochessum, zu dem es auf FreeBASIC-Portal.de eine Projektseite gibt.
' COLOCHESSUM
'*****************************************************************************************
' This program was written on the base of "gui.exe" written by VANYA, who's graphics and
' animation routines were inherited nearly unchanged.
' The pieces were created by BasicCoder2
' Special thanks to ALWIM and Roland Chastain for their helpful hints.
'*****************************************************************************************
#Include Once "windows.bi"
#Include "fbgfx.bi"
#Include "vbcompat.bi"
Type chessMove
x1 As Integer
x2 As Integer
y1 As Integer
y2 As Integer
End Type
Type wText
opponent As String
move As String
depth As String
End Type
Const As Integer castlingWhite = 1, castlingBlack = 2, cfont = RGB(0,0,0), _
cback = RGB(100,255,100), cbacklt = RGB(220,255,220)
Const As String w = "white", b = "black"
Dim Shared As Integer mx, my, btn, ox, oy, dx, dy, depth, moveTimePreset, currentWhite, _
currentBlack, errorCount, moveCount, relSpeed, _
animationSpeed, ExitCode, count50, pchoice, moveTimeHandicap, _
drawnGames, mox, moy, mob, mow, gameCount, depthPreset, depthHandicap, _
gameTimePreset, gameTimeHandicap, menuitemhit
Dim Shared As Integer board(12,12) 'internal representation of board
Dim Shared As Integer moveTime(2), winEngine(2), depthEngine(2), timeLeft(2), gameTime(2), _
timePlayed(2)
Dim Shared As Integer mateFlag, replayFlag, setEngineOptionsFlag, humanFlag 'flags
Dim Shared As Integer bx, by 'position top/left of board
Dim Shared As wText wt
Dim Shared As FB.Image Ptr sImage
Dim Shared As FB.Image Ptr iPiece(12) '12 images
Dim Shared As String engine(2), matesign(2)
ReDim Shared As String fen(1), movetable(1), engineOptions(5,1)
Dim Shared As String hod, moves, currDepth, nameWhite, castlingFlag, fenstr, menuitem, _
nameBlack, WindowText, move, opponent, playmode, lastmove, replayMoves, _
iniFile, fenBoard, fenOpponent, fenCastling, fenEnPassant, fenHalfmoves, _
fenMoves
Dim Shared As HANDLE hReadChildPipeWhite, hWriteChildPipeWhite, hReadChildPipeBlack, _
hWriteChildPipeBlack, hReadPipeWhite, hWritePipeWhite, hReadPipeBlack, _
hWritePipeBlack, hwndThisWindow, hProcessHandleWhite, hProcessHandleBlack
Dim Shared As Any Ptr thMouse
Dim Shared As ZString * 100 iniBuffer
Dim Shared As Double gameStamp, timeRemind
Declare Function GetEngineResponse(opponent As String) As String
Declare Function GetMove(opponent As String) As String
Declare Sub WriteEngineInfo(opponent As String, s As String)
Declare Sub update()
Declare Function strMoveToNumMove(move As String) As chessMove
Declare Sub makeMove(cMove As chessMove)
Declare Sub SetTitleBar
Declare Sub CloseEngines
Declare Sub PrintMoveTable
Declare Function makeFen() As String
Declare Sub fenToBoard(fen As String)
Declare Sub parseFen(fen As String)
Declare Function deleteFromString(text As String, character As String) As String
Declare Function checkForStale() As Integer
Declare Sub mouseMenu(text As String, separator As String, lin As Integer = 1, _
col As Integer = 1, foreground As UInteger, background As UInteger, _
mode As Integer = 0)
Declare Sub continueTurnament()
Declare Sub replayGame()
Declare Sub setup
Declare Sub setupEngine(engine As String, engNumber As Integer)
Declare Sub setEngineOptions(engine As String)
Declare Sub showInternalBoard()
Declare Sub pCon OverLoad (t As String = "",text As String)
Declare Sub pCon (text As String)
Declare Sub pCon (t As String = "",x As Integer)
Declare Sub pCon (x As Integer)
Declare Function timeFormat (seconds As Double, mode As Integer = 0) As String
Declare Sub Scan
Declare Sub GetEngineOptions(engine As String)
Dim As Integer x, y, menlin, mencol
Dim As String datum, g, g2, matecomp, movecomp, winner, keypressed
Dim As chessMove cMove
Dim As STARTUPINFO siWhite, siBlack
Dim As PROCESS_INFORMATION pi
Dim As SECURITY_ATTRIBUTES sa
Enum
oname = 1
otype
odefault
omin
omax
ovar = omin
End Enum
ScreenRes 640,608,32,2
ScreenSet 1,1
hwndThisWindow = GetForegroundWindow() 'get the window handle
startNew:
MkDir(ExePath + "\engines") 'create engines directory if not exists
iniFile = ExePath + "\setup.ini"
If Not FileExists(inifile) Then 'create .ini - file
Open inifile For Output As #1
Print #1, "[]"
Close 1
EndIf
'get variables from the .ini-file
GetPrivateProfileString("","engine1","none",@iniBuffer,100,StrPtr(iniFile))
engine(1) = iniBuffer
GetPrivateProfileString("","engine2","none",@iniBuffer,100,StrPtr(iniFile))
engine(2) = iniBuffer
GetPrivateProfileString("","animationSpeed","15",@iniBuffer,100,StrPtr(iniFile))
animationSpeed = Val(iniBuffer)
GetPrivateProfileString("","playmode","movetime",@iniBuffer,100,StrPtr(iniFile))
playmode = iniBuffer
GetPrivateProfileString("","moveTimePreset","100",@iniBuffer,100,StrPtr(iniFile))
moveTimePreset = Val(iniBuffer)
GetPrivateProfileString("","moveTimeHandicap","100",@iniBuffer,100,StrPtr(iniFile))
moveTimeHandicap = Val(iniBuffer)
GetPrivateProfileString("","depthPreset","10",@iniBuffer,100,StrPtr(iniFile))
depthPreset = Val(iniBuffer)
GetPrivateProfileString("","depthHandicap","1",@iniBuffer,100,StrPtr(iniFile))
depthHandicap = Val(iniBuffer)
GetPrivateProfileString("","gameTimePreset","300",@iniBuffer,100,StrPtr(iniFile))
gameTimePreset = Val(iniBuffer) 'default 5 minutes
GetPrivateProfileString("","gameTimeHandicap","10",@iniBuffer,100,StrPtr(iniFile))
gameTimeHandicap = Val(iniBuffer)
Color cfont,cback
Cls
mainMenu:
Color cfont,cback
Cls
Locate 15,20
Print "********** M A I N M E N U **********"
mencol = 25
menlin = 20
Do 'main menu loop
keypressed = Inkey
menuitem = ""
mouseMenu(" B = Begin new turnament ","=",menlin,mencol,cfont,cback)
mouseMenu(" C = Continue last turnament ","=",menlin + 2,mencol,cfont,cback)
mouseMenu(" R = Replay game ","=",menlin + 4,mencol,cfont,cback)
mouseMenu(" S = Setup ","=",menlin + 6,mencol,cfont,cback,0)
mouseMenu(" Esc = Quit program ","=",menlin + 8,mencol,cfont,cback)
Select Case menuitem 'convert menuitem to keystroke
Case ""
'do nothing
Case "Esc"
keypressed = Chr(27)
Case Else
keypressed = LCase(menuitem) 'key
End Select
Select Case keypressed
Case "b" 'begin new turnament
winEngine(1) = 0
winEngine(2) = 0
drawnGames = 0
moveTime(1) = moveTimePreset
moveTime(2) = moveTimePreset
depthEngine(1) = depthPreset
depthEngine(2) = depthPreset
gameTime(1) = gameTimePreset
gameTime(2) = gameTimePreset
Exit Do
Case "c" 'continue last turnament
continueTurnament
'sleep
Exit Do
Case "r" 'replay game
replayGame
Exit Do
Case "s" 'setup menu
setup
GoTo mainMenu
Case Chr(27), Chr(255,107) 'end program
End
End Select
Loop
Cls
Do 'turnament loop
ReDim fen(1)
ReDim movetable(0)
If (replayFlag = 0) Or (gameStamp = 0) Then
gameStamp = Now 'game identifier
EndIf
count50 = 0
castlingFlag = "KQkq"
humanFlag = 0
If replayFlag <> 1 Then 'no manual replay
gameCount += 1 'game counter
Open ExePath + "\ucilog.txt" For Output As #3 'initiate new file
Print #3, gamestamp
Close 3
Open ExePath + "\fenlog.txt" For Output As #4 'initiate new file
Print #4, gamestamp
Close 4
'swap engines
If gameCount And 1 Then 'every odd game number
currentWhite = 1
currentBlack = 2
Else 'every even game number
currentWhite = 2
currentBlack = 1
EndIf
'install the pipes to the two engines
sa.nLength = SizeOf(SECURITY_ATTRIBUTES)
sa.lpSecurityDescriptor = NULL
sa.bInheritHandle = TRUE
'start and connect white engine
CreatePipe(@hReadChildPipeWhite,@hWritePipeWhite,@sa,0)
CreatePipe(@hReadPipeWhite,@hWriteChildPipeWhite,@sa,0)
GetStartupInfo(@siWhite)
siWhite.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
siWhite.wShowWindow = SW_HIDE
siWhite.hStdOutput = hWriteChildPipeWhite
siWhite.hStdError = hWriteChildPipeWhite
siWhite.hStdInput = hReadChildPipeWhite
CreateProcess(0,ExePath + "\engines\" + engine(currentWhite),0,0,TRUE,0,0,0,@siWhite,@pi)
If engine(currentWhite) = "human.exe" Then
humanFlag = humanFlag Or 1
EndIf
hProcessHandleWhite = pi.hProcess
CloseHandle(hWriteChildPipeWhite)
CloseHandle(hReadChildPipeWhite)
'start and connect black engine
CreatePipe(@hReadChildPipeBlack,@hWritePipeBlack,@sa,0)
CreatePipe(@hReadPipeBlack,@hWriteChildPipeBlack,@sa,0)
GetStartupInfo(@siBlack)
siBlack.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
siBlack.wShowWindow = SW_HIDE
siBlack.hStdOutput = hWriteChildPipeBlack
siBlack.hStdError = hWriteChildPipeBlack
siBlack.hStdInput = hReadChildPipeBlack
CreateProcess(0,ExePath + "\engines\" + engine(currentBlack),0,0,TRUE,0,0,0,@siBlack,@pi)
If engine(currentBlack) = "human.exe" Then
humanFlag = humanFlag Or 2
EndIf
hProcessHandleBlack = pi.hProcess
CloseHandle(hWriteChildPipeBlack)
CloseHandle(hReadChildPipeBlack)
EndIf
sImage = ImageCreate( 42, 42, 0 ) 'save screen data
'THIS DETERMINES WHERE TO PLACE BOARD IN WINDOW
bx = 150
by = 30
'read board
Restore boardLayout
For j As Integer = 0 To 11
For i As Integer = 0 To 11
Read board(i,j)
Next i
Next j
'copy images from data statements to screen
Restore Pieces
For i As Integer = 0 To 5 'for each piece
For y As Integer = 0 To 41 'for each row
Read datum
For x As Integer = 0 To 41 'for each column
Select Case Mid(datum,x+1,1)
Case "."
PSet(x+i*42,y),RGB(255,0,255) 'transparent color
PSet(x+i*42+252,y),RGB(255,0,255)
Case "#"
PSet(x+i*42,y),RGB(0,0,0)
PSet(x+i*42+252,y),RGB(0,0,0)
Case "*"
PSet(x+i*42,y),RGB(120,120,180)
PSet(x+i*42+252,y),RGB(250,200,200)
End Select
Next x
Next y
Next i
'sleep
'allocate memory for 12 images
For i As Integer = 0 To 11
iPiece(i) = ImageCreate(42,42,0)
Next i
'get set of 12 images
For i As Integer = 0 To 11
Get (i*42,0)-(i*42+41,41), iPiece(i)
Next i
update()
'reset variables
move = ""
wt.move = "xx xx"
opponent = b '(!)
hod = "position startpos moves"
moves = ""
mateFlag = 0
moveCount = 0
If replayFlag = 0 Then 'no replay
timeLeft(1) = gameTime(1) * 1000
timeLeft(2) = gameTime(2) * 1000
timePlayed(1) = 0
timePlayed(2) = 0
EndIf
If replayFlag <> 1 Then
Open ExePath + "\gamelog.txt" For Output As #1 'open the protocol file
Print #1, "game";gameCount
Print #1, "stamp";gamestamp
Locate 52,30
Print "LOADING ENGINES"
If humanFlag Or 1 Then
WriteEngineInfo(w,Str(hReadChildPipeBlack))
WriteEngineInfo(w,Str(hWriteChildPipeBlack))
WriteEngineInfo(w,Str(hReadPipeBlack))
WriteEngineInfo(w,Str(hWritePipeBlack))
EndIf
If humanflag Or 2 Then
WriteEngineInfo(b,Str(hReadChildPipeBlack))
WriteEngineInfo(b,Str(hWriteChildPipeBlack))
WriteEngineInfo(b,Str(hReadPipeBlack))
WriteEngineInfo(b,Str(hWritePipeBlack))
EndIf
WriteEngineInfo(w,"uci")
WriteEngineInfo(b,"uci")
Do
g = GetEngineResponse(w)
Loop Until InStr(g,"uciok")
x = InStr(g,"id name ") + 8
nameWhite = Mid(g, x, InStr(x,g,Chr(13)) - x) 'get the name of engine 1
Do
g = GetEngineResponse(b)
Loop Until InStr(g,"uciok")
x = InStr(g,"id name ") + 8
nameBlack = Mid(g, x, InStr(x,g,Chr(13)) - x) 'get the name of engine 2
'write to protocol file
Print #1, "white ";nameWhite;" (";engine(currentWhite);")"
Print #1, "black ";nameBlack;" (";engine(currentBlack);")"
Print #1, "mode ";playmode;
Select Case playmode
Case "depth"
Print #1, depth
Case "movetime"
Print #1, moveTimePreset
Case "gametime"
Print #1, gameTimePreset
End Select
Print #1, ""
'Close 1
Open ExePath + "\turnamentlog.txt" For Append As #2
Print #2, ""
Print #2, "game";gameCount
Print #2, "stamp";gameStamp
Print #2, "white ";nameWhite;" ";engine(currentWhite)
Print #2, "black ";nameBlack;" ";engine(currentBlack)
Print #2, "mode ";playmode;
Select Case playmode
Case "depth"
Print #2, depth
Case "movetime"
Print #2, moveTimePreset;" (+";moveTimeHandicap;")"
Case "gametime"
Print #2, gameTimePreset;" (";gameTimeHandicap;")"
End Select
Close 2
'get the "mate"-messages from engine 1
WriteEngineInfo(w,"position fen 7K/6q1/7b/8/8/8/8/6k1 w - - 3 41 moves")
WriteEngineInfo(w,"go movetime 10")
matesign(1) = GetMove("fullwhite")
'get the "mate"-messages from engine 2
WriteEngineInfo(b,"position fen 7K/6q1/7b/8/8/8/8/6k1 w - - 3 41 moves")
WriteEngineInfo(b,"go movetime 10")
matesign(2) = GetMove("fullblack")
'Open ExePath + "\gamelog.txt" For Append As #1 'open the protocol file
Print #1, matesign(1);"*"
Print #1, matesign(2);"*"
Close 1
'set engine 1 options
setEngineOptions(w)
setEngineOptions(b)
EndIf
'*************** MAIN LOOP ************************
Do 'next halfmove
'switch opponents
humanFlag = 0
If opponent = w Then
opponent = b 'black
If nameBlack = "Colochessum human interface" Then
humanFlag = 1
EndIf
Else
opponent = w 'white
moveCount += 1 'move number
If nameWhite = "Colochessum human interface" Then
humanFlag = 1
EndIf
EndIf
g = makeFen
If replayFlag <> 1 Then
Open ExePath + "\fenlog.txt" For Append As #4 'write fen-string to log fole
Print #4, g
Close #4
EndIf
Locate 57,1
ReDim Preserve fen(UBound(fen) + 1)
fen(UBound(fen)) = g 'write fen-string to table
ScreenLock
update
Scan
ScreenUnLock
'showInternalBoard
mateFlag = 0
errorCount = 0 'reset the error counter
Print #1, Time;" ";moveCount;" ";opponent;" ";hod;moves 'write to protocol file
Print #1, ""
If replayFlag = 0 Then 'no replay --> calculate next move
WriteEngineInfo(opponent,hod + moves) 'send the actual board setup to the engine
ScreenLock
update()
Scan
ScreenUnLock
Select Case playmode
Case "depth"
Select Case opponent
Case w
WriteEngineInfo(opponent,"go depth " + Str(depthEngine(currentWhite))) 'depth mode
Case b
WriteEngineInfo(opponent,"go depth " + Str(depthEngine(currentBlack)))
End Select
Case "movetime"
timeRemind = Timer
Select Case opponent 'call the actual opponent with its movetime
Case w
WriteEngineInfo(opponent,"go movetime " + Str(moveTime(currentWhite)))
Case b
WriteEngineInfo(opponent,"go movetime " + Str(moveTime(currentBlack)))
End Select
Case "gametime"
timeRemind = Timer
Select Case opponent 'call the actual opponent with its rest time
Case w
WriteEngineInfo(opponent,"go wtime " + Str(timeLeft(currentWhite)))
Case b
WriteEngineInfo(opponent,"go btime " + Str(timeLeft(currentBlack)))
End Select
End Select
EndIf
move = GetMove(opponent) 'read the "bestmove" from the engine
If setEngineOptionsFlag Then
setEngineOptions(w)
setEngineOptions(b)
setEngineOptionsFlag = 0
update
EndIf
If move = "Esc" Then 'start a new game
Close
CloseEngines
replayFlag = 0
GoTo startNew
EndIf
If (playmode = "gametime") And (replayFlag = 0) Then 'subtract the calculating time
Select Case opponent
Case w
timeLeft(currentWhite) -= 1000 * (Timer - timeRemind)
If timeLeft(currentWhite) <= 0 Then
move = "timeout"
EndIf
Case b
timeLeft(currentBlack) -= 1000 * (Timer - timeRemind)
If timeLeft(currentBlack) <= 0 Then
move = "timeout"
EndIf
End Select
Open ExePath + "\timelog.txt" For Output As #6
Print #6, gameStamp
Print #6, timeLeft(1)
Print #6, timeLeft(2)
Close 6
ElseIf (playmode = "movetime") And (replayFlag = 0) Then 'add the calculating time
Select Case opponent
Case w
timePlayed(currentWhite) += 1000 * (Timer - timeRemind)
Case b
timePlayed(currentBlack) += 1000 * (Timer - timeRemind)
End Select
Open ExePath + "\timelog.txt" For Output As #6
Print #6, gameStamp
Print #6, timePlayed(1)
Print #6, timePlayed(2)
Close 6
EndIf
lastmove = move
'check if the response is a correct move
If move = "mate" Then 'checkmate
If checkForStale Then
mateFlag = 2 'stalemate
Else
mateFlag = 1 'checkmate
EndIf
ElseIf move = "timeout" Then
mateFlag = 6
ElseIf InStr(Mid(move,1,1),Any "abcdefgh") + _ '1st character
InStr(Mid(move,2,1),Any "12345678") + _ '2nd character
InStr(Mid(move,3,1),Any "abcdefgh") + _ '3rd character
InStr(Mid(move,4,1),Any "12345678") + _ '4th character
InStr(Mid(move,5,1),Any "qrbn") <> Len(move) Then '5th character (if existing)
'error
Locate 52,30
Print #1, move
Print #1, "game aborted due to response error caused by ";
Select Case opponent
Case w
Print #1, nameWhite
Case b
Print #1, nameBlack
End Select
If replayFlag <> 1 Then
Open ExePath + "\turnamentlog.txt" For Append As #2
Print #2, hod;moves;" *";move;"*"
Print #2, "game aborted due to response error caused by ";
Select Case opponent
Case w
Print #2, nameWhite
Case b
Print #2, nameBlack
End Select
Close 2
EndIf
Exit Do 'terminate current game
EndIf
Do 'check for drawn game
If mateFlag Then 'checkmate or stalemate
Exit Do 'leave the loop
EndIf
'check for threefold repetition
g = makeFen 'create fen-string
parseFen(makeFen)
g = fenBoard + fenCastling + fenEnPassant
y = 0
For x = UBound(fen) - 1 To 1 Step -1
parseFen(fen(x))
g2 = fenBoard + fenCastling + fenEnPassant
If g2 = g Then
y += 1
pCon("",String(Len(Str(x)) + 1," ") + g)
pCon("",Str(x) + " " + g2)
pCon("","")
EndIf
If y > 1 Then
mateFlag = 3 'threefold repetition
Exit Do 'leave the loop
EndIf
Next
'check for dead position
g = ""
For x = 1 To InStr(fen(UBound(fen))," ") - 1
If InStr(Mid(fen(UBound(fen)),x,1),Any "012345678/") = 0 Then 'isolate pieces from fen-string
g += Mid(fen(UBound(fen)),x,1)
EndIf
Next
Do 'sort pieces in alphabetical order
y = 0
For x = 0 To Len(g) - 2
If g[x] > g[x+1] Then
Swap g[x],g[x+1]
y = 1
EndIf
Next
Loop While y
Select Case LCase(g) 'check for pieces left on the board
Case "kk","kbk","knk","kkb","kkn"
mateFlag = 4
Exit Do 'leave the loop
End Select
'check for 50-moves-rule
If count50 > 99 Then
mateFlag = 5
Exit Do 'leave the loop
EndIf
Loop Until 1 'always leave the loop
If mateFlag Then 'end game
'showInternalBoard
If replayFlag <> 1 Then
Open ExePath + "\gamelog.txt" For Append As #1
Open ExePath + "\turnamentlog.txt" For Append As #2
EndIf
Select Case mateFlag
Case 1 'checkmate
Locate 51,29
Print " << CHECK MATE >> "
'write to protocol file
Print #1, " << CHECK MATE >> "
Locate 69,20
Select Case opponent 'set the win counter and write to protocol file
Case w
Print #1, "black (";nameBlack;
Print "<< BLACK (";nameBlack;
winEngine(currentBlack) += 1 'winner
Select Case playmode
Case "movetime"
moveTime(currentWhite) += moveTimeHandicap 'loser
moveTime(currentBlack) -= moveTimeHandicap 'winner
Case "depth"
depthEngine(currentWhite) += depthHandicap 'loser
depthEngine(currentBlack) -= depthHandicap 'winner
Case "gametime"
gameTime(currentWhite) += gameTimeHandicap 'loser
gameTime(currentBlack) -= gameTimeHandicap 'winner
End Select
Case b
Print #1, "white (";nameWhite;
Print "<< WHITE (";nameWhite;
winEngine(currentWhite) += 1 'winner
Select Case playmode
Case "movetime"
moveTime(currentBlack) += moveTimeHandicap 'loser
moveTime(currentWhite) -= moveTimeHandicap 'winner
Case "depth"
depthEngine(currentBlack) += depthHandicap 'loser
depthEngine(currentWhite) -= depthHandicap 'winner
Case "gametime"
gameTime(currentBlack) += gameTimeHandicap 'loser
gameTime(currentWhite) -= gameTimeHandicap 'winner
End Select
End Select
Print #1, ") wins in"; moveCount; " moves"
Print ") wins in"; moveCount; " moves >>"
'write to turnament log
If replayFlag <> 1 Then
Open ExePath + "\turnamentlog.txt" For Append As #2
EndIf
Print #2, "check mate ";
Select Case opponent
Case w
Print #2, nameBlack;" wins as black ";
Case b
Print #2, nameWhite;" wins as white ";
End Select
Print #2, "in"; moveCount; " moves"
'showInternalBoard
Case 2 'stalemate
drawnGames += 1
Print #2, "drawn because of stalemate after"; moveCount; " moves"
Locate 51,29
Print " << STALE MATE >> "
Case 3 'threefold repetition
drawnGames += 1
Print #2, "drawn because of threefold repetition after"; moveCount; " moves"
Locate 51,29
Print " << THREEFOLD REPETITION >> "
Case 4 'dead position
drawnGames += 1
Print #2, "drawn because of dead position after"; moveCount; " moves"
Locate 51,29
Print " << DEAD POSITION >> "
Case 5 '50-moves-rule
drawnGames += 1
Print #2, "drawn because of breaking the 50-moves-rule after"; moveCount; " moves"
Locate 51,29
Print " << 50 MOVES >> "
Case 6 'timeout
update
Locate 51,29
Print " << TIMEOUT >> "
'write to protocol file
Print #1, " << TIMEOUT >> "
Locate 69,20
Select Case opponent 'set the win counter and write to protocol file
Case w
Print #1, "black (";nameBlack;
Print "<< BLACK (";nameBlack;
winEngine(currentBlack) += 1 'winner
Select Case playmode
Case "movetime"
moveTime(currentWhite) += moveTimeHandicap 'loser
moveTime(currentBlack) -= moveTimeHandicap 'winner
Case "depth"
depthEngine(currentWhite) += depthHandicap 'loser
depthEngine(currentBlack) -= depthHandicap 'winner
Case "gametime"
gameTime(currentWhite) += gameTimeHandicap 'loser
gameTime(currentBlack) -= gameTimeHandicap 'winner
End Select
Case b
Print #1, "white (";nameWhite;
Print "<< WHITE (";nameWhite;
winEngine(currentWhite) += 1 'winner
Select Case playmode
Case "movetime"
moveTime(currentBlack) += moveTimeHandicap 'loser
moveTime(currentWhite) -= moveTimeHandicap 'winner
Case "depth"
depthEngine(currentBlack) += depthHandicap 'loser
depthEngine(currentWhite) -= depthHandicap 'winner
Case "gametime"
gameTime(currentBlack) += gameTimeHandicap 'loser
gameTime(currentWhite) -= gameTimeHandicap 'winner
End Select
End Select
Print #1, ") wins in"; moveCount; " moves"
Print ") wins in"; moveCount; " moves >>"
'write to turnament log
If replayFlag <> 1 Then
Open ExePath + "\turnamentlog.txt" For Append As #2
EndIf
Print #2, "timeout ";
Select Case opponent
Case w
Print #2, nameBlack;" wins as black ";
Case b
Print #2, nameWhite;" wins as white ";
End Select
Print #2, "in"; moveCount; " moves"
End Select
Print #2, Mid(moves,2)
Print #2, "*";lastmove;"*"
Print #2, "total won ";engine(1);winEngine(1)
Print #2, "total won ";engine(2);winEngine(2)
Print #2, "total drawn ";drawnGames
Close
If replayFlag Then
Sleep
Else
Sleep 10000
EndIf
Exit Do 'start next game
EndIf
moves += " " + move 'add the last move to the hod-string
'showInternalBoard
'save the moves string
If replayFlag <> 1 Then
Open ExePath + "\moveslog.txt" For Output As #5
Print #5, gameStamp
Print #5, Mid(moves,2)
Close 5
EndIf
'add the last move to the movetable
ReDim Preserve movetable(UBound(movetable) + 1)
If opponent = w Then
movetable(UBound(movetable)) = Right(" " + Str(moveCount),3)
Else
movetable(UBound(movetable)) = " "
EndIf
movetable(UBound(movetable)) += " " + UCase(Left(move,2)) + " " + _
UCase(Mid(move,3,2)) + " " + _
UCase(Mid(move,5,1)) + " "
wt.move = UCase(Left(move,2) + " " + Mid(move,3)) 'for title bar
SetTitleBar 'set screenwindow title bar
PrintMoveTable
'update castlig flag
Select Case Left(move,2)
Case "a1" 'left white rook
castlingFlag = deleteFromString(castlingFlag,"Q")
Case "h1" 'right white rook
castlingFlag = deleteFromString(castlingFlag,"K")
Case "e1" 'white king
castlingFlag = deleteFromString(castlingFlag,"QK")
Case "a8" 'left black rook
castlingFlag = deleteFromString(castlingFlag,"q")
Case "h8" 'right black rook
castlingFlag = deleteFromString(castlingFlag,"k")
Case "e8" 'black king
castlingFlag = deleteFromString(castlingFlag,"qk")
End Select
'show animated move
cMove = strMoveToNumMove(move)
makeMove(cMove)
'show animated castling
If (move = "e1g1") And pchoice = 6 Then
cMove = strMoveToNumMove("h1f1")
makeMove(cMove)
ElseIf (move = "e1c1") And pchoice = 6 Then
cMove = strMoveToNumMove("a1d1")
makeMove(cMove)
ElseIf (move = "e8g8") And pchoice = -6 Then
cMove = strMoveToNumMove("h8f8")
makeMove(cMove)
ElseIf (move = "e8c8") And pchoice = -6 Then
cMove = strMoveToNumMove("a8d8")
makeMove(cMove)
EndIf
ScreenLock
update()
Scan
ScreenUnLock
'showInternalBoard
g = Inkey 'check for keyboard input
Do
Select Case g
Case Chr(27) 'terminate current game
drawnGames += 1
End Select
g = Inkey 'check for key pressed
Loop While Len(g)
Loop Until (g = Chr(27))
If g = Chr(27) Then
drawnGames += 1
EndIf
CloseEngines
Close
Loop 'next game
Close
End
Sub update()
Dim As Integer x, y
Dim As Double t
'draw board
Color cfont,cback
Cls
Dim As Integer shade
shade = 1
For y As Integer = 0 To 7
shade = -shade
For x As Integer = 0 To 7
If shade = -1 Then
Line (bx+x*42,by+y*42)-(bx+x*42+41,by+y*42+41),RGB(252,206,156),bf
Else
Line (bx+x*42,by+y*42)-(bx+x*42+41,by+y*42+41),RGB(179,110,44),bf
End If
shade = -shade
Next x
Next y
'border of board
Line (bx-1,by-1)-(bx+336,by+336),cfont,b
'now draw image on square
For y As Integer = 0 To 7 'column
For x As Integer = 0 To 7 'line
'put image onto square
If board(x+2,y+2) <> 7 And board(x+2,y+2) <> 0 Then
If board(x+2,y+2) < 0 Then 'black
Put (bx+x*42,by+y*42),iPiece(Abs(board(x+2,y+2))-1),Trans
Else 'white
Put (bx+x*42,by+y*42),iPiece(Abs(board(x+2,y+2))+5),Trans
End If
End If
Next x
Next y
'print engine names and coordinates on screen
Locate 2,22
Print nameBlack
Locate 49,22
Print nameWhite
For x = 1 To 8
Locate 48 - 5.15 * x,17
Print x
Next
Locate 47,22
Draw String (168,371), "A B C D E F G H"
Locate 22,2
Print "Game";gameCount
Locate 23,2
Print "Move";moveCount;" (";Str(count50);")"
Locate 54,22
Print "engine 1: ";engine(1)
Select Case playmode
Case "movetime"
Print Tab(22);"movetime:";moveTime(1);" ms"
Case "depth"
Print Tab(25);"depth:";depthEngine(1)
Case "gametime"
Print Tab(22);"gametime: ";timeFormat(gameTime(1),1)
End Select
Print Tab(27);"won:";winEngine(1)
Print
Print Tab(22);"engine 2: ";engine(2)
Select Case playmode
Case "movetime"
Print Tab(22);"movetime:";moveTime(2);" ms"
Case "depth"
Print Tab(25);"depth:";depthEngine(2)
Case "gametime"
Print Tab(22);"gametime: ";timeFormat(gameTime(2),1)
End Select
Print Tab(27);"won:";winEngine(2)
Print
Print Tab(19);"drawn games:";drawnGames
Print
Print Tab(15);"animation speed:";animationSpeed
Print Tab(22);"playmode: ";playmode
Print Tab(22);"handicap:";
Select Case playmode
Case "movetime"
t = Abs(moveTimeHandicap * (winEngine(1) - winEngine(2)))
Print t;" ms (";CInt(100 * t / moveTimePreset);"% )"
Case "depth"
Print Abs(depthHandicap * (winEngine(1) - winEngine(2)))
Case "gametime"
t = Abs(gameTimeHandicap * (winEngine(1) - winEngine(2)))
Print " ";timeFormat(t,1);
Print " (";CInt(100 * t / gameTimePreset);"% )"
End Select
PrintMoveTable
If replayFlag = 1 Then
Locate 2,30
Print "R E P L A Y M O D E"
Locate 42,1
Print " ---------------"
Print
Print
Print
Print " ---------------"
showInternalBoard
EndIf
'showInternalBoard
End Sub
Sub makeMove(cMove As chessMove)
Dim As Integer choice, i, x 'number of selected piece
Dim As Integer px1, py1, px2, py2, dx, dy 'moving data
Dim As Double timeRem
Dim As String g
cMove.y1 = 8 - cMove.y1 'set correct line of internal board
cMove.y2 = 8 - cMove.y2
px1 = cMove.x1*42+bx 'screen pointer to chosen image
py1 = cMove.y1*42+by
px2 = cMove.x2*42+bx
py2 = cMove.y2*42+by
ox = px1
oy = py1
'make move on internal board
choice = board(cMove.x1+2,cMove.y1+2)
pchoice = choice
count50 += 1
If board(cMove.x2+2,cMove.y2+2) Then 'piece is captured
Mid(movetable(UBound(movetable)),7,1) = "x"
Mid(wt.move,3,1) = "x"
SetTitleBar
PrintMoveTable
count50 = 0
EndIf
If Abs(choice) = 1 Then 'pawn is moved
count50 = 0
EndIf
board(cMove.x2+2,cMove.y2+2) = choice
board(cMove.x1+2,cMove.y1+2)=0 'erase data
'convert to image ID of that number
If choice < 0 Then
choice = Abs(choice) - 1
Else
choice = choice + 5
End If
Select Case replayFlag
Case 0, 1 'no or manual replay
Line (px1,py1)-(px1+41,py1+41),Point(px1+4,py1+4),bf 'clear
For i = 0 To 3
Line (px1+i,py1+i)-(px1+41-i,py1+41-i),RGB(0,0,244),b 'source
Line (px2+i,py2+i)-(px2+41-i,py2+41-i),RGB(0,255,0),b 'destination
Next i
'compute direction of movement
If px1 > px2 Then
dx = -1
Else
dx = 1
End If
If py1 > py2 Then
dy = -1
Else
dy = 1
End If
Get (px1,py1)-(px1+41,py1+41),sImage
Put (px1,py1),iPiece(choice),Trans
ox = px1
oy = py1
timeRem = Timer
While px1 <> px2 Or py1 <> py2
If Timer > timeRem + .001 * animationSpeed Then
timeRem += .001 * animationSpeed'Timer
'update coordinates
If px1 <> px2 Then
px1 = px1 + dx
End If
If py1 <> py2 Then
py1 = py1 + dy
End If
ScreenLock
Put (ox,oy),sImage,PSet 'restore old back ground
Get (px1,py1)-(px1+41,py1+41),sImage 'save new back ground
Put (px1,py1),iPiece(choice),Trans 'place on new back ground
ox = px1
oy = py1
ScreenUnLock
Scan
EndIf
Wend
Case 2 'instant replay
End Select
If Len(move) = 5 Then 'pawn promotion
Select Case Mid(move,5,1) 'promote pawn to...
Case "q"
choice = Sgn(pchoice) * 5 'queen
Case "b"
choice = Sgn(pchoice) * 4 'bishop
Case "n"
choice = Sgn(pchoice) * 3 'knight
Case "r"
choice = Sgn(pchoice) * 2 'rook
End Select
board(cMove.x2+2,cMove.y2+2) = choice
EndIf
parseFen(fen(UBound(fen)))
If (Mid(move,3,2) = fenEnPassant) And (Abs(pchoice) = 1) Then 'en passant
pCon("en passant","")
Dim As Integer ff
Open ExePath + "\enpassantlog.txt" For Append As ff
Print #ff, "game ";gameCount
Print #ff, "move ";moveCount
Print #ff, "opponent ";opponent
Print #ff, ""
Close ff
If cMove.y2 = 5 Then 'remove captured white pawn
board(cMove.x2+2,6) = 0
ElseIf cMove.y2 = 2 Then 'remove captured black pawn
board(cMove.x2+2,5) = 0
EndIf
Mid(movetable(UBound(movetable)),7,1) = "x"
Mid(wt.move,3,1) = "x"
SetTitleBar
PrintMoveTable
EndIf
End Sub
'convert string chess moves to numbers
Function strMoveToNumMove(move As String) As chessMove
Dim As chessMove cm
Dim As String umove
umove = UCase(move)
cm.x1 = Asc(Mid(umove,1,1))-65
cm.y1 = Val(Mid(umove,2,1))
cm.x2 = Asc(Mid(umove,3,1))-65
cm.y2 = Val(Mid(umove,4,1))
Return cm
End Function
'convert chess move numbers to string format
Function numMovetoStrMove(cm As chessMove) As String
Return Chr(cm.x1+65)+Str(cm.y1)+Chr(cm.x2+65)+Str(cm.y2)
End Function
Function GetMove(opp As String) As String
Static As Integer begPtr, endPtr
Static As String oldReplayMoves
Dim As String g, sRet, key
Dim As Integer x, full = 0, repmerk
Scan
If (replayMoves <> oldReplayMoves) Or (endPtr >= Len(replayMoves)) Then 'reset string pointers
oldReplayMoves = replayMoves
begPtr = 0
endPtr = 0
EndIf
If Left(opp,4) = "full" Then 'don't edit the move message
full = 1
opp = Mid(opp,5)
repmerk = replayFlag
replayFlag = 0
EndIf
wt.opponent = opp 'for title bar
Select Case replayFlag
Case 0 'no replay
g = ""
Do
key = InKey
Select Case key
Case Chr(27)
Return "Esc" 'terminate game
'Case Chr(255,107) 'end program
' End
End Select
g += GetEngineResponse(opp) 'request a message from the engine
'print opponent and current depth to the screen
x = InStrRev(g,"info depth ")
currDepth = Str(Val(Mid(g,x+11,2)))
Locate 25, 2
Print UCase(opp)
Locate 26, 2
Print " depth ";currDepth;" "
wt.depth = currDepth 'for title bar
SetTitleBar 'set title bar
Locate 27,2
Print "currmove "
If (playmode = "gametime") And (timeRemind > 0) Then
Select Case opp
Case w
Locate 5,10
Print timeFormat(timeLeft(currentBlack)/1000,1)
Locate 46,9
Color cfont,cbacklt
Print " ";timeFormat(timeLeft(currentWhite)/1000 - (Timer - timeRemind),1);" "
Color cfont,cback
Case b
Locate 5,9
Color cfont,cbacklt
Print " ";timeFormat(timeLeft(currentBlack)/1000 - (Timer - timeRemind),1);" "
Color cfont,cback
Locate 46,10
Print timeFormat(timeLeft(currentWhite)/1000,1)
End Select
ElseIf timeRemind > 0 Then
Select Case opp
Case w
Locate 5,10
Print timeFormat(timePlayed(currentBlack)/1000,1)
Locate 46,9
Color cfont,cbacklt
Print " ";timeFormat(timePlayed(currentWhite)/1000 + (Timer - timeRemind),1);" "
Color cfont,cback
Case b
Locate 5,9
Color cfont,cbacklt
Print " ";timeFormat(timePlayed(currentBlack)/1000 + (Timer - timeRemind),1);" "
Color cfont,cback
Locate 46,10
Print timeFormat(timePlayed(currentWhite)/1000,1)
End Select
EndIf
x = InStrRev(g,"bestmove")
Loop Until x 'the engine has finished the calculating for this move
sRet = Mid(g,x + 9,InStr(x + 9,g," ") - (x + 9)) 'isolate the data of the move
Case 1 'manual replay
Do 'manual replay loop
g = Inkey
menuitem = ""
mouseMenu(" PgDn -> move ","->",43,6,cfont,cback)
mouseMenu(" PgUp -> back ","->",44,6,cfont,cback)
mouseMenu(" Esc -> quit ","->",45,6,cfont,cback)
Select Case menuitem 'convert menuitem to keystroke
Case ""
'do nothing
Case "PgDn"
g = Chr(255,81) 'page down
Case "PgUp"
g = Chr(255,73) 'page up
Case "Esc"
g = Chr(27) 'esc
Case Else
'do nothing
End Select
Select Case g
Case Chr(255,81) 'page down --> next move
'parse moves list
begPtr = endPtr
endPtr = InStr(begPtr + 1,replayMoves," ")
If endPtr = 0 Then
endPtr = begPtr
EndIf
sRet = Mid(replayMoves,begPtr + 1,endPtr - begPtr - 1)
Exit Do
Case Chr(255,73) 'page up --> one move back
If UBound(fen) > 2 Then 'fen-strings available
sRet = Mid(replayMoves,begPtr + 1,endPtr - begPtr - 1)
ReDim Preserve movetable(UBound(movetable) - 1)
ReDim Preserve fen(UBound(fen) - 1)
fenToBoard(fen(UBound(fen)))
update
endPtr = begPtr
begPtr = InStrRev(replayMoves," ",endPtr - 1)
EndIf
Case Chr(27) 'Esc --> main menu
Return "Esc"
Case Chr(255,107) 'end program
End
End Select
Loop
Case 2 'instant replay
g = GetEngineResponse(opp) 'request a message from the engine
begPtr = endPtr
endPtr = InStr(begPtr + 1,replayMoves," ")
If endPtr = 0 Then
endPtr = begPtr
EndIf
sRet = Mid(replayMoves,begPtr + 1,endPtr - begPtr - 1)
If endPtr = Len(replayMoves) Then
replayFlag = 0
timeRemind = Timer
pCon("FENs n ",UBound(fen))
EndIf
End Select
If full Then ' don't edit the message
replayFlag = repmerk
Return sRet
EndIf
For x = 1 To 2
If Left(sRet,4) = Left(matesign(x),4) Then
Return "mate"
EndIf
Next
Select Case Mid(sRet,5,1)
Case "q","b","n","r" 'pawn promotion
sRet = Left(sRet,5) 'clip string to 5 characters
Case Else
sRet = Left(sRet,4) 'clip string to 4 characters
End Select
Return sRet 'send the move to the gui
End Function
Function GetEngineResponse(opp As String) As String
Dim As Integer iTotalBytesAvail, iNumberOfBytesWritten, iBytesToRead, px1, py1, px2, py2, i
Dim As String sRet = "", sBuf
Dim As chessMove cfield
Const As Integer MaxBytesToRead = 4096 'maximum number of bytes to be returned at one 'ReadFile'-operation
Do
Scan
sBuf = "" 'clear buffer
'look if there's any data in the pipe
Select Case opp 'choose engine
Case "white"
PeekNamedPipe(hReadPipeWhite,NULL,NULL,NULL,@iTotalBytesAvail,NULL)
Case "black"
PeekNamedPipe(hReadPipeBlack,NULL,NULL,NULL,@iTotalBytesAvail,NULL)
End Select
If iTotalBytesAvail Then 'pipe is not empty
If iTotalBytesAvail < MaxBytesToRead Then
iBytesToRead = iTotalBytesAvail 'set all available bytes to be read
Else
iBytesToRead = MaxBytesToRead 'set the first 4096 bytes to be read
EndIf
sBuf = String(iBytesToRead,Chr(0)) 'set the length of the buffer string to the necessary value
'read the specified amount of bytes from the pipe
Select Case opp 'choose engine
Case "white"
ReadFile(hReadPipeWhite,StrPtr(sBuf),iBytesToRead,@iNumberOfBytesWritten,NULL)
Case "black"
ReadFile(hReadPipeBlack,StrPtr(sBuf),iBytesToRead,@iNumberOfBytesWritten,NULL)
End Select
sRet += sBuf 'add the buffer to the return string
Sleep 1
Else 'pipe is empty
Exit Do 'return
EndIf
Loop
If replayFlag <> 1 Then
Open ExePath + "\ucilog.txt" For Append As #3
Print #3, ""
Print #3, "RECEIVE FROM: ";opp
Print #3, sRet;"*"
Print #3, "----------"
Close 3
EndIf
If InStr(sRet,"currmove") Then
Locate 27,11
Print Mid(sRet,InStr(sRet,"currmove")+9,4)
EndIf
If InStr(sRet,"fieldset") Then
cfield = strMoveToNumMove(Mid(sRet,InStr(sRet,"fieldset") + 9,2)+"a1")
cfield.y1 = 8 - cfield.y1 'set correct line of internal board
cfield.y2 = 8 - cfield.y2
px1 = cfield.x1*42+bx 'screen pointer to chosen image
py1 = cfield.y1*42+by
px2 = cfield.x2*42+bx
py2 = cfield.y2*42+by
For i = 0 To 3
Line (px1+i,py1+i)-(px1+41-i,py1+41-i),RGB(0,0,244),b 'source
Next
EndIf
If InStr(sRet,"fieldreset") Then
update
EndIf
If Len(sRet) Then
pCon(opp,sRet)
EndIf
'Sleep 500
Return sRet
End Function
Sub WriteEngineInfo(opp As String, s As String)
Dim As Integer iNumberOfBytesWritten
Dim As String sBuf
sBuf = s + Chr(10)
If replayFlag <> 1 Then
Open ExePath + "\ucilog.txt" For Append As #3
Print #3,""
Print #3, "SEND TO: ";opp
Print #3, s
Print #3, "----------"
Close 3
EndIf
'send the command string to the engine
Select Case opp 'choose engine
Case "white"
WriteFile(hWritePipeWhite,StrPtr(sBuf),Len(sBuf),@iNumberOfBytesWritten,NULL)
Case "black"
WriteFile(hWritePipeBlack,StrPtr(sBuf),Len(sBuf),@iNumberOfBytesWritten,NULL)
End Select
End Sub
Sub SetTitleBar
Dim As String text
'set the text of the screen window
text = Left(UCase(wt.opponent),1) + " " + wt.move + " " + wt.depth
WindowTitle(text)
End Sub
Sub CloseEngines
TerminateProcess(hProcessHandleWhite, @ExitCode)
TerminateProcess(hProcessHandleBlack, @ExitCode)
CloseHandle(hWritePipeBlack)
CloseHandle(hReadPipeBlack)
End Sub
Function makeFen() As String
Dim As Integer x, col, lin, countFree, first, last
Dim As String fenPcs, g, fptest
For col = 2 To 9 'column
For lin = 2 To 9 'line
fenpcs += Mid("kqbnrp0PRNBQK ",board(lin,col) + 7,1) 'convert internal board to fen-string
Next
Next
'compress fen-string
countFree = 0
g = ""
For x = 1 To Len(fenpcs)
If Mid(fenpcs,x,1) = "0" Then
countFree += 1
Else
If countFree Then
g += Str(countFree)
countFree = 0
EndIf
g += Mid(fenpcs,x,1)
EndIf
Next
fenpcs = Left(g,Len(g) - 1) + " " + Left(opponent,1) 'add opponent
If Len(castlingFlag) Then 'castling
fenpcs += " " + castlingFlag
Else
fenpcs += " -"
EndIf
If Abs(pchoice) = 1 Then 'add en passant information
Select Case move
Case "a2a4"
fenpcs += " a3"
Case "b2b4"
fenpcs += " b3"
Case "c2c4"
fenpcs += " c3"
Case "d2d4"
fenpcs += " d3"
Case "e2e4"
fenpcs += " e3"
Case "f2f4"
fenpcs += " f3"
Case "g2g4"
fenpcs += " g3"
Case "h2h4"
fenpcs += " h3"
Case "a7a5"
fenpcs += " a6"
Case "b7b5"
fenpcs += " b6"
Case "c7c5"
fenpcs += " c6"
Case "d7d5"
fenpcs += " d6"
Case "e7e5"
fenpcs += " e6"
Case "f7f5"
fenpcs += " f6"
Case "g7g5"
fenpcs += " g6"
Case "h7h5"
fenpcs += " h6"
Case Else
fenpcs += " -"
End Select
Else
fenpcs += " -"
EndIf
fenpcs += " " + Str(count50) + " " + Str(moveCount) 'add counters
Return fenpcs
End Function
Sub PrintMoveTable
Dim As Integer x, listlen
listlen = UBound(movetable)
If listlen > 42 Then
listlen = 42
EndIf
For x = 1 To listlen
Locate 46 - listlen + x , 63
Print movetable(UBound(movetable) - listlen + x)
Next
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
Sub fenToBoard(fen As String)
Dim As Integer x, y, i, row, col
Dim As String opp, g
row = 2
col = 1
parseFen(fen)
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 = Val(fenHalfmoves)
moveCount = Val(fenMoves)
End Sub
Sub showInternalBoard()
Dim As Integer col, row
Locate 50,1
Print " 2 3 4 5 6 7 8 9 "
For row = 2 To 9 'row
Print 10-row;"|";
For col = 2 To 9 'column
Print board(col,row);
Next
Print "|";row;" "
Next
Print " A B C D E F G H "
End Sub
Sub pCon(t As String = "",text As String)
'print to console window
Dim kf As Integer = FreeFile
Open Cons For Output As #kf
Print #kf, t;
Print #kf, text
Close kf
End Sub
Sub pCon(text As String)
pCon("",text)
End Sub
Sub pCon(x As Integer)
pCon("",Str(x))
End Sub
Sub pCon(t As String = "",x As Integer)
pCon(t,Str(x))
End Sub
Function checkForStale() As Integer
Dim As Integer x, col, row, drow, dcol, kingrow, kingcol, kingsig
ScreenLock
update
Scan
ScreenUnLock
'set Sgn of the mated king
If opponent = w Then
kingsig = 1
Else
kingsig = -1
EndIf
'get the internal coordinates of the mated king
For row = 2 To 9
For col = 2 To 9
If board(col,row) = kingsig * 6 Then 'mated king found
kingrow = row
kingcol = col
Exit For,For 'terminate searching
EndIf
Next
Next
'let the mated 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 0
Else
Exit Do 'next direction
EndIf
Case 2 'rook
If (dcol = 0) Or (drow = 0) Then 'mated king is looking straight
Return 0
EndIf
Case 4 'bishop
If (dcol <> 0) And (drow <> 0) Then 'mated king is looking diagonal
Return 0
EndIf
Case 5 'queen
Return 0
End Select
EndIf
Loop
Next
Next
Restore knightCheck
For x = 1 To 8
Read dcol, drow
If Abs(board(kingcol + dcol, kingrow + drow)) = kingsig * -3 Then 'knight
Return 0
EndIf
Next
Return 1 'stalemate
End Function
#Macro PrintMenuItem()
Color foreground, background 'normal colours
compareColor = foreground + 16 * background
PrintMenuItemMain()
#EndMacro
#Macro PrintMenuItemInv()
Color background, foreground 'inverse colours
compareColor = background + 16 * foreground
PrintMenuItemMain()
#EndMacro
#Macro PrintMenuItemMain()
For x = 1 To Len(text)
If (Screen(lin,col - 1 + x,0) <> Asc(Mid(text,x,1))) Or _
(Screen(lin,col - 1 + x,1) <> compareColor) Then 'only print if necessary
Locate lin, col, 0 'adjust menu item to separator
Print text
Exit For
EndIf
Next
#EndMacro
Sub mouseMenu(text As String, separator As String, lin As Integer = 0, col As Integer = 0, _
foreground As UInteger, background As UInteger, mode As Integer = 0)
'mode 0 -> highlight at touch with cursor
'mode 1 -> highlight at click
Dim As Integer mc, ml, wheel, buttons, textmin, textmax, x, compareColor, separatorpos
If lin = 0 Then
lin = CsrLin
EndIf
If col = 0 Then
col = Pos
EndIf
If separator = "" Then
separatorpos = Len(text) 'whole text as return value
Else
separatorpos = InStr(text,separator) - 1 'text left from separator as return value
col = col - separatorpos + 1 'position text at separator
EndIf
If col < 1 Then
col = 1
EndIf
textmin = col - 2
textmax = textmin + Len(text) + 1
GetMouse (mc,ml,wheel,buttons)
mc = mc / 8 'text column
ml = ml / 8 'text line
menuitemhit = 0
Select Case mode
Case 0 'highlight when touching
If ml + 1 = lin Then 'mouse line = text line
Select Case mc
Case textmin To textmax 'cursor touches the text
menuitemhit = 1
PrintMenuItemInv() 'highlight menu item
If (buttons And 1) Then 'left mouse button pressed
Do 'wait for release of the mouse button
GetMouse (mc,ml,wheel,buttons)
Loop While buttons
menuitem = Trim(Left(text,separatorpos)) 'isolate menu item and write to global variable
EndIf
Return
End Select
EndIf
Case 1 'highlight at click
If (buttons And 1) Then 'linke mouse button pressed
If ml + 1 = lin Then 'mouse line = text line
Select Case mc
Case textmin To textmax 'cursor touches the text
PrintMenuItemInv() 'highlight menu item
Do 'wait for release of the mouse button
GetMouse (mc,ml,wheel,buttons)
Loop While buttons
menuitem = Trim(Left(text,separatorpos)) 'isolate menu item and write to global variable
Return
End Select
EndIf
EndIf
End Select
PrintMenuItem()
End Sub
Sub continueTurnament()
Dim As String tl(2,20)
Dim As Integer filepointer(2)
Dim As String g
Dim As Integer ff, x
Dim As Double stampCompare
ff = FreeFile
Open ExePath + "\turnamentlog.txt" For Input As ff
Do 'find and read the entries of the last 2 games
Line Input #ff, g
For x = 1 To UBound(tl,2) 'carry over the last game entry
tl(1,x) = tl(2,x)
tl(2,x) = ""
Next
filepointer(1) = filepointer(2)
tl(2,1) = g
x = 1
Do 'get new game entry
x += 1
Line Input #ff, tl(2,x)
Loop Until tl(2,x) = "" 'game entry complete
filepointer(2) = Seek(ff)
Loop Until EOF(ff)
Close ff
'game number
gameCount = Val(Mid(tl(1,1),InStrRev(tl(1,1)," ") + 1)) 'last finished game
'check if the last game was uncompleted
If tl(2,6) = "" Then 'uncompleted
'cleanup turnamentlog
Open ExePath + "\turnamentlog.txt" For Binary As ff
g = Input(filepointer(1)-3, ff)
Close ff
Open ExePath + "\turnamentlog.txt" For Output As ff
Print #ff, g;
Close ff
replayFlag = 2
'check for game stamp
replayMoves = ""
Open ExePath + "\moveslog.txt" For Binary As ff
Input #ff, g
gameStamp = Val(Mid(tl(2,2),7))
pCon("gameStamp ",gameStamp)
If Val(g) = gameStamp Then
Input #ff, replayMoves
EndIf
replayMoves += " "
Close ff
If Len(replayMoves) = 1 Then 'no moves done yet in the last game
replayFlag = 0
EndIf
Else 'start the next (new) game
For x = 1 To UBound(tl,2) 'carry over the last game entry
tl(1,x) = tl(2,x)
Next
EndIf
Close ff
'extract informations from logfile and set variables
'game counter
x = 0
Do
x += 1
Loop Until Left(tl(1,x),5) = "game "
gameCount = Val(Mid(tl(1,x),6))
'engine files
x = 0
Do
x += 1
Loop Until Left(tl(1,x),6) = "white "
g = tl(1,x)
engine(1) = Mid(g,InStrRev(g," ") + 1)
g = tl(1,x + 1)
engine(2) = Mid(g,InStrRev(g," ") + 1)
If Frac(gameCount/2) = 0 Then 'odd game number --> white = engine 1
Swap engine(1),engine(2)
EndIf
'result counters
x = 0
Do
x += 1
Loop Until Left(tl(1,x),10) = "total won "
winEngine(1) = Val(Mid(tl(1,x),InStrRev(tl(1,x)," ") + 1))
winEngine(2) = Val(Mid(tl(1,x + 1),InStrRev(tl(1,x + 1)," ") + 1))
drawnGames = Val(Mid(tl(1,x + 2),InStrRev(tl(1,x + 2)," ") + 1))
'playmode
x = 0
Do
x += 1
Loop Until Left(tl(1,x),5) = "mode "
'g = tl(2,x)
g = tl(1,x)
g = LTrim(Mid(g,InStr(g," "))) 'delete 1st item ("mode")
playmode = Left(g,InStr(g," ") - 1) 'get playmode keyword (2nd item)
g = LTrim(Mid(g,InStr(g," "))) 'delete 1st item (playmode keyword)
pCon("playmode ",playmode)
Select Case playmode
Case "movetime"
moveTimePreset = Val(Left(g,InStr(g," ") - 1))
g = LTrim(Mid(g,InStr(g," "))) '1st space
g = LTrim(Mid(g,InStr(g," "))) '2nd space
g = Trim(g, Any " )")
moveTimeHandicap = Val(Trim(g, Any " )"))
moveTime(1) = moveTimePreset + moveTimeHandicap * (winEngine(2) - winEngine(1))
moveTime(2) = moveTimePreset + moveTimeHandicap * (winEngine(1) - winEngine(2))
Open ExePath + "\timelog.txt" For Input As #6
Input #6, stampCompare
If stampCompare = gameStamp Then 'logged times belong to the actual game --> restore times
Input #6, timePlayed(1)
Input #6, timePlayed(2)
pCon ("timePlayed 1 ",timePlayed(1))
pCon ("timePlayed 2 ",timePlayed(2))
Else 'new game --> reset clock
timePlayed(1) = 0
timePlayed(2) = 0
EndIf
Close 6
Case "depth"
Case "gametime"
gameTimePreset = Val(Left(g,InStr(g," ") - 1))
g = LTrim(Mid(g,InStr(g," "))) 'delete 1st item (<gametime>)
g = Trim(g, Any "( )") 'delete brackets
gameTimeHandicap = Val(g)
'set the game times with the actual handicap
gameTime(1) = gameTimePreset + gameTimeHandicap * (winEngine(2) - winEngine(1))
gameTime(2) = gameTimePreset + gameTimeHandicap * (winEngine(1) - winEngine(2))
Open ExePath + "\timelog.txt" For Input As #6
Input #6, stampCompare
If stampCompare = gameStamp Then 'logged times belong to the actual game --> restore times
Input #6, timeLeft(1)
Input #6, timeLeft(2)
Else 'new game with full time amount
timeLeft(1) = gameTime(1) * 1000
timeLeft(2) = gameTime(2) * 1000
EndIf
Close 6
timeRemind = Timer
End Select
End Sub
Sub replayGame()
ReDim As Integer filepointer(1)
Dim As Integer ff, gamemax, x, gameNumber
Dim As String g
Cls
Locate 15,20
Print "********** R E P L A Y **********"
ff = FreeFile
Open ExePath + "\turnamentlog.txt" For Input As ff
Do
Line Input #ff, g
If Left(g,5) = "game " Then
x = Val(Mid(g,6))
If x > gamemax Then
gamemax = x
ReDim Preserve filepointer(x)
filepointer(x) = Seek(ff)
Else
gamemax = x
ReDim filepointer(x)
filepointer(x) = Seek(ff)
EndIf
EndIf
Loop Until EOF(ff)
Locate 20,20,1
Print x
Input "Game number ",gameNumber
Seek ff,filepointer(gameNumber)
For x = 1 To 6
Line Input #ff, replayMoves
Next
Line Input #ff, g
g = Trim(g,"*")
replayMoves += " " + g + " "
replayFlag = 1
gameCount = gameNumber
End Sub
Sub setup
Dim As Integer mencol, menlin, x, jump
Dim As String keypressed, filename
ReDim As String enginelist(1)
'write available engines to array
x = 0
ReDim enginelist(x)
filename = Dir(ExePath + "\engines\*.*", -1)
Do
pCon(filename,"")
If Right(filename,4) = ".exe" then
x += 1
ReDim Preserve enginelist(x)
enginelist(x) = filename
EndIf
filename = DIR("", -1)
Loop While Len(filename)
For x = LBound(enginelist) To UBound(enginelist)
pCon(Str(x),enginelist(x))
Next
Do 'setup menu loop
If jump = 0 Then
Cls
Locate 15,20
Print "********** S E T U P **********"
mencol = 25
menlin = 20
jump = 1
EndIf
keypressed = Inkey
menuitem = ""
mouseMenu(" 1 = Engine 1 (" + engine(1) + ")","=",menlin,mencol,cfont,cback)
mouseMenu(" 2 = Engine 2 (" + engine(2) + ")","=",menlin + 2,mencol,cfont,cback)
mouseMenu(" P = Playmode (" + playmode + ")","=",menlin + 4 ,mencol,cfont,cback)
mouseMenu(" Esc = Return to main menu ","=",menlin + 10,mencol,cfont,cback)
Select Case menuitem 'convert menuitem to keystroke
Case ""
'do nothing
Case "Esc"
keypressed = Chr(27)
Case Else
keypressed = LCase(menuitem) 'key
End Select
Select Case keypressed
Case "1" 'engine 1
Cls
Locate 15,20
Print "********** S E T U P **********"
Print
Print Tab(29);"CHOOSE ENGINE 1"
Do
keypressed = InKey
menuitem = ""
For x = 1 To UBound(enginelist)
mouseMenu(Str(x) + " - " + enginelist(x),"-",19 + 2*x,25,cfont,cback)
Next
mouseMenu("Esc = Return to setup menu","=",19 + 2*(x),25,cfont,cback)
Color cfont,cback
Select Case menuitem 'convert menuitem to keystroke
Case ""
'do nothing
Case "Esc"
keypressed = Chr(27)
Case Else
keypressed = menuitem 'key
End Select
Select Case keypressed
Case "1" To Str(UBound(enginelist))
engine(1) = enginelist(Val(keypressed))
WritePrivateProfileString("","engine1",StrPtr(engine(1)),StrPtr(iniFile))
jump = 0
Exit Do
Case Chr(27)
jump = 0
Exit Do
Case Chr(255,107) 'end program
End
End Select
Loop
Case "2" 'engine 2
Cls
Locate 15,20
Print "********** S E T U P **********"
Print
Print Tab(29);"CHOOSE ENGINE 2"
Do
keypressed = InKey
menuitem = ""
For x = 1 To UBound(enginelist)
mouseMenu(Str(x) + " - " + enginelist(x),"-",19 + 2*x,25,cfont,cback)
Next
mouseMenu("Esc = Return to setup menu","=",19 + 2*(x),25,cfont,cback)
Color cfont,cback
Select Case menuitem 'convert menuitem to keystroke
Case ""
'do nothing
Case "Esc"
keypressed = Chr(27)
Case Else
keypressed = menuitem 'key
End Select
Select Case keypressed
Case "1" To Str(UBound(enginelist))
engine(2) = enginelist(Val(keypressed))
WritePrivateProfileString("","engine2",StrPtr(engine(2)),StrPtr(iniFile))
jump = 0
Exit Do
Case Chr(27)
jump = 0
Exit Do
Case Chr(255,107) 'end program
End
End Select
Loop
Case "p" 'playmode
Cls
Locate 15,20
Print "********** S E T U P **********"
Print
Print Tab(29);"PLAYMODE"
Do
keypressed = InKey
menuitem = ""
If playmode = "movetime" Then
mouseMenu(">>> M = Movetime <<<","=",20,25,cfont,cback)
Else
mouseMenu(" M = Movetime ","=",20,25,cfont,cback)
EndIf
mouseMenu(" 1 = Movetime (" + Str(moveTimePreset) + " ms) ","=",22,27,cfont,cback)
mouseMenu(" 2 = Movetime Handicap (" + Str(moveTimeHandicap) + " ms) ","=",24,27,cfont,cback)
If playmode = "depth" Then
mouseMenu(">>> D = Depth <<<","=",26,25,cfont,cback)
Else
mouseMenu(" D = Depth ","=",26,25,cfont,cback)
EndIf
mouseMenu(" 3 = Depth (" + Str(depthPreset) + ") ","=",28,27,cfont,cback)
mouseMenu(" 4 = Depth Handicap (" + Str(depthHandicap) + ") ","=",30,27,cfont,cback)
If playmode = "gametime" Then
mouseMenu(">>> T = Gametime <<<","=",32,25,cfont,cback)
Else
mouseMenu(" T = Gametime ","=",32,25,cfont,cback)
EndIf
mouseMenu(" 5 = Gametime (" + Str(gameTimePreset) + " s) ","=",34,27,cfont,cback)
mouseMenu(" 6 = Gametime Handicap (" + Str(gameTimeHandicap) + " s) ","=",36,27,cfont,cback)
mouseMenu(" Esc = Return to setup menu ","=",38,25,cfont,cback)
Color cfont,cback
Select Case menuitem 'convert menuitem to keystroke
Case ""
'do nothing
Case "Esc"
keypressed = Chr(27)
Case Else
keypressed = LCase(Trim(menuitem,Any "> ")) 'key
End Select
Select Case keypressed
Case "m" 'playmode
playmode = "movetime"
WritePrivateProfileString("","playmode","movetime",StrPtr(iniFile))
Case "1" 'moveTimePreset
View Print 40 To 40
Locate 40,20
Input "Movetime (ms): ",moveTimePreset
WritePrivateProfileString("","moveTimePreset",Str(moveTimePreset),StrPtr(iniFile))
Cls
View Print
Case "2" 'moveTimeHandicap
View Print 40 To 40
Locate 40,20
Input "movetime handicap(ms): ",moveTimeHandicap
WritePrivateProfileString("","moveTimeHandicap",Str(moveTimeHandicap),StrPtr(iniFile))
Cls
View Print
Case "d" 'depth
playmode = "depth"
WritePrivateProfileString("","playmode","depth",StrPtr(iniFile))
Case "3" 'depthpreset
View Print 40 To 40
Locate 40,20
Input "depth: ",depthPreset
WritePrivateProfileString("","depthPreset",Str(depthPreset),StrPtr(iniFile))
Cls
View Print
Case "4" 'increase depth
View Print 40 To 40
Locate 40,20
Input "depth handicap: ",depthHandicap
WritePrivateProfileString("","depthHandicap",Str(depthHandicap),StrPtr(iniFile))
Cls
View Print
Case "t" 'time amount
playmode = "gametime"
WritePrivateProfileString("","playmode","gametime",StrPtr(iniFile))
Case "5"
View Print 40 To 40
Locate 40,20
Input "gametime (seconds): ",gameTimePreset
WritePrivateProfileString("","gameTimePreset",Str(gameTimePreset),StrPtr(iniFile))
Cls
View Print
Case "6"
View Print 40 To 40
Locate 40,20
Input "gametime handicap(seconds): ",gameTimeHandicap
WritePrivateProfileString("","gameTimeHandicap",Str(gameTimeHandicap),StrPtr(iniFile))
Cls
View Print
Case Chr(27)
jump = 0
Exit Do
Case Chr(255,107) 'end program
End
End Select
Loop
Case Chr(27)
Exit Do
Case Chr(255,107) 'end program
End
End Select
Loop
End Sub
Function timeFormat (seconds As Double, mode As Integer = 0) As String
Dim As Integer milliseconds, hours, minutes, secs
Dim As String tRet = ""
milliseconds = CInt(seconds * 1000)
hours = Int(milliseconds / 3600000)
milliseconds = milliseconds Mod 3600000
minutes = Int(milliseconds / 60000)
milliseconds = milliseconds Mod 60000
secs = Int(milliseconds / 1000)
milliseconds = milliseconds Mod 1000
If hours Then
tRet = Str(hours) + ":"
EndIf
If minutes < 10 Then
If Len(tRet) Then
tRet += "0"
EndIf
EndIf
tRet += Str(minutes) + ":"
If secs < 10 Then
tRet += "0"
EndIf
tRet += Str(secs)
Select Case mode
Case 0
tRet += "." + Str(milliseconds)
Case 1
'do nothing
Case 2 '1 digit
tRet += "." + Left(Str(milliseconds),1)
Case 3 '2 digits
tRet += "." + Left(Str(milliseconds),2)
End Select
Return tRet
End Function
Sub Scan
Dim As FB.EVENT se
Dim As String g, keySubst, mousecol, mouserow
Dim As Integer x, mx, my, mw, mb
Static As Double repeatLock
Static As Integer mouselock
menuitem = ""
Line (271,503)-(296,512),cfont,b
mouseMenu(" - ","",64,35,cfont,cback) 'decrease animation speed
Line (79,503)-(104,512),cfont,b
mouseMenu(" + ","",64,11,cfont,cback) 'increase animation speed
Line (351,439)-(544,448),cfont,b
mouseMenu(" setup engine 1 options ","",56,45,cfont,cback)
Line (351,471)-(544,480),cfont,b
mouseMenu(" setup engine 2 options ","",60,45,cfont,cback)
Color cfont,cback
Select Case menuitem
Case ""
'do nothing
Case "-" 'decrease animation speed
If animationSpeed > 0 Then
animationSpeed -= 1
WritePrivateProfileString("","animationSpeed",Str(animationSpeed),StrPtr(iniFile))
EndIf
update
Case "+" 'increase animation speed
animationSpeed += 1
WritePrivateProfileString("","animationSpeed",Str(animationSpeed),StrPtr(iniFile))
update
Case "setup engine 1 options"
ScreenSet 2,2
setupEngine(engine(1),1)
setEngineOptionsFlag = 1
ScreenSet 1,1
update
Case "setup engine 2 options"
ScreenSet 2,2
setupEngine(engine(2),2)
setEngineOptionsFlag = 1
ScreenSet 1,1
update
End Select
If Timer > repeatLock Then
If GetKeyState(109) < 0 Then 'minus-key --> decrease animation speed
If animationSpeed > 0 Then 'don't let animation speed get negative
animationSpeed -= 1
WritePrivateProfileString("","animationSpeed",Str(animationSpeed),StrPtr(iniFile))
EndIf
update
repeatLock = Timer + .2 'repetition delay
ElseIf GetKeyState(107) < 0 Then 'plus-key --> increase animation speed
animationSpeed += 1
WritePrivateProfileString("","animationSpeed",Str(animationSpeed),StrPtr(iniFile))
update
repeatLock = Timer + .2 'repetition delay
EndIf
EndIf
If ScreenEvent(@se) Then
If se.type = FB.EVENT_WINDOW_CLOSE Then 'end program
Close
CloseEngines
'Screen 0
ScreenSet
'Sleep 500
Print "ende"
'Sleep 500
End
EndIf
EndIf
If humanflag Then
If GetMouse(mx,my,mw,mb) = 0 Then
mousecol = Mid("abcdefgh",Fix((mx - bx)/42)+1,1)
mouserow = Mid("87654321",Fix((my - by)/42)+1,1)
If (mb And 1) And (mouselock = 0) Then
WriteEngineInfo(opponent,"field " + mousecol + mouserow)
Locate 50,10
mouselock = 1
EndIf
If mb = 0 Then
mouselock = 0
EndIf
EndIf
EndIf
End Sub
Sub GetEngineOptions(engine As String)
Dim As SECURITY_ATTRIBUTES sa
Dim As STARTUPINFO si
Dim As PROCESS_INFORMATION pi
Dim As HANDLE hReadChildPipe, hWritePipe, hReadPipe, hWriteChildPipe, hProcessHandle
Dim As Integer iNumberOfBytesWritten, iTotalBytesAvail, iBytesToRead, x, y, begPtr, endPtr
Dim As String order, g, sBuf
ReDim As String responseString(1)
Const As Integer MaxBytesToRead = 4096
ReDim engineOptions(5,1)
'install the pipes to the engine
sa.nLength = SizeOf(SECURITY_ATTRIBUTES)
sa.lpSecurityDescriptor = NULL
sa.bInheritHandle = TRUE
'start and connect engine
CreatePipe(@hReadChildPipe,@hWritePipe,@sa,0)
CreatePipe(@hReadPipe,@hWriteChildPipe,@sa,0)
GetStartupInfo(@si)
si.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
si.wShowWindow = SW_HIDE
si.hStdOutput = hWriteChildPipe
si.hStdError = hWriteChildPipe
si.hStdInput = hReadChildPipe
CreateProcess(0,ExePath + "\engines\" + engine,0,0,TRUE,0,0,0,@si,@pi)
hProcessHandle = pi.hProcess
CloseHandle(hWriteChildPipe)
CloseHandle(hReadChildPipe)
order = "uci" + Chr(10)
WriteFile(hWritePipe,StrPtr(order),Len(order),@iNumberOfBytesWritten,NULL)
g = ""
Do
Do
sBuf = "" 'clear buffer
PeekNamedPipe(hReadPipe,NULL,NULL,NULL,@iTotalBytesAvail,NULL)
If iTotalBytesAvail Then 'pipe is not empty
If iTotalBytesAvail < MaxBytesToRead Then
iBytesToRead = iTotalBytesAvail 'set all available bytes to be read
Else
iBytesToRead = MaxBytesToRead 'set the first 4096 bytes to be read
EndIf
sBuf = String(iBytesToRead,Chr(0)) 'set the length of the buffer string to the necessary value
'read the specified amount of bytes from the pipe
ReadFile(hReadPipe,StrPtr(sBuf),iBytesToRead,@iNumberOfBytesWritten,NULL)
g += sBuf 'add the buffer to the return string
Sleep 1
Else 'pipe is empty
Exit Do
EndIf
Loop
Loop Until InStr(g,"uciok")
x = 0
y = 0
begptr = 1
Do 'parse the engine response to separate strings
x += 1
ReDim Preserve responseString(x) 'enlarge array
endptr = InStr(begptr,g,Chr(13,10)) 'find next line feed
responseString(x) = Mid(g,begptr,endptr - begptr) 'write separate string to array
If InStr(responseString(x),"option name ")Then
y += 1 'count option strings
EndIf
begptr = endptr + 2 'set pointer to the beginnig of the next string
Loop While begptr <= Len(g)
ReDim engineOptions(5,y) 'dim options array
x = 0
For y = 1 To UBound(responseString) 'parse option strings
g = responseString(y)
If InStr(g,"option name ") Then 'option string
x += 1
begptr = InStr(g,"option name ") + 13
endptr = InStr(begptr,g,"type ")
engineOptions(oname,x) = Mid(g,begptr - 1,endptr - begptr)
If InStr(g,"type ") Then
begptr = InStr(g,"type ") + 5
endptr = InStr(begptr,g," ")
engineOptions(otype,x) = Mid(g,begptr,endptr - begptr)
EndIf
If InStr(g,"default ") Then
begptr = InStr(g,"default ") + 8
endptr = InStr(begptr,g," ")
engineOptions(odefault,x) = Mid(g,begptr,endptr - begptr)
EndIf
If InStr(g,"min ") Then
begptr = InStr(g,"min ") + 4
endptr = InStr(begptr,g," ")
engineOptions(omin,x) = Mid(g,begptr,endptr - begptr)
EndIf
If InStr(g,"max ") Then
begptr = InStr(g,"max ") + 4
endptr = InStr(begptr,g," ")
engineOptions(omax,x) = Mid(g,begptr,endptr - begptr)
EndIf
If InStr(g,"var ") Then
begptr = 1
Do
begptr = InStr(begptr,g,"var ") + 4
endptr = InStr(begptr,g," ")
engineOptions(ovar,x) += Mid(g,begptr,endptr - begptr) + Chr(10)'" "
begptr = endptr
Loop While InStr(begptr,g,"var ")
EndIf
EndIf
Next
TerminateProcess(hProcessHandle, @ExitCode)
CloseHandle(hWritePipe)
CloseHandle(hReadPipe)
End Sub
Sub setupEngine(engine As String, engNumber As Integer)
Dim As Integer menlin, mencol, x, y, xmax, setDefaultFlag, page, pages, pagelen, o, _
mx, my, mw, mb, sliderTop, sliderBot, scrollLock, begptr, endptr, wheel, _
wdiff
Dim As String menutext, g, engName, opp
engName = engine + " as " + Str(engNumber)
GetEngineOptions(engine)
pagelen = 20
pages = Int(UBound(engineOptions,2)/pagelen) + 1
page = 1
Do
Do 'setup loop
menlin = 6
mencol = 35
menuitem = ""
Cls
Locate 3,10
Print ">>> SETUP ENGINE ";
Color cfont,cbacklt
Print " ";engine;" ";
Color cfont,cback
Print " OPTIONS <<<
If page * pagelen < UBound(engineOptions,2) Then
xmax = pagelen
Else
xmax = UBound(engineOptions,2) - ((page - 1) * pagelen)
EndIf
Do 'menu loop
menuitem = ""
If pages > 1 Then 'more than 1 page --> create scrollbar
Line (520,57)-(530,370),cfont,b 'scrollbar
slidertop = 57 + 313/pages*(page-1)
sliderbot = 57 + 313/pages*page
Line (520,slidertop)-(530,sliderbot),cfont,bf 'slider
Locate menlin + 2, 69
Print "page";page;"/";Str(pages)
GetMouse(mx,my,mw,mb)
If mb = 0 Then 'no button pressed --> reset scrollLock
scrollLock = 0
EndIf
'scroll pages
If (mx > 520) And (mx < 530) And (scrollLock = 0) Then
If (my < slidertop) And (my > 57) And (mb And 1) Then 'scroll to previous page
page -= 1
scrollLock = 1
Exit Do,Do
ElseIf (my > sliderbot) And (my < 374) And (mb And 1) Then 'scroll to next page
page += 1
scrollLock = 1
Exit Do,Do
EndIf
EndIf
EndIf
For x = 1 To xmax 'selected page
o = (page - 1) * pagelen + x
GetPrivateProfileString(engName,engineOptions(oname,o),engineOptions(odefault,o),@iniBuffer,100,StrPtr(iniFile))
menutext = engineOptions(oname,o) + " = " + iniBuffer
Select Case engineOptions(otype,o) 'extend menu text
Case "check"
Case "spin"
menutext += " (" + engineOptions(omin,o) + ".." + engineOptions(omax,o) + ") [" + engineOptions(odefault,o) + "]"
Case "combo"
If iniBuffer = engineOptions(odefault,o) Then
menutext += " (=default)"
ElseIf inibuffer = Left(engineOptions(ovar,o),InStr(engineOptions(ovar,o),Chr(10)) - 1) Then
menutext += " (=1st)"
EndIf
Case "button"
menutext += "BUTTON"
Case "string"
End Select
mouseMenu(menutext,"=",menlin + 2 * x ,mencol,cfont,cback) 'put menu item on screen
If menuitemhit Then
Select Case engineOptions(otype,o)
Case "spin" 'change value with mouse wheel
If mw <> wheel Then
Exit Do
EndIf
End Select
EndIf
If menuitem = engineOptions(oname,o)Then 'item was clicked
Exit Do
EndIf
Next
If setDefaultFlag = 1 Then
If Frac(Timer) > .5 Then 'flash item text
mouseMenu(" CHOOSE VALUE to default","",menlin + 44,mencol - 15,cfont,cback)
Else
mouseMenu(" CHOOSE VALUE to default","",menlin + 44,mencol - 15,cfont,cbacklt)
EndIf
Else
mouseMenu("Set ONE value to default ","",menlin + 44,mencol - 15,cfont,cback)
EndIf
If setDefaultFlag = 2 Then
Locate menlin + 46,mencol - 15
If Frac(Timer) > .5 Then 'flash text
Color cfont,cback
Else
Color cfont,cbacklt
EndIf
Print " ARE YOU SURE ? "
mouseMenu(" NO ","",menlin + 46,mencol + 5,cfont,cback)
mouseMenu(" YES ","",menlin + 46,mencol + 10,cfont,cback)
Else
mouseMenu("Set ALL values to default","",menlin + 46,mencol - 15,cfont,cback)
EndIf
mouseMenu("Exit","",menlin + 48,mencol - 15,cfont,cback)
Color cfont,cback
Select Case menuitem 'clicked menu item
Case "Set ONE value to default"
setDefaultFlag = 1
Case "CHOOSE VALUE to default"
setDefaultFlag = 0
Case "Set ALL values to default" 'delete engine section from .ini file
setDefaultFlag = 2
Locate menlin + 46,mencol - 15
Print " "
Case "NO" 'cancel --> don't reset values
setDefaultFlag = 0
Locate menlin + 46,mencol - 15
Print " "
Case "YES" 'delete engine section from .ini file --> set all values to default
WritePrivateProfileString(engName,0,0,StrPtr(iniFile))
Locate menlin + 46,mencol - 15
Print " "
SetDefaultFlag = 0
Case "Exit" 'exit engine options setup
Return
End Select
wheel = mw
Loop
Color cfont,cback
'edit option
If setDefaultFlag Then 'set chosen value to default
iniBuffer = engineOptions(odefault,o)
setDefaultFlag = 0
Else 'set option to new value
Select Case engineOptions(otype,o) 'option type
Case "check" 'toggle value
Select Case iniBuffer
Case "true"
iniBuffer = "false"
Case "false"
iniBuffer = "true"
End Select
Case "spin"
If wheel = mw Then 'no mouse wheel action --> keyboard input
Locate menlin + 2 * x ,mencol + 2
Print String(Len(iniBuffer) + 3," ")
Locate menlin + 2 * x ,mencol + 3
Input "",g
Else 'mouse wheel
y = Val(iniBuffer)
y += wheel - mw
g = Str(y)
wheel = mw
EndIf
If g <> "" Then
If (Val(g) >= Val(engineOptions(omin,o))) And (Val(g) <= Val(engineOptions(omax,o))) Then
iniBuffer = g
EndIf
EndIf
Case "combo" 'flip through "var" items
begptr = 1 'set pointer to 1st var item
endptr = InStr(engineOptions(ovar,o),Chr(10)) 'set pointer to separator
Do Until Mid(engineOptions(ovar,o),begptr,endptr - begptr) = iniBuffer 'search current var item
begptr = endptr + 1
endptr = InStr(begptr,engineOptions(ovar,o),Chr(10))
If endptr >= Len(engineOptions(ovar,o)) Then 'set pointer to 1st var item
endptr = 0
Exit Do
EndIf
Loop
begptr = endptr + 1 'set pointer to next var item
endptr = InStr(begptr,engineOptions(ovar,o),Chr(10)) 'set pointer to next separator
iniBuffer = Mid(engineOptions(ovar,o),begptr,endptr - begptr) 'get next var item
Case "button"
'choose correct engine
If engNumber = currentWhite Then
opp = w
ElseIf engNumber = currentBlack Then
opp = b
EndIf
pCon("opp ",opp)
WriteEngineInfo(opp,"setoption name " + engineOptions(oname,o)) 'send BUTTON option to engine
Case "string"
Locate menlin + 2 * x ,mencol + 5 + Len(inibuffer)
Input "",g
If g <> "" Then
iniBuffer = g
EndIf
End Select
EndIf
If iniBuffer = engineOptions(odefault,o) Then 'remove .ini file entry --> set option to default
WritePrivateProfileString(engName,engineOptions(oname,o),0,StrPtr(iniFile))
Else 'write value to .ini file
WritePrivateProfileString(engName,engineOptions(oname,o),StrPtr(iniBuffer),StrPtr(iniFile))
EndIf
Loop
Loop
End Sub
Sub setEngineOptions(opp As String)
Dim As Integer x, ff
Dim As String engName, g, optName, optVal
Select Case opp
Case w
engName = engine(currentWhite) + " as " + Str(currentWhite)
Case b
engName = engine(currentBlack) + " as " + Str(currentBlack)
End Select
ff = FreeFile
Open ExePath + "\setup.ini" For Input As ff
Do 'search section in .ini - file
Line Input #ff,g
Loop Until (g = "[" + engName + "]") Or (Eof(ff))
If Eof(ff) Then 'section not found
Close ff
Return
EndIf
Do 'set all mentioned options
Line Input #ff,g
If Left(g,1) = "[" Then 'next section --> end option setting
Close ff
Return
ElseIf g = "" Then 'blank line
'next line
Else
x = InStr(g,"=")
If x <> 0 Then 'parse option entry
optname = Left(g,x - 1) 'option name
optVal = Mid(g,x + 1) 'option value
WriteEngineInfo(opp,"isready")
Do 'wait until engine is listening
Loop Until InStr(GetEngineResponse(opp),"readyok")
WriteEngineInfo(opp,"setoption name " + optName + " value " + optVal) 'send option to engine
EndIf
EndIf
Loop Until Eof(ff)
Close ff
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
'***************************************************
knightCheck:
Data -1,-2, 1,-2, 2,-1, 2,1, 1,2, -1,2, -2,1, -2,-1
' 1 = pawn, 2 = rook, 3 = knight, 4 = bishop, 5 = queen, 6 = king, 7 = border
' black pieces given negative value, sgn() returns -1 for black and +1 for white
' 0 1 2 3 4 5 6 7 8 9 10 11 <--- internal coordinates
' A B C D E F G H <--- display coordinates
boardLayout:
Data 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7 '0
Data 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7 '1
Data 7, 7,-2,-3,-4,-5,-6,-4,-3,-2, 7, 7 '2 8
Data 7, 7,-1,-1,-1,-1,-1,-1,-1,-1, 7, 7 '3 7
Data 7, 7, 0, 0, 0, 0, 0, 0, 0, 0, 7, 7 '4 6
Data 7, 7, 0, 0, 0, 0, 0, 0, 0, 0, 7, 7 '5 5
Data 7, 7, 0, 0, 0, 0, 0, 0, 0, 0, 7, 7 '6 4
Data 7, 7, 0, 0, 0, 0, 0, 0, 0, 0, 7, 7 '7 3
Data 7, 7, 1, 1, 1, 1, 1, 1, 1, 1, 7, 7 '8 2
Data 7, 7, 2, 3, 4, 5, 6, 4, 3, 2, 7, 7 '9 1
Data 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7 '10
Data 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7 '11
Pieces:
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data "....................####.................."
Data "...................#****#................."
Data "..................#******#................"
Data ".................#********#..............."
Data ".................#********#..............."
Data ".................#********#..............."
Data ".................#********#..............."
Data "..................#******#................"
Data "...................#****#................."
Data "...................######................."
Data "..................#******#................"
Data "................##********##.............."
Data "...............#************#............."
Data "..............#**************#............"
Data "..............################............"
Data ".................#********#..............."
Data ".................#********#..............."
Data ".................#********#..............."
Data "................#**********#.............."
Data "................#**********#.............."
Data "...............#************#............."
Data "..............#**************#............"
Data ".............#****************#..........."
Data "............#******************#.........."
Data "............#******************#.........."
Data "............####################.........."
Data "...........#********************#........."
Data "...........#********************#........."
Data "...........######################........."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data "...........#####..######..#####..........."
Data "...........#***#..#****#..#***#..........."
Data "...........#***#..#****#..#***#..........."
Data "...........#***#..#****#..#***#..........."
Data "...........#***####****####***#..........."
Data "...........#******************#..........."
Data "...........#******************#..........."
Data "...........#******************#..........."
Data "...........#******************#..........."
Data "...........####################..........."
Data "............#****************#............"
Data ".............################............."
Data ".............#****#****#****#............."
Data ".............#****#****#****#............."
Data ".............################............."
Data ".............#**#****#****#*#............."
Data ".............#**#****#****#*#............."
Data ".............################............."
Data ".............#****#****#****#............."
Data ".............#****#****#****#............."
Data ".............################............."
Data ".............#**#****#****#*#............."
Data ".............#**#****#****#*#............."
Data "............##################............"
Data "...........#******************#..........."
Data "..........#********************#.........."
Data "..........#********************#.........."
Data ".........#**********************#........."
Data ".........########################........."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data "....................#....................."
Data "...................##....................."
Data "..................#**#...................."
Data "..................#**###.................."
Data ".................#******###..............."
Data "................#**********#.............."
Data "................#***********#............."
Data "...............#**#*********#............."
Data "..............#**##**********#............"
Data ".............#**##.#*********#............"
Data ".............#**###***********#..........."
Data "............#*****************#..........."
Data "............#*****************#..........."
Data "...........#******************#..........."
Data "...........#*******************#.........."
Data "..........#******#####*********#.........."
Data "..........#******#..#**********#.........."
Data ".........#*******#..#**********#.........."
Data ".........#******#..#***********#.........."
Data "..........#****#..#***********#..........."
Data "..........#####..#************#..........."
Data "................#*************#..........."
Data "...............#*************#............"
Data "...............#*************#............"
Data "..............#***************#..........."
Data "..............#***************#..........."
Data ".............#*****************#.........."
Data ".............#******************#........."
Data "............#*******************#........."
Data "............######################........"
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".....................##..................."
Data "....................#**#.................."
Data "...................#****#................."
Data "..................#******#................"
Data ".................#********#..............."
Data "................#**********#.............."
Data "...............#************#............."
Data "...............#************#............."
Data "..............##************##............"
Data "..............#**************#............"
Data "..............#**************#............"
Data "..............#******##******#............"
Data ".............#*******##*******#..........."
Data ".............#*******##*******#..........."
Data ".............#*******##*******#..........."
Data ".............#****########****#..........."
Data ".............#****########****#..........."
Data ".............#*******##*******#..........."
Data ".............#*******##*******#..........."
Data ".............#*******##*******#..........."
Data ".............#*******##*******#..........."
Data ".............#*******##*******#..........."
Data "..............#******##******#............"
Data "..............#******##******#............"
Data "...............#************#............."
Data "...............#************#............."
Data "...............##############............."
Data "...............##**********##............."
Data "................############.............."
Data "..............##************##............"
Data "............##*****######*****##.........."
Data "...........#*****##......##*****#........."
Data "...........######..........######........."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".....................#...................."
Data "....................#*#..................."
Data "...................#***#.................."
Data "..................#*****#................."
Data "..................#*****#................."
Data "..................#*****#................."
Data "............#.....#*****#.....#..........."
Data "...........#*#.....#***#.....#*#.........."
Data "..........#***#....#***#....#***#........."
Data "..........#***#....#***#....#***#........."
Data "...........#*#.....#***#.....#*#.........."
Data "...........#*#.....#***#.....#*#.........."
Data "..........#***#...#*****#...#***#........."
Data "..........#***#..#*******#..#***#........."
Data "..........#***#..#*******#..#***#........."
Data ".....##...#***#...#*****#...#***#...##...."
Data ".....#*#..#***#...#*****#...#***#..#*#...."
Data ".....#**#.#***#...#*****#...#***#.#**#...."
Data ".....#**#.#***#...#*****#...#***#.#**#...."
Data "......#*#.#***#...#*****#...#***#.#*#....."
Data "......#**##***#...#*****#...#***##**#....."
Data "......#**#*****#.#*******#.#*****#**#....."
Data ".......#*******##*********##*******#......"
Data ".......#***************************#......"
Data "........#*************************#......."
Data "........###########################......."
Data "........#*************************#......."
Data "........#*************************#......."
Data "........#*************************#......."
Data "........#*************************#......."
Data "........#*************************#......."
Data "........###########################......."
Data ".......#***************************#......"
Data ".......#***************************#......"
Data ".......#############################......"
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data ".........................................."
Data "....................###..................."
Data "....................#*#..................."
Data "..................###*###................."
Data "..................#*****#................."
Data "..................###*###................."
Data "....................#*#..................."
Data "....................#*#..................."
Data "...................#####.................."
Data "..................#*****#................."
Data "..................#*****#................."
Data "..................#*****#................."
Data "...................#***#.................."
Data "......#########.....#*#.....#########....."
Data ".....#.........######*######.........#...."
Data ".....#..............#*#..............#...."
Data ".....#....####......#*#......####....#...."
Data ".....#...#****###...#*#...###****#...#...."
Data ".....#.##********##.#*#.##********##.#...."
Data ".....#.#***********##*##***********#.#...."
Data ".....#.#************#*#************#.#...."
Data ".....#.#*****####***#*#***####*****#.#...."
Data ".....#.#****#****##*#*#*##****#****#.#...."
Data "......#*****#******##*##******#*****#....."
Data ".......#****#*******#*#*******#****#......"
Data ".......#****#*******#*#*******#****#......"
Data "........#****#******#*#******#****#......."
Data "........#****#******#*#******#****#......."
Data ".........#****#*****#*#*****#****#........"
Data ".........#*****#****#*#****#*****#........"
Data "..........#*****#***#*#***#*****#........."
Data "..........#######################........."
Data "..........#*********************#........."
Data "..........#######################........."
Data ".........##*********************##........"
Data "........##***********************##......."
Data "........###########################......."
Data ".........................................."
Data ".........................................."
Data ".........................................."