The QBasic / QB64 Discussion Forum      Other Subforums, Links and Downloads
 
 

 Return to Index  

unfinished "mines".

November 13 2005 at 1:20 AM
Michael Calkins  (Login MCalkins)
R

 
This is a program I started last week, I think. I have been busy with other things since then. I did the mojority of the work today, got impatient, and decided to post now, even though it is not yet finished. I will move it to "Proud" when finished. There are no known bugs, but testing was minimal after the last coding. Got to go, as it is 3:19 AM.
Regards,
Michael

'to do list:
'incorporate sound
'incorporate mouse routines
'confirm minimum limits in Minesweeper and check colors.
'test, debug, optimize

'the following file will act as the high score data file:
CONST file = "mines.dat"

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                  'DOUBLE CHECK MINIMUMS
CONST miny = 8
CONST minmines = 10
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
TYPE scoret
 nam AS STRING * 30
 sec AS INTEGER
END TYPE
TYPE st
 id AS STRING * 1       '&hf, " " to "8",
 st AS INTEGER      '0=hidden, 1=mark, 2=?, 4=revealed
END TYPE
TYPE cot
 x AS INTEGER
 y AS INTEGER
END TYPE
DIM s(0 TO maxx - 1, 0 TO maxy - 1) AS st       'square
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
 score(i).nam = "---None---": score(i).sec = 999
NEXT i
n = 0   'read
GOSUB fileio

level = 0: snd = 0
GOSUB initlevel 'in turn calls newgame
PLAY "mbl16o2"
DO
 'uncomment the following line to cheat in the Begginer level
 'IF level = 0 THEN GOSUB debug

 LOCATE yd - cy, cx + 1, 1      'hardware cursor visible
 DO
  k$ = INKEY$
  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
 LOOP UNTIL LEN(k$)
 LOCATE , , 0           'hide hardware cursor
 IF LEN(k$) < 2 THEN
  SELECT CASE ASC(k$)
  CASE &H1B: WIDTH 80, 25: COLOR 7, 0: CLS : EXIT DO
  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       'sound toggle
   snd = NOT snd: LOCATE 8, 39: COLOR 7, 1
   IF snd THEN
    PRINT CHR$(&HE);
   ELSE
    PRINT " ";
   END IF
  CASE ELSE: GOSUB help
  END SELECT
 ELSE
  SELECT CASE ASC(RIGHT$(k$, 1))
  CASE &H3C: GOSUB newgame      'F2 = new game
  CASE &H44: GOSUB clevel
  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

togglemark:     'toggles normal, flag, "?". Right click mouse event.
 IF s(cx, cy).st XOR 4 THEN
  s(cx, cy).st = s(cx, cy).st + 1
  LOCATE yd - cy, cx + 1
  IF s(cx, cy).st = 3 THEN s(cx, cy).st = 0
  SELECT CASE s(cx, cy).st
  CASE 0: COLOR 3, 0: PRINT CHR$(&HFA);
  CASE 1: COLOR 4, 0: PRINT CHR$(&HB8); : nmarks = nmarks - 1
  CASE 2: COLOR 9, 5: PRINT "?"; : nmarks = nmarks + 1
  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!!!
   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$(27): WIDTH 80, 25: COLOR 7, 0: CLS : GOSUB thechamps: SYSTEM
    CASE "y": GOSUB redo: EXIT DO
    CASE "n"
     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
     GOSUB newgame: EXIT DO
    END SELECT
   LOOP
  CASE &H20     'blank squares cascade to nearby squares
   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
     FOR y = by TO ey
      IF s(x, y).st AND 8 THEN
       s(x, y).st = 4: nlef = nlef - 1: upd(x, y) = -1  'finalize previous finds
       FOR i = 0 TO 7
        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
         IF (s(tx, ty).st AND &HC) = 0 THEN
          IF s(tx, ty).id = " " THEN
           s(tx, ty).st = 8: n = -1     'cascade some more
           IF (tx < bx) AND (bx > 0) THEN bx = bx - 1
           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
           s(tx, ty).st = 4: nlef = nlef - 1: upd(tx, ty) = -1  'border
          END IF
         END IF
        END IF
       NEXT i
      END IF
     NEXT y
    NEXT x
   LOOP WHILE n 'loop until done
  CASE ELSE: s(cx, cy).st = 4: upd(cx, cy) = -1: nlef = nlef - 1 'regular
  END SELECT
  GOSUB updscr  'update predetermined squares
  IF nlef = 0 THEN      'victory condition
   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
     COLOR 15, 1: CLS
     PRINT "High score!"
     PRINT "Previous champion:"
     PRINT "'"; score(level).nam; "'"
     PRINT "with"; score(level).sec; "seconds."
     PRINT "you won in"; elap; "seconds."
     PRINT "(30 chars) Enter your name."
     LINE INPUT "? "; score(level).nam
     score(level).sec = elap
     n = -1     'write
     GOSUB fileio
    END IF
   END IF
   GOSUB newgame        'new game
  END IF
 END IF
