September 26, 2020, 01:40:24 PM

### Author Topic: Fun with hexagons  (Read 1596 times)

#### chrisws

• Jr. Member
• Posts: 55
##### Fun with hexagons
« on: February 03, 2020, 09:18:07 PM »
Code: [Select]

rem
rem https://www.redblobgames.com/grids/hexagons/
rem

sub draw_grid(size, pointy, col)
local v1 = sqr(3) * size
local v2 = size * 2
local border = 3
local width = iff(pointy, v1, v2)
local height = iff(pointy, v2, v1)
local x_start, row

func flat_hex_corner(x, y, i)
local angle = rad(iff(pointy, 30,0) + 60 * i)
return [x + (size - border) * cos(angle), y + (size - border) * sin(angle)]
end

func hexagon(x, y)
local i, a
for i = 0 to 6
a << flat_hex_corner(x, y, i)
next i
return a
end

row = 0
for y = height to ymax step height
x_start = iff(row %2 == 0, width, width / 2)
for x = x_start to xmax - width step width
drawpoly hexagon(x, y) color col filled
next x
row++
next y
end

zr=1
i=5
while 1
i+=zr
if (i>110) then zr=-1
if (i=5) then zr=1
j= !j
draw_grid(i+2,j,2)
draw_grid(i+3,j,3)
draw_grid(i+4,j,4)
draw_grid(i+5,j,1)
showpage
delay max(1, 100-i)
cls
wend

#### bplus

• Full Member
• Posts: 139
##### Re: Fun with hexagons
« Reply #1 on: February 04, 2020, 03:18:42 PM »
Thanks Chris

I pick up tips studying your code. Functions inside a Sub? Does it matter? And returning points and arrays, don't see that with QB64 nor drawpoly with or without filled option.

#### bplus

• Full Member
• Posts: 139
##### Re: Fun with hexagons
« Reply #2 on: February 05, 2020, 04:11:09 PM »
Hi Chris,

I am trying to translate a Hexagon Minesweeper Game from QB64 and it seems that PAINT to a border is flooding screen whereas PAINT without border will fill hexagon OK, is there a known bug with using the border color option? I think I tried both RGB and regular QB colors for border color.

Also, I look up PEN() from Help and there is nothing about crucial Mouse polling ie what are the Pen options available? Also PEN ON/OFF the only help given is no longer necessary as I recall? Really needs better documentation. SmallBASIC forum says well here is the shot

and the not so helpful one from github

#### bplus

• Full Member
• Posts: 139
##### Re: Fun with hexagons
« Reply #3 on: February 06, 2020, 03:33:53 PM »
More fun (when sweepZero's doesn't blow the stack!)

