Honeycombs _ Rosetta Code

[bplus]

ref:  http://rosettacode.org/wiki/Honeycombs

Here is updated translation and overhaul I made today:

Code: QB64: [Select]

1. _Title "Honeycombs - Rosetta Code" ' b+ 2021-10-30 trans from
2. ' Honeycomb Rosetta.txt for JB v2 2018-11-24 B+ finish Rosetta Challenge
3. ' 2021-10-30 complete overhaul except for grid drawing numbers and names.
4.  
5. ' ===================== Try alternate Cols and Rows for HoneyComb ===============================
6.  
7. Const Cols = 5, Rows = 4, LMax = Cols * Rows ' hex grid  <<<<<<<<<<<<<<  as Rosetta Requires
8. 'Const Cols = 4, Rows = 5, LMax = Cols * Rows ' hex grid <<<<<<<<<<<<<< reverse
9. 'Const Cols = 6, Rows = 5, LMax = Cols * Rows ' hex grid <<<<<<<<<<<<<< More than just Letters
10. 'Const Cols = 13, Rows = 2, LMax = Cols * Rows ' hex grid do exactly whole alphabet!
11.  
12.  
13. ' global   SELECTED$ ' all caps for globals
14. Const Pi3 = _Pi / 3, Sqr3 = Sqr(3), Side = 30 '           constants for Hexagon making
15. Const Xoff = 100 - 1.5 * Side, Yoff = 100 - Side * Sqr3 ' center grid with offsets on screen
16. Const XMax = 2 * Xoff + Cols * 1.5 * Side + 1.5 * Side '  screen display size needed
17. Const YMax = 2 * Yoff + (Rows + 2) * Side * Sqr3
18.  
19. Dim Shared L$(LMax), LX(LMax), LY(LMax), LSELECTED(LMax), Selected$ ' save letter and hex center positions by index
20.  
21. Randomize Timer ' get new grid when we start
22. For i = 1 To LMax ' get letters array loaded
23.     L$(i) = Chr$(64 + i)
24. Next
25. For i = LMax To 2 Step -1 ' shuffle letters Fisher - Yates
26.     Swap L$(i), L$(Int(Rnd * i) + 1)
27. Next
28.  
29. Screen _NewImage(XMax, YMax, 32) 'graphics custom size RGBA colors
30. _Delay .25 ' get screen loaded before trying to move
31. _ScreenMove _Middle ' center  screen
32.  
33. f& = _LoadFont("Consolab.ttf", 40) ' >>>>>>>>>>>> from Windows 10 Fonts
34. _Font f&
35. Color , _RGB32(200, 200, 220): Cls ' draw grid before selections
36. For y = 1 To Rows ' initialize screen with grid
37.     For x = 1 To Cols
38.         n = n + 1 ' index hex buttons
39.         If x Mod 2 = 0 Then yoff2 = .5 * Side * Sqr3 Else yoff2 = 0 ' is this column lower than first column?
40.         cx = x * 1.5 * Side + Xoff: cy = y * Side * Sqr3 + Yoff + yoff2 ' calc hex key centers
41.         LX(n) = cx: LY(n) = cy ' save hex key center positions
42.         drawHex n, 0 ' draw key
43.     Next
44. Next
45.  
46. While _KeyDown(27) = 0 ' allow user to select letters by key or mouse
47.     k$ = InKey$
48.     If Len(k$) Then
49.         For i = 1 To LMax 'if so was it selected already? or select it.
50.             If UCase$(k$) = L$(i) And LSELECTED(i) = 0 Then drawHex i, 1: Exit For
51.         Next
52.     End If
53.     While _MouseInput: Wend ' polls mouse
54.     mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
55.     If mb Then
56.         For i = 1 To LMax ' is distance from click within radius of non-selected button?
57.             If Sqr((mx - LX(i)) ^ 2 + (my - LY(i)) ^ 2) <= Side * .5 * Sqr3 And LSELECTED(i) = 0 Then drawHex i, 1
58.         Next
59.     End If
60. Wend
61.  
62. Sub drawHex (i, selectedTF)
63.     If selectedTF = 0 Then
64.         Color _RGB32(255, 0, 0), _RGB32(255, 255, 0)
65.     Else
66.         Color _RGB32(0, 0, 0), _RGB32(255, 0, 255)
67.     End If
68.     For a = 0 To 6
69.         x1 = LX(i) + Side * Cos(a * Pi3): y1 = LY(i) + Side * Sin(a * Pi3)
70.         If a > 0 Then Line (lastx, lasty)-(x1, y1), _RGB32(0, 0, 0)
71.         lastx = x1: lasty = y1
72.     Next
73.     Paint (LX(i), LY(i)), _BackgroundColor, _RGB32(0, 0, 0)
74.     _PrintString (LX(i) - 10, LY(i) - 13), L$(i)
75.     If selectedTF Then ' show the order of selection
76.         Color _RGB32(0, 0, 0), _RGB32(200, 200, 220)
77.         LSELECTED(i) = 1
78.         Selected$ = Selected$ + L$(i)
79.         centerText 0, _Width, _Height - 60, Mid$(Selected$, 1, Int(LMax / 2))
80.         If Len(Selected$) > 10 Then
81.             centerText 0, _Width, _Height - 20, Mid$(Selected$, Int(LMax / 2) + 1) 'are we done yet? are all letters selected?
82.             If Len(Selected$) = LMax Then Beep ' all have been selected
83.         End If
84.     End If
85. End Sub
86.  
87. Sub centerText (x1, x2, midy, s$) ' ' if you want to center fit a string between two goal posts x1, and x2
88.     _PrintString ((x1 + x2) / 2 - _PrintWidth(s$) / 2, midy - _FontHeight(_Font) / 2), s$
89. End Sub
90.  

