'===========================================================================
' Subject: PB CHESS GAME 06/99               Date: 06-21-99 (13:45)       
' Author:  Alexander Podkolzin               Code: PB                     
' Origin:  APP@nw.sbank.e-burg.su          Packet: DEMOS.ABC
'===========================================================================
'---------------------------------------------------------------------------
' This project is not finished (some "axception" moves and main EVALUATE
' ("thinking") function), as I'm lazy and work under it about one half an
' hour a week. I'm sending this stuff to ABC-archives because I've promiced
' it to you friends. Maybe in the future I'll return to it...
' So, SEE YOU LATER!!
'
' Copyright status - FREEWARE.
'---------------------------------------------------------------------------
' IMPORTANT NOTES:
'
' A. Any move is represented by one byte variable:
'    bits 7 - 4 for X-coordinate, bits 3 - 0 for Y-coordinate.
'    For instance, coordinates of a piece E1 (white king) are represented
'    by &H51 (01010001). I think it's very handy (e.g. see procedures/
'    functions "fPack", "UnPack").
'
' B. Lists of moves format.
'
'    All lists are strings, but I avoid to use (as far as it's possible)
'    any string procedures/functions in the program, as they are slow.
'    ASC/ASCII, are about 5 times faster then MID$ and at last using
'    pointers we achive speed about 20 times faster then MID$.
'    Example:
'    mList is a string, but we count it as an array of bytes, then
'    mList(1) contains number of moves (or zero) for a piece,
'    mList(2) contains coordinates of a piece having been moved,
'    elements from mList(3) to 29 contain all possible moves
'    (or zeros) for that piece.
'    All lists of moves in the program have the same structure or
'    consist of such structures.
'
' C. Lists of pieces format.
'    pList(1) contains number of pieces in the list,
'    elements from pList(2) to 17 contain coordinates of pieces.
'
'---------------------------------------------------------------------------
 $DIM ALL
 $LIB GRAPH
 $COMPILE MEMORY
' $COMPILE EXE
 $DYNAMIC
'---------------------------------------------------------------------------
 %FLAGS = 0: %AX = 1: %BX = 2: %CX = 3: %DX = 4
 %SI    = 5: %DI = 6: %BP = 7: %DS = 8: %ES = 9

 %True = -1
 %False = 0

 %Debug = %True
 %ESC_key = &H001B
 %Mouse_Click_Left = 1
 %Mouse_Click_Right = 2
 %Mark = 1
 %Unmark = 0
 %Opposite = -1
 %Own = 1
 %Absent = 0
 %OutOfBoard = 99

 %Pawn = 1
 %Knight = 2
 %Bishop = 3
 %Rook = 4
 %Queen = 5
 %King = 6

 %WhiteSide = 0
 %BlackSide = 1

 %White = 1
 %Black = -1

 %LegalMoves = 0
 %CaptureFields = 1
'---------------------------------------------------------------------------
 Type PieceInfo

   TotalMoves As Integer               'Total moves for the piece X,Y
   Moves As String * 29                'List of possible moves
   Attacked As Integer                 'Attacked (total number)
   Defended As Integer                 'Defended (total number)
   Attackers As String * 17            'List of attackers (coordinates)
   Defenders As String * 17            'List of defenders (coordinates)
   AttWeight As Integer                'Total weight of attackers
   DefWeight As Integer                'Total weight of defenders

 End Type
'---------------------------------------------------------------------------
 Type Position

   WhiteMoves As String * 128          'List of possible moves
   BlackMoves As String * 128          'List of possible moves
   WhiteKingAt As Byte                 'Coordinates
   BlackKingAt As Byte                 'Coordinates
   WhiteKingUnderCheck As Integer      'True/False
   BlackKingUnderCheck As Integer      'True/False
   WhiteKingCastlings As String * 4    'List of possible castlings
   BlackKingCastlings As String * 4    'List of possible castlings
   XY_PieceList As String * 29         'List of moves for an X,Y piece

 End Type
'---------------------------------------------------------------------------
'Procedures declarations list of CH.BAS :
'
 Declare Function MsThere()  As Integer
 Declare Function fAllPossibleMoves( _
         ChBoard() As Integer, _
         Byval Owner As Integer, _
         Byval TypeOfMoves As Integer _
         ) As String
 Declare Function fColorOfBox( _
         Byval X As Integer, _
         Byval Y As Integer _
         ) As Integer
 Declare Function fColorOfPiece( _
         Byval X As Integer, _
         Byval Y As Integer _
         ) As Integer
 Declare Function fFindKing( _
         ChBoard() As Integer, _
         Byval WhichKing As Integer _
         ) As Byte
 Declare Function fGetKey( _
         Col As Integer, _
         Row As Integer _
         ) As Integer
 Declare Function fHumanPiece( _
         Byval X As Integer, _
         Byval Y As Integer _
         ) As Integer
 Declare Function fInBoard( _
         Byval X As Integer, _
         Byval Y As Integer _
         ) As Integer
 Declare Function fLegalMove( _
         ChBoard() As Integer, _
         Byval FromX As Integer, _
         Byval FromY As Integer, _
         Byval ToX As Integer, _
         Byval ToY As Integer, _
         ListOfMoves As String _
         ) As Integer
 Declare Function fPack( _
         Byval X As Integer, _
         Byval Y As Integer _
         ) As Byte
 Declare Function fPiece( _
         ChBoard() As Integer, _
         Byval X As Integer, _
         Byval Y As Integer, _
         Byval xl As Integer, _
         Byval yl As Integer _
         ) As Integer
 Declare Function fPieceName( _
         Byval X As Integer, _
         Byval Y As Integer _
         ) As String
 Declare Sub DoMove( _
         Byval X1 As Integer, _
         Byval Y1 As Integer, _
         Byval X2 As Integer, _
         Byval Y2 As Integer _
         )
 Declare Sub ErrMessage( _
         Byval Mess As String _
         )
 Declare Sub GenMoves( _
         ChBoard() As Integer, _
         Byval X As Integer, _
         Byval Y As Integer, _
         ListOfMoves As String, _
         Byval What As Integer _
         )
 Declare Sub GetFieldInfo( _
         ChBoard() As Integer, _
         Byval X As Integer, _
         Byval Y As Integer, _
         Info As PieceInfo, _
         Byval Mover As Integer _
         )
 Declare Sub GetPosition( _
         ChBoard() As Integer, _
         Byval X As Integer, _
         Byval Y As Integer, _
         PosInfo As Position _
         )
 Declare Sub GetScrXY( _
         Byval X As Integer, _
         Byval Y As Integer, _
         sX As Integer, _
         sY As Integer _
         )
 Declare Sub InitGame()
 Declare Sub MarkIt( _
         Byval X As Integer, _
         Byval Y As Integer, _
         Byval State As Integer _
         )
 Declare Sub MkBoard()
 Declare Sub MkField( _
         Byval X As Integer, _
         Byval Y As Integer, _
         Byval C As Integer _
         )
 Declare Sub MsCursorOff()
 Declare Sub MsCursorOn()
 Declare Sub MsLocate( _
         Byval Row As Integer, _
         Byval Column As Integer _
         )
 Declare Sub MsSetWindow( _
         Byval Row As Integer, _
         Byval Col As Integer, _
         Byval Rows As Integer, _
         Byval Cols As Integer _
         )
 Declare Sub MsStatus( _
         Button As Integer, _
         Row As Integer, _
         Column As Integer _
         )
 Declare Sub PrepareGame()
 Declare Sub Show( _
         Byval Num As Integer, _
         Byval Xx As Integer, _
         Byval Yy As Integer, _
         Byval Colr As Integer _
         )
 Declare Sub ShowList( _
         Byval ListOfMoves As String _
         )
 Declare Sub UnPack( _
         Byval Move As Byte, _
         X As Integer, _
         Y As Integer _
         )