RETURN

redo:   'Restart this game. calls initscr and reveal
 GOSUB initscr
 FOR x = 0 TO xd - 1
  FOR y = 0 TO yd - 1
   s(x, y).id = bak(x, y)
   s(x, y).st = 0
   upd(x, y) = 0
  NEXT y
 NEXT x
 nlef = (xd * yd) - nmines
 nmarks = nmines
 cx = sx: cy = sy
 GOSUB reveal
 elap = 999
 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
    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 14, 0
     CASE &H35: COLOR 11, 0
     CASE &H36: COLOR 13, 0
     CASE &H37: COLOR 7, 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);
    END IF
    upd(x, y) = 0
   END IF
  NEXT y
 NEXT x
RETURN

newgame:        'starts a new game, calls initscr
 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
 FOR x = 0 TO xd - 1
  FOR y = 0 TO yd - 1
   s(x, y).st = 0
  NEXT y
 NEXT x
RETURN

initscr: 'this is resposible for setting up the initial screen
 WIDTH 40, 25: COLOR 7, 1: CLS
 COLOR 3, 0
 LOCATE 1, 1
 FOR y = yd TO 1 STEP -1
  PRINT STRING$(xd, &HFA)
  FOR x = 0 TO xd - 1
   upd(x, y - 1) = 0
  NEXT x
 NEXT y
 GOSUB drwclock
 GOSUB drwminen
 LOCATE 4, 40: COLOR 14, 1: PRINT CHR$(2);
 LOCATE 10, 40: 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

drwclock:       'draws the clock
 COLOR 12, 0
 t = LTRIM$(STR$(elap))
 t = STRING$(3 - LEN(t), "0") + t
 LOCATE 2, 38: PRINT t;
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, 37: 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
      SELECT CASE ASC(s(x, y).id)
      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

debug:  'this helped me debug the code, but can be used to cheat
 COLOR 7, 0
 FOR y = 7 TO 0 STEP -1
  LOCATE 8 - y, 20      'beginner level only
  FOR x = 0 TO 7
   PRINT s(x, y).id;
  NEXT x
 NEXT y
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
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 <> 98) THEN
  PRINT "Important file overwrite protection feature:"
  PRINT "File size is not 98 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."
  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).nam: NEXT i
  i = &HFFFF
  PUT 1, 97, i  'File didn't act right ending in null
 ELSE
  PRINT "Reading score data."
  FOR i = 0 TO 2: GET 1, (i * 32) + 1, score(i).nam: 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$(27): COLOR 7, 0: CLS : GOSUB thechamps: SYSTEM
  CASE "B": level = 0
  CASE "I": level = 1
  CASE "E": level = 2
  CASE "C": level = 4
  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
 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
RETURN

help:   'also acts as a pause
 SCREEN , , 1, 1        'use 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
RETURN

thechamps:      'displayed before normal termination.
 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 "This program runs best under DOS, Windows 3.1x/95/98/ME, or OS/2."
 PRINT
 COLOR 15, 1
 PRINT "---The Champions---"
 PRINT "Beginner:", "'"; score(0).nam; "',"; score(0).sec; "seconds."
 PRINT "Intermediate:", "'"; score(1).nam; "',"; score(1).sec; "seconds."
 PRINT "Expert:", "'"; score(2).nam; "',"; score(2).sec; "seconds."
 COLOR 7, 0
 PRINT
RETURN

 
 Respond to this message   
Response TitleAuthor and Date
*current ver is in "Proud"Michael Calkins on Nov 14
 Copyright © 1999-2014 Network54. All rights reserved.   Terms of Use   Privacy Statement  

Newbies usually go to www.qbasic.com and click on The QBasic Forum
Forum regulars have their own ways, which include The QBasic Community Forums