Hexagonal Minesweeper:
Code: [Select]
'Hexagon Minesweeper.bas for SmallBASIC dev 12.13 bplus 2020-02-04 translated from
'Hexagon Minesweeper.bas for QB64 by Bplus 2019-08-07 instigated by Steve McNeill
' 2019-08-08 fixed incomplete sweepZeros problem
' 2020-02-05 SmallBASIC v 12.13 (v 12.17 bugged out permanently loosing letter keys!!!!)
'  blows stack now and then sweeping Zero's even with this puny 10 x 10 field ;(

RANDOMIZE TIMER
CONST cellR = 25
const arrDx = 10  '10 works but puny board higher numbers overcome stack
const arrDy = 10
const mines = int(arrDx * arrDy * .14)
xspacing = 2 * cellR * COS(rad(30))
yspacing = cellR * (1 + SIN(rad(30)))
dim b(arrDx + 1, arrDy + 1) 'board
dim dxdyOFF(6, 1), dxdyNoOff(6, 1) 'set direction according to six sides and offset hexagon or not

'set the 2 sets of directions to neighbors a cell could have depending if the row is offset or not
RESTORE NoOff
FOR i = 0 TO 5
dxdyNoOff(i, 0) = dx: dxdyNoOff(i, 1) = dy
NEXT
RESTORE xOff
FOR i = 0 TO 5
dxdyOFF(i, 0) = dx: dxdyOFF(i, 1) = dy
NEXT

restart = 1
WHILE 1
gameOver = 0
WHILE gameOver = 0
IF restart THEN initialize
okay = 0
getCell cc, cr, okay
IF redOn = 0 AND b(cc, cr).reveal = 0 and okay THEN
IF b(cc, cr).mine THEN 'ka boom
FOR r = 1 TO arrDy 'show all mines
FOR c = 1 TO arrDy
IF b(c, r).mine THEN b(c, r).reveal = -1: showCell c, r
NEXT
NEXT
Text xmax / 2, ymax - 72, 72, 14, 0,  "KA - BOOOMMMM!"
gameOver = -1
delay 4000
ELSE
b(cc, cr).reveal = -1: showCell cc, cr
IF b(cc, cr).id = 0 THEN sweepZeros cc, cr
END IF
ELSEIF redOn and Okay
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
delay 30
END IF
IF TFwin THEN
Text xmax / 2 - 1, ymax - 72, 72, 9, 15, "Good Job!"
delay 3000
gameOver = -1
END IF
delay 30
WEND
restart = 1
cls
WEND

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

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

SUB initialize ()
local minesplaced, rx, ry, x, y, nMines, offset
CLS
restart = 0 : redON = 0
DIM b(arrDx + 1, arrDy + 1) 'AS boardType
minesPlaced = 0
WHILE minesPlaced < mines
rx = INT(RND * arrDx) + 1: ry = INT(RND * arrDy) + 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 arrDy
IF y MOD 2 = 0 THEN xoffset = .5 * xspacing ELSE xoffset = 0
FOR x = 1 TO arrDx
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
b(x, y).y = y * yspacing + 5
b(x, y).reveal = 0
showCell x, y
NEXT
NEXT
text xmax/2, ymax - 148, 20, 15, 12, " Press Spacebar to toggle Red Mine Marker (ON = Red at Right) "
END SUB

SUB showCell (c, r)
local da, x, y, lastx, lasty, clr
SELECT CASE b(c, r).reveal
CASE -1: IF b(c, r).mine THEN clr = 12 ELSE clr = 15 'revealed  white with number of mine neighbors
CASE 0: clr = 2 ' hidden green
CASE 1: clr = 12 ' marked red
END SELECT
lastx = b(c, r).x + cellR * COS(rad(-30))
lasty = b(c, r).y + cellR * SIN(rad(-30))
FOR da = 30 TO 330 STEP 60
x = b(c, r).x + cellR * COS(rad(da))
y = b(c, r).y + cellR * SIN(rad(da))
LINE lastx, lasty, x, y, 13
lastx = x: lasty = y
NEXT
PAINT b(c, r).x, b(c, r).y, clr
IF b(c, r).reveal = -1 THEN
IF b(c, r).id > 0 THEN text b(c, r).x, b(c, r).y + 1, 20, 0, 15, str(b(c, r).id)
IF b(c, r).mine = -1 THEN text b(c, r).x, b(c, r).y + 4, 20, 15, 12, "*"
ENDIF
END SUB

FUNC TFwin  'count cleared cells
local c, x, y
FOR y = 1 TO arrDy
FOR x = 1 TO arrDx
IF b(x, y).reveal = -1 AND b(x, y).mine = 0 THEN c = c + 1
NEXT
NEXT
IF c = arrDx * arrDy - mines THEN TFwin = -1
END

SUB getCell (byref returnCol, byref returnRow, byref OK)
local m, mx, my, mb, r, c, k   ' pen
mb = pen(3)
if inkey = " " then redOn = !redON
if redON then k = 12 else k = 0
rect xmax - 100, 0, xmax, ymax, k filled
IF mb then
mx = pen(4) : my = pen(5)
FOR r = 1 TO arrDy
FOR c = 1 TO arrDx
IF ((mx - b(c, r).x) ^ 2 + (my - b(c, r).y) ^ 2) ^ .5 < .5 * xspacing THEN
returnCol = c: returnRow = r: OK = 1 : EXIT SUB
END IF
NEXT
NEXT
while mb : mb = pen(3): delay 15 : wend  'one mouse click at a time please
END IF
OK = 0
END SUB

SUB sweepZeros (col, row)
'something is tripping up the sweep specially when lots of reveals
'tried a separate Text2 for less calls to changing font size (mostly back to same size as was), nope no fix
'now trying NO CALLs to showCell and displaying whole board again each loop through main, nope no fix
local c, r, d, x, y
c = col: r = row 'get copies for recursive sub
FOR d = 0 TO 5
IF r MOD 2 = 0 THEN
x = dxdyOFF(d, 0) + c: y = dxdyOFF(d, 1) + r
ELSE
x = dxdyNoOff(d, 0) + c: y = dxdyNoOff(d, 1) + r
END IF
IF (x >= 1 AND x <= arrDx) AND (y >= 1 AND y <= arrDy) THEN
IF b(x, y).reveal = 0 and b(x, y).mine = 0 THEN
b(x, y).reveal = -1 'mark played
showCell x, y
if b(x, y).id = 0 then sweepZeros x, y
END IF
END IF
NEXT
END SUB

sub Text(x, y, size, fcolor, bcolor, s)
local l
l.w = window() : l.w.setfont(size, "pt", 0, 0)
color fcolor, bcolor
at x - .5 * textwidth(s), y - .5 * textHeight(s) : ? s;
color 15, 0
l.w = window() : l.w.setfont(20, "pt", 0, 0)
end

#### chrisws

• Jr. Member
• Posts: 55
##### Re: Fun with hexagons
« Reply #4 on: February 07, 2020, 10:25:28 AM »
Looks amazing. But you know what would be even more awesome... your particle explosion code instead of Kaboom!

I will try and fix up the PEN docs soon. I'm not sure if there's a bug in PAINT, I will have a play and see.

I'm making a minor update to fix my stupid keyboard handling issue (I see you've left some notes in the other thread).

