+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: Chatting and Socializing (https://qb64phoenix.com/forum/forumdisplay.php?fid=11)
+--- Forum: General Discussion (https://qb64phoenix.com/forum/forumdisplay.php?fid=2)
+--- Thread: Arrays as UDTs (/showthread.php?tid=4442)
RE: Arrays as UDTs - Unseen Machine - 02-04-2026
Code: (Select All)
' ==========================================================
' WORD 95 PRO: OMEGA GOD-MODE (CYRUS EDITION) - FOR PETE
' ==========================================================
'$DYNAMIC
_TITLE "Microsoft Word 95 Professional - OMEGA GOD-MODE"
SCREEN _NEWIMAGE(800, 600, 32)
_FONT 16
TYPE OmegaPool
Handle AS _OFFSET
Capacity AS LONG
TypeID AS LONG
END TYPE
' --- THE OMEGA KERNEL ---
DECLARE LIBRARY "QB_omega"
FUNCTION Omega_Create%& (BYVAL sz AS _INTEGER64, BYVAL t AS _INTEGER64)
SUB Omega_SetL (BYVAL a AS _OFFSET, BYVAL i AS _INTEGER64, BYVAL v AS LONG)
SUB Omega_SetS (BYVAL a AS _OFFSET, BYVAL i AS _INTEGER64, v AS STRING)
FUNCTION Omega_GetL& (BYVAL a AS _OFFSET, BYVAL i AS _INTEGER64)
FUNCTION Omega_GetS%& (BYVAL a AS _OFFSET, BYVAL i AS _INTEGER64)
FUNCTION Omega_Len& (BYVAL a AS _OFFSET, BYVAL i AS _INTEGER64)
SUB Omega_Destroy (BYVAL a AS _OFFSET)
END DECLARE
' --- GLOBALS & STATE ---
DIM SHARED MenuLabels AS OmegaPool
DIM SHARED MenuMap AS OmegaPool
DIM SHARED MenuCount AS LONG
DIM SHARED CurrentParent AS LONG
DIM SHARED MenuOpen AS _BYTE
DIM SHARED TopSel AS LONG
DIM SHARED ActiveSub AS LONG
DIM SHARED ContextOpen AS _BYTE
DIM SHARED ContextX AS INTEGER
DIM SHARED ContextY AS INTEGER
DIM SHARED DocContent AS STRING
DIM SHARED LastAction AS STRING
DIM SHARED CaretPos AS LONG
DIM SHARED ShowCaret AS _BYTE
DIM SHARED CaretTimer AS SINGLE
DIM SHARED UseWordWrap AS _BYTE
DIM SHARED ScrollY AS INTEGER
DIM SHARED MaxScroll AS INTEGER
Titan_Init MenuLabels, 1000, "string"
Titan_Init MenuMap, 1000, "long"
DocContent = "CYRUS THE GREAT BUILD. ARROW KEYS ACTIVE. SCROLLBAR LOCKED."
LastAction = "Idle"
ActiveSub = -1
CaretPos = LEN(DocContent)
UseWordWrap = 1
ScrollY = 0
MaxScroll = 2000
' --- BUILDER ---
mFile = NewMenu("&File")
AddItem "&New"
AddItem "&Open"
AddItem "&Save"
mSend = AddSub("Sen&d To >")
SetFocus mSend
AddItem "Mail Recipient"
AddItem "3.5 Floppy (A
"
SetFocus mFile
AddItem "E&xit"
mEdit = NewMenu("&Edit")
AddItem "&Undo"
AddItem "Cu&t"
AddItem "&Copy"
AddItem "&Paste"
mView = NewMenu("&View")
AddItem "Toggle &WordWrap"
AddItem "&Normal View"
mContext = 999
SetFocus mContext
AddItem "Cu&t"
AddItem "&Copy"
AddItem "&Paste"
' --- MAIN ENGINE LOOP ---
DO
_LIMIT 60
CLS
COLOR _RGB32(0, 0, 0), _RGB32(192, 192, 192)
PAINT (0, 0), _RGB32(192, 192, 192)
DO WHILE _MOUSEINPUT
mx = _MOUSEX
my = _MOUSEY
mb1 = _MOUSEBUTTON(1)
mb2 = _MOUSEBUTTON(2)
IF mb2 THEN
ContextOpen = 1
ContextX = mx
ContextY = my
MenuOpen = 0
ActiveSub = -1
END IF
IF mb1 THEN
IF my > 25 THEN
menuHit = 0
IF MenuOpen THEN
IF mx >= (TopSel * 95) AND mx <= (TopSel * 95) + 230 THEN
menuHit = 1
END IF
END IF
IF menuHit = 0 THEN
MenuOpen = 0
ContextOpen = 0
ActiveSub = -1
' Check if we are clicking the scrollbar before resetting caret
IF mx < 740 THEN
HandleMouseClick mx, my
END IF
END IF
END IF
' FIXED SCROLLBAR INTERACTION
IF mx >= 740 AND mx <= 760 AND my >= 60 AND my <= 540 THEN
ScrollY = (my - 60) * (MaxScroll / 480)
END IF
END IF
LOOP
DrawWorkspace
DrawTopBar mx, my, mb1
IF MenuOpen THEN
rootIdx = -1
count = 0
FOR i = 0 TO MenuCount - 1
IF Titan_GetL(MenuMap, i) = -1 THEN
IF count = TopSel THEN
rootIdx = i
EXIT FOR
END IF
count = count + 1
END IF
NEXT
IF rootIdx > -1 THEN
Draw95Menu rootIdx, (TopSel * 95) + 5, 25, mx, my, mb1, 0
END IF
END IF
IF ContextOpen THEN
Draw95Menu mContext, ContextX, ContextY, mx, my, mb1, 0
END IF
k$ = INKEY$
IF k$ <> "" THEN
HandleInput k$
END IF
IF TIMER - CaretTimer > 0.5 THEN
ShowCaret = NOT ShowCaret
CaretTimer = TIMER
END IF
_DISPLAY
LOOP UNTIL k$ = CHR$(27) AND NOT MenuOpen
SYSTEM
' --- RENDERING CORE ---
SUB DrawWorkspace
' Page Body
LINE (40, 60)-(740, 540), _RGB32(255, 255, 255), BF
LINE (40, 60)-(740, 540), _RGB32(0, 0, 0), B
' WIN95 VERTICAL SCROLLBAR (FIXED THUMB)
LINE (741, 60)-(760, 540), _RGB32(212, 208, 200), BF
LINE (741, 60)-(760, 540), _RGB32(0, 0, 0), B
' Thumb Math - Clamped so it never disappears
thumbH = 40
perc = ScrollY / MaxScroll
thumbY = 60 + (perc * (480 - thumbH))
IF thumbY < 60 THEN thumbY = 60
IF thumbY > 540 - thumbH THEN thumbY = 540 - thumbH
LINE (743, thumbY)-(758, thumbY + thumbH), _RGB32(192, 192, 192), BF
LINE (743, thumbY)-(758, thumbY + thumbH), _RGB32(0, 0, 0), B
COLOR _RGB32(0, 0, 0), _RGBA32(0, 0, 0, 0)
curX = 55
curY = 75 - ScrollY
marginRight = 715
FOR i = 1 TO LEN(DocContent) + 1
IF i = CaretPos + 1 THEN
IF ShowCaret THEN
IF curY > 60 AND curY < 525 THEN
LINE (curX, curY)-(curX, curY + 16), _RGB32(0, 0, 0)
END IF
END IF
' Auto-Follow
IF curY > 510 THEN ScrollY = ScrollY + 20
IF curY < 75 AND ScrollY > 0 THEN ScrollY = ScrollY - 20
END IF
IF i > LEN(DocContent) THEN EXIT FOR
c$ = MID$(DocContent, i, 1)
ascii = ASC(c$)
IF ascii = 13 OR ascii = 10 THEN
curX = 55
curY = curY + 20
ELSE
IF UseWordWrap AND curX > marginRight THEN
curX = 55
curY = curY + 20
END IF
IF curY > 60 AND curY < 525 THEN
_PRINTSTRING (curX, curY), c$
END IF
curX = curX + _PRINTWIDTH(c$)
END IF
NEXT
' Masking Header/Footer
LINE (40, 541)-(761, 600), _RGB32(192, 192, 192), BF
LINE (0, 0)-(800, 59), _RGB32(192, 192, 192), BF
END SUB
SUB HandleInput (k$)
IF MenuOpen OR ContextOpen THEN
IF k$ = CHR$(27) THEN MenuOpen = 0: ContextOpen = 0: ActiveSub = -1
EXIT SUB
END IF
SELECT CASE k$
CASE CHR$(8)
IF CaretPos > 0 THEN
DocContent = LEFT$(DocContent, CaretPos - 1) + MID$(DocContent, CaretPos + 1)
CaretPos = CaretPos - 1
END IF
CASE CHR$(0) + "K": IF CaretPos > 0 THEN CaretPos = CaretPos - 1
CASE CHR$(0) + "M": IF CaretPos < LEN(DocContent) THEN CaretPos = CaretPos + 1
' NEW: ARROW KEY VERTICAL NAVIGATION
CASE CHR$(0) + "H" ' UP
IF CaretPos >= 75 THEN CaretPos = CaretPos - 75
CASE CHR$(0) + "P" ' DOWN
IF CaretPos <= LEN(DocContent) - 75 THEN CaretPos = CaretPos + 75
CASE CHR$(13):
DocContent = LEFT$(DocContent, CaretPos) + CHR$(13) + MID$(DocContent, CaretPos + 1)
CaretPos = CaretPos + 1
CASE ELSE
IF LEN(k$) = 1 AND ASC(k$) >= 32 THEN
DocContent = LEFT$(DocContent, CaretPos) + k$ + MID$(DocContent, CaretPos + 1)
CaretPos = CaretPos + 1
END IF
END SELECT
END SUB
' (All other SUBs remain exactly as John verified them - No Colons!)
' ... DrawTopBar, Draw95Menu, HandleMouseClick, Omega Wrappers ...
SUB DrawTopBar (mx, my, mb)
LINE (0, 0)-(800, 24), _RGB32(192, 192, 192), BF
LINE (0, 24)-(800, 25), _RGB32(0, 0, 0), BF
idx = 0
FOR i = 0 TO MenuCount - 1
IF Titan_GetL(MenuMap, i) = -1 THEN
x = (idx * 95) + 10
t$ = GetText(MenuLabels, i)
IF mx > x - 5 AND mx < x + 85 AND my < 25 THEN
LINE (x - 5, 2)-(x + 85, 22), _RGB32(0, 0, 0), B
IF mb THEN
MenuOpen = 1
TopSel = idx
ActiveSub = -1
END IF
END IF
IF MenuOpen AND TopSel = idx THEN
LINE (x - 5, 2)-(x + 85, 22), _RGB32(0, 0, 128), BF
COLOR _RGB32(255, 255, 255), _RGBA32(0, 0, 0, 0)
ELSE
COLOR _RGB32(0, 0, 0), _RGBA32(0, 0, 0, 0)
END IF
_PRINTSTRING (x, 5), t$
idx = idx + 1
END IF
NEXT
END SUB
SUB Draw95Menu (pID, x, y, mx, my, mb, level)
DIM w
w = 220
row = 0
cCount = 0
FOR i = 0 TO MenuCount - 1
IF Titan_GetL(MenuMap, i) = pID THEN cCount = cCount + 1
NEXT
h = cCount * 22 + 10
LINE (x + 3, y + 3)-(x + w + 3, y + h + 3), _RGB32(64, 64, 64), BF
LINE (x, y)-(x + w, y + h), _RGB32(192, 192, 192), BF
LINE (x, y)-(x + w, y + h), _RGB32(0, 0, 0), B
FOR i = 0 TO MenuCount - 1
IF Titan_GetL(MenuMap, i) = pID THEN
t$ = GetText(MenuLabels, i)
yy = y + 5 + (row * 22)
IF mx > x AND mx < x + w AND my > yy AND my < yy + 22 THEN
LINE (x + 2, yy)-(x + w - 2, yy + 20), _RGB32(0, 0, 0), B
IF INSTR(t$, ">") THEN
ActiveSub = i
ELSE
IF level = 0 THEN ActiveSub = -1
IF mb AND t$ <> "-" THEN
IF t$ = "E&xit" THEN SYSTEM
IF t$ = "Toggle &WordWrap" THEN UseWordWrap = NOT UseWordWrap
MenuOpen = 0
ContextOpen = 0
ActiveSub = -1
END IF
END IF
END IF
IF ActiveSub = i THEN
LINE (x + 2, yy)-(x + w - 2, yy + 20), _RGB32(0, 0, 128), BF
COLOR _RGB32(255, 255, 255), _RGBA32(0, 0, 0, 0)
Draw95Menu i, x + w - 5, yy, mx, my, mb, level + 1
ELSE
COLOR _RGB32(0, 0, 0), _RGBA32(0, 0, 0, 0)
END IF
IF t$ = "-" THEN
LINE (x + 5, yy + 10)-(x + w - 5, yy + 11), _RGB32(128, 128, 128), BF
ELSE
_PRINTSTRING (x + 10, yy + 4), t$
END IF
row = row + 1
END IF
NEXT
END SUB
SUB HandleMouseClick (mx, my)
IF mx > 50 AND mx < 730 AND my > 70 AND my < 530 THEN
lineNum = (my - 75 + ScrollY) \ 20
charNum = (mx - 55) \ 9
CaretPos = charNum + (lineNum * 75)
IF CaretPos < 0 THEN CaretPos = 0
IF CaretPos > LEN(DocContent) THEN CaretPos = LEN(DocContent)
END IF
END SUB
FUNCTION NewMenu (t$)
Titan_SetS MenuLabels, MenuCount, t$
Titan_SetL MenuMap, MenuCount, -1
NewMenu = MenuCount
CurrentParent = MenuCount
MenuCount = MenuCount + 1
END FUNCTION
SUB AddItem (t$)
Titan_SetS MenuLabels, MenuCount, t$
Titan_SetL MenuMap, MenuCount, CurrentParent
MenuCount = MenuCount + 1
END SUB
FUNCTION AddSub (t$)
Titan_SetS MenuLabels, MenuCount, t$
Titan_SetL MenuMap, MenuCount, CurrentParent
AddSub = MenuCount
MenuCount = MenuCount + 1
END FUNCTION
SUB SetFocus (id)
CurrentParent = id
END SUB
SUB Titan_Init (P AS OmegaPool, sz AS LONG, pType AS STRING)
P.Handle = Omega_Create(sz, 2)
END SUB
SUB Titan_SetL (P AS OmegaPool, i AS LONG, v AS LONG)
Omega_SetL P.Handle, i, v
END SUB
FUNCTION Titan_GetL& (P AS OmegaPool, i AS LONG)
Titan_GetL = Omega_GetL(P.Handle, i)
END FUNCTION
SUB Titan_SetS (P AS OmegaPool, i AS LONG, s AS STRING)
Omega_SetS P.Handle, i, s + CHR$(0)
END SUB
FUNCTION GetText$ (P AS OmegaPool, idx AS LONG)
addr%& = Omega_GetS(P.Handle, idx)
L& = Omega_Len(P.Handle, idx)
IF addr%& = 0 OR L& <= 0 THEN
EXIT FUNCTION
END IF
DIM buffer AS STRING
buffer = SPACE$(L&)
DIM m AS _MEM
m = _MEM(addr%&, L&)
_MEMGET m, m.OFFSET, buffer
_MEMFREE m
GetText$ = buffer
END FUNCTIONRE: Arrays as UDTs - Pete - 02-04-2026
(02-04-2026, 02:05 AM)Unseen Machine Wrote: Well we define arrays with a range so i don't think that's unreasonable! But @Pete are you saying the new system works as you require? If not, I will (as always for you) happily mod and remake it till it does!
John
Your new system uses less code, so that's good, but I think I got more of a kick out of the original one with the cool node structure. I also checked Henry's code. It works well for numeric arrays, however I wasn't able to quickly get his working with strings. I'd have to look through that long code example he posted to see what I missed. So all these work, including my old build one giant indexed array, but none would beat a QB64 real UDT type addition for ease of coding.
I did run your latest menu demo. I see you got some shadow effect going. If you haven't done a WP before, I'll warn you straight up there is a lot stuffed down that rabbit hole, so if this is just a fun demo, I'd hit the brakes and move on. If you plan to expand on it you should decide it you want to break the text lines up into arrays, or just have it as one giant string. I've done some as a giant string. Interesting coding to say the least, but the ones I have used in the past were all done with arrays. BTW - I think the QB64 IDE is the one-string method.
Pete
RE: Arrays as UDTs - Unseen Machine - 02-04-2026
@Pete
Mate its a demo to show it working but i was chuffed i got the window actually accepting text input and the scroll bar sort of working too...
I will, as i said MAKE YOU anything you need or want in whatever fashion you desire! As you took the time many years ago to teach me how to code I am always here to help and poke fun at you! And again, this library was only made because YOU inspired me to do so...
Give me the idea, the command names and the framework and i'll make it happen SIR!
John
p.s With the C++ backend we can have strings of >1mb easily so no need to break em up!
RE: Arrays as UDTs - Pete - 02-04-2026
Okay, make me an AI Pete that makes fun of AI Steve! (Just kidding).
If something comes up in the near future, I'll let you know. Right now, I'm finishing up my menu lib, but I'm also looking at mulling through 100,000 plus files, before I totally forget what I've built over the past 40 years. I'm also tempted to do another single string wp and I want to take another look at a graphics one I posted here a few years back. https://qb64phoenix.com/forum/showthread.php?tid=2531 It's the highest rated WIP of all times! (Probably because of the title). The rabbit hole gets pretty deep when you're trying to assemble an algorithm for page and wrap that works with mixed font styles and sizes. I may need AI Tommy Chong to help me get back on that road trip through HellTown.
Pete
RE: Arrays as UDTs - bplus - 02-06-2026
For those who want something simple and not have to resort to things outside QB64 you can use long strings to act as an array. Here are tools to do that:
https://qb64phoenix.com/forum/showthread.php?tid=2414
Where it says Source$ in the sub or function plug-in your UDT string.
Instead of UDT.string(index) it's value$ = Item$(UDT.string, delimiter$, index)
Instead of UDT.string(index) = value$ it's
UDT.string = InsertItem$ (Source$, Delimiter$, Value$, NthPlace&)
and SEE! that you can do more with String Insertions than you can do with arrays Without ReDim or ReDim Preserve!
RE: Arrays as UDTs - Pete - 02-06-2026
Yes, this can be done in QB64. Eventually I hope a developer can use one of these mem routines to get us a real array in UDT feature. Until then we can either write huge variable lists in our sub passing procedures, or declare the arrays as Shared or Global. I've played around with Shared and Global by using the dot nomenclature with a similar prefix for the array(s)...
Code: (Select All)
Dim Shared zz.pete(10) As String
Type foo
a As Integer
End Type
Dim z As foo
z.a = 1: zz.pete(1) = "Pete's TREMENDOUS. Steve's just amazing (TM)."
dsp z
Sub dsp (z As foo)
Print "#" + LTrim$(Str$(z.a)) + " " + zz.pete(1)
End Sub
As for a QB64 method like @bplus was describing. I've used this...
Code: (Select All)
Type foo
index As String
array As String
build As String
id As Integer
End Type
Dim z As foo
Pack_Strings z: Display_Arrays z
Sub Pack_Strings (z As foo) ' Get our strings from our database, pack, and index them.
While -1
i = i + 1: j = 0
Do
Read a$
If a$ = "eof" Then Exit While
If a$ = "eol" Then Exit Do
z.index = z.index + LTrim$(Str$(i)) + "," + LTrim$(Str$(Len(a$))) + "|"
z.array = z.array + a$
j = j + 1
Loop
Wend
End Sub
Sub Display_Arrays (z As foo) ' Unpack string, fill arrays, and display them.
ReDim a(10), Fruits$(10), Veggies$(10), Meats$(10)
Do
Unpack_String z: If z.id = 0 Then Exit Do
If z.id <> oldid Then a = 0
a = a + 1
Select Case z.id
Case 1: Fruits$(a) = z.build
Case 2: Veggies$(a) = z.build
Case 3: Meats$(a) = z.build
End Select
oldid = z.id
Loop
For i = 1 To UBound(Fruits$)
If Len(Fruits$(i)) Then Print Fruits$(i)
Next
Print
For i = 1 To UBound(Veggies$)
If Len(Veggies$(i)) Then Print Veggies$(i)
Next
Print
For i = 1 To UBound(Meats$)
If Len(Meats$(i)) Then Print Meats$(i)
Next
End Sub
Sub Unpack_String (z As foo) ' Returns each indexed string.
Static seed, c
j = InStr(seed, z.index, ","): If j = 0 Then z.id = 0: seed = 0: c = 0: Exit Sub
z.id = Val(Mid$(z.index, j - 1))
b = Val(Mid$(z.index, j + 1, InStr(Mid$(z.index, j + 1), "|")))
seed = j + 1
z.build = Mid$(z.array, c + 1, b)
c = c + b
End Sub
Data Fruits,Apple,Orange,Pear,Banana,Plum,eol
Data Veggies,Squash,Peas,Green Beans,Carrot,Celery,eol
Data Meats,Steak,Bacon,Chicken,Fish,eol
Data eofPete
RE: Arrays as UDTs - bplus - 02-06-2026
Or this way:
Code: (Select All)
Type Menu
As String MName, MList
As Integer MlistCnt
End Type
M$ = "Fruits;Apple,Orange,Pear,Banana,Plum:" +_
"Veggies;Squash,Peas,Green Beans,Carrot,Celery:"+_
"Meats;Steak,Bacon,Chicken,Fish"
nM = StrCount(M$, ":") + 1
Dim foods(1 To nM) As Menu
For i = 1 To nM
s$ = GetItem$(M$, ":", i)
'Print s$
foods(i).MName = GetItem$(s$, ";", 1)
foods(i).MList = GetItem$(s$, ";", 2)
nList = StrCount(foods(i).MList, ",") + 1
Print i; ""; foods(i).MName; ":"
For j = 1 To nList
Print Space$(4); j; " "; GetItem$(foods(i).MList, ",", j)
Next
Print
Next
Input "enter: food type number, item number eg 2,4 for Veggies: Carrot"; c1, c2
Print " You chose: "; foods(c1).MName, GetItem$(foods(c1).MList, ",", c2)
Function GetItem$ (AString$, Delimiter$, Index As Long) ' alternate Item$() function
'use: Function StrCount& (AString$, Char$ )
'use: Function StrPlace& (AString$, Char$, Nth&)
ReDim cnt As Long, p1 As Long, p2 As Long
cnt = StrCount&(AString$, Delimiter$) + 1
p1 = StrPlace&(AString$, Delimiter$, Index - 1)
p2 = StrPlace&(AString$, Delimiter$, Index)
If Index > cnt Or Index < 1 Then
Exit Function ' beyond the limit of string
ElseIf Index = 1 Then
GetItem$ = Mid$(AString$, 1, p2 - 1)
ElseIf Index = cnt Then
GetItem$ = Mid$(AString$, p1 + Len(Delimiter$))
Else 'between
GetItem$ = Mid$(AString$, p1 + Len(Delimiter$), p2 - p1 - Len(Delimiter$))
End If
End Function
Function StrCount& (AString$, S$) ' Count S$ in Astring$
ReDim place As Long, cnt As Long, lenS As Long
place = InStr(AString$, S$): lenS = Len(S$)
While place
cnt = cnt + 1
place = InStr(place + lenS, AString$, S$)
Wend
StrCount& = cnt
End Function
Function StrPlace& (Astring$, S$, Nth As Long) ' Locate the place the Nth S$ is in Astring$
ReDim place As Long, cnt As Long, lenS As Long
place = InStr(Astring$, S$): lenS = Len(S$)
While place
cnt = cnt + 1
If cnt = Nth Then StrPlace& = place: Exit Function
place = InStr(place + lenS, Astring$, S$)
Wend
End Function