Author Topic: Hexagon Minesweeper wCustomize Field  (Read 76 times)

B+

  • Hero Member
  • *****
  • Posts: 847
    • View Profile
Hexagon Minesweeper wCustomize Field
« on: 14. August 2019, 15:33:19 »
Try this version of Minesweeper from QB64, it's a blast.
(Even better with sound effects but the zip folder too big to attach here even wo exe, a pity!)
Update: there is a zip file attached here at QB64 forum
https://www.qb64.org/forum/index.php?topic=1558.msg108269#msg108269

QB64 code (that should be fairly easy to modify and add your own sound effects):
Code: [Select]
OPTION _EXPLICIT 'Bplus started 2019-08-08 from quick version of Hex Minesweeper and Minesweeper Custom Field
' Attention: this program creates a file: "Hexagon Minefield Custom Specs.txt"
' that you edit with your text editor, if you select that option in the opening screen menu.

DEFINT A-Z
'to make things easy set cellR as const at 25
CONST cellR = 25 ' which makes the following constant
DIM SHARED xspacing!, yspacing!
xspacing! = 2 * cellR * COS(_D2R(30)): yspacing! = cellR * (1 + SIN(_D2R(30)))

DIM SHARED xmax, ymax, Xarrd, Yarrd, mines 'set all this in customField sub
_TITLE "Hexagon Minesweeper: Custom Field"
customField
_TITLE STR$(mines) + " Minesweeper: left click reveals, right marks red"
SCREEN _NEWIMAGE(xmax, ymax, 32)
_SCREENMOVE (1280 - xmax) / 2 + 60, (760 - ymax) / 2
RANDOMIZE TIMER
TYPE boardType
    x AS SINGLE 'pixel location
    y AS SINGLE 'pixel location
    id AS INTEGER '0 to 6 neighbor mines
    reveal AS INTEGER ' 1 for marked, 0 hidden, -1 for revealed
    mine AS INTEGER '0 or -1
END TYPE
REDIM SHARED b(0 TO Xarrd + 1, 0 TO Yarrd + 1) AS boardType 'oversize the board to make it easy to count mines
DIM SHARED restart
DIM gameOver, cc, cr, mbN, c, r, s$, sz!
restart = 1
WHILE 1
    gameOver = 0
    WHILE gameOver = 0
        IF restart THEN initialize
        mbN = 0
        getCell cc, cr, mbN
        'LOCATE 1, 1: PRINT cc, cr, mbN
        IF mbN = 1 AND b(cc, cr).reveal = 0 THEN
            IF b(cc, cr).mine THEN 'ka boom
                FOR r = 1 TO Yarrd 'show all mines
                    FOR c = 1 TO Xarrd
                        IF b(c, r).mine THEN b(c, r).reveal = -1: showCell c, r
                    NEXT
                NEXT
                s$ = "KA - BOOOMMMM!"
                sz! = 1.2 * xmax / LEN(s$)
                cText xmax / 2, ymax / 2, sz!, &HFF000000, s$
                cText xmax / 2 - 4, ymax / 2 - 4, sz!, &HFFFF0000, s$
                cText xmax / 2 - 8, ymax / 2 - 8, sz!, &HFFFFFF00, s$
                gameOver = -1
                _DELAY 7
            ELSE
                b(cc, cr).reveal = -1: showCell cc, cr
                IF b(cc, cr).id = 0 THEN sweepZeros cc, cr
            END IF
        ELSEIF mbN = 2 THEN
            IF b(cc, cr).reveal = 1 THEN
                b(cc, cr).reveal = 0: showCell cc, cr
            ELSE
                IF b(cc, cr).reveal = 0 THEN b(cc, cr).reveal = 1: showCell cc, cr
            END IF
        END IF
        IF TFwin THEN
            s$ = "Good Job!"
            sz! = 1.2 * xmax / LEN(s$)
            cText xmax / 2, ymax / 2, sz!, &HFF000000, s$
            cText xmax / 2 - 1, ymax / 2 - 2, sz!, &HFF000055, s$
            _DELAY 5
            gameOver = -1
        END IF
        _LIMIT 60
    WEND
    restart = 1
WEND

NoOff:
DATA 1,0,0,-1,0,1,-1,-1,-1,0,-1,1

