home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / tcl / tclx7_31.z / tclx7_31 / tcldev / tclX7.3a-p1 / tclsrc / setfuncs.tcl < prev    next >
Encoding:
Text File  |  1993-11-19  |  3.5 KB  |  131 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-1993 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 3.0 1993/11/19 07:00:26 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.     if [lempty $list] {
  42.         return {}
  43.     }
  44.     set list [lsort $list]
  45.     set last [lvarpop list]
  46.     lappend result $last
  47.     foreach element $list {
  48.     if {$last != $element} {
  49.         lappend result $element
  50.         set last $element
  51.     }
  52.     }
  53.     return $result
  54. }
  55.  
  56. #
  57. # intersect3 - perform the intersecting of two lists, returning a list
  58. # containing three lists.  The first list is everything in the first
  59. # list that wasn't in the second, the second list contains the intersection
  60. # of the two lists, the third list contains everything in the second list
  61. # that wasn't in the first.
  62. #
  63.  
  64. proc intersect3 {list1 list2} {
  65.     set list1Result ""
  66.     set list2Result ""
  67.     set intersectList ""
  68.  
  69.     set list1 [lrmdups $list1]
  70.     set list2 [lrmdups $list2]
  71.  
  72.     while {1} {
  73.         if [lempty $list1] {
  74.             if ![lempty $list2] {
  75.                 set list2Result [concat $list2Result $list2]
  76.             }
  77.             break
  78.         }
  79.         if [lempty $list2] {
  80.         set list1Result [concat $list1Result $list1]
  81.             break
  82.         }
  83.         set compareResult [string compare [lindex $list1 0] [lindex $list2 0]]
  84.  
  85.         if {$compareResult < 0} {
  86.             lappend list1Result [lvarpop list1]
  87.             continue
  88.         }
  89.         if {$compareResult > 0} {
  90.             lappend list2Result [lvarpop list2]
  91.             continue
  92.         }
  93.         lappend intersectList [lvarpop list1]
  94.         lvarpop list2
  95.     }
  96.     return [list $list1Result $intersectList $list2Result]
  97. }
  98.  
  99. #
  100. # intersect - perform an intersection of two lists, returning a list
  101. # containing every element that was present in both lists
  102. #
  103. proc intersect {list1 list2} {
  104.     set intersectList ""
  105.  
  106.     set list1 [lsort $list1]
  107.     set list2 [lsort $list2]
  108.  
  109.     while {1} {
  110.         if {[lempty $list1] || [lempty $list2]} break
  111.  
  112.         set compareResult [string compare [lindex $list1 0] [lindex $list2 0]]
  113.  
  114.         if {$compareResult < 0} {
  115.             lvarpop list1
  116.             continue
  117.         }
  118.  
  119.         if {$compareResult > 0} {
  120.             lvarpop list2
  121.             continue
  122.         }
  123.  
  124.         lappend intersectList [lvarpop list1]
  125.         lvarpop list2
  126.     }
  127.     return $intersectList
  128. }
  129.  
  130.  
  131.