Recent posts

#91
Source Code and Discussions / Sunrise Calculation
Last post by Theo Gottwald - May 06, 2024, 11:19:25 AM
Copied from: Powerbasic Forum
'Reposted by Eric Pearson 03 May 2024 to remove COLOR tags caused by vBulletin database problems.
'Edited by David Roberts; 29 Mar 2015, 06:29 AM.
'"Calc_sunrise_set.bas" coded by O. Heinemeyer 3/2015
'Originally created for PBFORMS
'Modified to run in PBWIN10.4
'Update by Jim Fritts on 13 JAN 2017
'Added correction for negative longitude to locate west of Prime Meridian
'Added correction for Julian Date error
'Added display for Julian Date
'Added Date picker selection for DateStr
'Fairly accurate based on data from:
'http://aa.usno.navy.mil/data/docs/RS_OneYear.php
'Rise and Set times are within 3 minutes of table data
'when tested on the 1st and 15th of each month.

'note: did not correct issues with selecting a different UTC.
' Does not incorporate offset for DLS.

'Works with Jose Roca's includes
'Not tested with PB includes
'
'Program code to calculate sunrise and sunset times for any date and location
'Mr. Heinemeyer did a great job. Thanks!

'
'------------------------------------------------------------------------------
#COMPILER PBWIN 10
#COMPILE EXE "Calc_sunrise_set.exe"
#DIM ALL
#TOOLS OFF
'------------------------------------------------------------------------------
' ** Includes **
'------------------------------------------------------------------------------
%USEMACROS = 1
#INCLUDE ONCE "WIN32API.INC"
#INCLUDE ONCE "COMMCTRL.INC"
'---- -------------------------------------------------------------------------
GLOBAL ghDlg AS DWORD
GLOBAL stTime AS SYSTEMTIME
MACRO Pixz = 3.1415926535897932384626433832795##
MACRO Rad = 0.017453292519943295769236907684886##

GLOBAL NewComCtl AS LONG

'------------------------------------------------------------------------------
' ** Constants **
'------------------------------------------------------------------------------
%IDD_DIALOG1 = 101
%IDC_LABEL1 = 1006
%IDC_LABEL2 = 1007
%IDC_LABEL3 = 1008
%IDC_LABEL4 = 1009
%IDC_LABEL5 = 1012
%IDC_LABEL6 = 1013
%IDC_FRAME1 = 1014
%IDC_FRAME2 = 1015
%IDC_FRAME3 = 1016
%IDC_SYSMONTHCAL32_1 = 1020
%IDC_LABEL7 = 1021
%IDC_FRAME4 = 1022
%IDC_LABEL8 = 1023
%IDC_CALCULATE = 1004
%IDC_LATITUDE = 1010
%IDC_LONGITUDE = 1011
%IDC_SUNRISE = 1002
%IDC_SUNSET = 1003
%IDCANCEL = 2
%IDC_LABEL9 = 1026
%IDC_LABEL10 = 1027
%IDC_TEXTBOX1 = 1028
%IDC_LABEL11 = 1029
%IDC_UTC_0 = 1030
%IDC_UTC_1 = 1031
%IDC_UTC_2 = 1032
%IDC_TEXTBOX2 = 1033
%IDC_LABEL12 = 1034
%IDC_TEXTBOX3 = 1035 'display the selected julian date
'------------------------------------------------------------------------------
' ** Declarations **
'------------------------------------------------------------------------------
DECLARE CALLBACK FUNCTION ShowDIALOG1Proc()
DECLARE FUNCTION ShowDIALOG1(BYVAL hParent AS DWORD) AS LONG

DECLARE FUNCTION zInitCommonControlsEx (icc AS INIT_COMMON_CONTROLSEX) AS LONG

'------------------------------------------------------------------------------
' ** Main Application Entry Point **
'------------------------------------------------------------------------------
FUNCTION PBMAIN()
'Variables for IP-Camera handling
LOCAL hDlg AS LONG
LOCAL t1, t2 AS STRING
LOCAL year, month, day AS WORD
'Variables for Sunriseset calculation
LOCAL tr, sr, ss, RA, Decl, latitude, longitude AS EXT
LOCAL sMsg AS STRING
LOCAL vDate AS DOUBLE
LOCAL st AS SYSTEMTIME

NewComCtl = InitComctl32X (%ICC_BAR_CLASSES OR %ICC_WIN95_CLASSES OR %ICC_DATE_CLASSES OR _
%ICC_INTERNET_CLASSES)

ShowDIALOG1 %HWND_DESKTOP

END FUNCTION
'------------------------------------------------------------------------------
' ** CallBacks **
'------------------------------------------------------------------------------
CALLBACK FUNCTION ShowDIALOG1Proc()

LOCAL pNMSC AS NMSELCHANGE PTR
LOCAL pDTMC AS NMDATETIMECHANGE PTR
GLOBAL DateStr AS STRING
STATIC time_zone AS LONG
LOCAL i, hFile, dayofyear, old_zone AS LONG
LOCAL a, srise, sset AS STRING

DIM buffer(6) AS STATIC STRING

'Variables for Sunriseset calculation
LOCAL result, sMsg AS STRING
LOCAL tr, sr, ss, RA, Decl, latitude, longitude AS EXT
LOCAL vDate AS DOUBLE
LOCAL st AS SYSTEMTIME

SELECT CASE AS LONG CB.MSG

CASE %WM_INITDIALOG
IF ISFILE(EXE.NAME$ +".inf") THEN
hFile = FREEFILE
OPEN EXE.NAME$+".inf" FOR INPUT AS hFile
WHILE NOT EOF (hFile)
LINE INPUT# hFile, buffer(i)
INCR i
WEND
CLOSE hFile
END IF
'data from .inf file -> dialog
CONTROL SET TEXT ghDlg, %IDC_LATITUDE, buffer(1)
CONTROL SET TEXT ghDlg, %IDC_LONGITUDE, buffer(2)

CONTROL SET OPTION ghDlg, %IDC_UTC_0+VAL(buffer(6)), %IDC_UTC_0, %IDC_UTC_2
time_zone = VAL(buffer(6)) ' 0, 1 or 2

DateStr = MID$(DATE$, 4, 2) + "." + MID$(DATE$, 1, 2) + "." + MID$(DATE$, 7, 4)
PostMessage ghDlg, %WM_COMMAND, %IDC_CALCULATE, 0


CASE %WM_NCACTIVATE
STATIC hWndSaveFocus AS DWORD
IF ISFALSE CB.WPARAM THEN
' Save control focus
hWndSaveFocus = GetFocus()
ELSEIF hWndSaveFocus THEN
' Restore control focus
SetFocus(hWndSaveFocus)
hWndSaveFocus = 0
END IF

CASE %WM_NOTIFY

SELECT CASE CB.CTL

CASE %IDC_SYSMONTHCAL32_1
' Set up the NMSELCHANGE pointer passed in CB.LPARAM
pNMSC = CB.LPARAM

' Detect changes in the calendar control
IF @pNMSC.hdr.code = %MCN_SELCHANGE THEN ' Get selected date/time
DateStr = FORMAT$(@pNMSC.stSelStart.wDay,"00")+"." _
+ FORMAT$(@pNMSC.stSelStart.wMonth,"00")+"." _
+ FORMAT$(@pNMSC.stSelStart.wYear,"0000")

END IF

END SELECT


CASE %WM_SYSCOLORCHANGE, %WM_WININICHANGE
' If user changes system settings (color, etc), forward the change
' notification message to the Calendar control
CONTROL SEND CB.HNDL, %IDC_SYSMONTHCAL32_1, CB.MSG, CB.WPARAM, CB.LPARAM

CASE %WM_COMMAND
' Process control notifications
SELECT CASE AS LONG CB.CTL

