QB / QB64 Discussion Forum     RULES     Other Subforums, Links and Downloads    Index of Threads

 

 Return to Index  

mines.bas --- a text mode game based on Minesweeper.

November 14 2005 at 3:15 PM
Michael Calkins  (Login MCalkins)
R


Response to ProgramList Michael Calkins

 
ESC - quit
S - toggle sound
F2 - new game
F10 - select level and start new game
SPACE / left-click - uncover square
ENTER / right-click - toggle normal/flag/'?'
Arrows / mouse motion - move cursor

Begginer, Intermediate, and Expert levels conform to Minesweeper. Limits for custom levels also conform.
The keyboard alone can be used to play, or the mouse in addition to it. This game is in color, and uses both 80x25 and 40x25 color text modes. Sound is optional.

Thanks to Solitaire's recommendation, this game has a redo feature to retry a lost level. However, such a retry is not timed, and is not eligable for a high score.

To track high scores, a 96 byte binary file is used. This is currently "mines.dat" in the current directory.

This game, in the development stages (with mouse routines), has been tested using QBASIC 1.1 on MS-DOS 7.1, Win 95b, Win98SE, and using QBASIC 1.0 on IBM OS/2 Warp 3. I will further test the finished version on the same configurations. There is no known reason why this game would fail on normal configurations of the above mentioned OSes.

Possible NTVDM conflicts:
I use WIDTH 80, 25 and WIDTH 40, 25. I'm not sure how NTVDM will handle this, but DOS, 9x, and Warp handle it correctly.
Mouse access. Solitaire has reported failure with my mouse routine on Windows XP. I have included 2 mouse routines: my own, as well as one donated by The PhyloGenesis (thanks), who says it works with XP. Phylo's is used by default. Both routines work on all my test configurations, including Warp.

I made a point of avoiding SUB procedures and FUNCTIONs, not that there is anything wrong with them. This game makes extensive, efficient, and well organized use of GOSUB. I consider this program to be a model of effective GOSUB usage. RETURN is always used, except in cases of SYSTEM termination inside a routine.

I have tested it fairly well, but I did some late tweaking, so I will be testing it further, but I don't expect to find any bugs. If so, I will modify this post.

I hope you enjoy this freeware game. Please report all bugs and mistakes. I am curious as to how well the NTVDM systems will handle it, but I think the WIDTH thing will be trouble even if the mouse isn't.

Regards,
Michael

'The first 3 constants are meant to be user-changable.
'the following file will act as the high score data file:
CONST file = "mines.dat"

'the following line chooses between two mouse access routines.
CONST mouseoption = 2
'0 is disable mouse
'1 is my own routine, which definitely works with DOS 7.1, Win 9x, and OS/2 Warp
'2 is the routine donated by The PhyloGenesis, which is said to work with
'Windows NT/2000/XP, in addition to the other Operating Systems.

CONST enableq = 0       '"?" marks: 0=disable, non-zero=enable

DEFINT A-Z      'You knew I was going to do this, didn't you?
RANDOMIZE TIMER
CONST maxx = 30         'limits conform to Minesweeper's limits.
CONST maxy = 24
CONST maxmines = 667
CONST minx = 8
CONST miny = 8
CONST minmines = 10
'This routine has been donated by The PhyloGenesis:
CONST PhyloGenesis = "5589E58B5E0C8B07508B5E0A8B07508B5E088B0F8B5E068B175B581E07CD33538B5E0C8907588B5E0A89078B5E08890F8B5E0689175DCA0800"
TYPE codet      'user defined type for mouse access
 axv AS INTEGER
 cxv AS INTEGER
 dxv AS INTEGER
 bxv AS INTEGER
 code AS STRING * 21    'my routine goes here
 PG AS STRING * 57      'Phylo's routine goes here
 s AS INTEGER
