#!/bin/sh
# the next line restarts using wish \
exec wish "$0" "$@"

# tsp.tcl
# draws a load of hopfield net nodes

#
# set these two flags to 1 to get a stand-alone version
# as used by me; leave them at 0 to get plug-in netscape
# compatible version:
#
global verbose ; set verbose 0
global ownwindow ; set ownwindow 0
global version ; set version 1.1

frame .tsp
pack  .tsp
set w .tsp
set top .
if {$ownwindow>=1} {
    wm geometry . +10+10
    wm title . "TSP Demonstration"
    wm iconname . "tsp"
}
bind . <Control-C> {destroy .}
bind . <Control-c> {destroy .}
set colone [frame .tsp.colone]
set toprow [frame .tsp.toprow]
pack $toprow -side top
pack $colone -side left

label $w.msg -wraplength 4i -justify left -text "Negative Weights"
pack $w.msg -side top

frame $w.buttons
pack $w.buttons -side bottom -fill x -pady 2m
button $w.buttons.dismiss -text Dismiss -command "destroy $top"
pack $w.buttons.dismiss  -side left -expand 1

global font ; set font "Courier 20"
global x
global state
set state(1) "white"
set state(0) "red"
global Energy ; set Energy 0.0
label $w.energyl -width 7 -justify left -text "Energy:" -background pink1 -anchor nw  -font $font
label $w.energy -width 5 -justify left -text "" -textvariable Energy -background pink1 -anchor nw  -font $font
global Actvn ; set Actvn 0.0
label $w.actvnl -width 6 -justify left -text "Actvn:" -background sienna1 -anchor nw  -font $font
label $w.actvn -width 3 -justify left -text "" -textvariable Actvn -background gold1 -anchor nw  -font $font
global Happy ; set Happy ""
label $w.happy -width 8 -justify left -text "" -textvariable Happy -background skyblue -anchor nw  -font $font
pack $w.energyl $w.energy -in $toprow -side left
pack $w.actvnl $w.actvn -in $toprow -side left
pack $w.happy -in $toprow -side left

# make a frame called l within frame controls, and associate these buttons 
# with an integer called L
proc adjustableInteger { w controls l Lname Lstring } {
    frame $w.$l 
    pack $w.$l -in $controls -side left  -pady 2  -padx 2 -anchor w
    button $w.$l.l -text "$Lstring:" -padx 0 -pady 0 -borderwidth 1 -command {}
    button $w.$l.up -text ">" -padx 0 -pady 0 -borderwidth 1 -command "incr $Lname"
    button $w.$l.dn -text "<" -padx 0 -pady 0 -borderwidth 1 -command "incr $Lname -1"
    bind  $w.$l.up  <3> "$w.$l.dn invoke"
    bind  $w.$l.dn  <3> "$w.$l.up invoke"
    entry $w.$l.n -textvariable $Lname -width 3 -borderwidth 1
    pack $w.$l.l $w.$l.dn $w.$l.up $w.$l.n -in $w.$l -side left
}

adjustableInteger $toprow $toprow "bias" Bias Bias
set Bias -8
adjustableInteger $toprow $toprow "penalty1" penalty1 penalty1
adjustableInteger $toprow $toprow "penalty2" penalty2 penalty2
global penalty1 ; set penalty1 5 ;
global penalty2 ; set penalty2 7 ;

# Create a load of nodes of network
global nc ; set nc 4
global I  ; set I [expr $nc*$nc] ;# number of neurons
global K ; set K [expr $I*$I] ;# number of weights
global recdx ; set recdx 45
global recdy ; set recdy $recdx
global recwidth ; set recwidth 25 
global recheight ; set recheight $recwidth
set width [expr ($nc+1)*$recdy]

set c $w.c
# c is the canvas
canvas $c -relief sunken -borderwidth 2 -width $width -height $width -background black
set bg [lindex [$c config -bg] 4]
set name(1) "A" ;
set name(2) "B" ;
set name(3) "C" ;
set name(4) "D" ;
set topy 0
set ii 1
for {set i 1 } {$i <= $nc} {incr i} {
    set y [expr {$recdy * $i}]
    for {set j 1} {$j <= $nc} {incr j} {
	set x [expr {$recdx*$j}]
	set item [$c create rect ${x} ${y} [expr $x+$recwidth] [expr $y+$recheight] \
		-width 2 -outline yellow -fill Red -tags [list node$i$j nd$ii n$ii]]
	set xn($ii) 0
	$c addtag node withtag $item
	set city($ii) $i
	set rank($ii) $j
	incr ii
    }
    set x [expr {$recdx*0.5}]
    set item [$c create text ${y} ${x} -anchor nw \
	    -text "$i" -font $font -tags label -fill green]
    set item [$c create text ${x} ${y} -anchor nw \
	    -text $name($i) -font $font -tags label -fill green1]
}

