Fun with hexagons

Started by chrisws, February 03, 2020, 21:18:07

Previous topic - Next topic

chrisws



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

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. :)
1 person likes this

bplus

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


1 person likes this

bplus

More fun (when sweepZero's doesn't blow the stack!)

Hexagonal Minesweeper:

'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
    READ dx, dy
    dxdyNoOff(i, 0) = dx: dxdyNoOff(i, 1) = dy
NEXT
RESTORE xOff
FOR i = 0 TO 5
    READ dx, dy
    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



1 person likes this

chrisws

#4
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

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.  ;)

1 person likes this

bplus

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:

'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
    read dx, dy
    dxdyNoOff(i, 0) = dx: dxdyNoOff(i, 1) = dy
next
restore xoff
for i = 0 to 5
    read dx, dy
    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

1 person likes this

bplus

#7
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.

1 person likes this

bplus

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

1 person likes this

bplus

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
1 person likes this

chrisws

Quote from: bplus on February 09, 2020, 18:42:21
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:



#!QB64

... QB64 syntax

#!SB

... SmallBASIC syntax

#

... interoperable code that already works in both systems


bplus

Quote from: chrisws on February 14, 2020, 22:04:17
Quote from: bplus on February 09, 2020, 18:42:21
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:



#!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.
1 person likes this

round157

Quote from: bplus on February 15, 2020, 17:30:34

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?

(Your Minesweeper is interesting!)


bplus

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? ;-))
1 person likes this

round157

Quote from: bplus on February 20, 2020, 06:39:16
SmallBASIC is developed in C and graphics package is either SDL or FLTK

Ha...thanks for your information.