FreeBasic

Великолепный исходник 100 клеточных шашек. Программа имеет довольно неплохой AI . Вся графика выполнена средствами FbGfx. Управление мышью.

Платформы: Windows, Linux
Автор: badidea

' Autor: badidea
'-----------------------------------------------

'Option Explicit
'Option Byval
'OPTION DYNAMIC

#DEFINE CLEARCOLORS 0
#DEFINE MAX_MOVES 128
#DEFINE MAX_DEPTH 16
#DEFINE MAX_SEARCH_DEPTH 7
#DEFINE HIT_SEARCH_DEPTH 12

Type moveType
    x As Integer
    y As Integer
End Type

Type boardType
    occupied As Integer '0=empty, 1=black, 2=white
    discType As Integer '0=normal piece, 1=king
    tileType As Integer '0=brown/black, 1=yellow/white
End Type

Type boardPtrType
    board(9,9) As boardType
End Type

Type bufferType
    board(9,9) As boardType
    dummyMoveSeq(MAX_DEPTH-1) As moveType
    msl(MAX_MOVES-1,MAX_DEPTH-1) As moveType
    mdl(MAX_MOVES-1) As Integer
End Type

Declare Sub showIntro()
Declare Function intrnd(limit As Integer) As Integer
Declare Function xScreen(x As Integer) As Integer
Declare Function yScreen(y As Integer) As Integer
Declare Function getTileColour(pTile As moveType, inverted As Integer) As Integer
Declare Function getMousePos(MouseX As Integer, MouseY As Integer, Byref pTile As moveType) As Integer
Declare Sub drawTile(x As Integer, y As Integer, colour As Integer)
Declare Sub drawTileBorder(x As Integer, y As Integer, colour As Integer)
Declare Sub initBoardArray(bPtr As boardType Ptr)
Declare Sub initBoardRandom(bPtr As boardType Ptr)
Declare Sub drawBoard(bPtr As boardType Ptr)
Declare Sub showActiveColour(activeColour As Integer)
Declare Sub findForcedMoves(Byref moveCtr As Integer, Byref maxDepth As Integer,_
depth As Integer, hitColour As Integer, discType As Integer, bPtr As boardType Ptr,_
mdlPtr As Integer Ptr, mslPtr As moveType Ptr, cmsPtr As moveType Ptr)
Declare Sub findNormalMoves(Byref moveCtr As Integer, hitColour As Integer,_
bPtr As boardType Ptr, mdlPtr As Integer Ptr, mslPtr As moveType Ptr,_
cmsPtr As moveType Ptr)
Declare Sub showMoves(numMoves As Integer, colour As Integer,_
mdlPtr As Integer Ptr, mslPtr As moveType Ptr)
Declare Sub showSingleMove(moveNum As Integer, colour As Integer,_
mdlPtr As Integer Ptr, mslPtr As moveType Ptr)
Declare Sub doMove(p0 As moveType, p1 As moveType, bPtr As boardType Ptr)
Declare Sub doFullMove(localMoveSeq As moveType Ptr, localDepth As Integer,_
bPtr As boardType Ptr, animate As Integer)
Declare Function filterHitMoves(numMoves As Integer, maxDepth As Integer,_
bPtr As boardType Ptr, mdlPtr As Integer Ptr, mslPtr As moveType Ptr) As Integer
Declare Sub createMoveList(Byref moveCtr As Integer, Byref maxDepth As Integer,_
turnColour As Integer, bPtr As boardType Ptr, mdlPtr As Integer Ptr, mslPtr As moveType Ptr)
Declare Sub createHitList(Byref moveCtr As Integer, Byref maxDepth As Integer,_
turnColour As Integer, bPtr As boardType Ptr, mdlPtr As Integer Ptr, mslPtr As moveType Ptr)
Declare Function searchMove(p0 As moveType, p1 As moveType, moveDepth As Integer,_
moveCtr As Integer, mdlPtr As Integer Ptr, mslPtr As moveType Ptr) As Integer
Declare Function evalBoard(bPtr As boardType Ptr, turnColour As Integer) As Integer
Declare Sub copyBoard(bSrcPtr As boardType Ptr, bDstPtr As boardType Ptr)
Declare Sub saveBoard(bPtr As boardType Ptr)
Declare Sub loadBoard(bPtr As boardType Ptr)
Declare Function enemyColour(colour As Integer) As Integer
Declare Function findBestMove(bPtr As boardType Ptr, moveColour As Integer,_
evalColour As Integer, mdlPtr As Integer Ptr, mslPtr As moveType Ptr,_
searchDepth As Integer) As Integer


Const xOffset = 180 'horizontal offset board, centre of 1st tile
Const yOffset = 50 'vertical offset board, centre of 1st tile
Const rTile = 27 'tile radius, including borders
Const dTile = rTile*2
Const rDisc = 23 'disc radius, including borders

Const pressed = 1, released = -1, idle = 0
Const true = 1, false = 0
Const isEmpty = 0, isBlack = 1, isWhite = 2
Const isPiece = 0, isKing = 1
Const LMB = 1, RMB = 2, MMB = 4
Const isBrown = 0, isYellow = 1
Const isComputer = 0, isHuman = 1
Const noAnimate = 0, doAnimate = 1

