You are viewing a plain text version of this content. The canonical link for it is here.
Posted to rivet-dev@tcl.apache.org by da...@apache.org on 2001/09/19 15:20:18 UTC
cvs commit: tcl-rivet/src/buildscripts LICENSE aardvark.tcl findconfig.tcl graph.tcl parsetclConfig.tcl pkgIndex.tcl
davidw 01/09/19 06:20:18
Added: src/buildscripts LICENSE aardvark.tcl findconfig.tcl
graph.tcl parsetclConfig.tcl pkgIndex.tcl
Log:
Committed build scripts.
Revision Changes Path
1.1 tcl-rivet/src/buildscripts/LICENSE
Index: LICENSE
===================================================================
/* ====================================================================
* The Apache Software License, Version 1.1
*
* Copyright (c) 2000, 2001 The Apache Software Foundation. All rights
* reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
*
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in
* the documentation and/or other materials provided with the
* distribution.
*
* 3. The end-user documentation included with the redistribution,
* if any, must include the following acknowledgment:
* "This product includes software developed by the
* Apache Software Foundation (http://www.apache.org/)."
* Alternately, this acknowledgment may appear in the software itself,
* if and wherever such third-party acknowledgments normally appear.
*
* 4. The names "Apache" and "Apache Software Foundation" must
* not be used to endorse or promote products derived from this
* software without prior written permission. For written
* permission, please contact apache@apache.org.
*
* 5. Products derived from this software may not be called "aardvark"
* nor may "aardvark" appear in their name, without prior
* written permission of the Apache Software Foundation.
*
* THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED
* WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
* OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE APACHE SOFTWARE FOUNDATION OR
* ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
* SUCH DAMAGE.
* ====================================================================
*
* This software consists of voluntary contributions made by many
* individuals on behalf of the Apache Software Foundation. For more
* information on the Apache Software Foundation, please see
* <http://www.apache.org/>.
*
* Portions of this software are based upon public domain software
* originally written at the National Center for Supercomputing Applications,
* University of Illinois, Urbana-Champaign. */
1.1 tcl-rivet/src/buildscripts/aardvark.tcl
Index: aardvark.tcl
===================================================================
# aardvark make-like system
# $Id: aardvark.tcl,v 1.1 2001/09/19 13:20:18 davidw Exp $
# Copyright (c) 2001 Apache Software Foundation. All Rights reserved.
# See the LICENSE file for licensing terms.
package provide aardvark 0.1
package require struct
namespace eval aardvark {
# the graph 'object' we use throughout.
variable grph
# possible verbose variable to make output noisy.
variable vbose
# we use these to pass information from the AddNode "mini language"
variable buildinfo
variable dependencies
set vbose 0
proc Verbose { } {
variable vbose
set vbose 1
}
# creates one node, if it doesn't exist, and creates it's data
proc createnode { name } {
variable grph
if { ! [ $grph node exists $name ] } {
$grph node insert $name
$grph node set $name -key buildinfo {cmd "" tclcommand ""}
}
}
# the command that gets run when we walk the graph.
proc runbuildcommand { direction graphname node } {
variable grph
set rebuild 0
set mtime 0
set deps [ $grph nodes -out $node ]
array set buildinfo [ $grph node get $node -key buildinfo ]
# check file time
if { [ file exists $node ] } {
set mtime [ file mtime $node ]
}
# rebuild if dependencies are newer than file
if { [ llength $deps ] > 0 } {
foreach dep $deps {
if { [ file exists $dep ] } {
set depmtime [ file mtime $dep ]
} else {
set depmtime 0
}
if { $depmtime > $mtime } {
set rebuild 1
}
}
} else {
set rebuild 1
}
if { $rebuild == 1} {
if { $buildinfo(cmd) != "" } {
foreach cmd $buildinfo(cmd) {
puts -nonewline "$node :"
catch {
set cmd [uplevel #0 "subst {$cmd}"]
puts "$cmd"
} err
if { $err != "" } {
puts $cmd
puts $err
continue
}
catch {
set result [ eval exec $cmd ]
puts "$result"
} err
if { $err != "" } {
puts $err
}
}
}
if { $buildinfo(tclcommand) != "" } {
foreach tclcommand $buildinfo(tclcommand) {
catch {
puts -nonewline "$node :"
puts -nonewline "$tclcommand"
uplevel #0 $tclcommand
} err
if { $err != "" } {
puts $err
}
}
puts ""
}
}
}
# these form the 'syntax' of our mini build language
proc command { buildcmd } {
variable buildinfo
lappend buildinfo(cmd) $buildcmd
return ""
}
proc tclcommand { tclcommand } {
variable buildinfo
lappend buildinfo(tclcommand) $tclcommand
return ""
}
proc depends { deps } {
variable dependencies
set dependencies $deps
return ""
}
proc AddNode { name rest } {
variable grph
variable dependencies
variable buildinfo
set dependencies {}
array set buildinfo {cmd "" tclcommand ""}
set self $name
catch {
uplevel #0 $rest
} err
if { $err != "" } {
puts "Error: $err"
}
createnode $name
$grph node set $name -key buildinfo [ array get buildinfo ]
foreach dep $dependencies {
# puts -nonewline "$dep/"
createnode $dep
$grph arc insert $name $dep
}
}
proc Run { } {
global ::argv
variable grph
set start [ lindex $::argv 0 ]
if { $start != "" } {
$grph walk $start -order post -command runbuildcommand
} else {
$grph walk all -order post -command runbuildcommand
}
}
# create graph
set grph [ ::struct::graph ]
namespace export AddNode Run Verbose command tclcommand depends
}
1.1 tcl-rivet/src/buildscripts/findconfig.tcl
Index: findconfig.tcl
===================================================================
# $Id: findconfig.tcl,v 1.1 2001/09/19 13:20:18 davidw Exp $
# This program ought to return the location of tclConfig.sh
# Code borrowed from Don Porter's usenet posting.
proc RelToExec {exe cf} {
file join [file dirname [file dirname $exe]] lib $cf
}
proc RelToExec2 {cf} {
file join [ info library ] $cf
}
proc FindTclConfig {} {
set exec [file tail [info nameofexecutable]]
# If we're running tclsh...
if {[string match -nocase "*tclsh*" $exec]} {
set cf [RelToExec [info nameofexecutable] tclConfig.sh]
if {[file readable $cf]} {
return $cf
} else {
set cf [RelToExec2 tclConfig.sh]
if {[file readable $cf]} {
return $cf
}
}
}
# If tcl_pkgPath is available, look there...
global tcl_pkgPath
if {[info exists tcl_pkgPath]} {
foreach libdir $tcl_pkgPath {
if {[file readable [file join $libdir tclConfig.sh]]} {
return [file join $libdir tclConfig.sh]
}
}
}
# Not in usual places, go searching for tclsh...
set candshells [list]
if {[regsub -nocase wish $exec tclsh shell]} {
lappend candshells $shell
}
lappend candshells tclsh[package provide Tcl]
lappend candshells tclsh[join [split [package provide Tcl] .] ""] foreach shell $candshells {
set shell [auto_execok $shell]
if {[string length $shell]} {
set cf [RelToExec $shell tclConfig.sh]
if {[file readable $cf]} {
return $cf
}
}
}
return -code error "tclConfig.sh not found"
}
1.1 tcl-rivet/src/buildscripts/graph.tcl
Index: graph.tcl
===================================================================
# graph.tcl --
#
# Implementation of a graph data structure for Tcl.
#
# Copyright (c) 2000 by Andreas Kupries
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: graph.tcl,v 1.1 2001/09/19 13:20:18 davidw Exp $
namespace eval ::struct {}
namespace eval ::struct::graph {
# Data storage in the graph module
# -------------------------------
#
# There's a lot of bits to keep track of for each graph:
# nodes
# node values
# node relationships (arcs)
# arc values
#
# It would quickly become unwieldy to try to keep these in arrays or lists
# within the graph namespace itself. Instead, each graph structure will
# get its own namespace. Each namespace contains:
# node:$node array mapping keys to values for the node $node
# arc:$arc array mapping keys to values for the arc $arc
# inArcs array mapping nodes to the list of incoming arcs
# outArcs array mapping nodes to the list of outgoing arcs
# arcNodes array mapping arcs to the two nodes (start & end)
# counter is used to give a unique name for unnamed graph
variable counter 0
# commands is the list of subcommands recognized by the graph
variable commands [list \
"arc" \
"arcs" \
"destroy" \
"node" \
"nodes" \
"swap" \
"walk" \
]
variable arcCommands [list \
"delete" \
"exists" \
"get" \
"insert" \
"set" \
"source" \
"target" \
"unset" \
]
variable nodeCommands [list \
"degree" \
"delete" \
"exists" \
"get" \
"insert" \
"opposite" \
"set" \
"unset" \
]
# Only export one command, the one used to instantiate a new graph
namespace export graph
}
# ::struct::graph::graph --
#
# Create a new graph with a given name; if no name is given, use
# graphX, where X is a number.
#
# Arguments:
# name name of the graph; if null, generate one.
#
# Results:
# name name of the graph created
proc ::struct::graph::graph {{name ""}} {
variable counter
if { [llength [info level 0]] == 1 } {
incr counter
set name "graph${counter}"
}
if { ![string equal [info commands ::$name] ""] } {
error "command \"$name\" already exists, unable to create graph"
}
# Set up the namespace
namespace eval ::struct::graph::graph$name {
# Set up the map from nodes to the arcs coming to them
variable inArcs
array set inArcs {}
# Set up the map from nodes to the arcs going out from them
variable outArcs
array set outArcs {}
# Set up the map from arcs to the nodes they touch.
variable arcNodes
array set arcNodes {}
# Set up a value for use in creating unique node names
variable nextUnusedNode
set nextUnusedNode 1
# Set up a value for use in creating unique arc names
variable nextUnusedArc
set nextUnusedArc 1
}
# Create the command to manipulate the graph
interp alias {} ::$name {} ::struct::graph::GraphProc $name
return $name
}
##########################
# Private functions follow
# ::struct::graph::GraphProc --
#
# Command that processes all graph object commands.
#
# Arguments:
# name name of the graph object to manipulate.
# args command name and args for the command
#
# Results:
# Varies based on command to perform
proc ::struct::graph::GraphProc {name {cmd ""} args} {
# Do minimal args checks here
if { [llength [info level 0]] == 2 } {
error "wrong # args: should be \"$name option ?arg arg ...?\""
}
# Split the args into command and args components
if { [llength [info commands ::struct::graph::_$cmd]] == 0 } {
variable commands
set optlist [join $commands ", "]
set optlist [linsert $optlist "end-1" "or"]
error "bad option \"$cmd\": must be $optlist"
}
eval [list ::struct::graph::_$cmd $name] $args
}
# ::struct::graph::_arc --
#
# Dispatches the invocation of arc methods to the proper handler
# procedure.
#
# Arguments:
# name name of the graph.
# cmd arc command to invoke
# args arguments to propagate to the handler for the arc command
#
# Results:
# As of the invoked handler.
proc ::struct::graph::_arc {name cmd args} {
# Split the args into command and args components
if { [llength [info commands ::struct::graph::__arc_$cmd]] == 0 } {
variable arcCommands
set optlist [join $arcCommands ", "]
set optlist [linsert $optlist "end-1" "or"]
error "bad option \"$cmd\": must be $optlist"
}
eval [list ::struct::graph::__arc_$cmd $name] $args
}
# ::struct::graph::__arc_delete --
#
# Remove an arc from a graph, including all of its values.
#
# Arguments:
# name name of the graph.
# args list of arcs to delete.
#
# Results:
# None.
proc ::struct::graph::__arc_delete {name args} {
foreach arc $args {
if { ![__arc_exists $name $arc] } {
error "arc \"$arc\" does not exist in graph \"$name\""
}
}
upvar ::struct::graph::graph${name}::inArcs inArcs
upvar ::struct::graph::graph${name}::outArcs outArcs
upvar ::struct::graph::graph${name}::arcNodes arcNodes
foreach arc $args {
foreach {source target} $arcNodes($arc) break ; # lassign
unset arcNodes($arc)
unset ::struct::graph::graph${name}::arc$arc
# Remove arc from the arc lists of source and target nodes.
set index [lsearch -exact $outArcs($source) $arc]
set outArcs($source) [lreplace $outArcs($source) $index $index]
set index [lsearch -exact $inArcs($target) $arc]
set inArcs($target) [lreplace $inArcs($target) $index $index]
}
return
}
# ::struct::graph::__arc_exists --
#
# Test for existance of a given arc in a graph.
#
# Arguments:
# name name of the graph.
# arc arc to look for.
#
# Results:
# 1 if the arc exists, 0 else.
proc ::struct::graph::__arc_exists {name arc} {
return [info exists ::struct::graph::graph${name}::arcNodes($arc)]
}
# ::struct::graph::__arc_get --
#
# Get a keyed value from an arc in a graph.
#
# Arguments:
# name name of the graph.
# arc arc to query.
# flag -key; anything else is an error
# key key to lookup; defaults to data
#
# Results:
# value value associated with the key given.
proc ::struct::graph::__arc_get {name arc {flag -key} {key data}} {
if { ![__arc_exists $name $arc] } {
error "arc \"$arc\" does not exist in graph \"$name\""
}
upvar ::struct::graph::graph${name}::arc${arc} data
if { ![info exists data($key)] } {
error "invalid key \"$key\" for arc \"$arc\""
}
return $data($key)
}
# ::struct::graph::__arc_insert --
#
# Add an arc to a graph.
#
# Arguments:
# name name of the graph.
# source source node of the new arc
# target target node of the new arc
# args arc to insert; must be unique. If none is given,
# the routine will generate a unique node name.
#
# Results:
# arc The name of the new arc.
proc ::struct::graph::__arc_insert {name source target args} {
if { [llength $args] == 0 } {
# No arc name was given; generate a unique one
set arc [__generateUniqueArcName $name]
} else {
set arc [lindex $args 0]
}
if { [__arc_exists $name $arc] } {
error "arc \"$arc\" already exists in graph \"$name\""
}
if { ![__node_exists $name $source] } {
error "source node \"$source\" does not exist in graph \"$name\""
}
if { ![__node_exists $name $target] } {
error "target node \"$target\" does not exist in graph \"$name\""
}
upvar ::struct::graph::graph${name}::inArcs inArcs
upvar ::struct::graph::graph${name}::outArcs outArcs
upvar ::struct::graph::graph${name}::arcNodes arcNodes
upvar ::struct::graph::graph${name}::arc${arc} data
# Set up the new arc
set data(data) ""
set arcNodes($arc) [list $source $target]
# Add this arc to the arc lists of its source resp. target nodes.
lappend outArcs($source) $arc
lappend inArcs($target) $arc
return $arc
}
# ::struct::graph::__arc_set --
#
# Set or get a value for an arc in a graph.
#
# Arguments:
# name name of the graph.
# arc arc to modify or query.
# args ?-key key? ?value?
#
# Results:
# val value associated with the given key of the given arc
proc ::struct::graph::__arc_set {name arc args} {
if { ![__arc_exists $name $arc] } {
error "arc \"$arc\" does not exist in graph \"$name\""
}
upvar ::struct::graph::graph${name}::arc$arc data
if { [llength $args] > 3 } {
error "wrong # args: should be \"$name arc set $arc ?-key key?\
?value?\""
}
set key "data"
set haveValue 0
if { [llength $args] > 1 } {
foreach {flag key} $args break
if { ![string match "${flag}*" "-key"] } {
error "invalid option \"$flag\": should be key"
}
if { [llength $args] == 3 } {
set haveValue 1
set value [lindex $args end]
}
} elseif { [llength $args] == 1 } {
set haveValue 1
set value [lindex $args end]
}
if { $haveValue } {
# Setting a value
return [set data($key) $value]
} else {
# Getting a value
if { ![info exists data($key)] } {
error "invalid key \"$key\" for arc \"$arc\""
}
return $data($key)
}
}
# ::struct::graph::__arc_source --
#
# Return the node at the beginning of the specified arc.
#
# Arguments:
# name name of the graph object.
# arc arc to look up.
#
# Results:
# node name of the node.
proc ::struct::graph::__arc_source {name arc} {
if { ![__arc_exists $name $arc] } {
error "arc \"$arc\" does not exist in graph \"$name\""
}
upvar ::struct::graph::graph${name}::arcNodes arcNodes
return [lindex $arcNodes($arc) 0]
}
# ::struct::graph::__arc_target --
#
# Return the node at the end of the specified arc.
#
# Arguments:
# name name of the graph object.
# arc arc to look up.
#
# Results:
# node name of the node.
proc ::struct::graph::__arc_target {name arc} {
if { ![__arc_exists $name $arc] } {
error "arc \"$arc\" does not exist in graph \"$name\""
}
upvar ::struct::graph::graph${name}::arcNodes arcNodes
return [lindex $arcNodes($arc) 1]
}
# ::struct::graph::__arc_unset --
#
# Remove a keyed value from a arc.
#
# Arguments:
# name name of the graph.
# arc arc to modify.
# args additional args: ?-key key?
#
# Results:
# None.
proc ::struct::graph::__arc_unset {name arc {flag -key} {key data}} {
if { ![__arc_exists $name $arc] } {
error "arc \"$arc\" does not exist in graph \"$name\""
}
if { ![string match "${flag}*" "-key"] } {
error "invalid option \"$flag\": should be \"$name unset\
$arc ?-key key?\""
}
upvar ::struct::graph::graph${name}::arc${arc} data
if { [info exists data($key)] } {
unset data($key)
}
return
}
# ::struct::graph::_arcs --
#
# Return a list of all arcs in a graph satisfying some
# node based restriction.
#
# Arguments:
# name name of the graph.
#
# Results:
# arcs list of arcs
proc ::struct::graph::_arcs {name args} {
if {[llength $args] == 0} {
# No restriction, deliver all.
upvar ::struct::graph::graph${name}::arcNodes arcNodes
return [array names arcNodes]
}
# Get mode and node list
set cond [lindex $args 0]
set args [lrange $args 1 end]
# Validate that the cond is good.
switch -glob -- $cond {
"-in" {
set cond "in"
}
"-out" {
set cond "out"
}
"-adj" {
set cond "adj"
}
"-inner" {
set cond "inner"
}
"-embedding" {
set cond "embedding"
}
default {
error "invalid restriction \"$cond\": should be -in, -out,\
-adj, -inner or -embedding"
}
}
# Validate that there are nodes to use in the restriction.
# otherwise what's the point?
if {[llength $args] == 0} {
set usage "$name arcs ?-in|-out|-adj|-inner|-embedding node node...?"
error "no nodes specified: should be \"$usage\""
}
# Make sure that the specified nodes exist!
foreach node $args {
if { ![__node_exists $name $node] } {
error "node \"$node\" does not exist in graph \"$name\""
}
}
# Now we are able to go to work
upvar ::struct::graph::graph${name}::inArcs inArcs
upvar ::struct::graph::graph${name}::outArcs outArcs
upvar ::struct::graph::graph${name}::arcNodes arcNodes
set arcs [list]
array set coll {}
switch -exact -- $cond {
in {
# Result is all arcs going to at least one node
# in the list of arguments.
foreach node $args {
foreach e $inArcs($node) {
if {[info exists coll($e)]} {continue}
lappend arcs $e
set coll($e) .
}
}
}
out {
# Result is all arcs coming from at least one node
# in the list of arguments.
foreach node $args {
foreach e $outArcs($node) {
if {[info exists coll($e)]} {continue}
lappend arcs $e
set coll($e) .
}
}
}
adj {
# Result is all arcs coming from or going to at
# least one node in the list of arguments.
foreach node $args {
foreach e $inArcs($node) {
if {[info exists coll($e)]} {continue}
lappend arcs $e
set coll($e) .
}
foreach e $outArcs($node) {
if {[info exists coll($e)]} {continue}
lappend arcs $e
set coll($e) .
}
}
}
inner {
# Result is all arcs running between nodes in the list.
array set group {}
foreach node $args {
set group($node) .
}
foreach node $args {
foreach e $inArcs($node) {
set n [lindex $arcNodes($e) 0]
if {![info exists group($n)]} {continue}
if { [info exists coll($e)]} {continue}
lappend arcs $e
set coll($e) .
}
foreach e $outArcs($node) {
set n [lindex $arcNodes($e) 1]
if {![info exists group($n)]} {continue}
if { [info exists coll($e)]} {continue}
lappend arcs $e
set coll($e) .
}
}
}
embedding {
# Result is all arcs from -adj minus the arcs from -inner.
# IOW all arcs goint from a node in the list to a node
# which is *not* in the list
array set group {}
foreach node $args {
set group($node) .
}
foreach node $args {
foreach e $inArcs($node) {
set n [lindex $arcNodes($e) 0]
if {[info exists group($n)]} {continue}
if {[info exists coll($e)]} {continue}
lappend arcs $e
set coll($e) .
}
foreach e $outArcs($node) {
set n [lindex $arcNodes($e) 1]
if {[info exists group($n)]} {continue}
if {[info exists coll($e)]} {continue}
lappend arcs $e
set coll($e) .
}
}
}
}
return $arcs
}
# ::struct::graph::_destroy --
#
# Destroy a graph, including its associated command and data storage.
#
# Arguments:
# name name of the graph.
#
# Results:
# None.
proc ::struct::graph::_destroy {name} {
namespace delete ::struct::graph::graph$name
interp alias {} ::$name {}
}
# ::struct::graph::__generateUniqueArcName --
#
# Generate a unique arc name for the given graph.
#
# Arguments:
# name name of the graph.
#
# Results:
# arc name of a arc guaranteed to not exist in the graph.
proc ::struct::graph::__generateUniqueArcName {name} {
upvar ::struct::graph::graph${name}::nextUnusedArc nextUnusedArc
while {[__arc_exists $name "arc${nextUnusedArc}"]} {
incr nextUnusedArc
}
return "arc${nextUnusedArc}"
}
# ::struct::graph::__generateUniqueNodeName --
#
# Generate a unique node name for the given graph.
#
# Arguments:
# name name of the graph.
#
# Results:
# node name of a node guaranteed to not exist in the graph.
proc ::struct::graph::__generateUniqueNodeName {name} {
upvar ::struct::graph::graph${name}::nextUnusedNode nextUnusedNode
while {[__node_exists $name "node${nextUnusedNode}"]} {
incr nextUnusedNode
}
return "node${nextUnusedNode}"
}
# ::struct::graph::_node --
#
# Dispatches the invocation of node methods to the proper handler
# procedure.
#
# Arguments:
# name name of the graph.
# cmd node command to invoke
# args arguments to propagate to the handler for the node command
#
# Results:
# As of the the invoked handler.
proc ::struct::graph::_node {name cmd args} {
# Split the args into command and args components
if { [llength [info commands ::struct::graph::__node_$cmd]] == 0 } {
variable nodeCommands
set optlist [join $nodeCommands ", "]
set optlist [linsert $optlist "end-1" "or"]
error "bad option \"$cmd\": must be $optlist"
}
eval [list ::struct::graph::__node_$cmd $name] $args
}
# ::struct::graph::__node_degree --
#
# Return the number of arcs adjacent to the specified node.
# If one of the restrictions -in or -out is given only
# incoming resp. outgoing arcs are counted.
#
# Arguments:
# name name of the graph.
# args option, followed by the node.
#
# Results:
# None.
proc ::struct::graph::__node_degree {name args} {
if {([llength $args] < 1) || ([llength $args] > 2)} {
error "wrong # args: should be \"$name node degree ?-in|-out| node\""
}
switch -exact -- [llength $args] {
1 {
set opt {}
set node [lindex $args 0]
}
2 {
set opt [lindex $args 0]
set node [lindex $args 1]
}
}
# Validate the option.
switch -exact -- $opt {
{} -
-in -
-out {}
default {
error "invalid option \"$opt\": should be -in or -out"
}
}
# Validate the node
if { ![__node_exists $name $node] } {
error "node \"$node\" does not exist in graph \"$name\""
}
upvar ::struct::graph::graph${name}::inArcs inArcs
upvar ::struct::graph::graph${name}::outArcs outArcs
switch -exact -- $opt {
-in {
set result [llength $inArcs($node)]
}
-out {
set result [llength $outArcs($node)]
}
{} {
set result [expr {[llength $inArcs($node)] \
+ [llength $outArcs($node)]}]
# loops count twice, don't do <set> arithmetics, i.e. no union!
if {0} {
array set coll {}
set result [llength $inArcs($node)]
foreach e $inArcs($node) {
set coll($e) .
}
foreach e $outArcs($node) {
if {[info exists coll($e)]} {continue}
incr result
set coll($e) .
}
}
}
}
return $result
}
# ::struct::graph::__node_delete --
#
# Remove a node from a graph, including all of its values.
# Additionally removes the arcs connected to this node.
#
# Arguments:
# name name of the graph.
# args list of the nodes to delete.
#
# Results:
# None.
proc ::struct::graph::__node_delete {name args} {
foreach node $args {
if { ![__node_exists $name $node] } {
error "node \"$node\" does not exist in graph \"$name\""
}
}
upvar ::struct::graph::graph${name}::inArcs inArcs
upvar ::struct::graph::graph${name}::outArcs outArcs
foreach node $args {
# Remove all the arcs connected to this node
foreach e $inArcs($node) {
__arc_delete $name $e
}
foreach e $outArcs($node) {
# Check existence to avoid problems with
# loops (they are in and out arcs! at
# the same time and thus already deleted)
if { [__arc_exists $name $e] } {
__arc_delete $name $e
}
}
unset inArcs($node)
unset outArcs($node)
unset ::struct::graph::graph${name}::node$node
}
return
}
# ::struct::graph::__node_exists --
#
# Test for existance of a given node in a graph.
#
# Arguments:
# name name of the graph.
# node node to look for.
#
# Results:
# 1 if the node exists, 0 else.
proc ::struct::graph::__node_exists {name node} {
return [info exists ::struct::graph::graph${name}::inArcs($node)]
}
# ::struct::graph::__node_get --
#
# Get a keyed value from a node in a graph.
#
# Arguments:
# name name of the graph.
# node node to query.
# flag -key; anything else is an error
# key key to lookup; defaults to data
#
# Results:
# value value associated with the key given.
proc ::struct::graph::__node_get {name node {flag -key} {key data}} {
if { ![__node_exists $name $node] } {
error "node \"$node\" does not exist in graph \"$name\""
}
upvar ::struct::graph::graph${name}::node${node} data
if { ![info exists data($key)] } {
error "invalid key \"$key\" for node \"$node\""
}
return $data($key)
}
# ::struct::graph::__node_insert --
#
# Add a node to a graph.
#
# Arguments:
# name name of the graph.
# args node to insert; must be unique. If none is given,
# the routine will generate a unique node name.
#
# Results:
# node The namee of the new node.
proc ::struct::graph::__node_insert {name args} {
if { [llength $args] == 0 } {
# No node name was given; generate a unique one
set node [__generateUniqueNodeName $name]
} else {
set node [lindex $args 0]
}
if { [__node_exists $name $node] } {
error "node \"$node\" already exists in graph \"$name\""
}
upvar ::struct::graph::graph${name}::inArcs inArcs
upvar ::struct::graph::graph${name}::outArcs outArcs
upvar ::struct::graph::graph${name}::node${node} data
# Set up the new node
set inArcs($node) [list]
set outArcs($node) [list]
set data(data) ""
return $node
}
# ::struct::graph::__node_opposite --
#
# Retrieve node opposite to the specified one, along the arc.
#
# Arguments:
# name name of the graph.
# node node to look up.
# arc arc to look up.
#
# Results:
# nodex Node opposite to <node,arc>
proc ::struct::graph::__node_opposite {name node arc} {
if {![__node_exists $name $node] } {
error "node \"$node\" does not exist in graph \"$name\""
}
if {![__arc_exists $name $arc] } {
error "arc \"$arc\" does not exist in graph \"$name\""
}
upvar ::struct::graph::graph${name}::arcNodes arcNodes
# Node must be connected to at least one end of the arc.
if {[string equal $node [lindex $arcNodes($arc) 0]]} {
set result [lindex $arcNodes($arc) 1]
} elseif {[string equal $node [lindex $arcNodes($arc) 1]]} {
set result [lindex $arcNodes($arc) 0]
} else {
error "node \"$node\" and arc \"$arc\" are not connected\
in graph \"$name\""
}
return $result
}
# ::struct::graph::__node_set --
#
# Set or get a value for a node in a graph.
#
# Arguments:
# name name of the graph.
# node node to modify or query.
# args ?-key key? ?value?
#
# Results:
# val value associated with the given key of the given node
proc ::struct::graph::__node_set {name node args} {
if { ![__node_exists $name $node] } {
error "node \"$node\" does not exist in graph \"$name\""
}
upvar ::struct::graph::graph${name}::node$node data
if { [llength $args] > 3 } {
error "wrong # args: should be \"$name node set $node ?-key key?\
?value?\""
}
set key "data"
set haveValue 0
if { [llength $args] > 1 } {
foreach {flag key} $args break
if { ![string match "${flag}*" "-key"] } {
error "invalid option \"$flag\": should be key"
}
if { [llength $args] == 3 } {
set haveValue 1
set value [lindex $args end]
}
} elseif { [llength $args] == 1 } {
set haveValue 1
set value [lindex $args end]
}
if { $haveValue } {
# Setting a value
return [set data($key) $value]
} else {
# Getting a value
if { ![info exists data($key)] } {
error "invalid key \"$key\" for node \"$node\""
}
return $data($key)
}
}
# ::struct::graph::__node_unset --
#
# Remove a keyed value from a node.
#
# Arguments:
# name name of the graph.
# node node to modify.
# args additional args: ?-key key?
#
# Results:
# None.
proc ::struct::graph::__node_unset {name node {flag -key} {key data}} {
if { ![__node_exists $name $node] } {
error "node \"$node\" does not exist in graph \"$name\""
}
if { ![string match "${flag}*" "-key"] } {
error "invalid option \"$flag\": should be \"$name unset\
$node ?-key key?\""
}
upvar ::struct::graph::graph${name}::node${node} data
if { [info exists data($key)] } {
unset data($key)
}
return
}
# ::struct::graph::_nodes --
#
# Return a list of all nodes in a graph satisfying some restriction.
#
# Arguments:
# name name of the graph.
# args list of options and nodes specifying the restriction.
#
# Results:
# nodes list of nodes
proc ::struct::graph::_nodes {name args} {
if {[llength $args] == 0} {
# No restriction, deliver all.
upvar ::struct::graph::graph${name}::inArcs inArcs
return [array names inArcs]
}
# Get mode and node list
set cond [lindex $args 0]
set args [lrange $args 1 end]
# Validate that the cond is good.
switch -glob -- $cond {
"-in" {
set cond "in"
}
"-out" {
set cond "out"
}
"-adj" {
set cond "adj"
}
"-inner" {
set cond "inner"
}
"-embedding" {
set cond "embedding"
}
default {
error "invalid restriction \"$cond\": should be -in, -out,\
-adj, -inner or -embedding"
}
}
# Validate that there are nodes to use in the restriction.
# otherwise what's the point?
if {[llength $args] == 0} {
set usage "$name nodes ?-in|-out|-adj|-inner|-embedding node node...?"
error "no nodes specified: should be \"$usage\""
}
# Make sure that the specified nodes exist!
foreach node $args {
if { ![__node_exists $name $node] } {
error "node \"$node\" does not exist in graph \"$name\""
}
}
# Now we are able to go to work
upvar ::struct::graph::graph${name}::inArcs inArcs
upvar ::struct::graph::graph${name}::outArcs outArcs
upvar ::struct::graph::graph${name}::arcNodes arcNodes
set nodes [list]
array set coll {}
switch -exact -- $cond {
in {
# Result is all nodes with at least one arc going to
# at least one node in the list of arguments.
foreach node $args {
foreach e $inArcs($node) {
set n [lindex $arcNodes($e) 0]
if {[info exists coll($n)]} {continue}
lappend nodes $n
set coll($n) .
}
}
}
out {
# Result is all nodes with at least one arc coming from
# at least one node in the list of arguments.
foreach node $args {
foreach e $outArcs($node) {
set n [lindex $arcNodes($e) 1]
if {[info exists coll($n)]} {continue}
lappend nodes $n
set coll($n) .
}
}
}
adj {
# Result is all nodes with at least one arc coming from
# or going to at least one node in the list of arguments.
foreach node $args {
foreach e $inArcs($node) {
set n [lindex $arcNodes($e) 0]
if {[info exists coll($n)]} {continue}
lappend nodes $n
set coll($n) .
}
foreach e $outArcs($node) {
set n [lindex $arcNodes($e) 1]
if {[info exists coll($n)]} {continue}
lappend nodes $n
set coll($n) .
}
}
}
inner {
# Result is all nodes from the list! with at least one arc
# coming from or going to at least one node in the list of
# arguments.
array set group {}
foreach node $args {
set group($node) .
}
foreach node $args {
foreach e $inArcs($node) {
set n [lindex $arcNodes($e) 0]
if {![info exists group($n)]} {continue}
if { [info exists coll($n)]} {continue}
lappend nodes $n
set coll($n) .
}
foreach e $outArcs($node) {
set n [lindex $arcNodes($e) 1]
if {![info exists group($n)]} {continue}
if { [info exists coll($n)]} {continue}
lappend nodes $n
set coll($n) .
}
}
}
embedding {
# Result is all nodes with at least one arc coming from
# or going to at least one node in the list of arguments,
# but not in the list itself!
array set group {}
foreach node $args {
set group($node) .
}
foreach node $args {
foreach e $inArcs($node) {
set n [lindex $arcNodes($e) 0]
if {[info exists group($n)]} {continue}
if {[info exists coll($n)]} {continue}
lappend nodes $n
set coll($n) .
}
foreach e $outArcs($node) {
set n [lindex $arcNodes($e) 1]
if {[info exists group($n)]} {continue}
if {[info exists coll($n)]} {continue}
lappend nodes $n
set coll($n) .
}
}
}
}
return $nodes
}
# ::struct::graph::_swap --
#
# Swap two nodes in a graph.
#
# Arguments:
# name name of the graph.
# node1 first node to swap.
# node2 second node to swap.
#
# Results:
# None.
proc ::struct::graph::_swap {name node1 node2} {
# Can only swap two real nodes
if { ![__node_exists $name $node1] } {
error "node \"$node1\" does not exist in graph \"$name\""
}
if { ![__node_exists $name $node2] } {
error "node \"$node2\" does not exist in graph \"$name\""
}
# Can't swap a node with itself
if { [string equal $node1 $node2] } {
error "cannot swap node \"$node1\" with itself"
}
# Swapping nodes means swapping their labels, values and arcs
upvar ::struct::graph::graph${name}::outArcs outArcs
upvar ::struct::graph::graph${name}::inArcs inArcs
upvar ::struct::graph::graph${name}::arcNodes arcNodes
upvar ::struct::graph::graph${name}::node${node1} node1Vals
upvar ::struct::graph::graph${name}::node${node2} node2Vals
# Redirect arcs to the new nodes.
foreach e $inArcs($node1) {
set arcNodes($e) [lreplace $arcNodes($e) end end $node2]
}
foreach e $inArcs($node2) {
set arcNodes($e) [lreplace $arcNodes($e) end end $node1]
}
foreach e $outArcs($node1) {
set arcNodes($e) [lreplace $arcNodes($e) 0 0 $node2]
}
foreach e $outArcs($node2) {
set arcNodes($e) [lreplace $arcNodes($e) 0 0 $node1]
}
# Swap arc lists
set tmp $inArcs($node1)
set inArcs($node1) $inArcs($node2)
set inArcs($node2) $tmp
set tmp $outArcs($node1)
set outArcs($node1) $outArcs($node2)
set outArcs($node2) $tmp
# Swap the values
set value1 [array get node1Vals]
unset node1Vals
array set node1Vals [array get node2Vals]
unset node2Vals
array set node2Vals $value1
return
}
# ::struct::graph::_walk --
#
# Walk a graph using a pre-order depth or breadth first
# search. Pre-order DFS is the default. At each node that is visited,
# a command will be called with the name of the graph and the node.
#
# Arguments:
# name name of the graph.
# node node at which to start.
# args additional args: ?-order pre|post|both? ?-type {bfs|dfs}?
# -command cmd
#
# Results:
# None.
proc ::struct::graph::_walk {name node args} {
set usage "$name walk $node ?-dir forward|backward?\
?-order pre|post|both? ?-type {bfs|dfs}? -command cmd"
if {[llength $args] > 8 || [llength $args] < 2} {
error "wrong # args: should be \"$usage\""
}
if { ![__node_exists $name $node] } {
error "node \"$node\" does not exist in graph \"$name\""
}
# Set defaults
set type dfs
set order pre
set cmd ""
set dir forward
# Process specified options
for {set i 0} {$i < [llength $args]} {incr i} {
set flag [lindex $args $i]
incr i
if { $i >= [llength $args] } {
error "value for \"$flag\" missing: should be \"$usage\""
}
switch -glob -- $flag {
"-type" {
set type [string tolower [lindex $args $i]]
}
"-order" {
set order [string tolower [lindex $args $i]]
}
"-command" {
set cmd [lindex $args $i]
}
"-dir" {
set dir [string tolower [lindex $args $i]]
}
default {
error "unknown option \"$flag\": should be \"$usage\""
}
}
}
# Make sure we have a command to run, otherwise what's the point?
if { [string equal $cmd ""] } {
error "no command specified: should be \"$usage\""
}
# Validate that the given type is good
switch -glob -- $type {
"dfs" {
set type "dfs"
}
"bfs" {
set type "bfs"
}
default {
error "invalid search type \"$type\": should be dfs, or bfs"
}
}
# Validate that the given order is good
switch -glob -- $order {
"both" {
set order both
}
"pre" {
set order pre
}
"post" {
set order post
}
default {
error "invalid search order \"$order\": should be both,\
pre or post"
}
}
# Validate that the given direction is good
switch -glob -- $dir {
"forward" {
set dir -out
}
"backward" {
set dir -in
}
default {
error "invalid search direction \"$dir\": should be\
forward or backward"
}
}
# Do the walk
set st [list ]
lappend st $node
array set visited {}
if { [string equal $type "dfs"] } {
if { [string equal $order "pre"] } {
# Pre-order Depth-first search
while { [llength $st] > 0 } {
set node [lindex $st end]
set st [lreplace $st end end]
# Evaluate the command at this node
set cmdcpy $cmd
lappend cmdcpy enter $name $node
uplevel 2 $cmdcpy
set visited($node) .
# Add this node's neighbours (according to direction)
# Have to add them in reverse order
# so that they will be popped left-to-right
set next [_nodes $name $dir $node]
set len [llength $next]
for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} {
set nextnode [lindex $next $i]
if {[info exists visited($nextnode)]} {
# Skip nodes already visited
continue
}
lappend st $nextnode
}
}
} elseif { [string equal $order "post"] } {
# Post-order Depth-first search
while { [llength $st] > 0 } {
set node [lindex $st end]
if {[info exists visited($node)]} {
# Second time we are here, pop it,
# then evaluate the command.
set st [lreplace $st end end]
# Evaluate the command at this node
set cmdcpy $cmd
lappend cmdcpy leave $name $node
uplevel 2 $cmdcpy
} else {
# First visit. Remember it.
set visited($node) .
# Add this node's neighbours.
set next [_nodes $name $dir $node]
set len [llength $next]
for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} {
set nextnode [lindex $next $i]
if {[info exists visited($nextnode)]} {
# Skip nodes already visited
continue
}
lappend st $nextnode
}
}
}
} else {
# Both-order Depth-first search
while { [llength $st] > 0 } {
set node [lindex $st end]
if {[info exists visited($node)]} {
# Second time we are here, pop it,
# then evaluate the command.
set st [lreplace $st end end]
# Evaluate the command at this node
set cmdcpy $cmd
lappend cmdcpy leave $name $node
uplevel 2 $cmdcpy
} else {
# First visit. Remember it.
set visited($node) .
# Evaluate the command at this node
set cmdcpy $cmd
lappend cmdcpy enter $name $node
uplevel 2 $cmdcpy
# Add this node's neighbours.
set next [_nodes $name $dir $node]
set len [llength $next]
for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} {
set nextnode [lindex $next $i]
if {[info exists visited($nextnode)]} {
# Skip nodes already visited
continue
}
lappend st $nextnode
}
}
}
}
} else {
if { [string equal $order "pre"] } {
# Pre-order Breadth first search
while { [llength $st] > 0 } {
set node [lindex $st 0]
set st [lreplace $st 0 0]
# Evaluate the command at this node
set cmdcpy $cmd
lappend cmdcpy enter $name $node
uplevel 2 $cmdcpy
set visited($node) .
# Add this node's neighbours.
foreach child [_nodes $name $dir $node] {
if {[info exists visited($child)]} {
# Skip nodes already visited
continue
}
lappend st $child
}
}
} else {
# Post-order Breadth first search
# Both-order Breadth first search
# Haven't found anything in Knuth
# and unable to define something
# consistent for myself. Leave it
# out.
error "unable to do a ${order}-order breadth first walk"
}
}
return
}
# ::struct::graph::Union --
#
# Return a list which is the union of the elements
# in the specified lists.
#
# Arguments:
# args list of lists representing sets.
#
# Results:
# set list representing the union of the argument lists.
proc ::struct::graph::Union {args} {
switch [llength $args] {
0 {
return {}
}
1 {
return [lindex $args 0]
}
default {
foreach set $args {
foreach e $set {
set tmp($e) .
}
}
return [array names tmp]
}
}
}
1.1 tcl-rivet/src/buildscripts/parsetclConfig.tcl
Index: parsetclConfig.tcl
===================================================================
#!/usr/bin/tclsh
source [ file join . buildscripts findconfig.tcl ]
set config [ FindTclConfig ]
proc parseconfig { config } {
set fl [ open $config r ]
while { ! [ eof $fl ] } {
gets $fl line
if { [ string index $line 0 ] != "#" } {
set line [ split $line = ]
if { [ llength $line ] == 2 } {
set val ""
set var [ lindex $line 0 ]
global $var
catch {
set val [ subst [ string trim [ lindex $line 1 ] ' ] ]
}
set $var $val
}
}
}
}
parseconfig $config
1.1 tcl-rivet/src/buildscripts/pkgIndex.tcl
Index: pkgIndex.tcl
===================================================================
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script. It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands. When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
package ifneeded aardvark 0.1 [list source [file join $dir aardvark.tcl]]