CASE %IDC_UTC_0
old_zone = time_zone
time_zone = 0
IF time_zone <> old_zone THEN
ChangeTime(ghDlg,%IDC_SUNRISE, (time_zone-old_zone))
ChangeTime(ghDlg,%IDC_SUNSET, (time_zone-old_zone))
END IF
CASE %IDC_UTC_1
old_zone = time_zone
time_zone = 1
IF time_zone <> old_zone THEN
ChangeTime(ghDlg,%IDC_SUNRISE, (time_zone-old_zone))
ChangeTime(ghDlg,%IDC_SUNSET, (time_zone-old_zone))
END IF
CASE %IDC_UTC_2
old_zone = time_zone
time_zone = 2
IF time_zone <> old_zone THEN
ChangeTime(ghDlg,%IDC_SUNRISE, (time_zone-old_zone))
ChangeTime(ghDlg,%IDC_SUNSET, (time_zone-old_zone))
END IF

CASE %IDCANCEL
IF CB.CTLMSG = %BN_CLICKED OR CB.CTLMSG = 1 THEN
FetchData buffer()
buffer(6) = STR$(time_zone)
hFile = FREEFILE
OPEN EXE.NAME$+".inf" FOR OUTPUT AS hFile
FOR i = 0 TO 6
PRINT# hFile, buffer(i)
NEXT i
CLOSE hFile
DIALOG END CB.HNDL, 0
END IF

CASE %IDC_CALCULATE
IF CB.CTLMSG = %BN_CLICKED OR CB.CTLMSG = 1 THEN
FetchData buffer()
CONTROL SET TEXT ghDlg, %IDC_FRAME1, "times calculated for " + MID$(DateStr, 7, 4) + "-" + MID$(DateStr, 4, 2) + "-" + MID$(DateStr, 1, 2)'buffer(5)
'1=latitude, 2=longitude, 3=sunr, 4=suns, 5=date, 6=time_zone
IF TRIM$(buffer(1)) = "" THEN EXIT FUNCTION
IF TRIM$(buffer(2)) = "" THEN EXIT FUNCTION
latitude = VAL(buffer(1))
longitude= VAL(buffer(2))

vDate = INT(StrToVBDate(buffer(5)))
VariantTimeToSystemTime vDate, st
sMsg = ""

result = Sun_rise_set_advanced(latitude, longitude, JulianDate, time_zone)
SetTime ghDlg, %IDC_SUNRISE, PARSE$(result, $TAB, 2)+":00" 'set new sunrise
SetTime ghDlg, %IDC_SUNSET, PARSE$(result, $TAB, 3)+":00" 'set new sunset
CONTROL SET TEXT ghDlg, %IDC_TEXTBOX3, STR$(JulianDate)
SetFocus GetDlgItem(ghDlg, %IDC_CALCULATE)
END IF
END SELECT
END SELECT
END FUNCTION
'------------------------------------------------------------------------------

'------------------------------------------------------------------------------
' ** Dialogs **
'------------------------------------------------------------------------------
FUNCTION ShowDIALOG1(BYVAL hParent AS DWORD) AS LONG
LOCAL lRslt AS LONG

LOCAL hDlg AS DWORD

DIALOG NEW hParent, "Calculate sunrise & sunset times", 73, 105, 401, _
222, %WS_POPUP OR %WS_BORDER OR %WS_DLGFRAME OR %WS_SYSMENU OR _
%WS_MINIMIZEBOX OR %WS_MAXIMIZEBOX OR %WS_CLIPSIBLINGS OR _
%WS_VISIBLE OR %DS_MODALFRAME OR %DS_3DLOOK OR %DS_NOFAILCREATE OR _
%DS_SETFONT, %WS_EX_CONTROLPARENT OR %WS_EX_LEFT OR _
%WS_EX_LTRREADING OR %WS_EX_RIGHTSCROLLBAR, TO hDlg

CONTROL ADD "SysDateTimePick32", hDlg, %IDC_SUNRISE, _
"SysDateTimePick32_1", 180, 20, 60, 15, %WS_CHILD OR %WS_VISIBLE OR _
%WS_TABSTOP OR %DTS_TIMEFORMAT, %WS_EX_CLIENTEDGE OR %WS_EX_LEFT OR _
%WS_EX_LTRREADING OR %WS_EX_RIGHTSCROLLBAR
CONTROL ADD "SysDateTimePick32", hDlg, %IDC_SUNSET, _
"SysDateTimePick32_1", 180, 40, 60, 15, %WS_CHILD OR %WS_VISIBLE OR _
%WS_TABSTOP OR %DTS_TIMEFORMAT, %WS_EX_CLIENTEDGE OR %WS_EX_LEFT OR _
%WS_EX_LTRREADING OR %WS_EX_RIGHTSCROLLBAR
CONTROL ADD "SysMonthCal32", hDlg, %IDC_SYSMONTHCAL32_1, _
"SysMonthCal32_1", 265, 70, 125, 110, %WS_CHILD OR %WS_VISIBLE OR _
%WS_TABSTOP OR %MCS_NOTODAYCIRCLE, %WS_EX_CLIENTEDGE OR %WS_EX_LEFT _
OR %WS_EX_LTRREADING OR %WS_EX_LEFTSCROLLBAR

CONTROL ADD TEXTBOX, hDlg, %IDC_LATITUDE, "", 165, 80, 75, 15
CONTROL ADD TEXTBOX, hDlg, %IDC_LONGITUDE, "", 165, 100, 75, 15

CONTROL ADD TEXTBOX, hDlg, %IDC_TEXTBOX3, "", 20, 185, 75, 15

CONTROL ADD BUTTON, hDlg, %IDCANCEL, "Terminate", 280, 185, 95, 20
CONTROL ADD LABEL, hDlg, %IDC_LABEL1, "sunrise ", 105, 20, 60, 15
CONTROL ADD LABEL, hDlg, %IDC_LABEL2, "sunset", 105, 40, 60, 15
CONTROL ADD LABEL, hDlg, %IDC_LABEL5, "Latitude [N=+, S=-]", 45, 80, _
105, 15
CONTROL ADD LABEL, hDlg, %IDC_LABEL6, "Longitude [W=-, E=+]", 45, 100, _
110, 15
CONTROL ADD FRAME, hDlg, %IDC_FRAME1, "calculated times", 20, 5, 235, _
55
CONTROL ADD FRAME, hDlg, %IDC_FRAME2, "localization [decimal degrees]", _
20, 65, 235, 55
CONTROL ADD BUTTON, hDlg, %IDC_CALCULATE, "Calculate", 295, 10, 65, 20
CONTROL ADD LABEL, hDlg, %IDC_LABEL7, "Choose the date you want the " + _
"calculation to be made for from below. Then press 'Calculate'", _
270, 40, 115, 30, %WS_CHILD OR %WS_VISIBLE OR %SS_CENTER, _
%WS_EX_LEFT OR %WS_EX_LTRREADING
CONTROL ADD OPTION, hDlg, %IDC_UTC_0, "UTC+0", 25, 20, 65, 10
CONTROL ADD OPTION, hDlg, %IDC_UTC_1, "UTC+1", 25, 30, 65, 10
CONTROL ADD OPTION, hDlg, %IDC_UTC_2, "UTC+2", 25, 40, 65, 10
CONTROL ADD LABEL, hDlg, %IDC_LABEL12, "This user interface is just a " + _
"stub for your own modifications. Feel free to modify and use the " + _
"code for any of your needs. The same applies for the code for the " + _
"calculations .", 20, 130, 235, 40
ghDlg = hDlg
DIALOG SHOW MODAL hDlg, CALL ShowDIALOG1Proc TO lRslt

FUNCTION = lRslt
END FUNCTION