#IF (CLEARCOLORS = 1)
Const cBlack = 0, cDarkBlue = 1, cGreen = 6, cBlue = 3
Const cRed = 4, cPurple = 5, cBrown = 2, cLightGrey = 7
Const cDarkGrey = 8, cXBlue = 9, cLightGreen = 10, cLightBlue = 11
Const cLightRed = 12, cLightPurple = 13, cYellow = 14, cWhite = 15
#ELSE
Const cBlack = 0, cDarkBlue = 1, cGreen = 2, cBlue = 3
Const cRed = 4, cPurple = 5, cBrown = 6, cLightGrey = 7
Const cDarkGrey = 8, cXBlue = 9, cLightGreen = 10, cLightBlue = 11
Const cLightRed = 12, cLightPurple = 13, cYellow = 14, cWhite = 15
#ENDIF

Dim As boardType board(9,9), tempBoard(9,9)
Dim As moveType moveSeqList(MAX_MOVES-1,MAX_DEPTH-1) 'move sequence list
Dim As moveType bestMoveSeq(MAX_DEPTH-1)
Dim As moveType p0, p1, pOld, pCur0, pCur1
Dim As Integer moveDepthList(MAX_MOVES-1)
Dim As Integer bestMoveDepth
Dim As Integer i, j, x, y 'Free to use
Dim As Integer MouseX, MouseY, mouseWheel, mouseButtons
Dim As Integer lmbChange, lmbStat, lmbPrev
Dim As Integer rmbChange, rmbStat, rmbPrev
Dim As Integer mmbChange, mmbStat, mmbPrev
Dim As Integer startSet, stopSet, forcedHit
Dim As Integer turnColour, moveCtr, moveDone, allowMove
Dim As Integer moveDepth, maxDepth, moveNum, player(3-1)
Dim As Integer evalScore, evalColour
Dim As Integer moveScore, bestScore, nBestScores, score(MAX_MOVES-1)
Dim As String keyString

'-----------------------------------------------

Dim Shared As bufferType global(HIT_SEARCH_DEPTH)
Dim Shared As Integer endOfGame, startTime
Dim Shared As Integer maxSearchDepth, hitSearchDepth
maxSearchDepth = MAX_SEARCH_DEPTH
hitSearchDepth = HIT_SEARCH_DEPTH

'-----------------------------------------------

maxDepth = 1
moveDepth = 0
endOfGame = 0
moveDone = 0
player(isBlack) = isComputer
player(isWhite) = isHuman
turnColour = isWhite 'wit begint
moveCtr=-1

Screen 19

initBoardArray(@board(0,0))
showIntro
Color cLightGrey, cDarkGrey
startTime = Timer
Randomize startTime
drawBoard(@board(0,0))
showActiveColour(turnColour)

Do
    If player(turnColour) = isHuman Then

        Getmouse MouseX, MouseY, mouseWheel, mouseButtons

        lmbPrev = lmbStat
        If ((mouseButtons And LMB) = LMB) And (mouseButtons <> -1) Then lmbStat = 1 Else lmbStat = 0
        lmbChange = lmbStat - lmbPrev '+1=pressed, -1=released

        rmbPrev = rmbStat
        If ((mouseButtons And RMB) = RMB) And (mouseButtons <> -1) Then rmbStat = 1 Else rmbStat = 0
        rmbChange = rmbStat - rmbPrev '+1=pressed, -1=released

        mmbPrev = mmbStat
        If ((mouseButtons And MMB) = MMB) And (mouseButtons <> -1) Then mmbStat = 1 Else mmbStat = 0
        mmbChange = mmbStat - mmbPrev '+1=pressed, -1=released

        If (lmbChange = idle) And (rmbChange = idle) And (mmbChange = idle) Then
            Sleep 10 'Do not stress CPU, when doing nothing
        End If

        If (keyString = "s") Then
            saveBoard(@board(0,0)) 'save to board.bin
            drawBoard(@board(0,0))
        End If

        If (keyString = "o") Then
            loadBoard(@board(0,0)) 'open from board.bin
            drawBoard(@board(0,0))
        End If

        If (rmbChange = pressed) Then '(debug)
            'show allowed moves
            If (moveDepth = 0) Then
                createMoveList(moveCtr,maxDepth,turnColour,@board(0,0),@moveDepthList(0),@moveSeqList(0,0))
            End If
            showMoves(moveCtr,cLightGreen,@moveDepthList(0),@moveSeqList(0,0))
        End If

        If (rmbChange = released) Then '(debug)
            drawBoard(@board(0,0)) 'clear help lines
            showActiveColour(turnColour)
        End If

        If (lmbChange = pressed) Then
            startSet = getMousePos(MouseX, MouseY, p0)
        End If

        'Show mouse position
        If (lmbStat = 1) Then
            getMousePos(MouseX, MouseY, pCur0)
            If (pCur0.x<>pCur1.x) Or (pCur0.y<>pCur1.y) Then
                drawTileBorder(pCur0.x, pCur0.y, getTileColour(pCur0,1))
                drawTileBorder(pCur1.x, pCur1.y, getTileColour(pCur1,0))
                pCur1 = pCur0
            End If
        End If

        If (lmbChange = released) Then
            stopSet = getMousePos(MouseX, MouseY, p1)
        End If

        If (lmbChange = released) And (startSet = 1) And (stopSet = 1) Then
            'New move/turn? Make new list.
            If (moveDepth = 0) Then
                createMoveList(moveCtr,maxDepth,turnColour,@board(0,0),@moveDepthList(0),@moveSeqList(0,0))
                pOld=p0 'clear old end positions
            End If

            allowMove = searchMove(p0, p1, moveDepth, moveCtr, @moveDepthList(0), @moveSeqList(0,0))
            If (allowMove) And (pOld.x=p0.x) And (pOld.y=p0.y) Then
                doMove(p0,p1,@board(0,0)) 'Do partial move from sequence
                drawBoard(@board(0,0))
                moveDepth+=1
                pOld=p1
            Else
                showActiveColour(-1) 'error
                showActiveColour(turnColour)
            End If
        End If

        If (moveDepth >= maxDepth) Then
            If (p1.y=0) And (board(p1.x,p1.y).occupied=isWhite) Then board(p1.x,p1.y).discType = isKing
            If (p1.y=9) And (board(p1.x,p1.y).occupied=isBlack) Then board(p1.x,p1.y).discType = isKing
            moveDone = 1
            moveDepth = 0 'reset
        End If

        If (moveCtr = 0) Then endOfGame = 1

    Else 'player = isComputer

        moveScore = findBestMove(@board(0,0), turnColour, turnColour, @bestMoveDepth, @bestMoveSeq(0), 0)
        If (endOfGame <> 1) Then
            Locate 8,2: Print "Best:";moveScore\10;" ";
            doFullMove(@bestMoveSeq(0), bestMoveDepth, @board(0,0), doAnimate)
        Endif
        moveDone = 1

    End If

    If (moveDone = 1) Then
        moveDone = 0
        drawBoard(@board(0,0)) 'Draw whenever we do or try to do a move
        turnColour = enemyColour(turnColour)
        showActiveColour(turnColour)
    End If

    keyString = Inkey$
