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

# Huffman 3 was a specific a-z,A-Z,0-9 encoder/decoder.
# Huffman 4 is intended to be able to implement any of the codes 
#        made thus far
# to add new codes search for the string abcx and imitate what you see

set verbose 0
frame .text -background white -width 6i -height 5i
pack .text -fill both
set  w .text
frame $w.but
pack $w.but -side top -fill x -expand 1
button $w.dismiss -text Quit -command "destroy ."
button $w.help -text Help -command "help"
button $w.dump -text Dump -command "dumpcode"
pack $w.dismiss $w.help $w.dump -in $w.but -side left -fill x -expand 1 -anchor w

button .dismiss2 -text Quit -command "destroy ." 
pack .dismiss2 -side bottom -anchor w  -fill x -expand 1

set w .text
global EDstatus_old ; set EDstatus_old 0 
set EDstatus encoding
# label $w.msg -wraplength 4i -justify left -textvariable EDstatus
# pack $w.msg -side top 
frame $w.i ; frame $w.q ; frame $w.o ; frame $w.p
set wi $w.i ; set wq $w.q ; set wo $w.o ; set wp $w.p
set font "Courier 13 bold"
set back "gray90"
label $wi.input -wraplength 5.5i -justify left -text "" -textvariable input -font $font  -background $back
label $wp.input -wraplength 5.5i -justify left -text "" -textvariable parsed -font $font  -background $back
set parsed "("
label $wq.queue -wraplength 5.5i -justify left -text "" -textvariable queue -font $font  -background $back
label $wo.output -wraplength 5.5i -justify left -text "" -textvariable output -font $font  -background $back
label $wi.t -text "Input: " -width 9 -justify right
label $wp.t -text "Parsed: " -width 9 -justify right
label $wo.t -text "Output: " -width 9 -justify right
label $wq.t -text "Queue: " -width 9 -justify right
# length in characters
label $wi.l -text "" -width 5 -textvariable inputlength
label $wo.l -text "" -width 5 -textvariable outputlength
# lengths in bits:
label $wi.lb -text "" -width 5 -textvariable inputlengthb
label $wo.lb -text "" -width 5 -textvariable outputlengthb
label $wo.labels -text "bits / chars:"
label $wi.labels -text "bits / chars:"

frame $w.status
foreach i {encoding decoding} {
    radiobutton $w.status.b$i -text "$i" -variable EDstatus \
            -relief flat -value $i -command "EDswitch $i"
    pack  $w.status.b$i  -side left -pady 2 -anchor w
}
pack $w.status $w.i $w.q $w.p $w.o -side top -fill x

pack $wi.t $wi.input -side left -anchor n
pack $wq.t $wq.queue -side left -anchor n 
pack $wp.t $wp.input -side left  -anchor n
pack $wo.t $wo.output -side left -anchor n
pack $wo.l $wo.labels $wo.lb -side right
pack $wi.l $wi.labels $wi.lb -side right

####################################################
# keyboard data entry and status switching
####################################################
set bindplace .
bind $bindplace <Control-e> "EDswitch encoding"
bind $bindplace <Control-d> "EDswitch decoding"
bind $bindplace <Control-i> "copyover input"
bind $bindplace <Control-o> "copyover output"
bind $bindplace <Control-p> "copyover parsed"

