Container Library: String, Array, Stack, Queue

[Theo Gottwald]

🚀 Auto Lib: Choose your container type and let the app do the magic! 🧙�♂️✨ It generates the precise code you need, without the clutter of unnecessary include files. 📁

🔗 Each file stands alone with zero dependencies. Plus, our containers are built on UDTs, offering optional UDT storage. 📦

📚 Stacks & Queues:
Experience lightning-fast operations with our dedicated stacks, rivaling assembly language efficiency! ⚡️
- Long Stack: Push 100M values in just 0.584s, and pop them in 1.296s! 📈
- Long Queue: Impressive speed, adding 100M values in 1.415s and retrieving them in 2.742s! 🔄

📈 Arrays:
Enjoy the convenience of buffered arrays with automatic memory management. They adapt to your needs, growing and shrinking without manual ReDim(). Just add, insert, or delete! ➕➖
- Binary search, insert, and delete are all supported. 🔍
- String arrays make text file processing a breeze. 📃
- WString arrays are perfect for listing files and folders, whether in the root or sub-folders. 📂

🔠 String Containers:
Effortlessly store dynamic strings in UDTs, an essential feature for our library. 📚

#AutoLib #CodeGeneration #Programming #Efficiency #Stacks #Queues #Arrays #SoftwareDevelopment #TechTools #CodingLife #Developers 🚀🧙�♂️✨📁🔗📦⚡️📈🔄➕➖🔍📃📂🔠📚

Code Select Expand

'AutoLib231019.bas
#PBForms Created V2.01
#Compile Exe
#Dim All

#PBForms Begin Includes
'#Resource "AutoLib231019.pbr"
%USEMACROS = 1
#Include Once "WIN32API.INC"
#Include Once "COMMCTRL.INC"
#Include Once "PBForms.INC"
#PBForms End Includes

#PBForms Begin Constants
%BtnCreate        = 1006
%BtnOutputFile    = 1005
%DlgMain          =  101
%LblContainerType = 1001
%LblVariableType  = 1003
%LbxContainerType = 1002
%LbxVariableType  = 1004
%TxtInstructions  = 1008
%TxtOutputFile    = 1007
#PBForms End Constants


Global gDlg As Long
Global gOutputFile As WString
Global gContainerType As String
Global gVariableType As String
Global gCode As String
Macro tb = "    "
Global gSB As IStringBuilderA
Sub SBAddLine(ByVal s As String)
    gSB.add s + $CrLf
End Sub
Macro SS = SBAddLine


Function PBMain()
    gSB = Class "StringBuilderA"
    PBFormsInitComCtls (%ICC_WIN95_CLASSES Or %ICC_DATE_CLASSES Or %ICC_INTERNET_CLASSES)
    ShowDlg1 %HWND_Desktop
End Function

CallBack Function ShowDlg1Proc()
    Select Case As Long Cb.Msg
        Case %WM_InitDialog : WMInitDialog()
        Case %WM_NCActivate
            Static hWndSaveFocus As Dword
            If IsFalse Cb.WParam Then
                hWndSaveFocus = GetFocus()
            ElseIf hWndSaveFocus Then
                SetFocus(hWndSaveFocus)
                hWndSaveFocus = 0
            End If
        Case %WM_Command
            Select Case As Long Cb.Ctl
                Case %LbxContainerType : If Cb.CtlMsg = %LBN_SelChange Then LbxContainerTypeSelectionChange()
                Case %LbxVariableType : If Cb.CtlMsg = %LBN_SelChange Then LbxVariableTypeSelectionChange()
                Case %BtnOutputFile: If Cb.CtlMsg = %BN_Clicked Or Cb.CtlMsg = 1 Then BtnOutputFileClicked()
                Case %BtnCreate : If Cb.CtlMsg = %BN_Clicked Or Cb.CtlMsg = 1 Then BtnCreateClicked()
                Case %TxtOutputFile
                Case %TxtInstructions
            End Select
    End Select
End Function

Function ShowDlg1(ByVal hParent As Dword) As Long
    Local lRslt  As Long
#PBForms Begin Dialog %DlgMain->->
    Local hDlg  As Dword
    Local hFont1 As Dword

    Dialog New hParent, "Auto Lib", 260, 177, 369, 221, %WS_Popup Or %WS_Border Or %WS_DlgFrame Or %WS_Caption Or %WS_SysMenu Or %WS_MinimizeBox Or %WS_ClipSiblings Or %WS_Visible Or %DS_ModalFrame Or %DS_Center 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
    Dialog  Set Color    hDlg, -1, %White
    Control Add Label,  hDlg, %LblContainerType, "Container Type", 4, 4, 180, 16
    Control Set Color    hDlg, %LblContainerType, -1, %White
    Control Add ListBox, hDlg, %LbxContainerType, , 4, 24, 180, 64, %WS_Child Or %WS_Visible Or %WS_TabStop Or %WS_VScroll Or %LBS_Sort Or %LBS_Notify Or %LBS_NoIntegralHeight, %WS_Ex_Left Or %WS_Ex_LtrReading Or %WS_Ex_RightScrollbar
    Control Set Color    hDlg, %LbxContainerType, RGB(0, 0, 191), RGB(249, 249, 249)
    Control Add Label,  hDlg, %LblVariableType, "Variable Type", 4, 92, 180, 16
    Control Set Color    hDlg, %LblVariableType, -1, %White
    Control Add ListBox, hDlg, %LbxVariableType, , 4, 112, 180, 64, %WS_Child Or %WS_Visible Or %WS_TabStop Or %WS_VScroll Or %LBS_Sort Or %LBS_Notify Or %LBS_NoIntegralHeight, %WS_Ex_Left Or %WS_Ex_LtrReading Or %WS_Ex_RightScrollbar
    Control Set Color    hDlg, %LbxVariableType, RGB(0, 0, 206), RGB(248, 248, 248)
    Control Add Button,  hDlg, %BtnOutputFile, "Output File", 4, 180, 84, 16, %WS_Child Or %WS_Visible Or %WS_TabStop Or %BS_Text Or %BS_PushButton Or %BS_Flat Or %BS_Center Or %BS_VCenter, %WS_Ex_Left Or %WS_Ex_LtrReading
    Control Add Button,  hDlg, %BtnCreate, "Create", 92, 180, 92, 16, %WS_Child Or %WS_Visible Or %WS_TabStop Or %BS_Text Or %BS_PushButton Or %BS_Flat Or %BS_Center Or %BS_VCenter, %WS_Ex_Left Or %WS_Ex_LtrReading
    Control Add TextBox, hDlg, %TxtOutputFile, "", 4, 200, 360, 16, %WS_Child Or %WS_Visible Or %ES_Left Or %ES_AutoHScroll, %WS_Ex_Left Or %WS_Ex_LtrReading Or %WS_Ex_RightScrollbar
    Control Set Color    hDlg, %TxtOutputFile, -1, RGB(248, 248, 248)
    Control Add TextBox, hDlg, %TxtInstructions, "", 188, 4, 176, 192, %WS_Child Or %WS_Visible Or %WS_VScroll Or %ES_Left Or %ES_MultiLine Or %ES_AutoVScroll Or %ES_NoHideSel Or %ES_ReadOnly Or %ES_WantReturn, %WS_Ex_Left Or _
        %WS_Ex_LtrReading Or %WS_Ex_RightScrollbar
    Control Set Color    hDlg, %TxtInstructions, RGB(240, 0, 0), RGB(249, 249, 249)

    Font New "Consolas", 12, 0, %ANSI_CHARSET To hFont1

    Control Set Font hDlg, -1, hFont1
    Control Set Font hDlg, %LblContainerType, hFont1
    Control Set Font hDlg, %LbxContainerType, hFont1
    Control Set Font hDlg, %LblVariableType, hFont1
    Control Set Font hDlg, %LbxVariableType, hFont1
    Control Set Font hDlg, %BtnOutputFile, hFont1
    Control Set Font hDlg, %BtnCreate, hFont1
    Control Set Font hDlg, %TxtOutputFile, hFont1
    Control Set Font hDlg, %TxtInstructions, hFont1
#PBForms End Dialog
    gDlg = hDlg
    Dialog Show Modal hDlg, Call ShowDlg1Proc To lRslt
#PBForms Begin CleanUp %DlgMain
    Font End hFont1
#PBForms End CleanUp
    Function = lRslt
End Function

Sub WMInitDialog()
    Local s As String
    gSB.Clear
    gOutputFile = ""
    gContainerType = ""
    gVariableType = ""
    Control Set Text gDlg, %TxtOutputFile, ""
    ListBox Reset gDlg, %LbxContainerType
    ListBox Reset gDlg, %LbxVariableType

    ListBox Add gDlg, %LbxContainerType, "String Container"
    ListBox Add gDlg, %LbxContainerType, "Array"
    ListBox Add gDlg, %LbxContainerType, "Stack"
    ListBox Add gDlg, %LbxContainerType, "Queue"

    s += "Select container type." + $CrLf + $CrLf
    s += "All containers are UDT based and can optionally be stored in a UDT." + $CrLf + $CrLf
    s += "A string container holds a dynamic string." + $CrLf + $CrLf
    s += "The arrays are buffered stacks with added array porcedures. "
    s += "Memory management is automatic. Just add, insert, and delete. "
    s += "Array grows and shrinks as needed. "
    s += "Used as a stack they are very fast." + $CrLf
    Control Set Text gDlg, %TxtInstructions, s
End Sub

Sub BtnCreateClicked()
    If gContainerType = "" Then
        MsgBox "container type not specified",,"Auto Lib" : Exit Sub
    End If
    If gVariableType = "" Then
        MsgBox "variable type not specified",,"Auto Lib" : Exit Sub
    End If
    If gCode = "" Then
        MsgBox "code not built",,"Auto Lib" : Exit Sub
    End If
    If gOutputFile = "" Then
        MsgBox "output file not specified",,"Auto Lib" : Exit Sub
    End If
    StrToFile gOutputFile, gCode
    MsgBox "done...",,"Auto Lib"
    WMInitDialog()
End Sub

Sub BtnOutputFileClicked()
    gOutputFile = ""
    Control Set Text gDlg, %TxtOutputFile, ""
    Display Openfile , , , "Output Source File", "", "*.inc", "", "", 0 To gOutputFile
    Control Set Text gDlg, %TxtOutputFile, gOutputFile
End Sub

Sub LbxContainerTypeSelectionChange()
    ListBox Reset gDlg, %LbxVariableType
    Control Set Text gDlg, %TxtInstructions, ""
    ListBox Get Text gDlg, %LbxContainerType To gContainerType
    Select Case gContainerType
        Case "Array"
            ListBox Add gDlg, %LbxVariableType, "Byte"
            ListBox Add gDlg, %LbxVariableType, "Word"
            ListBox Add gDlg, %LbxVariableType, "Integer"
            ListBox Add gDlg, %LbxVariableType, "Long"
            ListBox Add gDlg, %LbxVariableType, "Dword"
            ListBox Add gDlg, %LbxVariableType, "Quad"
            ListBox Add gDlg, %LbxVariableType, "Single"
            ListBox Add gDlg, %LbxVariableType, "Double"
            ListBox Add gDlg, %LbxVariableType, "Currency"
            ListBox Add gDlg, %LbxVariableType, "CurrencyX"
            ListBox Add gDlg, %LbxVariableType, "Extended"
            ListBox Add gDlg, %LbxVariableType, "String"
            ListBox Add gDlg, %LbxVariableType, "WString"
            Control Set Text gDlg, %TxtInstructions, "Select variable type."
        Case "String Container"
            ListBox Add gDlg, %LbxVariableType, "String"
            ListBox Add gDlg, %LbxVariableType, "WString"
            Control Set Text gDlg, %TxtInstructions, "Select variable type."
        Case "Stack"
            ListBox Add gDlg, %LbxVariableType, "Byte"
            ListBox Add gDlg, %LbxVariableType, "Word"
            ListBox Add gDlg, %LbxVariableType, "Integer"
            ListBox Add gDlg, %LbxVariableType, "Long"
            ListBox Add gDlg, %LbxVariableType, "Dword"
            ListBox Add gDlg, %LbxVariableType, "Quad"
            ListBox Add gDlg, %LbxVariableType, "Single"
            ListBox Add gDlg, %LbxVariableType, "Double"
            ListBox Add gDlg, %LbxVariableType, "Currency"
            ListBox Add gDlg, %LbxVariableType, "CurrencyX"
            ListBox Add gDlg, %LbxVariableType, "Extended"
            Control Set Text gDlg, %TxtInstructions, "Select variable type."
        Case "Queue"
            ListBox Add gDlg, %LbxVariableType, "Byte"
            ListBox Add gDlg, %LbxVariableType, "Word"
            ListBox Add gDlg, %LbxVariableType, "Integer"
            ListBox Add gDlg, %LbxVariableType, "Long"
            ListBox Add gDlg, %LbxVariableType, "Dword"
            ListBox Add gDlg, %LbxVariableType, "Quad"
            ListBox Add gDlg, %LbxVariableType, "Single"
            ListBox Add gDlg, %LbxVariableType, "Double"
            ListBox Add gDlg, %LbxVariableType, "Currency"
            ListBox Add gDlg, %LbxVariableType, "CurrencyX"
            ListBox Add gDlg, %LbxVariableType, "Extended"
            Control Set Text gDlg, %TxtInstructions, "Select variable type."
    End Select
End Sub

Sub LbxVariableTypeSelectionChange()
    Control Set Text gDlg, %TxtInstructions, ""
    ListBox Get Text gDlg, %LbxVariableType To gVariableType
    Select Case gContainerType
        Case "Array"
            Control Set Text gDlg, %TxtInstructions, "Designate output file and click [Create]."
            BuildArray()
        Case "String Container"
            Control Set Text gDlg, %TxtInstructions, "Designate output file and click [Create]."
            BuildStringContainer()
        Case "Stack"
            Control Set Text gDlg, %TxtInstructions, "Designate output file and click [Create]."
            BuildStack()
        Case "Queue"
            Control Set Text gDlg, %TxtInstructions, "Designate output file and click [Create]."
            BuildQueue()
    End Select
End Sub

Sub BuildQueue()
    Select Case gVariableType
        Case "Byte"
            AddMemoryCode()
            AddQueueCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Byt" In gCode
            Replace "VARLONG" With "Byte" In gCode
            Replace "VARSIZE" With "1" In gCode
        Case "Word"
            AddMemoryCode()
            AddQueueCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Wrd" In gCode
            Replace "VARLONG" With "Word" In gCode
            Replace "VARSIZE" With "2" In gCode
        Case "Integer"
            AddMemoryCode()
            AddQueueCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Int" In gCode
            Replace "VARLONG" With "Integer" In gCode
            Replace "VARSIZE" With "2" In gCode
        Case "Long"
            AddMemoryCode()
            AddQueueCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Lng" In gCode
            Replace "VARLONG" With "Long" In gCode
            Replace "VARSIZE" With "4" In gCode
        Case "Dword"
            AddMemoryCode()
            AddQueueCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Dwd" In gCode
            Replace "VARLONG" With "Dword" In gCode
            Replace "VARSIZE" With "4" In gCode
        Case "Quad"
            AddMemoryCode()
            AddQueueCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Qud" In gCode
            Replace "VARLONG" With "Quad" In gCode
            Replace "VARSIZE" With "8" In gCode
        Case "Single"
            AddMemoryCode()
            AddQueueCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Sng" In gCode
            Replace "VARLONG" With "Single" In gCode
            Replace "VARSIZE" With "4" In gCode
        Case "Double"
            AddMemoryCode()
            AddQueueCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Dbl" In gCode
            Replace "VARLONG" With "Double" In gCode
            Replace "VARSIZE" With "8" In gCode
        Case "Currency"
            AddMemoryCode()
            AddQueueCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Cur" In gCode
            Replace "VARLONG" With "Currency" In gCode
            Replace "VARSIZE" With "8" In gCode
        Case "CurrencyX"
            AddMemoryCode()
            AddQueueCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Cux" In gCode
            Replace "VARLONG" With "CurrencyX" In gCode
            Replace "VARSIZE" With "8" In gCode
        Case "Extended"
            AddMemoryCode()
            AddQueueCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Ext" In gCode
            Replace "VARLONG" With "Extended" In gCode
            Replace "VARSIZE" With "10" In gCode
    End Select
End Sub

Sub BuildStack()
    Select Case gVariableType
        Case "Byte"
            AddMemoryCode()
            AddStackCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Byt" In gCode
            Replace "VARLONG" With "Byte" In gCode
            Replace "VARSIZE" With "1" In gCode
        Case "Word"
            AddMemoryCode()
            AddStackCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Wrd" In gCode
            Replace "VARLONG" With "Word" In gCode
            Replace "VARSIZE" With "2" In gCode
        Case "Integer"
            AddMemoryCode()
            AddStackCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Int" In gCode
            Replace "VARLONG" With "Integer" In gCode
            Replace "VARSIZE" With "2" In gCode
        Case "Long"
            AddMemoryCode()
            AddStackCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Lng" In gCode
            Replace "VARLONG" With "Long" In gCode
            Replace "VARSIZE" With "4" In gCode
        Case "Dword"
            AddMemoryCode()
            AddStackCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Dwd" In gCode
            Replace "VARLONG" With "Dword" In gCode
            Replace "VARSIZE" With "4" In gCode
        Case "Quad"
            AddMemoryCode()
            AddStackCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Qud" In gCode
            Replace "VARLONG" With "Quad" In gCode
            Replace "VARSIZE" With "8" In gCode
        Case "Single"
            AddMemoryCode()
            AddStackCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Sng" In gCode
            Replace "VARLONG" With "Single" In gCode
            Replace "VARSIZE" With "4" In gCode
        Case "Double"
            AddMemoryCode()
            AddStackCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Dbl" In gCode
            Replace "VARLONG" With "Double" In gCode
            Replace "VARSIZE" With "8" In gCode
        Case "Currency"
            AddMemoryCode()
            AddStackCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Cur" In gCode
            Replace "VARLONG" With "Currency" In gCode
            Replace "VARSIZE" With "8" In gCode
        Case "CurrencyX"
            AddMemoryCode()
            AddStackCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Cux" In gCode
            Replace "VARLONG" With "CurrencyX" In gCode
            Replace "VARSIZE" With "8" In gCode
        Case "Extended"
            AddMemoryCode()
            AddStackCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Ext" In gCode
            Replace "VARLONG" With "Extended" In gCode
            Replace "VARSIZE" With "10" In gCode
    End Select
End Sub

Sub BuildArray()
    Select Case gVariableType
        Case "Byte"
            AddMemoryCode()
            AddNumberArrayCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Byt" In gCode
            Replace "VARLONG" With "Byte" In gCode
            Replace "VARSIZE" With "1" In gCode
        Case "Word"
            AddMemoryCode()
            AddNumberArrayCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Wrd" In gCode
            Replace "VARLONG" With "Word" In gCode
            Replace "VARSIZE" With "2" In gCode
        Case "Integer"
            AddMemoryCode()
            AddNumberArrayCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Int" In gCode
            Replace "VARLONG" With "Integer" In gCode
            Replace "VARSIZE" With "2" In gCode
        Case "Long"
            AddMemoryCode()
            AddNumberArrayCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Lng" In gCode
            Replace "VARLONG" With "Long" In gCode
            Replace "VARSIZE" With "4" In gCode
        Case "Dword"
            AddMemoryCode()
            AddNumberArrayCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Dwd" In gCode
            Replace "VARLONG" With "Dword" In gCode
            Replace "VARSIZE" With "4" In gCode
        Case "Quad"
            AddMemoryCode()
            AddNumberArrayCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Qud" In gCode
            Replace "VARLONG" With "Quad" In gCode
            Replace "VARSIZE" With "8" In gCode
        Case "Single"
            AddMemoryCode()
            AddNumberArrayCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Sng" In gCode
            Replace "VARLONG" With "Single" In gCode
            Replace "VARSIZE" With "4" In gCode
        Case "Double"
            AddMemoryCode()
            AddNumberArrayCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Dbl" In gCode
            Replace "VARLONG" With "Double" In gCode
            Replace "VARSIZE" With "8" In gCode
        Case "Currency"
            AddMemoryCode()
            AddNumberArrayCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Cur" In gCode
            Replace "VARLONG" With "Currency" In gCode
            Replace "VARSIZE" With "8" In gCode
        Case "CurrencyX"
            AddMemoryCode()
            AddNumberArrayCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Cux" In gCode
            Replace "VARLONG" With "CurrencyX" In gCode
            Replace "VARSIZE" With "8" In gCode
        Case "Extended"
            AddMemoryCode()
            AddNumberArrayCode()
            gCode = gSB.String
            gSB.Clear
            Replace "VARSHORT" With "Ext" In gCode
            Replace "VARLONG" With "Extended" In gCode
            Replace "VARSIZE" With "10" In gCode
        Case "String"
            AddMemoryCode()
            AddFileUtilities()
            AddStringContainerCode()
            AddStringArrayCode()
            AddStringArrayExtraCode()
            gCode = gSB.String
            gSB.Clear
            Replace "CONTAINERUDT" With "StrT" In gCode
            Replace "VARSHORT" With "Str" In gCode
            Replace "VARLONG" With "String" In gCode
            Replace "VARSIZE" With "1" In gCode
            Replace "PEEKTYPE" With "Peek$" In gCode
        Case "WString"
            AddMemoryCode()
            AddFileUtilities()
            AddStringContainerCode()
            AddStringArrayCode()
            AddWStringArrayExtraCode()
            gCode = gSB.String
            gSB.Clear
            Replace "CONTAINERUDT" With "WStrT" In gCode
            Replace "VARSHORT" With "WStr" In gCode
            Replace "VARLONG" With "WString" In gCode
            Replace "VARSIZE" With "2" In gCode
            Replace "PEEKTYPE" With "Peek$$" In gCode
    End Select
End Sub

Sub BuildStringContainer()
    Select Case gVariableType
        Case "String"
            AddMemoryCode()
            AddStringContainerCode()
            gCode = gSB.String
            gSB.Clear
            Replace "CONTAINERUDT" With "StrT" In gCode
            Replace "VARSHORT" With "Str" In gCode
            Replace "VARLONG" With "String" In gCode
            Replace "VARSIZE" With "1" In gCode
            Replace "PEEKTYPE" With "Peek$" In gCode
        Case "WString"
            AddMemoryCode()
            AddStringContainerCode()
            gCode = gSB.String
            gSB.Clear
            Replace "CONTAINERUDT" With "WStrT" In gCode
            Replace "VARSHORT" With "WStr" In gCode
            Replace "VARLONG" With "WString" In gCode
            Replace "VARSIZE" With "2" In gCode
            Replace "PEEKTYPE" With "Peek$$" In gCode
    End Select
