]> git.zerfleddert.de Git - micropolis/blame - src/tclx/tclsrc/setfuncs.tcl
resize editor when resizing window
[micropolis] / src / tclx / tclsrc / setfuncs.tcl
CommitLineData
6a5fa4e0
MG
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#
25proc 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#
40proc 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
61proc 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#
100proc 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