set codelist {azAZ abcx}
foreach i [concat $codelist] {
    radiobutton $w.c$i -text "$i" -variable currentcode \
	    -relief flat -value $i -command "codeswitch $i"
    pack $w.c$i -in $w.status -side right -pady 2 -anchor w
}
proc startcodepack { } {
    global command masternumber h
    frame  $h.m$masternumber
    pack  $h.m$masternumber -side left -fill y -expand 1
    set command "pack "
}
proc finishcodepack { } {
    global command masternumber h
    append command " -in $h.m$masternumber \
	    -side top -anchor n"
    eval $command
    incr masternumber
}
proc codeswitch { i } {
    global valid_encode_chars valid_decode_chars back
    global bindplace M B verbose h masternumber command
    switch $i {
	azAZ {
	    puts "setting up code $i"
	    set valid_encode_chars "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 _ 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 1 2 3 4 5 6 7 8 9 0"
	    set valid_decode_chars "0 1" 

	    set hc "a 0000
b 001000
c 10000
d 10010
e 101
f 001010
g 001011
h 11000
i 0001
j 01000000000
k 01000100
l 00110
m 10001
n 1110
o 1101
p 10011
q 010001010
r 01001
s 1111
t 0101
u 00111
v 1100100
w 0100001
x 1100110
y 001001
z 1100101000
_ 011
A 1100111000
B 11001111000
C 01000101100
D 11001111001
E 110011110100
F 0100000100
G 01000000001000
H 11001010010
I 010001100
J 110011110101
K 11001111011
L 110011111
M 01000101101
N 010000000011
O 01000110100
P 01000101110
Q 01000000001001
R 01000000001010
S 01000110101
T 01000111
U 1100101001100
V 01000000001011
W 01000101111
X 010000001
Y 1100111010
Z 1100101001101
1 11001011
2 010000011
3 0100000001
4 0100000101
5 1100111001
6 110010100111
7 11001110110
8 11001110111
9 0100011011
0 110010101"
# the above huffman code was created by 
# frequency.p ~/tex/please.tex
# GQRVZU6EJ7NHBDK8jOSCMPWzA5YF4390L2XIq1Tkvxwybfgcmpdhulrsnoiate_
# was the order of letters.
set M 63
set B 2
	}
	abcx {
	    puts "setting up code $i"
	    set valid_encode_chars "a b c x"
	    set valid_decode_chars "0 1" 
set hc "a 0
b 10
c 110
x 111"
set M 4
set B 2

	}
    }   
	    # use concat, not list

    foreach i [concat $valid_encode_chars $valid_decode_chars] {
	bind $bindplace $i "selected $i"
	if { $verbose >=2 } { puts $i }
    }
    bind $bindplace <space> "selected _"
    bind $bindplace . "selected _"
    bind $bindplace : "selected _"
    bind $bindplace , "selected _"
    bind $bindplace ? "selected _"
    bind $bindplace / "selected _"
    bind $bindplace - "selected _"
    bind $bindplace + "selected _"
    bind $bindplace \; "selected _"
    bind $bindplace \) "selected _"
    bind $bindplace \( "selected _"

#########################
# define Huffman code
#########################

    set h .hc
    catch {destroy $h}
    toplevel $h 
    wm title $h "Symbol code"
#
    set font "Helvetica 14"
    set masternumber 0
    startcodepack
    set i -1
    for {set m 1} {$m <= $M} {incr m} {
	incr i
	set char [lindex $hc $i] ;# read the character
	incr i
	set code [lindex $hc $i] ;# read its code
	if { $verbose >= 1 } { puts "$char: $code" }
	
	set s [frame $h.s$char]  ;# make a frame for this char,code pair
	label $s.char -text "$char:" -width 3 -borderwidth 0
	global hc$char
	entry $s.code -width 15 -textvariable hc$char -borderwidth 1 -insertborderwidth 1 -font $font   -background $back
	set hc$char $code
	pack $s.char $s.code -side left
	append command " $h.s$char"
	if { ($M > 30) && [expr !($m%20)] } { finishcodepack ; startcodepack }
    }
    # finish off the pack
    #  bug: if m is a multiple of 20 then this will cause an invalid pack attempt
    finishcodepack
}

codeswitch azAZ
set command "pack "
foreach i {megatext} { 
    frame $w.$i
    set s $w.$i
    text $s.text -width 90 -height 10 -yscrollcommand "$s.scroll set" -wrap char -background white -insertofftime 0
    scrollbar $s.scroll -command "$s.text yview"
    pack $s.scroll -side right -fill y
    pack $s.text -side left
    append command " \$w.$i"
}
set megatext $s.text

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

