#!/bin/sh
# the next line restarts using wish \
exec wish4.1 "$0" "$@"
#
# Occam Design Tool
#
# (C) Copyright 1995,1996 Dave Beckett <D.J.Beckett@ukc.ac.uk>
# University of Kent at Canterbury
#
set rcsId {$Id: stooop.tcl,v 1.32 1995/12/23 21:57:46 jfontain Exp $}
if {[file exists libstooop.so.2.1]} {
load libstooop.so.2.1 stooop
}
catch {rename proc ::proc}
if {[llength [info commands new]]==0} {
if {![info exists _newId]} {
set _newId 0
}
::proc new {classOrId args} {
global _newId _class
if {[catch {expr $classOrId}]} {
set _class([set id [incr _newId]]) $classOrId
eval $classOrId::$classOrId $id $args
} else {
[set _class([set id [incr _newId]]) $_class($classOrId)]::_copy $id $classOrId
}
return $id
}
::proc delete {args} {
global _class
foreach id $args {
_delete $_class($id) $id
unset _class($id)
}
}
::proc _delete {class id} {
$class::~$class $id
global $class
foreach name [array names $class $id,*] {
unset ${class}($name)
}
}
::proc classof {id} {
global _class
return $_class($id)
}
::proc _copy {class from to} {
global $class
set index [string length $from]
foreach name [array names $class $from,*] {
set ${class}($to[string range $name $index end]) [set ${class}($name)]
}
set index [string length $class$from]
foreach name [info globals $class$from*] {
global [set target $class$to[string range $name $index end]] $name
array set $target [array get $name]
}
}
}
::proc virtual {keyword name arguments args} {
if {[string compare $keyword proc]!=0} {
error "virtual operator works only on proc, not $keyword"
}
if {![regexp {^(.+)::(.+)$} $name dummy class procedure]} {
error "$name is not a valid member procedure name"
}
if {[string compare $class $procedure]==0} {
error "cannot make a constructor virtual (class $class)"
}
if {[string compare ~$class $procedure]==0} {
error "cannot make a destructor virtual (class $class)"
}
if {[string compare [lindex $arguments 0] this]!=0} {
error "cannot make a static procedure ($name) virtual"
}
global _pureVirtual
set _pureVirtual [expr [llength $args]==0]
proc $name $arguments [lindex $args 0]
unset _pureVirtual
}
::proc proc {name arguments args} {
global _baseClasses
if {![regexp {^(.+)::(.+)$} $name dummy class procedure]} {
::proc $name $arguments [lindex $args 0]
return
}
if {[llength $args]==0} {
error "missing body for $name"
}
if {[string compare $class $procedure]==0} {
if {[string compare [lindex $arguments 0] this]!=0} {
error "class constructor first argument must be this (class $class)"
}
if {[catch {info body $class::$class}]} {
eval _constructorDeclaration $class 0 \{$arguments\} $args
_generateDefaultCopyConstructor $class
} else {
if {[llength $arguments]!=2} {
error "class copy constructor must have 2 arguments exactly (class $class)"
}
if {[string compare [lindex $arguments 1] copy]!=0} {
error "class copy constructor second argument must be copy (class $class)"
}
eval _constructorDeclaration $class 1 \{$arguments\} $args
}
} elseif {[string compare ~$class $procedure]==0} {
if {[llength $arguments]!=1} {
error "class destructor must have 1 argument exactly (class $class)"
}
if {[string compare [lindex $arguments 0] this]!=0} {
error "class destructor argument must be this (class $class)"
}
if {[catch {info body $class::$class}]} {
error "class $class destructor defined before constructor"
}
_destructorDeclaration $class $arguments [lindex $args 0]
} else {
_memberProcedureDeclaration $class $procedure $arguments [lindex $args 0]
}
}
::proc _ancestors {class} {
global _baseClasses
if {![info exists _baseClasses($class)]} {
return {}
}
foreach base [set ancestors $_baseClasses($class)] {
foreach class [_ancestors $base] {
if {[lsearch -exact $ancestors $class]<0} {
lappend ancestors $class
}
}
}
return $ancestors
}
::proc _constructorDeclaration {class copy arguments args} {
global _baseClasses
set number [expr [llength $args]-1]
if {($number%2)!=0} {
error "bad $class constructor declaration, a base class, contructor arguments or body may be missing"
}
for {set index 0} {$index<$number} {incr index} {
set base [lindex $args $index]
if {!$copy} {
if {[info exists _baseClasses($class)]&&([lsearch -exact $_baseClasses($class) $base]>=0)} {
error "class $class directly inherits from class $base more than once"
}
lappend _baseClasses($class) $base
}
regsub -all \n [lindex $args [incr index]] {} constructorArguments($base)
}
set body [lindex $args $index]
if {[info exists _baseClasses($class)]} {
foreach base $_baseClasses($class) {
if {[string compare $class $base]==0} {
error "class $class cannot be derived from itself"
}
if {[catch {info body $base::$base}]} {
error "class $class constructor defined before base class $base constructor"
}
}
set constructorBody \
"
global [_ancestors $class] $class
"
if {[string compare [lindex $arguments end] args]==0} {
foreach base $_baseClasses($class) {
if {![info exists constructorArguments($base)]} {
error "missing base class $base constructor arguments from class $class constructor"
}
if {[string compare [lindex $constructorArguments($base) end] \$args]==0} {
append constructorBody \
"set ${base}(\$this,_derived) $class
eval $base::$base \$this {[lrange $constructorArguments($base) 0 [expr [llength $constructorArguments($base)]-2]]} \$args
"
} else {
append constructorBody \
"set ${base}(\$this,_derived) $class
$base::$base \$this $constructorArguments($base)
"
}
}
} else {
foreach base $_baseClasses($class) {
if {![info exists constructorArguments($base)]} {
error "missing base class $base constructor arguments from class $class constructor"
}
append constructorBody \
"set ${base}(\$this,_derived) $class
$base::$base \$this $constructorArguments($base)
"
}
}
} else {
set constructorBody \
"
global $class
"
}
if {$copy} {
append constructorBody \
"catch {set ${class}(\$this,_derived) \[set ${class}(\$[lindex $arguments 1],_derived)\]}
"
}
append constructorBody $body
if {$copy} {
::proc $class::_copy $arguments $constructorBody
} else {
::proc $class::$class $arguments $constructorBody
}
}
::proc _destructorDeclaration {class arguments body} {
global _baseClasses
set body \
"
global [_ancestors $class] $class
$body
"
if {[info exists _baseClasses($class)]} {
for {set index [expr [llength $_baseClasses($class)]-1]} {$index>=0} {incr index -1} {
set base [lindex $_baseClasses($class) $index]
append body \
"_delete $base \$this
"
}
}
::proc $class::~$class $arguments $body
}
::proc _memberProcedureDeclaration {class name arguments body} {
global _pureVirtual
if {[info exists _pureVirtual]} {
if {$_pureVirtual} {
::proc $class::$name $arguments \
"
global [_ancestors $class] $class
eval \$${class}(\$this,_derived)::$name \[lrange \[info level 0\] 1 end\]
"
} else {
::proc ::$class::$name $arguments \
"
global [_ancestors $class] $class
$body
"
::proc $class::$name $arguments \
"
global [_ancestors $class] $class
if {!\[catch {info body \$${class}(\$this,_derived)::$name}\]} {
return \[eval \$${class}(\$this,_derived)::$name \[lrange \[info level 0\] 1 end\]\]
}
eval ::\[info level 0\]
"
}
} else {
::proc $class::$name $arguments \
"
global [_ancestors $class] $class
$body
"
}
}
::proc _baseCloningCode {class siblingArgumentName} {
global _baseClasses
if {![info exists _baseClasses($class)]} {
return {}
}
foreach base $_baseClasses($class) {
append body \
"$base::_copy \$this \$$siblingArgumentName
"
}
return $body
}
::proc _generateDefaultCopyConstructor {class} {
set body [_baseCloningCode $class sibling]
append body \
"_copy $class \$sibling \$this
"
::proc $class::_copy {this sibling} $body
}
proc listbox_set {path position value} {
set size [$path size]
if {$position >= $size} {
$path insert end $value
} else {
set curvalue [$path get $position]
if {$curvalue != $value} {
if {$curvalue != ""} {
$path delete $position
}
$path insert $position $value
}
}
}
proc lallbut {list one} {
while {$list != ""} {
set ix [lsearch -exact $list $one]
if {$ix < 0} {
break
}
set list [lreplace $list $ix $ix]
}
return $list
}
proc Debug::init_statics {} {
global Debug
set Debug(level) debug
set Debug(classes) {}
set Debug(levels) {debug warning info error}
foreach level $Debug(levels) {
set Debug(debug_level,$level) 0
set Debug(always_debug_level,$level) 0
}
set Debug(always_debug_level,error) 1
set Debug(filename) ""
set Debug(handle) ""
}
proc Debug::init {class} {
global Debug
lappend Debug(classes) $class
set Debug(debug_class,$class) 0
}
proc Debug::debug_classes {args} {
global Debug
foreach class $Debug(classes) {
set Debug(debug_class,$class) 0
}
foreach class $args {
if {$class == "all"} {
foreach class $Debug(classes) {
set Debug(debug_class,$class) 1
}
return
}
if {![info exists Debug(debug_class,$class)]} {
puts "Debug::debug_classes: ERROR: Unknown class $class - please call Debug::init $class for class $class"
Debug::init $class
}
set Debug(debug_class,$class) 1
}
}
proc Debug::undebug_classes {args} {
global Debug
foreach class $Debug(classes) {
set Debug(debug_class,$class) 0
}
foreach class $args {
if {![info exists Debug(debug_class,$class)]} {
puts "Debug::undebug_classes: ERROR: Unknown class $class - please call Debug::init $class for class $class"
Debug::init $class
}
set Debug(debug_class,$class) 0
}
}
proc Debug::toggle_debug_class {class} {
global Debug
if {[info exists Debug(debug_class,$class)]} {
set Debug(debug_class,$class) [expr 1-$Debug(debug_class,$class)]
} else {
puts "Debug::toggle_class: ERROR: Unknown class $class - please call Debug::init $class for class $class"
Debug::init $class
set Debug(debug_class,$class) 1
}
}
proc Debug::set_levels {args} {
global Debug
foreach level $args {
if {$level == "all"} {
foreach level $Debug(levels) {
set Debug(debug_level,$level) 1
}
return
}
if {![info exists Debug(debug_level,$level)]} {
puts "Debug::set_levels: ERROR: Unknown debug level $level (ignoring)"
} else {
set Debug(debug_level,$level) 1
}
}
}
proc Debug::always_debug_levels {args} {
global Debug
foreach level $args {
if {$level == "all"} {
foreach level $Debug(levels) {
set Debug(always_debug_level,$level) 1
}
return
}
if {![info exists Debug(always_debug_level,$level)]} {
puts "Debug::set_levels: ERROR: Unknown debug level $level (ignoring)"
} else {
set Debug(always_debug_level,$level) 1
}
}
}
proc Debug::puts {class proc level message} {
global Debug
if {(!$Debug(debug_class,$class) || !$Debug(debug_level,$level)) &&
!$Debug(always_debug_level,$level)} {
return
}
if {$message != ""} {
set message ": $message"
}
switch $level {
debug {
set message "$proc$message"
}
error {
set message "$proc: ERROR$message"
}
warning {
set message "WARNING: $proc$message"
}
default {
set message "$proc\($level\)$message"
}
}
if {$Debug(handle) != ""} {
puts $Debug(handle) $message
} else {
puts stderr $message
}
}
proc Debug::start_log {filename} {
global Debug
set Debug(handle) [open $filename a+]
if {$Debug(handle) == ""} {
puts "Debug::start_log: Could not create debug log file $filename"
}
fconfigure $Debug(handle) -buffering line
set Debug(filename) $filename
}
proc Debug::end_log {} {
global Debug
if {$Debug(handle) != ""} {
close $Debug(handle)
set Debug(handle) ""
set Debug(filename) ""
}
}
proc Debug::get_classes {} {
global Debug
return $Debug(classes)
}
proc Debug::debugging_class {class} {
global Debug
if {![info exists Debug(debug_class,$class)]} {
return 0
}
return $Debug(debug_class,$class)
}
Debug::init_statics
proc delete_file {name} {
global tcl_platform
switch $tcl_platform(platform) {
unix {
exec rm $name
}
windows {
exec del $name
}
MacOS {
rm $name
}
}
}
proc rename_file {old_name new_name} {
global tcl_platform
switch $tcl_platform(platform) {
unix {
exec mv $old_name $new_name
}
windows {
exec rename $old_name $new_name
}
MacOS {
mv $old_name $new_name
}
}
}
proc File::backup_filename {file} {
global tcl_platform
switch $tcl_platform(platform) {
unix {
return "$file~"
}
windows -
MacOS {
return "$file.bak"
}
}
}
proc File::working_filename {file} {
global tcl_platform
switch $tcl_platform(platform) {
unix {
return "#$file#"
}
windows {
return "$file.tmp"
}
MacOS {
return "$file.temp"
}
}
}
proc File::begin_save {file} {
return [File::working_filename $file]
}
proc File::end_save {filename} {
set working_filename [File::working_filename $filename]
if {![file exists $working_filename] || [file size $working_filename] == 0} {
delete_file $working_filename
return 0
}
set backup_filename [File::backup_filename $filename]
if {[file exists $backup_filename]} {
delete_file $backup_filename
}
if {[file exists $filename]} {
rename_file $filename $backup_filename
}
rename_file $working_filename $filename
return 1
}
proc File::is_valid_suffix {filename suffix} {
set base [file extension [string tolower $filename]]
return [expr {$base == "" || $base == ".$suffix"}]
}
proc File::enforce_suffix {filename suffix} {
set base [file rootname [string tolower $filename]]
return "$base.$suffix"
}
proc Position::Position {this}  {
set Position($this,x) ""
set Position($this,y) ""
set Position($this,xsize) ""
set Position($this,ysize) ""
set Position($this,rotation) 0
set Position($this,flips) ""
}
proc Position::init_statics {} {
set Position(valid_flips) {"" x y xy}
set Position(valid_rotations) {0 90 180 270}
}
proc Position::~Position {this} {
unset Position($this,x) Position($this,y) Position($this,xsize) Position($this,ysize) Position($this,rotation) Position($this,flips)
}
proc Position::init {this x y xsize ysize}  {
set Position($this,x) $x
set Position($this,y) $y
set Position($this,xsize) $xsize
set Position($this,ysize) $ysize
Position::update $this
}
proc Position::update {this} {
set Position($this,center) [Position::normalised_to_screen $this 0.5 0.5]
set Position($this,last) [Position::normalised_to_screen $this 1.0 1.0]
}
proc Position::get_bbox {this} {
return [concat "$Position($this,x) $Position($this,y)" $Position($this,last)]
}
proc Position::get_center {this} {
return $Position($this,center)
}
proc Position::get_xy {this} {
return "$Position($this,x) $Position($this,y)"
}
proc Position::get_sizes {this} {
return "$Position($this,xsize) $Position($this,ysize)"
}
proc Position::normalised_to_screen {this args} {
set x0 $Position($this,x)
set y0 $Position($this,y)
set xsize $Position($this,xsize)
set ysize $Position($this,ysize)
set coords {}
foreach {x y} $args {
lappend coords [expr ($x * $xsize) + $x0] [expr ($y * $ysize) + $y0]
}
return $coords
}
proc Position::screen_to_normalised {this args} {
set x0 $Position($this,x)
set y0 $Position($this,y)
set xsize $Position($this,xsize)
set ysize $Position($this,ysize)
set coords {}
foreach {x y} $args {
lappend coords [expr ((0.0 + $x - $x0) / $xsize)] [expr ((0.0 + $y - $y0) / $ysize)]
}
return $coords
}
proc Position::move {this x y} {
set Position($this,x) [expr round($x)]
set Position($this,y) [expr round($y)]
Position::update $this
}
proc Position::resize {this xsize ysize} {
set Position($this,xsize) $xsize
set Position($this,ysize) $ysize
Position::update $this
}
proc Position::save_object {this saver} {
Saver::begin $saver Position
Saver::save_fields $saver Position $this x y xsize ysize rotation
Saver::end $saver Position
}
proc Position::load_cleanup {this parent_object parent_ref} {
Position::update $this
}
proc Position::loaded_cleanup {this parent_object parent_ref} {}
proc Position::rotate_normalised_coords {angle cx cy coords} { 
set angle [expr int(fmod($angle + 360, 360))]
if {$angle == 0 || $coords == ""} {
return $coords
}
set ncoords {}
foreach {x y} $coords {
set rx [expr $x - $cx]
set ry [expr $y - $cy]
switch $angle {
90 {
set nx -$ry
set ny $rx
}
180 {
set nx -$rx
set ny -$ry
}
270 {
set nx $ry
set ny -$rx
}
default {
}
}
lappend ncoords [expr $cx+$nx] [expr $cy+$ny]
}
return $ncoords
}
proc Position::flip_normalised_coords {axis point coords} { 
set ncoords {}
foreach {x y} $coords {
if {$axis == "x"} {
set x [expr 2 * $point - $x]
} else {
set y [expr 2 * $point - $y]
}
lappend ncoords $x $y
}
return $ncoords
}
Position::init_statics
proc Colour::init_statics {} {
global Colour
set Colour(fg) black
set Colour(bg) white
}
proc Colour::get_fg {} {
return $Colour(fg)
}
proc Colour::get_bg {} {
return $Colour(bg)
}
proc Colour::set_colours {what} {
switch $what {
bonw {
set Colour(fg) "black"
set Colour(bg) "white"
}
wonb {
set Colour(fg) "white"
set Colour(bg) "black"
}
}
}
Colour::init_statics
Debug::init Gfx
proc Gfx::Gfx {this canvas type name fill outline shape position args} {
Debug::puts Gfx Gfx::Gfx debug "Canvas=$canvas; type=$type; name=$name; fill=$fill outline=$outline shape=$shape; position=$position; tags=$args"
set Gfx($this,canvas) $canvas
set Gfx($this,ids) {}
set Gfx($this,hilight_ids) {}
if {$type=="polygon" && $fill=="" && $outline!=""} {
set type "line"
set fill $outline
set outline ""
set Gfx($this,polyfix) 1
} else {
set Gfx($this,polyfix) 0
}
set Gfx($this,type) $type
set Gfx($this,name) $name
if {$fill!=""} {
set fill "-fill $fill"
}
set Gfx($this,fill) $fill
if {$outline!=""} {
set outline "-outline $outline"
}
set Gfx($this,outline) $outline
set Gfx($this,width) ""
set Gfx($this,shape) $shape
set Gfx($this,position) $position
set Gfx($this,other_coords) ""
if {$args == ""} {
set Gfx($this,tags) {}
} else {
set Gfx($this,tags) $args
}
set Gfx($this,drawargs) ""
set Gfx($this,coords) ""
Gfx::update $this
}
proc Gfx::init_statics {} {
set Gfx(hilight_box_width) 6
}
proc Gfx::~Gfx {this} {
Gfx::unhilight $this
Gfx::undraw $this
unset Gfx($this,canvas) Gfx($this,ids) Gfx($this,hilight_ids) Gfx($this,polyfix) Gfx($this,type) Gfx($this,name) Gfx($this,fill) Gfx($this,outline) Gfx($this,width) Gfx($this,shape) Gfx($this,position) Gfx($this,other_coords) Gfx($this,tags) Gfx($this,drawargs) Gfx($this,coords)
}
virtual proc Gfx::draw {this} {
if {$Gfx($this,coords) != ""} {
set Gfx($this,ids) [eval $Gfx($this,canvas) create $Gfx($this,type) $Gfx($this,coords) $Gfx($this,fill) $Gfx($this,outline) $Gfx($this,width) $Gfx($this,drawargs) -tags [list $Gfx($this,tags)]]
}
}
proc Gfx::undraw {this} {
if {$Gfx($this,ids)!=""} {
eval $Gfx($this,canvas) delete $Gfx($this,ids)
set Gfx($this,ids) {}
}
}
virtual proc Gfx::get_drawcoords {this} {
if {$Gfx($this,other_coords)!=""} {
set Gfx($this,coords) $Gfx($this,other_coords)
return
}
if {$Gfx($this,position) == ""} {
return
}
if {$Gfx($this,shape) !=""} {
set realcoords $Gfx($this,shape)
if {$Gfx($this,polyfix)} {
eval lappend realcoords [lrange $realcoords 0 1]
}
set Gfx($this,coords) [eval Position::normalised_to_screen $Gfx($this,position) $realcoords]
} else {
set Gfx($this,coords) [Position::get_bbox $Gfx($this,position)]
}
}
proc Gfx::update {this} {
Gfx::get_drawcoords $this
Debug::puts Gfx Gfx::update debug "Draw coords= $Gfx($this,coords)"
if {$Gfx($this,ids)==""} {
return
}
eval $Gfx($this,canvas) coords $Gfx($this,ids) $Gfx($this,coords)
eval $Gfx($this,canvas) itemconfigure $Gfx($this,ids) $Gfx($this,fill) $Gfx($this,outline) $Gfx($this,width) $Gfx($this,drawargs)
Gfx::update_hilights $this
}
proc Gfx::set_width {this width} {
Debug::puts Gfx Gfx::set_width debug "Set width for Gfx $this (type $Gfx($this,type)) to $width"
set Gfx($this,width) "-width $width"
Gfx::update $this
}
proc Gfx::set_other_coords {this args} {
Debug::puts Gfx Gfx::set_other_coords debug "Set other coords for Gfx $this (type $Gfx($this,type)) to $args"
set Gfx($this,other_coords) $args
Gfx::update $this
}
proc Gfx::set_shape {this shape} {
Debug::puts Gfx Gfx::set_shape debug "Set shape for Gfx $this (type $Gfx($this,type)) to $shape"
set Gfx($this,shape) $shape
Gfx::update $this
}
virtual proc Gfx::get_center {this} {
if {$Gfx($this,position) ==""} {
Debug::puts Gfx Gfx::get_center error "Gfx $this (type $Gfx($this,type)) has no position"
return "0 0"
}
if {$Gfx($this,shape)!=""} {
set totalx 0.0
set totaly 0.0
set npoints 0
foreach {x y} $Gfx($this,shape) {
set totalx [expr $totalx + $x]
set totaly [expr $totaly + $y]
incr npoints
}
return [eval Position::normalised_to_screen $Gfx($this,position) [expr $totalx / $npoints] [expr $totaly / $npoints]]
} else {
return [Position::get_center $Gfx($this,position)]
}
}
virtual proc Gfx::get_hilight_coords {this} {
set bbox [$Gfx($this,canvas) bbox $Gfx($this,ids)]
set x1 [lindex $bbox 0]
set y1 [lindex $bbox 1]
set x2 [lindex $bbox 2]
set y2 [lindex $bbox 3]
return "$x1 $y1 $x2 $y1 $x2 $y2 $x1 $y2"
}
proc Gfx::hilight {this} {
if {$Gfx($this,hilight_ids)!=""} {
return 1
}
set w [expr $Gfx(hilight_box_width) / 2]
foreach {x y} [Gfx::get_hilight_coords $this] {
lappend Gfx($this,hilight_ids) [eval $Gfx($this,canvas) create rectangle [expr $x - $w] [expr $y - $w] [expr $x + $w] [expr $y + $w] -fill [Colour::get_fg] -tags hilight]
}
return 0
}
proc Gfx::unhilight {this} {
if {$Gfx($this,hilight_ids)==""} {
return 0
}
eval $Gfx($this,canvas) delete $Gfx($this,hilight_ids)
set Gfx($this,hilight_ids) {}
return 1
}
proc Gfx::update_hilights {this} {
if {$Gfx($this,hilight_ids)==""} {
return
}
set w [expr $Gfx(hilight_box_width) / 2]
set ix 0
foreach {x y} [Gfx::get_hilight_coords $this] {
set hilight_gfx [lindex $Gfx($this,hilight_ids) $ix]
$Gfx($this,canvas) coords $hilight_gfx [expr $x - $w] [expr $y - $w] [expr $x + $w] [expr $y + $w]
incr ix
}
}
Gfx::init_statics
Debug::init Square
proc Square::Square {this canvas fill outline shape position args} Gfx {
$canvas rectangle Square $fill $outline $shape $position $args
} {
}
proc Square::~Square {this} {}
Debug::init Circle
proc Circle::Circle {this canvas fill outline shape position args} Gfx {
$canvas oval Circle $fill $outline $shape $position $args
} {
}
proc Circle::~Circle {this} {}
Debug::init Polygon
proc Polygon::Polygon {this canvas fill outline shape position args} Gfx {
$canvas polygon Polygon $fill $outline $shape $position $args
} {
}
proc Polygon::~Polygon {this} {}
proc Polygon::get_hilight_coords {this} {
return $Gfx($this,coords)
}
Debug::init Plug
proc Plug::Plug {this canvas x y position args} Gfx {
$canvas oval Plug [Colour::get_bg] [Colour::get_fg] {} $position $args
} {
Gfx::set_width $this $Plug(borderwidth)
Gfx::set_other_coords $this $x $y
}
proc Plug::init_statics {} {
set Plug(diameter) 18
set Plug(borderwidth) 1
}
proc Plug::~Plug {this} {}
proc Plug::get_drawcoords {this} {
if {$Gfx($this,other_coords) != ""} {
set ccoords [eval Position::normalised_to_screen $Gfx($this,position) $Gfx($this,other_coords)]
set x [lindex $ccoords 0]
set y [lindex $ccoords 1]
Debug::puts Plug Plug::get_drawcoords debug "Center coords are ($x,$y)"
set Gfx($this,coords) [list [expr $x - $Plug(diameter)/2] [expr $y - $Plug(diameter)/2] [expr $x + $Plug(diameter)/2] [expr $y + $Plug(diameter)/2]]
Debug::puts Plug Plug::get_drawcoords debug "Final coords are $Gfx($this,coords)"
}
}
Plug::init_statics
Debug::init AbsArrow
proc AbsArrow::AbsArrow {this canvas coords args} Gfx {
$canvas line AbsArrow [Colour::get_fg] "" "" "" $args
} {
Gfx::set_width $this $AbsArrow(width)
eval Gfx::set_other_coords $this $coords
AbsArrow::set_head $this last
}
proc AbsArrow::init_statics {} {
set AbsArrow(width) 2
}
proc AbsArrow::~AbsArrow {this} {}
proc AbsArrow::set_head {this head} {
set Gfx($this,drawargs) "-arrow $head"
if {$Gfx($this,ids)!=""} {
eval $Gfx($this,canvas) itemconfigure $Gfx($this,ids) $Gfx($this,drawargs)
}
}
proc AbsArrow::get_hilight_coords {this} {
return $Gfx($this,other_coords)
}
AbsArrow::init_statics
Debug::init RelArrow
proc RelArrow::RelArrow {this canvas shape position args} Gfx {
$canvas line Arrow [Colour::get_fg] "" $shape $position $args
} {
RelArrow::set_head $this last
}
proc RelArrow::~Arrow {this} {}
proc RelArrow::set_head {this head} {
set Gfx($this,drawargs) "-arrow $head"
if {$Gfx($this,ids)!=""} {
eval $Gfx($this,canvas) itemconfigure $Gfx($this,ids) $Gfx($this,drawargs)
}
}
Debug::init Text
proc Text::Text {this canvas x y text anchor args} Gfx {
$canvas text Text [Colour::get_fg] {} {} {} $args
} {
set Text($this,anchor) $anchor
Gfx::set_other_coords $this $x $y
set Text($this,text) ""
Text::set_text $this $text
Gfx::update $this
}
proc Text::~Text {this} {
unset Text($this,anchor) Text($this,text)
}
proc Text::set_text {this text} {
Debug::puts Text Text::set_text debug "Gfx $this text=$text"
if {$text != $Text($this,text)} {
set Text($this,text) $text
set Gfx($this,drawargs) "-text [list $text] -anchor $Text($this,anchor)"
if {$Gfx($this,ids)!=""} {
$Gfx($this,canvas) itemconfigure $Gfx($this,ids) -text $text
}
}
}
proc Text::set_anchor {this anchor} {
if {$anchor != $Text($this,anchor)} {
set Text($this,anchor) $anchor
set Gfx($this,drawargs) "-text [list $Text($this,text)] -anchor $anchor"
if {$Gfx($this,ids)!=""} {
$Gfx($this,canvas) itemconfigure $Gfx($this,ids) -anchor $anchor
}
}
}
global DialogId
set DialogId 0
proc newDialogPath {} {
global DialogId
set id .dialog$DialogId
incr DialogId
return $id
}
proc OKDialog {title text} {
tk_dialog [newDialogPath] $title $text "" 0 OK
update idletasks
}
proc OKCancelDialog {title text} {
set result [tk_dialog [newDialogPath] $title $text "" 0 OK Cancel]
update idletasks
return [expr !$result]
}
proc YesNoCancelDialog {title text} {
set result [tk_dialog [newDialogPath] $title $text "" 2 Yes No Cancel]
update idletasks
return $result
}
proc tk_namedialog {w title prompt varName default args} {
global tk_ndPriv
catch {destroy $w}
toplevel $w -class Dialog
wm title $w $title
wm iconname $w Dialog
wm protocol $w WM_DELETE_WINDOW { }
wm transient $w [winfo toplevel [winfo parent $w]]
frame $w.bot -relief raised -bd 1
pack $w.bot -side bottom -fill both
frame $w.top -relief raised -bd 1
pack $w.top -side top -fill both -expand 1
label $w.prompt -justify left -text $prompt
upvar $varName var
if ![info exists var] {
set tk_ndPriv(var) ""
} else {
set tk_ndPriv(var) $var
}
entry $w.entry -width 20 -relief sunken -bd 2 -textvariable tk_ndPriv(var)
pack $w.prompt $w.entry -in $w.top -side left -padx 1m -pady 2m
bind $w.entry <KeyPress-Return> "set tk_ndPriv(button) $default"
set i 0
foreach but $args {
button $w.button$i -text $but -command "set tk_ndPriv(button) $i"
if {$i == $default} {
frame $w.default -relief sunken -bd 1
raise $w.button$i $w.default
pack $w.default -in $w.bot -side left -expand 1 -padx 3m -pady 2m
pack $w.button$i -in $w.default -padx 2m -pady 2m
} else {
pack $w.button$i -in $w.bot -side left -expand 1 \
-padx 3m -pady 2m
}
incr i
}
wm withdraw $w
update idletasks
set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
- [winfo vrootx [winfo parent $w]]]
set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
- [winfo vrooty [winfo parent $w]]]
wm geom $w +$x+$y
wm deiconify $w
set oldFocus [focus]
if {$default >= 0} {
focus $w.button$default
} else {
focus $w
}
tkwait variable tk_ndPriv(button)
catch {focus $oldFocus}
destroy $w
set var $tk_ndPriv(var)
update idletasks
return $tk_ndPriv(button)
}
proc NameDialog {title prompt default} {
set v $default
set result [tk_namedialog [newDialogPath] $title $prompt v 0 OK Cancel]
if {$result==1} {
return ""
} else {
return $v
}
}
proc tk_textdialog {w title text width height default args} {
global tk_tdPriv
catch {destroy $w}
toplevel $w -class Dialog
wm title $w $title
wm iconname $w Dialog
wm protocol $w WM_DELETE_WINDOW { }
wm transient $w [winfo toplevel [winfo parent $w]]
frame $w.bot -relief raised -bd 1
pack $w.bot -side bottom -fill both
frame $w.top -relief raised -bd 1
pack $w.top -side top -fill both -expand 1
text $w.text -relief raised -bd 2 -yscrollcommand "$w.yscroll set"\
-width $width -height $height -wrap char
scrollbar $w.yscroll -command "$w.text yview"
pack $w.yscroll -side right -fill y -in $w.top
pack $w.text -side left -fill both -expand 1 -in $w.top
$w.text insert end $text
bind $w.text <KeyPress-Return> "set tk_tdPriv(button) $default"
set i 0
foreach but $args {
button $w.button$i -text $but -command "set tk_tdPriv(button) $i"
if {$i == $default} {
frame $w.default -relief sunken -bd 1
raise $w.button$i $w.default
pack $w.default -in $w.bot -side left -expand 1 -padx 3m -pady 2m
pack $w.button$i -in $w.default -padx 2m -pady 2m
} else {
pack $w.button$i -in $w.bot -side left -expand 1 \
-padx 3m -pady 2m
}
incr i
}
wm withdraw $w
update idletasks
set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
- [winfo vrootx [winfo parent $w]]]
set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
- [winfo vrooty [winfo parent $w]]]
wm geom $w +$x+$y
wm deiconify $w
set oldFocus [focus]
if {$default >= 0} {
focus $w.button$default
} else {
focus $w
}
tkwait variable tk_tdPriv(button)
catch {focus $oldFocus}
destroy $w
update idletasks
return $tk_tdPriv(button)
}
proc OKTextDialog {title text width height} {
tk_textdialog [newDialogPath] $title $text $width $height 0 OK
}
proc OKCancelTextDialog {title text width height} {
set result [tk_textdialog [newDialogPath] $title $text $width $height 0 OK Cancel]
return [expr $result == 0]
}
proc Options::init_statics {} {
global Options
set Options(list) {}
}
proc Options::init_option {name label init_value} {
global Options
set Options(option_store,$name) $init_value
set Options(option_label,$name) $label
lappend Options(list) $name
}
proc Options::set {option_name value} {
global Options
set Options(option_store,$option_name) $value
}
proc Options::get {option_name} {
global Options
return $Options(option_store,$option_name)
}
proc Options::get_options {} {
set result {}
foreach option $Options(list) {
lappend result Options(option_store,$option) $Options(option_label,$option)
}
return $result
}
Options::init_statics
Debug::init Window
proc Window::Window {this place name title parent} {
Debug::puts Window Window::Window debug "Place:$place Name:$name Title:$title Parent:$parent"
set Window($this,place) $place
if {$place == "."} {
set where ""
} else {
set where $place
}
set Window($this,where) $where
set Window($this,name)  $name
set Window($this,title) $title
set Window($this,parent) $parent
set Window($this,iconname) $title
set Window($this,message) ""
lappend Window(names) $name
lappend Window(refs) $this
set Window($this,state) 0
}
proc Window::~Window {this} {}
proc Window::get_place {this} {
return $Window($this,place)
}
proc Window::get_where {this} {
return $Window($this,where)
}
proc Window::get_name {this} {
return $Window($this,name)
}
proc Window::get_state {this} {
return $Window($this,state)
}
proc Window::set_title {this title} {
set Window($this,title) $title
Window::update_title $this
}
proc Window::set_iconname {this iconname} {
set Window($this,iconname) $iconname
Window::update_iconname $this
}
proc Window::update_title {this} {
if {$Window($this,state)} {
wm title $Window($this,place) $Window($this,title)
}
}
proc Window::update_iconname {this} {
if {$Window($this,state)} {
wm iconname $Window($this,place) $Window($this,iconname)
}
}
proc Window::show {this} {
Debug::puts Window Window::show debug ""
if {!$Window($this,state)} {
set Window($this,state) 1
set place $Window($this,place)
if {$place != "."} {
Debug::puts Window Window::show debug "Creating window $place"
toplevel $place
}
Window::update_title $this
Window::draw $this
}
}
virtual proc Window::draw {this} {}
proc Window::hide {this} {
Debug::puts Window Window::hide debug ""
if {$Window($this,state)} {
set Window($this,state) 0
Window::undraw $this
set place $Window($this,place)
if {$place != "."} {
destroy $place
}
}
}
virtual proc Window::undraw {this} {}
proc Window::toggle {this} {
Window::set_state $this [expr ! $Window($this,state)]
}
proc Window::set_state {this newstate} {
Debug::puts Window Window::set_state debug "State $newstate"
if {$newstate == 1} {
Window::show $this
} else {
Window::hide $this
}
}
proc Window::message {this message} {
if {$message != $Window($this,message)} {
set Window($this,message) $message
}
}
proc Window::get_window {name} {
set index [lsearch -exact $Window(names) $name]
if {$index < 0} {
error "Window::get_window: Window name '$name' is not registered"
}
return [lindex $Window(refs) $index]
}
proc Window::togglewindow {name} {
set index [lsearch -exact $Window(names) $name]
if {$index < 0} {
error "Window::toggle: Window name '$name' is not registered"
}
Window::toggle [lindex $Window(refs) $index]
}
virtual proc Window::button1up {this x y type typeref subtype subtyperef subsubtyperef args} {
Debug::puts Window Window::button1up debug "@$x,$y subtype=$subtype ($subtyperef,$subsubtyperef) $type ($typeref) tags=$args"
}
virtual proc Window::button1down {this x y shift type typeref subtype subtyperef subsubtyperef args} {
Debug::puts Window Window::button1down debug "@$x,$y shift=$shift subtype=$subtype ($subtyperef,$subsubtyperef) $type ($typeref) tags=$args"
}
virtual proc Window::doublebutton1 {this x y type typeref subtype subtyperef subsubtyperef args} {
Debug::puts Window Window::doublebutton1 debug "@$x,$y subtype=$subtype ($subtyperef,$subsubtyperef) $type ($typeref) tags=$args"
}
virtual proc Window::button2up {this x y type typeref subtype subtyperef subsubtyperef args} {
Debug::puts Window Window::button2up debug "@$x,$y subtype=$subtype ($subtyperef,$subsubtyperef) $type ($typeref) tags=$args"
}
virtual proc Window::button2down {this x y type typeref subtype subtyperef subsubtyperef args} {
Debug::puts Window Window::button2down debug "@$x,$y subtype=$subtype ($subtyperef,$subsubtyperef) $type ($typeref) tags=$args"
}
virtual proc Window::click {this x y} {
Debug::puts Window Window::click debug "@$x,$y"
}
virtual proc Window::move_to {this x y args} {
Debug::puts Window Window::move_to debug "@$x,$y (args=$args)"
}
virtual proc Window::moved {this x y args} {
Debug::puts Window Window::moved debug "@$x,$y (args=$args)"
}
virtual proc Window::resized {this xsize ysize args} {
Debug::puts Window Window::resized debug "Size $xsize x $ysize (args=$args)"
}
virtual proc Window::placed {this x y xsize ysize ref args} {
Debug::puts Window Window::placed debug "@$x,$y size $xsize x $ysize; reference $ref; (args=$args)"
}
virtual proc Window::connect_to {this type typeref start_subtype start_subtyperef start_subsubtyperef end_subtype end_subtyperef end_subsubtyperef coords} {
Debug::puts Window Window::connect_to debug "Type $type ($typeref) From subtype $start_subtype ($start_subtyperef,$start_subsubtyperef) To subtype $end_subtype ($end_subtyperef,$end_subsubtyperef) with middle coords $coords"
}
Debug::init Select
proc Select::Select {this} {
set Select(curelements) {}
set Select(number_elements) 0
}
proc Select::~Select {this} {}
proc Select::set {type typeref subtype subtyperef subsubtyperef args} {
Debug::puts Select Select::set debug "$type ($typeref) subtype $subtype ($subtyperef,$subsubtyperef) (more tags=$args)"
if {$Select(number_elements)==1} {
if {[Select::is_selected $type $typeref $subtype $subtyperef $subsubtyperef]} {
Debug::puts Select Select::set debug "$type $typeref $subtype $subtyperef $subsubtyperef is already selected"
return
}
}
Select::clear
Select::append 0 $type $typeref $subtype $subtyperef $subsubtyperef
}
proc Select::is_selected {type typeref subtype subtyperef subsubtyperef} {
foreach {thistype thistyperef thissubtype thissubtyperef thissubsubtyperef} $Select(curelements) {
if {$thistype==$type && $thistyperef==$typeref && 
$thissubtype==$subtype && $thissubtyperef==$subtyperef &&
$thissubsubtyperef==$subtyperef} {
return 1
}
}
return 0
}
proc Select::append {toggle type typeref subtype subtyperef subsubtyperef args} {
Debug::puts Select Select::append debug "Toggle?=$toggle $type ($typeref) subtype $subtype ($subtyperef,$subsubtyperef) (more tags=$args)"
if {$typeref == ""} {
return
}
if {[Select::is_selected $type $typeref $subtype $subtyperef $subsubtyperef]} {
if {$toggle} {
Select::remove $type $typeref $subtype $subtyperef $subsubtyperef
}
return
}
Instance::hilight_part $typeref $subtype $subtyperef $subsubtyperef
lappend Select(curelements) $type $typeref $subtype $subtyperef $subsubtyperef
incr Select(number_elements)
AttributesWindow::set_attributes
}
proc Select::remove {type typeref subtype subtyperef subsubtyperef args} {
Debug::puts Select Select::remove debug "$type ($typeref) subtype $subtype ($subtyperef,$subsubtyperef) (more tags=$args)"
set newelements {}
set removed 0
foreach {thistype thistyperef thissubtype thissubtyperef thissubsubtyperef} $Select(curelements) {
if {$thistype==$type && $thistyperef==$typeref && 
$thissubtype==$subtype && $thissubtyperef==$subtyperef &&
$thissubsubtyperef==$subsubtyperef} {
Instance::unhilight_part $thistyperef $thissubtype $thissubtyperef $thissubsubtyperef
set removed 1
} else {
lappend newelements $thistype $thistyperef $thissubtype $thissubtyperef $thissubsubtyperef
}
}
if {!$removed} {
Debug::puts Select Select::remove warning "Could not remove $type ($typeref) subtype $subtype ($subtyperef,$subsubtyperef) - not selected"
} else {
incr Select(number_elements) -1
set Select(curelements) $newelements
AttributesWindow::set_attributes
}
}
proc Select::clear {} {
if {$Select(number_elements)>0} {
Debug::puts Select Select::clear debug ""
Select::unhilight
AttributesWindow::set_attributes
}
}
proc Select::unhilight {} {
if {$Select(number_elements)>0} {
Debug::puts Select Select::unhilight debug ""
foreach {type typeref subtype subtyperef subsubtyperef} $Select(curelements) {
Instance::unhilight_part $typeref $subtype $subtyperef $subsubtyperef
}
set Select(curelements) {}
set Select(number_elements) 0
}
}
proc Select::get_cur_elements {} {
return $Select(curelements)
}
proc Select::get_last_element {} {
if {$Select(number_elements) == 0} {
return ""
}
return [lrange $Select(curelements) [expr ($Select(number_elements)-1)*5] end]
}
proc Select::something_is_selected {} {
return [expr $Select(number_elements) > 0]
}
Debug::init NetworkWindow
proc NetworkWindow::NetworkWindow {this where parent state} Window {
$where "Network" "ODT Network Editor" $parent
} {
set NetworkWindow($this,canvas_path) ""
set NetworkWindow($this,cur_instance) ""
set NetworkWindow($this,cur_interface) ""
set NetworkWindow($this,cur_implementation) ""
set NetworkWindow($this,label) ""
set NetworkWindow($this,show) $NetworkWindow(defaultshow)
foreach showvar $NetworkWindow(defaultshow) {
set NetworkWindow($this,show,$showvar) 1
}
Window::set_state $this $state
}
proc NetworkWindow::init_statics {} {
set NetworkWindow(minimum_network_box_size) 50
set NetworkWindow(minimum_node_box_size) 20
set NetworkWindow(default_network_box_xposition) 75
set NetworkWindow(default_network_box_yposition) 75
set NetworkWindow(interface_x_space) 50
set NetworkWindow(interface_y_space) 50
set NetworkWindow(showthings) {
comm/variable      {External Comms Names}  0
node/main/name     {Node Names}            5
node/comm/variable {Node Comms Names}     12
node/comm/arrow    {Node Arrows}           5
}
set NetworkWindow(defaultshow) {node/main/body node/main/border node/main/name main/border comm/plug comm/arrow comm/variable node/comm/plug node/comm/arrow node/comm/variable arc/arrow}
}
proc NetworkWindow::~NetworkWindow {this} {
unset NetworkWindow($this,canvas_path) NetworkWindow($this,cur_instance) NetworkWindow($this,cur_interface) NetworkWindow($this,cur_implementation) NetworkWindow($this,label) NetworkWindow($this,show)
}
proc NetworkWindow::draw {this} {
set where $Window($this,where)
NetworkWindow::init_menubar $this $where.mbar
frame $where.message -bd 1
label $where.message.value -textvariable Window($this,message)
pack $where.message.value -side left
label $where.impl_label -anchor w -textvariable NetworkWindow($this,label) -relief raised -bd 1
set NetworkWindow($this,canvas_path) ${where}.canvas
canvas $NetworkWindow($this,canvas_path) -width 16c -height 9c -bd 2 -yscrollcommand "$where.yscroll set" -xscrollcommand "$where.xscroll set" -confine 1
scrollbar $where.yscroll -command "$where.canvas yview"
scrollbar $where.xscroll -orient horizontal -command "$where.canvas xview"
pack $where.mbar -side top -fill x
pack $where.message -side top -fill x
pack $where.impl_label -side top -fill x
pack $where.yscroll -side right -fill y
pack $where.xscroll -side bottom -fill x
pack $NetworkWindow($this,canvas_path) -side left -fill both -expand 1
Project::canvas_bindings $Window($this,parent) NetworkWindow $this $NetworkWindow($this,canvas_path)
NetworkWindow::draw_cur_implementation $this
}
proc NetworkWindow::undraw {this} {
NetworkWindow::undraw_cur_implementation $this
}
proc NetworkWindow::init_menubar {this where} {
frame $where -relief raised -bd 2
set place $Window($this,place)
set m $where.window
menubutton $m -text "Window" -menu $where.window.menu -underline 0
menu $m.menu -tearoff 0
$m.menu add command -label "Close" -underline 0 -command [list Window::hide $this]
bind all <Control-q> [list ProjectWindow::MenuProjectQuit $this]
set m $where.edit
menubutton $m -text "Edit" -menu $m.menu -underline 0
menu $m.menu -tearoff 0
$m.menu add command -label "New Component" -underline 0 -command [list NetworkWindow::MenuEditNew $this]
$m.menu add command -label "Copy" -underline 0 -command [list NetworkWindow::MenuEditCopy $this]
$m.menu add command -label "Delete" -underline 0 -command [list NetworkWindow::MenuEditDelete $this]
$m.menu add command -label "Rotate" -underline 0 -command [list NetworkWindow::MenuEditShape $this rotate_node 0 90]
$m.menu add command -label "Square (x)" -underline 8 -command [list NetworkWindow::MenuEditShape $this make_square_node 0 x]
$m.menu add command -label "Square (y)" -underline 8 -command [list NetworkWindow::MenuEditShape $this make_square_node 0 y]
$m.menu add command -label "Same Size" -underline 7 -command [list NetworkWindow::MenuEditShape $this make_same_size 1 {}]
$m.menu add command -label "Refresh" -command [list NetworkWindow::MenuEditRefresh $this]
set m $where.show
menubutton $m -text "Show" -menu $m.menu -underline 0
menu $m.menu -tearoff 0
foreach {part label underline} $NetworkWindow(showthings) {
$m.menu add checkbutton -label $label -underline $underline -command [list NetworkWindow::MenuShow $this $part] -variable NetworkWindow($this,show,$part) -onvalue 1 -offvalue 0 -selectcolor [Colour::get_fg]
}
set m $where.output
menubutton $m -text "Output" -menu $m.menu -underline 0
menu $m.menu -tearoff 0
$m.menu add command -label "File..." -underline 0 -command [list NetworkWindow::MenuOutput $this File]
$m.menu add command -label "Print" -underline 0 -command [list NetworkWindow::MenuOutput $this Print]
$m.menu add command -label "Show" -underline 0 -command [list NetworkWindow::MenuOutput $this Show]
menubutton $where.help -text "Help" -underline 0
pack $where.window $where.edit $where.show $where.output -side left
pack $where.help -side right
}
proc NetworkWindow::MenuEditNew {this} {
set elements [Select::get_last_element]
if {$elements == ""} {
OKDialog "Error in adding component" "Nothing selected - cannot add new component"
return
}
set type [lindex $elements 0]
set instance [lindex $elements 1]
set part [lindex $elements 2]
if {[string match {node/*} $part]} {
set node [lindex $elements 3]
set interface [Node::get_interface $node]
set implementation [Node::get_implementation $node]
set position [Node::get_position $node]
} else {
set interface [Instance::get_interface $instance]
set implementation [Instance::get_implementation $instance]
set position [Interface::get_position $interface]
if {$interface == $NetworkWindow($this,cur_interface)} {
OKDialog "Error in adding component" "Cannot make a new component from\nthis Implementation"
return
}
if {$implementation == ""} {
OKDialog "Error in adding component" "Cannot make a component from an Interface\nPlease pick an Implementation"
return
}
if {![Interface::is_validated $interface]} {
OKDialog "Error in adding component" "Cannot make a component from $label\nillegal paradigm"
return
}
}
set label [Interface::get_pretty_label $interface $implementation 1]
Window::message $this "Making new node from $label"
Project::set_mode2 $Window($this,parent) Placing $NetworkWindow($this,canvas_path) 0 0 0 0 $position $implementation NetworkInstance $NetworkWindow($this,cur_instance) node/main/body {} {}
}
proc NetworkWindow::MenuEditCopy {this} {
Debug::puts NetworkWindow NetworkWindow::MenuEditCopy info ""
set elements [Select::get_last_element]
if {$elements == ""} {
OKDialog "Error in copying" "Nothing selected - cannot copy"
return
}
set type [lindex $elements 0]
set instance [lindex $elements 1]
set part [lindex $elements 2]
if {[string match {node/*} $part]} {
set node [lindex $elements 3]
set interface [Node::get_interface $node]
set implementation [Node::get_implementation $node]
set position [Node::get_position $node]
} else {
set interface [Instance::get_interface $instance]
set implementation [Instance::get_implementation $instance]
set position [Interface::get_position $interface]
if {$interface == $NetworkWindow($this,cur_interface)} {
OKDialog "Error in copying" "Cannot copy this Implementation\nto make a new component"
return
}
if {$implementation == ""} {
OKDialog "Error in copying" "Cannot copy an Interface as a component\nPlease pick an Implementation"
return
}
if {![Interface::is_validated $interface]} {
OKDialog "Error in copying" "Cannot copy an $label\nillegal paradigm"
return
}
}
set label [Interface::get_pretty_label $interface $implementation 1]
Window::message $this "Copying component $label"
Project::set_mode2 $Window($this,parent) Placing $NetworkWindow($this,canvas_path) 0 0 0 0 $position $implementation NetworkInstance $NetworkWindow($this,cur_instance) node/main/body {} {}
}
proc NetworkWindow::MenuEditDelete {this} {
if {![Select::something_is_selected]} {
Window::message $this "Cannot delete - nothing selected"
return
}
set arcs {}
set nodes {}
foreach {type typeref subtype subtyperef subsubtyperef} [Select::get_cur_elements] {
Debug::puts InterfaceWindow InterfaceWindow::MenuEditDelete debug "Unselecting type=$type ($typeref) subtype=$subtype ($subtyperef,$subsubtyperef)"
if {$type != "NetworkInstance"} {
continue
}
switch $subtype {
arc/arrow {
if {[lsearch -exact $arcs $subtyperef] <0} {
lappend arcs $subtyperef
}
}
node/main/body -
node/main/border -
node/main/name {
if {[lsearch -exact $nodes $subtyperef] <0} {
lappend nodes $subtyperef
foreach arc [Implementation::get_arcs_for_node $NetworkWindow($this,cur_implementation) $subtyperef] {
if {[lsearch -exact $arcs $arc] <0} {
lappend arcs $arc
}
}
}
}
default {
Debug::puts NetworkWindow NetworkWindow::MenuEditDelete warning "Ignoring delete on $subtype"
}
}
}
Select::clear
foreach arc $arcs {
Debug::puts NetworkWindow NetworkWindow::MenuEditDelete debug "Deleting arc $arc"
NetworkInstance::delete_arc $NetworkWindow($this,cur_instance) $arc 0
}
foreach node $nodes {
Debug::puts NetworkWindow NetworkWindow::MenuEditDelete debug "Deleting node $node"
NetworkInstance::delete_node $NetworkWindow($this,cur_instance) $node 0
}
Instance::update $NetworkWindow($this,cur_instance)
NetworkWindow::update_canvas_scrollregion $this
}
proc NetworkWindow::MenuEditShape {this operation select_all arg} {
Debug::puts NetworkWindow NetworkWindow::MenuEditShape debug "$operation $arg; select all=$select_all"
if {![Select::something_is_selected]} {
Window::message $this "Cannot change shape - nothing selected"
return
}
set change_body 0
set nodes {}
foreach {type typeref subtype subtyperef subsubtyperef} [Select::get_cur_elements] {
if {$type != "NetworkInstance"} {
continue
}
switch $subtype {
node/main/border -
node/main/name -
node/main/body {
lappend nodes $subtyperef
set change_body 1
}
default {
Debug::puts NetworkWindow NetworkWindow::MenuEditShape warning "Ignoring $operation $arg on $subtype ($subtyperef,subsubtyperef)"
}
}
}
if {$change_body} {
if {$select_all} {
NetworkInstance::$operation $typeref $arg $nodes
} else {
Select::set $type $typeref node/main/body $subtyperef $subsubtyperef
NetworkInstance::$operation $typeref $subtyperef $arg
}
}    
}
proc NetworkWindow::MenuEditProperties {this} {
Debug::puts NetworkWindow NetworkWindow::MenuEditProperties info ""
}
proc NetworkWindow::MenuEditRefresh {this} {
Debug::puts NetworkWindow NetworkWindow::MenuEditRefresh info ""
NetworkInstance::refresh $NetworkWindow($this,cur_instance)
}
proc NetworkWindow::MenuShow {this what} {
set value $NetworkWindow($this,show,$what)
Debug::puts NetworkWindow NetworkWindow::MenuShow debug "What=$what value=$value"
set newshow {}
foreach showvar $NetworkWindow(defaultshow) {
if {$NetworkWindow($this,show,$showvar)} {
lappend newshow $showvar
}
}
set NetworkWindow($this,show) $newshow
Instance::set_show $NetworkWindow($this,cur_instance) $newshow
}
proc NetworkWindow::MenuOutput {this type} {
Debug::puts NetworkWindow NetworkWindow::MenuOutput debug "$type"
if {$NetworkWindow($this,cur_instance) == ""} {
return
}
set label [Interface::get_pretty_label $NetworkWindow($this,cur_interface) $NetworkWindow($this,cur_implementation) 0]
set project_name [Project::get_name $Window($this,parent)]
switch $type {
File {
set name [NameDialog "Output Implementation" "Output File Name" ""]
if {$name == ""} {
return
}
if {[file exists $name] && [file readable $name]} {
if {[OKDialog "Output Implementation" "There is an existing file $name\nDo you want to overwrite it?"] == 1} {
return
}
}
set working_filename [File::begin_save $name]
set fd [open $working_filename w]
puts -nonewline $fd [Implementation::get_printed_body $NetworkWindow($this,cur_implementation) "$label ($project_name)" 0]
close $fd
File::end_save $name
}
Show {
set text [Implementation::get_printed_body $NetworkWindow($this,cur_implementation) "$label ($project_name)" 1]
OKTextDialog "Output $label" $text 80 25
}
Print {
OKDialog "Not Implemented" "Output operation $type not implemented"
return
}
}
}
proc NetworkWindow::update_instance_label {this} {
if {$NetworkWindow($this,cur_instance) == ""} {
set label ""
} else {
set label [Interface::get_pretty_label $NetworkWindow($this,cur_interface) $NetworkWindow($this,cur_implementation) 0]
}
set NetworkWindow($this,label) $label
}
proc NetworkWindow::pick_interface {this interface implementation} {
if {![Interface::is_validated $interface]} {
set name [Interface::get_name $interface]
OKDialog "Error in editing network" "Cannot edit network\nINTERFACE $name is not valid"
return
}
if {$implementation !=""} {
set impl_type [Implementation::get_type $implementation]
Debug::puts NetworkWindow NetworkWindow::pick_interface debug "Seen Interface $interface, implementation $implementation ($impl_type)"
if {$impl_type == "Network"} {
NetworkWindow::set_cur_implementation $this $interface $implementation
Window::show $this
return
}
}
return
}
proc NetworkWindow::set_cur_implementation {this interface implementation} {
Debug::puts NetworkWindow NetworkWindow::set_cur_implementation debug "Interface=$interface Implementation=$implementation"
if {$NetworkWindow($this,cur_instance) != ""} {
if {$NetworkWindow($this,cur_implementation) != $implementation} {
NetworkWindow::undraw_cur_implementation $this
} else {
return
}
}
set NetworkWindow($this,cur_interface) $interface
set NetworkWindow($this,cur_implementation) $implementation
if {![Window::get_state $this]} {
return
}
if {$interface == "" || $implementation == ""} {
NetworkWindow::update_instance_label $this
return
}
Debug::puts NetworkWindow NetworkWindow::set_cur_implementation debug "Creating new NetworkInstance"
set network_box_position [Implementation::get_network_box_position $implementation]
if {$network_box_position == ""} {
update idletasks
set w_width [winfo width $NetworkWindow($this,canvas_path)]
set w_height [winfo height $NetworkWindow($this,canvas_path)]
set width [expr $w_width - $NetworkWindow(interface_x_space) *2]
set height [expr $w_height - $NetworkWindow(interface_y_space) * 2]
Debug::puts NetworkWindow NetworkWindow::set_cur_implementation debug "Creating new Position at $xpos,$ypos $width,$height"
set network_box_position [new Position]
Position::init $network_box_position 0 0 $width $height
Implementation::set_network_box_position $implementation $network_box_position
}
set NetworkWindow($this,cur_instance) [new NetworkInstance $interface $implementation $NetworkWindow($this,canvas_path)]
Instance::set_show $NetworkWindow($this,cur_instance) $NetworkWindow($this,show)
NetworkWindow::update_instance_label $this
NetworkWindow::update_canvas_scrollregion $this
$NetworkWindow($this,canvas_path) xview moveto 0
$NetworkWindow($this,canvas_path) yview moveto 0
}
proc NetworkWindow::undraw_cur_implementation {this} {
Debug::puts NetworkWindow NetworkWindow::undraw_cur_implementation debug ""
if {$NetworkWindow($this,cur_instance) != ""} {
Debug::puts NetworkWindow NetworkWindow::undraw_cur_implementation debug "Deleting old NetworkInstance"
Select::clear
Instance::undraw $NetworkWindow($this,cur_instance)
delete $NetworkWindow($this,cur_instance)
set NetworkWindow($this,cur_instance) ""
}
}
proc NetworkWindow::draw_cur_implementation {this} {
Debug::puts NetworkWindow NetworkWindow::draw_cur_implementation debug ""
if {$NetworkWindow($this,cur_implementation) == ""} {
return
}
NetworkWindow::set_cur_implementation $this $NetworkWindow($this,cur_interface) $NetworkWindow($this,cur_implementation)
Instance::set_show $NetworkWindow($this,cur_instance) $NetworkWindow($this,show)
}
proc NetworkWindow::doublebutton1 {this x y type typeref subtype subtyperef subsubtyperef args} {
Debug::puts NetworkWindow NetworkWindow::doublebutton1 debug "@$x,$y subtype=$subtype ($subtyperef,$subsubtyperef) $type ($typeref) tags=$args"
switch $subtype {
node/main/body -
node/main/name {
Project::pick_interface $Window($this,parent) [Node::get_interface $subtyperef] [Node::get_implementation $subtyperef] 1
}
node/comm/plug -
node/comm/variable -
node/comm/arrow {
set arc [NetworkInstance::get_arc_by_node_comm $typeref $subtyperef $subsubtyperef]
if {$arc != ""} {
Window::message $this "Moving Arc (NOT IMPLEMENTED - delete it and redraw)"
} else {
Window::message $this "Connecting nodes with new Arc"
set position [Instance::get_position $typeref $subtype $subtyperef $subsubtyperef]
set ccoords [eval Position::normalised_to_screen $position [Instance::get_plug_coords $typeref $subtype $subtyperef $subsubtyperef]]
set cx [lindex $ccoords 0]
set cy [lindex $ccoords 1]
Project::set_mode $Window($this,parent) Connecting $cx $cy $cx $cy [Comm::get_head $subsubtyperef] $type $typeref node/comm/plug $subtyperef $subsubtyperef
}
}
comm/plug -
comm/variable -
comm/arrow {
set arc [NetworkInstance::get_arc_by_node_comm $typeref 0 $subtyperef]
if {$arc != ""} {
Window::message $this "Moving Arc (NOT IMPLEMENTED - delete it and redraw)"
} else {
Window::message $this "Connecting components with new Arc"
set position [Implementation::get_network_box_position $NetworkWindow($this,cur_implementation)]
set ccoords [eval Position::normalised_to_screen $position [Comm::get_coords $subtyperef]]
set cx [lindex $ccoords 0]
set cy [lindex $ccoords 1]
Project::set_mode $Window($this,parent) Connecting $cx $cy $cx $cy [Comm::get_reversed_head $subtyperef] $type $typeref comm/plug $subtyperef {}
}
}
arc/arrow {
}
default {
Debug::puts NetworkWindow NetworkWindow::doublebutton1 warning "Ignoring doublebutton1 on $subtype"
}
}
}
proc NetworkWindow::button2down {this x y type typeref subtype subtyperef subsubtyperef args} {
Debug::puts NetworkWindow NetworkWindow::button2down debug "@$x,$y subtype=$subtype ($subtyperef,$subsubtyperef) $type ($typeref) tags=$args"
switch $subtype {
node/main/name -
node/main/body {
Debug::puts NetworkWindow NetworkWindow::button2down debug "On $subtype @$x,$y - moving node"
Window::message $this "Moving component"
set position [Node::get_position $subtyperef]
set xy [Position::get_xy $position]
set xoffset [expr $x - [lindex $xy 0]]
set yoffset [expr $y - [lindex $xy 1]]
set sizes [Position::get_sizes $position]
set xsize [lindex $sizes 0]
set ysize [lindex $sizes 1]
Project::set_mode $Window($this,parent) Moving $x $y $x $y $xoffset $yoffset $xsize $ysize $type $typeref node/main/body $subtyperef $subsubtyperef
}
main/border -
node/main/border {
if {$subtype == "main/border"} {
Debug::puts NetworkWindow NetworkWindow::button2down debug "On $subtype @$x,$y - resizing"
set position [Implementation::get_network_box_position $NetworkWindow($this,cur_implementation)]
set min_size $NetworkWindow(minimum_network_box_size)
Window::message $this "Resizing network Implementation box"
set subtype "main/border"
} else {
Debug::puts NetworkWindow NetworkWindow::button2down debug "On node border @$x,$y - resizing node"
set position [Node::get_position $subtyperef]
set min_size $NetworkWindow(minimum_node_box_size)
Window::message $this "Resizing component"
set subtype "node/main/body"
}
set xy [Position::get_xy $position]
set x0 [lindex $xy 0]
set y0 [lindex $xy 1]
set sizes [Position::get_sizes $position]
set xsize [lindex $sizes 0]
set ysize [lindex $sizes 1]
Project::set_mode $Window($this,parent) Resizing $x0 $y0 $x $y $xsize $ysize $min_size $min_size $type $typeref $subtype $subtyperef $subsubtyperef
}
default {
Debug::puts NetworkWindow NetworkWindow::button2down warning "Ignoring button2down on $subtype"
}
}
}
proc NetworkWindow::move_to {this x y type typeref subtype subtyperef subsubtyperef} {
Debug::puts NetworkWindow NetworkWindow::move_to debug "@$x,$y subtype=$subtype ($subtyperef,$subsubtyperef) $type ($typeref)"
switch $subtype {
node/main/name {
Debug::puts NetworkWindow NetworkWindow::move_to debug "Moving $subtype to $x,$y"
NetworkInstance::move_node $typeref $subtyperef $x $y
}
default {
Debug::puts NetworkWindow NetworkWindow::move_to warning "Ignoring move_to for subtype $subtype"
}
}
}
proc NetworkWindow::moved {this x y type typeref subtype subtyperef subsubtyperef} {
Debug::puts NetworkWindow NetworkWindow::moved debug "@$x,$y subtype=$subtype ($subtyperef,$subsubtyperef) $type ($typeref)"
switch $subtype {
node/main/body {
Debug::puts NetworkWindow NetworkWindow::moved debug "Moved $subtype to $x,$y"
NetworkInstance::move_node $typeref $subtyperef $x $y
Window::message $this ""
}
default {
Debug::puts NetworkWindow NetworkWindow::moved debug "Ignoring moved for subtype $subtype"
}
}
}
proc NetworkWindow::resized {this xsize ysize type typeref subtype subtyperef subsubtyperef} {
Debug::puts NetworkWindow NetworkWindow::resized debug "Size $xsize x $ysize; subtype=$subtype ($subtyperef,$subsubtyperef) $type ($typeref)"
switch $subtype {
main/border {
NetworkInstance::resize $typeref $xsize $ysize
Window::message $this "Resized network Implementation box to $xsize by $ysize"
NetworkWindow::update_canvas_scrollregion $this
}
node/main/body {
if {[NetworkInstance::resize_node $typeref $subtyperef $xsize $ysize 1]} {
Window::message $this "Resized component to $xsize by $ysize"
}
}
default {
Debug::puts NetworkWindow NetworkWindow::resized warning "Ignoring resized for subtype $subtype"
}
}
}
proc NetworkWindow::placed {this x y xsize ysize ref type typeref subtype subtyperef subsubtyperef} {
Debug::puts NetworkWindow NetworkWindow::placed debug "@$x,$y size $xsize x $ysize; reference $ref; subtype=$subtype ($subtyperef,$subsubtyperef) $type ($typeref)"
switch $subtype {
node/main/body {
set implementation $ref
set interface [Implementation::get_interface $implementation]
set label [Interface::get_pretty_label $interface $implementation 0]
Debug::puts NetworkWindow NetworkWindow::placed debug "Placing $label at $x,$y size $xsize x $ysize"
set node [new Node]
eval Node::init $node $interface $implementation $NetworkWindow($this,cur_implementation) $x $y $xsize $ysize [Interface::get_default_angle $interface]
NetworkInstance::add_node $NetworkWindow($this,cur_instance) $node 1 1
Select::set $type $typeref node/main/body $node {}
Window::message $this "Added new $label"
}
default {
Debug::puts NetworkWindow NetworkWindow::placed warning "Ignoring placed for subtype $subtype"
}
}
}
proc NetworkWindow::window_resized {this x y} {
NetworkWindow::update_canvas_scrollregion $this
}
proc NetworkWindow::connect_to {this type typeref start_subtype start_subtyperef start_subsubtyperef end_subtype end_subtyperef end_subsubtyperef coords} {
Debug::puts NetworkWindow NetworkWindow::connect_to debug "Type $type ($typeref) From subtype $start_subtype ($start_subtyperef,$start_subsubtyperef) To subtype $end_subtype ($end_subtyperef,$end_subsubtyperef) with middle coords $coords"
set implementation $NetworkWindow($this,cur_implementation)
set network_box_position [Implementation::get_network_box_position $implementation]
if {$coords != ""} {
set coords [eval Position::screen_to_normalised $network_box_position $coords]
Debug::puts NetworkWindow NetworkWindow::connect_to debug "Normalised middle coords to $coords"
}
if {$start_subtype == "comm/plug"} {
set start_node 0
set start_comm $start_subtyperef
} else {
set start_node $start_subtyperef
set start_comm $start_subsubtyperef
}
if {$end_subtype == "comm/plug"} {
set end_node 0
set end_comm $end_subtyperef
} else {
set end_node $end_subtyperef
set end_comm $end_subsubtyperef
}
set arc [new Arc]
Arc::init $arc $start_node $start_comm $end_node $end_comm $coords
set msg [NetworkInstance::add_arc $NetworkWindow($this,cur_instance) $arc 1 1]
if {$msg == ""} {
Select::set NetworkInstance $NetworkWindow($this,cur_instance) arc/arrow $arc {}
NetworkWindow::update_canvas_scrollregion $this
} else {
delete $arc
OKDialog "Error in Connecting Arc" "Error in Connecting Arc\n$msg"
}
}
proc NetworkWindow::interface_change {this interface comm what} {
if {$NetworkWindow($this,cur_instance) == ""} {
return
}
Debug::puts NetworkWindow NetworkWindow::interface_change debug "Interface $interface (Comm $comm) - $what"
if {$NetworkWindow($this,cur_interface) != $interface} {
NetworkInstance::node_interface_change $NetworkWindow($this,cur_instance) $interface $comm $what
return
}
if {$comm != ""} {
NetworkInstance::body_interface_change $NetworkWindow($this,cur_instance) $interface $comm $what
NetworkWindow::update_canvas_scrollregion $this
return
}
switch $what {
deleted {
NetworkWindow::set_cur_implementation $this "" ""
NetworkWindow::update_canvas_scrollregion $this
}
name {
NetworkWindow::update_instance_label $this
}
default {
Debug::puts NetworkWindow NetworkWindow::interface_change error "Unknown change $what (for body)"
}
}
}
proc NetworkWindow::implementation_change {this interface implementation what} {
if {$NetworkWindow($this,cur_instance) == ""} {
return
}
if {$NetworkWindow($this,cur_interface) != $interface ||
$NetworkWindow($this,cur_implementation) != $implementation} {
NetworkInstance::node_implementation_change $NetworkWindow($this,cur_instance) $interface $implementation $what
return
}
switch $what {
deleted {
NetworkWindow::set_cur_implementation $this "" ""
}
name {
NetworkWindow::update_instance_label $this
}
default {
Debug::puts NetworkWindow NetworkWindow::implementation_change error "Unknown change $what (for body)"
}
}
}
proc NetworkWindow::deleted_all_interfaces {this} {
NetworkWindow::set_cur_implementation $this "" ""
}
proc NetworkWindow::update_canvas_scrollregion {this} {
if {$NetworkWindow($this,cur_instance) == ""} {
return
}
set canvas $NetworkWindow($this,canvas_path)
set bbox [$canvas bbox all]
set left   [expr [lindex $bbox 0] - $NetworkWindow(interface_x_space)]
set top    [expr [lindex $bbox 1] - $NetworkWindow(interface_y_space)]
set right  [expr [lindex $bbox 2] + $NetworkWindow(interface_x_space)]
set bottom [expr [lindex $bbox 3] + $NetworkWindow(interface_y_space)]
$canvas configure -scrollregion "$left $top $right $bottom"
}
NetworkWindow::init_statics
Debug::init AttributesWindow
proc AttributesWindow::AttributesWindow {this where parent state} Window {
$where "Attributes" "ODT Attributes" $parent
} {
set AttributesWindow($this,place) ""
set AttributesWindow($this,cur_no_attributes) 0
set AttributesWindow(ref) $this
set AttributesWindow($this,label) ""
Window::set_state $this $state
}
proc AttributesWindow::init_statics {} {
set AttributesWindow(max_no_attributes) 10
}
proc AttributesWindow::~AttributesWindow {this} {
unset AttributesWindow($this,place) AttributesWindow($this,cur_no_attributes) AttributesWindow(ref) AttributesWindow($this,label)
AttributesWindow::unset_attributes $this
}
proc AttributesWindow::draw {this} {
set where $Window($this,where)
set AttributesWindow($this,place) $where
AttributesWindow::init_menubar $this ${where}.mbar
label $where.object_label -textvariable AttributesWindow($this,label)
frame $where.body
set packstr ""
for {set i 0} {$i < $AttributesWindow(max_no_attributes)} {incr i} {
set linelab $where.body.line$i
frame $linelab
lappend packstr $linelab
label $linelab.fields -textvariable AttributesWindow($this,field,$i) -width 12 -anchor e
label $linelab.vals -textvariable AttributesWindow($this,value,$i) -relief sunken -bd 1 -width 18 -anchor w
pack $linelab.fields -side left
pack $linelab.vals -side left -fill x -expand 1
}
pack $where.mbar -side top -fill x
pack $where.object_label -side top -fill x
pack $where.body -side top -fill x -expand 1
eval pack $packstr -side top -fill x -expand 1
AttributesWindow::set_attributes
}
proc AttributesWindow::undraw {where} {
Debug::puts AttributesWindow AttributesWindow::undraw debug ""
}
proc AttributesWindow::init_menubar {this where} {
frame $where -relief raised -bd 2
menubutton $where.window -text "Window" -menu $where.window.menu -underline 0
menu $where.window.menu -tearoff 0
$where.window.menu add command -label "Close" -underline 0 -command [list Window::hide $this]
menubutton $where.help -text "Help" -underline 0
pack $where.window -side left
pack $where.help -side right
}
proc AttributesWindow::set_attributes {} {
set this $AttributesWindow(ref)
if {![Window::get_state $this]} {
return
}
set where $AttributesWindow($this,place)
set elements [Select::get_last_element]
set desti 0
if {$elements == ""} {
set AttributesWindow($this,cur_no_attributes) 0
set AttributesWindow($this,label) ""
} else {
set elements [eval Viewable::get_object_part_ref $elements]
set type [lindex $elements 0]
set typeref [lindex $elements 1]
set AttributesWindow($this,label) [Viewable::get_object_title $type $typeref]
set nv_list [Viewable::get_attributes $type $typeref]
set AttributesWindow($this,cur_no_attributes) [llength $nv_list]
Debug::puts AttributesWindow AttributesWindow::set_attributes debug "Got Name:Value list of $nv_list"
foreach {name value} $nv_list {
Debug::puts AttributesWindow AttributesWindow::set_attributes debug "$name=$value"
if {$AttributesWindow($this,field,$desti) != $name} {
set AttributesWindow($this,field,$desti) $name
}
if {$AttributesWindow($this,value,$desti) != $value} {
set AttributesWindow($this,value,$desti) $value
}
if {[incr desti] == $AttributesWindow(max_no_attributes)} {
break
}
}
}
while {$desti< $AttributesWindow(max_no_attributes)} {
if {$AttributesWindow($this,field,$desti) != ""} {
set AttributesWindow($this,field,$desti) ""
}
if {$AttributesWindow($this,value,$desti) != ""} {
set AttributesWindow($this,value,$desti) ""
}
incr desti
}
}
proc AttributesWindow::unset_attributes {this} {
if {![info exists AttributesWindow($this,field,0)]} {
return
}
set i 0
while {$i< $AttributesWindow(max_no_attributes)} {
unset AttributesWindow($this,field,$i) AttributesWindow($this,value,$i)
incr i
}
}
AttributesWindow::init_statics
Debug::init ProjectWindow
proc ProjectWindow::ProjectWindow {this where parent state} Window {
$where "Project" "ODT Project" $parent
} {
set ProjectWindow($this,curop) ""
set ProjectWindow($this,canvaspath) ""
Window::set_state $this $state
}
proc ProjectWindow::~ProjectWindow {this} {
ProjectWindow::cancelop
}
proc ProjectWindow::draw {this} {
set where $Window($this,where)
ProjectWindow::init_menubar $this $where.mbar
pack $where.mbar -side top -fill x
frame $where.message -bd 1
label $where.message.value -textvariable Window($this,message)
pack $where.message.value -side left
pack $where.message -side top -fill x
}
proc ProjectWindow::undraw {this} {}
proc ProjectWindow::init_menubar {this where} {
frame $where -relief raised -bd 2
set place $Window($this,place)
set m $where.project
menubutton $m -text "Project" -menu $m.menu -underline 0
menu $m.menu -tearoff 0
$m.menu add command -label "New" -accelerator "^N" -underline 0 -command [list ProjectWindow::MenuProjectNew $this]
bind $place <Control-n> [list ProjectWindow::MenuProjectNew $this]
$m.menu add separator
$m.menu add command -label "Open" -accelerator "^O" -underline 0 -command [list ProjectWindow::MenuProjectOpen $this ""]
bind $place <Control-o> [list ProjectWindow::MenuProjectOpen $this]
$m.menu add command -label "Save" -accelerator "^S" -underline 0 -command [list ProjectWindow::MenuProjectSave $this]
bind $place <Control-s> [list ProjectWindow::MenuProjectSave $this]
$m.menu add command -label "Save As..." -accelerator "^A" -underline 1 -command [list ProjectWindow::MenuProjectSaveAs $this]
bind $place <Control-a> [list ProjectWindow::MenuProjectSaveAs $this]
$m.menu add command -label "About..."  -underline 0 -command [list ProjectWindow::MenuProjectAbout $this]
$m.menu add separator
$m.menu add command -label "Quit" -accelerator "^Q"  -underline 0 -command [list ProjectWindow::MenuProjectQuit $this]
bind all <Control-q> [list ProjectWindow::MenuProjectQuit $this]
bind all <Escape> "Project::reset_mode $Window($this,parent)"
set m $where.options
menubutton $m -text "Options" -menu $m.menu -underline 0
menu $m.menu -tearoff 0
$m.menu add cascade -label "Language..." -underline 0 -menu $m.menu.language
menu $m.menu.language -tearoff 0
set project $Window($this,parent)
foreach lang [Language::get_languages] {
set name [Language::get_name $lang]
global Project
$m.menu.language add radio -label $name -underline 0 -command [list ProjectWindow::MenuOptionsChangeLanguage $this $name $lang] -variable Project($project,cur_language) -value $lang -selectcolor [Colour::get_fg]
}
$m.menu add cascade -label "Colours..." -underline 0 -menu $m.menu.colours
menu $m.menu.colours -tearoff 0
foreach {colour label} {bonw {Black on White} wonb {White on Black}} {
$m.menu.colours add command -label $label -command [list Colour::set_colours $colour]
}
foreach {option_var label} [Options::get_options] {
global Options
$m.menu add checkbutton -label $label -variable $option_var -onvalue 1 -offvalue 0 -selectcolor [Colour::get_fg]
}
set m $where.windows
menubutton $m -text "Windows" -underline 0 -menu $m.menu
menu $m.menu -tearoff 0
$m.menu add command -label "Interface Editor" -accelerator "1" -underline 0 -command [list Window::togglewindow Interface]
$m.menu add command -label "Network Editor" -accelerator "2" -underline 0 -command [list Window::togglewindow Network]
$m.menu add command -label "Attributes" -accelerator "3" -underline 0 -command [list Window::togglewindow Attributes]
set m $where.debug
menubutton $m -text "Debug" -underline 0 -menu $m.menu
menu $m.menu -tearoff 0
$m.menu add cascade -label "Class" -underline 0 -menu $m.menu.debug_class
$m.menu add cascade -label "Log" -underline 0 -menu $m.menu.debug_log
menu $m.menu.debug_class -tearoff 0
foreach class [lsort [Debug::get_classes]] {
$m.menu.debug_class add command -label $class -command [list Debug::toggle_debug_class $class]
}    
menu $m.menu.debug_log -tearoff 0
$m.menu.debug_log add command -label "Start debug log" -command "Debug::start_log odt.log"
$m.menu.debug_log add command -label "End debug log" -command "Debug::end_log"
menubutton $where.help -text "Help" -underline 0
pack $where.project $where.options $where.windows $where.debug -side left
pack $where.help -side right
}
proc ProjectWindow::MenuProjectNew {this} {
Debug::puts ProjectWindow ProjectWindow::MenuProjectNew info ""
Window::message $this ""
if {[Project::is_clear $Window($this,parent)]} {
return
}
if {[Project::is_modified $Window($this,parent)]} {
set result [YesNoCancelDialog "Project modified" "Project has been modified.\nDo you want to save this project before erasing it?"]
if {$result == 0} {
ProjectWindow::MenuProjectSave $this
} elseif {$result == 2} {
return
}
}
Project::clear $Window($this,parent)
ProjectWindow::update_title $this ""
}
proc Project::get_file_name_sequence {this dialog_title dialog_prompt} {
while {1} {
set name [NameDialog $dialog_title $dialog_prompt ""]
if {$name == ""} {
return
}
if {[File::is_valid_suffix $name $Project(file_suffix)]} {
break
} 
OKDialog "Invalid $dialog_title" "Invalid file name suffix in $name"
}
return [File::enforce_suffix $name $Project(file_suffix)]
}
proc ProjectWindow::MenuProjectOpen {this name} {
Debug::puts ProjectWindow ProjectWindow::MenuProjectOpen info ""
Window::message $this ""
set do_clear 0
if {![Project::is_clear $Window($this,parent)]} {
set result [YesNoCancelDialog "Project modified" "There is an existing Project\nDo you want to overwrite it?"]
if {$result == 0} {
set do_clear 1
} elseif {$result == 2} {
return
}
}
if {$name == ""} {
set name [Project::get_file_name_sequence $this "Load Project" "Load Name"]
if {$name == ""} {
return
}
}
if {![file exists $name] || ![file readable $name]} {
OKDialog "File not Found" "Project file '$name' not found"
return
}
if {$do_clear} {
Project::clear $Window($this,parent)
}
Window::message $this "Loading from $name..."
update idletasks
if {[Project::load_project_from $Window($this,parent) $name]} {
ProjectWindow::update_title $this $name
Window::message $this "Loading done"
} else {
OKDialog "File not Found" "Project file '$name' not found"
Window::message $this "Loading failed"
}
}
proc ProjectWindow::MenuProjectSave {this} {
Debug::puts ProjectWindow ProjectWindow::MenuProjectSave info ""
Window::message $this ""
if {[Project::is_clear $Window($this,parent)]} {
OKDialog "Nothing to save" "Project is empty\nNothing to save"
return
}
set name [Project::get_name $Window($this,parent)]
if {$name == ""} {
set name [Project::get_file_name_sequence $this "Save Project" "Project Name"]
if {$name == ""} {
return
}
Project::set_name $Window($this,parent) $name
ProjectWindow::update_title $this $name
}
Window::message $this "Saving as $name..."
update idletasks
Project::save_project $Window($this,parent)
Window::message $this "Saving done"
}
proc ProjectWindow::MenuProjectSaveAs {this} {
Debug::puts ProjectWindow ProjectWindow::MenuProjectSaveAs info ""
Window::message $this ""
if {[Project::is_clear $Window($this,parent)]} {
OKDialog "Nothing to save" "Project is empty\nNothing to Save As"
return
}
set name [Project::get_file_name_sequence $this "Save Project As" "Save Project As Name"]
if {$name == ""} {
return
}
if {$name != [Project::get_name $Window($this,parent)]} {
if {[file exists $name] && [file readable $name]} {
set backup_filename [File::backup_filename $name]
if {[OKCancelDialog "Save Project As..." "There is an existing file $name\nDo you want to overwrite it\n(and rename old file as $backup_filename)?"] == 1} {
return
} else {
if {[file exists $backup_filename]} {
delete_file $backup_filename
}
rename_file $name $backup_filename
}
}
Project::set_name $Window($this,parent) $name
ProjectWindow::update_title $this $name
}
Window::message $this "Saving as $name..."
update idletasks
Project::save_project $Window($this,parent)
Window::message $this "Saving done"
}
proc ProjectWindow::MenuProjectAbout {this} {
Debug::puts ProjectWindow ProjectWindow::MenuProjectAbout info ""
Window::message $this ""
set odt_version [Project::get_version]
OKDialog "About ODT" "Occam Design Tool (ODT) $odt_version\nCopyright 1995,1996\nDave Beckett\nUniversity of Kent\nCanterbury\nKent\nD.J.Beckett@ukc.ac.uk"
update idletasks
}
proc ProjectWindow::MenuProjectQuit {this} {
Debug::puts ProjectWindow ProjectWindow::MenuProjectQuit info ""
Window::message $this ""
if {[Project::is_modified $Window($this,parent)]} {
set result [YesNoCancelDialog "Project modified" "Project has been modified.\nDo you want to save before exiting?"]
if {$result == 0} {
ProjectWindow::MenuProjectSave $this
} elseif {$result == 2} {
return
}
}
update idletasks
Debug::end_log
exit
}
proc ProjectWindow::MenuOptionsChangeLanguage {this name lang} {
Debug::puts ProjectWindow ProjectWindow::MenuOptionsChangeLanguage debug "Language now $name ($lang)"
Window::message $this ""
Project::set_cur_language $Window($this,parent) $lang
}
proc ProjectWindow::update_title {this name} {
Window::set_title $this "ODT Project: $name"
}
Debug::init Language
proc Language::Language {this name basetypes udtypes commtypes of idregexp arrayplace null_body append_words_char par_block_start par_block_end proc_header_prefix proc_header_suffix proc_header_end include_command} {
set Language($this,name) $name
set Language($this,basetypes) $basetypes
set Language($this,udtypes) $udtypes
set Language($this,commtypes) $commtypes
set Language($this,of) $of
set Language($this,idregexp) $idregexp
set Language($this,array_placement) $arrayplace
set Language($this,null_body) $null_body
set Language($this,append_words_char) $append_words_char
set Language($this,par_block_start) $par_block_start
set Language($this,par_block_end) $par_block_end
set Language($this,proc_header_prefix) $proc_header_prefix
set Language($this,proc_header_suffix) $proc_header_suffix
set Language($this,proc_header_end) $proc_header_end
set Language($this,include_command) $include_command
lappend Language(languages) $this
set Language(name_to_language,$name) $this
}
proc Language::init_statics {} {
set Language(languages) {}
set Language(fold_begin) \{\{\{
set Language(fold_folded) ...
set Language(fold_end) \}\}\}
new occam
new parallelc
new java
}
proc Language::~Language {this} {}
proc Language::get_languages {} {
return $Language(languages)
}
proc Language::get_default_language {} {
return [lindex $Language(languages) 0]
}
proc Language::get_by_name {name} {
if {$name==""} {
return [Language::get_default_language]
}
return $Language(name_to_language,$name)
}
proc Language::get_object_description {this} {
return $Language($this,name)
}
proc Language::is_valid_id {this id} {
return [regexp $Language($this,idregexp) $id]
}
proc Language::is_udt {this type} {
return [expr [lsearch -exact $Language($this,udtypes) $type] >= 0]
}
proc Language::get_name {this} {
return $Language($this,name)
}
proc Language::get_commtypes {this} {
return $Language($this,commtypes)
}
proc Language::get_commdatatypes {this} {
return [concat $Language($this,basetypes) $Language($this,udtypes)]
}
proc Language::format_array_dims {this dims} {
set str ""
foreach dim $dims {
if {$dim >0} {
set str "$str\[$dim\]"
} else {
set str "$str\[]"
}
}
return $str
}
proc Language::chan_type_description {this type type_dims} {
Debug::puts Language Language::chan_type_description debug "Type=$type dims=$type_dims"
set dims_str ""
if {[llength $type_dims] > 0} {
set dims_str [Language::format_array_dims $this $type_dims]
}
Debug::puts Language Language::chan_type_description debug "dims_str=$dims_str"
if {$Language($this,array_placement) == "before"} {
return "$dims_str$type"
} else {
return "$type$dims_str"
}
}
proc Language::chan_data_description {this datatype datatype_name datatype_dims} {
Debug::puts Language Language::chan_data_description debug "Datatype=$datatype name=$datatype_name dims=$datatype_dims"
set dims_str ""
if {$datatype_dims != ""} {
set dims_str [Language::format_array_dims $this $datatype_dims]
}
Debug::puts Language Language::chan_data_description debug "Dims_str=$dims_str"
if {$datatype== ""} {
set type "?"
} elseif {$datatype== "Other"} {
set type $datatype_name
} else {
if {[Language::is_udt $this $datatype]} {
set type $datatype_name
} else {
set type $datatype
}
}
if {$Language($this,array_placement) == "before"} {
return "$dims_str$type"
} else {
return "$type$dims_str"
}
}
proc Language::comm_description {this type array_chan_dims contents_array_dims contents contents_name} {
return "[Language::chan_type_description $this $type $array_chan_dims] $Language($this,of) [Language::chan_data_description $this $contents $contents_name $contents_array_dims]"
}
proc Language::get_null_body {this} {
return $Language($this,null_body)
}
proc Language::append_words {this args} {
return [join $args $Language($this,append_words_char)]
}
proc Language::format_type_names {this prefix suffix nl_at_new_type width types_names} {
Debug::puts Language Language::format_type_names debug "Prefix='$prefix' Suffix='$suffix' nl_at_new_type=$nl_at_new_type Width=$width Types,Names=$types_names"
set prefix_len [string length $prefix]
set indent_string [string range "X                                                                                                   " 1 $prefix_len]
set line_len $prefix_len
set result $prefix
set sep ""
set last_type ""
foreach {type name} $types_names {
set break 0
if {$type == $last_type} {
set param $name
} else {
set param "$type $name"
if {$nl_at_new_type && $last_type != ""} {
set break 1
}
}
set bit "$sep$param"
set bit_len [string length $bit]
if {!$break && [expr $line_len + $bit_len >= $width]} {
set break 1
}
if {$break} {
if {$nl_at_new_type} {
append result "$suffix\n$indent_string"
} else {
append result "$sep\n$indent_string"
}
set line_len $prefix_len
set bit "$type $name"
set bit_len [string length $bit]
}
set sep ", "
append result $bit
incr line_len $bit_len
set last_type $type
}
append result $suffix
return $result
}
proc Language::format_names {this prefix suffix width names} {
Debug::puts Language Language::format_names debug "Prefix='$prefix' Suffix='$suffix' Width=$width Names=$names"
set prefix_len [string length $prefix]
set indent_string [string range "X                                                                                                   " 1 $prefix_len]
set line_len $prefix_len
set result $prefix
set sep ""
foreach name $names {
set bit "$sep$name"
set bit_len [string length $bit]
if {[expr $line_len + $bit_len >= $width]} {
append result "$sep\n$indent_string"
set line_len $prefix_len
set bit $name
set bit_len [string length $bit]
}
set sep ", "
append result $bit
incr line_len $bit_len
}
append result $suffix
return $result
}
proc Language::get_proc_dummy_body {this fake} {
if {$fake} {
return "$Language(fold_folded) body\n"
} else {
return [Language::comment_line $this {body}]
}
}
proc Language::start_folded_block {this line fake} {
if {$fake} {
return "$Language(fold_begin)  $line"
} else {
return [Language::start_comment_block $this $line]
}
}
proc Language::end_folded_block {this fake} {
if {$fake} {
return $Language(fold_end)
} else {
return [Language::end_comment_block $this]
}
}
proc Language::begin_par_block {this} {
return $Language($this,par_block_start)
}
proc Language::end_par_block {this} {
return $Language($this,par_block_end)
}
proc Language::get_proc_header_start {this indent name parameters} {
return [Language::format_type_names $this "$indent$Language($this,proc_header_prefix) $name (" ")$Language($this,proc_header_suffix)" 0 76 $parameters]
}
proc Language::get_proc_header_end {this name} {
return $Language($this,proc_header_end)
}
proc Language::call_include_files {this indent list fake} {
set result {}
foreach {file types_names} $list {
set comment [eval [concat "Language::format_type_names $this {For } {} 0 1000" $types_names]]
append result "$indent[Language::comment_line $this $comment]"
if {$file == ""} {
append result "$indent[Language::comment_line $this {No filename given}]";
} else {
append result "$indent$Language($this,include_command) \"$file\"\n"
}
}
return $result
}
proc Language::get_proc_header_short {this name} {
return "$Language($this,proc_header_prefix) $name (...)"
}
virtual proc Language::get_validtypes {this} {
return [concat $Language($this,basetypes) $Language($this,udtypes)]
}
virtual proc Language::start_comment_block {this line} {
return "start comment block: $line"
}
virtual proc Language::comment_block_line {this line} {
return "comment block line: $line"
}
virtual proc Language::end_comment_block {this} {
return "end comment block"
}
virtual proc Language::comment_line {this line} {
return "comment line: $line"
}
virtual proc Language::declare_channel {this name data_type} {
return "declare channel $name type $data_type"
}
virtual proc Language::declare_channels {this indent channel_decls} {
return [Language::format_type_names $this "${indent}declare " "" 0 76 $channel_decls]
}
virtual proc Language::call_process {this indent proc_name names} {
return [Language::format_names $this "${indent}call_proc $proc_name (" ")" 76 $names]
}
virtual proc Language::get_pure_ioseq_body {this indent comms_list fake} {
return [Language::comment_line $this "Pure I/O-SEQ body"]
}
virtual proc Language::get_pure_iopar_body {this indent comms_list fake} {
return [Language::comment_line $this "Pure I/O-PAR body"]
}
virtual proc Language::get_pure_client_body {this indent comms_list fake} {
return [Language::comment_line $this "Pure client body"]
}
virtual proc Language::get_pure_server_body {this indent comms_list fake} {
return [Language::comment_line $this "Pure server body"]
}
virtual proc Language::get_client_server_body {this indent comms_list fake} {
return [Language::comment_line $this "Client server body"]
}
proc occam::occam {this} Language {
"occam" {BOOL BYTE INT16 INT32 INT REAL32 REAL64} {PROTOCOL "DATA TYPE"} {CHAN PORT} "OF" {^[a-zA-Z][a-zA-Z0-9.]*$} "before" "SKIP" "." "PAR" "" "PROC" "" ":" "#INCLUDE"
} {
}
proc occam::~occam {this} {}
proc occam::get_validtypes {this} {
return [concat $Language($this,basetypes) {"DATA TYPE"}]
}
proc occam::start_comment_block {this line} {
return "--$Language(fold_begin)  $line"
}
proc occam::comment_block_line {this line} {
if {$line == ""} {
return "--"
}
return "-- $line"
}
proc occam::end_comment_block {this} {
return "--$Language(fold_end)"
}
proc occam::comment_line {this line} {
if {$line == ""} {
return "--\n"
}
return "-- $line\n"
}
proc occam::declare_channel {this name data_type} {
return "$data_type $name:"
}
proc occam::declare_channels {this indent channel_decls} {
return [Language::format_type_names $this $indent ":" 1 76 $channel_decls]
}
proc occam::call_process {this indent proc_name names} {
return [Language::format_names $this "${indent}$proc_name (" ")" 76 $names]
}
proc occam::get_pure_ioseq_body {this indent comms_list fake} {
set    output     "${indent}WHILE TRUE\n"
append output     "${indent}  SEQ\n"
set chans(in) {}
set chans(out) {}
foreach {comm full_name paradigm direction} $comms_list {
lappend chans($direction) $full_name
}
foreach direction {in compute out} {
if {$direction == "compute"} {
append output "${indent}    -- Compute\n"
} elseif {$chans($direction) != ""} {
set channels [join $chans($direction) ", "]
set dir_label [Comm::get_label_for_direction $direction]
append output "${indent}    -- $dir_label on all channels: $channels\n"
}
}
return $output
}
proc occam::get_pure_iopar_body {this indent comms_list fake} {
set    output   "${indent}WHILE TRUE\n"
append output   "${indent}  SEQ\n"
append output   "${indent}    PAR\n"
set chans(in) {}
set chans(out) {}
foreach {comm full_name paradigm direction} $comms_list {
lappend chans($direction) $full_name
}
foreach direction {in out} {
set dir_label [Comm::get_label_for_direction $direction]
set channels [join $chans($direction) ", "]
append output "${indent}      -- $dir_label on all channels once: $channels\n"
}
append output   "${indent}    -- Compute\n"
return $output
}
proc occam::get_pure_client_body {this indent comms_list fake} {
set    output   "${indent}WHILE TRUE\n"
append output   "${indent}  SEQ\n"
foreach {comm full_name paradigm direction} $comms_list {
lappend chans($direction) $full_name
}
foreach direction [array names chans] {
set channels [join $chans($direction) ", "]
if {$direction == "out"} {
append output   "${indent}    -- Output requests on $channels\n"
} else {
append output   "${indent}    -- Input requests/replies on $channels\n"
}
}
return $output
}
proc occam::get_pure_server_body {this indent comms_list fake} {
set    output     "${indent}WHILE TRUE\n"
append output     "${indent}  ALT\n"
foreach {comm full_name paradigm direction} $comms_list {
if {$direction == "in"} {
append output "${indent}    ${full_name}? parameters ...\n"
append output "${indent}      -- action with possible reply\n"
} else {
lappend reply_channels $full_name
}
}
if {$reply_channels != ""} {
set channels [join $reply_channels ", "]
append output   "${indent}     -- Replies on channels $channels\n"
}
return $output
}
proc occam::get_client_server_body {this indent comms_list fake} {
set    output     "${indent}WHILE TRUE\n"
append output     "${indent}  ALT\n"
foreach combination {anyserver,in anyserver,out client,in client,out}  {
set chans($combination) {}
}
foreach {comm full_name paradigm direction} $comms_list {
if {$paradigm == "server" || $paradigm == "semiserver"} {
set paradigm "anyserver"
}
lappend chans($paradigm,$direction) $full_name
}
foreach full_name $chans(anyserver,in) {
append output   "${indent}    ${full_name}? parameters ...\n"
append output   "${indent}      -- action with possible reply\n"
}
if {$chans(anyserver,out) != ""} {
set channels [join $chans(anyserver,out) ", "]
append output   "${indent}    -- Possible Service replies on channels $channels\n"
}
if {$chans(client,out) != ""} {
set channels [join $chans(client,out) ", "]
append output   "${indent}    -- Possible Client requests on channels $channels\n"
}
if {$chans(client,in) != ""} {
set channels [join $chans(client,in) ", "]
append output   "${indent}    -- Possible Client replies on channels $channels\n"
}
return $output
}
proc parallelc::parallelc {this} Language {
"Parallel C" {char short int long float double "long double"} {struct union} {chan port} "of" {^[a-zA-Z_][a-zA-Z0-9_]*$} "after" "/* Empty */" "_" "par \{" "\}" "void" " \{" "\}" "#include"
} {
}
proc parallelc::~parallelc {this} {}
proc parallelc::get_proc_header_start {this name parameters} {
return [Language::format_type_names $this "void $name (" ") \{" 0 76 $parameters]
}
proc parallelc::get_proc_header_end {this name} {
return \}
}
proc parallelc::start_comment_block {this line} {
return "/* $Language(fold_begin)$line */"
}
proc parallelc::comment_block_line {this line} {
if {$line == ""} {
return " *"
}
return " * $line"
}
proc parallelc::end_comment_block {this} {
return "/* $Language(fold_end) */"
}
proc parallelc::comment_line {this line} {
if {$line == ""} {
return " /**/\n"
}
return "/* $line */\n"
}
proc parallelc::declare_channel {this name data_type} {
return "$data_type $name;"
}
proc parallelc::declare_channels {this indent channel_decls} {
return [Language::format_type_names $this $indent ";" 1 76 $channel_decls]
}
proc parallelc::call_process {this indent proc_name names} {
return [Language::format_names $this "${indent}$proc_name (" ");" 76 $names]
}
proc java::java {this} Language {
"Java" {bool char short int long float double} {class} {Channel} "of" {^[a-zA-Z_][a-zA-Z0-9_]*$} "after" "/* Empty */" "_" "par \{" "\}" "void" " \{" "\}" "#include"
} {
}
proc java::~java {this} {}
Language::init_statics
Debug::init Viewable
proc Viewable::add_type {type viewargs} {
global Viewable
set Viewable($type,viewargs) $viewargs
set Viewable($type,type) $type
}
proc Viewable::add_derived_type {type parent_type} {
global Viewable
if {![info exists Viewable($parent_type,viewargs)]} {
Debug::puts Viewable Viewable::add"_derived_type error "$type $parent_type - $parent_type does not exist"
return
}
set Viewable($type,viewargs) $Viewable($parent_type,viewargs)
set Viewable($type,type) $parent_type
}
proc Viewable::get_attributes_for_type {type} {
Debug::puts Viewable Viewable::get_viewable_attributes_for_type debug "Type $type"
global Viewable
if {[info exists Viewable($type,viewargs)]} {
return $Viewable($type,viewargs)
} else {
return {}
}
}
proc Viewable::get_attributes {type ref} {
Debug::puts Viewable Viewable::get_attributes debug "Type $type ($ref)"
global Viewable
set attributes [Viewable::get_attributes_for_type $type]
Debug::puts Viewable Viewable::get_attributes debug "Attributes for type $type = $attributes"
if {$attributes == ""} {
return {}
}
set base_type $Viewable($type,type)
Debug::puts Viewable Viewable::get_attributes debug "Base type of $type is $base_type"
set nv {}
global $base_type
foreach element $attributes {
set label [lindex $element 0]
set attr_name [lindex $element 1]
set attr_type [lindex $element 2]
set attr_param [lindex $element 3]
Debug::puts Viewable Viewable::get_attributes debug "$base_type ($ref) $attr_name (type $attr_type) param=$attr_param"
set attr_value ""
set ref2 $ref
if {$ref != ""} {
set ref2 "$ref,"
}
if {$attr_name != "" && [eval info exists $base_type\($ref2$attr_name\)]} {
set attr_value [expr \$$base_type\($ref2$attr_name\)]
}
Debug::puts Viewable Viewable::get_attributes debug "Attribute value for $attr_name (type $attr_type) is $attr_value"
switch $attr_type {
string {}
object {
if {$attr_value !=""} {
Debug::puts Viewable Viewable::get_attributes debug "Calling $attr_param::get_object_description $attr_value"
set attr_value [$attr_param::get_object_description $attr_value]
}
}
method {
Debug::puts Viewable Viewable::get_attributes debug "Calling $base_type::$attr_param $ref"
set attr_value [$base_type::$attr_param $ref]
}
function {
if {$attr_value !=""} {
Debug::puts Viewable Viewable::get_attributes debug "Calling $attr_param $attr_value"
set attr_value [$attr_param $attr_value]
}
}
default {
Debug::puts Viewable Viewable::get_attributes warning "Type $base_type ($ref), element $attr_name: Unknown Attribute type $attr_type"
}
}
Debug::puts Viewable Viewable::get_attributes debug "Adding $label=$attr_value"
lappend nv $label $attr_value
}
return $nv
}
proc Viewable::get_object_description {type ref} {
global Viewable
set base_type $Viewable($type,type)
if {[info proc $base_type::get_object_description]!=""} {
return [$base_type::get_object_description $ref]
} else {
return "Object type $type reference $ref"
}
}
proc Viewable::get_object_title {type ref} {
global Viewable
set base_type $Viewable($type,type)
if {[info proc $base_type::get_object_title]!=""} {
return [$base_type::get_object_title $ref]
} else {
return [Viewable::get_object_description $type $ref]
}
}
proc Viewable::get_object_part_ref {type ref part partref subpartref} {
global Viewable
set base_type $Viewable($type,type)
if {[info proc $base_type::get_object_part_ref]!=""} {
return [$base_type::get_object_part_ref $ref $part $partref $subpartref]
} else {
return [list $type $ref]
}
}
Debug::init Saver
proc Saver::Saver {this label filename} {
set Saver($this,filename) $filename
set Saver($this,fd) [open $filename w+]
set Saver($this,indent) 0
puts $Saver($this,fd) $label
}
proc Saver::~Saver {this} {
close $Saver($this,fd)
unset Saver($this,filename) Saver($this,fd) Saver($this,indent)
}
proc Saver::indent {this} {
if {$Saver($this,indent) <=0} {
return ""
}
return [string range "                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    " 0 $Saver($this,indent)]
}
proc Saver::begin {this type} {
puts $Saver($this,fd) "[Saver::indent $this]BEGIN $type"
incr Saver($this,indent) +2
}
proc Saver::end {this type} {
incr Saver($this,indent) -2
puts $Saver($this,fd) "[Saver::indent $this]END $type"
}
proc Saver::save_field {this field value} {
if {[regsub -all "\n" $value {\\n} new_value] >0} {
set value $new_value
}
puts $Saver($this,fd) "[Saver::indent $this]FIELD $field=\"$value\""
}
proc Saver::save_fields {this type ref args} {
global $type
foreach field $args {
if {$ref != ""} {
set value [expr \$$type\($ref,$field\)]
} else {
set value [expr \$$type\($field\)]
}
Saver::save_field $this $field $value
}
}
proc Saver::begin_list {this field} {
puts $Saver($this,fd) "[Saver::indent $this]BEGIN_LIST_FIELD $field"
incr Saver($this,indent) +2
}
proc Saver::end_list {this} {
incr Saver($this,indent) -2
puts $Saver($this,fd) "[Saver::indent $this]END_LIST_FIELD"
}
Debug::init FileLines
proc FileLines::FileLines {this filename} {
set FileLines($this,file) $filename
set FileLines($this,lineno) -1
set FileLines($this,original_line) ""
set FileLines($this,fd) [open $filename r]
}
proc FileLines::~FileLines {this} {
close $FileLines($this,fd)
unset FileLines($this,file) FileLines($this,lineno) FileLines($this,original_line) FileLines($this,fd)
}
proc FileLines::format {this} {
return "$FileLines($this,file):$FileLines($this,lineno):"
}
proc FileLines::get_line {this} {
set results {}
while {1} {
if {[eof $FileLines($this,fd)]} {
break
}
incr FileLines($this,lineno)
set FileLines($this,original_line) [gets $FileLines($this,fd)]
Debug::puts FileLines FileLines::get_line debug "$FileLines($this,file):$FileLines($this,lineno): $FileLines($this,original_line)"
set line [string trim $FileLines($this,original_line)]
Debug::puts FileLines FileLines::get_line debug "[FileLines::format $this] (#1) '$line'"
if {[regsub {^(.*) *--.*$} $line {\1} newline]} {
set line [string trim $newline]
}
Debug::puts FileLines FileLines::get_line debug "[FileLines::format $this] (#2) '$line'"
if {$line == ""} {
continue
}
set command ""
set rest ""
if {![regexp {^([^ ]+) (.+)$} $line dummy command rest]} {
set command $line
}
Debug::puts FileLines FileLines::get_line debug "[FileLines::format $this] Command=$command Rest='$rest'"
switch $command {
BEGIN -
BEGIN_LIST_FIELD {
set results "$command $rest"
break
}
END -
END_LIST_FIELD {
set results $command
break
}
FIELD {
set value ""
scan $rest {%[^=]="%[^"]"} field value
if {[regsub -all {\\n} $value "\n" new_value] >0} {
set value $new_value
}
Debug::puts FileLines FileLines::get_line debug "[FileLines::format $this] Field $field Value=$value"
set results [list $command $field $value]
break
}
default {
Debug::puts FileLines FileLines::get_line warning "[FileLines::format $this] Do not understand command: $command in '[FileLines::get_original_line $this]'"
break
}
}
}
return $results
}
proc FileLines::get_lineno {this} {
return $FileLines($this,lineno)
}
proc FileLines::get_original_line {this} {
return $FileLines($this,original_line)
}
Debug::init Loader
proc Load {filename project} {
if {![file exists $filename] || ![file readable $filename]} {
return ""
}
set filelines [new FileLines $filename]
set object [LoadObjectList $filelines $project Project $project]
Project::loaded_cleanup $project $project "" ""
return $object
}
proc LoadObjectList {filelines this_ref parent_object parent_ref} {
set object_list {}
while {1} {
set elements [FileLines::get_line $filelines]
if {$elements ==""} {
break
}
set command [lindex $elements 0]
switch $command {
BEGIN {
set object [lindex $elements 1]
if {$this_ref != ""} {
set ref $this_ref
} else {
set ref [new $object]
Debug::puts Loader LoadObjectList debug "Creating new $object with ref $ref"
}
lappend object_list [LoadObjectBody $filelines $object $ref $parent_object $parent_ref]
}
END_LIST_FIELD {
break
}
default {
Debug::puts Loader LoadObjectList debug "[FileLines::format $filelines] Unexpected command: $command in [FileLines::get_original_line $filelines]"
break
}
}
}
return $object_list
}
proc LoadObjectBody {filelines object ref parent_object parent_ref} {
Debug::puts Loader LoadObjectBody debug "Filling new $object ($ref) fields"
global $object
while {1} {
set elements [FileLines::get_line $filelines]
if {$elements ==""} {
break
}
set command [lindex $elements 0]
switch $command {
FIELD {
set name [lindex $elements 1]
set value [lindex $elements 2]
Debug::puts Loader LoadObjectBody debug "Object $object ($ref): Setting field $name='$value'"
eval set $object\($ref,$name\) [list $value]
}
BEGIN_LIST_FIELD {
set name [lindex $elements 1]
set object_list [LoadObjectList $filelines "" $object $ref]
Debug::puts Loader LoadObjectBody debug "Object $object ($ref): Setting list field $name='$object_list'"
eval set $object\($ref,$name\) [list $object_list]
}
END {
break
}
}
}
if {[info proc $object::load_cleanup]!=""} {
Debug::puts Loader LoadObjectBody debug "Calling $object::load_cleanup $ref $parent_object $parent_ref"
$object::load_cleanup $ref $parent_object $parent_ref
}
return $ref
}
Viewable::add_type Comm {
{Name           name         string}
{Contents       {}           method get_data_type}
{Direction      direction    function Comm::get_label_for_direction}
{Paradigm       paradigm     function Paradigm::get_label}
{Interface      interface    object Interface}
{Language       language     object Language}
{{Include File} include_file string}
}
Debug::init Comm
proc Comm::Comm {this} {
set Comm($this,name) {}
set Comm($this,language) {}
set Comm($this,interface) {}
set Comm($this,type) {}
set Comm($this,direction) $Comm(default_direction)
set Comm($this,array_chan_dims) {}
set Comm($this,contents_array_dims) {}
set Comm($this,contents) {}
set Comm($this,contents_name) {}
set Comm($this,include_file) {}
set Comm($this,paradigm) [Paradigm::get_default]
set Comm($this,coords) {}
set Comm($this,arrowdir) {}
}
proc Comm::~Comm {this} {
unset Comm($this,name) Comm($this,interface) Comm($this,language) Comm($this,type) Comm($this,direction) Comm($this,array_chan_dims) Comm($this,contents_array_dims) Comm($this,contents) Comm($this,contents_name) Comm($this,include_file) Comm($this,paradigm) Comm($this,coords) Comm($this,arrowdir)
}
proc Comm::init_statics {} {
set comm_table {
out   Output      last
in    Input       first
inout {In/Output} both
}
set Comm(directions) {}
set Comm(direction_labels) {}
foreach {dir label head} $comm_table {
lappend Comm(directions) $dir
lappend Comm(direction_labels) $label
set Comm(direction_to_head,$dir) $head
set Comm(direction_to_label,$dir) $label
}
set Comm(default_direction) [lindex $Comm(directions) 0]
}
proc Comm::save_object {this saver} {
Saver::begin $saver Comm
Saver::save_fields $saver Comm $this name type direction array_chan_dims contents_array_dims contents contents_name include_file paradigm coords arrowdir
Saver::end $saver Comm
}
proc Comm::get_object_title {this} {
return [Comm::description $this]
}
proc Comm::get_object_description {this} {
return [Comm::description $this]
}
proc Comm::get_coords {this} {
return $Comm($this,coords)
}
proc Comm::set_coords {this x y} {
set Comm($this,coords) "$x $y"
}
proc Comm::get_arrowdir {this} {
return $Comm($this,arrowdir)
}
proc Comm::set_arrowdir {this xdir ydir} {
set Comm($this,arrowdir) "$xdir $ydir"
}
proc Comm::get_paradigm {this} {
return $Comm($this,paradigm)
}
proc Comm::get_name {this} {
return $Comm($this,name)
}
proc Comm::get_head {this} {
return $Comm(direction_to_head,$Comm($this,direction))
}
proc Comm::get_reversed_head {this} {
set rev_dir [Comm::get_reversed_direction $Comm($this,direction)]
return $Comm(direction_to_head,$rev_dir)
}
proc Comm::get_direction {this} {
return $Comm($this,direction)
}
proc Comm::get_language {this} {
return $Comm($this,language)
}
proc Comm::chan_of_type_description {this} {
return [Language::comm_description $Comm($this,language) $Comm($this,type) $Comm($this,array_chan_dims) $Comm($this,contents_array_dims) $Comm($this,contents) $Comm($this,contents_name)]
}
proc Comm::description {this} {
set str [Comm::chan_of_type_description $this]
if {$Comm($this,name)== ""} {
if {$Comm($this,contents)!=""} {
set str "$str ?"
}
} else {
set str "$str $Comm($this,name)"
}
return $str
}
proc Comm::get_label_for_direction {direction} {
return $Comm(direction_to_label,$direction)
}
proc Comm::edit_dialog_trace_contents {name element op} {
Debug::puts Comm Comm::edit_dialog_trace_contents debug "Name=$name element=$element op=$op"
set w $Comm(dialog_path)
set working_comm $Comm(dialog_working_comm)
$w.contents configure -text $Comm($working_comm,contents)
set contents_name ""
set include_name ""
if {[Language::is_udt $Comm($working_comm,language) $Comm($working_comm,contents)]} {
set contents_name ""
set include_name ""
} elseif {$Comm($working_comm,contents) == "Other"} {
set contents_name ""
set include_name ""
}
set Comm($working_comm,contents_name) $contents_name
set Comm($working_comm,include_file) $include_name
Comm::edit_dialog_update_contents_name_state
}
proc Comm::edit_dialog_update_contents_name_state {} {
set w $Comm(dialog_path)
set working_comm $Comm(dialog_working_comm)
set state disabled
if {[Language::is_udt $Comm($working_comm,language) $Comm($working_comm,contents)] ||
$Comm($working_comm,contents) == "Other"} {
set state normal
}
$w.contents_name configure -state $state
$w.include_entry configure -state $state
}
proc Comm::edit_dialog_trace_paradigm {name element op} {
Debug::puts Comm Comm::edit_dialog_trace_paradigm debug "Name=$name element=$element op=$op"
set w $Comm(dialog_path)
set working_comm $Comm(dialog_working_comm)
$w.paradigm configure -text [Paradigm::get_label $Comm($working_comm,paradigm)]
set new_direction [Paradigm::validate_commdir $Comm($working_comm,paradigm) $Comm($working_comm,direction)]
if {$new_direction != $Comm($working_comm,direction)} {
set Comm($working_comm,direction) $new_direction
}
Comm::edit_dialog_update_direction_state
}
proc Comm::edit_dialog_update_direction_state {} {
set w $Comm(dialog_path)
set working_comm $Comm(dialog_working_comm)
set state disabled
if {[Paradigm::inout_commdir_allowed $Comm($working_comm,paradigm)]} {
set state normal
}
$w.direction_inout configure -state $state
}
proc Comm::edit_dialog {w comm existing_names} {
set Comm(dialog_path) $w
set Comm(dialog_comm) $comm
set working_comm [new $comm]
set Comm(dialog_working_comm) $working_comm
set language $Comm($working_comm,language)
set title "Editing Communication"
set default 0
set buttons {OK Cancel}
catch {destroy $w}
toplevel $w -class Dialog
wm title $w $title
wm iconname $w Dialog
wm protocol $w WM_DELETE_WINDOW { }
wm transient $w [winfo toplevel [winfo parent $w]]
frame $w.bot -relief raised -bd 1
pack $w.bot -side bottom -fill both
frame $w.top -relief raised -bd 1
pack $w.top -side top -fill both -expand 1
set edited_fields {name type direction array_chan_dims contents_array_dims contents contents_name include_file paradigm}
frame $w.top.name
frame $w.top.type
frame $w.top.dims
frame $w.top.direction
frame $w.top.contents
frame $w.top.contents_dims
frame $w.top.include
frame $w.top.paradigm
pack $w.top.name $w.top.type $w.top.dims $w.top.direction $w.top.contents $w.top.contents_dims $w.top.include $w.top.paradigm -in $w.top -side top -fill both -expand 1
label $w.name -justify left -text Name
entry $w.name_entry -width 20 -relief sunken -bd 2 -textvariable Comm($working_comm,name)
pack $w.name $w.name_entry -in $w.top.name -side left -padx 1m -pady 1m
label $w.type -justify left -text Type
set buts ""
foreach commtype [Language::get_commtypes $language] {
radiobutton $w.typeentry_$commtype -selectcolor [Colour::get_fg] -text $commtype -variable Comm($working_comm,type) -value $commtype -anchor w
lappend buts $w.typeentry_$commtype
}
eval pack $w.type $buts -in $w.top.type -side left -padx 1m -pady 1m
set Comm($working_comm,array_chan_dims) [join $Comm($working_comm,array_chan_dims) " "]
label $w.dims -justify left -text Dimensions
entry $w.dims_entry -width 10 -relief sunken -bd 2 -textvariable Comm($working_comm,array_chan_dims)
pack $w.dims $w.dims_entry -in $w.top.dims -side left -padx 1m -pady 1m
label $w.direction -justify left -text Direction
set buts {}
foreach dir $Comm(directions) dir_label $Comm(direction_labels) {
radiobutton $w.direction_$dir -selectcolor [Colour::get_fg] -text $dir_label -variable Comm($working_comm,direction) -value $dir -anchor w
lappend buts $w.direction_$dir
}
eval pack $w.direction $buts -in $w.top.direction -side left -padx 1m -pady 1m
set m $w.contents_menu
menubutton $m -text "Contents..." -menu $m.menu
menu $m.menu -tearoff 0
foreach dtype [concat [Language::get_commdatatypes $language] {Other}] {
$m.menu add radiobutton -label $dtype -value $dtype -variable Comm($working_comm,contents)
}
label $w.contents -justify left -width 10 -text $Comm($working_comm,contents)
entry $w.contents_name -width 20 -relief sunken -bd 2 -textvariable Comm($working_comm,contents_name)
trace variable Comm($working_comm,contents) w Comm::edit_dialog_trace_contents
pack $m $w.contents $w.contents_name -in $w.top.contents -side left -padx 1m -pady 1m
set Comm($working_comm,contents_array_dims) [join $Comm($working_comm,contents_array_dims) " "]
label $w.contents_dims -justify left -text {Contents dimensions}
entry $w.contents_dims_entry -width 10 -relief sunken -bd 2 -textvariable Comm($working_comm,contents_array_dims)
pack $w.contents_dims $w.contents_dims_entry -in $w.top.contents_dims -side left -padx 1m -pady 1m
label $w.include -justify left -text {Type definition file}
entry $w.include_entry -width 20 -relief sunken -bd 2 -textvariable Comm($working_comm,include_file)
pack $w.include $w.include_entry -in $w.top.include -side left -padx 1m -pady 1m
set m $w.paradigm_menu
menubutton $m -text "Paradigm..." -menu $m.menu
menu $m.menu -tearoff 0
foreach paradigm [Paradigm::get_paradigms] {
set paradigm_label [Paradigm::get_label $paradigm]
$m.menu add radiobutton -label $paradigm_label -value $paradigm -variable Comm($working_comm,paradigm)
}
label $w.paradigm -justify left -width 10 -text [Paradigm::get_label $Comm($working_comm,paradigm)]
trace variable Comm($working_comm,paradigm) w Comm::edit_dialog_trace_paradigm
pack $m $w.paradigm -in $w.top.paradigm -side left -padx 1m -pady 1m
Comm::edit_dialog_update_contents_name_state
Comm::edit_dialog_update_direction_state
set i 0
foreach but $buttons {
button $w.button$i -text $but -command "set Comm(dialog_button) $i"
if {$i == $default} {
frame $w.default -relief sunken -bd 1
raise $w.button$i $w.default
pack $w.default -in $w.bot -side left -expand 1 -padx 3m -pady 2m
pack $w.button$i -in $w.default -padx 2m -pady 2m
} else {
pack $w.button$i -in $w.bot -side left -expand 1 \
-padx 3m -pady 2m
}
incr i
}
wm withdraw $w
update idletasks
set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
- [winfo vrootx [winfo parent $w]]]
set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
- [winfo vrooty [winfo parent $w]]]
wm geom $w +$x+$y
wm deiconify $w
set oldFocus [focus]
if {$default >= 0} {
focus $w.button$default
} else {
focus $w
}
set langname [Language::get_name $language]
while {1} {
tkwait variable Comm(dialog_button)
if {$Comm(dialog_button)==1} {
break
}
if {$Comm($working_comm,contents)==""} {
OKDialog Error {No channel contents defined}
continue
}
if {$Comm($working_comm,name)==""} {
OKDialog Error {No channel name defined}
continue
}
if {![Language::is_valid_id $language $Comm($working_comm,name)]} {
OKDialog Error "Name '$Comm($working_comm,name)' is not a valid $langname identifier"
continue
}
if {[Language::is_udt $language $Comm($working_comm,contents)]} {
if {![Language::is_valid_id $language $Comm($working_comm,contents_name)]} {
OKDialog Error "Type '$Comm($working_comm,contents_name)' is not a valid $langname identifier"
continue
}
}
if {[lsearch -exact $existing_names $Comm($working_comm,name)]>=0} {
OKDialog Error "Name '$Comm($working_comm,name)' is an existing communication name"
continue
}
break
}
catch {focus $oldFocus}
destroy $w
trace vdelete Comm($working_comm,contents) w Comm::edit_dialog_trace_contents
trace vdelete Comm($working_comm,paradigm) w Comm::edit_dialog_trace_paradigm
set Comm($working_comm,contents_array_dims) [split $Comm($working_comm,contents_array_dims) " ,"]
set Comm($working_comm,array_chan_dims) [split $Comm($working_comm,array_chan_dims) " ,"]
foreach field $edited_fields {
set Comm($comm,$field) $Comm($working_comm,$field)
}
delete $working_comm
return $Comm(dialog_button)
}
proc Comm::init {this interface x y xdir ydir} {
set Comm($this,interface) $interface
set language [Interface::get_language $interface]
set Comm($this,language) $language
set Comm($this,type) [lindex [Language::get_commtypes $language] 0]
set Comm($this,coords) "$x $y"
set Comm($this,arrowdir) "$xdir $ydir"
return $this
}
proc Comm::load_cleanup {this parent parent_ref} {
set Comm($this,interface) $parent_ref
}
proc Comm::loaded_cleanup {this project parent parent_ref} {
set Comm($this,language) [Interface::get_language $parent_ref]
}
proc Comm::get_reversed_direction {dir} {
if {$dir == "in"} {
set dir "out"
} elseif {$dir == "out"} {
set dir "in"
}
return $dir
}
proc Comm::get_data_type {this} {
return [Language::comm_description $Comm($this,language) $Comm($this,type) $Comm($this,array_chan_dims) $Comm($this,contents_array_dims) $Comm($this,contents) $Comm($this,contents_name)]
}
proc Comm::comm_data_types_connectable {comm1 comm2} {
if {$Comm($comm1,type) != $Comm($comm2,type)} {
return 0
}
if {$Comm($comm1,contents) != $Comm($comm2,contents)} {
return 0
}
if {$Comm($comm1,contents_name) != $Comm($comm2,contents_name)} {
return 0
}
if {$Comm($comm1,contents_array_dims) != $Comm($comm2,contents_array_dims)} {
return 0
}
return 1
}
proc Comm::comm_directions_equivalent {comm1 comm2} {
return [expr {$Comm($comm1,direction) == $Comm($comm2,direction)}]
}
proc Comm::comm_directions_connectable {comm1 comm2} {
switch $Comm($comm1,direction)-$Comm($comm2,direction) {
in-out -
out-in -
inout-inout {
return 1
}
default {
return 0
}
}
}
proc Comm::get_type_details {this} {
if {![Language::is_udt $Comm($this,language) $Comm($this,contents)]} {
return {}
}
return [list $Comm($this,contents) $Comm($this,contents_name) $Comm($this,include_file)]
}
proc Comm::split_directions {direction} {
if {$direction == "inout"} {
return {request in reply out}
} else {
return [list {} $direction]
}
}
proc Comm::get_directions {this} {
return [Comm::split_directions $Comm($this,direction)]
}
Comm::init_statics
Debug::init Paradigm
proc Paradigm::init_statics {} {
global Paradigm
set paradigm_table {
null       Null          1
client     Client        1
server     Server        1
semiserver "Semi Server" 1
ioseq      "I/O SEQ"     0
iopar      "I/O PAR"     1
}
set Paradigm(paradigms) {}
foreach {paradigm label inout_allowed} $paradigm_table {
lappend Paradigm(paradigms) $paradigm
set Paradigm(paradigm_to_label,$paradigm) $label
set Paradigm(paradigm_inout_allowed,$paradigm) $inout_allowed
}
set Paradigm(default) [lindex $Paradigm(paradigms) 0]
}
proc Paradigm::get_paradigms {} {
global Paradigm
return $Paradigm(paradigms)
}
proc Paradigm::inout_commdir_allowed {paradigm} {
global Paradigm
return $Paradigm(paradigm_inout_allowed,$paradigm)
}
proc Paradigm::validate_commdir {paradigm commdir} {
global Paradigm
if {$commdir == "inout" && !$Paradigm(paradigm_inout_allowed,$paradigm)} {
set commdir out
}
return $commdir
}
proc Paradigm::get_label {paradigm} {
global Paradigm
return $Paradigm(paradigm_to_label,$paradigm)
}
proc Paradigm::get_default {} {
global Paradigm
return $Paradigm(default)
}
proc Paradigm::validate_paradigm_combinations {args} {
Debug::puts Paradigm Paradigm::validate_paradigm_combinations debug "Checking paradigms: $args"
global Paradigm
foreach paradigm $Paradigm(paradigms) {
set Paradigm(seen,$paradigm) 0
}
foreach paradigm $args {
set Paradigm(seen,$paradigm) 1
}
set Paradigm(seen,anyserver) [expr $Paradigm(seen,server) || $Paradigm(seen,semiserver)]
if {$Paradigm(seen,ioseq) && $Paradigm(seen,iopar)} {
set ok 0
set message "ILLEGAL - Mixed I/O SEQ and I/O PAR"
} else {
set ok 1
set message_list {}
if {$Paradigm(seen,iopar)} {
lappend message_list $Paradigm(paradigm_to_label,iopar)
} elseif {$Paradigm(seen,ioseq)} {
lappend message_list $Paradigm(paradigm_to_label,ioseq)
}
if {$Paradigm(seen,client) && $Paradigm(seen,anyserver)} {
lappend message_list $Paradigm(paradigm_to_label,client)-$Paradigm(paradigm_to_label,server)
} elseif {$Paradigm(seen,client)} {
lappend message_list $Paradigm(paradigm_to_label,client)
} elseif {$Paradigm(seen,server)} {
lappend message_list $Paradigm(paradigm_to_label,server)
}
Debug::puts Paradigm Paradigm::validate_paradigm_combinations debug "Message list is $message_list"
if {$message_list == ""} {
set message $Paradigm(paradigm_to_label,null)
} else {
set message [join $message_list "/"]
}
}
foreach paradigm $Paradigm(paradigms) {
unset Paradigm(seen,$paradigm)
}
unset Paradigm(seen,anyserver)
return [list $ok $message]
}
proc Paradigm::paradigms_connectable {paradigm1 paradigm2} {
if {$paradigm1 == "null" || $paradigm2 == "null"} {
return ""
}
set paradigm1_is_server [expr {$paradigm1 == "server" || $paradigm1 == "semiserver"}]
set paradigm2_is_server [expr {$paradigm2 == "server" || $paradigm2 == "semiserver"}]
if {$paradigm1_is_server && $paradigm2_is_server} {
return {Both ends are Servers}
}
if {$paradigm1 == "client" && $paradigm2 == "client"} {
return {Both ends are Clients}
}
if {$paradigm1 == "client" && $paradigm2_is_server} {
return ""
}
if {$paradigm1_is_server && $paradigm2 == "client"} {
return "reorder"
}
if {$paradigm1 == "iopar" && $paradigm2 == "ioseq"} {
return ""
}
if {$paradigm1 == "ioseq" && $paradigm2 == "iopar"} {
return ""
}
if {$paradigm1 == $paradigm2} {
return ""
}
return "Paradigms mismatch: $Paradigm(paradigm_to_label,$paradigm1) and $Paradigm(paradigm_to_label,$paradigm2)"
}
proc Paradigm::paradigms_equivalent {paradigm1 paradigm2} {
if {$paradigm1 == "null" || $paradigm2 == "null"} {
return ""
}
set paradigm1_is_server [expr {$paradigm1 == "server" || $paradigm1 == "semiserver"}]
set paradigm2_is_server [expr {$paradigm2 == "server" || $paradigm2 == "semiserver"}]
if {$paradigm1_is_server && $paradigm2_is_server} {
return ""
}
if {$paradigm1 == "iopar" && $paradigm2 == "ioseq"} {
return ""
}
if {$paradigm1 == "ioseq" && $paradigm2 == "iopar"} {
return ""
}
if {$paradigm1 == $paradigm2} {
return ""
}
return "Paradigms mismatch: $Paradigm(paradigm_to_label,$paradigm1) and $Paradigm(paradigm_to_label,$paradigm2)"
}
proc Paradigm::is_client_server {paradigm} {
return [expr {$paradigm == "client" || $paradigm == "server" || $paradigm == "semiserver"}]
}
Paradigm::init_statics
Viewable::add_type Interface {
{Name        name              string}
{Description short_description string}
{Paradigm    paradigm          string}
{Language    language          object Language}
{Version     version           string}
{Impls.      impls             method get_implementation_names}
{Parameters  params            string}
}
Debug::init Interface
proc Interface::Interface {this} {
set Interface($this,name) ""
set Interface($this,gfx_type) ""
set Interface($this,shape) ""
set Interface($this,name_position) {0.5 0.5}
set Interface($this,position) {}
set Interface($this,comms) {}
set Interface($this,params) {}
set Interface($this,impls) {}
set Interface($this,paradigm) ""
set Interface($this,description) ""
set Interface($this,short_description) ""
set Interface($this,version) 0
set Interface($this,saved_version) -1
set Interface($this,validated_version) ""
set Interface($this,modified) 0
set Interface($this,default_angle) 0
set Interface($this,language) {}
}
proc Interface::init_statics {} {
}
proc Interface::~Interface {this} {
Debug::puts Interface Interface::~Interface debug "$this"
foreach impl $Interface($this,impls) {
delete $impl
}
foreach comm $Interface($this,comms) {
delete $comm
}
if {$Interface($this,position)!=""} {
delete $Interface($this,position)
}
unset Interface($this,name) Interface($this,gfx_type) Interface($this,shape) Interface($this,name_position) Interface($this,position) Interface($this,comms) Interface($this,params) Interface($this,impls) Interface($this,paradigm) Interface($this,description) Interface($this,short_description) Interface($this,version) Interface($this,saved_version) Interface($this,validated_version) Interface($this,modified) Interface($this,default_angle) Interface($this,language)
}
proc Interface::get_object_title {this} {
return "INTERFACE $Interface($this,name)"
}
proc Interface::get_object_description {this} {
return $Interface($this,name)
}
proc Interface::save_object {this saver} {
Saver::begin $saver Interface
Saver::save_fields $saver Interface $this name gfx_type name_position validated_version version paradigm description short_description
Saver::save_field $saver language [Language::get_name $Interface($this,language)]
if {$Interface($this,position) !=""} {
Saver::begin_list $saver position
Position::save_object $Interface($this,position) $saver
Saver::end_list $saver
}
Saver::save_field $saver shape $Interface($this,shape)
Saver::begin_list $saver comms
foreach comm $Interface($this,comms) {
Comm::save_object $comm $saver
}
Saver::end_list $saver
Saver::save_field $saver params $Interface($this,params)
Saver::begin_list $saver impls
foreach impl $Interface($this,impls) {
Implementation::save_object $impl $saver
}
Saver::end_list $saver
Saver::end $saver Interface
set Interface($this,modified) 0
}
proc Interface::is_modified {this} {
return [expr $Interface($this,modified) || ($Interface($this,version) != $Interface($this,saved_version))]
}
proc Interface::load_cleanup {this parent_object parent_ref} {
}
proc Interface::loaded_cleanup {this project parent_object parent_ref} {
if {$Interface($this,language) == ""} {
if {$Interface($this,comms) != ""} {
set language [Comm::get_language [lindex $Interface($this,comms) 0]]
set Interface($this,language) [Language::get_by_name $Interface($this,language)]
} else {
set Interface($this,language) [Project::get_cur_language $project]
}
} else {
set Interface($this,language) [Language::get_by_name $Interface($this,language)]
}
foreach comm $Interface($this,comms) {
Comm::loaded_cleanup $comm $project Interface $this
}
foreach impl $Interface($this,impls) {
Implementation::loaded_cleanup $impl $project Interface $this
}
set Interface($this,saved_version) $Interface($this,version)
set Interface($this,modified) 0
if {$Interface($this,paradigm)=="" ||
$Interface($this,validated_version) != $Interface($this,version)} {
Interface::validate $this
}
}
proc Interface::get_name {this} {
return $Interface($this,name)
}
proc Interface::get_body_name {this} {
return $Interface($this,name)
}
proc Interface::get_impls {this} {
return $Interface($this,impls)
}
proc Interface::get_comms {this} {
return $Interface($this,comms)
}
proc Interface::get_shape {this} {
return $Interface($this,shape)
}
proc Interface::get_gfx_type {this} {
return $Interface($this,gfx_type)
}
proc Interface::get_description {this} {
return $Interface($this,description)
}
proc Interface::get_default_angle {this} {
return $Interface($this,default_angle)
}
proc Interface::get_position {this} {
return $Interface($this,position)
}
proc Interface::set_position {this position} {
if {$Interface($this,position) !=""} {
delete $Interface($this,position)
}
set Interface($this,position) $position
set Interface($this,modified) 1
}
proc Interface::move {this x y} {
Position::move $Interface($this,position) $x $y
set Interface($this,modified) 1
}
proc Interface::resize {this xsize ysize} {
Position::resize $Interface($this,position) $xsize $ysize
set Interface($this,modified) 1
}
proc Interface::set_description {this description} {
set Interface($this,description) $description
set Interface($this,modified) 1
}
proc Interface::get_short_description {this} {
return $Interface($this,short_description)
}
proc Interface::set_short_description {this description} {
set Interface($this,short_description) $description
set Interface($this,modified) 1
}
proc Interface::get_name_position {this} {
return $Interface($this,name_position)
}
proc Interface::set_name_position {this x y} {
set Interface($this,name_position) "$x $y"
set Interface($this,modified) 1
}
proc Interface::add_implementation {this impl} {
lappend Interface($this,impls) $impl
incr Interface($this,version)
incr Interface($this,validated_version)
}
proc Interface::delete_implementation {this impl} {
set ix [lsearch -exact $Interface($this,impls) $impl]
if {$ix >= 0} {
set Interface($this,impls) [lreplace $Interface($this,impls) $ix $ix]
Debug::puts Interface Interface::delete_implementation debug "After impls=$Interface($this,impls)"
incr Interface($this,version)
incr Interface($this,validated_version)
return 1
} else {
Debug::puts Interface Interface::delete_implementation error "Implementation $impl not in list of implementations for Interface $this"
return 0
}
}
proc Interface::add_comm {this comm} {
lappend Interface($this,comms) $comm
incr Interface($this,version)
Interface::validate $this
Project::modified_interface_major $this $comm add_comm
}
proc Interface::delete_comm {this comm} {
Debug::puts Interface Interface::delete_comm debug "Deleting $comm from list $Interface($this,comms)"
set ix [lsearch -exact $Interface($this,comms) $comm]
if {$ix >= 0} {
set Interface($this,comms) [lreplace $Interface($this,comms) $ix $ix]
Debug::puts Interface Interface::delete_comm debug "After comms=$Interface($this,comms)"
incr Interface($this,version)
Interface::validate $this
Project::modified_interface_major $this $comm delete_comm
delete $comm
return 1
} else {
Debug::puts Interface Interface::delete_comm warning "Comm $comm not in list of comms"
return 0
}
}
proc Interface::set_name {this name} {
set Interface($this,name) $name
set Interface($this,modified) 1
Project::modified_interface_major $this {} name
}
proc Interface::get_comm_names {this} {
set names {}
foreach comm $Interface($this,comms) {
lappend names [Comm::get_name $comm]
}
return $names
}
proc Interface::get_pretty_label {interface implementation add_type} {
set label ""
if {$interface != ""} {
set interface_name [Interface::get_name $interface]
set label "INTERFACE $interface_name"
if {$implementation != ""} {
set impl_type [Implementation::get_type $implementation]
set impl_name [Implementation::get_name $implementation]
if {[Implementation::is_valid_user_type $impl_type] } {
if {$impl_name == ""} {
set impl_name "?"
}
set label "IMPLEMENTATION $impl_name OF $label"
if {$add_type} {
set label "$label ($impl_type)"
}
} else {
set label "$impl_type IMPLEMENTATION OF $label"
}
}
}
return $label
}
proc Interface::init {this name language gfx_type shape impls} {
set Interface($this,name) $name
set Interface($this,language) $language
set Interface($this,gfx_type) $gfx_type
set Interface($this,shape) $shape
set Interface($this,impls) $impls
Interface::validate $this
return $this
}
proc Interface::get_implementation_names_list {this} {
set results {}
foreach impl [Interface::get_impls $this] {
lappend results [Implementation::get_label $impl]
}
return $results
}
proc Interface::get_implementation_names {this} {
return [join [Interface::get_implementation_names_list $this]]
}
proc Interface::get_implementation_by_name_type {this name type} {
foreach implementation $Interface($this,impls) {
if {[Implementation::get_name $implementation] == $name && 
[Implementation::get_type $implementation] == $type} {
Debug::puts Interface Interface::get_implementation_by_name_type debug "Found Implementation $implementation for name $name, type $type"
return $implementation
}
}
Debug::puts Interface Interface::get_implementation_by_name_type debug "Found NO Implementation for name $name, type $type"
return ""
}
proc Interface::by_name {interface1 interface2} {
return [string compare $Interface($interface1,name) $Interface($interface2,name)]
}
proc Interface::get_validated_version {this} {
return $Interface($this,validated_version)
}
proc Interface::is_validated {this} {
return [expr $Interface($this,version) == $Interface($this,validated_version)]
}
proc Interface::get_version {this} {
return "$Interface($this,version) + $Interface($this,modified)"
}
proc Interface::validate {this} {
set paradigms {}
foreach comm $Interface($this,comms) {
set paradigm [Comm::get_paradigm $comm]
lappend paradigms $paradigm
}
set answers [eval Paradigm::validate_paradigm_combinations $paradigms]
if {[lindex $answers 0]} {
set Interface($this,validated_version) $Interface($this,version)
}
set Interface($this,paradigm) [lindex $answers 1]
}
proc Interface::get_paradigm {this} {
return $Interface($this,paradigm)
}
proc Interface::comm_modified_major {this comm} {
incr Interface($this,version)
Interface::validate $this
Project::modified_interface_major $this $comm modified_comm
}
proc Interface::comm_modified_minor {this comm} {
set Interface($this,modified) 1
}
proc Interface::implementation_modified {this implementation} {
set Interface($this,modified) 1
}
proc Interface::reset_version {this} {
set Interface($this,version) 0
set Interface($this,modified) 0
}
proc Interface::rotate {this angle} {
if {$Interface($this,shape) != ""} {
set ncoords [Position::rotate_normalised_coords $angle 0.5 0.5 $Interface($this,shape)]
Debug::puts Interface Interface::rotate debug "Rotated Interface $this to new shape $ncoords"
set Interface($this,shape) $ncoords
}
foreach comm $Interface($this,comms) {
set coords [Comm::get_coords $comm]
set ncoords [Position::rotate_normalised_coords $angle 0.5 0.5 $coords]
eval Comm::set_coords $comm $ncoords
set coords [Comm::get_arrowdir $comm]
set ncoords [Position::rotate_normalised_coords $angle 0 0 $coords]
eval Comm::set_arrowdir $comm $ncoords
}
set Interface($this,name_position) [Position::rotate_normalised_coords $angle 0.5 0.5 $Interface($this,name_position)]
set position $Interface($this,position)
set sizes [Position::get_sizes $position]
set new_xsize [lindex $sizes 1]
set new_ysize [lindex $sizes 0]
Position::resize $position $new_xsize $new_ysize
Debug::puts Interface Interface::rotate debug "Resized Interface $this to $new_xsize by $new_ysize"
set Interface($this,default_angle) [expr int(fmod($Interface($this,default_angle) + $angle + 360, 360))]
set Interface($this,modified) 1
}
proc Interface::flip {this axis} {
if {$Interface($this,shape) != ""} {
set ncoords [Position::flip_normalised_coords $axis 0.5 $Interface($this,shape)]
Debug::puts Interface Interface::flip debug "Flipped Interface $this to new shape $ncoords"
set Interface($this,shape) $ncoords
}
foreach comm $Interface($this,comms) {
set coords [Comm::get_coords $comm]
set ncoords [Position::flip_normalised_coords $axis 0.5 $coords]
eval Comm::set_coords $comm $ncoords
set coords [Comm::get_arrowdir $comm]
set ncoords [Position::flip_normalised_coords $axis 0 $coords]
eval Comm::set_arrowdir $comm $ncoords
}
set Interface($this,name_position) [Position::flip_normalised_coords $axis 0.5 $Interface($this,name_position)]
set Interface($this,modified) 1
}
proc Interface::get_comm_by_name {this name} {
foreach comm $Interface($this,comms) {
if {[Comm::get_name $comm] == $name} {
return $comm
}
}
return ""
}
proc Interface::get_network_implementations {this} {
set results {}
foreach implementation $Interface($this,impls) {
if {[Implementation::get_type $implementation] == "Network"} {
lappend results $implementation
}
}
return $results
}
proc Interface::get_comm_parameters {this} {
set language $Interface($this,language)
set parameters {}
foreach comm $Interface($this,comms) {
set name [Comm::get_name $comm]
foreach {dir_label dir} [Comm::split_directions [Comm::get_direction $comm]] {
if {$dir_label != ""} {
set full_name [Language::append_words $language $name $dir_label]
} else {
set full_name $name
}
lappend parameters [Comm::chan_of_type_description $comm] $full_name
}
}
return $parameters
}
proc Interface::analyse_paradigms {this} {
set language $Interface($this,language)
foreach paradigm [Paradigm::get_paradigms] {
set seen_paradigm($paradigm) 0
}
set comms_list {}
foreach comm $Interface($this,comms) {
set name [Comm::get_name $comm]
set paradigm [Comm::get_paradigm $comm]
set direction [Comm::get_direction $comm]
foreach {dir_label dir} [Comm::split_directions $direction] {
if {$dir_label != ""} {
set full_name [Language::append_words $language $name $dir_label]
} else {
set full_name $name
}
lappend comms_list $comm $full_name $paradigm $dir
lappend uses_paradigm($paradigm) $full_name
}
incr seen_paradigm($paradigm)
}
set paradigm_use {}
foreach paradigm [Paradigm::get_paradigms] {
if {$seen_paradigm($paradigm)>0} {
lappend paradigm_use $paradigm $uses_paradigm($paradigm)
}
}
return [list $comms_list $paradigm_use]
}
proc Interface::get_printed_header {this implementation fake} {
if {$implementation != ""} {
set name [Implementation::get_proc_name $implementation]
} else {
set name $Interface($this,name)
}
set indent ""
set output ""
set language $Interface($this,language)
set maybe_define_types [Interface::get_type_details $this]
foreach {contents contents_name include_file} $maybe_define_types {
if {[info exists seen_includes($include_file)]} {
continue
}
lappend include_files $include_file
lappend included_files $include_file
set seen_includes($include_file) 1
set including_file($include_file) 1
}
set define_types {}
set define_types_count 0
foreach {contents contents_name include_file} $maybe_define_types {
if {![info exists including_file($include_file)]} {
continue
}
lappend define_types $contents $contents_name $include_file
incr define_types_count
}
if {$define_types_count >0} {
set include_files_list [Implementation::invert_type_name_file_list $define_types]
append output "$indent[Language::start_folded_block $language "Includes" $fake]\n"
append output [Language::call_include_files $language $indent $include_files_list $fake]
append output "$indent[Language::end_folded_block $language $fake]\n"
}
set comm_parameters [Interface::get_comm_parameters $this]
append output "[Language::get_proc_header_start $language $indent $name $comm_parameters]\n"
set paradigm_analysis [Interface::analyse_paradigms $this]
set comms_list [lindex $paradigm_analysis 0]
set paradigm_use [lindex $paradigm_analysis 1]
foreach {paradigm paradigm_used} $paradigm_use {
set label "Paradigm [Paradigm::get_label $paradigm]: "
append label [join $paradigm_used ", "]
append output  "  $indent[Language::comment_line $language $label]"
}
if {$implementation != "" && 
[Implementation::get_type $implementation] == "Skeleton"} {
append output [Implementation::get_skeleton_implementation_body $implementation "  $indent" $language {} {} $comms_list $paradigm_use $fake]
} else {
append output "  $indent[Language::get_proc_dummy_body $language $fake]"
}
append output "$indent[Language::get_proc_header_end $language $name]\n"
return $output
}
proc Interface::get_language {this} {
return $Interface($this,language)
}
proc Interface::get_type_details {this} {
set results {}
foreach comm $Interface($this,comms) {
foreach {contents contents_name include_file} [Comm::get_type_details $comm] {
if {[info exists seen($contents,$contents_name,$include_file)]} {
continue
}
set seen($contents,$contents_name,$include_file) 1
lappend results $contents $contents_name $include_file
}
}
return $results
}
Interface::init_statics
Viewable::add_type Implementation {
{Name         name              string}
{Description  short_description string}
{Paradigm     paradigm          method get_paradigm}
{Interface    interface         object Interface}
{{Impl. Type} type              string}
{Filename     file              string}
}
Debug::init Implementation
proc Implementation::Implementation {this}  {
set Implementation($this,interface) ""
set Implementation($this,name) ""
set Implementation($this,name_position) ""
set Implementation($this,type) ""
set Implementation($this,file) ""
set Implementation($this,nodes) {}
set Implementation($this,arcs) {}
set Implementation($this,network_box_position) {}
set Implementation($this,description) ""
set Implementation($this,short_description) ""
}
proc Implementation::~Implementation {this} {
Debug::puts Implementation Implementation::~Implementation debug "$this"
foreach node $Implementation($this,nodes) {
delete $node
}
foreach arc $Implementation($this,arcs) {
delete $arc
}
unset Implementation($this,interface) Implementation($this,name) Implementation($this,name_position) Implementation($this,type) Implementation($this,file) Implementation($this,nodes) Implementation($this,arcs) Implementation($this,network_box_position) Implementation($this,description) Implementation($this,short_description)
}
proc Implementation::init {this interface name type}  {
set Implementation($this,interface) $interface
set Implementation($this,name) $name
set Implementation($this,name_position) [Interface::get_name_position $interface]
set Implementation($this,type) $type
return $this
}
proc Implementation::get_object_title {this} {
if {$Implementation($this,name) !=""} {
return "IMPLEMENTATION $Implementation($this,name)"
}
return "$Implementation($this,type) IMPLEMENTATION"
}
proc Implementation::get_object_description {this} {
return [Implementation::get_object_title $this]
}
proc Implementation::save_object {this saver} {
Saver::begin $saver Implementation
Saver::save_fields $saver Implementation $this name name_position type file
if {$Implementation($this,network_box_position) !=""} {
Saver::begin_list $saver network_box_position
Position::save_object $Implementation($this,network_box_position) $saver
Saver::end_list $saver
}
Saver::begin_list $saver nodes
foreach node $Implementation($this,nodes) {
Node::save_object $node $saver
}
Saver::end_list $saver
Saver::begin_list $saver arcs
foreach arc $Implementation($this,arcs) {
Arc::save_object $arc $saver
}
Saver::end_list $saver
Saver::save_fields $saver Implementation $this description short_description
Saver::end $saver Implementation
}
proc Implementation::load_cleanup {this parent_object parent_ref} {
set Implementation($this,interface) $parent_ref
}
proc Implementation::loaded_cleanup {this project parent_object parent_ref} {
if {$Implementation($this,network_box_position) != ""} {
Position::move $Implementation($this,network_box_position) 0 0
}
foreach node $Implementation($this,nodes) {
Node::loaded_cleanup $node $project Implementation $this
}
foreach arc $Implementation($this,arcs) {
Arc::loaded_cleanup $arc $project Implementation $this
}
}
proc Implementation::init_statics {} {
set Implementation(types) {
Null     0 "<Null>"
Skeleton 0 "<Skeleton>"
Network  1 "Network"
File     1 "File"
}
set Implementation(valid_types) {}
set Implementation(valid_user_types) {}
foreach {type is_user_type label} $Implementation(types) {
lappend Implementation(valid_types) $type
set Implementation(is_valid_user_type,$type) $is_user_type
if {$is_user_type} {
lappend Implementation(valid_user_types) $type
}
set Implementation(type_to_label,$type) $label
}
}
proc Implementation::get_valid_user_types {} {
return $Implementation(valid_user_types)
}
proc Implementation::is_valid_user_type {type} {
return $Implementation(is_valid_user_type,$type)
}
proc Implementation::format_type {type} {
return $Implementation(type_to_label,$type)
}
proc Implementation::get_name {this} {
return $Implementation($this,name)
}
proc Implementation::get_body_name {this} {
if {$Implementation($this,name)!=""} {
return $Implementation($this,name)
}
set name [Interface::get_name $Implementation($this,interface)]
if {[Options::get show_node_type_in_net_window]} {
return "$Implementation($this,type)\n$name"
} else {
return $name
}
}
proc Implementation::get_proc_name {this} {
if {$Implementation($this,name)!=""} {
return $Implementation($this,name)
}
set language [Interface::get_language $Implementation($this,interface)]
return [Language::append_words $language [Interface::get_name $Implementation($this,interface)] $Implementation($this,type)]
}
proc Implementation::get_type {this} {
return $Implementation($this,type)
}
proc Implementation::get_interface {this} {
return $Implementation($this,interface)
}
proc Implementation::set_name {this name} {
set Implementation($this,name) $name
Project::implementation_change $Implementation($this,interface) $this name
}
proc Implementation::get_description {this} {
return $Implementation($this,description)
}
proc Implementation::set_description {this description} {
set Implementation($this,description) $description
}
proc Implementation::get_short_description {this} {
return $Implementation($this,short_description)
}
proc Implementation::set_short_description {this description} {
set Implementation($this,short_description) $description
}
proc Implementation::get_name_position {this} {
return $Implementation($this,name_position)
}
proc Implementation::set_name_position {this x y} {
set Implementation($this,name_position) "$x $y"
}
proc Implementation::get_network_box_position {this} {
return $Implementation($this,network_box_position)
}
proc Implementation::set_network_box_position {this position} {
set Implementation($this,network_box_position) $position
foreach node $Implementation($this,nodes) {
Node::update $node
}
}
proc Implementation::get_label {this} {
if {$Implementation($this,name) !=""} {
return $Implementation($this,name)
}
set format_type [Implementation::format_type $Implementation($this,type)]
if {[Implementation::is_valid_user_type $Implementation($this,type)]} {
return "? ($format_type)"
}
return $format_type
}
proc Implementation::is_user_implementation {this} {
return $Implementation(is_valid_user_type,$Implementation($this,type))
}
proc Implementation::add_node {this node} {
set ix [lsearch -exact $Implementation($this,nodes) -]
if {$ix >= 0} {
set Implementation($this,nodes) [lreplace $Implementation($this,nodes) $ix $ix $node]
incr ix
} else {
lappend Implementation($this,nodes) $node
set ix [llength $Implementation($this,nodes)]
}
Node::set_index $node $ix
}
proc Implementation::delete_node {this node} {
set ix [lsearch -exact $Implementation($this,nodes) $node]
if {$ix <0} {
return {}
}
set moves {}
set nodes $Implementation($this,nodes)
set len [llength $nodes]
set last_ix [expr $len - 1]
if {$len == 1} {
set nodes {}
} elseif {$ix == $last_ix} {
set nodes [lreplace $nodes $ix $ix]
} else {
set moving_node [lindex $nodes $last_ix]
set nodes [lreplace $nodes $last_ix $last_ix]
set nodes [lreplace $nodes $ix $ix $moving_node]
incr last_ix
incr ix
Node::set_index $moving_node $ix
Debug::puts Implementation Implementation::delete_node debug "Moved Node $moving_node from $last_ix to $ix"
set moves "$last_ix $ix"
}
set Implementation($this,nodes) $nodes
Debug::puts Implementation Implementation::delete_node debug "Node list now $nodes"
return $moves
}
proc Implementation::get_nodes {this} {
return [lallbut $Implementation($this,nodes) -]
}
proc Implementation::add_arc {this node} {
lappend Implementation($this,arcs) $node
}
proc Implementation::delete_arc {this arc} {
set ix [lsearch -exact $Implementation($this,arcs) $arc]
if {$ix >= 0} {
set Implementation($this,arcs) [lreplace $Implementation($this,arcs) $ix $ix]
return 1
} else {
return 0
}
}
proc Implementation::get_arcs {this} {
return $Implementation($this,arcs)
}
proc Implementation::get_node_index {this this_node} {
set i 1
foreach node $Implementation($this,nodes) {
if {$node == $this_node} {
return $i
}
incr i
}
return ""
}
proc Implementation::get_node_by_index {this index} {
return [lindex $Implementation($this,nodes) [expr $index -1]]
}
proc Implementation::get_arcs_for_node {this node} {
set result {}
foreach arc $Implementation($this,arcs) {
if {[Arc::attached_to_node $arc $node]} {
lappend result $arc
}
}
return $result
}
proc Implementation::get_arc_by_node_comm {this node comm} {
foreach arc $Implementation($this,arcs) {
if {[Arc::attached_to_node_comm $arc $node $comm]} {
return $arc
}
}
return ""
}
proc Implementation::get_paradigm {this} {
return [Interface::get_paradigm $Implementation($this,interface)]
}
proc Implementation::is_complete {this} {
if {!$Implementation(is_valid_user_type,$Implementation($this,type))} {
return 1
}
set interface_complete [Interface::is_validated $Implementation($this,interface)]
switch $Implementation($this,type) {
File {
return $interface_complete
}
Network {
foreach arc $Implementation($this,arcs) {
foreach {node comm} [Arc::get_all_details $arc] {
if {$node != 0} {
set ImplementationConnected($node,$comm) 1
}
}
}
foreach node $Implementation($this,nodes) {
if {![Node::is_validated $node]} {
unset ImplementationConnected
return 0
}
foreach comm [Node::get_comms $node] {
if {![info exists ImplementationConnected($node,$comm)]} {
unset ImplementationConnected
return 0
}
}
}
}
}
unset ImplementationConnected
return 1
}
proc Implementation::get_nodes_by_interface {this interface} {
set nodes {}
foreach node $Implementation($this,nodes) {
if {[Node::get_interface $node] == $interface} {
lappend nodes $node
}
}
return $nodes
}
proc Implementation::interface_change {this interface comm what} {
Debug::puts Implementation Implementation::interface_change debug "Interface $interface (Comm $comm) - $what"
foreach node $Implementation($this,nodes) {
if {[Node::get_interface $node] == $interface} {
Debug::puts Implementation Implementation::node_interface_change debug "Node $node has Interface $interface"
if {$comm == ""} {
switch $what {
deleted {
foreach arc [Implementation::get_arcs_for_node $this $node] {
Implementation::delete_arc $this $arc
delete $arc
}
Implementation::delete_node $this $node
delete $node
}
name {
}	    
default {
Debug::puts Implementation Implementation::node_interface_change error "Unknown change $what (body)"
return
}
}
} else {
switch $what {
add_comm {
}
delete_comm -
modified_comm {
foreach arc [Implementation::get_arc_by_node_comm $this $node $comm] {
Implementation::delete_arc $this $arc
delete $arc
}
}
default {
Debug::puts Implementation Implementation::node_interface_change error "Unknown change $what"
return
}
}
}
}
}
}
proc Implementation::implementation_change {this interface implementation what} {
Debug::puts Implementation Implementation::implementation_change debug "Implementation $implementation of Interface $interface - $what"
foreach node $Implementation($this,nodes) {
if {[Node::get_interface $node] == $interface && 
[Node::get_implementation $node] == $implementation} {
Debug::puts Implementation Implementation::implementation_change debug "Node $node has Interface $interface, Implementation $implementation"
switch $what {
deleted {
foreach arc [Implementation::get_arcs_for_node $this $node] {
Implementation::delete_arc $this $arc
delete $arc
}
Implementation::delete_node $this $node
delete $node
}
name {
}
default {
Debug::puts Implementation Implementation::implementation_change error "Unknown change $what"
return
}
}
}
}
}
proc Implementation::invert_type_name_file_list {types} {
set results {}
foreach {contents contents_name include_file} $types {
lappend type_names($include_file) $contents $contents_name
}
foreach include_file [array names type_names] {
lappend results $include_file [list $type_names($include_file)]
}
return $results
}
proc Implementation::get_node_used_types {this} {
set type $Implementation($this,type)
if {$type != "Network" ||
($type == "Network" && $Implementation($this,nodes) == "")} {
return {}
}
set types {}
foreach node $Implementation($this,nodes) {
set node_interface [Node::get_interface $node]
set node_implementation [Node::get_implementation $node]
if {[info exists seen_impls($node_implementation)]} {
continue
}
set seen_impls($node_implementation) 1
foreach {contents contents_name include_file} [Interface::get_type_details $node_interface] {
if {[info exists seen_types($contents,$contents_name,$include_file)]} {
continue
}
set seen_types($contents,$contents_name,$include_file) 1
lappend types $contents $contents_name $include_file
}
}
return $types
}
proc Implementation::get_node_used_implementations {this recurse} {
Debug::puts Implementation Implementation::get_node_used_implementations debug "For $this, recursion=$recurse"
set type $Implementation($this,type)
if {$type != "Network" ||
($type == "Network" && $Implementation($this,nodes) == "")} {
Debug::puts Implementation Implementation::get_node_used_implementations debug "Not network, returning empty list"
return {}
}
set impls {}
set seen_impls($this) 1
foreach node $Implementation($this,nodes) {
set node_implementation [Node::get_implementation $node]
if {[info exists seen_impls($node_implementation)]} {
continue
}
set seen_impls($node_implementation) 1
lappend impls $node_implementation
if {$recurse} {
foreach sub_impl [Implementation::get_node_used_implementations $node_implementation 0] {
if {[info exists seen_impls($sub_impl)]} {
continue
}
set seen_impls($sub_impl) 1
lappend impls $sub_impl
}
}
}
if {!$recurse} {
Debug::puts Implementation Implementation::get_node_used_implementations debug "For $this, not recursing, returning $impls"
return $impls
}
set found_new 1
while {$found_new} {
set found_new 0
foreach impl $impls {
foreach sub_impl [Implementation::get_node_used_implementations $impl 0] {
if {[info exists seen_impls($sub_impl)]} {
continue
}
set seen_impls($sub_impl) 1
lappend impls $sub_impl
set found_new 1
}
}
}
Debug::puts Implementation Implementation::get_node_used_implementations debug "For $this, recursed, found $impls"
return $impls
}
proc Implementation::order_implementations {impls} {
Debug::puts Implementation Implementation::order_implementations debug "For Implementations $impls"
if {[llength $impls] <2} {
return $impls
}
foreach impl $impls { 
set this_impl_uses [Implementation::get_node_used_implementations $impl 1]
set impl_uses($impl) $this_impl_uses
}
set ordered_impls {}
while {$impls != ""} {
set new_impls {}
foreach impl $impls {
if {$impl_uses($impl) == ""} {
lappend ordered_impls $impl
foreach impl2 $impls {
set ix [lsearch -exact $impl_uses($impl2) $impl]
if {$ix >= 0} {
set impl_uses($impl2) [lreplace $impl_uses($impl2) $ix $ix]
}
}
} else {
lappend new_impls $impl
}
}
set impls $new_impls
}
Debug::puts Implementation Implementation::order_implementations debug "New order: $ordered_impls"
return $ordered_impls
}
proc Implementation::get_network_implementation_body {this indent language included_files declared_impls fake} {
Debug::puts Implementation Implementation::get_network_implementation_body debug "Indent='$indent' Language=$language Included files=$included_files Declared Impls=$declared_impls Fake=$fake"
set nodes_count [llength $Implementation($this,nodes)]
if {$nodes_count == 0} {
return "$indent[Language::get_null_body $language]\n"
}
foreach include_file $included_files {
set seen_includes($include_file) 1
}
foreach impl $declared_impls {
set is_declared_impl($impl) 1
}
set sub_impls [Implementation::get_node_used_implementations $this 0]
set all_sub_impls [Implementation::get_node_used_implementations $this 1]
foreach impl $all_sub_impls {
set impl_count($impl) 0
}
set define_impls {}
foreach impl $all_sub_impls {
if {![info exists is_declared_impl($impl)]  &&
![info exists is_defined_here($impl)]} {
lappend define_impls $impl
set is_defined_here($impl) 1
}
}
set maybe_define_types {}
foreach {contents contents_name include_file} [Implementation::get_node_used_types $this] {
lappend maybe_define_types $contents $contents_name $include_file
}
foreach impl $define_impls {
foreach {contents contents_name include_file} [Implementation::get_node_used_types $impl] {
lappend maybe_define_types $contents $contents_name $include_file
}
lappend declared_impls $impl
}
set define_types {}
set define_types_count 0
set include_files {}
foreach {contents contents_name include_file} $maybe_define_types {
if {[info exists seen_includes($include_file)]} {
continue
}
lappend include_files $include_file
lappend included_files $include_file
set seen_includes($include_file) 1
set including_file($include_file) 1
}
foreach {contents contents_name include_file} $maybe_define_types {
if {![info exists including_file($include_file)]} {
continue
}
if {[info exists seen_types($contents,$contents_name,$include_file)]} {
continue
}
set seen_types($contents,$contents_name,$include_file) 1
lappend define_types $contents $contents_name $include_file
incr define_types_count
}
if {$define_types_count >0} {
set include_files_list [Implementation::invert_type_name_file_list $define_types]
append output "$indent[Language::start_folded_block $language "Includes" $fake]\n"
append output [Language::call_include_files $language $indent $include_files_list $fake]
append output "$indent[Language::end_folded_block $language $fake]\n"
}
if {$define_impls != ""} {
set ordered_impls [Implementation::order_implementations $define_impls]
foreach impl $ordered_impls {
set name [Implementation::get_proc_name $impl]
set label [Language::get_proc_header_short $language $name]
Debug::puts Implementation Implementation::get_network_implementation_body debug "Defining $label"
append output "$indent[Language::start_folded_block $language $label $fake]\n"
append output [Implementation::get_proc_body $impl $indent $included_files $declared_impls $fake]
append output "$indent[Language::end_folded_block $language $fake]\n"
}
}
set need_par 0
if {[llength $Implementation($this,nodes)] >1} {
set arc_count 0
set channel_decls {}
foreach arc $Implementation($this,arcs) {
set is_edge_arc [Arc::is_at_edge $arc]
if {$is_edge_arc} {
set name [Arc::get_edge_name $arc]
} else {
set name [Language::append_words $language "arc" $arc_count]
incr arc_count
}
set data_type [Arc::get_data_type $arc]
set details [Arc::get_all_details $arc]
set direction [Arc::get_direction $arc]
Debug::puts Implementation Implementation::get_network_implementation_body debug "Found Arc $arc ($arc_count) - name $name, type $data_type, details $details, direction $direction"
foreach {dir_label dir} [Comm::split_directions $direction] {
if {$dir_label != ""} {
set full_name [Language::append_words $language $name $dir_label]
} else {
set full_name $name
}
foreach {node comm} $details {
set node_comm_to_arc_name($node,$comm$dir_label) $full_name
}
if {!$is_edge_arc} {
lappend channel_decls $data_type $full_name
}
}
}
if {$arc_count >0} {
append output "$indent[Language::start_folded_block $language {Channel declarations} $fake]\n"
append output "[Language::declare_channels $language $indent $channel_decls]\n"
append output "$indent[Language::end_folded_block $language $fake]\n"
}
set need_par 1
}
set original_indent $indent
if {$need_par} {
append output "$indent[Language::begin_par_block $language]\n"
append indent "  "
}
foreach node $Implementation($this,nodes) {
set node_interface [Node::get_interface $node]
set node_implementation [Node::get_implementation $node]
set name [Implementation::get_proc_name $node_implementation]
Debug::puts Implementation Implementation::get_network_implementation_body debug "Found Node $node - name $name"
set names {}
foreach comm [Node::get_comms $node] {
foreach {dir_label dir} [Comm::get_directions $comm] {
if {[info exists node_comm_to_arc_name($node,$comm$dir_label)]} {
lappend names $node_comm_to_arc_name($node,$comm$dir_label)
} else {
lappend names "<missing>"
}
}
}
append output "[Language::call_process $language $indent $name $names]\n"
}
if {$need_par} {
set str [Language::end_par_block $language]
set indent $original_indent
if {$str != ""} {
append output "$indent$str\n"
}
}
return $output
}
proc Implementation::get_skeleton_implementation_body {this indent language included_files declared_impls comms_list paradigm_use fake} {
Debug::puts Implementation Implementation::get_skeleton_implementation_body debug "Indent='$indent' Language=$language Included files=$included_files Declared Impls=$declared_impls Fake=$fake"
foreach paradigm [Paradigm::get_paradigms] {
set seen_paradigm($paradigm) 0
}
set seen_paradigm(anyserver) 0
set paradigm_count 0
set paradigms_used_here {}
foreach {paradigm used_list} $paradigm_use {
if {$paradigm == "server" || $paradigm == "semiserver"} {
set paradigm "anyserver"
}
lappend uses_paradigm($paradigm) $used_list
incr seen_paradigm($paradigm) [llength $used_list]
incr paradigm_count
lappend paradigms_used_here $paradigm
}
foreach {comm full_name paradigm direction} $comms_list {
set comms_details($full_name) [list $comm $paradigm $direction]
}
set output ""
if {$paradigm_count == 1} {
set label "Pure [Paradigm::get_label $paradigm] paradigm"
append output "$indent[Language::comment_line $language $label]"
if {$seen_paradigm(null)} {
append output "$indent[Language::get_null_body $language]\n"
} elseif {$seen_paradigm(ioseq)} {
append output [Language::get_pure_ioseq_body $language $indent $comms_list $fake]
} elseif {$seen_paradigm(iopar)} {
append output [Language::get_pure_iopar_body $language $indent $comms_list $fake]
} elseif {$seen_paradigm(client)} {
append output [Language::get_pure_client_body $language $indent $comms_list $fake]
} elseif {$seen_paradigm(anyserver)} {
append output [Language::get_pure_server_body $language $indent $comms_list $fake]
}
return $output
}
if {$paradigm_count == 2} {
if {$seen_paradigm(client) && $seen_paradigm(anyserver)} {
set label "Client-Server paradigm"
append output "$indent[Language::comment_line $language $label]"
append output [Language::get_client_server_body $language $indent $comms_list $fake]
return $output
}
}
set label "Multiple paradigm skeleton code not yet written ($paradigms_used_here)"
append output "$indent[Language::get_null_body $language] [Language::comment_line $language $label]"
return $output
}
proc Implementation::get_proc_body {this indent included_files declared_impls fake} {
set interface $Implementation($this,interface)
set language [Interface::get_language $interface]
set name [Implementation::get_proc_name $this]
set original_indent $indent
foreach include_file $included_files {
set seen_includes($include_file) 1
}
set maybe_define_types [Interface::get_type_details $interface]
set include_files {}
foreach {contents contents_name include_file} $maybe_define_types {
if {[info exists seen_includes($include_file)]} {
continue
}
lappend include_files $include_file
lappend included_files $include_file
set seen_includes($include_file) 1
set including_file($include_file) 1
}
set define_types {}
set define_types_count 0
foreach {contents contents_name include_file} $maybe_define_types {
if {![info exists including_file($include_file)]} {
continue
}
if {[info exists seen_types($contents,$contents_name,$include_file)]} {
continue
}
set seen_types($contents,$contents_name,$include_file) 1
lappend define_types $contents $contents_name $include_file
incr define_types_count
}
if {$define_types_count >0} {
set include_files_list [Implementation::invert_type_name_file_list $define_types]
append output "$indent[Language::start_folded_block $language "Includes" $fake]\n"
append output [Language::call_include_files $language $indent $include_files_list $fake]
append output "$indent[Language::end_folded_block $language $fake]\n"
}
set comm_parameters [Interface::get_comm_parameters $interface]
append output "[Language::get_proc_header_start $language $indent $name $comm_parameters]\n"
append indent "  "
append output "$indent[Language::start_folded_block $language body $fake]\n"
set paradigm_analysis [Interface::analyse_paradigms $interface]
set comms_list [lindex $paradigm_analysis 0]
set paradigm_use [lindex $paradigm_analysis 1]
foreach {paradigm paradigm_used} $paradigm_use {
set label "Paradigm [Paradigm::get_label $paradigm]: "
append label [join $paradigm_used ", "]
append output  "$indent[Language::comment_line $language $label]"
}
switch $Implementation($this,type) {
Null {
append output "$indent[Language::get_null_body $language]\n"
}
Network {
append output [Implementation::get_network_implementation_body $this $indent $language $included_files $declared_impls $fake]
}
Skeleton {
append output [Implementation::get_skeleton_implementation_body $this $indent $language $included_files $declared_impls $comms_list $paradigm_use $fake]
}
default {
append output "$indent[Language::get_null_body $language] "
append output [Language::comment_line $language "$Implementation($this,type) Implementation not implemented"]
}
}
append output "$indent[Language::end_folded_block $language $fake]\n"
append output "$original_indent[Language::get_proc_header_end $language $name]\n"
return $output
}
proc Implementation::get_printed_body {this name fake} {
set interface $Implementation($this,interface)
set language [Interface::get_language $interface]
set odt_version [Project::get_version]
set output [Language::comment_line $language "ODT $odt_version code output for $name"]
append output [Implementation::get_proc_body $this "" {} {} $fake]
return $output
}
Implementation::init_statics
Viewable::add_type Instance {
{Interface      interface      object Interface}
{Implementation implementation object Implementation}
{Description    ""             method get_description}
}
Debug::init Instance
proc Instance::Instance {this type interface implementation canvas showable show main_showable comm_showable implementation_change_parts arrow_length} {
set Instance($this,type) $type
set Instance($this,interface) $interface
set Instance($this,implementation) $implementation
set Instance($this,canvas) $canvas
set Instance($this,showable) $showable
Instance::set_show_value $this $show
set Instance($this,comm_showable) $comm_showable
set Instance($this,implementation_change_parts) $implementation_change_parts
set Instance($this,drawn) {}
foreach part $main_showable {
Instance::add_part $this $part {} {} {}
}
foreach comm [Interface::get_comms $Instance($this,interface)] {
Instance::add_comm_fields $this $comm
}
set Instance($this,updated) {}
if {$arrow_length == ""} {
set arrow_length $Instance(default_arrow_length)
}
set Instance($this,arrow_length) $arrow_length
Instance::update $this
}
proc Instance::~Instance {this} {
Instance::undraw $this
}
proc Instance::init_statics {} {
set Instance(default_arrow_length) 50
set Instance(default_border_width) 3
}
proc Instance::get_what_ref {this} {
if {$Instance($this,implementation)!=""} {
return [list Implementation $Instance($this,implementation) IMPLEMENTATION]
}
return [list Interface $Instance($this,interface) INTERFACE]
}
proc Instance::get_object_description {this} {
return [Instance::get_label $this]
}
proc Instance::get_object_part_ref {this part part_ref subpart_ref} {
switch -glob $part {
comm/* {
return "Comm $part_ref"
}
node/main/* {
return "Implementation [Node::get_implementation $part_ref]"
}
node/* {
return "Comm $subpart_ref"
}
arc/* {
return "Arc $part_ref"
}
main/* -
default {
return [Instance::get_what_ref $this]
}
}
}
proc Instance::get_interface {this} {
return $Instance($this,interface)
}
proc Instance::get_implementation {this} {
return $Instance($this,implementation)
}
virtual proc Instance::get_position {this part part_ref subpart_ref} {}
virtual proc Instance::get_shape {this part part_ref subpart_ref} {
return [Interface::get_shape $Instance($this,interface)]
}
virtual proc Instance::get_gfx_type {this part part_ref subpart_ref} {
return [Interface::get_gfx_type $Instance($this,interface)]
}
virtual proc Instance::get_part_tags {this part part_ref subpart_ref} {
set instance_type $Instance($this,type)
return [list $instance_type $this $part $part_ref $subpart_ref clickable selectable]
}
virtual proc Instance::get_plug_coords {this part part_ref subpart_ref} {
return [Comm::get_coords $part_ref]
}
virtual proc Instance::get_arrowdir {this part part_ref subpart_ref} {
return [Comm::get_arrowdir $part_ref]
}
virtual proc Instance::move {this x y} {}
virtual proc Instance::resize {this xsize ysize} {} 
proc Instance::set_show_value {this show} {
set Instance($this,show) $show
foreach part $Instance($this,showable) {
set Instance($this,show_part,$part) [expr [lsearch -exact $show $part]>=0]
}
}
proc Instance::get_show {this} {
return $Instance($this,show)
}
proc Instance::set_show {this new_show} {
Debug::puts Instance Instance::set_show debug "Show=$new_show"
Instance::set_show_value $this $new_show
set newdrawn {}
foreach {part part_ref subpart_ref gfx_ref show} $Instance($this,drawn) {
lappend newdrawn $part $part_ref $subpart_ref $gfx_ref $Instance($this,show_part,$part)
}
set Instance($this,drawn) $newdrawn
Debug::puts Instance Instance::set_show debug "Draw state is now $Instance($this,drawn)"
Instance::update $this
}
proc Instance::set_implementation {this implementation} {
set Instance($this,implementation) $implementation
if {$Instance($this,implementation_change_parts) !=""} {
eval Instance::add_updated_parts $this $Instance($this,implementation_change_parts)
Instance::update $this
}
}
proc Instance::undraw {this} {
set newdrawn {}
foreach {part part_ref subpart_ref gfx_ref show} $Instance($this,drawn) {
if {$gfx_ref !=""} {
delete $gfx_ref
}
lappend newdrawn $part $part_ref $subpart_ref "" $show
}
set Instance($this,drawn) $newdrawn
Debug::puts Instance Instance::undraw debug "Draw state is now $Instance($this,drawn)"
}
proc Instance::undraw_part {this part part_ref subpart_ref} {
Debug::puts Instance Instance::undraw_part debug "Part=$part ($part_ref,$subpart_ref)"
set gfx_ref [Instance::get_gfx_for_part $this $part $part_ref $subpart_ref]
Debug::puts Instance Instance::undraw_part debug "Undrawing part $part ($part_ref,$subpart_ref) Gfx=$gfx_ref"
Instance::undraw_part_gfx $this $part $part_ref $subpart_ref $gfx_ref
}
proc Instance::undraw_part_gfx {this part part_ref subpart_ref gfx_ref} {
Debug::puts Instance Instance::undraw_part_gfx debug "part=$part ($part_ref,$subpart_ref) Gfx=$gfx_ref"
delete $gfx_ref
Instance::set_gfx_for_part $this $part $part_ref $subpart_ref ""
}
proc Instance::add_part {this part part_ref subpart_ref gfx_ref} {
lappend Instance($this,drawn) $part $part_ref $subpart_ref $gfx_ref $Instance($this,show_part,$part)
Debug::puts Instance Instance::add_part debug "Draw state is now $Instance($this,drawn)"
}
proc Instance::delete_part {this this_part this_part_ref this_subpart_ref gfx_ref} {
set newdrawn {}
foreach {part part_ref subpart_ref gfx_ref show} $Instance($this,drawn) {
if {$part == $this_part && $part_ref == $this_part_ref && $subpart_ref == $this_subpart_ref} {
if {$gfx_ref != ""} {
delete $gfx_ref
}
} else {
lappend newdrawn $part $part_ref $subpart_ref $gfx_ref $show
}
}
set Instance($this,drawn) $newdrawn
Debug::puts Instance Instance::delete_part debug "Draw state is now $Instance($this,drawn)"
}
proc Instance::set_gfx_for_part {this this_part this_part_ref this_subpart_ref this_gfx_ref} {
Debug::puts Instance Instance::set_gfx_for_part debug "Gfx for part $this_part ($this_part_ref,$this_subpart_ref) is $this_gfx_ref"
set newdrawn {}
foreach {part part_ref subpart_ref gfx_ref show} $Instance($this,drawn) {
if {$part == $this_part &&
$part_ref == $this_part_ref &&
$subpart_ref == $this_subpart_ref} {
set gfx_ref $this_gfx_ref
}
lappend newdrawn $part $part_ref $subpart_ref $gfx_ref $show
}
set Instance($this,drawn) $newdrawn
Debug::puts Instance Instance::set_gfx_for_part debug "Draw state is now $Instance($this,drawn)"
}
proc Instance::get_gfx_for_part {this this_part this_part_ref this_subpart_ref} {
Debug::puts Instance Instance::get_gfx_for_part debug "Looking for part $this_part ($this_part_ref,$this_subpart_ref)"
foreach {part part_ref subpart_ref gfx_ref show} $Instance($this,drawn) {
if {[string match $this_part $part] && $part_ref == $this_part_ref && $subpart_ref == $this_subpart_ref} {
return $gfx_ref
}
}
Debug::puts Instance Instance::get_gfx_for_part debug "For path $this_part ($this_part_ref,$this_subpart_ref) returing Gfx ref $gfx_ref"
return ""
}
proc Instance::draw_part_gfx {this part part_ref subpart_ref gfx_ref} {
Debug::puts Instance Instance::draw_part_gfx debug "Part $part ($part_ref,$subpart_ref) Gfx $gfx_ref"
set old_gfx_ref $gfx_ref
set position [Instance::get_position $this $part $part_ref $subpart_ref]
set shape [Instance::get_shape $this $part $part_ref $subpart_ref]
set gfx_type [Instance::get_gfx_type $this $part $part_ref $subpart_ref]
set tags [Instance::get_part_tags $this $part $part_ref $subpart_ref]
switch $part {
main/body -
node/main/body {
if {$gfx_ref==""} {
Debug::puts Instance Instance::draw_part_gfx debug "Drawing new $part"
set gfx_ref [eval new [concat [list $gfx_type $Instance($this,canvas) [Colour::get_bg] [Colour::get_fg] $shape] $position $tags]]
} else {
Debug::puts Instance Instance::draw_part_gfx debug "Updating $part"
Gfx::set_shape $gfx_ref $shape
}
}
main/border -
node/main/border {
if {$gfx_ref==""} {
Debug::puts Instance Instance::draw_part_gfx debug "Drawing new $part"
set gfx_ref [eval new [concat [list $gfx_type $Instance($this,canvas) {} [Colour::get_fg] $shape $position] $tags]]
Gfx::set_width $gfx_ref $Instance(default_border_width)
} else {
Debug::puts Instance Instance::draw_part_gfx debug "Updating $part"
Gfx::set_shape $gfx_ref $shape
}
}
comm/plug -
node/comm/plug {
if {$part == "node/comm/plug"} {
set comm $subpart_ref
} else {
set comm $part_ref
}
if {$comm ==""} {
Debug::puts Instance Instance::draw_part_gfx warning "Part $part - null comm - ignoring"
return
}
set coords [Instance::get_plug_coords $this $part $part_ref $subpart_ref]
if {$gfx_ref ==""} {
Debug::puts Instance Instance::draw_part_gfx debug "Drawing new $part, comm=$comm"
set gfx_ref [eval new [concat Plug $Instance($this,canvas) $coords $position] $tags]
} else {
Debug::puts Instance Instance::draw_part_gfx debug "Updating $part comm=$comm"
eval Gfx::set_other_coords $gfx_ref $coords
}
}
comm/arrow -
node/comm/arrow {
if {$part == "node/comm/arrow"} {
set comm $subpart_ref
} else {
set comm $part_ref
}
if {$comm ==""} {
Debug::puts Instance Instance::draw_part_gfx warning "Part $part - null comm - ignoring"
return
}
set coords [eval Position::normalised_to_screen $position [Instance::get_plug_coords $this $part $part_ref $subpart_ref]]
set x [lindex $coords 0]
set y [lindex $coords 1]
set arrowdir [Instance::get_arrowdir $this $part $part_ref $subpart_ref]
set arrowx [expr $x + ([lindex $arrowdir 0] * $Instance($this,arrow_length))]
set arrowy [expr $y + ([lindex $arrowdir 1] * $Instance($this,arrow_length))]
set head [Comm::get_head $comm]
if {$gfx_ref ==""} {
Debug::puts Instance Instance::draw_part_gfx debug "Drawing new $part, comm=$comm"
set gfx_ref [eval new [concat [list AbsArrow $Instance($this,canvas) "$x $y $arrowx $arrowy"] $tags]]
} else {
Debug::puts Instance Instance::draw_part_gfx debug "Updating $part comm=$comm"
Gfx::set_other_coords $gfx_ref $x $y $arrowx $arrowy
}
AbsArrow::set_head $gfx_ref $head
}
comm/name -
comm/variable -
node/comm/name -
node/comm/variable {
if {$part == "node/comm/name" || $part == "node/comm/variable"} {
set comm $subpart_ref
} else {
set comm $part_ref
}
if {$comm ==""} {
Debug::puts Instance Instance::draw_part_gfx warning "Part $part - null comm - ignoring"
return
}
set coords [eval Position::normalised_to_screen $position [Instance::get_plug_coords $this $part $part_ref $subpart_ref]]
set x [lindex $coords 0]
set y [lindex $coords 1]
set arrowdir [Instance::get_arrowdir $this $part $part_ref $subpart_ref]
set arrow_end_x [expr $x + ([lindex $arrowdir 0] * $Instance($this,arrow_length))]
set arrow_end_y [expr $y + ([lindex $arrowdir 1] * $Instance($this,arrow_length))]
if {$part == "comm/variable" || $part == "node/comm/variable"} {
set description [Comm::get_name $comm]
if {[Options::get show_node_paradigm_in_net_window]} {
append description "\n[Paradigm::get_label [Comm::get_paradigm $comm]]"
}
} else {
set description "[Comm::description $comm]\n[Paradigm::get_label [Comm::get_paradigm $comm]]"
}
set anchor [eval Instance::get_comm_name_anchor $this $arrowdir]
if {$gfx_ref ==""} {
Debug::puts Instance Instance::draw_part_gfx debug "Drawing new $part, comm=$comm"
set gfx_ref [eval new [concat [list Text $Instance($this,canvas) $arrow_end_x $arrow_end_y $description] $anchor $tags]]
} else {
Debug::puts Instance Instance::draw_part_gfx debug "Updating $part comm=$comm"
Gfx::set_other_coords $gfx_ref $arrow_end_x $arrow_end_y
Text::set_text $gfx_ref $description
Text::set_anchor $gfx_ref $anchor
}
}
main/name -
node/main/name {
if {$part == "node/main/name"} {
set what Implementation
set ref [Node::get_implementation $part_ref]
} else {
set what_ref [Instance::get_what_ref $this]
set what [lindex $what_ref 0]
set ref [lindex $what_ref 1]
}
set name [$what::get_body_name $ref]
Debug::puts Instance Instance::draw_part_gfx debug "Using name $name from $what $ref"
set ncoords [eval Position::normalised_to_screen $position [$what::get_name_position $ref]]
set nx [lindex $ncoords 0]
set ny [lindex $ncoords 1]
if {$gfx_ref==""} {
Debug::puts Instance Instance::draw_part_gfx debug "Drawing new $part"
set gfx_ref [eval new [concat [list Text $Instance($this,canvas) $nx $ny $name c] $tags]]
} else {
Debug::puts Instance Instance::draw_part_gfx debug "Updating $part"
Gfx::set_other_coords $gfx_ref $nx $ny
Text::set_text $gfx_ref $name
}
}
main/longname {
Debug::puts Instance Instance::draw_part_gfx debug "Setting $part"
InterfaceWindow::update_instance_label [Instance::get_label $this]
}
main/status {
Debug::puts Instance Instance::draw_part_gfx debug "Setting $part"
InterfaceWindow::update_status_label
}
main/description {
InterfaceWindow::update_description_label [Instance::get_description $this]
}
arc/arrow {
set start_details [Arc::get_start_details $part_ref]
set start_coords [eval [concat NetworkInstance::get_plug_final_coords_by_node $this $start_details]]
set middle_coords [eval Position::normalised_to_screen $position [Arc::get_middle_coords $part_ref]]
set end_details [Arc::get_end_details $part_ref]
set end_coords [eval [concat NetworkInstance::get_plug_final_coords_by_node $this $end_details]]
set coords [concat $start_coords $middle_coords $end_coords]
set head [Arc::get_head $part_ref]
Debug::puts Instance Instance::draw_part_gfx debug "Start details=$start_details start_coords=$start_coords"
Debug::puts Instance Instance::draw_part_gfx debug "End details=$end_details end_coords=$end_coords"
Debug::puts Instance Instance::draw_part_gfx debug "Middle coords=$middle_coords; head=$head"
if {$gfx_ref ==""} {
Debug::puts Instance Instance::draw_part_gfx debug "Drawing new $part"
set gfx_ref [eval new [concat [list AbsArrow $Instance($this,canvas) $coords] $tags]]
} else {
Debug::puts Instance Instance::draw_part_gfx debug "Updating $part"
eval Gfx::set_other_coords $gfx_ref $coords
}
AbsArrow::set_head $gfx_ref $head
}
default {
Debug::puts Instance Instance::draw_part_gfx warning "Ignoring new $part"
}
}
if {$old_gfx_ref == "" && $gfx_ref !=""} {
Debug::puts Instance Instance::draw_part_gfx debug "Drawing part $part gave Gfx ref $gfx_ref"
Gfx::draw $gfx_ref
Instance::set_gfx_for_part $this $part $part_ref $subpart_ref $gfx_ref
}
return $gfx_ref
}
proc Instance::get_comm_name_anchor {this x y} {
if {$x<0} {
set dir "e"
} else {
set dir "w"
}
if {$y<0} {
set dir "s$dir"
} else {
set dir "n$dir"
}
return $dir
}
proc Instance::update {this} {
Debug::puts Instance Instance::update debug "Updating Instance $this"
foreach {part part_ref subpart_ref gfx_ref show} $Instance($this,drawn) {
Debug::puts Instance Instance::update debug "Part $part ($part_ref,$subpart_ref); Gfx ref=$gfx_ref"
if { !$show} {
if {$gfx_ref==""} {
Debug::puts Instance Instance::update debug "Part $part not shown and not drawn - nothing to do"
continue
}
Debug::puts Instance Instance::update debug "Undrawing part $part ($part_ref,$subpart_ref); Gfx ref=$gfx_ref"
Instance::undraw_part $this $part $part_ref $subpart_ref
} else {
set is_updated 0
set hilighted 0
set draw_it 1
if {$gfx_ref == ""} {
Debug::puts Instance Instance::update debug "Want to draw part $part ($part_ref,$subpart_ref); NO Gfx ref"
} else {
if {$Instance($this,updated) != ""} {
set is_updated [Instance::match_part $this $part $part_ref $subpart_ref $Instance($this,updated)]
}
if {$is_updated} {
Debug::puts Instance Instance::update debug "Want to update part $part ($part_ref,$subpart_ref) for Instance $this; Gfx ref=$gfx_ref"
set hilighted [Gfx::unhilight $gfx_ref]
} else {
Debug::puts Instance Instance::update debug "No update or drawing of $part ($part_ref,$subpart_ref); Gfx ref=$gfx_ref"
set draw_it 0
}
}
if {$draw_it} {
Instance::draw_part_gfx $this $part $part_ref $subpart_ref $gfx_ref
}
if {$is_updated} {
if {$hilighted} {
Gfx::hilight $gfx_ref
}
}
}
}
set Instance($this,updated) {}
}
proc Instance::get_center {this} {
return [Gfx::get_center [Instance::get_gfx_for_part $this main/body {} {}]]
}
proc Instance::add_updated_parts {this args} {
Debug::puts Instance Instance::add_updated_parts debug "Instance $this update parts=$args"
set updated $Instance($this,updated)
Debug::puts Instance Instance::add_updated_parts debug "Initial update list: $updated"
foreach part $args {
if {[lsearch -exact $updated $part]<0} {
eval lappend updated $args
}
}
Debug::puts Instance Instance::add_updated_parts debug "Update list after uniquing: $updated"
if {[lsearch -exact $args "*"]>=0} {
set Instance($this,updated) "*"
return
}
foreach subpart $Instance($this,comm_showable) {
set glob "$subpart/*"
if {[lsearch -exact $args $subpart]>=0} {
Debug::puts Instance Instance::add_updated_parts debug "Found presence of glob $glob"
set updated {}
foreach part $updated {
if {$part != $glob && ![string match $glob $part]} {
lappend updated $part
}
}
Debug::puts Instance Instance::add_updated_parts debug "Update list after glob $glob: $updated"
}
}
set Instance($this,updated) $updated
}
proc Instance::match_part {this part part_ref subpart_ref globs} {
set name $part
if {$part_ref != ""} {
set name "$name/$part_ref"
}
if {$subpart_ref != ""} {
set name "$name/$subpart_ref"
}
Debug::puts Instance Instance::match_part debug "Part=$part ($part_ref,$subpart_ref) Name=$name; Globs=$globs"
foreach glob $globs {
if {$glob == "*" || $name == $glob} {
return 1
}
if {[string match $glob $name]} {
return 1
}
}
return 0
}
virtual proc Instance::part2groups {this part} {
if {$part=="main/border"} {
return "main/body"
}
if {$part=="node/main/border"} {
return "node/main/body"
}
return $part
}
proc Instance::hilight_part {this part part_ref subpart_ref} {
set apart [Instance::part2groups $this $part]
Debug::puts Instance Instance::hilight_part debug "part=$part ($part_ref,$subpart_ref) (actually $apart)"
set gfx_ref [Instance::get_gfx_for_part $this $apart $part_ref $subpart_ref]
if {$gfx_ref !=""} {
Debug::puts Instance Instance::hilight_part debug "Calling Gfx::hilight $gfx_ref"
return [Gfx::hilight $gfx_ref]
} else {
Debug::puts Instance Instance::hilight_part debug "Part $part ($part_ref,$subpart_ref) not drawn"
return 0
}
}
proc Instance::unhilight_part {this part part_ref subpart_ref} {
set apart [Instance::part2groups $this $part]
Debug::puts Instance Instance::unhilight_part debug "Part=$part ($part_ref,$subpart_ref) (actually $apart)"
set gfx_ref [Instance::get_gfx_for_part $this $apart $part_ref $subpart_ref]
if {$gfx_ref !=""} {
Debug::puts Instance Instance::unhilight_part debug "Calling Gfx::unhilight $gfx_ref"
return [Gfx::unhilight $gfx_ref]
} else {
Debug::puts Instance Instance::unhilight_part debug "Part $part ($part_ref,$subpart_ref) not drawn"
return 0
}
}
proc Instance::add_comm_fields {this comm} {
Debug::puts Instance Instance::add_comm_fields debug "For comm $comm"
foreach comm_part $Instance($this,comm_showable) {
Instance::add_part $this $comm_part $comm {} {}
}
}
proc Instance::delete_comm_fields {this comm} {
set newdrawn {}
foreach {part part_ref subpart_ref gfx_ref show} $Instance($this,drawn) {
if {[string match comm/* $part] && $part_ref == $comm} {
Debug::puts Instance Instance::delete_comm_fields debug "Deleting comm ($part_ref) Gfx ($gfx_ref) show=$show"
if {$gfx_ref !=""} {
delete $gfx_ref
}
} else {
lappend newdrawn $part $part_ref $subpart_ref $gfx_ref $show
}
}
set Instance($this,drawn) $newdrawn
Debug::puts Instance Instance::delete_comm debug "Draw state is now $Instance($this,drawn)"
}
proc Instance::get_comm_names {this iface} {
return [Interface::get_comm_names $iface]
}
proc Instance::get_description {this} {
set what_ref [Instance::get_what_ref $this]
set what [lindex $what_ref 0]
set ref [lindex $what_ref 1]
set description [$what::get_short_description $ref]
if {$description == ""} {
set description "(No description)"
}
return $description
}
proc Instance::get_label {this} {
return [Interface::get_pretty_label $Instance($this,interface) $Instance($this,implementation) 1]
}
proc Instance::get_language {this} {
return [Interface::get_language $Instance($this,interface)]
}
Instance::init_statics
Viewable::add_derived_type EditableInstance Instance
Debug::init EditableInstance
proc EditableInstance::EditableInstance {this interface implementation canvas} Instance {
EditableInstance $interface $implementation $canvas $EditableInstance(showable) $EditableInstance(show) $EditableInstance(main_showable) $EditableInstance(comm_showable) $EditableInstance(implementation_change_parts) {}
} {
}
proc EditableInstance::~EditableInstance {this} {}
proc EditableInstance::init_statics {} {
set EditableInstance(main_showable) {main/longname main/status main/body main/border main/name main/description}
set EditableInstance(comm_showable) {comm/plug comm/arrow comm/name}
set EditableInstance(implementation_change_parts) {main/name main/description}
set EditableInstance(main_show) {main/body main/border main/name main/description}
set EditableInstance(comm_show) {comm/plug comm/arrow comm/name}
set EditableInstance(showable)  [concat $EditableInstance(main_showable) $EditableInstance(comm_showable)]
set EditableInstance(show) [concat $EditableInstance(main_show) $EditableInstance(comm_show)]
}
proc EditableInstance::get_position {this part part_ref subpart_ref} {
return [Interface::get_position $Instance($this,interface)]
}
proc EditableInstance::move {this x y} {
Interface::move $Instance($this,interface) $x $y
Instance::add_updated_parts $this {*}
Instance::update $this
}
proc EditableInstance::resize {this xsize ysize} {
Interface::resize $Instance($this,interface) $xsize $ysize
Instance::add_updated_parts $this {*}
Instance::update $this
}
proc EditableInstance::add_comm {this comm} {
Interface::add_comm $Instance($this,interface) $comm
Instance::add_comm_fields $this $comm
Instance::update $this
}
proc EditableInstance::delete_comm {this comm} {
Debug::puts EditableInstance EditableInstance::delete_comm debug "Deleting $comm"
if {[Interface::delete_comm $Instance($this,interface) $comm]} {
Instance::delete_comm_fields $this $comm
Instance::update $this
}
}
proc EditableInstance::set_name {this name} {
set interface $Instance($this,interface) 
set implementation $Instance($this,implementation) 
if {$implementation == ""} {
Interface::set_name $interface $name
} else {
Implementation::set_name $implementation $name
Interface::implementation_modified $interface $implementation
}
Instance::add_updated_parts $this main/name main/longname main/status
Instance::update $this
}
proc EditableInstance::move_name {this x y} {
set interface $Instance($this,interface) 
set implementation $Instance($this,implementation) 
set position [Interface::get_position $Instance($this,interface)]
set norm_coords [Position::screen_to_normalised $position $x $y]
if {$implementation == ""} {
eval Interface::set_name_position $interface $norm_coords
} else {
eval Implementation::set_name_position $implementation $norm_coords
Interface::implementation_modified $interface $implementation
}
Instance::add_updated_parts $this main/name main/status
Instance::update $this
}
proc EditableInstance::move_comm_arrow {this comm x y} {
set position [Interface::get_position $Instance($this,interface)]
set end_coords   [Position::screen_to_normalised $position $x $y]
set start_coords [Comm::get_coords $comm]
set dx [expr [lindex $end_coords 0] - [lindex $start_coords 0]]
set dy [expr [lindex $end_coords 1] - [lindex $start_coords 1]]
set hyp [expr sqrt (($dx * $dx) + ($dy * $dy))]
Comm::set_arrowdir $comm [expr $dx / $hyp] [expr $dy / $hyp]
Interface::comm_modified_minor $Instance($this,interface) $comm
Instance::add_updated_parts $this comm/arrow/$comm comm/name/$comm
Instance::update $this
}
proc EditableInstance::move_comm_plug {this comm x y} {
set position [Interface::get_position $Instance($this,interface)]
eval Comm::set_coords $comm [eval Position::screen_to_normalised $position $x $y]
Interface::comm_modified_minor $this $comm
Instance::add_updated_parts $this comm/*/$comm
Instance::update $this
}
proc EditableInstance::rotate {this angle} {
Debug::puts EditableInstance EditableInstance::rotate debug "By $angle degrees"
Interface::rotate $Instance($this,interface) $angle
Instance::add_updated_parts $this {*}
Instance::update $this
}
proc EditableInstance::flip {this axis} {
Debug::puts EditableInstance EditableInstance::flip debug "Along axis $axis"
Interface::flip $Instance($this,interface) $axis
Instance::add_updated_parts $this {*}
Instance::update $this
}
proc EditableInstance::make_square {this axis} {
Debug::puts EditableInstance EditableInstance::make_square debug "Square to axis $axis"
set position [Interface::get_position $Instance($this,interface)]
set sizes [Position::get_sizes $position]
set xsize [lindex $sizes 0]
set ysize [lindex $sizes 1]
if {$axis == "x"} {
set ysize $xsize
} else {
set xsize $ysize
}
Interface::resize $Instance($this,interface) $xsize $ysize
Instance::add_updated_parts $this {*}
Instance::update $this
}
proc EditableInstance::comm_edited {this comm} {
Interface::comm_modified_major $Instance($this,interface) $comm
Instance::add_updated_parts $this comm/*/$comm
Instance::update $this
}
proc EditableInstance::description_edited {this short_desc desc} {
set interface $Instance($this,interface)
set implementation $Instance($this,implementation)
if {$implementation == ""} {
Interface::set_short_description $interface $short_desc
Interface::set_description $interface $desc
} else {
Implementation::set_short_description $implementation $short_desc
Implementation::set_description $implementation $desc
Interface::implementation_modified $interface $implementation
}
Instance::add_updated_parts $this main/description
Instance::update $this
}
EditableInstance::init_statics
Debug::init InterfaceWindow
proc InterfaceWindow::InterfaceWindow {this where parent state} Window {
$where "Interface" "ODT Interface Editor" $parent
} {
set InterfaceWindow(interface_list) {}
set InterfaceWindow(cur_interface) ""
set InterfaceWindow(cur_interface_instance) ""
set InterfaceWindow(cur_implementation) ""
set InterfaceWindow(interface_names) {}
set InterfaceWindow(cur_interface_impl_names) {}
set InterfaceWindow(cur_interface_index) -1
set InterfaceWindow(drawn) 0
set InterfaceWindow(canvas_path) ""
set InterfaceWindow(listbox_path) ""
set InterfaceWindow(label) ""
set InterfaceWindow(status) ""
set InterfaceWindow(showthings) {
comm/name        {Comms Names}  6
comm/arrow       {Comms Arrows} 6
main/name        {Name}         0
main/description {Description}  0 
}
set InterfaceWindow(defaultshow) {main/body main/border main/name main/longname main/status main/description comm/plug comm/arrow comm/name}
foreach showvar $InterfaceWindow(defaultshow) {
set InterfaceWindow(show,$showvar) 1
}
set InterfaceWindow(show) $InterfaceWindow(defaultshow)
set InterfaceWindow(shapes) {{Circle Circle {}} {Square Square {}} {Triangle Polygon {0 0.5 1 0 1 1}}}
set InterfaceWindow(minimum_interface_size) 40
set InterfaceWindow(interface_x_space) 50
set InterfaceWindow(interface_y_space) 50
Window::set_state $this $state
}
proc InterfaceWindow::~InterfaceWindow {this} {}
proc InterfaceWindow::draw {this} {
set where $Window($this,where)
InterfaceWindow::init_menubar $this ${where}.mbar
frame $where.ifbox
label $where.ifbox.label -text "   Interfaces\n     Implementations" -anchor w -justify left -relief raised -bd 1
frame $where.message -bd 1
label $where.message.value -textvariable Window($this,message)
pack $where.message.value -side left
set InterfaceWindow(listbox_path) $where.ifbox.names
listbox $InterfaceWindow(listbox_path) -relief raised -borderwidth 2 -yscrollcommand "$where.ifbox.scrollbar set"
bind $InterfaceWindow(listbox_path) <ButtonRelease-1> [list InterfaceWindow::listbox_clicked $this 1]
bind $InterfaceWindow(listbox_path) <Double-ButtonRelease-1> [list InterfaceWindow::listbox_clicked $this 2]
scrollbar $where.ifbox.scrollbar -command "$InterfaceWindow(listbox_path) yview"
pack $where.ifbox.label -side top -fill x
pack $where.ifbox.names $where.ifbox.scrollbar -side right -fill y
label $where.iflabel -anchor w -textvariable InterfaceWindow(label) -relief raised -bd 1
bind $where.iflabel <Double-ButtonPress-1> "InterfaceWindow::label_double_click $this"
label $where.description -anchor w -textvariable InterfaceWindow(description) -relief raised -bd 1
bind $where.description <Double-ButtonPress-1> "InterfaceWindow::description_double_click $this"
label $where.status -anchor w -textvariable InterfaceWindow(status) -relief raised -bd 1
set InterfaceWindow(canvas_path) $where.canvas
canvas $InterfaceWindow(canvas_path) -width 10c -height 7c -bd 2 -yscrollcommand "$where.yscroll set" -xscrollcommand "$where.xscroll set" -confine 1
scrollbar $where.yscroll -command "$where.canvas yview"
scrollbar $where.xscroll -orient horizontal -command "$where.canvas xview"
pack $where.mbar -side top -fill x
pack $where.message -side top -fill x
pack $where.ifbox -side left -fill y
pack $where.iflabel -side top -fill x
pack $where.description -side top -fill x
pack $where.status -side top -fill x
pack $where.yscroll -side right -fill y
pack $where.xscroll -side bottom -fill x
pack $InterfaceWindow(canvas_path) -side top -fill both -expand 1
bind $InterfaceWindow(canvas_path) <Configure> "InterfaceWindow::window_resized $this %h %w"
Project::canvas_bindings $Window($this,parent) InterfaceWindow $this $InterfaceWindow(canvas_path)
InterfaceWindow::refresh $this
}
proc InterfaceWindow::refresh {this} {
if {![Window::get_state $this]} {
return
}
InterfaceWindow::update_iflistbox $this
InterfaceWindow::update_cur_interface $this
}
proc InterfaceWindow::undraw {this} {
Debug::puts InterfaceWindow InterfaceWindow::undraw debug ""
InterfaceWindow::undraw_cur_interface $this
}
proc InterfaceWindow::init_menubar {this where} {
frame $where -relief raised -bd 2
set m $where.window
menubutton $m -text "Window" -menu $where.window.menu -underline 0
menu $m.menu -tearoff 0
$m.menu add command -label "Close" -underline 0 -command [list Window::hide $this]
menubutton $where.help -text "Help" -underline 0
set m $where.edit
menubutton $m -text "Edit" -menu $m.menu -underline 0
menu $m.menu -tearoff 0
$m.menu add command -label "Copy" -underline 0 -command [list InterfaceWindow::MenuEditCopy $this]
$m.menu add command -label "Delete" -underline 0 -command [list InterfaceWindow::MenuEditDelete $this]
$m.menu add command -label "Rotate" -underline 0 -command [list InterfaceWindow::MenuEditShape $this rotate 90]
$m.menu add command -label "Flip x" -underline 0 -command [list InterfaceWindow::MenuEditShape $this flip x]
$m.menu add command -label "Flip y" -underline 0 -command [list InterfaceWindow::MenuEditShape $this flip y]
$m.menu add command -label "Square (x)" -underline 0 -command [list InterfaceWindow::MenuEditShape $this make_square x]
$m.menu add command -label "Square (y)" -underline 0 -command [list InterfaceWindow::MenuEditShape $this make_square y]
$m.menu add command -label "Properties..." -underline 0 -command [list InterfaceWindow::MenuEditProperties $this]
set m $where.show
menubutton $m -text "Show" -menu $m.menu -underline 0
menu $m.menu -tearoff 0
foreach {part label underline} $InterfaceWindow(showthings) {
$m.menu add checkbutton -label $label -underline $underline -command [list InterfaceWindow::MenuShow $this $part] -variable InterfaceWindow(show,$part) -onvalue 1 -offvalue 0 -selectcolor [Colour::get_fg]
}
set m $where.interface
menubutton $m -text "Interface" -menu $m.menu -underline 0
menu $m.menu -tearoff 0
$m.menu add cascade -label "New..." -underline 0 -menu $m.menu.shape
menu $m.menu.shape -tearoff 0
foreach shape_elements $InterfaceWindow(shapes) {
set label [lindex $shape_elements 0]
set gfx_type [lindex $shape_elements 1]
set coords [lindex $shape_elements 2]
$m.menu.shape add command -label $label -underline 0 -command [list InterfaceWindow::MenuInterfaceNew $this $gfx_type $coords]
}
$m.menu add command -label "Validate" -underline 0 -command [list InterfaceWindow::MenuInterfaceValidate $this]
set m $where.implementation
menubutton $m -text "Implementation" -menu $m.menu -underline 0
menu $m.menu -tearoff 0
$m.menu add cascade -label "New..." -underline 0 -menu $m.menu.impl_type
menu $m.menu.impl_type -tearoff 0
foreach impl_type [Implementation::get_valid_user_types] {
$m.menu.impl_type add command -label $impl_type -underline 0 -command [list InterfaceWindow::MenuImplementationNew $this $impl_type]
}
set m $where.output
menubutton $m -text "Output" -menu $m.menu -underline 0
menu $m.menu -tearoff 0
$m.menu add command -label "File..." -underline 0 -command [list InterfaceWindow::MenuOutput $this File]
$m.menu add command -label "Print" -underline 0 -command [list InterfaceWindow::MenuOutput $this Print]
$m.menu add command -label "Show" -underline 0 -command [list InterfaceWindow::MenuOutput $this Show]
pack $where.window $where.edit $where.show $where.interface $where.implementation $where.output -side left
pack $where.help -side right
}
proc InterfaceWindow::MenuEditCopy {this} {
Debug::puts InterfaceWindow InterfaceWindow::MenuEditCopy debug ""
OKDialog "Not Implemented" "Copy operation not implemented"
}
proc InterfaceWindow::MenuEditDelete {this} {
Debug::puts InterfaceWindow InterfaceWindow::MenuEditDelete debug ""
if {![Select::something_is_selected]} {
Window::message $this "Cannot delete - nothing selected"
return
}
set comms {}
set delete_if_or_impl 0
foreach {type typeref subtype subtyperef subsubtyperef} [Select::get_cur_elements] {
Debug::puts InterfaceWindow InterfaceWindow::MenuEditDelete debug "Unselecting type=$type ($typeref) subtype=$subtype ($subtyperef,$subsubtyperef)"
if {$type != "EditableInstance"} {
continue
}
switch $subtype {
comm/plug -
comm/arrow -
comm/name {
if {[lsearch -exact $comms $subtyperef] <0} {
lappend comms $subtyperef
}
}
main/border -
main/body -
main/name {
set delete_if_or_impl 1
}
default {
Debug::puts InterfaceWindow InterfaceWindow::MenuEditDelete warning "Ignoring delete on $subtype"
}
}
Instance::update $typeref
}
Select::clear
foreach comm $comms {
Debug::puts InterfaceWindow InterfaceWindow::MenuEditDelete debug "Deleting comm $comm"
EditableInstance::delete_comm $InterfaceWindow(cur_interface_instance) $comm
}
if {!$delete_if_or_impl} {
InterfaceWindow::update_canvas_scrollregion $this
return
}
if {$InterfaceWindow(cur_implementation) !=""} {
if {![Implementation::is_user_implementation $InterfaceWindow(cur_implementation)]} {
OKDialog "Error" "Cannot delete a built-in Implementation"
return
}
Debug::puts InterfaceWindow InterfaceWindow::MenuEditDelete debug "Deleting Implementation $InterfaceWindow(cur_implementation)"
set name [Implementation::get_name $InterfaceWindow(cur_implementation)]
if {[OKCancelDialog "Deleting Implementation $name" "Deleting Implementation $name\nContinue?"]} {
Project::delete_implementation $Window($this,parent) $InterfaceWindow(cur_interface) $InterfaceWindow(cur_implementation)
InterfaceWindow::update_iflistbox $this
InterfaceWindow::set_cur_interface $this "" [expr $InterfaceWindow(cur_interface_index) -1]
}
} else {
Debug::puts InterfaceWindow InterfaceWindow::MenuEditDelete debug "Deleting Interface $InterfaceWindow(cur_interface)"
set name [Interface::get_name $InterfaceWindow(cur_interface)]
if {[OKCancelDialog "Deleting Interface $name" "Deleting Interface $name\nContinue?"]} {
Project::delete_interface $Window($this,parent) $InterfaceWindow(cur_interface)
InterfaceWindow::update_iflistbox $this
InterfaceWindow::set_cur_interface $this "" -1
Project::pick_interface $Window($this,parent) $InterfaceWindow(cur_interface) $InterfaceWindow(cur_implementation) 0
}
}
}
proc InterfaceWindow::MenuEditProperties {this} {
Debug::puts InterfaceWindow InterfaceWindow::MenuEditProperties debug ""
set els [Select::get_last_element]
if {$els == ""} {
Window::message $this "Nothing selected - no properties to check"
return
}
eval InterfaceWindow::EditProperties $this $els
}
proc InterfaceWindow::label_double_click {this} {
Debug::puts InterfaceWindow InterfaceWindow::label_double_click debug ""
if {$InterfaceWindow(cur_interface_instance) == ""} {
return
}
InterfaceWindow::edit_name $this $InterfaceWindow(cur_interface_instance) $InterfaceWindow(cur_interface)
}
proc InterfaceWindow::description_double_click {this} {
Debug::puts InterfaceWindow InterfaceWindow::description_double_click debug ""
if {$InterfaceWindow(cur_interface_instance) == ""} {
return
}
InterfaceWindow::edit_descriptions $this $InterfaceWindow(cur_interface_instance) $InterfaceWindow(cur_interface)
}
proc InterfaceWindow::EditProperties {this type instance subtype subtyperef subsubtyperef} {
Debug::puts InterfaceWindow InterfaceWindow::EditProperties debug "Type $type ($instance) subtype $subtype ($subtyperef,$subsubtyperef)"
if {$type != "EditableInstance"} {
return
}
set interface [Instance::get_interface $instance]
set implementation [Instance::get_implementation $instance]
switch $subtype {
main/name {
if {$implementation == "" ||
($implementation != "" && [Implementation::is_user_implementation $implementation])} {
Debug::puts InterfaceWindow InterfaceWindow::EditProperties debug "On $subtype - editing name"
InterfaceWindow::edit_name $this $instance $interface
}
}
comm/plug -
comm/arrow -
comm/name {
Debug::puts InterfaceWindow InterfaceWindow::EditProperties debug "On $subtype - editing comms"
InterfaceWindow::edit_comm $this $instance $interface $subtyperef
}
main/description {
Debug::puts InterfaceWindow InterfaceWindow::EditProperties debug "On $subtype - editing descriptions"
InterfaceWindow::edit_descriptions $this $instance $interface
}
main/body {
Project::pick_interface $Window($this,parent) $interface $implementation 0
}
default {
Window::message $this "Ignoring EditProperties on image sub type $subtype"
}
}
}
proc InterfaceWindow::MenuEditShape {this operation arg} {
Debug::puts InterfaceWindow InterfaceWindow::MenuEditRotate debug "$operation $arg"
if {![Select::something_is_selected]} {
Window::message $this "Cannot change shape - nothing selected"
return
}
set change_interface 0
foreach {type typeref subtype subtyperef subsubtyperef} [Select::get_cur_elements] {
if {$type != "EditableInstance"} {
Select::remove $type $typeref $subtype $subtyperef $subsubtyperef
continue
}
switch $subtype {
main/body {
set change_interface 1
}
default {
Debug::puts InterfaceWindow InterfaceWindow::MenuEditShape warning "Ignoring $operation $arg on $subtype"
}
}
}
if {$change_interface} {
EditableInstance::$operation $typeref $arg
}
}
proc InterfaceWindow::MenuShow {this what} {
set value $InterfaceWindow(show,$what)
Debug::puts InterfaceWindow InterfaceWindow::MenuShow debug "What=$what value=$value"
set newshow {}
foreach showvar $InterfaceWindow(defaultshow) {
if {$InterfaceWindow(show,$showvar)} {
lappend newshow $showvar
}
}
set InterfaceWindow(show) $newshow
set cur_interface_instance $InterfaceWindow(cur_interface_instance)
if {$cur_interface_instance != "" && $InterfaceWindow(drawn)} {
Instance::set_show $cur_interface_instance $InterfaceWindow(show)
}
}
proc InterfaceWindow::MenuInterfaceNew {this gfx_type shape} {
Debug::puts InterfaceWindow InterfaceWindow::MenuInterfaceNew debug ""
set interface [new Interface]
set impls "[Implementation::init [new Implementation] $interface {} Null] [Implementation::init [new Implementation] $interface {} Skeleton]"
set language [Project::get_cur_language $Window($this,parent)]
Interface::init $interface "" $language $gfx_type $shape $impls
Project::add_interface $Window($this,parent) $interface
InterfaceWindow::update_iflistbox $this
set old_interface_index $InterfaceWindow(cur_interface_index)
InterfaceWindow::set_cur_interface $this $interface -1
Debug::puts InterfaceWindow InterfaceWindow::MenuInterfaceNew debug "Interface=$interface"
if {[InterfaceWindow::edit_name $this $InterfaceWindow(cur_interface_instance) $interface]!= ""} {
Debug::puts InterfaceWindow InterfaceWindow::MenuInterfaceNew debug "Added OK"
Select::set EditableInstance $InterfaceWindow(cur_interface_instance) main/body {} {}
Interface::reset_version $interface
} else {
Debug::puts InterfaceWindow InterfaceWindow::MenuInterfaceNew debug "Cancelled"
Project::delete_interface $Window($this,parent) $interface
InterfaceWindow::update_iflistbox $this
InterfaceWindow::set_cur_interface $this "" -1
Project::pick_interface $Window($this,parent) $InterfaceWindow(cur_interface) $InterfaceWindow(cur_implementation) 0
}
}
proc InterfaceWindow::MenuInterfaceValidate {this} {
Debug::puts InterfaceWindow InterfaceWindow::MenuInterfaceValidate debug ""
if {$InterfaceWindow(cur_interface_instance) != ""} {
Debug::puts InterfaceWindow InterfaceWindow::MenuInterfaceValidate info "This operation should not be necessary - if it is, describe how you got into this state"
Interface::validate $InterfaceWindow(cur_interface)
InterfaceWindow::update_status_label
}
}
proc InterfaceWindow::MenuImplementationNew {this type} {
Debug::puts InterfaceWindow InterfaceWindow::MenuImplementationNew debug "Type=$type"  
if {![InterfaceWindow::checkselected $this]} {
return
}
set cur_interface $InterfaceWindow(cur_interface)
set impl [Implementation::init [new Implementation] $cur_interface "" $type]
Interface::add_implementation $cur_interface $impl
set old_interface_index $InterfaceWindow(cur_interface_index)
InterfaceWindow::update_iflistbox $this
set index [InterfaceWindow::get_implementation_index $this $impl]
InterfaceWindow::set_cur_interface $this "" $index
if {[InterfaceWindow::edit_name $this $InterfaceWindow(cur_interface_instance) $cur_interface]!= ""} {
Debug::puts InterfaceWindow InterfaceWindow::MenuImplementationNew debug "Added OK"
InterfaceWindow::update_iflistbox $this
Project::pick_interface $Window($this,parent) $cur_interface $impl 0
} else {
Debug::puts InterfaceWindow InterfaceWindow::MenuImplementationNew debug "Cancelled"
Project::delete_implementation $Window($this,parent) $cur_interface $impl
InterfaceWindow::update_iflistbox $this
InterfaceWindow::set_cur_interface $this "" $old_interface_index
}
}
proc InterfaceWindow::MenuOutput {this type} {
Debug::puts InterfaceWindow InterfaceWindow::MenuOutput debug "$type"
if {![InterfaceWindow::checkselected $this]} {
return
}
switch $type {
File {
set name [NameDialog "Output PROC header" "Output File Name" ""]
if {$name == ""} {
return
}
if {[file exists $name] && [file readable $name]} {
if {[OKDialog "Output PROC header" "There is an existing file $name\nDo you want to overwrite it?"] == 1} {
return
}
}
set working_filename [File::begin_save $name]
set fd [open $working_filename w]
puts -nonewline $fd [Interface::get_printed_header $InterfaceWindow(cur_interface) $InterfaceWindow(cur_implementation) 0]
close $fd
File::end_save $name
}
Show {
set text [Interface::get_printed_header $InterfaceWindow(cur_interface) $InterfaceWindow(cur_implementation) 1]
OKTextDialog "PROC header" $text 80 15
}
Print {
OKDialog "Not Implemented" "Output operation $type not implemented"
return
}
}
}
proc InterfaceWindow::checkselected {this} {
if {$InterfaceWindow(cur_interface)==""} {
Window::message $this "No Interface Selected"
return 0
}
return 1
}
proc InterfaceWindow::get_elements_at {this index} {
set elements [lindex $InterfaceWindow(interface_list) $index]
return $elements
}
proc InterfaceWindow::get_interface_index {this interface} {
set i 0
foreach element $InterfaceWindow(interface_list) {
if {$interface == [lindex $element 1]} {
return $i
}
incr i
}
return -1
}
proc InterfaceWindow::get_implementation_index {this impl} {
set i 0
foreach element $InterfaceWindow(interface_list) {
if {$impl == [lindex $element 4]} {
return $i
}
incr i
}
return -1
}
proc InterfaceWindow::update_iflistbox {this} {
set i 0
set np $InterfaceWindow(listbox_path)
set InterfaceWindow(interface_list) {}
set InterfaceWindow(interface_names) {}
set InterfaceWindow(cur_interface_impl_names) {}
foreach interface [lsort -command Interface::by_name [Project::get_interfaces $Window($this,parent)]] {
set name [Interface::get_name $interface]
listbox_set $np $i $name
incr i
lappend InterfaceWindow(interface_names) $name
lappend InterfaceWindow(interface_list) [list $name $interface "" "" ""]
foreach impl [Interface::get_impls $interface] {
set impl_name [Implementation::get_name $impl]
set impl_type [Implementation::get_type $impl]
set label [Implementation::get_label $impl]
if {$interface == $InterfaceWindow(cur_interface) && $impl_name != ""} {
lappend InterfaceWindow(cur_interface_impl_names) $impl_name
}
listbox_set $np $i "  $label"
incr i
lappend InterfaceWindow(interface_list) [list $name $interface $impl_type $impl_name $impl]
}
}
Debug::puts InterfaceWindow InterfaceWindow::update_iflistbox debug "Interface_list is $InterfaceWindow(interface_list)"
set size [$InterfaceWindow(listbox_path) size]
while {$size > $i} {
$np delete $i
incr i
}    
set len [llength $InterfaceWindow(interface_list)]
if {$InterfaceWindow(cur_interface)=="" && $len > 0} {
InterfaceWindow::set_cur_interface $this "" 0
}
if {$len == 0} {
set InterfaceWindow(label) ""
set InterfaceWindow(status) ""
}
}
proc InterfaceWindow::listbox_clicked {this button_clicks} {
set index [$InterfaceWindow(listbox_path) curselection]
Debug::puts InterfaceWindow InterfaceWindow::listbox_clicked debug "At index $index"
if {$index != ""} {
InterfaceWindow::set_cur_interface $this "" $index
Project::pick_interface $Window($this,parent) $InterfaceWindow(cur_interface) $InterfaceWindow(cur_implementation) [expr $button_clicks ==2]
} else {
Select::clear
}
}
proc InterfaceWindow::get_cur_interface {this} {
return $InterfaceWindow(cur_interface)
}
proc InterfaceWindow::set_cur_interface {this interface index} {
Debug::puts InterfaceWindow InterfaceWindow::set_cur_interface debug "Interface=$interface index=$index"
if {$interface == "" && $index >= 0} {
set elements [InterfaceWindow::get_elements_at $this $index]
set interface [lindex $elements 1]
}
if {$index <0 && $interface != ""} {
set index [InterfaceWindow::get_interface_index $this $interface]
}
set elements [InterfaceWindow::get_elements_at $this $index]
set implementation [lindex $elements 4]
Debug::puts InterfaceWindow InterfaceWindow::set_cur_interface debug "==> interface=$interface index=$index"
Debug::puts InterfaceWindow InterfaceWindow::set_cur_interface debug "cur interface=$InterfaceWindow(cur_interface) cur interface index=$InterfaceWindow(cur_interface_index)"
Debug::puts InterfaceWindow InterfaceWindow::set_cur_interface debug "cur interface instance=$InterfaceWindow(cur_interface_instance)"
if {$InterfaceWindow(cur_interface_instance) != ""} {
if {$interface != $InterfaceWindow(cur_interface) ||
($interface == $InterfaceWindow(cur_interface) &&
$implementation == $InterfaceWindow(cur_implementation) &&
$index != $InterfaceWindow(cur_interface_index))} {
Debug::puts InterfaceWindow InterfaceWindow::set_cur_interface debug "Deleting current Instance - interfaces are different"
Select::clear
InterfaceWindow::undraw_cur_interface $this
delete $InterfaceWindow(cur_interface_instance)
set InterfaceWindow(cur_interface_instance) ""
}
}
if {$InterfaceWindow(cur_interface_instance) != "" &&
$interface == $InterfaceWindow(cur_interface) &&
$implementation == $InterfaceWindow(cur_implementation)} {
Debug::puts InterfaceWindow InterfaceWindow::set_cur_interface debug "Ending - same interface and implementation and instance present"
set InterfaceWindow(cur_interface_index) $index
return
}
set set_impl 1
if {$InterfaceWindow(cur_interface_instance) == ""  && $interface != ""} {
Debug::puts InterfaceWindow InterfaceWindow::set_cur_interface debug "Creating new Instance"
set interface_position [Interface::get_position $interface]
if {$interface_position ==""} {
Debug::puts InterfaceWindow InterfaceWindow::set_cur_interface debug "Creating Interface position"
set interface_position [new Position]
Position::init $interface_position 0 0 120 120
Interface::set_position $interface $interface_position
} else {
Position::move $interface_position 0 0
}
set InterfaceWindow(cur_interface_instance) [new EditableInstance $interface $implementation $InterfaceWindow(canvas_path)]
set set_impl 0
}
set InterfaceWindow(cur_interface) $interface
set InterfaceWindow(cur_implementation) $implementation
set InterfaceWindow(cur_interface_index) $index
if {$InterfaceWindow(cur_interface_instance) != ""} {
Debug::puts InterfaceWindow InterfaceWindow::set_cur_interface debug "Instance is $InterfaceWindow(cur_interface_instance)"
if {$set_impl} {
Debug::puts InterfaceWindow InterfaceWindow::set_cur_interface debug "Setting implementation to $implementation"
Instance::set_implementation $InterfaceWindow(cur_interface_instance) $implementation
}
InterfaceWindow::update_cur_interface $this
if {!$set_impl} {
InterfaceWindow::update_canvas_scrollregion $this
$InterfaceWindow(canvas_path) xview moveto 0
$InterfaceWindow(canvas_path) yview moveto 0
}
} else {
Debug::puts InterfaceWindow InterfaceWindow::set_cur_interface debug "Just redrawing iflistbox"
InterfaceWindow::update_iflistbox $this
}
}
proc InterfaceWindow::update_cur_interface {this} {
$InterfaceWindow(listbox_path) selection clear 0 end
$InterfaceWindow(listbox_path) selection set $InterfaceWindow(cur_interface_index)
$InterfaceWindow(listbox_path) see $InterfaceWindow(cur_interface_index)
InterfaceWindow::draw_cur_interface $this
Select::set EditableInstance $InterfaceWindow(cur_interface_instance) main/body {} {}
}
proc InterfaceWindow::undraw_cur_interface {this} {
set cur_interface_instance $InterfaceWindow(cur_interface_instance)
if {$InterfaceWindow(drawn)} {
Instance::undraw $cur_interface_instance
set InterfaceWindow(drawn) 0
}
}
proc InterfaceWindow::draw_cur_interface {this} {
set cur_interface_instance $InterfaceWindow(cur_interface_instance)
if {$cur_interface_instance != "" && !$InterfaceWindow(drawn)} {
Instance::set_show $cur_interface_instance $InterfaceWindow(show)
set InterfaceWindow(drawn) 1
}
}
proc InterfaceWindow::doublebutton1 {this x y type typeref subtype subtyperef subsubtyperef args} {
Debug::puts InterfaceWindow InterfaceWindow::doublebutton1 debug "@$x,$y subtype=$subtype ($subtyperef,$subsubtyperef) $type ($typeref) tags=$args"
switch $subtype {
main/border {
Debug::puts InterfaceWindow InterfaceWindow::doublebutton1 debug "On $subtype @$x,$y - creating Plug"
set center [Instance::get_center $typeref]
set position [Instance::get_position $typeref border {} {}]
set interface [Instance::get_interface $typeref]
set cx [lindex $center 0]
set cy [lindex $center 1]
set dx [expr $x - $cx]
set dy [expr $y - $cy]
set hyp [expr sqrt (($dx * $dx) + ($dy * $dy))]
set comm [eval Comm::init [new Comm] $interface [Position::screen_to_normalised $position $x $y] [expr $dx / $hyp] [expr $dy / $hyp]]
set w [newDialogPath]
set existing_names [Instance::get_comm_names $typeref $interface]
set result [Comm::edit_dialog $w $comm $existing_names]
if {$result==0} {
Debug::puts InterfaceWindow InterfaceWindow::doublebutton1 debug "Comm added OK"
EditableInstance::add_comm $typeref $comm
InterfaceWindow::update_canvas_scrollregion $this
Select::set EditableInstance $InterfaceWindow(cur_interface_instance) comm/name $comm {}
} else {
Debug::puts InterfaceWindow InterfaceWindow::doublebutton1 debug "Comm cancelled"
delete $comm
}
}
main/body {
Project::pick_interface $Window($this,parent) $InterfaceWindow(cur_interface) $InterfaceWindow(cur_implementation) 1
}
default {
Debug::puts InterfaceWindow InterfaceWindow::doublebutton1 debug "Invoking EditProperties on $subtype"
InterfaceWindow::EditProperties $this $type $typeref $subtype $subtyperef $subsubtyperef
}
}
}
proc InterfaceWindow::edit_name {this instance interface} {
set language [Interface::get_language $interface]
set langname [Language::get_name $language]
set whatref [Instance::get_what_ref $InterfaceWindow(cur_interface_instance)]
set what [lindex $whatref 0]
set ref [lindex $whatref 1]
set label [lindex $whatref 2]
set name [$what::get_name $ref]
if {$what == "Implementation"} {
set existing_names [lallbut $InterfaceWindow(cur_interface_impl_names) $name]
} else {
set existing_names [lallbut $InterfaceWindow(interface_names) $name]
}
Debug::puts InterfaceWindow InterfaceWindow::edit_name debug "Existing names for $what = $existing_names"
while {1} {
set newname [NameDialog "Editing $what name" "Name for $label" $name]
if {$newname == "" || $newname == $name} {
set newname ""
break
}
if {[lsearch -exact $existing_names $newname]>=0} {
OKDialog "Error" "Name '$newname' is an existing $what name"
continue
}
if {![Language::is_valid_id $language $newname]} {
OKDialog "Error" "$newname is not a valid $langname identifier"
} else {
EditableInstance::set_name $instance $newname
if {$what == "Interface"} {
InterfaceWindow::set_cur_interface $this $interface -1
}
InterfaceWindow::update_iflistbox $this
break
}
}
return $newname
}
proc InterfaceWindow::edit_comm {this instance interface comm} {
Debug::puts InterfaceWindow InterfaceWindow::edit_comm debug "Instance $instance Interface $interface comm $comm"
set w [newDialogPath]
set existing_names [Instance::get_comm_names $instance $interface]
set this_name [Comm::get_name $comm]
set result [Comm::edit_dialog $w $comm [lallbut $existing_names $this_name]]
if {$result==0} {
Debug::puts InterfaceWindow InterfaceWindow::edit_comm debug "Comm edited OK."
EditableInstance::comm_edited $instance $comm
InterfaceWindow::update_canvas_scrollregion $this
}
return $result
}
proc InterfaceWindow::update_instance_label {label} {
Debug::puts InterfaceWindow InterfaceWindow::update_instance_label debug "Updating label to $label"
set InterfaceWindow(label) $label
}
proc InterfaceWindow::update_description_label {desc} {
set InterfaceWindow(description) $desc
}
proc InterfaceWindow::update_status_label {} {
set interface $InterfaceWindow(cur_interface)
set paradigm [Interface::get_paradigm $interface]
set version [Interface::get_version $interface]
set InterfaceWindow(status) "Paradigm: $paradigm  Version: $version"
}
proc InterfaceWindow::edit_descriptions {this instance interface} {
Debug::puts InterfaceWindow InterfaceWindow::edit_descriptions debug "Instance $instance Interface $interface"
set elements [lindex $InterfaceWindow(interface_list) $InterfaceWindow(cur_interface_index)]
set implementation [lindex $elements 4]
if {$implementation != ""} {
set what IMPLEMENTATION
set type Implementation
set ref $implementation
set name [lindex $elements 3]
} else {
set what Interface
set type Interface
set ref $interface
set name [lindex $elements 0]
}
set short_desc [$type::get_short_description $ref]
set desc [$type::get_description $ref]
set label "Editing description for [Interface::get_pretty_label $interface $implementation 1]"
set newdescs [InterfaceWindow::edit_description_dialog [newDialogPath] $label  $short_desc $desc]
if {$newdescs == ""} {
Debug::puts InterfaceWindow InterfaceWindow::edit_descriptions debug "Cancelled"
return 0
}
Debug::puts InterfaceWindow InterfaceWindow::edit_descriptions debug "Changed OK"
set short_desc [lindex $newdescs 0]
set desc [lindex $newdescs 1]
EditableInstance::description_edited $instance $short_desc $desc
return 1
}
proc InterfaceWindow::edit_description_dialog {w label short_desc desc} {
Debug::puts InterfaceWindow InterfaceWindow::edit_description_dialog debug "Window=$w Label=$label Short desc='$short_desc' Long desc='$desc'"
set InterfaceWindow(dialog_path) $w
set InterfaceWindow(dialog_short_desc) $short_desc
set InterfaceWindow(dialog_desc) $desc
set title "Editing Descriptions"
set default 0
set buttons {OK Cancel}
catch {destroy $w}
toplevel $w -class Dialog
wm title $w $title
wm iconname $w Dialog
wm protocol $w WM_DELETE_WINDOW { }
wm transient $w [winfo toplevel [winfo parent $w]]
frame $w.bot -relief raised -bd 1
pack $w.bot -side bottom -fill both
frame $w.top -relief raised -bd 1
pack $w.top -side top -fill both -expand 1
frame $w.top.label
frame $w.top.short_desc
frame $w.top.long_desc
pack $w.top.label $w.top.short_desc $w.top.long_desc -in $w.top -side top -fill both -expand 1
label $w.top.label.body -justify left -text $label
pack $w.top.label.body -in $w.top.label -side top -padx 1m -pady 1m
label $w.short_desc_name -justify left -text "Short description"
entry $w.short_desc_entry -width 70 -relief sunken -bd 2 -textvariable InterfaceWindow(dialog_short_desc)
pack $w.short_desc_name $w.short_desc_entry -in $w.top.short_desc -side top -padx 1m -pady 1m
label $w.desc_name -justify left -text "Long description"
text $w.desc_text -width 70 -height 5 -relief sunken -bd 2 -yscrollcommand "$w.desc_scroll set" -wrap word
scrollbar $w.desc_scroll -command "$w.desc_text yview"
pack $w.desc_name -in $w.top.long_desc -side top -padx 1m -pady 1m
pack $w.desc_scroll -in $w.top.long_desc -side right -fill y
pack $w.desc_text -in $w.top.long_desc -side left
$w.desc_text insert end $InterfaceWindow(dialog_desc)
set i 0
foreach but $buttons {
button $w.button$i -text $but -command "set InterfaceWindow(dialog_button) $i"
if {$i == $default} {
frame $w.default -relief sunken -bd 1
raise $w.button$i $w.default
pack $w.default -in $w.bot -side left -expand 1 -padx 3m -pady 2m
pack $w.button$i -in $w.default -padx 2m -pady 2m
} else {
pack $w.button$i -in $w.bot -side left -expand 1 \
-padx 3m -pady 2m
}
incr i
}
wm withdraw $w
update idletasks
set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
- [winfo vrootx [winfo parent $w]]]
set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
- [winfo vrooty [winfo parent $w]]]
wm geom $w +$x+$y
wm deiconify $w
set oldFocus [focus]
if {$default >= 0} {
focus $w.button$default
} else {
focus $w
}
tkwait variable InterfaceWindow(dialog_button)
set cancelled [expr $InterfaceWindow(dialog_button)==1]
set InterfaceWindow(dialog_desc) [$w.desc_text get 1.0 end]
catch {focus $oldFocus}
destroy $w
if {$cancelled} {
return {}
} else {
Debug::puts InterfaceWindow InterfaceWindow::edit_description_dialog debug "Returning descs short='$InterfaceWindow(dialog_short_desc)' long='$InterfaceWindow(dialog_desc)'"
return [list $InterfaceWindow(dialog_short_desc) $InterfaceWindow(dialog_desc)]
}
}
proc InterfaceWindow::button2down {this x y type typeref subtype subtyperef subsubtyperef args} {
Debug::puts InterfaceWindow InterfaceWindow::button2down debug "@$x,$y subtype=$subtype ($subtyperef,$subsubtyperef) $type ($typeref) tags=$args"
switch $subtype {
main/name {
Debug::puts InterfaceWindow InterfaceWindow::button2down debug "On name @$x,$y - moving name"
Window::message $this "Moving Interface name"
Project::set_mode $Window($this,parent) Moving $x $y $x $y 0 0 0 0 $type $typeref $subtype $subtyperef $subsubtyperef
}
main/border {
Debug::puts InterfaceWindow InterfaceWindow::button2down debug "On $subtype @$x,$y - resizing body"
Window::message $this "Resizing Interface box"
set position [Instance::get_position $typeref main/body {} {}]
set xy [Position::get_xy $position]
set x0 [lindex $xy 0]
set y0 [lindex $xy 1]
set sizes [Position::get_sizes $position]
set xsize [lindex $sizes 0]
set ysize [lindex $sizes 1]
Project::set_mode $Window($this,parent) Resizing $x0 $y0 $x $y $xsize $ysize $InterfaceWindow(minimum_interface_size) $InterfaceWindow(minimum_interface_size) $type $typeref main/body $subtyperef $subsubtyperef
}
comm/name -
comm/arrow {
Debug::puts InterfaceWindow InterfaceWindow::button2down debug "On comm/arrow @$x,$y - moving arrow"
Window::message $this "Moving arrow"
Project::set_mode $Window($this,parent) Moving $x $y $x $y 0 0 0 0 $type $typeref comm/arrow $subtyperef $subsubtyperef
}
comm/plug {
Debug::puts InterfaceWindow InterfaceWindow::button2down debug "On comm/plug @$x,$y - moving plug"
Window::message $this "Moving plug"
Project::set_mode $Window($this,parent) Moving $x $y $x $y 0 0 0 0 $type $typeref $subtype $subtyperef $subsubtyperef
}
default {
Debug::puts InterfaceWindow InterfaceWindow::button2down warning "Ignoring button2down on $subtype"
}
}
}
proc InterfaceWindow::button2up {this x y type typeref subtype subtyperef subsubtyperef} {
Debug::puts InterfaceWindow InterfaceWindow::button2up debug "@$x,$y subtype=$subtype ($subtyperef,$subsubtyperef) $type ($typeref)"
}
proc InterfaceWindow::move_to {this x y type typeref subtype subtyperef subsubtyperef} {
Debug::puts InterfaceWindow InterfaceWindow::move_to debug "@$x,$y subtype=$subtype ($subtyperef,$subsubtyperef) $type ($typeref)"
switch $subtype {
main/name {
Debug::puts InterfaceWindow InterfaceWindow::move_to debug "Moving $subtype to $x,$y"
EditableInstance::move_name $typeref $x $y
}
comm/arrow {
Debug::puts InterfaceWindow InterfaceWindow::move_to debug "Moving $subtype to $x,$y"
EditableInstance::move_comm_arrow $typeref $subtyperef $x $y
InterfaceWindow::update_canvas_scrollregion $this
}
comm/plug {
Debug::puts InterfaceWindow InterfaceWindow::move_to debug "Moving $subtype to $x,$y"
EditableInstance::move_comm_plug $typeref $subtyperef $x $y
InterfaceWindow::update_canvas_scrollregion $this
}
default {
Debug::puts InterfaceWindow InterfaceWindow::move_to debug "Ignoring move_to for subtype $subtype"
}
}
}
proc InterfaceWindow::moved {this x y type typeref subtype subtyperef subsubtyperef} {
Debug::puts InterfaceWindow InterfaceWindow::moved debug "@$x,$y subtype=$subtype ($subtyperef,$subsubtyperef) $type ($typeref)"
switch $subtype {
main/name -
comm/arrow -
comm/plug {
Window::message $this ""
Debug::puts InterfaceWindow InterfaceWindow::moved debug "Moved $subtype to $x,$y"
InterfaceWindow::update_canvas_scrollregion $this
}
default {
Debug::puts InterfaceWindow InterfaceWindow::moved warning "Ignoring moved for subtype $subtype"
}
}
}
proc InterfaceWindow::resized {this xsize ysize type typeref subtype subtyperef subsubtyperef} {
Debug::puts InterfaceWindow InterfaceWindow::resized debug "subtype=$subtype ($subtyperef,$subsubtyperef) $type ($typeref)"
switch $subtype {
main/body {
Instance::resize $typeref $xsize $ysize
InterfaceWindow::update_canvas_scrollregion $this
Window::message $this "Resized shape to $xsize x $ysize"
InterfaceWindow::update_canvas_scrollregion $this
}
default {
Debug::puts InterfaceWindow InterfaceWindow::resized warning "Ignoring place for subtype $subtype"
}
}
}
proc InterfaceWindow::window_resized {this x y} {
InterfaceWindow::update_canvas_scrollregion $this
}
proc InterfaceWindow::deleted_all_interfaces {this} {
InterfaceWindow::update_iflistbox $this
InterfaceWindow::set_cur_interface $this "" -1
}
proc InterfaceWindow::update_canvas_scrollregion {this} {
if {$InterfaceWindow(cur_interface_instance) == ""} {
return
}
set canvas $InterfaceWindow(canvas_path)
set bbox [$canvas bbox all]
set left   [expr [lindex $bbox 0] - $InterfaceWindow(interface_x_space)]
set top    [expr [lindex $bbox 1] - $InterfaceWindow(interface_y_space)]
set right  [expr [lindex $bbox 2] + $InterfaceWindow(interface_x_space)]
set bottom [expr [lindex $bbox 3] + $InterfaceWindow(interface_y_space)]
Debug::puts InterfaceWindow InterfaceWindow::update_canvas_scrollregion info "Region now $left $top $right $bottom"
$canvas configure -scrollregion "$left $top $right $bottom"
}
Viewable::add_derived_type NetworkInstance Instance
Debug::init NetworkInstance
proc NetworkInstance::NetworkInstance {this interface implementation canvas} Instance {
NetworkInstance $interface $implementation $canvas $NetworkInstance(showable) $NetworkInstance(show) $NetworkInstance(main_showable) $NetworkInstance(comm_showable) $NetworkInstance(implementation_change_parts) 25
} {
set NetworkInstance($this,node_main_showable) $NetworkInstance(node_main_showable)
set NetworkInstance($this,node_comm_showable) $NetworkInstance(node_comm_showable)
set NetworkInstance($this,arc_showable) $NetworkInstance(arc_showable)
set NetworkInstance($this,route_cs) [new Route]
set NetworkInstance($this,route_ioseq) [new Route]
Route::add_node $NetworkInstance($this,route_ioseq) 0
foreach node [Implementation::get_nodes $Instance($this,implementation)] {
NetworkInstance::add_node $this $node 0 0
}
foreach arc [Implementation::get_arcs $Instance($this,implementation)] {
NetworkInstance::add_arc $this $arc 0 0
}
Instance::update $this
}
proc NetworkInstance::~NetworkInstance {this} {
delete $NetworkInstance($this,route_cs)
delete $NetworkInstance($this,route_ioseq)
unset NetworkInstance($this,node_main_showable) NetworkInstance($this,node_comm_showable) NetworkInstance($this,arc_showable) NetworkInstance($this,route_cs) NetworkInstance($this,route_ioseq)
}
proc NetworkInstance::init_statics {} {
set NetworkInstance(node_main_showable) {node/main/body node/main/border node/main/name}
set NetworkInstance(node_comm_showable) {node/comm/plug node/comm/arrow node/comm/variable}
set NetworkInstance(arc_showable) {arc/arrow}
set NetworkInstance(main_showable) {main/border}
set NetworkInstance(comm_showable) {comm/plug comm/arrow comm/variable}
set NetworkInstance(implementation_change_parts) {}
set NetworkInstance(main_show) $NetworkInstance(main_showable)
set NetworkInstance(comm_show) $NetworkInstance(comm_showable)
set NetworkInstance(node_main_show) $NetworkInstance(node_main_showable)
set NetworkInstance(node_comm_show) $NetworkInstance(node_comm_showable)
set NetworkInstance(arc_show)  $NetworkInstance(arc_showable)
set NetworkInstance(showable)  [concat $NetworkInstance(main_showable) $NetworkInstance(comm_showable) $NetworkInstance(node_main_showable) $NetworkInstance(node_comm_showable) $NetworkInstance(arc_showable)]
set NetworkInstance(show) [concat $NetworkInstance(main_show) $NetworkInstance(comm_show) $NetworkInstance(node_main_show) $NetworkInstance(node_comm_show) $NetworkInstance(arc_show)]
}
proc NetworkInstance::get_position {this part part_ref subpart_ref} {
switch -glob $part {
main/* -
comm/* -
arc/* {
return [Implementation::get_network_box_position $Instance($this,implementation)]
}
node/* {
return [Node::get_position $part_ref]
}
default {
Debug::puts NetworkInstance NetworkInstance::get_position warning "Ignoring part '$part'"
}
}
return ""
}
proc NetworkInstance::get_shape {this part part_ref subpart_ref} {
switch -glob $part {
main/* -
comm/* {
return ""
}
node/* {
return [Node::get_shape $part_ref]
}
arc/* {
return ""
}
default {
Debug::puts NetworkInstance NetworkInstance::get_shape warning "Ignoring part '$part'"
}
}
return ""
}
proc NetworkInstance::get_gfx_type {this part part_ref subpart_ref} {
switch -glob $part {
main/* -
comm/* {
return Square
}
node/* {
return [Interface::get_gfx_type [Node::get_interface $part_ref]]
}
arc/* {
return ""
}
default {
Debug::puts NetworkInstance NetworkInstance::get_gfx_type warning "Ignoring part '$part'"
}
}
return Square
}
proc NetworkInstance::get_plug_coords {this part part_ref subpart_ref} {
switch $part {
comm/plug -
comm/arrow -
comm/name -
comm/variable {
return [Comm::get_coords $part_ref]
}
node/comm/plug -
node/comm/arrow -
node/comm/name -
node/comm/variable {
return [Node::get_plug_coords $part_ref $subpart_ref]
}
}
}
proc NetworkInstance::get_arrowdir {this part part_ref subpart_ref} {
switch $part {
comm/arrow -
comm/name -
comm/variable {
return [Comm::get_arrowdir $part_ref]
}
node/comm/arrow -
node/comm/name -
node/comm/variable {
return [Node::get_arrowdir $part_ref $subpart_ref]
}
}
}
proc NetworkInstance::move {this x y} {
Debug::puts NetworkInstance NetworkInstance::move debug "To $x,$y"
set position [Implementation::get_network_box_position $Instance($this,implementation)]
eval Position::move $position $x $y
Interface::implementation_modified $Instance($this,interface) $Instance($this,implementation)
Instance::add_updated_parts $this {*}
foreach node [Implementation::get_nodes $Instance($this,implementation)] {
Node::update $node
}
Instance::update $this
}
proc NetworkInstance::refresh {this} {
Instance::add_updated_parts $this {*}
foreach node [Implementation::get_nodes $Instance($this,implementation)] {
Node::update_rotation $node
Node::update_position $node
}
Instance::update $this
}
proc NetworkInstance::resize {this xsize ysize} {
Debug::puts NetworkInstance NetworkInstance::resize debug "To $xsize,$ysize"
set position [Implementation::get_network_box_position $Instance($this,implementation)]
eval Position::resize $position $xsize $ysize
Interface::implementation_modified $Instance($this,interface) $Instance($this,implementation)
Instance::add_updated_parts $this {*}
foreach node [Implementation::get_nodes $Instance($this,implementation)] {
Node::update $node
}
Instance::update $this
}
proc NetworkInstance::add_node {this node do_add do_update} {
if {$do_add} {
Implementation::add_node $Instance($this,implementation) $node
Interface::implementation_modified $Instance($this,interface) $Instance($this,implementation)
}
set index [Node::get_index $node]
Route::add_node $NetworkInstance($this,route_cs) $index
Route::add_node $NetworkInstance($this,route_ioseq) $index
foreach node_part $NetworkInstance($this,node_main_showable) {
Instance::add_part $this $node_part $node {} {}
}
foreach comm [Node::get_comms $node] {
NetworkInstance::add_node_comm_fields $this $node $comm
}
if {$do_update} {
Instance::update $this
}
}
proc NetworkInstance::add_node_comm_fields {this node comm} {
foreach node_part $NetworkInstance($this,node_comm_showable) {
Instance::add_part $this $node_part $node $comm {}
}
}
proc NetworkInstance::delete_node {this node do_update} {
set index [Node::get_index $node]
Route::subtract_node $NetworkInstance($this,route_cs) $index
Route::subtract_node $NetworkInstance($this,route_ioseq) $index
Interface::implementation_modified $Instance($this,interface) $Instance($this,implementation)
set from_to_nodes [Implementation::delete_node $Instance($this,implementation) $node]
foreach {from_node to_node} $from_to_nodes {
Route::rename_node $NetworkInstance($this,route_cs) $from_node $to_node
Route::rename_node $NetworkInstance($this,route_ioseq) $from_node $to_node
}
foreach node_part $NetworkInstance($this,node_main_showable) {
Instance::delete_part $this $node_part $node {} {}
}
foreach comm [Node::get_comms $node] {
NetworkInstance::delete_node_comm_fields $this $node $comm
}
delete $node
if {$do_update} {
Instance::update $this
}
}
proc NetworkInstance::delete_node_comm_fields {this node comm} {
foreach node_part $NetworkInstance($this,node_comm_showable) {
Instance::delete_part $this $node_part $node $comm {}
}
}
proc NetworkInstance::add_arc {this arc arc_is_new do_update} {
set msg [NetworkInstance::check_arc $this $arc $arc_is_new]
if {$msg != ""} {
return $msg
}
if {$arc_is_new} {
Implementation::add_arc $Instance($this,implementation) $arc
Interface::implementation_modified $Instance($this,interface) $Instance($this,implementation)
}
foreach arc_part $NetworkInstance($this,arc_showable) {
Instance::add_part $this $arc_part $arc {} {}
}
foreach {node comm} [Arc::get_all_details $arc] {
if {$node != 0} {
Instance::delete_part $this node/comm/arrow $node $comm {}
Instance::delete_part $this node/comm/variable $node $comm {}
} else {
Instance::delete_part $this comm/arrow $comm {} {}
Instance::delete_part $this comm/variable $comm {} {}
}
}
if {$do_update} {
Instance::update $this
}
return ""
}
proc NetworkInstance::delete_arc {this arc do_update} {
Implementation::delete_arc $Instance($this,implementation) $arc
Interface::implementation_modified $Instance($this,interface) $Instance($this,implementation)
set details [Arc::get_all_details $arc]
set start_node [lindex $details 0]
set start_comm [lindex $details 1]
set end_node   [lindex $details 2]
set end_comm   [lindex $details 3]
if {$start_node != 0} {
set start_index [Node::get_index $start_node]
} else {
set start_index 0
}
if {$end_node != 0} {
set end_index [Node::get_index $end_node]
} else {
set end_index 0
}
set start_paradigm [Comm::get_paradigm $start_comm]
set end_paradigm [Comm::get_paradigm $end_comm]
if {$start_node != 0 && $end_node != 0} {
if {[Paradigm::is_client_server $start_paradigm]} {
Route::subtract_arc $NetworkInstance($this,route_cs) $start_index $end_index
}
if {$start_paradigm == "ioseq" && $end_paradigm == "ioseq"} {
Route::subtract_arc $NetworkInstance($this,route_ioseq) $start_index $end_index
}
} else {
if {($start_index == 0 && $start_paradigm == "iopar" && $end_paradigm   == "ioseq") ||
($end_index   == 0 && $end_paradigm   == "iopar" && $start_paradigm == "ioseq")} {
Route::subtract_arc $NetworkInstance($this,route_ioseq) $start_index $end_index
}
}
foreach arc_part $NetworkInstance($this,arc_showable) {
Instance::delete_part $this $arc_part $arc {} {}
}
foreach {node comm} [Arc::get_all_details $arc] {
if {$node != "0"} {
Instance::add_part $this node/comm/arrow $node $comm {}
Instance::add_part $this node/comm/variable $node $comm {}
} else {
Instance::add_part $this comm/arrow $comm {} {}
Instance::add_part $this comm/variable $comm {} {}
}
}
delete $arc
if {$do_update} {
Instance::update $this
}
}
proc NetworkInstance::move_node {this node x y} {
Debug::puts NetworkInstance NetworkInstance::move_node debug "Node $node moved to $x,$y"
Node::move $node $x $y
Interface::implementation_modified $Instance($this,interface) $Instance($this,implementation)
foreach arc [Implementation::get_arcs_for_node $Instance($this,implementation) $node] {
Instance::add_updated_parts $this arc/*/$arc
}
Instance::add_updated_parts $this node/*/$node node/comm/*/$node/*
Instance::update $this
}
proc NetworkInstance::resize_node {this node xsize ysize do_update} {
Debug::puts NetworkInstance NetworkInstance::resize_node debug "Node $node resized to $xsize by $ysize"
set sizes [Node::get_sizes $node]
set old_xsize [lindex $sizes 0]
set old_ysize [lindex $sizes 1]
if {$old_xsize == $xsize && $old_ysize == $ysize} {
return 0
}
Node::resize $node $xsize $ysize
Interface::implementation_modified $Instance($this,interface) $Instance($this,implementation)
foreach arc [Implementation::get_arcs_for_node $Instance($this,implementation) $node] {
Instance::add_updated_parts $this arc/*/$arc
}
Instance::add_updated_parts $this node/*/$node node/comm/*/$node/*
if {$do_update} {
Instance::update $this
}
return 1
}
proc NetworkInstance::part2groups {this part} {
switch $part {
main/border {
return main/border
}
comm/arrow -
comm/variable -
comm/plug {
return comm/plug
}
node/main/body -
node/main/border -
node/main/name {
return node/main/body
}
node/comm/arrow -
node/comm/variable -
node/comm/plug {
return node/comm/plug
}
default {
return $part
}
}
}
proc NetworkInstance::rotate_node {this node angle} {
Debug::puts NetworkInstance NetworkInstance::rotate_node debug "Node $node by $angle degrees"
Node::rotate $node $angle
Interface::implementation_modified $Instance($this,interface) $Instance($this,implementation)
foreach arc [Implementation::get_arcs_for_node $Instance($this,implementation) $node] {
Instance::add_updated_parts $this arc/*/$arc
}
Instance::add_updated_parts $this node/*/$node node/comm/*/$node/*
Instance::update $this
}
proc NetworkInstance::flip_node {this node axis} {
Debug::puts NetworkInstance NetworkInstance::flip_node debug "Node $node along axis $axis"
Node::flip $node $axis
Interface::implementation_modified $Instance($this,interface) $Instance($this,implementation)
foreach arc [Implementation::get_arcs_for_node $Instance($this,implementation) $node] {
Instance::add_updated_parts $this arc/*/$arc
}
Instance::add_updated_parts $this node/*/$node node/comm/*/$node/*
Instance::update $this
}
proc NetworkInstance::make_square_node {this node axis} {
Debug::puts NetworkInstance NetworkInstance::make_square_node debug "Node $node square to axis $axis"
set sizes [Node::get_sizes $node]
set xsize [lindex $sizes 0]
set ysize [lindex $sizes 1]
if {$axis == "x"} {
set ysize $xsize
} else {
set xsize $ysize
}
NetworkInstance::resize_node $this $node $xsize $ysize 1
}
proc NetworkInstance::make_same_size {this arg nodes} {
Debug::puts NetworkInstance NetworkInstance::make_square_node debug "Nodes $nodes"
set node0 [lindex $nodes 0]
set sizes [Node::get_sizes $node0]
set xsize [lindex $sizes 0]
set ysize [lindex $sizes 1]
set do_update 0
foreach node $nodes {
if {$node != $node0} {
if {[NetworkInstance::resize_node $this $node $xsize $ysize 0]} {
set do_update 1
}
}
}
if {$do_update} {
Interface::implementation_modified $Instance($this,interface) $Instance($this,implementation)
Instance::update $this
}
}
proc NetworkInstance::get_plug_final_coords_by_node {this node comm} {
if {$node == "0"} {
set coords [Comm::get_coords $comm]
set position [Implementation::get_network_box_position $Instance($this,implementation)]
} else {
set coords [Node::get_plug_coords $node $comm]
set position [Node::get_position $node]
}
Debug::puts NetworkInstance NetworkInstance::get_plug_final_coords_by_node debug "For Node $node, Comm $comm gives Coords $coords Position $position"
return [eval Position::normalised_to_screen $position $coords]
}
proc NetworkInstance::check_arc {this arc is_new} {
while {1} {
set details [Arc::get_all_details $arc]
set start_node [lindex $details 0]
set start_comm [lindex $details 1]
set end_node [lindex $details 2]
set end_comm [lindex $details 3]
if {$start_node != 0} {
set start_index [Node::get_index $start_node]
} else {
set start_index 0
}
if {$end_node != 0} {
set end_index [Node::get_index $end_node]
} else {
set end_index 0
}
Debug::puts NetworkInstance NetworkInstance::NetworkInstance::check_arc debug "Arc From node $start_node ($start_index), comm $start_comm To node $end_node ($end_index), comm $end_comm New=$is_new"
if {!$is_new} {
set start_paradigm [Comm::get_paradigm $start_comm]
set end_paradigm [Comm::get_paradigm $end_comm]
break
}
if {$start_index == 0 && $end_index == 0} {
return {Cannot connect between parameter channels}
}
if {$start_node == $end_node} {
return {Cannot connect between parameters of same Node}
}
if {![Comm::comm_data_types_connectable $start_comm $end_comm]} {
return {Cannot connect between parameters with different data types}
}
if {[Implementation::get_arc_by_node_comm $Instance($this,implementation) $start_node $start_comm] != "" ||
[Implementation::get_arc_by_node_comm $Instance($this,implementation) $end_node $end_comm] != ""} {
return {An Arc already connects one of the ends}
}
set swap 0
set start_paradigm [Comm::get_paradigm $start_comm]
set end_paradigm [Comm::get_paradigm $end_comm]
if {$start_index == 0 || $end_index == 0} {
Debug::puts NetworkInstance NetworkInstance::NetworkInstance::check_arc debug "Checking Arc to box edge"
if {![Comm::comm_directions_equivalent $start_comm $end_comm]} {
return {Parameters directions do not match}
}
set msg [Paradigm::paradigms_equivalent $start_paradigm $end_paradigm]
if {$msg != ""} {
return $msg
}
if {$start_paradigm == "ioseq" || $end_paradigm == "ioseq"} {
set direction [Comm::get_direction $start_comm]
Debug::puts NetworkInstance NetworkInstance::NetworkInstance::check_arc debug "Checking I/O-SEQ <-> edge direction=$direction"
if {($end_index == 0 && $direction == "in") ||
($start_index == 0 && $direction == "out")} {
set swap 1
}
}
} else {
Debug::puts NetworkInstance NetworkInstance::NetworkInstance::check_arc debug "Checking internal Arc"
if {![Comm::comm_directions_connectable $start_comm $end_comm]} {
return {Comm directions do not connect}
}
set msg [Paradigm::paradigms_connectable $start_paradigm $end_paradigm]
if {$msg == "reorder"} {
set swap 1
} elseif {$msg != ""} {
return $msg
} elseif {$start_paradigm == "ioseq" || $end_paradigm == "ioseq"} {
if {[Comm::get_direction $start_comm] == "in"} {
set swap 1
}
}
}
if {$swap} {
Debug::puts NetworkInstance NetworkInstance::NetworkInstance::check_arc debug "Swapping arc order"
set middle_coords [Arc::get_middle_coords $arc]
if {$middle_coords != ""} {
set ncoords {}
set i [expr [llength $middle_coords] -2 ]
while {$i >=0} {
set x [lindex $middle_coords $i]
set y [lindex $middle_coords [expr $i + 1]]
lappend ncoords $x $y
incr i -2
}
set middle_coords $ncoords
}
Arc::init $arc $end_node $end_comm $start_node $start_comm $middle_coords
continue
}
break
}
Debug::puts NetworkInstance NetworkInstance::NetworkInstance::check_arc debug "Checking paradigms for Arc:\n  From node $start_node ($start_index), comm $start_comm paradigm $start_paradigm\n  To node $end_node ($end_index), comm $end_comm paradigm $end_paradigm"
if {$start_index != 0 && $end_index != 0} {
if {[Paradigm::is_client_server $start_paradigm]} {
if {![Route::add_arc $NetworkInstance($this,route_cs) $start_index $end_index]} {
return "Client-Server loop"
} else {
return ""
}
}
if {$start_paradigm == "ioseq" && $end_paradigm == "ioseq"} {
if {![Route::add_arc $NetworkInstance($this,route_ioseq) $start_index $end_index]} {
return "I/O-SEQ loop"
} else {
return ""
}
}
} else {
if {($start_index == 0 && $start_paradigm == "iopar" && $end_paradigm   == "ioseq") ||
($end_index   == 0 && $end_paradigm   == "iopar" && $start_paradigm == "ioseq")} {
if {![Route::add_arc $NetworkInstance($this,route_ioseq) $start_index $end_index]} {
return "I/O-SEQ loop"
}
}
}
Debug::puts NetworkInstance NetworkInstance::NetworkInstance::check_arc debug "Arc is assumed valid\n  From node $start_node ($start_index), comm $start_comm paradigm $start_paradigm\n  To node $end_node ($end_index), comm $end_comm paradigm $end_paradigm"
return ""
}
proc NetworkInstance::get_arc_by_node_comm {this node comm} {
return [Implementation::get_arc_by_node_comm $Instance($this,implementation) $node $comm]
}
proc NetworkInstance::node_interface_change {this interface comm what} {
Debug::puts NetworkInstance NetworkInstance::node_interface_change debug "Interface $interface (Comm $comm) - $what"
set do_update 0
foreach node [Implementation::get_nodes $Instance($this,implementation)] {
if {[Node::get_interface $node] == $interface} {
Debug::puts NetworkInstance NetworkInstance::node_interface_change debug "Node $node has Interface $interface"
if {$comm == ""} {
switch $what {
deleted {
foreach arc [Implementation::get_arcs_for_node $Instance($this,implementation) $node] {
NetworkInstance::delete_arc $this $arc 0
}
NetworkInstance::delete_node $this $node 1
}
name {
Instance::add_updated_parts $this node/main/name/$node
set do_update 1
}	    
default {
Debug::puts NetworkInstance NetworkInstance::node_interface_change error "Unknown change $what (body)"
return
}
}
} else {
switch $what {
add_comm {
NetworkInstance::add_node_comm_fields $this $node $comm
Node::set_plug_coords $node $comm
}
delete_comm {
foreach arc [Implementation::get_arc_by_node_comm $Instance($this,implementation) $node $comm] {
NetworkInstance::delete_arc $this $arc 0
}
NetworkInstance::delete_node_comm_fields $this $node $comm
Node::reset_plug_coords $node $comm
} 
modified_comm {
Instance::add_updated_parts $this node/comm/*/$node/$comm
Node::set_plug_coords $node $comm
foreach arc [Implementation::get_arc_by_node_comm $Instance($this,implementation) $node $comm] {
NetworkInstance::delete_arc $this $arc 0
}
}
default {
Debug::puts NetworkInstance NetworkInstance::node_interface_change error "Unknown change $what"
return
}
}
set do_update 1
}
}
}
if {$do_update} {
Instance::update $this
}
}
proc NetworkInstance::body_interface_change {this interface comm what} {
Debug::puts NetworkInstance NetworkInstance::body_interface_change debug "Interface $interface (Comm $comm) - $what"
switch $what {
add_comm {
Instance::add_comm_fields $this $comm
}
delete_comm {
foreach arc [Implementation::get_arc_by_node_comm $Instance($this,implementation) 0 $comm] {
NetworkInstance::delete_arc $this $arc 0
}
Instance::delete_comm_fields $this $comm
} 
modified_comm {
foreach arc [Implementation::get_arc_by_node_comm $Instance($this,implementation) 0 $comm] {
NetworkInstance::delete_arc $this $arc 0
}
Instance::add_updated_parts $this comm/*/$comm
}
default {
Debug::puts NetworkInstance NetworkInstance::body_interface_change error "Unknown change $what"
return
}
}
Instance::update $this
}
proc NetworkInstance::node_implementation_change {this interface implementation what} {
Debug::puts NetworkInstance NetworkInstance::node_implementation_change debug "Implementation $implementation of Interface $interface - $what"
set do_update 0
foreach node [Implementation::get_nodes $Instance($this,implementation)] {
if {[Node::get_interface $node] == $interface && 
[Node::get_implementation $node] == $implementation} {
Debug::puts NetworkInstance NetworkInstance::implementation_change debug "Node $node has Interface $interface, Implementation $implementation"
switch $what {
deleted {
foreach arc [Implementation::get_arcs_for_node $Instance($this,implementation) $node] {
NetworkInstance::delete_arc $this $arc 0
}
NetworkInstance::delete_node $this $node 0
set do_update 1
}
name {
Instance::add_updated_parts $this node/main/name/$node
set do_update 1
}
default {
Debug::puts NetworkInstance NetworkInstance::implementation_change error "Unknown change $what"
return
}
}
}
}
if {$do_update} {
Instance::update $this
}
}
NetworkInstance::init_statics
Debug::init Node
proc Node::Node {this}  {
set Node($this,position) [new Position]
set Node($this,interface) ""
set Node($this,implementation) ""
set Node($this,parent_implementation) ""
set Node($this,xpos) ""
set Node($this,ypos) ""
set Node($this,xsize) ""
set Node($this,ysize) ""
set Node($this,angle) 0
set Node($this,shape) {}
set Node($this,index) ""
set Node($this,comms) {}
}
proc Node::init {this interface implementation parent_implementation xpos ypos xsize ysize angle} {
Debug::puts Node Node::init debug "Interface $interface, implementation $implementation @$xpos,$ypos; size $xsize x $ysize"
set Node($this,interface) $interface
set Node($this,implementation) $implementation
set Node($this,xsize) $xsize
set Node($this,ysize) $ysize
set Node($this,parent_implementation) $parent_implementation
set parent_position [Implementation::get_network_box_position $parent_implementation]
set rel_coords [Position::screen_to_normalised $parent_position $xpos $ypos]
set Node($this,xpos) [lindex $rel_coords 0]
set Node($this,ypos) [lindex $rel_coords 1]
set Node($this,angle) $angle
set Node($this,comms) [Interface::get_comms $interface]
Node::update_position $this
Node::update_rotation $this
return $this
}
proc Node::~Node {this}  {
delete $Node($this,position)
foreach comm $Node($this,comms) {
unset Node($this,plug_coords,$comm) Node($this,arrowdir,$comm)
}
unset Node($this,position) Node($this,interface) Node($this,implementation) Node($this,parent_implementation) Node($this,xpos) Node($this,ypos) Node($this,xsize) Node($this,ysize) Node($this,angle) Node($this,shape) Node($this,index) Node($this,comms)
}
proc Node::save_object {this saver} {
Saver::begin $saver Node
Saver::save_fields $saver Node $this xpos ypos xsize ysize angle
Saver::save_field $saver interface [Interface::get_name $Node($this,interface)]
Saver::save_field $saver implementation [Implementation::get_name $Node($this,implementation)]
Saver::save_field $saver implementation_type [Implementation::get_type $Node($this,implementation)]
Saver::end $saver Node
}
proc Node::load_cleanup {this parent_object parent_ref} {
set Node($this,parent_implementation) $parent_ref
}
proc Node::loaded_cleanup {this project parent_object parent_ref} {
set Node($this,interface) [Project::get_interface_by_name $project $Node($this,interface)]
set Node($this,implementation) [Interface::get_implementation_by_name_type $Node($this,interface) $Node($this,implementation) $Node($this,implementation_type)]
unset Node($this,implementation_type)
set Node($this,index) [Implementation::get_node_index $parent_ref $this]
set Node($this,comms) [Interface::get_comms $Node($this,interface)]
Node::update_position $this
Node::update_rotation $this
}
proc Node::get_interface {this} {
return $Node($this,interface)
}
proc Node::get_implementation {this} {
return $Node($this,implementation)
}
proc Node::get_position {this} {
return $Node($this,position)
}
proc Node::get_sizes {this} {
return "$Node($this,xsize) $Node($this,ysize)"
}
proc Node::get_comms {this} {
return $Node($this,comms)
}
proc Node::update {this} {
Node::update_position $this
}
proc Node::update_position {this} {
set parent_position [Implementation::get_network_box_position $Node($this,parent_implementation)]
set abs_coords [Position::normalised_to_screen $parent_position $Node($this,xpos) $Node($this,ypos)]
Debug::puts Node Node::update_position debug "Set position to $abs_coords $Node($this,xsize) $Node($this,ysize)"
eval Position::init $Node($this,position) $abs_coords $Node($this,xsize) $Node($this,ysize)
}
proc Node::update_rotation {this} {
Debug::puts Node Node::update_rotation debug "Updating rotation information"
set coords [Interface::get_shape $Node($this,interface)]
if {$coords != ""} {
set parent_angle [Interface::get_default_angle $Node($this,interface)]
set angle [expr $Node($this,angle) - $parent_angle]
Debug::puts Node Node::update debug "Found parent angle $parent_angle giving angle $angle"
set Node($this,shape) [Position::rotate_normalised_coords $angle 0.5 0.5 $coords]
}
foreach comm $Node($this,comms) {
Node::set_plug_coords $this $comm
}
}
proc Node::move {this x y} {
set parent_position [Implementation::get_network_box_position $Node($this,parent_implementation)]
set rel_coords [Position::screen_to_normalised $parent_position $x $y]
set Node($this,xpos) [lindex $rel_coords 0]
set Node($this,ypos) [lindex $rel_coords 1]
Position::move $Node($this,position) $x $y
}
proc Node::resize {this xsize ysize} {
set Node($this,xsize) $xsize
set Node($this,ysize) $ysize
Position::resize $Node($this,position) $xsize $ysize
}
proc Node::rotate {this angle} {
set Node($this,angle) [expr int(fmod($Node($this,angle) + $angle + 360, 360))]
Debug::puts Node Node::rotate debug "Rotated by $angle degrees to give $Node($this,angle) degrees"
set sizes [Position::get_sizes $Node($this,position)]
set Node($this,xsize) [lindex $sizes 1]
set Node($this,ysize) [lindex $sizes 0]
Position::resize $Node($this,position) $Node($this,xsize) $Node($this,ysize)
Debug::puts Node Node::rotate debug "Resized Node $this to $Node($this,xsize) by $Node($this,ysize)"
Node::update_rotation $this
}
proc Node::flip {this axis} {
Debug::puts Node Node::flip warning "Ignoring flip along axis $axis"
}
proc Node::get_shape {this} {
return $Node($this,shape)
}
proc Node::get_plug_coords {this comm} {
return $Node($this,plug_coords,$comm)
}
proc Node::reset_plug_coords {this comm} {
unset Node($this,plug_coords,$comm) Node($this,arrowdir,$comm)
}
proc Node::set_plug_coords {this comm} {
set parent_angle [Interface::get_default_angle $Node($this,interface)]
set angle [expr $Node($this,angle) - $parent_angle]
Debug::puts Node Node::set_plug_coords debug "Found parent angle $parent_angle giving angle $angle"
set coords [Comm::get_coords $comm]
set Node($this,plug_coords,$comm) [Position::rotate_normalised_coords $angle 0.5 0.5 $coords]
set coords [Comm::get_arrowdir $comm]
set Node($this,arrowdir,$comm) [Position::rotate_normalised_coords $angle 0 0 $coords]
set Node($this,comms) [Interface::get_comms $Node($this,interface)]
}
proc Node::get_arrowdir {this comm} {
return $Node($this,arrowdir,$comm)
}
proc Node::set_index {this index} {
set Node($this,index) $index
}
proc Node::get_index {this} {
return $Node($this,index)
}
proc Node::is_validated {this} {
return [Interface::is_validated $Node($this,interface)]
}
Viewable::add_type Arc {
{From        start_node method get_start_node_comm_description}
{To          to_node    method get_end_node_comm_description}
{Contents    {}         method get_data_type}
{Paradigms   {}         method get_paradigms}
}
Debug::init Arc
proc Arc::Arc {this}  {
set Arc($this,start_node) ""
set Arc($this,end_node) ""
set Arc($this,start_comm) ""
set Arc($this,end_comm) ""
set Arc($this,middle_coords) {}
set Arc($this,shape) ""
}
proc Arc::init {this start_node start_comm end_node end_comm middle_coords}  {
Debug::puts Arc Arc::init debug "New node from Node $start_node, Comm $start_comm to Node $end_node, Comm $end_comm with middle indices $middle_coords"
set Arc($this,start_node) $start_node
set Arc($this,start_comm) $start_comm
set Arc($this,end_node) $end_node
set Arc($this,end_comm) $end_comm
set Arc($this,middle_coords) $middle_coords
}
proc Arc::~Arc {this}  {
unset Arc($this,start_node) Arc($this,start_comm) Arc($this,end_node) Arc($this,end_comm) Arc($this,middle_coords) Arc($this,shape)
}
proc Arc::save_object {this saver} {
Saver::begin $saver Arc
Saver::save_field $saver middle_coords $Arc($this,middle_coords)
if {$Arc($this,start_node) == 0} {
set start_index 0
} else {
set start_index [Node::get_index $Arc($this,start_node)]
}
Saver::save_field $saver start_node $start_index
Saver::save_field $saver start_comm [Comm::get_name $Arc($this,start_comm)]
if {$Arc($this,end_node) == 0} {
set end_index 0
} else {
set end_index [Node::get_index $Arc($this,end_node)]
}
Saver::save_field $saver end_node $end_index
Saver::save_field $saver end_comm [Comm::get_name $Arc($this,end_comm)]
Saver::end $saver Arc
}
proc Arc::load_cleanup {this parent_object parent_ref} {
}
proc Arc::loaded_cleanup {this project parent_object parent_ref} {
if {$Arc($this,start_node) !=0} {
set Arc($this,start_node) [Implementation::get_node_by_index $parent_ref $Arc($this,start_node)]
set start_interface [Node::get_interface $Arc($this,start_node)]
} else {
set start_interface [Implementation::get_interface $parent_ref]
}
set Arc($this,start_comm) [Interface::get_comm_by_name $start_interface $Arc($this,start_comm)]
if {$Arc($this,end_node) != 0} {
set Arc($this,end_node) [Implementation::get_node_by_index $parent_ref $Arc($this,end_node)]
set end_interface [Node::get_interface $Arc($this,end_node)]
} else {
set end_interface [Implementation::get_interface $parent_ref]
}
set Arc($this,end_comm) [Interface::get_comm_by_name $end_interface $Arc($this,end_comm)]
}
proc Arc::get_middle_coords {this} {
return $Arc($this,middle_coords)
}
proc Arc::get_start_details {this} {
return [list $Arc($this,start_node) $Arc($this,start_comm)]
}
proc Arc::get_end_details {this} {
return [list $Arc($this,end_node) $Arc($this,end_comm)]
}
proc Arc::get_head {this} {
if {$Arc($this,start_node) == 0} {
return [Comm::get_reversed_head $Arc($this,start_comm)]
} else {
return [Comm::get_head $Arc($this,start_comm)]
}
}
proc Arc::attached_to_node {this node} {
return [expr $node == $Arc($this,start_node) || $node == $Arc($this,end_node) ]
}
proc Arc::get_all_details {this} {
return [list $Arc($this,start_node) $Arc($this,start_comm) $Arc($this,end_node) $Arc($this,end_comm)]
}
proc Arc::attached_to_node_comm {this node comm} {
return [expr ($node == $Arc($this,start_node) && $comm == $Arc($this,start_comm)) || ($node == $Arc($this,end_node) && $comm == $Arc($this,end_comm)) ]
}
proc Arc::get_start_node_name {this} {
if {$Arc($this,start_node) == 0} {
return "Edge"
} else {
set interface [Node::get_interface $Arc($this,start_node)]
set implementation [Node::get_implementation $Arc($this,start_node)]
return [Interface::get_pretty_label $interface $implementation 0]
}
}
proc Arc::get_end_node_name {this} {
if {$Arc($this,end_node) == 0} {
return "Edge"
} else {
set interface [Node::get_interface $Arc($this,end_node)]
set implementation [Node::get_implementation $Arc($this,end_node)]
return [Interface::get_pretty_label $interface $implementation 0]
}
}
proc Arc::get_data_type {this} {
return [Comm::get_data_type $Arc($this,start_comm)]
}
proc Arc::get_paradigms {this} {
return "[Paradigm::get_label [Comm::get_paradigm $Arc($this,start_comm)]] and [Paradigm::get_label [Comm::get_paradigm $Arc($this,end_comm)]]"
}
proc Arc::get_object_title {this} {
return "Arc"
}
proc Arc::get_object_description {this} {
return "Arc"
}
proc Arc::get_direction {this} {
return [Comm::get_direction $Arc($this,start_comm)]
}
proc Arc::is_at_edge {this} {
return [expr $Arc($this,start_node) == 0 || $Arc($this,end_node) == 0]
}
proc Arc::get_edge_name {this} {
if {$Arc($this,start_node) == 0} {
return [Comm::get_name $Arc($this,start_comm)]
}
return [Comm::get_name $Arc($this,end_comm)]
}
proc Arc::get_start_node_comm_description {this} {
return "[Arc::get_start_node_name $this], [Comm::get_name $Arc($this,start_comm)]"
}
proc Arc::get_end_node_comm_description {this} {
return "[Arc::get_end_node_name $this], [Comm::get_name $Arc($this,end_comm)]"
}
Debug::init Route
proc Route::Route {this}  {
set Route($this,nodes) {}
set Route($this,used_nodes) {}
}
proc Route::~Route {this} {
foreach row_node $Route($this,used_nodes) {
foreach column_node $Route($this,used_nodes) {
unset Route($this,route,$row_node,$column_node)
}
}
unset Route($this,nodes) Route($this,used_nodes)
}
proc Route::display {this} {
set len [llength $Route($this,nodes)]
puts "Route::display: There are $len nodes in Route $this (used nodes are: $Route($this,used_nodes))"
set bar    "    "
set output "    "
foreach column_node $Route($this,nodes) {
set bar "${bar}----"
set output "$output [format {%3d} $column_node]"
}
puts $output
puts $bar
foreach row_node $Route($this,nodes) {
set output [format "%3d:" $row_node]
foreach column_node $Route($this,nodes) {
set val $Route($this,route,$row_node,$column_node)
if {$val != 0} {
set output "$output [format {%3d} $val]"
} else {
set output "$output    "
}
}
puts $output
}
}
proc Route::row_sum {this row} {
set total 0
foreach column_node $Route($this,nodes) {
incr total $Route($this,route,$row,$column_node)
}
Debug::puts Route Route::row_sum debug "Route $this, sum of row $row is $total"
return $total
}
proc Route::column_sum {this column} {
set total 0
foreach row_node $Route($this,nodes) {
incr total $Route($this,route,$row_node,$column)
}
Debug::puts Route Route::column_sum debug "Route $this, sum of column $column is $total"
return $total
}
proc Route::add_node {this node} {
Debug::puts Route Route::add_node debug "Route $this, node $node"
foreach n $Route($this,used_nodes) {
set Route($this,route,$n,$node) 0
set Route($this,route,$node,$n) 0
}
lappend Route($this,nodes) $node
if {[lsearch -exact $Route($this,used_nodes) $node] < 0} {
lappend Route($this,used_nodes) $node
}
Debug::puts Route Route::add_node debug "Nodes=$Route($this,nodes); Used nodes=$Route($this,used_nodes)"
set Route($this,route,$node,$node) 1
}
proc Route::subtract_node {this node} {
Debug::puts Route Route::subtract_node debug "Route $this, node $node"
set ix [lsearch -exact $Route($this,nodes) $node]
set Route($this,nodes) [lreplace $Route($this,nodes) $ix $ix]
set ix [lsearch -exact $Route($this,nodes) $node]
set Route($this,nodes) [lreplace $Route($this,nodes) $ix $ix]
set ix [lsearch -exact $Route($this,used_nodes) $node]
set Route($this,used_nodes) [lreplace $Route($this,used_nodes) $ix $ix]
foreach n $Route($this,used_nodes) {
unset Route($this,route,$n,$node)
unset Route($this,route,$node,$n)
}
unset Route($this,route,$node,$node)
return 1
}
proc Route::rename_node {this old_node new_node} {
Debug::puts Route Route::rename_node debug "Route $this.  Rename from node $old_node to $new_node"
set ix [lsearch -exact $Route($this,nodes) $old_node]
set Route($this,nodes) [lreplace $Route($this,nodes) $ix $ix $new_node]
set ix [lsearch -exact $Route($this,used_nodes) $old_node]
set Route($this,used_nodes) [lreplace $Route($this,used_nodes) $ix $ix $new_node]
foreach node $Route($this,used_nodes) {
if {$node == $new_node} {
continue
}
set Route($this,route,$node,$new_node) $Route($this,route,$node,$old_node)
unset Route($this,route,$node,$old_node)
set Route($this,route,$new_node,$node) $Route($this,route,$old_node,$node)
unset Route($this,route,$old_node,$node)
}
set Route($this,route,$new_node,$new_node) 1
unset Route($this,route,$old_node,$old_node)
}
proc Route::add_arc {this start_node end_node} {
Debug::puts Route Route::add_arc debug "Route $this; Arc from $start_node => $end_node"
if {$Route($this,route,$end_node,$start_node) > 0} {
return 0
}
foreach node_i $Route($this,nodes) {
set routes_i_to_start_node $Route($this,route,$node_i,$start_node)
if {$routes_i_to_start_node >0} {
foreach node_j $Route($this,nodes) {
incr Route($this,route,$node_i,$node_j) [expr $routes_i_to_start_node * $Route($this,route,$end_node,$node_j)]
}
}
}
Debug::puts Route Route::add_arc debug "Added arc from $start_node => $end_node to Route $this"
if {[Debug::debugging_class Route]} {
puts "Added arc from $start_node => $end_node to Route $this"
Route::display $this
}
return 1
}
proc Route::subtract_arc {this start_node end_node} {
Debug::puts Route Route::subtract_arc debug "Route $this; Arc from $start_node => $end_node"
foreach node_i $Route($this,nodes) {
set routes_i_to_start_node $Route($this,route,$node_i,$start_node)
if {$routes_i_to_start_node >0} {
foreach node_j $Route($this,nodes) {
incr Route($this,route,$node_i,$node_j) [expr -$routes_i_to_start_node * $Route($this,route,$end_node,$node_j)]
}
}
}
Debug::puts Route Route::subtract_arc debug "Subtracted arc from $start_node => $end_node from Route $this"
if {[Debug::debugging_class Route]} {
puts "Subtracted arc from $start_node => $end_node to Route $this"
Route::display $this
}
}
proc Route::check_add_arc {this start_node end_node} {
Debug::puts Route Route::check_add_arc debug "Route $this; Arc from $start_node => $end_node"
if {$Route($this,route,$end_node,$start_node) > 0} {
return 0
}
return 1
}
Debug::init Project
proc Project::Project {this argv} {
set Project(ref) $this
set Project($this,name) ""
set Project($this,description) ""
set Project($this,cur_language) [Language::get_default_language]
set Project($this,interfaces) {}
set Project(cur_canvas) ""
set Project(cur_window) ""
set Project(modelabel) ""
set Project(mode) ""
Project::reset_mode $this
set Project(cur_tags) ""
set Project(cur_id) ""
Options::init_option show_node_type_in_net_window "Show Node Types" 0
Options::init_option show_node_paradigm_in_net_window "Show Node Paradigm" 1
set Project(selection) [new Select]
set Project(NetworkWindow) [new NetworkWindow .network $this 0]
set Project(AttributesWindow) [new AttributesWindow .attributes $this 0]
set Project(InterfaceWindow) [new InterfaceWindow .interface $this 0]
set Project(ProjectWindow) [new ProjectWindow . $this 1]
if {$argv != ""} {
set filename [File::enforce_suffix [lindex $argv 0] $Project(file_suffix)]
ProjectWindow::MenuProjectOpen $Project(ProjectWindow) $filename
}
}
proc Project::init_statics {} {
set Project(version) "1.02"
set Project(file_label) "-- ODT $Project(version) Project"
set Project(file_suffix) "odt"
}
proc Project::~Project {this} {
Project::clear $this
delete $Project(selection)
delete $Project(NetworkWindow)
delete $Project(AttributesWindow)
delete $Project(InterfaceWindow)
delete $Project(ProjectWindow)
unset Project($this,name) Project($this,description) Project($this,cur_language) Project($this,interfaces) Project(selection)  Project(cur_canvas) Project(cur_window) Project(modelabel) Project(mode) Project(cur_tags) Project(cur_id) Project(NetworkWindow) Project(AttributesWindow) Project(InterfaceWindow) Project(ProjectWindow)
}
proc Project::canvas_bindings {this childtype child where} {
set name [Window::get_name $child]
bind $where <Any-Enter> "Project::canvas_enter $this $where $name"
bind $where <Any-Leave> "Project::canvas_leave $this $where"
bind $where <Shift-Motion> "Project::motion $this $where %x %y 1"
bind $where <Motion> "Project::motion $this $where %x %y 0"
bind $where <Shift-ButtonPress-1> "Project::button1down $this $where %x %y 1"
bind $where <Double-ButtonPress-1> "Project::doublebutton1 $this $where %x %y"
bind $where <ButtonPress-1> "Project::button1down $this $where %x %y 0"
bind $where <ButtonRelease-1> "Project::button1up $this $where %x %y"
bind $where <Shift-Button1-Motion> "Project::button1andmotion $this $where %x %y 1"
bind $where <Button1-Motion> "Project::button1andmotion $this $where %x %y 0"
bind $where <ButtonPress-2> "Project::button2down $this $where %x %y"
bind $where <ButtonRelease-2> "Project::button2up $this $where %x %y"
bind $where <Shift-Button2-Motion> "Project::button2andmotion $this $where %x %y 1"
bind $where <Button2-Motion> "Project::button2andmotion $this $where %x %y 0"
$where bind clickable <Any-Enter> "Project::element_enter $this $where %x %y"
$where bind clickable <Any-Leave> "Project::element_leave $this $where %x %y"
set place [Window::get_place $child]
bind $place <KeyPress-1> {Window::togglewindow Interface}
bind $place <KeyPress-2> {Window::togglewindow Network}
bind $place <KeyPress-3> {Window::togglewindow Attributes}
set Project(child,$where) $child
set Project(childtype,$where) $childtype
set Project(childwindowname,$where) $name
}
proc Project::canvas_enter {this canvas winname} {
Debug::puts Project Project::canvas_enter debug "Canvas $canvas window $winname"
set Project(cur_canvas) $canvas
set Project(cur_window) $winname
set Project(cur_id) ""
}
proc Project::canvas_leave {this canvas} {
if {$Project(cur_canvas)!=""} {
Debug::puts Project Project::canvas_leave debug "Canvas $canvas window"
Project::message $this ""
set Project(cur_canvas) ""
set Project(cur_window) ""
Project::reset_mode $this
}
}
proc Project::update_cur_tags {this canvas x y use_current} {
set Project(cur_canvas) $canvas
set Project(cur_window) $Project(childwindowname,$canvas)
if {$use_current} {
set ids [$Project(cur_canvas) find withtag current]
} else {
set ids [$Project(cur_canvas) find overlapping [expr $x -1] [expr $y -1] [expr $x +1] [expr $y +1]]
}
set i [expr [llength $ids]-1]
while {$i >=0} {
set id [lindex $ids $i]
if {$id == $Project(cur_id)} {
return
}
set tags [$Project(cur_canvas) gettags $id]
if {$tags !="" && [lsearch -exact $tags clickable]>=0} {
Debug::puts Project Project::update_cur_tags debug "Id $id; has valid tags $tags"
set Project(cur_tags) $tags
set Project(cur_id) $id
Project::update_element_message $this
return
}
incr i -1
}
set Project(cur_tags) ""
set Project(cur_id) ""
Project::update_element_message $this
}
proc Project::motion {this canvas x y shift} {
set x [$canvas canvasx $x]
set y [$canvas canvasy $y]
Debug::puts Project Project::motion debug "On canvas $Project(cur_canvas) @$x,$y; shift=$shift"
Project::update_cur_tags $this $canvas $x $y 0
if {$Project(cur_tags) != ""} {
eval [eval [concat {Mode::motion $Project(mode) $x $y $shift} $Project(cur_tags)]]
} else {
eval [Mode::motion $Project(mode) $x $y $shift {} {} {} {} {}]
}
}
proc Project::button1down {this canvas x y shift} {
set x [$canvas canvasx $x]
set y [$canvas canvasy $y]
Debug::puts Project Project::button1down debug "On canvas $Project(cur_canvas) @$x,$y; shift=$shift"
Project::update_cur_tags $this $canvas $x $y 0
if {![Mode::is_selection_allowed $Project(mode)]} {
if {$Project(cur_tags) != ""} {
eval [eval [concat {Mode::button1down $Project(mode) $x $y $shift} $Project(cur_tags)]]
} else {
eval [Mode::button1down $Project(mode) $x $y $shift {} {} {} {} {}]
}
return
}
if {$Project(cur_tags) != ""} {
if {[lsearch -exact $Project(cur_tags) selectable]>=0} {
if {$shift==1} {
eval Select::append 1 $Project(cur_tags)
} else {
eval Select::set $Project(cur_tags)
}
}
eval [concat {Project::tochild $this 1 button1down $x $y $shift} $Project(cur_tags)]
} else {
Select::clear
eval [Mode::button1down $Project(mode) $x $y $shift {} {} {} {} {}]
}
}
proc Project::button1andmotion {this canvas x y shift} {
set x [$canvas canvasx $x]
set y [$canvas canvasy $y]
Debug::puts Project Project::button1andmotion debug "On canvas $Project(cur_canvas) @$x,$y; shift=$shift";
Project::update_cur_tags $this $canvas $x $y 0
if {$Project(cur_tags) != ""} {
eval [eval [concat {Mode::button1andmotion $Project(mode) $x $y $shift} $Project(cur_tags)]]
} else {
eval [Mode::button1andmotion $Project(mode) $x $y $shift {} {} {} {} {}]
}
}
proc Project::button1up {this canvas x y} {
set x [$canvas canvasx $x]
set y [$canvas canvasy $y]
Debug::puts Project Project::button1up debug "On canvas $Project(cur_canvas) @$x,$y";
Project::update_cur_tags $this $canvas $x $y 0
if {![Mode::is_selection_allowed $Project(mode)]} {
if {$Project(cur_tags) != ""} {
eval [eval [concat {Mode::button1up $Project(mode) $x $y} $Project(cur_tags)]]
} else {
eval [Mode::button1up $Project(mode) $x $y {} {} {} {} {}]
}
return
}
if {$Project(cur_tags) != ""} {
eval [concat {Project::tochild $this 0 button1up $x $y} $Project(cur_tags)]
} else {
eval [Mode::button1up $Project(mode) $x $y {} {} {} {} {}]
}
}
proc Project::doublebutton1 {this canvas x y} {
set x [$canvas canvasx $x]
set y [$canvas canvasy $y]
Debug::puts Project Project::doublebutton1 debug "On canvas $Project(cur_canvas) @$x,$y"
Project::update_cur_tags $this $canvas $x $y 0
if {![Mode::is_selection_allowed $Project(mode)]} {
if {$Project(cur_tags) != ""} {
eval [eval [concat {Mode::doublebutton1 $Project(mode) $x $y} $Project(cur_tags)]]
} else {
eval [Mode::doublebutton1 $Project(mode) $x $y {} {} {} {} {}]
}
return
}
if {$Project(cur_tags) != ""} {
if {[lsearch -exact $Project(cur_tags) selectable]>=0} {
eval Select::set $Project(cur_tags)
}
eval [concat {Project::tochild $this 1 doublebutton1 $x $y} $Project(cur_tags)]
} else {
Select::clear
eval [Mode::doublebutton1 $Project(mode) $x $y {} {} {} {} {}]
}
}
proc Project::button2down {this canvas x y} {
set x [$canvas canvasx $x]
set y [$canvas canvasy $y]
Debug::puts Project Project::button2down debug "On canvas $Project(cur_canvas) @$x,$y";
Project::update_cur_tags $this $canvas $x $y 0
if {![Mode::is_selection_allowed $Project(mode)]} {
if {$Project(cur_tags) != ""} {
eval [eval [concat {Mode::button2down $Project(mode) $x $y} $Project(cur_tags)]]
} else {
eval [Mode::button2down $Project(mode) $x $y {} {} {} {} {}]
}
return
}
if {$Project(cur_tags) != ""} {
eval [concat {Project::tochild $this 0 button2down $x $y} $Project(cur_tags)]
} else {
eval [Mode::button2down $Project(mode) $x $y {} {} {} {} {}]
}
}
proc Project::button2up {this canvas x y} {
set x [$canvas canvasx $x]
set y [$canvas canvasy $y]
Debug::puts Project Project::button2up debug "On canvas $Project(cur_canvas) @$x,$y";
Project::update_cur_tags $this $canvas $x $y 0
eval [eval [concat {Mode::button2up $Project(mode) $x $y} $Project(cur_tags)]]
}
proc Project::button2andmotion {this canvas x y shift} {
set x [$canvas canvasx $x]
set y [$canvas canvasy $y]
Debug::puts Project Project::button2andmotion debug "On canvas $Project(cur_canvas) @$x,$y; shift=$shift";
Project::update_cur_tags $this $canvas $x $y 0
if {$Project(cur_tags) != ""} {
eval [eval [concat {Mode::button2andmotion $Project(mode) $x $y $shift} $Project(cur_tags)]]
} else {
eval [Mode::button2andmotion $Project(mode) $x $y $shift {} {} {} {} {}]
}
}
proc Project::element_enter {this canvas x y} {
set Project(cur_canvas) $canvas
set x [$canvas canvasx $x]
set y [$canvas canvasy $y]
Project::update_cur_tags $this $canvas $x $y 1
}
proc Project::element_leave {this canvas x y} {
set Project(cur_canvas) $canvas
set x [$canvas canvasx $x]
set y [$canvas canvasy $y]
Project::update_cur_tags $this $canvas $x $y 0
}
proc Project::update_element_message {this} {
if {![Debug::debugging_class Project]} {
return
}
if {$Project(cur_canvas) != ""} {
if {$Project(cur_tags) != ""} {
Project::message $this $Project(cur_tags)
} else {
Project::message $this ""
}
} else {
Project::message $this {Inside element outside any canvas}
}
}
proc Project::set_mode {this mode sx sy ex ey args} {
eval [concat {Project::set_mode2 $this $mode $Project(cur_canvas) $sx $sy $ex $ey} $args]
}  
proc Project::set_mode2 {this mode canvas sx sy ex ey args} {
Debug::puts Project Project::set_mode2 debug "Mode $mode on canvas $canvas @$sx,$sy - $ex,$ey args=$args"
set Project(cur_canvas) $canvas
if {$Project(mode) != ""} {
delete $Project(mode)
}
set Project(mode) [eval new [concat {Mode$mode $canvas $this $sx $sy $ex $ey} $args]]
set Project(modelabel) $mode
}  
proc Project::reset_mode {this} {
if {$Project(modelabel) != "None"} {
Debug::puts Project Project::reset_mode debug ""
Project::set_mode $this None 0 0 0 0
}
}
proc Project::message {this message} {
if {$Project(cur_window)!=""} {
set child $Project(child,$Project(cur_canvas))
Window::message $child $message
} else {
if {$message != ""} {
puts "(No current window): $message"
}
}
}
proc Project::tochild {this do_resetmode op args} {
Debug::puts Project Project::tochild debug "Do_reset?=$do_resetmode op=$op args=$args"
if {$do_resetmode} {
Debug::puts Project Project::tochild debug "Doing reset mode"
Project::reset_mode $this
}
set childtype $Project(childtype,$Project(cur_canvas))
set child $Project(child,$Project(cur_canvas))
Debug::puts Project Project::tochild debug "Running Window::$op $child $args"
eval Window::$op $child $args
}
proc Project::get_cur_language {this} {
return $Project($this,cur_language)
}
proc Project::set_cur_language {this language} {
if {$Project($this,cur_language) != $language} {
set Project($this,cur_language) $language
}
}
proc Project::get_interfaces {this} {
return $Project($this,interfaces)
}
proc Project::add_interface {this interface} {
lappend Project($this,interfaces) $interface
}
proc Project::delete_interface {this interface} {
set ix [lsearch -exact $Project($this,interfaces) $interface]
if {$ix >= 0} {
set Project($this,interfaces) [lreplace $Project($this,interfaces) $ix $ix]
Debug::puts Project Project::delete_interface debug "After interfaces=$Project($this,interfaces)"
NetworkWindow::interface_change $Project(NetworkWindow) $interface {} deleted
foreach interface2 $Project($this,interfaces) {
if {$interface2 != $interface} {
set impl_list {}
foreach impl [Interface::get_network_implementations $interface2] {
if {![lsearch -exact $impl_list $impl]} {
lappend impl_list $impl
}
}
foreach impl $impl_list {
Implementation::interface_change $impl $interface {} deleted
}
}
}
delete $interface
return 1
} else {
Debug::puts Project Project::delete_interface error "Interface $interface not in list of interfaces"
return 0
}
}
proc Project::modified_interface_major {interface comm what} {
NetworkWindow::interface_change $Project(NetworkWindow) $interface $comm $what
set this $Project(ref)
set impl_list {}
foreach interface2 $Project($this,interfaces) {
if {$interface2 != $interface} {
foreach impl [Interface::get_network_implementations $interface2] {
if {![lsearch -exact $impl_list $impl]} {
lappend impl_list $impl
}
}
foreach impl $impl_list {
Implementation::interface_change $impl $interface $comm $what
}
}
}
}
proc Project::delete_implementation {this interface implementation} {
Interface::delete_implementation $interface $implementation
Project::implementation_change $interface $implementation deleted
delete $implementation
}
proc Project::implementation_change {interface implementation what} {
set this $Project(ref)
NetworkWindow::implementation_change $Project(NetworkWindow) $interface $implementation $what
foreach interface2 $Project($this,interfaces) {
if {$interface2 != $interface} {
set impl_list {}
foreach impl [Interface::get_network_implementations $interface2] {
if {![lsearch -exact $impl_list $impl]} {
lappend impl_list $impl
}
}
foreach impl $impl_list {
Implementation::implementation_change $impl $interface $implementation $what
}
}
}
}
proc Project::pick_interface {this interface implementation active} {
if {$active ==1} {
NetworkWindow::pick_interface $Project(NetworkWindow) $interface $implementation
}
AttributesWindow::set_attributes
}
proc Project::save_project {this} {
Project::save_project_as $this $Project($this,name)
}
proc Project::save_project_as {this filename} {
set filename [File::enforce_suffix $filename $Project(file_suffix)]
set working_filename [File::begin_save $filename]
set saver [new Saver $Project(file_label) $working_filename]
Project::save_object $this $saver
delete $saver
if {![File::end_save $filename]} {
return
}
}
proc Project::save_object {this saver} {
Saver::begin $saver Project
Saver::save_fields $saver Project $this name description
Saver::save_field $saver cur_language [Language::get_name $Project($this,cur_language)]
Saver::begin_list $saver interfaces
foreach interface $Project($this,interfaces) {
Interface::save_object $interface $saver
}
Saver::end_list $saver
Saver::end $saver Project
}
proc Project::load_project_from {this filename} {
set filename [File::enforce_suffix $filename $Project(file_suffix)]
set object [Load $filename $this]
if {$object != ""} {
set Project($this,name) $filename
return 1
}
return 0
}
proc Project::load_cleanup {this parent parent_ref} {
set Project($this,cur_language) [Language::get_by_name $Project($this,cur_language)]
}
proc Project::loaded_cleanup {this project parent parent_ref} {
foreach interface $Project($this,interfaces) {
Interface::loaded_cleanup $interface $project Project $this
}
InterfaceWindow::refresh $Project(InterfaceWindow)
}
proc Project::get_interface_by_name {this name} {
foreach interface $Project($this,interfaces) {
if {[Interface::get_name $interface] == $name} {
Debug::puts Project Project::get_interface_by_name debug "Found Interface $interface for name $name"
return $interface
}
}
Debug::puts Project Project::get_interface_by_name debug "Found NO Interface for name $name"
return ""
}
proc Project::is_modified {this} {
foreach interface $Project($this,interfaces) {
if {[Interface::is_modified $interface]} {
return 1
}
}
return 0
}
proc Project::get_name {this} {
return $Project($this,name)
}
proc Project::set_name {this name} {
set Project($this,name) $name
}
proc Project::clear {this} {
foreach interface $Project($this,interfaces) {
delete $interface
}
set Project($this,interfaces) {}
NetworkWindow::deleted_all_interfaces $Project(NetworkWindow)
InterfaceWindow::deleted_all_interfaces $Project(InterfaceWindow)
set Project($this,name) ""
set Project($this,description) ""
}
proc Project::is_clear {this} {
return [expr [llength $Project($this,interfaces)] == 0]
}
proc Project::get_version {} {
return $Project(version)
}
Project::init_statics
Debug::init Mode
proc Mode::Mode {this name canvas parent sx sy ex ey is_selection_allowed} {
set Mode($this,name) $canvas
set Mode($this,canvas) $canvas
set Mode($this,parent) $parent
set Mode($this,startx) $sx
set Mode($this,starty) $sy
set Mode($this,endx) $ex
set Mode($this,endy) $ey
set Mode($this,is_selection_allowed) $is_selection_allowed
}
proc Mode::init_statics {} {
set Mode(selection_box_min_size) 5
set Mode(moving_min_move) 0
}
proc Mode::~Mode {this} {
unset Mode($this,name) Mode($this,canvas) Mode($this,parent) Mode($this,startx) Mode($this,starty) Mode($this,endx) Mode($this,endy) Mode($this,is_selection_allowed)
}
virtual proc Mode::button1down {this x y shift args} {}
virtual proc Mode::button1andmotion {this x y shift args} {}
virtual proc Mode::button1up {this x y args} {}
virtual proc Mode::button2up {this x y args} {}
virtual proc Mode::button2down {this x y args} {}
virtual proc Mode::button2andmotion {this x y shift args} {}
virtual proc Mode::doublebutton1 {this x y args} {}
virtual proc Mode::motion {this x y shift args} {}
proc Mode::is_selection_allowed {this} {
return $Mode($this,is_selection_allowed)
}
Mode::init_statics
Debug::init ModeNone
proc ModeNone::ModeNone {this canvas parent sx sy ex ey args} Mode {
None $canvas $parent $sx $sy $ex $ey 1
} {
Debug::puts ModeNone ModeNone::ModeNone debug ""
}
proc ModeNone::~ModeNone {this} {}
proc ModeNone::button1down {this x y shift args} {
Debug::puts ModeNone ModeNone::button1down debug "@$x,$y shift=$shift; args=$args"
return "Project::set_mode $Mode($this,parent) Selecting $x $y $x $y"
}
Debug::init ModeSelecting
proc ModeSelecting::ModeSelecting {this canvas parent sx sy ex ey args} Mode {
Selecting $canvas $parent $sx $sy $ex $ey 0
} {
Debug::puts ModeSelecting ModeSelecting::ModeSelecting debug "Canvas=$canvas @$sx,$sy-$ex,$ey"
Select::clear
$Mode($this,canvas) create rectangle $sx $sy $ex $ey -outline [Colour::get_fg] -width 1 -tags selecting_rect
}
proc ModeSelecting::~ModeSelecting {this} {
$Mode($this,canvas) delete selecting_rect
}
proc ModeSelecting::button1andmotion {this x y shift args} {
Debug::puts ModeSelecting ModeSelecting::button1andmotion debug "To $x,$y; shift=$shift; args=$args"
set x0 $Mode($this,startx)
set y0 $Mode($this,starty)
$Mode($this,canvas) coords selecting_rect $x0 $y0 $x $y
}
proc ModeSelecting::button1down {this x y shift args} {
Debug::puts ModeSelecting ModeSelecting::button1down debug "@$x,$y (shift=$shift); args=$args"
$Mode($this,canvas) create rectangle $x $y $x $y -outline [Colour::get_fg] -width 1 -tags selecting_rect
}
proc ModeSelecting::button1up {this x y args} {
Debug::puts ModeSelecting ModeSelecting::button1up debug "@$x,$y; args=$args"
if {([expr abs($Mode($this,startx) - $x)] <= $Mode(selection_box_min_size)) &&
([expr abs($Mode($this,starty) - $y)] <= $Mode(selection_box_min_size))} {
Debug::puts ModeSelecting ModeSelecting::button1up debug "Single click @$x,$y"
return "Project::tochild $Mode($this,parent) 1 click $x $y"
}
Debug::puts ModeSelecting ModeSelecting::button1up debug "Dragged from $Mode($this,startx), $Mode($this,starty) - $x,$y"
set x0 $Mode($this,startx)
set y0 $Mode($this,starty)
if {$x0 > $x} {
set t $x0
set x0 $x
set x $t
}
if {$y0 > $y} {
set t $y0
set y0 $y
set y $t
}
set els [$Mode($this,canvas) find enclosed $x0 $y0 $x $y]
foreach id $els {
set tags [$Mode($this,canvas) gettags $id]
if {[lsearch -exact $tags selectable]>=0} {
Debug::puts ModeSelecting ModeSelecting::button1up debug "Enclosed element (id=$id): $tags"
eval Select::append 0 $tags
}
}
return "Project::reset_mode $Mode($this,parent)"
}
Debug::init ModePlacing
proc ModePlacing::ModePlacing {this canvas parent sx sy ex ey position args} Mode {
Placing $canvas $parent $sx $sy $ex $ey 0
} {
Debug::puts ModePlacing ModePlacing::ModePlacing debug "Canvas=$canvas @$sx,$sy-$ex,$ey; args=$args"
set sizes [Position::get_sizes $position]
set xsize [lindex $sizes 0]
set ysize [lindex $sizes 1]
set xoffset [expr -$xsize/2]
set yoffset [expr -$ysize/2]
set ModePlacing($this,handle_xoffset) $xoffset
set ModePlacing($this,handle_yoffset) $yoffset
set ModePlacing($this,xsize) $xsize
set ModePlacing($this,ysize) $ysize
set ModePlacing($this,xsize_and_offset) [expr $xsize + $xoffset]
set ModePlacing($this,ysize_and_offset) [expr $ysize + $yoffset]
set ModePlacing($this,args) $args
$canvas create rectangle [expr $sx + $xoffset] [expr $sy + $yoffset] [expr $sx + $ModePlacing($this,xsize_and_offset)] [expr $sy + $ModePlacing($this,ysize_and_offset)] -outline [Colour::get_fg] -width 3 -tags placing_rectangle
}
proc ModePlacing::~ModePlacing {this} {
$Mode($this,canvas) delete placing_rectangle
unset ModePlacing($this,handle_xoffset) ModePlacing($this,handle_yoffset) ModePlacing($this,xsize) ModePlacing($this,ysize) ModePlacing($this,xsize_and_offset) ModePlacing($this,ysize_and_offset) ModePlacing($this,args)
}
proc ModePlacing::motion {this x y shift args} {
$Mode($this,canvas) coords placing_rectangle [expr $x + $ModePlacing($this,handle_xoffset)] [expr $y + $ModePlacing($this,handle_yoffset)] [expr $x + $ModePlacing($this,xsize_and_offset)] [expr $y + $ModePlacing($this,ysize_and_offset)]
}
proc ModePlacing::button1up {this x y args} {
Debug::puts ModePlacing ModePlacing::button1up debug "@$x,$y; args=$args"
set x_final [expr $x + $ModePlacing($this,handle_xoffset)]
set y_final [expr $y + $ModePlacing($this,handle_yoffset)]
set args $ModePlacing($this,args)
return "Project::tochild $Mode($this,parent) 1 placed $x_final $y_final $ModePlacing($this,xsize) $ModePlacing($this,ysize) $args"
}
Debug::init ModeMoving
proc ModeMoving::ModeMoving {this canvas parent sx sy ex ey xoffset yoffset xsize ysize args} Mode {
Moving $canvas $parent $sx $sy $ex $ey 0
} {
Debug::puts ModeMoving ModeMoving::ModeMoving debug "Canvas=$canvas @$sx,$sy-$ex,$ey; offset=$xoffset,$yoffset; size=$xsize,$ysize; args=$args"
eval Select::set $args
set ModeMoving($this,handle_xoffset) $xoffset
set ModeMoving($this,handle_yoffset) $yoffset
set ModeMoving($this,xsize) $xsize
set ModeMoving($this,ysize) $ysize
set ModeMoving($this,args) $args
if {$xsize >0} {
$Mode($this,canvas) create rectangle [expr $sx - $xoffset] [expr $sy - $yoffset] [expr $sx - $xoffset + $xsize] [expr $sy - $yoffset + $ysize] -outline [Colour::get_fg] -width 1 -tags moving_rect
}
}
proc ModeMoving::~ModeMoving {this} {
$Mode($this,canvas) delete moving_rect
unset ModeMoving($this,handle_xoffset) ModeMoving($this,handle_yoffset)  ModeMoving($this,args) ModeMoving($this,xsize) ModeMoving($this,ysize)
}
proc ModeMoving::button2andmotion {this x y shift args} {
Debug::puts ModeMoving ModeMoving::button2andmotion debug "To $x,$y; shift=$shift; args=$args"
set x_final [expr $x - $ModeMoving($this,handle_xoffset)]
set y_final [expr $y - $ModeMoving($this,handle_yoffset)]
if {$ModeMoving($this,xsize) == 0} {
return "Project::tochild $Mode($this,parent) 0 move_to $x_final $y_final $ModeMoving($this,args)"
} else {
set xoffset $ModeMoving($this,handle_xoffset)
set yoffset $ModeMoving($this,handle_yoffset)
$Mode($this,canvas) coords moving_rect [expr $x - $xoffset] [expr $y - $yoffset] [expr $x - $xoffset + $ModeMoving($this,xsize)] [expr $y - $yoffset + $ModeMoving($this,ysize)]
}
}
proc ModeMoving::button2up {this x y args} {
Debug::puts ModeMoving ModeMoving::button2up debug "@$x,$y; args=$args"
if {([expr abs($Mode($this,startx) - $x)] <= $Mode(moving_min_move)) &&
([expr abs($Mode($this,starty) - $y)] <= $Mode(moving_min_move))} {
Debug::puts ModeMoving ModeMoving::button2up debug "Single button2up @$x,$y; reseting mode"
return "Project::reset_mode $Mode($this,parent)"
}
set x_final [expr $x - $ModeMoving($this,handle_xoffset)]
set y_final [expr $y - $ModeMoving($this,handle_yoffset)]
set args $ModeMoving($this,args)
return "Project::tochild $Mode($this,parent) 1 moved $x_final $y_final $args"
}
Debug::init ModeResizing
proc ModeResizing::ModeResizing {this canvas parent sx sy ex ey xsize ysize min_xsize min_ysize args} Mode {
Resizing $canvas $parent $sx $sy $ex $ey 0
} {
Debug::puts ModeResizing ModeResizing::ModeResizing debug "Canvas=$canvas @$sx,$sy-$ex,$ey; size=$xsize,$ysize; min sizes=$min_xsize,$min_ysize;  args=$args"
eval Select::set $args
set ModeResizing($this,xsize) $xsize
set ModeResizing($this,ysize) $ysize
set ModeResizing($this,min_xsize) $min_xsize
set ModeResizing($this,min_ysize) $min_ysize
set ModeResizing($this,args) $args
$Mode($this,canvas) create rectangle $sx $sy [expr $sx + $xsize] [expr $sy + $ysize] -outline [Colour::get_fg] -width 1 -tags resizing_rect
}
proc ModeResizing::~ModeResizing {this} {
$Mode($this,canvas) delete resizing_rect
unset ModeResizing($this,args) ModeResizing($this,xsize) ModeResizing($this,ysize) ModeResizing($this,min_xsize) ModeResizing($this,min_ysize)
}
proc ModeResizing::button2andmotion {this x y shift args} {
Debug::puts ModeResizing ModeResizing::button2andmotion debug "To $x,$y; shift=$shift; args=$args"
set xsize $ModeResizing($this,xsize)
set ysize $ModeResizing($this,ysize)
if {$x < $Mode($this,startx)} {
} else {
set xsize_new [expr $x - $Mode($this,startx)]
if {$xsize_new >= $ModeResizing($this,min_xsize)} {
set ModeResizing($this,xsize) $xsize_new
set xsize $xsize_new
}
}
if {$y < $Mode($this,starty)} {
} else {
set ysize_new [expr $y - $Mode($this,starty)]
if {$ysize_new >= $ModeResizing($this,min_ysize)} {
set ModeResizing($this,ysize) $ysize_new
set ysize $ysize_new
}
}
Debug::puts ModeResizing ModeResizing::button2andmotion debug "Size $xsize,$ysize"
$Mode($this,canvas) coords resizing_rect $Mode($this,startx) $Mode($this,starty) [expr $Mode($this,startx) + $xsize] [expr $Mode($this,starty) + $ysize]
}
proc ModeResizing::button2up {this x y args} {
Debug::puts ModeResizing ModeResizing::button2up debug "@$x,$y; args=$args"
if {([expr abs($Mode($this,startx) - $x)] <= $Mode(selection_box_min_size)) &&
([expr abs($Mode($this,starty) - $y)] <= $Mode(selection_box_min_size))} {
Debug::puts ModeResizing ModeResizing::button2up debug "Single button2up @$x,$y; reseting mode"
return "Project::reset_mode $Mode($this,parent)"
}
set args $ModeResizing($this,args)
return "Project::tochild $Mode($this,parent) 1 resized $ModeResizing($this,xsize) $ModeResizing($this,ysize) $args"
}
Debug::init ModeConnecting
proc ModeConnecting::ModeConnecting {this canvas parent sx sy ex ey head args} Mode {
Connecting $canvas $parent $sx $sy $ex $ey 0
} {
Debug::puts ModeConnecting ModeConnecting::ModeConnecting debug "Canvas=$canvas @$sx,$sy-$ex,$ey args=$args"
Select::clear
set ModeConnecting($this,args) $args
set ModeConnecting($this,middle_coords) {}
ModeConnecting::update_line $this $ex $ey
$Mode($this,canvas) create line $sx $sy $ex $ey -fill [Colour::get_fg] -width 1 -tags connecting_line -arrow $head
}
proc ModeConnecting::~ModeConnecting {this} {
$Mode($this,canvas) delete connecting_line
unset ModeConnecting($this,args) ModeConnecting($this,middle_coords)
}
proc ModeConnecting::update_line {this ex ey} {
eval $Mode($this,canvas) coords connecting_line $Mode($this,startx) $Mode($this,starty) $ModeConnecting($this,middle_coords) $ex $ey
}
proc ModeConnecting::motion {this x y shift args} {
Debug::puts ModeConnecting ModeConnecting::motion debug "To $x,$y; shift=$shift; args=$args"
ModeConnecting::update_line $this $x $y
}
proc ModeConnecting::button1down {this x y shift type typeref subtype subtyperef subsubtyperef args} {
Debug::puts ModeConnecting ModeConnecting::button1down debug "@$x,$y; shift=$shift; subtype=$subtype ($subtyperef,$subsubtyperef) $type ($typeref); tags=$args"
set start_type [lindex $ModeConnecting($this,args) 0]
set start_typeref [lindex $ModeConnecting($this,args) 1]
set start_subtype [lindex $ModeConnecting($this,args) 2]
set start_subtyperef [lindex $ModeConnecting($this,args) 3]
set start_subsubtyperef [lindex $ModeConnecting($this,args) 4]
if {$start_type != $type || $start_typeref != $typeref} {
Debug::puts ModeConnecting ModeConnecting::button1down debug "Clicked on different Instances at each end - reseting mode"
return "Project::reset_mode $Mode($this,parent)"
}
if {$start_subtyperef == $subtyperef &&
$start_subsubtyperef == $subsubtyperef} {
Debug::puts ModeConnecting ModeConnecting::button1down debug "Connected to start end - reseting mode"
return "Project::reset_mode $Mode($this,parent)"
}
if {$type == ""} {
return "Project::reset_mode $Mode($this,parent)"
}
switch $subtype {
main/body {
lappend ModeConnecting($this,middle_coords) $x $y
ModeConnecting::update_line $this $x $y
return
}
node/comm/plug -
node/comm/arrow -
node/comm/variable {
set args $ModeConnecting($this,args)
return [list Project::tochild $Mode($this,parent) 1 connect_to $start_type $start_typeref $start_subtype $start_subtyperef $start_subsubtyperef node/comm/plug $subtyperef $subsubtyperef $ModeConnecting($this,middle_coords)]
}
comm/plug -
comm/arrow -
comm/variable {
set args $ModeConnecting($this,args)
return [list Project::tochild $Mode($this,parent) 1 connect_to $start_type $start_typeref $start_subtype $start_subtyperef $start_subsubtyperef comm/plug $subtyperef {} $ModeConnecting($this,middle_coords)]
}
node/main/body -
node/main/border -
node/main/name {
}
main/border {
return "Project::reset_mode $Mode($this,parent)"
}
default {
Debug::puts ModeConnecting ModeConnecting::button1down warning "Ignoring button1down on subtype $subtype"
}
}
}
Debug::always_debug_levels error
Debug::set_levels debug warning info error
global TheProject
set TheProject [new Project $argv]