xOff:
DATA -1,0,0,-1,0,1,1,-1,1,0,1,1

'set all this 'DIM SHARED xmax, ymax, XarrD, YarrD, mines
SUB customField
    DIM fName$, fe, fLine$, p, inCnt, beenHere, allow$, choice$

    fName$ = "Hexagon Minefield Custom Specs.txt"
    IF _FILEEXISTS(fName$) THEN fe = -1 ELSE fe = 0
    allow$ = "12" + CHR$(27)
    PRINT
    PRINT "     Hexagom Minesweeper options:"
    PRINT
    PRINT "  1. Use mine field settings: 10 X 10 cells and 10 mines."
    PRINT "  2. Customize your own field settings."
    IF fe THEN PRINT "  3. Use the last customized mine field settings.": allow$ = allow$ + "3"
    PRINT
    PRINT "     or press esc to quit."
    choice$ = getChar$(allow$)
    SELECT CASE choice$
        CASE "1": xmax = 800: ymax = 600: Xarrd = 10: Yarrd = 10: mines = 10
        CASE "2": GOSUB editCustom
        CASE "3": GOSUB loadCustom
        CASE ELSE: SYSTEM
    END SELECT
    xmax = (Xarrd + 2.5) * xspacing!: ymax = (Yarrd + 2) * yspacing!
    EXIT SUB

    editCustom:
    IF fe = 0 THEN
        OPEN fName$ FOR OUTPUT AS #1
        PRINT #1, " "
        PRINT #1, "          Custom Field Specs For Your Hexagon Minesweeper Game"
        PRINT #1, " "
        PRINT #1, " We will be sizing the screen according to a constant cell radius of 25"
        PRINT #1, " and then numbers filled in here."
        PRINT #1, " "
        PRINT #1, " Please fill out the right side of all Equal signs."
        PRINT #1, " "
        PRINT #1, "   X dimensions across the screen:"
        PRINT #1, "         Your Max Screen Width (pixels) = "
        PRINT #1, "      Number of Horizontal Cells Across = "
        PRINT #1, " "
        PRINT #1, "   Y dimensions going down:"
        PRINT #1, "        Your Max Screen Height (pixels) = "
        PRINT #1, "                   Number of Cells Down = "
        PRINT #1, " "
        PRINT #1, "The percent of mines (8 easy - 15 hard) = "
        PRINT #1, " "
        PRINT #1, "    To finish, Save the file and then close the editor."
        CLOSE #1
    END IF
    ' I picked up this shortcut from Ken, normally I would call a text editor that I don't know if you have!
    SHELL fName$
    GOSUB loadCustom
    RETURN

    loadCustom:
    beenHere = beenHere + 1 'we'll give it 5 tries
    IF beenHere > 5 THEN
        PRINT "OK we tried 5 times, going with default settings..."
        xmax = 800: ymax = 600: Xarrd = 10: Yarrd = 10: mines = 10
        RETURN
    END IF
    inCnt = 0
    OPEN fName$ FOR INPUT AS #1
    WHILE EOF(1) = 0 ' look to get 5 values from 5 = signs
        LINE INPUT #1, fLine$
        'PRINT fLine$
        p = INSTR(fLine$, "=")
        IF p > 0 THEN
            inCnt = inCnt + 1
            SELECT CASE inCnt
                CASE 1: xmax = VAL(rightOf$(fLine$, "="))
                CASE 2: Xarrd = VAL(rightOf$(fLine$, "="))
                CASE 3: ymax = VAL(rightOf$(fLine$, "="))
                CASE 4: Yarrd = VAL(rightOf$(fLine$, "="))
                CASE 5: mines = VAL(rightOf$(fLine$, "=")) * Xarrd * Yarrd / 100
            END SELECT
            IF inCnt = 5 THEN EXIT WHILE
        END IF
    WEND
    CLOSE #1
    IF inCnt = 5 THEN 'alternate exit from gosub
        IF xmax >= (Xarrd + 2.5) * xspacing! THEN
            IF ymax < (Yarrd + 2) * yspacing! THEN 'all good
                PRINT "Opps, Screen height is not big enough for Y cells down."
            ELSE
                RETURN
            END IF
        ELSE
            PRINT "Opps, Screen width is not big enough for X cells across."
        END IF
    ELSE
        PRINT "We did not get everything filled out by = signs."
    END IF
    PRINT: PRINT "Press any to continue.. "
    SLEEP
    SHELL fName$
    GOTO loadCustom
