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     ! 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.