END TYPE
DIM SHARED cd AS codet  'main variable for mouse access
DIM mousepref, obx, ocx, odx, visible, ovis     'misc mouse variables
'main variables
DIM xd, yd, nmines, nmarks, start AS SINGLE, tsing AS SINGLE, game
DIM x, y, i, sx, sy, elap, oelap, cx, cy, tx, ty, bx, by, ex, ey
DIM nlef, k AS STRING, t AS STRING, level, snd
GOSUB initmousecode             'init mouse routines
mousepref = mouseoption
GOSUB resetmouse                'reset mouse
TYPE scoret             'record type for high score file
 nam AS STRING * 28
 sec AS INTEGER
 rai AS INTEGER
END TYPE
TYPE st         'main field
 id AS STRING * 1       '&hf, " " to "8",
 st AS INTEGER      '0=hidden, 1=mark, 2=?, 4=revealed
END TYPE
TYPE cot        'for storing location of mines
 x AS INTEGER
 y AS INTEGER
END TYPE
DIM s(0 TO maxx - 1, 0 TO maxy - 1) AS st       'squares of main field
DIM upd(0 TO maxx - 1, 0 TO maxy - 1)   'update enable
DIM bak(0 TO maxx - 1, 0 TO maxy - 1) AS STRING * 1     'backup for redo
DIM mloc(0 TO maxmines) AS cot  'location of mines
DIM score(0 TO 2) AS scoret     'high scores

FOR i = 0 TO 2  'defaults
 score(i).nam = "---None---": score(i).sec = 999: score(i).rai = 0
NEXT i
n = 0   'read
GOSUB fileio    'file I/O

level = 0: snd = 0      'defaults

GOSUB initlevel         'in turn calls newgame
PLAY "mbt200l64o1"      'init music
DO      'main loop
 LOCATE yd - cy, cx + 1, 1, 30, 31      'hardware cursor visible
 IF ovis THEN GOSUB showmouse
 DO     'primary input poll loop
  IF (game = 1) AND (elap <> 999) THEN
   tsing = TIMER
   IF tsing < start THEN start = start - 86400  'crossed midnight
   elap = INT(tsing - start)
  END IF
  IF elap <> oelap THEN GOSUB drwclock: oelap = elap: LOCATE yd - cy, cx + 1, 1, 30, 31
  IF mousepref THEN             'Beginning of mouse poll section
   cd.axv = 3        'get status
   GOSUB accessmouse
   cd.bxv = cd.bxv AND 3 'button mask
   cd.dxv = (cd.dxv \ 8): cd.cxv = cd.cxv \ 16  '40x25 grid
   n = cd.bxv   'backup button data incase of intervening mouse access
   IF (cd.dxv < yd) AND (cd.cxv < xd) THEN      'is inside area?
    IF (ocx <> cd.cxv) OR (odx <> cd.dxv) THEN  'did it move?
     cx = cd.cxv: cy = (yd - 1) - cd.dxv        'move cursor
     LOCATE yd - cy, cx + 1, 1, 30, 31  'display hardware cursor
    END IF
    ocx = cd.cxv: odx = cd.dxv  'save mouse pos to detect motion next time
    IF visible THEN GOSUB hidemouse     'mouse off
   ELSE
    ocx = cd.cxv: odx = cd.dxv  'save mouse pos to detect motion next time
    IF NOT visible THEN GOSUB showmouse 'mouse on
   END IF
   IF (obx AND 1) < (n AND 1) THEN      'left click
    LOCATE , , 0        'hide hardware cursor
    GOSUB reveal        'same as space bar
    LOCATE yd - cy, cx + 1, 1, 30, 31   'hardware cursor visible
   ELSEIF (obx AND 2) < (n AND 2) THEN  'right click
    LOCATE , , 0         'hide hardware cursor
    GOSUB togglemark    'same as enter
    LOCATE yd - cy, cx + 1, 1, 30, 31   'hardware cursor visible
   END IF
   obx = n      'save button state to detect change next time
  END IF        'End of mouse poll section
  k$ = INKEY$
 LOOP UNTIL LEN(k$)
 ovis = visible
 IF visible THEN GOSUB hidemouse        'to prevent graphical corruption
 LOCATE , , 0           'hide hardware cursor
 IF LEN(k$) < 2 THEN
  SELECT CASE ASC(k$)
  CASE &H1B: EXIT DO    'ESC exits
  CASE &HD: GOSUB togglemark    'enter triggers togglemark, same as right click
  CASE &H20: GOSUB reveal       'space triggers reveal, same as left click
  CASE &H53, &H73: snd = NOT snd: GOSUB drwsnd
  CASE ELSE: GOSUB help
  END SELECT
 ELSE
  SELECT CASE ASC(RIGHT$(k$, 1))
  CASE &H3C: GOSUB newgame      'F2 = new game
  CASE &H44: GOSUB clevel       'F10 = new level
  CASE &H48: cy = cy + 1: IF cy = yd THEN cy = 0
  CASE &H4B: cx = cx - 1: IF cx = -1 THEN cx = cx + xd
  CASE &H4D: cx = cx + 1: IF cx = xd THEN cx = 0
  CASE &H50: cy = cy - 1: IF cy = -1 THEN cy = cy + yd
  CASE ELSE: GOSUB help
  END SELECT
 END IF
