mirror of
https://github.com/QB64-Phoenix-Edition/QB64pe.git
synced 2024-09-28 07:37:47 +00:00
321 lines
5.9 KiB
QBasic
321 lines
5.9 KiB
QBasic
|
CHDIR ".\programs\samples\thebob\chess"
|
||
|
|
||
|
'CHESSUBS.BAS
|
||
|
DEFINT A-Z
|
||
|
DECLARE FUNCTION InitMOUSE ()
|
||
|
DECLARE SUB MouseSTATUS (LB, RB, MouseX, MouseY)
|
||
|
DECLARE SUB ShowMOUSE ()
|
||
|
DECLARE SUB HideMOUSE ()
|
||
|
DECLARE SUB LocateMOUSE (x, y)
|
||
|
DECLARE SUB FieldMOUSE (x1, y1, x2, y2)
|
||
|
DECLARE SUB PauseMOUSE (LB, RB, MouseX, MouseY)
|
||
|
DECLARE SUB ClearMOUSE ()
|
||
|
DECLARE SUB MouseDRIVER (LB, RB, MX, MY)
|
||
|
DECLARE SUB LoadSCREEN ()
|
||
|
DECLARE SUB SetPALETTE ()
|
||
|
DECLARE SUB PutPIECE (OldROW, OldCOL, NewROW, NewCOL)
|
||
|
DECLARE SUB ClearSQUARE (Row, Col)
|
||
|
DECLARE SUB HighLIGHT (Row, Col, OnOFF)
|
||
|
|
||
|
DIM SHARED MouseDATA$
|
||
|
DIM SHARED LB, RB
|
||
|
|
||
|
'Create and load MouseDATA$ for CALL ABSOLUTE routines
|
||
|
DATA 55,89,E5,8B,5E,0C,8B,07,50,8B,5E,0A,8B,07,50,8B,5E,08,8B
|
||
|
DATA 0F,8B,5E,06,8B,17,5B,58,1E,07,CD,33,53,8B,5E,0C,89,07,58
|
||
|
DATA 8B,5E,0A,89,07,8B,5E,08,89,0F,8B,5E,06,89,17,5D,CA,08,00
|
||
|
MouseDATA$ = SPACE$(57)
|
||
|
FOR i = 1 TO 57
|
||
|
READ h$
|
||
|
Hexxer$ = CHR$(VAL("&H" + h$))
|
||
|
MID$(MouseDATA$, i, 1) = Hexxer$
|
||
|
NEXT i
|
||
|
|
||
|
Moused = InitMOUSE
|
||
|
IF NOT Moused THEN
|
||
|
PRINT "Sorry, cat must have got the mouse."
|
||
|
SLEEP 2
|
||
|
SYSTEM
|
||
|
END IF
|
||
|
|
||
|
BoardDATA:
|
||
|
DATA 2, 3, 4, 5, 6, 4, 3, 2
|
||
|
DATA 1, 1, 1, 1, 1, 1, 1, 1
|
||
|
DATA 0, 0, 0, 0, 0, 0, 0, 0
|
||
|
DATA 0, 0, 0, 0, 0, 0, 0, 0
|
||
|
DATA 0, 0, 0, 0, 0, 0, 0, 0
|
||
|
DATA 0, 0, 0, 0, 0, 0, 0, 0
|
||
|
DATA 11, 11, 11, 11, 11, 11, 11, 11
|
||
|
DATA 12, 13, 14, 15, 16, 14, 13, 12
|
||
|
|
||
|
DIM SHARED Box(1 TO 26000)
|
||
|
DIM SHARED LilBOX(1 TO 800)
|
||
|
DIM SHARED Board(1 TO 8, 1 TO 8)
|
||
|
|
||
|
CONST King = 1
|
||
|
CONST Queen = 751
|
||
|
CONST Bishop = 1501
|
||
|
CONST Knight = 2251
|
||
|
CONST Rook = 3001
|
||
|
CONST Pawn = 3751
|
||
|
CONST White = 0 'piece color
|
||
|
CONST Black = 4500 'piece color
|
||
|
CONST Light = 0 'square color
|
||
|
CONST Dark = 9000 'square color
|
||
|
CONST ELight = 18751 'erase light square
|
||
|
CONST EDark = 18001 'erase dark square
|
||
|
|
||
|
SCREEN 12
|
||
|
|
||
|
SetPALETTE
|
||
|
LoadSCREEN
|
||
|
COLOR 7: LOCATE 29, 22: PRINT "PRESS ESC TO QUIT";
|
||
|
LocateMOUSE 254, 194
|
||
|
ShowMOUSE
|
||
|
DO
|
||
|
k$ = INKEY$
|
||
|
MouseSTATUS LB, RB, MouseX, MouseY
|
||
|
SELECT CASE MouseX
|
||
|
CASE 31 TO 80: Col = 1
|
||
|
CASE 81 TO 130: Col = 2
|
||
|
CASE 131 TO 180: Col = 3
|
||
|
CASE 181 TO 230: Col = 4
|
||
|
CASE 231 TO 280: Col = 5
|
||
|
CASE 281 TO 330: Col = 6
|
||
|
CASE 331 TO 380: Col = 7
|
||
|
CASE 381 TO 430: Col = 8
|
||
|
END SELECT
|
||
|
SELECT CASE MouseY
|
||
|
CASE 31 TO 80: Row = 1
|
||
|
CASE 81 TO 130: Row = 2
|
||
|
CASE 131 TO 180: Row = 3
|
||
|
CASE 181 TO 230: Row = 4
|
||
|
CASE 231 TO 280: Row = 5
|
||
|
CASE 281 TO 330: Row = 6
|
||
|
CASE 331 TO 380: Row = 7
|
||
|
CASE 381 TO 430: Row = 8
|
||
|
END SELECT
|
||
|
|
||
|
IF LB = -1 THEN
|
||
|
SELECT CASE Clicked
|
||
|
CASE 0
|
||
|
ExROW = Row: ExCOL = Col
|
||
|
HighLIGHT Row, Col, 1
|
||
|
Clicked = 1
|
||
|
CASE 1
|
||
|
IF ExROW = Row AND ExCOL = Col THEN
|
||
|
HighLIGHT Row, Col, 0
|
||
|
ELSE
|
||
|
PutPIECE ExROW, ExCOL, Row, Col
|
||
|
END IF
|
||
|
Clicked = 0
|
||
|
END SELECT
|
||
|
END IF
|
||
|
|
||
|
ClearMOUSE
|
||
|
LOOP UNTIL k$ = CHR$(27)
|
||
|
|
||
|
SYSTEM
|
||
|
|
||
|
PaletteDATA:
|
||
|
DATA 12,0,10, 17,19,17, 20,22,20, 23,25,23
|
||
|
DATA 63,0,0, 63,60,50, 58,55,45, 53,50,40
|
||
|
DATA 0,0,0, 42,42,48, 50,50,55, 40,40,63
|
||
|
DATA 15,15,34, 58,37,15, 60,52,37, 63,63,63
|
||
|
|
||
|
SUB ClearMOUSE
|
||
|
|
||
|
WHILE LB OR RB
|
||
|
MouseSTATUS LB, RB, MouseX, MouseY
|
||
|
WEND
|
||
|
|
||
|
END SUB
|
||
|
|
||
|
SUB ClearSQUARE (Row, Col)
|
||
|
|
||
|
IF (Col + Row MOD 2) MOD 2 THEN Square = EDark ELSE Square = ELight
|
||
|
x = Col * 50 - 19
|
||
|
y = Row * 50 - 19
|
||
|
PUT (x, y), Box(Square), PSET
|
||
|
|
||
|
END SUB
|
||
|
|
||
|
SUB FieldMOUSE (x1, y1, x2, y2)
|
||
|
|
||
|
MouseDRIVER 7, 0, x1, x2
|
||
|
MouseDRIVER 8, 0, y1, y2
|
||
|
|
||
|
END SUB
|
||
|
|
||
|
SUB HideMOUSE
|
||
|
|
||
|
LB = 2
|
||
|
MouseDRIVER LB, 0, 0, 0
|
||
|
|
||
|
END SUB
|
||
|
|
||
|
SUB HighLIGHT (Row, Col, OnOFF)
|
||
|
STATIC SquareON, Oldx, Oldy
|
||
|
|
||
|
IF SquareON AND OnOFF = 0 THEN
|
||
|
HideMOUSE
|
||
|
PUT (Oldx, Oldy), LilBOX, PSET
|
||
|
ShowMOUSE
|
||
|
SquareON = 0
|
||
|
EXIT SUB
|
||
|
END IF
|
||
|
|
||
|
x = Col * 50 - 19
|
||
|
y = Row * 50 - 19
|
||
|
HideMOUSE
|
||
|
GET (x, y)-(x + 46, y + 46), LilBOX
|
||
|
LINE (x, y)-(x + 46, y + 46), 4, B
|
||
|
LINE (x + 1, y + 1)-(x + 45, y + 45), 4, B
|
||
|
ShowMOUSE
|
||
|
SquareON = 1: Oldx = x: Oldy = y
|
||
|
|
||
|
END SUB
|
||
|
|
||
|
FUNCTION InitMOUSE
|
||
|
|
||
|
LB = 0
|
||
|
MouseDRIVER LB, 0, 0, 0
|
||
|
InitMOUSE = LB
|
||
|
|
||
|
END FUNCTION
|
||
|
|
||
|
SUB LoadSCREEN
|
||
|
|
||
|
'Loads screen and then loads chess pieces into Box array
|
||
|
FileNUM = 0
|
||
|
DEF SEG = VARSEG(Box(1))
|
||
|
FOR y = 0 TO 320 STEP 160
|
||
|
FileNUM = FileNUM + 1
|
||
|
FileNAME$ = "ChessBD" + LTRIM$(STR$(FileNUM)) + ".BSV"
|
||
|
BLOAD FileNAME$, VARPTR(Box(1))
|
||
|
PUT (0, y), Box, PSET
|
||
|
NEXT y
|
||
|
BLOAD "chesspcs.bsv", VARPTR(Box(1))
|
||
|
DEF SEG
|
||
|
|
||
|
'read starting values into map array
|
||
|
RESTORE BoardDATA
|
||
|
FOR Col = 1 TO 8
|
||
|
FOR Row = 1 TO 8
|
||
|
READ Board(Col, Row)
|
||
|
NEXT Row
|
||
|
NEXT Col
|
||
|
|
||
|
END SUB
|
||
|
|
||
|
SUB LocateMOUSE (x, y)
|
||
|
|
||
|
LB = 4
|
||
|
MX = x
|
||
|
MY = y
|
||
|
MouseDRIVER LB, 0, MX, MY
|
||
|
|
||
|
END SUB
|
||
|
|
||
|
SUB MouseDRIVER (LB, RB, MX, MY)
|
||
|
|
||
|
DEF SEG = VARSEG(MouseDATA$)
|
||
|
mouse = SADD(MouseDATA$)
|
||
|
CALL ABSOLUTE_MOUSE_EMU (LB, RB, MX, MY)
|
||
|
|
||
|
END SUB
|
||
|
|
||
|
SUB MouseSTATUS (LB, RB, MouseX, MouseY)
|
||
|
|
||
|
LB = 3
|
||
|
MouseDRIVER LB, RB, MX, MY
|
||
|
LB = ((RB AND 1) <> 0)
|
||
|
RB = ((RB AND 2) <> 0)
|
||
|
MouseX = MX
|
||
|
MouseY = MY
|
||
|
|
||
|
END SUB
|
||
|
|
||
|
SUB PauseMOUSE (OldLB, OldRB, OldMX, OldMY)
|
||
|
|
||
|
|
||
|
SHARED Key$
|
||
|
|
||
|
DO
|
||
|
Key$ = UCASE$(INKEY$)
|
||
|
MouseSTATUS LB, RB, MouseX, MouseY
|
||
|
LOOP UNTIL LB <> OldLB OR RB <> OldRB OR MouseX <> OldMX OR MouseY <> OldMY OR Key$ <> ""
|
||
|
|
||
|
END SUB
|
||
|
|
||
|
SUB PutPIECE (Row1, Col1, Row2, Col2)
|
||
|
|
||
|
IF Board(Row1, Col1) <> 0 THEN
|
||
|
SELECT CASE Board(Row1, Col1) MOD 10
|
||
|
CASE 1: Piece = Pawn
|
||
|
CASE 2: Piece = Rook
|
||
|
CASE 3: Piece = Knight
|
||
|
CASE 4: Piece = Bishop
|
||
|
CASE 5: Piece = Queen
|
||
|
CASE 6: Piece = King
|
||
|
END SELECT
|
||
|
|
||
|
IF (Col1 + Row1 MOD 2) MOD 2 THEN Cancel = EDark ELSE Cancel = ELight
|
||
|
IF (Col2 + Row2 MOD 2) MOD 2 THEN Square = Dark ELSE Square = Light
|
||
|
IF Board(Row1, Col1) \ 10 = 0 THEN Colr = Black ELSE Colr = White
|
||
|
|
||
|
x = Col1 * 50 - 19
|
||
|
y = Row1 * 50 - 19
|
||
|
HideMOUSE
|
||
|
PUT (x, y), Box(Cancel), PSET
|
||
|
ShowMOUSE
|
||
|
|
||
|
Board(Row2, Col2) = Board(Row1, Col1)
|
||
|
Board(Row1, Col1) = 0
|
||
|
|
||
|
x = Col2 * 50 - 19
|
||
|
y = Row2 * 50 - 19
|
||
|
HideMOUSE
|
||
|
PUT (x, y), Box(Colr + Piece + Square), PSET
|
||
|
ShowMOUSE
|
||
|
ELSE
|
||
|
HighLIGHT Row1, Col1, 0
|
||
|
END IF
|
||
|
|
||
|
END SUB
|
||
|
|
||
|
SUB SetPALETTE
|
||
|
|
||
|
RESTORE PaletteDATA
|
||
|
OUT &H3C8, 0
|
||
|
FOR n = 1 TO 48
|
||
|
READ Intensity
|
||
|
OUT &H3C9, Intensity
|
||
|
NEXT n
|
||
|
|
||
|
END SUB
|
||
|
|
||
|
SUB ShowMOUSE
|
||
|
LB = 1
|
||
|
MouseDRIVER LB, 0, 0, 0
|
||
|
END SUB
|
||
|
|
||
|
SUB ABSOLUTE_MOUSE_EMU (AX%, BX%, CX%, DX%)
|
||
|
SELECT CASE AX%
|
||
|
CASE 0
|
||
|
AX% = -1
|
||
|
CASE 1
|
||
|
_MOUSESHOW
|
||
|
CASE 2
|
||
|
_MOUSEHIDE
|
||
|
CASE 3
|
||
|
WHILE _MOUSEINPUT
|
||
|
WEND
|
||
|
BX% = -_MOUSEBUTTON(1) - _MOUSEBUTTON(2) * 2 - _MOUSEBUTTON(3) * 4
|
||
|
CX% = _MOUSEX
|
||
|
DX% = _MOUSEY
|
||
|
CASE 4
|
||
|
_MOUSEMOVE CX%, DX% 'Not currently supported in QB64 GL
|
||
|
END SELECT
|
||
|
END SUB
|