├── AABB.cls ├── ArrayList.cls ├── ArrayListCol.cls ├── Arrays.bas ├── Collections.bas ├── DataStructures └── ArrayList.cls ├── HashCodeBuilder.cls ├── HashCodeBuilderFactory.bas ├── IVariantComparator.cls ├── Longs.bas ├── Main.bas ├── Matrix.bas ├── Objects.bas ├── QuadTree.cls ├── README.md ├── Random.bas ├── Strings.bas ├── TadpoleChart.bas ├── Timer.cls ├── Utils.bas ├── VBA-Utilities.xlam ├── XYPoint.cls ├── iCollection.cls ├── iIterable.cls ├── iList.cls ├── iMap.cls ├── iSet.cls └── tSNE.bas /AABB.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "AABB" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | 'axis-aligned bounding box with half dimension and center 11 | Public center As XYpoint 12 | Public halfDimension As Double 13 | 14 | Private Sub Class_Initialize() 15 | Set center = New XYpoint 16 | End Sub 17 | 18 | ' @description returns true if the bounding box contains the point. Containment is true for all interior points. Points on the bottom and right boundaries (i.e. at the max X and max Y values) are included. Points on the top and left boundaries (i.e. at the min X and min Y values) are not included. 19 | Public Function contains(ByRef p As XYpoint) As Boolean 20 | Dim xMin As Double, xMax As Double, yMin As Double, yMax As Double 21 | xMin = center.x - halfDimension 22 | xMax = center.x + halfDimension 23 | yMin = center.y - halfDimension 24 | yMax = center.y + halfDimension 25 | 26 | If xMin >= p.x Then 27 | Exit Function 28 | ElseIf xMax < p.x Then 29 | Exit Function 30 | ElseIf yMin >= p.y Then 31 | Exit Function 32 | ElseIf yMax < p.y Then 33 | Exit Function 34 | End If 35 | 36 | contains = True 37 | 38 | End Function 39 | 40 | Public Function intersects(ByRef box As AABB) As Boolean 41 | Dim dist As Double 42 | dist = halfDimension + boxhalfDimension 43 | 44 | If Abs(center.x - box.center.x) >= dist Then 45 | Exit Function 'x-dimension doesn't overlap 46 | End If 47 | 48 | If Abs(center.y - box.center.y) >= dist Then 49 | Exit Function 'y-dimension doesn't overlap 50 | End If 51 | 52 | 'must be < `dist` away in both x- and y-dimensions.. they intersect 53 | intersects = True 54 | 55 | End Function 56 | -------------------------------------------------------------------------------- /ArrayList.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "ArrayList" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | Option Base 0 'Index all arrays from 0 11 | 12 | Private Const DEFAULT_CAPACITY As Long = 10 ' The default intial capacity of the ArrayList 13 | Private Const MAX_ARRAY_SIZE As Long = 2147483639 ' maximum size of array to allocate 14 | Private elementData() As Variant ' The actual array of Variants in the ArrayList 15 | Private size As Long ' size of the ArrayList 16 | Private modCount As Long ' The number of times this list has been structurally modified 17 | 18 | 19 | Private Sub Class_Initialize() 20 | size = 0 21 | ReDim elementData(0 To DEFAULT_CAPACITY) 22 | End Sub 23 | 24 | 25 | 'Trims the capacity of this ArrayList instance to list's current size. An application can use this operation to minimize the storage of an ArrayList instance 26 | Public Sub trimToSize() 27 | modCount = modCount + 1 28 | If size < UBound(elementData) Then 29 | ReDim Preserve elementData(0 To size) 30 | End If 31 | End Sub 32 | 33 | Public Sub ensureCapacity(minCapacity As Long) 34 | modCount = modCount + 1 35 | 36 | 'Overflow-conscious code 37 | If minCapacity - UBound(elementData) > 0 Then 38 | grow (minCapacity) 39 | End If 40 | 41 | End Sub 42 | 43 | Private Sub grow(minCapacity As Long) 44 | 'Overflow-conscious code 45 | Dim oldCapacity As Long 46 | oldCapacity = UBound(elementData) 47 | Dim newCapacity As Long 48 | newCapacity = oldCapacity + (oldCapacity / 2) 49 | If newCapacity - minCapacity < 0 Then 50 | newCapacity = minCapacity 51 | End If 52 | If newCapacity - MAX_ARRAY_SIZE > 0 Then 53 | newCapacity = hugeCapacity(minCapacity) 54 | End If 55 | 56 | 'minCapacity is usually close to size, so this is a win 57 | ReDim Preserve elementData(0 To newCapacity) 58 | 59 | End Sub 60 | 61 | Private Function hugeCapacity(minCapacity As Long) As Long 62 | If minCapacity < 0 Then 63 | err.Raise 6 ' overflow 64 | End If 65 | hugeCapacity = IIf(minCapacity > MAX_ARRAY_SIZE, _ 66 | 2147483647, MAX_ARRAY_SIZE) 67 | End Function 68 | 69 | Private Sub ensureCapacityInternal(minCapacity As Long) 70 | ensureExplicitCapacity (minCapacity) 71 | End Sub 72 | 73 | Private Sub ensureExplicitCapacity(minCapacity As Long) 74 | modCount = modCount + 1 75 | 76 | 'overflow-conscious code 77 | If minCapacity - UBound(elementData) > 0 Then 78 | grow (minCapacity) 79 | End If 80 | 81 | End Sub 82 | 83 | Private Property Let setSize(value As Long) 84 | size = value 85 | End Property 86 | 87 | ' Returns the number of elements in this list 88 | Public Property Get getSize() As Long 89 | getSize = size 90 | End Property 91 | 92 | 'Returns true if this list contains no elements 93 | Public Function isEmpty() As Boolean 94 | isEmpty = (size = 0) 95 | End Function 96 | 97 | ' Returns true if this list contains the specified element 98 | Public Function contains(o As Variant) As Boolean 99 | contains = (indexOf(o) >= 0) 100 | End Function 101 | 102 | 'Returns the index of the first occurrence of the specified element in this list, or -1 if this list does not contain the element 103 | Public Function indexOf(o As Variant) As Long 104 | Dim i As Long 105 | If o = Empty Then 106 | 107 | For i = 0 To size Step 1 108 | If elementData(i) Is Nothing Then 109 | indexOf = i 110 | Exit Function 111 | End If 112 | Next i 113 | Else 114 | 115 | For i = 0 To size Step 1 116 | If o = elementData(i) Then 117 | indexOf = i 118 | Exit Function 119 | End If 120 | Next i 121 | End If 122 | indexOf = -1 123 | End Function 124 | 125 | 'Returns the index of the last occurrence of the specified element in this list, or -1 if this list does not contain the element 126 | Public Function lastIndexOf(o As Variant) As Long 127 | Dim i As Long 128 | If (o Is Nothing) Then 129 | For i = size - 1 To 0 Step 1 130 | If elementData(i) Is Nothing Then 131 | lastIndexOf = i 132 | Exit Function 133 | End If 134 | Next i 135 | Else 136 | For i = size - 1 To 0 Step 1 137 | If o Is elementData(i) Then 138 | lastIndexOf = i 139 | Exit Function 140 | End If 141 | Next i 142 | End If 143 | End Function 144 | 145 | Public Function ToArray() As Variant() 146 | Dim arrCopy() As Variant 147 | ReDim arrCopy(0 To size) 148 | Dim i As Long 149 | For i = 0 To size Step 1 150 | arrCopy(i) = elementData(i) 151 | Next i 152 | ToArray = arrCopy 153 | End Function 154 | 155 | 156 | Public Function getIndex(index As Long) As Variant 157 | rangeCheck (index) 158 | getIndex = elementData(index) 159 | End Function 160 | 161 | Public Function setIndex(index As Long, element As Variant) As Variant 162 | rangeCheck (index) 163 | 164 | Dim oldValue As Variant 165 | oldValue = elementData(index) 166 | elementData(index) = element 167 | setIndex = oldValue 168 | End Function 169 | 170 | Public Function add(e As Variant) As Boolean 171 | ensureCapacityInternal (size + 1) 172 | elementData(size) = e 173 | size = size + 1 174 | add = True 175 | End Function 176 | 177 | Public Sub addIndex(index As Long, element As Variant) 178 | rangeCheckForAdd (index) 179 | ensureCapacity (size + 1) 180 | 181 | 'shift current elements to the right one 182 | arrayCopy elementData, index, elementData, index + 1, size - index 183 | elementData(index) = element 184 | size = size + 1 185 | End Sub 186 | 187 | Public Function removeIndex(index As Long) As Variant 188 | rangeCheck (index) 189 | 190 | modCount = modCount + 1 191 | 192 | Dim oldValue As Variant 193 | oldValue = elementData(index) 194 | 195 | 196 | Dim numMoved As Long 197 | numMoved = size - index - 1 198 | If numMoved > 0 Then 199 | 'move the remaining elements left one 200 | arrayCopy elementData, index + 1, elementData, index, numMoved 201 | End If 202 | 203 | size = size - 1 204 | elementData(size) = Empty 205 | removeIndex = oldValue 206 | End Function 207 | 208 | Private Sub rangeCheck(index As Long) 209 | If index >= size Then 210 | err.Raise 9, , outOfBoundsMsg(index) 211 | End If 212 | End Sub 213 | 214 | Private Sub rangeCheckForAdd(index As Long) 215 | If index >= size Or index < 0 Then 216 | err.Raise 9, , outOfBoundsMsg(index) 217 | End If 218 | End Sub 219 | 220 | Private Function outOfBoundsMsg(index As Long) As String 221 | outOfBoundsMsg = "Index " & index & ", Size: " & size 222 | End Function 223 | 224 | Public Function remove(o As Variant) As Boolean 225 | Dim index As Long 226 | If o = Empty Then 227 | For index = 0 To size Step 1 228 | If elementData(index) Is Nothing Then 229 | fastRemove (index) 230 | removeVariant = True 231 | Exit Function 232 | End If 233 | Next index 234 | Else 235 | For index = 0 To size Step 1 236 | If elementData(index) = o Then 237 | fastRemove (index) 238 | removeVariant = True 239 | Exit Function 240 | End If 241 | Next index 242 | End If 243 | removeVariant = False 244 | End Function 245 | 246 | Private Sub fastRemove(index As Long) 247 | modCount = modCount + 1 248 | Dim numMoved As Long 249 | numMoved = size - index - 1 250 | If numMoved > 0 Then 251 | arrayCopy elementData, index + 1, elementData, index, numMoved 252 | End If 253 | size = size - 1 254 | elementData(size) = Null 255 | End Sub 256 | 257 | Public Sub clear() 258 | modCount = modCount + 1 259 | 260 | Dim i As Long 261 | For i = 0 To size Step 1 262 | elementData(i) = Null 263 | Next i 264 | 265 | size = 0 266 | End Sub 267 | 268 | Public Function addAll(Arr() As Variant) As Boolean 269 | Dim numNew As Long 270 | numNew = UBound(Arr) - LBound(Arr) 271 | ensureCapacityInternal (size + numNew) 272 | 273 | Dim i As Long 274 | Dim j As Long 275 | j = size 276 | For i = LBound(Arr) To UBound(Arr) Step 1 277 | elementData(j) = Arr(i) 278 | j = j + 1 279 | Next i 280 | size = size + numNew 281 | addAll = numNew <> 0 282 | End Function 283 | 284 | Public Function addAllAtIndex(index As Long, Arr() As Variant) As Boolean 285 | rangeCheckForAdd (index) 286 | 287 | Dim numNew As Long 288 | numNew = UBound(Arr) - LBound(Arr) 289 | ensureCapacityInternal (size + numNew) 290 | 291 | Dim numMoved As Long 292 | numMoved = size - index 293 | If numMoved > 0 Then 294 | arrayCopy elementData, index, elementData, index + numNew, numMoved 295 | End If 296 | 297 | Dim i As Long 298 | Dim j As Long 299 | j = LBound(Arr) 300 | For i = index To index + numNew Step 1 301 | elementData(i) = Arr(j) 302 | j = j + 1 303 | Next i 304 | 305 | size = size + numNew 306 | addAllAtIndex = numNew <> 0 307 | End Function 308 | 309 | Sub removeRange(fromIndex As Long, toIndex As Long) 310 | modCount = modCount + 1 311 | Dim numMoved As Long 312 | numMoved = size - toIndex 313 | arrayCopy elementData, toIndex, elementData, fromIndex, numMoved 314 | 315 | 'clear to let GC do its work 316 | Dim newSize As Long 317 | newSize = size - (toIndex - fromIndex) 318 | Dim i As Long 319 | For i = newSize To size Step 1 320 | elementData(i) = Null 321 | Next i 322 | size = newSize 323 | End Sub 324 | 325 | Public Function removeAll(c As ArrayList) As Boolean 326 | If c Is Nothing Then 327 | err.Raise 31004, , "Collection c Is Nothing" 328 | End If 329 | batchRemove c, False 330 | End Function 331 | 332 | Public Function retainAll(c As ArrayList) As Boolean 333 | If c Is Nothing Then 334 | err.Raise 31004, , "Collection c Is Nothing" 335 | End If 336 | batchRemove c, True 337 | End Function 338 | 339 | Private Function batchRemove(c As ArrayList, complement As Boolean) As Boolean 340 | Dim r As Integer 341 | Dim w As Integer 342 | r = 0 343 | w = 0 344 | Dim modified As Boolean 345 | modified = False 346 | 347 | On Error GoTo finally 348 | For r = 0 To size Step 1 349 | If (c.contains(elementData(r)) = complement) Then 350 | elementData(w) = elementData(r) 351 | w = w + 1 352 | End If 353 | Next r 354 | batchRemove = modified 355 | Exit Function 356 | finally: 357 | If r <> size Then 358 | ''''arrayCopy elementData, r, elementData, w, size - r 359 | w = w + size - r 360 | End If 361 | If w <> size Then 362 | 'clear to let GC do its work 363 | Dim i As Long 364 | For i = w To size Step 1 365 | elementData(i) = Null 366 | Next i 367 | modCount = modCount + size - w 368 | size = w 369 | modified = True 370 | 371 | End If 372 | batchRemove = modified 373 | Exit Function 374 | 375 | 376 | 377 | End Function 378 | 379 | 380 | Public Sub arrayCopy(ByRef src() As Variant, srcPos As Long, ByRef dst() As Variant, dstPos As Long, length As Long) 381 | 382 | 'Check if all offsets and lengths are non negative 383 | If srcPos < 0 Or dstPos < 0 Or length < 0 Then 384 | err.Raise 9, , "negative value supplied" 385 | End If 386 | 387 | 'Check if ranges are valid 388 | If length + srcPos > UBound(src) Then 389 | err.Raise 9, , "Not enough elements to copy, src+length: " & srcPos + length & ", UBound(src): " & UBound(src) 390 | End If 391 | If length + dstPos > UBound(dst) Then 392 | err.Raise 9, , "Not enough room in destination array. dstPos+length: " & dstPos + length & ", UBound(dst): " & UBound(dst) 393 | End If 394 | Dim i As Long 395 | i = 0 396 | 'copy src elements to dst 397 | Do While length > i 398 | dst(dstPos + i) = src(srcPos + i) 399 | i = i + 1 400 | Loop 401 | 402 | End Sub 403 | 404 | Public Function subList(fromIndex As Long, toIndex As Long) As ArrayList 405 | subListRangeCheck fromIndex, toIndex, Me.getSize 406 | subList = New ArrayList 407 | subList.addAll elementData 408 | 409 | End Function 410 | 411 | Private Sub subListRangeCheck(fromIndex As Long, toIndex As Long, curSize As Long) 412 | If fromIndex < 0 Then 413 | err.Raise 6, , "fromIndex = " & fromIndex 414 | End If 415 | If toIndex > curSize Then 416 | err.Raise 6, , "toIndex = " & toIndex 417 | End If 418 | If fromIndex > toIndex Then 419 | err.Raise 328, , "fromIndex(" & fromIndex & ") > toIndex(" & toIndex & ")" 420 | End If 421 | End Sub 422 | 423 | Public Property Get NewEnum() As IUnknown 424 | 'interface method 425 | End Property 426 | -------------------------------------------------------------------------------- /ArrayListCol.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "ArrayListCol" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | Option Base 0 'Index all arrays from 0 11 | Implements iCollection 12 | 'Implements iList 13 | Implements iIterable 14 | 15 | Private Const DEFAULT_CAPACITY As Long = 10 ' The default intial capacity of the ArrayListCol 16 | Private Const MAX_ARRAY_SIZE As Long = 2147483639 ' maximum size of array to allocate 17 | Private elementData As Collection ' The actual array of Variants in the ArrayListCol 18 | Private modCount As Long ' The number of times this list has been structurally modified 19 | 20 | 21 | Private Sub Class_Initialize() 22 | Set elementData = New Collection 23 | End Sub 24 | 25 | 26 | 'Trims the capacity of this ArrayListCol instance to list's current size. An application can use this operation to minimize the storage of an ArrayListCol instance 27 | 'Public Sub trimToSize() 28 | ' modCount = modCount + 1 29 | ' capacity = elementData.Count - 1 30 | 'End Sub 31 | 32 | 'Public Sub ensureCapacity(minCapacity As Long) 33 | ' modCount = modCount + 1 34 | ' 35 | ' 'Overflow-conscious code 36 | ' If minCapacity - elementData.Count - 1 > 0 Then 37 | ' grow (minCapacity) 38 | ' End If 39 | ' 40 | 'End Sub 41 | 42 | 'Private Sub grow(minCapacity As Long) 43 | ' 'Overflow-conscious code 44 | ' Dim oldCapacity As Long 45 | ' oldCapacity = UBound(elementData) 46 | ' Dim newCapacity As Long 47 | ' newCapacity = oldCapacity + (oldCapacity / 2) 48 | ' If newCapacity - minCapacity < 0 Then 49 | ' newCapacity = minCapacity 50 | ' End If 51 | ' If newCapacity - MAX_ARRAY_SIZE > 0 Then 52 | ' newCapacity = hugeCapacity(minCapacity) 53 | ' End If 54 | ' 55 | ' 'minCapacity is usually close to size, so this is a win 56 | ' ReDim Preserve elementData(0 To newCapacity) 57 | ' 58 | 'End Sub 59 | 60 | 'Private Function hugeCapacity(minCapacity As Long) As Long 61 | ' If minCapacity < 0 Then 62 | ' err.Raise 6 ' overflow 63 | ' End If 64 | ' hugeCapacity = IIf(minCapacity > MAX_ARRAY_SIZE, _ 65 | ' 2147483647, MAX_ARRAY_SIZE) 66 | 'End Function 67 | 68 | 'Private Sub ensureCapacityInternal(minCapacity As Long) 69 | ' ensureExplicitCapacity (minCapacity) 70 | 'End Sub 71 | ' 72 | 'Private Sub ensureExplicitCapacity(minCapacity As Long) 73 | ' modCount = modCount + 1 74 | ' 75 | ' 'overflow-conscious code 76 | ' If minCapacity - UBound(elementData) > 0 Then 77 | ' grow (minCapacity) 78 | ' End If 79 | ' 80 | 'End Sub 81 | 82 | 83 | ' Returns the number of elements in this list 84 | Public Function size() As Long 85 | size = elementData.Count 86 | End Function 87 | 88 | 'Returns true if this list contains no elements 89 | Public Function isEmpty() As Boolean 90 | isEmpty = (size = 0) 91 | End Function 92 | 93 | ' Returns true if this list contains the specified element 94 | Public Function contains(ByRef o As Variant) As Boolean 95 | contains = (indexOf(o) >= 0) 96 | End Function 97 | 98 | 'Returns the index of the first occurrence of the specified element in this list, or -1 if this list does not contain the element 99 | Public Function indexOf(ByRef o As Variant) As Long 100 | Dim i As Long 101 | If o = Empty Then 102 | err.Raise 424, , "NullPointerException" 103 | Else 104 | If size = 0 Then 105 | indexOf = -1 106 | Exit Function 107 | End If 108 | For i = 0 To size - 1 Step 1 109 | If o = getIndexInternal(i) Then 110 | indexOf = i 111 | Exit Function 112 | End If 113 | Next i 114 | End If 115 | indexOf = Longs.valueOf(-1) 116 | End Function 117 | 118 | 'Returns the index of the last occurrence of the specified element in this list, or -1 if this list does not contain the element 119 | Public Function lastIndexOf(ByRef o As Variant) As Long 120 | Dim i As Long 121 | If o = Empty Then 122 | err.Raise 424, , "NullPointerException" 123 | Else 124 | If size = 0 Then 125 | lastIndexOf = -1 126 | Exit Function 127 | End If 128 | For i = size - 1 To 0 Step -1 129 | If o = getIndexInternal(i) Then 130 | lastIndexOf = i 131 | Exit Function 132 | End If 133 | Next i 134 | End If 135 | lastIndexOf = -1 136 | End Function 137 | 138 | Public Function ToArray() As Variant() 139 | Dim arrCopy() As Variant 140 | ReDim arrCopy(0 To size - 1) 141 | Dim i As Long 142 | For i = 0 To size - 1 Step 1 143 | arrCopy(i) = getIndexInternal(i) 144 | Next i 145 | ToArray = arrCopy 146 | End Function 147 | 148 | 149 | Public Function getIndex(index As Long) As Variant 150 | rangeCheck (index) 151 | getIndex = elementData.Item(index + 1) 152 | End Function 153 | 154 | Private Function getIndexInternal(index As Long) As Variant 155 | getIndexInternal = elementData.Item(index + 1) 156 | End Function 157 | 158 | Public Function setIndex(index As Long, ByRef element As Variant) As Variant 159 | rangeCheck (index) 160 | 161 | Dim oldValue As Variant 162 | oldValue = getIndexInternal(index) 163 | elementData.add element, , , index + 2 = element 164 | removeIndex (index) 165 | setIndex = oldValue 166 | End Function 167 | 168 | Public Function add(ByRef e As Variant) As Boolean 169 | ' ensureCapacityInternal (size + 1) 170 | elementData.add e 171 | ' size = size + 1 172 | add = True 173 | End Function 174 | 175 | Public Sub addAtIndex(index As Long, ByRef element As Variant) 176 | rangeCheckForAdd (index) 177 | ' ensureCapacity (size + 1) 178 | 179 | 'shift current elements to the right one 180 | ' arrayCopy elementData, index, elementData, index + 1, size - index 181 | If index = elementData.Count Then 182 | elementData.add element 183 | Else 184 | elementData.add element, , index + 1 185 | End If 186 | End Sub 187 | 188 | Public Function removeIndex(index As Long) As Variant 189 | rangeCheck (index) 190 | 191 | modCount = modCount + 1 192 | 193 | Dim oldValue As Variant 194 | oldValue = getIndex(index) 195 | 196 | elementData.remove index + 2 197 | ' Dim numMoved As Long 198 | ' numMoved = size - index - 1 199 | ' If numMoved > 0 Then 200 | ' 'move the remaining elements left one 201 | ' arrayCopy elementData, index + 1, elementData, index, numMoved 202 | ' End If 203 | ' 204 | ' size = size - 1 205 | ' elementData(size) = Empty 206 | removeIndex = oldValue 207 | End Function 208 | 209 | Private Sub rangeCheck(index As Long) 210 | If index >= size Then 211 | err.Raise 9, , outOfBoundsMsg(index) 212 | End If 213 | End Sub 214 | 215 | Private Sub rangeCheckForAdd(index As Long) 216 | If index > size Or index < 0 Then 217 | err.Raise 9, , outOfBoundsMsg(index) 218 | End If 219 | End Sub 220 | 221 | Private Function outOfBoundsMsg(index As Long) As String 222 | outOfBoundsMsg = "Index " & index & ", Size: " & size 223 | End Function 224 | 225 | Public Function remove(ByRef o As Variant) As Boolean 226 | Variants.requireNonNull o 227 | 228 | Dim index As Long 229 | For index = 0 To size - 1 Step 1 230 | If getIndexInternal(index) = o Then 231 | fastRemove (index) 232 | remove = True 233 | Exit Function 234 | End If 235 | Next index 236 | 237 | remove = False 238 | End Function 239 | 240 | Private Sub fastRemove(index As Long) 241 | modCount = modCount + 1 242 | 243 | elementData.remove index + 1 244 | ' Dim numMoved As Long 245 | ' numMoved = size - index - 1 246 | ' If numMoved > 0 Then 247 | ' arrayCopy elementData, index + 1, elementData, index, numMoved 248 | ' End If 249 | ' size = size - 1 250 | ' elementData(size) = Null 251 | End Sub 252 | 253 | Public Sub clear() 254 | modCount = modCount + 1 255 | 256 | Set elementData = Nothing 257 | Set elementData = New Collection 258 | ' Dim i As Long 259 | ' For i = 0 To size Step 1 260 | ' elementData(i) = Null 261 | ' Next i 262 | ' 263 | ' size = 0 264 | End Sub 265 | 266 | Public Function addAll(ByRef c As iCollection) As Boolean 267 | Variants.requireNonNull c 268 | 269 | Dim A() As Variant 270 | A = c.ToArray 271 | 272 | For Each element In A 273 | elementData.add element 274 | Next element 275 | addAll = c.size > 0 276 | 277 | ' Dim numNew As Long 278 | ' numNew = UBound(arr) - LBound(arr) 279 | '' ensureCapacityInternal (size + numNew) 280 | ' 281 | ' Dim i As Long 282 | ' Dim j As Long 283 | ' j = size 284 | ' For i = LBound(arr) To UBound(arr) Step 1 285 | ' elementData(j) = arr(i) 286 | ' j = j + 1 287 | ' Next i 288 | ' size = size + numNew 289 | ' addAll = numNew <> 0 290 | End Function 291 | 292 | 293 | Public Function addAllAtIndex(index As Long, ByRef c As iCollection) As Boolean 294 | rangeCheckForAdd index 295 | Variants.requireNonNull c 296 | 297 | If index < elementData.Count Then 298 | Dim offset As Long 299 | offset = 0 300 | Dim A() As Variant 301 | A = c.ToArray 302 | 303 | For Each element In A 304 | elementData.add element, , , index + 1 + offset 305 | offset = offset + 1 306 | Next element 307 | Else 308 | addAll c 309 | End If 310 | addAllAtIndex = (c.size > 0) 311 | 312 | 313 | ' rangeCheckForAdd (index) 314 | ' 315 | ' Dim numNew As Long 316 | ' numNew = UBound(arr) - LBound(arr) 317 | ' ensureCapacityInternal (size + numNew) 318 | ' 319 | ' Dim numMoved As Long 320 | ' numMoved = size - index 321 | ' If numMoved > 0 Then 322 | ' arrayCopy elementData, index, elementData, index + numNew, numMoved 323 | ' End If 324 | ' 325 | ' Dim i As Long 326 | ' Dim j As Long 327 | ' j = LBound(arr) 328 | ' For i = index To index + numNew Step 1 329 | ' elementData(i) = arr(j) 330 | ' j = j + 1 331 | ' Next i 332 | ' 333 | ' size = size + numNew 334 | ' addAllAtIndex = numNew <> 0 335 | End Function 336 | 337 | Sub removeRange(fromIndex As Long, toIndex As Long) 338 | modCount = modCount + 1 339 | Dim numRemoved As Long 340 | numRemoved = toIndex - fromIndex 341 | Dim i As Long 342 | 343 | For i = numRemoved To 0 Step -1 344 | removeIndex (fromIndex) 345 | Next i 346 | 347 | 348 | ' Dim numMoved As Long 349 | ' numMoved = size - toIndex 350 | ' arrayCopy elementData, toIndex, elementData, fromIndex, numMoved 351 | ' 352 | ' 'clear to let GC do its work 353 | ' Dim newSize As Long 354 | ' newSize = size - (toIndex - fromIndex) 355 | ' Dim i As Long 356 | ' For i = newSize To size Step 1 357 | ' elementData(i) = Null 358 | ' Next i 359 | ' size = newSize 360 | End Sub 361 | 362 | Public Function removeAll(ByRef c As iCollection) As Boolean 363 | Variants.requireNonNull c 364 | batchRemove c, False 365 | End Function 366 | 367 | Public Function retainAll(ByRef c As iCollection) As Boolean 368 | Variants.requireNonNull c 369 | batchRemove c, True 370 | End Function 371 | 372 | Private Function batchRemove(ByRef c As ArrayListCol, complement As Boolean) As Boolean 373 | Dim r As Integer 374 | Dim w As Integer 375 | r = 0 376 | w = 0 377 | Dim modified As Boolean 378 | modified = False 379 | 380 | On Error GoTo finally 381 | For r = 0 To size Step 1 382 | If (c.contains(elementData(r)) = complement) Then 383 | elementData(w) = elementData(r) 384 | w = w + 1 385 | End If 386 | Next r 387 | batchRemove = modified 388 | Exit Function 389 | finally: 390 | If r <> size Then 391 | ''''arrayCopy elementData, r, elementData, w, size - r 392 | w = w + size - r 393 | End If 394 | If w <> size Then 395 | 'clear to let GC do its work 396 | Dim i As Long 397 | For i = w To size Step 1 398 | elementData(i) = Null 399 | Next i 400 | modCount = modCount + size - w 401 | size = w 402 | modified = True 403 | 404 | End If 405 | batchRemove = modified 406 | Exit Function 407 | 408 | 409 | 410 | End Function 411 | 412 | 413 | 414 | 415 | Public Function subList(fromIndex As Long, toIndex As Long) As ArrayListCol 416 | subListRangeCheck fromIndex, toIndex, Me.getSize 417 | subList = New ArrayListCol 418 | subList.addAll elementData 419 | 420 | End Function 421 | 422 | Private Sub subListRangeCheck(fromIndex As Long, toIndex As Long, curSize As Long) 423 | If fromIndex < 0 Then 424 | err.Raise 6, , "fromIndex = " & fromIndex 425 | End If 426 | If toIndex > curSize Then 427 | err.Raise 6, , "toIndex = " & toIndex 428 | End If 429 | If fromIndex > toIndex Then 430 | err.Raise 328, , "fromIndex(" & fromIndex & ") > toIndex(" & toIndex & ")" 431 | End If 432 | End Sub 433 | 434 | Public Property Get NewEnum() As IUnknown 435 | Attribute NewEnum.VB_UserMemId = -4 436 | Set NewEnum = elementData.[_NewEnum] 437 | End Property 438 | 439 | ' ------------------ iCollection Interface Methods 440 | 441 | 442 | Public Function iCollection_add(ByRef e As Variant) As Boolean 443 | iCollection_add = add(e) 444 | End Function 445 | 446 | Public Function iCollection_addAll(ByRef c As iCollection) As Boolean 447 | iCollection_addAll = addAll(c) 448 | End Function 449 | 450 | Public Sub iCollection_clear() 451 | clear 452 | End Sub 453 | 454 | Public Function iCollection_contains(ByRef o As Variant) As Boolean 455 | iCollection_contains = contains(o) 456 | End Function 457 | 458 | Public Function iCollection_equals(ByRef o As Variant) As Boolean 459 | ''TODO 460 | End Function 461 | 462 | Public Function iCollection_hashCode() As Long 463 | ''TODO 464 | End Function 465 | 466 | Public Function iCollection_isEmpty() As Boolean 467 | iCollection_isEmpty = isEmpty 468 | End Function 469 | 470 | 'iterator() 471 | 472 | 'parallelStream() 473 | 474 | Public Function iCollection_remove(o As Variant) As Boolean 475 | iCollection_remove = remove(o) 476 | End Function 477 | 478 | Public Function iCollection_removeAll(ByRef c As iCollection) As Boolean 479 | iCollection_removeAll = removeAll(c) 480 | End Function 481 | 482 | Public Function iCollection_retainAll(ByRef c As iCollection) As Boolean 483 | iCollection_retainAll = retainAll(c) 484 | End Function 485 | 486 | Public Function iCollection_size() As Long 487 | iCollection_size = size 488 | End Function 489 | 490 | 'spliterator 491 | 'stream 492 | Public Function iCollection_toArray() As Variant() 493 | iCollection_toArray = ToArray 494 | End Function 495 | 496 | Public Property Get iCollection_NewEnum() As IUnknown 497 | ''specified in iIterable 498 | Set iCollection_NewEnum = NewEnum 499 | End Property 500 | 501 | Public Property Get iIterable_NewEnum() As IUnknown 502 | ''specified in iIterable 503 | Set iIterable_NewEnum = NewEnum 504 | End Property 505 | 506 | 507 | -------------------------------------------------------------------------------- /Collections.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Collections" 2 | Option Explicit 3 | Option Base 1 4 | 5 | 'Returns True if the Collection contains the specified key. Otherwise, returns False 6 | Public Function hasKey(Key As Variant, col As Collection) As Boolean 7 | Dim obj As Variant 8 | On Error GoTo err 9 | hasKey = True 10 | obj = col(Key) 11 | Exit Function 12 | 13 | err: 14 | hasKey = False 15 | End Function 16 | 17 | 'Returns True if the Collection contains an element equal to value 18 | Public Function contains(value As Variant, col As Collection) As Boolean 19 | contains = (indexOf(value, col) >= 0) 20 | End Function 21 | 22 | 23 | 'Returns the first index of an element equal to value. If the Collection 24 | 'does not contain such an element, returns -1. 25 | Public Function indexOf(value As Variant, col As Collection) As Long 26 | 27 | Dim index As Long 28 | 29 | For index = 1 To col.count Step 1 30 | If col(index) = value Then 31 | indexOf = index 32 | Exit Function 33 | End If 34 | Next index 35 | indexOf = -1 36 | End Function 37 | 38 | ''Sorts the given collection using the Arrays.MergeSort algorithm. 39 | '' O(n log(n)) time 40 | '' O(n) space 41 | 'Public Sub mergeSort(col As Collection) 42 | ' Dim A() As Variant 43 | ' Dim B() As Variant 44 | ' A = Collections.ToArray(col) 45 | ' Arrays.mergeSort A() 46 | ' Set col = Collections.FromArray(A()) 47 | 'End Sub 48 | 49 | 'Returns an array which exactly matches this collection. 50 | ' Note: This function is not safe for concurrent modification. 51 | Public Function toArray(col As Collection) As Variant 52 | Dim A() As Variant 53 | ReDim A(0 To col.count) 54 | Dim i As Long 55 | For i = 0 To col.count - 1 56 | A(i) = col(i + 1) 57 | Next i 58 | toArray = A() 59 | End Function 60 | 61 | 'Returns a Collection which exactly matches the given Array 62 | ' Note: This function is not safe for concurrent modification. 63 | Public Function FromArray(A() As Variant) As Collection 64 | Dim col As Collection 65 | Set col = New Collection 66 | Dim element As Variant 67 | For Each element In A 68 | col.add element 69 | Next element 70 | Set FromArray = col 71 | End Function 72 | 73 | Public Sub BubbleSort() 74 | 75 | Dim cFruit As Collection 76 | Dim vItm As Variant 77 | Dim i As Long, j As Long 78 | Dim vTemp As Variant 79 | 80 | Set cFruit = New Collection 81 | 82 | 'fill the collection 83 | cFruit.add "Mango", "Mango" 84 | cFruit.add "Apple", "Apple" 85 | cFruit.add "Peach", "Peach" 86 | cFruit.add "Kiwi", "Kiwi" 87 | cFruit.add "Lime", "Lime" 88 | 89 | 'Two loops to bubble sort 90 | For i = 1 To cFruit.count - 1 91 | For j = i + 1 To cFruit.count 92 | If cFruit(i) > cFruit(j) Then 93 | 'store the lesser item 94 | vTemp = cFruit(j) 95 | 'remove the lesser item 96 | cFruit.remove j 97 | 're-add the lesser item before the 98 | 'greater Item 99 | cFruit.add vTemp, vTemp, i 100 | End If 101 | Next j 102 | Next i 103 | 104 | 'Test it 105 | For Each vItm In cFruit 106 | Debug.Print vItm 107 | Next vItm 108 | 109 | End Sub 110 | 111 | 112 | ''''''''''''''''''''''''''''''''''''''''''''''''' 113 | 'Sorts the array using the MergeSort algorithm (follows the pseudocode on Wikipedia 114 | 'O(n*log(n)) time; O(n) space 115 | Public Sub mergeSort(A As Collection) 116 | Dim b As Collection 117 | Set b = New Collection 118 | Collections.Copy A, 1, b, 1, A.count 119 | TopDownSplitMerge A, 1, A.count, b 120 | End Sub 121 | 122 | 'Used by MergeSortAlgorithm 123 | Private Sub TopDownSplitMerge(A As Collection, iBegin As Long, iEnd As Long, b As Collection) 124 | 125 | If iEnd - iBegin < 2 Then ' if run size = 1 126 | Exit Sub ' consider it sorted 127 | End If 128 | 129 | ' recursively split runs into two halves until run size = 1 130 | ' then merge them and return back up the call chain 131 | Dim iMiddle As Long 132 | iMiddle = (iEnd + iBegin) / 2 ' iMiddle = mid point 133 | TopDownSplitMerge A, iBegin, iMiddle, b 'split-merge left half 134 | TopDownSplitMerge A, iMiddle, iEnd, b ' split-merge right half 135 | TopDownMerge A, iBegin, iMiddle, iEnd, b ' merge the two half runs 136 | Copy b, iBegin, A, iBegin, iEnd - iBegin 'copy the merged runs back to A 137 | End Sub 138 | 139 | 'Used by MergeSort algirtm 140 | Private Sub TopDownMerge(A As Collection, iBegin As Long, iMiddle As Long, iEnd As Long, b As Collection) 141 | 'left half is A[iBegin:iMiddle-1] 142 | 'right half is A[iMiddle:iEnd-1] 143 | Dim i As Long 144 | Dim j As Long 145 | Dim k As Long 146 | i = iBegin 147 | j = iMiddle 148 | 149 | 'while there are elements in the left or right runs... 150 | For k = iBegin To iEnd Step 1 151 | 'If left run head exists and is <= existing right run head. 152 | If i < iMiddle And (j >= iEnd Or A(i) <= A(j)) Then 153 | b.add A(i) 154 | i = i + 1 155 | Else 156 | b(k) = A(j) 157 | j = j + 1 158 | End If 159 | Next k 160 | End Sub 161 | 162 | 'Used by MergeSort algorithm 163 | Private Sub CopyRange(source As Collection, iBegin As Long, iEnd As Long, dest As Collection) 164 | Dim k As Long 165 | For k = iBegin To iEnd Step 1 166 | destination(k) = source(k) 167 | Next k 168 | End Sub 169 | 170 | 'Copies an array from the specified source array, beginning at the specified position, to the specified position in the destination array 171 | Public Sub Copy(ByRef src As Collection, srcPos As Long, ByRef dst As Collection, dstPos As Long, length As Long) 172 | 173 | 'Check if all offsets and lengths are non negative 174 | If srcPos < 1 Then 175 | err.Raise 9, , "srcPos too small: " & srcPos 176 | End If 177 | If dstPos < 1 Then 178 | err.Raise 9, , "dstPos too small: " & dstPos 179 | End If 180 | If length < 0 Then 181 | err.Raise 9, , "negative length provided" 182 | End If 183 | 184 | 185 | 'Check if ranges are valid 186 | If length + srcPos - 1 > src.count Then 187 | err.Raise 9, , "Not enough elements to copy, (src+length - 1): " & srcPos + length - 1 & ", src.Count: " & src.count 188 | End If 189 | If length + dstPos - 1 > dst.count Then 190 | err.Raise 9, , "Not enough room in destination array. (dstPos+length - 1): " & dstPos + length - 1 & ", dst.Count: " & dst.count 191 | End If 192 | Dim i As Long 193 | i = 0 194 | 'copy src elements to dst 195 | Do While length > i 196 | dst(dstPos + i) = src(srcPos + i) 197 | i = i + 1 198 | Loop 199 | 200 | End Sub 201 | 202 | ' @description adds all elements of the source Collection to the destination Collection 203 | ' @param dest the destination collection to which the elements will be added 204 | ' @param source the collection from which the elements originate 205 | Public Sub addAll(dest As Collection, source As Collection) 206 | Dim v As Variant 207 | 208 | For Each v In source 209 | dest.add v 210 | Next v 211 | 212 | End Sub 213 | -------------------------------------------------------------------------------- /DataStructures/ArrayList.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "ArrayList" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | Option Base 0 'Index all arrays from 0 11 | 12 | Private Const DEFAULT_CAPACITY As Long = 10 ' The default intial capacity of the ArrayList 13 | Private Const MAX_ARRAY_SIZE As Long = 2147483639 ' maximum size of array to allocate 14 | Private elementData() As Variant ' The actual array of Variants in the ArrayList 15 | Private size As Long ' size of the ArrayList 16 | Private modCount As Long ' The number of times this list has been structurally modified 17 | 18 | 19 | Private Sub Class_Initialize() 20 | size = 0 21 | ReDim elementData(0 To DEFAULT_CAPACITY) 22 | End Sub 23 | 24 | 25 | 'Trims the capacity of this ArrayList instance to list's current size. An application can use this operation to minimize the storage of an ArrayList instance 26 | Public Sub trimToSize() 27 | modCount = modCount + 1 28 | If size < UBound(elementData) Then 29 | ReDim Preserve elementData(0 To size) 30 | End If 31 | End Sub 32 | 33 | Public Sub ensureCapacity(minCapacity As Long) 34 | modCount = modCount + 1 35 | 36 | 'Overflow-conscious code 37 | If minCapacity - UBound(elementData) > 0 Then 38 | grow (minCapacity) 39 | End If 40 | 41 | End Sub 42 | 43 | Private Sub grow(minCapacity As Long) 44 | 'Overflow-conscious code 45 | Dim oldCapacity As Long 46 | oldCapacity = UBound(elementData) 47 | Dim newCapacity As Long 48 | newCapacity = oldCapacity + (oldCapacity / 2) 49 | If newCapacity - minCapacity < 0 Then 50 | newCapacity = minCapacity 51 | End If 52 | If newCapacity - MAX_ARRAY_SIZE > 0 Then 53 | newCapacity = hugeCapacity(minCapacity) 54 | End If 55 | 56 | 'minCapacity is usually close to size, so this is a win 57 | ReDim Preserve elementData(0 To newCapacity) 58 | 59 | End Sub 60 | 61 | Private Function hugeCapacity(minCapacity As Long) As Long 62 | If minCapacity < 0 Then 63 | err.Raise 6 ' overflow 64 | End If 65 | hugeCapacity = IIf(minCapacity > MAX_ARRAY_SIZE, _ 66 | 2147483647, MAX_ARRAY_SIZE) 67 | End Function 68 | 69 | Private Sub ensureCapacityInternal(minCapacity As Long) 70 | ensureExplicitCapacity (minCapacity) 71 | End Sub 72 | 73 | Private Sub ensureExplicitCapacity(minCapacity As Long) 74 | modCount = modCount + 1 75 | 76 | 'overflow-conscious code 77 | If minCapacity - UBound(elementData) > 0 Then 78 | grow (minCapacity) 79 | End If 80 | 81 | End Sub 82 | 83 | Private Property Let setSize(value As Long) 84 | size = value 85 | End Property 86 | 87 | ' Returns the number of elements in this list 88 | Public Property Get getSize() As Long 89 | getSize = size 90 | End Property 91 | 92 | 'Returns true if this list contains no elements 93 | Public Function isEmpty() As Boolean 94 | isEmpty = (size = 0) 95 | End Function 96 | 97 | ' Returns true if this list contains the specified element 98 | Public Function contains(o As Variant) As Boolean 99 | contains = (indexOf(o) >= 0) 100 | End Function 101 | 102 | 'Returns the index of the first occurrence of the specified element in this list, or -1 if this list does not contain the element 103 | Public Function indexOf(o As Variant) As Long 104 | Dim i As Long 105 | If o = Empty Then 106 | 107 | For i = 0 To size Step 1 108 | If elementData(i) Is Nothing Then 109 | indexOf = i 110 | Exit Function 111 | End If 112 | Next i 113 | Else 114 | 115 | For i = 0 To size Step 1 116 | If o = elementData(i) Then 117 | indexOf = i 118 | Exit Function 119 | End If 120 | Next i 121 | End If 122 | indexOf = -1 123 | End Function 124 | 125 | 'Returns the index of the last occurrence of the specified element in this list, or -1 if this list does not contain the element 126 | Public Function lastIndexOf(o As Variant) As Long 127 | Dim i As Long 128 | If (o Is Nothing) Then 129 | For i = size - 1 To 0 Step 1 130 | If elementData(i) Is Nothing Then 131 | lastIndexOf = i 132 | Exit Function 133 | End If 134 | Next i 135 | Else 136 | For i = size - 1 To 0 Step 1 137 | If o Is elementData(i) Then 138 | lastIndexOf = i 139 | Exit Function 140 | End If 141 | Next i 142 | End If 143 | End Function 144 | 145 | Public Function ToArray() As Variant() 146 | Dim arrCopy() As Variant 147 | ReDim arrCopy(0 To size) 148 | Dim i As Long 149 | For i = 0 To size Step 1 150 | arrCopy(i) = elementData(i) 151 | Next i 152 | ToArray = arrCopy 153 | End Function 154 | 155 | 156 | Public Function getIndex(index As Long) As Variant 157 | rangeCheck (index) 158 | getIndex = elementData(index) 159 | End Function 160 | 161 | Public Function setIndex(index As Long, element As Variant) As Variant 162 | rangeCheck (index) 163 | 164 | Dim oldValue As Variant 165 | oldValue = elementData(index) 166 | elementData(index) = element 167 | setIndex = oldValue 168 | End Function 169 | 170 | Public Function Add(e As Variant) As Boolean 171 | ensureCapacityInternal (size + 1) 172 | elementData(size) = e 173 | size = size + 1 174 | Add = True 175 | End Function 176 | 177 | Public Sub addIndex(index As Long, element As Variant) 178 | rangeCheckForAdd (index) 179 | ensureCapacity (size + 1) 180 | 181 | 'shift current elements to the right one 182 | arrayCopy elementData, index, elementData, index + 1, size - index 183 | elementData(index) = element 184 | size = size + 1 185 | End Sub 186 | 187 | Public Function removeIndex(index As Long) As Variant 188 | rangeCheck (index) 189 | 190 | modCount = modCount + 1 191 | 192 | Dim oldValue As Variant 193 | oldValue = elementData(index) 194 | 195 | 196 | Dim numMoved As Long 197 | numMoved = size - index - 1 198 | If numMoved > 0 Then 199 | 'move the remaining elements left one 200 | arrayCopy elementData, index + 1, elementData, index, numMoved 201 | End If 202 | 203 | size = size - 1 204 | elementData(size) = Empty 205 | removeIndex = oldValue 206 | End Function 207 | 208 | Private Sub rangeCheck(index As Long) 209 | If index >= size Then 210 | err.Raise 9, , outOfBoundsMsg(index) 211 | End If 212 | End Sub 213 | 214 | Private Sub rangeCheckForAdd(index As Long) 215 | If index >= size Or index < 0 Then 216 | err.Raise 9, , outOfBoundsMsg(index) 217 | End If 218 | End Sub 219 | 220 | Private Function outOfBoundsMsg(index As Long) As String 221 | outOfBoundsMsg = "Index " & index & ", Size: " & size 222 | End Function 223 | 224 | Public Function remove(o As Variant) As Boolean 225 | Dim index As Long 226 | If o = Empty Then 227 | For index = 0 To size Step 1 228 | If elementData(index) Is Nothing Then 229 | fastRemove (index) 230 | removeVariant = True 231 | Exit Function 232 | End If 233 | Next index 234 | Else 235 | For index = 0 To size Step 1 236 | If elementData(index) = o Then 237 | fastRemove (index) 238 | removeVariant = True 239 | Exit Function 240 | End If 241 | Next index 242 | End If 243 | removeVariant = False 244 | End Function 245 | 246 | Private Sub fastRemove(index As Long) 247 | modCount = modCount + 1 248 | Dim numMoved As Long 249 | numMoved = size - index - 1 250 | If numMoved > 0 Then 251 | arrayCopy elementData, index + 1, elementData, index, numMoved 252 | End If 253 | size = size - 1 254 | elementData(size) = Null 255 | End Sub 256 | 257 | Public Sub clear() 258 | modCount = modCount + 1 259 | 260 | Dim i As Long 261 | For i = 0 To size Step 1 262 | elementData(i) = Null 263 | Next i 264 | 265 | size = 0 266 | End Sub 267 | 268 | Public Function addAll(arr() As Variant) As Boolean 269 | Dim numNew As Long 270 | numNew = UBound(arr) - LBound(arr) 271 | ensureCapacityInternal (size + numNew) 272 | 273 | Dim i As Long 274 | Dim j As Long 275 | j = size 276 | For i = LBound(arr) To UBound(arr) Step 1 277 | elementData(j) = arr(i) 278 | j = j + 1 279 | Next i 280 | size = size + numNew 281 | addAll = numNew <> 0 282 | End Function 283 | 284 | Public Function addAllAtIndex(index As Long, arr() As Variant) As Boolean 285 | rangeCheckForAdd (index) 286 | 287 | Dim numNew As Long 288 | numNew = UBound(arr) - LBound(arr) 289 | ensureCapacityInternal (size + numNew) 290 | 291 | Dim numMoved As Long 292 | numMoved = size - index 293 | If numMoved > 0 Then 294 | arrayCopy elementData, index, elementData, index + numNew, numMoved 295 | End If 296 | 297 | Dim i As Long 298 | Dim j As Long 299 | j = LBound(arr) 300 | For i = index To index + numNew Step 1 301 | elementData(i) = arr(j) 302 | j = j + 1 303 | Next i 304 | 305 | size = size + numNew 306 | addAllAtIndex = numNew <> 0 307 | End Function 308 | 309 | Sub removeRange(fromIndex As Long, toIndex As Long) 310 | modCount = modCount + 1 311 | Dim numMoved As Long 312 | numMoved = size - toIndex 313 | arrayCopy elementData, toIndex, elementData, fromIndex, numMoved 314 | 315 | 'clear to let GC do its work 316 | Dim newSize As Long 317 | newSize = size - (toIndex - fromIndex) 318 | Dim i As Long 319 | For i = newSize To size Step 1 320 | elementData(i) = Null 321 | Next i 322 | size = newSize 323 | End Sub 324 | 325 | Public Function removeAll(c As ArrayList) As Boolean 326 | If c Is Nothing Then 327 | err.Raise 31004, , "Collection c Is Nothing" 328 | End If 329 | batchRemove c, False 330 | End Function 331 | 332 | Public Function retainAll(c As ArrayList) As Boolean 333 | If c Is Nothing Then 334 | err.Raise 31004, , "Collection c Is Nothing" 335 | End If 336 | batchRemove c, True 337 | End Function 338 | 339 | Private Function batchRemove(c As ArrayList, complement As Boolean) As Boolean 340 | Dim r As Integer 341 | Dim w As Integer 342 | r = 0 343 | w = 0 344 | Dim modified As Boolean 345 | modified = False 346 | 347 | On Error GoTo finally 348 | For r = 0 To size Step 1 349 | If (c.contains(elementData(r)) = complement) Then 350 | elementData(w) = elementData(r) 351 | w = w + 1 352 | End If 353 | Next r 354 | batchRemove = modified 355 | Exit Function 356 | finally: 357 | If r <> size Then 358 | ''''arrayCopy elementData, r, elementData, w, size - r 359 | w = w + size - r 360 | End If 361 | If w <> size Then 362 | 'clear to let GC do its work 363 | Dim i As Long 364 | For i = w To size Step 1 365 | elementData(i) = Null 366 | Next i 367 | modCount = modCount + size - w 368 | size = w 369 | modified = True 370 | 371 | End If 372 | batchRemove = modified 373 | Exit Function 374 | 375 | 376 | 377 | End Function 378 | 379 | 380 | Public Sub arrayCopy(ByRef src() As Variant, srcPos As Long, ByRef dst() As Variant, dstPos As Long, length As Long) 381 | 382 | 'Check if all offsets and lengths are non negative 383 | If srcPos < 0 Or dstPos < 0 Or length < 0 Then 384 | err.Raise 9, , "negative value supplied" 385 | End If 386 | 387 | 'Check if ranges are valid 388 | If length + srcPos > UBound(src) Then 389 | err.Raise 9, , "Not enough elements to copy, src+length: " & srcPos + length & ", UBound(src): " & UBound(src) 390 | End If 391 | If length + dstPos > UBound(dst) Then 392 | err.Raise 9, , "Not enough room in destination array. dstPos+length: " & dstPos + length & ", UBound(dst): " & UBound(dst) 393 | End If 394 | Dim i As Long 395 | i = 0 396 | 'copy src elements to dst 397 | Do While length > i 398 | dst(dstPos + i) = src(srcPos + i) 399 | i = i + 1 400 | Loop 401 | 402 | End Sub 403 | 404 | Public Function subList(fromIndex As Long, toIndex As Long) As ArrayList 405 | subListRangeCheck fromIndex, toIndex, Me.getSize 406 | subList = New ArrayList 407 | subList.addAll elementData 408 | 409 | End Function 410 | 411 | Private Sub subListRangeCheck(fromIndex As Long, toIndex As Long, curSize As Long) 412 | If fromIndex < 0 Then 413 | err.Raise 6, , "fromIndex = " & fromIndex 414 | End If 415 | If toIndex > curSize Then 416 | err.Raise 6, , "toIndex = " & toIndex 417 | End If 418 | If fromIndex > toIndex Then 419 | err.Raise 328, , "fromIndex(" & fromIndex & ") > toIndex(" & toIndex & ")" 420 | End If 421 | End Sub 422 | 423 | 424 | -------------------------------------------------------------------------------- /HashCodeBuilder.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "HashCodeBuilder" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | Option Explicit 11 | 12 | Private constant_ As Long 13 | Private total_ As Long 14 | 15 | 16 | Public Sub initializeVariables(Optional initialNonZeroOddNumber As Long, Optional multiplierNonZeroOddNumber As Long) 17 | 18 | If (initialNonZeroOddNumber = 0) Then 19 | constant_ = 37 20 | ElseIf (initialNonZeroOddNumber Mod 2 = 0) Then 21 | err.Raise Number:=5, source:="Factory.createHashCodeBuilder", Description:="HashCodeBuilder requires an odd initial value" 22 | Else 23 | constant_ = multiplierNonZeroOddNumber 24 | End If 25 | 26 | If (multiplierNonZeroOddNumber = 0) Then 27 | 'variable was not supplied 28 | total_ = 17 29 | ElseIf (multiplierNonZeroOddNumber Mod 2 = 0) Then 30 | err.Raise Number:=5, source:="Factory.createHashCodeBuilder", Description:="HashCodeBuilder requires an odd multiplier" 31 | Else 32 | total_ = multiplierNonZeroOddNumber 33 | End If 34 | End Sub 35 | 36 | '' ***************************** 37 | '' ****** PRIMITIVE TYPES ****** 38 | '' ***************************** 39 | 40 | Public Function appendLong(value As Long) As HashCodeBuilder 41 | total_ = total_ * constant_ + value 42 | Set appendLong = Me 43 | End Function 44 | 45 | Public Function appendInteger(value As Integer) As HashCodeBuilder 46 | total_ = total_ * constant_ + value 47 | Set appendInteger = Me 48 | End Function 49 | 50 | Public Function appendByte(value As Byte) As HashCodeBuilder 51 | total_ = total_ * constant_ + value 52 | Set appendByte = Me 53 | End Function 54 | 55 | Public Function appendSingle(value As Single) As HashCodeBuilder 56 | total_ = total_ * constant_ + value 57 | Set appendSingle = Me 58 | End Function 59 | 60 | Public Function appendDouble(value As Double) As HashCodeBuilder 61 | total_ = total_ * constant_ + value 62 | Set appendDouble = Me 63 | End Function 64 | 65 | Public Function appendBoolean(value As Boolean) As HashCodeBuilder 66 | If value = True Then 67 | total_ = total_ * constant_ + value 68 | End If 69 | Set appendBoolean = Me 70 | End Function 71 | 72 | '' *************************************** 73 | '' ****** ARRAYS OF PRIMITIVE TYPES ****** 74 | '' *************************************** 75 | 76 | Public Function appendLongArray(Arr() As Long) As HashCodeBuilder 77 | If UBound(Arr, 1) - LBound(Arr, 1) + 1 = 0 Then 78 | total_ = total_ * constant_ 79 | Else 80 | Dim val As Long 81 | For Each val In Arr 82 | appendLong val 83 | Next val 84 | 85 | Set appendLongArray = Me 86 | End Function 87 | 88 | Public Function appendIntegerArray(Arr() As Integer) As HashCodeBuilder 89 | If UBound(Arr, 1) - LBound(Arr, 1) + 1 = 0 Then 90 | total_ = total_ * constant_ 91 | Else 92 | Dim val As Integer 93 | For Each val In Arr 94 | appendInteger val 95 | Next val 96 | 97 | Set appendIntegerArray = Me 98 | End Function 99 | 100 | Public Function appendByteArray(Arr() As Byte) As HashCodeBuilder 101 | If UBound(Arr, 1) - LBound(Arr, 1) + 1 = 0 Then 102 | total_ = total_ * constant_ 103 | Else 104 | Dim val As Byte 105 | For Each val In Arr 106 | appendByte val 107 | Next val 108 | 109 | Set appendByteArray = Me 110 | End Function 111 | 112 | Public Function appendSingleArray(Arr() As Single) As HashCodeBuilder 113 | If UBound(Arr, 1) - LBound(Arr, 1) + 1 = 0 Then 114 | total_ = total_ * constant_ 115 | Else 116 | Dim val As Single 117 | For Each val In Arr 118 | appendShort val 119 | Next val 120 | 121 | Set appendSingleArray = Me 122 | End Function 123 | 124 | Public Function appendDoubleArray(Arr() As Double) As HashCodeBuilder 125 | If UBound(Arr, 1) - LBound(Arr, 1) + 1 = 0 Then 126 | total_ = total_ * constant_ 127 | Else 128 | Dim val As Double 129 | For Each val In Arr 130 | appendDouble val 131 | Next val 132 | 133 | Set appendDoubleArray = Me 134 | End Function 135 | 136 | Public Function appendBooleanArray(Arr() As Boolean) As HashCodeBuilder 137 | If UBound(Arr, 1) - LBound(Arr, 1) + 1 = 0 Then 138 | total_ = total_ * constant_ 139 | Else 140 | Dim val As Boolean 141 | For Each val In Arr 142 | appendBoolean val 143 | Next val 144 | 145 | Set appendBooleanArray = Me 146 | End Function 147 | 148 | Public Function hashCode() As Long 149 | hashCode = total_ 150 | End Function 151 | -------------------------------------------------------------------------------- /HashCodeBuilderFactory.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "HashCodeBuilderFactory" 2 | Option Explicit 3 | 4 | Public Function newHashCodeBuilder(Optional initialNonZeroOddNumber As Long, Optional multiplierNonZeroOddNumber As Long) As HashCodeBuilder 5 | Set newHashCodeBuilder = New HashCodeBuilder 6 | newHashCodeBuilder.initializeVariables initialNonZeroOddNumber, multiplierNonZeroOddNumber 7 | End Function 8 | 9 | -------------------------------------------------------------------------------- /IVariantComparator.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "IVariantComparator" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | Option Explicit 11 | 12 | Public Function Compare(ByRef v1 As Variant, ByRef v2 As Variant) As Long 13 | End Function 14 | 15 | Public Function reverse() As IVariantComparator 16 | End Function 17 | 18 | -------------------------------------------------------------------------------- /Longs.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Longs" 2 | Public Const MAX_VALUE As Long = 2147483647 3 | Public Const MIN_VALUE As Long = -2147483648# 4 | 5 | -------------------------------------------------------------------------------- /Main.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Main" 2 | Option Explicit 3 | Option Base 0 4 | 5 | 6 | 7 | Sub Main() 8 | 9 | Dim Arr As ArrayListCol 10 | Set Arr = New ArrayListCol 11 | 12 | 13 | 14 | Dim col As iCollection 15 | Set col = New ArrayListCol 16 | 17 | col.add "blah" 18 | col.add "blah2" 19 | 20 | 21 | Arr.addAll col 22 | Debug.Print (Arr.size = 2) & " ## addAll " 23 | 24 | col.remove 1 25 | col.remove 1 26 | col.add "a" 27 | col.add "b" 28 | 29 | Arr.addAllAtIndex 0, col 30 | Arr.addAllAtIndex 1, col 31 | Arr.addAllAtIndex 2, col 32 | Debug.Print ("[ blah, blah, blah, blah2, a, b, blah2, a, b, blah2, a, b, blah, blah2]" = Arrays.toString(Arr.ToArray)) & " ## addAllAtIndex " 33 | 34 | Arr.clear 35 | Arr.add "something" 36 | Debug.Print (Arr.size = 1) & " ## add" 37 | Debug.Print (Arr.size = 1) & " ## size" 38 | 39 | 40 | Arr.addAtIndex 0, "fun thing" 41 | Arr.addAtIndex 2, "cool thing" 42 | Debug.Print (Arr.getIndex(2) = "cool thing" And Arr.getIndex(0) = "fun thing") & " ## addAtIndex " 43 | 44 | Arr.clear 45 | Debug.Print (Arr.size = 0) & " ## clear " 46 | 47 | Arr.add "foo" 48 | Debug.Print (Arr.contains("foo") And Not Arr.contains("bar")) & " ## contains" 49 | 50 | Arr.add "bar" 51 | Debug.Print (Arr.getIndex(0) = "foo" And Arr.getIndex(1) = "bar") & " ## getIndex" 52 | 53 | Arr.add "boze" 54 | Arr.add "boze" 55 | Debug.Print (Arr.indexOf("foo") = 0 And Arr.indexOf("bar") = 1 And Arr.indexOf("baz") = -1 And Arr.indexOf("boze") = 2) & " ## indexOf " 56 | Debug.Print (Arr.lastIndexOf("foo") = 0 And Arr.lastIndexOf("bar") = 1 And Arr.lastIndexOf("baz") = -1 And Arr.lastIndexOf("boze") = 3) & " ## lastIndexOf " 57 | 58 | Debug.Print (Arr.remove("foo") = True And Arr.remove("foo") = False) & " ## Remove" 59 | 60 | Dim isEmpty As Boolean 61 | isEmpty = Arr.isEmpty 62 | Arr.clear 63 | Debug.Print (isEmpty = False And Arr.isEmpty = True) & " ## isEmpty " 64 | 65 | Arr.add "foo" 66 | Arr.addAll col 67 | Arr.add "bar" 68 | Arr.addAll col 69 | Arr.add "baz" 70 | 71 | 72 | Dim removeAllContains1 As Boolean 73 | Dim removeAllContains2 As Boolean 74 | ' Arr.removeAll col 75 | ' removeAllContains1 = (Arr.contains("a") And Arr.contains("b")) 76 | ' Arr.removeAll col 77 | ' removeAllContains2 = (Arr.contains("a") And Arr.contains("b")) 78 | ' 79 | ' Debug.Print (removeAllContains1 And Not removeAllContains2 And Not Arr.isEmpty) & " ## removeAll " 80 | 81 | 82 | End Sub 83 | 84 | 85 | 86 | -------------------------------------------------------------------------------- /Matrix.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Matrix" 2 | Option Explicit 3 | Option Base 1 4 | 5 | ' This module provides methods for performing various matrix operations. Rather than using a custom User-defined class, this module 6 | ' uses 2-dimensional, 1-based arrays to represent a matrix. For performance purposes, these methods assume the input is allocated, 7 | ' non-empty, 1-based (vice zero-based) and Double-valued. If these assumptions fail, the results are unpredictable. 8 | ' 9 | ' 10 | 11 | 'Private subroutine to test the various methods in this module. Completion without assertion errors implies all tests passed 12 | Private Sub test() 13 | 14 | Dim mat() As Double, i As Long, j As Long 15 | 16 | mat = Matrix.diagonal(3, 4, 5) 17 | Debug.Assert UBound(mat, 1) = 3 18 | Debug.Assert UBound(mat, 2) = 4 19 | Debug.Assert UBound(identity(12), 1) = 12 20 | Debug.Assert UBound(identity(12), 2) = 12 21 | 22 | 23 | For i = 1 To UBound(mat, 1) 24 | For j = 1 To UBound(mat, 2) 25 | Debug.Assert mat(i, j) = IIf(i = j, 5, 0) 26 | Next j 27 | Next i 28 | 29 | Debug.Assert sameSize(identity(3), identity(3)) 30 | Debug.Assert Not sameSize(identity(3), identity(4)) 31 | Debug.Assert isEqual(mat, mat) 32 | Debug.Assert isEqual(identity(2), identity(2)) 33 | Debug.Assert Not isEqual(identity(2), identity(3)) 34 | Debug.Assert Not isEqual(identity(3), identity(2)) 35 | Debug.Assert Not isEqual(randomUniform(3, 3), randomUniform(3, 3)) 36 | Debug.Assert isEqual(transpose(transpose(mat)), mat) 37 | Debug.Assert trace(identity(3)) = 3 38 | Debug.Assert trace(identity(5)) = 5 39 | Debug.Assert trace(identity(39)) = 39 40 | Debug.Assert det(identity(12)) = 1 41 | Debug.Assert det(randomUniform(100, 100, 1, 2)) > 0 42 | Debug.Print "All tests complete: " & Now() 43 | End Sub 44 | 45 | ' @description Given an invertable n-by-n matrix A, returns the matrix A' such that (A*A')=(A'*A)=I_n 46 | ' @param A an invertable n-by-n 47 | ' @return the inverse A' of A 48 | Public Function inverse(A As Variant) As Variant 49 | Debug.Assert UBound(A, 1) = UBound(A, 2) 50 | det = WorksheetFunction.MInverse(A) 51 | End Function 52 | 53 | ' @description Given square matrix A, returns the determinant of the matrix A which can be viewed as the scaling factor of the transofmration described by the matrix, c.f. https://en.wikipedia.org/wiki/Determinant 54 | ' @param A an n-by-n (square) matrix 55 | ' @return the determiniate of A 56 | Public Function det(A As Variant) As Double 57 | Attribute det.VB_Description = "Given square matrix A, returns the determinant of the matrix A which can be viewed as the scaling factor of the transofmration described by the matrix, c.f. https://en.wikipedia.org/wiki/Determinant" 58 | Attribute det.VB_ProcData.VB_Invoke_Func = " \n18" 59 | Debug.Assert UBound(A, 1) = UBound(A, 2) 60 | det = WorksheetFunction.MDeterm(A) 61 | End Function 62 | 63 | ' @description Computes the sum of the elements on the main diagonal of the matrix A, i.e. tr(A)=a_11+a_22+...+a_nn 64 | ' @param A an n-by-n (square) matrix 65 | ' @return the trace of A defined as the sum of its diagonal elements 66 | Public Function trace(A As Variant) As Double 67 | Debug.Assert UBound(A, 1) = UBound(A, 2) 68 | Dim i As Long 69 | 70 | For i = 1 To UBound(A, 1) 71 | trace = trace + A(i, i) 72 | Next i 73 | 74 | End Function 75 | ' @description performs scalar multiplication 76 | ' @param A an arbitrary sized m-by-n matrix 77 | ' @param s a double-valued scalar 78 | ' @return returns matrix C with elements c_ij=(s*a_ij) 79 | Public Function timesScalar(A As Variant, s) As Variant 80 | Dim result As Variant, i As Long, j As Long 81 | ReDim result(UBound(A, 1), UBound(A, 2)) 82 | 83 | For i = 1 To UBound(A, 1) 84 | For j = 1 To UBound(A, 2) 85 | result(i, j) = A(i, j) * s 86 | Next j 87 | Next i 88 | timesScalar = result 89 | End Function 90 | 91 | ' @description performs in-place scalar multiplication. Unlike the `timesScalar` method, this method replaces A with the result of scalar multiplication 92 | ' @param A an arbitrary sized m-by-n matrix 93 | ' @param s a double-valued scalar 94 | ' @return returns A after performing scalar multiplication so that (A)_ij now equals s*a_ij. 95 | Public Function timesScalarEquals(A As Variant, s As Double) As Variant 96 | Dim i As Long, j As Long 97 | 98 | For i = 1 To UBound(A, 1) 99 | For j = 1 To UBound(A, 2) 100 | A(i, j) = A(i, j) * s 101 | Next j 102 | Next i 103 | 104 | timesScalarEquals = A 105 | End Function 106 | 107 | ' @description transposes matrix A 108 | ' @Param A an arbitrary sized m-by-n matrix 109 | ' @return returns the m-by-n transpose matrix A^t such that (A)_ij = (A^t)_ji 110 | Public Function transpose(A As Variant) As Variant 111 | Dim result As Variant, i As Long, j As Long 112 | ReDim result(UBound(A, 1), UBound(A, 2)) 113 | 114 | For i = 1 To UBound(A, 1) 115 | For j = 1 To UBound(A, 2) 116 | result(i, j) = A(i, j) 117 | Next j 118 | Next i 119 | transpose = result 120 | End Function 121 | 122 | ' @description Returns true if the two matrices are equal, and returns false otherwise. More formally, given m-by-n matrix A and p-by-q matrix B, returns TRUE iff m=p, and n=q, and for all a_ij in A and b_ij in B, a_ij = b_ij. Otherwise, returns FALSE. 123 | ' @param A a m-by-n matrix 124 | ' @param B a p-by-q matrix 125 | ' @returns TRUE iff m=p and n=q and a_ij=b_ij for all i,j. Otherwise, returns FALSE. 126 | Public Function isEqual(A As Variant, b As Variant) As Boolean 127 | isEqual = False 128 | 129 | If Not sameSize(A, b) Then 130 | Exit Function 131 | End If 132 | 133 | Dim i As Long, j As Long 134 | 135 | For i = 1 To UBound(A) 136 | For j = 1 To UBound(b) 137 | If (A(i, j) <> b(i, j)) Then 138 | Exit Function 139 | End If 140 | Next j 141 | Next i 142 | 143 | isEqual = True 144 | End Function 145 | 146 | ' @description Returns the matrix product of A and B--a matrix with the same number of rows as A and same number of columns as B. See https://en.wikipedia.org/wiki/Matrix_multiplication for details of this operation 147 | ' @param A an m-by-n matrix 148 | ' @param B an n-by-p matrix 149 | ' @return the n-by-p matrix product AB 150 | Public Function timesMatrix(A As Variant, b As Variant) As Variant 151 | Debug.Assert UBound(A, 2) = UBound(b, 1) 152 | multiply = WorksheetFunction.MMult(A, b) 153 | End Function 154 | 155 | ' @description performs element-wise addition of two same-sized matrices 156 | ' @param A an m-by-n matrix 157 | ' @param B an m-by-n matrix 158 | ' @return the matrix C whose elements c_ij equal a_ij + b_ij 159 | Public Function plus(A As Variant, b As Variant) As Variant 160 | Debug.Assert sameSize(A, b) 161 | 162 | Dim mat As Variant, i As Long, j As Long 163 | ReDim mat(UBound(A, 1), UBound(A, 2)) 164 | 165 | For i = 1 To UBound(A, 1) 166 | For j = 1 To UBound(A, 2) 167 | mat(i, j) = A(i, j) + b(i, j) 168 | Next j 169 | Next i 170 | 171 | add = mat 172 | 173 | End Function 174 | 175 | 'Returns true if A and B are the same size. Formally, given m-by-n matrix A and p-by-q matrix B, returns true iff m=p and n=q. 176 | ' @description returns TRUE if the matrices are the same size. 177 | ' @param A an m-by-n matrix 178 | ' @param B a p-by-q matrix 179 | ' @return returns TRUE iff m=p and n=q. Otherwise, returns FALSE. 180 | Public Function sameSize(A As Variant, b As Variant) As Boolean 181 | sameSize = (UBound(A, 1) = UBound(b, 1)) And (UBound(A, 2) = UBound(b, 2)) 182 | End Function 183 | 184 | 185 | ' @description creates an identity matrix of size n (denoted I_n) such that for all m-by-n matrices A and n-by-m matrices B, A*I_n = A and I_n*B = B. 186 | ' @param size the numberof rows/columns (denoted by n) in the resulting identity matrix. 187 | ' @param returns the I_n identity matrix where (I_n)_ij = 1 if i=j and 0 otherwise. 188 | Public Function identity(size As Long) As Variant 189 | identity = diagonal(size, size, 1#) 190 | End Function 191 | 192 | ' @description Returns an m-by-n matrix A with the specified size whose diagonal equals the specified value. (Note: This matrix need not be square.) 193 | ' @param numberOfRows the number of rows (n) in the resulting matrix 194 | ' @param numberOfColumns the number of columns (m) in the resulting matrix 195 | ' @param value the value (v) of the elements along the diagonal. 196 | ' @return returns an m-by-n matrix A, with elements a_ij = v if i=j, and a_ij = 0 elsewhere. 197 | Public Function diagonal(numberOfRows As Long, numberOfColumns As Long, value As Double) As Variant 198 | Debug.Assert numberOfRows > 0 And numberOfColumns > 0 199 | Dim mat() As Double, i As Long, minsize As Long 200 | 201 | minsize = IIf(numberOfRows < numberOfColumns, numberOfRows, numberOfColumns) 202 | ReDim mat(numberOfRows, numberOfColumns) 203 | 204 | For i = 1 To minsize 205 | mat(i, i) = value 206 | Next i 207 | 208 | diagonal = mat 209 | 210 | End Function 211 | 212 | ' @description Returns a m-by-n matrix whose elements are uniformly distributed between the specified range of values. Formally, given a uniform distribution U(minVal,maxVal), returns an m-by-n matrix A with elements a_ij are selected from U(minVal,maxVal) If a minimum values is not specified, 0 is used. If a maximum value is not specified, then 1 is used. 213 | ' @param numberOfRows = the number of rows (denoted m) in the resulting matrix 214 | ' @param numberOfColumns = the number of columns (denoted n) in the resulting matrix 215 | ' @param minVal = (Optional) the minimum value of the uniform distribution used to fill the resulting matrix. If not specified, 0 is used. 216 | ' @param maxVal = (Optional) the maximumvalue of the uniform distribution used to fill the resulting matrix. If not specified, 1 is used. 217 | Public Function randomUniform(numberOfRows As Long, numberOfColumns As Long, Optional minVal As Double = 0#, Optional maxVal As Double = 1#) As Variant 218 | Debug.Assert numberOfRows > 0 And numberOfColumns > 0 219 | Debug.Assert maxVal > minVal 220 | 221 | Dim mat() As Double, i As Long, j As Long, range As Double 222 | ReDim mat(numberOfRows, numberOfColumns) 223 | 224 | range = maxVal - minVal 225 | 226 | For i = 1 To numberOfRows 227 | For j = 1 To numberOfColumns 228 | mat(i, j) = range * Rnd() + minVal 229 | Next j 230 | Next i 231 | 232 | randomUniform = mat 233 | 234 | End Function 235 | 236 | ' @description Returns a m-by-n matrix whose elements are normally distributed. Formally, given a normal distribution N(mean,sigma), returns an m-by-n matrix A with elements a_ij are selected from N(mean,sigma) 237 | ' @param numberOfRows = the number of rows (denoted m) in the resulting matrix 238 | ' @param numberOfColumns = the number of columns (denoted n) in the resulting matrix 239 | ' @param mean = (Optional) the mean of the normal distribution used to fill the resulting matrix. If not specified, 0 is used. 240 | ' @param standard_dev = (Optional) the standard deviation of the normal distribution used to fill the resulting matrix. If not specified, 1.0 is used. 241 | Public Function randomNormal(numberOfRows As Long, numberOfColumns As Long, Optional mean As Double = 0#, Optional standard_Dev As Double = 1#) As Variant 242 | Debug.Assert numberOfRows > 0 And numberOfColumns > 0 243 | 244 | Dim mat() As Double, i As Long, j As Long 245 | ReDim mat(numberOfRows, numberOfColumns) 246 | 247 | For i = 1 To numberOfRows 248 | For j = 1 To numberOfColumns 249 | mat(i, j) = WorksheetFunction.NormInv(Rnd(), mean, standard_Dev) 250 | Next j 251 | Next i 252 | 253 | randomNormal = mat 254 | 255 | End Function 256 | 257 | ' @description Prints to console the given matrix. This method is especially helpful when debugging code or outputing results of reasonable size (<30 rows/columns) 258 | ' @param mat the matrix to print to console 259 | Public Sub printMatrix(mat As Variant) 260 | Debug.Assert Arrays.NumberOfArrayDimensions(mat) = 2 261 | Dim result As String, numRows As Long, numCols As Long, i As Long, j As Long, slice As Variant 262 | numRows = UBound(mat, 1) 263 | numCols = UBound(mat, 2) 264 | result = "[" 265 | For i = 1 To numRows 266 | slice = Application.index(mat, i, 0) 267 | result = result & vbCrLf & "[" & Join(slice, ", ") & "] " 268 | Next i 269 | 270 | result = result & "]" 271 | 272 | Debug.Print result 273 | End Sub 274 | 275 | 276 | 277 | -------------------------------------------------------------------------------- /Objects.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Objects" 2 | Option Explicit 3 | 4 | Public Sub requireNonNull(o As Variant) 5 | If o Is Empty Then 6 | err.Raise 31004, , "NullPointerException" 7 | End If 8 | End Sub 9 | -------------------------------------------------------------------------------- /QuadTree.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "QuadTree" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | Option Explicit 11 | Option Base 0 12 | 13 | '' A quadtree is a tree data structure in which each internal node has exactly four children. Quadtrees are the two-dimensional analog of octrees and are most often used to partition a two-dimensional space by recursively subdividing it into four quadrants or regions. 14 | '' This implementation acts like a set for storage of two-dimensional data as X-Y coordinates. 15 | 16 | 'arbitrary constant to indicate how many elements can be stored in thsi quad tree node 17 | Private Const QT_NODE_CAPACITY = 4 18 | 19 | 'AABB that represents the boundary of the quad-trr 20 | Private boundary As AABB 21 | 22 | 'Points in this quad tree node 23 | Private points As Collection 24 | 25 | 'Children 26 | Private northWest As QuadTree 27 | Private northEast As QuadTree 28 | Private southWest As QuadTree 29 | Private southEast As QuadTree 30 | 31 | 'constructor 32 | Private Sub Class_Initialize() 33 | Set points = New Collection 34 | Set boundary = New AABB 35 | End Sub 36 | 37 | ' @description This method should be used immediately after instantiation of the QuadTree if not using the factor method for creating a QuadTree. This method changes the boundary of this QuadTree to the specified coordinates and size. 38 | ' @param centerX the center of the bounding box for this QuadTree 39 | ' @param centerY the center of the boundnig box for this QuadTree 40 | ' @param halfDimension axis-aligned distance from the center of the bounding box to the edge of the bounding box 41 | Public Sub setBoundary(centerX As Double, centerY As Double, halfDimension As Double) 42 | Debug.Assert halfDimension > 0 43 | Set boundary = New AABB 44 | boundary.center.x = centerX 45 | boundary.center.y = centerY 46 | boundary.halfDimension = halfDimension 47 | End Sub 48 | 49 | ' @description returns the axis-aligned bounding box of this QuadTree 50 | ' @return returns the axis-aligned bounding box of this QuadTree 51 | Public Function getBoundary() As AABB 52 | Set getBoundary = boundary 53 | End Function 54 | 55 | 56 | Public Sub demo() 57 | Dim qt As QuadTree, i As Long, halfSize As Double, queryResults As Collection, p As XYpoint 58 | Set qt = New QuadTree 59 | halfSize = 400 60 | qt.setBoundary 400, 400, halfSize 61 | 62 | For i = 1 To 500 63 | qt.insertCoordinate WorksheetFunction.NormInv(Rnd(), 400, halfSize), WorksheetFunction.NormInv(Rnd(), 400, halfSize) 64 | Next i 65 | 66 | qt.drawTree 67 | 68 | Set p = New XYpoint 69 | p.x = Rnd() * halfSize 70 | p.y = Rnd() * halfSize 71 | 72 | Debug.Print "Query Target Center: " & p.getTranslation(-halfSize, -halfSize).toString & vbCrLf & "Query Target Size: " & 2 * (halfSize - 1) 73 | Set queryResults = qt.queryRangeBoundary(p.x, p.y, halfSize - 1) 74 | 75 | For Each p In queryResults 76 | Debug.Print " " & p.toString() 77 | Next p 78 | 79 | End Sub 80 | 81 | ' @description inserts a point into the QuadTree 82 | ' @param x the x-coodinate of the new point 83 | ' @param y the y-coordinate of the new point 84 | ' @return returns true if the point was successfully inserted; returns false, otherwise. 85 | Public Function insertCoordinate(x As Double, y As Double) As Boolean 86 | Dim p As XYpoint 87 | Set p = New XYpoint 88 | p.x = x 89 | p.y = y 90 | insertCoordinate = insertPoint(p) 91 | End Function 92 | 93 | ' @description inserts a point into the QuadTree 94 | ' @param x the x-coodinate of the new point 95 | ' @param y the y-coordinate of the new point 96 | ' @return returns true if the point was successfully inserted; returns false, otherwise. 97 | Public Function insertPoint(p As XYpoint) As Boolean 98 | 99 | 'ignore objects that do not belong to this quad tree node 100 | If (Not boundary.contains(p)) Then 101 | insertPoint = False 102 | Exit Function 103 | End If 104 | 105 | 'if this node has not been subdivided 106 | If northWest Is Nothing Then 107 | 'check if there is still room at this level of the tree 108 | If points.count < QT_NODE_CAPACITY Then 109 | points.add p 110 | insertPoint = True 111 | Exit Function 112 | Else 113 | 'otherwise, subdivide add redistribute the contained points among its children 114 | subdivide 115 | End If 116 | End If 117 | 118 | If northWest.insertPoint(p) Then 119 | insertPoint = True 120 | Exit Function 121 | ElseIf northEast.insertPoint(p) Then 122 | insertPoint = True 123 | Exit Function 124 | ElseIf southWest.insertPoint(p) Then 125 | insertPoint = True 126 | Exit Function 127 | ElseIf southEast.insertPoint(p) Then 128 | insertPoint = True 129 | Exit Function 130 | End If 131 | 132 | 'otherwise, the point cannot be inserted for some unknown reason (should never happen) 133 | insertPoint = False 134 | 135 | End Function 136 | 137 | ' @description a factory method for producing a QuadTree 138 | ' @param centerLocation the point at which the QuadTree is centered 139 | ' @param halfDimension the distance to the dividing edge of the QuadTree's area of coverage 140 | ' @return returns a quadtree with the specified center and height/width 141 | Public Function factory(centerLocation As XYpoint, halfDimension As Double) As QuadTree 142 | Dim qt As QuadTree, range As AABB 143 | Set qt = New QuadTree 144 | qt.setBoundary centerLocation.x, centerLocation.y, halfDimension 145 | Set factory = qt 146 | End Function 147 | 148 | 'subdivides this quadtree into 4 child quadtrees and then distributes points according to their XY coordinates 149 | Private Sub subdivide() 150 | Dim newSize As Double, p As XYpoint 151 | newSize = boundary.halfDimension / 2# 152 | 153 | 'prepare child quadtrees 154 | Set northWest = factory(boundary.center.getTranslation(-newSize, -newSize), newSize) 155 | Set northEast = factory(boundary.center.getTranslation(newSize, -newSize), newSize) 156 | Set southWest = factory(boundary.center.getTranslation(-newSize, newSize), newSize) 157 | Set southEast = factory(boundary.center.getTranslation(newSize, newSize), newSize) 158 | 159 | 'move points in this quadtree node to the appropriate child node 160 | For Each p In points 161 | 'if the point p is successfully inserted into any one of the children, then the subsequent IfElse statements are not evaluated. And we continue moving the remaining points 162 | If northWest.insertPoint(p) Then 163 | ElseIf northEast.insertPoint(p) Then 164 | ElseIf southWest.insertPoint(p) Then 165 | ElseIf southEast.insertPoint(p) Then 166 | Else 167 | err.Raise 17, Description:="Illegal state: Unable to find appropriate child node for subdividion." 168 | End If 169 | Next p 170 | 171 | 'since all points now reside in the child quadtree nodes, clear the points Collection 172 | Set points = New Collection 173 | 174 | End Sub 175 | 176 | Public Function queryRangeBoundary(centerX As Double, centerY As Double, boundaryHalfDimension As Double) As Collection 177 | Dim range As AABB 178 | Set range = New AABB 179 | range.center.x = centerX 180 | range.center.y = centerY 181 | range.halfDimension = boundaryHalfDimension 182 | Set queryRangeBoundary = queryRange(range) 183 | End Function 184 | 185 | Public Function queryRange(range As AABB) As Collection 186 | Dim pointsInRange As Collection, p As XYpoint 187 | Set pointsInRange = New Collection 188 | 189 | 'automatically abort if range does not intersect this quad 190 | If Not boundary.intersects(range) Then 191 | Set queryRange = pointsInRange 192 | Exit Function 193 | End If 194 | 195 | 'check objects at this quad level 196 | For Each p In points 197 | If range.contains(p) Then 198 | pointsInRange.add p 199 | End If 200 | Next p 201 | 202 | 'terminate here if there are no children 203 | If northWest Is Nothing Then 204 | Set queryRange = pointsInRange 205 | Exit Function 206 | End If 207 | 208 | 'otherwise, recursively add points from the children 209 | Collections.addAll pointsInRange, northWest.queryRange(range) 210 | Collections.addAll pointsInRange, northEast.queryRange(range) 211 | Collections.addAll pointsInRange, southWest.queryRange(range) 212 | Collections.addAll pointsInRange, southEast.queryRange(range) 213 | 214 | Set queryRange = pointsInRange 215 | 216 | End Function 217 | 218 | Public Function contains(p As XYpoint) As Boolean 219 | contains = boundary.contains(p) 220 | End Function 221 | 222 | 223 | Public Sub drawTree() 224 | Dim wksht As Worksheet, p As XYpoint, r As Single, left As Single, top As Single, width As Single, height As Single, shp As Shape 225 | Set wksht = ThisWorkbook.Sheets.add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count)) 226 | r = 2 227 | 228 | 'draw boundary 229 | left = boundary.center.x - boundary.halfDimension + 1 230 | top = boundary.center.y - boundary.halfDimension + 1 231 | width = 2 * boundary.halfDimension 232 | height = 2 * boundary.halfDimension 233 | Set shp = wksht.Shapes.AddShape(msoShapeRectangle, left, top, width, height) 234 | shp.Line.Visible = msoTrue 235 | shp.Line.Weight = 0.1 236 | shp.Line.ForeColor.RGB = RGB(0, 0, 0) 237 | shp.Fill.Visible = msoTrue 238 | shp.Fill.Transparency = 0.8 239 | shp.Fill.ForeColor.RGB = RGB(120, 120, 120) 240 | shp.TextFrame.characters.Text = points.count 241 | shp.TextFrame.characters.Font.ColorIndex = 2 242 | shp.TextFrame.VerticalAlignment = xlVAlignCenter 243 | shp.TextFrame.HorizontalAlignment = xlHAlignCenter 244 | 245 | 'recurse 246 | If Not northWest Is Nothing Then 247 | northWest.drawTree 248 | northEast.drawTree 249 | southWest.drawTree 250 | southEast.drawTree 251 | 252 | Set shp = wksht.Shapes.AddLine(boundary.center.x, boundary.center.y, northWest.getBoundary().center.x, northWest.getBoundary().center.y) 253 | Set shp = wksht.Shapes.AddLine(boundary.center.x, boundary.center.y, northEast.getBoundary().center.x, northEast.getBoundary().center.y) 254 | Set shp = wksht.Shapes.AddLine(boundary.center.x, boundary.center.y, southWest.getBoundary().center.x, southWest.getBoundary().center.y) 255 | Set shp = wksht.Shapes.AddLine(boundary.center.x, boundary.center.y, southEast.getBoundary().center.x, southEast.getBoundary().center.y) 256 | 257 | End If 258 | 259 | 'draw points last so they are on top 260 | For Each p In points 261 | Set shp = wksht.Shapes.AddShape(msoShapeOval, left:=p.x - r + 1, top:=p.y - r + 1, width:=2 * r, height:=2 * r) 262 | shp.Line.Visible = msoFalse 263 | shp.Fill.Transparency = 0.3 264 | shp.Fill.ForeColor.RGB = RGB(0, 0, 0) 265 | Next p 266 | 267 | End Sub 268 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # VBA-utilities 2 | VBA-utilities is a collection of helpful modules for programming in VBA. It is important to note, these modules are all programed using the `Option Base 0` and `Option Compare Text` settings. 3 | 4 | ## Modules 5 | This section lists each of the modules along with a brief description of their purpose. 6 | 7 | ### Arrays 8 | The `Arrays` module contains various methods for manipulating arrays in VBA, e.g. copying and sorting. The `Arrays` module requires the `IVariantComparator` module be loaded. Useage example: an array `A()` can be sorted using the following method call 9 | 10 | Arrays.sort A() 11 | 12 | If using a custom `IVariantComparator`, the order of elements can be customized. 13 | 14 | The `Arrays.copyOf` method produces a 1D copy of the entire original array, and the `Arrays.copy` method copies a subrange of the source array, `src` to the destination array, `dest` 15 | 16 | ### Collections 17 | The `Collections` module contains various methods for manipulating collections in VBA. Specifically, the module provides methods to check if a collection contains a specific element and also to retrieve its index, and to sort a collection (requires the `Arrays` and `IVariantComparator` modules to be loaded). For a collection `col`, the following is a list of example method calls: 18 | 19 | Dim bVal1 As Boolean 20 | bVal1 = Collections.contains("hello world", col) 21 | 22 | Dim bVal2 As Boolean 23 | bVal = Collections.hasKey(5, col) 24 | 25 | Dim iVal As Long 26 | iVal = Collections.indexOf("hello world", col) 27 | 28 | The sort method for the `Collections` module 29 | 30 | Collections.sort col 31 | 32 | -------------------------------------------------------------------------------- /Random.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Random" 2 | Option Explicit 3 | 4 | ' This Class extends the functionality of the built-in Rnd function by 5 | ' providing functions for generating pseudorandom strings, integers, Longs, etc. 6 | ' 7 | ' Warning: If you don't call the Randomize function before calling these 8 | ' functions, they may return the same sequence of pseudorandom numbers across 9 | ' multiple function calls 10 | 11 | ' the array of characters from which the NextString method will select characters unless an alternative string of characters is supplied 12 | Private Const CHAR_ARR As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" 13 | 14 | ' The length of the CHAR_ARR constant 15 | Private Const LEN_CHAR_ARR As Integer = 62 16 | 17 | ' The value of PI 18 | Private Const PI As Double = 3.14159265358979 19 | 20 | ' The most recent string returned by the NextString method; can be accessed via the LastString method 21 | Private LastStringValue As String 22 | 23 | ' The most recent Boolean value returned by the NextBoolean method; can be accessed via the LastBoolean method 24 | Private LastBoolValue As Boolean 25 | 26 | ' The most recent Long value returned by the NextLong method; can be accessed via the LastLong method 27 | Private LastLongValue As Long 28 | 29 | ' @description Equivalent to the VBA Randomize method. Resets the seed of the pseudorandom number generator. 30 | ' @param seed Optional. a numeric seed that will be used by the RND function to generate a pseudorandom number. If no seed value is provided, the system timer as the seed value for the RND function. 31 | Public Sub setSeed(Optional seed As Long) 32 | If (seed Is Nothing) Then 33 | Randomize 34 | Else 35 | Rnd (-1) ' This must be called 36 | Randomize (seed) 37 | End 38 | End Sub 39 | 40 | 41 | ' @description Generates a randomized string of characters. A new pseudorandom string is generated with each call to the NextString method, and the value is cached in a persistent variable. The last value can be accessed after-the-fact using the {@ref LastString} method. 42 | ' @param length Optional. The desired length of the resulting string. If no value is provided, the default length of eight (8) is used. 43 | ' @param characters Optional. A string from which characters will be selected at random. If not provided, a pseudorandom string will be generated using characters 0-9, A-z 44 | Public Function NextString(Optional length As Long = 8, Optional characters As String = CHAR_ARR) As String 45 | 46 | Dim s As String 47 | s = Space(length) 48 | Dim charLen As Long 49 | charLen = Len(characters) - 1 50 | Dim n As Long 51 | Dim nl As Long 52 | For n = 1 To length 'don't hardcode the length twice 53 | nl = NextLong(1, charLen) 54 | Mid(s, n, 1) = Mid(characters, nl, 1) 'bit more efficient than concatenation 55 | Next 56 | 57 | LastStringValue = s 58 | NextString = s 59 | 60 | End Function 61 | 62 | '@description Returns the last pseudorandom string generated by the {@ref NextString} method 63 | '@return the last pseudorandom string generated by the NextString method. If the NextString method has not been called, returns the empty String "" 64 | Public Function LastString() As String 65 | LastString = LastStringValue 66 | End Function 67 | 68 | '@description Returns a pseudorandom Long value within the specified bounds. Formally, given a lower bound L and upper bound U, returns a random value x, such that L<=x<=U. A new random number is returned after each call to this method. The most recently returned value can be retrieved after-the-fact usign the {@ref LastLong} method 69 | '@param LowerBound Optional. The smallest Long value returned by the function. If no value is specified, 0 is used as the lower bound. 70 | '@param UpperBound Optional. The largest Long value returned by the function. If no value is specified, the maximum Long value (i.e. 2,147,483,647) is used as the upper bound. 71 | '@return Returns 72 | Public Function NextLong(Optional LowerBound As Long = 0, Optional UpperBound As Long = 2147483647) As Long 73 | NextLong = (UpperBound - LowerBound + 1) * Rnd + LowerBound 74 | LastLongValue = NextLong 75 | End Function 76 | 77 | '@description Returns the last pseudorandom Long generated by the {@ref NextLong} method 78 | '@return the last pseudorandom Long generated by the {@ref NextLong} method. If the NextLong method has not been called, returns 0. 79 | Public Function LastLong() As Long 80 | LastLong = LastLongValue 81 | End Function 82 | 83 | '@description Used to get a pseudorandom, uniformly distributed boolean value. The likelihood of receiving a TRUE value can be adjusted parametrically, but by default TRUE appears 50% of the time. A new random Boolean is returned after each call to this method. The most recently returned value can be retrieved after-the-fact usign the {@ref LastBoolean} method 84 | '@param trueFrequency Optional. The likelihood (probability) of receiving a TRUE value. If not specified, the function assumes a 50% likelihood. 85 | '@return Returns a Boolean value with the likelihood of the value being TRUE equal to the trueFrequency parameter 86 | Public Function NextBoolean(Optional trueFrequency As Double = 0.5) As Boolean 87 | NextBoolean = IIf(Rnd() < trueFrequency, True, False) 88 | End Function 89 | 90 | '@description Returns the last pseudorandom Boolean generated by the {@ref NextBoolean} method 91 | '@return the last pseudorandom Boolean generated by the {@ref NextBoolean} method. If the NextBoolean method has not been called, returns FALSE. 92 | Public Function LastBoolean(Optional trueFrequency As Double = 0.5) As Boolean 93 | LastBoolean = LastBoolValue 94 | End Function 95 | 96 | '@description returns the probability that the observed value of a normal random variable with given mean and standard deviation will be less than or equal to x. 97 | '@param x The observed value 98 | '@param mean Optional. The mean of the normal random variable. If no value is given, a mean of 0 is used. 99 | '@param standard_dev the standard deviation of the normal random variable. If no value is given, a standard deviation of 1 is used. 100 | '@return Returns the probability that the observed value x would be drawn from a normal random variable with the given mean and standard deviation 101 | Public Function NormDistVBA(x As Double, Optional mean As Double = 0, Optional standard_dev As Double = 1) As Double 102 | Dim expNum As Double, expDenom As Double, denom As Double 103 | expNum = -((x - mean) * (x - mean)) 104 | expDenom = 2 * standard_dev * standard_dev 105 | denom = standard_dev * Sqr(2 * PI) 106 | NormDistVBA = (1 / denom) * Exp(expNum / expDenom) 107 | End Function 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | -------------------------------------------------------------------------------- /Strings.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Strings" 2 | Option Base 0 3 | 4 | ' Computes the Levenshtein distance between two strings. Levenshtein distance (LD) is a measure of the similarity 5 | ' between two strings: the source, string1, and the target, string2. The distance is the number of deletions, insertions, 6 | ' or substitutions required to transform string1 into string2. 7 | ' This implementation is provided by Patrick OBeirne of StackOverflow.com (ref http://stackoverflow.com/a/11584381/3795219) 8 | Function Levenshtein(ByVal string1 As String, ByVal string2 As String) As Long 9 | 10 | 'POB: fn with byte array is 17 times faster 11 | Dim i As Long, j As Long, bs1() As Byte, bs2() As Byte 12 | Dim string1_length As Long 13 | Dim string2_length As Long 14 | Dim distance() As Long 15 | Dim min1 As Long, min2 As Long, min3 As Long 16 | 17 | string1_length = Len(string1) 18 | string2_length = Len(string2) 19 | ReDim distance(string1_length, string2_length) 20 | bs1 = string1 21 | bs2 = string2 22 | 23 | For i = 0 To string1_length 24 | distance(i, 0) = i 25 | Next 26 | 27 | For j = 0 To string2_length 28 | distance(0, j) = j 29 | Next 30 | 31 | For i = 1 To string1_length 32 | For j = 1 To string2_length 33 | 'slow way: If Mid$(string1, i, 1) = Mid$(string2, j, 1) Then 34 | If bs1((i - 1) * 2) = bs2((j - 1) * 2) Then ' *2 because Unicode every 2nd byte is 0 35 | distance(i, j) = distance(i - 1, j - 1) 36 | Else 37 | 38 | ' spell it out, 50 times faster than worksheetfunction.min 39 | min1 = distance(i - 1, j) + 1 40 | min2 = distance(i, j - 1) + 1 41 | min3 = distance(i - 1, j - 1) + 1 42 | If min1 <= min2 And min1 <= min3 Then 43 | distance(i, j) = min1 44 | ElseIf min2 <= min1 And min2 <= min3 Then 45 | distance(i, j) = min2 46 | Else 47 | distance(i, j) = min3 48 | End If 49 | 50 | End If 51 | Next 52 | Next 53 | 54 | Levenshtein = distance(string1_length, string2_length) 55 | 56 | End Function 57 | 58 | Public Function JaccardDistance(ByVal A As String, ByVal B As String, Optional k As Long = 5) As Double 59 | Dim aUb As Scripting.Dictionary, aSet As Scripting.Dictionary, bSet As Scripting.Dictionary 60 | Dim m As Long 'length of A 61 | Dim n As Long 'length of B 62 | Dim ngram As Variant 63 | Dim aNb_Size As Long 64 | Dim i As Long 65 | 66 | If A = B Then 67 | JaccardDistance = 1# 68 | Exit Function 69 | End If 70 | 71 | Set aUb = New Scripting.Dictionary 72 | Set aSet = getNgramProfile(A, k) 73 | Set bSet = getNgramProfile(B, k) 74 | 75 | 'compute the intersection and unions 76 | For Each ngram In aSet 77 | aUb(ngram) = ngram 78 | Next ngram 79 | For Each ngram In bSet 80 | aUb(ngram) = ngram 81 | Next ngram 82 | 83 | aNb_Size = aSet.Count + bSet.Count - aUb.Count 84 | JaccardDistance = aNb_Size / aUb.Count 85 | 86 | 87 | ' For Each i In aUb 88 | ' Next i 89 | 90 | End Function 91 | 92 | Private Function getNgramProfile(s As String, Optional k As Long = 3) As Scripting.Dictionary 93 | Dim i As Long 94 | Dim old As Long 95 | Dim ngram As String 96 | Dim ngrams As Scripting.Dictionary 97 | Dim string_no_space As String 98 | string_no_space = normalize(s, " ,./;'[]\!@#$%^&*()_") 'Replace(s, " ", "") 99 | Set ngrams = New Scripting.Dictionary 100 | 101 | 102 | For i = 1 To (Len(string_no_space) - k + 1) 103 | ngram = Mid(string_no_space, i, k) 104 | If ngrams.Exists(ngram) Then 105 | old = ngrams.Item(ngram) 106 | ngrams(ngram) = old + 1 107 | Else 108 | ngrams(ngram) = 1 109 | End If 110 | 111 | Next i 112 | 113 | Set getNgramProfile = ngrams 114 | 115 | End Function 116 | 117 | Private Function normalize(s As String, special_characters As String) As String 118 | Dim i As Long 119 | 120 | For i = 1 To Len(special_characters) 121 | s = replace(s, Mid(special_characters, i, 1), "") 122 | Next i 123 | 124 | normalize = s 125 | End Function 126 | 127 | 128 | 'FuzzyMatch uses the Levenshtein distance to match strings in the input array to strings in the output array. The results 129 | 'are printed to the current worksheet in a 3-column output range defined prior to execution. The first column shows the 130 | 'string in the search array that is closest to the input string. The second column shows the Levenshtein distance between 131 | 'the closest match. The third column shows the proportional similarity between the Levenshtein distance and the length of 132 | 'the longer of the two strings, i.e. the input and the closest match; it is useful for giving a relative similarity among 133 | 'a large list of strings 134 | Public Function FuzzyMatch(lookup_value As String, table_array As range) As Variant 135 | 136 | Dim c As range, result(1 To 3) As Variant, cell_value As String, min_dist As Long, best_match As String, _ 137 | lev_dist As Long 138 | 139 | 'normalize the lookup_value by removing extra spaces 140 | lookup_value = Trim(lookup_value) 141 | 142 | For Each c In table_array 143 | If (Trim(c.value) = lookup_value) Then 144 | result(1) = c.value 145 | result(2) = 0 ' zero levenshtein distance 146 | result(3) = 1 ' perfect match is 100% accurate 147 | FuzzyMatch = result 148 | Exit Function 149 | End If 150 | Next c 151 | 152 | 'No exact match found, must compute values pairwise to determine 153 | min_dist = 2147483647 154 | best_match = xlErrNA 155 | 156 | For Each c In table_array 157 | cell_value = Trim(c.value) 158 | lev_dist = Levenshtein(lookup_value, cell_value) 159 | If lev_dist < min_dist Then 160 | min_dist = lev_dist 161 | best_match = c.value 'use unnormalized cell value 162 | End If 163 | Next c 164 | 165 | result(1) = best_match 166 | result(2) = min_dist 167 | result(3) = 1 - (min_dist) / IIf(Len(best_match) > Len(input_val), Len(best_match), Len(input_val)) 168 | 169 | FuzzyMatch = result 170 | 171 | End Function 172 | 173 | 'FuzzyMatch uses the Levenshtein distance to match strings in the input array to strings in the output array. The results 174 | 'are printed to the current worksheet in a 3-column output range defined prior to execution. The first column shows the 175 | 'string in the search array that is closest to the input string. The second column shows the Levenshtein distance between 176 | 'the closest match. The third column shows the proportional similarity between the Levenshtein distance and the length of 177 | 'the longer of the two strings, i.e. the input and the closest match; it is useful for giving a relative similarity among 178 | 'a large list of strings 179 | Sub FuzzyMatch_Batch() 180 | 181 | Dim _ 182 | input_arr As range, _ 183 | search_arr As range, _ 184 | ouptut_arr As range, _ 185 | search_val As range, _ 186 | input_val As range, _ 187 | min_dist As Long, _ 188 | best_match As String, _ 189 | lev_dist As Long, _ 190 | i As Long, _ 191 | n As Long, _ 192 | m As Long, _ 193 | outputValues() As String 194 | 195 | 196 | 197 | Set input_arr = Application.InputBox("Select input values", "Obtain Range Object", Type:=8) 198 | Set search_arr = Application.InputBox("Select lookup table array", "Obtain Range Object", Type:=8) 199 | Set output_arr = Application.InputBox("Select Top Left corner of output range", "Obtain Range Object", Type:=8) 200 | 201 | n = input_arr.Count 202 | m = search_arr.Count 203 | 204 | 205 | If m > 500 Then 206 | If MsgBox("The search array you provided contains " & m & " elements. Processing " & n & " input values against this search space may take a while. Do you wish to continue?", vbYesNo, "Large Selection Detected") = vbNo Then 207 | Exit Sub 208 | End If 209 | End If 210 | 211 | ReDim outputValues(1 To 3, 1 To n) 212 | 213 | i = 1 214 | 215 | For Each input_val In input_arr 216 | 217 | If i Mod 10 = 0 Then 218 | Application.StatusBar = "Fuzzy matching item: " & i & " of " & n 219 | output_arr.Resize(n, 3).value = Application.transpose(outputValues) 220 | End If 221 | 222 | min_dist = 2147483647 223 | best_match = xlErrNA 224 | 225 | For Each search_val In search_arr 226 | If input_val.value = search_val.value Then 227 | min_dist = 0 228 | best_match = search_val.value 229 | GoTo ExitFor 230 | End If 231 | 232 | lev_dist = Levenshtein(Trim(input_val.value), Trim(search_val.value)) 233 | If lev_dist < min_dist Then 234 | min_dist = lev_dist 235 | best_match = Trim(search_val.value) 236 | End If 237 | 238 | Next search_val 239 | 240 | ExitFor: 241 | 242 | outputValues(1, i) = best_match 243 | outputValues(2, i) = min_dist 244 | outputValues(3, i) = 1 - (min_dist) / IIf(Len(best_match) > Len(input_val), Len(best_match), Len(input_val)) 245 | 246 | i = i + 1 247 | Next input_val 248 | 249 | 'Copy output to worksheet 250 | output_arr.Resize(n, 3).value = Application.transpose(outputValues) 251 | 252 | Application.StatusBar = "" 253 | 254 | End Sub 255 | 256 | 257 | -------------------------------------------------------------------------------- /TadpoleChart.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "TadpoleChart" 2 | Option Explicit 3 | 4 | Sub createTadpoleChart() 5 | 'Creates a tadpole chart using two sets of data. The length of the tadpole _ 6 | tails is determined by the number of rows in the data matrices. The number _ 7 | of tadpoles is equal to the number of columns in the data matrices. 8 | 9 | 10 | Dim xDataRange, yDataRange As String 11 | xDataRange = "xAxisDataMatrix" 12 | yDataRange = "YAxisDataMatrix" 13 | 14 | 15 | Dim ChartObj As ChartObject 16 | Set ChartObj = ActiveSheet.ChartObjects.add(Left:=20, Width:=800, Top:=20, Height:=500) 17 | ChartObj.Chart.ChartType = xlXYScatterSmoothNoMarkers 18 | 19 | Dim teamId As Integer 20 | 21 | Dim teamCount, tailLength As Integer 22 | Dim xRng, yRng As range 23 | Dim ChartSeries As Series 24 | 25 | teamCount = range(xDataRange).Columns.Count 26 | tailLength = range(xDataRange).Rows.Count 27 | 28 | tailLength = 4 29 | 30 | For teamId = 1 To teamCount 31 | 32 | With range(xDataRange).Cells(0, 0) 33 | Set xRng = range(.offset(1, teamId), .offset(tailLength, teamId)) 34 | End With 35 | With range(yDataRange).Cells(0, 0) 36 | Set yRng = range(.offset(1, teamId), .offset(tailLength, teamId)) 37 | End With 38 | 39 | Debug.Print "----" & teamId & "----" 40 | Debug.Print "x Range: " & xRng.Address 41 | Debug.Print "y Range: " & yRng.Address 42 | 43 | 44 | 45 | Set ChartSeries = ChartObj.Chart.SeriesCollection.NewSeries 46 | With ChartSeries 47 | .XValues = xRng.Cells 48 | .values = yRng.Cells 49 | .Name = "Team " & teamId 50 | .Format.Line.DashStyle = msoLineSolid 51 | .Format.Line.Transparency = 0.25 52 | End With 53 | 54 | Dim headPoint As Point 55 | Set headPoint = ChartSeries.Points(1) 56 | headPoint.MarkerStyle = xlMarkerStyleDiamond 57 | headPoint.MarkerForegroundColor = ColorConstants.vbBlack 58 | headPoint.MarkerSize = 8 59 | 60 | Next teamId 61 | 62 | 'ChartObj.Activate 63 | ' With ChartObj.Chart 64 | ' .SetElement (msoElementLegendBottom) 65 | ' .Axes(xlValue).MajorUnit = 1 66 | ' .Axes(xlValue).MinorUnit = 0.5 67 | ' .Axes(xlValue).MinorTickMark = xlOutside 68 | ' '.Axes(xlCategory).TickLabels.NumberFormat = "#,##000" 69 | ' .Axes(xlCategory).TickLabels.NumberFormat = "#,##0" 70 | ' '.Location Where:=xlLocationAsObject, Name:="Plot" 71 | ' End With 72 | 73 | End Sub 74 | -------------------------------------------------------------------------------- /Timer.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "Timer" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | 11 | ' A high-precision timer class used to test performance of VBA code. 12 | ' This class was copied from the StackOverflow answer at http://stackoverflow.com/a/198702/3795219 13 | 14 | Option Explicit 15 | 16 | Private Type LARGE_INTEGER 17 | lowpart As Long 18 | highpart As Long 19 | End Type 20 | 21 | Private Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As LARGE_INTEGER) As Long 22 | Private Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As LARGE_INTEGER) As Long 23 | 24 | Private m_CounterStart As LARGE_INTEGER 25 | Private m_CounterEnd As LARGE_INTEGER 26 | Private m_crFrequency As Double 27 | 28 | Private Const TWO_32 = 4294967296# ' = 256# * 256# * 256# * 256# 29 | 30 | Private Function LI2Double(LI As LARGE_INTEGER) As Double 31 | Dim Low As Double 32 | Low = LI.lowpart 33 | If Low < 0 Then 34 | Low = Low + TWO_32 35 | End If 36 | LI2Double = LI.highpart * TWO_32 + Low 37 | End Function 38 | 39 | Private Sub Class_Initialize() 40 | Dim PerfFrequency As LARGE_INTEGER 41 | QueryPerformanceFrequency PerfFrequency 42 | m_crFrequency = LI2Double(PerfFrequency) 43 | End Sub 44 | 45 | Public Sub StartCounter() 46 | QueryPerformanceCounter m_CounterStart 47 | End Sub 48 | 49 | Property Get TimeElapsed() As Double 50 | Dim crStart As Double 51 | Dim crStop As Double 52 | QueryPerformanceCounter m_CounterEnd 53 | crStart = LI2Double(m_CounterStart) 54 | crStop = LI2Double(m_CounterEnd) 55 | TimeElapsed = 1000# * (crStop - crStart) / m_crFrequency 56 | End Property 57 | -------------------------------------------------------------------------------- /Utils.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Utils" 2 | 3 | Public Function Logistic(x, x_0, k, L) 4 | 'The Logistic family of functions exhibit a common "S" shaped curve behavior. 5 | ' Inputs: 6 | ' x = the input value, a real number from -infty to +infty 7 | ' x_0 = the x-value of the sigmoid's midpoint 8 | ' L = the curve's maximum value 9 | ' k = the steepness of the curve 10 | 11 | Logistic = L / (1 + Exp(-k * (x - x_0))) 12 | End Function 13 | 14 | 15 | Public Function Sigmoid(x) 16 | 'A special case of the logistic curve where x_0=0.5, L=1, and k=1. Sigmoids are commonly used as the activation function of artificial neurons and statistics as the CDFs 17 | ' Inputs: 18 | ' x = the input value, a real number from -infty to +infty 19 | Sigmoid = 1 / (1 + Exp(-x)) 20 | End Function 21 | 22 | Public Function ReLU(x) 23 | 'Rectifier is an activation function equal to max(0,x). ReLU is used extensively in the context of artificial neural networks. 24 | ReLU = IIf(x > 0, x, 0) 25 | End Function 26 | 27 | Public Function LeakyReLU(x, A) 28 | 'Rectifier that allows a small, non-zero gradient when the unit is not active. 29 | ' Inputs: 30 | ' x = the input scalar value, a real number from -infty to +infty 31 | ' a = the coefficient of leakage 32 | LeakyReLU = IIf(x > 0, x, A * x) 33 | End Function 34 | 35 | Public Function NoisyReLU(x) 36 | 'Rectifier that includes Gaussian noise. 37 | 38 | Dim Y As Double 39 | Y = WorksheetFunction.Norm_Inv(Rnd(), 0, Sigmoid(x)) + x 40 | NoisyReLU = IIf(Y > 0, Y, 0) 41 | End Function 42 | 43 | Public Function Softplus(x) 44 | 'Softplus is a smooth approximation of the Linear rectifier function 45 | Softplus = Math.Log(1 + Exp(x)) 46 | End Function 47 | 48 | 49 | Public Function CosineSimilarity(ByRef Arr1 As range, ByRef Arr2 As range) 50 | 'Computes the Cosine Similarity Metric between two Ranges. Cosine similarity is a measure of similarity between two non-zero vectors of an inner product space that measures the cosine of the angle between them. 51 | 52 | AB = Dot(Arr1, Arr2) 53 | AA = Dot(Arr1, Arr1) 54 | BB = Dot(Arr2, Arr2) 55 | 56 | CosineSimilarity = AB / (Sqr(AA) * Sqr(BB)) 57 | 58 | End Function 59 | 60 | Public Function Hamming(s As String, t As String) 61 | 'Computes the hamming distance between two Strings. Hamming Distance measures the minimum number of substitutions required to change one string into the other, or the minimum number of errors that could have transformed one string into the other 62 | Dim i As Long, cost As Long 63 | 64 | If Len(s) <> Len(t) Then 65 | err.Raise xlErrValue 66 | End If 67 | 68 | cost = 0 69 | 70 | For i = 1 To Len(s) 71 | If Mid(s, i, 1) <> Mid(t, i, 1) Then 72 | cost = cost + 1 73 | End If 74 | Next i 75 | 76 | Hamming = cost 77 | 78 | End Function 79 | 80 | 81 | Public Function Levenshtein(s As String, t As String) 82 | 'Computs the Levenshtein distance between two Strings. Levenshtein distance is a metric for measuring the difference between two Strings. Informally, the Levenshtein distance between two words is the minimum number of single-character edits (insertions, deletions or substitutions) required to change one word into the other. 83 | Dim v0() As Long, v1() As Long, temp() As Long, m As Long, n As Long, i As Long, j As Long, substitutionCost As Long 84 | m = Len(s) 85 | n = Len(t) 86 | 87 | 'create two work vectors 88 | ReDim v0(0 To n + 1) 89 | ReDim v1(0 To n + 1) 90 | 91 | 'initialize v0 (the previous row of distances 92 | 'this row is A[0][i]: edit distance for an empty s 93 | 'the distance is just the number of characters to delete from t 94 | 95 | For i = 0 To n 96 | v0(i) = i 97 | Next i 98 | 99 | For i = 0 To m - 1 100 | 'calculate v1 (current row distances) from the previous row v0 101 | 102 | 'first element of v1 is A[i+1][0] 103 | ' edit distance is delete(i+1) chars from s to match empty t 104 | v1(0) = i + 1 105 | 106 | 'use formula to fill in the rest of the row 107 | For j = 0 To n - 1 108 | If Mid(s, i + 1, 1) = Mid(t, j + 1, 1) Then 109 | substitutionCost = 0 110 | Else 111 | substitutionCost = 1 112 | End If 113 | 114 | v1(j + 1) = WorksheetFunction.min(v1(j) + 1, v0(j + 1) + 1, v0(j) + substitutionCost) 115 | 116 | Next j 117 | 118 | 'copy v1 (current row) to v0 (previous row for each iteration 119 | temp = v1 120 | v1 = v0 121 | v0 = temp 122 | Next i 123 | 124 | Levenshtein = v0(n) 125 | 126 | End Function 127 | 128 | 129 | Public Function Dot(ByRef A As range, ByRef B As range) 130 | 'Computes the dot product between two ranges. Assumes ranges are equally sized 131 | Dot = Application.Evaluate("SUMPRODUCT(" & A.Address & "," & B.Address & ")") 132 | End Function 133 | 134 | -------------------------------------------------------------------------------- /VBA-Utilities.xlam: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/austinleedavis/VBA-utilities/d5bc080dc787d2795ffcc1b6244a3e0e2bb7856f/VBA-Utilities.xlam -------------------------------------------------------------------------------- /XYPoint.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "XYPoint" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | 'simple coordinate object to represent points and vectors 11 | Public x As Double 12 | Public y As Double 13 | 14 | Public Function getTranslation(xShift As Double, yShift As Double) As XYpoint 15 | Dim p As XYpoint 16 | Set p = New XYpoint 17 | p.x = x + xShift 18 | p.y = y + yShift 19 | Set getTranslation = p 20 | End Function 21 | 22 | 23 | Public Function toString() As String 24 | toString = "[Class: XYPoint; x: " & x & ", y: " & y & " ]" 25 | End Function 26 | -------------------------------------------------------------------------------- /iCollection.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "iCollection" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | Option Explicit 11 | 12 | Public Function add(ByRef e As Variant) As Boolean 13 | 'interface method 14 | End Function 15 | 16 | Public Function addAll(ByRef c As iCollection) As Boolean 17 | 'interface method 18 | End Function 19 | 20 | Public Sub clear() 21 | 'interface method 22 | End Sub 23 | 24 | Public Function contains(ByRef o As Variant) As Boolean 25 | 'interface method 26 | End Function 27 | 28 | Public Function equals(ByRef o As Variant) As Boolean 29 | 'interface method 30 | End Function 31 | 32 | Public Function hashCode() As Long 33 | 'interface method 34 | End Function 35 | 36 | Public Function isEmpty() As Boolean 37 | 'interface method 38 | End Function 39 | 40 | 'iterator() 41 | 42 | 'parallelStream() 43 | 44 | Public Function remove(ByRef o As Variant) As Boolean 45 | 'interface method 46 | End Function 47 | 48 | Public Function removeAll(ByRef c As iCollection) As Boolean 49 | 'interface method 50 | End Function 51 | 52 | Public Function retainAll(ByRef c As iCollection) As Boolean 53 | 'interface method 54 | End Function 55 | 56 | Public Function size() As Long 57 | 'interface method 58 | End Function 59 | 60 | 'spliterator 61 | 'stream 62 | Public Function ToArray() As Variant() 63 | 'interface method 64 | End Function 65 | 66 | Public Property Get NewEnum() As IUnknown 67 | Attribute NewEnum.VB_UserMemId = -4 68 | ''specified in iIterable 69 | End Property 70 | 71 | -------------------------------------------------------------------------------- /iIterable.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "iIterable" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | Option Explicit 11 | 12 | 'Interface for custom data structures that implies all instances can be iterated over using the For-Each construct 13 | Public Property Get NewEnum() As IUnknown 14 | Attribute NewEnum.VB_UserMemId = -4 15 | ''specified in iIterable 16 | End Property 17 | -------------------------------------------------------------------------------- /iList.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "iList" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | Option Explicit 11 | Option Base 0 12 | 13 | ''Methods inherited from the iCollection interface 14 | 15 | Public Function add(ByRef e As Variant) As Boolean 16 | 'inherited method from iCollection 17 | End Function 18 | 19 | Public Function addAll(ByRef c As iCollection) As Boolean 20 | 'inherited method from iCollection 21 | End Function 22 | 23 | Public Sub clear() 24 | 'inherited method from iCollection 25 | End Sub 26 | 27 | Public Function contains(ByRef o As Variant) As Boolean 28 | 'inherited method from iCollection 29 | End Function 30 | 31 | Public Function equals(ByRef o As Variant) As Boolean 32 | 'inherited method from iCollection 33 | End Function 34 | 35 | Public Function hashCode() As Long 36 | 'inherited method from iCollection 37 | End Function 38 | 39 | Public Function isEmpty() As Boolean 40 | 'inherited method from iCollection 41 | End Function 42 | 43 | 'iterator() 44 | 45 | 'parallelStream() 46 | 47 | Public Function remove(o As Variant) As Boolean 48 | 'inherited method from iCollection 49 | End Function 50 | 51 | Public Function removeAll(c As iCollection) As Boolean 52 | 'inherited method from iCollection 53 | End Function 54 | 55 | Public Function retainAll(c As iCollection) As Boolean 56 | 'inherited method from iCollection 57 | End Function 58 | 59 | Public Function size() As Long 60 | 'inherited method from iCollection 61 | End Function 62 | 63 | 'spliterator 64 | 'stream 65 | Public Function ToArray() As Variant() 66 | 'inherited method from iCollection 67 | End Function 68 | 69 | ''Methods provided by the iList interface 70 | 71 | Public Sub addAt(index As Long, e As Variant) 72 | 'instance method 73 | End Sub 74 | 75 | Public Function addAllAt(index As Long, c As iCollection) As Boolean 76 | 'instance method 77 | End Function 78 | 79 | Public Function getIndex(index As Long) As Variant 80 | 'instance method 81 | End Function 82 | 83 | Public Function indexOf(o As Variant) As Long 84 | 'instance method 85 | End Function 86 | 87 | Public Function lastIndexOf(o As Variant) As Long 88 | 'instance method 89 | End Function 90 | 91 | Public Function removeIndex(index As Long) As Variant 92 | 'instance method 93 | End Function 94 | 95 | 'replaceAll 96 | 97 | Public Function setIndex(index As Long, element As Variant) As Variant 98 | 'instance method 99 | End Function 100 | 101 | 'sort 102 | 103 | Public Function subList(fromIndex As Long, toIndex As Long) As iList 104 | 'instance method 105 | End Function 106 | 107 | 108 | 109 | -------------------------------------------------------------------------------- /iMap.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "iMap" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | Option Explicit 11 | Option Base 0 12 | 13 | 'Methods provided by the iMap interface 14 | Public Sub clear() 15 | 'interface method 16 | End Sub 17 | 18 | 'compute 19 | 'computeIfAbsent 20 | 'computeIfPresent 21 | 22 | Public Function containsKey(Key As Variant) As Boolean 23 | 'interface method 24 | End Function 25 | 26 | Public Function containsValue(value As Variant) As Boolean 27 | 'interface method 28 | End Function 29 | 30 | Public Function entrySet() As iSet 31 | 'interface method 32 | End Function 33 | 34 | Public Function equals(o As Variant) As Boolean 35 | 'interface method 36 | End Function 37 | 38 | 'foreach 39 | 40 | Public Function getByKey(Key As Variant) As Variant 41 | 'interface method 42 | End Function 43 | 44 | Public Function getOrDefault(Key As Variant, DefaultValue As Variant) As Variant 45 | 'interface method 46 | End Function 47 | 48 | Public Function keySet() As iSet 49 | 'interface method 50 | End Function 51 | 52 | 'merge 53 | 54 | Public Function putKV(Key As Variant, value As Variant) As Variant 55 | 'interface method 56 | End Function 57 | 58 | Public Sub putAll(m As iMap) 59 | 'interface method 60 | End Sub 61 | 62 | Public Function putIfAbsent(Key As Variant, value As Variant) As Variant 63 | 'interface method 64 | End Function 65 | 66 | Public Function remove(Key As Variant) As Variant 67 | 'interface method 68 | End Function 69 | 70 | Public Function removeIfValueMatch(Key As Variant, value As Variant) As Boolean 71 | 'interface method 72 | End Function 73 | 74 | Public Function replace(Key As Variant, value As Variant) As Variant 75 | 'interface method 76 | End Function 77 | 78 | Public Function replaceIfValueMatch(Key As Variant, oldValue As Variant, newValue As Variant) As Boolean 79 | 'interface method 80 | End Function 81 | 82 | 'replaceAll 83 | 84 | Public Function size() As Long 85 | 'interface method 86 | End Function 87 | 88 | Public Function values() As iCollection 89 | 'interface method 90 | End Function 91 | -------------------------------------------------------------------------------- /iSet.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "iSet" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | Option Explicit 11 | Option Base 0 12 | 13 | ''Methods inherited from the iCollection interface 14 | 15 | Public Function add(ByRef e As Variant) As Boolean 16 | 'inherited method from iCollection 17 | End Function 18 | 19 | Public Function addAll(ByRef c As iCollection) As Boolean 20 | 'inherited method from iCollection 21 | End Function 22 | 23 | Public Sub clear() 24 | 'inherited method from iCollection 25 | End Sub 26 | 27 | Public Function contains(ByRef o As Variant) As Boolean 28 | 'inherited method from iCollection 29 | End Function 30 | 31 | Public Function equals(ByRef o As Variant) As Boolean 32 | 'inherited method from iCollection 33 | End Function 34 | 35 | Public Function hashCode() As Long 36 | 'inherited method from iCollection 37 | End Function 38 | 39 | Public Function isEmpty() As Boolean 40 | 'inherited method from iCollection 41 | End Function 42 | 43 | 'iterator() 44 | 45 | 'parallelStream() 46 | 47 | Public Function remove(o As Variant) As Boolean 48 | 'inherited method from iCollection 49 | End Function 50 | 51 | Public Function removeAll(c As iCollection) As Boolean 52 | 'inherited method from iCollection 53 | End Function 54 | 55 | Public Function retainAll(c As iCollection) As Boolean 56 | 'inherited method from iCollection 57 | End Function 58 | 59 | Public Function size() As Long 60 | 'inherited method from iCollection 61 | End Function 62 | 63 | 'spliterator 64 | 'stream 65 | Public Function ToArray() As Variant() 66 | 'inherited method from iCollection 67 | End Function 68 | 69 | Public Property Get NewEnum() As IUnknown 70 | 'interface method 71 | End Property 72 | 73 | ''Methods provided by the iSet interface 74 | ' NONE 75 | 76 | -------------------------------------------------------------------------------- /tSNE.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "tSNE" 2 | Option Explicit 3 | 4 | 5 | Private Const DBL_MAX As Double = 1.79769313486231E+308 6 | Private Const DBL_MIN As Double = 1 / DBL_MAX 7 | Private Const FLT_MAX As Double = 3.402823E+38 8 | Private Const FLT_MIN As Double = 3.402823E-38 9 | 10 | Public Sub run(ByRef X() As Double, N As Long, D As Long, Y() As Double, _ 11 | no_dims As Long, _ 12 | perplexity As Double, _ 13 | theta As Double, _ 14 | rand_seed As Long, _ 15 | skip_random_init As Boolean, _ 16 | Optional max_iter As Long = 500, _ 17 | Optional stop_lying_iter As Long = 2, _ 18 | Optional mom_switch_iter As Long = 180) 19 | 20 | Application.StatusBar = "Running t-SNE" 21 | 22 | 'On Error GoTo whatError 23 | 24 | Dim i As Long, j As Long, lastC As Double 25 | 26 | 'set random seed 27 | If Not skip_random_init Then 28 | If rand_seed >= 0 Then 29 | Debug.Print "Using random seed: " & rand_seed 30 | Randomize (rand_seed) 31 | Else 32 | Debug.Print "Using current time as random seed..." 33 | Randomize Now() 34 | End If 35 | End If 36 | 37 | 'determine whether we are using an exact algorithm 38 | 39 | If N - 1 < 3 * perplexity Then 40 | Debug.Print "Perplexity too large for the number of data points!" 41 | Exit Sub 42 | End If 43 | 44 | Debug.Print "Using no_dims = " & no_dims & ", perplexity = " & perplexity & ", and theta = " & theta 45 | Dim exact As Boolean 46 | exact = (theta = 0#) 47 | 48 | 'set learning parameters 49 | Dim total_time As Double 50 | total_time = 0# 51 | Dim clock As Timer, endTime As Long 52 | Set clock = New Timer 53 | Dim momentum As Double, final_momentum As Double, eta As Double 54 | momentum = 0.5 55 | final_momentum = 0.8 56 | eta = 200# 57 | 58 | 'allocate arrays 59 | Dim dY() As Double, uY() As Double, gains() As Double 60 | ReDim dY(0 To N * no_dims - 1) 61 | ReDim uY(0 To N * no_dims - 1) 62 | ReDim gains(0 To N * no_dims - 1) 63 | 64 | For i = 0 To N * no_dims - 1 65 | uY(i) = 0# 66 | gains(i) = 1# 67 | Next i 68 | 69 | 'normalize input data (to prevent numerical problems 70 | Debug.Print "Computing input similarities..." 71 | clock.StartCounter 72 | zeroMean X, N, D 73 | squash X, N, D 74 | 75 | 'compute input similarities for exact t-SNE 76 | Dim P() As Double, row_P() As Long, col_P() As Long, val_P() As Double 'these Longs are supposed to be unsigned -- watch for overflow! 77 | Dim sum_P As Double 78 | 79 | If (exact) Then 80 | 81 | 'compute simlarities 82 | Debug.Print "Exact?" 83 | ReDim P(0 To N * N - 1) 84 | computeGaussianPerplexity X, N, D, P, perplexity 85 | 86 | 'Symmetrize input similarities 87 | Debug.Print "Symmetrizing..." 88 | Dim nN As Long, mN As Long 89 | nN = 0 90 | For i = 0 To N - 1 91 | mN = (i + 1) * N 92 | For j = i + 1 To N - 1 93 | P(nN + j) = P(nN + j) + P(mN + i) 94 | P(mN + i) = P(nN + j) 95 | mN = mN + N 96 | Next j 97 | nN = nN + N 98 | Next i 99 | 100 | sum_P = 0# 101 | For i = 0 To N * N - 1 102 | sum_P = sum_P + P(i) 103 | Next i 104 | For i = 0 To N * N - 1 105 | P(i) = P(i) / sum_P 106 | Next i 107 | 108 | 'compute input similarities for approximate t-SNE 109 | Else 110 | 111 | 'compute asymmetric pairwise input simlarities 112 | computeGaussianPerplexityApprox X, N, D, row_P, col_P, val_P, perplexity, Int(3 * perplexity) 113 | 114 | 'symmetrize input similarities 115 | symmetrizeMatrix row_P, col_P, val_P, N 116 | 117 | sum_P = 0# 118 | For i = 0 To N * N - 1 119 | sum_P = sum_P + P(i) 120 | Next i 121 | For i = 0 To N * N - 1 122 | P(i) = P(i) / sum_P 123 | Next i 124 | 125 | End If 126 | 127 | endTime = clock.TimeElapsed 128 | 129 | 'lie about the p-values 130 | If (exact) Then 131 | For i = 0 To N * N - 1 132 | P(i) = P(i) * 12# 133 | Next i 134 | Else 135 | For i = 0 To row_P(N) - 1 136 | val_P(i) = val_P(i) * 12# 137 | Next i 138 | End If 139 | 140 | 'initialize solution (randomly) 141 | If Not skip_random_init Then 142 | For i = 0 To N * no_dims - 1 143 | Y(i) = randn() * 0.0001 144 | Next i 145 | End If 146 | 147 | 'perform main training loop 148 | If exact Then 149 | Debug.Print "Input Similarities computed in " & endTime / 1000 & " seconds!" 150 | Debug.Print "Learning Embedding..." 151 | Else 152 | Debug.Print "Input Similarities computed in " & endTime / 1000 & " seconds!" & "(sparsity = " & row_P(N) / (N * N) 153 | Debug.Print "Learning Embedding..." 154 | End If 155 | 156 | clock.StartCounter 157 | 158 | Dim iter As Long 159 | For iter = 0 To max_iter - 1 160 | Application.StatusBar = "Running t-SNE. Iteration " & iter + 1 & " of " & max_iter 161 | 162 | 'compute (approximate) gradient 163 | If exact Then 164 | computeExactGradient P, Y, N, no_dims, dY 165 | Else 166 | computeGradient P, row_P, col_P, val_P, Y, N, no_dims, dY, theta 167 | End If 168 | 169 | 'update gains 170 | For i = 0 To N * no_dims - 1 171 | If (sign(dY(i)) <> sign(uY(i))) Then 172 | gains(i) = gains(i) + 0.2 173 | Else 174 | gains(i) = gains(i) * 0.8 175 | End If 176 | Next i 177 | For i = 0 To N * no_dims - 1 178 | If gains(i) < 0.01 Then 179 | gains(i) = 0.01 180 | End If 181 | Next i 182 | 183 | 'perform gradient update (with momentum and gains) 184 | For i = 0 To N * no_dims - 1 185 | uY(i) = momentum * uY(i) - eta * gains(i) * dY(i) 186 | Next i 187 | For i = 0 To N * no_dims - 1 188 | Y(i) = Y(i) + uY(i) 189 | Next i 190 | 191 | 'make solution zero-mean 192 | zeroMean Y, N, no_dims 193 | 194 | 'stop lying about the P-values after a while, and switch momentum 195 | If iter = stop_lying_iter Then 196 | If exact Then 197 | For i = 0 To N * N - 1 198 | P(i) = P(i) / 12# 199 | Next i 200 | Else 201 | For i = 0 To row_P(N) - 1 202 | val_P(i) = val_P(i) / 12# 203 | Next i 204 | End If 205 | End If 206 | If iter = mom_switch_iter Then 207 | momentum = final_momentum 208 | End If 209 | 210 | 'print out progress 211 | If (iter > 0) And ((iter Mod 50) = 0 Or (iter = max_iter - 1)) Then 212 | Dim C As Double 213 | C = 0# 214 | If exact Then 215 | C = evaluateError(P, Y, N, no_dims) 216 | Else 217 | C = evaluateErrorApprox(row_P, col_P, val_P, Y, N, no_dims, theta) 'doing approximate computation here! 218 | End If 219 | If iter = 0 Then 220 | Debug.Print "Iteration " & iter + 1 & ": error is " & C 221 | Else 222 | total_time = total_time + clock.TimeElapsed 223 | Debug.Print "Iteration " & iter + 1 & ": error is " & C & " (50 iterations in " & clock.TimeElapsed / 1000 & " seconds)" 224 | End If 225 | 226 | If Abs(lastC - C) < 0.000001 Then 227 | iter = max_iter + 1 228 | Debug.Print "No progress" 229 | End If 230 | 231 | lastC = C 232 | 233 | clock.StartCounter 234 | End If 235 | 236 | Next iter 237 | 238 | 239 | 240 | 241 | Debug.Print "Fitting performed in " & (total_time + clock.TimeElapsed) / 1000 & " seconds" 242 | 243 | End Sub 244 | 245 | Private Function sign(D As Double) As Long 246 | sign = IIf(D > 0, 1, IIf(D < 0, -1, 0)) 247 | End Function 248 | 249 | 'centers data on the mean 250 | Private Sub zeroMean(ByRef X() As Double, N As Long, D As Long) 251 | 252 | Dim ni As Long, di As Long 253 | 254 | 'compute data mean 255 | Dim mean() As Double 256 | ReDim mean(0 To D - 1) 257 | 258 | Dim nD As Long 259 | nD = 0 260 | For ni = 0 To N - 1 261 | For di = 0 To D - 1 262 | mean(di) = mean(di) + X(nD + di) 263 | Next di 264 | nD = nD + D 265 | Next ni 266 | 267 | For di = 0 To D - 1 268 | mean(di) = mean(di) / CDbl(N) 269 | Next di 270 | 271 | 'subtract data mean 272 | nD = 0 273 | For ni = 0 To N - 1 274 | For di = 0 To D - 1 275 | X(nD + di) = X(nD + di) - mean(di) 276 | Next di 277 | nD = nD + D 278 | Next ni 279 | 280 | End Sub 281 | 282 | 'normalizes all X values to a range of (-1,1) 283 | Private Sub squash(ByRef X() As Double, N As Long, D As Long) 284 | Dim Max_X As Double, i As Long 285 | Max_X = 0# 286 | For i = 0 To N * D - 1 287 | If (Abs(X(i)) > Max_X) Then 288 | Max_X = Abs(X(i)) 289 | End If 290 | Next i 291 | 292 | For i = 0 To N * D - 1 293 | X(i) = X(i) / Max_X 294 | Next i 295 | End Sub 296 | 297 | Private Function randn() As Double 298 | randn = WorksheetFunction.NormInv(Rnd(), 0, 1) 299 | End Function 300 | 301 | 302 | Private Sub computeGaussianPerplexity(ByRef X() As Double, N As Long, D As Long, ByRef P() As Double, perplexity As Double) 303 | 304 | 'compute the squared Euclidean distance matrix 305 | Dim DD() As Double 306 | ReDim DD(N * N - 1) 307 | 308 | computeSquaredEuclideanDistance X, N, D, DD 309 | 310 | 'compute the gaussian kernel row by row 311 | Dim ni As Long, i As Long, j As Long, nN As Long 312 | nN = 0 313 | For i = 0 To N - 1 314 | 315 | 'initialize some variables 316 | Dim found As Boolean, beta As Double, min_beta As Double, max_beta As Double, tol As Double, sum_P As Double 317 | found = False 318 | beta = 1# 319 | min_beta = -DBL_MAX 320 | max_beta = DBL_MAX 321 | tol = 0.00001 322 | 323 | ' Iterate until we found a good perplexity 324 | Dim iter As Long 325 | iter = 0 326 | While (Not found And iter < 200) 327 | 328 | 'compute gaussian kernel row 329 | For j = 0 To N - 1 330 | P(nN + j) = Exp(-beta * DD(nN + j)) 331 | Next j 332 | P(nN + i) = DBL_MIN 333 | 334 | 'compute entropy of current row 335 | sum_P = DBL_MIN 336 | For j = 0 To N - 1 337 | sum_P = sum_P + P(nN + j) 338 | Next j 339 | 340 | Dim H As Double 341 | H = 0# 342 | For j = 0 To N - 1 343 | H = H + beta * (DD(nN + j) * P(nN + j)) 344 | Next j 345 | H = (H / sum_P) + Log(sum_P) 346 | 347 | 'evaluate whether the entropy is within the tolerance level 348 | Dim Hdiff As Double 349 | Hdiff = H - Log(perplexity) 350 | If (Hdiff < tol And -Hdiff < tol) Then 351 | found = True 352 | Else 353 | If Hdiff > 0 Then 354 | min_beta = beta 355 | If (max_beta = DBL_MAX) Or (max_beta = -DBL_MAX) Then 356 | beta = beta * 2# 357 | Else 358 | beta = (beta + max_beta) / 2# 359 | End If 360 | Else 361 | max_beta = beta 362 | If (min_beta = -DBL_MAX) Or (min_beta = DBL_MAX) Then 363 | beta = beta / 2# 364 | Else 365 | beta = (beta + min_beta) / 2# 366 | End If 367 | End If 368 | End If 369 | 370 | 'update iteration counter 371 | iter = iter + 1 372 | 373 | Wend 374 | 375 | 'row normalize P 376 | For j = 0 To N - 1 377 | P(nN + j) = P(nN + j) / sum_P 378 | Next j 379 | 380 | nN = nN + N 381 | 382 | Next i 383 | 384 | End Sub 385 | 386 | Private Sub computeSquaredEuclideanDistanceVersion1(ByRef X() As Double, N As Long, D As Long, ByRef DD() As Double) 387 | Dim i As Long, j As Long 388 | For i = 0 To N - 1 389 | For j = 0 To N - 1 390 | DD(i * N + j) = (X(i) - X(j)) * (X(i) - X(j)) 391 | Next j 392 | Next i 393 | End Sub 394 | 395 | 'computes distance between two vectors of the 2D array X 396 | Private Function L2(X() As Double, i1 As Long, i2 As Long, D As Long) As Double 397 | Dim dist As Double, j As Long, x1 As Double, x2 As Double 398 | dist = 0# 399 | For j = 0 To D - 1 400 | x1 = X(i1 * D + j) 401 | x2 = X(i2 * D + j) 402 | dist = dist + (x1 - x2) * (x1 - x2) 403 | Next j 404 | L2 = dist 405 | End Function 406 | 407 | Private Sub computeSquaredEuclideanDistance(ByRef X() As Double, N As Long, D As Long, ByRef DD() As Double) 408 | Dim i As Long, j As Long, dist As Double 409 | For i = 0 To N - 1 410 | For j = i + 1 To N - 1 411 | dist = L2(X, i, j, D) 412 | DD(i * N + j) = dist 413 | DD(j * N + i) = dist 414 | Next j 415 | Next i 416 | End Sub 417 | 418 | Private Sub computeSquaredEuclideanDistanceVersion2(ByRef X() As Double, N As Long, D As Long, ByRef DD() As Double) 419 | Dim i As Long, j As Long, k As Long, XnD As Long, XmD As Long 420 | XnD = 0 421 | For i = 0 To N - 1 422 | XmD = XnD + D 423 | Dim curr_elem As Double 424 | curr_elem = i * N + i 425 | DD(curr_elem) = 0# 426 | Dim curr_elem_sym As Double 427 | curr_elem_sym = curr_elem + N 428 | For j = i + 1 To N - 1 429 | curr_elem = curr_elem + 1 430 | DD(curr_elem) = 0# 431 | 432 | For k = 0 To D - 1 433 | DD(curr_elem) = DD(curr_elem) + (DD(XnD + D) - DD(XmD + D)) * (DD(XnD + D) - DD(XmD + D)) 434 | Next k 435 | curr_elem_sym = curr_elem 436 | 437 | XmD = XmD + D 438 | curr_elem_sym = curr_elem_sym + N 439 | Next j 440 | Next i 441 | End Sub 442 | 443 | 444 | 445 | 'compute the t-SNE cost function (exactly) 446 | Private Function evaluateError(P() As Double, Y() As Double, N As Long, D As Long) As Double 447 | 448 | 'Compute the squared Eclidean distance matrix 449 | Dim DD() As Double, Q() As Double 450 | ReDim DD(0 To N * N - 1) 451 | ReDim Q(0 To N * N - 1) 452 | 453 | computeSquaredEuclideanDistance Y, N, D, DD 454 | 455 | 'compute Q-matrix and normalization sum 456 | Dim nN As Long, sum_Q As Double, i As Long, j As Long 457 | sum_Q = DBL_MIN 458 | 459 | For i = 0 To N - 1 460 | For j = 0 To N - 1 461 | If (i <> j) Then 462 | Q(nN + j) = 1 / (1 + DD(nN + j)) 463 | sum_Q = sum_Q + Q(nN + j) 464 | Else 465 | Q(nN + j) = DBL_MIN 466 | End If 467 | Next j 468 | nN = nN + N 469 | Next i 470 | 471 | For i = 0 To N * N - 1 472 | Q(i) = Q(i) / sum_Q 473 | Next i 474 | 475 | 'sum t-SNE error 476 | Dim C As Double 477 | For i = 0 To N * N - 1 478 | C = C + P(i) * Log((P(i) + FLT_MIN) / (Q(i) + FLT_MIN)) 479 | Next i 480 | 481 | evaluateError = C 482 | 483 | End Function 484 | 485 | Private Sub computeExactGradient(P() As Double, Y() As Double, N As Long, D As Long, dC() As Double) 486 | 487 | Dim i As Long, j As Long, k As Long 488 | 489 | 'make sure the current gradient contains zeros 490 | For i = 0 To N * D - 1 491 | dC(i) = 0# 492 | Next i 493 | 494 | 'compute the squared Euclidean distance matrix 495 | Dim DD() As Double 496 | ReDim DD(0 To N * N - 1) 497 | computeSquaredEuclideanDistance Y, N, D, DD 498 | 499 | 'compute the Q-matrix and normalize sum 500 | Dim Q() As Double 501 | ReDim Q(0 To N * N - 1) 502 | Dim sum_Q As Double, nN As Long 503 | For i = 0 To N - 1 504 | For j = 0 To N - 1 505 | If (i <> j) Then 506 | Q(nN + j) = 1 / (1 + DD(nN + j)) 507 | sum_Q = sum_Q + Q(nN + j) 508 | End If 509 | Next j 510 | nN = nN + N 511 | Next i 512 | 513 | 'perform the computation of the gradient 514 | nN = 0 515 | Dim nD As Long 516 | nD = 0 517 | For i = 0 To N - 1 518 | Dim mD As Long 519 | mD = 0 520 | For j = 0 To N - 1 521 | If (i <> j) Then 522 | Dim mult As Double 523 | mult = (P(nN + j) - (Q(nN + j) / sum_Q)) * Q(nN + j) 524 | For k = 0 To D - 1 525 | dC(nD + k) = dC(nD + k) + (Y(nD + k) - Y(mD + k)) * mult 526 | Next k 527 | End If 528 | mD = mD + D 529 | Next j 530 | nN = nN + N 531 | nD = nD + D 532 | Next i 533 | 534 | End Sub 535 | 536 | Private Function evaluateErrorApprox(ByRef row_P() As Long, ByRef col_P() As Long, ByRef val_P() As Double, ByRef Y() As Double, N As Long, D As Long, theta As Double) As Double 537 | 'TODO 538 | End Function 539 | 540 | 541 | 'compute input simlarities with a fixed perplexity using ball trees 542 | Private Sub computeGaussianPerplexityApprox(X() As Double, N As Long, D As Long, row_P_() As Long, col_P_() As Long, val_P_() As Double, perplexity As Double, k As Long) 543 | 'TODO 544 | End Sub 545 | 546 | Private Sub symmetrizeMatrix(row_P() As Long, col_P() As Long, val_P() As Double, N As Long) 547 | 'TODO 548 | End Sub 549 | 550 | Private Sub computeGradient(P() As Double, inp_row_P() As Long, inp_col_P() As Long, inp_val_P() As Double, Y() As Double, N As Long, D As Long, dC() As Double, theta As Double) 551 | 'TODO 552 | End Sub 553 | 554 | 555 | --------------------------------------------------------------------------------