LOOP
GOSUB thechamps
SYSTEM          'termination

togglemark:     'toggles normal, flag, "?". Right click mouse event.
 IF s(cx, cy).st XOR 4 THEN     'must not be already visible
  IF enableq THEN       'allow "?"
   s(cx, cy).st = s(cx, cy).st + 1
   IF s(cx, cy).st = 3 THEN s(cx, cy).st = 0
  ELSE                  'disallow "?"
   s(cx, cy).st = s(cx, cy).st XOR 1
   IF s(cx, cy).st = 0 THEN nmarks = nmarks + 1
  END IF
  LOCATE yd - cy, cx + 1
  SELECT CASE s(cx, cy).st
  CASE 0: COLOR 3, 0: PRINT CHR$(&HFA); : IF snd THEN PLAY "g"
  CASE 1: COLOR 4, 0: PRINT CHR$(&HB8); : nmarks = nmarks - 1: IF snd THEN PLAY "e"
  CASE 2: COLOR 1, 5: PRINT "?"; : nmarks = nmarks + 1: IF snd THEN PLAY "a"
  END SELECT
  GOSUB drwminen        'update the number display
 END IF
RETURN

reveal: 'reveals a square or series of squares. Left click mouse event.
 IF (s(cx, cy).st AND 5) = 0 THEN       'not flagged or already revealed
  IF sx = -1 THEN sx = cx: sy = C: GOSUB setfld 'is it the start of the game?
  SELECT CASE ASC(s(cx, cy).id)
  CASE &HF      'You are dead!!!
   IF snd THEN PLAY "l16e.c<a.>l64"
   s(cx, cy).st = 4
   upd(cx, cy) = -1
   GOSUB updscr
   COLOR 15, 1: LOCATE 25, 32: PRINT "Redo?";   'Solitaire's recommendation.
   DO
    k$ = LCASE$(INKEY$)
    SELECT CASE k$
    CASE CHR$(&H1B): GOSUB thechamps: SYSTEM    'ESC, termination
    CASE "y": GOSUB redo: EXIT DO       'redo game
    CASE "n", MKI$(&H3C00)      '"N" or F2
     LOCATE 25, 32: PRINT SPACE$(5);
     FOR x = 0 TO xd - 1        'check for incorrect flags
      FOR y = 0 TO yd - 1
       IF (s(x, y).st = 1) AND (s(x, y).id <> CHR$(&HF)) THEN
        COLOR 28, 0: LOCATE yd - y, x + 1: PRINT "X"; 'what's wrong with you?
       END IF
      NEXT y
     NEXT x
     FOR i = 0 TO nmines - 1    'reveal flags
      IF s(mloc(i).x, mloc(i).y).st <> 1 THEN
       COLOR 31, 0: LOCATE yd - mloc(i).y, mloc(i).x + 1: PRINT CHR$(&HF);
      END IF
     NEXT i
     SLEEP: WHILE INKEY$ <> "": WEND    'pause
     GOSUB newgame: EXIT DO     'new game
    END SELECT
   LOOP
  CASE &H20     'blank squares cascade to nearby squares
   IF snd THEN PLAY "ce"
   s(cx, cy).st = 8     'temporary mark
   bx = cx: by = cy: ex = cx: ey = cy   'start the work here
   DO
    n = 0       'assume done
    FOR x = bx TO ex    'progressively larger bounderies for efficient looping
     FOR y = by TO ey
      IF s(x, y).st AND 8 THEN  'this blank was found in previous loop or is first square
       s(x, y).st = 4: nlef = nlef - 1: upd(x, y) = -1  'finalize previous finds
       FOR i = 0 TO 7   'loop through adjacent possibilities
        SELECT CASE i
        CASE 0: tx = x - 1: ty = y
        CASE 1: tx = x + 1: ty = y
        CASE 2: tx = x: ty = y - 1
        CASE 3: tx = x: ty = y + 1
        CASE 4: tx = x - 1: ty = y - 1
        CASE 5: tx = x + 1: ty = y + 1
        CASE 6: tx = x + 1: ty = y - 1
        CASE 7: tx = x - 1: ty = y + 1
        END SELECT
        IF (tx >= 0) AND (ty >= 0) AND (tx < xd) AND (ty < yd) THEN 'bounds
         IF (s(tx, ty).st AND &HD) = 0 THEN 'check if already revealed, marked, flagged
          IF s(tx, ty).id = " " THEN    'is blank?
           s(tx, ty).st = 8: n = -1     'cascade some more, temp mark, will be finilized in next loop
           IF (tx < bx) AND (bx > 0) THEN bx = bx - 1   'broaden scope
           IF (ty < by) AND (by > 0) THEN by = by - 1
           IF (tx > ex) AND (ex < (xd - 1)) THEN ex = ex + 1
           IF (ty > ey) AND (ey < (yd - 1)) THEN ey = ey + 1
          ELSE  'not blank
           s(tx, ty).st = 4: nlef = nlef - 1: upd(tx, ty) = -1  'border, finilize now
          END IF
         END IF
        END IF
       NEXT i   'end of adjacent possibility loop
      END IF
     NEXT y
    NEXT x      'end of marked square handler loops
   LOOP WHILE n 'loop until done. end of multiple-pass loop
  CASE ELSE     'regular numbered square
   IF snd THEN PLAY "c"
   s(cx, cy).st = 4: upd(cx, cy) = -1: nlef = nlef - 1  'regular
  END SELECT
  GOSUB updscr  'update predetermined squares
  GOSUB drwlef
  IF nlef = 0 THEN      'victory condition
   IF snd THEN PLAY "l16a.>df.<l64"
   COLOR 15, 1: LOCATE 25, 32: PRINT "VICTORY!";
   SLEEP: WHILE INKEY$ <> "": WEND
   IF level <= 2 THEN
    IF elap < score(level).sec THEN     'high score condition
     IF snd THEN PLAY "p1l4a.a>e.<l64"
     COLOR 15, 1: CLS
     PRINT "High score!"
     PRINT "Previous champion:"
     PRINT "'"; score(level).nam; "',"
     PRINT "with"; score(level).sec; "seconds."
     PRINT
     PRINT "You won in"; elap; "seconds."
     PRINT "Num of broken records in this level now:";
     IF score(level).rai < &H7FFF THEN score(level).rai = score(level).rai + 1
     PRINT score(level).rai
     PRINT
     PRINT "(28 chars) Enter your name."
     LINE INPUT "? "; score(level).nam
     score(level).sec = elap
     n = -1     'write
     GOSUB fileio       'file I/O
    END IF
   END IF
   GOSUB newgame        'new game
  END IF
 END IF