# make distance canvas
set cd $w.cd
canvas $cd -relief sunken -borderwidth 2  -width $width -height $width  -background black

set ii 1
for {set i 1 } {$i <= $nc} {incr i} {
    set x [expr {$recdx*$i}]
    for {set j 1} {$j <= $nc} {incr j} {
	set y [expr {$recdy * $j}]
	set d($i,$j) [expr (($j-$i)*($j-$i))]
	if {($d($i,$j)>6)} { set d($i,$j) 6 }
	if {$i==$j} {
	    set s "" 
	} else {
	    set s [expr $d($i,$j)]
	}
	set item [$cd create text ${x} ${y} \
		   -font $font -text "$s" -tags [list d$i,$j d$ii] -fill yellow]
	incr ii
	$cd addtag distance withtag $item
    }
    set y [expr {$recdx*0.5}]
    set item [$cd create text ${x} ${y} \
	    -text  $name($i)  -font $font -tags label -fill green1]
    set item [$cd create text ${y} ${x} \
	    -text  $name($i)  -font $font -tags label -fill green1]
}

# make weight canvas
global recdx ; set recdx 28
global recdy ; set recdy 28
set width [expr ($I+1)*$recdy]

set cw $w.cw
canvas $cw -relief sunken -borderwidth 2  -width $width -height $width  -background black
pack $c $cd -side top -in $colone
pack $cw -side right
set bgw [lindex [$cw config -bg] 4]

set ii 0
for {set i 1 } {$i <= $I} {incr i} {
    set x [expr {$recdx*$i}]
    for {set j 1} {$j <= $I} {incr j} {
	set y [expr {$recdy * $j}]
	if {$i==$j} {
	    set s ""
	    set weight($i,$j) 0
	} else {
	    set dused 0
	    set dcity [expr ( $city($i) - $city($j) )]
	    if {($dcity==0)} {
		set s $penalty2
	    } else {
		set drank [expr ( $rank($i) - $rank($j) )]
		if {($drank==1)||($drank==-1)||($drank==($nc-1))||($drank==-($nc-1))} {
		    set s [expr $d($city($i),$city($j))]
		    set dused 1
		} elseif { $drank == 0 } {
		    set s $penalty1
		} else {
		    set s "0"
		}
	    }
	    set item [$cw create text ${x} ${y} \
		    -text "$s" -font $font -fill white \
		    -tags [list weight$i,$j w$ii from$i to$j fromnd$i tond$j \
		    between$i,$j between$j,$i]]
	    set weight($i,$j) $s
	    incr ii
	    $cw addtag weight withtag $item
	    if {$dused} {
		$cw addtag d$city($i),$city($j) withtag $item
		$cw addtag d$city($j),$city($i) withtag $item
	    }
	}
    }
}


$c bind node <1> "toggleNode $c"
$c bind node <Any-Enter> "enterNode $c $cw"
$c bind node <Any-Leave> "itemLeave"

$cw bind weight <Any-Enter> "enterWeight $cw $c"
$cw bind weight <Any-Leave> "itemLeave"

$cd bind distance <Any-Enter> "enterDistance $cd $cw"
$cd bind distance <Any-Leave> "itemLeave"

# from plot.tcl

# Utility procedures for highlighting the item under the pointer:

proc enterWeight {cw c} {
    global verbose
    global restoreCmd 
    $cw  itemconfig current -fill red
# find parents of this edge
    set nowthen [$cw gettags current]
    if {$verbose>=1} {
	puts $nowthen
    }
    set myfrom [lindex $nowthen [lsearch -regexp $nowthen from]]
    set myto [lindex $nowthen [lsearch  -regexp $nowthen to]]
#    if {!([lsearch  -regexp $nowthen d]==-1)} {
#	set myd [lindex $nowthen [lsearch  -regexp $nowthen d]]
#    }
    regsub  "from" $myfrom "" from
    regsub  "to" $myto "" to
    if {$verbose>=1} {
	puts "w from $from to $to"
    }
    # find these nodes.
    set rememberfrom [lindex [$c itemconfig n$from -fill] 4]
    set rememberto [lindex [$c itemconfig n$to -fill] 4]

    $c itemconfig n$from -fill skyblue
    $c itemconfig n$to -fill green
    set restoreCmd "$cw itemconfig current -fill white;     $c itemconfig n$from -fill $rememberfrom ;    $c itemconfig n$to -fill $rememberto"
}