#### bplus

• Full Member
• Posts: 139
##### Re: Fun with hexagons
« Reply #5 on: February 07, 2020, 04:55:13 PM »
Hi Chris,

Well you are consistent, you had same comment a couple of years ago for regular Minesweeper.

I don't know how much time you have to play around with things but increase arrDx say to 20 or even 15 and the thing errors out easy. Since it loads pages with "error", I assume it is a stack problem which is odd because regular Minesweeper could handle much larger game boards...

By popular demand (twice now from highly respected coder), I will look into exploding game boards.

#### bplus

• Full Member
• Posts: 139
##### Re: Fun with hexagons
« Reply #6 on: February 08, 2020, 03:02:01 AM »
Fixed problem with stack by dumping recursive sub and used a "stack" array instead, plus some other improvements...
Now the Mine Field Fills the screen:
Code: [Select]
'hexagon minesweeper.bas for smallbasic dev 12.13 bplus 2020-02-04 translated from
'hexagon minesweeper.bas for qb64 by bplus 2019-08-07 instigated by steve mcneill
' 2020-02-07 fix stack problem with recursive sub by dumping it and using a stack array instead.
' Now I can expand the field to fill the screen! Added an r keypress option to restart a game.

randomize timer
const cellr = 25
const arrdx = 26  '10 works but puny board higher numbers overcome stack
const arrdy = 14
const mines = int(arrdx * arrdy * .14)
const dm30 = -1/6 * pi
const d30 = 1/6 * pi
const d60 = 1/3 * pi
const d330 = 2 * pi + dm30
xspacing = 2 * cellr * cos(d30)
yspacing = cellr * (1 + sin(d30))
dim b(arrdx + 1, arrdy + 1) 'board
dim dxdyOff(6, 1), dxdyNoOff(6, 1) 'set direction according to six sides and offset hexagon or not

'set the 2 sets of directions to neighbors a cell could have depending if the row is offset or not
restore noOff
for i = 0 to 5
dxdyNoOff(i, 0) = dx: dxdyNoOff(i, 1) = dy
next
restore xoff
for i = 0 to 5
dxdyOff(i, 0) = dx: dxdyOff(i, 1) = dy
next

