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

# hebb.tcl
# draws a load of hopfield net nodes and does hebbian learning
# of patterns.

#
# 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
#
global pinkish ; set pinkish "#ff00ff"
global inferenceblue ; set  inferenceblue "#005544"

set datad "1111001001010010100101110";
set dataj "1111100010000101001011100";
set datac "0111110000100001000001111";
set datam "1000111011101011000110001";
set datax "0101010101010101010101010";
set datas "0111010000011100000101110";

frame .tsp
pack  .tsp
set w .tsp
set top .
if {$ownwindow>=1} {
    wm geometry . +10+10
    wm title . "Hebbian learning Demonstration"
    wm iconname . "hebb"
}
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 "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 12"
global fontl ; set fontl "Courier 20"
global x
global state
set state(1) "white"
set state(0) "red4"
set state(-1) "red4"
global Energy ; set Energy 0.0
label $w.energyl -width 7 -justify left -text "Energy:" -background pink1 -anchor nw  -font $fontl
label $w.energy -width 5 -justify left -text "" -textvariable Energy -background pink1 -anchor nw  -font $fontl
global Actvn ; set Actvn 0.0
label $w.actvnl -width 6 -justify left -text "Actvn:" -background sienna1 -anchor nw  -font $fontl
label $w.actvn -width 3 -justify left -text "" -textvariable Actvn -background gold1 -anchor nw  -font $fontl
global Happy ; set Happy ""
label $w.happy -width 8 -justify left -text "" -textvariable Happy -background skyblue -anchor nw  -font $fontl
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 0

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

global c
set c $w.c
# c is the canvas
canvas $c -relief sunken -borderwidth 2 -width $width -height $width -background $inferenceblue 
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-0.5)}]
    for {set j 1} {$j <= $nc} {incr j} {
	set x [expr {$recdx*($j-0.5)}]
	set item [$c create rect ${x} ${y} [expr $x+$recwidth] [expr $y+$recheight] \
		-width 2 -outline yellow -fill Red4 -tags [list node$i$j nd$ii n$ii]]
	set xn($ii) -1
	$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 weight canvas
global recdx ; set recdx 18
global recdy ; set recdy 18
set width [expr ($I+1)*$recdy]

set cw $w.cw
canvas $cw -relief sunken -borderwidth 2  -width $width -height $width  -background $inferenceblue
set ctitle $w.ctitle
label  $ctitle  -wraplength 4i -justify center -text "State controls"
set wtitle [label  $w.wtitle  -wraplength 4i -justify center -text "Weight controls"]
set statecontrols1 [frame $w.statecontrols1]
set statecontrols2 [frame $w.statecontrols2]
set sweep   [button $statecontrols1.sweep    -text "Sweep!" -command "sweep 1" ]
set random  [button $statecontrols1.random     -text "Random" -command "random 1" ]
set invert  [button $statecontrols1.invert     -text "Invert" -command "sweep 0" ]
set flipfew [button $statecontrols1.flipfew  -text "Flip few" -command "sweep 2" ]
set zero  [button $statecontrols2.zero   -text "-1" -command "random -1" ]
set setd  [button $statecontrols2.d   -text "d" -command "random d" ]
set setj  [button $statecontrols2.j   -text "j" -command "random j" ]
set setc  [button $statecontrols2.c   -text "c" -command "random c" ]
set setm  [button $statecontrols2.m   -text "m" -command "random m" ]
set setx  [button $statecontrols2.x   -text "x" -command "random x" ]
set sets  [button $statecontrols2.s   -text "s" -command "random s" ]

set botrow $w.botrow
frame $botrow
pack [button $botrow.learn   -text "Learn!" -command "learn 1" ] -side left
pack [button $botrow.forget  -text "Forget!" -command "learn -1"] -side left
pack [button $botrow.zero    -text "Zero!" -command "zeroweights"] -side left

pack $c $ctitle $statecontrols1 $statecontrols2 $wtitle $botrow -pady 3 -side top -in $colone
pack  $sweep $random $invert $flipfew -in $statecontrols1  -pady 1 -side left
pack  $zero $setd $setj $setc $setm $setx $sets -in $statecontrols2  -pady 1 -side left
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 s 0
	    set weight($i,$j) $s
	    set item [$cw create text ${x} ${y} \
		    -text $weight($i,$j) -anchor e -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]]
	    incr ii
	    $cw addtag weight withtag $item
	}
    }
}

