#!/bin/sh
# the next line restarts using wish \
exec wish "0ドル" "$@"
# dasher.tcl
# David J C MacKay (1997)
# Arithmetic Coding Dasher
# See help below for information
# I wish that I could get text to be non-sticky.
#
# why did my key bind to canvas not work? (see keyboard_) 
# also had trouble with array exist
#
# If I am going to destroy siblings of ancestors, I need to 
# go back to parents and tell them they are childless again
# and the child making routine has to know to only create the 
# missing children, if we later backtrack. 
#
# 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 2.9
#
if {$verbose>=1} {
 puts "Arithmetic Coding version 2.7 David J C MacKay 1997"
 puts " written under tcl 8.0 on linux"
}
# changes
#########################################################################
# 2.9: came from version 2.7. added jack button
# 2.7: jack and jill went up the hill bigrams included.
# 2.6: new string handling, shortening
# 2.5: remove rand to make tcl7-compatible. include entropy information in help
# 2.3: 
# 2.2: canvas 1 expandable
# 2.0: 
# 1.9: add current strings at the bottom.
# 1.8: allow attention to follow mouse horizontally
# 1.7: have the attention point go up and down with the mouse
# 1.6: automatic rescaling "sliding"
# 1.5: color coding of buttons, variable trunaction length
# 1.5: postscript writing
# 1.4: includes bigram english
# 1.3: includes monogram english. 
# 1.3: a few corrections to the deletion of distant relatives
# 1.2: added deletion of rectangles and text that don't need drawing,
# and reinstatement whenever they come back in view
# 1.2: added mouse-on-canvas navigation with correct vector direction
# when fractional steps are made, such that the integrated trajectory
# goes through the current point.
#
######################################################################
# contents:
#
# * a few top level things
# * main procedures
# * packing procedures
# * toplevel stuff
# * help procedure
######################################################################
frame .ac
pack .ac
set w .ac
set top .
if {$ownwindow>=1} {
 wm title . "DASHER - Arithmetic coding data interface"
 wm iconname . "AC dasher"
 wm geometry . +10+10
}
#######################################################################
#
# procedures
#
#######################################################################
proc default_mc { } {
 global magnification centre
 set magnification 0
 set centre 0.5 ;# where the middle of the window is, vertically.
}
# valid options:
# numerosity = binary or ternary or 2 3 4 5 6 7
# alphabet = alpha or num or alphax
# counts is a list of numbers used to define the probability distribution
#
# broodiness doesn't quite belong here, since it is a display-related
# variable rather than a defn of the model
proc define_model {c numerosity alphabet counts adaptive broodiness} {
 global tails model madaptive mcounts Broodiness verbose
 set alist "a b c d e f g h i j k l m n o p q r s t u v w x y z _"
 set xlist ": a b c d e f g h i j k l m n o p q r s t u v w x y z _"
 set nlist "0 1 2 3 4 5 6 7 8 9 x"
 switch $numerosity {
	binary {
	 set M 2
	}
	ternary {
	 set M 3
	}
	default {
	 set M $numerosity
	}
 }
 switch $alphabet {
	alpha {
	 set thelist $alist
	}
	alphax {
	 set thelist $xlist
	}
	num {
	 set thelist $nlist 
	}
	default {
	 set thelist $nlist 
	}
 }
 if {$verbose>=2} { puts "number of symbols = $M" }
 set model($c) $M
 set mcounts($c) $counts
 set tails($c) [lrange $thelist 0 [expr $M-1]]
 if {$verbose>=1} { puts "alphabet: $tails($c)" }
 if {($adaptive=="no")||($adaptive=="nonadaptive")} { 
	set adaptive 0 
 } elseif {$adaptive=="yes"||$adaptive=="adaptive"} {
	set adaptive 1 
 }
 set madaptive($c) $adaptive
 set Broodiness($c) $broodiness ;# how many generations an attended node 
 # likes to create below itself
# now some window stuff.
 global w ;# this had better still be the main window
 global bias nickname
 set cn $nickname($c)
 set fr $w.lbiaslist$cn
 catch {pack forget $fr}
 catch {frame $fr}
 switch $cn {
	c1 {
	 set side left
	} 
	c2 {
	 set side right
	}
	default {
	 set side left
	 puts "oi! $cn"
	}
 }
 pack $fr -in $w.lbias($cn) -side $side
 for {set ii 0} {$ii<$m} {incr ii} { set bias($c,$ii) [lindex $counts $ii] if {$verbose>=2} { puts "$ii : [set bias($c,$ii)]" }
	catch {entry $w.lbias($cn,$ii) -textvariable bias($c,$ii) -width 3 -borderwidth 1}
	pack $w.lbias($cn,$ii) -in $fr -side left
	bind $w.lbias($cn,$ii) <return> "sort_out_biases $c $M"
 }
 catch {pack forget $w.lbias($cn,$ii)} ;# delete excess entries if they exist
 sort_out_biases $c $M
}
proc sort_out_biases { c M } {
 global bias verbose
 for {set ii 0; set cum 0.0} {$ii<$m} {incr ii} { if {$verbose>=2} { puts "$ii :: $cum :: [set bias($c,$ii)]" }
	set cum [expr $cum+$bias($c,$ii)]
 }
 for {set ii 0} {$ii<$m} {incr ii} { set bias($c,$ii) [expr 1.0*$bias($c,$ii)/$cum] } } proc setupdisplaystyle { D } { global alpha beta gwidth Ox Oy RHS W H verbose vsign vfactor Nx Ny # Ox and Oy define the origin for drawing things. # Nx and Ny define another attention point which is the point that is queried # to determine what node expansion to do. # whatever is above the attention origin is the current string. # # vertical stretch factor's sign set vsign 1 ;# (change to negative to make up positive); but positive agrees with figures in MacKay(97-8) # vector's length stretched by this factor set vfactor 2.0 switch $D { uniform { set Ox [expr $W/4] ; set Nx [expr 3*$W/4] set Oy [expr $H/2] ; set RHS $W ;# unimportant set alpha 70 ;# global horizontal magnification factor set gwidth [expr $W*0.85] ;# generic box width set beta 250 ;# global vertical # puts "done uniform" } bounded { set Ox [expr $W/4] ; set Nx [expr 3*$W/4] set Oy [expr $H/2] ; set RHS [expr int($W*0.85)] global RHSbuffer ; set RHSbuffer 3 global Nxmax Nxmin ;# safe interval for mouse x coord set Nxmax [expr $RHS-int($W*0.03)] set Nxmin 0 set alpha 250 set beta 250 set gwidth 250 ;# unimportant # puts "done bounded" } default { puts "don't know $D!!" } } set Ny $Oy set beta [expr $beta*$vsign] if {$verbose>=2} { puts "done $D" }
}
proc request_model { c m {alphab -1} {adap -1} } {
 if {($m<2)} { if {$verbose>=1} {
	 puts "can't have alphabet of size $m"
	}
	bell
 } else {
	global nickname
	set cn $nickname($c)
	set counts "1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1"
	# this is UGLY but this whole subroutine is ugly
	switch $cn {
	 c1 {
		if {"$alphab"==-1} {
		 set alphab alpha
		}
		if {"$adap"==-1} {
		 set adap 1
		}
	 }
	 c2 {
		if {"$alphab"==-1} {
		 set alphab num
		}
		if {"$adap"==-1} {
		 set adap 0
		}
	 }
	}
	define_model $c $m $alphab $counts $adap 1
	global bigramic ; set bigramic($c) 0
 }
}
proc cleancanvases { } {
 global gwidth canvaslist
 global nodenumber ; set nodenumber 0
 foreach c [concat $canvaslist] {
	global $c
	$c delete child
	# this deletes everything called a child
	# but we need to put childless tag back on all nodes!
	# so it is easiest to delete all
	$c delete node
	# and start from scratch:
	# make the mother of all nodes
	truenode make $c 0 1 $gwidth b ":"
 }
}
proc bind_keys_canvas { c } {
 # idea: use keyboard 123456..90 to zoom ahead. space bar is the retraction
 # method. z...m are stationary up and down. 
 global verbose vsign
 set keyboardxfactor 5
 set keyboardyfactor 5
 set p "1 2 3 4 5 6 7 8 9 0
 q w e r t y u i o p
 a s d f g h j k l ;
 z x c v b n m , . /"
 set i -1 ;
 set mmax 3
 set mmin 0
 set kmin -4
 set kmax 5
 for {set m $mmax} {$m>=$mmin} {incr m -1} {
	for {set k $kmin} {$k<=$kmax} {incr k} { incr i set key [lindex $p $i] if {$verbose>=2} {puts $key}
	 bind $c $key "move_ed [expr $m*$keyboardxfactor] [expr ($vsign)*$keyboardyfactor*($k)] 1"
	}
 }
 bind $c <space> "move_ed [expr -5*$keyboardxfactor] 0 1"
}
proc setexpm { } { 
 global magnification expm Top Bot centre
 set expm [expr exp(-$magnification)]
 # expm is the vertical height of the window
 set Top [expr $centre + 0.5*$expm]
 set Bot [expr $centre - 0.5*$expm]
}
# bind a mouse click to cause a snap to a new centred view.
# and grab the mouse and put it in the centre.
proc mouse1 { x y } {
# move the mouse itself (don't yet)
 global Ox Oy verbose
# and move everything in the window
 if {$verbose>=2} {
	puts "snapping to $x $y - origin is $Ox $Oy"
 }
 snap_to $x $y
}
proc snap_to { x y {factor 1.0} {showvector 0} } {
# convert x y coordinates to a new centre, magnification value
 global Ox alpha beta expm magnification centre Oy Displaystyle RHS dm dc
 global RHSbuffer verbose
 if {$verbose>=2} { 
	puts "snap_to $x $y $factor $showvector $RHS [expr $RHS-$x] $RHSbuffer"
 }
 if {!($factor==1.0)} { 
	set dmmax [expr 1.0/$factor] ;# magnification by exp(1) seems safest max
 } else {
	set dmmax 3.0 ;# a plain click is allowed to magnify by exp(3)
 }
 switch $Displaystyle {
# see also truenode
	uniform {
	 # x: - ( x-Ox )/alpha is the change in magnification needed
	 set dm [expr ($x - $Ox)/$alpha]
	}
	bounded {
	 if {($RHS-$x)>$RHSbuffer} {
		if {$verbose>=2} { 
		 puts "doing log, ($RHS-$x)>$RHSbuffer"
		}
		set dm [expr log(1.0*($RHS-$Ox)/($RHS-$x))]
	 } else {
		set dm [expr $dmmax] ;# maximum magnification step permitted
	 }
	}
	default {
	 puts "don't know how to snap $Displaystyle"
	}
 }
 if {$dm>$dmmax} {
	set dm [expr $dmmax] ;# maximum magnification step permitted
 }
 # idea: to prevent frustrating falling--off--the bottom when chasing 
 # something, have factor be made larger here. 
 if {!($factor==1.0)} { 
	set tiny 0.001
	set dmtarget $dm
	set dm [expr $dm*$factor]
	# check to see that we are not too close to tiny movements, which 
	# would make the following exp's break.
	if {($dm>$tiny)&#124;&#124;(-$dm<-$tiny)} { set factor [expr (1.0-exp(-$dm))/(1.0-exp(-$dmtarget))] } # this modifies things perfectly i think. } if {$verbose>=2} {
	puts "$dm , $dmmax , $factor [expr $y-$Oy], $expm, $beta;" 
 }
 # c: ( y - Oy ) / ( beta / expm ) is the change in centre
 set rawdc [expr $factor*($y-$Oy)/($beta)]
 set dc [expr $rawdc * $expm ]
 if {$verbose>=2} { puts "dm $dm dc $dc [expr $dc/($dm*$expm)]" }
 dincr magnification $dm ; dincr centre $dc
 propagate_mc 1
 if {$showvector} { updateVectors $dm $rawdc }
}
# propagate_mc instructs all items on the canvases to update
# 
# active says whether node expansion of the origin node
# should be done immediately. active can be overridden by the global 
# variable Active
proc propagate_mc { active } {
 global expm magnification centre canvaslist item2node n2i verbose n_s currents
 global Broodiness Active slideatme slidelength
 if {$centre> 1.0} {
	set centre 1.0
 }
 if {$centre < 0.0} { set centre 0.0 } if {$magnification>$slideatme} {
	slideallnodes $slidelength
 }
 if {$magnification < -1.5} { set magnification -1.5 } if {$magnification> 25.0} {
	if {$verbose>=1} {
	 puts "warning, close to magnification limit $magnification (27.6)"
	}
	bell
 }
 setexpm
 updateallnodes
 update idletasks
# the following expands children of the central node
 foreach c [concat $canvaslist] {
	global $c
	if {$active} {
	 if {$Active($c)} {
		# global n i ;# these will be found by find_currents
		set n -1 ;# using upvar
		find_currents $c
		if {$n>=0} {
		 push_at $i $n $Broodiness($c) $c
		}
	 }
	}
	$c raise hairs
	$c raise string
 }
}
# the following is grabbed from the tail of propagate_mc
# 
# find item nearest the attention origin Nx Ny
proc find_currents { c } {
 global currents item2node n2i Nx Ny verbose n_s attentionpoint
 global Displaystyle
 switch $attentionpoint {
	at_cross {
	 set Ox $Nx ; set Oy $Ny
	 # this was the original standard
	}
	at_mouse {
	 # but I think it might be good to get the y coordinate of the mouse
	 # how to get mousey ?
	 global Mousey Mousex
	 set Ox $Nx ; set Oy $Mousey
	 switch $Displaystyle {
		bounded {
		 global Nxmax Nxmin
		 # here there is a limited interval in which 
		 # it is safe for the mouse x coord to be used.
		 if {$Mousex<$nxmin} { set Ox $Nxmin } elseif {$Mousex>$Nxmax} { 
			set Ox $Nxmax
		 } else {
			set Ox $Mousex
		 }
		}
		uniform {
		 # here, just use the mouse x coordinate.
		 set Ox $Mousex
		}
	 }
	}
	default {
	 set Ox $Nx ; set Oy $Ny
	}
 }
# global n i ;# these are global in order to return them
 upvar i i ;#
 upvar n n ;# this grabs the calling procedure's i and n 
 # now find the item nearest to the origin
 # would like to restrict to ... withtag rect , so I can have crosshairs ignored
 $c addtag attend closest $Ox $Oy
 $c addtag attend overlapping $Ox $Oy $Ox $Oy
 # select the youngest node of all. How to ask for the youngest
 # that also has the tag rect?
 set attend [$c find withtag attend]
 # the list comes ordered by raise/lower order, not by age order.
 # so I need to select the largest on the list. 
 set attend0 [lsort -integer $attend]
 # last on list
 set attend2 [lindex $attend0 end] 
 if {$verbose>=2} {
	set len [expr ([llength $attend0])]
	puts "on the list $attend0"
	puts " whose length is $len"
	puts "the last item is $attend2"
 }
 # if only the cross hairs and vector are kicking in, forget it. 
 # the number HAIRS is used to check to ignore items
 global HAIRS
 if {$attend2<=$hairs($c)} { set currents($c) "none" set n -1 ; set i -1 } else { foreach item [concat $attend2] { set n $item2node($item,$c) set i $n2i($n) if {$verbose>=2} {
		set s $n_s($n)
		puts "nearest string to origin is $s"
	 }
	 set currents($c) $n_s($n)
	}
 }
 # remove the attend tag
 $c dtag attend attend
}
proc dump { } {
 global canvaslist currents
 puts "Current strings are:"
 set iii 0 
 foreach c [concat $canvaslist] {
	incr iii
	find_currents $c
#	puts "$iii: $currents($c)"
	puts "$currents($c)"
 }
}
proc updateVectors { dm rawdc } {
 global canvaslist currents
 global magnification alpha beta centre expm Ox Oy falpha
 global Displaystyle RHS verbose
 global vfactor
 set y [expr $Oy + $vfactor * $beta * $rawdc ]
 switch $Displaystyle {
	uniform {
	 set x [expr $Ox + $vfactor * $alpha * $dm ]
	}
	bounded { 
	 set x [expr $Ox + $vfactor * ($RHS-$Ox)*$dm]
	}
	default {
	 puts "don't know $Displaystyle!!"
	}
 }
 if {$verbose>=2} { puts "uv: $dm $rawdc \t$x \t$y" }
 foreach c [concat $canvaslist] {
	set v [$c find withtag vector]
	$c coords $v $Ox $Oy $x $y 
	$c raise $v
 }
}
# really=1 really makes the move.
set Epsilon 0.05
set Delta 0.01
proc move_ed { epsilon delta really } {
 global Epsilon Delta expm verbose dm dc
 if {$verbose>=2} {
	puts "move $epsilon $delta" ;
 }
 global magnification alpha beta centre
 set dm [expr $epsilon * $Epsilon]
 set rawdc [expr $delta*$Delta]
 set dc [expr $rawdc * $expm ]
 # now is a perfect time to create a vector and show it.
 updateVectors $dm $rawdc 
 if {$really} {
	dincr magnification $dm
	dincr centre $dc
	set expanding [expr ($epsilon>=0)?1:0]
	propagate_mc $expanding ;# only push at nodes if we are expanding
 }
}
proc dincr { x y } {
 global $x
# puts "adding:"
# puts [set $x]
# puts $y
 set $x [expr [set $x] + $y]
# puts [set $x]
# puts "done"
}
# this is invoked once only to record the a and b coordinates of 
# each node. Also, the box width w, the main tag, its prob and log 
# prob, which canvas it is on, and whether it is actually on the canvas.
proc newnode {a b w t s p l c o} {
 global nodenumber n_a n_b n_s n_w n_t n_p n_l n_c n_o
# store the a b w t and s of this object in an array
 set n_a($nodenumber) $a
 set n_b($nodenumber) $b
 set n_c($nodenumber) $c
 set n_s($nodenumber) $s
 set n_w($nodenumber) $w
 set n_t($nodenumber) $t
 set n_l($nodenumber) $l
 set n_p($nodenumber) $p
 set n_o($nodenumber) $o
}
# make or update a node.
#
# truenode is only called by (1) making the mother node
# (2) creating children
# (3) updateallnodes 
#
proc truenode {method c a b w t s} {
# a and b define an arithmetic interval.
# c is the canvas to put it on.
# the difference p=b-a determines how far to the right the node is drawn.
# when making, t is a tag you can choose.
# when updating t is the nodenumber , which is used to find the object
 global magnification alpha beta centre expm Ox Oy falpha H
 global n_a n_b n_s n_w n_t n_p n_l n_o n_tr n_tt Displaystyle RHS
 global DeleteDistantRelatives ReinstateDistantRelatives verbose
 switch $method {
	make {
	 set p [expr $b-$a]
	 set logp [expr -log($p)]
	}
	update {
	 set p $n_p($t) 
	 set logp $n_l($t) 
	}
	default {
	 puts "don't know $method!!"
	}
 }
 set ytop [expr $Oy + $beta * ( $b - $centre ) / $expm ]
 set ybot [expr $Oy + $beta * ( $a - $centre ) / $expm ]
 if {(($ybot>$H)&&($ytop>$H))&#124;&#124;(($ybot<0)&&($ytop<0))} { # definitely off canvas set o 0 } else { # could be on canvas; overlaps the current interval vertically. set o 1 } set drawingrect 1 if {($DeleteDistantRelatives)} { if {$o==0} { # don't need to bother working out fontsizes, etc if {"$method"=="make"} { set drawingrect 3 ;# this will draw it then delete it } elseif {("$method"=="update")&&($n_o($t))} { # we should delete this dude, cos he thinks he is on canvas set n_o($t) $o set drawingrect 0 } } elseif {$ReinstateDistantRelatives} { if {("$method"=="update")&&($n_o($t)==0)} { # we should put this guy back set n_o($t) $o if {$verbose>=2} { puts "reinstating $t" }
		set drawingrect 2 ;# this indicates special circumstances
	 }
	}
 }
 if {$drawingrect} {
	switch $Displaystyle {
	 uniform {
		set rightness [expr ( $logp - $magnification ) ]
		set x [expr $Ox + $alpha * $rightness ]
		set rhs [expr $x+$w]
		set fontsize [expr ($rightness> 4)?8: ($rightness> 3)?10: ($rightness> 2)?14:(($rightness>1)? 30:40) ]
	 }
	 bounded { 
		set factor [expr $p/$expm]
		set x [expr $RHS-$alpha*$factor]
		set rhs $RHS
		set rightness [expr 1.0/$factor]
		set fontsize [expr ($rightness> 6)?8:($rightness> 4)?13: ($rightness> 3)?19: ($rightness> 2.5)?24:(($rightness>2)? 30:40) ]
	 }
	 # see also snap_to
	 default {
		puts "don't know $Displaystyle!!"
	 }
	}
	# fontsize setting:
	#
	# a completely covariant method would be:
	# set fontsize [expr int(80*$p/$expm)]
	#
	# but to make things to the right more visible set falpha non-1, e.g. 0.5
	# set falpha 0.5
	# set fontsize [expr int(80*exp($falpha*$rightness))]
	#
	# set fontsize 16
	#
	set f "Courier $fontsize"
 }
 switch $method {
	make {
	 newnode $a $b $w $t $s $p $logp $c $o
	 if {($drawingrect)} {
		set n [makeNode $c $x $ybot $rhs $ytop $t $s $f]
	 }
	 if {($drawingrect==3)} {
		deleteNode $c $n 
	 }
	}
	update {
	 if {($drawingrect==1)} {
		updateNode $c $x $ybot $rhs $ytop $t $f
	 } elseif {$drawingrect==2} {
		# reinstating involves extra arguments, unless in fact the 
		# poor chap was never drawn ever. 
		#		if [array exists n_tr($t)] 
		makeNode $c $x $ybot $rhs $ytop $t $s $f 1 $t $n_tr($t) $n_tt($t) 
	 } elseif {$drawingrect==0} {
		deleteNode $c $t 
	 }
	}
	default {
	 puts "don't know $method!!"
	}
 }
}
set colorlist "SkyBlue2
	LightSkyBlue2 
	lightblue2 
	CadetBlue2 	
	aquamarine2 
	seagreen2 
	turquoise2 
	paleturquoise2 
	lightcyan2 
	lightsteelblue2
	orchid2	 
	plum2	 
	magenta2 
	mediumorchid2 
 SkyBlue3 
 LightSkyBlue3 
 lightblue3 
 CadetBlue3 
 aquamarine3 
 seagreen3 
 turquoise3 
 paleturquoise3
 lightcyan3 
 lightsteelblue3
 orchid3 
 plum3 
 magenta3 
 mediumorchid3
 springgreen3 
 Maroon3 
 lavenderblush3
 palegreen3 
	springgreen2 
 Maroon2	 
	lavenderblush2 
	palegreen2 	
	bisque2	 
	khaki2 
 khaki3 
 bisque3 