'---------------------------------------------------------------------------
 Dim ChessBoard(8, 8) As Shared Integer
 Dim Piece(%Pawn To %King) As Shared String
 Dim WhiteBox As Shared Integer
 Dim BlackBox As Shared Integer
 Dim WhiteC As Shared Integer
 Dim BlackC As Shared Integer
 Dim HumanPiece As Shared Integer
 Dim ComputerPiece As Shared Integer
 Dim HumanSide As Shared Integer
 Dim HumanMovesFirst As Shared Integer
 Dim CurX As Shared Integer
 Dim CurY As Shared Integer
 Dim OldX As Shared Integer
 Dim OldY As Shared Integer
 Dim MarkerColor As Shared Integer
 Dim i As Integer
 Dim MouseX As Integer
 Dim MouseY As Integer
 Dim ReadyToMove As Shared Integer
 Dim mList As String
 Dim Pinfo As PieceInfo
 Dim PosInfo As Position
 Dim PosInfo0 As Position

 Dim WhiteKingMoved As Shared Integer
 Dim BlackKingMoved As Shared Integer
 Dim RookA1Moved As Shared Integer
 Dim RookH1Moved As Shared Integer
 Dim RookA8Moved As Shared Integer
 Dim RookH8Moved As Shared Integer
 Dim WhiteLongCastlingPossible As Shared Integer
 Dim WhiteShortCastlingPossible As Shared Integer
 Dim BlackLongCastlingPossible As Shared Integer
 Dim BlackShortCastlingPossible As Shared Integer

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

 If Not MsThere() Then
   Print "Mouse not presents!"
   End
 End If

 On Timer(1) Gosub ShowTime                           'Every second

 InitGame

 Do
   PosInfo = PosInfo0                                 'Clear position info
   GetPosition ChessBoard(), 1, 1, PosInfo
   If HumanMovesFirst Then
     Gosub HumanMove
     Gosub ComputerMove
   Else
     Gosub ComputerMove
     Gosub HumanMove
   End If
 Loop

 Finish:
 Cls
 Screen 0,0,0,0
 End
'---------------------------------------------------------------------------
 HumanMove:
 Color 10
 Locate 1, 54
 Print "YOUR MOVE    "
 Do
   i = fGetKey(MouseX, MouseY)
   Select Case i
   Case %Mouse_Click_Left
     CurX = MouseX : CurY = MouseY                    '
     If ReadyToMove Then                              'Marked field
       If (OldX = CurX) And (OldY = CurY) Then        'At the same place
         ReadyToMove = %False                         '
         OldX = 0: OldY = 0                           '
         MarkIt CurX, CurY, %Unmark                   'Remove marker
         Exit Select                                  '
       Else                                           'Another place
         If fLegalMove(ChessBoard(), _                '
                       OldX, OldY, _                  '
                       CurX, CurY, mList) Then        '
                                                      '
           DoMove OldX, OldY, CurX, CurY              'Replace piece
           MarkIt OldX, OldY, %Unmark                 'Remove marker
           ReadyToMove = %False                       '
                                                      '
           RETURN                                     'Move is done!
                                                      '
         Else                                         'Illegal move
           ErrMessage "         Illegal move!"        '
           Iterate Loop                               '
         End If                                       '
       End If                                         '
     End If                                           '
     If ChessBoard(CurX, CurY) = 0 Then               'Can not mark
       Exit Select                                    'empty field
     End If                                           '
     If Not fHumanPiece(CurX, CurY) Then              'Can not mark
       Exit Select                                    'computer's piece
     End If                                           '
     ReadyToMove = %True                              '
     OldX = CurX: OldY = CurY                         '
     MarkIt CurX, CurY, %Mark                         'Make marker
     GetPosition ChessBoard(), CurX, CurY, PosInfo    '
     mList = PosInfo.XY_PieceList                     '
     ShowList mList                                   '
   Case %ESC_key, %Mouse_Click_Right                  'Exit program
     Goto Finish                                      '
   End Select
 Loop
 Return
'---------------------------------------------------------------------------
 ComputerMove:
 Color 10
 Locate 1, 54
 Print "COMPUTER MOVE"
 Timer On