' --------------------------------------------------------------------------
SUB ChangeTime(BYVAL hWnd AS DWORD, BYVAL CtlID AS DWORD, change AS LONG)
' Retrieve Time String from Control in HH:MM:SS format
LOCAL dt AS SYSTEMTIME

CONTROL SEND hWnd, CtlID, %DTM_GETSYSTEMTIME, 0, VARPTR(dt)
dt.wHour = dt.whour + change
CONTROL SEND hWnd, CtlID, %DTM_SETSYSTEMTIME, %GDT_VALID, VARPTR(dt)

END SUB
' --------------------------------------------------------------------------
SUB GetDate(BYVAL hWnd AS DWORD, BYVAL CtlID AS DWORD, DateStr AS STRING)
' Retrieve Date String from Control in yyyy:mm:dd format
LOCAL dt AS SYSTEMTIME

CONTROL SEND hWnd, CtlID, %DTM_GETSYSTEMTIME, 0, VARPTR(dt)
Datestr = FORMAT$(dt.wDay,"00") & "." & _
FORMAT$(dt.wMonth,"00") & "." & _
FORMAT$(dt.wYear, "0000")

END SUB

' --------------------------------------------------------------------------
SUB SetTime(BYVAL hWnd AS DWORD, BYVAL CtlID AS DWORD, TimeStr AS STRING)
' Set Control to time in string HH:MM:SS format.
LOCAL dt AS SYSTEMTIME
LOCAL x AS WORD

' These date items must be set or it won't work!
dt.wMonth = 1
dt.wDay = 1
dt.wYear = 2000

IF LEN(TimeStr) <> 8 THEN EXIT SUB ' Wrong Length
x = VAL(LEFT$(TimeStr,2)) ' First Check Hour
IF x > 23 THEN EXIT SUB ' Bad Format
dt.wHour = x
x = VAL(MID$(TimeStr,4,2))
IF x > 59 THEN EXIT SUB ' Bad Format
dt.wMinute = x
x = VAL(RIGHT$(TimeStr,2))
'x = 0
IF x > 59 THEN EXIT SUB ' Bad Format
dt.wSecond = x

CONTROL SEND hWnd, CtlID, %DTM_SETSYSTEMTIME, %GDT_VALID, VARPTR(dt)
END SUB

' --------------------------------------------------------------------------
SUB FetchData (buffer()AS STRING)
CONTROL GET TEXT ghDlg,%IDC_LATITUDE TO buffer(1)
CONTROL GET TEXT ghDlg,%IDC_LONGITUDE TO buffer(2)
CONTROL GET TEXT ghDlg,%IDC_SUNRISE TO buffer(3)
CONTROL GET TEXT ghDlg,%IDC_SUNSET TO buffer(4)
GetDate ghDlg, %IDC_SYSMONTHCAL32_1, buffer(5)
END SUB

FUNCTION uString(BYVAL x AS STRING) AS STRING
LOCAL y AS STRING
LOCAL n AS INTEGER
IF LEN(x) THEN
FOR n = 1 TO LEN(x)
y = y + MKI$(ASC(x, n))
NEXT n
END IF
FUNCTION = y
END FUNCTION

FUNCTION StrToVbDate(BYVAL dt AS STRING) AS DOUBLE
LOCAL x AS LONG
LOCAL y AS STRING
LOCAL vbdate AS DOUBLE
dt = uString(dt)
IF ISFALSE(VarDateFromStr(BYVAL STRPTR(dt), 0, 0, vbdate)) THEN
FUNCTION = vbdate
END IF
END FUNCTION

FUNCTION Sun_rise_set_advanced(latitude AS EXT, longitude AS EXT, JD AS DOUBLE, time_zone AS LONG) AS STRING
'advanced calculation function for sunrise and sunset times with respect to different years
'according to http://lexikon.astronomie.info/zeitgleichung/, Arnold Barmettler
'time_zone = 0 'Worldtime (UTC)
'time_zone = 1 'European Wintertime
'time_zone = 2 'European Summertime

LOCAL JD2000, T, h, B AS DOUBLE
LOCAL rise_LT, set_LT, rise_UTC, set_UTC, rise_SLT, set_SLT AS EXT
LOCAL declination, time_function, time_difference AS EXT

JD2000 = 2451545.0
T = (JD - JD2000)/36525.0
time_function = calculate_time_function(declination, T)

h = -50.0/60.0*Rad 'angel of sunrise = -50 minutes = -0.0145 rad
B = latitude*Rad
time_difference = 12.0*arccos((SIN(h) - SIN(B)*SIN(declination))/(COS(B)*COS(declination)))/Pixz

rise_LT = 12.0 - time_difference - time_function
set_LT = 12.0 + time_difference - time_function
rise_UTC = rise_LT - (longitude /15.0)
set_UTC = set_LT - (longitude /15.0)

rise_SLT = rise_UTC + time_zone 'in decimal hours Standard Local Time
IF rise_SLT<0.0 THEN : rise_SLT = rise_SLT + 24.0
IF rise_SLT>=24.0 THEN : rise_SLT = rise_SLT - 24.0

set_SLT = set_UTC + time_zone 'in decimal hours Standard Local Time
IF set_SLT<0.0 THEN : set_SLT = set_SLT + 24.0
IF set_SLT>=24.0 THEN : set_SLT = set_SLT - 24.0

FUNCTION = STR$(JD) + $TAB + toHHMMSS(rise_SLT) + $TAB + toHHMMSS(set_SLT)
END FUNCTION

FUNCTION JulianDate () AS DOUBLE ' (year AS WORD, month AS WORD, day AS WORD, hour AS WORD, minutes AS WORD, seconds AS DOUBLE) AS DOUBLE
LOCAL gregor AS LONG 'gregorian calender
LOCAL year AS WORD
LOCAL month AS WORD
LOCAL day AS WORD
LOCAL hour AS WORD
LOCAL minutes AS WORD
LOCAL seconds AS DOUBLE

'DateStr format DD.MM.YYYY
day = VAL(MID$(DateStr, 1, 2))
month = VAL(MID$(DateStr, 4, 2))
year = VAL(MID$(DateStr, 7, 4))

hour = 12
minutes = 0
seconds = 0

IF (month < =2) THEN
month = month + 12
year = year -1
END IF
gregor = (year/400)-(year/100)+(year/4)
FUNCTION = (2400000.5+365.0 * year - 679004.0 + gregor _
+ INT(30.6001*(month + 1)) + day + hour/24.0 _
+ minutes/1440.0 + seconds/86400.0) - 1

END FUNCTION

FUNCTION InPi(x AS EXT) AS EXT
LOCAL N AS LONG
n = INT(x/(2*Pixz))
x = x - n*2*Pixz
IF (x<0)THEN : x = x + 2*Pixz
FUNCTION = x
END FUNCTION

FUNCTION eps(T AS DOUBLE) AS EXT
'inclination of axis of the earth
FUNCTION = Rad *(23.43929111 + (-46.8150*T - 0.00059*T*T + 0.001813*T*T*T)/3600.0)
END FUNCTION

FUNCTION arcsin(Value AS EXT) AS EXT
FUNCTION = ATN(Value / SQR(1 - Value * Value))
END FUNCTION

FUNCTION arccos(Value AS EXT) AS EXT
FUNCTION = Pixz / 2 - ATN(Value / SQR(1 - Value * Value))
END FUNCTION

FUNCTION toHHMMSS(hh AS EXT) AS STRING
LOCAL mm, ss, ret AS STRING
LOCAL x AS EXT

ret = FORMAT$(INT(hh), "00") 'hours
x = hh - INT(hh)
x = x * 60
ret = ret + ":" + FORMAT$(INT(x), "00") 'minutes:
x = x - INT(x)
x = x * 60
'ret = ret + ":" + FORMAT$(x, "00.000") 'seconds:
FUNCTION = ret
END FUNCTION