Loop While (keyString <> Chr$(27)) And (endOfGame = 0)

'-----------------------------------------------

Color cWhite, cBlack
Locate 19,44: Print "End of Game!";
Locate 21,40: Print "Random seed was:";StartTime
Sleep 1000
While (Inkey$ <> Chr$(27)): Wend
End 0

'-----------------------------------------------

Sub showIntro
    Dim As Integer scrWidth, scrHeight
    Dim As Integer PlayerLevel

    Locate 12,35: Print " Checkers game by BadIdea";
    Locate 13,35: Print "    with 'Dutch' rules";
    Sleep 200
    Locate 15,35: Print " Version 1.8 / 25 May 2007";
    Locate 16,35: Print " very_bad_idea@hotmail.com";
    Sleep 200
    Locate 18,35: Print " <Escape> to exit program!";
    Sleep 200

    While ((PlayerLevel < 2) Or (PlayerLevel > 6))
        Locate 25,35: Print "                              "
        Locate 25,35: Input "   Dificulty (2...6): ", PlayerLevel
    Wend
    maxSearchDepth = PlayerLevel
    hitSearchDepth = PlayerLevel*2-1

    'draw dark grey window background
    Screeninfo scrWidth, scrHeight
    Line (0, 0)-(scrWidth-1, scrHeight-1), cDarkGrey, BF
End Sub

'-----------------------------------------------

Function intrnd(limit As Integer) As Integer
    Return Int(Rnd*limit)
End Function

'-----------------------------------------------

Function xScreen(x As Integer) As Integer
    Return x * dTile + xOffset
End Function

'-----------------------------------------------

Function yScreen(y As Integer) As Integer
    Return y * dTile + yOffset
End Function

'-----------------------------------------------

Function getTileColour(pTile As moveType, inverted As Integer) As Integer
    'Strange code, but works
    If (((pTile.x+pTile.y) And 1) = inverted) Then
        Return cYellow
    Else
        Return cBrown
    End If
End Function

'-----------------------------------------------

Function getMousePos(MouseX As Integer, MouseY As Integer, Byref pTile As moveType) As Integer
    Dim validPos As Integer
    validPos = 0
    If (MouseX > xOffset - rTile And MouseX < xOffset + rTile * 19) Then
        If (MouseY > yOffset - rTile And MouseY < yOffset + rTile * 19) Then
            pTile.x = (MouseX - xOffset + rTile) \ (dTile)
            pTile.y = (MouseY - yOffset + rTile) \ (dTile)
            validPos = 1
        End If
    End If
    Return validPos
End Function

'-----------------------------------------------

Sub drawTile(x As Integer, y As Integer, colour As Integer)
    Dim sz As Integer 'sz = size to edge, half of square tile
    sz = rTile - 1
    Line (xScreen(x)-sz, yScreen(y)-sz)-(xScreen(x)+sz, yScreen(y)+sz), colour, BF
End Sub

'-----------------------------------------------

Sub drawTileBorder(x As Integer, y As Integer, colour As Integer)
    'for debugging
    Dim As Integer sz1, sz2 'sz = size to edge, half of square tile
    sz1 = rTile - 1
    sz2 = rTile - 2
    Line (xScreen(x)-sz1, yScreen(y)-sz1)-(xScreen(x)+sz1, yScreen(y)+sz1), colour, B
    Line (xScreen(x)-sz2, yScreen(y)-sz2)-(xScreen(x)+sz2, yScreen(y)+sz2), colour, B
End Sub

'-----------------------------------------------

Sub initBoardArray(bPtr As boardType Ptr)
    'Initiate: board().tileType & board().occupied
    Dim As Integer x, y
    For y = 0 To 9
        For x = 0 To 9
            If ((y+x) And 1) Then
                bPtr[x*10+y].tileType = isBrown
                If (y<4) Then
                    bPtr[x*10+y].occupied = isBlack
                    bPtr[x*10+y].discType = isPiece
                Elseif (y>5) Then
                    bPtr[x*10+y].occupied = isWhite
                    bPtr[x*10+y].discType = isPiece
                Else
                    bPtr[x*10+y].occupied = isEmpty
                End If
            Else
                bPtr[x*10+y].tileType = isYellow
            End If
        Next
    Next
