mirror of
https://github.com/QB64-Phoenix-Edition/QB64pe.git
synced 2024-07-06 03:30:23 +00:00
9ee89d6ff4
These tests use a variety of sample code (with some of the larger files removed, so they are not complete!) and verifies that they all compile successfully.
283 lines
5 KiB
QBasic
283 lines
5 KiB
QBasic
CHDIR ".\programs\samples\thebob\abacus"
|
|
|
|
'****************************************************************************'
|
|
'
|
|
'------------------------- A B A C U S 1 2. B A S ---------------------------'
|
|
'--------------- Copyright (C) 2007 by Bob Seguin (Freeware) ----------------'
|
|
'
|
|
'****************************************************************************'
|
|
|
|
DEFINT A-Z
|
|
|
|
DECLARE FUNCTION InitMOUSE ()
|
|
|
|
DECLARE SUB MouseSTATUS (LB, RB, MouseX, MouseY)
|
|
DECLARE SUB ShowMOUSE ()
|
|
DECLARE SUB HideMOUSE ()
|
|
DECLARE SUB ClearMOUSE ()
|
|
|
|
DECLARE SUB MouseDRIVER (LB, RB, MX, MY)
|
|
|
|
DECLARE SUB Graphics ()
|
|
DECLARE SUB PutBEADS (col, OneVAL)
|
|
DECLARE SUB PutNUM (col)
|
|
DECLARE SUB Menu (InOUT)
|
|
DECLARE SUB ResetABACUS ()
|
|
|
|
DIM SHARED Box(26000)
|
|
DIM SHARED NumBOX(1 TO 250)
|
|
DIM SHARED MenuBOX(600)
|
|
DEF SEG = VARSEG(NumBOX(1))
|
|
BLOAD "abanums.bsv", VARPTR(NumBOX(1))
|
|
DEF SEG = VARSEG(MenuBOX(0))
|
|
BLOAD "abamenu.bsv", VARPTR(MenuBOX(0))
|
|
DEF SEG
|
|
DIM SHARED Abacus(1 TO 10, 1 TO 2)
|
|
|
|
DIM SHARED MouseDATA$
|
|
DIM SHARED LB, RB
|
|
|
|
'Create and load MouseDATA$ for CALL ABSOLUTE routines
|
|
Cheddar:
|
|
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)
|
|
RESTORE Cheddar
|
|
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
|
|
|
|
SCREEN 12
|
|
|
|
GOSUB SetPALETTE
|
|
Graphics
|
|
ShowMOUSE
|
|
|
|
DO
|
|
k$ = INKEY$
|
|
IF k$ = CHR$(27) THEN SYSTEM
|
|
MouseSTATUS LB, RB, MouseX, MouseY
|
|
SELECT CASE MouseX
|
|
CASE 212 TO 233: col = 1
|
|
CASE 234 TO 255: col = 2
|
|
CASE 256 TO 277: col = 3
|
|
CASE 278 TO 299: col = 4
|
|
CASE 300 TO 321: col = 5
|
|
CASE 322 TO 343: col = 6
|
|
CASE 344 TO 365: col = 7
|
|
CASE 366 TO 387: col = 8
|
|
CASE 388 TO 409: col = 9
|
|
CASE 410 TO 431: col = 10
|
|
CASE ELSE: col = 0
|
|
END SELECT
|
|
SELECT CASE MouseY
|
|
CASE 124 TO 133: Menu 1
|
|
CASE 161 TO 176: row = 1
|
|
CASE 177 TO 192: row = 2
|
|
CASE 202 TO 218: row = 3
|
|
CASE 219 TO 234: row = 4
|
|
CASE 235 TO 250: row = 5
|
|
CASE 251 TO 266: row = 6
|
|
CASE 267 TO 282: row = 7
|
|
CASE ELSE: row = 0: Menu 0
|
|
END SELECT
|
|
|
|
IF LB = -1 THEN
|
|
IF col <> 0 THEN
|
|
SELECT CASE row
|
|
CASE 1: PutBEADS col, 6: Abacus(col, 1) = 5
|
|
CASE 2: PutBEADS col, 5: Abacus(col, 1) = 0
|
|
CASE 3 TO 7: Sum = row - 3: Abacus(col, 2) = Sum: PutBEADS col, Sum
|
|
END SELECT
|
|
PutNUM col
|
|
END IF
|
|
ClearMOUSE
|
|
END IF
|
|
|
|
LOOP
|
|
|
|
SYSTEM
|
|
|
|
SetPALETTE:
|
|
DATA 20, 0, 24, 0, 0, 42, 0, 0, 45, 10, 0, 50
|
|
DATA 55, 0, 0, 50, 0, 0, 40, 0, 0, 42, 42, 42
|
|
DATA 30, 0, 0, 20, 10, 55, 25, 5, 29, 40, 30, 63
|
|
DATA 45, 0, 0, 63, 0, 0, 60, 45, 20, 63, 63, 63
|
|
RESTORE SetPALETTE
|
|
OUT &H3C8, 0
|
|
FOR n = 1 TO 48
|
|
READ Intensity
|
|
OUT &H3C9, Intensity
|
|
NEXT n
|
|
RETURN
|
|
|
|
SUB ClearMOUSE
|
|
|
|
WHILE LB OR RB
|
|
MouseSTATUS LB, RB, MouseX, MouseY
|
|
WEND
|
|
|
|
END SUB
|
|
|
|
SUB Graphics
|
|
|
|
DEF SEG = VARSEG(Box(0))
|
|
FOR y = 0 TO 320 STEP 160
|
|
FileCOUNT = FileCOUNT + 1
|
|
FileNAME$ = "ABACUS" + LTRIM$(RTRIM$(STR$(FileCOUNT))) + ".BSV"
|
|
BLOAD FileNAME$, VARPTR(Box(0))
|
|
PUT (0, y), Box
|
|
NEXT y
|
|
BLOAD "abasets.bsv", VARPTR(Box(0))
|
|
DEF SEG
|
|
|
|
END SUB
|
|
|
|
SUB HideMOUSE
|
|
|
|
LB = 2
|
|
MouseDRIVER LB, 0, 0, 0
|
|
|
|
END SUB
|
|
|
|
FUNCTION InitMOUSE
|
|
|
|
LB = 0
|
|
MouseDRIVER LB, 0, 0, 0
|
|
InitMOUSE = LB
|
|
|
|
END FUNCTION
|
|
|
|
SUB Menu (InOUT)
|
|
STATIC MenuITEM
|
|
|
|
IF InOUT = 0 THEN GOSUB CloseMENU: EXIT SUB
|
|
|
|
MouseSTATUS LB, RB, MouseX, MouseY
|
|
SELECT CASE MouseX
|
|
CASE 210 TO 238
|
|
IF MenuITEM <> 1 THEN
|
|
GOSUB CloseMENU
|
|
MenuITEM = 1
|
|
GOSUB OpenMENU
|
|
END IF
|
|
CASE 412 TO 432
|
|
IF MenuITEM <> 2 THEN
|
|
GOSUB CloseMENU
|
|
MenuITEM = 2
|
|
GOSUB OpenMENU
|
|
END IF
|
|
CASE ELSE: GOSUB CloseMENU
|
|
END SELECT
|
|
|
|
IF LB = -1 THEN
|
|
SELECT CASE MenuITEM
|
|
CASE 1: ResetABACUS
|
|
CASE 2: GOSUB CloseMENU: SYSTEM
|
|
END SELECT
|
|
END IF
|
|
|
|
EXIT SUB
|
|
|
|
OpenMENU:
|
|
HideMOUSE
|
|
SELECT CASE MenuITEM
|
|
CASE 1: PUT (210, 124), MenuBOX(200), PSET
|
|
CASE 2: PUT (412, 124), MenuBOX(300), PSET
|
|
END SELECT
|
|
ShowMOUSE
|
|
RETURN
|
|
|
|
CloseMENU:
|
|
IF MenuITEM <> 0 THEN
|
|
HideMOUSE
|
|
SELECT CASE MenuITEM
|
|
CASE 1: PUT (210, 124), MenuBOX, PSET
|
|
CASE 2: PUT (412, 124), MenuBOX(100), PSET
|
|
END SELECT
|
|
ShowMOUSE
|
|
MenuITEM = 0
|
|
END IF
|
|
RETURN
|
|
|
|
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 PutBEADS (col, BeadVAL)
|
|
|
|
PutCOL = col * 22 + 192
|
|
IF BeadVAL > 4 THEN Hop = -43 ELSE Hop = 0
|
|
HideMOUSE
|
|
PUT (PutCOL, 204 + Hop), Box(BeadVAL * 1000 + 10000), PSET
|
|
ShowMOUSE
|
|
|
|
END SUB
|
|
|
|
SUB PutNUM (col)
|
|
Sum = Abacus(col, 1) + Abacus(col, 2)
|
|
HideMOUSE
|
|
PUT (col * 22 + 198, 320), NumBOX(Sum * 25 + 1), PSET
|
|
ShowMOUSE
|
|
END SUB
|
|
|
|
SUB ResetABACUS
|
|
|
|
HideMOUSE
|
|
PUT (212, 161), Box, PSET
|
|
ShowMOUSE
|
|
ERASE Abacus
|
|
|
|
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
|