FUNCTION calculate_time_function(declination AS EXT, T AS DOUBLE)AS EXT
LOCAL RA_mean, M, L, e, RA, dRA AS EXT

RA_mean = 18.71506921 + 2400.0513369*T +(2.5862e-5 - 1.72e-9*T)*T*T

'calculate the Sun's mean anomaly
M = InPi(Pixz*2 * (0.993133 + 99.997361*T))

'calculate the Sun's true longitude
L = InPi(Pixz*2 * (0.7859453 + M/(Pixz*2) + (6893.0*SIN(M)+72.0*SIN(2.0*M)+6191.2*T) / 1296.0e3))

'calculate the Sun's right ascension
e = eps(T)
RA = ATN(TAN(L)*COS(e))

'right ascension value needs to be in the same quadrant
IF (RA < 0.0) THEN : RA = RA + Pixz
IF (L > Pixz) THEN : RA = RA + Pixz

'right ascension value needs to be converted into hours
RA = 24.0*RA/(Pixz*2)

'calculate the Sun's declination
declination = arcsin(SIN(e)*SIN(L))

'calculate the Sun's local hour angle

'finish calculating H and convert into hours

RA_mean = 24.0*InPi(Pixz*2*RA_mean/24.0)/(Pixz*2) 'for 0<=RA_mean<24
dRA = RA_mean - RA
IF (dRA < -12.0)THEN: dRA = dRA + 24.0
IF (dRA > 12.0) THEN: dRA = dRA - 24.0
dRA = dRA* 1.0027379
FUNCTION = dRA
END FUNCTION


FUNCTION InitComctl32X (BYVAL iccClasses AS DWORD ) AS LONG
LOCAL hLib AS DWORD
LOCAL dwProc AS DWORD
LOCAL iccex AS INIT_COMMON_CONTROLSEX

hLib = LoadLibrary("COMCTL32.DLL")
IF hLib THEN
dwProc = GetProcAddress(hLib, "InitCommonControlsEx")
IF dwProc THEN
FUNCTION = 1 'return 1 on success
iccex.dwSize = SIZEOF(iccex) 'fill the iccex structure
iccex.dwICC = iccClasses 'tell what classes to initiate
CALL DWORD dwProc USING zInitCommonControlsEx(iccex)
ELSE
InitCommonControls
END IF
CALL FreeLibrary(hLib) 'we can FreeLibrary now, because InitCommonControls(Ex)
END IF 'has made sure comctl32.dll is loaded into the system.

END FUNCTION
#92
Advanced Datatypes / Graph Database from Stanley Du...
Last post by Theo Gottwald - May 06, 2024, 11:16:24 AM
[English]
🌐 **Exploring the Intricacies of Graph Structures and Trie Trees in Today's Tech Landscape** 🌐

---

🔹 **Graph Data Structures** 🔹 
Used in Google Maps, AI, social networks, and much more! A graph data structure includes a finite, possibly mutable set of vertices (or nodes) 📌, linked by edges (also known as links or lines in undirected graphs, and arrows or arcs in directed ones). 🔄

---

🔹 **What is a Trie Tree?** 🔹 
A Trie Tree acts as a key/payload data storage structure, similar to hash tables or AVL trees, but it uniquely operates as a prefix tree. 🌳

---

🔹 **Implementing Graph Databases** 🔹 
To start, you need:
- A unique list of nodes 📊
- Links (edges) between these nodes 🔗
- Sometimes, values associated with nodes or edges 🏷�

---

🔹 **Trie Tree Operations** 🔹 
Adding a prefix to a Trie Tree creates a Unique Ordered Set, allowing traversal of any prefix using the prefix cursor. 🗺�

---

🔹 **Practical Applications** 🔹 
Though a simple sample, graph databases and Trie Trees need custom tailoring for effective use. The tree structure serves as a foundation; its potential is unlocked by the user's needs and creativity. 🛠�

---

🚀 **Fast and Efficient** 🚀 
Comparable to a hash in speed and can be stored to file for efficient data management. 💾

---

#GraphDataStructures #TrieTree #TechInnovation #DataStorage #AI #GoogleMaps #SocialNetworking ✨📈🖥�🌍🔍

[German]
🌐💡 Nutzt du Google Maps, KI, soziale Netzwerke oder ähnliches? Heutzutage sind Graphenstrukturen überall im Einsatz! 🚀

🔍 "Eine Graph-Datenstruktur besteht aus einer endlichen (und möglicherweise veränderbaren) Menge von Knotenpunkten, zusammen mit einem Set von ungeordneten Paaren dieser Knoten für einen ungerichteten Graph oder einem Set von geordneten Paaren für einen gerichteten Graph. Diese Paare werden als Kanten (auch Verbindungen oder Linien genannt) bezeichnet, und für einen gerichteten Graph auch manchmal als Pfeile oder Bögen." – WP

🌳 Ein Trie-Baum ist eine Schlüssel-/Datenstruktur. Daten werden mittels eines einzigartigen Schlüssels gespeichert und abgerufen, ähnlich einer Hashtabelle oder einem AVL-Baum.
Aber es ist auch ein Präfix-Baum.

📊 Um eine Graphendatenbank zu implementieren, benötigen wir:
- Eine einzigartige Liste von Knotenpunkten.
- Eine Liste von Verbindungen (Kanten).
- In manchen Fällen kann ein Knoten oder eine Kante einen Wert haben.

🔗 Im Trie-Baum müssen wir nur ein Präfix hinzufügen. Alles mit demselben Präfix wird zu einem einzigartigen geordneten Set. Mit dem Präfix-Cursor können wir jedes Präfix durchlaufen.

📝 Hier ist ein einfaches Beispiel. Mehr kann man wirklich nicht machen, da Graphendatenbanken maßgeschneidert sein müssen.
Der Baum kann genutzt werden, um die Struktur aufzubauen, was danach passiert, liegt am Nutzer.
Schnell wie eine Hashtabelle und kann in Dateien gespeichert werden.

🔥🌟 Nutze die Kraft der Graphen- und Trie-Strukturen für deine Projekte und optimiere deine Datenverarbeitung! 🚀

#GraphenDatenstrukturen #TrieBaum #Datenbanken #KI #TechInnovation #DatenVerarbeiten 🌐📊🔍🌳


'TrieC.inc
'Public domain, use at own risk. SDurham

    '   Trie Tree

    '   if %MessageOnError defined before including file, message box on lib error
    '   if %HaltOnError defined before including file, app will halt on lib error

    ' ----------------------------------------------------------------------------------
    '
    '   Key/Payload container. Payload stored/retrieved using unique Key.
    '
    '       Extremely Fast:
    '           Fast as hash, Keys always in Key order.
    '       Tree:
    '           Faster than a tree and doesn't need to rebalance.
    '           Like a tree, the Keys are in order.
    '       Prefix Tree:
    '           Can be used for IntelliSense like lookup.
    '           Nothing faster.
    '           Use prefix cursor to find prefixes.
    '           Everything below a position in the tree has the same prefix.
    '       Suffix Tree:
    '           Store refers key before storing, use Prefix cursor.
    '       Unique Ordered Set:
    '          A set is a group of members that share a common attribute.
    '       Store/Restore tree To/From String/File:
    '
    '   Implementation: "Range" Triee Tree
    '       Each node represents a character in a Key.
    '       The character's ASCII value in the node array is a pointer to the next character.
    '       This gets heavy very fast.
    '       In this implementation, the array only holds the range between low and high character.
    '       At some point, there will only be one character in the node.
    '
    '   Keys:
    '       case sensitive, no nulls
    '   Payload:
    '       any kind of data packed into a string
    '
    '   Keys aren't stored in Tree
    '   The Key is the structure of the Tree
    ' ----------------------------------------------------------------------------------
    '   Keys lay on top of each other until a difference is encountered
    '   Keys = (cat, cats, catastrophe, catastrophes, cattle, cattleman, cattlemen, catch, catches, caught)
    '
    '   c
    '   a
    '   t*--------------u
    '   a--c--s*--t     g
    '   s  h*     l     h
    '   t  e      e*    t*
    '   r  s*     m
    '   o         a--e
    '   p         n* n*
    '   h
    '   e*
    '   s*
    ' ----------------------------------------------------------------------------------