End Sub

'-----------------------------------------------

Sub initBoardRandom(bPtr As boardType Ptr)
    'Initiate: board().tileType & board().occupied
    Dim As Integer x, y

    For y = 0 To 9
        For x = 0 To 9
            If ((y+x) And 1) Then
                bPtr[x*10+y].tileType = isBrown
                If Int(Rnd(1) * 10) > 7 Then
                    If Int(Rnd(1) * 2) = 1 Then
                        bPtr[x*10+y].discType = isPiece
                    Else
                        'bPtr[x*10+y].discType = isKing
                    End If
                    If Int(Rnd(1) * 2) = 1 Then
                        bPtr[x*10+y].occupied = isBlack
                    Else
                        bPtr[x*10+y].occupied = isWhite
                    End If
                Else
                    bPtr[x*10+y].occupied = isEmpty
                End If
            Else
                bPtr[x*10+y].tileType = isYellow
            End If
        Next
    Next

End Sub

'-----------------------------------------------

Sub drawBoard(bPtr As boardType Ptr)
    Dim As Integer x, y, colour, edge
    Dim As Integer whiteCtr, blackCtr
    Dim As Integer whiteKingCtr, blackKingCtr
    Dim As Integer discHeight, discYoffset, discXoffset
    'XXX Theoretical bug! No king if no pieces hit

    'draw light grey board background
    edge = rTile + 1
    Line (xScreen(0)-edge, yScreen(0)-edge)-(xScreen(9)+edge, yScreen(9)+edge), cLightGrey, BF

    'draw square tiles & discs
    For y = 0 To 9
        For x = 0 To 9
            If (bPtr[x*10+y].tileType = isYellow) Then
                drawTile(x,y,cYellow)
            Else
                drawTile(x,y,cBrown)
                If (bPtr[x*10+y].occupied = isWhite) Then
                    Circle (xScreen(x),yScreen(y)),rDisc,8,,,,f      'white disc
                    Circle (xScreen(x),yScreen(y)),rDisc-1,15,,,,f   'white disc border
                    If (bPtr[x*10+y].discType = isKing) Then
                        Circle (xScreen(x),yScreen(y)),rDisc-8,7,,,,f    'white disc king!
                        whiteKingCtr+=1
                    End If
                    whiteCtr+=1
                Elseif (bPtr[x*10+y].occupied = isBlack) Then
                    Circle (xScreen(x),yScreen(y)),rDisc,7,,,,f      'black disc
                    Circle (xScreen(x),yScreen(y)),rDisc-1,0,,,,f    'black disc border
                    If (bPtr[x*10+y].discType = isKing) Then
                        Circle (xScreen(x),yScreen(y)),rDisc-8,8,,,,f    'black disc king!
                        blackKingCtr+=1
                    End If
                    blackCtr+=1
                Else
                    'Empty square
                End If
            End If
        Next
    Next

    discHeight = 12
    discYoffset = 550
    discXoffset = 20
    For y = 0 To 19-(whiteCtr+whiteKingCtr)
        Line (discXoffset, discYoffset-y*(discHeight+1))-Step(rDisc*2, discHeight), cBlack, b
        Line (discXoffset+1, discYoffset-y*(discHeight+1)+1)-Step(rDisc*2-2, discHeight-2), cWhite, bf
    Next
    Line (discXoffset, discYoffset-y*(discHeight+1))-Step(rDisc*2, discHeight), cDarkGrey, bf

    discXoffset = 80
    For y = 0 To 19-(blackCtr+blackKingCtr)
        Line (discXoffset, discYoffset-y*(discHeight+1))-Step(rDisc*2, discHeight), cLightGrey, b
        Line (discXoffset+1, discYoffset-y*(discHeight+1)+1)-Step(rDisc*2-2, discHeight-2), cBlack, bf
    Next
    Line (discXoffset, discYoffset-y*(discHeight+1))-Step(rDisc*2, discHeight), cDarkGrey, bf


    Locate 2,2: Print "Black:";blackCtr;" ";
    Locate 3,2: Print "White:";whiteCtr;" ";
    Locate 5,2: Print "Time:";Int(Timer)-startTime;" ";
    Locate 6,2: Print "Eval:";evalBoard(bPtr, isWhite)\10;" ";

    If (blackCtr = 0) Or (whiteCtr = 0) Then endOfGame = 1
End Sub

'-----------------------------------------------

Sub showActiveColour(activeColour As Integer)
    Dim As Integer scrWidth, scrHeight
    Screeninfo scrWidth, scrHeight
    If (activeColour=isWhite) Then
        Circle (scrWidth-50,scrHeight\2),rDisc,8,,,,f
        Circle (scrWidth-50,scrHeight\2),rDisc-1,15,,,,f
    Elseif (activeColour=isBlack) Then
        Circle (scrWidth-50,scrHeight\2),rDisc,7,,,,f
        Circle (scrWidth-50,scrHeight\2),rDisc-1,0,,,,f
    Else 'unknown color
        Circle (scrWidth-50,scrHeight\2),rDisc,cRed,,,,f
        Circle (scrWidth-50,scrHeight\2),rDisc-1,cLightRed,,,,f
        Sleep 250
    End If
End Sub

'-----------------------------------------------

Sub showMoves(numMoves As Integer, colour As Integer,_
    mdlPtr As Integer Ptr, mslPtr As moveType Ptr)

    Dim As Integer i
    For i = 0 To numMoves-1
        showSingleMove(i,colour,mdlPtr,mslPtr)
    Next