proc lengths { } {
    global input output inputlength outputlength 
    global inputlengthb outputlengthb M B EDstatus
    set inputlength [string length $input]
    set outputlength [string length $output]
# lengths in bits
    if { $EDstatus == "encoding" } {
	set MI $M ; set MO $B 
    } else {
	set MI $B ; set MO $M
    }
    set inputlengthb [expr (int( $inputlength * log($MI)/log(2.0)))]
    set outputlengthb [expr (int( $outputlength * log($MO)/log(2.0)))]
}

proc selected { i } {
    global EDstatus verbose
    if { $verbose >= 1 } {puts "$i"  }
    if { $EDstatus == "encoding" } { 
	global valid_encode_chars ; set valids $valid_encode_chars 
    }    elseif { $EDstatus == "decoding" }  { 
	global valid_decode_chars ; set valids $valid_decode_chars 
    } else {
	# not encoding or decoding
    }
    #    puts [regexp [set $i] $valids]
    set valid [regexp $i $valids]
    if { $valid } {
#	puts "allowed: $i"
	global input output parsed 
	append input $i
	if { $EDstatus == "encoding" } { 
	    global hc$i             ;# go and find the corresponding code
	    append output [set hc$i]
	    append parsed [set hc$i]
	    append parsed ")"
	    append parsed "("
	} elseif { $EDstatus == "decoding" }  { 
	    global valid_encode_chars queue
	    append queue $i
	    append parsed $i
	    # check all codewords to see if queue matches
	    foreach c [ concat $valid_encode_chars ] {
		global hc$c
		set match [ string compare $queue  [set hc$c] ]
		if { $match == 0 }  { # this is like match or string_eq
		    if { $verbose >= 2 } {
			puts "queue = $queue"
			puts "$c <-> [set hc$c]"
		    }
		    set queue "" 
		    append output $c
		    append parsed ")"
		    append parsed "("
		    # last foreach
		}
	    }
	}
	lengths

    } else {
	puts "illegal char when $EDstatus"
    }
}

proc EDswitch { i } {
    global EDstatus EDstatus_old
#    puts $EDstatus
    set EDstatus $i
    if { $EDstatus == $EDstatus_old } {
	puts "already $EDstatus" 
    } else {
# whatever needs doing when status changes.... (*)
    }
#
# the following clears the buffers.
#  one might prefer to put this in the above section (*)
# to prevent accidental killing of buffers
    global input output parsed queue
    set input "" ; set output "" ; set parsed "(" ; set queue "" ;
    set EDstatus_old $EDstatus
    puts $EDstatus
}

proc copyover { s } {
    global $s
    global megatext
    $megatext insert end "\n"
    $megatext insert end [set $s]
    
#    append $megatext [set $s]
}

proc dumpcode { } {
    global M valid_encode_chars
    foreach f [concat $valid_encode_chars] {
	global hc$f
	puts "$f [set hc$f]" ;
    }
}

proc help { } {
    set w .help
    catch {destroy $w}
    toplevel $w
frame $w.buttons
pack $w.buttons -side bottom -fill x -pady 2m -expand 1
button $w.buttons.dismiss -text Dismiss -command "destroy $w"
pack $w.buttons.dismiss  -side left -fill x -expand 1


    text $w.t -relief sunken -setgrid 1

    $w.t insert 0.0 \
	    {This symbol decoder demonstrates encoding 
and decoding using a prefix code. If the specified code is 
not a prefix code, then anything can happen. You are free to edit
the codewords defined in the symbol code window.
New Huffman codes can be created by the perl script frequency.p

Control-E, Control-D toggle between encoding and decoding

Control-I, Control-O and Control-P cause the current contents
of the input, output and 'parse' buffers to be written into the 
jotter pad.
    
The Dump button writes the current code to stdout.

Bugs: writing to the jotter may cause trouble}
  pack $w.t
}