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

#
# 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 backgroundcol ; set backgroundcol gray90

set top .

if ($ownwindow>=1) {
    wm title . "Typicality"
    wm iconname . "typicality"
    wm geometry . +10+10
}
if ($verbose>=1) {
    puts "Typicality version 1.5               (c) David J C MacKay 1998"
    puts ""
    puts "shortcuts: d - do it (generate iid binary string of length N) "
    puts "           s - switch between slow and fast display"
    puts "           l - switch display of log(p(x))"
    puts "         n/N - increment / decrement N by 10"
    puts "         0/1 - generate the all zero and all ones strings"
    puts "           q - quit"
    puts "      return - insert space in window"
    puts ""
    # puts "green numbers: log_2(p(x))    red numbers: p(x)"
    puts "source entropy is displayed at bottom."
}
set w ""

frame $w.status ; set status $w.status
frame $w.buttons ; set buttons $w.buttons
#
global fn
scale $status.fn -orient horizontal -length 284 -from 0.01 -to 0.99 \
	-variable fn -tickinterval 0.2 -resolution 0.01 -bigincrement 0 \
	-label "P(1)" -command {setentropy} -background lightblue -width 8
set fn 0.1
global entropyfn
entry $status.entropy -width 5 -textvariable entropyfn  -background palegreen
label $status.entropyl -text "Entropy:" -background palegreen

proc setentropy { fn } {
    global entropyfn
    set entropyfn [entropy $fn]
} 

global zerostring ; set zerostring " "
# aka Slow
global colourful ; set colourful 1 
global showl ; set showl 0
global showp ; set showp 0
global lcolor ; set lcolor palegreen
global pcolor ; set pcolor red
checkbutton $w.buttons.slow -text Slow -variable colourful
checkbutton $w.buttons.showl -text "Show log_2(p(x))" -variable showl -background $lcolor
checkbutton $w.buttons.showp -text "Show p(x)" -variable showp -foreground $pcolor -background $backgroundcol
button $buttons.noise -text DoIt -command {noise $fn}
button $status.noise -text DoIt -command {noise $fn}
button $status.zeros -text 0000 -command {noise 0.0}
button $status.ones -text 1111 -command {noise 1.0}
button $buttons.dismiss -text Quit -command "destroy ."
button $buttons.dismiss2 -text Quit -command "destroy ."
global doingcanvases ; set doingcanvases 0
checkbutton $w.buttons.canvas -variable doingcanvases -command canvaspack -text "show figure"
#
pack $status.noise  $status.ones  $status.zeros  $status.entropy $status.entropyl $status.fn  -side right -padx 5
pack   $w.buttons.dismiss  -side right
pack $w.buttons.dismiss2  $w.buttons.noise  $w.buttons.slow   -side left -padx 4
pack  $w.buttons.showp   $w.buttons.showl   -side right -padx 4
pack  $status -side bottom -fill x -pady 2m
pack $w.buttons  -side top -fill x -pady 2m

# 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 4 -borderwidth 1
    pack $w.$l.l $w.$l.dn $w.$l.up $w.$l.n -in $w.$l -side left

}


proc entropy { f } {
    if (($f>0.0)&&($f<1.0)) {
	set h [expr -($f*log($f)+(1.0-$f)*log(1.0-$f))/log(2.0)]
    } else {
	set h 0
    }
    return $h
}

proc spitqueue { queue digit } {
    if ($digit) { 
	set thiscolor color3 
    }  else { set thiscolor color4 }
    appendover $queue "small $thiscolor"
}
proc noise { f } {
    global colourful zerostring
    global N fn ;# fn is used to compute log prob; f to generate
    set space " "
    set x "" ; set c 0
    if ($colourful) {
	appendover "\n"  
    }
    # this stuff if colourful:
    set successive(0) 0
    set successive(1) 0
    set queue ""
    # end this stuff
    for {set k 1} {$k<=$N} {incr k} {
	set n [expr (rand())>$f ? 0:1 ]
	append x [expr $n?$n:$zerostring]
	incr c $n
	if ($colourful) {
	    set other [expr 1-$n]
	    if ($successive($other)) {
		# then we need to print the queue
		spitqueue $queue $other
		set queue ""
		set successive($other) 0
	    } 
	    append queue $n
	    incr successive($n) 
	}
    }
# finish off queue
    if ($colourful) {
	spitqueue $queue $n
	set queue ""
    } 
    set logprob [expr ($c * log($fn) + ($N-$c) * log(1.0-$fn))/log(2.0)]
    set prob [expr exp($logprob*log(2.0))]
    set pl [expr [string length $prob] - 4]
    if ([string match *e* $prob]&&($pl>7)) {
	set probs [string range $prob 0 3]
	set probs2 [string range $prob $pl end]
    } else {
	set probs [string range $prob 0 7] 
	set probs2 ""
    }
    set logprobs [string range $logprob 0 5]

    if (!$colourful) {
	copyover $x small
    }

    global showl showp
    if ($showl) {
	set str $space$logprobs
	appendover $str {large color1}
    }
    if ($showp) {
	set str $space$probs$probs2
	appendover $str {large color2}
    }
    update idletasks
}
###############################################################
#
#               Status
#
###############################################################
global N ; set N 100
adjustableInteger $w $status "n" "N" "N"

bind . <Control-q> "destroy ."
bind . <Control-c> "destroy ."
bind . <q> "destroy ."
bind . <s> "$buttons.slow invoke"
bind . <l> "$buttons.showl invoke ; $buttons.showp invoke "
bind . <p> "$buttons.showl invoke ; $buttons.showp invoke "
bind . <d> "$status.noise invoke"
bind . <Return> {appendover "\n"}
bind . <0> "$status.zeros invoke"
bind . <Key-1> "$status.ones invoke"
bind . <n> "incr N 10"
bind . <N> "incr N -10"

set command "pack "
# set font "Helvetica 14 bold"
foreach i {megatext} { 
    frame $w.$i
    set s $w.$i
    text $s.text -width 100 -height 24 -yscrollcommand "$s.scroll set" -xscrollcommand "$s.scrollx set" -wrap none -background white -insertofftime 0
    scrollbar $s.scroll -command "$s.text yview"
    scrollbar $s.scrollx -orient horiz  -command "$s.text xview"
    pack $s.scrollx -side bottom -fill x
    pack $s.scroll -side right -fill y
    pack $s.text -side left
    append command " \$w.$i"
    $s.text tag configure small -font {Courier 8}
    $s.text tag configure bold -font {Courier 12 bold italic}
    $s.text tag configure large -font {Courier 16 bold}
    $s.text tag configure verybig -font {Helvetica 24 bold}
    $s.text tag configure color1 -background palegreen
    $s.text tag configure color2 -foreground red
    $s.text tag configure color3 -foreground slateblue3
    $s.text tag configure color4 -foreground gray70
 }
set megatext $s.text

# finish off the pack
append command " -side top -fill x"
eval $command

proc copyover { s {m {}} } {
    global megatext
    $megatext insert end "\n"
    $megatext insert end $s $m
    $megatext yview end
}
proc appendover { s {m {}} } {
    global megatext
    $megatext insert end $s $m
    $megatext yview end
}
proc spitout { s } {
    global $s
    global megatext
    $megatext insert end "\n"
    $megatext insert end [set $s]
}