1 # datastruct.tcl --
2 #
3 # Implementation of common data structures in OTcl.
4 #
5 # Copyright (c) 1996-2002 The Regents of the University of California.
6 # All rights reserved.
7 #
8 # Redistribution and use in source and binary forms, with or without
9 # modification, are permitted provided that the following conditions are met:
10 #
11 # A. Redistributions of source code must retain the above copyright notice,
12 # this list of conditions and the following disclaimer.
13 # B. Redistributions in binary form must reproduce the above copyright notice,
14 # this list of conditions and the following disclaimer in the documentation
15 # and/or other materials provided with the distribution.
16 # C. Neither the names of the copyright holders nor the names of its
17 # contributors may be used to endorse or promote products derived from this
18 # software without specific prior written permission.
19 #
20 # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS''
21 # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
22 # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23 # ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
24 # ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
25 # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
26 # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
27 # CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
28 # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
29 # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
30 #
31 # @(#) $Header: /usr/mash/src/repository/mash/mash-1/tcl/common/datastruct.tcl,v 1.4 2002/07/11 19:47:04 weitsang Exp $
32
33 #------------------------------------------------------------------
34 # Class:
35 # MashQueue
36 # Description:
37 # An implementation of the Queue data structure using a Tcl list.
38 #------------------------------------------------------------------
39 Class MashQueue
40 MashQueue instproc init {} {
41 $self set list_ {}
42 }
43 MashQueue instproc enq {item} {
44 $self instvar list_
45 lappend list_ $item
46 }
47 MashQueue instproc deq {} {
48 $self instvar list_
49 set head [lindex $list_ 0]
50 set list_ [lreplace $list_ 0 0]
51 return $head
52 }
53 MashQueue instproc is_empty {} {
54 $self instvar list_
55 if {$list_ == {}} {
56 return 1
57 } else {
58 return 0
59 }
60 }
61
62
63 #------------------------------------------------------------------
64 # Class:
65 # MashStack
66 # Description:
67 # An implementation of the Stack data structure using a Tcl list.
68 #------------------------------------------------------------------
69 Class MashStack
70 MashStack instproc init {} {
71 $self set list_ {}
72 }
73 MashStack instproc push {item} {
74 $self instvar list_
75 lappend list_ $item
76 }
77 MashStack instproc pop {} {
78 $self instvar list_
79 set tail [lindex $list_ end]
80 set list_ [lreplace $list_ end end]
81 return $tail
82 }
83 MashStack instproc is_empty {} {
84 $self instvar list_
85 if {$list_ == {}} {
86 return 1
87 } else {
88 return 0
89 }
90 }
91
92
93
94
95
96 #------------------------------------------------------------------
97 # Class:
98 # MashHeap
99 # Description:
100 # An implementation of the Heap data structure using a Tcl list.
101 #------------------------------------------------------------------
102 Class MashHeap
103 MashHeap instproc init {} {
104 $self set last_ -1
105 }
106
107
108 MashHeap instproc is_empty {} {
109 $self instvar last_
110 return [expr $last_ == -1]
111 }
112
113
114 MashHeap instproc insert {data cost} {
115 $self instvar a_ last_ cost_ pos_
116
117 if [info exists pos_($data)] {
118 error "$data already exists in heap"
119 }
120 incr last_
121 set a_($last_) $data
122 set cost_($last_) $cost
123 set pos_($data) $last_
124
125 $self percolate_up $last_
126
127 }
128
129
130 MashHeap instproc delete_min {} {
131 $self instvar a_ last_ cost_ pos_
132
133 if {$last_ < 0} {
134 error "Heap is empty"
135 }
136
137 set data $a_(0)
138
139 # swap first and last element.
140 foreach "a_(0) a_($last_) cost_(0) cost_($last_)" \
141 [list $a_($last_) $a_(0) $cost_($last_) $cost_(0)] { break }
142 set pos_($a_(0)) 0
143
144 # delete last element
145 unset cost_($last_)
146 unset pos_($a_($last_))
147 unset a_($last_)
148 incr last_ -1
149
150 $self percolate_down 0
151
152 return $data
153 }
154
155
156 MashHeap instproc has {name} {
157 $self instvar pos_
158 return [info exists pos_($name)]
159 }
160
161 MashHeap instproc decrease_key {name cost} {
162 $self instvar pos_ cost_
163 set cost_($pos_($name)) $cost
164
165 $self percolate_up $pos_($name)
166 }
167
168
169 MashHeap instproc print {} {
170 $self instvar pos_ cost_ a_ last_
171 for {set i 0} {$i <= $last_} {incr i} {
172 puts "$i\t$a_($i)\t$cost_($i)\t$pos_($a_($i))"
173 }
174 }
175
176
177 MashHeap private percolate_up {root} {
178 # procalate up
179 $self instvar cost_ a_ pos_
180 set curr $root
181 while {$curr != 0} {
182 set parent [expr {$curr >> 1}]
183 if {$cost_($parent) < $cost_($curr)} {
184 break
185 } else {
186 # a little foreach trick to swap variables, without temp var.
187 set l [list $a_($curr) $a_($parent) $cost_($curr) $cost_($parent)]
188 foreach "a_($parent) a_($curr) cost_($parent) cost_($curr)" $l {
189 break
190 }
191 set pos_($a_($curr)) $curr
192 set pos_($a_($parent)) $parent
193 set curr $parent
194 }
195 }
196 }
197
198
199 MashHeap private percolate_down {root} {
200 $self instvar last_ cost_ pos_ a_
201 set curr $root
202 while {1} {
203 set left [expr {$curr << 1}]
204 set right [expr {$left + 1}]
205 set smallest $curr
206 if {$left <= $last_ && $cost_($smallest) > $cost_($left)} {
207 set smallest $left
208 }
209 if {$right <= $last_ && $cost_($smallest) > $cost_($right)} {
210 set smallest $right
211 }
212 # smallest now points to the smallest among all three elements.
213 # If current is the smallest, we are done.
214 if {$smallest == $curr} {
215 break
216 } else {
217 # Otherwise, bring the smallest to the top. and continue.
218 # A little foreach trick to swap variables, without temp var.
219 foreach "a_($smallest) a_($curr) cost_($smallest) cost_($curr)" \
220 [list $a_($curr) $a_($smallest) $cost_($curr) $cost_($smallest)] {
221 break
222 }
223 set pos_($a_($curr)) $curr
224 set pos_($a_($smallest)) $smallest
225 set curr $smallest
226 }
227 }
228 }
229
230
231 #------------------------------------------------------------------
232 # Class:
233 # MashGraph
234 # Description:
235 # An implementation of the graph data structure. Each node is
236 # identified by a given name. Edges are identified by a pair
237 # of names. Nodes and edges can be associated with a "data".
238 #
239 # tcllib comes with its own graph structure. I just
240 # thought an OO implementation of graph would be nice to have
241 # around in Mash.
242 #------------------------------------------------------------------
243 Class MashGraph
244
245 MashGraph instproc init {} {
246 }
247
248
249 #------------------------------------------------------------------
250 # Method:
251 # MashGraph add_node
252 # MashGraph set_node
253 # MashGraph get_node
254 # MashGraph del_node
255 # MashGraph has_node
256 # Arguments:
257 # id -- an unique id supplied by caller to identify a node.
258 # data -- some data caller associates with a node.
259 # Description:
260 # add_node adds a node to the graph. set_node changes the
261 # data of the node with a given id. get_node returns the
262 # data of the node with a given id. del_node deletes the
263 # node with a given id (caller is responsible for freeing the
264 # associated data where applicable.). has_node checks if a
265 # node with a given id exists.
266 #------------------------------------------------------------------
267
268 MashGraph instproc add_node { id {data ""} } {
269 $self set nodes_($id) $data
270 }
271
272 MashGraph instproc set_node { id data } {
273 if [$self has_node $id] {
274 $self set nodes_($id) $data
275 } else {
276 error "no such node $id"
277 }
278 }
279
280 MashGraph instproc del_node { id } {
281
282 # delete edges
283 $self del_out_edges $id
284 $self del_in_edges $id
285
286 # delete the node
287 if {[$self has_node $id]} {
288 $self unset nodes_($id)
289 } else {
290 error "no such node $id"
291 }
292 }
293
294 MashGraph instproc has_node { id } {
295 $self instvar nodes_
296 return [info exists nodes_($id)]
297 }
298
299 MashGraph instproc get_node { id } {
300 if {[$self has_node $id]} {
301 return [$self set nodes_($id)]
302 } else {
303 return ""
304 }
305 }
306
307
308 #------------------------------------------------------------------
309 # Method:
310 # MashGraph add_edge
311 # MashGraph set_edge
312 # MashGraph get_edge
313 # MashGraph del_edge
314 # MashGraph has_edge
315 # Arguments:
316 # n1,n2 -- unique ids of the two nodes adjacent to an edge.
317 # data -- data associates with a edge.
318 # Description:
319 # add_edge adds a edge to the graph. set_edge changes the
320 # data of the edge (n1,n2). get_edge returns the data of the
321 # edge (n1,n2). del_edge deletes the edge (n1,n2). (caller
322 # is responsible for freeing the associated data where applicable.).
323 # has_edge checks if edge (n1,n2) exists in the graph.
324 #------------------------------------------------------------------
325 MashGraph instproc add_edge {n1 n2 {data ""}} {
326 if {[$self has_node $n1]} {
327 if {[$self has_node $n2]} {
328 $self set edges_($n1,$n2) $data
329 } else {
330 error "no such node $n2"
331 }
332 } else {
333 error "no such node $n1"
334 }
335 }
336
337 MashGraph instproc set_edge { n1 n2 data } {
338 if [$self has_edge $n1 $n2] {
339 $self set edges_($n1,$n2) $data
340 } else {
341 error "no such edge $n1 $n2"
342 }
343 }
344
345 MashGraph instproc del_edge {n1 n2} {
346 if {[$self has_edge $n1 $n2]} {
347 $self unset edges_($n1,$n2)
348 } else {
349 error "no such edge ($n1,$n2)"
350 }
351 }
352
353 MashGraph instproc has_edge {n1 n2} {
354 $self instvar edges_
355 return [info exists edges_($n1,$n2)]
356 }
357
358 MashGraph instproc get_edge {n1 n2} {
359 $self instvar edges_
360 if {[$self has_edge $n1 $n2]} {
361 return $edges_($n1,$n2)
362 } else {
363 error "no such edge ($n1,$n2)"
364 }
365 }
366
367
368 #------------------------------------------------------------------
369 # Method:
370 # MashGraph get_all_nodes
371 # MashGraph get_all_edges
372 # Description:
373 # Return a list of all nodes and edges in the graph respectively.
374 # Nodes are returned as a list of node ids, and edges are return
375 # as a list of lists of node id pairs.
376 #------------------------------------------------------------------
377 MashGraph instproc get_all_nodes { } {
378 #$self instvar nodes_
379 return [$self array names nodes_]
380 }
381
382 MashGraph instproc get_all_edges { } {
383 #$self instvar edges_
384 foreach key [$self array names edges_] {
385 lappend result [split $key ,]
386 }
387 return $result
388 }
389
390
391 #------------------------------------------------------------------
392 # Method:
393 # MashGraph get_nodes
394 # Description:
395 # Return a list of all node ids that matches a given pattern.
396 #------------------------------------------------------------------
397 MashGraph instproc get_nodes { pattern } {
398 #$self instvar nodes_
399 return [$self array names nodes_ $pattern]
400 }
401
402
403 #------------------------------------------------------------------
404 # Method:
405 # MashGraph get_in_neighbors
406 # MashGraph get_out_neighbors
407 # Description:
408 # Return a list of all adjacent nodes for incoming edges and
409 # outgoing edges respectively.
410 #------------------------------------------------------------------
411 MashGraph instproc get_in_neighbors {n2} {
412 $self instvar edges_
413 set result ""
414 foreach key [array names edges_ *,$n2] {
415 set neighbor [lindex [split $key ,] 0]
416 lappend result $neighbor
417 }
418 return $result
419 }
420
421 MashGraph instproc get_out_neighbors {n1} {
422 $self instvar edges_
423 set result ""
424 foreach key [array names edges_ $n1,*] {
425 set neighbor [lindex [split $key ,] 1]
426 lappend result $neighbor
427 }
428 return $result
429 }
430
431
432 #------------------------------------------------------------------
433 # Method:
434 # MashGraph get_in_edges
435 # MashGraph get_out_edges
436 # Description:
437 # Return a list of all incoming edges and outgoing edges. Edges
438 # are returned as a list of {<node id> <edge data>}.
439 #------------------------------------------------------------------
440 MashGraph instproc get_in_edges {n2} {
441 $self instvar edges_
442 set result ""
443 foreach key [array names edges_ *,$n2] {
444 set neighbor [lindex [split $key ,] 0]
445 lappend result $neighbor $edges_($key)
446 }
447 return $result
448 }
449
450 MashGraph instproc get_out_edges {n1} {
451 $self instvar edges_
452 set result ""
453 foreach key [array names edges_ $n1,*] {
454 set neighbor [lindex [split $key ,] 1]
455 lappend result $neighbor $edges_($key)
456 }
457 return $result
458 }
459
460
461 #------------------------------------------------------------------
462 # Method:
463 # MashGraph del_in_edges
464 # MashGraph del_out_edges
465 # Description:
466 # Delete all incoming edges and outgoing edges of a given node id.
467 #------------------------------------------------------------------
468 MashGraph instproc del_in_edges {n2} {
469 $self instvar edges_
470 foreach n1 [$self get_in_neighbors $n2] {
471 unset edges_($n1,$n2)
472 }
473 }
474
475 MashGraph instproc del_out_edges {n1} {
476 $self instvar edges_
477 foreach n2 [$self get_out_neighbors $n1] {
478 unset edges_($n1,$n2)
479 }
480 }
481
482 MashGraph instproc print {} {
483 $self instvar nodes_ edges_
484 puts "===================="
485 foreach pair [array names edges_] {
486 set l [split $pair ,]
487 puts "[lindex $l 0] -> [lindex $l 1]"
488 }
489 puts "===================="
490 }
491
This page was automatically generated by the
LXR engine.
Visit the LXR main site for more
information.