git.zerfleddert.de Git - micropolis/blob - 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