1# disjointset.tcl -- 2# 3# Implementation of a Disjoint Set for Tcl. 4# 5# Copyright (c) Google Summer of Code 2008 Alejandro Eduardo Cruz Paz 6# Copyright (c) 2008 Andreas Kupries (API redesign and simplification) 7 8package require Tcl 8.2 9package require struct::set 10 11# Initialize the disjointset structure namespace. Note that any 12# missing parent namespace (::struct) will be automatically created as 13# well. 14namespace eval ::struct::disjointset { 15 # Counter for naming disjoint sets without a given name 16 variable counter 0 17 18 # Only export one command, the one used to instantiate a new 19 # disjoint set 20 namespace export disjointset 21} 22 23# ::struct::disjointset::disjointset -- 24# 25# Create a new disjoint set with a given name; if no name is 26# given, use disjointsetX, where X is a number. 27# 28# Arguments: 29# name Optional name of the disjoint set; if not specified, generate one. 30# 31# Results: 32# name Name of the disjoint set created 33 34proc ::struct::disjointset::disjointset {args} { 35 variable counter 36 37 # Derived from the constructor of struct::queue, see file 38 # "queue_tcl.tcl". Create name of not specified. 39 switch -exact -- [llength [info level 0]] { 40 1 { 41 # Missing name, generate one. 42 incr counter 43 set name "disjointset${counter}" 44 } 45 2 { 46 # Standard call. New empty disjoint set. 47 set name [lindex $args 0] 48 } 49 default { 50 # Error. 51 return -code error \ 52 "wrong # args: should be \"::struct::disjointset ?name?\"" 53 } 54 } 55 56 # FIRST, qualify the name. 57 if {![string match "::*" $name]} { 58 # Get caller's namespace; append :: if not global namespace. 59 set ns [uplevel 1 [list namespace current]] 60 if {"::" != $ns} { 61 append ns "::" 62 } 63 set name "$ns$name" 64 } 65 66 # Done after qualification so that we have a canonical name and 67 # know exactly what we are looking for. 68 if {[llength [info commands $name]]} { 69 return -code error \ 70 "command \"$name\" already exists, unable to create disjointset" 71 } 72 73 74 # This is the structure where each disjoint set will be kept. A 75 # namespace containing a list/set of the partitions, and a set of 76 # all elements (for quick testing of validity when adding 77 # partitions.). 78 79 namespace eval $name { 80 variable partitions {} ; # Set of partitions. 81 variable all {} ; # Set of all elements. 82 } 83 84 # Create the command to manipulate the DisjointSet 85 interp alias {} ::$name {} ::struct::disjointset::DisjointSetProc $name 86 return $name 87} 88 89########################## 90# Private functions follow 91 92# ::struct::disjointset::DisjointSetProc -- 93# 94# Command that processes all disjointset object commands. 95# 96# Arguments: 97# name Name of the disjointset object to manipulate. 98# cmd Subcommand to invoke. 99# args Arguments for subcommand. 100# 101# Results: 102# Varies based on command to perform 103 104proc ::struct::disjointset::DisjointSetProc {name {cmd ""} args} { 105 # Do minimal args checks here 106 if { [llength [info level 0]] == 2 } { 107 error "wrong # args: should be \"$name option ?arg arg ...?\"" 108 } 109 110 # Derived from the struct::queue dispatcher (see queue_tcl.tcl). 111 # Gets rid of the explicit list of commands. Slower in case of an 112 # error, considered acceptable, as errors should not happen, or 113 # only seldomly. 114 115 set sub _$cmd 116 if { ![llength [info commands ::struct::disjointset::$sub]]} { 117 set optlist [lsort [info commands ::struct::disjointset::_*]] 118 set xlist {} 119 foreach p $optlist { 120 set p [namespace tail $p] 121 lappend xlist [string range $p 1 end] 122 } 123 set optlist [linsert [join $xlist ", "] "end-1" "or"] 124 return -code error \ 125 "bad option \"$cmd\": must be $optlist" 126 } 127 128 # Run the method in the same context as the dispatcher. 129 return [uplevel 1 [linsert $args 0 ::struct::disjointset::_$cmd $name]] 130} 131 132# ::struct::disjointset::_add-partition 133# 134# Creates a new partition in the disjoint set structure, 135# verifying the integrity of each new insertion for previous 136# existence in the structure. 137# 138# Arguments: 139# name The name of the actual disjoint set structure 140# items A set of elements to add to the set as a new partition. 141# 142# Results: 143# A new partition is added to the disjoint set. If the disjoint 144# set already included any of the elements in any of its 145# partitions an error will be thrown. 146 147proc ::struct::disjointset::_add-partition {name items} { 148 variable ${name}::partitions 149 variable ${name}::all 150 151 # Validate that one of the elements to be added are already known. 152 foreach element $items { 153 if {[struct::set contains $all $element]} { 154 return -code error \ 155 "The element \"$element\" is already known to the disjoint set $name" 156 } 157 } 158 159 struct::set add all $items 160 lappend partitions $items 161 return 162} 163 164# ::struct::disjointset::_partitions 165# 166# Retrieves the set of partitions the disjoint set consists of. 167# 168# Arguments: 169# name The name of the disjoint set. 170# 171# Results: 172# A set of the partitions contained in the disjoint set. 173# If the disjoint set has no partitions the returned set 174# will be empty. 175 176proc ::struct::disjointset::_partitions {name} { 177 variable ${name}::partitions 178 return $partitions 179} 180 181# ::struct::disjointset::_num-partitions 182# 183# Retrieves the number of partitions the disjoint set consists of. 184# 185# Arguments: 186# name The name of the disjoint set. 187# 188# Results: 189# The number of partitions contained in the disjoint set. 190 191proc ::struct::disjointset::_num-partitions {name} { 192 variable ${name}::partitions 193 return [llength $partitions] 194} 195 196# ::struct::disjointset::_equal 197# 198# Determines if the two elements belong to the same partition 199# of the disjoint set. Throws an error if either element does 200# not belong to the disjoint set at all. 201# 202# Arguments: 203# name The name of the disjoint set. 204# a The first element to be compared 205# b The second element set to be compared 206# 207# Results: 208# The result of the comparison, a boolean flag. 209# True if the element are in the same partition, and False otherwise. 210 211proc ::struct::disjointset::_equal {name a b} { 212 CheckValidity $name $a 213 CheckValidity $name $b 214 return [expr {[FindIndex $name $a] == [FindIndex $name $b]}] 215} 216 217# ::struct::disjointset::_merge 218# 219# Determines the partitions the two elements belong to and 220# merges them, if they are not the same. An error is thrown 221# if either element does not belong to the disjoint set. 222# 223# Arguments: 224# name The name of the actual disjoint set structure 225# a 1st item whose partition will be merged. 226# b 2nd item whose partition will be merged. 227# 228# Results: 229# An empty string. 230 231proc ::struct::disjointset::_merge {name a b} { 232 CheckValidity $name $a 233 CheckValidity $name $b 234 235 set a [FindIndex $name $a] 236 set b [FindIndex $name $b] 237 238 if {$a == $b} return 239 240 variable ${name}::partitions 241 242 set apart [lindex $partitions $a] 243 set bpart [lindex $partitions $b] 244 245 # Remove the higher partition first, otherwise the 2nd replace 246 # will access the wrong element. 247 if {$b > $a} { set t $a ; set a $b ; set b $t } 248 249 set partitions [linsert \ 250 [lreplace [lreplace [K $partitions [unset partitions]] \ 251 $a $a] $b $b] \ 252 end [struct::set union $apart $bpart]] 253 return 254} 255 256# ::struct::disjointset::_find 257# 258# Determines and returns the partition the element belongs to. 259# Returns an empty partition if the element does not belong to 260# the disjoint set. 261# 262# Arguments: 263# name The name of the disjoint set. 264# item The element to be searched. 265# 266# Results: 267# Returns the partition containing the element, or an empty 268# partition if the item is not present. 269 270proc ::struct::disjointset::_find {name item} { 271 variable ${name}::all 272 if {![struct::set contains $all $item]} { 273 return {} 274 } else { 275 variable ${name}::partitions 276 return [lindex $partitions [FindIndex $name $item]] 277 } 278} 279 280proc ::struct::disjointset::FindIndex {name item} { 281 variable ${name}::partitions 282 # Check each partition directly. 283 # AK XXX Future Use a nested-tree structure to make the search 284 # faster 285 286 set i 0 287 foreach p $partitions { 288 if {[struct::set contains $p $item]} { 289 return $i 290 } 291 incr i 292 } 293 return -1 294} 295 296# ::struct::disjointset::_destroy 297# 298# Destroy the disjoint set structure and releases all memory 299# associated with it. 300# 301# Arguments: 302# name The name of the actual disjoint set structure 303 304proc ::struct::disjointset::_destroy {name} { 305 namespace delete $name 306 interp alias {} ::$name {} 307 return 308} 309 310# ### ### ### ######### ######### ######### 311## Internal helper 312 313# ::struct::disjointset::CheckValidity 314# 315# Verifies if the argument element is a member of the disjoint 316# set or not. Throws an error if not. 317# 318# Arguments: 319# name The name of the disjoint set 320# element The element to look for. 321# 322# Results: 323# 1 if element is a unary list, 0 otherwise 324 325proc ::struct::disjointset::CheckValidity {name element} { 326 variable ${name}::all 327 if {![struct::set contains $all $element]} { 328 return -code error \ 329 "The element \"$element\" is not known to the disjoint set $name" 330 } 331 return 332} 333 334proc ::struct::disjointset::K { x y } { set x } 335 336# ### ### ### ######### ######### ######### 337## Ready 338 339namespace eval ::struct { 340 namespace import -force disjointset::disjointset 341 namespace export disjointset 342} 343 344package provide struct::disjointset 1.0 345