'=======================================
' "Mirror" moves for debugging:

  DoMove OldX, 9 - OldY, CurX, 9 - CurY

'=======================================
 Timer Off
 Return
'---------------------------------------------------------------------------
 ShowTime:
 Color 14
 Locate 1, 70: Print Time$
 Return
'---------------------------------------------------------------------------
 Sub GetPosition(ChBoard() As Integer, _
                 Byval X As Integer, _
                 Byval Y As Integer, _
                 PosInfo As Position)

   Dim s As String
   Dim n As Integer

   PosInfo.WhiteMoves = fAllPossibleMoves(ChBoard(), %White, %LegalMoves)
   PosInfo.BlackMoves = fAllPossibleMoves(ChBoard(), %Black, %LegalMoves)
   PosInfo.WhiteKingAt = fFindKing(ChBoard(), %White)
   PosInfo.BlackKingAt = fFindKing(ChBoard(), %Black)

   PosInfo.WhiteKingUnderCheck = (Instr(PosInfo.BlackMoves, _
                                  Chr$(PosInfo.WhiteKingAt)) <> 0)
   PosInfo.BlackKingUnderCheck = (Instr(PosInfo.WhiteMoves, _
                                  Chr$(PosInfo.BlackKingAt)) <> 0)
   GenMoves ChBoard(), X, Y, s, %LegalMoves

   PosInfo.XY_PieceList = s
   '
   'Test castlings:
   '
   n = 0
   If (Not PosInfo.WhiteKingUnderCheck)  And (Not WhiteKingMoved) Then
     '
     'White long castling
     '
     If Not RookA1Moved Then
       If ChBoard(2, 1) + ChBoard(3, 1) + ChBoard(4, 1) = 0 Then
         If Instr(PosInfo.BlackMoves, Any Chr$(&H21, &H31, &H41)) = 0 Then
           Incr n
           Asc(PosInfo.WhiteKingCastlings, n + 2) = &H31
         End If
       End If
     End If
     '
     'White short castling
     '
     If Not RookH1Moved Then
       If ChBoard(6, 1) + ChBoard(7, 1) = 0 Then
         If Instr(PosInfo.BlackMoves, Any Chr$(&H61, &H71)) = 0 Then
           Incr n
           Asc(PosInfo.WhiteKingCastlings, n + 2) = &H71
         End If
       End If
     End If
     Asc(PosInfo.WhiteKingCastlings, 1) = n
     Asc(PosInfo.WhiteKingCastlings, 2) = PosInfo.WhiteKingAt
   End If

   n = 0
   If (Not PosInfo.BlackKingUnderCheck)  And (Not BlackKingMoved) Then
     '
     'Black long castling
     '
     If Not RookA8Moved Then
       If ChBoard(2, 8) + ChBoard(3, 8) + ChBoard(4, 8) = 0 Then
         If Instr(PosInfo.WhiteMoves, Any Chr$(&H28, &H38, &H48)) = 0 Then
           Incr n
           Asc(PosInfo.BlackKingCastlings, n + 2) = &H38
         End If
       End If
     End If
     '
     'Black short castling
     '
     If Not RookH8Moved Then
       If ChBoard(6, 8) + ChBoard(7, 8) = 0 Then
         If Instr(PosInfo.WhiteMoves, Any Chr$(&H68, &H78)) = 0 Then
           Incr n
           Asc(PosInfo.BlackKingCastlings, n + 2) = &H78
         End If
       End If
     End If
     Asc(PosInfo.BlackKingCastlings, 1) = n
     Asc(PosInfo.BlackKingCastlings, 2) = PosInfo.BlackKingAt
   End If

$IF %Debug

   Color 14, 0
   Locate 3, 54
   If PosInfo.WhiteKingUnderCheck Then
     ? "White king under check!"
   Else
     ? "                       "
   End If
   Locate 4, 54
   If PosInfo.BlackKingUnderCheck Then
     ? "Black king under check!"
   Else
     ? "                       "
   End If
   Color 2
   Locate 5, 54
   If Ascii(PosInfo.WhiteKingCastlings, 1) <> 0 Then
     ? "White castling possible."
   Else
     ? "                        "
   End If
   Locate 6, 54
   If Ascii(PosInfo.BlackKingCastlings, 1) <> 0 Then
     ? "Black castling possible."
   Else
     ? "                        "
   End If

$ENDIF

 End Sub
'---------------------------------------------------------------------------
' This procedure is reserved for future needs...
'
 Sub GetFieldInfo(ChBoard() As Integer, _
                  Byval X As Integer, _
                  Byval Y As Integer, _
                  Info As PieceInfo, _
                  Byval Mover As Integer)

   Dim s As String
   Dim i as Integer
   Dim k as Integer
   Dim l as Integer
   Dim m as Integer
   Dim n as Integer
   Dim Temp As Integer

   GenMoves ChBoard(), X, Y, s, %LegalMoves
   Info.Moves = s
   Info.TotalMoves = Asc(s, 1)
   '
   '  Temporary change, for defenders counting
   '
   Temp = ChBoard(X, Y)
   If Mover > 0 Then
     ChBoard(X, Y) = - %Pawn                          'If white move
   Else
     ChBoard(X, Y) = + %Pawn                          'If black move
   End If
   s = fAllPossibleMoves(ChBoard(), Mover, %CaptureFields)
   ChBoard(X, Y) = Temp                               'Restore change
   '
   '  Selecting all pieces-defenders for the field X,Y:
   '
   k = 1
   l = 2
   m = fPack(X, Y)
   Do While k <= Len(s)
     n = Asc(s, k)
     For i = k + 2 To k + 2 + n - 1
       If Asc(s, i) = m Then
         Asc(Info.Defenders, l) = Asc(s, k + 1)       'Update defenders list
         Incr l
       End If
     Next
     Incr k, n + 2
   Loop
   Decr l, 2
   Asc(Info.Defenders, 1) = l                         'Length of list
   Info.Defended = l                                  'Number of defenders
   s = fAllPossibleMoves(ChBoard(), -Mover, %LegalMoves) '-Mover for enemy
   '
   '  Selecting all pieces-attackers for the field X,Y:
   '
   k = 1
   l = 2
   m = fPack(X, Y)
   Do While k <= Len(s)
     n = Asc(s, k)
     For i = k + 2 To k + 2 + n - 1
       If Asc(s, i) = m Then
         Asc(Info.Attackers, l) = Asc(s, k + 1)       'Update attackers list
         Incr l
       End If
     Next
     Incr k, n + 2
   Loop
   Decr l, 2
   Asc(Info.Attackers, 1) = l                         'Length of list
   Info.Attacked = l                                  'Number of attackers

   Info.DefWeight = 0
   For i = 1 To Asc(Info.Defenders, 1)
     UnPack Asc(Info.Defenders, i + 1), m, n
     Incr Info.DefWeight, Abs(ChBoard(m, n))          'Weight of defenders
   Next

   Info.AttWeight = 0
   For i = 1 To Asc(Info.Attackers, 1)
     UnPack Asc(Info.Attackers, i + 1), m, n
     Incr Info.DefWeight, Abs(ChBoard(m, n))          'Weight of attackers
   Next

 End Sub
