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

# gibbs.tcl stripped down version
#                                   David J C MacKay (1998)

set ownwindow 0
set verbose 0
if {$verbose>=1} {
    puts "Gibbs Inequality 1.1                David J C MacKay          1998"
    puts "                                    written under tcl 8.0 on linux"
}
# changes
#########################################################################
#
######################################################################
# contents:
#
######################################################################

frame .th
pack  .th
set w .th
set top .
if {$ownwindow>=1} {
    wm title . "Gibbs Inequality"
    wm iconname . "Gibbs"
    wm geometry . +10+10
}

#######################################################################
#
#  variables
#
#######################################################################
set types "p q"

set color(p) "red"
set color(q) "green"

set palecolor(p) "pink"
set palecolor(q) "palegreen"

foreach t [concat $types] {
    set Active($t) 1
}

#######################################################################
#
#                      procedures
#
#######################################################################

global thewidth ;    set thewidth 50

proc makeEnergylevels { w energylevels } {
    global I Emin Emax ocmax ocmin betamin Z KL KLqp logprob
    global energy types color meanoc verbose palecolor
    global thewidth 

    # make our own local frame
    set L $I
    set e $energylevels.e
    catch { destroy $e }
    pack [frame $e]

    foreach  t [concat $types] {
#	set elabels [frame $e.labels$t]
#	puts [set elabels]

#	pack $elabels -in $e -side top -pady 2 -expand 1 -fill x
#	label $elabels.e -text "log probabilities" -anchor w
#	pack $elabels.e -in $elabels -side top -pady 0
	for { set l 1 } { $l <= $L } { incr l } {
	    set energy($l,$t) 3
	    catch { destroy $e.ee$l$t  ; destroy $e.e$l$t }
	    if {$verbose>=2} { puts "elmax = $Elmax" }
	    set ee$l [frame $e.ee$l$t] ; pack [set ee$l] -in $e -side left -pady 2
	    set e$l [scale $e.e$l$t -orient vertical -length 180  \
		    -from $Emin -to $Emax   -width $thewidth -sliderlength 8 -background $color($t) \
		    -borderwidth 0 -showvalue 0  \
		    -variable energy($l,$t) -tickinterval 0 -resolution 0.2  \
		    -bigincrement 0     -command {computeMicrostateProbs}]
	    pack [set e$l] -in [set ee$l] -side top -pady 2 -padx 2 -expand 1 -fill x

	    catch { destroy $e.et$l$t  }
	    set p$l$t [label $e.et$l$t -background $palecolor($t) \
		    -textvariable energy($l,$t) -width 2 -anchor w]
	    pack [set p$l$t] -in [set ee$l] -side top -pady 2   -padx 2 -expand 1 -fill x

	    # show probs too.
	    catch { destroy $e.p$l$t  }
	    set p$l$t [scale $e.p$l$t -orient vertical -length 180  \
		    -from $ocmax -to $ocmin   -width $thewidth -sliderlength 6 \
		    -borderwidth 0 -showvalue 0  -background \
		    $color($t) \
		    -variable p($l,$t) -tickinterval 0 \
		    -resolution 0.00000001 ]
	    pack [set p$l$t] -in [set ee$l] -side top  -pady 2  -padx 2 -expand 1 -fill x
	    catch { destroy $e.pt$l$t  }
	    set p$l$t [label $e.pt$l$t -background $palecolor($t) \
		    -textvariable p($l,$t) -width 2 -anchor w]
	    pack [set p$l$t] -in [set ee$l] -side top  -pady 2  -padx 2 -expand 1 -fill x

	    catch { destroy $e.lpt$l$t  }
	    set p$l$t [label $e.lpt$l$t -background $palecolor($t) \
		    -textvariable logprob($l,$t) -width 2 -anchor w]
	    pack [set p$l$t] -in [set ee$l] -side top  -padx 2  -pady 2 -expand 1 -fill x
	}
    }
#    raise    $elabels

    catch { destroy $e.zframe }

# partition functions (these don't quite belong here... 
    set zframe [frame $e.zframe]
    pack $zframe -in $e -side top
    pack [label $zframe.zl -text "normalizing constants"]  \
	    -side top -pady 0 -padx 10
    foreach t [concat $types] {
	set Z($t) 1.0 ;
	set z$t [label $zframe.z$t  -width 10 -anchor w -background \
			$palecolor($t) -borderwidth 2 -textvariable Z($t)]
	pack [set z$t]  -side left -pady 0 -padx 6
    }

# KL
    global KL KLqp
    set klframe [frame $e.klframe]
    pack $klframe -in $e -side bottom -expand 1 -fill y
    set klframe [frame $e.klframe.p]
    pack $klframe  -side left
    pack [label $klframe.zl  -anchor w -borderwidth 2  \
	    -text "D_KL(p||q)" -width 10 ]  \
	    -side top -pady 2 -padx 10
    set z$t [label $klframe.kl    -anchor w -width 10  -background \
	    lightblue -borderwidth 2 -textvariable KL]
    pack [set z$t]  -side left -pady 0 -padx 6

    set klframe [frame $e.klframe.q]
    pack $klframe  -side right
    pack [label $klframe.zl  -anchor w -borderwidth 2  \
	    -text "D_KL(q||p)" -width 10 ]  \
	    -side top -pady 2 -padx 10
    set z$t [label $klframe.kl    -anchor w -width 10  -background \
	    magenta -borderwidth 2 -textvariable KLqp]
    pack [set z$t]  -side left -pady 0 -padx 6
}




