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

common.bi

Uploader:Mitgliedgrindstone
Datum/Zeit:12.01.2021 16:22:42
Hinweis: Dieser Quelltext ist Bestandteil des Projekts Colochessum, zu dem es auf FreeBASIC-Portal.de eine Projektseite gibt.

'#Include "d:\basic\freebasic\_tests\bipipe\bipipe.bi"
#Include "bipipe.bi"

Type direction
    col As Integer
    row As Integer
End Type

Type tFen
    pieces As String
    opponent As String
    castling As String
    enPassant As String
    halfmoves As Integer
    moves As Integer
    Declare Property fen As String 'read fen
    Declare Property fen(board() As Integer) As String 'generate fen from internal board
    Declare Property fen(f As String) 'write fen
    Declare Property fen(f As String, board() As Integer) 'write fen and set internal board
End Type

Property tFen.fen(f As String) 'parse fen
    Dim As Integer ptr1, ptr2

    ptr1 = InStr(f, " ")
    pieces = Left(f, ptr1 - 1)
    ptr2 = InStr(ptr1 + 1, f, " ")
    opponent = Mid(f, ptr1 + 1, ptr2 - ptr1 - 1)
    ptr1 = InStr(ptr2 + 1, f, " ")
    castling = Mid(f, ptr2 + 1, ptr1 - ptr2 - 1)
    ptr2 = InStr(ptr1 + 1, f, " ")
    enPassant = Mid(f, ptr1 + 1, ptr2 - ptr1 - 1)
    ptr1 = InStr(ptr2 + 1,f," ")
    halfmoves = Val(Mid(f, ptr2 + 1, ptr1 - ptr2 - 1))
    moves = Val(Mid(f, ptr1 + 1))

End Property

Property tFen.fen As String
    Return pieces + " " + opponent + " " + castling + " " + enPassant + " " + _
           Str(halfmoves) + " " + Str(moves)
End Property

Property tFen.fen(f As String, bo() As Integer) 'write fen and set internal board
    Dim As Integer x, y, i, row, col
    Dim As String opp, g

    If Len(f) Then
        fen = f 'write fen
    EndIf

    'preset internal board
    For row = 0 To 11
        For col = 0 To 11
            bo(col, row) = 7 'border
        Next
    Next

    row = 2
    col = 1

    For x = 1 To Len(pieces)
        g = Mid(pieces, x, 1)
        Select Case g
            Case "1" To "8" 'empty field(s)
                i = Val(g)
                For y = 1 To i
                    bo(col + y, row) = 0 'empty field
                Next
                col += i
            Case "/" 'next row
                row += 1
                col = 1
            Case Else
                col += 1 'next column
                bo(col, row) = InStr("kqbnrp0PRNBQK", g) - 7 'put piece to field
        End Select
    Next

End Property

Property tFen.fen(bo() As Integer) As String 'generate fen from internal board
    Dim As Integer col, lin, countFree
    Dim As String g

    pieces = ""
    For col = 2 To 9
        For lin = 2 To 9
            'convert internal board to fen-string
            g = Mid("kqbnrp0PRNBQK", bo(lin, col) + 7, 1)
            If g = "0" Then
                countFree += 1
            Else
                If countFree Then
                    pieces += Str(countFree)
                    countFree = 0
                EndIf
                pieces += g
            EndIf
        Next
        If countFree Then
            pieces += Str(countFree)
            countFree = 0
        EndIf
        pieces += "/"
    Next
    pieces = RTrim(pieces, "/")

    Return fen

End Property


'Const As String w = "white", b = "black"

Dim Shared As direction north, northeast, east, southeast,  south, southwest, west, northwest ', _
                        'knightpattern(8)
Dim Shared As Integer board(12,12), sBoard(12,12) 'internal representation of board

Dim Shared As Double gameStamp

'Dim Shared As String enPassantField



'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
Dim Shared As direction knightpattern(1 To ...) = {(-1,-2),(1,-2),(2,-1),(2,1), _
                                                   (1,2),(-1,2),(-2,1),(-2,-1)}




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

Function testForCheck(opp As String) As Integer

    Dim As Integer x, col, row, drow, dcol, kingrow, kingcol, kingsig

    'set Sgn of the king
    kingsig = IIf(opp = "w", 1, -1)

    'get the internal coordinates of the king
    For kingrow = 2 To 9
        For kingcol = 2 To 9
            If board(kingcol,kingrow) = kingsig * 6 Then 'king found
                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 100*col + 10*row + 1
                            'Else
                            '   Exit Do 'next direction
                            EndIf
                        Case 2 'rook
                            If (dcol = 0) Or (drow = 0) Then    'king is looking straight
                                Return 100*col + 10*row + 2
                            'Else
                            '   Exit Do
                            EndIf
                        Case 3 'knight
                            'Exit Do 'next direction
                        Case 4 'bishop
                            If (dcol <> 0) And (drow <> 0) Then 'king is looking diagonal
                                Return 100*col + 10*row + 3
                            'Else
                            '   Exit Do
                            EndIf
                        Case 5 'queen
                            Return 100*col + 10*row + 4
                        Case 6 'king
                            If (Abs(kingcol - col) < 2) And (Abs(kingrow - row) < 2) Then
                                Return 100*col + 10*row + 5
                            'Else
                            '   Exit Do
                            EndIf
                    End Select
                    Exit Do 'next direction
                EndIf
            Loop
        Next
    Next

    For x = 1 To 8
        If board(kingcol + knightpattern(x).col, kingrow + knightpattern(x).row) = kingsig * -3 Then 'knight
            Return 100*col + 10*row + 6
        EndIf
    Next
    Return 0 'no check

End Function

Sub restoreBoard
    Dim As Integer col, row

    CopyMemory(@board(0,0),@sBoard(0,0),13*13*SizeOf(Integer))

    'For row = 0 To 12
    '   For col = 0 To 12
    '       Board(col,row) = sBoard(col,row)
    '   Next
    'Next

End Sub

Sub saveBoard
    Dim As Integer col, row
    'dim as any ptr bp '= @board(lbound(board)), sbp = @sBoard(LBound(sBoard))

    CopyMemory(@sBoard(0,0),@board(0,0),13*13*SizeOf(Integer))

    'For row = 0 To 12
    '   For col = 0 To 12
    '       sBoard(col,row) = board(col,row)
    '   Next
    'Next

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