END SUB

SUB initialize ()
    DIM minesPlaced, rx, ry, x, y, nMines, xoffset!
    CLS
    restart = 0
    REDIM b(0 TO Xarrd + 1, 0 TO Yarrd + 1) AS boardType
    minesPlaced = 0
    WHILE minesPlaced < mines
        rx = INT(RND * Xarrd) + 1: ry = INT(RND * Yarrd) + 1
        IF b(rx, ry).mine = 0 THEN
            b(rx, ry).mine = -1: minesPlaced = minesPlaced + 1
        END IF
    WEND
    'count mines amoung the neighbors
    FOR y = 1 TO Yarrd
        IF y MOD 2 = 0 THEN xoffset! = .5 * xspacing! ELSE xoffset! = 0
        FOR x = 1 TO Xarrd
            IF b(x, y).mine <> -1 THEN 'not already a mine
                '2 sets of neighbors depending if x offset or not
                IF xoffset! > .1 THEN
                    nMines = b(x - 1, y).mine + b(x, y - 1).mine + b(x, y + 1).mine
                    nMines = nMines + b(x + 1, y - 1).mine + b(x + 1, y).mine + b(x + 1, y + 1).mine
                ELSE
                    nMines = b(x + 1, y).mine + b(x, y - 1).mine + b(x, y + 1).mine
                    nMines = nMines + b(x - 1, y - 1).mine + b(x - 1, y).mine + b(x - 1, y + 1).mine
                END IF
                b(x, y).id = -nMines
            ELSE
                b(x, y).id = 0
            END IF
            b(x, y).x = x * xspacing! + xoffset! + .5 * xspacing!
            b(x, y).y = y * yspacing! + .5 * yspacing!
            b(x, y).reveal = 0
            showCell x, y
        NEXT
    NEXT
END SUB

SUB showCell (c, r)
    DIM da, x!, y!, lastx!, lasty!, clr AS _UNSIGNED LONG
    SELECT CASE b(c, r).reveal
        CASE -1: IF b(c, r).mine THEN clr = &HFF883300 ELSE clr = &HFFFFFFFF 'revealed  white with number of mine neighbors
        CASE 0: clr = &HFF008800 'hidden green
        CASE 1: clr = &HFFFF0000 'marked red
    END SELECT
    lastx! = b(c, r).x + cellR * COS(_D2R(-30))
    lasty! = b(c, r).y + cellR * SIN(_D2R(-30))
    FOR da = 30 TO 330 STEP 60
        x! = b(c, r).x + cellR * COS(_D2R(da))
        y! = b(c, r).y + cellR * SIN(_D2R(da))
        LINE (lastx!, lasty!)-(x!, y!), &HFFFF00FF
        lastx! = x!: lasty! = y!
    NEXT
    PAINT (b(c, r).x, b(c, r).y), clr, &HFFFF00FF
    IF b(c, r).reveal = -1 THEN
        'cText b(c, r).x, b(c, r).y, 15, &HFF000000, _TRIM$(STR$(c)) + "," + _TRIM$(STR$(r))
        IF b(c, r).id > 0 THEN cText b(c, r).x, b(c, r).y, 35, &HFF000000, _TRIM$(STR$(b(c, r).id))
        IF b(c, r).mine = -1 THEN cText b(c, r).x, b(c, r).y, 35, &HFFFFFFFF, "*"
    END IF
END SUB

FUNCTION TFwin
    DIM c, x, y
    FOR y = 1 TO Yarrd
        FOR x = 1 TO Xarrd
            IF b(x, y).reveal = -1 AND b(x, y).mine = 0 THEN c = c + 1
        NEXT
    NEXT
    IF c = Xarrd * Yarrd - mines THEN TFwin = -1
END FUNCTION