#If Not %Def(%TrieTree4)
    %TrieTree4 = 1
    %TrieGoDown = 1
    %TrieGoRight = 2
    %TrieGoUp = 3
    %TriePtrSize = 4
    'error exit macro, errors logged to app folder
    Macro TrieExit(test, message, exitWhat)
        If test Then
            Error 151
            Me.Log(message )
            Exit exitWhat
        End If
    End Macro
    Type StrBldT 'forward reference
        mem As Long
        count As Long
        max As Long
    End Type
    Type TrieStrT
        count As Long
        mem As Long
    End Type
    Type TrieNodeT
        prnt As TrieNodeT Ptr
        char As Byte
        low As Byte
        high As Byte
        count As Byte
        arr As Long Ptr
        payload As TrieStrT Ptr
    End Type

    Class TrieC
        Instance count_ As Long
        Instance root_ As TrieNodeT Ptr
        Instance cursor_ As TrieNodeT Ptr
        Instance index_ As Long
        Instance way_ As Byte
        Instance prefix_ As TrieNodeT Ptr
        Class Method Destroy()
            Me.ClearMe()
        End Method

        ' ------------------------------------------------------------------------------
        '   String Trie Tree
        ' ------------------------------------------------------------------------------
       
        Interface TrieI : Inherit IUnknown

            Property Get Count() As Long
                ' get item count
                Property = count_
            End Property

            Method Clear()
                ' empty container
                Me.ClearMe()
            End Method

            Method Add(key As String, payload As String, Opt ByVal update As Long)
                ' add key/payload to tree : key ignored if already in tree
                ' if 'update' specified then payload replaced if key in tree
                Register x As Long
                Local n As TrieNodeT Ptr
                Local k As Byte Ptr
                Err = 0
                If Len(key) Then
                    If root_ = 0 Then root_ = Me.NodeAllocate(0, 0)
                    If Err Then Exit Method
                    n = root_
                    k = StrPtr(key)
                    While @k
                        x = Me.NodeAddToRange(n, @k)
                        If @n.@arr[x] = 0 Then @n.@arr[x] = Me.NodeAllocate(n, @k)
                        n = @n.@arr[x]
                        Incr k
                    Wend
                    'all of key's characters are now in tree
                    If @n.payload = 0 Then
                        @n.payload = Me.StringAllocate()
                        Me.StringSet(@n.@payload, payload)
                        Incr count_
                    ElseIf IsTrue update Then
                        Me.StringSet(@n.@payload, payload)
                    End If
                End If
            End Method

            Method Set(key As String, payload As String)
                ' replace key's payload
                Local n As TrieNodeT Ptr
                n = Me.Contains(key)
                If n And @n.payload Then Me.StringSet(@n.@payload, payload)
            End Method

            Method Get(key As String) As String
                ' get key's payload
                Local n As TrieNodeT Ptr
                n = Me.Contains(key)
                If n And @n.payload Then Method = Peek$(@n.@payload.mem, @n.@payload.count)
            End Method

            Method Contains(key As String) As Long
                ' return zero if key not in tree
                Register c As Long
                Local n As TrieNodeT Ptr
                Local k As Byte Ptr
                If Len(key) Then
                    k = StrPtr(key)
                    c = @k
                    n = root_
                    While n And c
                        If c < @n.low Or c > @n.high Then Exit Method
                        n = @n.@arr[c - @n.low]
                        Incr k : c = @k
                    Wend
                End If
                If n And @n.payload Then Method = n
            End Method

            Method Remove(key As String)
                ' delete key and payload
                Local n, prnt As TrieNodeT Ptr
                n = Me.Contains(key)
                If n And @n.payload Then
                    @n.payload = Me.StringFree(@n.payload)
                    Decr count_
                    While n
                        prnt = @n.prnt
                        If @n.count Or @n.payload Then Exit Method
                        Me.NodeDisconnect(n)
                        Me.NodeFree(n)
                        n = prnt
                    Wend
                    If count_ = 0 Then Me.ClearMe()
                End If
            End Method

            ' ------------------------------------------------------------------------------
            '   Key Cursor : move through every key in tree
            ' ------------------------------------------------------------------------------

            Method FirstKey() As Long
                ' move to first Key in tree : true/false success
                cursor_ = 0
                prefix_ = 0
                If root_ Then
                    cursor_ = root_
                    index_ = -1 'incr by %TrieGoRight
                    way_ = %TrieGoRight
                    Method = Me.NextKey()
                End If
            End Method

            Method NextKey() As Long
                ' move to next Key in tree : true/false success
                If count_ Then
                    While cursor_
                        Select Case As Const way_
                        Case %TrieGoDown
                            If @cursor_.count = 0 Or index_ >= @cursor_.count Then
                                way_ = %TrieGoUp 'can't go down or right - go up
                            ElseIf @cursor_.@arr[index_] = 0 Then
                                way_ = %TrieGoRight 'no child - can't go down - go right
                            Else 'go down
                                cursor_ = @cursor_.@arr[index_]
                                index_ = 0
                                way_ = %TrieGoDown
                                If @cursor_.payload Then
                                    Method = 1 : Exit Method
                                End If
                            End If
                        Case %TrieGoRight
                            Incr index_ 'go right
                            If index_ >= @cursor_.count Then
                                way_ = %TrieGoUp 'can't go right or down
                            Else
                                way_ = %TrieGoDown
                            End If
                        Case %TrieGoUp
                            If @cursor_.prnt Then index_ = @cursor_.char - @cursor_.@prnt.low
                            cursor_ = @cursor_.prnt 'will exit loop if cursor on root node
                            way_ = %TrieGoRight
                        End Select
                    Wend
                End If
            End Method

            ' ------------------------------------------------------------------------------
            '   Prefix Cursor : move through every key starting with "prefix"
            ' ------------------------------------------------------------------------------

            Method FirstPrefix(keyPrefix As String) As Long
                ' move cursor to first matching prefix : true/false success
                Local c, x As Long
                Local k As Byte Ptr
                Local n As TrieNodeT Ptr
                cursor_ = 0
                prefix_ = 0
                n = root_
                If Len(keyPrefix) Then
                    k = StrPtr(keyPrefix)
                    While @k And n
                        c = @k
                        If c < @n.low Or c > @n.high Then Exit Method
                        x = c - @n.low
                        Incr k
                        n = @n.@arr[x]
                    Wend
                    If n Then
                        prefix_ = @n.prnt
                        cursor_ = n
                        index_ = -1
                        way_ = %TrieGoRight
                        If @n.payload Then
                            Method = 1
                        Else
                            Method = Me.NextPrefix()
                        End If
                    End If
                End If
            End Method

            Method NextPrefix() As Long
                ' move to next Key in tree : true/false success
                If count_ Then
                    While cursor_
                        Select Case As Const way_
                        Case %TrieGoDown
                            If @cursor_.count = 0 Or index_ >= @cursor_.count Then
                                way_ = %TrieGoUp 'can't go down or right - go up
                            ElseIf @cursor_.@arr[index_] = 0 Then
                                way_ = %TrieGoRight 'no child - can't go down - go right
                            Else 'go down
                                cursor_ = @cursor_.@arr[index_]
                                index_ = 0
                                way_ = %TrieGoDown
                                If @cursor_.payload Then
                                    Method = 1 : Exit Method
                                End If
                            End If
                        Case %TrieGoRight
                            Incr index_ 'go right
                            If index_ >= @cursor_.count Then
                                way_ = %TrieGoUp 'can't go right or down
                            Else
                                way_ = %TrieGoDown
                            End If
                        Case %TrieGoUp
                            If @cursor_.prnt = prefix_ Then Exit Method
                            If @cursor_.prnt Then index_ = @cursor_.char - @cursor_.@prnt.low
                            cursor_ = @cursor_.prnt 'will exit loop if cursor on root node
                            way_ = %TrieGoRight
                        End Select
                    Wend
                End If
            End Method

            ' ------------------------------------------------------------------------------
            '   Get values at cursor position
            ' ------------------------------------------------------------------------------

            Property Get Key() As String
                'get Key at current cursor position
                Local s As String
                Local n As TrieNodeT Ptr
                If cursor_ And @cursor_.payload Then
                    n = cursor_
                    While n And @n.char
                        s = Chr$(@n.char) + s
                        n = @n.prnt
                    Wend
                End If
                Property = s
            End Property

            Property Get Payload() As String
                'get Payload at current cursor position
                If cursor_ And @cursor_.payload Then Property = Me.StringGet(@cursor_.@payload)
            End Property

            ' ------------------------------------------------------------------------------
            '   Store/Restore tree To/From String/File
            ' ------------------------------------------------------------------------------

            Method Store() As String
                ' store container to String
                Register i As Long
                Register ok As Long
                Local key$, payload$
                Local sb As StrBldT
                If count_ Then
                    StrBldAdd sb, Mkl$(count_)
                    ok = Me.FirstKey()
                    While ok
                        Incr i
                        key$ = Me.Key
                        payload$ = Me.Payload
                        StrBldAdd sb, Mkl$(Len(key$))
                        StrBldAdd sb, key$
                        StrBldAdd sb, Mkl$(Len(payload$))
                        StrBldAdd sb, payload$
                        ok = Me.NextKey()
                    Wend
                    Method = StrBldGet(sb)
                End If
            End Method

            Method Restore(ByVal stored As String)
                ' restore container from String
                Register i As Long
                Local items, characters As Long
                Local key$, payload$
                Local p As Long Ptr
                Me.ClearMe()
                If Len(stored) Then
                    p = StrPtr(stored)
                    items = @p : Incr p
                    For i = 1 To items
                        characters = @p : Incr p
                        key$ = Peek$(p, characters) : p += characters
                        characters = @p : Incr p
                        payload$ = Peek$(p, characters) : p += characters
                        Me.Add(key$, payload$)
                    Next i
                End If
            End Method

            Method FileStore(ByVal file As WString)
                ' store container to File
                StrToFile file, Me.Store()
            End Method

            Method FileRestore(ByVal file As WString)
                ' restore container from File
                Me.Restore(StrFromFile(file))
            End Method

        End Interface 'TrieI

        ' ----------------------------------------------------------------------------------
        '   Class Methods
        ' ----------------------------------------------------------------------------------
        Class Method ClearMe()
            root_ = Me.NodeFree(root_)
            count_ = 0
            cursor_ = 0
            index_ = -1
            prefix_ = 0
        End Method
        ' ----------------------------------------------------------------------------------
        '   Node
        ' ----------------------------------------------------------------------------------
        Class Method NodeAllocate(ByVal prnt As TrieNodeT Ptr, ByVal char As Byte) As Long
            Local node As TrieNodeT Ptr
            node = MemAllocate(SizeOf(@node))
            TrieExit(node = 0, "TrieC: NodeAllocate: node allocate fail", Method)
            @node.prnt = prnt
            @node.char = char
            Method = node
        End Method
        Class Method NodeFree(ByVal node As TrieNodeT Ptr) As Long
            Register i As Long
            If node Then
                For i = 0 To @node.count - 1
                    If @node.@arr[i] Then @node.@arr[i] = Me.NodeFree(@node.@arr[i])
                Next i
                Me.NodeArrayClear(node)
                If @node.payload Then @node.payload = Me.StringFree(@node.payload)
                MemFree(node)
            End If
        End Method
        Class Method NodeAddToRange(ByVal node As TrieNodeT Ptr, ByVal char As Byte) As Long
            Register i As Long
            Register items As Long
            If node Then
                If @node.count = 0 Then
                    Me.NodeArrayAdd(node, 0)
                    @node.low = char
                    @node.high = char
                    Method = 0 'first in array
                ElseIf char < @node.low Then
                    items = @node.low - char
                    For i = 1 To items
                        Me.NodeArrayInsert(node, 0, 0)
                    Next i
                    @node.low = char
                    Method = 0
                ElseIf char > @node.high Then
                    items = char - @node.high
                    For i = 1 To items
                        Me.NodeArrayAdd(node, 0)
                    Next i
                    @node.high = char
                    Method = @node.count - 1
                Else
                    Method = char - @node.low
                End If
            Else
                TrieExit(1, "TrieC: NodeAddToRange: null node", Method)
            End If
        End Method
        Class Method NodeDisconnect(ByVal node As TrieNodeT Ptr)
            Register x As Long
            Local prnt As TrieNodeT Ptr
            TrieExit(node = 0, "TrieC: NodeDisconnect: null node", Method)
            prnt = @node.prnt
            If prnt Then
                x = @node.char - @prnt.low
                TrieExit(x < 0 Or x >= @prnt.count, "TrieC: NodeDisconnect: out of bunds", Method)
                @prnt.@arr[x] = 0
                'may need to collapse range
                While @prnt.count And @prnt.@arr[0] = 0
                    Me.NodeArrayDelete(prnt, 0)
                    Incr @prnt.low
                Wend
                While @prnt.count And @prnt.@arr[@prnt.count - 1] = 0
                    Me.NodeArrayDelete(prnt, @prnt.count - 1)
                    Decr @prnt.high
                Wend
            End If
        End Method
        ' ----------------------------------------------------------------------------------
        '   Node Array
        ' ----------------------------------------------------------------------------------
        Class Method NodeArrayClear(ByVal node As TrieNodeT Ptr)
            TrieExit(node = 0, "TrieC: NodeArrayClear: null node ptr", Method)
            @node.arr = MemFree(@node.arr)
            @node.count = 0
        End Method
        Class Method NodeArrayReDim(ByVal node As TrieNodeT Ptr, ByVal items As Long)
            TrieExit(node = 0, "TrieC: NodeArrayReDim: null node ptr", Method)
            If items = 0 Then
                Me.NodeArrayClear(node)
            ElseIf items <> @node.count Then
                @node.count = 0
                @node.arr = MemReAllocate(@node.arr, items * %TriePtrSize)
                TrieExit(@node.arr = 0, "TrieC: NodeArrayReDim: memory reallocation fial", Method)
                @node.count = items
            End If
        End Method
        Class Method NodeArrayAdd(ByVal node As TrieNodeT Ptr, ByVal payload As Long)
            TrieExit(node = 0, "TrieC: NodeArrayAdd: null node ptr", Method)
            Me.NodeArrayReDim(node, @node.count + 1)
            TrieExit(@node.count = 0, "TrieC: NodeArrayAdd: NodeArrayReDim fail", Method)
            @node.@arr[@node.count - 1] = payload
        End Method
        Class Method NodeArrayInsert(ByVal node As TrieNodeT Ptr, ByVal index As Byte, ByVal payload As Long)
            TrieExit(node = 0, "TrieC: NodeArrayInsert: null node ptr", Method)
            TrieExit(index >= @node.count, "TrieC: NodeArrayInsert: out of bounds", Method)
            Me.NodeArrayReDim(node, @node.count + 1)
            TrieExit(@node.count = 0, "TrieC: NodeArrayInsert: NodeArrayReDim fail", Method)
            Me.NodeArrayMove(node, index, index + 1, @node.count - index - 1)
            @node.@arr[index] = payload
        End Method
        Class Method NodeArrayDelete(ByVal node As TrieNodeT Ptr, ByVal index As Byte)
            TrieExit(node = 0, "TrieC: NodeArrayDelete: null node ptr", Method)
            TrieExit(index >= @node.count, "TrieC: NodeArrayDelete: out of bounds", Method)
            If index < @node.count - 1 Then
                Me.NodeArrayMove(node, index + 1, index , @node.count - index - 1)
            End If
            Me.NodeArrayReDim(node, @node.count - 1)
        End Method
        Class Method NodeArrayMove(ByVal node As TrieNodeT Ptr, ByVal fromIndex As Long, ByVal toIndex As Long, ByVal Count As Long)
            Memory Copy @node.arr + (fromIndex * %TriePtrSize), @node.arr + (toIndex * %TriePtrSize), Count * %TriePtrSize
        End Method
        ' ----------------------------------------------------------------------------------
        '   String
        ' ----------------------------------------------------------------------------------
        Class Method StringAllocate() As Long
            Local p As TrieStrT Ptr
            p = MemAllocate(SizeOf(@p))
            TrieExit(p = 0, "TrieC: StringAllocate: memory allocation fail", Method)
            Method = p
        End Method
        Class Method StringFree(ByVal p As TrieStrT Ptr) As Long
            If p Then
                Me.StringClear(@p)
                MemFree(p)
            End If
        End Method
        Class Method StringClear(str As TrieStrT)
            str.count = 0
            str.mem = MemFree(str.mem)
        End Method
        Class Method StringSet(str As TrieStrT, payload As String)
            Register strLen As Long
            strLen = Len(payload)
            Me.StringClear(str)
            If strLen Then
                str.mem = MemAllocate(strLen)
                TrieExit(str.mem = 0, "TrieC: StringSet: memory allocation fail", Method)
                str.count = strLen
                Memory Copy StrPtr(payload), str.mem, strLen
            End If
        End Method
        Class Method StringGet(str As TrieStrT) As String
            If str.count Then Method = Peek$(str.mem, str.count)
        End Method
        ' ----------------------------------------------------------------------------------
        '  Error Log
        ' ----------------------------------------------------------------------------------
        Class Method Log(message As String)
            Local h As Long
            h = FreeFile
            Try
                Open Exe.Path$ + "TrieeTree.log" For Append As h
                If Lof(h) < 16000 Then
                    Print# h, Date$ +": "+ Time$ +": "+ Exe.Full$ +": "+ message
                End If
            Catch
            Finally
                Close h
                #If %Def(%MessageOnError)
                    MsgBox message, ,"Error!"
                #EndIf
                #If %Def(%HaltOnError)
                    End
                #EndIf
            End Try
        End Method
    End Class 'TrieC