"
global nextcolor ; set nextcolor 0
# c is canvas, x and y are coords. t is tag
proc makeNode {c x ybot xr ytop t s f {remaking 0} {oldn -1} {rtags "null"} {ttags "null"}} {
 global nodenumber bordercol item2node n2i numcols
 global colorlist maxstringlength truncated verbose nextcolor variableStrings n_s_long n_s_short
# tcl 8:
# set th [expr int(rand()*$numcols) ]
 if {$nextcolor>$numcols} { set nextcolor 0 }
 set th $nextcolor ; incr nextcolor
 set thiscolor [lindex $colorlist $th]
 if {$maxstringlength} {
	set len [string length $s]
	if {$len>$maxstringlength} {
	 set s [string range $s [expr $len-$maxstringlength] end]
	 set s "$truncated$s"
	} 
 }
 if {$remaking} {
	set mynumber $oldn
 } else {
	set mynumber $nodenumber
	incr nodenumber 
	set n_s_short($mynumber) [string range $s end end]
	set n_s_long($mynumber) $s
 }
 
 if {$variableStrings} {
	set s [nodes_string $mynumber $x]
 }
 set item [$c create rect [expr $x] [expr $ybot] \
 [expr $xr] [expr $ytop] -width 1 -outline $bordercol \
	 -fill $thiscolor ]
 set item2 [$c create text [expr $x] [expr ($ybot+$ytop)/2] \
 -anchor w -justify left -text "$s" -font $f ]
# this gives the number of the object to the variable item.
 if {$remaking} {
	foreach ta [concat $rtags] {
	 $c addtag $ta withtag $item
	}
	foreach ta [concat $ttags] {
	 $c addtag $ta withtag $item2 
	}
	set $rtags [$c gettags $item] ;# is this right?
	if {$verbose>=2} { puts "restored $rtags" }
 } else {
 $c addtag node$mynumber withtag $item
	$c addtag text$mynumber withtag $item2
	foreach ta [concat $t] {
	 $c addtag $ta withtag $item
	}
	$c addtag t$t withtag $item2
 $c addtag rect withtag $item
	$c addtag string withtag $item2
	$c addtag node withtag $item
	$c addtag node withtag $item2 ;# text must be tagged so that entering
	#the text and entering the rectangle are equivalent
	$c addtag childless withtag $item
	$c addtag ggggchildless withtag $item
	$c addtag gggchildless withtag $item
	$c addtag ggchildless withtag $item
	$c addtag gchildless withtag $item
 }
 set item2node($item,$c) $mynumber
 set item2node($item2,$c) $mynumber
 set n2i($mynumber) $item
 return $mynumber
}
proc nodes_string { n x } {
 global n_s_short n_s_long Nx Ox RHS Displaystyle
 if {$x<$nx} { set s $n_s_long($n) } else { set s $n_s_short($n) } return $s } proc updateNode {c x ybot xr ytop n f} { global verbose variableStrings if {$verbose>=2} {
	set junk "$c coords node$n [expr $x] [expr $ybot] [expr $xr] [expr $ytop]"
	puts "invoking $junk" 
 }
 # update rect:
 $c coords node$n [expr $x] [expr $ybot] [expr $xr] [expr $ytop]
 # update text:
 $c coords text$n [expr $x] [expr ($ybot+$ytop)/2] 
 $c itemconfigure text$n -font $f 
 if {$variableStrings} {
	set s [nodes_string $n $x]
	$c itemconfigure text$n -text $s
 }
 if {$verbose>=2} {
	set junk [$c coords node$n]
	puts "now coords are $junk" 
 }
}
proc deleteNode {c n} {
 global n_tr n_tt ;# place to put tags while we destroy these guys
 global verbose
 set n_tr($n) [concat [concat [$c gettags node$n]]]
 set n_tt($n) [$c gettags text$n] 
 if {$verbose>=2} { puts "deleting $n_tr($n)" }
# rect:
 $c delete node$n 
# text:
 $c delete text$n 
}
# see itp/bigrams
#####################################################################
proc english1 { c } {
 global verbose
# put english monogram model in c
 set counts "5366 1219 2602 2718 8377 1785 1280 3058 5903 70 800 3431 2319 5470 6526 1896 539 4660 5453 6767 3108 652 1388 765 1564 78 18104"
 define_model $c 27 alpha $counts 0 1
 if {$verbose>=2} { puts "Hint: change pushiness for the other canvas to 3." }
 global nickname
 set cn $nickname($c)
 upvar w w
 global $w.lbias($cn)
 pack forget $w.lbias($cn)
 global bigramic ; set bigramic($c) 0
}
#####################################################################
proc english2 { c {jack 1} } {
 global verbose 
 global mbigramic ; set mbigramic($c) 1
# put english bigram model in c
 if {$jack} {
	set counts "
0.05 0.05 2 0.05 0.05 1 0.05 0.05 1 0.05 0.05 0.05 1 3 0.05 0.05 0.05 0.05 0.05 1 0.05 0.05 0.05 0.05 0.05 0.05 1 
0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 1 0.05 0.05 0.05 0.05 0.05 1 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 
1 0.05 0.05 0.05 0.05 0.05 0.05 1 0.05 0.05 2 0.05 0.05 0.05 0.05 0.05 0.05 1 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 
0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 1 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 3 
0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 1 0.05 1 0.05 0.05 0.05 2 0.05 1 0.05 0.05 0.05 0.05 0.05 0.05 3 
0.05 0.05 0.05 0.05 2 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 1 0.05 0.05 0.05 0.05 0.05 0.05 1 
0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 1 
0.05 0.05 0.05 0.05 1 0.05 0.05 0.05 2 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 1 
0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 4 0.05 1 0.05 0.05 0.05 0.05 1 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 
2 0.05 0.05 0.05 0.05 0.05 0.05 0.05 2 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 
0.05 0.05 0.05 0.05 1 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 2 
0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 1 0.05 0.05 4 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 5 
0.05 1 0.05 0.05 1 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 
0.05 0.05 0.05 3 0.05 0.05 1 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 1 0.05 0.05 0.05 0.05 0.05 0.05 2 
0.05 0.05 0.05 0.05 0.05 1 0.05 0.05 0.05 0.05 1 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 2 0.05 0.05 0.05 1 
1 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 1 
0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 4.05 0.05 0.05 0.05 0.05 0.05 0.05 
0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 2 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 2 
0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 1 
0.05 0.05 1 0.05 2 0.05 0.05 1 0.05 0.05 0.05 0.05 0.05 0.05 1 0.05 0.05 0.05 0.05 0.05 1 0.05 0.05 0.05 0.05 0.05 1 
0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 1 0.05 0.05 1 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 
0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 
1 0.05 0.05 0.05 1 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 2 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 
0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 
0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 
0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 0.05 
5 1 2 1 0.05 2 0.05 2 0.05 3 0.05 0.05 0.05 0.05 1 1 0.05 0.05 0.05 3 1 0.05 2 0.05 0.05 0.05 0.05 
"
 } else {
	set counts "
 3 226 291 209 4 19 128 5 213 5 65 412 173 966 0.5 106 45 674 307 698 68 187 11 9 99 3 440 
 73 1 14 11 215 4 1 2 75 8 0.5 230 6 0.5 171 2 0.5 31 38 5 100 1 0.5 0.5 88 0.5 143 
 316 1 95 4 256 0.5 0.5 332 49 0.5 184 83 5 0.5 496 8 0.5 80 61 221 87 0.5 2 1 17 0.5 304 
 78 8 3 27 403 14 8 2 242 1 0.5 9 21 4 410 4 0.5 37 60 0.5 125 10 15 5 15 0.5 1217 
 290 35 311 529 203 71 19 4 40 1 2 332 330 410 33 48 27 1065 863 400 4 103 71 124 52 6 3004 
 85 0.5 0.5 37 49 46 0.5 0.5 288 0.5 0.5 44 4 1 363 1 0.5 127 82 124 46 1 0.5 0.5 2 0.5 485 
 22 0.5 44 2 306 1 9 58 47 0.5 0.5 15 11 30 37 2 0.5 145 19 1 25 0.5 0.5 1 6 33 466 
 516 0.5 0.5 12 1327 4 0.5 0.5 344 0.5 0.5 10 2 4 339 8 0.5 24 5 86 21 0.5 0.5 0.5 13 0.5 343 
 98 112 195 71 95 141 96 0.5 5 6 43 487 119 1806 619 67 0.5 119 738 626 7 85 1 49 1 7 310 
 12 0.5 0.5 0.5 27 0.5 0.5 0.5 2 0.5 0.5 0.5 2 0.5 12 0.5 0.5 0.5 0.5 1 13 0.5 0.5 0.5 0.5 0.5 1 
 32 3 6 3 296 6 4 1 51 0.5 0.5 4 0.5 32 0.5 0.5 0.5 0.5 55 4 4 0.5 8 1 4 0.5 286 
 198 7 6 118 646 35 0.5 0.5 780 0.5 3 307 3 7 245 38 0.5 5 126 49 67 5 4 0.5 252 0.5 530 
 455 78 9 6 407 0.5 2 0.5 174 1 15 30 59 4 247 223 0.5 1 107 17 57 2 0.5 0.5 82 0.5 343 
 149 6 184 615 396 99 473 1 140 1 44 56 3 74 228 16 0.5 6 302 400 539 21 1 0.5 61 1 1654 
 36 79 157 91 50 343 125 2 13 15 37 128 393 1135 171 142 0.5 981 252 289 799 38 364 6 0.5 0.5 880 
 227 1 22 12 153 13 16 23 77 0.5 2 103 15 0.5 159 127 0.5 313 72 71 115 0.5 0.5 0.5 58 1 316 
 0.5 0.5 0.5 0.5 0.5 0.5 0.5 0.5 0.5 0.5 0.5 0.5 1 0.5 0.5 0.5 0.5 0.5 5 1 193 0.5 0.5 0.5 0.5 0.5 139 
 261 8 114 119 1094 9 30 1 308 1 73 30 141 176 485 5 1 84 224 255 82 18 10 0.5 190 1 940 
 109 5 96 21 578 9 19 162 285 0.5 107 29 26 24 275 58 1 41 197 760 164 6 91 16 134 0.5 2240 
 349 0.5 102 7 659 5 11 1593 859 0.5 0.5 56 30 0.5 710 98 0.5 169 147 81 68 0.5 47 0.5 73 3 1700 
 40 116 68 41 196 15 28 0.5 44 0.5 21 135 128 400 0.5 147 0.5 215 366 259 2 0.5 1 440 1 0.5 445 
 99 0.5 8 0.5 398 9 2 0.5 70 0.5 0.5 0.5 4 0.5 14 0.5 0.5 2 0.5 0.5 0.5 0.5 0.5 0.5 1 0.5 45 
 156 2 1 2 104 0.5 0.5 282 223 1 0.5 17 0.5 33 107 1 0.5 38 72 97 3 0.5 44 0.5 0.5 0.5 205 
 23 1 4 4 20 21 0.5 0.5 18 0.5 0.5 0.5 0.5 1 0.5 14 0.5 2 0.5 59 0.5 0.5 0.5 16 8 0.5 574 
 0.5 13 0.5 0.5 13 0.5 1 0.5 9 0.5 0.5 19 17 5 402 33 0.5 17 160 9 0.5 0.5 6 0.5 0.5 7 853 
 3 0.5 0.5 0.5 13 0.5 0.5 1 10 0.5 0.5 3 0.5 0.5 6 0.5 0.5 0.5 1 0.5 0.5 0.5 0.5 0.5 0.5 0.5 41 
 1736 517 872 777 469 921 308 589 1537 30 204 892 826 358 997 748 465 484 1194 2254 519 175 712 97 407 16 0.5 
 "
# i slightly modified the above. the entry 139 for q_ was actually 339
# because of all the faq and q's in the document.
}
 set M 27
 set m1 0 ; set m2 [expr $M-1]
 set alist "a b c d e f g h i j k l m n o p q r s t u v w x y z _"
 global bigram
 foreach a [concat $alist] {
	set bigram($a) [lrange $counts $m1 $m2]
	if {$verbose>=2} { puts "$a: $bigram($a)" }
	incr m1 $M ; incr m2 $M
 }
 
 define_model $c 27 alpha $counts 0 1
 if {$verbose>=2} { puts "Hint: change pushiness for the other canvas to 3." }
 global nickname
 set cn $nickname($c)
 upvar w w
 global $w.lbias($cn)
 pack forget $w.lbias($cn)
}
#####################################################################
global filenumber; set filenumber 0
proc postscript { c } {
# write canvas to a ps file
# make a dialog window suggesting a file name
 global filenumber ownwindow
 set fileprefix "ps/"
 set filepostfix ".ps"
 set w .psdialog
 if {$ownwindow>=1} {
	toplevel $w
	wm geometry $w +300+300
 } else {
	pack [frame $w]
 }
 frame $w.text
 pack $w.text
 global filename ; set filename "$fileprefix$filenumber$filepostfix"
 entry $w.filename -textvariable filename
 pack $w.filename -in $w.text
 focus $w.filename
# puts "$c postscript -file $filename"
# $c postscript -file $filename
 bind $w.filename <return> " $c postscript -file $filename ; destroy $w "
 bind $w.filename <control-c> " destroy $w "
 bind $w <control-c> " destroy $w "
 incr filenumber
}
#####################################################################
proc push_at { i n broodiness c } {
 global n_a n_b n_s n_t gwidth verbose
 if {$verbose>=2} { $c itemconfig $i -fill pink }
# if the node is childless,
# find my coordinates and make some children
# remove the childless tag and record the fact that I am a mother
 set t [$c gettags $i] ;# t is the list of my tags
 # if we have the childless tag:
 if "[lsearch -exact $t childless] != -1" {
	make_children $i $n $c
 } 
 set threshold 2
 foreach stigma "gchildless ggchildless gggchildless ggggchildless" {
	set havestigma [expr ([lsearch -exact $t $stigma]!=-1)]
	if {($broodiness>=$threshold)&&($havestigma)} {
	 pester_children $i $n [expr ($broodiness-1)] $stigma $c
	} 
	incr threshold
 } 
}
# child-pestering (asking for grandchildren, etc)
# 
# story "hey, I am (tagtolose), that's no good, so you should be broody!"
proc pester_children { i n broodiness tagtolose c } {
 # go through all children, push_at them to have a broodiness that matches
 # mine
 global n_a n_b n_s n_t gwidth verbose item2node n2i 
 # anticipate success.
 $c dtag $i $tagtolose
 # first, remember my name
 set s $n_s($n) ; 
 # then find my children , using a child-of tag
 set t "of_$i" 
 set children [$c find withtag $t]
 foreach child [concat $children] {
	if {$verbose>=2} { puts "my child: $child" }
# I know where you live
	set n $item2node($child,$c)
	set i $n2i($n)
# send them a whinging postcard
	push_at $i $n $broodiness $c
 }
}
# binary child-making
proc make_children { i n c } {
 global n_a n_b n_s n_t gwidth verbose bias tails madaptive mbigramic
 global mcounts total cum bigram
 $c dtag $i childless
 $c addtag mother withtag $i 
 set a $n_a($n) ; 
 set b $n_b($n) ; 
 set s $n_s($n) ; 
 if {$madaptive($c)} {
	# monogram statistics adaptive Dirichlet model
	# find out what bias should be here.
	set ii 0 ; set total 0 
	foreach tail $tails($c) {
	 # count all occurrences in context.
	 set count($ii) [regsub -all $tail $s "" junk]
	 set count($ii) [expr $count($ii)+[lindex $mcounts($c) $ii]] 
	 # the usual laplace offset
	 dincr total $count($ii)
	 incr ii
	}
 }
 if {$mbigramic($c)} {
	# bigram statistics, fixed model
	set ii 0 ; set total 0 
	set context [string range $s end end]
	if {"$context"==":"} {
	 set context "_"
	}
	set mcounts($c) $bigram($context)
	if {$verbose>=2} {
	 puts "context is $context"
	 puts "$mcounts($c)"
	}
	foreach tail $tails($c) {
	 set count($ii) [lindex $mcounts($c) $ii] 
	 dincr total $count($ii)
	 incr ii
	}
 }
 if {$madaptive($c)&#124;&#124;$mbigramic($c)} {
	set ii 0 
	foreach tail $tails($c) {
	 set bias($c,$ii) [expr 1.0*$count($ii)/$total]
	 if {$verbose>=2} {
		puts "in context $s, prob ($tail) is $bias($c,$ii)"
	 }
	 incr ii
	}
 }
 set ii 0 ; set cum 0.0 ; set w [expr $b-$a]
 foreach tail $tails($c) {
	set a$ii [expr $a+$cum*$w]
	dincr cum $bias($c,$ii)
	set b$ii [expr $a+$cum*$w]
	set news $s$tail
	set t "s$news child of_$i"
	if {$verbose>=2} {
	 puts "making node for $news"
	 puts "interval [set a$ii] [set b$ii]"
	}
	truenode make $c [set a$ii] [set b$ii] $gwidth $t $news
	incr ii
 }
 update idletasks
 $c raise hairs
 $c raise string
}
proc enterNode {c} {
 global restoreCmd item2node n2i Broodiness Active verbose
# puts "entered node "
 set item [$c find withtag current]
 set n $item2node($item,$c)
 set i $n2i($n)
 set remember [lindex [$c itemconfig $i -fill] 4]
 if {$verbose>=2} { puts $remember }
 set restoreCmd "$c itemconfig $i -fill $remember"
 set highcol orange
 # change the current square to a similar color
 foreach nu "2 3" {
	if [expr ([string first $nu $remember]>-1)] {
	 # replace nu by nu-1 and put in highcol
	 set num [expr $nu-1]
	 regsub $nu $remember $num highcol
	 break
	}
 }
 $c itemconfig $i -fill $highcol
 if {$Active($c)} {push_at $i $n $Broodiness($c) $c}
}
proc itemLeave {c} {
 global restoreCmd
 if {!($restoreCmd=="null")} {
	eval $restoreCmd
 }
 set restoreCmd "null"
}
#####################################################################
# Modify all coordinates.
proc updateallnodes {} {
# find all objects that exist, i.e. all nodes and all strings.
# go through array of attributes invoking truenode
 global nodenumber n_a n_b n_s n_w n_t n_c n_o ReinstateDistantRelatives
 global nodenumber 
 for { set n 0 } { $n < $nodenumber } { incr n } { if {($n_o($n)>-1)&&(($ReinstateDistantRelatives)&#124;&#124;$n_o($n))} {
	 truenode update $n_c($n) $n_a($n) $n_b($n) $n_w($n) $n $n_s($n)
	}
 }
}
#####################################################################
# Slide the world relative to m.
# Rescale all array coordinates and m in accordance with a prescribed 
# change in m
proc slideallnodes { deltam } {
# find all objects that exist, i.e. all nodes and all strings.
# anything that slides off canvas gets its status downgraded to n_o=-1
 
 global nodenumber n_p n_l n_a n_b n_s n_w n_t n_c n_o
 global magnification centre verbose
 if {$verbose>=2} {
	puts "slide! - m = $magnification , deltam = $deltam"
 }
 set magnification [expr $magnification+$deltam] ;# expect deltam negative
 if {$magnification<0.0} { if {$verbose>=1} {
	 puts "warning, excessive slide in magnification to $magnification requested" ;
	}
	set deltam [expr $deltam-$magnification]
	set magnification 0.0 
 }
 setexpm
 set newcentre 0.5
 set factor [expr exp(-$deltam)] ;# factor by which to increase all p's
 for { set n 0 } { $n < $nodenumber } { incr n } { if {$n_o($n)>-1} {
	 set n_a($n) [expr ($n_a($n)-$centre)*$factor+$newcentre]
	 set n_b($n) [expr ($n_b($n)-$centre)*$factor+$newcentre]
	 if {($n_a($n)>1.0)&#124;&#124;($n_a($n)<0.0)&#124;&#124;($n_b($n)>1.0)&#124;&#124;($n_b($n)<0.0)} { deleteNode $n_c($n) $n set n_o($n) -1 continue } set n_p($n) [expr ($n_b($n)-$n_a($n))] set n_l($n) [expr -log($n_p($n))] } } set centre $newcentre updateallnodes } proc mousepad { } { set w .mp catch {destroy $w} toplevel $w wm geometry $w -30-30 set c $w.c set W 200 ; set H 200 set Ox [expr $W/2] ; set Oy [expr $H/2] ; canvas $c -borderwidth 0 -width $W -height $H -background gold pack $c -expand yes -fill both bind $w <control-x> "destroy ."
 bind $w <control-q> "destroy ."
 $c create line 0 $Oy $W $Oy -fill red
 $c create line $Ox 0 $Ox $H -fill red
 
 bind $c <motion> \
	 "entercenter \[expr (%x-$Ox)\] \[expr (%y-$Oy)\] 0"
 bind $c <shift-motion> \
	 "entercenter \[expr (%x-$Ox)\] \[expr (%y-$Oy)\] 1"
 bind $c <control-motion> \
	 "entercenter \[expr (%x-$Ox)\] \[expr (%y-$Oy)\] 1"
 # make the keys work there too.
 bind_keys_canvas $c
}
# when really = 0 , all that happens is the vector wanders around
proc entercenter { i j really } {
# puts "entered $i $j" ;
 global vsign
 move_ed [expr $i*0.25] [expr ($vsign)*($j)*0.25] $really
}
#######################################################################
#
# procedures for packing
#
#######################################################################
proc controls { w status } {
 switch $status {
	hide {
	 catch { pack forget $w.cbuttons }
	 catch { pack forget $w.head }
	 catch { pack forget $w.l }	 
	 catch { pack forget $w.l2 }
	 $w.hidecontrols configure -state disabled 
	 $w.showcontrols configure -state normal
	 bind . <control-s> "$w.showcontrols invoke"
	}
	show {
	 pack $w.head -before $w.canvases -side top -expand 1 -fill x
	 pack $w.cbuttons -side bottom -fill x -pady 2 -expand 1
	 pack $w.l -side top -fill both -expand 1 -padx 4 -pady 4
	 pack $w.l2 -side top -fill both -expand 1 -padx 4 -pady 2
	 $w.showcontrols configure -state disabled 
	 $w.hidecontrols configure -state normal
	 bind . <control-s> "$w.hidecontrols invoke"
	}
 }
}
proc pair_of_canvases { w } {
 global canvaslist c1 c2 nickname W H Displaystyle
 set canvaslist "$w.c1 $w.c2"
 set c1 $w.c1 ; set c2 $w.c2
 set nickname($c1) c1
 set nickname($c2) c2
 set W 375 ; set H 350
 # only when W and H are fixed can the origin and things be set up:
 setupdisplaystyle $Displaystyle
 foreach c [concat $canvaslist] {
	standard_canvas $w $c
 }
}
proc reduce_to_single_canvas { w } {
 global canvaslist c1 c2 nickname W H Displaystyle
 pack forget $c2 
 pack forget $c1
 destroy $c2
 destroy $c1 
 right_controls $w forget
 single_canvas $w 
 cleancanvases ;# puts the mother node
 .ac.lreset invoke ;# UGLY global variable sorry
}
proc single_canvas { w } {
 global canvaslist c1 nickname W H Displaystyle
 set canvaslist "$w.c1"
 set c1 $w.c1 
 set nickname($c1) c1
 set W 750 ; set H 500
 # only when W and H are fixed can the origin and things be set up:
 setupdisplaystyle $Displaystyle
 foreach c [concat $canvaslist] {
	standard_canvas $w $c
 }
 $w.aat_mouse invoke
 $w.english2 invoke
 controls $w hide
}
proc standard_canvas { w c } {
 global W H RHS Nx Ny Ox Oy gwidth HAIRS mbigramic
 canvas $c -relief sunken -borderwidth 2 -width $W -height $H -background gray90
 pack $c -in $w.canvases -expand yes -fill both -side left -padx 5
 bind $c <control-c> "destroy ."
 set mbigramic($c) 0
# two ways to bind motion in the canvas. 
# 1: snap, allows huge motions in the case of bounded.
# 2: behaves more linearly.
#
# both these have problems. 1 is OK with bounded, but can feel slow
# 2 is greatly preferable for not needing cmfx to be set right.
# and 2 feels OK with bounded. But with uniform, it can happpen that you 
# plonk themouse on a desired character and it drifts off the screen
# all the same because of the magnification. There is a slight tendency to this
# in bounded too. maybe need to modify the 'factor' handling
#
# 1
# bind $c <control-motion> 	 "snap_to %x %y 0.5 1"
# 2
# bind $c <control-shift-motion> \
#	 "entercenter \[expr (%x-$Ox)*3*$cmfx\] \[expr (%y-$Oy)*3*$cmfy\] 1"
 bind $c <control-motion> 	 "snap_to %x %y 0.15 1"
 bind $c <control-shift-motion> "snap_to %x %y 0.35 1"
 bind $c <shift-motion> 	 "snap_to %x %y 0.6 1"
 # cross hairs - items 1,2,..
 $c create line $RHS 0 $RHS $H -tags "hairs" -fill gray -width 1
# this width is to attempt to prevent over-expansion at the edge of the world
# but it doesn't help, because entering text is just as bad as entering 
# the thing itself.
 $c create line $Ox 0 $Ox $H -tags "hairs" -fill gray
 $c create line 0 $Oy $W $Oy -tags "hairs" -fill gray
 $c create line $Ox $Oy [expr $Ox+$gwidth] $Oy -tags "vector hairs" -arrow last -fill red
# find_currents routine uses HAIRS (largest item
 # number that could be overlapping origin)
 set HAIRS($c) [$c create line [expr $Nx-10] $Ny [expr $Nx+10] $Ny -tags "hairs" -fill gold] 
 set HAIRS($c) [$c create line $Nx [expr $Ny-10] $Nx [expr $Ny+10] -tags "hairs" -fill gold] 
 bind $c <1> "mouse1 %x %y"
 $c bind node <alt-enter> "enterNode $c"
 $c bind node <any-leave> "itemLeave $c"
}
# generic controls for each canvas (i.e. unrelated to the model)
#
# canvas 1
proc red_canvas_controls { w c1 } {
 global Active
 set Active($c1) 1
 checkbutton $w.active1 -text Active -variable Active($c1) \
	 -command "if $Active($c1) {propagate_mc 1}" -background pink1
 bind . "<control-i>" "$w.active1 invoke"
 button $w.broo1l -text "Pushiness" -borderwidth 1 -background pink1 -padx 1 -pady 1
 button $w.ps1 -text "ps" -command "postscript $c1" -borderwidth 1 -background pink1 -padx 1 -pady 1
 entry $w.broo1 -textvariable Broodiness($c1) -width 1 -borderwidth 1 -background pink1 
 bind $w.broo1l <1> "incr Broodiness($c1)"
 bind $w.broo1l <2> "incr Broodiness($c1) -1"
 bind $w.broo1l <3> "incr Broodiness($c1) -1"
 bind . "<control-p>" "$w.ps1 invoke"
 pack $w.active1 $w.broo1l $w.broo1 $w.ps1 \
	 -in $w.clbuttons -side left -fill x -anchor w -padx 3 -pady 1
}
proc green_canvas_controls { w c2 } {
 global Active
 set Active($c2) 1
 checkbutton $w.active2 -text Active -variable Active($c2) \
	 -command "if $Active($c2) {propagate_mc 1}" -background palegreen1
 bind . "<control-i>" "$w.active2 invoke"
 button $w.broo2l -text "Pushiness" -borderwidth 1 -background palegreen1 -padx 1 -pady 1
 button $w.ps2 -text "ps" -command "postscript $c2" -borderwidth 1 -background palegreen1 -padx 1 -pady 1
 entry $w.broo2 -textvariable Broodiness($c2) -width 1 -borderwidth 1 -background palegreen1
 bind $w.broo2l <1> "incr Broodiness($c2)"
 bind $w.broo2l <2> "incr Broodiness($c2) -1"
 bind $w.broo2l <3> "incr Broodiness($c2) -1"
 bind . "<control-p>" "$w.ps2 invoke"
 pack $w.ps2 $w.broo2 $w.broo2l $w.active2 \
	 -in $w.crbuttons -side right -fill x -anchor w -padx 3 -pady 1
}
proc red_model_controls { w c1 } {
 button $w.alph1l -text "Alphabet" -borderwidth 1 -background pink1 -padx 1 -pady 1
 entry $w.alph1 -textvariable model($c1) -width 2 -borderwidth 1 -background pink1 
 bind $w.alph1l <1> {set newm [expr $model($c1)+1]; request_model $c1 $newm alpha 1}
 bind $w.alph1l <2> {set newm [expr $model($c1)-1]; request_model $c1 $newm alpha 1}
 bind $w.alph1l <3> {set newm [expr $model($c1)-1]; request_model $c1 $newm alpha 1}
 # note I find that frame can't have an arbitrary array argument.
 # any "." in the argument causes trouble 
 # hence the use of nicknames
 label $w.lsbl -text "bias:" -background pink1 
 frame $w.lbias(c1) -background red1 
 checkbutton $w.lsa -text "adaptive" -variable madaptive($c1) -background pink1
 global jack ; set jack 0
 checkbutton $w.jack -text "jack" -variable jack -background pink1
 button $w.english1 -text "english1" -command "english1 $c1" -background pink1 -padx 1 -pady 1 -borderwidth 1
 button $w.english2 -text "english2" -command "english2 $c1 \$jack" -background pink1 -padx 1 -pady 1 -borderwidth 1
 bind . "<control-a>" "$w.lsa invoke"
# $w.lsbl removed from list to give space
 pack $w.english1 $w.english2 $w.jack $w.alph1l $w.alph1 $w.lsa $w.lbias(c1) -in $w.l2l -side left -fill x -padx 3 -pady 1
}
proc green_model_controls { w c2 } {
 button $w.alph2l -text "Alphabet" -borderwidth 1 -background palegreen1 -padx 1 -pady 1
 entry $w.alph2 -textvariable model($c2) -width 2 -borderwidth 1 -background palegreen1
 bind $w.alph2l <1> {set newm [expr $model($c2)+1]; request_model $c2 $newm}
 bind $w.alph2l <2> {set newm [expr $model($c2)-1]; request_model $c2 $newm}
 bind $w.alph2l <3> {set newm [expr $model($c2)-1]; request_model $c2 $newm}
 label $w.lsbl2 -text "bias:" -background palegreen1
 frame $w.lbias(c2) -background green
 checkbutton $w.lsa2 -text "adaptive" -variable madaptive($c2) -background palegreen1
 bind . "<control-a>" "$w.lsa2 invoke"
 pack $w.lbias(c2) $w.lsa2 $w.alph2 $w.alph2l -in $w.l2r -side right -fill x -padx 3 -pady 1
}
proc left_controls { w status } {
 switch $status {
	pack {
	 pack $w.l2l -in $w.l2 -side left -expand 1 -anchor w
	 pack $w.clbuttons -in $w.cbuttons -before $w.cbothbuttons -side left -anchor w -expand 1 -padx 3
	 pack $w.currents1 -in $w.currents -padx 4 -side left -expand 1 -fill x -anchor nw
	} 
	forget {
	 pack forget $w.l2l
	 pack forget $w.clbuttons
	 pack forget $w.currents1
	}
 }
}
proc right_controls { w status } {
 switch $status {
	pack {
	 pack $w.l2r -in $w.l2 -side right -expand 1 -anchor e
	 pack $w.crbuttons -in $w.cbuttons -after $w.cbothbuttons -side right -anchor e -expand 1 -padx 3
	 pack $w.currents2 -in $w.currents -padx 4 -side left -expand 1 -fill x -anchor nw
	} 
	forget {
	 pack forget $w.l2r
	 pack forget $w.crbuttons
	 pack forget $w.currents2
	}
 } 
}
proc red_string { w c1 } {
 global stringfont
 label $w.currents1 -width 20 -wraplength 300 -justify left -text "" -textvariable currents($c1) -font $stringfont -background pink1 -anchor nw
}
set stringfont "Courier 13 bold"
proc green_string { w c2 } {
 global stringfont
 label $w.currents2 -width 20 -wraplength 300 -justify left -text "" -textvariable currents($c2) -font $stringfont -background palegreen1 -anchor nw
}
####################################################################
#
# set up windows 
# 
####################################################################
bind . <control-x> "destroy ."
bind . <control-q> "destroy ."
bind . <control-z> "destroy ."
set bordercol gray
global restoreCmd ; set restoreCmd "null"
frame $w.head
# Top row:
label $w.msg -wraplength 4i -justify left -text "Dasher"
frame $w.dstyle
frame $w.numcols
frame $w.maxsl
frame $w.sl
frame $w.at_point
# $w.msg removed here
pack $w.dstyle $w.at_point $w.numcols $w.maxsl $w.sl -in $w.head -side left -expand 1 -fill x -padx 10 
# top row
set numcols 28 ;# see makenode. max is 38.
label $w.numcolsl -text "Colors:"
entry $w.numcolsn -textvariable numcols -width 3 -borderwidth 1
pack $w.numcolsl $w.numcolsn -in $w.numcols -side left
# top row
global maxstringlength ; set maxstringlength 6
global truncated ; set truncated "'"
button $w.maxsll -text "Truncate:" -padx 0 -pady 0 -borderwidth 1
entry $w.maxsln -textvariable maxstringlength -width 2 -borderwidth 1
bind $w.maxsll <1> "incr maxstringlength"
bind $w.maxsll <2> "incr maxstringlength -1"
bind $w.maxsll <3> "incr maxstringlength -1"
pack $w.maxsll $w.maxsln -in $w.maxsl -side left
# top row
global slideatme ; set slideatme 6
global slidelength ; set slidelength -2
# top row
button $w.sll -text "Slide:" -padx 0 -pady 0 -borderwidth 1 -command {slideallnodes $slidelength}
button $w.sllup -text ">" -padx 0 -pady 0 -borderwidth 1 -command "incr slidelength"
button $w.slldn -text "<" -padx 0 -pady 0 -borderwidth 1 -command "incr slidelength -1" bind $w.sllup <3> "$w.slldn invoke"
bind $w.slldn <3> "$w.sllup invoke"
entry $w.sln -textvariable slidelength -width 3 -borderwidth 1
# top row
label $w.slal -text "At:" -padx 0 -pady 0 -borderwidth 1
button $w.slaup -text ">" -padx 0 -pady 0 -borderwidth 1 -command "incr slideatme"
button $w.sladn -text "<" -padx 0 -pady 0 -borderwidth 1 -command "incr slideatme -1" entry $w.slan -textvariable slideatme -width 2 -borderwidth 1 bind $w.slaup <3> "$w.sladn invoke"
bind $w.sladn <3> "$w.slaup invoke"
# top row
pack $w.slal $w.sladn $w.slaup $w.slan -in $w.sl -side left
pack $w.sll $w.slldn $w.sllup $w.sln -in $w.sl -side left
# top row
set attentionpoint at_cross
# where expansion should occur
foreach i {at_mouse at_cross} {
 radiobutton $w.a$i -text "$i" -variable attentionpoint \
	 -relief flat -value $i 
 pack $w.a$i -in $w.at_point -side left -pady 2 -anchor w
}
# attach commands to these:
$w.aat_mouse configure -command { mouse_logging on }
$w.aat_cross configure -command { mouse_logging off }
global Mousey Mousex
proc mouse_logging { state } {
 global Mousey
 switch $state {
	on {
	 bind . <motion> { set Mousey %y ; set Mousex %x } 
	}
	off {
	 # if I knew the name of the above binding, I could destroy it?
	}
 }
}
# top row
foreach i {uniform bounded} {
 radiobutton $w.d$i -text "$i" -variable Displaystyle \
	 -relief flat -value $i \
	 -command {setupdisplaystyle $Displaystyle; propagate_mc 0}
 pack $w.d$i -in $w.dstyle -side left -pady 2 -anchor w
}
bind . <control-u> "$w.duniform invoke"
bind . <control-b> "$w.dbounded invoke"
set Displaystyle bounded
# set Displaystyle uniform
# uniform is the original method, where unit increases in magnification 
# move us unit distances to the right.
# bounded is the style where all nodes terminate at the same RHS,
# and the left hand sides are located 
# This is referred to by two routines, snap_to and truenode
global variableStrings ; set variableStrings 1
##############################################################
# end top row
##############################################################
#
# define canvases
#
frame $w.canvases 
pack $w.canvases -expand yes -fill both
# 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.hidecontrols -text Hide -command "controls $w hide"
button $w.showcontrols -text Show -command "controls $w show"
button $w.single_canvas -text OneCanvas -command "reduce_to_single_canvas $w"
bind . <control-o> "$w.single_canvas invoke"
button $w.dump -text Dump -command "dump"
bind . <control-d> "$w.dump invoke"
button $w.help -text Help -command "help"
bind . <control-h> "$w.help invoke"
button $w.mousepad -text Mousepad -command "mousepad"
bind . <control-m> "$w.mousepad invoke"
pack $w.dismiss $w.hidecontrols $w.showcontrols $w.single_canvas $w.dump $w.mousepad $w.help \
	-in $w.buttons -side left -fill x -expand 1 -anchor w -padx 3 -pady 1
############
# end bottom row
############
# buttons to do with canvases
frame $w.cbuttons
##################################################################
# canvas specific stuff
##################################################################
global mbigramic ;# indicates whether a fixed bigram stats model is in use
set cmfx 0.11
set cmfy 0.4 
# canvas control motion factor (these have to be set to match
# epsilon and delta, and, if "uniform" mode, alpha and beta too. 
# (not in use)
#
# canvas control buttons
#
frame $w.cbothbuttons -background yellow ;# buttons pertaining to both canvases' control
frame $w.clbuttons -background red1 ;# buttons pertaining to left canvas's control
frame $w.crbuttons -background green ;# buttons pertaining to right canvas's control
######################################################
# useful buttons regardless of the number of canvases
######################################################
checkbutton $w.variablestrings -text VariableL -variable variableStrings -background lightgoldenrod1
bind . <control-v> "$w.variablestrings invoke" 
set DeleteDistantRelatives 1
checkbutton $w.ddr -text DelDisRel -variable DeleteDistantRelatives -background lightgoldenrod1
set ReinstateDistantRelatives 1
checkbutton $w.rdr -text Reinstate -variable ReinstateDistantRelatives -background lightgoldenrod1
button $w.clean -text Clean -command "cleancanvases" -background lightgoldenrod1 -padx 1 -pady 1
bind . <control-c> "$w.clean invoke"
pack $w.cbothbuttons -in $w.cbuttons -side left -expand 1 -padx 3
pack $w.clean $w.variablestrings $w.ddr $w.rdr \
 	-in $w.cbothbuttons -side left -padx 2
###########################################################
# things to do with the current view
############################################################
frame $w.l -background yellow
#
# controls affecting both canvases, and displays of magnification and centre
#
button $w.lreset -text "Reset" -command {default_mc; propagate_mc 0} -background lightgoldenrod1
bind . <control-r> "$w.lreset invoke"
entry $w.lm -textvariable magnification -width 4 -borderwidth 1 -background lightgoldenrod1
label $w.lml -text "magnifn:" -background lightgoldenrod1
label $w.lw -textvariable expm -width 16 -justify left -background lightgoldenrod1
label $w.lwl -text "width:" -background lightgoldenrod1
entry $w.lc -textvariable centre -width 8 -borderwidth 1 -justify left -background lightgoldenrod1
label $w.lcl -text "centre:" -background lightgoldenrod1
pack $w.lreset $w.lml $w.lm $w.lm $w.lwl $w.lw $w.lcl $w.lc \
	 -in $w.l -side left -fill x -padx 2 -pady 3
#
label $w.lt -textvariable Top -width 16 -justify left -background lightgoldenrod1
label $w.lb -textvariable Bot -width 16 -justify left -background lightgoldenrod1
pack $w.lt $w.lb -in $w.l -side right -fill x
bind $w.lm <enter> "focus $w.lm"
bind $w.lc <enter> "focus $w.lc"
bind $w.lm <leave> "focus $w"
bind $w.lc <leave> "focus $w"
bind $w.lm <return> "propagate_mc 1"
bind $w.lc <return> "propagate_mc 1"
#bind $w.lm <shift-return> "propagate_mc 1; focus $w"
#bind $w.lc <shift-return> "propagate_mc 1; focus $w"
#
# things to do with the probabilistic model being used in each canvas
#
frame $w.l2
frame $w.l2l -background red
frame $w.l2r -background green
########################################
# the strings
########################################
frame $w.currents
#	 catch { pack forget $w.currents }
pack $w.currents -side bottom -fill both -expand 1 -padx 4 -pady 2
#
# OK, from here on we make some arbitrary choices about
# how to initialize things.
# standard m,c values
default_mc
setexpm
# let's show all the buttons
controls $w show
# start with two canvases
pair_of_canvases $w ;# defines $c1,$c2,H,W
# these define the controls but do not pack them
red_string $w $c1
green_string $w $c2
red_model_controls $w $c1
green_model_controls $w $c2
red_canvas_controls $w $c1
green_canvas_controls $w $c2
left_controls $w pack
right_controls $w pack
# define_model $c1 binary alpha "1 3" nonadaptive 1
define_model $c1 ternary alpha "1 1 0.3" nonadaptive 1
define_model $c2 binary num "1 1" nonadaptive 1
####################################################################
cleancanvases ;# puts the mother nodes
bind_keys_canvas . 
# I wanted this to be bind $c rather than .
#####################################################################
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 \
{Dasher - author David J C MacKay mackay@mrao.cam.ac.uk
 - conceptual authors MacKay & Lewicki 1997
 This tool has two roles:
 (1) Arithmetic coding demonstration.
 (2) Data entry device (conceptual demonstration).
 The unit interval and its subdivisions are represented on a 
 two dimensional plane with the interval itself vertically and the 
 size of a subdivision indicated additionally by horizontal placement,
 so that small intervals are put to the right. 
 At any moment, the canvas displays a view of a subinterval 
 of the unit interval, defined by its centre and its magnification
 or width. (Magnification is -log(width).)
 Data entry is achieved simply by contracting this interval. This
 contraction only requires two degrees of freedom, one of which 
 represents rate of contraction, and one, the direction of movement 
 of the centre of the interval. Of these, only the latter needs 
 a real number to control it. For the former, it is satisfactory
 to have a discretized control.
 The current (centre,magnification) value can be changed in several
 ways.
 (a) a mousepad window can be requested. As the mouse is moved
 around this pad, small changes in (c,m) are made.
 (Hold down shift key or control key to enable this.)
 As soon as you stop moving the mouse, the (c,m) stop
 changing. This is not ideal, but it will do for a start. 
 (This option is now considered to be obsolete.)
 (a2) the canvases also work as mousepads; here, hold down the control
 both control and shift for turbo speed; shift alone for absurdly fast
 (b) a keyboard version of the mousepad can also be used
 when the focus is in the canvas's window: Because it is 
 most useful to have a lot of vertical dynamic range,
 the keyboard has to be rotated clockwise 90 degrees for it to 
 match the mouse pad orientation.
 The keys 1,2,...0 correspond to the right side (fastest expansion
 of magnification), and the keys z,x,...,/
 correspond to the null line on which only vertical movements
 of the centre take place. The other axis is b-g-t-5.
 To expand a little, press g; more, t;
 for a step of maximum expansion, press 5.
 b causes no step at all, but is useful because it causes 
 the canvases to be redisplayed.
 The space key achieves retraction, i.e. reduction in magnification.
 (c) a click of the mouse at any point in the canvas immediately 
 snaps that point to the origin, which is a point 
 somewhat to the left of the centre of the canvas.
 (d) you can edit the entries for m and c at the foot of the canvas.
 Hit return to propagate the changes.
 Automatic child creation:
 A node's children (and grandchildren, out to a number of generations
 given by the parameter Broodiness) are created whenever:
 1 - the alt-mouse enters the node.
 if "at_cross" is on
 2 - that node is the youngest node overlapping the golden cross
 'attention point' after a move of the canvas.
 if "at_mouse" is on
 3 - that node is the youngest node overlapping the point 
 whose x coord is that of the golden cross
 and whose y coord is that of the mouse.
 This is obviously only useful if you are using the mouse
 to drive things along on one of the canvases. (a2 above).
 This is my favourite driving style: at_mouse, and use the 
 mouse on the canvas.
 General layout:
 Red = left canvas. Green = right canvas. Yellow = both canvases.
 The top yellow display shows the state of the view of both canvases.
 The top row of red/green buttons control the probabilistic models.
 The bottom row of red/green buttons control other aspects of each canvas.
 active = whether new nodes are created
 pushiness = how many generations are created below the
 node currently at the attention point.
 It may be useful to increase the value of this on the 
 binary encoding canvas, if the other canvas has a large
 alphabet and is being magnified rapidly.
 A pushiness of 0 is similar to setting 'active' to zero.
 ps causes the canvas to be written to file as postscript.
 'Truncate' controls the maximum length of a displayed string.
 'Colors' controls the number of colors used when randomly painting
 the squares.
 Shortcuts: 
 C-r reset
 C-c clean both canvases
 C-d dump (i.e., put the two canvases' strings to stdout)
 C-h help (this window)
 C-m mousepad
 C-z,q,x exit
 C-a adaptive 1
 C-A adaptive 2
 C-p postscript 1
 C-P postscript 2
 C-i (in)active
 C-u switch to uniform display (log scale x axis)
 C-b switch to bounded display (linear)
 C-s toggle between hide and show control panels
 C-o one canvas
 C-v variable-length strings (shorter when small) 
 Choice of alphabet and probabilistic model. Small alphabets with characters a,b,c..
 and 0,1,2... are available. You can choose between a monogram model with 
 fixed marginal probabilities, or adaptive probabilities (using a standard Dirichlet
 model, also known as Laplace's rule). You can also choose between english1
 which is a monogram model for english (with entropy 4.2 bits per character)
 and english2, which is a bigram model, mean entropy 3.5 bits per character.
 [~/bin/sayHb.p ~/itp/bigrams/mon-bi]
 The button OneCanvas makes a single big canvas with english2 installed. 
 DelDisRel, Reinstate: this means 'delete distant relatives'. If both are
 1 it should speed things up but otherwise
 have no effect at all on the behaviour of the tool. It simply means
 that things not currently on the canvas are not considered. But
 as soon as they get on again, they are reinstated, tags and all.
 If reinstating is switched off a further slight speed improvement
 may be gained. But nodes that leave the canvas are then gone for ever.
 Sliding: The implementation of arithmetic is extremely simple and dumb.
 It uses real numbers to represent the top and bottom of each interval
 in terms of raw cumulative probabilities, numbers between 0 and 1. 
 As the view moves to greater magnifications, we simply scale and 
 move the boxes appropriately. However, all good things come to an end,
 and when you have magnified by about exp(27), the arithmetic doesn't
 work any more. The simple procedure implemented here (which is not 
 necessarily exact, but it allows encoding to continue) is called
 sliding. During a slide (which occurs whenever the magnification hits
 a threshold called slideatme (displayed by the word 'At')),
 all the boxes' vertices are redefined
 and the magnification is also adjusted, in such a way that the view 
 is unchanged, except for the irreversible loss of excessively magnified 
 boxes. Slides can be forced to occur by hitting the slide button,
 but this is not something you should need to do. The amount by which 
 things slide is adjustable; that's given by the number next to the word 
 slide.
 NB: if you have a lot of nodes in your canvases then the scrolling
 may become very slow.
 Beware: if you drag the alt-mouse to the right hand side when you are in 
 the bounded world, you risk creating a very large number of nodes 
 very suddenly!
 Bugs: typing into the editable entries still sends commands to the 
 keyboard bindings.
}
}
</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/dasher.tcl">(-&gt;オリジナル)</a>
/ <label>アドレス: <input type="text" name="naked_post_url" value="http://www.inference.org.uk/mackay/itprnn/code/tcl/dasher.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>