SUB getCell (returnCol AS INTEGER, returnRow AS INTEGER, mbNum AS INTEGER)
    DIM m, mx, my, mb1, mb2, r, c
    WHILE _MOUSEINPUT: WEND
    mb1 = _MOUSEBUTTON(1): mb2 = _MOUSEBUTTON(2)
    IF mb1 THEN mbNum = 1
    IF mb2 THEN mbNum = 2
    IF mb1 OR mb2 THEN '                      get last place mouse button was down
        WHILE mb1 OR mb2 '                    wait for mouse button release as a "click"
            m = _MOUSEINPUT: mb1 = _MOUSEBUTTON(1): mb2 = _MOUSEBUTTON(2)
            mx = _MOUSEX: my = _MOUSEY
        WEND
        FOR r = 1 TO Yarrd
            FOR c = 1 TO Xarrd
                IF ((mx - b(c, r).x) ^ 2 + (my - b(c, r).y) ^ 2) ^ .5 < .5 * xspacing! THEN
                    returnCol = c: returnRow = r: EXIT SUB
                END IF
            NEXT
        NEXT
        mbNum = 0 'still here then clicked wrong
    END IF
END SUB

SUB sweepZeros (col, row) ' recursive sweep with Rod's limits set
    DIM c, r, cMin, cMax, rMin, rMax, x, y, id
    c = col: r = row 'get copies for recursive sub
    IF c > 2 THEN cMin = c - 1 ELSE cMin = 1
    IF c < Xarrd - 1 THEN cMax = c + 1 ELSE cMax = Xarrd
    IF r > 2 THEN rMin = r - 1 ELSE rMin = 1
    IF r < Yarrd - 1 THEN rMax = r + 1 ELSE rMax = Yarrd
    FOR y = rMin TO rMax
        FOR x = cMin TO cMax
            IF b(x, y).reveal = 0 THEN
                id = b(x, y).id
                IF b(x, y).mine = 0 AND id = 0 THEN
                    b(x, y).reveal = -1 'mark played
                    showCell x, y
                    sweepZeros x, y
                ELSE
                    IF b(x, y).mine = 0 AND id >= 1 AND id <= 8 THEN
                        b(x, y).reveal = -1
                        showCell x, y
                    END IF
                END IF
            END IF
        NEXT
    NEXT
END SUB

'center the text around (x, y) point, needs a graphics screen!
SUB cText (x, y, textHeight AS SINGLE, K AS _UNSIGNED LONG, txt$)
    DIM fg AS _UNSIGNED LONG, cur&, I&, mult!, xlen
    fg = _DEFAULTCOLOR
    'screen snapshot
    cur& = _DEST
    I& = _NEWIMAGE(8 * LEN(txt$), 16, 32)
    _DEST I&
    COLOR K, _RGBA32(0, 0, 0, 0)
    _PRINTSTRING (0, 0), txt$
    mult! = textHeight / 16
    xlen = LEN(txt$) * 8 * mult!
    _PUTIMAGE (x - .5 * xlen, y - .5 * textHeight)-STEP(xlen, textHeight), I&, cur&
    COLOR fg
    _FREEIMAGE I&
END SUB

FUNCTION rightOf$ (source$, of$)
    IF INSTR(source$, of$) > 0 THEN rightOf$ = MID$(source$, INSTR(source$, of$) + LEN(of$))
END FUNCTION

FUNCTION getChar$ (fromStr$)
    DIM OK AS INTEGER, k$
    WHILE OK = 0
        k$ = INKEY$
        IF LEN(k$) THEN
            IF INSTR(fromStr$, k$) <> 0 THEN OK = -1
        END IF
        _LIMIT 200
    WEND
    _KEYCLEAR
    getChar$ = k$
END SUB


To customize the minefield, I use your editor to fill out a form with your specs if you choose that option at start. The default choice is pretty easy starter to get use to play. (see first attached) I am curious if this works in OS outside Windows, QB64 just runs a txt file through a SHELL command.

Here is the simple Spec form: Hexagom Minefield Custom Specs.txt
Code: [Select]

          Custom Field Specs For Your Hexagon Minesweeper Game
 
 We will be sizing the screen according to a constant cell radius of 25
 and then numbers filled in here.
 
 Please fill out the right side of all Equal signs.
 
   X dimensions across the screen:
         Your Max Screen Width (pixels) = 1280
      Number of Horizontal Cells Across = 25
 
   Y dimensions going down:
        Your Max Screen Height (pixels) = 720
                   Number of Cells Down = 15
 
The percent of mines (8 easy - 15 hard) = 12
 
    To finish, Save the file and then close the editor.

« Last Edit: 14. August 2019, 15:54:18 by B+ »