Liberty BASIC Community Forum
« [RC] Honeycombs »

Welcome Guest. Please Login or Register.
Jan 22nd, 2018, 6:05pm


Rules|Home|Help|Search|Recent Posts|Notification


« Previous Topic | Next Topic »
Pages: 1  Notify Send Topic Print
 thread  Author  Topic: [RC] Honeycombs  (Read 834 times)
AndyAmaya
Senior Member
ImageImageImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 265
xx [RC] Honeycombs
« Thread started on: Sep 24th, 2015, 11:50am »

RC Honeycombs

Quote:
Honeycombs
You are encouraged to solve this task according to the task description, using any language you may know.
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.


Code:
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
 
User IP Logged

Knowledge liberates minds. It does not diminish when shared with more minds. Instead, the more it is shared, the more it grows.
tsh73
Moderator
ImageImageImageImageImage


member is offline

Avatar

Anatoly (real name)


PM

Gender: Male
Posts: 1732
xx Re: [RC] Honeycombs
« Reply #1 on: Sep 25th, 2015, 03:25am »

Such a complexly weird task.
Nicely done wink
User IP Logged

damned Dog in the Manger
AndyAmaya
Senior Member
ImageImageImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 265
xx Re: [RC] Honeycombs
« Reply #2 on: Sep 25th, 2015, 09:39am »

Thanks.

It's not so weird if you look at it as the basis for one of those old turn based strategy games played on a hex grid. wink
User IP Logged

Knowledge liberates minds. It does not diminish when shared with more minds. Instead, the more it is shared, the more it grows.
Alyce Watson
Administrator
ImageImageImageImageImage


member is offline

Avatar




Homepage PM

Gender: Female
Posts: 14918
xx Re: [RC] Honeycombs
« Reply #3 on: Nov 19th, 2015, 08:52am »

on Sep 25th, 2015, 03:25am, tsh73 wrote:
Such a complexly weird task.
Nicely done wink


My words, exactly!
User IP Logged

Alyce
Liberty BASIC Workshop - a complete IDE for Liberty BASIC


Alyce's Restaurant
for Liberty BASIC code, tools and references
Jack Kelly
New Member
Image


member is offline

Avatar




Homepage PM

Gender: Male
Posts: 17
xx Re: [RC] Honeycombs
« Reply #4 on: Oct 22nd, 2016, 2:00pm »

Andy completed this task over a year ago. He couldn't have done a better job at it! Would it be ok with everyone if I posted it on Rosetta Code?
User IP Logged

Rod
Global Moderator
ImageImageImageImageImage


member is offline

Avatar

Graphics = goosebumps!


PM

Gender: Male
Posts: 5618
xx Re: [RC] Honeycombs
« Reply #5 on: Oct 22nd, 2016, 2:37pm »

I don't think you need to ask permission. You are well capable of deciding if it fits the bill, if so post it.

Most of us are recreational users of Liberty BASIC and supporters of it's forums. That means we have limited time and drop in and out, so things get missed.

It is a an open café club culture so do as much as you can.

And welcome back.

User IP Logged

Jack Kelly
New Member
Image


member is offline

Avatar




Homepage PM

Gender: Male
Posts: 17
xx Re: [RC] Honeycombs
« Reply #6 on: Oct 23rd, 2016, 03:59am »

Thanks, Rod. Posted as approved.
User IP Logged

Pages: 1  Notify Send Topic Print
« Previous Topic | Next Topic »

Rules|Home|Help|Search|Recent Posts|Notification

Donate $6.99 for 50,000 Ad-Free Pageviews!

| |

This forum powered for FREE by Conforums ©
Sign up for your own Free Message Board today!
Terms of Service | Privacy Policy | Conforums Support | Parental Controls