proc enterDistance {cd cw} {
    global restoreCmd 
    global verbose
    $cd  itemconfig current -fill red
# find weights that use this distance
    set nowthen [$cd gettags current]
#    puts $nowthen
    set myd [lindex $nowthen [lsearch -regexp $nowthen d]]
    if {$verbose>=1} {
	puts "$myd"
    }

    $cw itemconfig $myd -fill red
    set restoreCmd "$cd itemconfig current -fill yellow;     $cw itemconfig $myd -fill purple"
}

proc enterNode {c cw} {
    global verbose
    global restoreCmd 
    $c  itemconfig current -outline skyblue2
# find weights that use this distance
    set nowthen [$c gettags current]
#    puts $nowthen
    set myn [lindex $nowthen [lsearch -regexp $nowthen nd]]
    if {$verbose>=1} {
	puts "$myn"
    }
    regsub  "nd" $myn "" ii
    find_actvn $ii
    $cw itemconfig from$myn -fill red
    $cw itemconfig to$myn -fill green
    set restoreCmd "global Actvn; set Actvn {}; global Happy; set Happy {}; $c itemconfig current -outline yellow;     $cw itemconfig from$myn -fill white ;     $cw itemconfig to$myn -fill white "
}

proc toggleNode {c} {
    global restoreCmd 
    global verbose
    global state xn
# find weights that use this distance
    set nowthen [$c gettags current]
#    puts $nowthen
    set myn [lindex $nowthen [lsearch -regexp $nowthen nd]]
    if {$verbose>=1} {
	puts "$myn"
    }
    regsub  "nd" $myn "" ii
    set xn($ii) [expr 1-$xn($ii)]
    $c  itemconfig current -fill $state($xn($ii))
    # find change in energy
    find_energy $ii
}

proc find_energy { ii } {
# this assumes the energy is right and just works out the change
    global Energy weight xn Bias I Actvn Happy
    global verbose
    set activation $Bias
    for {set i 1 } {$i <= $I} {incr i} {
	set activation [expr $activation+$weight($i,$ii)*$xn($i)]
    }
    set change [expr 2*$xn($ii)-1]
    set Energy [expr $Energy+$change*$activation]

    if {[expr -$change*$activation]>0} {
	set Happy "stable"
    } else {
	set Happy "unstable"
    }
}

proc find_actvn { ii } {
# this assumes the energy is right and just works out the change
    global Energy weight xn Bias I  Actvn Happy
    set activation $Bias
    for {set i 1 } {$i <= $I} {incr i} {
	set activation [expr $activation+$weight($i,$ii)*$xn($i)]
    }
    set Actvn [expr -$activation]
    set change [expr 2*$xn($ii)-1]
    if {[expr $change*$Actvn]>0} {
	set Happy "stable"
    } else {
	set Happy "unstable"
    }
}

proc itemLeave { } {
    global restoreCmd

    eval $restoreCmd
}
#####################################################################

# subroutine for positioning magnification in response to the horizontal coord
proc hpositionscale {w s} {
    $w.scale set [expr $s*0.01]

    $w.c coords poly $s 15 $s 35 [expr $s+20] 35 [expr $s+20] 15
    $w.c coords line $s 15 $s 35 [expr $s+20] 35 [expr $s+20] 15
}

# what to do when the scale is set.
proc setScale {w scale} {
global nrecx 
global recdx 
global nrecy 
global recdy 
global recwidth
global recheight

    set realscale [expr exp($scale)]
#    puts $realscale 
    for {set i 0} {$i < $nrecx} {incr i} {
	set x [expr {$recdx*$i}]
	set factor [expr int(pow(2,$nrecx-$i))]
	for {set j 0; set y -5} {$j < $nrecy} {incr j $factor} {
	    set y [expr {$recdy * $j - 1}]
	    $w coords rect$i$j ${x}c [expr $y*$realscale]c [expr $x+$recwidth]c [expr ($y+($factor*$recheight))*$realscale ]c
	}
    }
}