'---------------------------------------------------------------------------
 Function fFindKing(ChBoard() As Integer, _
                    Byval WhichKing As Integer) As Byte

   Dim x As Integer
   Dim y As Integer

   For x = 1 To 8
     For y = 1 To 8
       If ChBoard(x, y) = WhichKing * %King Then
         Function = fPack(x, y) : Exit Function
       End If
     Next
   Next

 End Function
'---------------------------------------------------------------------------
 Function fPack(Byval X As Integer, Byval Y As Integer) As Byte

   ! mov cl, 4                   ;Assembler (need speed)
   ! mov ax, X
   ! shl ax, cl
   ! add ax, Y
   ! mov Function, al

$IF 0
   Shift Left X, 4               'BASIC
   Function = X + Y
$ENDIF

 End Function
'---------------------------------------------------------------------------
 Sub UnPack(Byval Move As Byte, X As Integer, Y As Integer)

   Y = Move And &HF              'BASIC, we do not need speed here...
   Shift Right Move, 4
   X = Move

 End Sub
'---------------------------------------------------------------------------
 Function fLegalMove(ChBoard() As Integer, _
                     Byval FromX As Integer, _
                     Byval FromY As Integer, _
                     Byval ToX As Integer, _
                     Byval ToY As Integer, _
                     ListOfMoves As String) As Integer

   Dim kInfo As PieceInfo
   Dim TempF As Integer
   Dim TempT As Integer
   Dim k As Byte
   Dim x As Integer
   Dim y As Integer

   TempF = ChBoard(FromX, FromY)
   TempT = ChBoard(ToX, ToY)
   ChBoard(FromX, FromY) = 0
   ChBoard(ToX, ToY) = TempF

   If Abs(TempF) = %King Then
     GetFieldInfo ChBoard(), ToX, ToY, kInfo, Sgn(TempF)
     If kInfo.Attacked Then
       Gosub RestoreBoard
       Function = %False
       Exit Function
     End If
   Else
     k = fFindKing(ChBoard(), Sgn(TempF))
     UnPack k, x, y
     GetFieldInfo ChBoard(), x, y, kInfo, Sgn(TempF)
     If kInfo.Attacked Then
       Gosub RestoreBoard
       Function = %False
       Exit Function
     End If
   End If

   Gosub RestoreBoard
   Function = (Instr(3, ListOfMoves, Chr$(fPack(ToX, ToY))) <> 0)
   Exit Function

   RestoreBoard:
   ChBoard(FromX, FromY) = TempF
   ChBoard(ToX, ToY) = TempT
   Return

 End Function