End Sub

'-----------------------------------------------

Sub showSingleMove(moveNum As Integer, colour As Integer,_
    mdlPtr As Integer Ptr, mslPtr As moveType Ptr)

    Dim As Integer i, j, pitch
    Dim As moveType p0, p1
    i = moveNum
    pitch = i * MAX_DEPTH
    For j = 0 To mdlPtr[i]-1
        'Lines between steps
        p0 = mslPtr[pitch+j]
        p1 = mslPtr[pitch+j+1]
        Line(xScreen(p0.x)-1, yScreen(p0.y))-(xScreen(p1.x)-1, yScreen(p1.y)),colour
        Line(xScreen(p0.x), yScreen(p0.y))-(xScreen(p1.x), yScreen(p1.y)),colour
        Line(xScreen(p0.x)+1, yScreen(p0.y))-(xScreen(p1.x)+1, yScreen(p1.y)),colour
    Next
    drawTileBorder(mslPtr[pitch+j].x, mslPtr[pitch+j].y, colour)
End Sub

'-----------------------------------------------

Sub doMove(p0 As moveType, p1 As moveType, bPtr As boardType Ptr)
    Dim As Integer x, y, xSign, ySign
    'do move
    bPtr[p1.x*10+p1.y].occupied = bPtr[p0.x*10+p0.y].occupied
    bPtr[p1.x*10+p1.y].discType = bPtr[p0.x*10+p0.y].discType
    bPtr[p0.x*10+p0.y].occupied = isEmpty
    'Remove all discs between x0,y0 and x1,y1; Works for kings as well
    If Abs(p1.x-p0.x) > 1 Then 'not a normal move?
        xSign = Sgn(p1.x-p0.x)
        ySign = Sgn(p1.y-p0.y)
        y = p0.y + ySign
        For x = p0.x+xSign To p1.x-xSign Step xSign
            bPtr[x*10+y].occupied = isEmpty
            y+=ySign
        Next
    End If
End Sub

'-----------------------------------------------

Sub doFullMove(localMoveSeq As moveType Ptr, localDepth As Integer,_
    bPtr As boardType Ptr, animate As Integer)

    Dim As Integer i
    Dim As moveType p0, p1

    For i = 0 To localDepth-1
        p0 = localMoveSeq[i]
        p1 = localMoveSeq[i+1]
        If (animate = doAnimate) Then
            showSingleMove(0,cGreen,@localDepth,localMoveSeq)
            Sleep 750
            doMove(p0, p1, bPtr) 'deel v/d move
            drawBoard(bPtr)
            Sleep 250
        Else
            doMove(p0, p1, bPtr) 'deel v/d move
        End If
    Next
    If (p1.y=0) And (bPtr[p1.x*10+p1.y].occupied=isWhite) Then bPtr[p1.x*10+p1.y].discType = isKing
    If (p1.y=9) And (bPtr[p1.x*10+p1.y].occupied=isBlack) Then bPtr[p1.x*10+p1.y].discType = isKing
End Sub

'-----------------------------------------------

Function filterHitMoves(numMoves As Integer, maxDepth As Integer,_
    bPtr As boardType Ptr, mdlPtr As Integer Ptr, mslPtr As moveType Ptr) As Integer

    Dim As Integer i,j,k
    Dim kingFound As Integer
    j = 0
    'Filter to get highest depths
    For i = 0 To numMoves-1
        If (mdlPtr[i] = maxDepth) Then
            If (i<>j) Then 'Equal? copy is nonsense
                mdlPtr[j] = mdlPtr[i]
                For k = 0 To maxDepth
                    mslPtr[j*MAX_DEPTH+k] = mslPtr[i*MAX_DEPTH+k]
                Next
            End If
            j+=1
        End If
    Next
    'King present in hit-list?
    numMoves = j-1
    kingFound = 0
    For i = 0 To numMoves
        If bPtr[mslPtr[i*MAX_DEPTH+0].x * 10 + mslPtr[i*MAX_DEPTH+0].y].discType = isKing Then
            kingFound = 1
            Exit For
        End If
    Next
    'Filter to get king moves
    If (kingFound = 1) Then
        j = 0
        For i = 0 To numMoves
            If bPtr[mslPtr[i*MAX_DEPTH+0].x * 10 + mslPtr[i*MAX_DEPTH+0].y].discType = isKing Then
                If (i<>j) Then 'Equal? copy is nonsense
                    mdlPtr[j] = mdlPtr[i]
                    For k = 0 To maxDepth
                        mslPtr[j*MAX_DEPTH+k] = mslPtr[i*MAX_DEPTH+k]
                    Next
                End If
                j+=1
            End If
        Next
    End If

    Return j
End Function

'-----------------------------------------------