RETURN

redo:   'Restart this game. calls initscr and reveal
 FOR x = 0 TO xd - 1
  FOR y = 0 TO yd - 1
   s(x, y).id = bak(x, y)       'restore from backup
   s(x, y).st = 0       'clear status
   upd(x, y) = 0
  NEXT y
 NEXT x
 nlef = (xd * yd) - nmines
 nmarks = nmines
 cx = sx: cy = sy
 GOSUB initscr  'initialize screen
 GOSUB reveal           'reveal initial square, same square as on first attempt
 elap = 999     'second attempts are not timed and never get a high score.
 game = 2
RETURN

updscr:         'updates predetermined squares. Not to be used for flags or "?"s
 FOR x = 0 TO xd - 1
  FOR y = 0 TO yd - 1
   IF upd(x, y) THEN    'has it been marked for an update?
    LOCATE yd - y, x + 1
    IF s(x, y).st AND 4 THEN
     SELECT CASE ASC(s(x, y).id)
     CASE &H20: COLOR 3, 0
     CASE &H31: COLOR 9, 0
     CASE &H32: COLOR 10, 0
     CASE &H33: COLOR 12, 0
     CASE &H34: COLOR 11, 0
     CASE &H35: COLOR 14, 0
     CASE &H36: COLOR 11, 0
     CASE &H37: COLOR 13, 0
     CASE &H38: COLOR 15, 0
     CASE &HF: COLOR 31, 0
     END SELECT
     PRINT s(x, y).id;
    ELSE
     COLOR 3, 0: PRINT CHR$(&HFA);      'unrevealed square
    END IF
    upd(x, y) = 0       'unmark
   END IF
  NEXT y
 NEXT x
