#!/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&#124;&#124;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&#124;&#124;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
}
}
</div><div class="naked_ctrl">
<form action="/index.cgi/speech" method="get" name="gate">
<p><a href="http://altstyle.alfasado.net">AltStyle</a> によって変換されたページ <a href="http://www.inference.org.uk/mackay/itprnn/code/tcl/gibbs.tcl">(-&gt;オリジナル)</a>
/ <label>アドレス: <input type="text" name="naked_post_url" value="http://www.inference.org.uk/mackay/itprnn/code/tcl/gibbs.tcl" size="22" /></label> <label>モード: <select name="naked_post_mode">
<option value="default">デフォルト</option>
<option value="speech" selected="selected">音声ブラウザ</option>
<option value="ruby">ルビ付き</option>
<option value="contrast">配色反転</option>
<option value="larger-text">文字拡大</option>
<option value="mobile">モバイル</option>
</select>
<input type="submit" value="表示" />
</p>
</form>
</div>