Here's what it looked like in Just Basic 3 years ago:

Code: [Select]

'Honeycomb Rosetta.txt for JB v2 2018-11-24 B+ finish Rosetta Challenge

global XMAX, YMAX, PI3, SQR3, SIDE, LMAX, SELECTED$, ROWS, YOFF  ' all caps for globals
PI3 = acs(-1)/3 : SQR3 = sqr(3) : SIDE = 30                      ' constants for Hexagon making
cols = 5 : ROWS = 4 : LMAX = cols * ROWS                         ' hex grid size
dim L$(LMAX), LX(LMAX), LY(LMAX), LSELECTED(LMAX)                ' save letter and hex center positions by index
xoff = 100 - 1.5 * SIDE : YOFF = 100 - SIDE * SQR3               ' center grid with offsets
for i = 1 to LMAX : L$(i) = chr$(64 + i) : next                  ' get letters array loaded
for i = LMAX to 2 step -1                                        ' shuffle letters Fisher - Yates
    r = int(rnd(0) * i) + 1                                      ' random number up to i place
    t$ = L$(r) : L$(r) = L$(i) : L$(i) = t$                      ' swap
next
XMAX = 2*xoff + cols*1.5*SIDE + 1.5*SIDE                         'screen display size needed
YMAX = 2*YOFF + (ROWS + 2)*SIDE*SQR3
nomainwin                                                        ' Window prep before open
WindowWidth = XMAX + 8                                           ' size
WindowHeight = YMAX + 32
UpperLeftX = (DisplayWidth - XMAX) / 2                           ' top left corner, center window
UpperLeftY = (DisplayHeight - YMAX) / 2
open "Honeycomb - Rosetta Challenge" for graphics_nsb_nf as #gr  ' open with title
#gr "setfocus"                                                   ' catch keys and mouse
#gr "trapclose quit"                                             ' set exit code sub
#gr "when leftButtonUp lButtonUp"                                ' set mouse click up sub
#gr "when characterInput charIn"                                 ' set keppress sub
#gr "font consolus bold 20"                                      ' set font
#gr "down"                                                       ' pen ready to draw
for y = 1 to ROWS                                                ' initialize screen with grid
    for x = 1 to cols
        n = n + 1                                                ' index hex buttons
        if x mod 2 = 0 then yoff2 = .5*SIDE*SQR3 else yoff2 = 0  ' is this column lower than first column?
        cx = x*1.5*SIDE + xoff : cy = y*SIDE*SQR3 + YOFF + yoff2 ' calc hex key centers
        LX(n) = cx : LY(n) = cy                                  ' save hex key center positions
        call drawHex n, "green"                                  ' draw key
    next
next
#gr "flush"
wait
sub charIn H$, c$                                                'is c$, the key pressed, one of the letters in L$?
    for i = 1 to LMAX                                            'if so was it selected already? or select it.
        if upper$(c$) = L$(i) and LSELECTED(i) = 0 then call drawHex i, "blue" : #gr "flush" : exit sub
    next
