]> git.zerfleddert.de Git - micropolis/blob - src/tclx/tclsrc/setfuncs.tcl
re-add (disabled) air crash disaster
[micropolis] / src / tclx / tclsrc / setfuncs.tcl
1 #
2 # setfuncs --
3 #
4 # Perform set functions on lists. Also has a procedure for removing duplicate
5 # list entries.
6 #------------------------------------------------------------------------------
7 # Copyright 1992 Karl Lehenbauer and Mark Diekhans.
8 #
9 # Permission to use, copy, modify, and distribute this software and its
10 # documentation for any purpose and without fee is hereby granted, provided
11 # that the above copyright notice appear in all copies. Karl Lehenbauer and
12 # Mark Diekhans make no representations about the suitability of this
13 # software for any purpose. It is provided "as is" without express or
14 # implied warranty.
15 #------------------------------------------------------------------------------
16 # $Id: setfuncs.tcl,v 2.0 1992/10/16 04:52:10 markd Rel $
17 #------------------------------------------------------------------------------
18 #
19
20 #@package: TclX-set_functions union intersect intersect3 lrmdups
21
22 #
23 # return the logical union of two lists, removing any duplicates
24 #
25 proc union {lista listb} {
26 set full_list [lsort [concat $lista $listb]]
27 set check_element [lindex $full_list 0]
28 set outlist $check_element
29 foreach element [lrange $full_list 1 end] {
30 if {$check_element == $element} continue
31 lappend outlist $element
32 set check_element $element
33 }
34 return $outlist
35 }
36
37 #
38 # sort a list, returning the sorted version minus any duplicates
39 #
40 proc lrmdups {list} {
41 set list [lsort $list]
42 set result [lvarpop list]
43 lappend last $result
44 foreach element $list {
45 if {$last != $element} {
46 lappend result $element
47 set last $element
48 }
49 }
50 return $result
51 }
52
53 #
54 # intersect3 - perform the intersecting of two lists, returning a list
55 # containing three lists. The first list is everything in the first
56 # list that wasn't in the second, the second list contains the intersection
57 # of the two lists, the third list contains everything in the second list
58 # that wasn't in the first.
59 #
60
61 proc intersect3 {list1 list2} {
62 set list1Result ""
63 set list2Result ""
64 set intersectList ""
65
66 set list1 [lrmdups $list1]
67 set list2 [lrmdups $list2]
68
69 while {1} {
70 if [lempty $list1] {
71 if ![lempty $list2] {
72 set list2Result [concat $list2Result $list2]
73 }
74 break
75 }
76 if [lempty $list2] {
77 set list1Result [concat $list1Result $list1]
78 break
79 }
80 set compareResult [string compare [lindex $list1 0] [lindex $list2 0]]
81
82 if {$compareResult < 0} {
83 lappend list1Result [lvarpop list1]
84 continue
85 }
86 if {$compareResult > 0} {
87 lappend list2Result [lvarpop list2]
88 continue
89 }
90 lappend intersectList [lvarpop list1]
91 lvarpop list2
92 }
93 return [list $list1Result $intersectList $list2Result]
94 }
95
96 #
97 # intersect - perform an intersection of two lists, returning a list
98 # containing every element that was present in both lists
99 #
100 proc intersect {list1 list2} {
101 set intersectList ""
102
103 set list1 [lsort $list1]
104 set list2 [lsort $list2]
105
106 while {1} {
107 if {[lempty $list1] || [lempty $list2]} break
108
109 set compareResult [string compare [lindex $list1 0] [lindex $list2 0]]
110
111 if {$compareResult < 0} {
112 lvarpop list1
113 continue
114 }
115
116 if {$compareResult > 0} {
117 lvarpop list2
118 continue
119 }
120
121 lappend intersectList [lvarpop list1]
122 lvarpop list2
123 }
124 return $intersectList
125 }
126
127
Impressum, Datenschutz