proc zeroweights { } {
    global I J xn cw  weight
    for {set i 1 } {$i <= $I} {incr i} {
	for {set j 1} {$j <= $I} {incr j} {
	    if {$i==$j} {
	    } else {
		set weight($i,$j) 0
		$cw itemconfigure  weight$i,$j -text $weight($i,$j) 
	    }
	}
    }
    find_energy_from_scratch
}
proc learn { sign } {
    global I J xn cw weight
    for {set i 1 } {$i <= $I} {incr i} {
	for {set j 1} {$j <= $I} {incr j} {
	    if {$i==$j} {
	    } else {
		set weight($i,$j) [expr $weight($i,$j)+$sign*$xn($i)*$xn($j)]
		$cw itemconfigure weight$i,$j -text $weight($i,$j) 
#		puts "w($i,$j) = $weight($i,$j)"
	    }
	}
    }
    find_energy_from_scratch
}

$c bind node <1> "toggleNode $c"
$c bind node <Alt-Enter> "enterNode $c $cw; toggleNode $c"
$c bind node <Control-Enter> "enterNode $c $cw; 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"

# from plot.tcl

# Utility procedures for highlighting the item under the pointer:

proc enterWeight {cw c} {
    global verbose pinkish
    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 $pinkish
# 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 enterNode {c cw} {
    global verbose pinkish
    global restoreCmd 
    $c  itemconfig current -outline skyblue2

    set nowthen [$c gettags current]
    set myn [lindex $nowthen [lsearch -regexp $nowthen nd]]
    if {$verbose>=1} {
	puts "enternode $myn"
    }
    regsub  "nd" $myn "" ii
    find_actvn $ii
    $cw itemconfig from$myn -fill $pinkish
    $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

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

proc find_energy_from_scratch { } {
    global I J  weight cw Energy xn Bias
    set Energy 0.0
    for {set i 1 } {$i <= $I} {incr i} {
	set Energy [expr $Energy-$Bias*$xn($i)]
	
	for {set j 1} {$j <= $I} {incr j} {
	    if {$i==$j} {
	    } else {
		set Energy [expr $Energy-0.5*$weight($i,$j)*$xn($i)*$xn($j)]
	    }
	}
    }
}

proc find_energy { ii } {
# this assumes the energy is right and just works out the change
    global Energy weight xn Bias I Actvn Happy change
    global verbose activation
    find_actvn $ii
    set Energy [expr $Energy+$change*$activation]
}

proc sweep { normal } {
    global I happy verbose c xn
    if {$normal>1} {
	# then flip this many bits, regardless!
	for {set iii $normal} {$iii >= 1} {incr iii -1} {
	    set ii [expr (int(rand()*$I))+1 ] 
	    toggleNodei $c $ii
	}
    } else {
	for {set ii 1 } {$ii <= $I} {incr ii} {
	    if {$verbose>=1} {
		puts "considering $ii, current state $xn($ii)"
	    }
	    find_actvn $ii
	    if {$normal<1} {
		set happy 0
	    }
	    if {$happy<1} {
		toggleNodei $c $ii
		if {$verbose>=1} {
		    puts "unhappy, flip"
		}
	    } else {
		if {$verbose>=1} {
		    puts "happy"
		}
	    }
	}
    }
}
# random state
proc random { normal } {
    global I happy verbose c xn state data$normal
    for {set ii 1 } {$ii <= $I} {incr ii} {
	if {![string compare $normal 1]} {
	    set xn($ii) [expr 2*(int(rand()*2))-1 ] 
	}	elseif {![string compare $normal -1]} {
	    set xn($ii) $normal
	} else 	 {
	    set xn($ii) [string range [set data$normal] [expr $ii-1] [expr $ii-1]]
#	    puts $xn($ii)
#	    set xn($ii) -1
	}
	if {$verbose>=1} {
	    puts "$ii: xn($ii)"
	}
	if {!($xn($ii))} {
	    set xn($ii) -1 
	}
	$c  itemconfig nd$ii -fill $state($xn($ii))
    }
#    update_all_node_pics 
    find_energy_from_scratch
}
#proc update_all_node_pics { } {
#}

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

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
	}
    }
}