'===========================================================================
' Subject: PB CHESS GAME PROGRAMMING          Date: 04-23-99 (12:18)       
'  Author: Alexander Podkolzin                Code: PB                     
'  Origin: app@nw.sbank.e-burg.su           Packet: PB.ABC
'===========================================================================
'---------------------------------------------------------------------------
'  PowerBasic chess game programming.
'  First steps. Simpliest computer chess graphics and board representation.
'  Author: Alexander Podkolzin.
'  As I think, it's about 1% of work under real chess programme...
'  Next step will be "Generating of possible moves" or something like this.
'  Sorry, I do not know of English chess terminology, but source code is
'  self-explanatory.
'  Now the programme can do nothing but removing pieces from one place
'  to another, as a kid. Hope we'll tech it !?:)
'  Mouse functions are rewritten in pure basic, as native source code
'  is copyrighted by PowerBasic Inc. Names of mouse functions are the same.
'  Public domain.
'  Have fun!
'---------------------------------------------------------------------------
 $DIM ALL
 $LIB GRAPH
 $COMPILE MEMORY ' 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 = 1
 %ESC_key = &H001B
 %Mouse_Click_Left = 1
 %Mouse_Click_Right = 2
 %Mark = 1
 %Unmark = 0
 %Pawn = 1
 %Knight = 2
 %Bishop = 3
 %Rook = 4
 %Queen = 5
 %King = 6
 %WhiteSide = 0
 %BlackSide = 1
'---------------------------------------------------------------------------
 Declare Function MsButtons() As Integer
 Declare Function MsThere() 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 MkBoard()
 Declare Sub MkField( _
         Byval X As Integer, _
         Byval Y As Integer, _
         Byval C As Integer _
         )
 Declare Function fColorOfBox( _
         Byval X As Integer, _
         Byval Y As Integer _
         ) As Integer
 Declare Sub MarkIt( _
         Byval X As Integer, _
         Byval Y As Integer, _
         Byval State As Integer _
         )
 Declare Function fGetKey( _
         Row As Integer, _
         Col As Integer _
         ) As Integer
 Declare Sub DoMove( _
         Byval X1 As Integer, _
         Byval Y1 As Integer, _
         Byval X2 As Integer, _
         Byval Y2 As Integer _
         )
 Declare Sub PrepareGame()
 Declare Sub Show( _
         Byval Num As Integer, _
         Byval x As Integer, _
         Byval y As Integer, _
         Byval Colr As Integer)
 Declare Sub GetScrXY( _
         Byval X As Integer, _
         Byval Y As Integer, _
         sX As Integer, _
         sY As Integer)
'---------------------------------------------------------------------------
 Dim WhiteBox As Shared Integer
 Dim BlackBox As Shared Integer
 Dim Side As Shared Integer
 Dim Piece(%Pawn To %King) As Shared String
 Dim WhiteC As Shared Integer
 Dim BlackC As Shared Integer
 Dim i As Integer
 Dim MouseX As Integer
 Dim MouseY As Integer
 Dim CurX As Shared Integer
 Dim CurY As Shared Integer
 Dim OldX As Shared Integer
 Dim OldY As Shared Integer
 Dim Pointed As Shared Integer
 Dim MarkerColor As Shared Integer
 Dim ChessBoard(8, 8) As Shared Integer
'---------------------------------------------------------------------------

 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
 Side = %WhiteSide                               'Human side
