Return to setfuncs.tcl CVS log

Up to [Micropolis - Activity] / micropolis / src / tclx / tclsrc

Annotation of micropolis/src/tclx/tclsrc/setfuncs.tcl, revision 1.1.1.1

1.1       root        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: 

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.