The collection must be persistent in order to iterate over it persistent in order to iterate over it. I chose to keep it static to confine it to this function but that is up for debate.
The collection must be persistent in order to iterate over it. I chose to keep it static to confine it to this function but that is up for debate.
The collection must be persistent in order to iterate over it. I chose to keep it static to confine it to this function but that is up for debate.
Immutable Linked List in VBA
I made an immutable list class using the head-tail idiom. If I did this correctly, it implements persistent data structures. Unfortunately it doesn't scale well as VBA is not tail recursive. Note: I use a method called seq.Assign to handle assigning objects without using Set. I would like to copy the objects and preserve immutability but for now; if you build a List of mutable objects and mutate one of those objects it will mutate the contents of that list and any list built from that list.
Let's get some basics out of the way.
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "SList"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True ' Client code cannot use `new` Keyword
Attribute VB_Exposed = True
Option Explicit
Private Members
Private TypedName As String
Private pHead As Variant
Private pTail As SList
TypeChecking
SList is also strongly typed using the following methods and boilerplate code
''
' TypeCheck:
Friend Sub TypeCheck(ByVal element As Variant, ByVal source As String)
If TypedName = vbNullString Then TypedName = TypeName(element)
If (TypeName(element) <> TypedName) Then RaiseTypeError element, source
End Sub
''
' RaiseTypeError:
Private Sub RaiseTypeError(ByVal badItem As Variant, ByVal method As String)
Err.Raise 13, method, "Element is of type " & TypeName(badItem) & _
", not " & TypedName & "."
End Sub
Private Sub RaiseEmptyError(ByVal method As String)
Err.Raise 9, TypeName(Me) & "." & method, method & " cannot be called on Empty List!"
End Sub
Private Sub RaiseOutOfRangeError(Byval method As String)
Err.Raise 9, TypeName(Me) & "." & method, method & " Index is out of range!"
End Sub
Friend Methods (mutability)
These methods violate mutability and should only be used carefully in constructor functions.
Friend Property Let Head(ByVal x As Variant)
TypeCheck x, "Head"
seq.Assign pHead, x
End Property
Friend Property Set refEnd(ByRef that As SList)
If pTail Is Nothing Then
Set pTail = that
ElseIf pTail.IsNil Then
Set pTail = that
Else
Set pTail.refEnd = that
End If
End Property
Note refEnd goes to the entire end of the list.
Iteration
The collection must be persistent in order to iterate over it. I chose to keep it static to confine it to this function but that is up for debate.
Public Property Get NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
Static tempCollection As Collection
If tempCollection Is Nothing Then Set tempCollection = ToCollection
Set NewEnum = tempCollection.[_NewEnum]
End Property
Constructors
Client Code will need to use these to create a new SList object
Basic
Public Function Nil() As SList
Set Nil = New SList
End Function
Public Function Node(ByVal elem As Variant) As SList
Set Node = Cons(elem, Nil)
End Function
Public Function Cons(ByVal hd As Variant, ByRef tl As SList) As SList
If Not tl.IsNil Then tl.TypeCheck hd, "Cons"
Dim made As New SList
made.Head = hd
Set made.refEnd = tl
Set Cons = made
End Function
Convenience
Public Function Create(ParamArray args() As Variant) As SList
Set Create = Copy(args)
End Function
Public Function Copy(ByVal sequence As Variant) As SList
Dim result As SList
Set result = Nil
Dim element As Variant
For Each element In sequence
If result.IsNil Then
Set result = Node(element)
Else
Set result.refEnd = Node(element)
End If
Next
Set Copy = result
End Function
Copy is essential because I use it to copy existing instances as shown in the following Append and Concat.
Builders
I am unsure if my usage of Copy and refEnd as shortcuts is acceptable.
Public Function Prepend(ByVal elem As Variant) As SList
TypeCheck elem, "Prepend"
Set Prepend = Cons(elem, Me)
End Function
Public Function Append(ByVal elem As Variant) As SList
TypeCheck elem, "Append"
Set Append = Copy(Me)
Set Append.refEnd = Node(elem)
End Function
Public Function Concat(ByVal that As SList) As SList
TypeCheck that.Head, "Concat"
Set Concat = Copy(that)
Set Concat.refEnd = Me
End Function
Properties
Primitive
Public Property Get IsNil() As Boolean
IsNil = IsEmpty(pHead)
End Property
Public Property Get Head() As Variant
If IsNil Then
RaiseEmptyError "Head"
Else
seq.Assign Head, pHead
End If
End Property
Public Property Get Tail() As SList
If IsNil Then
RaiseEmptyError "Tail"
Else
Set Tail = pTail
End If
End Property
Non Primitive
Public Property Get Last() As Variant
If IsNil Then
RaiseEmptyError "Last"
ElseIf pTail.IsNil Then
seq.Assign Last, pHead
Else
seq.Assign Last, pTail.Last
End If
End Property
Public Property Get Init() As SList
If IsNil Then
RaiseEmptyError "Init"
ElseIf pTail.IsNil Then
Set Init = Nil
Else
Set Init = pTail.Init.Prepend(pHead)
End If
End Property
Public Property Get Length() As Long
If IsNil Then
Length = 0
Else
Length = 1 + pTail.Length
End If
End Property
Public Property Get Max() As Variant
If IsNil Then
Set Max = Nothing
ElseIf pTail.IsNil Then
seq.Assign Max, pHead
Else
Dim other As Variant
seq.Assign other, pTail.Max
seq.Assign Max, IIf(pHead > other, pHead, other)
End If
End Property
Public Property Get Min() As Variant
If IsNil Then
Set Min = Nothing
ElseIf pTail.IsNil Then
seq.Assign Min, pHead
Else
Dim other As Variant
seq.Assign other, pTail.Min
seq.Assign Min, IIf(pHead < other, pHead, other)
End If
End Property
Public Property Get Reverse() As SList
If pTail.IsNil Then
Set Reverse = Me
Else
Set Reverse = Node(pHead).Concat(pTail.Reverse)
End If
End Property
Public Property Get ToArray() As Variant()
Dim size As Long
size = Length
Dim a() As Variant
ReDim a(size - 1) As Variant
BuildArray a, 0
ToArray = a
End Sub
Friend Sub BuildArray(ByRef a() As Variant, ByVal index As Long)
If Not IsNil Then
a(index) = pHead
pTail.BuildArray a, index + 1
End If
End Sub
Public Property Get ToCollection() As Collection
Dim result As New Collection
Dim elem As Variant
For Each elem In ToArray
result.Add elem
Next elem
Set ToCollection = result
End Property
Functions
Public Property Get Item(ByVal n As Long) As Variant
If n = 0 Then
seq.Assign Item, pHead
ElseIf pTail.IsNil Then
RaiseOutOfRangeError("Item")
Else
seq.Assign Item, pTail.Item(n - 1)
End If
End Property
Public Function Take(ByVal n As Long) As SList
If IsNil Or n <= 0 Then
Set Take = Nil
Else
Set Take = pTail.Take(n - 1).Prepend(pHead)
End If
End Function
Public Function TakeLeft(ByVal n As Long) As SList
Set TakeLeft = Drop(Length - n)
End Function
Public Function Drop(ByVal n As Long) As SList
If n <= 0 Or IsNil Then
Set Drop = Me
Else
Set Drop = pTail.Drop(n - 1)
End If
End Function
Public Function DropRight(ByVal n As Long) As SList
Set DropRight = Take(Length - n)
End Function
Public Function DropAt(ByVal n As Long) As SList
Set DropAt = Drop(n).Concat(Take(n - 1))
End Function
Public Function Contains(ByVal elem As Variant) As Boolean
If IsNil Then
Contains = False
ElseIf elem = pHead Then
Contains = True
Else
Contains = pTail.Contains(elem)
End If
End Function
Public Function IndexOf(ByVal elem As Variant) As Long
If pHead = elem Then
IndexOf = 0
ElseIf pTail.IsNil Then
IndexOf = -1
Else
Dim index As Long
index = pTail.IndexOf(elem)
IndexOf = IIf(index = -1, -1, 1 + index)
End If
End Function
Public Function LastIndexOf(ByVal elem As Variant) As Long
LastIndexOf = (Length - 1) - Reverse.IndexOf(elem)
End Function