The task is to produce a matrix of 20 hexagon shaped widgets in a honeycomb arrangement. The matrix should be arranged in such a manner that there are five
columns of four hexagons. The hexagons in columns one, three and five are aligned horizontally, whereas the hexagons in columns two and four occupy a lower position within the arrangement. Each hexagon should be the same colour, and should
display a unique randomly selected single capital letter on the front. The application should now wait for the user to select a hexagon, either by using a pointing device, or by pressing a key that carries a corresponding letter on a hexagon. For platforms that support pointing devices and keyboards, the application should support both methods of selection. A record of the chosen letters should be maintained and the code should be suitably commented, at the point where the the selected letter has been determined. The selected hexagon should now change colour on the display. The cycle repeats until the user has chosen all of the letters. Note that each letter can only be selected once and previously selected hexagons retain their colour after selection. The program terminates when all letters have been chosen.

Optionally: output the list of selected letters and show the last selected letter, cater for a different number of columns or a different number of hexagons in each column, cater for two players, (turns alternate and the hexagons change a different colour depending on whether they were selected by player one or player two and records of both players selections are maintained.)



 
NoMainWin
Dim hxc(20,2), ltr(26)
Global sw, sh, radius, radChk, mx, my, h$, last
h$="#g": radius = 40: radChk = 35 * 35: last = 0
sw = 400: sh = 380: WindowWidth = sw+6: WindowHeight= sh+32
Open "Liberty BASIC - Honeycombs" For graphics_nsb_nf As #g
#g "Down; Cls; TrapClose xit"
 
Call shuffle
Call grid 75, 15, "0 0 0", "255 215 32", "0 0 0"
 
#g "SetFocus; when characterInput getKey; when leftButtonDown chkClick"
Wait
 
Sub xit h$
    Close #h$:End
End Sub
 
'Assign ASCII values of A thru Z to ltr() array and randomize order of letters
Sub shuffle
    For i = 1 To 26
        ltr(i) = i+64
    Next
    For i = 1 To 77
        r1 = Int(Rnd(1)*26)+1
        r2 = Int(Rnd(1)*26)+1
        temp = ltr(r1): ltr(r1) = ltr(r2): ltr(r2) = temp
    Next
End Sub
 
'Draw the hex cells and fill with 20 out of 26 random letters
Sub grid ox, oy, fc$, bc$, tc$
    cx = ox: cy = oy
    For i = 1 To 5
        If (i And 1)=0 Then cy = oy + 76 Else cy = oy + 42
        For j = 1 To 4
            count = count + 1: letter$ = Chr$(ltr(count))
            Call cell, cx, cy, fc$, bc$, tc$, letter$
            hxc(count,0)=cx: hxc(count,1)=cy: cy = cy + 70
        Next
        cx = cx + 61
    Next
End Sub
 
'Draw a filled hex cell and printed the letter associated with cell
Sub cell cx, cy, fc$, bc$, tc$, lt$
    lastx = cx + radius: lasty = cy
    For f = 1.04719755 To 6.2831853 Step 1.0471955
        nx = Cos(f)*radius+cx: ny = Sin(f)*radius+cy
        #g "Size 2; Color ";bc$;";BackColor ";bc$
        Call triFill cx, cy, lastx, lasty, nx, ny
        #g "Size 5; Color ";fc$
        #g "Line ";lastx;" ";lasty;" ";nx;" ";ny;";Size 1"
        lastx = nx: lasty = ny
    Next
    #g "Font Courier_New 36 Bold"
    #g "Color ";tc$;";BackColor ";bc$
    #g "Place ";cx-15;" ";cy+15;";\";lt$
End Sub
 
'Check for a mouse click in a hex cell
Sub chkClick h$, x, y
    mx = MouseX
    my = MouseY
    For i = 1 To 20
        If pnc(mx,my,hxc(i,0),hxc(i,1)) = 1 Then 'selected hex cell found
            If hxc(i,2)=0 Then
                hxc(i,2)=1 'when set to 1, hex cell & letter no longer selectable
                key$ = Chr$(ltr(i))
                Call cell hxc(i,0),hxc(i,1),"0 0 0","80 0 128","255 255 255",key$
                Call showLetter key$
                Exit For
            End If
        End If
    Next
End Sub
 
'Allow letter selection via keyboard
Sub getKey h$, char$
    key$ = Upper$(Inkey$)
    'Poll ESC key to exit at any time
    If key$=Chr$(27) Then Call xit h$
    idx = Instr("ABCDEFGHIJKLMNOPQRSTUVWXYZ",key$)
    If idx <> 0 Then
        For i = 1 To 20
            If idx+64 = ltr(i) Then 'letter matching key press found
                If hxc(i,2)=0 Then
                    hxc(i,2)=1 'when set to 1, hex cell & letter no longer selectable
                    Call cell hxc(i,0),hxc(i,1),"0 0 0","80 0 128","255 255 255",key$
                    Call showLetter key$
                    Exit For
                End If
            End If
        Next
    End If
End Sub
 
'Print letters selected at bottom of screen
Sub showLetter key$
    #g "Font Courier_New 18 Bold"
    #g "Color Black;BackColor white"
    #g "Place ";last*18+20;" 365;\"; key$
    last = last + 1
    'When 20th letter selected; exit
    If last > 19 Then Call xit h$
End Sub
 
'Draw a filled triangle
Sub triFill x1,y1, x2,y2, x3,y3
    If x2<x1 Then x=x2: y=y2: x2=x1: y2=y1: x1=x: y1=y
    If x3<x1 Then x=x3: y=y3: x3=x1: y3=y1: x1=x: y1=y
    If x3<x2 Then x=x3: y=y3: x3=x2: y3=y2: x2=x: y2=y
    If x1<>x3 Then slope1=(y3-y1)/(x3-x1)
    length=x2-x1
    If length<>0 Then
        slope2=(y2-y1)/(x2-x1)
        For x = 0 To length
            #g "Line ";Int(x+x1);" ";Int(x*slope1+y1);" ";Int(x+x1);" ";Int(x*slope2+y1)
        Next
    End If
    y = length*slope1+y1 :length=x3-x2
    If length<>0 Then
        slope3=(y3-y2)/(x3-x2)
        For x = 0 To length
            #g "Line ";Int(x+x2);" ";Int(x*slope1+y);" ";Int(x+x2);" ";Int(x*slope3+y2)
        Next
    End If
End Sub
 
'Point in Circle function
Function pnc(ax, ay, bx, by)
    If (bx-ax)*(bx-ax)+(by-ay)*(by-ay) <= radChk Then
        pnc=1
    Else
        pnc=0
    End If
End Function
 