Author Topic: Hexagon Minesweeper by bplus  (Read 913 times)

0 Members and 1 Guest are viewing this topic.

Offline Qwerkey

  • Moderator
  • Forum Resident
  • Posts: 736
Hexagon Minesweeper by bplus
« on: May 17, 2020, 09:59:01 AM »
Hexagon Minesweeper

Author: @bplus
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=1558.msg128396#msg128396
Version: v3.1W Crater 2021-01-19 update
Tags: [Graphics], [2D], [Audio]

Description:
I have a new and improved Hexagonal Minesweeper. I was challenged to add particle explosion at SmallBASIC board at Syntax Bomb forum. Couldn't help myself, I tweaked Crater Maker some more to scale to board size and closer fit to Bomb sound.  PS the exe is for Windows 64

Controls:
Right & Left Mouse Buttons

Source Code:
Code: QB64: [Select]
  1. OPTION _EXPLICIT 'Bplus started 2019-08-08 from quick version of Hex Minesweeper and Minesweeper Custom Field
  2. ' 2021-01-19 update move all ogg files into separate sub folder  for Windows users
  3. '============================================================================================================
  4. '
  5. '         Hex Minesweeper v3.1W: Field Customization, Sound Effects and mod Crater Maker!
  6. '
  7. '                                      bplus mod 2021-01-19
  8. '=============================================================================================================
  9.  
  10. ' Attention: this program creates a file: "Hexagon Minefield Custom Specs.txt"
  11. ' that you edit with your text editor, if you select that option in the opening screen menu.
  12.  
  13. ' 2019-08-13 Hex Minesweeper Custom and Sound.bas add ogg file sound effects
  14. '   Public domain .ogg files source
  15. '   https://bigsoundbank.com/detail-0029-computer-mouse.html
  16. '   and bomb #6: https://www.mediacollege.com/downloads/sound-effects/explosion/
  17.  
  18. '2020-02-09 adding Crater Maker effect I devloped for SmallBASIC 2020-02-08 should work even better with QB64.
  19. '                                      It does indeed!!!!
  20. '
  21. '2020-02-10 refined Crater Maker to scale to board size and Bombsound time of blast
  22. '
  23.  
  24. DEFINT A-Z
  25. CONST P2 = 6.28318531
  26. 'to make things easy set cellR as const at 25
  27. CONST cellR = 25 ' which makes the following constant
  28. DIM SHARED xspacing!, yspacing!
  29. xspacing! = 2 * cellR * COS(_D2R(30)): yspacing! = cellR * (1 + SIN(_D2R(30)))
  30. DIM SHARED xmax, ymax, Xarrd, Yarrd, mines 'set all this in customField sub
  31.  
  32. 'sound events
  33. DIM SHARED ToggleSnd AS LONG, BombSnd AS LONG, ApplauseSnd AS LONG, openSnd AS LONG
  34. DIM SHARED SwooshSnd AS LONG
  35.  
  36. _TITLE "Hexagon Minesweeper v3.1W: Customize, Sound Effects and now Crater Maker"
  37. DIM ogg$
  38. ogg$ = "Ogg Files\"
  39.  
  40. ToggleSnd = _SNDOPEN(ogg$ + "Toggle.ogg")
  41. openSnd = _SNDOPEN(ogg$ + "Ticking.ogg")
  42. BombSnd = _SNDOPEN(ogg$ + "bomb.ogg")
  43. ApplauseSnd = _SNDOPEN(ogg$ + "Applause sm.ogg")
  44. SwooshSnd = _SNDOPEN(ogg$ + "Flyby.ogg")
  45. '_SNDPLAY SwooshSnd: IF SwooshSnd = 0 THEN PRINT " not loaded." ELSE PRINT "OK loaded.": END
  46. 'rnd reveal sounds
  47. DIM SHARED rndSnd(28) AS LONG
  48. rndSnd(0) = _SNDOPEN(ogg$ + "357 shot.ogg")
  49. rndSnd(1) = _SNDOPEN(ogg$ + "alarm.ogg")
  50. rndSnd(2) = _SNDOPEN(ogg$ + "Apple bite.ogg")
  51. rndSnd(3) = _SNDOPEN(ogg$ + "Barkings.ogg")
  52. rndSnd(4) = _SNDOPEN(ogg$ + "Bike.ogg")
  53. rndSnd(5) = _SNDOPEN(ogg$ + "brake.ogg")
  54. rndSnd(6) = _SNDOPEN(ogg$ + "bumble bee.ogg")
  55. rndSnd(7) = _SNDOPEN(ogg$ + "creaking.ogg")
  56. rndSnd(8) = _SNDOPEN(ogg$ + "crows.ogg")
  57. rndSnd(9) = _SNDOPEN(ogg$ + "Ding.ogg")
  58. rndSnd(10) = _SNDOPEN(ogg$ + "dinggg.ogg")
  59. rndSnd(11) = _SNDOPEN(ogg$ + "Donkey.ogg")
  60. rndSnd(12) = _SNDOPEN(ogg$ + "elec phone.ogg")
  61. rndSnd(13) = _SNDOPEN(ogg$ + "Fill mug.ogg")
  62. rndSnd(14) = _SNDOPEN(ogg$ + "goat.ogg")
  63. rndSnd(15) = _SNDOPEN(ogg$ + "hen.ogg")
  64. rndSnd(16) = _SNDOPEN(ogg$ + "Horse.ogg")
  65. rndSnd(17) = _SNDOPEN(ogg$ + "Kids.ogg")
  66. rndSnd(18) = _SNDOPEN(ogg$ + "M scream.ogg")
  67. rndSnd(19) = _SNDOPEN(ogg$ + "Male Hilarious.ogg")
  68. rndSnd(20) = _SNDOPEN(ogg$ + "Marimba.ogg")
  69. rndSnd(21) = _SNDOPEN(ogg$ + "neighing.ogg")
  70. rndSnd(22) = _SNDOPEN(ogg$ + "polaris ring.ogg")
  71. rndSnd(23) = _SNDOPEN(ogg$ + "pull top can.ogg")
  72. rndSnd(24) = _SNDOPEN(ogg$ + "Punch line drum.ogg")
  73. rndSnd(25) = _SNDOPEN(ogg$ + "Ring 2.ogg")
  74. rndSnd(26) = _SNDOPEN(ogg$ + "Rooster.ogg")
  75. rndSnd(27) = _SNDOPEN(ogg$ + "Unlock door.ogg")
  76. rndSnd(28) = _SNDOPEN(ogg$ + "whook.ogg")
  77. 'DIM i 'test load and sounds
  78. 'FOR i = 10 TO 28
  79. '    _SNDPLAY (rndSnd(i))
  80. '    PRINT i;
  81. '    IF rndSnd(i) = 0 THEN PRINT i; " not loaded." ELSE PRINT
  82. '    _DELAY 2
  83. 'NEXT
  84. 'END
  85.  
  86. customField
  87. SCREEN _NEWIMAGE(xmax, ymax, 32)
  88. _SCREENMOVE (1280 - xmax) / 2 + 60, (760 - ymax) / 2
  89. TYPE boardType
  90.     x AS SINGLE 'pixel location
  91.     y AS SINGLE 'pixel location
  92.     dx AS SINGLE 'for Crater making
  93.     dy AS SINGLE ' ditto
  94.     id AS INTEGER '0 to 6 neighbor mines
  95.     reveal AS INTEGER ' 1 for marked, 0 hidden, -1 for revealed
  96.     mine AS INTEGER '0 or -1
  97. REDIM SHARED b(0 TO Xarrd + 1, 0 TO Yarrd + 1) AS boardType 'oversize the board to make it easy to count mines
  98. DIM SHARED restart
  99. DIM gameOver, cc, cr, mbN, s$, sz!
  100. _TITLE _TRIM$(STR$(Yarrd * Xarrd - mines)) + " Cells to Free   Instructions: Left click Reveals, Right Marks Red"
  101. restart = 1
  102.     gameOver = 0
  103.     WHILE gameOver = 0
  104.         IF restart THEN initialize
  105.         mbN = 0
  106.         getCell cc, cr, mbN
  107.         IF mbN = 1 AND b(cc, cr).reveal = 0 THEN
  108.             IF b(cc, cr).mine THEN 'ka boom
  109.                 makeCrater cc, cr
  110.                 's$ = "KA - BOOOMMMM!"           'comment out since post code
  111.                 'sz! = 1.2 * xmax / LEN(s$)
  112.                 'cText xmax / 2, ymax / 2, sz!, &HFF000000, s$
  113.                 'cText xmax / 2 - 4, ymax / 2 - 4, sz!, &HFFFF0000, s$
  114.                 'cText xmax / 2 - 8, ymax / 2 - 8, sz!, &HFFFFFF00, s$
  115.                 gameOver = -1
  116.                 _DELAY 4
  117.             ELSE
  118.                 b(cc, cr).reveal = -1: showCell cc, cr
  119.                 IF b(cc, cr).id = 0 THEN
  120.                     sweepZeros cc, cr
  121.                 ELSE
  122.                     _SNDPLAY rndSnd(INT(RND * 29))
  123.                 END IF
  124.             END IF
  125.         ELSEIF mbN = 2 THEN
  126.             _SNDPLAY ToggleSnd
  127.             IF b(cc, cr).reveal = 1 THEN
  128.                 b(cc, cr).reveal = 0: showCell cc, cr
  129.             ELSE
  130.                 IF b(cc, cr).reveal = 0 THEN b(cc, cr).reveal = 1: showCell cc, cr
  131.             END IF
  132.         END IF
  133.         IF TFwin THEN
  134.             s$ = "Good Job!"
  135.             sz! = 1.2 * xmax / LEN(s$)
  136.             cText xmax / 2, ymax / 2, sz!, &HFF000000, s$
  137.             cText xmax / 2 - 1, ymax / 2 - 2, sz!, &HFF000055, s$
  138.             _DELAY 4
  139.             _SNDPLAY ApplauseSnd
  140.             _DELAY 7
  141.             gameOver = -1
  142.         END IF
  143.         _LIMIT 60
  144.     WEND
  145.     restart = 1
  146.  
  147. NoOff:
  148. DATA 1,0,0,-1,0,1,-1,-1,-1,0,-1,1
  149.  
  150. xOff:
  151. DATA -1,0,0,-1,0,1,1,-1,1,0,1,1
  152.  
  153. SUB makeCrater (col, row)
  154.     TYPE Particle
  155.         x AS SINGLE
  156.         y AS SINGLE
  157.         dx AS SINGLE
  158.         dy AS SINGLE
  159.         sz AS SINGLE
  160.         c AS _UNSIGNED LONG
  161.         type AS INTEGER
  162.     END TYPE
  163.  
  164.     DIM nP, r, c, a!, i, ra!, red!, j, stopper
  165.     nP = 25 * Xarrd * Yarrd
  166.     DIM p(nP) AS Particle
  167.     _SNDPLAY BombSnd
  168.     _DELAY .500 'need a fairly long delay before actually hear sound
  169.     LINE (0, 0)-(xmax, ymax), &HFFFFFFFF, BF
  170.     _DELAY .01
  171.     CLS
  172.     FOR r = 1 TO Yarrd 'show all mines
  173.         FOR c = 1 TO Xarrd
  174.             IF b(c, r).mine THEN b(c, r).reveal = -1
  175.             showCell c, r
  176.             a! = _ATAN2(b(c, r).y - b(col, row).y, b(c, r).x - b(col, row).x)
  177.             b(c, r).dx = .005 * Xarrd * Yarrd * COS(a!)
  178.             b(c, r).dy = .005 * Xarrd * Yarrd * SIN(a!)
  179.         NEXT
  180.     NEXT
  181.     FOR i = 0 TO nP
  182.         p(i).x = b(col, row).x + RND * 2 * cellR - cellR
  183.         p(i).y = b(col, row).y + RND * 2 * cellR - cellR
  184.         p(i).sz = RND * 6.5 + .1
  185.         ra! = RND * P2
  186.         p(i).dx = .09 * Xarrd * Yarrd / p(i).sz * COS(ra!)
  187.         p(i).dy = .09 * Xarrd * Yarrd / p(i).sz * SIN(ra!)
  188.         red! = RND * 100
  189.         p(i).c = _RGB32(red!, .5 * red! + .1 * red! * RND - .05 * red!, .25 * red! + .05 * red! * RND - .025 * red!)
  190.         p(i).type = INT(RND * 2)
  191.     NEXT
  192.     stopper = .5 * nP 'orig .3
  193.     FOR i = 1 TO 170 'make a Crater!!! maybe runs to long try 70 from original post 270
  194.         CLS
  195.         FOR r = 1 TO Yarrd 'redraw board with cells moved
  196.             FOR c = 1 TO Xarrd
  197.                 IF r = row AND c = col THEN
  198.                 ELSE
  199.                     IF i > 70 THEN
  200.                         b(c, r).dx = .9 * b(c, r).dx
  201.                         b(c, r).dy = .9 * b(c, r).dy
  202.                     END IF
  203.                     b(c, r).x = b(c, r).x + b(c, r).dx
  204.                     b(c, r).y = b(c, r).y + b(c, r).dy
  205.                     showCell c, r
  206.                 END IF
  207.             NEXT
  208.         NEXT
  209.         FOR j = 1 TO stopper
  210.             IF p(j).type THEN
  211.                 fcirc p(j).x, p(j).y, p(j).sz, p(j).c
  212.             ELSE
  213.                 LINE (p(j).x - .5 * p(i).sz, p(j).y - .5 * p(j).sz)-STEP(p(j).sz, p(j).sz), p(j).c, BF
  214.             END IF
  215.             p(j).x = p(j).x + p(j).dx
  216.             p(j).y = p(j).y + p(j).dy
  217.             p(j).dx = .97 * p(j).dx ' original post .992
  218.             p(j).dy = .97 * p(j).dy
  219.         NEXT
  220.         _DISPLAY
  221.         _LIMIT 35
  222.         IF i < 70 THEN stopper = stopper + 80 ' ELSE stopper = stopper + 1
  223.         IF stopper > nP THEN stopper = nP
  224.     NEXT
  225.  
  226. 'set all these 'DIM SHARED xmax, ymax, XarrD, YarrD, mines
  227. SUB customField
  228.     DIM fName$, fe, fLine$, p, inCnt, beenHere, allow$, choice$
  229.  
  230.     fName$ = "Hexagon Minefield Custom Specs.txt"
  231.     IF _FILEEXISTS(fName$) THEN fe = -1 ELSE fe = 0
  232.     allow$ = "12" + CHR$(27)
  233.     PRINT
  234.     PRINT "     Hexagom Minesweeper options:"
  235.     PRINT
  236.     PRINT "  1. Use mine field settings: 10 X 10 cells and 10 mines."
  237.     PRINT "  2. Customize your own field settings."
  238.     IF fe THEN PRINT "  3. Use the last customized mine field settings.": allow$ = allow$ + "3"
  239.     PRINT
  240.     PRINT "     or press esc to quit."
  241.     choice$ = getChar$(allow$)
  242.     SELECT CASE choice$
  243.         CASE "1": xmax = 800: ymax = 600: Xarrd = 10: Yarrd = 10: mines = 10
  244.         CASE "2": GOSUB editCustom
  245.         CASE "3": GOSUB loadCustom
  246.         CASE ELSE: SYSTEM
  247.     END SELECT
  248.     xmax = (Xarrd + 2.5) * xspacing!: ymax = (Yarrd + 2) * yspacing!
  249.     EXIT SUB
  250.  
  251.     editCustom:
  252.     IF fe = 0 THEN
  253.         OPEN fName$ FOR OUTPUT AS #1
  254.         PRINT #1, " "
  255.         PRINT #1, "          Custom Field Specs For Your Hexagon Minesweeper Game"
  256.         PRINT #1, " "
  257.         PRINT #1, " We will be sizing the screen according to a constant cell radius of 25"
  258.         PRINT #1, " and then numbers filled in here."
  259.         PRINT #1, " "
  260.         PRINT #1, " Please fill out the right side of all Equal signs."
  261.         PRINT #1, " "
  262.         PRINT #1, "   X dimensions across the screen:"
  263.         PRINT #1, "         Your Max Screen Width (pixels) = "
  264.         PRINT #1, "      Number of Horizontal Cells Across = "
  265.         PRINT #1, " "
  266.         PRINT #1, "   Y dimensions going down:"
  267.         PRINT #1, "        Your Max Screen Height (pixels) = "
  268.         PRINT #1, "                   Number of Cells Down = "
  269.         PRINT #1, " "
  270.         PRINT #1, "The percent of mines (8 easy - 15 hard) = "
  271.         PRINT #1, " "
  272.         PRINT #1, "    To finish, Save the file and then close the editor."
  273.         CLOSE #1
  274.     END IF
  275.     ' I picked up this shortcut from Ken, normally I would call a text editor that I don't know if you have!
  276.     SHELL fName$
  277.     GOSUB loadCustom
  278.     RETURN
  279.  
  280.     loadCustom:
  281.     beenHere = beenHere + 1 'we'll give it 5 tries
  282.     IF beenHere > 5 THEN
  283.         PRINT "OK we tried 5 times, going with default settings..."
  284.         xmax = 800: ymax = 600: Xarrd = 10: Yarrd = 10: mines = 10
  285.         RETURN
  286.     END IF
  287.     inCnt = 0
  288.     OPEN fName$ FOR INPUT AS #1
  289.     WHILE EOF(1) = 0 ' look to get 5 values from 5 = signs
  290.         LINE INPUT #1, fLine$
  291.         p = INSTR(fLine$, "=")
  292.         IF p > 0 THEN
  293.             inCnt = inCnt + 1
  294.             SELECT CASE inCnt
  295.                 CASE 1: xmax = VAL(rightOf$(fLine$, "="))
  296.                 CASE 2: Xarrd = VAL(rightOf$(fLine$, "="))
  297.                 CASE 3: ymax = VAL(rightOf$(fLine$, "="))
  298.                 CASE 4: Yarrd = VAL(rightOf$(fLine$, "="))
  299.                 CASE 5: mines = VAL(rightOf$(fLine$, "=")) * Xarrd * Yarrd / 100
  300.             END SELECT
  301.             IF inCnt = 5 THEN EXIT WHILE
  302.         END IF
  303.     WEND
  304.     CLOSE #1
  305.     IF inCnt = 5 THEN 'alternate exit from gosub
  306.         IF xmax >= (Xarrd + 2.5) * xspacing! THEN
  307.             IF ymax < (Yarrd + 2) * yspacing! THEN 'all good
  308.                 PRINT "Opps, Screen height is not big enough for Y cells down."
  309.             ELSE
  310.                 RETURN
  311.             END IF
  312.         ELSE
  313.             PRINT "Opps, Screen width is not big enough for X cells across."
  314.         END IF
  315.     ELSE
  316.         PRINT "We did not get everything filled out by = signs."
  317.     END IF
  318.     PRINT: PRINT "Press any to continue.. "
  319.     SLEEP
  320.     SHELL fName$
  321.     GOTO loadCustom
  322.  
  323. SUB initialize ()
  324.     DIM minesPlaced, rx, ry, x, y, nMines, xoffset!
  325.     CLS
  326.     _SNDPLAY openSnd
  327.     restart = 0
  328.     REDIM b(0 TO Xarrd + 1, 0 TO Yarrd + 1) AS boardType
  329.     minesPlaced = 0
  330.     WHILE minesPlaced < mines
  331.         rx = INT(RND * Xarrd) + 1: ry = INT(RND * Yarrd) + 1
  332.         IF b(rx, ry).mine = 0 THEN
  333.             b(rx, ry).mine = -1: minesPlaced = minesPlaced + 1
  334.         END IF
  335.     WEND
  336.     'count mines amoung the neighbors
  337.     FOR y = 1 TO Yarrd
  338.         IF y MOD 2 = 0 THEN xoffset! = .5 * xspacing! ELSE xoffset! = 0
  339.         FOR x = 1 TO Xarrd
  340.             IF b(x, y).mine <> -1 THEN 'not already a mine
  341.                 '2 sets of neighbors depending if x offset or not
  342.                 IF xoffset! > .1 THEN
  343.                     nMines = b(x - 1, y).mine + b(x, y - 1).mine + b(x, y + 1).mine
  344.                     nMines = nMines + b(x + 1, y - 1).mine + b(x + 1, y).mine + b(x + 1, y + 1).mine
  345.                 ELSE
  346.                     nMines = b(x + 1, y).mine + b(x, y - 1).mine + b(x, y + 1).mine
  347.                     nMines = nMines + b(x - 1, y - 1).mine + b(x - 1, y).mine + b(x - 1, y + 1).mine
  348.                 END IF
  349.                 b(x, y).id = -nMines
  350.             ELSE
  351.                 b(x, y).id = 0
  352.             END IF
  353.             b(x, y).x = x * xspacing! + xoffset! + .5 * xspacing!
  354.             b(x, y).y = y * yspacing! + .5 * yspacing!
  355.             b(x, y).reveal = 0
  356.             showCell x, y
  357.         NEXT
  358.     NEXT
  359.  
  360. SUB showCell (c, r)
  361.     DIM da, x!, y!, lastx!, lasty!, clr AS _UNSIGNED LONG
  362.     SELECT CASE b(c, r).reveal
  363.         CASE -1: IF b(c, r).mine THEN clr = &HFF883300 ELSE clr = &HFFFFFFFF 'revealed  white with number of mine neighbors
  364.         CASE 0: clr = &HFF008800 'hidden green
  365.         CASE 1: clr = &HFFFF0000 'marked red
  366.     END SELECT
  367.     lastx! = b(c, r).x + cellR * COS(_D2R(-30))
  368.     lasty! = b(c, r).y + cellR * SIN(_D2R(-30))
  369.     FOR da = 30 TO 330 STEP 60
  370.         x! = b(c, r).x + cellR * COS(_D2R(da))
  371.         y! = b(c, r).y + cellR * SIN(_D2R(da))
  372.         LINE (lastx!, lasty!)-(x!, y!), &HFFFF00FF
  373.         lastx! = x!: lasty! = y!
  374.     NEXT
  375.     PAINT (b(c, r).x, b(c, r).y), clr, &HFFFF00FF
  376.     IF b(c, r).reveal = -1 THEN
  377.         'cText b(c, r).x, b(c, r).y, 15, &HFF000000, _TRIM$(STR$(c)) + "," + _TRIM$(STR$(r))
  378.         IF b(c, r).id > 0 THEN cText b(c, r).x, b(c, r).y, 35, &HFF000000, _TRIM$(STR$(b(c, r).id))
  379.         IF b(c, r).mine = -1 THEN cText b(c, r).x, b(c, r).y, 35, &HFFFFFFFF, "*"
  380.     END IF
  381.  
  382. FUNCTION TFwin
  383.     DIM c, x, y
  384.     FOR y = 1 TO Yarrd
  385.         FOR x = 1 TO Xarrd
  386.             IF b(x, y).reveal = -1 AND b(x, y).mine = 0 THEN c = c + 1
  387.         NEXT
  388.     NEXT
  389.     IF c = Xarrd * Yarrd - mines THEN TFwin = -1
  390.  
  391. SUB getCell (returnCol AS INTEGER, returnRow AS INTEGER, mbNum AS INTEGER)
  392.     DIM m, mx, my, mb1, mb2, r, c
  393.     mb1 = _MOUSEBUTTON(1): mb2 = _MOUSEBUTTON(2)
  394.     IF mb1 THEN mbNum = 1
  395.     IF mb2 THEN mbNum = 2
  396.     IF mb1 OR mb2 THEN '                      get last place mouse button was down
  397.         WHILE mb1 OR mb2 '                    wait for mouse button release as a "click"
  398.             m = _MOUSEINPUT: mb1 = _MOUSEBUTTON(1): mb2 = _MOUSEBUTTON(2)
  399.             mx = _MOUSEX: my = _MOUSEY
  400.         WEND
  401.         FOR r = 1 TO Yarrd
  402.             FOR c = 1 TO Xarrd
  403.                 IF ((mx - b(c, r).x) ^ 2 + (my - b(c, r).y) ^ 2) ^ .5 < .5 * xspacing! THEN
  404.                     returnCol = c: returnRow = r: EXIT SUB
  405.                 END IF
  406.             NEXT
  407.         NEXT
  408.         mbNum = 0 'still here then clicked wrong
  409.     END IF
  410.  
  411. SUB sweepZeros (col, row) ' recursive sweep
  412.     DIM c, r, cMin, cMax, rMin, rMax, x, y, id
  413.     _SNDPLAY SwooshSnd
  414.     c = col: r = row 'get copies for recursive sub
  415.     IF c > 2 THEN cMin = c - 1 ELSE cMin = 1
  416.     IF c < Xarrd - 1 THEN cMax = c + 1 ELSE cMax = Xarrd
  417.     IF r > 2 THEN rMin = r - 1 ELSE rMin = 1
  418.     IF r < Yarrd - 1 THEN rMax = r + 1 ELSE rMax = Yarrd
  419.     FOR y = rMin TO rMax
  420.         FOR x = cMin TO cMax
  421.             IF b(x, y).reveal = 0 THEN
  422.                 id = b(x, y).id
  423.                 IF b(x, y).mine = 0 AND id = 0 THEN
  424.                     b(x, y).reveal = -1 'mark played
  425.                     showCell x, y
  426.                     sweepZeros x, y
  427.                 ELSE
  428.                     IF b(x, y).mine = 0 AND id >= 1 AND id <= 8 THEN
  429.                         b(x, y).reveal = -1
  430.                         showCell x, y
  431.                     END IF
  432.                 END IF
  433.             END IF
  434.         NEXT
  435.     NEXT
  436.  
  437. 'center the text around (x, y) point, needs a graphics screen!
  438. SUB cText (x, y, textHeight AS SINGLE, K AS _UNSIGNED LONG, txt$)
  439.     DIM fg AS _UNSIGNED LONG, cur&, I&, mult!, xlen
  440.     fg = _DEFAULTCOLOR
  441.     'screen snapshot
  442.     cur& = _DEST
  443.     I& = _NEWIMAGE(8 * LEN(txt$), 16, 32)
  444.     _DEST I&
  445.     COLOR K, _RGBA32(0, 0, 0, 0)
  446.     _PRINTSTRING (0, 0), txt$
  447.     mult! = textHeight / 16
  448.     xlen = LEN(txt$) * 8 * mult!
  449.     _PUTIMAGE (x - .5 * xlen, y - .5 * textHeight)-STEP(xlen, textHeight), I&, cur&
  450.     COLOR fg
  451.     _FREEIMAGE I&
  452.  
  453. FUNCTION rightOf$ (source$, of$)
  454.     IF INSTR(source$, of$) > 0 THEN rightOf$ = MID$(source$, INSTR(source$, of$) + LEN(of$))
  455.  
  456. FUNCTION getChar$ (fromStr$)
  457.     DIM OK AS INTEGER, k$
  458.     WHILE OK = 0
  459.         k$ = INKEY$
  460.         IF LEN(k$) THEN
  461.             IF INSTR(fromStr$, k$) <> 0 THEN OK = -1
  462.         END IF
  463.         _LIMIT 200
  464.     WEND
  465.     _KEYCLEAR
  466.     getChar$ = k$
  467.  
  468. 'from Steve Gold standard
  469. SUB fcirc (CX AS INTEGER, CY AS INTEGER, R AS INTEGER, C AS _UNSIGNED LONG)
  470.     DIM Radius AS INTEGER, RadiusError AS INTEGER
  471.     DIM X AS INTEGER, Y AS INTEGER
  472.     Radius = ABS(R): RadiusError = -Radius: X = Radius: Y = 0
  473.     IF Radius = 0 THEN PSET (CX, CY), C: EXIT SUB
  474.     LINE (CX - X, CY)-(CX + X, CY), C, BF
  475.     WHILE X > Y
  476.         RadiusError = RadiusError + Y * 2 + 1
  477.         IF RadiusError >= 0 THEN
  478.             IF X <> Y + 1 THEN
  479.                 LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
  480.                 LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
  481.             END IF
  482.             X = X - 1
  483.             RadiusError = RadiusError - X * 2
  484.         END IF
  485.         Y = Y + 1
  486.         LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
  487.         LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
  488.     WEND
  489.  
  490.  

 


 




« Last Edit: January 19, 2021, 01:29:31 PM by bplus »