RETURN

newgame:        'starts a new game, calls initscr
 IF snd THEN PLAY "l64<ado6ado1l64"
 cx = 0: cy = 0
 nlef = (xd * yd) - nmines      'number of good squares left
 nmarks = nmines        'number of unused flags
 game = 0        '0=reset; 1=in play; 2=redo
 elap = 0
 oelap = 999
 sx = -1        'starting square yet unchosen, game is not in play
 GOSUB initscr  'initialize screen
 FOR x = 0 TO xd - 1
  FOR y = 0 TO yd - 1
   s(x, y).st = 0       'clear status
  NEXT y
 NEXT x
 'the board is not set yet. That will happen when user chooses first square.
RETURN

initscr: 'this is resposible for setting up the initial screen
 WIDTH 40, 25: COLOR 7, 1: CLS
 VIEW PRINT 1 TO 25
 COLOR 3, 0
 LOCATE 1, 1
 FOR y = yd TO 1 STEP -1
  PRINT STRING$(xd, &HFA);
  IF yd - y < 24 THEN PRINT
  FOR x = 0 TO xd - 1
   upd(x, y - 1) = 0
  NEXT x
 NEXT y
 GOSUB drwclock
 GOSUB drwminen
 GOSUB drwsnd
 GOSUB drwlef
 LOCATE 4, 39: COLOR 14, 1: PRINT CHR$(2);      'decorative happy face
 LOCATE 10, 39: COLOR 7, 1
 SELECT CASE level
 CASE 0: PRINT "B";
 CASE 1: PRINT "I";
 CASE 2: PRINT "E";
 CASE 3: PRINT "C";
 END SELECT
RETURN

drwsnd:         'draws sound status indicator
 LOCATE 8, 39: COLOR 7, 1: IF snd THEN PRINT CHR$(&HE);  ELSE PRINT ; " ";
RETURN