Sub createMoveList(Byref moveCtr As Integer, Byref maxDepth As Integer,_
    turnColour As Integer, bPtr As boardType Ptr, mdlPtr As Integer Ptr, mslPtr As moveType Ptr)

    'Prioriteit:
    ' 1. Meerslag gaat voor
    ' 2. Damslag gaat voor
    ' 3. Slag gaat voor

    'createMoveList:
    ' 1. findForcedMoves (recursive function)
    ' 2. findNormalMoves
    ' 3. filterHitMoves

    Dim As Integer x, y, xs
    Dim As Integer hitColour, hitForced, discType
    Dim As moveType curMoveSeq(MAX_DEPTH-1) 'current move sequence
    Dim cmsPtr As moveType Ptr

    moveCtr = 0
    maxDepth = 0
    hitForced = 1
    cmsPtr = @curMoveSeq(0)
    hitColour = enemyColour(turnColour)

    'search for forced moves
    For y = 0 To 9
        If (y And 1) Then xs = 0 Else xs = 1 'skip yellow squares
        For x = xs To 9 Step 2
            If bPtr[x*10+y].occupied = turnColour Then
                cmsPtr[0].x = x 'start position disc
                cmsPtr[0].y = y 'start position disc
                discType = bPtr[x*10+y].discType
                findForcedMoves(moveCtr, maxDepth, 0, hitColour, discType, bPtr, mdlPtr, mslPtr, cmsPtr)
            End If
        Next
    Next

    'no forced moves found, now find normal moves
    If (moveCtr = 0) Then
        hitForced = 0
        maxDepth = 1
        For y = 0 To 9
            If (y And 1) Then xs = 0 Else xs = 1 'skip yellow squares
            For x = xs To 9 Step 2
                If bPtr[x*10+y].occupied = turnColour Then
                    cmsPtr[0].x = x 'start position disc
                    cmsPtr[0].y = y 'start position disc
                    findNormalMoves(moveCtr, hitColour, bPtr, mdlPtr, mslPtr, cmsPtr)
                End If
            Next
        Next
    End If

    If (hitForced = 1) Then
        moveCtr = filterHitMoves(moveCtr, maxDepth, bPtr, mdlPtr, mslPtr)
    End If

End Sub

'-----------------------------------------------

Sub createHitList(Byref moveCtr As Integer, Byref maxDepth As Integer,_
    turnColour As Integer, bPtr As boardType Ptr, mdlPtr As Integer Ptr, mslPtr As moveType Ptr)

    Dim As Integer x, y, xs
    Dim As Integer hitColour, discType
    Dim As moveType curMoveSeq(MAX_DEPTH-1) 'current move sequence
    Dim cmsPtr As moveType Ptr

    moveCtr = 0
    maxDepth = 0
    cmsPtr = @curMoveSeq(0)
    hitColour = enemyColour(turnColour)

    'search for forced moves
    For y = 0 To 9
        If (y And 1) Then xs = 0 Else xs = 1 'skip yellow squares
        For x = xs To 9 Step 2
            If bPtr[x*10+y].occupied = turnColour Then
                cmsPtr[0].x = x 'start position disc
                cmsPtr[0].y = y 'start position disc
                discType = bPtr[x*10+y].discType
                findForcedMoves(moveCtr, maxDepth, 0, hitColour, discType, bPtr, mdlPtr, mslPtr, cmsPtr)
            End If
        Next
    Next

End Sub

'-----------------------------------------------

Sub findForcedMoves(Byref moveCtr As Integer, Byref maxDepth As Integer,_
    depth As Integer, hitColour As Integer, discType As Integer, bPtr As boardType Ptr,_
    mdlPtr As Integer Ptr, mslPtr As moveType Ptr, cmsPtr As moveType Ptr)
    'Todo: change xCur, yCur to curPos.x, curPos.y, etc.

    Dim As moveType pCur, pHit, pNew 'current, hit & new position
    Dim As Integer xi, yi, i, enemyFound
    Static As Integer boardHit(9,9)

    pCur = cmsPtr[depth]
    'if (depth=0) then erase boardHit
    depth+=1

    If discType = isPiece Then

        For xi = -1 To +1 Step 2
            For yi = -1 To +1 Step 2
                pHit.x = pCur.x - xi
                pHit.y = pCur.y - yi
                pNew.x = pCur.x - xi*2
                pNew.y = pCur.y - yi*2:
                If (pNew.x<10) And (pNew.x>=0) And (pNew.y>=0) And (pNew.y<10) Then
                    If (bPtr[pNew.x*10+pNew.y].occupied=isEmpty) Then
                        If bPtr[pHit.x*10+pHit.y].occupied=hitColour And boardHit(pHit.x,pHit.y)=0 Then
                            If depth > maxDepth Then maxDepth = depth 'one level deeper
                            cmsPtr[depth] = pNew
                            mdlPtr[moveCtr] = depth
                            For i = 0 To depth
                                mslPtr[moveCtr*MAX_DEPTH+i] = cmsPtr[i] 'store current move sequence
                            Next
                            moveCtr+=1
                            boardHit(pHit.x,pHit.y)=1 'mark jumped
                            findForcedMoves(moveCtr, maxDepth, depth, hitColour, discType, bPtr, mdlPtr, mslPtr, cmsPtr)
                            boardHit(pHit.x,pHit.y)=0 'unmark jumped
                        End If
                    End If
                End If
            Next
        Next

    Elseif discType = isKing Then

        For xi = -1 To +1 Step 2
            For yi = -1 To +1 Step 2
                pNew.x = pCur.x + xi
                pNew.y = pCur.y + yi
                enemyFound = 0

                'look for enemy
                While (pNew.x<10) And (pNew.x>=0) And (pNew.y>=0) And (pNew.y<10)
                    If (bPtr[pNew.x*10+pNew.y].occupied <> isEmpty) Then 'white or black
                        If (bPtr[pNew.x*10+pNew.y].occupied = hitColour) And (boardHit(pNew.x,pNew.y) = 0) Then
                            enemyFound = 1
                            pHit = pNew
                        End If
                        Exit While
                    End If
                    pNew.x += xi
                    pNew.y += yi
                Wend

                'look for empty places after enemy
                If (enemyFound = 1) Then
                    pNew.x += xi
                    pNew.y += yi
                    While (pNew.x<10) And (pNew.x>=0) And (pNew.y>=0) And (pNew.y<10)
                        If (bPtr[pNew.x*10+pNew.y].occupied = isEmpty) Then

                            If depth > maxDepth Then maxDepth = depth 'one level deeper
                            cmsPtr[depth] = pNew
                            mdlPtr[moveCtr] = depth
                            For i = 0 To depth
                                mslPtr[moveCtr*MAX_DEPTH+i] = cmsPtr[i] 'store current move sequence
                            Next
                            moveCtr+=1
                            boardHit(pHit.x,pHit.y)=1 'mark jumped
                            findForcedMoves(moveCtr, maxDepth, depth, hitColour, discType, bPtr, mdlPtr, mslPtr, cmsPtr)
                            boardHit(pHit.x,pHit.y)=0 'unmark jumped

                        Else
                            Exit While
                        End If
                        pNew.x += xi
                        pNew.y += yi
                    Wend
                End If

            Next
        Next

    Else
        Print "Error: findForcedMoves": Sleep 100
    End If

    depth-=1
