aboutsummaryrefslogtreecommitdiff
path: root/tree.tcl
blob: 8c35320f4f6ffcea847ddce16006adf381b18a4c (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
# Conceptually compatible with tcllib ::struct::tree
# but uses an object based interface.
# To mimic tcllib, do:
#   rename [tree] mytree

# set pt [tree]
#
#   Create a tree
#   This automatically creates a node named "root"
#
# $pt destroy
#
#   Destroy the tree and all it's nodes
#
# $pt set <nodename> <key> <value>
#
#   Set the value for the given key
#
# $pt lappend <nodename> <key> <value> ...
#
#   Append to the (list) value(s) for the given key, or set if not yet set
#
# $pt keyexists <nodename> <key>
#
#   Returns 1 if the given key exists
#
# $pt get <nodename> <key>
#
#   Returns the value associated with the given key
# 
# $pt depth <nodename>
#
#   Returns the depth of the given node. The depth of "root" is 0.
#
# $pt parent <nodename>
#
#   Returns the name of the parent node, or "" for the root node.
# 
# $pt numchildren <nodename>
#
#   Returns the number of child nodes.
# 
# $pt children <nodename>
#
#   Returns a list of the child nodes.
# 
# $pt next <nodename>
#
#   Returns the next sibling node, or "" if none.
# 
# $pt insert <nodename> <index>
#
#   Add a new child node to the given node.
#   Currently the node is always added at the end (index=end)
#   Returns the name of the newly added node
#
# $pt walk <nodename> dfs|bfs {actionvar nodevar} <code>
#
#   Walks the tree starting from the given node, either breadth first (bfs)
#   depth first (dfs).
#   The value "enter" or "exit" is stored in variable $actionvar
#   The name of each node is stored in $nodevar.
#   The script $code is evaluated twice for each node, on entry and exit.

# Create a new tree
proc tree {} {
	# A tree is a dictionary of (name, noderef)
	# The name for the root node is always "root",
	# and other nodes are automatically named "node1", "node2", etc.

	# Create the root node
	lassign [tree._makenode ""] dummy rootref

	# Create the tree containing one node
	set tree [dict create root $rootref]

	# And create a reference to a tree dictionary
	set treeref [ref $tree tree]

	lambda {command args} {treeref} {
		#puts "You invoked [list \$tree $command $args]"
		uplevel 1 [list tree.$command $treeref {*}$args]
	}
}

# $tree insert node ?index?
#
proc tree.insert {treeref node {index end}} {
	# Get the parent node
	set parentref [tree._getnoderef $treeref $node]

	# Make a new node
	lassign [tree._makenode $parentref] childname childref

	# Add it to the list of children in the parent node
	tree._update_node $treeref $node parent {
		lappend parent(.children) $childref
	}

	# Add it to the tree
	tree._update_tree $treeref tree {
		set tree($childname) $childref
	}

	return $childname
}

# $tree set node key value
#
proc tree.set {treeref node key value} {
	tree._update_node $treeref $node n {
		set n($key) $value
	}
	return $value
}

# $tree lappend node key value
#
proc tree.lappend {treeref node key args} {
	tree._update_node $treeref $node n {
		lappend n($key) {expand}$args
		set result $n($key)
	}
	return $result
}

# $tree get node key
#
proc tree.get {treeref node key} {
	set n [tree._getnode $treeref $node]

	return $n($key)
}

# $tree keyexists node key
#
proc tree.keyexists {treeref node key} {
	set n [tree._getnode $treeref $node]
	info exists n($key)
}

# $tree depth node
#
proc tree.depth {treeref node} {
	set n [tree._getnode $treeref $node]
	return $n(.depth)
}

# $tree parent node
#
proc tree.parent {treeref node} {
	set n [tree._getnode $treeref $node]
	return $n(.parent)
}

# $tree numchildren node
#
proc tree.numchildren {treeref node} {
	set n [tree._getnode $treeref $node]
	llength $n(.children)
}

# $tree children node
#
proc tree.children {treeref node} {
	set n [tree._getnode $treeref $node]
	set result {}
	foreach child $n(.children) {
		set c [getref $child]
		lappend result $c(.name)
	}
	return $result
}

# $tree next node
#
proc tree.next {treeref node} {
	set parent [tree.parent $treeref $node]
	set siblings [tree.children $treeref $parent] 
	set i [lsearch $siblings $node]
	incr i
	return [lindex $siblings $i]
}

# $tree walk node bfs|dfs {action loopvar} <code>
#
proc tree.walk {treeref node type vars code} {
	set n [tree._getnode $treeref $node]

	# set up vars
	lassign $vars actionvar namevar

	if {$type ne "child"} {
		upvar $namevar name
		upvar $actionvar action

		# Enter this node
		set name $node
		set action enter

		uplevel 1 $code
	}

	if {$type eq "dfs"} {
		# Depth-first so do the children
		foreach childref $n(.children) {
			set child [getref $childref]
			uplevel 1 [list tree.walk $treeref $child(.name) $type $vars $code]
		}
	} elseif {$type ne "none"} {
		# Breadth-first so do the children to one level only
		foreach childref $n(.children) {
			set child [getref $childref]
			uplevel 1 [list tree.walk $treeref $child(.name) none $vars $code]
		}

		# Now our grandchildren
		foreach childref $n(.children) {
			set child [getref $childref]
			uplevel 1 [list tree.walk $treeref $child(.name) child $vars $code]
		}
	}

	if {$type ne "child"} {
		# Exit this node
		set name $node
		set action exit

		uplevel 1 $code
	}
}

# Destroys the tree
#
proc tree.destroy {treeref} {
	set tree [getref $treeref]
	foreach {nodename noderef} $tree {
		setref $noderef {}
	}
	setref $treeref {}

	# Extract the name of the handle
	set t [lindex [info level 1] 0]
	rename $t ""
}

#
# INTERNAL procedures below this point
#


# Make a new child node of the parent
#
# Note that this does *not* add the node
# to the parent or to the tree
#
# Returns a list of {nodename noderef}
#
proc tree._makenode {parent} {{nodeid 1}} {
	if {$parent eq ""} {
		# The root node
		set name root
		set depth 0
		set parentname ""
	} else {
		set parentnode [getref $parent]

		set name node$nodeid
		incr nodeid
		set depth $parentnode(.depth)
		incr depth
		set parentname $parentnode(.name)
	}

	# Return a list of name, reference
	list $name [ref [list .name $name .depth $depth .parent $parentname .children {}] node]
}

# Return the node (dictionary value) with the given name
#
proc tree._getnode {treeref node} {
	getref [dict get [getref $treeref] $node]
}

# Return the noderef with the given name
#
proc tree._getnoderef {treeref node} {
	dict get [getref $treeref] $node
}

# Set a dictionary value named $varname in the parent context,
# evaluate $code, and then store any changes to
# the node (via $varname) back to the node
#
proc tree._update_node {treeref node varname code} {
	upvar $varname n

	# Get a reference to the node
	set ref [tree._getnoderef $treeref $node]

	# Get the node itself
	set n [getref $ref]

	uplevel 1 $code

	# And update the reference
	setref $ref $n
}

# Set a dictionary value named $varname in the parent context,
# evaluate $code, and then store any changes to
# the tree (via $varname) back to the tree
#
proc tree._update_tree {treeref varname code} {
	upvar $varname t

	# Get the tree value
	set t [getref $treeref]

	# Possibly modify it
	uplevel 1 $code

	# And update the reference
	setref $treeref $t
}