#EndIf '%TrieTree4

#If Not %Def(%Memory230424)
    %Memory230424 = 1
    Declare Function GlobalAlloc Lib "Kernel32.dll" Alias "GlobalAlloc" (ByVal uFlags As Dword, ByVal dwBytes As Dword) As Dword
    Declare Function GlobalReAlloc Lib "Kernel32.dll" Alias "GlobalReAlloc" (ByVal hMem As Dword, ByVal dwBytes As Dword, ByVal uFlags As Dword) As Dword
    Declare Function GlobalFree Lib "Kernel32.dll" Alias "GlobalFree" (ByVal hMem As Dword) As Dword
    %MEMFIXED = &H0000 : %MEMMOVEABLE = &H0002 : %MEMZEROINIT = &H0040 : %MEMGPTR = (%MEMZEROINIT Or %MEMFIXED)
    Function MemAllocate(ByVal bytes As Long) ThreadSafe As Long
        If bytes Then Function = GlobalAlloc(ByVal %MEMGPTR, ByVal bytes)
    End Function
    Function MemReAllocate(ByVal hMem As Long, ByVal bytes As Long) ThreadSafe As Long
        If hMem And bytes Then
            Function = GlobalReAlloc(ByVal hMem, ByVal bytes, ByVal %MEMMOVEABLE Or %MEMZEROINIT)
        ElseIf bytes Then
            Function = GlobalAlloc(ByVal %MEMGPTR, ByVal bytes)
        ElseIf hMem Then
            Function = GlobalFree(ByVal hMem)
        End If
    End Function
    Function MemFree(ByVal hMem As Long) ThreadSafe As Long
        If hMem Then GlobalFree(ByVal hMem)
    End Function