End Sub

'-----------------------------------------------

Sub findNormalMoves(Byref moveCtr As Integer, hitColour As Integer,_
    bPtr As boardType Ptr, mdlPtr As Integer Ptr, mslPtr As moveType Ptr,_
    cmsPtr As moveType Ptr)

    'Todo: change xCur, yCur to curPos.x, curPos.y, etc.
    Dim As moveType pCur, pNew  'current & new position
    Dim As Integer xi, yi, i, pitch  'move increment

    pCur = cmsPtr[0]
    'Deze twee Piece/King kunnen (in principe) samen gevoegd worden.
    If bPtr[pCur.x*10+pCur.y].discType = isPiece Then
        If hitColour = isBlack Then yi = +1
        If hitColour = isWhite Then yi = -1
        For xi = -1 To +1 Step 2
            pNew.x = pCur.x-xi
            pNew.y = pCur.y-yi
            If (pNew.x<10) And (pNew.x>=0) And (pNew.y>=0) And (pNew.y<10) Then
                If (bPtr[pNew.x*10+pNew.y].occupied=isEmpty) Then
                    mdlPtr[moveCtr] = 1
                    pitch = moveCtr * MAX_DEPTH
                    mslPtr[pitch] = pCur
                    mslPtr[pitch+1] = pNew
                    moveCtr+=1
                End If
            End If
        Next
    Elseif bPtr[pCur.x*10+pCur.y].discType = isKing Then
        For xi = -1 To +1 Step 2
            For yi = -1 To +1 Step 2
                pNew.x = pCur.x + xi
                pNew.y = pCur.y + yi
                While (pNew.x<10) And (pNew.x>=0) And (pNew.y>=0) And (pNew.y<10)
                    If (bPtr[pNew.x*10+pNew.y].occupied = isEmpty) Then
                        mdlPtr[moveCtr] = 1
                        pitch = moveCtr * MAX_DEPTH
                        mslPtr[pitch] = pCur
                        mslPtr[pitch+1] = pNew
                        moveCtr+=1
                    Else
                        Exit While 'Oject encountered
                    End If
                    pNew.x += xi
                    pNew.y += yi
                Wend
            Next
        Next
    Else
        Print "Error: findNormalMoves": Sleep 100
    End If

End Sub

'-----------------------------------------------

Function searchMove(p0 As moveType, p1 As moveType, moveDepth As Integer,_
    moveCtr As Integer, mdlPtr As Integer Ptr, mslPtr As moveType Ptr) As Integer

    Dim As Integer i, moveFound, pitch
    moveFound = 0
    'Search for move in list: moveFound
    For i = 0 To moveCtr-1
        pitch = i * MAX_DEPTH
        If mdlPtr[i] > moveDepth Then
            'May this disc (x0,y0) move to (x1,y1) ?
            If p0.x = mslPtr[pitch+moveDepth].x And p0.y = mslPtr[pitch+moveDepth].y Then
                If p1.x = mslPtr[pitch+moveDepth+1].x And p1.y = mslPtr[pitch+moveDepth+1].y Then
                    moveFound = 1
                    Exit For
                End If
            End If
        End If
    Next
    Return moveFound
End Function

'-----------------------------------------------

Function evalBoard(bPtr As boardType Ptr, turnColour As Integer) As Integer
    Dim As Integer x, y, xs, score, hitColour
    Dim As Integer moveCtr, maxDepth

    hitColour = enemyColour(turnColour)
    score = intrnd(19)-9 'Choice between: -9...+9
    ' if bPtr[x*10+y].occupied = turnColour then
    '  cmsPtr[0].x = x 'start position disc
    '  cmsPtr[0].y = y 'start position disc
    '  discType = bPtr[x*10+y].discType
    '  findForcedMoves(moveCtr, maxDepth, 0, hitColour, discType, bPtr, mdlPtr, mslPtr, cmsPtr)
    ' end if

    For y = 0 To 9
        If (y And 1) Then xs = 0 Else xs = 10 'skip yellow squares
        For x = xs To 90 Step 20
            If bPtr[x+y].occupied = turnColour Then
                If bPtr[x+y].discType = isPiece Then
                    score+=30
                    If (x=0) Or (x=90) Or (y=0) Or (y=9) Then score+=10
                Else
                    score+=70
                    If (y=9) And (turnColour=isWhite) Then score+=10
                    If (y=0) And (turnColour=isBlack) Then score+=10
                End If
            Elseif bPtr[x+y].occupied = hitColour Then
                If bPtr[x+y].discType = isPiece Then
                    score-=30
                    If (x=0) Or (x=90) Or (y=0) Or (y=9) Then score-=10
                Else
                    score-=70
                    If (y=0) And (hitColour=isWhite) Then score-=10
                    If (y=9) And (hitColour=isBlack) Then score-=10
                End If
            Else
                'empty
            End If
        Next
    Next

    Return score