drwlef:         'draws number of non-mine squares remaining. victory is when # reaches 0
 LOCATE 12, 38: COLOR 9, 1
 t = LTRIM$(STR$(nlef))
 t = STRING$(3 - LEN(t), "0") + t
 PRINT t;
RETURN

drwclock:       'draws the clock. this may be called while mouse is visible
 ovis = visible
 IF visible THEN GOSUB hidemouse        'to prevent graphical corruption
 LOCATE 2, 37, 0
 COLOR 12, 0
 t = LTRIM$(STR$(elap))
 t = STRING$(3 - LEN(t), "0") + t
 PRINT t;
 IF ovis THEN GOSUB showmouse
RETURN

drwminen:       'draws number of mines - flags used
 COLOR 12, 0
 t = LTRIM$(STR$(ABS(nmarks)))
 t = STRING$(3 - LEN(t), "0") + t
 IF nmarks < 0 THEN t = "-" + t ELSE t = " " + t
 LOCATE 6, 36: PRINT t;
RETURN

setfld: 'this is responsible for initing the playing field for new game
 'this is called when the user chooses his first square on a blank board. The
 'mines are laid and the clock starts after the first square has been chosen.
 sx = cx: sy = cy       'save start position for redo
 FOR x = 0 TO xd - 1    'clear board
  FOR y = 0 TO yd - 1
   s(x, y).id = " "
   s(x, y).st = 0
  NEXT y
 NEXT x
 FOR i = 0 TO nmines - 1        'place mines
  DO
   x = INT(RND * xd): y = INT(RND * yd)
  LOOP UNTIL (s(x, y).id = " ") AND ((sx <> x) OR (sy <> y))
  s(x, y).id = CHR$(&HF)
  mloc(i).x = x: mloc(i).y = y  'store location
 NEXT i
 FOR i = 0 TO nmines - 1        'mines affect adjacent squares
  FOR x = mloc(i).x - 1 TO mloc(i).x + 1
   FOR y = mloc(i).y - 1 TO mloc(i).y + 1
    IF (x >= 0) AND (x < xd) THEN
     IF (y >= 0) AND (y < yd) THEN      'bounds
      SELECT CASE ASC(s(x, y).id)       'increment #
      CASE &H20: s(x, y).id = "1"
      CASE &H30 TO &H37: s(x, y).id = CHR$(ASC(s(x, y).id) + 1)
      END SELECT
     END IF
    END IF
   NEXT y
  NEXT x
 NEXT i
 FOR x = 0 TO xd - 1    'backup field for redo
  FOR y = 0 TO yd - 1
   bak(x, y) = s(x, y).id
  NEXT y
 NEXT x
 game = 1       'game is in play
 start = TIMER  'mark start time
RETURN

initlevel:      'default values for standard levels. Conforms to Minesweeper.
 SELECT CASE level
 CASE 0: xd = 8: yd = 8: nmines = 10    'begginer
 CASE 1: xd = 16: yd = 16: nmines = 40  'intermediate
 CASE 2: xd = 30: yd = 16: nmines = 99  'expert
 END SELECT
 GOSUB newgame          'start newgame
RETURN

fileio:         'reads/writes the high score file
 PRINT "Opening score file: '"; file; "'."
 OPEN file FOR BINARY AS 1
 i = LOF(1)
 IF (i > 0) AND (i <> 96) THEN
  PRINT "Important file overwrite protection feature:"
  PRINT "File size is not 96 bytes. Please verify that file is not critical."
  PRINT "If not, erase the file. If so, change either the current directory, or the"
  PRINT "'file' constant within the program."
  PRINT "Size:"; i; "Expected: 96."
  CLOSE
  SYSTEM
 END IF
 IF (i = 0) OR n THEN
  PRINT "Creating new score file."
  FOR i = 0 TO 2: PUT 1, (i * 32) + 1, score(i): NEXT i
 ELSE
  PRINT "Reading score data."
  FOR i = 0 TO 2: GET 1, (i * 32) + 1, score(i): NEXT i
 END IF
 CLOSE
 PRINT "Done."