'---------------------------------------------------------------------------
'Generates "theoretically" possible moves for a piece.
 Sub GenMoves(ChBoard() As Integer, _
              Byval X As Integer, _
              Byval Y As Integer, _
              ListOfMoves As String, _
              Byval What As Integer)

   Dim It As Integer
   Dim n As Byte '''Integer
   Dim Sign As Integer
   Dim xl As Integer
   Dim yl As Integer
   Dim ListPtr As Byte Ptr
   Dim Work As Byte Ptr

   '
   '  Max moves for one piece is 27 (queen).
   '
   ListOfMoves = String$(29, 0)
   ListPtr = Strptr32(ListOfMoves)

   It = ChBoard(X, Y)
   If It > 0 Then
     Sign = +1
   Else
     Sign = -1
   End If

   n = 3
   Select Case Abs(It)
   Case %Pawn
     '
     '    Pawn moves:
     '
     If What = %LegalMoves Then
       xl = X: yl = Y + Sign
       If fPiece(ChBoard(), X, Y, xl, yl) = %Absent Then     'Up
         Gosub SetXY
         If Y = 7 Or Y = 2 Then
           yl = Y + Sign + Sign
           If fPiece(ChBoard(), X, Y, xl, yl) = %Absent Then 'Up
             Gosub SetXY
           End If
         End If
       End If
       '
       '      Pawn captures:
       '
       yl = Y + Sign: xl = X - 1
       If fPiece(ChBoard(), X, Y, xl, yl) = %Opposite Then   'Up and left
         Gosub SetXY
       End If
       xl = X + 1
       If fPiece(ChBoard(), X, Y, xl, yl) = %Opposite Then   'Up and right
         Gosub SetXY
       End If

     Elseif What = %CaptureFields Then
       '
       '      Pawn attacks/supports fields:
       '
       yl = Y + Sign: xl = X - 1
       Gosub SetXY                                           'Up and left
       xl = X + 1
       Gosub SetXY                                           'Up and right

     End If

   Case %Knight

     If fPiece(ChBoard(), X, Y, X+1, Y-2) <> %Own Then xl=X+1: yl=Y-2: Gosub SetXY
     If fPiece(ChBoard(), X, Y, X+2, Y-1) <> %Own Then xl=X+2: yl=Y-1: Gosub SetXY
     If fPiece(ChBoard(), X, Y, X+2, Y+1) <> %Own Then xl=X+2: yl=Y+1: Gosub SetXY
     If fPiece(ChBoard(), X, Y, X+1, Y+2) <> %Own Then xl=X+1: yl=Y+2: Gosub SetXY
     If fPiece(ChBoard(), X, Y, X-1, Y+2) <> %Own Then xl=X-1: yl=Y+2: Gosub SetXY
     If fPiece(ChBoard(), X, Y, X-2, Y+1) <> %Own Then xl=X-2: yl=Y+1: Gosub SetXY
     If fPiece(ChBoard(), X, Y, X-2, Y-1) <> %Own Then xl=X-2: yl=Y-1: Gosub SetXY
     If fPiece(ChBoard(), X, Y, X-1, Y-2) <> %Own Then xl=X-1: yl=Y-2: Gosub SetXY

   Case %Bishop
     Gosub CheckDiagonals

   Case %Rook
     Gosub CheckLines

   Case %Queen
     Gosub CheckLines
     Gosub CheckDiagonals

   Case %King
     xl = X: yl = Y - 1
     If fPiece(ChBoard(), X, Y, xl, yl) <> %Own Then Gosub SetXY

     xl = X - 1: yl = Y - 1
     If fPiece(ChBoard(), X, Y, xl, yl) <> %Own Then Gosub SetXY

     xl = X + 1: yl = Y - 1
     If fPiece(ChBoard(), X, Y, xl, yl) <> %Own Then Gosub SetXY

     xl = X - 1: yl = Y
     If fPiece(ChBoard(), X, Y, xl, yl) <> %Own Then Gosub SetXY

     xl = X + 1: yl = Y
     If fPiece(ChBoard(), X, Y, xl, yl) <> %Own Then Gosub SetXY

     xl = X - 1: yl = Y + 1
     If fPiece(ChBoard(), X, Y, xl, yl) <> %Own Then Gosub SetXY

     xl = X: yl = Y + 1
     If fPiece(ChBoard(), X, Y, xl, yl) <> %Own Then Gosub SetXY

     xl = X + 1: yl = Y + 1
     If fPiece(ChBoard(), X, Y, xl, yl) <> %Own Then Gosub SetXY

   End Select

   Work = ListPtr
   @Work = n - 3                                      'Number of moves
   Incr Work
   @Work = fPack(X, Y)                                'Moves from that field
   Exit Sub
   '
   '  Checking lines:
   '
   CheckLines:
   xl = X: yl = Y - 1
   Do While yl > 0                                    'Up
     If fPiece(ChBoard(), X, Y, xl, yl) = %Own Then Exit Loop
     Gosub SetXY
     If fPiece(ChBoard(), X, Y, xl, yl) = %Opposite Then Exit Loop
     Decr yl
   Loop

   xl = X - 1: yl = Y
   Do While xl > 0                                    'Left
     If fPiece(ChBoard(), X, Y, xl, yl) = %Own Then Exit Loop
     Gosub SetXY
     If fPiece(ChBoard(), X, Y, xl, yl) = %Opposite Then Exit Loop
     Decr xl
   Loop

   xl = X + 1: yl = Y
   Do While xl < 9                                    'Right
     If fPiece(ChBoard(), X, Y, xl, yl) = %Own Then Exit Loop
     Gosub SetXY
     If fPiece(ChBoard(), X, Y, xl, yl) = %Opposite Then Exit Loop
     Incr xl
   Loop

   xl = X: yl = Y + 1
   Do While yl < 9                                    'Down
     If fPiece(ChBoard(), X, Y, xl, yl) = %Own Then Exit Loop
     Gosub SetXY
     If fPiece(ChBoard(), X, Y, xl, yl) = %Opposite Then Exit Loop
     Incr yl
   Loop
   Return
   '
   '  Checking diagonals:
   '
   CheckDiagonals:
   xl = X - 1: yl = Y - 1
   Do While yl = > 1 And xl > 0                       'Up and left
     If fPiece(ChBoard(), X, Y, xl, yl) = %Own Then Exit Loop
     Gosub SetXY
     If fPiece(ChBoard(), X, Y, xl, yl) = %Opposite Then Exit Loop
     Decr xl
     Decr yl
   Loop

   xl = X + 1: yl = Y - 1
   Do While yl > 0 And xl < 9                         'Up and right
     If fPiece(ChBoard(), X, Y, xl, yl) = %Own Then Exit Loop
     Gosub SetXY
     If fPiece(ChBoard(), X, Y, xl, yl) = %Opposite Then Exit Loop
     Incr xl
     Decr yl
   Loop

   xl = X - 1: yl = Y + 1
   Do While yl < 9 And xl > 0                         'Down and left
     If fPiece(ChBoard(), X, Y, xl, yl) = %Own Then Exit Loop
     Gosub SetXY
     If fPiece(ChBoard(), X, Y, xl, yl) = %Opposite Then Exit Loop
     Decr xl
     Incr yl
   Loop

   xl = X + 1: yl = Y + 1
   Do While yl < 9 And xl < 9                         'Down and right
     If fPiece(ChBoard(), X, Y, xl, yl) = %Own Then Exit Loop
     Gosub SetXY
     If fPiece(ChBoard(), X, Y, xl, yl) = %Opposite Then Exit Loop
     Incr xl
     Incr yl
   Loop
   Return
   '
   '  Writting to list:
   '
   SetXY:
     If fInBoard(xl, yl) Then
       Work = ListPtr + n - 1
       @Work = fPack(xl, yl)
       Incr n
     End If
   Return

 End Sub
'---------------------------------------------------------------------------
 Function fAllPossibleMoves(ChBoard() As Integer, _
                            Byval Owner As Integer, _
                            Byval TypeOfMoves As Integer) As String
   Dim x As Integer
   Dim y As Integer
   Dim mL As String        'List of all posiible moves for Owner
   Dim Temp As String
'
'  Owner > 0 - white side,
'  Owner < 0 - black side.
'
   mL = ""
   For y = 1 To 8
     For x = 1 To 8
       If ChBoard(x, y) = 0 Then Iterate For
       If Sgn(ChBoard(x, y)) = Sgn(Owner) Then
         GenMoves ChBoard(), x, y, Temp, TypeOfMoves
         If Ascii(Temp, 1) <> 0 Then
           mL = mL + Rtrim$(Temp, Chr$(0))
         End If
       End If
     Next
   Next
   Function = mL

 End Function
'---------------------------------------------------------------------------
 Sub ErrMessage(Byval Mess As String)

   Locate 27, 28
   Print Mess
   Delay 1
   Locate 27, 28
   Print Space$(Len(Mess))

 End Sub
'---------------------------------------------------------------------------
 Sub ShowList(Byval ListOfMoves As String)

   Dim i As Integer
   Dim n As Integer
   Dim x As Integer
   Dim y As Integer
   Dim pn As String

   n = Ascii(ListOfMoves, 1)                          'Number of moves
   x = Ascii(ListOfMoves, 2)                          'X, Y
   UnPack x, x, y                                     'coordinates of a piece
   pn = fPieceName(x, y)                              'Piece name
   Color 2
   Locate 27, 1
   If n > 0 Then
     Print "List of moves "; Chr$(34); pn; Chr$(34);
   Else
     Print "No moves for the "; pn
     Exit Sub
   End If
   Color 10
   Locate 29, 1
   For i = 1 To n
     x = Ascii(ListOfMoves, i + 2)
     UnPack x, x, y
     Print Mid$("ABCDEFGH", x, 1); Ltrim$(Str$(y)); " ";
   Next
   Color 2
   Locate 28, 1
   Print "Length of list ="; Str$(n);

  End Sub
'---------------------------------------------------------------------------
 Function fPieceName(Byval X As Integer, Byval Y As Integer) As String

   Select Case Abs(ChessBoard(X, Y))
   Case %Pawn   : Function = "Pawn"
   Case %Knight : Function = "Knight"
   Case %Bishop : Function = "Bishop"
   Case %Rook   : Function = "Rook"
   Case %Queen  : Function = "Queen"
   Case %King   : Function = "King"
   End Select

 End Function
'---------------------------------------------------------------------------
 Function fPiece(ChBoard() As Integer, _
                 Byval X As Integer, _
                 Byval Y As Integer, _
                 Byval xl As Integer, _
                 Byval yl As Integer) As Integer

   If Not fInBoard(xl, yl) Then
     Function = %OutOfBoard
     Exit Function
   End If
   If ChBoard(xl, yl) = 0 Then
     Function = %Absent
   Elseif Sgn(ChBoard(X, Y))  = Sgn(ChBoard(xl, yl)) Then
     Function = %Own
   Else
     Function = %Opposite
   End If

 End Function
'---------------------------------------------------------------------------
 Function fInBoard(Byval X As Integer, Byval Y As Integer) As Integer

   Function = (X > 0) And (X < 9) And (Y > 0) And (Y < 9)

 End Function
'---------------------------------------------------------------------------
 Function fHumanPiece(Byval X As Integer, Byval Y As Integer) As Integer

   Function = (fColorOfPiece(X, Y) <> ComputerPiece)

 End Function
'---------------------------------------------------------------------------
 Function fColorOfPiece(Byval X As Integer, Byval Y As Integer) As Integer

   If ChessBoard(X, Y) < 0 Then
     Function = BlackC
   Elseif ChessBoard(X, Y) > 0 Then
     Function = WhiteC
   Else
     Function = 0
   End If

 End Function
'---------------------------------------------------------------------------
 Function fGetKey(Col As Integer, Row As Integer) As Integer

   Dim s As String
   Dim Button As Integer
   Dim x As Integer
   Dim y As Integer

   Do
     s = Inkey$
     MsStatus Button, y, x
     x = (x - 3) \ 48 + 1
     y = (y - 3) \ 48 + 1

     If HumanSide Then                                'Calculating
       Col = 9 - x : Row = y                          'chess board
     Else                                             'coordinates
       Col = x     : Row = 9 - y                      'of a piece
     End If                                           '

     Color 14
     Locate 1, 70: Print Time$
     Locate 27, 25
     Print Mid$("ABCDEFGH", Col, 1); Ltrim$(Str$(Row))

     If Button Then
       Function = Button
       Do
         MsStatus Button, y, x
       Loop Until Button = 0
       CurX = Col
       CurY = Row
       Exit Function
     End If
   Loop Until Len(s)
   Function = Cvi(s + Chr$(0))

 End Function
'---------------------------------------------------------------------------
 Sub DoMove(Byval X1 As Integer, _
            Byval Y1 As Integer, _
            Byval X2 As Integer, _
            Byval Y2 As Integer)

   Dim Man As Integer
   Dim cp As Integer
   Dim cba As Integer
   Dim cbb As Integer
   Dim k As Integer
   Dim i As Integer
   Dim x As Integer
   Dim y As Integer

   Man = ChessBoard(X1, Y1)

   Select Case Abs(Man)                               'Update castling info
   Case %King
     If Man > 0 Then
       WhiteKingMoved = %True
       WhiteLongCastlingPossible = %False
       WhiteShortCastlingPossible = %False
     Else
       BlackKingMoved = %True
       BlackLongCastlingPossible = %False
       BlackShortCastlingPossible = %False
     End If
   Case %Rook
     If Man > 0 Then
       If X1 = 1 Then
         RookA1Moved = %True
         WhiteLongCastlingPossible = %False
       End If
       If X1 = 8 Then
         RookH1Moved = %True
         WhiteShortCastlingPossible = %False
       End If
     Else
       If X1 = 1 Then
         RookA8Moved = %True
         BlackLongCastlingPossible = %False
       End If
       If X1 = 8 Then
         RookH8Moved = %True
         BlackShortCastlingPossible = %False
       End If
     End If
   End Select

   ChessBoard(X1, Y1) = 0
   ChessBoard(X2, Y2) = Man
   x = X2
   y = Y2

   If Man > 0 Then
     cp = WhiteC
   Elseif Man < 0 Then
     cp = BlackC
   Else
     Exit Sub
   End If

   cba = fColorOfBox(X1, Y1)
   cbb = fColorOfBox(X2, Y2)

   GetScrXY X1, Y1, X1, Y1
   GetScrXY X2, Y2, X2, Y2

   MsCursorOff
   k = (X1 - 1) * 48 + 3
   i = (Y1 - 1) * 48 + 3
   Line(k, i) - (k + 47, i + 47), cba, BF
   k = (X2 - 1) * 48 + 3
   i = (Y2 - 1) * 48 + 3
   Line(k, i) - (k + 47, i + 47), cbb, BF
   Show Abs(Man), x, y, cp
   MsCursorOn

 End Sub
'---------------------------------------------------------------------------
 Sub GetScrXY(Byval X As Integer, _
              Byval Y As Integer, _
              sX As Integer, _
              sY As Integer)

   If HumanSide Then
     sX = 9 - X : sY = Y
   Else
     sX = X     : sY = 9 - Y
   End If

 End Sub
'---------------------------------------------------------------------------
 Sub MarkIt(Byval X As Integer, Byval Y As Integer, Byval State As Integer)

   Dim k As Integer
   Dim i As Integer
   Dim c As Integer

   If State Then
     c = MarkerColor
   Else
     c = fColorOfBox(X, Y)
   End If

   GetScrXY X, Y, X, Y

   k = (X - 1) * 48 + 4
   i = (Y - 1) * 48 + 4

   MsCursorOff
   Color 2
   Locate 27, 1: Print Space$(240);
   Line(k, i) - (k + 45, i + 45), c, B
   Line(k + 1, i + 1) - (k + 44, i + 44), c, B
   MsCursorOn

 End Sub
'---------------------------------------------------------------------------
 Function fColorOfBox(Byval X As Integer, Byval Y As Integer) As Integer

   GetScrXY X, Y, X, Y
   If (X + Y) Mod 2 Then
     Function = BlackBox
   Else
     Function = WhiteBox
   End If

 End Function
'---------------------------------------------------------------------------
 Sub MkBoard()

   Dim X As Integer
   Dim Y As Integer
   Dim CBlack As Integer
   Dim CWhite As Integer

   CBlack = BlackBox
   CWhite = WhiteBox

   For X = 1 To 8
     For Y = 1 To 8
       Swap CBlack, CWhite
       MkField X, Y, CBlack
     Next
     Swap CBlack, CWhite
   Next

   Line (0, 0) - (389, 389), 2, B
   Line (1, 1) - (388, 388), 2, B

   Color 2
   Locate 26, 4
   If HumanSide Then
     Print "H     G     F     E     D     C     B     A"
     For Y = 1 To 8
       Locate 2 + (Y - 1) * 3, 51: Print Mid$("12345678", Y, 1)
     Next
   Else
     Print "A     B     C     D     E     F     G     H"
     For Y = 1 To 8
       Locate 2 + (Y - 1) * 3, 51: Print Mid$("12345678", 9 - Y, 1)
     Next
   End If
   Color 7

 End Sub
'---------------------------------------------------------------------------
 Sub PrepareGame()

   Dim i As Integer
   Dim k As Integer
   Dim c As Integer

   For i = 1 To 8
     ChessBoard(i, 2) = %Pawn
     ChessBoard(i, 7) = -%Pawn
   next

   ChessBoard(1, 1) = %Rook
   ChessBoard(8, 1) = %Rook
   ChessBoard(1, 8) = -%Rook
   ChessBoard(8, 8) = -%Rook
   ChessBoard(2, 1) = %Knight
   ChessBoard(7, 1) = %Knight
   ChessBoard(2, 8) = -%Knight
   ChessBoard(7, 8) = -%Knight
   ChessBoard(3, 1) = %Bishop
   ChessBoard(6, 1) = %Bishop
   ChessBoard(3, 8) = -%Bishop
   ChessBoard(6, 8) = -%Bishop

   If HumanSide Then
     ChessBoard(5, 1) = %Queen
     ChessBoard(5, 8) = -%Queen
     ChessBoard(4, 1) = %King
     ChessBoard(4, 8) = -%King
   Else
     ChessBoard(4, 1) = %Queen
     ChessBoard(4, 8) = -%Queen
     ChessBoard(5, 1) = %King
     ChessBoard(5, 8) = -%King
   End If

   For i = 1 To 8
     For k = 1 To 8
       If ChessBoard(i, k) > 0 Then
         c = WhiteC
       Elseif ChessBoard(i, k) < 0 Then
         c = BlackC
       Else
         Iterate For
       End If
       Show Abs(ChessBoard(i, k)), i, k, c
     Next
   Next

 End Sub
'---------------------------------------------------------------------------
 Sub MkField(Byval X As Integer, _
             Byval Y As Integer, _
             Byval C As Integer)

   Dim Xb As Integer
   Dim Yb As Integer
   Dim Xe As Integer
   Dim Ye As Integer

   Xb = 3 + (X - 1) * 48
   Yb = 3 + (Y - 1) * 48
   Xe = Xb + 47
   Ye = Yb + 47

   Line (Xb, Yb) - (Xe, Ye), C, BF

 End Sub
'---------------------------------------------------------------------------
 Sub Show(Byval Num As Integer, _
          Byval Xx As Integer, _
          Byval Yy As Integer, _
          Byval Colr As Integer)

   Dim x As Integer
   Dim y As Integer

   GetScrXY Xx, Yy, Xx, Yy

   x = (Xx - 1) * 48 + 10
   y = (Yy - 1) * 48 + 46

   Draw "C8BM" + Str$(x) + "," + Str$(y)
   Draw Piece(Num)
   '
   '  Drawing some additional stuff
   '
   Select Case Num
   Case %Knight
     Draw "C8BM" + Str$(x + 12) + "," + Str$(y - 31)
     Draw "URG"

   Case %Bishop
   Case %Rook
   Case %Queen
     Draw "C8BM" + Str$(x + 1) + "," + Str$(y - 24)
     Draw "UFL"
     Draw "C8BM" + Str$(x + 32) + "," + Str$(y - 24)
     Draw "UGR"
     Draw "C8BM" + Str$(x + 8) + "," + Str$(y - 29)
     Draw "HEFG"
     Draw "C8BM" + Str$(x + 25) + "," + Str$(y - 29)
     Draw "HEFG"
     Draw "C8BM" + Str$(x + 16) + "," + Str$(y - 33)
     Draw "HERFGL"

   Case %King
     Draw "C8BM" + Str$(x + 6) + "," + Str$(y - 21)
     Draw "UEHURFERDGFDLHGL"
     Draw "C8BM" + Str$(x + 23) + "," + Str$(y - 21)
     Draw "UEHURFERDGFDLHGL"
     Draw "C8BM" + Str$(x + 16) + "," + Str$(y - 32)
     Draw "HUERFDG"

   End Select

   If Num <> %Pawn Then
     Draw "C8BM" + Str$(x + 16) + "," + Str$(y - 10)
     Draw "U4L3UR3U4RD4R3DL3D4L"
   End If

   Draw "BM" + _                                      'Filling area
        Str$(x + 17) + "," + _
        Str$(y - 2) + "P" + _
        Str$(Colr) + ",8"

 End Sub
'---------------------------------------------------------------------------
 Function MsThere() Public As Integer

   Reg %AX, 0
   Call Interrupt &H33
   If Reg(%AX) Then
     Function = %True
   End If

 End Function
'---------------------------------------------------------------------------
 Sub MsCursorOn() Public

   Reg %AX, 1 : Call Interrupt &H33

 End Sub
'---------------------------------------------------------------------------
 Sub MsCursorOff() Public

   Reg %AX, 2 : Call Interrupt &H33

 End Sub
'---------------------------------------------------------------------------
 Sub MsStatus(Button As Integer, Row As Integer, Column As Integer) Public

   Reg %AX, 3 : Call Interrupt &H33
   Button = Reg(%BX) : Row = Reg(%DX) : Column = Reg(%CX)
   If (Pbvscrnmode = 7) Or (Pbvscrnmode = 0) Then
     Row = (Row \ 8) + 1
     Column = (Column \ 8) + 1
   End If

 End Sub
'---------------------------------------------------------------------------
 Sub MsLocate(Byval Row As Integer, Byval Column As Integer) Public

   If (Pbvscrnmode = 7) Or (Pbvscrnmode = 0) Then
     Row = (Row - 1) * 8
     Column = (Column - 1) * 8
   End If
   Reg %AX, 4 : Reg %CX, Column : Reg %DX, Row : Call Interrupt &H33

 End Sub
'---------------------------------------------------------------------------
 Sub MsSetWindow(Byval Row As Integer, Byval Col As Integer, _
                 Byval Rows As Integer, Byval Cols As Integer) Public

   Rows = Row + Rows - 1
   If (Pbvscrnmode = 7) Or (Pbvscrnmode = 0) Then
     Row = Row * 8 : Rows = Rows * 8
     Col = Col * 8 : Cols = Cols * 8
   End If
   Reg %AX, 8 : Reg %CX, Row : Reg %DX, Rows : Call Interrupt &H33
   Reg %AX, 7 : Reg %CX, Col : Reg %DX, Cols : Call Interrupt &H33
   MsLocate Row, Col

 End Sub
'---------------------------------------------------------------------------
 Sub InitGame()

   Dim s As String

   Piece(%Pawn)   = "E2REHERE8U5HLHER2EH4U3E4R3F4D3G4FR2FGL2D6F8RFGFRF2L32"
   Piece(%Rook)   = "E2REHER2U6R3U12HL2U7R3D3R3U3R3D3R3U3R3D3R3U3R3D7L2GD1" + _
                    "2R3D6R2FGFRF2L32"
   Piece(%Knight) = "E2REHER3U4EREH2U4E3REREREREU2HL2GLGL2G3LHLU3E5UE4R3EU" + _
                    "E2FERD4FRF4DFDFD6GDGDG2LG3DFRFD4R3FGFRF2L32"
   Piece(%Bishop) = "E2R2U1H1E1R3U5E1U6E1U5E1U4E5U3R3D3F5D4F1D5F1D6F1D4F1R" + _
                    "3F1G1F1R1F2L33"
   Piece(%Queen)  = "E2REHER2EU3ER2EH13UE3F4G2F2RFRFRFRU2HUHUHUH5E4F4G2DF5" + _
                    "U8H3UE4RF4DG3D8E5UH2E4F4G5DGDGDGD2RERERERE2H2E4F3DG13" + _
                    "FR2FD3FR2FGFRF2L32"
   Piece(%King)   = "E3H1E2R2U3E2R2H11U4E6R5F3R1U2H2U1E4R1F4D1G2D2R1E3R5F6" + _
                    "D4G11R2F2D3R2F2G1F3L32"

   WhiteBox = 7
   BlackBox = 0
   WhiteC = 10
   BlackC =  9
   MarkerColor = 12

   Do
     Cls
     Print "What side do you want, (B)lack  or (W)hite?"
     s = Input$(1)
     If Instr("Bb", s) Then
       HumanSide = %BlackSide                         'Human side is black
       HumanMovesFirst = %False
       HumanPiece = BlackC
       ComputerPiece = WhiteC
       Exit Loop
     Elseif Instr("Ww", s) Then
       HumanSide = %WhiteSide                         'Human side is white
       HumanMovesFirst = %True
       HumanPiece = WhiteC
       ComputerPiece = BlackC
       Exit Loop
     End If
     Sound 880, .5
   Loop

   Screen 12
   MkBoard
   PrepareGame

   MsCursorOn
   MsSetWindow 4, 4, 383, 386
   MsLocate 194, 194

 End Sub
'---------------------------------------------------------------------------