End Function

'-----------------------------------------------

Sub copyBoard(bSrcPtr As boardType Ptr, bDstPtr As boardType Ptr)
    'Quick and dirty!
    Dim As boardPtrType Ptr scrPtr, dstPtr
    scrPtr = Cptr(boardPtrType Ptr, bSrcPtr)
    dstPtr = Cptr(boardPtrType Ptr, bDstPtr)
    *dstPtr = *scrPtr
End Sub

'-----------------------------------------------

Sub saveBoard(bPtr As boardType Ptr)
    Dim As Integer filePtr
    Dim As boardPtrType Ptr bufferPtr
    bufferPtr = Cptr(boardPtrType Ptr, bPtr)
    filePtr = Freefile
    Open "board.bin" For Binary As #filePtr
    Put #filePtr, , bufferPtr[0]
    Close #filePtr
    Locate 20,41: Print "board --> board.bin";
    Sleep 500
End Sub

'-----------------------------------------------

Sub loadBoard(bPtr As boardType Ptr)
    Dim As Integer filePtr
    Dim As Byte Ptr bufferPtr
    bufferPtr = Cptr(Byte Ptr, bPtr)
    filePtr = Freefile
    Open "board.bin" For Binary As #filePtr
    Get #filePtr, ,bufferPtr[0], Sizeof(boardPtrType)
    Close #filePtr
End Sub

'-----------------------------------------------

Function enemyColour(colour As Integer) As Integer
    If colour = isWhite Then
        Return isBlack
    Elseif colour = isBlack Then
        Return isWhite
    Else
        Return -1
    End If
End Function

'-----------------------------------------------

Function findBestMove(bPtr As boardType Ptr, moveColour As Integer,_
    evalColour As Integer, mdlPtr As Integer Ptr, mslPtr As moveType Ptr,_
    searchDepth As Integer) As Integer

    Dim As boardType Ptr tempBoardPtr
    Dim As moveType Ptr tempMslPtr
    Dim As moveType Ptr dummyMsPtr
    Dim As Integer Ptr tempMdlPtr
    Dim As Integer dummyMoveDepth, DummyMaxDepth
    Dim As Integer bestMoveScore, bestMoveIndex, moveScore
    Dim As Integer i, moveCtr, hitColour

    hitColour = enemyColour(moveColour)
    searchDepth+=1
    tempMdlPtr = @global(searchDepth).mdl(0)
    tempMslPtr = @global(searchDepth).msl(0,0)
    tempBoardPtr = @global(searchDepth).board(0,0)
    dummyMsPtr = @global(searchDepth).dummyMoveSeq(0)

    If (searchDepth > maxSearchDepth And searchDepth <= hitSearchDepth) Then
        createHitList(moveCtr, dummyMoveDepth, moveColour, bPtr, tempMdlPtr, tempMslPtr)
    End If

    If ((searchDepth <= maxSearchDepth) Or (moveCtr<>0)) Then

        If ((searchDepth And 1) = 1) Then bestMoveScore = -999 Else bestMoveScore = 999
        bestMoveIndex = -1
        createMoveList(moveCtr, dummyMoveDepth, moveColour, bPtr, tempMdlPtr, tempMslPtr)

        If (moveCtr <> 0) Then

            For i = 0 To moveCtr-1

                copyBoard(bPtr, tempBoardPtr)
                doFullMove(tempMslPtr+i*MAX_DEPTH, tempMdlPtr[i], tempBoardPtr, noAnimate)
                moveScore = findBestMove(tempBoardPtr, hitColour, evalColour, @dummyMoveDepth, dummyMsPtr, searchDepth)

                If ((searchDepth And 1) = 1) Then 'even
                    If (moveScore > bestMoveScore) Then
                        bestMoveScore = moveScore
                        bestMoveIndex = i
                    End If
                Else
                    If (moveScore < bestMoveScore) Then
                        bestMoveScore = moveScore
                        bestMoveIndex = i
                    End If
                End If

                If (searchDepth = 1) Then
                    If (i < moveCtr-1) Then
                        Locate 37,2: Print Using "Searching: ## % ";(i*100)\(moveCtr-1);
                    Else
                        Locate 37,2: Print "Searching: Ready";
                    End If
                End If

            Next
            *mdlPtr = tempMdlPtr[bestMoveIndex]
            For i = 0 To *mdlPtr
                mslPtr[i] = tempMslPtr[bestMoveIndex*MAX_DEPTH+i]
            Next

        Else

            If (moveColour = evalColour) Then
                If (searchDepth = 1) Then
                    endOfGame = 1 'no move to start with...
                Else
                    bestMoveScore = -900 'E.g.: white plays & white can not move: bad thing
                End If
            Else
                bestMoveScore = +900 'E.g.: white plays & black can not move: good thing
            End If

        End If

    Else
        bestMoveScore = evalBoard(bPtr, evalColour)
    End If

    Return bestMoveScore
End Function

'-----------------------------------------------

Онлайн версия игры здесь