#!/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
# Huffman 5 includes az_ which is also embodied in the dasher
# arithmetic coder.
# Huffman 6 is the version with ownwindow codes to allow use under netscape.
#
# to add new codes search for the string abcx and imitate what you see
#
# 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 6.0 
#
if {$verbose>=1} {
 puts "Huffman coding version $version David J C MacKay 1997"
 puts " written under tcl 8.0 on linux"
 puts " believed to require tcl 7.6 or greater"
 puts "Main shortcodes: C-e/d and C-i/o"
}
if {$ownwindow>=1} {
 wm geometry . +10+10
 wm title . "Symbol code"
 wm iconname . "symbol code"
}
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 {az_ 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 ownwindow verbose
 global bindplace M B verbose h masternumber command
 # az_ is from the linux FAQ.ascii
 # which are ordered thus jzqvxkwbgyfpmcdhulrsaniote_
 # azAZ is from please.tex
 switch $i {
	az_ {
	 if {$verbose>=1} {
		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 _"
	 set valid_decode_chars "0 1" 
	 set hc "a 0000
b 001000
c 00101
d 10000
e 1100
f 111000
g 001001
h 10001
i 1001
j 1101000000
k 1010000
l 11101
m 110101
n 0001
o 1011
p 111001
q 110100001
r 11011
s 0011
t 1111
u 10101
v 11010001
w 1101001
x 1010001
y 101001
z 1101000001
_ 01
"
set M 27
set B 2
# from frequency.p /usr/doc/FAQ/linux-faq.ascii
	}
	azAZ {
	 if {$verbose>=1} {
		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 {
	 if {$verbose>=1} {
		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}
 if {$ownwindow>=1} {
	toplevel $h
	wm title $h "Symbol code"
	wm geometry $h +200+300
 } else {
	frame $h
	pack $h
 }
#
 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>= 2 } { 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> 15 ) && [expr !($m%12)] } { 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
codeswitch abcx
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
# bring up the code window
 raise $h
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>= 2 } {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 {
	if {$verbose>=1} {
	 puts "illegal char when $EDstatus"
	}
 }
}
proc EDswitch { i } {
 global EDstatus EDstatus_old verbose
# puts $EDstatus
 set EDstatus $i
 if { $EDstatus == $EDstatus_old } {
	if {$verbose>=1} {
	 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
 if {$verbose>=1} {
	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 verbose
 foreach f [concat $valid_encode_chars] {
	global hc$f
	if {$verbose>=1} {
	 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.
Built-in models: abcx is a toy example
 az_ is a monogram model derived from the linux FAQ.ascii
 azAZ is a monogram model from a latex document of mine
Bugs: writing to the jotter may cause trouble}
 pack $w.t
}
</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/huffman.tcl">(-&gt;オリジナル)</a>
/ <label>アドレス: <input type="text" name="naked_post_url" value="http://www.inference.org.uk/mackay/itprnn/code/tcl/huffman.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>