RETURN

clevel:         'user chooses a level
 WIDTH 80, 25
 COLOR 7, 1: CLS
 PRINT "Level:", "X dim:", "Y dim:", "Mines:"
 PRINT "Begginer", "8", "8", "10"
 PRINT "Intermediate", "16", "16", "40"
 PRINT "Expert", "30", "16", "99"
 PRINT "Custom", "?", "?", "?"
 PRINT
 PRINT "B/I/E/C ? ";
 DO
  k$ = UCASE$(INKEY$)
  SELECT CASE k$
  CASE CHR$(&H1B): GOSUB thechamps: SYSTEM
  CASE "B": level = 0
  CASE "I": level = 1
  CASE "E": level = 2
  CASE "C": level = 3
  CASE ELSE: k$ = ""
  END SELECT
 LOOP UNTIL LEN(k$)
 PRINT k$
 IF level <= 2 THEN GOSUB initlevel: RETURN     'premature exit
        'level is 3
 PRINT
 INPUT "X"; xd
 INPUT "Y"; yd
 INPUT "Mines"; nmines
 IF xd < minx THEN xd = minx    'limits
 IF xd > maxx THEN xd = maxx
 IF yd < miny THEN yd = miny
 IF yd > maxy THEN yd = maxy
 IF nmines < minmines THEN nmines = minmines
 IF nmines > maxmines THEN nmines = maxmines
 GOSUB newgame          'starts a newgame
RETURN

help:   'also acts as a pause
 SCREEN , , 1, 1        'use video page 1
 COLOR 11, 1: CLS
 IF game = 1 THEN PRINT "Game paused.": PRINT
 PRINT "ESC - quit"
 PRINT "S - toggle sound"
 PRINT "F2 - new game"
 PRINT "F10 - select level and start new game"
 PRINT "SPACE / left-click - uncover square"
 PRINT "ENTER / right-click - toggle normal/flag/'?'"
 PRINT "Arrows / mouse motion - move cursor"
 PRINT
 PRINT
 PRINT "Need more help? Found a bug? Want to"
 PRINT "comment? Please contact me via the"
 PRINT "'Classic' forum at:"
 PRINT "http://www.qbasic.com/"
 PRINT ", or email me at:"
 PRINT "mcalkins0"; "@"; "hotmail.com"
 SLEEP: WHILE INKEY$ <> "": WEND
 SCREEN , , 0, 0        'use page 0
 start = TIMER - elap   'unpause. The user may gain a fraction of a second, but
 'it will take him that long to orient himself.
RETURN

thechamps:      'displayed before normal (non-error) termination.
 WIDTH 80, 25: COLOR 7, 0: CLS
 COLOR 15, 6: PRINT "PeanutWare"; : COLOR 11, 0
 PRINT " mcalkins0"; "@"; "hotmail.com": COLOR 7, 0
 PRINT "Programming by Michael Calkins. Thank you for playing this freeware game."
 PRINT "Win NT/2000/XP compatible mouse routine donated by The PhyloGenesis. Thanks."
 PRINT
 PRINT "If you use Windows NT/2000/XP and have trouble with the mouse, try setting the"
 PRINT "'mouseoption' constant to 2."
 PRINT
 PRINT "This game was tested using QBASIC 1.1 on MS-DOS 7.1, Win 95b, and Win 98SE."
 PRINT "This game was tested using QBASIC 1.0 on IBM OS/2 Warp 3."
 PRINT
 COLOR 10, 1
 PRINT "---The Champions---"
 n = CSRLIN
 COLOR 11, 0
 PRINT "Beginner:": PRINT "Intermediate:": PRINT "Expert"
 FOR i = 0 TO 2
  LOCATE i + n, 16: COLOR 15, 1: PRINT score(i).nam, ; : COLOR 11, 1
  t = STR$(score(i).sec): t = SPACE$(4 - LEN(t)) + t
  PRINT t; " seconds."; : COLOR 9, 0: PRINT score(i).rai
 NEXT i
 COLOR 7, 0
 PRINT
