871 lines
25 KiB
VB.net
871 lines
25 KiB
VB.net
Attribute VB_Name = "stdArray"
|
|
'@TODO:
|
|
'* Implement Exceptions throughout all Array functions.
|
|
'* Fully implement pInitialised where necessary.
|
|
'* Build Methods Slice; Splice; Sort
|
|
'* Add methods from ruby
|
|
'* Documentation of methods
|
|
|
|
#If VBA6 Then
|
|
Private Declare PtrSafe Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As Long)
|
|
#Else
|
|
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
|
|
#End If
|
|
Private Enum SortDirection
|
|
Ascending = 1
|
|
Descending = 2
|
|
End Enum
|
|
Private Type SortStruct
|
|
value As Variant
|
|
sortValue As Variant
|
|
End Type
|
|
|
|
Private pArr() As Variant
|
|
Private pProxyLength As Long
|
|
Private pLength As Long
|
|
|
|
Private pChunking As Long
|
|
Private pInitialised As Boolean
|
|
|
|
|
|
|
|
Public Event BeforeArrLet(ByRef arr As stdArray, ByRef arr As Variant)
|
|
Public Event AfterArrLet(ByRef arr As stdArray, ByRef arr As Variant)
|
|
Public Event BeforeAdd(ByRef arr As stdArray, ByVal iIndex As Long, ByRef item As Variant, ByRef cancel As Boolean)
|
|
Public Event AfterAdd(ByRef arr As stdArray, ByVal iIndex As Long, ByRef item As Variant)
|
|
Public Event BeforeRemove(ByRef arr As stdArray, ByVal iIndex As Long, ByRef item As Variant, ByRef cancel As Boolean)
|
|
Public Event AfterRemove(ByRef arr As stdArray, ByVal iIndex As Long)
|
|
Public Event AfterClone(ByRef Clone As stdArray)
|
|
Public Event AfterCreate(ByRef arr As stdArray)
|
|
|
|
'Create a stdArray object from params
|
|
'@param {paramarray variant()} The items of the array
|
|
'@returns {stdArray<variant>} A stdArray from the parameters.
|
|
Public Function Create(ParamArray params() As Variant) As stdArray
|
|
Set Create = New stdArray
|
|
|
|
Dim i As Long
|
|
Dim lb As Long: lb = LBound(params)
|
|
Dim ub As Long: ub = UBound(params)
|
|
|
|
Call Create.Init(ub - lb + 1, 10)
|
|
|
|
For i = lb To ub
|
|
Call Create.Push(params(i))
|
|
Next
|
|
|
|
'Raise AfterCreate event
|
|
RaiseEvent AfterCreate(Create)
|
|
End Function
|
|
|
|
'Create a stdArray object from params
|
|
'@param {Long} The length of the initial private array created
|
|
'@param {Long} The number of items the private array is increased by when required.
|
|
'@param {paramarray variant()} The items of the array
|
|
'@returns {stdArray<variant>} A stdArray from the parameters.
|
|
Public Function CreateWithOptions(ByVal iInitialLength As Long, ByVal iChunking As Long, ParamArray params() As Variant) As stdArray
|
|
Set CreateWithOptions = New stdArray
|
|
|
|
Dim i As Long
|
|
Dim lb As Long: lb = LBound(params)
|
|
Dim ub As Long: ub = UBound(params)
|
|
|
|
Call CreateWithOptions.Init(iInitialLength, iChunking)
|
|
For i = lb To ub
|
|
Call CreateWithOptions.Push(params(i))
|
|
Next
|
|
|
|
'Raise AfterCreate event
|
|
RaiseEvent AfterCreate(Create)
|
|
End Function
|
|
|
|
'Create a stdArray object from a VBA array
|
|
'@param {variant()} Variant array to create a `stdArray` object from.
|
|
'@returns {stdArray<variant>} Returns `stdArray` of variants.
|
|
Public Function CreateFromArray(ByVal arr As Variant) As stdArray
|
|
Set CreateFromArray = New stdArray
|
|
|
|
Dim i As Long
|
|
Dim lb As Long: lb = LBound(arr)
|
|
Dim ub As Long: ub = UBound(arr)
|
|
Call CreateFromArray.Init(ub - lb + 1, 10)
|
|
|
|
For i = lb To ub
|
|
Call CreateFromArray.Push(arr(i))
|
|
Next
|
|
|
|
'Raise AfterCreate event
|
|
RaiseEvent AfterCreate(Create)
|
|
End Function
|
|
|
|
'Create an array by splitting a string
|
|
'@param {string} Haystack to split
|
|
'@param {string?=","} Delimiter
|
|
'@returns {stdArray<string>} A list of strings
|
|
Public Function CreateFromString(ByVal sHaystack As String, Optional ByVal sDelimiter As String = ",") As stdArray
|
|
Set CreateFromString = CreateFromArray(Split(sHaystack, sDelimiter))
|
|
End Function
|
|
|
|
'Initialise array
|
|
'@param {Long} The length of the initial private array created
|
|
'@param {Long} The number of items the private array is increased by when required.
|
|
Friend Sub Init(ByVal iInitialLength As Long, ByVal iChunking As Long)
|
|
If iChunking > iInitialLength Then iInitialLength = iChunking
|
|
If Not pInitialised Then
|
|
pProxyLength = iInitialLength
|
|
ReDim pArr(1 To iInitialLength) As Variant
|
|
pChunking = iChunking
|
|
pInitialised = True
|
|
End If
|
|
End Sub
|
|
|
|
'Obtain a collection from the data contained within the array. Primarily used for NewEnum() method.
|
|
'@returns {Collection} Collection from Array
|
|
Public Function AsCollection() As collection
|
|
Set AsCollection = New collection
|
|
Dim i As Long
|
|
For i = 1 To Length()
|
|
AsCollection.Add pArr(i)
|
|
Next
|
|
End Function
|
|
|
|
'For-each compatibility
|
|
'@protected
|
|
'@returns {IEnumVARIANT} An enumerator with methods enumNext, enumRefresh etc.
|
|
'@usage `For each obj in myEnum: ... : next`
|
|
'@TODO: Use custom IEnumVARIANT instead of casting to Collection
|
|
Public Property Get NewEnum() As IUnknown
|
|
Static oEnumCol As collection: If oEnumCol Is Nothing Then Set oEnumCol = AsCollection()
|
|
Set NewEnum = oEnumCol.[_NewEnum]
|
|
End Property
|
|
|
|
'Obtain the length of the array
|
|
Public Property Get Length() As Long
|
|
Length = pLength
|
|
End Property
|
|
|
|
'Obtain the length of the private array which stores the data of this array class
|
|
Public Property Get zProxyLength() As Long
|
|
zProxyLength = pProxyLength
|
|
End Property
|
|
|
|
'Resize the array to a length
|
|
'@param {Long} The length of the desired array
|
|
Public Sub Resize(ByVal iLength As Long)
|
|
pLength = iLength
|
|
End Sub
|
|
|
|
'Rechunk the private array to the length / number of items.
|
|
Public Sub Rechunk()
|
|
Dim fNumChunks As Double, iNumChunks As Long
|
|
fNumChunks = pLength / pChunking
|
|
iNumChunks = CLng(fNumChunks)
|
|
If fNumChunks > iNumChunks Then iNumChunks = iNumChunks + 1
|
|
|
|
ReDim Preserve pArr(1 To iNumChunks * pChunking) As Variant
|
|
End Sub
|
|
|
|
|
|
'Sort the array
|
|
'@param {stdICallable<(variant)=>variant>} A mapping function which should map whatever the input is to whatever variant the array should be sorted on.
|
|
'@param {stdICallable<(variant,variant)=>boolean>} Comparrison function which consumes 2 variants and generates a boolean. See implementation of `Sort_QuickSort` for details.
|
|
'@param {long} Currently only 1 algorithm: 0 - Quicksort
|
|
'@param {boolean} Sort the array in place. Sorting in-place is prefferred if possible as it is much more performant.
|
|
'@returns {stdArray<T>}
|
|
Public Function Sort(Optional ByVal cbSortBy As stdICallable = Nothing, Optional ByVal cbComparrason As stdICallable = Nothing, Optional ByVal iAlgorithm As Long = 0, Optional ByVal bSortInPlace As Boolean = False) As stdArray
|
|
If Not bSortInPlace Then
|
|
Set Sort = Clone().Sort(cbSortBy, cbComparrason, iAlgorithm, True)
|
|
Else
|
|
If Length() = 0 Then
|
|
Set Sort = Me
|
|
Exit Function
|
|
End If
|
|
|
|
Dim arr() As SortStruct
|
|
ReDim arr(1 To Length()) As SortStruct
|
|
|
|
Dim i As Long
|
|
|
|
'Copy array to sort structures
|
|
For i = 1 To Length()
|
|
Call CopyVariant(arr(i).value, pArr(i))
|
|
If cbSortBy Is Nothing Then
|
|
Call CopyVariant(arr(i).sortValue, pArr(i))
|
|
Else
|
|
Call CopyVariant(arr(i).sortValue, cbSortBy.Run(pArr(i)))
|
|
End If
|
|
Next
|
|
|
|
'Call sort algorithm
|
|
Select Case iAlgorithm
|
|
Case 0 'QuickSort
|
|
Call Sort_QuickSort(arr, cbComparrason)
|
|
Case Else
|
|
stdError.Raise "Invalid sorting algorithm specified"
|
|
End Select
|
|
|
|
'Copy sort structures to array
|
|
For i = 1 To Length()
|
|
Call CopyVariant(pArr(i), arr(i).value)
|
|
Next
|
|
|
|
'Return array
|
|
Set Sort = Me
|
|
End If
|
|
End Function
|
|
|
|
'QuickSort3
|
|
' Src: https://www.vbforums.com/showthread.php?473677-VB6-Sorting-algorithms-%28sort-array-sorting-arrays%29
|
|
' Omit plngLeft & plngRight; they are used internally during recursion
|
|
Private Sub Sort_QuickSort(ByRef pvarArray() As SortStruct, Optional cbComparrison As stdICallable = Nothing, Optional ByVal plngLeft As Long, Optional ByVal plngRight As Long)
|
|
Dim lngFirst As Long
|
|
Dim lngLast As Long
|
|
Dim varMid As SortStruct
|
|
Dim varSwap As SortStruct
|
|
|
|
If plngRight = 0 Then
|
|
plngLeft = 1
|
|
plngRight = Length()
|
|
End If
|
|
lngFirst = plngLeft
|
|
lngLast = plngRight
|
|
varMid = pvarArray((plngLeft + plngRight) \ 2)
|
|
Do
|
|
If cbComparrison Is Nothing Then
|
|
Do While pvarArray(lngFirst).sortValue < varMid.sortValue And lngFirst < plngRight
|
|
lngFirst = lngFirst + 1
|
|
Loop
|
|
Do While varMid.sortValue < pvarArray(lngLast).sortValue And lngLast > plngLeft
|
|
lngLast = lngLast - 1
|
|
Loop
|
|
Else
|
|
Do While cbComparrison.Run(pvarArray(lngFirst).sortValue, varMid.sortValue) And lngFirst < plngRight
|
|
lngFirst = lngFirst + 1
|
|
Loop
|
|
Do While cbComparrison.Run(varMid.sortValue, pvarArray(lngLast).sortValue) And lngLast > plngLeft
|
|
lngLast = lngLast - 1
|
|
Loop
|
|
End If
|
|
|
|
If lngFirst <= lngLast Then
|
|
varSwap = pvarArray(lngFirst)
|
|
pvarArray(lngFirst) = pvarArray(lngLast)
|
|
pvarArray(lngLast) = varSwap
|
|
lngFirst = lngFirst + 1
|
|
lngLast = lngLast - 1
|
|
End If
|
|
Loop Until lngFirst > lngLast
|
|
If plngLeft < lngLast Then Sort_QuickSort pvarArray, cbComparrison, plngLeft, lngLast
|
|
If lngFirst < plngRight Then Sort_QuickSort pvarArray, cbComparrison, lngFirst, plngRight
|
|
End Sub
|
|
|
|
|
|
|
|
|
|
'Obtain the array as a regular VBA array
|
|
Public Property Get arr() As Variant
|
|
If pLength = 0 Then
|
|
arr = Array()
|
|
Else
|
|
Dim vRet() As Variant
|
|
ReDim vRet(1 To pLength) As Variant
|
|
For i = 1 To pLength
|
|
Call CopyVariant(vRet(i), pArr(i))
|
|
Next
|
|
arr = vRet
|
|
End If
|
|
End Property
|
|
Public Property Let arr(v As Variant)
|
|
RaiseEvent BeforeArrLet(Me, v)
|
|
Dim lb As Long: lb = LBound(v)
|
|
Dim ub As Long: ub = UBound(v)
|
|
Dim cnt As Long: cnt = ub - lb + 1
|
|
ReDim pArr(1 To (Int(cnt / pChunking) + 1) * pChunking) As Variant
|
|
For i = lb To ub
|
|
Call Push(pArr(i))
|
|
Next
|
|
RaiseEvent AfterArrLet(Me, v)
|
|
End Property
|
|
|
|
'Add an element to the end of the array
|
|
'@param {variant} The element to add to the end of the array.
|
|
'@returns {stdArray} me
|
|
'TODO: Add multiple elements with push
|
|
Public Function Push(ByVal el As Variant) As stdArray
|
|
If pInitialised Then
|
|
'Before Add event
|
|
Dim bCancel As Boolean
|
|
RaiseEvent BeforeAdd(Me, pLength + 1, el, bCancel)
|
|
If bCancel Then Exit Function
|
|
|
|
If pLength = pProxyLength Then
|
|
pProxyLength = pProxyLength + pChunking
|
|
ReDim Preserve pArr(1 To pProxyLength) As Variant
|
|
End If
|
|
|
|
pLength = pLength + 1
|
|
CopyVariant pArr(pLength), el
|
|
|
|
'After add event
|
|
RaiseEvent AfterAdd(Me, pLength, pArr(pLength))
|
|
|
|
Set Push = Me
|
|
Else
|
|
'Error
|
|
End If
|
|
End Function
|
|
|
|
'Remove an element from the end of the array
|
|
'@returns {variant} The element removed from the array
|
|
Public Function Pop() As Variant
|
|
If pInitialised Then
|
|
If pLength > 0 Then
|
|
'Raise BeforeRemove event and optionally cancel
|
|
Dim bCancel As Boolean
|
|
RaiseEvent BeforeRemove(Me, pLength, pArr(pLength), bCancel)
|
|
If bCancel Then Exit Function
|
|
|
|
CopyVariant Pop, pArr(pLength)
|
|
pLength = pLength - 1
|
|
|
|
'Raise AfterRemove event
|
|
RaiseEvent AfterRemove(Me, pLength)
|
|
Else
|
|
Pop = Empty
|
|
End If
|
|
Else
|
|
'Error
|
|
End If
|
|
End Function
|
|
|
|
'Remove the ith element from the array
|
|
'@param {Long} Index of the element to remove
|
|
'@returns {Variant} The element removed
|
|
Public Function Remove(ByVal index As Long) As Variant
|
|
'Ensure initialised
|
|
If pInitialised Then
|
|
'Ensure length > 0
|
|
If pLength > 0 Then
|
|
'Ensure index < length
|
|
If index <= pLength Then
|
|
'Raise BeforeRemove event and optionally cancel
|
|
Dim bCancel As Boolean
|
|
RaiseEvent BeforeRemove(Me, index, pArr(index), bCancel)
|
|
If bCancel Then Exit Function
|
|
|
|
'Copy party we are removing to return variable
|
|
CopyVariant Remove, pArr(index)
|
|
|
|
'Loop through array from removal, set i-1th element to ith element
|
|
Dim i As Long
|
|
For i = index + 1 To pLength
|
|
pArr(i - 1) = pArr(i)
|
|
Next
|
|
|
|
'Set last element length and subtract total length by 1
|
|
pArr(pLength) = Empty
|
|
pLength = pLength - 1
|
|
|
|
'Raise after remove event
|
|
RaiseEvent AfterRemove(Me, index)
|
|
Else
|
|
'Error
|
|
End If
|
|
Else
|
|
'Error
|
|
End If
|
|
Else
|
|
'Error
|
|
End If
|
|
End Function
|
|
|
|
'Remove and return element from the start of the array
|
|
'@returns {variant} Element removed
|
|
Public Function Shift() As Variant
|
|
'Would be good to use CopyMemory here
|
|
|
|
CopyVariant Shift, pArr(1)
|
|
Dim i As Long
|
|
For i = 1 To pLength - 1
|
|
pArr(i) = pArr(i + 1)
|
|
Next
|
|
pLength = pLength - 1
|
|
End Function
|
|
|
|
'Insert an element onto the start of the array
|
|
'@param {Variant} Value to append to the start of the array
|
|
'@returns {stdArray} me
|
|
Public Function Unshift(val As Variant) As stdArray
|
|
'Would be good to use CopyMemory here
|
|
|
|
'Before Add event
|
|
Dim bCancel As Boolean
|
|
RaiseEvent BeforeAdd(Me, 1, val, bCancel)
|
|
If bCancel Then Exit Function
|
|
|
|
'Ensure array is big enough and increase pLength
|
|
If pLength = pProxyLength Then
|
|
pProxyLength = pProxyLength + pChunking
|
|
ReDim Preserve pArr(1 To pProxyLength) As Variant
|
|
End If
|
|
pLength = pLength + 1
|
|
|
|
'Unshift
|
|
For i = pLength - 1 To 1 Step -1
|
|
pArr(i + 1) = pArr(i)
|
|
Next
|
|
pArr(1) = val
|
|
|
|
'After Add event
|
|
RaiseEvent AfterAdd(Me, 1, val)
|
|
|
|
Set Unshift = Me
|
|
End Function
|
|
|
|
'TODO:
|
|
'Public Function Slice() As stdArray
|
|
'
|
|
'End Function
|
|
|
|
'TODO:
|
|
'Public Function Splice() As stdArray
|
|
'
|
|
'End Function
|
|
|
|
'Creates a new instance of the same array
|
|
'@returns {stdArray}
|
|
Public Function Clone() As stdArray
|
|
If pInitialised Then
|
|
If pInitialised Then
|
|
'Similar to CreateFromArray() but passing length through also:
|
|
Set Clone = New stdArray
|
|
|
|
Call Clone.Init(pLength, 10)
|
|
|
|
Dim i As Long
|
|
For i = 1 To pLength
|
|
Call Clone.Push(pArr(i))
|
|
Next
|
|
Else
|
|
'Error
|
|
End If
|
|
|
|
RaiseEvent AfterClone(Clone)
|
|
Else
|
|
'Error
|
|
End If
|
|
End Function
|
|
|
|
'Returns a new array with all elements in reverse order
|
|
'@returns {stdArray}
|
|
Public Function Reverse() As stdArray
|
|
'TODO: Need to find a better more low level approach to creating arrays from existing arrays/preventing redim for methods like this
|
|
Dim ret As stdArray
|
|
Set ret = stdArray.Create()
|
|
For i = pLength To 1 Step -1
|
|
Call ret.Push(pArr(i))
|
|
Next
|
|
Set Reverse = ret
|
|
End Function
|
|
|
|
'Concatenate an existing array of elements onto the end of this array
|
|
'@param {stdArray} Array whose elements we wish to append to the end of this array
|
|
'@returns {stdArray} New composite array.
|
|
Public Function Concat(ByVal arr As stdArray) As stdArray
|
|
Dim x As stdArray
|
|
Set x = Clone()
|
|
|
|
If Not arr Is Nothing Then
|
|
Dim i As Long
|
|
For i = 1 To arr.Length
|
|
Call x.Push(arr.item(i))
|
|
Next
|
|
End If
|
|
|
|
Set Concat = x
|
|
End Function
|
|
|
|
'Join each of the elements of this array together as a string
|
|
'@param {string} Delimiter to insert between strings
|
|
Public Function Join(Optional ByVal delimeter As String = ",") As String
|
|
If pInitialised Then
|
|
If pLength > 0 Then
|
|
Dim sOutput As String
|
|
sOutput = pArr(1)
|
|
|
|
Dim i As Long
|
|
For i = 2 To pLength
|
|
sOutput = sOutput & delimeter & pArr(i)
|
|
Next
|
|
Join = sOutput
|
|
Else
|
|
Join = ""
|
|
End If
|
|
Else
|
|
'Error
|
|
End If
|
|
End Function
|
|
|
|
'Get/Let/Set item
|
|
'@param {long} The location to get/set the item
|
|
Public Property Get item(ByVal i As Long) As Variant
|
|
'item(1) = 1st element
|
|
'item(2) = 2nd element
|
|
'etc.
|
|
CopyVariant item, pArr(i)
|
|
|
|
End Property
|
|
Public Property Set item(ByVal i As Long, ByVal item As Object)
|
|
Set pArr(i) = item
|
|
End Property
|
|
Public Property Let item(ByVal i As Long, ByVal item As Variant)
|
|
pArr(i) = item
|
|
End Property
|
|
|
|
'Copy a variant into the array's ith element. This saves from having to test the item and call the correct `set` keyword
|
|
'@param {Long} The index at which the item's data should be set
|
|
'@param {ByRef Variant} Item to set at the index
|
|
Public Sub PutItem(ByVal i As Long, ByRef item As Variant)
|
|
CopyVariant pArr(i), item
|
|
End Sub
|
|
|
|
'Obtain the index of an element
|
|
'@param {Variant} Element to find
|
|
'@param {Ingeger?=1} Location to start search for element.
|
|
'@returns {long} Index of element
|
|
Public Function indexOf(ByVal el As Variant, Optional ByVal start As Long = 1) As Long
|
|
Dim elIsObj As Boolean, i As Long, item As Variant, itemIsObj As Boolean
|
|
|
|
'Is element an object?
|
|
elIsObj = isObject(el)
|
|
|
|
'Loop over contents starting from start
|
|
For i = start To pLength
|
|
'Get item data
|
|
CopyVariant item, pArr(i)
|
|
|
|
'Is item an object?
|
|
itemIsObj = isObject(item)
|
|
|
|
'If both item and el are objects (must be the same type in order to be the same data)
|
|
If itemIsObj And elIsObj Then
|
|
If item Is el Then 'check items equal
|
|
indexOf = i 'return item index
|
|
Exit Function
|
|
End If
|
|
'If both item and el are not objects (must be the same type in order to be the same data)
|
|
ElseIf Not itemIsObj And Not elIsObj Then
|
|
If item = el Then 'check items equal
|
|
indexOf = i 'return item index
|
|
Exit Function
|
|
End If
|
|
End If
|
|
Next
|
|
|
|
'Return -1 i.e. no match found
|
|
indexOf = -1
|
|
End Function
|
|
|
|
'Obtain the last index of an element
|
|
'@param {Variant} Element to find
|
|
'@returns {long} Last index of element
|
|
Public Function lastIndexOf(ByVal el As Variant)
|
|
Dim elIsObj As Boolean, i As Long, item As Variant, itemIsObj As Boolean
|
|
|
|
'Is element an object?
|
|
elIsObj = isObject(el)
|
|
|
|
'Loop over contents starting from start
|
|
For i = pLength To 1 Step -1
|
|
'Get item data
|
|
CopyVariant item, pArr(i)
|
|
|
|
'Is item an object?
|
|
itemIsObj = isObject(item)
|
|
|
|
'If both item and el are objects (must be the same type in order to be the same data)
|
|
If itemIsObj And elIsObj Then
|
|
If item Is el Then 'check items equal
|
|
lastIndexOf = i 'return item index
|
|
Exit Function
|
|
End If
|
|
'If both item and el are not objects (must be the same type in order to be the same data)
|
|
ElseIf Not itemIsObj And Not elIsObj Then
|
|
If item = el Then 'check items equal
|
|
lastIndexOf = i 'return item index
|
|
Exit Function
|
|
End If
|
|
End If
|
|
Next
|
|
|
|
'Return -1 i.e. no match found
|
|
lastIndexOf = -1
|
|
End Function
|
|
|
|
'Returns true if the array contains an item
|
|
'@param {Variant} Item to find
|
|
'@param {long?=1} Index to start search for item at. (Internally uses indexOf())
|
|
Public Function includes(ByVal el As Variant, Optional ByVal startFrom As Long = 1) As Boolean
|
|
includes = indexOf(el, startFrom) >= startFrom
|
|
End Function
|
|
|
|
|
|
|
|
|
|
|
|
'Iterative Functions (All require stdICallable):
|
|
|
|
'Example: if incidents.IsEvery(cbValid) then ...
|
|
Public Function IsEvery(ByVal cb As stdICallable) As Boolean
|
|
If pInitialised Then
|
|
Dim i As Long
|
|
For i = 1 To pLength
|
|
Dim bFlag As Boolean
|
|
bFlag = cb.Run(pArr(i))
|
|
|
|
If Not bFlag Then
|
|
IsEvery = False
|
|
Exit Function
|
|
End If
|
|
Next
|
|
|
|
IsEvery = True
|
|
Else
|
|
'Error
|
|
End If
|
|
End Function
|
|
|
|
Public Function IsSome(ByVal cb As stdICallable) As Boolean
|
|
If pInitialised Then
|
|
Dim i As Long
|
|
For i = 1 To pLength
|
|
Dim bFlag As Boolean
|
|
bFlag = cb.Run(pArr(i))
|
|
|
|
If bFlag Then
|
|
IsSome = True
|
|
Exit Function
|
|
End If
|
|
Next
|
|
IsSome = False
|
|
Else
|
|
'Error
|
|
End If
|
|
End Function
|
|
|
|
Public Sub ForEach(ByVal cb As stdICallable)
|
|
If pInitialised Then
|
|
Dim i As Long
|
|
For i = 1 To pLength
|
|
Call cb.Run(pArr(i))
|
|
Next
|
|
Else
|
|
'Error
|
|
End If
|
|
End Sub
|
|
|
|
Public Function Map(ByVal cb As stdICallable) As stdArray
|
|
If pInitialised Then
|
|
Dim pMap As stdArray
|
|
Set pMap = Clone()
|
|
|
|
Dim i As Long
|
|
For i = 1 To pLength
|
|
'BUGFIX: Sometimes required, not sure when
|
|
Dim v As Variant
|
|
CopyVariant v, item(i)
|
|
|
|
'Call callback
|
|
Call pMap.PutItem(i, cb.Run(v))
|
|
Next
|
|
|
|
Set Map = pMap
|
|
Else
|
|
'Error
|
|
End If
|
|
End Function
|
|
|
|
|
|
'OPTIMISE: Needs optimisation. Currently very sub-optimal
|
|
Public Function Unique(Optional ByVal cb As stdICallable = Nothing) As stdArray
|
|
Dim ret As stdArray: Set ret = stdArray.CreateWithOptions(pLength, pChunking)
|
|
Dim retL As stdArray: Set retL = CreateWithOptions(pLength, pChunking)
|
|
|
|
'Collect keys
|
|
Dim vKeys As stdArray
|
|
If cb Is Nothing Then
|
|
Set vKeys = Clone()
|
|
Else
|
|
Set vKeys = Map(cb)
|
|
End If
|
|
|
|
'Unique by key
|
|
For i = 1 To pLength
|
|
If Not retL.includes(vKeys.item(i)) Then
|
|
Call retL.Push(vKeys.item(i))
|
|
Call ret.Push(pArr(i))
|
|
End If
|
|
Next
|
|
|
|
'Return data
|
|
Set Unique = ret
|
|
End Function
|
|
|
|
Public Function reduce(ByVal cb As stdICallable, Optional ByVal initialValue As Variant) As Variant
|
|
Dim iStart As Long
|
|
If pInitialised Then
|
|
If pLength > 0 Then
|
|
If IsMissing(initialValue) Then
|
|
Call CopyVariant(reduce, pArr(1))
|
|
iStart = 2
|
|
Else
|
|
Call CopyVariant(reduce, initialValue)
|
|
iStart = 1
|
|
End If
|
|
Else
|
|
If IsMissing(initialValue) Then
|
|
reduce = Empty
|
|
Else
|
|
Call CopyVariant(reduce, initialValue)
|
|
End If
|
|
Exit Function
|
|
End If
|
|
|
|
Dim i As Long
|
|
For i = iStart To pLength
|
|
'BUGFIX: Sometimes required, not sure when
|
|
Dim el As Variant
|
|
CopyVariant el, pArr(i)
|
|
|
|
'Reduce
|
|
CopyVariant reduce, cb.Run(reduce, el)
|
|
Next
|
|
Else
|
|
'Error
|
|
End If
|
|
End Function
|
|
|
|
|
|
Public Function Filter(ByVal cb As stdICallable) As stdArray
|
|
Dim ret As stdArray
|
|
Set ret = stdArray.CreateWithOptions(pLength, pChunking)
|
|
Set Filter = ret
|
|
|
|
'If initialised...
|
|
If pInitialised Then
|
|
Dim i As Long, v As Variant
|
|
'Loop over array
|
|
For i = 1 To pLength
|
|
'If callback succeeds, push retvar
|
|
If cb.Run(pArr(i)) Then
|
|
Call ret.Push(pArr(i))
|
|
End If
|
|
Next i
|
|
Else
|
|
'error
|
|
End If
|
|
End Function
|
|
|
|
Public Function count(Optional ByVal cb As stdICallable = Nothing) As Long
|
|
If cb Is Nothing Then
|
|
count = Length
|
|
Else
|
|
Dim i As Long, lCount As Long
|
|
lCount = 0
|
|
For i = 1 To pLength
|
|
If cb.Run(pArr(i)) Then
|
|
lCount = lCount + 1
|
|
End If
|
|
Next i
|
|
count = lCount
|
|
End If
|
|
End Function
|
|
|
|
Public Function groupBy(ByVal cb As stdICallable) As Object
|
|
'Array to store result in
|
|
Dim result As Object
|
|
Set result = CreateObject("Scripting.Dictionary")
|
|
|
|
'Loop over items
|
|
Dim i As Long
|
|
For i = 1 To pLength
|
|
'Get grouping key
|
|
Dim key As Variant
|
|
key = cb.Run(pArr(i))
|
|
|
|
'If key is not set then set it
|
|
If Not result.Exists(key) Then Set result(key) = stdArray.Create()
|
|
|
|
'Push item to key
|
|
result(key).Push pArr(i)
|
|
Next
|
|
|
|
'Return result
|
|
Set groupBy = result
|
|
End Function
|
|
|
|
Public Function Max(Optional ByVal cb As stdICallable = Nothing, Optional ByVal startingValue As Variant = Empty) As Variant
|
|
Dim vRet, vMaxValue, v
|
|
vMaxValue = startingValue: vRet = startingValue
|
|
For i = 1 To pLength
|
|
Call CopyVariant(v, pArr(i))
|
|
|
|
'Get value to test
|
|
Dim vtValue As Variant
|
|
If cb Is Nothing Then
|
|
Call CopyVariant(vtValue, v)
|
|
Else
|
|
Call CopyVariant(vtValue, cb.Run(v))
|
|
End If
|
|
|
|
'Compare values and return
|
|
If IsEmpty(vRet) Then
|
|
Call CopyVariant(vRet, v)
|
|
Call CopyVariant(vMaxValue, vtValue)
|
|
ElseIf vMaxValue < vtValue Then
|
|
Call CopyVariant(vRet, v)
|
|
Call CopyVariant(vMaxValue, vtValue)
|
|
End If
|
|
Next
|
|
|
|
Call CopyVariant(Max, vRet)
|
|
End Function
|
|
Public Function Min(Optional ByVal cb As stdICallable = Nothing, Optional ByVal startingValue As Variant = Empty) As Variant
|
|
Dim vRet, vMinValue, v
|
|
vMinValue = startingValue: vRet = startingValue
|
|
For i = 1 To pLength
|
|
Call CopyVariant(v, pArr(i))
|
|
|
|
'Get value to test
|
|
Dim vtValue As Variant
|
|
If cb Is Nothing Then
|
|
Call CopyVariant(vtValue, v)
|
|
Else
|
|
Call CopyVariant(vtValue, cb.Run(v))
|
|
End If
|
|
|
|
'Compare values and return
|
|
If IsEmpty(vRet) Then
|
|
Call CopyVariant(vRet, v)
|
|
Call CopyVariant(vMinValue, vtValue)
|
|
ElseIf vMinValue > vtValue Then
|
|
Call CopyVariant(vRet, v)
|
|
Call CopyVariant(vMinValue, vtValue)
|
|
End If
|
|
Next
|
|
|
|
Call CopyVariant(Min, vRet)
|
|
End Function
|
|
|
|
'Copies one variant to a destination
|
|
'@param {ByRef Variant} dest Destination to copy variant to
|
|
'@param {Variant} value Source to copy variant from.
|
|
'@perf This appears to be a faster variant of "oleaut32.dll\VariantCopy" + it's multi-platform
|
|
Private Sub CopyVariant(ByRef dest As Variant, ByVal value As Variant)
|
|
If isObject(value) Then
|
|
Set dest = value
|
|
Else
|
|
dest = value
|
|
End If
|
|
End Sub
|