#this is the nodes and lines canvas program from Ousterhoust's book
#with a few additions
#the next few lines kill of existing tk objects - just in case you
#want to repeat the source statement in the same wish window.
if [winfo exists .c] {destroy .c}
if [winfo exists .yscroll] {destroy .yscroll}
if [winfo exists .xscroll] {destroy .xscroll}
if [winfo exists .f] {destroy .f}

frame .f
pack .f -side top -fill both -expand 1 

#create the canvas with scroll bars .f.c and .f.yscroll are children of .f
canvas .f.c -yscrollcommand ".f.yscroll set" -xscrollcommand ".xscroll set"
scrollbar .f.yscroll -command ".f.c yview"
scrollbar .xscroll -orient horizontal -command ".f.c xview"

#pack the canvas - good examples of packing in Welch's book
pack .xscroll -side bottom -fill x -padx 1m -pady 1m -expand 1
pack .f.yscroll -side right -fill y -padx 1m -pady 1m -expand 1
pack .f.c -side left -fill both -expand 1 -padx 1m -pady 1m

#this example uses procedures - notice the use of indents
proc mkNode {x y} {
        #variables which need to be used outside the procedure need to
	# be specified as global - try to avoid global variables as
	#much as possible
	global nodeX nodeY edgeFirst edgeSecond

	#for details on tk commands look in the manual
	#when the oval is created an integer is returned, the value of
	#which is assigned to the variable new .f.c is a child of .f
	set new [.f.c create oval [expr $x-10] [expr $y-10] \
	[expr $x+10] [expr $y+10] -outline black \
	-fill white -tags node]

	#these arrays remember where the nodes and located.
	set nodeX($new) $x
	set nodeY($new) $y

	#these arrays record which lines start and finish at the node
	#they are set to null because there are no lines yet!
	set edgeFirst($new) {}
	set edgeSecond($new) {}
	}

proc mkEdge {first second} {
	#first is the start node, second is the finish node
	global nodeX nodeY edgeFirst edgeSecond

	#create the line and assign the integer returned to the variable edge
	set edge [.f.c create line $nodeX($first) $nodeY($first) \
		$nodeX($second) $nodeY($second)]

	#put the line on a layer below the circle, so that it is filled white
	.f.c lower $edge

	#add the new line to the line of lines starting at the first node
	lappend edgeFirst($first) $edge

	#add the new line to the line of lines finishing at the second node
	lappend edgeSecond($second) $edge
	}

proc moveNode {node xDist yDist} {
	global nodeX nodeY edgeFirst edgeSecond
	#a canvas command follows see the tk manual entry for canvas
	.f.c move $node $xDist $yDist

	#next change the values of x and y to reflect the distance moved.
	incr nodeX($node) $xDist
	incr nodeY($node) $yDist

	#we have now moved the node - next we need to move all the lines
	#connected to the node
	foreach edge $edgeFirst($node) {
		#lindex extracts items from a list
		.f.c coords $edge $nodeX($node) $nodeY($node) \
		[lindex [.f.c coords $edge] 2] \
		[lindex [.f.c coords $edge] 3]
		}
	foreach edge $edgeSecond($node) {
	.f.c coords $edge [lindex [.f.c coords $edge] 0] \
		[lindex [.f.c coords $edge] 1] \
		$nodeX($node) $nodeY($node)
		}
	}

#binding defines an action when an event occurs - in this case pressing
#button 1
bind .f.c <Button-1> {mkNode %x %y
   #a bit of tcl output to check that button pressed OK
   puts "Button 1 pressed"
}

.f.c bind node <Any-Enter> {
	.f.c itemconfigure current -fill black
	}
.f.c bind node <Any-Leave> {
	.f.c itemconfigure current -fill white
}

#binding on keyboard characters "1" and "2" to select start and end nodes
#for lines
bind .f.c <KeyPress-1> {set firstNode [.f.c find withtag current]}
bind .f.c <KeyPress-2> {set curNode [.f.c find withtag current]
	if {($firstNode != {}) && ($curNode != "")} {
	mkEdge $firstNode $curNode
	}
	}

.f.c bind node <Button-3> {
	#change the colour of the node to black to indicate that it is picked
	.f.c itemconfigure current -fill black
	puts "Button 3 pressed"
	set curX %x
	set curY %y
	}

.f.c bind node <B3-Motion> {
	puts "Button 3 motion"
	moveNode [.f.c find withtag current] [expr %x-$curX] \
		[expr %y-$curY]
	set curX %x
	set curY %y
	}

focus .f.c