Here's a somewhat complicated program that mimics the popular
Windows Mine Sweeper game. This program is one of many BASIC programs
written to teach the power of programming. This program demonstrates mouse
control from within a QBASIC program as well as a method for determining the
best screen to use under DOS. This program also uses a recursive algorithm and
generates its own line-drawn fonts to display large numbers. This program contains
many advanced features of QBASIC and may be difficult for beginners to
understand since the commenting is minimal. It is provided here as an example
of what can be done using the tools freely available to most PC users.
Note: This program is easier to view if you turn off hypertext (shortcut) underlining.
' Copyright @ 1995,1999 by Robert M. Kuczewski
' Right to copy is granted to all provided all Copyright notices are maintained
DECLARE SUB ShowCopyRight ()
DECLARE SUB ShowNeighbors (r AS INTEGER, c AS INTEGER)
DECLARE SUB RightPress (MineField AS ANY, x AS INTEGER, y AS INTEGER)
DECLARE SUB LeftPress (MineField AS ANY, x AS INTEGER, y AS INTEGER)
DECLARE SUB encode (code AS STRING, value AS INTEGER, covered AS INTEGER, flagged AS INTEGER, questioned AS INTEGER)
DECLARE SUB decode (code AS STRING, value AS INTEGER, covered AS INTEGER, flagged AS INTEGER, questioned AS INTEGER)
DECLARE SUB EnCodeField (MineField AS ANY)
DECLARE SUB CalcNeighbors (MineField AS ANY)
DECLARE SUB DrawMine (x AS INTEGER, y AS INTEGER, w AS INTEGER, h AS INTEGER, s AS STRING)
DECLARE SUB DrawMineField (MineField AS ANY)
DECLARE SUB InitMineField (MineField AS ANY)
DEFINT A-Z
CONST MaxField = 10000
TYPE MineFieldType
NumRows AS INTEGER
NumCols AS INTEGER
NumMines AS INTEGER
OffX AS INTEGER
OffY AS INTEGER
MineW AS INTEGER
MineH AS INTEGER
MField AS STRING * MaxField
END TYPE
DIM SHARED MineField AS MineFieldType
' Skill Levels: 1 2 3
DIM SkillLevel AS INTEGER
DIM SHARED MineFieldRows AS INTEGER: MineFieldRows = 8 ' 8 16 16
DIM SHARED MineFieldCols AS INTEGER: MineFieldCols = 8 ' 8 16 30
DIM SHARED MineFieldMines AS INTEGER: MineFieldMines = 10 ' 10 40 99
CLS
' Show the Copyright notice and use PLAY to pause while it's being read
CALL ShowCopyRight
PLAY "MF T60 L4 P1 P1 N0 N0 N0 N0"
DIM SHARED ScreenNum AS INTEGER: ScreenNum = 1
DIM SHARED Xmax AS INTEGER: Xmax = 319
DIM SHARED Ymax AS INTEGER: Ymax = 199
DIM ErrorDetected AS INTEGER
GOTO EndHandler
Handler:
ErrorDetected = 1
RESUME NEXT
EndHandler:
MaxScreens = 20
DIM BestGraphScr AS INTEGER
DIM LegalScreen(MaxScreens) AS INTEGER
DIM ScreenW(MaxScreens), ScreenH(MaxScreens), ScreenC(MaxScreens) AS INTEGER
DIM ScreenA(MaxScreens) AS SINGLE
ScreenW(0) = 80: ScreenH(0) = 25: ScreenC(0) = 16: ScreenA(0) = 1
ScreenW(1) = 320: ScreenH(1) = 200: ScreenC(1) = 4: ScreenA(1) = 1
ScreenW(2) = 640: ScreenH(2) = 200: ScreenC(2) = 2: ScreenA(2) = 1
ScreenW(3) = 720: ScreenH(3) = 348: ScreenC(3) = 2: ScreenA(3) = .8
ScreenW(4) = 640: ScreenH(4) = 400: ScreenC(4) = 2: ScreenA(4) = 1
ScreenW(5) = 80: ScreenH(5) = 25: ScreenC(5) = 16: ScreenA(5) = 1
ScreenW(6) = 80: ScreenH(6) = 25: ScreenC(6) = 16: ScreenA(6) = 1
ScreenW(7) = 320: ScreenH(7) = 200: ScreenC(7) = 16: ScreenA(7) = 1
ScreenW(8) = 640: ScreenH(8) = 200: ScreenC(8) = 16: ScreenA(8) = 1
ScreenW(9) = 640: ScreenH(9) = 350: ScreenC(9) = 16: ScreenA(9) = 1
ScreenW(10) = 640: ScreenH(10) = 350: ScreenC(10) = 4: ScreenA(10) = 1
ScreenW(11) = 640: ScreenH(11) = 480: ScreenC(11) = 2: ScreenA(11) = 1
ScreenW(12) = 640: ScreenH(12) = 480: ScreenC(12) = 16: ScreenA(12) = 1
ScreenW(13) = 320: ScreenH(13) = 200: ScreenC(13) = 256: ScreenA(13) = 1
BestGraphScr = 0
ON ERROR GOTO Handler
' First check for Hercules mode which will take precedence for speed on XT's
ErrorDetected = 0
ScreenNum = 3
SCREEN ScreenNum
LegalScreen(ScreenNum) = ABS(1 - ErrorDetected)
IF LegalScreen(ScreenNum) THEN
' This machine supports Hercules so don't search further
BestGraphScr = ScreenNum
ELSE
' Non-Hercules Machine, so search for best screen. This takes a few seconds.
FOR ScreenNum = 0 TO MaxScreens
ErrorDetected = 0
SCREEN ScreenNum
LegalScreen(ScreenNum) = ABS(1 - ErrorDetected)
IF LegalScreen(ScreenNum) THEN
IF (BestGraphScr = 0) OR (ScreenH(ScreenNum) >= ScreenH(BestGraphScr)) THEN
BestGraphScr = ScreenNum
END IF
END IF
'Note: the view statement could be used here to get actual dimensions
NEXT ScreenNum
END IF
ON ERROR GOTO 0
ScreenNum = BestGraphScr
Xmax = ScreenW(ScreenNum) - 1
Ymax = ScreenH(ScreenNum) - 1
SCREEN ScreenNum
CALL ShowCopyRight
DIM PointCursor(4 + 2 * 2) AS INTEGER
CLS
PSET (0, 0)
GET (0, 0)-(0, 0), PointCursor
DIM SmallCursor(4 + 5 * 5) AS INTEGER
CLS
LINE (0, 0)-(0, 3)
LINE (1, 1)-(1, 2)
PSET (2, 2)
PSET (0, 0)
GET (0, 0)-(2, 3), SmallCursor
DIM cursor(4 + (13 * 11)) AS INTEGER
CLS
IF ScreenNum = 3 THEN
PSET (0, 0): PSET (1, 0): PSET (0, 1)
LINE (0, 0)-(8, 8): LINE (0, 0)-(8, 7): LINE (0, 0)-(8, 6)
LINE (0, 0)-(11, 6): LINE (0, 0)-(10, 6): LINE (0, 0)-(10, 7): LINE (0, 0)-(11, 6)
LINE (0, 0)-(3, 5): LINE (0, 0)-(2, 5): LINE (0, 0)-(6, 3): LINE (0, 0)-(7, 2)
GET (0, 0)-(11, 8), cursor ' : Xmax = Xmax - 12: Ymax = Ymax - 8
ELSE
PSET (0, 0)
LINE (0, 0)-(0, 7): LINE (0, 0)-(5, 5): LINE (0, 0)-(3, 5)
LINE (0, 0)-(1, 6): LINE (0, 0)-(4, 5): LINE (0, 0)-(2, 5)
PSET (4, 10): PSET (4, 9): PSET (3, 8): PSET (3, 7): PSET (2, 6): PSET (3, 6)
GET (0, 0)-(5, 10), cursor ' : Xmax = Xmax - 5: Ymax = Ymax - 10
END IF
CLS
' Set up the mouse variables and call interface
CONST XMotionScale = 1 / 1
CONST YMotionScale = 1 / 1
DIM mouseg, mouse AS INTEGER
REM DIM m1%, m2%, m3%, m4% AS INTEGER
DEF SEG = 0
mouseg = 256 * PEEK(207) + PEEK(206)
mouse = 256 * PEEK(205) + PEEK(204) + 2
DEF SEG = mouseg
IF ((mouseg OR (mouse - 2)) AND (PEEK(mouse - 2) <> 207)) = 0 THEN
SCREEN 0
PRINT "Mouse Driver not found"
END
END IF
DEF SEG
'Reset the mouse and get its status
m1% = 0: DEF SEG = mouseg: CALL absolute(m1%, m2%, m3%, m4%, mouse): DEF SEG
IF m1% <> -1 THEN
PRINT "Mouse was not found"
END
END IF
'Turn on the mouse cursor
m1% = 1: DEF SEG = mouseg: CALL absolute(m1%, m2%, m3%, m4%, mouse): DEF SEG
REM Turn off the mouse cursor (problem with Helen's XT)
m1% = 2: DEF SEG = mouseg: CALL absolute(m1%, m2%, m3%, m4%, mouse): DEF SEG
CLS
CALL ShowCopyRight
DIM x AS INTEGER, y AS INTEGER, Buttons AS INTEGER
DIM LastX AS INTEGER, LastY AS INTEGER, LastButtons AS INTEGER
x = Xmax / 2
y = Ymax / 2
Buttons = 0
DIM StartX AS INTEGER, StartY AS INTEGER
ErrorDetected = 0
GOTO EndPutHandler
PutHandler:
ErrorDetected = 1
RESUME NEXT
EndPutHandler:
ON ERROR GOTO PutHandler
' Application Code Initialization
RANDOMIZE TIMER
DO
CLS
LOCATE 10, 20
INPUT ; "Enter Skill Level (1-3) ", SkillLevel
SELECT CASE SkillLevel
CASE 1
MineFieldRows = 8 ' 8 16 16
MineFieldCols = 8 ' 8 16 30
MineFieldMines = 10 ' 10 40 99
CASE 2
MineFieldRows = 16 ' 8 16 16
MineFieldCols = 16 ' 8 16 30
MineFieldMines = 40 ' 10 40 99
CASE 3
MineFieldRows = 16 ' 8 16 16
MineFieldCols = 30 ' 8 16 30
MineFieldMines = 99 ' 10 40 99
CASE ELSE
MineFieldRows = 8 ' 8 16 16
MineFieldCols = 8 ' 8 16 30
MineFieldMines = 10 ' 10 40 99
END SELECT
CALL InitMineField(MineField)
CALL DrawMineField(MineField)
DO
LastX = x
LastY = y
LastButtons = Buttons
PUT (LastX, LastY), cursor, XOR
IF ErrorDetected THEN
ErrorDetected = 0
PUT (LastX, LastY), SmallCursor, XOR
IF ErrorDetected THEN
PUT (LastX, LastY), PointCursor, XOR
ErrorDetected = 0
END IF
END IF
DO
' Get input from physical devices (keyboard and mouse)
k$ = INKEY$
' Read the Mouse Motion Counters
m1% = 11: DEF SEG = mouseg: CALL absolute(m1%, m2%, m3%, m4%, mouse): DEF SEG
x = x + (m3% * XMotionScale)
y = y + (m4% * YMotionScale)
' Read the Mouse Button Status
m1% = 3: DEF SEG = mouseg: CALL absolute(m1%, m2%, m3%, m4%, mouse): DEF SEG
Buttons = m2%
' Bound the Mouse Position to within the Screen
IF x < 0 THEN x = 0
IF x > Xmax THEN x = Xmax
IF y < 0 THEN y = 0
IF y > Ymax THEN y = Ymax
' Process any Changes
IF (Buttons <> LastButtons) OR (x <> LastX) OR (y <> LastY) THEN
' Turn off the cursor
PUT (LastX, LastY), cursor, XOR
IF ErrorDetected THEN
' Handle cursor updates near the right or bottom boundaries
ErrorDetected = 0
PUT (LastX, LastY), SmallCursor, XOR
IF ErrorDetected THEN
ErrorDetected = 0
PUT (LastX, LastY), PointCursor, XOR
END IF
END IF
' Process the buttons and perform any resulting drawing
IF (LastButtons = 0) THEN
IF (Buttons = 1) THEN
' PSET (x, y)
CALL LeftPress(MineField, x, y)
ELSEIF (Buttons = 2) THEN
' PRESET (x, y)
CALL RightPress(MineField, x, y)
END IF
END IF
' Turn the cursor back on
PUT (x, y), cursor, XOR
IF ErrorDetected THEN
' Handle cursor updates near the right or bottom boundaries
ErrorDetected = 0
PUT (x, y), SmallCursor, XOR
IF ErrorDetected THEN
ErrorDetected = 0
PUT (x, y), PointCursor, XOR
END IF
END IF
' Update the mouse position
LastX = x
LastY = y
LastButtons = Buttons
IF 0 THEN
' Show the cursor position
IF Xmax < 400 THEN
LOCATE 25, 12
ELSE
LOCATE 25, 30
END IF
PRINT USING "#: (### , ###)"; Buttons; x; y;
END IF
END IF
LOOP UNTIL k$ <> ""
IF k$ = " " THEN
CLS
END IF
LOOP UNTIL (k$ = CHR$(27)) OR (k$ = " ") '27 is the ASCII code for Esc.
LOOP UNTIL k$ = CHR$(27)
SUB CalcNeighbors (MineField AS MineFieldType)
FOR r = 0 TO MineField.NumRows - 1
FOR c = 0 TO MineField.NumCols - 1
i = 1 + (r * MineField.NumCols) + c
IF MID$(MineField.MField, i, 1) <> "9" THEN
FOR sr = r - 1 TO r + 1
IF (sr >= 0) AND (sr < MineField.NumRows) THEN
FOR sc = c - 1 TO c + 1
IF (sc >= 0) AND (sc < MineField.NumCols) THEN
IF (sr <> r) OR (sc <> c) THEN
j = 1 + (sr * MineField.NumCols) + sc
IF MID$(MineField.MField, j, 1) = "9" THEN
MID$(MineField.MField, i, 1) = CHR$(1 + ASC(MID$(MineField.MField, i, 1)))
END IF
END IF
END IF
NEXT sc
END IF
NEXT sr
END IF
NEXT c
NEXT r
END SUB
SUB decode (code AS STRING, value AS INTEGER, covered AS INTEGER, flagged AS INTEGER, questioned AS INTEGER)
DIM c AS INTEGER
c = ASC(code)
value = c MOD 16
c = c \ 16
covered = c MOD 2
c = c \ 2
flagged = c MOD 2
c = c \ 2
questioned = c MOD 2
END SUB
SUB DrawMine (x AS INTEGER, y AS INTEGER, wid AS INTEGER, hgt AS INTEGER, s AS STRING)
DIM m AS STRING * 1
DIM value AS INTEGER
DIM covered AS INTEGER
DIM flagged AS INTEGER
DIM questioned AS INTEGER
DIM i AS INTEGER
w = wid
h = hgt
b = 2
bb = b * 2
m = LEFT$(s, 1)
CALL decode(m, value, covered, flagged, questioned)
LINE (x, y)-(x + w - 1, y + h - 1), 0, BF
LINE (x, y)-(x, y)
LINE -STEP(w, 0)
LINE -STEP(0, h)
LINE -STEP(-w, 0)
LINE -STEP(0, -h)
IF (covered OR flagged OR questioned) THEN
' Draw in the covered button top
c = 7
LINE STEP(b, b)-STEP(w - bb, h - bb), c, BF
LINE STEP(0, 0)-STEP(-(w - bb), -(h - bb)), c, BF
FOR i = 0 TO 3
c = 7
LINE (x + (i MOD 2), y + (i \ 2))-STEP(0, 0), , , 0
IF questioned THEN
c = 0
LINE STEP(w / 4, 3 * h / 8)-STEP(0, 0), c
LINE -STEP(0, -h / 8), c
LINE -STEP(w / 8, -h / 8), c
LINE -STEP(w / 4, 0), c
LINE -STEP(w / 8, h / 8), c
LINE -STEP(0, h / 8), c
LINE -STEP(-w / 4, h / 4), c
LINE -STEP(0, h / 8), c
PSET STEP(0, h / 8), c
END IF
IF flagged THEN
c = 0
LINE STEP(7 * w / 12, 5 * h / 6)-STEP(0, 0), c
LINE -STEP(0, -4 * h / 6), c
LINE -STEP(-w / 3, h / 6), c
LINE -STEP(w / 3, h / 6), c
END IF
NEXT
ELSE
IF value = 0 THEN
c = 0
LINE STEP(b, b)-STEP(w - bb, h - bb), c, BF
ELSE
'Draw in the number of surrounding mines
FOR i = 0 TO 3
LINE (x + (i MOD 2), y + (i \ 2))-STEP(0, 0), , , 0
SELECT CASE value
CASE 0
' This was handled above as a blank square
CASE 1
c = 9
LINE STEP(w / 2, h / 6)-STEP(0, 0), c
LINE -STEP(0, 4 * h / 6), c
CASE 2
c = 10
LINE STEP(w / 4, 3 * h / 8)-STEP(0, -h / 8), c
LINE -STEP(w / 8, -h / 8), c
LINE -STEP(w / 4, 0), c
LINE -STEP(w / 8, h / 8), c
LINE -STEP(0, w / 8), c
LINE -STEP(-w / 2, w / 2), c
LINE -STEP(w / 2, 0), c
CASE 3
c = 12
LINE STEP(w / 4, h / 4)-STEP(0, 0)
LINE -STEP(w / 8, -h / 8), c
LINE -STEP(w / 4, 0), c
LINE -STEP(w / 8, h / 8), c
LINE -STEP(0, h / 8), c
LINE -STEP(-w / 8, h / 8), c
LINE -STEP(-w / 4, 0), c
LINE -STEP(w / 4, 0), c
LINE -STEP(w / 8, h / 8), c
LINE -STEP(0, h / 8), c
LINE -STEP(-w / 8, h / 8), c
LINE -STEP(-w / 4, 0), c
LINE -STEP(-w / 8, -h / 8), c
CASE 4
c = 13
LINE STEP(w / 3, h / 6)-STEP(0, 0), c
LINE -STEP(-w / 6, 2 * h / 6), c
LINE -STEP(4 * w / 6, 0), c
LINE -STEP(-1 * w / 6, 0), c
LINE -STEP(0, -2 * h / 6), c
LINE -STEP(0, 4 * h / 6), c
CASE 5
c = 14
' LINE STEP(5 * w / 6, h / 6)-STEP(0, 0), c
' LINE -STEP(-4 * w / 6, 0), c
' LINE -STEP(0, 2 * h / 6), c
' LINE -STEP(4 * w / 6, 0), c
' LINE -STEP(0, 2 * h / 6), c
' LINE -STEP(-4 * w / 6, 0), c
LINE STEP(3 * w / 4, h / 8)-STEP(0, 0), c
LINE -STEP(-w / 2, 0), c
LINE -STEP(0, 3 * h / 8), c
LINE -STEP(w / 8, -h / 8), c
LINE -STEP(w / 4, 0), c
LINE -STEP(w / 8, h / 8), c
LINE -STEP(0, h / 4), c
LINE -STEP(-w / 8, h / 8), c
LINE -STEP(-w / 4, 0), c
LINE -STEP(-w / 8, -h / 8), c
CASE 6
c = 15
' LINE STEP(5 * w / 6, h / 6)-STEP(0, 0), c
' LINE -STEP(-4 * w / 6, 0), c
' LINE -STEP(0, 2 * h / 6), c
' LINE -STEP(4 * w / 6, 0), c
' LINE -STEP(0, 2 * h / 6), c
' LINE -STEP(-4 * w / 6, 0), c
' LINE -STEP(0, -2 * h / 6), c
LINE STEP(3 * w / 4, h / 4)-STEP(0, 0), c
LINE -STEP(-w / 8, -h / 8), c
LINE -STEP(-w / 4, 0), c
LINE -STEP(-w / 8, h / 8), c
LINE -STEP(0, h / 2), c
LINE -STEP(w / 8, h / 8), c
LINE -STEP(w / 4, 0), c
LINE -STEP(w / 8, -h / 8), c
LINE -STEP(0, -h / 4), c
LINE -STEP(-w / 8, -h / 8), c
LINE -STEP(-w / 4, 0), c
LINE -STEP(-w / 8, h / 8), c
CASE 7
c = 2
LINE STEP(w / 4, h / 6)-STEP(0, 0), c
LINE -STEP(2 * w / 4, 0), c
LINE -STEP(-3 * w / 8, 4 * h / 6), c
CASE 8
c = 3
LINE STEP(5 * w / 6, h / 6)-STEP(0, 0), c
LINE -STEP(-4 * w / 6, 0), c
LINE -STEP(0, 2 * h / 6), c
LINE -STEP(4 * w / 6, 0), c
LINE -STEP(0, 2 * h / 6), c
LINE -STEP(-4 * w / 6, 0), c
LINE -STEP(0, -2 * h / 6), c
LINE -STEP(4 * w / 6, 0), c
LINE -STEP(0, -2 * h / 6), c
CASE 9
c = 12
CIRCLE STEP(w / 2, h / 2), w / 3, c
c = 13
CIRCLE STEP(0, 0), w / 4, c
c = 13
CIRCLE STEP(0, 0), w / 5, c
c = 15
CIRCLE STEP(0, 0), w / 6, c
c = 13
CIRCLE STEP(0, 0), w / 7, c
c = 13
CIRCLE STEP(0, 0), w / 8, c
c = 12
CIRCLE STEP(0, 0), w / 9, c
c = 12
CIRCLE STEP(0, 0), w / 10, c
CASE ELSE
c = 15
CIRCLE STEP(w / 2, h / 2), w / 4, c
END SELECT
NEXT
END IF
END IF
END SUB
SUB DrawMineField (MineField AS MineFieldType)
DIM m AS STRING * 1
w = MineField.MineW
h = MineField.MineH
x0 = MineField.OffX
y0 = MineField.OffY
i = 1
FOR r = 0 TO MineField.NumRows - 1
FOR c = 0 TO MineField.NumCols - 1
m = MID$(MineField.MField, i, 1)
CALL DrawMine(x0 + (c * w), y0 + (r * h), w, h, m)
i = i + 1
NEXT c
NEXT r
END SUB
SUB encode (code AS STRING, value AS INTEGER, covered AS INTEGER, flagged AS INTEGER, questioned AS INTEGER)
DIM c AS INTEGER
c = value
IF covered <> 0 THEN
c = c + 16
END IF
IF flagged <> 0 THEN
c = c + 32
END IF
IF questioned <> 0 THEN
c = c + 64
END IF
code = CHR$(c)
END SUB
SUB EnCodeField (MineField AS MineFieldType)
DIM c AS STRING * 1
DIM value AS INTEGER
FOR i = 1 TO (MineField.NumRows * MineField.NumCols)
c = MID$(MineField.MField, i, 1)
value = ASC(c) - ASC("0")
CALL encode(c, value, 1, 0, 0)
MID$(MineField.MField, i, 1) = c
NEXT
END SUB
SUB InitMineField (MineField AS MineFieldType)
DIM code AS STRING * 1
MineField.NumRows = MineFieldRows
MineField.NumCols = MineFieldCols
MineField.NumMines = MineFieldMines
MineField.MineW = (20 * Xmax / 21) / MineField.NumCols
MineField.MineH = (20 * Ymax / 21) / MineField.NumRows
IF MineField.MineW > MineField.MineH THEN
MineField.MineW = MineField.MineH
ELSE
MineField.MineH = MineField.MineW
END IF
MineField.OffX = (Xmax - (MineField.NumCols * MineField.MineW)) / 2
MineField.OffY = (Ymax - (MineField.NumRows * MineField.MineH)) / 2
FOR i = 1 TO (MineField.NumRows * MineField.NumCols)
MID$(MineField.MField, i, 1) = "0"
NEXT
FOR n = 1 TO MineField.NumMines
DO
DO
i = RND * (MineField.NumRows * MineField.NumCols)
LOOP WHILE (i <= 0) OR (i > (MineField.NumRows * MineField.NumCols))
LOOP WHILE (MID$(MineField.MField, i, 1) <> "0")
MID$(MineField.MField, i, 1) = "9"
NEXT
CALL CalcNeighbors(MineField)
CALL EnCodeField(MineField)
END SUB
SUB LeftPress (MineField AS MineFieldType, x AS INTEGER, y AS INTEGER)
DIM m AS STRING * 1
c = (x - MineField.OffX) \ MineField.MineW
r = (y - MineField.OffY) \ MineField.MineH
i = 1 + (r * MineField.NumCols) + c
m = MID$(MineField.MField, i, 1)
CALL decode(m, value, covered, flagged, questioned)
IF (flagged = 0) AND (questioned = 0) THEN
IF value = 0 THEN
CALL ShowNeighbors(r, c)
END IF
CALL encode(m, value, 0, 0, 0)
MID$(MineField.MField, i, 1) = m
CALL DrawMine(MineField.OffX + (c * MineField.MineW), MineField.OffY + (r * MineField.MineH), MineField.MineW, MineField.MineH, m)
END IF
END SUB
SUB RightPress (MineField AS MineFieldType, x AS INTEGER, y AS INTEGER)
DIM m AS STRING * 1
c = (x - MineField.OffX) \ MineField.MineW
r = (y - MineField.OffY) \ MineField.MineH
i = 1 + (r * MineField.NumCols) + c
m = MID$(MineField.MField, i, 1)
CALL decode(m, value, covered, flagged, questioned)
IF covered THEN
IF flagged THEN
flagged = 0
questioned = 1
ELSE
IF questioned THEN
flagged = 0
questioned = 0
ELSE
flagged = 1
questioned = 0
END IF
END IF
CALL encode(m, value, covered, flagged, questioned)
MID$(MineField.MField, i, 1) = m
CALL DrawMine(MineField.OffX + (c * MineField.MineW), MineField.OffY + (r * MineField.MineH), MineField.MineW, MineField.MineH, m)
END IF
END SUB
SUB ShowCopyRight
LOCATE 10, 29: PRINT " M I N E 1 . 1 ";
LOCATE 12, 29: PRINT " by ";
LOCATE 14, 29: PRINT " Robert M. Kuczewski ";
LOCATE 16, 29: PRINT "Copyright @ 1995,1999";
LOCATE 22, 2: PRINT "Right to copy is granted to all provided all Copyright notices are maintained.";
END SUB
SUB ShowNeighbors (r AS INTEGER, c AS INTEGER)
DIM m AS STRING * 1
DIM i AS INTEGER
DIM value AS INTEGER
DIM covered AS INTEGER
DIM flagged AS INTEGER
DIM questioned AS INTEGER
DIM sr AS INTEGER
DIM sc AS INTEGER
DIM j AS INTEGER
i = 1 + (r * MineField.NumCols) + c
m = MID$(MineField.MField, i, 1)
CALL decode(m, value, covered, flagged, questioned)
IF (flagged = 0) AND (questioned = 0) THEN
CALL encode(m, value, 0, 0, 0)
MID$(MineField.MField, i, 1) = m
CALL DrawMine(MineField.OffX + (c * MineField.MineW), MineField.OffY + (r * MineField.MineH), MineField.MineW, MineField.MineH, m)
END IF
IF (value = 0) AND covered THEN
FOR sr = r - 1 TO r + 1
IF (sr >= 0) AND (sr < MineField.NumRows) THEN
FOR sc = c - 1 TO c + 1
IF (sc >= 0) AND (sc < MineField.NumCols) THEN
IF (sr <> r) OR (sc <> c) THEN
CALL ShowNeighbors(sr, sc)
END IF
END IF
NEXT sc
END IF
NEXT sr
END IF
END SUB
You can use your web browser to copy this program to the clipboard. Then
paste it into any text editor (like Windows Notepad), and
save it in a file called "mine_swp.bas". Then use DOS QBASIC to open the
file and run it.
As mentioned above, this is an advanced program which demonstrates many advanced capabilities of QBASIC. It also shows the level of complexity required to create full-scale programs in most procedural languages.