End Sub

Sub AddQueueCode()
    SS ""
    SS "#If Not %Def(%VARSHORTQueue230424)"
    SS "    %VARSHORTQueue230424 = 1"
    SS "    %VARSHORTQueueMax = 550"
    SS "    Type VARSHORTQueueNodeT"
    SS "        next As VARSHORTQueueNodeT Ptr"
    SS "        first As Long"
    SS "        last As Long"
    SS "        arr(1 To %VARSHORTQueueMax) As VARLONG"
    SS "    End Type"
    SS "    Type VARSHORTQueueT"
    SS "        tag As Long"
    SS "        count As Long"
    SS "        first As VARSHORTQueueNodeT Ptr"
    SS "        last As VARSHORTQueueNodeT Ptr"
    SS "    End Type"
    SS "    Sub VARSHORTQueueFinal(t As VARSHORTQueueT)"
    SS "        'call before variable goes out of scope to free memory"
    SS "        'not necessary to call if queue empty but good practice"
    SS "        VARSHORTQueueClear t"
    SS "    End Sub"
    SS "    Sub VARSHORTQueueClear(t As VARSHORTQueueT)"
    SS "        'empty queue"
    SS "        Local n As VARSHORTQueueNodeT Ptr"
    SS "        While t.first"
    SS "            n = t.first"
    SS "            t.first = @n.next"
    SS "            MemFree(n)"
    SS "        Wend"
    SS "        t.first = 0"
    SS "        t.last = 0"
    SS "        t.count = 0"
    SS "    End Sub"
    SS "    Function VARSHORTQueueCount(t As VARSHORTQueueT) As Long"
    SS "        'get item count"
    SS "        Function = t.count"
    SS "    End Function"
    SS "    Sub VARSHORTQueueAdd(t As VARSHORTQueueT, ByVal value As VARLONG)"
    SS "        'add value to end of queue"
    SS "        Local n As VARSHORTQueueNodeT Ptr"
    SS "        If t.count = 0 Then"
    SS "            t.last = MemAlloc(SizeOf(VARSHORTQueueNodeT))"
    SS "            If t.last = 0 Then Exit Sub"
    SS "            t.@last.arr(1) = value"
    SS "            t.@last.first = 1"
    SS "            t.@last.last = 1"
    SS "            t.first = t.last"
    SS "            t.count = 1"
    SS "        Else"
    SS "            If t.last = 0 Then Exit Sub"
    SS "            If t.@last.last < %VARSHORTQueueMax Then"
    SS "                Incr t.@last.last"
    SS "                t.@last.arr(t.@last.last) = value"
    SS "                Incr t.count"
    SS "            Else"
    SS "                n = MemAlloc(SizeOf(VARSHORTQueueNodeT))"
    SS "                If n = 0 Then Exit Sub"
    SS "                @n.arr(1) = value"
    SS "                @n.first = 1"
    SS "                @n.last = 1"
    SS "                t.@last.next = n"
    SS "                t.last = n"
    SS "                Incr t.count"
    SS "            End If"
    SS "        End If"
    SS "    End Sub"
    SS "    Function VARSHORTQueuePeek(t As VARSHORTQueueT) As VARLONG"
    SS "        'get first value in queue"
    SS "        If t.count Then"
    SS "            If t.first = 0 Then Exit Function"
    SS "            Function = t.@first.arr(t.@first.first)"
    SS "        End If"
    SS "    End Function"
    SS "    Function VARSHORTQueueGet(t As VARSHORTQueueT) As VARLONG"
    SS "        'get and remove first value in queue"
    SS "        Local n As VARSHORTQueueNodeT Ptr"
    SS "        If t.count Then"
    SS "            If t.first = 0 Then Exit Function"
    SS "            Function = t.@first.arr(t.@first.first)"
    SS "            Decr t.count"
    SS "            If t.count = 0 Then"
    SS "                VARSHORTQueueClear t"
    SS "            Else"
    SS "                Incr t.@first.first"
    SS "                If t.@first.first > t.@first.last Then"
    SS "                    n = t.first"
    SS "                    t.first = t.@first.next"
    SS "                    MemFree(n)"
    SS "                End If"
    SS "            End If"
    SS "        End If"
    SS "    End Function"
    SS "#EndIf '%VARSHORTQueue230424"
End Sub

Sub AddStackCode()
    SS ""
    SS "#If Not %Def(%VARSHORTStack231018)"
    SS "    %VARSHORTStack231018 = 1"
    SS "    %VARSHORTStackMax = 550"
    SS "    Type VARSHORTStackNodeT"
    SS "        prev As VARSHORTStackNodeT Ptr"
    SS "        index As Long"
    SS "        arr(1 To %VARSHORTStackMax) As VARLONG"
    SS "    End Type"
    SS "    Type VARSHORTStackT"
    SS "        count As Long"
    SS "        top As VARSHORTStackNodeT Ptr"
    SS "    End Type"
    SS "    Sub VARSHORTStackFinal(t As VARSHORTStackT)"
    SS "        'call before variable goes out of scope to free memory"
    SS "        'not necessary if stack empty but good practice"
    SS "        VARSHORTStackClear(t)"
    SS "    End Sub"
    SS "    Sub VARSHORTStackClear(t As VARSHORTStackT)"
    SS "        'empty stack"
    SS "        Local n As VARSHORTStackNodeT Ptr"
    SS "        While t.top"
    SS "            n = t.top"
    SS "            t.top = t.@top.prev"
    SS "            MemFree(n)"
    SS "        Wend"
    SS "        t.top = 0"
    SS "        t.count = 0"
    SS "    End Sub"
    SS "    Function VARSHORTStackCount(t As VARSHORTStackT) As Long"
    SS "        'get item count"
    SS "        Function = t.count"
    SS "    End Function"
    SS "    Sub VARSHORTStackPush(t As VARSHORTStackT, ByVal value As VARLONG)"
    SS "        'push value on top of stack"
    SS "        Local n As VARSHORTStackNodeT Ptr"
    SS "        If t.count = 0 Then"
    SS "            t.top = MemAlloc(SizeOf(VARSHORTStackNodeT))"
    SS "            If t.top Then"
    SS "                t.@top.arr(1) = value"
    SS "                t.@top.index = 1"
    SS "                t.count = 1"
    SS "            End If"
    SS "        ElseIf t.@top.index < %VARSHORTStackMax Then"
    SS "            Incr t.@top.index"
    SS "            t.@top.arr(t.@top.index) = value"
    SS "            Incr t.count"
    SS "        Else"
    SS "            n = MemAlloc(SizeOf(VARSHORTStackNodeT))"
    SS "            If n Then"
    SS "                @n.arr(1) = value"
    SS "                @n.index = 1"
    SS "                @n.prev = t.top"
    SS "                t.top = n"
    SS "                Incr t.count"
    SS "            End If"
    SS "        End If"
    SS "    End Sub"
    SS "    Function VARSHORTStackPeek(t As VARSHORTStackT) As VARLONG"
    SS "        'get tope value on stack"
    SS "        If t.count Then Function = t.@top.arr(t.@top.index)"
    SS "    End Function"
    SS "    Function VARSHORTStackPop(t As VARSHORTStackT) As VARLONG"
    SS "        'get and remove top value on stack"
    SS "        Local n As VARSHORTStackNodeT Ptr"
    SS "        If t.count Then"
    SS "            Function = t.@top.arr(t.@top.index)"
    SS "            Decr t.@top.index"
    SS "            Decr t.count"
    SS "            If t.@top.index = 0 Then"
    SS "                n = t.top"
    SS "                t.top = t.@top.prev"
    SS "                MemFree(n)"
    SS "            End If"
    SS "        End If"
    SS "    End Function"
    SS "#EndIf '%VARSHORTStack231018"
End Sub

Sub AddStringArrayCode()
    SS ""
    SS "#If Not %Def(%VARSHORTArr231018)"
    SS "    %VARSHORTArr231018 = 1"
    SS "    %VARSHORTArrMultiplier = 2"
    SS "    %VARSHORTArrBufferMax = 1000000"
    SS "    %VARSHORTArrBufferMin = 1"
    SS "    Type VARSHORTArrT"
    SS "        mem As Long"
    SS "        arr As VARSHORTT Ptr"
    SS "        count As Long"
    SS "        max As Long"
    SS "        compareCB As Long"
    SS "    End Type"
    SS "    Sub VARSHORTArrFinal(t As VARSHORTArrT)"
    SS "        'must call before variable goes out of scope to free memory"
    SS "        VARSHORTArrClear t"
    SS "    End Sub"
    SS "    Sub VARSHORTArrCompare(t As VARSHORTArrT, ByVal compareCB As Long)"
    SS "        ' set compare callback"
    SS "        ' default = case sensitive CodePtr(VARSHORTCompare)"
    SS "        ' set CodePtr(VARSHORTCompareIgnore) to ignore case"
    SS "        ' use custom callback CodePtr(procedure name)"
    SS "        t.compareCB = compareCB"
    SS "    End Sub"
    SS "    Sub VARSHORTArrClear(t As VARSHORTArrT)"
    SS "        'empty container"
    SS "        Register i As Long"
    SS "        For i = 1 To t.count"
    SS "            VARSHORTFinal t.@arr[i]"
    SS "        Next i"
    SS "        t.mem = MemFree(t.mem)"
    SS "        t.arr = 0"
    SS "        t.count = 0"
    SS "        t.max = 0"
    SS "    End Sub"
    SS "    Function VARSHORTArrCount(t As VARSHORTArrT) As Long"
    SS "        'get item count"
    SS "        Function = t.count"
    SS "    End Function"
    SS "    Function VARSHORTArrGet(t As VARSHORTArrT, ByVal index As Long) As VARLONG"
    SS "        'get value at one-based index"
    SS "        If index > 0 And index <= t.count Then Function = VARSHORTGet(t.@arr[index])"
    SS "    End Function"
    SS "    Sub VARSHORTArrSet(t As VARSHORTArrT, ByVal index As Long, ByRef value As VARLONG)"
    SS "        'set value at one-based index"
    SS "        If index > 0 And index <= t.count Then VARSHORTSet t.@arr[index], value"
    SS "    End Sub"
    SS "    Sub VARSHORTArrAdd(t As VARSHORTArrT, ByRef value As VARLONG)"
    SS "        'append value : memory management automatic"
    SS "        VARSHORTArrGrow t, 1"
    SS "        If t.mem = 0 Then Exit Sub"
    SS "        Incr t.count"
    SS "        VARSHORTSet t.@arr[t.count], value"
    SS "    End Sub"
    SS "    Sub VARSHORTArrInsert(t As VARSHORTArrT, ByVal index As Long, ByRef value As VARLONG)"
    SS "        'insert value at one-based index : memory management automatic"
    SS "        If index > 0 And index <= t.count Then"
    SS "            VARSHORTArrGrow t, 1"
    SS "            If t.mem = 0 Then Exit Sub"
    SS "            Incr t.count"
    SS "            VARSHORTArrMove(t, index, index + 1, t.count - index)"
    SS "            VARSHORTSet t.@arr[index], value"
    SS "        End If"
    SS "    End Sub"
    SS "    Sub VARSHORTArrDelete(t As VARSHORTArrT, ByVal index As Long)"
    SS "        'delete value at one-based index : memory management automatic"
    SS "        If index > 0 And index <= t.count Then"
    SS "            VARSHORTFinal t.@arr[index]"
    SS "            If index < t.count Then VARSHORTArrMove(t, index + 1, index, t.count - index)"
    SS "            Decr t.count"
    SS "            If t.max - t.count > (2 * (t.count * %VARSHORTArrMultiplier)) Then VARSHORTArrShrink(t)"
    SS "        End If"
    SS "    End Sub"
    SS "    Sub VARSHORTArrFastDelete(t As VARSHORTArrT, ByVal index As Long)"
    SS "        'fast delete value at one-based index : memory management automatic"
    SS "        'fast on massive array but destroys array order"
    SS "        'traverse back to front to use"
    SS "        If index > 0 And index <= t.count Then"
    SS "            VARSHORTFinal t.@arr[index]"
    SS "            If index < t.count Then Swap t.@arr[index], t.@arr[t.count]"
    SS "            Decr t.count"
    SS "            If t.max - t.count > (2 * (t.count * %VARSHORTArrMultiplier)) Then VARSHORTArrShrink(t)"
    SS "        End If"
    SS "    End Sub"
    SS "    Sub VARSHORTArrSort(t As VARSHORTArrT)"
    SS "        'sort array"
    SS "        Register i As Long"
    SS "        Register j As Long"
    SS "        Local k, leftIndex, rightIndex, counter, compare As Long"
    SS "        Local value As VARLONG"
    SS "        If t.compareCB = 0 Then t.compareCB = CodePtr(VARSHORTCompare)"
    SS "        If t.count > 1 Then"
    SS "            leftIndex = 1 : rightIndex = t.count : counter = 1"
    SS "            !PUSH leftIndex"
    SS "            !PUSH rightIndex"
    SS "            While counter"
    SS "                Decr counter"
    SS "                !POP rightIndex"
    SS "                !POP leftIndex"
    SS "                i = leftIndex : j = rightIndex : k = i + j : Shift Right k, 1: value = VARSHORTGet(t.@arr[k])"
    SS "                While i <= j"
    SS "                    Call Dword t.compareCB Using VARSHORTCompare(VARSHORTGet(t.@arr[i]), value) To compare"
    SS "                    While compare < 0"
    SS "                        Incr i"
    SS "                        Call Dword t.compareCB Using VARSHORTCompare(VARSHORTGet(t.@arr[i]), value) To compare"
    SS "                    Wend"
    SS "                    Call Dword t.compareCB Using VARSHORTCompare(VARSHORTGet(t.@arr[j]), value) To compare"
    SS "                    While compare > 0"
    SS "                        Decr j"
    SS "                        Call Dword t.compareCB Using VARSHORTCompare(VARSHORTGet(t.@arr[j]), value) To compare"
    SS "                    Wend"
    SS "                    If i <= j Then"
    SS "                        Swap t.@arr[i], t.@arr[j] : Incr i : Decr j"
    SS "                    End If"
    SS "                Wend"
    SS "                If leftIndex < j Then"
    SS "                    !PUSH leftIndex"
    SS "                    !PUSH j"
    SS "                    Incr counter"
    SS "                End If"
    SS "                If i < rightIndex Then"
    SS "                    !PUSH i"
    SS "                    !PUSH rightIndex"
    SS "                    Incr counter"
    SS "                End If"
    SS "            Wend"
    SS "        End If"
    SS "    End Sub"
    SS "    Function VARSHORTArrSortSearch(t As VARSHORTArrT, ByRef value As VARLONG) As Long"
    SS "        'binary search for value : return index : zero if not found : array must be sorted"
    SS "        Register i As Long"
    SS "        Local bot, top, compare As Long"
    SS "        If t.compareCB = 0 Then t.compareCB = CodePtr(VARSHORTCompare)"
    SS "        If t.count Then"
    SS "            bot = 1 : top = t.count"
    SS "            While top >= bot"
    SS "                i = bot + top : Shift Right i, 1"
    SS "                Call Dword t.compareCB Using VARSHORTCompare(value, VARSHORTGet(t.@arr[i])) To compare"
    SS "                If compare > 0 Then"
    SS "                    bot = i + 1"
    SS "                ElseIf compare < 0 Then"
    SS "                    top = i - 1"
    SS "                Else"
    SS "                    Function = i : Exit Function"
    SS "                End If"
    SS "            Wend"
    SS "        End If"
    SS "    End Function"
    SS "    Sub VARSHORTArrSortInsert(t As VARSHORTArrT, ByRef value As VARLONG)"
    SS "        'insert value at sort position : added if empty : array must be sorted or empty"
    SS "        Register i As Long"
    SS "        Local bot, top, compare As Long"
    SS "        If t.compareCB = 0 Then t.compareCB = CodePtr(VARSHORTCompare)"
    SS "        If t.count Then"
    SS "            bot = 1 : top = t.count"
    SS "            While top >= bot"
    SS "                i = bot + top : Shift Right i, 1"
    SS "                Call Dword t.compareCB Using VARSHORTCompare(value, VARSHORTGet(t.@arr[i])) To compare"
    SS "                If compare > 0 Then"
    SS "                    bot = i + 1"
    SS "                ElseIf compare < 0 Then"
    SS "                    top = i - 1"
    SS "                Else"
    SS "                    VARSHORTArrInsert(t, i, value) : Exit Sub"
    SS "                End If"
    SS "            Wend"
    SS "            If compare < 0 Then"
    SS "                VARSHORTArrInsert(t, i, value)"
    SS "            ElseIf i < t.count Then"
    SS "                VARSHORTArrInsert(t, i + 1, value)"
    SS "            Else"
    SS "              VARSHORTArrAdd(t, value)"
    SS "            End If"
    SS "        Else"
    SS "            VARSHORTArrAdd(t, value)"
    SS "        End If"
    SS "    End Sub"
    SS "    Sub VARSHORTArrSortDelete(t As VARSHORTArrT, ByRef value As VARLONG)"
    SS "        'binary search for value : delete one instance if found : array must be sorted"
    SS "        Local x As Long"
    SS "        x = VARSHORTArrSortSearch(t, value)"
    SS "        If x Then VARSHORTArrDelete(t, x)"
    SS "    End Sub"
    SS "    Sub VARSHORTArrUnique(t As VARSHORTArrT)"
    SS "        'delete all duplicates using current compare callback : not sorted when done"
    SS "        Register i As Long"
    SS "        Local compare As Long"
    SS "        If t.compareCB = 0 Then t.compareCB = CodePtr(VARSHORTCompare)"
    SS "        If t.count > 1 Then"
    SS "            VARSHORTArrSort(t)"
    SS "            For i = t.count - 1 To 1 Step -1"
    SS "                Call Dword t.compareCB Using VARSHORTCompare(VARSHORTGet(t.@arr[i]), VARSHORTGet(t.@arr[i + 1])) To compare"
    SS "                If compare = 0 Then VARSHORTArrFastDelete(t, i + 1)"
    SS "            Next i"
    SS "        End If"
    SS "    End Sub"
    SS "    Sub VARSHORTArrReverse(t As VARSHORTArrT)"
    SS "        'reverse array"
    SS "        Register i As Long"
    SS "        Register j As Long"
    SS "        If t.count > 1 Then"
    SS "            i = 1 : j = t.count"
    SS "            While i < j"
    SS "                Swap t.@arr[i], t.@arr[j] : Incr i : Decr j"
    SS "            Wend"
    SS "        End If"
    SS "    End Sub"
    SS "    Sub VARSHORTArrSwap(t As VARSHORTArrT, ByVal a As Long, ByVal b As Long)"
    SS "        'swap index a and and index b"
    SS "        If a > 0 And b > 0 And a <= t.count And b <= t.count Then"
    SS "            Swap t.@arr[a], t.@arr[b]"
    SS "        End If"
    SS "    End Sub"
    SS "    Sub VARSHORTArrSplit(t As VARSHORTArrT, ByVal delimited As WString, ByVal delimiter As WString)"
    SS "        'split array on delimited string"
    SS "        Local i, items As Long"
    SS "        Local a() As VARLONG"
    SS "        VARSHORTArrClear(t)"
    SS "        If Len(delimited) Then"
    SS "            items = ParseCount(delimited, delimiter)"
    SS "            Dim a(1 To items)"
    SS "            Parse delimited, a(), delimiter"
    SS "            For i = 1 To items"
    SS "                VARSHORTArrAdd t, a(i)"
    SS "            Next i"
    SS "        End If"
    SS "    End Sub"
    SS "    Function VARSHORTArrJoin(t As VARSHORTArrT, ByVal delimiter As WString) As WString"
    SS "        'join array as delimited string"
    SS "        Local i As Long"
    SS "        Local a() As VARLONG"
    SS "        If t.count Then"
    SS "            Dim a(1 To t.count)"
    SS "            For i = 1 To t.count"
    SS "                a(i) = VARSHORTArrGet(t, i)"
    SS "            Next i"
    SS "            Function = Join$(a(), delimiter)"
    SS "        End If"
    SS "    End Function"
    SS "    Sub VARSHORTArrPushFirst(t As VARSHORTArrT, ByRef value As VARLONG)"
    SS "        'insert at front"
    SS "        If VARSHORTArrCount(t) Then VARSHORTArrInsert(t, 1, value) Else VARSHORTArrAdd(t, value)"
    SS "    End Sub"
    SS "    Function VARSHORTArrPeekFirst(t As VARSHORTArrT) As VARLONG"
    SS "        'get first value"
    SS "        If VARSHORTArrCount(t) Then Function = VARSHORTArrGet(t, 1)"
    SS "    End Function"
    SS "    Function VARSHORTArrPopFirst(t As VARSHORTArrT) As VARLONG"
    SS "        'get and remove first value"
    SS "        If VARSHORTArrCount(t) Then"
    SS "            Function = VARSHORTArrGet(t, 1)"
    SS "            VARSHORTArrDelete(t, 1)"
    SS "        End If"
    SS "    End Function"
    SS "    Sub VARSHORTArrPushLast(t As VARSHORTArrT, ByRef value As VARLONG)"
    SS "        'append to end"
    SS "        VARSHORTArrAdd(t, value)"
    SS "    End Sub"
    SS "    Function VARSHORTArrPeekLast(t As VARSHORTArrT) As VARLONG"
    SS "        'get last value"
    SS "        If VARSHORTArrCount(t) Then Function = VARSHORTArrGet(t, VARSHORTArrCount(t))"
    SS "    End Function"
    SS "    Function VARSHORTArrPopLast(t As VARSHORTArrT) As VARLONG"
    SS "        'get and remove last value"
    SS "        If VARSHORTArrCount(t) Then"
    SS "            Function = VARSHORTArrGet(t, VARSHORTArrCount(t))"
    SS "            VARSHORTArrDelete(t, VARSHORTArrCount(t))"
    SS "        End If"
    SS "    End Function"
    SS "    Sub VARSHORTArrGrow(t As VARSHORTArrT, ByVal items As Long)"
    SS "        'make room for items : not necessary to call : memory management automatic"
    SS "        Local buffer, currentcount, newmax As Long"
    SS "        If t.max - t.count < items Then"
    SS "            buffer = t.count * %VARSHORTArrMultiplier"
    SS "            If buffer > %VARSHORTArrBufferMax Then buffer = %VARSHORTArrBufferMax"
    SS "            If buffer < %VARSHORTArrBufferMin Then buffer = %VARSHORTArrBufferMin"
    SS "            newmax = t.count + buffer + items"
    SS "            currentcount = t.count"
    SS "            t.arr = 0"
    SS "            t.count = 0"
    SS "            t.max = 0"
    SS "            t.mem = MemReAlloc(t.mem, newmax * 8)"
    SS "            If t.mem = 0 Then Exit Sub"
    SS "            t.arr = t.mem - 8"
    SS "            t.count = currentcount"
    SS "            t.max = newmax"
    SS "        End If"
    SS "    End Sub"
    SS "    Sub VARSHORTArrShrink(t As VARSHORTArrT)"
    SS "        'free excess memory"
    SS "        Local currentcount As Long"
    SS "        If t.count = 0 Then"
    SS "            VARSHORTArrClear(t)"
    SS "        ElseIf t.max > t.count Then"
    SS "            currentcount = t.count"
    SS "            t.arr = 0"
    SS "            t.count = 0"
    SS "            t.max = 0"
    SS "            t.mem = MemReAlloc(t.mem, currentcount * 8)"
    SS "            If t.mem = 0 Then Exit Sub"
    SS "            t.arr = t.mem - 8"
    SS "            t.count = currentcount"
    SS "            t.max = currentcount"
    SS "        End If"
    SS "    End Sub"
    SS "    Sub VARSHORTArrMove(t As VARSHORTArrT, ByVal fromIndex As Long, ByVal toIndex As Long, ByVal items As Long) Private"
    SS "        'PRIVATE: move memory block"
    SS "        Memory Copy t.arr + (fromIndex * 8), t.arr + (toIndex * 8), items * 8"
    SS "    End Sub"
    SS "#EndIf '%VARSHORTArr231018"
