-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathlistutils.tcl
320 lines (276 loc) · 8.54 KB
/
listutils.tcl
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
#
# Copyright 2015 (c) Pointwise, Inc.
# All rights reserved.
#
# This sample script is not supported by Pointwise, Inc.
# It is provided freely for demonstration purposes only.
# SEE THE WARRANTY DISCLAIMER AT THE BOTTOM OF THIS FILE.
#
if { [namespace exists pw::listutils] } {
return
}
# See: http://en.wikipedia.org/wiki/Set_(mathematics)
# pw::listutils <cmd> ?<options>?
namespace eval pw::listutils {
# pw::listutils lproduct <subcmd> ?<options>?
# pw::listutils lproduct get <list> ?<list> ...?
# pw::listutils lproduct foreach <varname> <list> ?<list> ...? <body>
namespace export lproduct
proc lproduct { subCmd args } {
set callingLvl [expr {[info level] - 1}]
return [lproduct_${subCmd} $callingLvl {*}$args]
}
# pw::listutils lmutate <subcmd> ?<options>?
# pw::listutils lmutate get <list>
# pw::listutils lmutate foreach <varname> <list> <body>
namespace export lmutate
proc lmutate { subCmd args } {
return [lmutate_${subCmd} {*}$args]
}
# pw::listutils lunion ?<list> ...?
namespace export lunion
proc lunion { args } {
set d [dict create]
# $args is a list of lists
foreach arg $args {
# for each val in the list...
foreach val $arg {
# create an entry in the dict d
dict set d $val 1
}
}
# grab unique keys from dict which is the union
return [dict keys $d]
}
# pw::listutils lintersect <list> <list> ?<list> ...?
namespace export lintersect
proc lintersect { A B args } {
set d [dict create]
set B [lsort -unique $B]
foreach val $A {
if { -1 != [lsearch -sorted $B $val] } {
dict set d $val 1
}
}
if { 0 != [llength $args] } {
# recursively intersect with additional lists
set ret [lintersect [dict keys $d] {*}$args]
} else {
# no more lists, we are done
set ret [dict keys $d]
}
return $ret
}
# pw::listutils lsubtract <list> <list> ?<list> ...?
namespace export lsubtract
proc lsubtract { A B args } {
set d [dict create]
set B [lsort -unique $B]
foreach val $A {
if { -1 == [lsearch -sorted $B $val] } {
dict set d $val 1
}
}
if { 0 != [llength $args] } {
# recursively subtract with additional lists
set ret [lsubtract [dict keys $d] {*}$args]
} else {
# no more lists, we are done
set ret [dict keys $d]
}
return $ret
}
# pw::listutils lsymmetricdiff <list> <list> ?<list> ...?
namespace export lsymmetricdiff
proc lsymmetricdiff { A B args } {
# == (A - B) union (B - A)
set ret [lunion [lsubtract $A $B] [lsubtract $B $A]]
if { 0 != [llength $args] } {
# recursively lsymmetricdiff with additional lists
set ret [lsymmetricdiff $ret {*}$args]
}
return $ret
}
# pw::listutils lissubset <superlist> <sublist> ?<sublist> ...?
namespace export lissubset
proc lissubset { superlist sublist args } {
set superlist [lsort $superlist]
set ret 1
while { $ret } {
foreach val $sublist {
if { -1 == [lsearch -sorted $superlist $val] } {
set ret 0
break
}
}
if { 0 == [llength $args] } {
break
}
set args [lassign $args sublist]
}
return $ret
}
# pw::listutils lunique <list>
namespace export lunique
proc lunique { lst } {
set tmp [dict create]
foreach l $lst {
dict set tmp $l 1
}
return [dict keys $tmp]
}
# pw::listutils lremove <listvar> <value> ?<options>?
namespace export lremove
proc lremove { theListVar value args} {
upvar $theListVar theList
set idx [lsearch {*}$args $theList $value]
set theList [lreplace $theList $idx $idx]
}
# pw::listutils lstitch <list1> ?<list2>? ?<repeat>?
namespace export lstitch
proc lstitch { keys {vals {}} {repeatVals 0} } {
if { $repeatVals && ([llength $vals] < [llength $keys]) } {
if { 1 == [llength $vals] } {
set vals [lrepeat [llength $keys] $vals]
} else {
while { [llength $vals] < [llength $keys] } {
set vals [concat $vals $vals]
}
}
}
set db [dict create]
set ndx -1
foreach key $keys {
dict set db $key [lindex $vals [incr ndx]]
}
return $db
}
# pw::listutils lshift <listvar>
namespace export lshift
proc lshift { theListVar } {
upvar $theListVar theList
set theList [lassign $theList ret]
return $ret
}
# pw::listutils lisempty <list>
namespace export lisempty
proc lisempty { theList } {
return [expr {0 == [llength $theList]}]
}
# pw::listutils lcontains <list> <needle>
namespace export lcontains
proc lcontains { haystack needle args } {
return [expr {-1 != [lsearch {*}$args $haystack $needle]}]
}
#================================================================
# PRIVATE lproduct IMPL PROCS
#================================================================
# pw::listutils lproduct foreach <varname> <list> ?<list> ...? <body>
proc lproduct_foreach { callingLvl varName args } {
if { 2 > [llength $args] } {
error "Invalid number of args: lproduct foreach <varname> <list> ?<list> ...? <body>"
}
lproduct_foreach_level $callingLvl $varName {*}$args
}
# pw::listutils lproduct get <list> ?<list> ...?
proc lproduct_get { callingLvl args } {
if { 1 > [llength $args] } {
error "Invalid number of args: lproduct get <list> ?<list> ...?"
}
set ret [list]
lproduct_foreach_level [info level] combo {*}$args {
lappend ret $combo
}
return $ret
}
# pw::listutils lproduct foreach <varname> <list> ?<list> ...? <body>
proc lproduct_foreach_level { callingLvl varName args } {
set body [lindex $args end]
set args [lassign [lrange $args 0 end-1] vals]
if { 0 == [llength $vals] } {
set vals [list {}]
}
foreach val $vals {
lproduct_foreachR $varName $callingLvl [list $val] $body {*}$args
}
}
# combo lproduct_foreachR varName callingLvl subCombo body ?<list> ...?
proc lproduct_foreachR { varName callingLvl subCombo body args } {
if { 0 == [llength $args] } {
# no more sets
upvar #$callingLvl $varName combo
set combo $subCombo
uplevel #$callingLvl $body
} else {
set args [lassign $args vals]
if { 0 == [llength $vals] } {
set vals [list {}]
}
foreach val $vals {
set tmp $subCombo
lappend tmp $val
lproduct_foreachR $varName $callingLvl $tmp $body {*}$args
}
}
}
#================================================================
# PRIVATE lmutate IMPL PROCS
#================================================================
# pw::listutils lmutate get <list>
proc lmutate_get { args } {
set ret [list]
lmutate_for_level 1 0 perm $args {
lappend ret $perm
}
return $ret
}
# pw::listutils lmutate foreach <varname> <list> <body>
proc lmutate_foreach { varName items body } {
lmutate_for_level 3 0 $varName $items $body
}
proc lmutate_for_level { level ndx varName items body } {
set ret [list]
set cnt [llength $items]
if { $ndx == $cnt } {
# At the end of the array, we have one permutation we can use.
upvar $level $varName perm
set perm $items
uplevel $level $body
} else {
# Recursively explore the permutations starting at index ndx going
# through index cnt-1
incr level
set ndxPlus1 [expr {$ndx + 1}]
for {set ii $ndx} {$ii < $cnt} {incr ii} {
# try the array with ndx and ii switched
swap items $ndx $ii
set ret [concat $ret [lmutate_for_level $level $ndxPlus1 $varName $items $body]]
# swap them back the way they were
swap items $ndx $ii
}
}
return $ret
}
proc swap { itemsVar ndx1 ndx2 } {
upvar $itemsVar items
set t [lindex $items $ndx1]
lset items $ndx1 [lindex $items $ndx2]
lset items $ndx2 $t
}
namespace ensemble create
}
# END SCRIPT
#
# DISCLAIMER:
# TO THE MAXIMUM EXTENT PERMITTED BY APPLICABLE LAW, POINTWISE DISCLAIMS
# ALL WARRANTIES, EITHER EXPRESS OR IMPLIED, INCLUDING, BUT NOT LIMITED
# TO, IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
# PURPOSE, WITH REGARD TO THIS SCRIPT. TO THE MAXIMUM EXTENT PERMITTED
# BY APPLICABLE LAW, IN NO EVENT SHALL POINTWISE BE LIABLE TO ANY PARTY
# FOR ANY SPECIAL, INCIDENTAL, INDIRECT, OR CONSEQUENTIAL DAMAGES
# WHATSOEVER (INCLUDING, WITHOUT LIMITATION, DAMAGES FOR LOSS OF
# BUSINESS INFORMATION, OR ANY OTHER PECUNIARY LOSS) ARISING OUT OF THE
# USE OF OR INABILITY TO USE THIS SCRIPT EVEN IF POINTWISE HAS BEEN
# ADVISED OF THE POSSIBILITY OF SUCH DAMAGES AND REGARDLESS OF THE
# FAULT OR NEGLIGENCE OF POINTWISE.
#