end sub
sub lButtonUp H$, mx, my                                         ' mx, my are mouse button release locations
    for i = 1 to LMAX                                            ' is distance from click within radius of non-selected button?
        if sqr((mx-LX(i))^2+(my-LY(i))^2) <= SIDE*.5*SQR3 and LSELECTED(i) = 0 then call drawHex i, "blue" : #gr "flush" : exit sub
    next
end sub
sub drawHex i, c$
    #gr "size 1"
    #gr "backcolor ";c$                                          ' color location
    #gr "place ";LX(i) + .5;" ";LY(i);"; circlefilled ";SIDE * .5 * SQR3
    #gr "color black"                                            ' color letter and grid, thick line #10
    #gr "size 10"
    call Hex LX(i), LY(i)                                        ' draw hexagon cell
    call stext LX(i) - 10, LY(i) + 11, L$(i)                     ' draw letter
    if c$ = "blue" then                                          ' update Selection tracking and display
        LSELECTED(i) = 1
        SELECTED$ = SELECTED$ + L$(i)
        call stext 0, (ROWS + 2) * SIDE * SQR3 + YOFF, SELECTED$ 'are we done yet? are all letters selected?
        if len(SELECTED$) = LMAX then notice "All the keys have been used. Goodbye" : call quit "#gr"
    end if
end sub
sub Hex x0, y0                                                    ' draw hexagon around x0, y0 with 6 lines
    for i = 0 to 6
        x1 = x0 + SIDE * cos(i * PI3) : y1 = y0 + SIDE * sin(i * PI3)
        if i > 0 then #gr "line ";lastx;" ";lasty;" ";x1;" ";y1
        lastx = x1 : lasty = y1
    next
end sub
sub stext x, y, message$                                          ' note: y is the bottom edge not top
    #gr "place ";x;" ";y;";|";message$                            ' print message at x, y
end sub
sub quit H$                                                       ' close window ie click top right x box
    close #H$ : end
end sub

Just Basic has a very different way of doing screens and graphics.

[jack]

excellent bplus 😀

[bplus]

Thanks @jack   Just Basic has no Paint and no Triangle Fill though Andy Amaya came up with good one.

What JB has is adjustable line thickness, so to fill the Hexagons I used Filled Circles and then I drew very thick lined Hexagons to look like Honeycomb. The lines covered all the over lapping parts of circles. :)

[Dav]

That's cool.  Good coding, beeplus.  :)

I like to see code along with other translations for comparison.  Rosettacode is really a neat site.

- Dav

[Dav]

You mentioned about JB having thick lines.  I wished QB64 had it built-in, but Fellippe wrote a really cool easy to use SUB for doing that which is worth mentioning: https://www.qb64.org/forum/index.php?topic=116.0

- Dav

[bplus]

Thanks @Dav, you must know I've debated thickening those lines. I didn't know you could size lines with Draw.

[bplus]

Well I looked into Fellippe's Thick Lines and needed a color parameter added to the sub so I tried a couple of my own Thick Line Subs. Drawing Rectangle Thick lines leaves gaps where the two lines meet. I tried to fix with filled circles at the end points but a circle with radius 1/2 thickness left knobs and subtracting 1 from radius still left gaps in places.
So I pulled out my thick line by filled circles like a ball point pen, OK no gaps or knobs at meeting point but sort of jagged at some angles still the best I think.

I have the 3 versions, 2 commented out that you can try. I also had to change size of font because letter background was drawing over the blacklines:

Code: QB64: [Select]

