-
Notifications
You must be signed in to change notification settings - Fork 3
/
Setx.cls
411 lines (324 loc) · 11.1 KB
/
Setx.cls
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "Setx"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Private d As Scripting.Dictionary
Private isTyped As Boolean
Private innerType As String
Private c As Collection
'Untyped set
Public Sub init(arr As Variant)
isTyped = False
Set d = New Scripting.Dictionary
If LBound(arr) = UBound(arr) Then
add arr(LBound(arr))
Else
append arr
End If
End Sub
' Typed list initialized with a type string
Public Sub initT(typeString As String)
isTyped = True
Set d = New Scripting.Dictionary
innerType = typeString
End Sub
' Lazily typed set which determines the type by looking at the first object added
Public Sub initLT(arr As Variant)
isTyped = True
Set d = New Scripting.Dictionary
If (LBound(arr) = UBound(arr)) Then
add arr(LBound(arr))
Else
append arr
End If
End Sub
'' ***************************************************************************************
'' Private functions
'' ***************************************************************************************
Private Function createSimilarSetx() As Setx
Dim s As New Setx
If isTyped Then
s.initT innerType
Else
s.init Arrays.emptyVariantArray
End If
Set createSimilarSetx = l
End Function
Private Function equalsAny(ByVal text As String, ParamArray searchTerms() As Variant) As Boolean
Dim i As Integer, found As Boolean
For i = LBound(searchTerms) To UBound(searchTerms)
found = text = searchTerms(i)
If found Then Exit For
Next
equalsAny = found
End Function
Private Function isTypeCompatible(value As Variant) As Boolean
If innerType = TypeName(value) Then
isTypeCompatible = True
Else
isTypeCompatible = innerType = "Integer" And equalsAny(TypeName(value), "Byte") _
Or innerType = "Long" And equalsAny(TypeName(value), "Integer", "Byte") _
Or innerType = "LongLong" And equalsAny(TypeName(value), "Long", "Integer", "Byte") _
Or innerType = "Single" And equalsAny(TypeName(value), "LongLong", "Long", "Integer", "Byte") _
Or innerType = "Double" And equalsAny(TypeName(value), "Single", "LongLong", "Long", "Integer", "Byte") _
Or innerType = "Currency" And equalsAny(TypeName(value), "Long", "Integer", "Byte", "Single", "Double")
End If
End Function
Private Sub checkType(value As Variant, member As String)
If isTyped Then
If innerType = vbNullString Then
If TypeName(value) = "Empty" Then
' When adding an empty Variant (TypeName() = "Empty") we don't set the typename.
' This prevents accidentally trashing the set type by adding an empty variant when
' the set was actually meant to hold a real type.
Else
innerType = TypeName(value)
End If
Else
If Not isTypeCompatible(value) Then
Err.Raise E_TYPEMISMATCH, Stringx.format("{0}.{1}", toString, member), _
Stringx.format("Type Mismatch. Expected: '{0}' Given: '{1}'", innerType, TypeName(value))
End If
End If
Else
' Untyped
End If
End Sub
Private Function getPrettyInnerTypeName() As String
If isTyped Then
If innerType = vbNullString Then
getPrettyInnerTypeName = "Lazy Unknown"
Else
getPrettyInnerTypeName = innerType
End If
Else
getPrettyInnerTypeName = "Untyped"
End If
End Function
'' ***************************************************************************************
'' Properties
'' ***************************************************************************************
Public Property Get elems() As Long
elems = d.count
End Property
Public Property Get typed() As Boolean
typed = isTyped
End Property
Public Property Get innerTypeName() As String
innerTypeName = innerType
End Property
Public Sub add(value As Variant)
checkType value, "Setx.add()"
If Not d.exists(value) Then
d.add value, 0
End If
End Sub
Public Sub append(ParamArray values())
' Force values to a Variant array.
Dim varArray() As Variant
varArray = values
If LBound(varArray) = UBound(varArray) And varType(varArray(LBound(varArray))) = vbObject And TypeName(varArray(LBound(varArray))) = "List" Then
' If we have a single List -> unpack it
Dim element As Variant
For Each element In varArray(LBound(varArray))
checkType element, "Setx.add()"
add element
Next
ElseIf LBound(varArray) = UBound(varArray) And varType(varArray(LBound(varArray))) = vbObject And TypeName(varArray(LBound(varArray))) = "Collection" Then
' If we have a single Collection -> unpack it
Dim element2 As Variant
For Each element2 In varArray(LBound(varArray))
checkType element2, "Setx.add()"
add element2
Next
ElseIf LBound(varArray) = UBound(varArray) And varType(varArray(LBound(varArray))) = vbObject And TypeName(varArray(LBound(varArray))) = "Setx" Then
' If we have a single set -> unpack it
Dim element3 As Variant
For Each element3 In varArray(LBound(varArray))
checkType element3, "Setx.add()"
add element3
Next
Else
' Array case
If LBound(varArray) = UBound(varArray) And Variants.isArray(varArray(LBound(varArray))) Then
' If we have a single array -> unpack it
' This line kills Excel. Thus write it a little differently.
' varArray = varArray(LBound(varArray))
Dim tmp() As Variant
tmp = Arrays.toVariantArray(varArray(LBound(varArray)))
varArray = tmp
End If
Dim i As Long
For i = LBound(varArray) To UBound(varArray)
checkType varArray(i), "Setx.add()"
add varArray(i)
Next
End If
End Sub
Public Sub remove(value As Variant)
On Error Resume Next
d.remove value
If Err.number = 32811 Then
On Error GoTo 0
Err.Raise E_ARGUMENTOUTOFRANGE, "Setx.remove()", "Setx remove failed on missing element"
End If
End Sub
Public Sub removeAll()
d.removeAll
End Sub
Public Function exists(value As Variant) As Boolean
exists = d.exists(value)
End Function
Public Function equals(other As Setx) As Boolean
If is_subset(other) Then
If is_superset(other) Then
equals = True
End If
Else:
equals = False
End If
'If d.is_subset(other) And d.is_superset(other) Then
' d.equals(other) = True
'Else:
' d.equals(other) = False
'End If
End Function
Public Sub discard(value As Variant)
On Error Resume Next
d.remove value
On Error GoTo 0
End Sub
Public Function pick() As Variant
Dim keys() As Variant
keys = d.keys()
Dim elementnum As Integer
Dim random As Double
random = Rnd(1)
Dim result As Double
result = random * elems
Dim choice As Integer
choice = Int(result)
pick = keys(choice)
End Function
Public Function pop() As Variant
If d.count > 0 Then
Dim keys() As Variant
keys = d.keys()
pop = keys(LBound(keys))
d.remove pop
End If
End Function
Public Function values() As List
Set values = List_create
values.append d.keys()
End Function
Public Function union(other As Setx) As Setx
Set union = Setx_create
Dim element As Variant
Dim element2 As Variant
For Each element In other
union.add element
Next
For Each element2 In Me
union.add element2
Next
End Function
Public Function intersection(other As Setx) As Setx
Set intersection = Setx_create
Dim element As Variant
For Each element In other
If d.exists(element) Then
intersection.add element
End If
Next
End Function
Public Function difference(other As Setx) As Setx
Set difference = Setx_create
Dim element As Variant
For Each element In d
If Not other.exists(element) Then
difference.add element
End If
Next
End Function
Public Function symmetric_difference(other As Setx) As Setx
Dim difference1 As Setx: Set difference1 = difference(other)
Dim difference2 As Setx: Set difference2 = other.difference(Me)
Set symmetric_difference = difference1.union(difference2)
End Function
Public Function is_disjoint(other As Setx) As Boolean
Dim element As Variant
is_disjoint = True
For Each element In other
If d.exists(element) Then
is_disjoint = False
Exit For
End If
Next
End Function
Public Function is_subset(other As Setx) As Boolean
is_subset = True
Dim element As Variant
For Each element In Me
If Not other.exists(element) Then
is_subset = False
Exit For
End If
Next
End Function
Public Function is_superset(other As Setx) As Boolean
is_superset = True
Dim element As Variant
For Each element In other
If Not d.exists(element) Then
is_superset = False
Exit For
End If
Next
End Function
'Augmented Assigment Methods
Public Function update_union(other As Setx)
Dim resulting_set As Setx: Set resulting_set = union(other)
Set d = New Dictionary
append resulting_set
End Function
Public Function update_intersection(other As Setx)
Dim resulting_set As Setx: Set resulting_set = intersection(other)
Set d = New Dictionary
append resulting_set
End Function
Public Function update_difference(other As Setx)
Dim resulting_set As Setx: Set resulting_set = difference(other)
Set d = New Dictionary
append resulting_set
End Function
Public Function update_symmetric_difference(other As Setx)
Dim resulting_set As Setx: Set resulting_set = symmetric_difference(other)
Set d = New Dictionary
append resulting_set
End Function
Public Property Get newEnum() As IUnknown
Attribute newEnum.VB_UserMemId = -4
' If For Each loops return "Method not supported" do the following:
' 1. Export this class to a file (right mouse button on the class in the Project Explorer -> Export file...)
' 2. Delete the class in the Project Explorer.
' 3. In that exported file add the following text above this comment: "Attribute NewEnum.VB_UserMemID = -4"
' 4. Import the changed file again (right mouse button in the Project Explorer -> Import file...)
Set c = New Collection
Dim e As Variant
For Each e In d
c.add e
Next
Set newEnum = c.[_NewEnum]
End Property
Public Function toString() As String
toString = Stringx.format("{0}<{1}>", TypeName(Me), getPrettyInnerTypeName)
End Function
Public Function gist() As String
gist = "[" & Stringx.join(Me.values, ", ") & "]<" & getPrettyInnerTypeName & ">"
End Function