#EndIf '%Memory230424

#If Not %Def(%StrBld230424)
    %StrBld230424 = 1
    ' String Builder : all memory freed when StrBldGet() called
    ' add 1,000,000 one-character Strings =  0.094 seconds
    ' public domain, use at own risk
    ' SDurham
    %StrBldItemsSize = 1
    %StrBldBuffer = 100000
    Type StrBldT
        mem As Long
        count As Long
        max As Long
    End Type
    Function StrBldCount(t As StrBldT) ThreadSafe As Long
        ' get character count
        Function = t.count
    End Function
    Sub StrBldAdd(t As StrBldT, ByRef value As String) ThreadSafe
        ' append string
        Local currentCount, currentMax, newMax As Long
        Local lenValue As Long : lenValue = Len(value)
        If lenValue Then
            If lenValue > t.max - t.count Then
                currentCount = t.count
                currentMax = t.max
                t.count = 0
                t.max = 0
                newMax = currentCount + lenValue + %StrBldBuffer
                t.mem = MemReAllocate(t.mem, newMax * %StrBldItemsSize)
                If t.mem = 0 Then Exit Sub
                t.count = currentCount
                t.max = newMax
            End If
            Memory Copy StrPtr(value), t.mem + (t.count * %StrBldItemsSize), lenValue * %StrBldItemsSize
            t.count += lenValue
        End If
    End Sub
    Function StrBldGet(t As StrBldT) ThreadSafe As String
        ' get complete string and free all memory
        If t.count Then Function = Peek$(t.mem, t.count)
        t.mem = MemFree(t.mem)
        t.count = 0
        t.max = 0
    End Function
#EndIf '%StrBld230424

#If Not %Def(%FileUtilities230424)
    %FileUtilities230424 = 1
    'File Utilities
    Sub StrToFile(ByRef file As WString, ByRef value As String)
        'store string to File
        Local f As Long
        If Len(file) = 0 Then Exit Sub
        f = FreeFile
        Open file For Binary As f
        SetEof f
        Put$ f, value
        Close f
    End Sub
    Function StrFromFile(ByRef file As WString) As String
        'get file contents as string
        Local f As Long, value As String
        If IsFalse IsFile(file) Then Exit Function
        f = FreeFile
        Open file For Binary As f
        Get$ f, Lof(f), value
        Close f
        Function = value
    End Function
    Function StrFromFileFixed(ByRef file As WString) As String
        'get file contents converted from Unix line endings if any
        Local value As String
        value = StrFromFile(file)
        Replace $CrLf With $Lf In value
        Replace $CrLf With $Lf In value
        Replace $Cr With $Lf In value
        Replace $Cr With $Lf In value
        Replace $Lf With $CrLf In value
        Function = value
    End Function
    Sub WStrToFile(ByRef file As WString, ByRef value As WString)
        'store string to File
        Local f As Long
        If Len(file) = 0 Then Exit Sub
        f = FreeFile
        Open file For Binary As f
        SetEof f
        Put$$ f, value
        Close f
    End Sub
    Function WStrFromFile(ByRef file As WString) As WString
        'get file contents as string
        Local f As Long, value As WString
        If IsFalse IsFile(file) Then Exit Function
        f = FreeFile
        Open file For Binary As f
        Get$$ f, Lof(f), value
        Close f
        Function = value
    End Function
    Sub WStrToTextFile(ByRef file As WString, ByRef value As WString)
        'store string converted to UTF8 to File
        StrToFile file, ChrToUtf8$(value)
    End Sub
    Function WStrFromTextFile(ByRef file As WString) As WString
        'get file contents converted from UTF8
        Function = Utf8ToChr$(StrFromFile(file))
    End Function
    Function WStrFromTextFileFixed(ByRef file As WString) As WString
        'get file contents converted from UTF8 fixing Unix line endings if any
        Local value As WString
        value = Utf8ToChr$(StrFromFile(file))
        Replace $CrLf With $Lf In value
        Replace $CrLf With $Lf In value
        Replace $Cr With $Lf In value
        Replace $Cr With $Lf In value
        Replace $Lf With $CrLf In value
        Function = value
    End Function