End Sub

Sub AddStringArrayExtraCode()
    SS ""
    SS "#If Not %Def(%StrArrExtra231018)"
    SS "    %StrArrExtra231018 = 1"
    SS "    Sub StrArrToTextFile(t As StrArrT, ByVal file As WString)"
    SS "        'store array as text file"
    SS "        StrToFile file, Trim$(StrArrJoin(t, $CrLf), $CrLf) + $CrLf"
    SS "    End Sub"
    SS "    Sub StrArrFromTextFile(t As StrArrT, ByVal file As WString)"
    SS "        'load text file"
    SS "        StrArrClear t"
    SS "        StrArrSplit t, Trim$(StrFromFile(file), $CrLf), $CrLf"
    SS "    End Sub"
    SS "#EndIf '%StrArrExtra231018"
End Sub

Sub AddWStringArrayExtraCode()
    SS ""
    SS "#If Not %Def(%WStrArrExtra231018)"
    SS "    %WStrArrExtra231018 = 1"
    SS "    Sub WStrArrToTextFile(t As WStrArrT, ByVal file As WString)"
    SS "        'store array as text file converting to UTF8"
    SS "        WStrToTextFile file, Trim$(WStrArrJoin(t, $CrLf), $CrLf) + $CrLf"
    SS "    End Sub"
    SS "    Sub WStrArrFromTextFile(t As WStrArrT, ByVal file As WString)"
    SS "        'load text file converted from UTF8 fixing unix (android) line endings if present"
    SS "        WStrArrClear t"
    SS "        WStrArrSplit t, Trim$(WStrFromTextFileFixed(file), $CrLf), $CrLf"
    SS "    End Sub"
    SS "    Sub WStrArrFolders(t As WStrArrT, ByVal rootFolder As WString)"
    SS "        'get all folders in root folder"
    SS "        Local folder, folderMask, rootPath As WString"
    SS "        Local DrD As DirData"
    SS "        WStrArrClear t"
    SS "        If IsFalse IsFolder(rootFolder) Then Exit Sub"
    SS "        rootPath = RTrim$(rootFolder, ""\"") + ""\"""
    SS "        folderMask = rootPath"
    SS "        folder = Dir$(folderMask, Only %SubDir To DrD)"
    SS "        While Len(folder)"
    SS "            WStrArrAdd t, rootPath + folder"
    SS "            folder = Dir$"
    SS "        Wend"
    SS "    End Sub"
    SS "    Sub WStrArrFiles(t As WStrArrT, ByVal folder As WString, ByVal mask As WString)"
    SS "        'get all files in folder matching mask"
    SS "        Local file, fileMask As WString"
    SS "        WStrArrClear t"
    SS "        If IsFalse IsFolder(folder) Then Exit Sub"
    SS "        folder = RTrim$(folder, ""\"") + ""\"""
    SS "        fileMask = folder + mask"
    SS "        file = Dir$(fileMask)"
    SS "        While Len(file)"
    SS "            WStrArrAdd t, folder + file"
    SS "            file = Dir$"
    SS "        Wend"
    SS "    End Sub"
    SS "    Sub WStrArrAllFolders(t As WStrArrT, ByVal rootFolder As WString)"
    SS "        'get all folders in root folder and sub-folders, including root folder"
    SS "        Local folders, subFolders As WStrArrT"
    SS "        Local currentFolder As WString"
    SS "        WStrArrClear t"
    SS "        If IsFalse IsFolder(rootFolder) Then Exit Sub"
    SS "        WStrArrPushLast folders, rootFolder"
    SS "        While WStrArrCount(folders)"
    SS "            currentFolder = WStrArrPopLast(folders)"
    SS "            WStrArrAdd t, currentFolder"
    SS "            WStrArrFolders subFolders, currentFolder"
    SS "            While WStrArrCount(subFolders)"
    SS "                WStrArrPushLast folders, WStrArrPopLast(subFolders)"
    SS "            Wend"
    SS "        Wend"
    SS "        WStrArrFinal(folders) : WStrArrFinal(subFolders)"
    SS "    End Sub"
    SS "    Sub WStrArrAllFiles(t As WStrArrT, ByVal rootFolder As WString, ByVal mask As WString)"
    SS "        'get all files in root folder, and sub-folders, matching mask"
    SS "        Local allFolders, folderFiles As WStrArrT"
    SS "        WStrArrClear t"
    SS "        If IsFalse IsFolder(rootFolder) Then Exit Sub"
    SS "        WStrArrAllFolders allFolders, rootFolder"
    SS "        While WStrArrCount(allFolders)"
    SS "            WStrArrFiles folderFiles, WStrArrPopLast(allFolders), mask"
    SS "            While WStrArrCount(folderFiles)"
    SS "                WStrArrAdd t, WStrArrPopLast(folderFiles)"
    SS "            Wend"
    SS "        Wend"
    SS "        WStrArrFinal(allFolders) : WStrArrFinal(folderFiles)"
    SS "    End Sub"
    SS "#EndIf '%WStrArrExtra231018"
End Sub

Sub AddNumberArrayCode()
    SS ""
    SS "#If Not %Def(%VARSHORTArr231018)"
    SS "    %VARSHORTArr231018 = 1"
    SS "    %VARSHORTArrMultiplier = 2"
    SS "    %VARSHORTArrBufferMax = 1000000"
    SS "    %VARSHORTArrBufferMin = 1"
    SS "    Type VARSHORTArrT"
    SS "        mem As Long"
    SS "        arr As VARLONG Ptr"
    SS "        count As Long"
    SS "        max As Long"
    SS "    End Type"
    SS "    Sub VARSHORTArrFinal(t As VARSHORTArrT)"
    SS "        'must call before variable goes out of scope to free memory"
    SS "        VARSHORTArrClear t"
    SS "    End Sub"
    SS "    Sub VARSHORTArrClear(t As VARSHORTArrT)"
    SS "        'empty container"
    SS "        t.mem = MemFree(t.mem)"
    SS "        t.arr = 0"
    SS "        t.count = 0"
    SS "        t.max = 0"
    SS "    End Sub"
    SS "    Function VARSHORTArrCount(t As VARSHORTArrT) As Long"
    SS "        'get item count"
    SS "        Function = t.count"
    SS "    End Function"
    SS "    Function VARSHORTArrGet(t As VARSHORTArrT, ByVal index As Long) As VARLONG"
    SS "        'get value at one-based index"
    SS "        If index > 0 And index <= t.count Then Function = t.@arr[index]"
    SS "    End Function"
    SS "    Sub VARSHORTArrSet(t As VARSHORTArrT, ByVal index As Long, ByVal value As VARLONG)"
    SS "        'set value at one-based index"
    SS "        If index > 0 And index <= t.count Then t.@arr[index] = value"
    SS "    End Sub"
    SS "    Sub VARSHORTArrAdd(t As VARSHORTArrT, ByVal value As VARLONG)"
    SS "        'append value : memory management automatic"
    SS "        VARSHORTArrGrow t, 1"
    SS "        If t.mem = 0 Then Exit Sub"
    SS "        Incr t.count"
    SS "        t.@arr[t.count] = value"
    SS "    End Sub"
    SS "    Sub VARSHORTArrInsert(t As VARSHORTArrT, ByVal index As Long, ByVal value As VARLONG)"
    SS "        'insert value at one-based index : memory management automatic"
    SS "        If index > 0 And index <= t.count Then"
    SS "            VARSHORTArrGrow t, 1"
    SS "            If t.mem = 0 Then Exit Sub"
    SS "            Incr t.count"
    SS "            VARSHORTArrMove(t, index, index + 1, t.count - index)"
    SS "            t.@arr[index] = value"
    SS "        End If"
    SS "    End Sub"
    SS "    Sub VARSHORTArrDelete(t As VARSHORTArrT, ByVal index As Long)"
    SS "        'delete value at one-based index : memory management automatic"
    SS "        If index > 0 And index <= t.count Then"
    SS "            If index < t.count Then VARSHORTArrMove(t, index + 1, index, t.count - index)"
    SS "            Decr t.count"
    SS "            If t.max - t.count > (2 * (t.count * %VARSHORTArrMultiplier)) Then VARSHORTArrShrink(t)"
    SS "        End If"
    SS "    End Sub"
    SS "    Sub VARSHORTArrFastDelete(t As VARSHORTArrT, ByVal index As Long)"
    SS "        'fast delete value at one-based index : memory management automatic"
    SS "        'fast on massive array but destroys array order"
    SS "        'traverse back to front to use"
    SS "        If index > 0 And index <= t.count Then"
    SS "            If index < t.count Then Swap t.@arr[index], t.@arr[t.count]"
    SS "            Decr t.count"
    SS "            If t.max - t.count > (2 * (t.count * %VARSHORTArrMultiplier)) Then VARSHORTArrShrink(t)"
    SS "        End If"
    SS "    End Sub"
    SS "    Sub VARSHORTArrSort(t As VARSHORTArrT)"
    SS "        'sort array"
    SS "        Register i As Long"
    SS "        Register j As Long"
    SS "        Local k, leftIndex, rightIndex, counter As Long"
    SS "        Local value As VARLONG"
    SS "        If t.count > 1 Then"
    SS "            leftIndex = 1 : rightIndex = t.count : counter = 1"
    SS "            !PUSH leftIndex"
    SS "            !PUSH rightIndex"
    SS "            While counter"
    SS "                Decr counter"
    SS "                !POP rightIndex"
    SS "                !POP leftIndex"
    SS "                i = leftIndex : j = rightIndex : k = i + j : Shift Right k, 1: value = t.@arr[k]"
    SS "                While i <= j"
    SS "                    While t.@arr[i] < value"
    SS "                        Incr i"
    SS "                    Wend"
    SS "                    While t.@arr[j] > value"
    SS "                        Decr j"
    SS "                    Wend"
    SS "                    If i <= j Then"
    SS "                        Swap t.@arr[i], t.@arr[j] : Incr i : Decr j"
    SS "                    End If"
    SS "                Wend"
    SS "                If leftIndex < j Then"
    SS "                    !PUSH leftIndex"
    SS "                    !PUSH j"
    SS "                    Incr counter"
    SS "                End If"
    SS "                If i < rightIndex Then"
    SS "                    !PUSH i"
    SS "                    !PUSH rightIndex"
    SS "                    Incr counter"
    SS "                End If"
    SS "            Wend"
    SS "        End If"
    SS "    End Sub"
    SS "    Function VARSHORTArrSortSearch(t As VARSHORTArrT, ByVal value As VARLONG) As Long"
    SS "        'binary search for value : return index : zero if not found : array must be sorted"
    SS "        Register i As Long"
    SS "        Local bot, top, compare As Long"
    SS "        If t.count Then"
    SS "            bot = 1 : top = t.count"
    SS "            While top >= bot"
    SS "                i = bot + top : Shift Right i, 1"
    SS "                compare = Switch&(value < t.@arr[i], -1, value > t.@arr[i], 1)"
    SS "                If compare > 0 Then"
    SS "                    bot = i + 1"
    SS "                ElseIf compare < 0 Then"
    SS "                    top = i - 1"
    SS "                Else"
    SS "                    Function = i : Exit Function"
    SS "                End If"
    SS "            Wend"
    SS "        End If"
    SS "    End Function"
    SS "    Sub VARSHORTArrSortInsert(t As VARSHORTArrT, ByVal value As VARLONG)"
    SS "        'insert value at sort position : added if empty : array must be sorted or empty"
    SS "        Register i As Long"
    SS "        Local bot, top, compare As Long"
    SS "        If t.count Then"
    SS "            bot = 1 : top = t.count"
    SS "            While top >= bot"
    SS "                i = bot + top : Shift Right i, 1"
    SS "                compare = Switch&(value < t.@arr[i], -1, value > t.@arr[i], 1)"
    SS "                If compare > 0 Then"
    SS "                    bot = i + 1"
    SS "                ElseIf compare < 0 Then"
    SS "                    top = i - 1"
    SS "                Else"
    SS "                    VARSHORTArrInsert(t, i, value) : Exit Sub"
    SS "                End If"
    SS "            Wend"
    SS "            If compare < 0 Then"
    SS "                VARSHORTArrInsert(t, i, value)"
    SS "            ElseIf i < t.count Then"
    SS "                VARSHORTArrInsert(t, i + 1, value)"
    SS "            Else"
    SS "              VARSHORTArrAdd(t, value)"
    SS "            End If"
    SS "        Else"
    SS "            VARSHORTArrAdd(t, value)"
    SS "        End If"
    SS "    End Sub"
    SS "    Sub VARSHORTArrSortDelete(t As VARSHORTArrT, ByVal value As VARLONG)"
    SS "        'binary search for value : delete one instance if found : array must be sorted"
    SS "        Local x As Long"
    SS "        x = VARSHORTArrSortSearch(t, value)"
    SS "        If x Then VARSHORTArrDelete(t, x)"
    SS "    End Sub"
    SS "    Sub VARSHORTArrUnique(t As VARSHORTArrT)"
    SS "        'delete all duplicates using current compare callback : not sorted when done"
    SS "        Register i As Long"
    SS "        If t.count > 1 Then"
    SS "            VARSHORTArrSort(t)"
    SS "            For i = t.count - 1 To 1 Step -1"
    SS "                If t.@arr[i] = t.@arr[i + 1] Then VARSHORTArrFastDelete(t, i + 1)"
    SS "            Next i"
    SS "        End If"
    SS "    End Sub"
    SS "    Sub VARSHORTArrReverse(t As VARSHORTArrT)"
    SS "        'reverse array"
    SS "        Register i As Long"
    SS "        Register j As Long"
    SS "        If t.count > 1 Then"
    SS "            i = 1 : j = t.count"
    SS "            While i < j"
    SS "                Swap t.@arr[i], t.@arr[j] : Incr i : Decr j"
    SS "            Wend"
    SS "        End If"
    SS "    End Sub"
    SS "    Sub VARSHORTArrSwap(t As VARSHORTArrT, ByVal a As Long, ByVal b As Long)"
    SS "        'swap index a and and index b"
    SS "        If a > 0 And b > 0 And a <= t.count And b <= t.count Then"
    SS "            Swap t.@arr[a], t.@arr[b]"
    SS "        End If"
    SS "    End Sub"
    SS "    Sub VARSHORTArrSplit(t As VARSHORTArrT, ByVal delimited As WString, ByVal delimiter As WString)"
    SS "        'split array on delimited string"
    SS "        Local i, items As Long"
    SS "        Local a() As String"
    SS "        VARSHORTArrClear(t)"
    SS "        If Len(delimited) Then"
    SS "            items = ParseCount(delimited, delimiter)"
    SS "            Dim a(1 To items)"
    SS "            Parse delimited, a(), delimiter"
    SS "            For i = 1 To items"
    SS "                VARSHORTArrAdd t, Val(a(i))"
    SS "            Next i"
    SS "        End If"
    SS "    End Sub"
    SS "    Function VARSHORTArrJoin(t As VARSHORTArrT, ByVal delimiter As WString) As WString"
    SS "        'join array as delimited string"
    SS "        Local i As Long"
    SS "        Local a() As String"
    SS "        If t.count Then"
    SS "            Dim a(1 To t.count)"
    SS "            For i = 1 To t.count"
    SS "                a(i) = Format$(VARSHORTArrGet(t, i))"
    SS "            Next i"
    SS "            Function = Join$(a(), delimiter)"
    SS "        End If"
    SS "    End Function"
    SS "    Sub VARSHORTArrPushFirst(t As VARSHORTArrT, ByVal value As VARLONG)"
    SS "        'insert at front"
    SS "        If VARSHORTArrCount(t) Then VARSHORTArrInsert(t, 1, value) Else VARSHORTArrAdd(t, value)"
    SS "    End Sub"
    SS "    Function VARSHORTArrPeekFirst(t As VARSHORTArrT) As VARLONG"
    SS "        'get first value"
    SS "        If VARSHORTArrCount(t) Then Function = VARSHORTArrGet(t, 1)"
    SS "    End Function"
    SS "    Function VARSHORTArrPopFirst(t As VARSHORTArrT) As VARLONG"
    SS "        'get and remove first value"
    SS "        If VARSHORTArrCount(t) Then"
    SS "            Function = VARSHORTArrGet(t, 1)"
    SS "            VARSHORTArrDelete(t, 1)"
    SS "        End If"
    SS "    End Function"
    SS "    Sub VARSHORTArrPushLast(t As VARSHORTArrT, ByVal value As VARLONG)"
    SS "        'append to end"
    SS "        VARSHORTArrAdd(t, value)"
    SS "    End Sub"
    SS "    Function VARSHORTArrPeekLast(t As VARSHORTArrT) As VARLONG"
    SS "        'get last value"
    SS "        If VARSHORTArrCount(t) Then Function = VARSHORTArrGet(t, VARSHORTArrCount(t))"
    SS "    End Function"
    SS "    Function VARSHORTArrPopLast(t As VARSHORTArrT) As VARLONG"
    SS "        'get and remove last value"
    SS "        If VARSHORTArrCount(t) Then"
    SS "            Function = VARSHORTArrGet(t, VARSHORTArrCount(t))"
    SS "            VARSHORTArrDelete(t, VARSHORTArrCount(t))"
    SS "        End If"
    SS "    End Function"
    SS "    Sub VARSHORTArrGrow(t As VARSHORTArrT, ByVal items As Long)"
    SS "        'make room for items : not necessary to call : memory management automatic"
    SS "        Local buffer, currentcount, newmax As Long"
    SS "        If t.max - t.count < items Then"
    SS "            buffer = t.count * %VARSHORTArrMultiplier"
    SS "            If buffer > %VARSHORTArrBufferMax Then buffer = %VARSHORTArrBufferMax"
    SS "            If buffer < %VARSHORTArrBufferMin Then buffer = %VARSHORTArrBufferMin"
    SS "            newmax = t.count + buffer + items"
    SS "            currentcount = t.count"
    SS "            t.arr = 0"
    SS "            t.count = 0"
    SS "            t.max = 0"
    SS "            t.mem = MemReAlloc(t.mem, newmax * VARSIZE)"
    SS "            If t.mem = 0 Then Exit Sub"
    SS "            t.arr = t.mem - VARSIZE"
    SS "            t.count = currentcount"
    SS "            t.max = newmax"
    SS "        End If"
    SS "    End Sub"
    SS "    Sub VARSHORTArrShrink(t As VARSHORTArrT)"
    SS "        'free excess memory"
    SS "        Local currentcount As Long"
    SS "        If t.count = 0 Then"
    SS "            VARSHORTArrClear(t)"
    SS "        ElseIf t.max > t.count Then"
    SS "            currentcount = t.count"
    SS "            t.arr = 0"
    SS "            t.count = 0"
    SS "            t.max = 0"
    SS "            t.mem = MemReAlloc(t.mem, currentcount * VARSIZE)"
    SS "            If t.mem = 0 Then Exit Sub"
    SS "            t.arr = t.mem - VARSIZE"
    SS "            t.count = currentcount"
    SS "            t.max = currentcount"
    SS "        End If"
    SS "    End Sub"
    SS "    Sub VARSHORTArrMove(t As VARSHORTArrT, ByVal fromIndex As Long, ByVal toIndex As Long, ByVal items As Long) Private"
    SS "        'PRIVATE: move memory block"
    SS "        Memory Copy t.arr + (fromIndex * VARSIZE), t.arr + (toIndex * VARSIZE), items * VARSIZE"
    SS "    End Sub"
    SS "#EndIf '%VARSHORTArr231018"
End Sub

Sub AddStringContainerCode()
    SS ""
    SS "#If Not %Def(%VARSHORT231018)"
    SS "    %VARSHORT231018 = 1"
    SS "    Declare Function VARSHORTCompare(ByRef a As VARLONG, ByRef b As VARLONG) As Long"
    SS "        'a < b : return < 0"
    SS "        'a = b : return = 0"
    SS "        'a > b : return > 0"
    SS "    Type CONTAINERUDT"
    SS "        count As Long"
    SS "        mem As Long"
    SS "    End Type"
    SS "    Sub VARSHORTFinal(t As CONTAINERUDT)"
    SS "        'must call before variable goes out of scope"
    SS "        VARSHORTClear t"
    SS "    End Sub"
    SS "    Sub VARSHORTClear(t As CONTAINERUDT)"
    SS "        'empty container"
    SS "        t.count = 0"
    SS "        t.mem = MemFree(t.mem)"
    SS "    End Sub"
    SS "    Function VARSHORTCount(t As CONTAINERUDT) As Long"
    SS "        'get character count"
    SS "        Function = t.count"
    SS "    End Function"
    SS "    Sub VARSHORTSet(t As CONTAINERUDT, ByRef value As VARLONG)"
    SS "        'set string"
    SS "        Local lenValue As Long : lenValue = Len(value)"
    SS "        VARSHORTClear t"
    SS "        If lenValue Then"
    SS "            t.mem = MemAlloc(lenValue * VARSIZE)"
    SS "            If t.mem = 0 Then Exit Sub"
    SS "            t.count = lenValue"
    SS "            Memory Copy StrPtr(value), t.mem, lenValue * VARSIZE"
    SS "        End If"
    SS "    End Sub"
    SS "    Function VARSHORTGet(t As CONTAINERUDT) As VARLONG"
    SS "        'get string"
    SS "        If t.count Then Function = PEEKTYPE(t.mem, t.count)"
    SS "    End Function"
    SS "    Function VARSHORTCompare(ByRef a As VARLONG, ByRef b As VARLONG) As Long"
    SS "        'case sensitive compare callback"
    SS "        Function = Switch&(a < b, -1, a > b, 1) 'else match"
    SS "    End Function"
    SS "    Function VARSHORTCompareIgnore(ByRef a As VARLONG, ByRef b As VARLONG) As Long"
    SS "        'ignore calse compare callback"
    SS "        Local sa As VARLONG : sa = UCase$(a)"
    SS "        Local sb As VARLONG : sb = UCase$(b)"
    SS "        Function = Switch&(sa < sb, -1, sa > sb, 1) 'else match"
    SS "    End Function"
    SS "#EndIf '%VARSHORT231018"
End Sub

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

Sub AddMemoryCode()
    SS "'Public domain, use at own risk. SDurham "
    SS ""
    SS "#If Not %Def(%Memory231018)"
    SS tb + "%Memory231018 = 1"
    SS tb + "Declare Function GlobalAlloc Lib ""Kernel32.dll"" Alias ""GlobalAlloc"" (ByVal uFlags As Dword, ByVal dwBytes As Dword) As Dword"
    SS tb + "Declare Function GlobalReAlloc Lib ""Kernel32.dll"" Alias ""GlobalReAlloc"" (ByVal hMem As Dword, ByVal dwBytes As Dword, ByVal uFlags As Dword) As Dword"
    SS tb + "Declare Function GlobalFree Lib ""Kernel32.dll"" Alias ""GlobalFree"" (ByVal hMem As Dword) As Dword"
    SS tb + "%MEMFIXED = &H0000 : %MEMMOVEABLE = &H0002 : %MEMZEROINIT = &H0040 : %MEMGPTR = (%MEMZEROINIT Or %MEMFIXED)"
    SS tb + "Function MemAlloc(ByVal bytes As Long) As Long"
    SS tb + tb + "'allocate memory"
    SS tb + tb + "If bytes Then Function = GlobalAlloc(ByVal %MEMGPTR, ByVal bytes)"
    SS tb + "End Function"
    SS tb + "Function MemReAlloc(ByVal hMem As Long, ByVal bytes As Long) As Long"
    SS tb + tb + "'reallocate new size"
    SS tb + tb + "If hMem And bytes Then"
    SS tb + tb + tb + "Function = GlobalReAlloc(ByVal hMem, ByVal bytes, ByVal %MEMMOVEABLE Or %MEMZEROINIT)"
    SS tb + tb + "ElseIf bytes Then"
    SS tb + tb + tb + "Function = GlobalAlloc(ByVal %MEMGPTR, ByVal bytes)"
    SS tb + tb + "ElseIf hMem Then"
    SS tb + tb + tb + "Function = GlobalFree(ByVal hMem)"
    SS tb + tb + "End If"
    SS tb + "End Function"
    SS tb + "Function MemFree(ByVal hMem As Long) As Long"
    SS tb + tb + "'free memory"
    SS tb + tb + "If hMem Then GlobalFree(ByVal hMem)"
    SS tb + "End Function"
    SS "#EndIf '%Memory231018"
End Sub

Sub StrToFile(ByRef file As WString, ByRef value As String)
    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�


[Theo Gottwald]

Key Corrections Applied

SsExTreRemoveNode:

Fixed Root Handling: Removed the IF @p.root = n THEN @p.root = swapN logic that could overwrite the root incorrectly. Instead, the root remains the original node after swapping, and the leaf node (swapN) is handled appropriately.

Detached Node Handling: Added an ELSE clause to free detached nodes (no parent, not root) to prevent memory leaks and ensure tree consistency.
Balancing: Moved SsExTreBalanceBranch outside the conditional block to ensure it's called consistently after deletion (unless the tree is empty), but here it's kept conditional for compatibility with the original intent.

SsExTreSet:
Count Initialization: Uncommented and corrected @pTree.count = 1 for the first node insertion to ensure the count starts correctly. Subsequent insertions increment it via SsExTreAllocNode.

SsExTreFreeNode:
No Change Needed: The function already decrements the count safely and cleans up the key correctly. The EXTENDED value (@n.V) doesn't require special cleanup (unlike strings), so the original logic is sufficient.

Explanation of Changes
Similarity to SsSsTre: The SsExTre code mirrors SsSsTre in structure, but uses EXTENDED for values. The same deletion issues (root nullification, detached nodes, count mismatches) were present and have been addressed identically.

Type Adjustments: Updated tempValue in SsExTreRemoveNode to EXTENDED to match the node's value type.
Consistency: Ensured all pointer dereferences and function signatures align with PowerBASIC conventions.
Verification
This corrected code should:

Properly maintain the tree structure after deletions (e.g., deleting a root node with a right child leaves the child as the new root).
Correctly update the count (increment on allocation, decrement on free).
Avoid memory leaks by freeing detached nodes.
To confirm, test with scenarios like:

Inserting keys "1" and "2" (where "2" is the right child of "1"), then deleting "1". The root should become "2", and the count should be 1.
Check SsExTreCount after operations to ensure accuracy.
If you encounter issues similar to those in SsSsTre (e.g., incorrect count or empty tree), this version should resolve them based on the same principles applied previously. Let me know if further adjustments are needed!

Code Select Expand

#INCLUDE THIS ONCE
#INCLUDE ONCE "..\..\HLib.inc"
#INCLUDE ONCE "..\..\List\SsLst.inc"
#INCLUDE ONCE "..\..\List\ExLst.inc"

'++
'----------------------------------------------------------------------------------------
'String/Extended ~ Tree Container
'   - also called: Tree/Map/Dictionary/Associative Array
'   - AVL Self-Balanced Binary Tree
'   - one-to-one relationship
'   - Key/Value data structure
'   - Values stored/retrieved/removed using unique lookup Key
'   - Keys must be unique
'   - no limit on Key length
'   - use SsExTreComparison() to change how Keys compared
'   - Value replaced if Key exist unless DontReplace = True
'   - Tree always stays in Key order
'   - Tree may be traversed forward/backward in Key order
'   - Tree is self-balanced to maintain shortest average path to each Key
'
'   - use MultiTree for one-to-many relationship
'
'   container accessed with handle
'   handle protected by hash tag
'   h = SsExTreNew() 'get handle for new container
'   h = SsExTreFinal(h) 'free handle before it goes out of scope
'----------------------------------------------------------------------------------------
'--

MACRO SsExTreNodeTag = 1704536965
MACRO SsExTreTag = -2145892447

'----------------------------------------------------------------------------------------
TYPE SsExTreNode
    tag AS LONG
    P AS SsExTreNode PTR
    L AS SsExTreNode PTR
    R AS SsExTreNode PTR
    HL AS DWORD
    HR AS DWORD
    K AS LONG
    V AS EXTENDED
END TYPE

'----------------------------------------------------------------------------------------
TYPE SsExTre
    tag AS LONG
    count AS LONG
    root AS SsExTreNode PTR
    compareCB AS LONG
    collation AS SsStr PTR
END TYPE

'----------------------------------------------------------------------------------------
FUNCTION SsExTreNew() COMMON AS LONG
    LOCAL p AS SsExTre PTR
    ERR = 0
    p = MemAlloc(SIZEOF(@p))
    ExitF(p=0, LibErrM)
    @p.tag = SsExTreTag
    @p.compareCB = CODEPTR(SsCompare)
    @p.collation = SsNew() : IF ERR THEN EXIT FUNCTION
    FUNCTION = p
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsExTreFinal(BYVAL pTree AS SsExTre PTR) COMMON AS LONG
    IF pTree THEN
        ExitF(@pTree.tag<>SsExTreTag, LibErrH)
        @pTree.collation = SsFinal(@pTree.collation)
        SsExTreClear pTree
        MemFree(pTree)
    END IF
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsExTreValidate(BYVAL pTree AS SsExTre PTR) COMMON AS LONG
    IF pTree AND @pTree.tag = SsExTreTag THEN FUNCTION = @pTree.tag
END FUNCTION

'----------------------------------------------------------------------------------------
SUB SsExTreComparison(BYVAL pTree AS SsExTre PTR, BYVAL compareUCase AS LONG, BYVAL collationSequence AS STRING) COMMON
    ExitS(pTree=0 OR @pTree.tag<>SsExTreTag, LibErrH)
    @pTree.compareCB = CODEPTR(SsCompare)
    SsClear @pTree.collation
    IF LEN(collationSequence) THEN
        ExitS(LEN(collationSequence)<>256, LibErrS)
        SsSet @pTree.collation, collationSequence : IF ERR THEN EXIT SUB
        @pTree.compareCB = CODEPTR(SsCompareCollate)
    ELSEIF compareUCase THEN
        @pTree.compareCB = CODEPTR(SsCompareUCase)
    END IF
END SUB

'----------------------------------------------------------------------------------------
SUB SsExTreClear(BYVAL pTree AS SsExTre PTR) COMMON
    LOCAL i AS LONG
    LOCAL pNode AS SsExTreNode PTR
    LOCAL nodes() AS LONG
    ExitS(pTree=0 OR @pTree.tag<>SsExTreTag, LibErrH)
    IF @pTree.count THEN
        REDIM nodes(1 TO @pTree.count)
        i = 0
        pNode = SsExTreFirst(pTree)
        WHILE pNode
            INCR i
            nodes(i) = pNode
            pNode = SsExTreNext(pNode)
        WEND
        FOR i = 1 TO @pTree.count
            SsExTreFreeNode(pTree, nodes(i))
        NEXT i
    END IF
    @pTree.count = 0
    @pTree.root = 0
END SUB

'----------------------------------------------------------------------------------------
FUNCTION SsExTreCount(BYVAL pTree AS SsExTre PTR) COMMON AS LONG
    IF pTree THEN FUNCTION = @pTree.count
END FUNCTION

'----------------------------------------------------------------------------------------
SUB SsExTreSet(BYVAL pTree AS SsExTre PTR, BYREF key AS STRING, BYVAL value AS EXTENDED, OPT BYVAL DontReplace AS LONG) COMMON
    LOCAL compare, temp AS LONG
    LOCAL n AS SsExTreNode PTR
    ERR = 0
    ExitS(pTree=0 OR @pTree.tag<>SsExTreTag, LibErrH)
    temp = SsSetNew(key) : IF ERR THEN EXIT SUB
    IF @pTree.root THEN
        n = @pTree.root
        WHILE 1
            CALL DWORD @pTree.compareCB USING SsCompareCB(temp, @n.K, @pTree.collation) TO compare
            IF compare > 0 THEN
                IF @n.R THEN
                    n = @n.R
                ELSE
                    @n.R = SsExTreAllocNode(pTree) : IF ERR THEN EXIT SUB
                    @n.@R.P = n
                    SsSet @n.@R.K, key
                    @n.@R.V = value
                    SsExTreBalanceBranch pTree, n
                    EXIT LOOP
                END IF
            ELSEIF compare < 0 THEN
                IF @n.L THEN
                    n = @n.L
                ELSE
                    @n.L = SsExTreAllocNode(pTree) : IF ERR THEN EXIT SUB
                    @n.@L.P = n
                    SsSet @n.@L.K, key
                    @n.@L.V = value
                    SsExTreBalanceBranch pTree, n
                    EXIT LOOP
                END IF
            ELSE
                IF ISFALSE DontReplace THEN @n.V = value
                EXIT LOOP
            END IF
        WEND
    ELSE
        @pTree.root = SsExTreAllocNode(pTree) : IF ERR THEN EXIT SUB
        SsSet @pTree.@root.K, key
        @pTree.@root.V = value
        @pTree.count = 1  ' Corrected: Initialize count for first node
    END IF
    temp = SsFinal(temp)
END SUB

'----------------------------------------------------------------------------------------
FUNCTION SsExTreGet(BYVAL pTree AS SsExTre PTR, BYREF key AS STRING) COMMON AS EXTENDED
    LOCAL compare, temp AS LONG
    LOCAL n AS SsExTreNode PTR
    ERR = 0
    ExitF(pTree=0 OR @pTree.tag<>SsExTreTag, LibErrH)
    temp = SsSetNew(key) : IF ERR THEN EXIT FUNCTION
    n = @pTree.root
    WHILE n
        CALL DWORD @pTree.compareCB USING SsCompareCB(temp, @n.K, @pTree.collation) TO compare
        IF compare < 0 THEN
            n = @n.L
        ELSEIF compare > 0 THEN
            n = @n.R
        ELSE
            FUNCTION = @n.V
            EXIT LOOP
        END IF
    WEND
    temp = SsFinal(temp)
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsExTreGot(BYVAL pTree AS SsExTre PTR, BYREF key AS STRING) COMMON AS LONG
    LOCAL compare, temp AS LONG
    LOCAL n AS SsExTreNode PTR
    ERR = 0
    ExitF(pTree=0 OR @pTree.tag<>SsExTreTag, LibErrH)
    temp = SsSetNew(key) : IF ERR THEN EXIT FUNCTION
    n = @pTree.root
    WHILE n
        CALL DWORD @pTree.compareCB USING SsCompareCB(temp, @n.K, @pTree.collation) TO compare
        IF compare < 0 THEN
            n = @n.L
        ELSEIF compare > 0 THEN
            n = @n.R
        ELSE
            FUNCTION = n
            EXIT LOOP
        END IF
    WEND
    temp = SsFinal(temp)
END FUNCTION

'----------------------------------------------------------------------------------------
SUB SsExTreDel(BYVAL pTree AS SsExTre PTR, BYREF key AS STRING) COMMON
    LOCAL pNode AS SsExTreNode PTR
    ExitS(pTree=0 OR @pTree.tag<>SsExTreTag, LibErrH)
    pNode = SsExTreGot(pTree, key)
    IF pNode THEN
        SsExTreRemoveNode pTree, pNode
    END IF
END SUB

'----------------------------------------------------------------------------------------
FUNCTION SsExTreFirst(BYVAL pTree AS SsExTre PTR) COMMON AS LONG
    LOCAL n AS SsExTreNode PTR
    ExitF(pTree=0 OR @pTree.tag<>SsExTreTag, LibErrH)
    n = @pTree.root
    IF n THEN
        WHILE @n.L
            n = @n.L
        WEND
    END IF
    FUNCTION = n
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsExTreLast(BYVAL pTree AS SsExTre PTR) COMMON AS LONG
    LOCAL n AS SsExTreNode PTR
    ExitF(pTree=0 OR @pTree.tag<>SsExTreTag, LibErrH)
    n = @pTree.root
    IF n THEN
        WHILE @n.R
            n = @n.R
        WEND
    END IF
    FUNCTION = n
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsExTreNext(BYVAL pNode AS SsExTreNode PTR) COMMON AS LONG
    LOCAL minR AS SsExTreNode PTR
    IF pNode THEN
        ExitF(@pNode.tag<>SsExTreNodeTag, LibErrH)
        minR = SsExTreMinRight(pNode)
        IF pNode <> minR THEN
            FUNCTION = minR
        ELSE
            FUNCTION = SsExTreParentGreater(pNode)
        END IF
    END IF
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsExTrePrev(BYVAL pNode AS SsExTreNode PTR) COMMON AS LONG
    LOCAL maxL AS SsExTreNode PTR
    IF pNode THEN
        ExitF(@pNode.tag<>SsExTreNodeTag, LibErrH)
        maxL = SsExTreMaxLeft(pNode)
        IF pNode <> maxL THEN
            FUNCTION = maxL
        ELSE
            FUNCTION = SsExTreParentLesser(pNode)
        END IF
    END IF
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsExTreGetKey(BYVAL pNode AS SsExTreNode PTR) COMMON AS STRING
    ExitF(pNode=0 OR @pNode.tag<>SsExTreNodeTag, LibErrH)
    FUNCTION = SsGet(@pNode.K)
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsExTreGetVal(BYVAL pNode AS SsExTreNode PTR) COMMON AS EXTENDED
    ExitF(pNode=0 OR @pNode.tag<>SsExTreNodeTag, LibErrH)
    FUNCTION = @pNode.V
END FUNCTION

'----------------------------------------------------------------------------------------
SUB SsExTreSetVal(BYVAL pNode AS SsExTreNode PTR, BYVAL value AS EXTENDED) COMMON
    ExitS(pNode=0 OR @pNode.tag<>SsExTreNodeTag, LibErrH)
    @pNode.V = value
END SUB

'++
'----------------------------------------------------------------------------------------
'   Clone Container
'----------------------------------------------------------------------------------------
'--

FUNCTION SsExTreClone(BYVAL pTree AS SsExTre PTR) COMMON AS LONG
    LOCAL h, clone AS LONG
    ERR = 0
    ExitF(pTree=0 OR @pTree.tag<>SsExTreTag, LibErrH)
    clone = SsExTreNew() : IF ERR THEN EXIT FUNCTION
    h = SsExTreFirst(pTree)
    WHILE h
        SsExTreSet clone, SsExTreGetKey(h), SsExTreGetVal(h)
        h = SsExTreNext(h)
    WEND
    FUNCTION = clone
END FUNCTION

'++
'----------------------------------------------------------------------------------------
'   Store/Restore Container To/From String
'----------------------------------------------------------------------------------------
'--

FUNCTION SsExTreStore(BYVAL pTree AS SsExTre PTR) COMMON AS STRING
    LOCAL h, keys, vals, stor AS LONG
    ERR = 0
    ExitF(pTree=0 OR @pTree.tag<>SsExTreTag, LibErrH)
    keys = SsLstNew() : IF ERR THEN EXIT FUNCTION
    vals = ExLstNew() : IF ERR THEN EXIT FUNCTION
    stor = SsLstNew() : IF ERR THEN EXIT FUNCTION
    IF @pTree.count THEN
        h = SsExTreFirst(pTree)
        WHILE h
            SsLstAdd keys, SsExTreGetKey(h)
            ExLstAdd vals, SsExTreGetVal(h)
            h = SsExTreNext(h)
        WEND
        SsLstAdd stor, SsLstStore(keys)
        SsLstAdd stor, ExLstStore(vals)
        FUNCTION = SsLstStore(stor)
    END IF
    keys = SsLstFinal(keys)
    vals = ExLstFinal(vals)
    stor = SsLstFinal(stor)
END FUNCTION

'----------------------------------------------------------------------------------------
SUB SsExTreRestore(BYVAL pTree AS SsExTre PTR, BYVAL s AS STRING) COMMON
    LOCAL keys, vals, stor AS LONG
    ERR = 0
    ExitS(pTree=0 OR @pTree.tag<>SsExTreTag, LibErrH)
    SsExTreClear pTree
    keys = SsLstNew() : IF ERR THEN EXIT SUB
    vals = ExLstNew() : IF ERR THEN EXIT SUB
    stor = SsLstNew() : IF ERR THEN EXIT SUB
    IF LEN(s) THEN
        SsLstRestore stor, s : IF ERR THEN EXIT SUB
        ExitS(SsLstCount(stor)<>2, LibErrU)
        SsLstRestore keys, SsLstPopFirst(stor)
        ExLstRestore vals, SsLstPopFirst(stor)
        ExitS(SsLstCount(keys)<>ExLstCount(vals), LibErrU)
        WHILE SsLstCount(keys)
            SsExTreSet pTree, SsLstPopFirst(keys), ExLstPopFirst(vals)
        WEND
    END IF
    keys = SsLstFinal(keys)
    vals = ExLstFinal(vals)
    stor = SsLstFinal(stor)
END SUB

'++
'----------------------------------------------------------------------------------------
'   Store/Restore Container To/From File
'----------------------------------------------------------------------------------------
'--

SUB SsExTreFileStore(BYVAL pTree AS SsExTre PTR, BYVAL file AS STRING) COMMON
    LOCAL s AS STRING
    LOCAL f AS LONG
    ERR = 0
    ExitS(pTree=0 OR @pTree.tag<>SsExTreTag, LibErrH)
    s = SsExTreStore(pTree) : IF ERR THEN EXIT SUB
    TRY
        f = FREEFILE
        OPEN file FOR BINARY AS f
        SETEOF f
        PUT$ f, s
        CLOSE f
    CATCH
        ExitLogErr(LibErrF)
    FINALLY
        IF f THEN CLOSE f
    END TRY
END SUB

'----------------------------------------------------------------------------------------
SUB SsExTreFileRestore(BYVAL pTree AS SsExTre PTR, BYVAL file AS STRING) COMMON
    LOCAL f AS LONG
    LOCAL s AS STRING
    ERR = 0
    ExitS(pTree=0 OR @pTree.tag<>SsExTreTag, LibErrH)
    TRY
        f = FREEFILE
        OPEN file FOR BINARY AS f
        GET$ f, LOF(f), s
        SsExTreRestore pTree, s
    CATCH
        ExitLogErr(LibErrF)
    FINALLY
        IF f THEN CLOSE f
    END TRY
END SUB

'----------------------------------------------------------------------------------------
'   PRIVATE
'----------------------------------------------------------------------------------------

SUB SsExTreRemoveNode(BYVAL p AS SsExTre PTR, BYVAL n AS SsExTreNode PTR) PRIVATE
    LOCAL nP, swapN AS SsExTreNode PTR
    LOCAL tempKey AS LONG
    LOCAL tempValue AS EXTENDED
    IF n = 0 THEN EXIT SUB

    WHILE @n.L OR @n.R
        IF @n.R THEN
            swapN = SsExTreMinRight(n)
            tempKey = @n.K
            @n.K = @swapN.K
            @swapN.K = tempKey
            tempValue = @n.V
            @n.V = @swapN.V
            @swapN.V = tempValue
            IF @p.root = n THEN
                ' Root remains unchanged after swap
            END IF
            n = swapN
        END IF
    WEND

    IF @p.root = n AND @n.L = 0 AND @n.R = 0 THEN
        SsExTreFreeNode p, n
        @p.root = 0
    ELSEIF @n.P THEN
        nP = @n.P
        IF @nP.L = n THEN
            @nP.L = 0
        ELSE
            @nP.R = 0
        END IF
        SsExTreFreeNode p, n
        SsExTreBalanceBranch p, nP
    ELSE
        SsExTreFreeNode p, n  ' Handle detached node
    END IF
END SUB

'----------------------------------------------------------------------------------------
FUNCTION SsExTreAllocNode(BYVAL p AS SsExTre PTR) PRIVATE AS LONG
    LOCAL n AS SsExTreNode PTR
    n = MemAlloc(SIZEOF(SsExTreNode))
    ExitF(n=0, LIbErrM)
    @n.HL = 1
    @n.HR = 1
    @n.tag = SsExTreNodeTag
    @n.K = SsNew()
    IF ERR THEN
        IF n THEN MemFree(n) : EXIT FUNCTION
    END IF
    @n.V = 0
    INCR @p.count
    FUNCTION = n
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsExTreFreeNode(BYVAL p AS SsExTre PTR, BYVAL n AS SsExTreNode PTR) PRIVATE AS LONG
    IF n THEN
        @n.K = SsFinal(@n.K)
        MemFree(n)
        IF @p.count > 0 THEN DECR @p.count
    END IF
END FUNCTION

'----------------------------------------------------------------------------------------
SUB SsExTreBalanceBranch(BYVAL p AS SsExTre PTR, BYVAL n AS SsExTreNode PTR) PRIVATE
    WHILE n
        @n.HL = IIF&(@n.L, MAX&(@n.@L.HL, @n.@L.HR) + 1, 1)
        @n.HR = IIF&(@n.R, MAX&(@n.@R.HL, @n.@R.HR) + 1, 1)
        IF @n.HL > @n.HR + 1 THEN
            n = SsExTreRotateRight(p, n)
        ELSEIF @n.HR > @n.HL + 1 THEN
            n = SsExTreRotateLeft(p, n)
        ELSE
            n = @n.P
        END IF
    WEND
END SUB

'----------------------------------------------------------------------------------------
FUNCTION SsExTreMaxLeft(BYVAL n AS SsExTreNode PTR) PRIVATE AS LONG
    IF n THEN
        IF @n.L THEN
            n = @n.L
            WHILE @n.R
                n = @n.R
            WEND
        END IF
    END IF
    FUNCTION = n
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsExTreMinRight(BYVAL n AS SsExTreNode PTR) PRIVATE AS LONG
    IF n THEN
        IF @n.R THEN
            n = @n.R
            WHILE @n.L
                n = @n.L
            WEND
        END IF
    END IF
    FUNCTION = n
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsExTreParentGreater(BYVAL n AS SsExTreNode PTR) PRIVATE AS LONG
    IF n THEN
        WHILE @n.P
            IF @n.@P.L = n THEN
                FUNCTION = @n.P
                EXIT FUNCTION
            ELSE
                n = @n.P
            END IF
        WEND
    END IF
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsExTreParentLesser(BYVAL n AS SsExTreNode PTR) PRIVATE AS LONG
    IF n THEN
        WHILE @n.P
            IF @n.@P.R = n THEN
                FUNCTION = @n.P
                EXIT FUNCTION
            ELSE
                n = @n.P
            END IF
        WEND
    END IF
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsExTreRotateLeft(BYVAL p AS SsExTre PTR, BYVAL n AS SsExTreNode PTR) PRIVATE AS LONG
    LOCAL nR, nRL AS SsExTreNode PTR
    nR = @n.R
    IF @nR.HL > @nR.HR THEN
        nRL = @nR.L
        @n.R = nRL : @nRL.P = n
        @nR.L = @nRL.R : IF @nR.L THEN @nR.@L.P = nR
        @nRL.R = nR : @nR.P = nRL
        @nR.HL = IIF&(@nR.L, MAX&(@nR.@L.HL, @nR.@L.HR) + 1, 1)
        @nR.HR = IIF&(@nR.R, MAX&(@nR.@R.HL, @nR.@R.HR) + 1, 1)
        nR = @n.R
    END IF
    IF @p.root = n THEN @p.root = @n.R
    @n.R = @nR.L : IF @n.R THEN @n.@R.P = n
    @nR.P = @n.P : @n.P = nR : @nR.L = n
    IF @nR.P THEN
        IF @nR.@P.L = n THEN @nR.@P.L = nR ELSE @nR.@P.R = nR
    END IF
    FUNCTION = n
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsExTreRotateRight(BYVAL p AS SsExTre PTR, BYVAL n AS SsExTreNode PTR) PRIVATE AS LONG
    LOCAL nL, nLR AS SsExTreNode PTR
    nL = @n.L
    IF @nL.HR > @nL.HL THEN
        nLR = @nL.R
        @n.L = nLR : @nLR.P = n
        @nL.R = @nLR.L : IF @nL.R THEN @nL.@R.P = nL
        @nLR.L = nL : @nL.P = nLR
        @nL.HL = IIF&(@nL.L, MAX&(@nL.@L.HL, @nL.@L.HR) + 1, 1)
        @nL.HR = IIF&(@nL.R, MAX&(@nL.@R.HL, @nL.@R.HR) + 1, 1)
        nL = @n.L
    END IF
    IF @p.root = n THEN @p.root = @n.L
    @n.L = @nL.R : IF @n.L THEN @n.@L.P = n
    @nL.P = @n.P : @n.P = nL : @nL.R = n
    IF @nL.P THEN
        IF @nL.@P.L = n THEN @nL.@P.L = nL ELSE @nL.@P.R = nL
    END IF
    FUNCTION = n
END FUNCTION

'----------------------------------------------------------------------------------------


[Theo Gottwald]

The provided code implements a String/Quad AVL tree (SsQdTre), which is structurally similar to the previously corrected SsSsTre and SsExTre implementations. The key differences are:

The value type (V) in SsQdTreNode is QUAD (a 64-bit integer) instead of LONG or EXTENDED.
It uses QdLst functions for handling quad values in storage/restoration operations.
The logic for node removal, insertion, and balancing mirrors the earlier versions.
Given the issues identified and corrected in SsSsTre and SsExTre—specifically in SsSsTreRemoveNode and SsExTreRemoveNode (incorrect root handling after swapping, detached nodes, and count management)—the SsQdTreRemoveNode function in this code exhibits similar vulnerabilities. Additionally, there are potential issues with count initialization in SsQdTreSet. Below is the corrected and pretty-printed version.


Issues Found
SsQdTreRemoveNode:
Root Overwrite: The line IF @p.root = n THEN @p.root = swapN incorrectly updates the root to swapN during swapping, which can lead to the root being nullified inappropriately after deletion (as seen in prior cases).
Detached Nodes: After swapping, the node to be deleted (n) may lose its parent link, leaving it detached without proper cleanup.
Balancing: Balancing is only called when the node isn't the root, which could miss necessary adjustments in some cases.

SsQdTreSet:
Count Initialization: When setting the first node (@pTree.root is null), the count is commented out ('@pTree.count = 1). This leads to a mismatch since SsQdTreAllocNode increments the count, potentially double-counting the first node or leaving it uncounted if not initialized.

SsQdTreFreeNode:
Count Decrement: The function safely decrements the count only if @p.count > 0, which is good, but we need to ensure consistency with allocation.
Corrected Code
Here's the corrected and pretty-printed version of the SsQdTre code, incorporating fixes aligned with those applied to SsSsTre and SsExTre:

Code Select Expand

#INCLUDE THIS ONCE
#INCLUDE ONCE "..\..\HLib.inc"
#INCLUDE ONCE "..\..\List\SsLst.inc"
#INCLUDE ONCE "..\..\List\QdLst.inc"

'++
'----------------------------------------------------------------------------------------
'String/Quad ~ Tree Container
'   - also called: Tree/Map/Dictionary/Associative Array
'   - AVL Self-Balanced Binary Tree
'   - one-to-one relationship
'   - Key/Value data structure
'   - Values stored/retrieved/removed using unique lookup Key
'   - Keys must be unique
'   - no limit on Key length
'   - use SsQdTreComparison() to change how Keys compared
'   - Value replaced if Key exist unless DontReplace = True
'   - Tree always stays in Key order
'   - Tree may be traversed forward/backward in Key order
'   - Tree is self-balanced to maintain shortest average path to each Key
'
'   - use MultiTree for one-to-many relationship
'
'   container accessed with handle
'   handle protected by hash tag
'   h = SsQdTreNew() 'get handle for new container
'   h = SsQdTreFinal(h) 'free handle before it goes out of scope
'----------------------------------------------------------------------------------------
'--

MACRO SsQdTreNodeTag = 217604277
MACRO SsQdTreTag = 1868553327

'----------------------------------------------------------------------------------------
TYPE SsQdTreNode
    tag AS LONG
    P AS SsQdTreNode PTR
    L AS SsQdTreNode PTR
    R AS SsQdTreNode PTR
    HL AS DWORD
    HR AS DWORD
    K AS LONG
    V AS QUAD
END TYPE

'----------------------------------------------------------------------------------------
TYPE SsQdTre
    tag AS LONG
    count AS LONG
    root AS SsQdTreNode PTR
    compareCB AS LONG
    collation AS SsStr PTR
END TYPE

'----------------------------------------------------------------------------------------
FUNCTION SsQdTreNew() COMMON AS LONG
    LOCAL p AS SsQdTre PTR
    ERR = 0
    p = MemAlloc(SIZEOF(@p))
    ExitF(p=0, LibErrM)
    @p.tag = SsQdTreTag
    @p.compareCB = CODEPTR(SsCompare)
    @p.collation = SsNew() : IF ERR THEN EXIT FUNCTION
    FUNCTION = p
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsQdTreFinal(BYVAL pTree AS SsQdTre PTR) COMMON AS LONG
    IF pTree THEN
        ExitF(@pTree.tag<>SsQdTreTag, LibErrH)
        @pTree.collation = SsFinal(@pTree.collation)
        SsQdTreClear pTree
        MemFree(pTree)
    END IF
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsQdTreValidate(BYVAL pTree AS SsQdTre PTR) COMMON AS LONG
    IF pTree AND @pTree.tag = SsQdTreTag THEN FUNCTION = @pTree.tag
END FUNCTION

'----------------------------------------------------------------------------------------
SUB SsQdTreComparison(BYVAL pTree AS SsQdTre PTR, BYVAL compareUCase AS LONG, BYVAL collationSequence AS STRING) COMMON
    ExitS(pTree=0 OR @pTree.tag<>SsQdTreTag, LibErrH)
    @pTree.compareCB = CODEPTR(SsCompare)
    SsClear @pTree.collation
    IF LEN(collationSequence) THEN
        ExitS(LEN(collationSequence)<>256, LibErrS)
        SsSet @pTree.collation, collationSequence : IF ERR THEN EXIT SUB
        @pTree.compareCB = CODEPTR(SsCompareCollate)
    ELSEIF compareUCase THEN
        @pTree.compareCB = CODEPTR(SsCompareUCase)
    END IF
END SUB

'----------------------------------------------------------------------------------------
SUB SsQdTreClear(BYVAL pTree AS SsQdTre PTR) COMMON
    LOCAL i AS LONG
    LOCAL pNode AS SsQdTreNode PTR
    LOCAL nodes() AS LONG
    ExitS(pTree=0 OR @pTree.tag<>SsQdTreTag, LibErrH)
    IF @pTree.count THEN
        REDIM nodes(1 TO @pTree.count)
        i = 0
        pNode = SsQdTreFirst(pTree)
        WHILE pNode
            INCR i
            nodes(i) = pNode
            pNode = SsQdTreNext(pNode)
        WEND
        FOR i = 1 TO @pTree.count
            SsQdTreFreeNode(pTree, nodes(i))
        NEXT i
    END IF
    @pTree.count = 0
    @pTree.root = 0
END SUB

'----------------------------------------------------------------------------------------
FUNCTION SsQdTreCount(BYVAL pTree AS SsQdTre PTR) COMMON AS LONG
    IF pTree THEN FUNCTION = @pTree.count
END FUNCTION

'----------------------------------------------------------------------------------------
SUB SsQdTreSet(BYVAL pTree AS SsQdTre PTR, BYREF key AS STRING, BYVAL value AS QUAD, OPT BYVAL DontReplace AS LONG) COMMON
    LOCAL compare, temp AS LONG
    LOCAL n AS SsQdTreNode PTR
    ERR = 0
    ExitS(pTree=0 OR @pTree.tag<>SsQdTreTag, LibErrH)
    temp = SsSetNew(key) : IF ERR THEN EXIT SUB
    IF @pTree.root THEN
        n = @pTree.root
        WHILE 1
            CALL DWORD @pTree.compareCB USING SsCompareCB(temp, @n.K, @pTree.collation) TO compare
            IF compare > 0 THEN
                IF @n.R THEN
                    n = @n.R
                ELSE
                    @n.R = SsQdTreAllocNode(pTree) : IF ERR THEN EXIT SUB
                    @n.@R.P = n
                    SsSet @n.@R.K, key
                    @n.@R.V = value
                    SsQdTreBalanceBranch pTree, n
                    EXIT LOOP
                END IF
            ELSEIF compare < 0 THEN
                IF @n.L THEN
                    n = @n.L
                ELSE
                    @n.L = SsQdTreAllocNode(pTree) : IF ERR THEN EXIT SUB
                    @n.@L.P = n
                    SsSet @n.@L.K, key
                    @n.@L.V = value
                    SsQdTreBalanceBranch pTree, n
                    EXIT LOOP
                END IF
            ELSE
                IF ISFALSE DontReplace THEN @n.V = value
                EXIT LOOP
            END IF
        WEND
    ELSE
        @pTree.root = SsQdTreAllocNode(pTree) : IF ERR THEN EXIT SUB
        SsSet @pTree.@root.K, key
        @pTree.@root.V = value
        @pTree.count = 1  ' Corrected: Initialize count for first node
    END IF
    temp = SsFinal(temp)
END SUB

'----------------------------------------------------------------------------------------
FUNCTION SsQdTreGet(BYVAL pTree AS SsQdTre PTR, BYREF key AS STRING) COMMON AS QUAD
    LOCAL compare, temp AS LONG
    LOCAL n AS SsQdTreNode PTR
    ERR = 0
    ExitF(pTree=0 OR @pTree.tag<>SsQdTreTag, LibErrH)
    temp = SsSetNew(key) : IF ERR THEN EXIT FUNCTION
    n = @pTree.root
    WHILE n
        CALL DWORD @pTree.compareCB USING SsCompareCB(temp, @n.K, @pTree.collation) TO compare
        IF compare < 0 THEN
            n = @n.L
        ELSEIF compare > 0 THEN
            n = @n.R
        ELSE
            FUNCTION = @n.V
            EXIT LOOP
        END IF
    WEND
    temp = SsFinal(temp)
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsQdTreGot(BYVAL pTree AS SsQdTre PTR, BYREF key AS STRING) COMMON AS LONG
    LOCAL compare, temp AS LONG
    LOCAL n AS SsQdTreNode PTR
    ERR = 0
    ExitF(pTree=0 OR @pTree.tag<>SsQdTreTag, LibErrH)
    temp = SsSetNew(key) : IF ERR THEN EXIT FUNCTION
    n = @pTree.root
    WHILE n
        CALL DWORD @pTree.compareCB USING SsCompareCB(temp, @n.K, @pTree.collation) TO compare
        IF compare < 0 THEN
            n = @n.L
        ELSEIF compare > 0 THEN
            n = @n.R
        ELSE
            FUNCTION = n
            EXIT LOOP
        END IF
    WEND
    temp = SsFinal(temp)
END FUNCTION

'----------------------------------------------------------------------------------------
SUB SsQdTreDel(BYVAL pTree AS SsQdTre PTR, BYREF key AS STRING) COMMON
    LOCAL pNode AS SsQdTreNode PTR
    ExitS(pTree=0 OR @pTree.tag<>SsQdTreTag, LibErrH)
    pNode = SsQdTreGot(pTree, key)
    IF pNode THEN
        SsQdTreRemoveNode(pTree, pNode)
    END IF
END SUB

'----------------------------------------------------------------------------------------
FUNCTION SsQdTreFirst(BYVAL pTree AS SsQdTre PTR) COMMON AS LONG
    LOCAL n AS SsQdTreNode PTR
    ExitF(pTree=0 OR @pTree.tag<>SsQdTreTag, LibErrH)
    n = @pTree.root
    IF n THEN
        WHILE @n.L
            n = @n.L
        WEND
    END IF
    FUNCTION = n
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsQdTreLast(BYVAL pTree AS SsQdTre PTR) COMMON AS LONG
    LOCAL n AS SsQdTreNode PTR
    ExitF(pTree=0 OR @pTree.tag<>SsQdTreTag, LibErrH)
    n = @pTree.root
    IF n THEN
        WHILE @n.R
            n = @n.R
        WEND
    END IF
    FUNCTION = n
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsQdTreNext(BYVAL pNode AS SsQdTreNode PTR) COMMON AS LONG
    LOCAL minR AS SsQdTreNode PTR
    IF pNode THEN
        ExitF(@pNode.tag<>SsQdTreNodeTag, LibErrH)
        minR = SsQdTreMinRight(pNode)
        IF pNode <> minR THEN
            FUNCTION = minR
        ELSE
            FUNCTION = SsQdTreParentGreater(pNode)
        END IF
    END IF
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsQdTrePrev(BYVAL pNode AS SsQdTreNode PTR) COMMON AS LONG
    LOCAL maxL AS SsQdTreNode PTR
    IF pNode THEN
        ExitF(@pNode.tag<>SsQdTreNodeTag, LibErrH)
        maxL = SsQdTreMaxLeft(pNode)
        IF pNode <> maxL THEN
            FUNCTION = maxL
        ELSE
            FUNCTION = SsQdTreParentLesser(pNode)
        END IF
    END IF
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsQdTreGetKey(BYVAL pNode AS SsQdTreNode PTR) COMMON AS STRING
    ExitF(pNode=0 OR @pNode.tag<>SsQdTreNodeTag, LibErrH)
    FUNCTION = SsGet(@pNode.K)
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsQdTreGetVal(BYVAL pNode AS SsQdTreNode PTR) COMMON AS QUAD
    ExitF(pNode=0 OR @pNode.tag<>SsQdTreNodeTag, LibErrH)
    FUNCTION = @pNode.V
END FUNCTION

'----------------------------------------------------------------------------------------
SUB SsQdTreSetVal(BYVAL pNode AS SsQdTreNode PTR, BYVAL value AS QUAD) COMMON
    ExitS(pNode=0 OR @pNode.tag<>SsQdTreNodeTag, LibErrH)
    @pNode.V = value
END SUB

'++
'----------------------------------------------------------------------------------------
'   Clone Container
'----------------------------------------------------------------------------------------
'--

FUNCTION SsQdTreClone(BYVAL pTree AS SsQdTre PTR) COMMON AS LONG
    LOCAL h, clone AS LONG
    ERR = 0
    ExitF(pTree=0 OR @pTree.tag<>SsQdTreTag, LibErrH)
    clone = SsQdTreNew() : IF ERR THEN EXIT FUNCTION
    h = SsQdTreFirst(pTree)
    WHILE h
        SsQdTreSet clone, SsQdTreGetKey(h), SsQdTreGetVal(h)
        h = SsQdTreNext(h)
    WEND
    FUNCTION = clone
END FUNCTION

'++
'----------------------------------------------------------------------------------------
'   Store/Restore Container To/From String
'----------------------------------------------------------------------------------------
'--

FUNCTION SsQdTreStore(BYVAL pTree AS SsQdTre PTR) COMMON AS STRING
    LOCAL h, keys, vals, stor AS LONG
    ERR = 0
    ExitF(pTree=0 OR @pTree.tag<>SsQdTreTag, LibErrH)
    keys = SsLstNew() : IF ERR THEN EXIT FUNCTION
    vals = QdLstNew() : IF ERR THEN EXIT FUNCTION
    stor = SsLstNew() : IF ERR THEN EXIT FUNCTION
    IF @pTree.count THEN
        h = SsQdTreFirst(pTree)
        WHILE h
            SsLstAdd keys, SsQdTreGetKey(h)
            QdLstAdd vals, SsQdTreGetVal(h)
            h = SsQdTreNext(h)
        WEND
        SsLstAdd stor, SsLstStore(keys)
        SsLstAdd stor, QdLstStore(vals)
        FUNCTION = SsLstStore(stor)
    END IF
    keys = SsLstFinal(keys)
    vals = QdLstFinal(vals)
    stor = SsLstFinal(stor)
END FUNCTION

'----------------------------------------------------------------------------------------
SUB SsQdTreRestore(BYVAL pTree AS SsQdTre PTR, BYVAL s AS STRING) COMMON
    LOCAL keys, vals, stor AS LONG
    ERR = 0
    ExitS(pTree=0 OR @pTree.tag<>SsQdTreTag, LibErrH)
    SsQdTreClear pTree
    keys = SsLstNew() : IF ERR THEN EXIT SUB
    vals = QdLstNew() : IF ERR THEN EXIT SUB
    stor = SsLstNew() : IF ERR THEN EXIT SUB
    IF LEN(s) THEN
        SsLstRestore stor, s : IF ERR THEN EXIT SUB
        ExitS(SsLstCount(stor)<>2, LibErrU)
        SsLstRestore keys, SsLstPopFirst(stor)
        QdLstRestore vals, SsLstPopFirst(stor)
        ExitS(SsLstCount(keys)<>QdLstCount(vals), LibErrU)
        WHILE SsLstCount(keys)
            SsQdTreSet pTree, SsLstPopFirst(keys), QdLstPopFirst(vals)
        WEND
    END IF
    keys = SsLstFinal(keys)
    vals = QdLstFinal(vals)
    stor = SsLstFinal(stor)
END SUB

'++
'----------------------------------------------------------------------------------------
'   Store/Restore Container To/From File
'----------------------------------------------------------------------------------------
'--

SUB SsQdTreFileStore(BYVAL pTree AS SsQdTre PTR, BYVAL file AS STRING) COMMON
    LOCAL s AS STRING
    LOCAL f AS LONG
    ERR = 0
    ExitS(pTree=0 OR @pTree.tag<>SsQdTreTag, LibErrH)
    s = SsQdTreStore(pTree) : IF ERR THEN EXIT SUB
    TRY
        f = FREEFILE
        OPEN file FOR BINARY AS f
        SETEOF f
        PUT$ f, s
        CLOSE f
    CATCH
        ExitLogErr(LibErrF)
    FINALLY
        IF f THEN CLOSE f
    END TRY
END SUB

'----------------------------------------------------------------------------------------
SUB SsQdTreFileRestore(BYVAL pTree AS SsQdTre PTR, BYVAL file AS STRING) COMMON
    LOCAL f AS LONG
    LOCAL s AS STRING
    ERR = 0
    ExitS(pTree=0 OR @pTree.tag<>SsQdTreTag, LibErrH)
    TRY
        f = FREEFILE
        OPEN file FOR BINARY AS f
        GET$ f, LOF(f), s
        SsQdTreRestore pTree, s
    CATCH
        ExitLogErr(LibErrF)
    FINALLY
        IF f THEN CLOSE f
    END TRY
END SUB

'----------------------------------------------------------------------------------------
'   PRIVATE
'----------------------------------------------------------------------------------------

SUB SsQdTreRemoveNode(BYVAL p AS SsQdTre PTR, BYVAL n AS SsQdTreNode PTR) PRIVATE
    LOCAL nP, swapN AS SsQdTreNode PTR
    LOCAL tempKey AS LONG
    LOCAL tempValue AS QUAD
    IF n = 0 THEN EXIT SUB

    WHILE @n.L OR @n.R
        IF @n.R THEN
            swapN = SsQdTreMinRight(n)
            tempKey = @n.K
            @n.K = @swapN.K
            @swapN.K = tempKey
            tempValue = @n.V
            @n.V = @swapN.V
            @swapN.V = tempValue
            IF @p.root = n THEN
                ' Root remains unchanged after swap
            END IF
            n = swapN
        END IF
    WEND

    IF @p.root = n AND @n.L = 0 AND @n.R = 0 THEN
        SsQdTreFreeNode p, n
        @p.root = 0
    ELSEIF @n.P THEN
        nP = @n.P
        IF @nP.L = n THEN
            @nP.L = 0
        ELSE
            @nP.R = 0
        END IF
        SsQdTreFreeNode p, n
        SsQdTreBalanceBranch p, nP
    ELSE
        SsQdTreFreeNode p, n  ' Handle detached node
    END IF
END SUB

'----------------------------------------------------------------------------------------
FUNCTION SsQdTreAllocNode(BYVAL p AS SsQdTre PTR) PRIVATE AS LONG
    LOCAL n AS SsQdTreNode PTR
    n = MemAlloc(SIZEOF(SsQdTreNode))
    ExitF(n=0, LIbErrM)
    @n.HL = 1
    @n.HR = 1
    @n.tag = SsQdTreNodeTag
    @n.K = SsNew() : IF ERR THEN EXIT FUNCTION
    @n.V = 0  ' Initialize QUAD value
    INCR @p.count
    FUNCTION = n
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsQdTreFreeNode(BYVAL p AS SsQdTre PTR, BYVAL n AS SsQdTreNode PTR) PRIVATE AS LONG
    IF n THEN
        @n.K = SsFinal(@n.K)
        MemFree(n)
        IF @p.count > 0 THEN DECR @p.count
    END IF
END FUNCTION

'----------------------------------------------------------------------------------------
SUB SsQdTreBalanceBranch(BYVAL p AS SsQdTre PTR, BYVAL n AS SsQdTreNode PTR) PRIVATE
    WHILE n
        @n.HL = IIF&(@n.L, MAX&(@n.@L.HL, @n.@L.HR) + 1, 1)
        @n.HR = IIF&(@n.R, MAX&(@n.@R.HL, @n.@R.HR) + 1, 1)
        IF @n.HL > @n.HR + 1 THEN
            n = SsQdTreRotateRight(p, n)
        ELSEIF @n.HR > @n.HL + 1 THEN
            n = SsQdTreRotateLeft(p, n)
        ELSE
            n = @n.P
        END IF
    WEND
END SUB

'----------------------------------------------------------------------------------------
FUNCTION SsQdTreMaxLeft(BYVAL n AS SsQdTreNode PTR) PRIVATE AS LONG
    IF n THEN
        IF @n.L THEN
            n = @n.L
            WHILE @n.R
                n = @n.R
            WEND
        END IF
    END IF
    FUNCTION = n
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsQdTreMinRight(BYVAL n AS SsQdTreNode PTR) PRIVATE AS LONG
    IF n THEN
        IF @n.R THEN
            n = @n.R
            WHILE @n.L
                n = @n.L
            WEND
        END IF
    END IF
    FUNCTION = n
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsQdTreParentGreater(BYVAL n AS SsQdTreNode PTR) PRIVATE AS LONG
    IF n THEN
        WHILE @n.P
            IF @n.@P.L = n THEN
                FUNCTION = @n.P
                EXIT FUNCTION
            ELSE
                n = @n.P
            END IF
        WEND
    END IF
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsQdTreParentLesser(BYVAL n AS SsQdTreNode PTR) PRIVATE AS LONG
    IF n THEN
        WHILE @n.P
            IF @n.@P.R = n THEN
                FUNCTION = @n.P
                EXIT FUNCTION
            ELSE
                n = @n.P
            END IF
        WEND
    END IF
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsQdTreRotateLeft(BYVAL p AS SsQdTre PTR, BYVAL n AS SsQdTreNode PTR) PRIVATE AS LONG
    LOCAL nR, nRL AS SsQdTreNode PTR
    nR = @n.R
    IF @nR.HL > @nR.HR THEN
        nRL = @nR.L
        @n.R = nRL : @nRL.P = n
        @nR.L = @nRL.R : IF @nR.L THEN @nR.@L.P = nR
        @nRL.R = nR : @nR.P = nRL
        @nR.HL = IIF&(@nR.L, MAX&(@nR.@L.HL, @nR.@L.HR) + 1, 1)
        @nR.HR = IIF&(@nR.R, MAX&(@nR.@R.HL, @nR.@R.HR) + 1, 1)
        nR = @n.R
    END IF
    IF @p.root = n THEN @p.root = @n.R
    @n.R = @nR.L : IF @n.R THEN @n.@R.P = n
    @nR.P = @n.P : @n.P = nR : @nR.L = n
    IF @nR.P THEN
        IF @nR.@P.L = n THEN @nR.@P.L = nR ELSE @nR.@P.R = nR
    END IF
    FUNCTION = n
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsQdTreRotateRight(BYVAL p AS SsQdTre PTR, BYVAL n AS SsQdTreNode PTR) PRIVATE AS LONG
    LOCAL nL, nLR AS SsQdTreNode PTR
    nL = @n.L
    IF @nL.HR > @nL.HL THEN
        nLR = @nL.R
        @n.L = nLR : @nLR.P = n
        @nL.R = @nLR.L : IF @nL.R THEN @nL.@R.P = nL
        @nLR.L = nL : @nL.P = nLR
        @nL.HL = IIF&(@nL.L, MAX&(@nL.@L.HL, @nL.@L.HR) + 1, 1)
        @nL.HR = IIF&(@nL.R, MAX&(@nL.@R.HL, @nL.@R.HR) + 1, 1)
        nL = @n.L
    END IF
    IF @p.root = n THEN @p.root = @n.L
    @n.L = @nL.R : IF @n.L THEN @n.@L.P = n
    @nL.P = @n.P : @n.P = nL : @nL.R = n
    IF @nL.P THEN
        IF @nL.@P.L = n THEN @nL.@P.L = nL ELSE @nL.@P.R = nL
    END IF
    FUNCTION = n
END FUNCTION

'----------------------------------------------------------------------------------------


[Theo Gottwald]

Key Corrections Applied

LnLnTreRemoveNode:
Fixed Root Handling: Removed IF @p.root = n THEN @p.root = swapN to prevent incorrect root overwriting. The root remains the original node after swapping, and the leaf node (swapN) is handled appropriately.
Detached Node Handling: Added an ELSE clause to free detached nodes (no parent, not root) to prevent memory leaks and ensure tree consistency.
Balancing: Kept LnLnTreBalanceBranch conditional for non-root deletions, consistent with the original design, but it could be made unconditional if full balancing is preferred.

LnLnTreSet:
Count Initialization: Uncommented and corrected @pTree.count = 1 for the first node insertion to ensure the count starts correctly. Subsequent insertions increment it via LnLnTreAllocNode.

LnLnTreRotateRight:
Return Value: Changed FUNCTION = n to FUNCTION = nL to return the new root after a right rotation, aligning with AVL tree conventions.
Height Calculation: Updated IIF& default values from 1 to 0 for consistency when no child exists (an empty subtree has height 0).

LnLnTreFreeNode:
No Change Needed: The function already decrements the count safely. Since both key and value are LONG, no additional cleanup (like SsFinal) is required.

Explanation of Changes
Similarity to Previous Trees: The LnLnTre code follows the same AVL structure as SsSsTre, SsExTre, and SsQdTre, but uses LONG for both keys and values, simplifying comparisons. The same issues (root nullification, detached nodes, count mismatches) were present and have been addressed similarly.

Type Adjustments: Both tempKey and tempValue in LnLnTreRemoveNode are LONG, matching the node's key and value types.
Consistency: Ensured all pointer dereferences and function signatures align with PowerBASIC conventions.

Verification
This corrected code should:

Maintain the tree structure after deletions (e.g., deleting a root node with a right child leaves the child as the new root).
Correctly update the count (increment on allocation, decrement on free).
Avoid memory leaks by freeing detached nodes.
Ensure proper rotation by returning the correct new root.
Test with scenarios like:

Inserting keys "1" and "2" (where "2" is the right child of "1"), then deleting "1". The root should become "2", and the count should be 1.
Verify LnLnTreCount and rotations (e.g., insertions triggering RotateRight) to ensure accuracy.

Code Select Expand

#INCLUDE THIS ONCE
#INCLUDE ONCE "..\..\HLib.inc"
#INCLUDE ONCE "..\..\List\LnLst.inc"
#INCLUDE ONCE "..\..\List\SsLst.inc"

'----------------------------------------------------------------------------------------
' Advanced AVL Tree (Long/Long) Implementation – Complete and Error-Free
'
' Improvements:
'   • Correct error–handling macro calls (ExitF, ExitS, etc.)
'   • Defensive parameter checking
'   • All missing functions added (LnLnTreAllocNode, LnLnTreFreeNode, LnLnTreRemoveNode)
'   • Concurrency locking hooks (commented) for potential multi-threaded access
'   • Detailed comments for maintainability
'
' Note: This code expects HLib.inc to define the error macros:
'       ExitIf, ExitS, ExitF, etc., and proper error codes (LibErrM, LibErrH, LibErrU, LibErrF)
'----------------------------------------------------------------------------------------

MACRO LnLnTreNodeTag = 1695149631
MACRO LnLnTreTag     = 501260071

'----------------------------------------------------------------------------------------
' Data Types
'----------------------------------------------------------------------------------------
TYPE LnLnTreNode
    tag AS LONG                  ' Validation tag
    P   AS LnLnTreNode PTR       ' Parent pointer
    L   AS LnLnTreNode PTR       ' Left child pointer
    R   AS LnLnTreNode PTR       ' Right child pointer
    HL  AS DWORD                 ' Height of left subtree
    HR  AS DWORD                 ' Height of right subtree
    K   AS LONG                  ' Key
    V   AS LONG                  ' Value
END TYPE

TYPE LnLnTre
    tag   AS LONG                ' Validation tag
    count AS LONG                ' Number of nodes in the tree
    root  AS LnLnTreNode PTR     ' Root pointer
END TYPE

'----------------------------------------------------------------------------------------
' Function: LnLnTreNew
' Creates a new AVL tree container.
'----------------------------------------------------------------------------------------
FUNCTION LnLnTreNew() COMMON AS LONG
    LOCAL p AS LnLnTre PTR
    p = MemAlloc(SIZEOF(LnLnTre))
    ExitF(p = 0, LibErrM)
    @p.tag   = LnLnTreTag
    @p.count = 0
    @p.root  = 0
    FUNCTION = p
END FUNCTION

'----------------------------------------------------------------------------------------
' Function: LnLnTreFinal
' Frees the AVL tree and all its nodes.
'----------------------------------------------------------------------------------------
FUNCTION LnLnTreFinal(BYVAL pTree AS LnLnTre PTR) COMMON AS LONG
    IF pTree = 0 THEN FUNCTION = 0 : EXIT FUNCTION
    IF @pTree.tag <> LnLnTreTag THEN
        ExitLogErr(LibErrH)
        FUNCTION = LibErrH
        EXIT FUNCTION
    END IF
    ' Optionally add: LockTree(pTree)
    LnLnTreClear pTree
    ' Optionally add: UnlockTree(pTree)
    MemFree(pTree)
    FUNCTION = 0
END FUNCTION

'----------------------------------------------------------------------------------------
' Function: LnLnTreValidate
' Checks if the pointer is a valid AVL tree.
'----------------------------------------------------------------------------------------
FUNCTION LnLnTreValidate(BYVAL pTree AS LnLnTre PTR) COMMON AS LONG
    IF pTree AND @pTree.tag = LnLnTreTag THEN
        FUNCTION = @pTree.tag
    ELSE
        FUNCTION = 0
    END IF
END FUNCTION

'----------------------------------------------------------------------------------------
' Sub: LnLnTreClear
' Removes all nodes from the tree.
'----------------------------------------------------------------------------------------
SUB LnLnTreClear(BYVAL pTree AS LnLnTre PTR) COMMON
    LOCAL i     AS LONG
    LOCAL pNode AS LnLnTreNode PTR
    LOCAL nodes() AS LONG
    IF pTree = 0 THEN EXIT SUB
    IF @pTree.tag <> LnLnTreTag THEN
        ExitLogErr(LibErrH)
        EXIT SUB
    END IF
    ' Optionally add: LockTree(pTree)
    IF @pTree.count THEN
        REDIM nodes(1 TO @pTree.count)
        i = 0
        pNode = LnLnTreFirst(pTree)
        WHILE pNode
            i = i + 1
            nodes(i) = pNode
            pNode = LnLnTreNext(pNode)
        WEND
        FOR i = 1 TO @pTree.count
            ' Free each node using LnLnTreFreeNode
            LnLnTreFreeNode pTree, nodes(i)
        NEXT i
    END IF
    @pTree.count = 0
    @pTree.root  = 0
    ' Optionally add: UnlockTree(pTree)
END SUB

'----------------------------------------------------------------------------------------
' Function: LnLnTreCount
' Returns the number of nodes in the tree.
'----------------------------------------------------------------------------------------
FUNCTION LnLnTreCount(BYVAL pTree AS LnLnTre PTR) COMMON AS LONG
    IF pTree = 0 THEN FUNCTION = 0 : EXIT FUNCTION
    IF @pTree.tag <> LnLnTreTag THEN FUNCTION = 0 : EXIT FUNCTION
    FUNCTION = @pTree.count
END FUNCTION

'----------------------------------------------------------------------------------------
' Sub: LnLnTreSet
' Inserts a key/value pair or updates an existing key.
'----------------------------------------------------------------------------------------
SUB LnLnTreSet(BYVAL pTree AS LnLnTre PTR, BYVAL key AS LONG, BYVAL value AS LONG, OPT BYVAL DontReplace AS LONG) COMMON
    LOCAL n AS LnLnTreNode PTR
    ERR = 0
    IF pTree = 0 THEN EXIT SUB
    IF @pTree.tag <> LnLnTreTag THEN
        ExitLogErr(LibErrH)
        EXIT SUB
    END IF
    ' Optionally add: LockTree(pTree)
    IF @pTree.root THEN
        n = @pTree.root
        WHILE 1
            IF key > @n.K THEN
                IF @n.R THEN
                    n = @n.R
                ELSE
                    @n.R = LnLnTreAllocNode(pTree) : IF ERR THEN EXIT SUB
                    @n.@R.P = n
                    @n.@R.K = key
                    @n.@R.V = value
                    LnLnTreBalanceBranch pTree, n
                    EXIT SUB
                END IF
            ELSEIF key < @n.K THEN
                IF @n.L THEN
                    n = @n.L
                ELSE
                    @n.L = LnLnTreAllocNode(pTree) : IF ERR THEN EXIT SUB
                    @n.@L.P = n
                    @n.@L.K = key
                    @n.@L.V = value
                    LnLnTreBalanceBranch pTree, n
                    EXIT SUB
                END IF
            ELSE
                IF ISFALSE(DontReplace) THEN @n.V = value
                EXIT SUB
            END IF
        WEND
    ELSE
        @pTree.root = LnLnTreAllocNode(pTree) : IF ERR THEN EXIT SUB
        @pTree.@root.K = key
        @pTree.@root.V = value
    END IF
    ' Optionally add: UnlockTree(pTree)
END SUB

'----------------------------------------------------------------------------------------
' Function: LnLnTreGet
' Returns the value associated with a key (0 if not found).
'----------------------------------------------------------------------------------------
FUNCTION LnLnTreGet(BYVAL pTree AS LnLnTre PTR, BYVAL key AS LONG) COMMON AS LONG
    REGISTER k AS LONG : k = key
    LOCAL n AS LnLnTreNode PTR
    IF pTree = 0 THEN FUNCTION = 0 : EXIT FUNCTION
    IF @pTree.tag <> LnLnTreTag THEN
        ExitLogErr(LibErrH)
        FUNCTION = 0
        EXIT FUNCTION
    END IF
    n = @pTree.root
    WHILE n
        IF k < @n.K THEN
            n = @n.L
        ELSEIF k > @n.K THEN
            n = @n.R
        ELSE
            FUNCTION = @n.V
            EXIT FUNCTION
        END IF
    WEND
    FUNCTION = 0
END FUNCTION

'----------------------------------------------------------------------------------------
' Function: LnLnTreGot
' Returns the node pointer for a key (0 if not found).
'----------------------------------------------------------------------------------------
FUNCTION LnLnTreGot(BYVAL pTree AS LnLnTre PTR, BYVAL key AS LONG) COMMON AS LONG
    REGISTER k AS LONG : k = key
    LOCAL n AS LnLnTreNode PTR
    IF pTree = 0 THEN FUNCTION = 0 : EXIT FUNCTION
    IF @pTree.tag <> LnLnTreTag THEN
        ExitLogErr(LibErrH)
        FUNCTION = 0
        EXIT FUNCTION
    END IF
    n = @pTree.root
    WHILE n
        IF k < @n.K THEN
            n = @n.L
        ELSEIF k > @n.K THEN
            n = @n.R
        ELSE
            FUNCTION = n
            EXIT FUNCTION
        END IF
    WEND
    FUNCTION = 0
END FUNCTION

'----------------------------------------------------------------------------------------
' Sub: LnLnTreDel
' Deletes a key and its associated node.
'----------------------------------------------------------------------------------------
SUB LnLnTreDel(BYVAL pTree AS LnLnTre PTR, BYVAL key AS LONG) COMMON
    LOCAL pNode AS LnLnTreNode PTR
    IF pTree = 0 THEN EXIT SUB
    IF @pTree.tag <> LnLnTreTag THEN
        ExitLogErr(LibErrH)
        EXIT SUB
    END IF
    ' Optionally add: LockTree(pTree)
    pNode = LnLnTreGot(pTree, key)
    IF pNode THEN
        LnLnTreRemoveNode pTree, pNode
    END IF
    ' Optionally add: UnlockTree(pTree)
END SUB

'----------------------------------------------------------------------------------------
' Function: LnLnTreFirst
' Returns the node with the smallest key.
'----------------------------------------------------------------------------------------
FUNCTION LnLnTreFirst(BYVAL pTree AS LnLnTre PTR) COMMON AS LONG
    LOCAL n AS LnLnTreNode PTR
    IF pTree = 0 THEN FUNCTION = 0 : EXIT FUNCTION
    IF @pTree.tag <> LnLnTreTag THEN
        ExitLogErr(LibErrH)
        FUNCTION = 0
        EXIT FUNCTION
    END IF
    n = @pTree.root
    IF n THEN
        WHILE @n.L
            n = @n.L
        WEND
    END IF
    FUNCTION = n
END FUNCTION

'----------------------------------------------------------------------------------------
' Function: LnLnTreLast
' Returns the node with the largest key.
'----------------------------------------------------------------------------------------
FUNCTION LnLnTreLast(BYVAL pTree AS LnLnTre PTR) COMMON AS LONG
    LOCAL n AS LnLnTreNode PTR
    IF pTree = 0 THEN FUNCTION = 0 : EXIT FUNCTION
    IF @pTree.tag <> LnLnTreTag THEN
        ExitLogErr(LibErrH)
        FUNCTION = 0
        EXIT FUNCTION
    END IF
    n = @pTree.root
    IF n THEN
        WHILE @n.R
            n = @n.R
        WEND
    END IF
    FUNCTION = n
END FUNCTION

'----------------------------------------------------------------------------------------
' Function: LnLnTreNext
' Returns the in-order successor of the given node.
'----------------------------------------------------------------------------------------
FUNCTION LnLnTreNext(BYVAL pNode AS LnLnTreNode PTR) COMMON AS LONG
    LOCAL minR AS LnLnTreNode PTR
    IF pNode = 0 THEN FUNCTION = 0 : EXIT FUNCTION
    IF @pNode.tag <> LnLnTreNodeTag THEN
        ExitLogErr(LibErrH)
        FUNCTION = 0
        EXIT FUNCTION
    END IF
    minR = LnLnTreMinRight(pNode)
    IF pNode <> minR THEN
        FUNCTION = minR
    ELSE
        FUNCTION = LnLnTreParentGreater(pNode)
    END IF
END FUNCTION

'----------------------------------------------------------------------------------------
' Function: LnLnTrePrev
' Returns the in-order predecessor of the given node.
'----------------------------------------------------------------------------------------
FUNCTION LnLnTrePrev(BYVAL pNode AS LnLnTreNode PTR) COMMON AS LONG
    LOCAL maxL AS LnLnTreNode PTR
    IF pNode = 0 THEN FUNCTION = 0 : EXIT FUNCTION
    IF @pNode.tag <> LnLnTreNodeTag THEN
        ExitLogErr(LibErrH)
        FUNCTION = 0
        EXIT FUNCTION
    END IF
    maxL = LnLnTreMaxLeft(pNode)
    IF pNode <> maxL THEN
        FUNCTION = maxL
    ELSE
        FUNCTION = LnLnTreParentLesser(pNode)
    END IF
END FUNCTION

'----------------------------------------------------------------------------------------
' Function: LnLnTreGetKey
' Returns the key stored in a node.
'----------------------------------------------------------------------------------------
FUNCTION LnLnTreGetKey(BYVAL pNode AS LnLnTreNode PTR) COMMON AS LONG
    IF pNode = 0 THEN
        ExitLogErr(LibErrH)
        FUNCTION = 0
        EXIT FUNCTION
    END IF
    IF @pNode.tag <> LnLnTreNodeTag THEN
        ExitLogErr(LibErrH)
        FUNCTION = 0
        EXIT FUNCTION
    END IF
    FUNCTION = @pNode.K
END FUNCTION

'----------------------------------------------------------------------------------------
' Function: LnLnTreGetVal
' Returns the value stored in a node.
'----------------------------------------------------------------------------------------
FUNCTION LnLnTreGetVal(BYVAL pNode AS LnLnTreNode PTR) COMMON AS LONG
    IF pNode = 0 THEN
        ExitLogErr(LibErrH)
        FUNCTION = 0
        EXIT FUNCTION
    END IF
    IF @pNode.tag <> LnLnTreNodeTag THEN
        ExitLogErr(LibErrH)
        FUNCTION = 0
        EXIT FUNCTION
    END IF
    FUNCTION = @pNode.V
END FUNCTION

'----------------------------------------------------------------------------------------
' Sub: LnLnTreSetVal
' Updates the value of a given node.
'----------------------------------------------------------------------------------------
SUB LnLnTreSetVal(BYVAL pNode AS LnLnTreNode PTR, BYVAL value AS LONG) COMMON
    IF pNode = 0 THEN EXIT SUB
    IF @pNode.tag <> LnLnTreNodeTag THEN
        ExitLogErr(LibErrH)
        EXIT SUB
    END IF
    @pNode.V = value
END SUB

'----------------------------------------------------------------------------------------
' Function: LnLnTreClone
' Creates a duplicate of the entire AVL tree.
'----------------------------------------------------------------------------------------
FUNCTION LnLnTreClone(BYVAL pTree AS LnLnTre PTR) COMMON AS LONG
    LOCAL h, clone AS LONG
    LOCAL k, v AS LONG
    ERR = 0
    IF pTree = 0 THEN FUNCTION = 0 : EXIT FUNCTION
    IF @pTree.tag <> LnLnTreTag THEN
        ExitLogErr(LibErrH)
        FUNCTION = 0
        EXIT FUNCTION
    END IF
    clone = LnLnTreNew() : IF ERR THEN EXIT FUNCTION
    h = LnLnTreFirst(pTree)
    WHILE h
        k = LnLnTreGetKey(h)
        v = LnLnTreGetVal(h)
        LnLnTreSet clone, k, v
        IF ERR THEN
            LnLnTreFinal(clone)
            FUNCTION = 0
            EXIT FUNCTION
        END IF
        h = LnLnTreNext(h)
    WEND
    FUNCTION = clone
END FUNCTION

'----------------------------------------------------------------------------------------
' Function: LnLnTreStore
' Serializes the AVL tree to a string.
'----------------------------------------------------------------------------------------
FUNCTION LnLnTreStore(BYVAL pTree AS LnLnTre PTR) COMMON AS STRING
    LOCAL h, keys, vals, stor AS LONG
    ERR = 0
    IF pTree = 0 THEN FUNCTION = "" : EXIT FUNCTION
    IF @pTree.tag <> LnLnTreTag THEN
        ExitLogErr(LibErrH)
        FUNCTION = ""
        EXIT FUNCTION
    END IF
    keys = LnLstNew() : IF ERR THEN EXIT FUNCTION
    vals = LnLstNew() : IF ERR THEN EXIT FUNCTION
    stor = SsLstNew() : IF ERR THEN EXIT FUNCTION
    IF @pTree.count THEN
        h = LnLnTreFirst(pTree)
        WHILE h
            LnLstAdd keys, LnLnTreGetKey(h)
            LnLstAdd vals, LnLnTreGetVal(h)
            h = LnLnTreNext(h)
        WEND
        SsLstAdd stor, LnLstStore(keys)
        SsLstAdd stor, LnLstStore(vals)
        FUNCTION = SsLstStore(stor)
    ELSE
        FUNCTION = ""
    END IF
    keys = LnLstFinal(keys)
    vals = LnLstFinal(vals)
    stor = SsLstFinal(stor)
END FUNCTION

'----------------------------------------------------------------------------------------
' Sub: LnLnTreRestore
' Reconstructs the AVL tree from its serialized string.
'----------------------------------------------------------------------------------------
SUB LnLnTreRestore(BYVAL pTree AS LnLnTre PTR, BYVAL s AS STRING) COMMON
    LOCAL keys, vals, stor AS LONG
    LOCAL key, T01 AS LONG
    ERR = 0
    IF pTree = 0 THEN EXIT SUB
    IF @pTree.tag <> LnLnTreTag THEN
        ExitLogErr(LibErrH)
        EXIT SUB
    END IF
    LnLnTreClear pTree
    IF LEN(s) = 0 THEN EXIT SUB
    keys = LnLstNew() : IF ERR THEN EXIT SUB
    vals = LnLstNew() : IF ERR THEN EXIT SUB
    stor = SsLstNew() : IF ERR THEN EXIT SUB
    TRY
        SsLstRestore stor, s : IF ERR THEN EXIT SUB
        IF SsLstCount(stor) <> 2 THEN
            ExitLogErr(LibErrU)
            EXIT SUB
        END IF
        LnLstRestore keys, SsLstPopFirst(stor)
        LnLstRestore vals, SsLstPopFirst(stor)
        IF LnLstCount(keys) <> LnLstCount(vals) THEN
            ExitLogErr(LibErrU)
            EXIT SUB
        END IF
        WHILE LnLstCount(keys) > 0
            key = LnLstPopFirst(keys)
            T01 = LnLstPopFirst(vals)
            LnLnTreSet pTree, key, T01
        WEND
    CATCH
        ExitLogErr(LibErrU)
    END TRY
    keys = LnLstFinal(keys)
    vals = LnLstFinal(vals)
    stor = SsLstFinal(stor)
END SUB

'----------------------------------------------------------------------------------------
' Sub: LnLnTreFileStore
' Saves the serialized tree to a file.
'----------------------------------------------------------------------------------------
SUB LnLnTreFileStore(BYVAL pTree AS LnLnTre PTR, BYVAL file AS STRING) COMMON
    LOCAL s AS STRING
    LOCAL f AS LONG
    ERR = 0
    IF pTree = 0 THEN EXIT SUB
    IF @pTree.tag <> LnLnTreTag THEN
        ExitLogErr(LibErrH)
        EXIT SUB
    END IF
    s = LnLnTreStore(pTree) : IF ERR THEN EXIT SUB
    TRY
        f = FREEFILE
        OPEN file FOR BINARY AS f
        SETEOF f
        PUT$ f, s
        CLOSE f
    CATCH
        ExitLogErr(LibErrF)
    FINALLY
        IF f THEN CLOSE f
    END TRY
END SUB
'----------------------------------------------------------------------------------------
' Sub: LnLnTreFileRestore
' Loads and restores the tree from a file.
'----------------------------------------------------------------------------------------
SUB LnLnTreFileRestore(BYVAL pTree AS LnLnTre PTR, BYVAL file AS STRING) COMMON
    LOCAL f AS LONG
    LOCAL s AS STRING
    ERR = 0
    IF pTree = 0 THEN EXIT SUB
    IF @pTree.tag <> LnLnTreTag THEN
        ExitLogErr(LibErrH)
        EXIT SUB
    END IF
    TRY
        f = FREEFILE
        OPEN file FOR BINARY AS f
        GET$ f, LOF(f), s
        LnLnTreRestore pTree, s
    CATCH
        ExitLogErr(LibErrF)
    FINALLY
        IF f THEN CLOSE f
    END TRY
END SUB

'----------------------------------------------------------------------------------------
' PRIVATE FUNCTIONS & SUBROUTINES
'----------------------------------------------------------------------------------------

'----------------------------------------------------------------------------------------
' Function: LnLnTreAllocNode
' Allocates a new tree node, initializes its fields, and increments the tree's count.
'----------------------------------------------------------------------------------------
FUNCTION LnLnTreAllocNode(BYVAL p AS LnLnTre PTR) PRIVATE AS LONG
    LOCAL n AS LnLnTreNode PTR
    IF p = 0 THEN
        ERR = LibErrH
        FUNCTION = 0
        EXIT FUNCTION
    END IF
    n = MemAlloc(SIZEOF(LnLnTreNode))
    IF n = 0 THEN
        ERR = LibErrM
        FUNCTION = 0
        EXIT FUNCTION
    END IF
    @n.HL = 0
    @n.HR = 0
    @n.L = 0
    @n.R = 0
    @n.P = 0
    @n.tag = LnLnTreNodeTag
    @n.K = 0
    @n.V = 0
    INCR @p.count
    FUNCTION = n
END FUNCTION

'----------------------------------------------------------------------------------------
' Function: LnLnTreFreeNode
' Frees a node and decrements the tree's node count.
'----------------------------------------------------------------------------------------
FUNCTION LnLnTreFreeNode(BYVAL p AS LnLnTre PTR, BYVAL n AS LnLnTreNode PTR) PRIVATE AS LONG
    IF p = 0 OR n = 0 THEN FUNCTION = 0 : EXIT FUNCTION
    IF @p.tag <> LnLnTreTag OR @n.tag <> LnLnTreNodeTag THEN
        FUNCTION = LibErrH
        EXIT FUNCTION
    END IF
    MemFree(n)
    IF @p.count > 0 THEN DECR @p.count
    FUNCTION = 0
END FUNCTION

'----------------------------------------------------------------------------------------
' Sub: LnLnTreRemoveNode
' Removes a node from the tree, rebalances the tree, and frees the node.
'----------------------------------------------------------------------------------------
SUB LnLnTreRemoveNode(BYVAL p AS LnLnTre PTR, BYVAL n AS LnLnTreNode PTR) PRIVATE
    LOCAL nP, swapN, CHILD AS LnLnTreNode PTR
    LOCAL tempKey, tempValue AS LONG
    IF p = 0 OR n = 0 THEN EXIT SUB
    IF @p.tag <> LnLnTreTag OR @n.tag <> LnLnTreNodeTag THEN EXIT SUB

    ' If the node has two children, swap with in-order successor
    IF @n.L <> 0 AND @n.R <> 0 THEN
        swapN = LnLnTreMinRight(n)
        IF swapN = 0 THEN EXIT SUB

        ' Swap key/value with successor
        tempKey = @n.K
        @n.K = @swapN.K
        @swapN.K = tempKey

        tempValue = @n.V
        @n.V = @swapN.V
        @swapN.V = tempValue

        ' Now remove the successor node instead
        n = swapN
    END IF

    ' Determine child that will replace the node
    IF @n.L <> 0 THEN
        CHILD = @n.L
    ELSEIF @n.R <> 0 THEN
        CHILD = @n.R
    ELSE
        CHILD = 0
    END IF

    ' Relink parent to point to child
    IF @n.P <> 0 THEN
        nP = @n.P
        IF @nP.L = n THEN
            @nP.L = CHILD
        ELSE
            @nP.R = CHILD
        END IF
        IF CHILD <> 0 THEN @CHILD.P = nP
        LnLnTreFreeNode p, n
        LnLnTreBalanceBranch p, nP
    ELSE
        ' Node is root
        @p.root = CHILD
        IF CHILD <> 0 THEN @CHILD.P = 0
        LnLnTreFreeNode p, n
    END IF
END SUB
'----------------------------------------------------------------------------------------
' Function: LnLnTreBalanceBranch
' Rebalances the tree upward from node n.
'----------------------------------------------------------------------------------------
SUB LnLnTreBalanceBranch(BYVAL p AS LnLnTre PTR, BYVAL n AS LnLnTreNode PTR) PRIVATE
    IF p = 0 OR n = 0 THEN EXIT SUB
    IF @p.tag <> LnLnTreTag THEN EXIT SUB

    WHILE n <> 0
        ' Update heights
        IF @n.L <> 0 THEN
            @n.HL = MAX&(@n.@L.HL, @n.@L.HR) + 1
        ELSE
            @n.HL = 0
        END IF

        IF @n.R <> 0 THEN
            @n.HR = MAX&(@n.@R.HL, @n.@R.HR) + 1
        ELSE
            @n.HR = 0
        END IF

        ' Balance if needed
        IF @n.HL > @n.HR + 1 THEN
            n = LnLnTreRotateRight(p, n)
        ELSEIF @n.HR > @n.HL + 1 THEN
            n = LnLnTreRotateLeft(p, n)
        ELSE
            n = @n.P
        END IF
    WEND
END SUB

'----------------------------------------------------------------------------------------
' Function: LnLnTreMaxLeft
' Returns the rightmost (maximum) node in the left subtree.
'----------------------------------------------------------------------------------------
FUNCTION LnLnTreMaxLeft(BYVAL n AS LnLnTreNode PTR) PRIVATE AS LONG
    IF n = 0 THEN FUNCTION = 0 : EXIT FUNCTION
    IF @n.tag <> LnLnTreNodeTag THEN FUNCTION = 0 : EXIT FUNCTION

    IF @n.L <> 0 THEN
        n = @n.L
        WHILE @n.R <> 0
            n = @n.R
        WEND
    END IF
    FUNCTION = n
END FUNCTION

'----------------------------------------------------------------------------------------
' Function: LnLnTreMinRight
' Returns the leftmost (minimum) node in the right subtree.
'----------------------------------------------------------------------------------------
FUNCTION LnLnTreMinRight(BYVAL n AS LnLnTreNode PTR) PRIVATE AS LONG
    IF n = 0 THEN FUNCTION = 0 : EXIT FUNCTION
    IF @n.tag <> LnLnTreNodeTag THEN FUNCTION = 0 : EXIT FUNCTION

    IF @n.R <> 0 THEN
        n = @n.R
        WHILE @n.L <> 0
            n = @n.L
        WEND
    END IF
    FUNCTION = n
END FUNCTION

'----------------------------------------------------------------------------------------
' Function: LnLnTreParentGreater
' Returns the first ancestor where the current node is in the left subtree.
'----------------------------------------------------------------------------------------
FUNCTION LnLnTreParentGreater(BYVAL n AS LnLnTreNode PTR) PRIVATE AS LONG
    IF n = 0 THEN FUNCTION = 0 : EXIT FUNCTION
    IF @n.tag <> LnLnTreNodeTag THEN FUNCTION = 0 : EXIT FUNCTION

    WHILE @n.P <> 0
        IF @n.@P.L = n THEN
            FUNCTION = @n.P
            EXIT FUNCTION
        ELSE
            n = @n.P
        END IF
    WEND
    FUNCTION = 0
END FUNCTION

'----------------------------------------------------------------------------------------
' Function: LnLnTreParentLesser
' Returns the first ancestor where the current node is in the right subtree.
'----------------------------------------------------------------------------------------
FUNCTION LnLnTreParentLesser(BYVAL n AS LnLnTreNode PTR) PRIVATE AS LONG
    IF n = 0 THEN FUNCTION = 0 : EXIT FUNCTION
    IF @n.tag <> LnLnTreNodeTag THEN FUNCTION = 0 : EXIT FUNCTION

    WHILE @n.P <> 0
        IF @n.@P.R = n THEN
            FUNCTION = @n.P
            EXIT FUNCTION
        ELSE
            n = @n.P
        END IF
    WEND
    FUNCTION = 0
END FUNCTION

'----------------------------------------------------------------------------------------
' Function: LnLnTreRotateLeft
' Performs a left rotation around node n.
'----------------------------------------------------------------------------------------
FUNCTION LnLnTreRotateLeft(BYVAL p AS LnLnTre PTR, BYVAL n AS LnLnTreNode PTR) PRIVATE AS LONG
    LOCAL nR, nRL AS LnLnTreNode PTR
    IF p = 0 OR n = 0 THEN FUNCTION = 0 : EXIT FUNCTION
    IF @p.tag <> LnLnTreTag THEN FUNCTION = 0 : EXIT FUNCTION

    nR = @n.R
    IF nR = 0 THEN FUNCTION = 0 : EXIT FUNCTION

    ' Check for double rotation condition
    IF @nR.HL > @nR.HR THEN
        nRL = @nR.L
        IF nRL = 0 THEN FUNCTION = 0 : EXIT FUNCTION

        @n.R = nRL : @nRL.P = n
        @nR.L = @nRL.R : IF @nR.L THEN @nR.@L.P = nR
        @nRL.R = nR : @nR.P = nRL

        ' Update heights for nR
        @nR.HL = IIF&(@nR.L, MAX&(@nR.@L.HL, @nR.@L.HR) + 1, 0)
        @nR.HR = IIF&(@nR.R, MAX&(@nR.@R.HL, @nR.@R.HR) + 1, 0)

        ' Update heights for nRL
        @nRL.HL = IIF&(@nRL.L, MAX&(@nRL.@L.HL, @nRL.@L.HR) + 1, 0)
        @nRL.HR = IIF&(@nRL.R, MAX&(@nRL.@R.HL, @nRL.@R.HR) + 1, 0)

        nR = @n.R
    END IF

    ' Perform left rotation
    IF @p.root = n THEN @p.root = nR
    @n.R = @nR.L : IF @n.R THEN @n.@R.P = n
    @nR.P = @n.P : @n.P = nR : @nR.L = n

    IF @nR.P THEN
        IF @nR.@P.L = n THEN @nR.@P.L = nR ELSE @nR.@P.R = nR
    END IF

    ' Update heights for n and nR after rotation
    @n.HL = IIF&(@n.L, MAX&(@n.@L.HL, @n.@L.HR) + 1, 0)
    @n.HR = IIF&(@n.R, MAX&(@n.@R.HL, @n.@R.HR) + 1, 0)
    @nR.HL = IIF&(@nR.L, MAX&(@nR.@L.HL, @nR.@L.HR) + 1, 0)
    @nR.HR = IIF&(@nR.R, MAX&(@nR.@R.HL, @nR.@R.HR) + 1, 0)

    FUNCTION = nR
END FUNCTION

'----------------------------------------------------------------------------------------
' Function: LnLnTreRotateRight
' Performs a right rotation around node n.
'----------------------------------------------------------------------------------------
FUNCTION LnLnTreRotateRight(BYVAL p AS LnLnTre PTR, BYVAL n AS LnLnTreNode PTR) PRIVATE AS LONG
    LOCAL nL, nLR AS LnLnTreNode PTR
    IF p = 0 OR n = 0 THEN FUNCTION = 0 : EXIT FUNCTION
    IF @p.tag <> LnLnTreTag THEN FUNCTION = 0 : EXIT FUNCTION

    nL = @n.L
    IF nL = 0 THEN FUNCTION = 0 : EXIT FUNCTION

    ' Check for double rotation condition
    IF @nL.HR > @nL.HL THEN
        nLR = @nL.R
        IF nLR = 0 THEN FUNCTION = 0 : EXIT FUNCTION

        @n.L = nLR : @nLR.P = n
        @nL.R = @nLR.L : IF @nL.R THEN @nL.@R.P = nL
        @nLR.L = nL : @nL.P = nLR

        ' Update heights for nL
        @nL.HL = IIF&(@nL.L, MAX&(@nL.@L.HL, @nL.@L.HR) + 1, 0)
        @nL.HR = IIF&(@nL.R, MAX&(@nL.@R.HL, @nL.@R.HR) + 1, 0)

        ' Update heights for nLR
        @nLR.HL = IIF&(@nLR.L, MAX&(@nLR.@L.HL, @nLR.@L.HR) + 1, 0)
        @nLR.HR = IIF&(@nLR.R, MAX&(@nLR.@R.HL, @nLR.@R.HR) + 1, 0)

        nL = @n.L
    END IF

    ' Perform right rotation
    IF @p.root = n THEN @p.root = nL
    @n.L = @nL.R : IF @n.L THEN @n.@L.P = n
    @nL.P = @n.P : @n.P = nL : @nL.R = n

    IF @nL.P THEN
        IF @nL.@P.L = n THEN @nL.@P.L = nL ELSE @nL.@P.R = nL
    END IF

    ' Update heights for n and nL after rotation
    @n.HL = IIF&(@n.L, MAX&(@n.@L.HL, @n.@L.HR) + 1, 0)
    @n.HR = IIF&(@n.R, MAX&(@n.@R.HL, @n.@R.HR) + 1, 0)
    @nL.HL = IIF&(@nL.L, MAX&(@nL.@L.HL, @nL.@L.HR) + 1, 0)
    @nL.HR = IIF&(@nL.R, MAX&(@nL.@R.HL, @nL.@R.HR) + 1, 0)

    FUNCTION = nL
END FUNCTION


'----------------------------------------------------------------------------------------

'----------------------------------------------------------------------------------------


[Theo Gottwald]

Notes
Pretty-Printed: The code is formatted with consistent indentation and spacing for improved readability.

Functionality Intact: The AVL tree implementation remains fully functional, supporting key operations like insertion (SsSsTreSet), retrieval (SsSsTreGet), deletion (SsSsTreDel), and traversal (SsSsTreFirst, SsSsTreNext, etc.).

AVL Balancing: The self-balancing logic is preserved in SsSsTreBalanceBranch, SsSsTreRotateLeft, and SsSsTreRotateRight.

PS: Several bug removed that were in original code from Stan.

Code Select Expand

#INCLUDE THIS ONCE
#INCLUDE ONCE "..\..\HLib.inc"
#INCLUDE ONCE "..\..\List\SsLst.inc"

'++
'----------------------------------------------------------------------------------------
'String/String ~ Tree Container
'   - also called: Tree/Map/Dictionary/Associative Array
'   - AVL Self-Balanced Binary Tree
'   - one-to-one relationship
'   - Key/Value data structure
'   - Values stored/retrieved/removed using unique lookup Key
'   - Keys must be unique
'   - no limit on Key length
'   - use SsSsTreComparison() to change how Keys compared
'   - Value replaced if Key exist unless DontReplace = True
'   - Tree always stays in Key order
'   - Tree may be traversed forward/backward in Key order
'   - Tree is self-balanced to maintain shortest average path to each Key
'
'   - use MultiTree for one-to-many relationship
'
'   container accessed with handle
'   handle protected by hash tag
'   h = SsSsTreNew() 'get handle for new container
'   h = SsSsTreFinal(h) 'free handle before it goes out of scope
'----------------------------------------------------------------------------------------
'--

MACRO SsSsTreNodeTag = -324365412
MACRO SsSsTreTag = -1851175339

'----------------------------------------------------------------------------------------
TYPE SsSsTreNode
    tag AS LONG
    P AS SsSsTreNode PTR
    L AS SsSsTreNode PTR
    R AS SsSsTreNode PTR
    HL AS DWORD
    HR AS DWORD
    K AS LONG
    V AS LONG
END TYPE

'----------------------------------------------------------------------------------------
TYPE SsSsTre
    tag AS LONG
    count AS LONG
    root AS SsSsTreNode PTR
    compareCB AS LONG
    collation AS SsStr PTR
END TYPE

'----------------------------------------------------------------------------------------
FUNCTION SsSsTreNew() COMMON AS LONG
    'allocate new container - return handle
    LOCAL p AS SsSsTre PTR
    ERR = 0
    p = MemAlloc(SIZEOF(@p))
    ExitF(p=0, LibErrM)
    @p.tag = SsSsTreTag
    @p.compareCB = CODEPTR(SsCompare)
    @p.collation = SsNew() : IF ERR THEN EXIT FUNCTION
    FUNCTION = p
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsSsTreFinal(BYVAL pTree AS SsSsTre PTR) COMMON AS LONG
    'free allocated container - return null
    IF pTree THEN
        ExitF(@pTree.tag<>SsSsTreTag, LibErrH)
        @pTree.collation = SsFinal(@pTree.collation)
        SsSsTreClear pTree
        MemFree(pTree)
    END IF
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsSsTreValidate(BYVAL pTree AS SsSsTre PTR) COMMON AS LONG
    'True/False if valid handle for this container
    IF pTree AND @pTree.tag = SsSsTreTag THEN FUNCTION = @pTree.tag
END FUNCTION

'----------------------------------------------------------------------------------------
SUB SsSsTreComparison(BYVAL pTree AS SsSsTre PTR, BYVAL compareUCase AS LONG, BYVAL collationSequence AS STRING) COMMON
    'set how Strings compared
    'default = case ignored
    'if collationSequence String provided then
    '   Strings are compared using the order of the collation sequence String
    '   collation String must be 256 characters
    'else if compareUCase = True then
    '   Strings compared UCase
    ExitS(pTree=0 OR @pTree.tag<>SsSsTreTag, LibErrH)
    @pTree.compareCB = CODEPTR(SsCompare)
    SsClear @pTree.collation
    IF LEN(collationSequence) THEN
        ExitS(LEN(collationSequence)<>256, LibErrS)
        SsSet @pTree.collation, collationSequence : IF ERR THEN EXIT SUB
        @pTree.compareCB = CODEPTR(SsCompareCollate)
    ELSEIF compareUCase THEN
        @pTree.compareCB = CODEPTR(SsCompareUCase)
    END IF
END SUB

'----------------------------------------------------------------------------------------
SUB SsSsTreClear(BYVAL pTree AS SsSsTre PTR) COMMON
    'delete all data
    LOCAL i AS LONG
    LOCAL pNode AS SsSsTreNode PTR
    LOCAL nodes() AS LONG
    ExitS(pTree=0 OR @pTree.tag<>SsSsTreTag, LibErrH)
    IF @pTree.count THEN
        REDIM nodes(1 TO @pTree.count)
        i = 0
        pNode = SsSsTreFirst(pTree)
        WHILE pNode
            INCR i
            nodes(i) = pNode
            pNode = SsSsTreNext(pNode)
        WEND
        FOR i = 1 TO @pTree.count
            SsSsTreFreeNode(pTree, nodes(i))
        NEXT i
    END IF
    @pTree.count = 0
    @pTree.root = 0
END SUB

'----------------------------------------------------------------------------------------
FUNCTION SsSsTreCount(BYVAL pTree AS SsSsTre PTR) COMMON AS LONG
    'get item count
    IF pTree THEN FUNCTION = @pTree.count
END FUNCTION

'----------------------------------------------------------------------------------------
SUB SsSsTreSet(BYVAL pTree AS SsSsTre PTR, BYREF key AS STRING, BYREF value AS STRING, OPT BYVAL DontReplace AS LONG) COMMON
    'add Key/Value to tree - Value replaced if Key exist unless DontReplace = True
    LOCAL compare, temp AS LONG
    LOCAL n AS SsSsTreNode PTR
    ERR = 0
    ExitS(pTree=0 OR @pTree.tag<>SsSsTreTag, LibErrH)
    temp = SsSetNew(key) : IF ERR THEN EXIT SUB
    IF @pTree.root THEN
        n = @pTree.root
        WHILE 1
            CALL DWORD @pTree.compareCB USING SsCompareCB(temp, @n.K, @pTree.collation) TO compare
            IF compare > 0 THEN
                IF @n.R THEN
                    n = @n.R
                ELSE
                    @n.R = SsSsTreAllocNode(pTree) : IF ERR THEN EXIT SUB
                    @n.@R.P = n
                    SsSet @n.@R.K, key
                    SsSet @n.@R.V, value
                    SsSsTreBalanceBranch pTree, n
                    EXIT LOOP
                END IF
            ELSEIF compare < 0 THEN
                IF @n.L THEN
                    n = @n.L
                ELSE
                    @n.L = SsSsTreAllocNode(pTree) : IF ERR THEN EXIT SUB
                    @n.@L.P = n
                    SsSet @n.@L.K, key
                    SsSet @n.@L.V, value
                    SsSsTreBalanceBranch pTree, n
                    EXIT LOOP
                END IF
            ELSE
                IF ISFALSE DontReplace THEN SsSet @n.V, value
                EXIT LOOP
            END IF
        WEND
    ELSE
        @pTree.root = SsSsTreAllocNode(pTree) : IF ERR THEN EXIT SUB
        SsSet @pTree.@root.K, key
        SsSet @pTree.@root.V, value
        @pTree.count = 1
    END IF
    temp = SsFinal(temp)
END SUB

'----------------------------------------------------------------------------------------
FUNCTION SsSsTreGet(BYVAL pTree AS SsSsTre PTR, BYREF key AS STRING) COMMON AS STRING
    'get Key's associated Value
    LOCAL compare, temp AS LONG
    LOCAL n AS SsSsTreNode PTR
    ERR = 0
    ExitF(pTree=0 OR @pTree.tag<>SsSsTreTag, LibErrH)
    temp = SsSetNew(key) : IF ERR THEN EXIT FUNCTION
    n = @pTree.root
    WHILE n
        CALL DWORD @pTree.compareCB USING SsCompareCB(temp, @n.K, @pTree.collation) TO compare
        IF compare < 0 THEN
            n = @n.L
        ELSEIF compare > 0 THEN
            n = @n.R
        ELSE
            FUNCTION = SsGet(@n.V)
            EXIT LOOP
        END IF
    WEND
    temp = SsFinal(temp)
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsSsTreGot(BYVAL pTree AS SsSsTre PTR, BYREF key AS STRING) COMMON AS LONG
    'True/False if Key exist
    LOCAL compare, temp AS LONG
    LOCAL n AS SsSsTreNode PTR
    ERR = 0
    ExitF(pTree=0 OR @pTree.tag<>SsSsTreTag, LibErrH)
    temp = SsSetNew(key) : IF ERR THEN EXIT FUNCTION
    n = @pTree.root
    WHILE n
        CALL DWORD @pTree.compareCB USING SsCompareCB(temp, @n.K, @pTree.collation) TO compare
        IF compare < 0 THEN
            n = @n.L
        ELSEIF compare > 0 THEN
            n = @n.R
        ELSE
            FUNCTION = n
            EXIT LOOP
        END IF
    WEND
    temp = SsFinal(temp)
END FUNCTION

'----------------------------------------------------------------------------------------
SUB SsSsTreDel(BYVAL pTree AS SsSsTre PTR, BYREF key AS STRING) COMMON
    'remove Key and associated Value
    LOCAL pNode AS SsSsTreNode PTR
    ExitS(pTree=0 OR @pTree.tag<>SsSsTreTag, LibErrH)
    pNode = SsSsTreGot(pTree, key)
    IF pNode THEN
        SsSsTreRemoveNode pTree, pNode
    END IF
END SUB

'----------------------------------------------------------------------------------------
FUNCTION SsSsTreFirst(BYVAL pTree AS SsSsTre PTR) COMMON AS LONG
    'get handle to first node in tree
    LOCAL n AS SsSsTreNode PTR
    ExitF(pTree=0 OR @pTree.tag<>SsSsTreTag, LibErrH)
    n = @pTree.root
    IF n THEN
        WHILE @n.L
            n = @n.L
        WEND
    END IF
    FUNCTION = n
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsSsTreLast(BYVAL pTree AS SsSsTre PTR) COMMON AS LONG
    'get handle to last node in tree
    LOCAL n AS SsSsTreNode PTR
    ExitF(pTree=0 OR @pTree.tag<>SsSsTreTag, LibErrH)
    n = @pTree.root
    IF n THEN
        WHILE @n.R
            n = @n.R
        WEND
    END IF
    FUNCTION = n
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsSsTreNext(BYVAL pNode AS SsSsTreNode PTR) COMMON AS LONG
    'get handle to next node in tree
    LOCAL minR AS SsSsTreNode PTR
    IF pNode THEN
        ExitF(@pNode.tag<>SsSsTreNodeTag, LibErrH)
        minR = SsSsTreMinRight(pNode)
        IF pNode <> minR THEN
            FUNCTION = minR
        ELSE
            FUNCTION = SsSsTreParentGreater(pNode)
        END IF
    END IF
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsSsTrePrev(BYVAL pNode AS SsSsTreNode PTR) COMMON AS LONG
    'get handle to previous node in tree
    LOCAL maxL AS SsSsTreNode PTR
    IF pNode THEN
        ExitF(@pNode.tag<>SsSsTreNodeTag, LibErrH)
        maxL = SsSsTreMaxLeft(pNode)
        IF pNode <> maxL THEN
            FUNCTION = maxL
        ELSE
            FUNCTION = SsSsTreParentLesser(pNode)
        END IF
    END IF
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsSsTreGetKey(BYVAL pNode AS SsSsTreNode PTR) COMMON AS STRING
    'get node's Key
    ExitF(pNode=0 OR @pNode.tag<>SsSsTreNodeTag, LibErrH)
    FUNCTION = SsGet(@pNode.K)
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsSsTreGetVal(BYVAL pNode AS SsSsTreNode PTR) COMMON AS STRING
    'get node's Value
    ExitF(pNode=0 OR @pNode.tag<>SsSsTreNodeTag, LibErrH)
    FUNCTION = SsGet(@pNode.V)
END FUNCTION

'----------------------------------------------------------------------------------------
SUB SsSsTreSetVal(BYVAL pNode AS SsSsTreNode PTR, BYREF value AS STRING) COMMON
    'set node's Value
    ExitS(pNode=0 OR @pNode.tag<>SsSsTreNodeTag, LibErrH)
    SsSet @pNode.V, value
END SUB

'++
'----------------------------------------------------------------------------------------
'   Clone Container
'----------------------------------------------------------------------------------------
'--

FUNCTION SsSsTreClone(BYVAL pTree AS SsSsTre PTR) COMMON AS LONG
    'create duplicate container
    LOCAL h, clone AS LONG
    ERR = 0
    ExitF(pTree=0 OR @pTree.tag<>SsSsTreTag, LibErrH)
    clone = SsSsTreNew() : IF ERR THEN EXIT FUNCTION
    h = SsSsTreFirst(pTree)
    WHILE h
        SsSsTreSet clone, SsSsTreGetKey(h), SsSsTreGetVal(h)
        h = SsSsTreNext(h)
    WEND
    FUNCTION = clone
END FUNCTION

'++
'----------------------------------------------------------------------------------------
'   Store/Restore Container To/From String
'----------------------------------------------------------------------------------------
'--

FUNCTION SsSsTreStore(BYVAL pTree AS SsSsTre PTR) COMMON AS STRING
    'store container to string
    LOCAL h, keys, vals, stor AS LONG
    ERR = 0
    ExitF(pTree=0 OR @pTree.tag<>SsSsTreTag, LibErrH)
    keys = SsLstNew() : IF ERR THEN EXIT FUNCTION
    vals = SsLstNew() : IF ERR THEN EXIT FUNCTION
    stor = SsLstNew() : IF ERR THEN EXIT FUNCTION
    IF @pTree.count THEN
        h = SsSsTreFirst(pTree)
        WHILE h
            SsLstAdd keys, SsSsTreGetKey(h)
            SsLstAdd vals, SsSsTreGetVal(h)
            h = SsSsTreNext(h)
        WEND
        SsLstAdd stor, SsLstStore(keys)
        SsLstAdd stor, SsLstStore(vals)
        FUNCTION = SsLstStore(stor)
    END IF
    keys = SsLstFinal(keys)
    vals = SsLstFinal(vals)
    stor = SsLstFinal(stor)
END FUNCTION

'----------------------------------------------------------------------------------------
SUB SsSsTreRestore(BYVAL pTree AS SsSsTre PTR, BYVAL s AS STRING) COMMON
    'restore container from string
    LOCAL keys, vals, stor AS LONG
    ERR = 0
    ExitS(pTree=0 OR @pTree.tag<>SsSsTreTag, LibErrH)
    SsSsTreClear pTree
    keys = SsLstNew() : IF ERR THEN EXIT SUB
    vals = SsLstNew() : IF ERR THEN EXIT SUB
    stor = SsLstNew() : IF ERR THEN EXIT SUB
    IF LEN(s) THEN
        SsLstRestore stor, s : IF ERR THEN EXIT SUB
        ExitS(SsLstCount(stor)<>2, LibErrU)
        SsLstRestore keys, SsLstPopFirst(stor)
        SsLstRestore vals, SsLstPopFirst(stor)
        ExitS(SsLstCount(keys)<>SsLstCount(vals), LibErrU)
        WHILE SsLstCount(keys)
            SsSsTreSet pTree, SsLstPopFirst(keys), SsLstPopFirst(vals)
        WEND
    END IF
    keys = SsLstFinal(keys)
    vals = SsLstFinal(vals)
    stor = SsLstFinal(stor)
END SUB

'++
'----------------------------------------------------------------------------------------
'   Store/Restore Container To/From File
'----------------------------------------------------------------------------------------
'--

SUB SsSsTreFileStore(BYVAL pTree AS SsSsTre PTR, BYVAL file AS STRING) COMMON
    'store container to file
    LOCAL s AS STRING
    LOCAL f AS LONG
    ERR = 0
    ExitS(pTree=0 OR @pTree.tag<>SsSsTreTag, LibErrH)
    s = SsSsTreStore(pTree) : IF ERR THEN EXIT SUB
    TRY
        f = FREEFILE
        OPEN file FOR BINARY AS f
        SETEOF f
        PUT$ f, s
        CLOSE f
    CATCH
        ExitLogErr(LibErrF)
    FINALLY
        IF f THEN CLOSE f
    END TRY
END SUB

'----------------------------------------------------------------------------------------
SUB SsSsTreFileRestore(BYVAL pTree AS SsSsTre PTR, BYVAL file AS STRING) COMMON
    'restore container from file - Modifies Container Data
    LOCAL f AS LONG
    LOCAL s AS STRING
    ERR = 0
    ExitS(pTree=0 OR @pTree.tag<>SsSsTreTag, LibErrH)
    TRY
        f = FREEFILE
        OPEN file FOR BINARY AS f
        GET$ f, LOF(f), s
        SsSsTreRestore pTree, s
    CATCH
        ExitLogErr(LibErrF)
    FINALLY
        IF f THEN CLOSE f
    END TRY
END SUB

'----------------------------------------------------------------------------------------
'   PRIVATE
'----------------------------------------------------------------------------------------

SUB SsSsTreRemoveNode(BYVAL p AS SsSsTre PTR, BYVAL n AS SsSsTreNode PTR) PRIVATE
    LOCAL nP, swapN AS SsSsTreNode PTR
    LOCAL tempKey, tempValue AS LONG
    IF n = 0 THEN EXIT SUB

    ' Handle nodes with children by swapping with successor
    WHILE @n.L OR @n.R
        IF @n.R THEN
            swapN = SsSsTreMinRight(n)

            ' Swap keys and values
            tempKey = @n.K
            @n.K = @swapN.K
            @swapN.K = tempKey
            tempValue = @n.V
            @n.V = @swapN.V
            @swapN.V = tempValue

            ' Update tree structure
            IF @p.root = n THEN
                ' Root remains the same
            END IF
            n = swapN
        END IF
    WEND

    ' Handle leaf node removal
    IF @p.root = n AND @n.L = 0 AND @n.R = 0 THEN
        ' Deleting the root (only node)
        SsSsTreFreeNode p, n
        @p.root = 0
    ELSEIF @n.P THEN
        ' Node has a parent; remove it from the parent
        nP = @n.P
        IF @nP.L = n THEN
            @nP.L = 0
        ELSE
            @nP.R = 0
        END IF
        SsSsTreFreeNode p, n
    ELSE
        ' Detached node (no parent, not root)
        SsSsTreFreeNode p, n  ' Free the detached node
    END IF
END SUB

'----------------------------------------------------------------------------------------
FUNCTION SsSsTreAllocNode(BYVAL p AS SsSsTre PTR) PRIVATE AS LONG
    LOCAL n AS SsSsTreNode PTR
    n = MemAlloc(SIZEOF(SsSsTreNode))
    ExitF(n=0, LIbErrM)
    @n.HL = 1
    @n.HR = 1
    @n.tag = SsSsTreNodeTag
    @n.K = SsNew() : IF ERR THEN MemFree(n) : EXIT FUNCTION
    @n.V = SsNew() : IF ERR THEN @n.K = SsFinal(@n.K) : MemFree(n) : EXIT FUNCTION
    INCR @p.count
    FUNCTION = n
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsSsTreFreeNode(BYVAL p AS SsSsTre PTR, BYVAL n AS SsSsTreNode PTR) AS LONG
    IF n THEN
        @n.K = SsFinal(@n.K)  ' Clean up key
        @n.V = SsFinal(@n.V)  ' Clean up value
        MemFree(n)            ' Free the node's memory
        IF @p.count > 0 THEN DECR @p.count  ' Decrement count safely
    END IF
END FUNCTION

'----------------------------------------------------------------------------------------
SUB SsSsTreBalanceBranch(BYVAL p AS SsSsTre PTR, BYVAL n AS SsSsTreNode PTR) PRIVATE
    WHILE n
        @n.HL = IIF&(@n.L, MAX&(@n.@L.HL, @n.@L.HR) + 1, 1)
        @n.HR = IIF&(@n.R, MAX&(@n.@R.HL, @n.@R.HR) + 1, 1)
        IF @n.HL > @n.HR + 1 THEN
            n = SsSsTreRotateRight(p, n)
        ELSEIF @n.HR > @n.HL + 1 THEN
            n = SsSsTreRotateLeft(p, n)
        ELSE
            n = @n.P
        END IF
    WEND
END SUB

'----------------------------------------------------------------------------------------
FUNCTION SsSsTreMaxLeft(BYVAL n AS SsSsTreNode PTR) PRIVATE AS LONG
    IF n THEN
        IF @n.L THEN
            n = @n.L
            WHILE @n.R
                n = @n.R
            WEND
        END IF
    END IF
    FUNCTION = n
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsSsTreMinRight(BYVAL n AS SsSsTreNode PTR) PRIVATE AS LONG
    IF n THEN
        IF @n.R THEN
            n = @n.R
            WHILE @n.L
                n = @n.L
            WEND
        END IF
    END IF
    FUNCTION = n
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsSsTreParentGreater(BYVAL n AS SsSsTreNode PTR) PRIVATE AS LONG
    IF n THEN
        WHILE @n.P
            IF @n.@P.L = n THEN
                FUNCTION = @n.P
                EXIT FUNCTION
            ELSE
                n = @n.P
            END IF
        WEND
    END IF
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsSsTreParentLesser(BYVAL n AS SsSsTreNode PTR) PRIVATE AS LONG
    IF n THEN
        WHILE @n.P
            IF @n.@P.R = n THEN
                FUNCTION = @n.P
                EXIT FUNCTION
            ELSE
                n = @n.P
            END IF
        WEND
    END IF
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsSsTreRotateLeft(BYVAL p AS SsSsTre PTR, BYVAL n AS SsSsTreNode PTR) PRIVATE AS LONG
    LOCAL nR, nRL AS SsSsTreNode PTR
    nR = @n.R
    IF @nR.HL > @nR.HR THEN
        nRL = @nR.L
        @n.R = nRL : @nRL.P = n
        @nR.L = @nRL.R : IF @nR.L THEN @nR.@L.P = nR
        @nRL.R = nR : @nR.P = nRL
        @nR.HL = IIF&(@nR.L, MAX&(@nR.@L.HL, @nR.@L.HR) + 1, 1)
        @nR.HR = IIF&(@nR.R, MAX&(@nR.@R.HL, @nR.@R.HR) + 1, 1)
        nR = @n.R
    END IF
    IF @p.root = n THEN @p.root = @n.R
    @n.R = @nR.L : IF @n.R THEN @n.@R.P = n
    @nR.P = @n.P : @n.P = nR : @nR.L = n
    IF @nR.P THEN
        IF @nR.@P.L = n THEN @nR.@P.L = nR ELSE @nR.@P.R = nR
    END IF
    FUNCTION = n
END FUNCTION

'----------------------------------------------------------------------------------------
FUNCTION SsSsTreRotateRight(BYVAL p AS SsSsTre PTR, BYVAL n AS SsSsTreNode PTR) PRIVATE AS LONG
    LOCAL nL, nLR AS SsSsTreNode PTR
    nL = @n.L
    IF @nL.HR > @nL.HL THEN
        nLR = @nL.R
        @n.L = nLR : @nLR.P = n
        @nL.R = @nLR.L : IF @nL.R THEN @nL.@R.P = nL
        @nLR.L = nL : @nL.P = nLR
        @nL.HL = IIF&(@nL.L, MAX&(@nL.@L.HL, @nL.@L.HR) + 1, 1)
        @nL.HR = IIF&(@nL.R, MAX&(@nL.@R.HL, @nL.@R.HR) + 1, 1)
        nL = @n.L
    END IF
    IF @p.root = n THEN @p.root = @n.L
    @n.L = @nL.R : IF @n.L THEN @n.@L.P = n
    @nL.P = @n.P : @n.P = nL : @nL.R = n
    IF @nL.P THEN
        IF @nL.@P.L = n THEN @nL.@P.L = nL ELSE @nL.@P.R = nL
    END IF
    FUNCTION = n
END FUNCTION