' Side = %BlackSide                               'Human side

 Screen 12
 MkBoard
 PrepareGame

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

 Do
   i = fGetKey(MouseX, MouseY)
   Select Case i
   Case %Mouse_Click_Left
     CurX = MouseX : CurY = MouseY
     If Pointed Then                             'Marked field
       If (OldX = CurX) And (OldY = CurY) Then   'At the same place
         Pointed = %False                        '
         OldX = 0                                '
         OldY = 0                                '
         MarkIt CurX, CurY, %Unmark              'Remove marker
       Else                                      'Another place
         MarkIt OldX, OldY, %Unmark              'Remove marker
         DoMove OldX, OldY, CurX, CurY           'Replace piece
         Pointed = %False                        '
         OldX = 0                                '
         OldY = 0                                '
       End If                                    '
     Else                                        'Not marked field
       If ChessBoard(CurX, CurY) = 0 Then        'Can not
         Exit Select                             'mark empty
       End If                                    'field
       Pointed = %True                           '
       OldX = CurX                               '
       OldY = CurY                               '
       MarkIt CurX, CurY, %Mark                  'Make marker
     End If                                      '

   Case %ESC_key, %Mouse_Click_Right
     Exit Loop

   Case %Mouse_Click_Left
   End Select

 Loop

 Screen 0,0,0,0
 End
'---------------------------------------------------------------------------
 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 Side 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)
   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 Side 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
   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

   Dim cb As Integer
   Dim cw 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 Side 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 Side 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)
'
'  Painting 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
'---------------------------------------------------------------------------
'         MsThere - Returns true if mouse driver is present.
 Function MsThere() Public As Integer
   Reg %AX, 0
   Call Interrupt &H33
   If Reg(%AX) Then
     Function = %True
   End If
 End Function
'---------------------------------------------------------------------------
'         MsButtons - Returns number of buttons if a mouse is installed.
 Function MsButtons() Public As Integer
   Reg %AX, 0
   Call Interrupt &H33
   If Reg(%BX) Then
     Function = Reg(%BX)
   End If
 End Function
'---------------------------------------------------------------------------
'    MsCursorOn - Turn mouse cursor on.
 Sub MsCursorOn() Public
   Reg %AX, 1 : Call Interrupt &H33
 End Sub
'---------------------------------------------------------------------------
'    MsCursorOff - Turn mouse cursor off.
 Sub MsCursorOff() Public
   Reg %AX, 2 : Call Interrupt &H33
 End Sub
'---------------------------------------------------------------------------
'    MsStatus - Return button(s) pressed, row and column of cursor.
'    Button = Current button(s) pressed.
'    Left button - 1
'    Right button - 2,
'    Middle button - 4
'    Row    = Current mouse cursor row
'    Column = Current mouse cursor column
 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                         'If text mode, then
     Column = (Column \ 8) + 1                   'fix coordinates
   End If
 End Sub
'---------------------------------------------------------------------------
'    MsLocate - Locates the mouse cursor at Row, Column.
'    Row    = New mouse cursor row
'    Column = New mouse cursor column
 Sub MsLocate(Byval Row As Integer, Byval Column As Integer) Public
   If (Pbvscrnmode = 7) Or (Pbvscrnmode = 0) Then
     Row = (Row - 1) * 8                         'If text mode, then
     Column = (Column - 1) * 8                   'fix coordinates
   End If
   Reg %AX, 4 : Reg %CX, Column : Reg %DX, Row : Call Interrupt &H33
 End Sub
'---------------------------------------------------------------------------
'    MsSetWindow - defines window for mouse cursor.  The mouse
'    cursor will not be allowed outside of this defined area.
'    Row  = Top row for mouse window boundary
'    Col  = Left column for mouse window boundary
'    Rows = Total rows for mouse window boundary
'    Cols = Total columns for mouse window boundary
 Sub MsSetWindow(Byval Row As Integer, Byval Col As Integer, _
                 Byval Rows As Integer, Byval Cols As Integer) Public
   Rows = Row + Rows - 1                         'Adjust cols to
'                                                'real coordinates
   If (Pbvscrnmode = 7) Or (Pbvscrnmode = 0) Then
     Row = Row * 8 : Rows = Rows * 8             'If text mode,
     Col = Col * 8 : Cols = Cols * 8             'adjust coordinates
   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                             'Move mouse cursor to
'                                                'upper left corner
 End Sub
'---------------------------------------------------------------------------