SetOps, Code, 7.6

Back to the Chart of proposed set functionality. See also SetOps.
 # ---------------------------------------------
 # SetOps -- Set operations for Tcl
 #
 # (C) c.l.t. community, 1999
 #
 # $Id: 358,v 1.3 2003-03-21 09:00:45 jcw Exp $
 # ---------------------------------------------
 # Implementation variant for tcl 7.6 and below.
 # It looks as if the procedures would use namespaces,
 # but they don't. For 7.6 the '::'s are just part of
 # the procedure name. It is especially not possible
 # to use the internal procedures in a shortcut manner
 # (without preceding ::setops::).
 # ---------------------------------------------


 proc ::setops::create {args} {
    if {[llength $args] == 0} {
        return {}
    }
    foreach $args {.} {break}
    unset args
    info locals
 }


 proc ::setops::contains {set element} {
    expr {[lsearch -exact $set $element] < 0 ? 0 : 1}
 }


 proc ::setops::union {args} {
    switch [llength $args] {
        0 {
            return {}
        }
        1 {
            return [lindex $args 0]
        }
        default {
            foreach __SETA__ $args {
                if {[llength $__SETA__] > 0} {
                    foreach $__SETA__ {.} {break}
                }
            }

            unset args __SETA__
            info locals
        }
    }
 }


 proc ::setops::Intersect2 {__SETA__ __SETB__} {

    if {[llength $__SETA__] == 0} {
        return {}
    }
    if {[llength $__SETB__] == 0} {
        return {}
    }

    set __RESULT__ {}

    if {[llength $__SETA__] < [llength $__SETB__]} {
        foreach $__SETB__ {.} {break}

        foreach __ITEM__ $__SETA__ {
            if {[info exists $__ITEM__]} {
                lappend __RESULT__ $__ITEM__
            }
        }
    } else {
        foreach $__SETA__ {.} {break}

        foreach __ITEM__ $__SETB__ {
            if {[info exists $__ITEM__]} {
                lappend __RESULT__ $__ITEM__
            }
        }
    }

    return $__RESULT__
 }


 proc ::setops::intersect {args} {
    switch [llength $args] {
        0 {
            # Intersection of nothing is nothing
            return {}
        }
        1 {
            return [lindex $args 0]
        }
        default {
            set res  [lindex $args 0]
            set args [lrange $args 1 end]

            while {($res != {}) && ([llength $args] > 0)} {
                set res  [::setops::Intersect2 $res [lindex $args 0]]
                set args [lrange $args 1 end]
            }

            return $res
        }
    }
 }


 proc ::setops::diff {__SETA__ __SETB__} {
    if {[llength $__SETA__] == 0} {
        return {}
    }
    if {[llength $__SETB__] == 0} {
        return $__SETA__
    }

    set __RESULT__ {}

    foreach $__SETB__ {.} {break}

    foreach __ITEM__ $__SETA__ {
        if {![info exists $__ITEM__]} {
            lappend __RESULT__ $__ITEM__
        }
    }

    return $__RESULT__
 }


 proc ::setops::symdiff {a b} {
    ::setops::diff [::setops::union $a $b] [::setops::Intersect2 $a $b]
 }


 proc ::setops::empty {set} {
    expr {[llength $set] == 0}
 }
Category Package