#!/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)||(-$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))||(($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)||$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)||$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)||($n_a($n)<0.0)||($n_b($n)>1.0)||($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.
}
}