restart = 1
while 1
gameover = 0
while gameover = 0
if restart then initialize
okay = 0
getcell cc, cr, okay
if redon = 0 and b(cc, cr).reveal = 0 and okay then
if b(cc, cr).mine then 'ka boom
for r = 1 to arrdy 'show all mines
for c = 1 to arrdx
if b(c, r).mine then b(c, r).reveal = -1: showcell c, r
next
next
text xmax / 2, ymax - 72, 72, 14, 0,  "ka - booommmm!"
gameover = -1
delay 4000
else
b(cc, cr).reveal = -1: showcell cc, cr
if b(cc, cr).id = 0 then sweep0 cc, cr
end if
elseif redon and okay
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
text xmax / 2 - 1, ymax - 72, 72, 9, 15, "good job!"
delay 4000
gameover = -1
end if
wend
restart = 1
cls
wend

label noOff:
data 1,0,0,-1,0,1,-1,-1,-1,0,-1,1

label xoff:
data -1,0,0,-1,0,1,1,-1,1,0,1,1

sub initialize ()
local minesplaced, rx, ry, x, y, nmines, offset
cls
text xmax/2, ymax - 148, 20, 15, 12, " press spacebar to toggle red mine marker (on = red at right) "
restart = 0 : redon = 0
dim b(arrdx + 1, arrdy + 1) 'as boardtype
minesplaced = 0
while minesplaced < mines
rx = int(rnd * arrdx) + 1: ry = int(rnd * arrdy) + 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 arrdy
if y mod 2 = 0 then xoffset = .5 * xspacing else xoffset = 0
for x = 1 to arrdx
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
b(x, y).y = y * yspacing + 5
b(x, y).reveal = 0
showcell x, y
next
next
end sub

sub showcell (c, r)
local da, arr
select case b(c, r).reveal
case -1: if b(c, r).mine then color 12, 0 else color 15, 0  'revealed white with number of mine neighbors
case 0: color  2, 0 ' hidden green
case 1: color 12, 0' marked red
end select

for da = dm30 to d330 step d60
arr << b(c, r).x + cellr * cos(da)
arr << b(c, r).y + cellr * sin(da)
next
drawpoly arr filled
color 13, 0
drawpoly arr
if b(c, r).reveal = -1 then
if b(c, r).id > 0 then text b(c, r).x, b(c, r).y + 1, 20, 0, 15, str(b(c, r).id)
if b(c, r).mine = -1 then text b(c, r).x, b(c, r).y + 4, 20, 15, 12, "*"
endif
color 15, 0
end sub

func tfwin  'count cleared cells
local c, x, y
for y = 1 to arrdy
for x = 1 to arrdx
if b(x, y).reveal = -1 and b(x, y).mine = 0 then c = c + 1
next
next
if c = arrdx * arrdy - mines then tfwin = -1
end

sub getcell (byref returncol, byref returnrow, byref ok)
local m, mx, my, mb, r, c, k   ' pen
mb = pen(3)
k = inkey
if k = "r" then gameover = -1 '<<< faster debug testing
if k = " " then redon = !redon
if redon then k = 12 else k = 0
rect xmax - 100, 0, xmax, ymax, k filled
if mb then
mx = pen(4) : my = pen(5)
while mb : mb = pen(3): delay 60 : wend  'one mouse click at a time please
for r = 1 to arrdy
for c = 1 to arrdx
if ((mx - b(c, r).x) ^ 2 + (my - b(c, r).y) ^ 2) ^ .5 < .5 * xspacing then
returncol = c: returnrow = r: ok = 1 : exit sub
end if
next
next
end if
ok = 0
end sub

sub text(x, y, size, fcolor, bcolor, s)
local l
l.w = window() : l.w.setfont(size, "pt", 0, 0)
color fcolor, bcolor
at x - .5 * textwidth(s), y - .5 * textheight(s) : ? s;
color 15, 0
l.w = window() : l.w.setfont(20, "pt", 0, 0)
end