RETURN

accessmouse:    'accesses the mouse, using either of the routines
 IF NOT cd.s THEN WIDTH 80, 25: COLOR 7, 0: CLS : PRINT "ERR with codeinit": SYSTEM
 SELECT CASE mousepref
 CASE 1: DEF SEG = VARSEG(cd.code): CALL Absolute(VARPTR(cd.code))      'mine
 CASE 2
  cd.bxv = 0: cd.cxv = 0: cd.dxv = 0: DEF SEG = VARSEG(cd.PG)   'Phylo's
  CALL Absolute(cd.axv, cd.bxv, cd.cxv, cd.dxv, VARPTR(cd.PG))
 END SELECT
 DEF SEG
RETURN

showmouse:      'display mouse cursor
 cd.axv = 1
 GOSUB accessmouse
 visible = -1
RETURN

hidemouse:      'hide mouse cursor
 cd.axv = 2
 GOSUB accessmouse
 visible = 0
RETURN

resetmouse:     'resets mouse
 cd.axv = 0
 GOSUB accessmouse
 IF NOT cd.axv THEN mousepref = 0 'no mouse? (borrowed from Phylo's code)
 obx = 0: ocx = o: odx = 0
RETURN

initmousecode:          'loads both mouse routines
 PRINT "Loading mouse routines"

' ;Written by Michael Calkins
' ;this routine has been tested on and fine on the following operating systems:
' ;MS-DOS 7.1, MS Windows 95b, MS Windows 98SE, IBM OS/2 Warp 3
'A1????        MOV     AX,[axv]
'CD33          INT     33
'A3????        MOV     [axv],AX
'890E????      MOV     [cxv],CX
'8916????      MOV     [dxv],DX
'891E????      MOV     [bxv],BX
'CB            RETF

 t$ = ""        'my routine incorporates memory offsets at runtime
 t$ = t$ + CHR$(&HA1) + MKI$(VARPTR(cd.axv))'MOV AX,[axv]
 t$ = t$ + CHR$(&HCD) + CHR$(&H33)'INT 33
 t$ = t$ + CHR$(&HA3) + MKI$(VARPTR(cd.axv))'MOV [axv],AX
 t$ = t$ + CHR$(&H89) + CHR$(&HE) + MKI$(VARPTR(cd.cxv))'MOV [cxv],CX
 t$ = t$ + CHR$(&H89) + CHR$(&H16) + MKI$(VARPTR(cd.dxv))'MOV [dxv],DX
 t$ = t$ + CHR$(&H89) + CHR$(&H1E) + MKI$(VARPTR(cd.bxv))'MOV [bxv],BX
 t$ = t$ + CHR$(&HCB)'RETF
 IF LEN(t$) <> LEN(cd.code) THEN PRINT "ERROR with initcd": SYSTEM
 cd.code = t$
 FOR i = 1 TO 57        'Phylo's is static
  MID$(cd.PG, i, 1) = CHR$(VAL("&h" + MID$(PhyloGenesis, (i * 2) - 1, 2)))
 NEXT i
 cd.s = -1

'functions 0 to 3:
'0, "Reset mouse and get status"
'1, "Show mouse pointer"
'2, "Hide mouse pointer"
'3, "Get mouse position and button status"
 PRINT "Done."
RETURN


    
This message has been edited by MCalkins on Nov 16, 2005 12:03 AM


 
 Respond to this message   
Response TitleAuthorDate
 *Great little game, Michael.TheBOBNov 19, 2005
  *Thanks.Michael CalkinsNov 19, 2005
 Copyright © 1999-2014 Network54. All rights reserved.   Terms of Use   Privacy Statement