This is an example CanvasGadget that I wrote up for a task on RosettaCode. Even though the need for a gadget like this is contrived for the RosettaCode task I thought it would also make a useful example here.
It is designed to meet the task as it was specified on RosettaCode but it contains elements which can easily modified and adapted to one's own needs.
First, the task involved creating a honeycomb of smaller hex gadgets (each with a random unique letter) that reacted to both mouseclicks and key presses. The hex region changed color and a message was displayed reporting the selection. A hex region could only be selected, and not unselected. After five selections the program ends. I modified the task to allow nine selections, which is enough to select the letters in PureBasic (if all are present).
Useful things that the program code demonstrates include: defining polygon regions within a gadget and detecting mouse interactions within a region, detecting keyclicks for a canvas gadget and acting on them and drawing to a CanvasGadget. It also demonstrates prototypes.
Some comments on the polygon regions is in order. The polygon regions are defined according to their vertexes. An alternative method for defining regions by pixel color is provided by netmaestro's excellent CustomRegions.pbi. One significant difference between the two is the amount of memory required to define the regions. To define the honeycomb regions with the CustomRegions.pbi would require about 54275 bytes (2171 bytes for each hex region) whereas defining the regions using the polygon method requires 1200 bytes (24 bytes for each hex region). There is also a difference in speed, CustomRegions.pbi is faster, though the difference may be insignificant based on the number and the complexity of the regions. Both methods are useful and should be evaluated based on the regions needed. They can even be intermixed.
I hope this is useful to someone...
Code: Select all
Macro PS(a)
#PB_Shortcut_#a
EndMacro
DataSection
keyAlphaArray:
Data.i ps(a), ps(b), ps(c), ps(d), ps(e), ps(f), ps(g), ps(h), ps(i), ps(j), ps(k), ps(l), ps(m)
Data.i ps(n), ps(o), ps(p), ps(q), ps(r), ps(s), ps(t), ps(u), ps(v), ps(w), ps(x), ps(y), ps(z)
EndDataSection
Structure integerArray
i.i[0]
EndStructure
Structure hexGadget
text.s
Status.i ;nonselected = 0, selected = 1
center.POINT ;location of hex's center
List shape.POINT()
EndStructure
Structure honeycomb
gadgetID.i
margins.POINT
unusedLetters.s
chosen.s
maxLength.i
Array hexGadgets.hexGadget(0)
textY.i
fontID.i
EndStructure
Prototype hexEvent_prt(*h.honeycomb, hexID)
Global *keyAlphaArray.integerArray = ?keyalphaarray
Procedure inpoly(*p.POINT, List poly.POINT())
;returns 1 if point is inside the polygon defined by poly(), otherwise returns 0
Protected new.POINT, old.POINT, lp.POINT, rp.POINT, i, inside, *poly
If ListSize(poly()) < 3: ProcedureReturn 0: EndIf
LastElement(poly()): old = poly()
ForEach poly()
;find leftmost endpoint 'lp' and the rightmost endpoint 'rp' based on x value
If poly()\x > old\x
lp = old
rp = poly()
Else
lp = poly()
rp = old
EndIf
If lp\x < *p\x And *p\x <= rp\x And (*p\y - lp\y) * (rp\x - lp\x) < (rp\y - lp\y) * (*p\x - lp\x)
inside = ~inside
EndIf
old = poly()
Next
ProcedureReturn inside & 1
EndProcedure
;draw a hex Gadget by number
Procedure drawhex(*h.honeycomb, hexID)
With *h\hexGadgets(hexID)
Protected p.POINT
If LastElement(\shape())
p = \shape()
EndIf
ForEach \shape()
LineXY(p\x, p\y, \shape()\x, \shape()\y, RGB(0, 0, 0)) ;black
p = \shape()
Next
DrawingMode(#PB_2DDrawing_Transparent)
DrawingFont(FontID(*h\fontID))
If \Status
FillArea(\center\x + 1, \center\y + 1, RGB(0, 0, 0), RGB($FF, 0, $FF)) ;magenta
DrawText(\center\x - TextWidth(\text) / 2, \center\y - TextHeight(\text) / 2, \text, RGB(0, 0, 1)) ;black, almost
Else
FillArea(\center\x + 1, \center\y + 1, RGB(0, 0, 0), RGB($FF, $FF, 0)) ;yellow
DrawText(\center\x - TextWidth(\text) / 2, \center\y - TextHeight(\text) / 2, \text, RGB($FF, 0, 0)) ;red
EndIf
EndWith
EndProcedure
Procedure selectHex(*h.honeycomb, hexID)
If Not *h\hexGadgets(hexID)\Status
*h\chosen + *h\hexGadgets(hexID)\text
*h\hexGadgets(hexID)\Status = 1
StartDrawing(CanvasOutput(*h\gadgetID))
drawhex(*h, hexID)
DrawingMode(#PB_2DDrawing_Default)
DrawingFont(#PB_Default)
DrawText(0, *h\textY, "Chosen: " + *h\chosen)
DrawText(0, *h\textY + 20, "The user chose letter " + *h\hexGadgets(hexID)\text + ". ")
StopDrawing()
ProcedureReturn 1
EndIf
EndProcedure
Procedure hexKey(*h.honeycomb, hexID)
Protected key = GetGadgetAttribute(*h\gadgetID, #PB_Canvas_Key)
If key = *keyAlphaArray\i[Asc(*h\hexGadgets(hexID)\text) - 65]
ProcedureReturn selectHex(*h, hexID)
EndIf
EndProcedure
Procedure hexMouse(*h.honeycomb, hexID)
Protected mPos.POINT
mPos\x = GetGadgetAttribute(*h\gadgetID, #PB_Canvas_MouseX)
mPos\y = GetGadgetAttribute(*h\gadgetID, #PB_Canvas_MouseY)
If inpoly(mPos,*h\hexGadgets(hexID)\shape())
ProcedureReturn selectHex(*h, hexID)
EndIf
EndProcedure
Procedure honeycombEvents(*h.honeycomb)
If Len(*h\chosen) >= *h\maxLength: ProcedureReturn: EndIf
Protected event = EventType(), *eventFunction.hexEvent_prt
Select event
Case #PB_EventType_KeyDown
*eventFunction = @hexKey()
Case #PB_EventType_LeftButtonUp
*eventFunction = @hexMouse()
Case #PB_EventType_LostFocus
SetActiveGadget(*h\gadgetID)
EndSelect
If *eventFunction
For hexID = 0 To ArraySize(*h\hexGadgets())
If *eventFunction(*h, hexID)
Break ;event successfully handled
EndIf
Next
EndIf
EndProcedure
Procedure createHexGadget(*h.honeycomb, hexID, x, y, dx, dy)
With *h\hexGadgets(hexID)
If *h\unusedLetters
Protected letterNum = Random(Len(*h\unusedLetters) - 1) + 1
\text = Mid(*h\unusedLetters, letterNum, 1)
*h\unusedLetters = ReplaceString(*h\unusedLetters, \text, "")
EndIf
\center\x = x: \center\y = y
AddElement(\shape()): \shape()\x = x - dx: \shape()\y = y
AddElement(\shape()): \shape()\x = x - dx / 2: \shape()\y = y + dy
AddElement(\shape()): \shape()\x = x + dx / 2: \shape()\y = y + dy
AddElement(\shape()): \shape()\x = x + dx: \shape()\y = y
AddElement(\shape()): \shape()\x = x + dx / 2: \shape()\y = y - dy
AddElement(\shape()): \shape()\x = x - dx / 2: \shape()\y = y - dy
EndWith
EndProcedure
Procedure initHoneycomb(*h.honeycomb, posX, posY, dx = 30, dy = 25, marginX = 10, marginY = 5)
Protected i, sx, sy, hCols = 5, hRows = 5, hexGadgetCount = hCols * hRows - 1
If Not *h: ProcedureReturn 0: EndIf
*h\unusedLetters.s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
*h\chosen = ""
*h\maxLength = 9
Dim *h\hexGadgets(hexGadgetCount)
;calculate size width, height and create honeycomb with margins
sx = Round(dx * (0.5 + hCols * 1.5), #PB_Round_Nearest) + 1 + 2 * marginX
sy = dy * (2 * hRows + 1) + 1 + 2 * marginY + 2 * 20 ;includes room for hex, margins, and text
*h\textY = sy - 2 * 20
;create hexes
Protected hexID, column, row, x, y, baseX, baseY, majorOffsetY = dy
baseX = dx + marginX
For column = 0 To hCols - 1
baseY = dy + marginY
majorOffsetY ! dy
For row = 0 To hRows - 1
x = baseX
y = baseY + majorOffsetY
createHexGadget(*h, hexID, x, y, dx, dy)
baseY + dy * 2
hexID + 1
Next
baseX + dx * 1.5
Next
;draw honeycomb
*h\gadgetID = CanvasGadget(#PB_Any, posX, posY, sx, sy, #PB_Canvas_Keyboard | #PB_Canvas_ClipMouse)
If *h\gadgetID = 0: ProcedureReturn 0: EndIf ;failed to created honeycomb
*h\fontID = LoadFont(#PB_Any, "Arial", 24, #PB_Font_Bold)
StartDrawing(CanvasOutput(*h\gadgetID))
For i = 0 To ArraySize(*h\hexGadgets())
drawhex(*h, i)
Next
Box(0, *h\textY, sx, 40, RGB(0, 0, 0)) ;draw black text box
StopDrawing()
ProcedureReturn 1
EndProcedure
If OpenWindow(0, 0, 0, 400, 400, "PureBasic - Honeycombs", #PB_Window_SystemMenu)
Define honeycomb.honeycomb, quit
If Not initHoneycomb(honeycomb, 0, 0): End: EndIf
ResizeWindow(0, #PB_Ignore, #PB_Ignore, GadgetWidth(honeycomb\gadgetID), GadgetHeight(honeycomb\gadgetID))
SetActiveGadget(honeycomb\gadgetID)
Repeat
event = WaitWindowEvent()
Select event
Case #PB_Event_Gadget
If EventGadget() = honeycomb\gadgetID
honeycombEvents(honeycomb)
If Len(honeycomb\chosen) = honeycomb\maxLength
MessageRequester("Exit", "You chose: " + honeycomb\chosen + ".")
quit = 1
EndIf
EndIf
Case #PB_Event_CloseWindow
quit = 1
EndSelect
Until quit = 1
EndIf