# 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

}

proc makeControls { w controls } {
    pack [button $w.restart -text "Restart" -borderwidth 1 \
	    -command {restart}] -in $controls  -side left \
	    -pady 0 -padx 2 -anchor w
    adjustableInteger $w $controls "i" "II" "I"
    adjustableInteger $w $controls "ema" "Emin" "Emin"
    adjustableInteger $w $controls "emi" "Emax" "Emax"
    adjustableInteger $w $controls "w" "thewidth" "width"
}

#
# packing procedures
#
proc restart { } {
    global N L II I
    upvar w w   energylevels energylevels  controls controls  
    upvar microstates microstates

    set I $II
    global ocmin ; set ocmin 0 ;
    global ocmax ; set ocmax 1 ;

    makeEnergylevels $w $energylevels
}

# invoked when the energy level scales are touched
# finds probabilities 
proc computeMicrostateProbs { {junk 0} } {
    global energy I types  p  Z KL KLqp logprob
    global Active
    set L $I
    foreach  t [concat $types] {
	set Z($t) 0.0
	for { set l 1 } { $l <= $L } { incr l } {
	    set pn($l,$t) [expr  exp(-$energy($l,$t)*log(2.0))]
	    set Z($t) [expr $Z($t) + $pn($l,$t)]
	}
	for { set l 1 } { $l <= $L } { incr l } {
	    set p($l,$t) [expr   $pn($l,$t)/$Z($t)]
	    set logprob($l,$t) [expr   -log($p($l,$t))/log(2.0)]
	}
    }

    # compute D_KL(p,q) = sum p log p/q
    set KL 0.0
    set KLqp 0.0
    for { set l 1 } { $l <= $L } { incr l } {
	set KL [expr $KL + $p($l,p) * log($p($l,p)/$p($l,q))]
	set KLqp [expr $KLqp + $p($l,q) * log($p($l,q)/$p($l,p))]
    }
    set KL [expr $KL/log(2.0)]
    set KLqp [expr $KLqp/log(2.0)]
    
}

####################################################################
#
# set up windows 
# 
####################################################################

global II ; set II 4
global Emin ; set Emin 0 ;
global Emax ; set Emax 6 ;# highest energy for a level

bind . <Control-x> "destroy ."
bind . <Control-q> "destroy ."
bind . <q> "destroy ."
bind . <Control-c> "destroy ."
bind . <Control-z> "destroy ."

frame $w.controls
set controls $w.controls
pack $controls -side top
makeControls $w $controls

frame $w.middlerow
set middlerow $w.middlerow
pack $middlerow -side top

frame $w.energylevels
set energylevels $w.energylevels
pack $energylevels -in $middlerow -side top -expand y -fill x

# buttons to do with overall control (quit, etc.)
frame $w.buttons
pack $w.buttons -side bottom -fill x -pady 2 -expand 1

#
# overall control buttons
#
button $w.dismiss -text Quit -command "destroy $top"
button $w.help -text Help -command "help"

pack $w.dismiss  $w.help \
	-in $w.buttons -side left -fill x -expand 1 -anchor w  -padx 3 -pady 1
############
#  end bottom row
############

# make it happen!
restart

#####################################################################

proc help { } {
    set w .help
    catch {destroy $w}
    toplevel $w
    wm geometry $w +10+10
    bind $w <Control-c> "destroy $w"
    frame $w.buttons
    pack $w.buttons -side bottom -fill x -pady 2 -expand 1 -padx 4
    button $w.buttons.dismiss -text Dismiss -command "destroy $w"
    pack $w.buttons.dismiss  -side left -fill x -expand 1 -padx 4

  text $w.t -background white -height 24 -wrap word\
            -xscrollcommand "$w.xscroll set" \
            -yscrollcommand "$w.yscroll set" \
            -setgrid 1 -highlightthickness 0 -pady 2 -padx 3
        scrollbar $w.xscroll -command "$w.t xview" \
            -highlightthickness 0 -orient horizontal
        scrollbar $w.yscroll -command "$w.t yview" \
            -highlightthickness 0 -orient vertical

pack $w.yscroll -side right -fill y
pack $w.xscroll -side bottom -fill x
pack $w.t -expand yes -fill both

    $w.t insert 0.0 \
{Gibbs Inequality          - author David J C MacKay  mackay@mrao.cam.ac.uk


 General layout:

 Shortcuts: 
     C-r     reset

}
}