sub sweep0 (col, row) 'non recursive
local d, x, y, stack, sti
dim stack()
label again:
for d = 0 to 5
if row mod 2 = 0 then
x = dxdyoff(d, 0) + col: y = dxdyoff(d, 1) + row
else
x = dxdynooff(d, 0) + col: y = dxdynooff(d, 1) + row
end if
if (x >= 1 and x <= arrdx) and (y >= 1 and y <= arrdy) then
if b(x, y).reveal = 0 and b(x, y).mine = 0 then
b(x, y).reveal = -1 'mark played
showcell x, y
if b(x, y).id = 0 then
append stack, x, y
end if
end if
end if
next
if ubound(stack)
row = stack(ubound(stack))
delete stack, ubound(stack)
col = stack(ubound(stack))
delete stack, ubound(stack)
goto again
end if
end sub

#### bplus

• Full Member
• Posts: 139
##### Re: Fun with hexagons
« Reply #7 on: February 08, 2020, 11:58:02 PM »
Here is some more modifications for Minesweeper with explosion of board and sound effect. Man I only found one wav file that would work in SmallBASIC, fortunately it was the most important one. I have also adjusted the mine field to fill your screen with cells based on your systems xmax, ymax settings.

Update: See next reply for two explosion versions in attached file.

#### bplus

• Full Member
• Posts: 139
##### Re: Fun with hexagons
« Reply #8 on: February 09, 2020, 04:23:32 AM »
OK that was one way to do explosions, here is another, better way, except in SmallBASIC it is sort of in slow motion. Remember when the 6 Million Dollar man use to run?

The attached .zip contains the SmallBASIC source code for 2 explosion methods plus .wav

#### bplus

• Full Member
• Posts: 139
##### Re: Fun with hexagons
« Reply #9 on: February 09, 2020, 06:42:21 PM »
I liked this so much I took it back to QB64 and really blow up the board!
https://www.syntaxbomb.com/index.php/topic,7079.msg34156.html#msg34156

#### chrisws

• Jr. Member
• Posts: 55
##### Re: Fun with hexagons
« Reply #10 on: February 14, 2020, 10:04:17 PM »
I liked this so much I took it back to QB64 and really blow up the board!
https://www.syntaxbomb.com/index.php/topic,7079.msg34156.html#msg34156
Nice, I still think it would be good if there was a way to make the same code work in both environments, something like this:

Code: [Select]

#!QB64

... QB64 syntax

#!SB

... SmallBASIC syntax

#

... interoperable code that already works in both systems

#### bplus

• Full Member
• Posts: 139
##### Re: Fun with hexagons
« Reply #11 on: February 15, 2020, 05:30:34 PM »
I liked this so much I took it back to QB64 and really blow up the board!
https://www.syntaxbomb.com/index.php/topic,7079.msg34156.html#msg34156
Nice, I still think it would be good if there was a way to make the same code work in both environments, something like this:

Code: [Select]

#!QB64

... QB64 syntax

#!SB

... SmallBASIC syntax

#

... interoperable code that already works in both systems

Well they both branch from same tree QB45 or so but QB64 is developed and compiled in C+ with Open GL for graphics package and SmallBASIC going down another path...

Qb64 sure could use SmallBASIC's array tools! and would be nice not to have to worry about TYPE's.

#### round157

• Sr. Member
• Posts: 371
##### Re: Fun with hexagons
« Reply #12 on: February 19, 2020, 04:31:51 PM »

Well they both branch from same tree QB45 or so but QB64 is developed and compiled in C+ with Open GL for graphics package and SmallBASIC going down another path...

Hi, I have a question. What is SmallBASIC's another path?

#### bplus

• Full Member
• Posts: 139
##### Re: Fun with hexagons
« Reply #13 on: February 20, 2020, 06:39:16 AM »
SmallBASIC is developed in C and graphics package is either SDL or FLTK with the one original developer still active after all these years, whereas a trio or more have picked up the ball with QB64 and continue to carry it forward into the future.

Both can still run original QB code, can VB do that? would we want it to? ;-))

#### round157

• Sr. Member
• Posts: 371
##### Re: Fun with hexagons
« Reply #14 on: February 21, 2020, 08:45:00 AM »
SmallBASIC is developed in C and graphics package is either SDL or FLTK