#EndIf '%FileUtilities230424


Sample code:

'Graph.bas
#Option LargeMem32
#Dim All
#Compile Exe
#Include Once "WIN32API.INC"

%MessageOnError = 1
%HaltOnError = 1
#Include Once "TrieC.inc"

%TextBox = 101
%BtnID = 102
Global gDlg As Long

Sub SampleCode()
    Local tree As TrieI : tree = Class "TrieC"
    Local more As Long

    Control Set Text gDlg, %TextBox, ""

    SS "add nodes, "
    SS "using 'N:' as a prefix for all nodes"
    tree.Add("N:A", "A")
    tree.Add("N:B", "B")
    tree.Add("N:C", "C")
    tree.Add("N:D", "D")

    SS ""
    SS "list nodes"
    more = tree.FirstPrefix("N:")
    While more
        SS $Dq + tree.Payload() + $Dq
        more = tree.NextPrefix()
    Wend

    SS ""
    SS "link A to B"
    SS "using 'L:' as a prefix for all links, edges"
    tree.Add("L:A:B", "B")
    SS "link A to C"
    tree.Add("L:A:C", "C")

    SS ""
    SS "list A links"
    more = tree.FirstPrefix("L:A:")
    While more
        SS $Dq + tree.Payload() + $Dq
        more = tree.NextPrefix()
    Wend

    SS ""
    SS "link C to D"
    tree.Add("L:C:D", "D")

    SS ""
    SS "list all links"
    more = tree.FirstPrefix("L:")
    While more
        SS $Dq + tree.Key() + $Dq
        more = tree.NextPrefix()
    Wend

    SS ""
    SS "add weights"
    SS "using 'W:' as prefix for weights"
    tree.Add("W:A", "4")
    tree.Add("W:B", "3")
    tree.Add("W:C", "2")
    tree.Add("W:D", "1")

    SS ""
    SS "weight for A = " + tree.Get("W:A")
    SS "weight for B = " + tree.Get("W:B")
    SS "weight for C = " + tree.Get("W:C")
    SS "weight for D = " + tree.Get("W:D")

    SS ""
    SS ""

    Control Send gDlg, %TextBox, %EM_SETSEL, 1, 1
    Control Send gDlg, %TextBox, %EM_SCROLLCARET, 0, 0
End Sub

Sub SS(ByVal value As WString)
    'appends without the overhead of getting the text
    Local characterCount As Long
    Local hWin As Long : hWin = GetDlgItem(gDlg, %TextBox)
    value += $CrLf
    characterCount =  SendMessageW(hWin, %WM_GETTEXTLENGTH, 0, 0)
    SendMessageW(hWin, %EM_SETSEL, characterCount, characterCount)
    SendMessageW(hWin, %EM_REPLACESEL, 1, StrPtr(value))
End Sub

Function PBMain()
    Local clientW, clientH As Long
    Desktop Get Client To clientW, clientH
    Dialog Default Font "consolas", 13, 0, 0
    Dialog New 0, Exe.Name$, 0, 0, clientW \ 7, clientH \ 4, %WS_Caption Or %WS_ClipSiblings Or %WS_MinimizeBox Or %WS_SysMenu Or %WS_ThickFrame Or %DS_Center, %WS_Ex_AppWindow To gDlg
    Control Add TextBox, gDlg, %TextBox, "", 0, 0, 0, 0, %ES_AutoHScroll Or %ES_AutoVScroll Or %ES_MultiLine Or %ES_NoHideSel Or %ES_WantReturn Or %WS_HScroll Or %WS_VScroll, 0
    Control Add Button,  gDlg, %BtnID, "Run", 275, 220, 60, 15, %BS_Flat, 0
    SendMessageW(GetDlgItem(gDlg, %TextBox), %EM_SETLIMITTEXT, 4000000, 0)
    Dialog Show Modeless gDlg, Call DlgCB
    Do
        Dialog DoEvents
    Loop While IsWin(gDlg)
End Function

CallBack Function DlgCB()
    Select Case As Long Cb.Msg
        Case %WM_Size
            WM_Size()
        Case %WM_Command
            Select Case As Long Cb.Ctl
                Case %BtnID : If Cb.CtlMsg = %BN_Clicked Then SampleCode()
            End Select
    End Select
End Function

Sub WM_Size()
    Local clientW, clientH As Long
    Local marg As Long
    Local buttonW, buttonH As Long
    Local txtWidth, txtHeight As Long
    Local fromLeft, fromBottom As Long
    Dialog Get Client gDlg To clientW, clientH
    marg = 3 : buttonW = 25 : buttonH = 10
    fromLeft = clientW - marg - buttonW
    fromBottom = clientH - marg - buttonH
    Control Set Size gDlg, %BtnID, buttonW, buttonH
    Control Set Loc gDlg, %BtnID, fromLeft, fromBottom
    txtWidth = clientW - marg - marg
    txtHeight = clientH - marg - buttonH - marg - marg
    Control Set Size gDlg, %TextBox, txtWidth, txtHeight
    Control Set Loc gDlg, %TextBox, marg, marg
End Sub
#93
OxygenBasic / Re: Array Ubound problem
Last post by Zlatko Vid - May 05, 2024, 06:49:05 PM
and for what is spanof()

ahh yes ...spanof() seems that work  ;)
ye i remember, i use it few times .

'quick test
int arr[1000]

print spanof(arr)
#94
General Discussion / Re: Paul Squirres going to ret...
Last post by Zlatko Vid - May 05, 2024, 06:48:02 PM
Quotedatabase projects.
then okay  :)
#95
OxygenBasic / Re: Array Ubound problem
Last post by Charles Pegge - May 05, 2024, 05:41:57 PM
Indexbase can be  read as well as set:
print indexbase

sizeof only works for elements, not arrays in o2
#96
General Discussion / Re: Paul Squirres going to ret...
Last post by Charles Pegge - May 05, 2024, 04:51:05 PM
I see it is complete with source code and public license. It is built around sqlite3, so it could be very useful in database projects.
#97
OxygenBasic / Re: Array Ubound problem
Last post by Zlatko Vid - May 05, 2024, 04:16:31 PM
QuoteHow do yo ufind out if the Array is 0-based or 1-based and how large it is?

easy
indexbase ..you define yourself
sizeOf() return array size
#98
General Discussion / Re: Paul Squirres going to ret...
Last post by Zlatko Vid - May 05, 2024, 04:13:46 PM
so you suggest to download forum
ziped 1.5MB...

may i ask why ?
#99
General Discussion / History of AI / Information Pi...
Last post by Charles Pegge - May 05, 2024, 01:21:24 PM
3 hours, epic!


How AI was Stolen

Then & Now
2 may 2024