home *** CD-ROM | disk | FTP | other *** search
/ Serving the Web / ServingTheWeb1995.disc1of1.iso / linux / slacksrce / tcl / tcl+tk+t / tclx7.3bl / tclx7 / tclX7.3b / tclsrc / setfuncs.tcl < prev    next >
Encoding:
Text File  |  1994-07-16  |  3.3 KB  |  123 lines
  1. #
  2. # setfuncs --
  3. #
  4. # Perform set functions on lists.  Also has a procedure for removing duplicate
  5. # list entries.
  6. #------------------------------------------------------------------------------
  7. # Copyright 1992-1994 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 4.0 1994/07/16 05:29:49 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.     return [lrmdups [concat $lista $listb]]
  27. }
  28.  
  29. #
  30. # sort a list, returning the sorted version minus any duplicates
  31. #
  32. proc lrmdups list {
  33.     if [lempty $list] {
  34.         return {}
  35.     }
  36.     set list [lsort $list]
  37.     set last [lvarpop list]
  38.     lappend result $last
  39.     foreach element $list {
  40.     if {$last != $element} {
  41.         lappend result $element
  42.         set last $element
  43.     }
  44.     }
  45.     return $result
  46. }
  47.  
  48. #
  49. # intersect3 - perform the intersecting of two lists, returning a list
  50. # containing three lists.  The first list is everything in the first
  51. # list that wasn't in the second, the second list contains the intersection
  52. # of the two lists, the third list contains everything in the second list
  53. # that wasn't in the first.
  54. #
  55.  
  56. proc intersect3 {list1 list2} {
  57.     set list1Result ""
  58.     set list2Result ""
  59.     set intersectList ""
  60.  
  61.     set list1 [lrmdups $list1]
  62.     set list2 [lrmdups $list2]
  63.  
  64.     while {1} {
  65.         if [lempty $list1] {
  66.             if ![lempty $list2] {
  67.                 set list2Result [concat $list2Result $list2]
  68.             }
  69.             break
  70.         }
  71.         if [lempty $list2] {
  72.         set list1Result [concat $list1Result $list1]
  73.             break
  74.         }
  75.         set compareResult [string compare [lindex $list1 0] [lindex $list2 0]]
  76.  
  77.         if {$compareResult < 0} {
  78.             lappend list1Result [lvarpop list1]
  79.             continue
  80.         }
  81.         if {$compareResult > 0} {
  82.             lappend list2Result [lvarpop list2]
  83.             continue
  84.         }
  85.         lappend intersectList [lvarpop list1]
  86.         lvarpop list2
  87.     }
  88.     return [list $list1Result $intersectList $list2Result]
  89. }
  90.  
  91. #
  92. # intersect - perform an intersection of two lists, returning a list
  93. # containing every element that was present in both lists
  94. #
  95. proc intersect {list1 list2} {
  96.     set intersectList ""
  97.  
  98.     set list1 [lsort $list1]
  99.     set list2 [lsort $list2]
  100.  
  101.     while {1} {
  102.         if {[lempty $list1] || [lempty $list2]} break
  103.  
  104.         set compareResult [string compare [lindex $list1 0] [lindex $list2 0]]
  105.  
  106.         if {$compareResult < 0} {
  107.             lvarpop list1
  108.             continue
  109.         }
  110.  
  111.         if {$compareResult > 0} {
  112.             lvarpop list2
  113.             continue
  114.         }
  115.  
  116.         lappend intersectList [lvarpop list1]
  117.         lvarpop list2
  118.     }
  119.     return $intersectList
  120. }
  121.  
  122.  
  123.