In tests the HLIB3 - original Tree functions fail.
Because i use it, i have corrrected the WsLnTre.inc
#INCLUDE THIS ONCE
#INCLUDE ONCE "..\HLib3\HLib.inc"
#INCLUDE ONCE "..\HLib3\List\SsLst.inc"
#INCLUDE ONCE "..\HLib3\List\WsLst.inc"
#INCLUDE ONCE "..\HLib3\List\LnLst.inc"
'++
'----------------------------------------------------------------------------------------
' Corrected and tested
'WString/Long ~ 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 WsLnTreComparison() 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 = WsLnTreNew() 'get handle for new container
' h = WsLnTreFinal(h) 'free handle before it goes out of scope
'----------------------------------------------------------------------------------------
'--
MACRO WsLnTreNodeTag = 1320870834
MACRO WsLnTreTag = -212996673
TYPE WsLnTreNode
tag AS LONG
P AS WsLnTreNode PTR
L AS WsLnTreNode PTR
R AS WsLnTreNode PTR
HL AS WORD
HR AS WORD
K AS LONG
V AS LONG
END TYPE
TYPE WsLnTre
tag AS LONG
count AS LONG
root AS WsLnTreNode PTR
compareCB AS LONG
collation AS WsStr PTR
END TYPE
FUNCTION WsLnTreNew() AS LONG
'allocate new container - return handle
LOCAL p AS WsLnTre PTR
ERR = 0
p = MemAlloc(SIZEOF(@p))
ExitF(p=0, LibErrM)
@p.tag = WsLnTreTag
@p.compareCB = CODEPTR(WsCompare)
@p.collation = WsNew() : IF ERR THEN EXIT FUNCTION
FUNCTION = p
END FUNCTION
FUNCTION WsLnTreFinal(BYVAL pTree AS WsLnTre PTR) AS LONG
'free allocated container - return null
IF pTree THEN
ExitF(@pTree.tag<>WsLnTreTag, LibErrH)
@pTree.collation = WsFinal(@pTree.collation)
WsLnTreClear pTree
MemFree(pTree)
END IF
END FUNCTION
FUNCTION WsLnTreValidate(BYVAL pTree AS WsLnTre PTR) AS LONG
'True/False if valid handle for this container
IF pTree AND @pTree.tag = WsLnTreTag THEN FUNCTION = @pTree.tag
END FUNCTION
SUB WsLnTreComparison(BYVAL pTree AS WsLnTre PTR, BYVAL compareUCase AS LONG, BYVAL collationSequence AS WSTRING)
'set how WStrings compared
'default = case ignored
'if collationSequence WString provided then
' WStrings are compared using the order of the collation sequence WString
' collation WString must be 65536 characters
'else if compareUCase = True then
' WStrings compared UCase
ExitS(pTree=0 OR @pTree.tag<>WsLnTreTag, LibErrH)
@pTree.compareCB = CODEPTR(WsCompare)
WsClear @pTree.collation
IF LEN(collationSequence) THEN
ExitS(LEN(collationSequence)<>65536, LibErrS)
WsSet @pTree.collation, collationSequence : IF ERR THEN EXIT SUB
@pTree.compareCB = CODEPTR(WsCompareCollate)
ELSEIF compareUCase THEN
@pTree.compareCB = CODEPTR(WsCompareUCase)
END IF
END SUB
SUB WsLnTreClear(BYVAL pTree AS WsLnTre PTR)
'delete all data
LOCAL i AS LONG
LOCAL pNode AS WsLnTreNode PTR
LOCAL nodes() AS LONG
ExitS(pTree=0 OR @pTree.tag<>WsLnTreTag, LibErrH)
IF @pTree.count THEN
REDIM nodes(1 TO @pTree.count)
i = 0
pNode = WsLnTreFirst(pTree)
WHILE pNode
INCR i
nodes(i) = pNode
pNode = WsLnTreNext(pNode)
WEND
FOR i = 1 TO @pTree.count
WsLnTreFreeNode(pTree, nodes(i))
NEXT i
END IF
@pTree.count = 0
@pTree.root = 0
END SUB
FUNCTION WsLnTreCount(BYVAL pTree AS WsLnTre PTR) AS LONG
'get item count
IF pTree THEN FUNCTION = @pTree.count
END FUNCTION
SUB WsLnTreSet(BYVAL pTree AS WsLnTre PTR, BYREF key AS WSTRING, BYVAL value AS LONG, OPT BYVAL DontReplace AS LONG)
'add Key/Value to tree - Value replaced if Key exist unless DontReplace = True
LOCAL compare, temp AS LONG
LOCAL n AS WsLnTreNode PTR
ERR = 0
ExitS(pTree=0 OR @pTree.tag<>WsLnTreTag, LibErrH)
temp = WsSetNew(key) : IF ERR THEN EXIT SUB
IF @pTree.root THEN
n = @pTree.root
WHILE 1
CALL DWORD @pTree.compareCB USING WsCompareCB(temp, @n.K, @pTree.collation) TO compare
IF compare > 0 THEN
IF @n.R THEN
n = @n.R
ELSE
@n.R = WsLnTreAllocNode(pTree) : IF ERR THEN EXIT SUB
@n.@R.P = n
WsSet @n.@R.K, key
@n.@R.V = value
WsLnTreBalanceBranch pTree, n
EXIT LOOP
END IF
ELSEIF compare < 0 THEN
IF @n.L THEN
n = @n.L
ELSE
@n.L = WsLnTreAllocNode(pTree) : IF ERR THEN EXIT SUB
@n.@L.P = n
WsSet @n.@L.K, key
@n.@L.V = value
WsLnTreBalanceBranch pTree, n
EXIT LOOP
END IF
ELSE
IF ISFALSE DontReplace THEN @n.V = value
EXIT LOOP
END IF
WEND
ELSE
@pTree.root = WsLnTreAllocNode(pTree) : IF ERR THEN EXIT SUB
WsSet @pTree.@root.K, key
@pTree.@root.V = value
@pTree.count = 1
END IF
temp = WsFinal(temp)
END SUB
FUNCTION WsLnTreGet(BYVAL pTree AS WsLnTre PTR, BYREF key AS WSTRING) AS LONG
'get Key's associated Value
LOCAL compare, temp AS LONG
LOCAL n AS WsLnTreNode PTR
ERR = 0
ExitF(pTree=0 OR @pTree.tag<>WsLnTreTag, LibErrH)
temp = WsSetNew(key) : IF ERR THEN EXIT FUNCTION
n = @pTree.root
WHILE n
CALL DWORD @pTree.compareCB USING WsCompareCB(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 = WsFinal(temp)
END FUNCTION
FUNCTION WsLnTreGot(BYVAL pTree AS WsLnTre PTR, BYREF key AS WSTRING) AS LONG
'True/False if Key exist
LOCAL compare, temp AS LONG
LOCAL n AS WsLnTreNode PTR
ERR = 0
ExitF(pTree=0 OR @pTree.tag<>WsLnTreTag, LibErrH)
temp = WsSetNew(key) : IF ERR THEN EXIT FUNCTION
n = @pTree.root
WHILE n
CALL DWORD @pTree.compareCB USING WsCompareCB(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 = WsFinal(temp)
END FUNCTION
SUB WsLnTreDel(BYVAL pTree AS WsLnTre PTR, BYREF key AS WSTRING)
'remove Key and associated Value
LOCAL pNode AS WsLnTreNode PTR
ExitS(pTree=0 OR @pTree.tag<>WsLnTreTag, LibErrH)
pNode = WsLnTreGot(pTree, key)
IF pNode THEN
WsLnTreRemoveNode(pTree, pNode)
END IF
END SUB
FUNCTION WsLnTreFirst(BYVAL pTree AS WsLnTre PTR) AS LONG
'get handle to first node in tree
LOCAL n AS WsLnTreNode PTR
ExitF(pTree=0 OR @pTree.tag<>WsLnTreTag, LibErrH)
n = @pTree.root
IF n THEN
WHILE @n.L
n = @n.L
WEND
END IF
FUNCTION = n
END FUNCTION
FUNCTION WsLnTreLast(BYVAL pTree AS WsLnTre PTR) AS LONG
'get handle to last node in tree
LOCAL n AS WsLnTreNode PTR
ExitF(pTree=0 OR @pTree.tag<>WsLnTreTag, LibErrH)
n = @pTree.root
IF n THEN
WHILE @n.R
n = @n.R
WEND
END IF
FUNCTION = n
END FUNCTION
FUNCTION WsLnTreNext(BYVAL pNode AS WsLnTreNode PTR) AS LONG
'get handle to next node in tree
LOCAL minR AS WsLnTreNode PTR
IF pNode THEN
ExitF(@pNode.tag<>WsLnTreNodeTag, LibErrH)
minR = WsLnTreMinRight(pNode)
IF pNode <> minR THEN
FUNCTION = minR
ELSE
FUNCTION = WsLnTreParentGreater(pNode)
END IF
END IF
END FUNCTION
FUNCTION WsLnTrePrev(BYVAL pNode AS WsLnTreNode PTR) AS LONG
'get handle to previous node in tree
LOCAL maxL AS WsLnTreNode PTR
IF pNode THEN
ExitF(@pNode.tag<>WsLnTreNodeTag, LibErrH)
maxL = WsLnTreMaxLeft(pNode)
IF pNode <> maxL THEN
FUNCTION = maxL
ELSE
FUNCTION = WsLnTreParentLesser(pNode)
END IF
END IF
END FUNCTION
FUNCTION WsLnTreGetKey(BYVAL pNode AS WsLnTreNode PTR) AS WSTRING
'get node's Key
ExitF(pNode=0 OR @pNode.tag<>WsLnTreNodeTag, LibErrH)
FUNCTION = WsGet(@pNode.K)
END FUNCTION
FUNCTION WsLnTreGetVal(BYVAL pNode AS WsLnTreNode PTR) AS LONG
'get node's Value
ExitF(pNode=0 OR @pNode.tag<>WsLnTreNodeTag, LibErrH)
FUNCTION = @pNode.V
END FUNCTION
SUB WsLnTreSetVal(BYVAL pNode AS WsLnTreNode PTR, BYVAL value AS LONG)
'get node's Value
ExitS(pNode=0 OR @pNode.tag<>WsLnTreNodeTag, LibErrH)
@pNode.V = value
END SUB
'++
'----------------------------------------------------------------------------------------
' Clone Container
'----------------------------------------------------------------------------------------
'--
FUNCTION WsLnTreClone(BYVAL pTree AS WsLnTre PTR) AS LONG
'create duplicate container
LOCAL h, clone AS LONG
ERR = 0
ExitF(pTree=0 OR @pTree.tag<>WsLnTreTag, LibErrH)
clone = WsLnTreNew() : IF ERR THEN EXIT FUNCTION
h = WsLnTreFirst(pTree)
WHILE h
WsLnTreSet clone, WsLnTreGetKey(h), WsLnTreGetVal(h)
h = WsLnTreNext(h)
WEND
FUNCTION = clone
END FUNCTION
'++
'----------------------------------------------------------------------------------------
' Store/Restore Container To/From String
'----------------------------------------------------------------------------------------
'--
FUNCTION WsLnTreStore(BYVAL pTree AS WsLnTre PTR) AS STRING
'store container to string
LOCAL h, keys, vals, stor AS LONG
ERR = 0
ExitF(pTree=0 OR @pTree.tag<>WsLnTreTag, LibErrH)
keys = WsLstNew() : IF ERR THEN EXIT FUNCTION
vals = LnLstNew() : IF ERR THEN EXIT FUNCTION
stor = SsLstNew() : IF ERR THEN EXIT FUNCTION
IF @pTree.count THEN
h = WsLnTreFirst(pTree)
WHILE h
WsLstAdd keys, WsLnTreGetKey(h)
LnLstAdd vals, WsLnTreGetVal(h)
h = WsLnTreNext(h)
WEND
SsLstAdd stor, WsLstStore(keys)
SsLstAdd stor, LnLstStore(vals)
FUNCTION = SsLstStore(stor)
END IF
keys = WsLstFinal(keys)
vals = LnLstFinal(vals)
stor = SsLstFinal(stor)
END FUNCTION
SUB WsLnTreRestore(BYVAL pTree AS WsLnTre PTR, BYVAL s AS STRING)
'restore container from string
LOCAL keys, vals, stor AS LONG
ERR = 0
ExitS(pTree=0 OR @pTree.tag<>WsLnTreTag, LibErrH)
WsLnTreClear pTree
keys = WsLstNew() : IF ERR THEN EXIT SUB
vals = LnLstNew() : 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)
WsLstRestore keys, SsLstPopFirst(stor)
LnLstRestore vals, SsLstPopFirst(stor)
ExitS(WsLstCount(keys)<>LnLstCount(vals), LibErrU)
WHILE WsLstCount(keys)
WsLnTreSet pTree, WsLstPopFirst(keys), LnLstPopFirst(vals)
WEND
END IF
keys = WsLstFinal(keys)
vals = LnLstFinal(vals)
stor = SsLstFinal(stor)
END SUB
'++
'----------------------------------------------------------------------------------------
' Store/Restore Container To/From File
'----------------------------------------------------------------------------------------
'--
SUB WsLnTreFileStore(BYVAL pTree AS WsLnTre PTR, BYVAL FILE AS STRING)
'store container to file
LOCAL s AS STRING
LOCAL f AS LONG
ERR = 0
ExitS(pTree=0 OR @pTree.tag<>WsLnTreTag, LibErrH)
s = WsLnTreStore(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 WsLnTreFileRestore(BYVAL pTree AS WsLnTre PTR, BYVAL FILE AS STRING)
'restore container from file - Modifies Container Data
LOCAL f AS LONG
LOCAL s AS STRING
ERR = 0
ExitS(pTree=0 OR @pTree.tag<>WsLnTreTag, LibErrH)
TRY
f = FREEFILE
OPEN FILE FOR BINARY AS f
GET$ f, LOF(f), s
WsLnTreRestore pTree, s
CATCH
ExitLogErr(LibErrF)
FINALLY
IF f THEN CLOSE f
END TRY
END SUB
'----------------------------------------------------------------------------------------
' PRIVATE
'----------------------------------------------------------------------------------------
'========================================================
' SUB: WsLnTreRemoveNode (Corrected Data-Swapping Approach)
'========================================================
' Note: Use this with the corrected WsLnTreBalanceBranch (Attempt 4)
SUB WsLnTreRemoveNode(BYVAL p AS WsLnTre PTR, BYVAL n AS WsLnTreNode PTR) PRIVATE
ExitS(n=0, LibErrP) ' Exit if node handle is NULL
LOCAL nodeToDelete AS WsLnTreNode PTR ' The node whose original position needs deletion after data swap
LOCAL nP AS WsLnTreNode PTR ' Parent of nodeToDelete
LOCAL replacementNode AS WsLnTreNode PTR ' Child node that replaces nodeToDelete (can be NULL)
LOCAL nodeToBalanceFrom AS WsLnTreNode PTR ' Where to start balancing
nodeToDelete = n ' Start with the node passed in
' --- Step 1: If node has TWO children, find successor, swap data, target successor for deletion ---
IF @nodeToDelete.L AND @nodeToDelete.R THEN
' Node has two children. Find inorder successor (minimum node in right subtree).
LOCAL successor AS WsLnTreNode PTR
successor = WsLnTreMinRight(nodeToDelete) ' Find the successor node
' Swap Key handles (K) and Values (V) between nodeToDelete and successor
SWAP @nodeToDelete.K, @successor.K
SWAP @nodeToDelete.V, @successor.V
' Now, the node we *actually* need to remove physically is the successor node
' from its original position. It's guaranteed to have 0 or 1 right child.
nodeToDelete = successor
END IF
' --- Step 2: Now 'nodeToDelete' has 0 or 1 child. Remove it physically. ---
' Determine the single child (if any) that will replace the nodeToDelete
IF @nodeToDelete.L THEN
replacementNode = @nodeToDelete.L
ELSE
replacementNode = @nodeToDelete.R ' Can be NULL if no children
END IF
' Get the parent of the node we are about to physically remove
nP = @nodeToDelete.P
nodeToBalanceFrom = nP ' Balance starts from here
' --- Link replacement node to parent (nP) ---
IF nP = %NULL THEN
' Deleting the root node
@p.root = replacementNode ' New root is the replacement (or NULL if tree empty)
IF replacementNode THEN @replacementNode.P = %NULL ' Update replacement's parent
ELSE
' Deleting a non-root node
IF @nP.L = nodeToDelete THEN
@nP.L = replacementNode ' Link parent's left to replacement
ELSE
@nP.R = replacementNode ' Link parent's right to replacement
END IF
IF replacementNode THEN @replacementNode.P = nP ' Update replacement's parent
END IF
' --- Free the node that was physically removed ---
nodeToDelete = WsLnTreFreeNode(p, nodeToDelete) ' Frees memory, decrements count
' --- Rebalance starting from the parent of the removed node's position ---
IF nodeToBalanceFrom THEN ' Only balance if there was a parent
WsLnTreBalanceBranch p, nodeToBalanceFrom
END IF
END SUB
FUNCTION WsLnTreFreeNode(BYVAL p AS WsLnTre PTR, BYVAL n AS WsLnTreNode PTR) AS LONG
IF n THEN
@n.K = WsFinal(@n.K)
MemFree(n)
IF @p.count = 0 THEN
ERR = LibErrU
FUNCTION = %FALSE
EXIT FUNCTION
END IF
DECR @p.count
FUNCTION = %TRUE
END IF
END FUNCTION
FUNCTION WsLnTreAllocNode(BYVAL p AS WsLnTre PTR) PRIVATE AS LONG
LOCAL n AS WsLnTreNode PTR
n = MemAlloc(SIZEOF(WsLnTreNode))
ExitF(n=0, LIbErrM)
@n.HL = 1
@n.HR = 1
@n.tag = WsLnTreNodeTag
@n.K = WsNew() : IF ERR THEN EXIT FUNCTION
INCR @p.count
FUNCTION = n
END FUNCTION
'========================================================
' SUB: WsLnTreBalanceBranch (Attempt 4 - PB Syntax Fixes)
'========================================================
SUB WsLnTreBalanceBranch(BYVAL p AS WsLnTre PTR, BYVAL n AS WsLnTreNode PTR) PRIVATE
LOCAL rotatedNodeHandle AS LONG ' Handle of the new root after rotation
LOCAL nodeToProcessCurrent AS WsLnTreNode PTR ' Node being processed in this iteration
LOCAL nodeToProcessNext AS WsLnTreNode PTR ' Node to process in the *next* iteration
LOCAL tempRotatedNodePtr AS WsLnTreNode PTR ' Temporary pointer for casting handle
nodeToProcessNext = n ' Start balancing from the specified node
WHILE nodeToProcessNext ' Loop upwards as long as we have a valid node handle
nodeToProcessCurrent = nodeToProcessNext ' Assign node for this iteration
' --- Store Parent for the NEXT iteration EARLY ---
' This is crucial because rotations might change the current node's parent pointer.
IF @nodeToProcessCurrent.P THEN
nodeToProcessNext = @nodeToProcessCurrent.P ' Store its parent handle
ELSE
nodeToProcessNext = %NULL ' Reached the root's parent (NULL)
END IF
' --- Recalculate heights for the current node ---
@nodeToProcessCurrent.HL = IIF&(@nodeToProcessCurrent.L, MAX&(@nodeToProcessCurrent.@L.HL, @nodeToProcessCurrent.@L.HR) + 1, 1)
@nodeToProcessCurrent.HR = IIF&(@nodeToProcessCurrent.R, MAX&(@nodeToProcessCurrent.@R.HL, @nodeToProcessCurrent.@R.HR) + 1, 1)
' --- Check for imbalance and perform rotation if needed ---
IF @nodeToProcessCurrent.HL > @nodeToProcessCurrent.HR + 1 THEN
' Rotate Right needed
rotatedNodeHandle = WsLnTreRotateRight(p, nodeToProcessCurrent)
' After rotation, the original 'nodeToProcessCurrent' might have moved.
' The 'rotatedNodeHandle' points to the NEW root of this balanced subtree.
' The loop should continue from the PARENT of whatever node is now at the top
' of the subtree where the rotation occurred.
IF rotatedNodeHandle <> 0 THEN ' Check if rotation actually returned a valid handle
tempRotatedNodePtr = rotatedNodeHandle ' Assign LONG handle to PTR
IF @tempRotatedNodePtr.P THEN ' Does the new root have a parent?
nodeToProcessNext = @tempRotatedNodePtr.P ' Continue from new root's parent
ELSE
nodeToProcessNext = %NULL ' New root became the tree root
END IF
ELSE
' Rotation function failed or returned NULL unexpectedly
nodeToProcessNext = %NULL ' Stop balancing
END IF
' *** NO ITERATE needed here *** - Let WHILE condition check nodeToProcessNext
ELSEIF @nodeToProcessCurrent.HR > @nodeToProcessCurrent.HL + 1 THEN
' Rotate Left needed
rotatedNodeHandle = WsLnTreRotateLeft(p, nodeToProcessCurrent)
' Similar logic as above
IF rotatedNodeHandle <> 0 THEN
tempRotatedNodePtr = rotatedNodeHandle ' Assign LONG handle to PTR
IF @tempRotatedNodePtr.P THEN
nodeToProcessNext = @tempRotatedNodePtr.P ' Continue from new root's parent
ELSE
nodeToProcessNext = %NULL
END IF
ELSE
nodeToProcessNext = %NULL ' Stop balancing
END IF
' *** NO ITERATE needed here ***
ELSE
' Node is balanced at this level.
' The loop will continue with the parent stored in 'nodeToProcessNext'
' which was captured at the beginning of this iteration.
' *** NO ITERATE needed here ***
END IF
WEND ' Loop continues with nodeToProcessNext
END SUB
FUNCTION WsLnTreMaxLeft(BYVAL n AS WsLnTreNode 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 WsLnTreMinRight(BYVAL n AS WsLnTreNode 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 WsLnTreParentGreater(BYVAL n AS WsLnTreNode 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 WsLnTreParentLesser(BYVAL n AS WsLnTreNode 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: WsLnTreRotateLeft (Corrected Return Value)
'========================================================
FUNCTION WsLnTreRotateLeft(BYVAL p AS WsLnTre PTR, BYVAL n AS WsLnTreNode PTR) PRIVATE AS LONG
LOCAL nR AS WsLnTreNode PTR ' Right child of n
LOCAL nRL AS WsLnTreNode PTR ' Right child's Left child (for double rotation)
LOCAL newSubtreeRoot AS LONG ' Handle to the node that becomes root of this subtree
nR = @n.R ' Get right child
' Check for Right-Left Case (Double Rotation needed)
IF @nR.HL > @nR.HR THEN
' Perform Rotation Right on nR first
nRL = @nR.L
@n.R = nRL ' n's right child becomes nRL
@nRL.P = n ' nRL's parent becomes n
@nR.L = @nRL.R ' nR's left child becomes nR's old right grandchild
IF @nR.L THEN @nR.@L.P = nR ' Update parent of that grandchild
@nRL.R = nR ' nRL's right child becomes nR
@nR.P = nRL ' nR's parent becomes nRL
' Recalculate heights for nR after its rotation
@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 has been updated locally, update pointer for main rotation
nR = @n.R ' nR now points to nRL (the new right child of n)
END IF
' Perform Rotation Left on n
newSubtreeRoot = nR ' nR (or nRL if double) will be the new root
' Update tree root if n was the root
IF @p.root = n THEN @p.root = nR
' Re-parent nR
@nR.P = @n.P ' nR takes n's old parent
IF @nR.P THEN ' Make old parent point to nR
IF @nR.@P.L = n THEN @nR.@P.L = nR ELSE @nR.@P.R = nR
END IF
' Adjust child pointers
@n.R = @nR.L ' n adopts nR's left child as its right child
IF @n.R THEN @n.@R.P = n ' Update parent of adopted child
@nR.L = n ' n becomes the left child of nR
@n.P = nR ' n's parent becomes nR
' *** Recalculate heights AFTER structure changes
' Height of n (which moved down)
@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)
' Height of nR (the new root of this subtree)
@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)
FUNCTION = newSubtreeRoot ' *** Corrected: Return the NEW root of this subtree ***
END FUNCTION
'========================================================
' FUNCTION: WsLnTreRotateRight (Corrected Return Value)
'========================================================
FUNCTION WsLnTreRotateRight(BYVAL p AS WsLnTre PTR, BYVAL n AS WsLnTreNode PTR) PRIVATE AS LONG
LOCAL nL AS WsLnTreNode PTR ' Left child of n
LOCAL nLR AS WsLnTreNode PTR ' Left child's Right child (for double rotation)
LOCAL newSubtreeRoot AS LONG ' Handle to the node that becomes root of this subtree
nL = @n.L ' Get left child
' Check for Left-Right Case (Double Rotation needed)
IF @nL.HR > @nL.HL THEN
' Perform Rotation Left on nL first
nLR = @nL.R
@n.L = nLR ' n's left child becomes nLR
@nLR.P = n ' nLR's parent becomes n
@nL.R = @nLR.L ' nL's right child becomes nLR's old left grandchild
IF @nL.R THEN @nL.@R.P = nL ' Update parent of that grandchild
@nLR.L = nL ' nLR's left child becomes nL
@nL.P = nLR ' nL's parent becomes nLR
' Recalculate heights for nL after its rotation
@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 has been updated locally, update pointer for main rotation
nL = @n.L ' nL now points to nLR (the new left child of n)
END IF
' Perform Rotation Right on n
newSubtreeRoot = nL ' nL (or nLR if double) will be the new root
' Update tree root if n was the root
IF @p.root = n THEN @p.root = nL
' Re-parent nL
@nL.P = @n.P ' nL takes n's old parent
IF @nL.P THEN ' Make old parent point to nL
IF @nL.@P.L = n THEN @nL.@P.L = nL ELSE @nL.@P.R = nL
END IF
' Adjust child pointers
@n.L = @nL.R ' n adopts nL's right child as its left child
IF @n.L THEN @n.@L.P = n ' Update parent of adopted child
@nL.R = n ' n becomes the right child of nL
@n.P = nL ' n's parent becomes nL
' *** Recalculate heights AFTER structure changes
' Height of n (which moved down)
@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)
' Height of nL (the new root of this subtree)
@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)
FUNCTION = newSubtreeRoot ' *** Corrected: Return the NEW root of this subtree ***
END FUNCTION
To see the original codes fail use this test.
Its very likely that all other Tre-Functions also have the same problem and must get the same fix before using them.
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "..\HLIB3\Tree\WsLnTre.inc"
#INCLUDE "Your Debugger"
' Switches to enable testing different aspects
%DoTreLifeCycleTests = 1
%DoTreSetGetGotTests = 1
%DoTreIterationTests = 1
%DoTreDeleteTests = 1
%DoTreComparisonTests = 1 ' Assumes WsCompare* in WsStr.inc are COMMON
%DoTreCapacityTests = 1
%DoTreCloneTests = 1
%DoTreStoreRestoreTests = 1
' --- Global Test Variables ---
GLOBAL gTreTestCount AS LONG
GLOBAL gTreFailCount AS LONG
' --- Test Reporting Sub ---
' Use the same TestResult SUB as before, just ensure gTreTestCount/gTreFailCount are used.
SUB TestResultTre(BYVAL TestName AS STRING, BYVAL Success AS LONG)
INCR gTreTestCount
IF Success = %FALSE THEN
INCR gTreFailCount
X_AU TestName & ": *** FAIL ***" ' Use X_AU
ELSE
X_AU TestName & ": Pass" ' Use X_AU
END IF
END SUB
' --- Helper Functions ---
' Creates a simple tree for reuse in tests
FUNCTION CreateSimpleTree(compareMode AS LONG) AS LONG
LOCAL hTree AS LONG
LOCAL key AS WSTRING
LOCAL retVal AS LONG
retVal = 0 'Default fail
hTree = WsLnTreNew()
IF hTree = 0 THEN GOTO CreateSimpleExit
IF compareMode = 1 THEN WsLnTreComparison hTree, %TRUE, "" ' Set Case-Insensitive
' Add some keys - order chosen to likely trigger rotations
key = "Mango" : WsLnTreSet hTree, key, 10
key = "Apple" : WsLnTreSet hTree, key, 20
key = "Orange" : WsLnTreSet hTree, key, 30
key = "Banana" : WsLnTreSet hTree, key, 40
key = "Peach" : WsLnTreSet hTree, key, 50
key = "Grape" : WsLnTreSet hTree, key, 60
' Check final count (basic validation)
IF WsLnTreCount(hTree) <> 6 THEN
X_AU "CreateSimpleTree: Incorrect count after adds!"
hTree = WsLnTreFinal(hTree) ' Cleanup on failure
GOTO CreateSimpleExit
END IF
retVal = hTree ' Success
CreateSimpleExit:
FUNCTION = retVal
END FUNCTION
' Verifies iteration order and values
FUNCTION VerifyTreeOrder(BYVAL hTree AS LONG, expectedKeys() AS WSTRING, expectedVals() AS LONG, BYVAL UCASECheck AS LONG) AS LONG
LOCAL i AS LONG
LOCAL hNode AS LONG
LOCAL nodeKey AS WSTRING
LOCAL nodeVal AS LONG
LOCAL result AS LONG
LOCAL numExpected AS LONG
result = %TRUE ' Assume success
numExpected = UBOUND(expectedKeys)
IF UBOUND(expectedVals) <> numExpected THEN
X_AU "VerifyTreeOrder: Key/Value array size mismatch!"
FUNCTION = %FALSE : EXIT FUNCTION
END IF
IF WsLnTreCount(hTree) <> numExpected THEN
X_AU "VerifyTreeOrder: Tree count (" & TRIM$(STR$(WsLnTreCount(hTree))) & ") mismatch expected count(" & STR$(numExpected) & ")"
result = %FALSE
' Continue checks anyway
END IF
' Forward Iteration Check
i = 0
hNode = WsLnTreFirst(hTree)
WHILE hNode
INCR i
IF i > numExpected THEN
X_AU "VerifyTreeOrder: Forward iteration yielded MORE items than expected!"
result = %FALSE : EXIT LOOP
END IF
nodeKey = WsLnTreGetKey(hNode)
nodeVal = WsLnTreGetVal(hNode)
IF UCASECheck THEN
IF UCASE$(nodeKey) <> UCASE$(expectedKeys(i)) OR nodeVal <> expectedVals(i) THEN
X_AU "VerifyTreeOrder: Mismatch Forward Item " & STR$(i) & " - Got '" & nodeKey & "':" & STR$(nodeVal) & ", Expected(UCASE) '" & expectedKeys(i) & "':" & STR$(expectedVals(i))
result = %FALSE
END IF
ELSE
IF nodeKey <> expectedKeys(i) OR nodeVal <> expectedVals(i) THEN
X_AU "VerifyTreeOrder: Mismatch Forward Item " & STR$(i) & " - Got '" & nodeKey & "':" & STR$(nodeVal) & ", Expected '" & expectedKeys(i) & "':" & STR$(expectedVals(i))
result = %FALSE
END IF
END IF
hNode = WsLnTreNext(hNode)
WEND
IF i <> numExpected AND result <> %FALSE THEN
X_AU "VerifyTreeOrder: Forward iteration yielded FEWER items than expected (" & STR$(i) & "/" & STR$(numExpected) & ")"
result = %FALSE
END IF
' Backward Iteration Check (if forward was okay)
IF result = %TRUE THEN
i = numExpected + 1
hNode = WsLnTreLast(hTree)
WHILE hNode
DECR i
IF i < 1 THEN
X_AU "VerifyTreeOrder: Backward iteration yielded MORE items than expected!"
result = %FALSE : EXIT LOOP
END IF
nodeKey = WsLnTreGetKey(hNode)
nodeVal = WsLnTreGetVal(hNode)
IF UCASECheck THEN
IF UCASE$(nodeKey) <> UCASE$(expectedKeys(i)) OR nodeVal <> expectedVals(i) THEN
X_AU "VerifyTreeOrder: Mismatch Backward Item " & STR$(i) & " - Got '" & nodeKey & "':" & STR$(nodeVal) & ", Expected(UCASE) '" & expectedKeys(i) & "':" & STR$(expectedVals(i))
result = %FALSE
END IF
ELSE
IF nodeKey <> expectedKeys(i) OR nodeVal <> expectedVals(i) THEN
X_AU "VerifyTreeOrder: Mismatch Backward Item " & STR$(i) & " - Got '" & nodeKey & "':" & STR$(nodeVal) & ", Expected '" & expectedKeys(i) & "':" & STR$(expectedVals(i))
result = %FALSE
END IF
END IF
hNode = WsLnTrePrev(hNode)
WEND
IF i <> 1 AND result <> %FALSE THEN
X_AU "VerifyTreeOrder: Backward iteration yielded FEWER items than expected (" & STR$(numExpected-i+1) & "/" & STR$(numExpected) & ")"
result = %FALSE
END IF
END IF
FUNCTION = result
END FUNCTION
' --- Test Subroutines ---
SUB TestTreLifecycle()
LOCAL h1 AS LONG
LOCAL isValid AS LONG
LOCAL COUNT AS LONG
X_AU "-- Tree Lifecycle Tests --"
gTreTestCount = 0 : gTreFailCount = 0
' Test New/Validate/Final
h1 = WsLnTreNew()
TestResultTre("TreLifecycle: WsLnTreNew", IIF(h1 <> 0, %TRUE, %FALSE))
isValid = WsLnTreValidate(h1)
TestResultTre("TreLifecycle: WsLnTreValidate (Valid)", IIF(isValid <> 0, %TRUE, %FALSE))
COUNT = WsLnTreCount(h1)
TestResultTre("TreLifecycle: WsLnTreCount (New)", IIF(COUNT = 0, %TRUE, %FALSE))
h1 = WsLnTreFinal(h1)
TestResultTre("TreLifecycle: WsLnTreFinal", IIF(h1 = 0, %TRUE, %FALSE))
isValid = WsLnTreValidate(h1) ' h1 is 0
TestResultTre("TreLifecycle: WsLnTreValidate (Final)", IIF(isValid = 0, %TRUE, %FALSE))
COUNT = WsLnTreCount(h1) ' Count on NULL handle
TestResultTre("TreLifecycle: WsLnTreCount (Final)", IIF(COUNT = 0, %TRUE, %FALSE))
X_AU "Tree Lifecycle Tests Complete: " & TRIM$(FORMAT$(gTreTestCount-gTreFailCount)) & "/" & TRIM$(FORMAT$(gTreTestCount)) & " Passed."
X_AU ""
END SUB
SUB TestTreSetGetGot()
LOCAL hTree AS LONG
LOCAL key AS WSTRING
LOCAL L02 AS LONG
LOCAL hNodeCheck AS LONG
LOCAL expectVal AS LONG
X_AU "-- Tree Set/Get/Got Tests --"
gTreTestCount = 0 : gTreFailCount = 0
hTree = WsLnTreNew()
TestResultTre("SetGetGot: New", IIF(hTree <> 0, %TRUE, %FALSE))
IF hTree = 0 THEN EXIT SUB
' Add first item
key = "First" : WsLnTreSet hTree, key, 100
TestResultTre("SetGetGot: First Add Count", IIF(WsLnTreCount(hTree) = 1, %TRUE, %FALSE))
L02 = WsLnTreGet(hTree, key)
TestResultTre("SetGetGot: First Get Value", IIF(L02 = 100, %TRUE, %FALSE))
hNodeCheck = WsLnTreGot(hTree, key)
TestResultTre("SetGetGot: First Got Handle", IIF(hNodeCheck <> 0, %TRUE, %FALSE))
' Add second item
key = "Second" : WsLnTreSet hTree, key, 200
TestResultTre("SetGetGot: Second Add Count", IIF(WsLnTreCount(hTree) = 2, %TRUE, %FALSE))
L02 = WsLnTreGet(hTree, key)
TestResultTre("SetGetGot: Second Get Value", IIF(L02 = 200, %TRUE, %FALSE))
hNodeCheck = WsLnTreGot(hTree, key)
TestResultTre("SetGetGot: Second Got Handle", IIF(hNodeCheck <> 0, %TRUE, %FALSE))
' Get first item again
key = "First" : L02 = WsLnTreGet(hTree, key)
TestResultTre("SetGetGot: First Get Again Value", IIF(L02 = 100, %TRUE, %FALSE))
' Replace existing item
key = "First" : WsLnTreSet hTree, key, 150 ' Replace value
TestResultTre("SetGetGot: Replace Count", IIF(WsLnTreCount(hTree) = 2, %TRUE, %FALSE))
L02 = WsLnTreGet(hTree, key)
TestResultTre("SetGetGot: Replace Get Value", IIF(L02 = 150, %TRUE, %FALSE))
' Try replace with DontReplace = TRUE
key = "First" : expectVal = 150 : WsLnTreSet hTree, key, 999, %TRUE ' DontReplace
TestResultTre("SetGetGot: DontReplace Count", IIF(WsLnTreCount(hTree) = 2, %TRUE, %FALSE))
L02 = WsLnTreGet(hTree, key)
TestResultTre("SetGetGot: DontReplace Get Value", IIF(L02 = expectVal, %TRUE, %FALSE))
' Get non-existent key
key = "Missing"
L02 = WsLnTreGet(hTree, key)
TestResultTre("SetGetGot: Get Missing Value", IIF(L02 = 0, %TRUE, %FALSE)) ' Expect 0
hNodeCheck = WsLnTreGot(hTree, key)
TestResultTre("SetGetGot: Got Missing Handle", IIF(hNodeCheck = 0, %TRUE, %FALSE)) ' Expect 0
hTree = WsLnTreFinal(hTree)
TestResultTre("SetGetGot: Final", IIF(hTree = 0, %TRUE, %FALSE))
X_AU "Tree Set/Get/Got Tests Complete: " & TRIM$(FORMAT$(gTreTestCount-gTreFailCount)) & "/" & TRIM$(FORMAT$(gTreTestCount)) & " Passed."
X_AU ""
END SUB
SUB TestTreIteration()
LOCAL hTree AS LONG
LOCAL hNode AS LONG
LOCAL key AS WSTRING
LOCAL L02 AS LONG
DIM expectedKeys(1 TO 6) AS WSTRING
DIM expectedVals(1 TO 6) AS LONG
X_AU "-- Tree Iteration Tests --"
gTreTestCount = 0 : gTreFailCount = 0
' Test Empty Tree
hTree = WsLnTreNew()
TestResultTre("Iterate: New Empty", IIF(hTree <> 0, %TRUE, %FALSE))
IF hTree = 0 THEN EXIT SUB
hNode = WsLnTreFirst(hTree)
TestResultTre("Iterate: First (Empty)", IIF(hNode=0, %TRUE, %FALSE))
hNode = WsLnTreLast(hTree)
TestResultTre("Iterate: Last (Empty)", IIF(hNode=0, %TRUE, %FALSE))
WsLnTreClear hTree ' Test Clear on empty
TestResultTre("Iterate: Clear (Empty)", IIF(WsLnTreCount(hTree)=0, %TRUE, %FALSE))
hTree = WsLnTreFinal(hTree)
' Test Single Item Tree
hTree = WsLnTreNew()
TestResultTre("Iterate: New Single", IIF(hTree <> 0, %TRUE, %FALSE))
IF hTree = 0 THEN EXIT SUB
key = "Only" : WsLnTreSet hTree, key, 5
hNode = WsLnTreFirst(hTree)
TestResultTre("Iterate: First (Single)", IIF(hNode<>0, %TRUE, %FALSE))
IF hNode <> 0 THEN
TestResultTre("Iterate: First Key (Single)", IIF(WsLnTreGetKey(hNode)="Only", %TRUE, %FALSE))
TestResultTre("Iterate: First Value (Single)", IIF(WsLnTreGetVal(hNode)=5, %TRUE, %FALSE))
TestResultTre("Iterate: Next (Single)", IIF(WsLnTreNext(hNode)=0, %TRUE, %FALSE))
END IF
hNode = WsLnTreLast(hTree)
TestResultTre("Iterate: Last (Single)", IIF(hNode<>0, %TRUE, %FALSE))
IF hNode <> 0 THEN
TestResultTre("Iterate: Prev (Single)", IIF(WsLnTrePrev(hNode)=0, %TRUE, %FALSE))
END IF
hTree = WsLnTreFinal(hTree)
' Test Multi-Item Tree (Case-Sensitive Default)
hTree = CreateSimpleTree(0) ' Use helper, case-sensitive
TestResultTre("Iterate: Create Multi", IIF(hTree <> 0, %TRUE, %FALSE))
IF hTree = 0 THEN EXIT SUB
' Expected order (Alphabetical)
expectedKeys(1) = "Apple" : expectedVals(1) = 20
expectedKeys(2) = "Banana" : expectedVals(2) = 40
expectedKeys(3) = "Grape" : expectedVals(3) = 60
expectedKeys(4) = "Mango" : expectedVals(4) = 10
expectedKeys(5) = "Orange" : expectedVals(5) = 30
expectedKeys(6) = "Peach" : expectedVals(6) = 50
TestResultTre("Iterate: Verify Order Multi (Case-Sensitive)", VerifyTreeOrder(hTree, expectedKeys(), expectedVals(), %FALSE))
hTree = WsLnTreFinal(hTree)
X_AU "Tree Iteration Tests Complete: " & TRIM$(FORMAT$(gTreTestCount-gTreFailCount)) & "/" & TRIM$(FORMAT$(gTreTestCount)) & " Passed."
X_AU ""
END SUB
SUB TestTreDelete()
LOCAL hTree AS LONG
LOCAL key AS WSTRING
LOCAL COUNT AS LONG
LOCAL hNodeCheck AS LONG
DIM expectedKeys() AS WSTRING
DIM expectedVals() AS LONG
X_AU "-- Tree Deletion Tests --"
gTreTestCount = 0 : gTreFailCount = 0
' Create simple tree
hTree = CreateSimpleTree(0) ' Case-sensitive
TestResultTre("Delete: Create Tree", IIF(hTree <> 0, %TRUE, %FALSE))
IF hTree = 0 THEN EXIT SUB
' Delete non-existent key
key = "Watermelon" : WsLnTreDel hTree, key
COUNT = WsLnTreCount(hTree)
TestResultTre("Delete: Delete Non-existent Count", IIF(COUNT = 6, %TRUE, %FALSE))
' Delete leaf node ("Apple")
key = "Apple" : WsLnTreDel hTree, key
TestResultTre("Delete: Delete Leaf Count", IIF(WsLnTreCount(hTree) = 5, %TRUE, %FALSE))
hNodeCheck = WsLnTreGot(hTree, key)
TestResultTre("Delete: Delete Leaf Got", IIF(hNodeCheck = 0, %TRUE, %FALSE))
REDIM expectedKeys(1 TO 5) : REDIM expectedVals(1 TO 5)
expectedKeys(1) = "Banana" : expectedVals(1) = 40
expectedKeys(2) = "Grape" : expectedVals(2) = 60
expectedKeys(3) = "Mango" : expectedVals(3) = 10
expectedKeys(4) = "Orange" : expectedVals(4) = 30
expectedKeys(5) = "Peach" : expectedVals(5) = 50
TestResultTre("Delete: Verify Order After Leaf Delete", VerifyTreeOrder(hTree, expectedKeys(), expectedVals(), %FALSE))
' Delete node with one child (e.g., delete "Peach" - requires adding another element first maybe?)
' Let's delete "Orange" which likely has one child ("Peach"?) after rotations
key = "Orange" : WsLnTreDel hTree, key
TestResultTre("Delete: Delete Node w/ Child Count", IIF(WsLnTreCount(hTree) = 4, %TRUE, %FALSE))
hNodeCheck = WsLnTreGot(hTree, key)
TestResultTre("Delete: Delete Node w/ Child Got", IIF(hNodeCheck = 0, %TRUE, %FALSE))
REDIM expectedKeys(1 TO 4) : REDIM expectedVals(1 TO 4)
expectedKeys(1) = "Banana" : expectedVals(1) = 40
expectedKeys(2) = "Grape" : expectedVals(2) = 60
expectedKeys(3) = "Mango" : expectedVals(3) = 10
expectedKeys(4) = "Peach" : expectedVals(4) = 50
TestResultTre("Delete: Verify Order After One Child Delete", VerifyTreeOrder(hTree, expectedKeys(), expectedVals(), %FALSE))
' Delete node with two children (e.g., delete "Mango" if root)
key = "Mango" : WsLnTreDel hTree, key
TestResultTre("Delete: Delete Root/Node w/ 2 Children Count", IIF(WsLnTreCount(hTree) = 3, %TRUE, %FALSE))
hNodeCheck = WsLnTreGot(hTree, key)
TestResultTre("Delete: Delete Root/Node w/ 2 Children Got", IIF(hNodeCheck = 0, %TRUE, %FALSE))
REDIM expectedKeys(1 TO 3) : REDIM expectedVals(1 TO 3)
expectedKeys(1) = "Banana" : expectedVals(1) = 40 ' Order might depend on rotation logic
expectedKeys(2) = "Grape" : expectedVals(2) = 60
expectedKeys(3) = "Peach" : expectedVals(3) = 50
TestResultTre("Delete: Verify Order After Two Child Delete", VerifyTreeOrder(hTree, expectedKeys(), expectedVals(), %FALSE))
' Delete remaining
key = "Grape" : WsLnTreDel hTree, key
key = "Peach" : WsLnTreDel hTree, key
key = "Banana" : WsLnTreDel hTree, key
TestResultTre("Delete: Delete All Remaining", IIF(WsLnTreCount(hTree) = 0, %TRUE, %FALSE))
hTree = WsLnTreFinal(hTree)
TestResultTre("Delete: Final", IIF(hTree = 0, %TRUE, %FALSE))
X_AU "Tree Deletion Tests Complete: " & TRIM$(FORMAT$(gTreTestCount-gTreFailCount)) & "/" & TRIM$(FORMAT$(gTreTestCount)) & " Passed."
X_AU ""
END SUB
SUB TestTreComparison()
LOCAL hTree AS LONG
LOCAL key1 AS WSTRING
LOCAL key2 AS WSTRING
LOCAL key3 AS WSTRING
LOCAL hNodeCheck AS LONG
X_AU "-- Tree Comparison Tests --"
gTreTestCount = 0 : gTreFailCount = 0
hTree = WsLnTreNew()
TestResultTre("Compare: New", IIF(hTree <> 0, %TRUE, %FALSE))
IF hTree=0 THEN EXIT SUB
' Default is Case Sensitive (WsCompare)
key1 = "KeY" : WsLnTreSet hTree, key1, 1
key2 = "key" : WsLnTreSet hTree, key2, 2
key3 = "KEY" : WsLnTreSet hTree, key3, 3
TestResultTre("Compare: Case-Sensitive Add Count", IIF(WsLnTreCount(hTree) = 3, %TRUE, %FALSE))
TestResultTre("Compare: Case-Sensitive Get 'KeY'", IIF(WsLnTreGet(hTree, key1)=1, %TRUE, %FALSE))
TestResultTre("Compare: Case-Sensitive Get 'key'", IIF(WsLnTreGet(hTree, key2)=2, %TRUE, %FALSE))
TestResultTre("Compare: Case-Sensitive Get 'KEY'", IIF(WsLnTreGet(hTree, key3)=3, %TRUE, %FALSE))
' Change to Case Insensitive
WsLnTreComparison hTree, %TRUE, "" ' Set UCase comparison
TestResultTre("Compare: Set Case-Insensitive", %TRUE) ' Assumes no error
' Try adding again - should replace/fail based on DontReplace (default is replace)
key1 = "kEy" : WsLnTreSet hTree, key1, 4
TestResultTre("Compare: Case-Insensitive Replace Count", IIF(WsLnTreCount(hTree) = 3, %TRUE, %FALSE)) ' Count shouldn't change
' Which one did it replace? Depends on tree structure/ comparison result of "kEy" vs existing. Let's check Got
key1="KeY": hNodeCheck = WsLnTreGot(hTree, key1)
TestResultTre("Compare: Case-Insensitive Got 'KeY'", IIF(hNodeCheck <> 0, %TRUE, %FALSE)) 'Should find *an* entry
IF hNodeCheck <> 0 THEN TestResultTre("Compare: Case-Insensitive Check Final Value", IIF(WsLnTreGetVal(hNodeCheck)=4, %TRUE, %FALSE))
hTree = WsLnTreFinal(hTree)
TestResultTre("Compare: Final", IIF(hTree = 0, %TRUE, %FALSE))
X_AU "Tree Comparison Tests Complete: " & TRIM$(FORMAT$(gTreTestCount-gTreFailCount)) & "/" & TRIM$(FORMAT$(gTreTestCount)) & " Passed."
X_AU ""
END SUB
SUB TestTreCapacity()
LOCAL hTree AS LONG
LOCAL i AS LONG
LOCAL keyBase AS WSTRING
LOCAL key AS WSTRING
LOCAL L02 AS LONG
LOCAL hNode AS LONG
LOCAL numItems AS LONG : numItems = 10000 ' Number of items for stress test
DIM keysToDel() AS WSTRING
X_AU "-- Tree Capacity Tests --"
gTreTestCount = 0 : gTreFailCount = 0
' --- Test 1: Add Many Items ---
X_AU "Capacity: Adding " & TRIM$(STR$(numItems)) & " items..."
hTree = WsLnTreNew()
TestResultTre("Capacity: AddMany - New", IIF(hTree <> 0, %TRUE, %FALSE))
IF hTree = 0 THEN GOTO CapacityExit_Tre
keyBase = "Key_"
FOR i = 1 TO numItems
key = keyBase & FORMAT$(i, "00000") ' Create unique keys
WsLnTreSet hTree, key, i
IF (i MOD 1000) = 0 AND WsLnTreCount(hTree) <> i THEN
TestResultTre("Capacity: AddMany - Count mismatch at " & STR$(i), %FALSE)
GOTO CapacityCleanup_Tre ' Stop test if count wrong
END IF
NEXT i
TestResultTre("Capacity: AddMany - Final Count", IIF(WsLnTreCount(hTree) = numItems, %TRUE, %FALSE))
' --- Test 2: Get Many Items ---
X_AU "Capacity: Getting " & TRIM$(STR$(numItems)) & " items..."
FOR i = 1 TO numItems
key = keyBase & FORMAT$(i, "00000")
L02 = WsLnTreGet(hTree,key)
IF L02 <> i THEN
TestResultTre("Capacity: GetMany - Value mismatch for key " & key, %FALSE)
' Don't exit, allows seeing multiple errors
END IF
NEXT i
TestResultTre("Capacity: GetMany - Finished Gets (Check log for fails)", %TRUE) ' Assume loop ok if no hard exit
' --- Test 3: Iterate Large Tree (Check First/Last/Count) ---
X_AU "Capacity: Iterating " & TRIM$(STR$(numItems)) & " items..."
LOCAL firstKey AS WSTRING, lastKey AS WSTRING, firstVal AS LONG, lastVal AS LONG, iterCount AS LONG
hNode = WsLnTreFirst(hTree)
IF hNode THEN firstKey = WsLnTreGetKey(hNode) : firstVal = WsLnTreGetVal(hNode) ELSE firstKey="" : firstVal = -1
hNode = WsLnTreLast(hTree)
IF hNode THEN lastKey = WsLnTreGetKey(hNode) : lastVal = WsLnTreGetVal(hNode) ELSE lastKey="" : lastVal = -1
' Expected keys depend on comparison - assumes standard string compare for Key_00001 vs Key_10000
TestResultTre("Capacity: Iterate - First Key Check", IIF(firstKey = "Key_00001", %TRUE, %FALSE))
TestResultTre("Capacity: Iterate - Last Key Check", IIF(lastKey = "Key_10000", %TRUE, %FALSE))
iterCount = 0 : hNode = WsLnTreFirst(hTree)
WHILE hNode
INCR iterCount
hNode = WsLnTreNext(hNode)
WEND
TestResultTre("Capacity: Iterate - Iteration Count", IIF(iterCount = numItems, %TRUE, %FALSE))
' --- Test 4: Delete Many Items ---
X_AU "Capacity: Deleting ~half (" & TRIM$(STR$(numItems \ 2)) & ") items..."
REDIM keysToDel(1 TO numItems \ 2)
FOR i = 1 TO numItems STEP 2 ' Delete odd keys
key = keyBase & FORMAT$(i, "00000")
WsLnTreDel hTree, key
IF (i MOD 1001)=0 AND WsLnTreGot(hTree,key)<>0 THEN ' Check occasionally
TestResultTre("Capacity: DeleteMany - Failed delete for key " & key, %FALSE)
END IF
NEXT i
L02 = numItems - (numItems \ 2) ' Expected remaining count
TestResultTre("Capacity: DeleteMany - Final Count", IIF(WsLnTreCount(hTree) = L02, %TRUE, %FALSE))
' Verify a deleted key is gone and an existing key remains
key = "Key_00001" : hNode = WsLnTreGot(hTree, key)
TestResultTre("Capacity: DeleteMany - Check Deleted Key Gone", IIF(hNode = 0, %TRUE, %FALSE))
key = "Key_00002" : hNode = WsLnTreGot(hTree, key)
TestResultTre("Capacity: DeleteMany - Check Remaining Key Exists", IIF(hNode <> 0, %TRUE, %FALSE))
' --- Test 5: Clear Large Tree ---
X_AU "Capacity: Clearing remaining items..."
WsLnTreClear hTree
TestResultTre("Capacity: ClearLarge Count", IIF(WsLnTreCount(hTree) = 0, %TRUE, %FALSE))
hNode = WsLnTreFirst(hTree)
TestResultTre("Capacity: ClearLarge First", IIF(hNode = 0, %TRUE, %FALSE))
CapacityCleanup_Tre:
IF hTree <> 0 THEN hTree = WsLnTreFinal(hTree)
TestResultTre("Capacity: Final Cleanup", IIF(hTree = 0, %TRUE, %FALSE))
CapacityExit_Tre:
X_AU "Tree Capacity Tests Complete: " & TRIM$(FORMAT$(gTreTestCount-gTreFailCount)) & "/" & TRIM$(FORMAT$(gTreTestCount)) & " Passed."
X_AU ""
END SUB
SUB TestTreClone()
LOCAL hOrig AS LONG
LOCAL hClone AS LONG
LOCAL key AS WSTRING
LOCAL VALO AS LONG, valC AS LONG
LOCAL countO AS LONG, countC AS LONG
X_AU "-- Tree Clone Tests --"
gTreTestCount = 0 : gTreFailCount = 0
hOrig = CreateSimpleTree(0) ' Case-sensitive
TestResultTre("Clone: Create Original", IIF(hOrig <> 0, %TRUE, %FALSE))
IF hOrig = 0 THEN EXIT SUB
hClone = WsLnTreClone(hOrig)
TestResultTre("Clone: WsLnTreClone called", IIF(hClone <> 0, %TRUE, %FALSE))
IF hClone = 0 THEN hOrig = WsLnTreFinal(hOrig) : EXIT SUB
' Check counts
countO = WsLnTreCount(hOrig)
countC = WsLnTreCount(hClone)
TestResultTre("Clone: Initial Counts Match", IIF(countO=countC AND countO=6, %TRUE, %FALSE))
' Check value retrieval matches
key = "Mango"
valO = WsLnTreGet(hOrig, key)
valC = WsLnTreGet(hClone, key)
TestResultTre("Clone: Initial Get Match", IIF(valO=valC AND valO=10, %TRUE, %FALSE))
' Modify original, check clone unchanged
key = "Mango" : WsLnTreSet hOrig, key, 111
valO = WsLnTreGet(hOrig, key)
valC = WsLnTreGet(hClone, key) ' Get from clone *after* modifying original
TestResultTre("Clone: Modify Original - Check Original", IIF(valO=111, %TRUE, %FALSE))
TestResultTre("Clone: Modify Original - Check Clone Unchanged", IIF(valC=10, %TRUE, %FALSE))
' Modify clone, check original unchanged
key = "Apple" : WsLnTreSet hClone, key, 222
valO = WsLnTreGet(hOrig, key) ' Get from original *after* modifying clone
valC = WsLnTreGet(hClone, key)
TestResultTre("Clone: Modify Clone - Check Clone", IIF(valC=222, %TRUE, %FALSE))
TestResultTre("Clone: Modify Clone - Check Original Unchanged", IIF(valO=20, %TRUE, %FALSE))
' Add to original only
key = "Kiwi" : WsLnTreSet hOrig, key, 70
TestResultTre("Clone: Add Original - Count Orig", IIF(WsLnTreCount(hOrig)=7, %TRUE, %FALSE))
TestResultTre("Clone: Add Original - Count Clone", IIF(WsLnTreCount(hClone)=6, %TRUE, %FALSE))
CloneCleanup:
hOrig = WsLnTreFinal(hOrig)
hClone = WsLnTreFinal(hClone)
TestResultTre("Clone: Cleanup Final", IIF(hOrig = 0 AND hClone = 0, %TRUE, %FALSE))
X_AU "Tree Clone Tests Complete: " & TRIM$(FORMAT$(gTreTestCount-gTreFailCount)) & "/" & TRIM$(FORMAT$(gTreTestCount)) & " Passed."
X_AU ""
END SUB
'########################################################################
' SUB: TestTreStoreRestore
'------------------------------------------------------------------------
' Purpose: Tests WsLnTreStore and WsLnTreRestore functions.
'########################################################################
SUB TestTreStoreRestore()
LOCAL hOrig AS LONG
LOCAL hRestore AS LONG
LOCAL sStore AS STRING
DIM expectedKeys(1 TO 6) AS WSTRING
DIM expectedVals(1 TO 6) AS LONG
X_AU "-- Tree Store/Restore Tests --"
gTreTestCount = 0 : gTreFailCount = 0
hOrig = CreateSimpleTree(0) ' Case-sensitive
TestResultTre("StoreRestore: Create Original", IIF(hOrig <> 0, %TRUE, %FALSE))
IF hOrig = 0 THEN EXIT SUB
' Store
ERR = 0 ' Optional: Clear ERR before calling function that might set it
sStore = WsLnTreStore(hOrig)
TestResultTre("StoreRestore: Store executed (Len=" & STR$(LEN(sStore)) & ")", IIF(LEN(sStore)>0 AND ERR = 0, %TRUE, %FALSE)) ' Check ERR also
' Create new, restore into it
hRestore = WsLnTreNew()
TestResultTre("StoreRestore: New Restore Target", IIF(hRestore <> 0, %TRUE, %FALSE))
IF hRestore = 0 THEN
hOrig = WsLnTreFinal(hOrig)
EXIT SUB
END IF
ERR = 0 ' Clear ERR before restore
WsLnTreRestore hRestore, sStore
' *** CORRECTED LINE: Check ERR, not W_JSON_GetLastError ***
TestResultTre("StoreRestore: Restore executed", IIF(ERR = 0, %TRUE, %FALSE)) ' Check HLib Error via ERR
' Verify restored tree (only if restore reported no error)
IF ERR = 0 THEN
TestResultTre("StoreRestore: Restored Count", IIF(WsLnTreCount(hRestore) = 6, %TRUE, %FALSE))
expectedKeys(1) = "Apple" : expectedVals(1) = 20
expectedKeys(2) = "Banana" : expectedVals(2) = 40
expectedKeys(3) = "Grape" : expectedVals(3) = 60
expectedKeys(4) = "Mango" : expectedVals(4) = 10
expectedKeys(5) = "Orange" : expectedVals(5) = 30
expectedKeys(6) = "Peach" : expectedVals(6) = 50
TestResultTre("StoreRestore: Verify Restored Order", VerifyTreeOrder(hRestore, expectedKeys(), expectedVals(), %FALSE))
ELSE
X_AU "StoreRestore: Skipping verification due to restore error (ERR=" & STR$(ERR) & ")"
INCR gTreFailCount ' Count verification as failed if restore failed
INCR gTreTestCount ' Account for the skipped verification test
END IF
' Restore into original after clearing
WsLnTreClear hOrig
TestResultTre("StoreRestore: Clear Original Count", IIF(WsLnTreCount(hOrig)=0, %TRUE, %FALSE))
ERR = 0 ' Clear ERR before restore
WsLnTreRestore hOrig, sStore
' *** CORRECTED LINE: Check ERR, not W_JSON_GetLastError ***
TestResultTre("StoreRestore: Restore into Original executed", IIF(ERR = 0, %TRUE, %FALSE))
IF ERR = 0 THEN
TestResultTre("StoreRestore: Restore into Original Count", IIF(WsLnTreCount(hOrig) = 6, %TRUE, %FALSE))
TestResultTre("StoreRestore: Verify Restore into Original Order", VerifyTreeOrder(hOrig, expectedKeys(), expectedVals(), %FALSE))
ELSE
X_AU "StoreRestore: Skipping verification due to restore error (ERR=" & STR$(ERR) & ")"
INCR gTreFailCount ' Count verification as failed if restore failed
gTreTestCount+=2 ' Account for the two skipped verification tests
END IF
StoreRestoreCleanup_TSR: ' Renamed Label
hOrig = WsLnTreFinal(hOrig)
hRestore = WsLnTreFinal(hRestore)
TestResultTre("StoreRestore: Cleanup Final", IIF(hOrig = 0 AND hRestore = 0, %TRUE, %FALSE))
X_AU "Tree Store/Restore Tests Complete: " & TRIM$(FORMAT$(gTreTestCount-gTreFailCount)) & "/" & TRIM$(FORMAT$(gTreTestCount)) & " Passed."
X_AU ""
END SUB
' --- Main Program ---
FUNCTION PBMAIN()
X_AU "Starting WsLnTre Container Test Suite..." ' Use X_AU
X_AU "=====================================" ' Use X_AU
IF %DoTreLifeCycleTests = 1 THEN TestTreLifecycle()
IF %DoTreSetGetGotTests = 1 THEN TestTreSetGetGot()
IF %DoTreIterationTests = 1 THEN TestTreIteration()
IF %DoTreDeleteTests = 1 THEN TestTreDelete()
IF %DoTreComparisonTests = 1 THEN TestTreComparison()
IF %DoTreCapacityTests = 1 THEN TestTreCapacity()
IF %DoTreCloneTests = 1 THEN TestTreClone()
IF %DoTreStoreRestoreTests = 1 THEN TestTreStoreRestore()
X_AU "=====================================" ' Use X_AU
X_AU "Test Suite Finished." ' Use X_AU
?"!"
END FUNCTION