1. _Title "Honeycombs thic lines - Rosetta Code" ' b+ 2021-10-30 trans from
2. ' Honeycomb Rosetta.txt for JB v2 2018-11-24 B+ finish Rosetta Challenge
3. ' 2021-10-30 complete overhaul except for grid drawing numbers and names.
4. ' 2021-10-31 thicken lines a little, fix font for thicker lines.
5.  
6. ' ===================== Try alternate Cols and Rows for HoneyComb ===============================
7.  
8. Const Cols = 5, Rows = 4, LMax = Cols * Rows ' hex grid  <<<<<<<<<<<<<<  as Rosetta Requires
9. 'Const Cols = 4, Rows = 5, LMax = Cols * Rows ' hex grid <<<<<<<<<<<<<< reverse
10. 'Const Cols = 6, Rows = 5, LMax = Cols * Rows ' hex grid <<<<<<<<<<<<<< More than just Letters
11. 'Const Cols = 13, Rows = 2, LMax = Cols * Rows ' hex grid do exactly whole alphabet!
12.  
13.  
14. ' global   SELECTED$ ' all caps for globals
15. Const Pi3 = _Pi / 3, Sqr3 = Sqr(3), Side = 30 '           constants for Hexagon making
16. Const Xoff = 100 - 1.5 * Side, Yoff = 100 - Side * Sqr3 ' center grid with offsets on screen
17. Const XMax = 2 * Xoff + Cols * 1.5 * Side + 1.5 * Side '  screen display size needed
18. Const YMax = 2 * Yoff + (Rows + 2) * Side * Sqr3
19.  
20. Dim Shared L$(LMax), LX(LMax), LY(LMax), LSELECTED(LMax), Selected$ ' save letter and hex center positions by index
21.  
22. Randomize Timer ' get new grid when we start
23. For i = 1 To LMax ' get letters array loaded
24.     L$(i) = Chr$(64 + i)
25. Next
26. For i = LMax To 2 Step -1 ' shuffle letters Fisher - Yates
27.     Swap L$(i), L$(Int(Rnd * i) + 1)
28. Next
29.  
30. Screen _NewImage(XMax, YMax, 32) 'graphics custom size RGBA colors
31. _Delay .25 ' get screen loaded before trying to move
32. _ScreenMove _Middle ' center  screen
33.  
34. f& = _LoadFont("Consolab.ttf", 36) ' >>>>>>>>>>>> from Windows 10 Fonts
35. _Font f&
36. Color , _RGB32(200, 200, 220): Cls ' draw grid before selections
37. For y = 1 To Rows ' initialize screen with grid
38.     For x = 1 To Cols
39.         n = n + 1 ' index hex buttons
40.         If x Mod 2 = 0 Then yoff2 = .5 * Side * Sqr3 Else yoff2 = 0 ' is this column lower than first column?
41.         cx = x * 1.5 * Side + Xoff: cy = y * Side * Sqr3 + Yoff + yoff2 ' calc hex key centers
42.         LX(n) = cx: LY(n) = cy ' save hex key center positions
43.         drawHex n, 0 ' draw key
44.     Next
45. Next
46.  
47. While _KeyDown(27) = 0 ' allow user to select letters by key or mouse
48.     k$ = InKey$
49.     If Len(k$) Then
50.         For i = 1 To LMax 'if so was it selected already? or select it.
51.             If UCase$(k$) = L$(i) And LSELECTED(i) = 0 Then drawHex i, 1: Exit For
52.         Next
53.     End If
54.     While _MouseInput: Wend ' polls mouse
55.     mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
56.     If mb Then
57.         For i = 1 To LMax ' is distance from click within radius of non-selected button?
58.             If Sqr((mx - LX(i)) ^ 2 + (my - LY(i)) ^ 2) <= Side * .5 * Sqr3 And LSELECTED(i) = 0 Then drawHex i, 1
59.         Next
60.     End If
61. Wend
62.  
63. Sub drawHex (i, selectedTF)
64.     If selectedTF = 0 Then
65.         Color _RGB32(255, 0, 0), _RGB32(255, 255, 0)
66.     Else
67.         Color _RGB32(0, 0, 0), _RGB32(255, 0, 255)
68.     End If
69.     For a = 0 To 6
70.         x1 = LX(i) + Side * Cos(a * Pi3): y1 = LY(i) + Side * Sin(a * Pi3)
71.  
72.         ' =============================== Different versions of Thick Lines ======================
73.         'If a > 0 Then Line (lastx, lasty)-(x1, y1), _RGB32(0, 0, 0) ' original no thick lines
74.  
75.         'If a > 0 Then thic lastx, lasty, x1, y1, 2, _RGB32(0, 0, 0) ' these rectangle thick lines
76.         ' leave gaps where they meet at angles rounded with circles they leave knobs, r-1 they
77.         ' still leave gaps!
78.  
79.         'Best
80.         If a > 0 Then thic2 lastx, lasty, x1, y1, 2, _RGB32(0, 0, 0)
81.         ' these thick lines are draw with filled circles like ball point pen
82.         '=========================================================================================
83.  
84.         lastx = x1: lasty = y1
85.     Next
86.     Paint (LX(i), LY(i)), _BackgroundColor, _RGB32(0, 0, 0)
87.     _PrintString (LX(i) - 9, LY(i) - 11), L$(i)
88.     If selectedTF Then ' show the order of selection
89.         Color _RGB32(0, 0, 0), _RGB32(200, 200, 220)
90.         LSELECTED(i) = 1
91.         Selected$ = Selected$ + L$(i)
92.         centerText 0, _Width, _Height - 60, Mid$(Selected$, 1, Int(LMax / 2))
93.         If Len(Selected$) > 10 Then
94.             centerText 0, _Width, _Height - 20, Mid$(Selected$, Int(LMax / 2) + 1)
95.             If Len(Selected$) = LMax Then Beep ' all have been selected
96.         End If
97.     End If
98. End Sub
99.  
100. Sub centerText (x1, x2, midy, s$) ' ' if you want to center fit a string between two goal posts x1, and x2
101.     _PrintString ((x1 + x2) / 2 - _PrintWidth(s$) / 2, midy - _FontHeight(_Font) / 2), s$
102. End Sub
103.  
104. 'update 2020-01-24 to include PD2 inside the sub
105. Sub thic (x1, y1, x2, y2, thick, K As _Unsigned Long)
106.     Dim PD2 As Double, t2 As Single, a As Single, x3 As Single, y3 As Single, x4 As Single, y4 As Single
107.     Dim x5 As Single, y5 As Single, x6 As Single, y6 As Single
108.     PD2 = 1.570796326794897
109.     t2 = thick / 2
110.     If t2 < 1 Then t2 = 1
111.     a = _Atan2(y2 - y1, x2 - x1)
112.     x3 = x1 + t2 * Cos(a + PD2)
113.     y3 = y1 + t2 * Sin(a + PD2)
114.     x4 = x1 + t2 * Cos(a - PD2)
115.     y4 = y1 + t2 * Sin(a - PD2)
116.     x5 = x2 + t2 * Cos(a + PD2)
117.     y5 = y2 + t2 * Sin(a + PD2)
118.     x6 = x2 + t2 * Cos(a - PD2)
119.     y6 = y2 + t2 * Sin(a - PD2)
120.     ftri x6, y6, x4, y4, x3, y3, K
121.     ftri x3, y3, x5, y5, x6, y6, K
122.     fcirc x1, y1, t2 - 1, _RGB32(0, 0, 0) ' close gaps where two lines meet
123.     fcirc x2, y2, t2 - 1, _RGB32(0, 0, 0)
124. End Sub
125.  
126. '2019-12-16 fix by Steve saves some time with STATIC and saves and restores last dest
127. Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
128.     Dim D As Long
129.     Static a&
130.     D = _Dest
131.     If a& = 0 Then a& = _NewImage(1, 1, 32)
132.     _Dest a&
133.     _DontBlend a& '  '<<<< new 2019-12-16 fix
134.     PSet (0, 0), K
135.     _Blend a& '<<<< new 2019-12-16 fix
136.     _Dest D
137.     _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
138. End Sub
139.  
140. Sub fcirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
141.     Dim Radius As Long, RadiusError As Long
142.     Dim X As Long, Y As Long
143.     Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
144.     If Radius = 0 Then PSet (CX, CY), C: Exit Sub
145.     Line (CX - X, CY)-(CX + X, CY), C, BF
146.     While X > Y
147.         RadiusError = RadiusError + Y * 2 + 1
148.         If RadiusError >= 0 Then
149.             If X <> Y + 1 Then
150.                 Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
151.                 Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
152.             End If
153.             X = X - 1
154.             RadiusError = RadiusError - X * 2
155.         End If
156.         Y = Y + 1
157.         Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
158.         Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
159.     Wend
160. End Sub
161.  
162. 'this version needs fcirc and is pretty inefficient but once and a while it comes in handy
163. Sub thic2 (x1, y1, x2, y2, rThick, K As _Unsigned Long)
164.     'x1, y1 is one endpoint of line
165.     'x2, y2 is the other endpoint of the line
166.     'rThick is the radius of the tiny circles that will be drawn
167.     '   from one end point to the other to create the thick line
168.     'Yes, the line will then extend beyond the endpoints with circular ends.
169.     rThick = Int(rThick / 2): stepx = x2 - x1: stepy = y2 - y1
170.     length = Int((stepx ^ 2 + stepy ^ 2) ^ .5)
171.     If length Then
172.         dx = stepx / length: dy = stepy / length
173.         For i = 0 To length
174.             fcirc x1 + dx * i, y1 + dy * i, rThick, K
175.         Next
176.     Else
177.         fcirc x1, y1, rThick, K
178.     End If
179. End Sub
180.  
181.  
182.