pctb/dictionary-manager

   1 #!/usr/bin/wish
   2
   3 # helper program for OCR in PCTB upload client
   4
   5 # This is part of ypp-sc-tools, a set of third-party tools for assisting
   6 # players of Yohoho Puzzle Pirates.
   7 #
   8 # Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
   9 #
  10 # This program is free software: you can redistribute it and/or modify
  11 # it under the terms of the GNU General Public License as published by
  12 # the Free Software Foundation, either version 3 of the License, or
  13 # (at your option) any later version.
  14 #
  15 # This program is distributed in the hope that it will be useful,
  16 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 # GNU General Public License for more details.
  19 #
  20 # You should have received a copy of the GNU General Public License
  21 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  22 #
  23 # Yohoho and Puzzle Pirates are probably trademarks of Three Rings and
  24 # are used without permission.  This program is not endorsed or
  25 # sponsored by Three Rings.
  26
  27
  28 # ./dictionary-manager --approve-updates ijackson@login.chiark.greenend.org.uk /home/ijackson/things/ypp-sc-tools.pctb-dict/pctb /home/ftp/users/ijackson/pctb
  29
  30 # ./dictionary-manager --approve-updates ijackson@login.chiark.greenend.org.uk /home/ijackson/things/ypp-sc-tools.pctb-dict-test/pctb /home/ftp/users/ijackson/pctb/test
  31
  32 # ./dictionary-manager --approve-updates '' . .
  33
  34
  35 # invocation:
  36 # OUT OF DATE
  37 #  run this without args
  38 #  then on stdin write
  39 #     one line which is a Tcl list for unk_{l,r} unk_contexts glyphsdone etc.
  40 #     the xpm in the format expected
  41 #  then expect child to exit 0, or write a single 0 byte to fd 4
  42 #  if it wrote a byte to fd 4, it can take another question
  43
  44
  45 set aadepth 2
  46
  47
  48 #---------- library routines ----------
  49
  50 proc manyset {list args} {
  51     foreach val $list var $args {
  52         upvar 1 $var my
  53         set my $val
  54     }
  55 }
  56
  57 proc must_gets {f lvar} {
  58     upvar 1 $lvar l
  59     if {[gets $f l] < 0} { error "huh?" }
  60 }
  61
  62 proc must_gets_imagel {f lvar} {
  63     global debug_rect
  64     upvar 1 $lvar l
  65     must_gets $f l
  66     if {$debug_rect} { debug "<< $l" }
  67 }
  68
  69 proc must_gets_exactly {f expected} {
  70     must_gets $f got
  71     if {[string compare $expected $got]} { error "$expected $got ?" }
  72 }
  73
  74 proc read_counted {f var} {
  75     upvar 1 $var val
  76     must_gets $f count
  77     set val [read $f $count]
  78     must_gets $f eol
  79     if {[string length $eol]} { error "$eol ?" }
  80     debug "READ_COUNTED $count $var"
  81 }
  82
  83 proc puts_counted {f dvar} {
  84     upvar 1 $dvar d
  85     set count [string length $d]
  86     puts $f $count
  87     puts $f $d
  88     debug "PUTS_COUNTED $count $dvar"
  89 }
  90
  91 proc bgerror {m} {
  92     global errorCode errorInfo
  93     puts stderr "ERROR: $m\n[list $errorCode]\n$errorInfo\n";
  94     exit 16
  95 }
  96
  97 #---------- display core ----------
  98
  99 set mul 6
 100 set inter 1
 101
 102 set gotsh 20
 103 set csrh 20
 104 set ctxh 20
 105
 106 proc init_widgets {} {
 107     # idempotent
 108     global csrh gotsh ctxh
 109
 110     if {[winfo exists .d]} return
 111
 112     frame .privacy -bd 2 -relief groove
 113     pack .privacy -side top -padx 2 -pady 2 -fill x
 114
 115     upload_init
 116
 117     frame .d -pady 2 -padx 2 -bg black -bd 2 -relief sunken
 118
 119     image create bitmap image/main
 120     label .d.mi -image image/main -bd 0
 121
 122     frame .d.csr -bg black -height $csrh
 123     frame .d.got -bg black -height $gotsh
 124     frame .d.ctx -bg black
 125
 126     image create bitmap image/cursor -foreground white -background black \
 127         -data \
 128 {#define csr_width 11
 129 #define csr_height 11
 130 static unsigned char csr_bits[] = {
 131    0x20, 0x00, 0x20, 0x00, 0x20, 0x00, 0x21, 0x04, 0x22, 0x02, 0x25, 0x05,
 132    0xaa, 0x02, 0x74, 0x01, 0xa8, 0x00, 0x70, 0x00, 0x20, 0x00};
 133 }
 134
 135     frame .d.csr.csr
 136     label .d.csr.csr.l -image image/cursor -compound left -fg white -bg black
 137     entry .d.csr.csr.e -bd 0
 138     pack .d.csr.csr.l -side left
 139
 140     frame .selctx -bd 2 -relief groove
 141     frame .d.mi.csr_0 -bg white -width 1
 142     frame .d.mi.csr_1 -bg white -width 1
 143     frame .pe
 144     frame .pe.grid
 145
 146     button .pe.ok -text OK
 147     pack .pe.grid .pe.ok -side left
 148     bind .pe.ok <Key-Return> { .pe.ok invoke }
 149
 150     pack .d.mi .d.ctx -side top -anchor w
 151     pack .d -fill x -padx 2 -pady 2
 152
 153     frame .help -bd 2 -relief groove
 154     pack .help -pady 2 -padx 2
 155 }
 156
 157 proc resize_widgets_core {} {
 158     global mulcols mulrows csrh gotsh ctxh
 159     global unk_l unk_contexts
 160
 161     foreach w {.d.csr .d.got .d.ctx} {
 162         $w configure -width $mulcols
 163     }
 164     .d.csr configure -width [expr {$mulcols+150}]
 165
 166     eval destroy [winfo children .d.ctx]
 167 }
 168
 169 set last_ht {}
 170
 171 proc helptext {t} {
 172     global last_ht
 173     if {![string compare $t $last_ht]} return
 174     eval destroy [grid slaves .help]
 175     set y 0; foreach l $t {
 176         set x 0; foreach c $l {
 177             set w .help.at${x}x${y}
 178             label $w -text $c
 179             grid $w -row $y -column $x -padx 5 -sticky w
 180             incr x
 181         }
 182         incr y
 183     }
 184     set last_ht $t
 185 }
 186
 187 proc bind_key {k proc} {
 188     global keybindings
 189     bind .d <Key-$k> $proc
 190     set keybindings($k) [expr {!![string length $proc]}]
 191     .d configure -takefocus 1
 192 }
 193 proc unbind_all_keys {} {
 194     global keybindings
 195     foreach k [array names keybindings] { bind_key $k {} }
 196     .d configure -takefocus 0
 197 }
 198
 199 #---------- database read and write common wrapper ----------
 200
 201 proc db_getsl {f} {
 202     if {[gets $f l] < 0} { error "unexpected db eof" }
 203     return $l
 204 }
 205
 206 proc read_database {fn} {
 207     global reqkind database database_fn
 208     upvar #0 database_magic/$reqkind magic
 209     catch { unset database }
 210
 211     set database_fn $fn
 212     if {![file exists $database_fn]} return
 213     set f [open $database_fn r]
 214     if {[string compare [db_getsl $f] $magic]} { error "$magic $reqkind ?" }
 215
 216     read_database_header/$reqkind $f
 217     while 1 {
 218         set l1 [db_getsl $f]
 219
 220         if {![string length $l1]} continue
 221         if {[regexp {^\#} $l1]} continue
 222         if {![string compare . $l1]} break
 223
 224         read_database_entry/$reqkind $f $l1
 225     }
 226     close $f
 227 }
 228
 229 proc write_database {} {
 230     global reqkind database_fn database
 231     upvar #0 database_magic/$reqkind magic
 232
 233     set f [open $database_fn.tmp w]
 234     puts $f $magic
 235
 236     write_database_header/$reqkind $f
 237
 238     set ol {}
 239     foreach bm [array names database] {
 240         lappend ol [format_database_entry/$reqkind $bm $database($bm)]
 241     }
 242     foreach o [lsort $ol] {
 243         puts $f $o
 244     }
 245     puts $f "."
 246     close $f
 247     file rename -force $database_fn.tmp $database_fn
 248 }
 249
 250 proc select_database {dbname_spec} {
 251     global dbname
 252     set dbname $dbname_spec
 253     read_database "./#local-$dbname#.txt"
 254 }
 255
 256 proc do_database_update {im def} {
 257     global database
 258     maybe_upload_entry $im $def
 259     set database($im) $def
 260     write_database
 261 }
 262
 263 proc required/char {} {
 264     global mulrows glyphsdone unk_l unk_r unk_contexts rows new_context
 265     global all_contexts debug_rect
 266
 267     must_gets stdin l
 268     debug "GOT $l"
 269
 270     manyset [lrange $l 0 3] unk_l unk_r unk_contexts
 271     set glyphsdone [lrange $l 3 end]
 272
 273     char_read_pgm stdin
 274
 275     catch { unset all_contexts }
 276
 277     resize_widgets_core
 278     foreach w {0 1} {
 279         .d.mi.csr_$w configure -height $mulrows
 280     }
 281     set maxh 0
 282     foreach {min max context contexts got} $glyphsdone {
 283         show_context maxh $min $context
 284         foreach ctx $contexts { set all_contexts($ctx) 1 }
 285     }
 286     foreach ctx $unk_contexts { set all_contexts($ctx) 1 }
 287
 288     eval destroy [winfo children .selctx]
 289     label .selctx.title -text \
 290         {Select match context for altering dictionary:}
 291     pack .selctx.title -side left
 292     set new_context {}
 293
 294     set ci 0; foreach ctx [lsort [array names all_contexts]] {
 295         set all_contexts($ctx) $ci
 296         set selw .selctx.c$ci
 297         set seltxt $ctx
 298         radiobutton $selw -variable new_context -value $ctx -text $seltxt
 299         pack $selw -side left
 300         incr ci
 301     }
 302     $selw configure -text "$seltxt."
 303     label .selctx.warning -text {See README.charset.}
 304     pack .selctx.warning -side left
 305
 306     show_context maxh $unk_l $unk_contexts
 307     .d.ctx configure -height $maxh
 308     pack forget .pe
 309     pack .selctx -before .d -padx 2 -fill x
 310     pack .d.csr -side top -before .d.mi -anchor w
 311     pack .d.got .d.ctx -side top -after .d.mi -anchor w
 312     pack configure .selctx -fill x
 313     focus .d
 314
 315     select_database char$rows
 316     draw_glyphsdone
 317     startup_cursor
 318 }
 319
 320 proc approve_showentry_xinfo/char {w def} {
 321     set unic [string2unicodenames $def]
 322     label $w -text $unic
 323 }
 324
 325 #========== PIXMAPS ==========
 326
 327 #---------- pixmap database read and write ----------
 328
 329 set database_magic/pixmap {# ypp-sc-tools pctb pixmaps v1}
 330
 331 proc read_database_header/pixmap {f} { }
 332 proc read_database_entry/pixmap {f def} {
 333     global database
 334
 335     set im ""
 336
 337     set p3 [db_getsl $f];       append im $p3    "\n"
 338     if {[string compare $p3 P3]} { error "$p3 ?" }
 339
 340     set wh [db_getsl $f];       append im $wh    "\n";   manyset $wh w h
 341     set depth [db_getsl $f];    append im $depth "\n"
 342
 343     for {set y 0} {$y < $h} {incr y} {
 344         set line [db_getsl $f]; append im $line  "\n"
 345     }
 346     set database($im) $def
 347 }
 348 proc write_database_header/pixmap {f} { puts $f "" }
 349 proc format_database_entry/pixmap {im def} {
 350     return "$def\n$im"
 351 }
 352
 353 #---------- pixmap display and input handling ----------
 354
 355 proc foreach_pixmap_col {var body} {
 356     global alloptions
 357     upvar 1 $var col
 358     for {set col 0} {$col < [llength $alloptions]/3} {incr col} {
 359         uplevel 1 $body
 360     }
 361 }
 362
 363 proc pixmap_select {ncol} {
 364     global alloptions
 365     debug "PIX SELECT $ncol [llength $alloptions]"
 366     foreach_pixmap_col col {
 367         if {$col==$ncol} continue
 368         .pe.grid.l$col selection clear 0 end
 369     }
 370     if {[pixmap_maybe_ok]} {
 371         focus .pe.ok
 372     }
 373 }
 374 proc pixmap_maybe_ok {} {
 375     global alloptions pixmap_selcol pixmap_selrow
 376     set nsel 0
 377     foreach_pixmap_col col {
 378         set cs [.pe.grid.l$col curselection]
 379         set lcs [llength $cs]
 380         if {!$lcs} continue
 381         incr nsel $lcs
 382         set pixmap_selcol $col
 383         set pixmap_selrow [lindex $cs 0]
 384     }
 385     if {$nsel==1} {
 386         debug "MAYBE_OK YES col=$pixmap_selcol row=$pixmap_selrow."
 387         .pe.ok configure -state normal -command pixmap_ok
 388         return 1
 389     } else {
 390         .pe.ok configure -state disabled -command {}
 391         return 0
 392     }
 393 }
 394 proc pixmap_ok {} {
 395     global database ppm pixmap_selcol pixmap_selrow mainkind alloptions
 396
 397     return_result_start
 398     foreach_pixmap_col col {
 399         .pe.grid.l$col configure -state disabled
 400     }
 401     .pe.ok configure -state disabled
 402
 403     manyset [lrange $alloptions [expr {$pixmap_selcol*3}] end] \
 404         colname coldesc rows
 405     manyset [lrange $rows [expr {$pixmap_selrow*2}] end] \
 406         rowname rowdesc
 407     set result "$colname - $rowname"
 408     debug "UPDATE PIXMAP AS >$result<"
 409
 410     do_database_update $ppm $result
 411
 412     return_result_finish
 413 }
 414
 415 proc required/pixmap {} {
 416     global unk_what ppm mulcols alloptions
 417     must_gets stdin unk_what
 418     debug "GOT pixmap $unk_what"
 419     set ppm {}
 420     while 1 {
 421         must_gets_imagel stdin ppml
 422         if {![string length $ppml]} break
 423         append ppm $ppml "\n"
 424     }
 425     set data [exec pnmscale 2 << $ppm]
 426     image create photo image/main -data $data
 427
 428     set alloptions [exec ./database-info-fetch $unk_what]
 429
 430     select_database pixmap
 431
 432     set mulcols [image width image/main]
 433     set mulrows [image height image/main]
 434     resize_widgets_core
 435     place forget .d.mi.csr_0
 436     place forget .d.mi.csr_1
 437
 438     pack forget .selctx .d.csr .d.got
 439     pack .pe -side top -before .d -pady 2
 440     .d configure -takefocus 0
 441     #-pady 2 -fill x
 442
 443     eval destroy [winfo children .pe.grid]
 444     set col 0; foreach {colname coldesc rows} $alloptions {
 445         debug "INIT $col $colname \"$coldesc\""
 446         label .pe.grid.t$col -text $colname
 447         listbox .pe.grid.l$col
 448         foreach {rowname rowdesc} $rows {
 449             debug "INIT $col $colname \"$coldesc\" $rowname \"$rowdesc\""
 450             .pe.grid.l$col insert end $rowdesc
 451         }
 452         bind .pe.grid.l$col <<ListboxSelect>> [list pixmap_select $col]
 453         grid .pe.grid.t$col -column $col -row 0
 454         grid .pe.grid.l$col -column $col -row 1
 455         incr col
 456     }
 457     pixmap_maybe_ok
 458
 459     helptext {
 460         {{Indicate the meaning of this image; then click OK or hit Return.}}
 461     }
 462 }
 463
 464 proc approve_showentry_xinfo/pixmap {w def} {
 465     label $w -image image/empty
 466 }
 467
 468 #========== UPLOADS TO DICTIONARY SERVER ==========
 469
 470 proc upload_init {} {
 471     global privacy_setting
 472
 473     set privacy_setting [upload_status]
 474
 475     label .privacy.warn -text " Privacy "
 476     if {$privacy_setting} {
 477         .privacy.warn configure -background yellow -foreground black
 478     }
 479     label .privacy.overall -text " Upload new dictionary entry:"
 480     label .privacy.reference -text " See README.privacy."
 481
 482     pack .privacy.warn .privacy.overall -side left
 483
 484     foreach {setting string} {
 485         0 {No}
 486         1 {Yes, anonymously}
 487         2 {Yes, quoting my pirate name.}
 488     } {
 489         radiobutton .privacy.o$setting -text $string \
 490             -value $setting -variable privacy_setting
 491         pack .privacy.o$setting -side left
 492         if {$setting > $privacy_setting} {
 493             .privacy.o$setting configure -state disabled
 494         }
 495     }
 496     pack .privacy.reference -side left
 497
 498     if {!$privacy_setting} {
 499         foreach w [winfo children .privacy] {
 500             $w configure -state disabled
 501         }
 502     }
 503     if {$privacy_setting} {
 504         package require http
 505         ::http::config -urlencoding utf-8
 506     }
 507 }
 508
 509 proc upload_status {} {
 510     # returns 0, 1, 2 for none, anon, with pirate name
 511     global env
 512
 513     if {![info exists env(YPPSC_PCTB_DICT_SUBMIT)]} { debug a; return 0 }
 514     if {![string compare 0 $env(YPPSC_PCTB_DICT_SUBMIT)]} { debug b; return 0 }
 515
 516     if {![info exists env(YPPSC_PIRATE)]} { return 1 }
 517     if {![info exists env(YPPSC_OCEAN)]} { return 1 }
 518     if {![string length $env(YPPSC_PIRATE)]} { return 1 }
 519     if {![string length $env(YPPSC_OCEAN)]} { return 1 }
 520
 521     return 2
 522 }
 523
 524 proc maybe_upload_entry {im def} {
 525     global reqkind privacy_setting env dbname quiet aadepth
 526
 527     debug "DB-UPDATE PRIVACY $privacy_setting"
 528     if {!$privacy_setting} return
 529
 530     debug "DB-UPDATE UPLOADING"
 531
 532     set pl {}
 533     lappend pl dict $dbname
 534     lappend pl version 3
 535     lappend pl depth $aadepth
 536
 537     if {$privacy_setting>=2} {
 538         set pirate [string totitle $env(YPPSC_PIRATE)]
 539         set ocean [string totitle $env(YPPSC_OCEAN)]
 540         debug "DB-UPDATE NON-ANON $ocean $pirate"
 541         lappend pl \
 542             pirate $pirate \
 543             ocean $ocean
 544     }
 545     lappend pl entry [format_database_entry/$reqkind $im $def]
 546
 547     set url $env(YPPSC_PCTB_DICT_SUBMIT)
 548     append url dictionary-update-receiver
 549
 550     set query [eval ::http::formatQuery $pl]
 551     regsub -all {%0d} $query {} query
 552     debug "DB-UPDATE QUERY $query"
 553
 554     if {[regexp {^\.?/} $url]} {
 555         set cmd [list $url $query]
 556         debug "SUBMIT CMD [string range $cmd 0 200]..."
 557         set body [eval exec $cmd 2>@ stderr]
 558         regsub {^Content-Type: text/plain.*\n\n} $body {} body
 559     } else {
 560
 561         if {[catch {
 562             set req [::http::geturl $url -query $query]
 563         } emsg]} {
 564             puts stderr \
 565                 "\nWARNING: Cannot do dictionary upload: $emsg\n"
 566             return
 567         }
 568         upvar #0 $req s
 569         debug "DB-UPDATE DONE $req $s(status) [array names s]"
 570         set ncode [::http::ncode $req]
 571
 572         if {!(![string compare ok $s(status)] &&
 573               ![string compare 200 $ncode])} {
 574             set m "\nWARNING: Dictionary upload failed:"
 575             foreach v {status http error posterror} {
 576                 if {[info exists s($v)]} { append m "\n $v: $s($v)" }
 577             }
 578             puts stderr $m
 579             return
 580         }
 581         set body $s(body)
 582         ::http::cleanup $req
 583     }
 584
 585     if {![string match {OK *} $body]} {
 586         set m "\nWARNING: Dictionary upload went wrong:\n"
 587         append m "\n  " [join [split $body "\n"] "\n  "]
 588         puts stderr $m
 589         return
 590     }
 591
 592     if {!$quiet} {
 593         puts stderr \
 594             "Uploaded $dbname `$def': $body"
 595     }
 596 }
 597
 598 #========== CHARACTER SET ==========
 599
 600 #---------- pgm input processor ----------
 601
 602 proc char_read_pgm {f} {
 603     global glyphsdone mul inter rhsmost_max unk_l unk_r mulcols mulrows
 604     global cols rows charkey
 605
 606     must_gets_imagel $f l
 607     if {[string compare $l P2]} { error "magic $l ?" }
 608
 609     must_gets_imagel $f l
 610     if {![regexp {^([1-9]\d{0,3}) ([1-9]\d{0,3}) ([1-9]\d?)$} \
 611               $l dummy cols rows maxval]} { error "head $l ?" }
 612
 613     for {set depth 1} {$maxval != (1<<$depth)-1} {incr depth} {
 614         if {$depth >= 16} { error "maxval $maxval ?" }
 615     }
 616
 617     set chop_l [expr {$unk_l - 80}]
 618     set chop_r [expr {$cols - $unk_l - 100}]
 619     if {$chop_l<0} { set chop_l 0 }
 620     if {$chop_r<0} { set chop_r 0 }
 621
 622     set unk_l [expr {$unk_l - $chop_l}]
 623     set unk_r [expr {$unk_r - $chop_l}]
 624     set ngd {}
 625     foreach {min max context contexts got} $glyphsdone {
 626         lappend ngd \
 627             [expr {$min-$chop_l}] \
 628             [expr {$max-$chop_l}] \
 629             $context $contexts $got
 630     }
 631     set glyphsdone $ngd
 632
 633     set realcols $cols
 634     set cols [expr {$cols - $chop_l - $chop_r}]
 635     debug "NOW cols=$cols chop_l,r=$chop_l,$chop_r rows=$rows\
 636                 $unk_l $unk_r $ngd"
 637
 638     set mulcols [expr {$cols*$mul+$inter}]
 639     set mulrows [expr {$rows*$mul+$inter}]
 640
 641     set o "P3\n$mulcols $mulrows 15\n"
 642
 643     for {set x 0} {$x<$cols} {incr x} { set charkey($x) {} }
 644
 645     set ointer1 "   1  1  1"
 646     set ointer  [string repeat $ointer1 $inter]
 647     set ointerl "[string repeat $ointer1 $mulcols]\n"
 648
 649     append o $ointerl
 650
 651     for {set y 0} {$y<$rows} {incr y} {
 652         must_gets_imagel $f l
 653         if {[llength $l] != $realcols} { error "realcols=$realcols $l ?" }
 654
 655         set ol $ointer
 656
 657         for {set x 0} {$x<$cols} {incr x} {
 658             set realx [expr {$x + $chop_l}]
 659             set c [lindex $l $realx]
 660             append charkey($x) [format %x $c]
 661
 662             set how "u"
 663             if {$x >= $unk_l && $x <= $unk_r} {
 664                 set how q
 665             } else {
 666                 set ab 0
 667                 foreach {min max context contexts got} $glyphsdone {
 668                     set rhsmost_max $max
 669                     if {$x >= $min && $x <= $max} {
 670                         set how [lindex {a b} $ab]
 671                         break
 672                     }
 673                     set ab [expr {!$ab}]
 674                 }
 675             }
 676             set c15 [expr {$c << (16-$depth)}]
 677             set c15 [expr {$c15 | ($c15 >> $depth)}]
 678             set c15 [expr {$c15 | ($c15 >> $depth*2)}]
 679             set c15 [expr {$c15 >> 12}]
 680
 681             foreach rgb {r g b} { set $rgb {$c15} }
 682             switch -exact $how {
 683                 a { set r {$c15>>1 | 0x8} }
 684                 b { set b {$c15>>2 | 0xc} }
 685                 u { set b  0              }
 686                 q { set b  0              }
 687                 default { error "how $how ?" }
 688             }
 689 #debug "PIXEL $x,$y how=$how c=$c c15=$c15 $r $g $b"
 690
 691             set opixel " "
 692             foreach rgb {r g b} {
 693                 append opixel [format " %2d" [expr [set $rgb]]]
 694             }
 695             append ol [string repeat $opixel [expr {$mul-$inter}]]
 696             append ol $ointer
 697         }
 698         append ol "\n"
 699         append o [string repeat $ol [expr {$mul-$inter}]]
 700         append o $ointerl
 701     }
 702
 703     debug "DATA1 $o"
 704     set tmpfile ./#dictimage#.tmp
 705     exec pnmscale 1 << $o >$tmpfile
 706     image create photo image/main -file $tmpfile
 707     file delete $tmpfile
 708 }
 709
 710 #---------- character set editor display ----------
 711
 712 proc show_context {maxhv x ctxs} {
 713     global mul
 714     upvar 1 $maxhv maxh
 715     set w .d.ctx.at$x
 716     if {[llength $ctxs]==1} { set fg blue } { set fg yellow }
 717     label $w -bg black -fg $fg -text [join $ctxs "/\n"] -justify left
 718     place $w -x [expr {($x-1)*$mul}] -y 0
 719     set wh [winfo reqheight $w]
 720     if {$wh > $maxh} { set maxh $wh }
 721 }
 722
 723 proc draw_glyphsdone {} {
 724     global glyphsdone mul inter
 725     eval destroy [winfo children .d.got]
 726     foreach {min max context contexts got} $glyphsdone {
 727         frame .d.got.m$min -bd 0 -background \#888
 728         label .d.got.m$min.l -text "$got" -fg white -bg black -bd 0
 729         pack .d.got.m$min.l -padx 1 -pady 1
 730         place .d.got.m$min -x [expr {$min*$mul+$inter}] -y 0
 731     }
 732 }
 733
 734 proc startup_cursor {} {
 735     global cur_already cur_mode cur_0 cur_1 last_ht
 736     global glyphsdone unk_l unk_r
 737
 738     set cur_already [expr {[llength $glyphsdone]/5-1}]
 739     set cur_mode 0 ;# one of:   0 1 already text
 740
 741     set cur_0 $unk_l
 742     set cur_1 [expr {$unk_r+1}]
 743
 744     recursor
 745 }
 746
 747 #---------- character set runtime display and keystroke handling ----------
 748
 749 proc char_exactly_selctxts {contexts} {
 750     global all_contexts
 751     foreach ctx [array names all_contexts] {
 752         set ci $all_contexts($ctx)
 753         set selw .selctx.c$ci
 754         if {[lsearch -exact $contexts $ctx]>=0} {
 755             set state normal
 756         } else {
 757             set state disabled
 758         }
 759         $selw configure -state $state
 760     }
 761 }
 762
 763 proc recursor/0 {} { recursor//01 0 }
 764 proc recursor/1 {} { recursor//01 1 }
 765 proc recursor//01 {z1} {
 766     global mul rhsmost_max cols glyphsdone cur_0 cur_1
 767     global all_contexts
 768     upvar #0 cur_$z1 cur
 769     .d.csr.csr.l configure -text "adjust [char_get_definition_context_actual]"
 770     place .d.csr.csr -x [expr {$cur*$mul - 7}]
 771
 772     set okctxts [char_get_definition_contexts]
 773     char_exactly_selctxts $okctxts
 774
 775     foreach ctx [lsort [array names all_contexts]] {
 776         set key [string range $ctx 0 0]
 777         if {[lsearch -exact $okctxts $ctx] >= 0} {
 778             bind_key [string tolower $key] "
 779                 [list set new_context $ctx]
 780                 char_start_define_text
 781             "
 782         } else {
 783             bind_key [string tolower $key] {}
 784         }
 785         lappend context_help $key
 786     }
 787     set context_help [list [join $context_help " "] \
 788       {Set match context for new glyph, confirm location, and start entry.}]
 789
 790     bind_key space { othercursor }
 791     bind_leftright_q cur_$z1 0 [expr {$cols-1}]
 792     if {[llength $glyphsdone]} {
 793         bind_key BackSpace { set cur_mode already; recursor }
 794     } else {
 795         bind_key BackSpace {}
 796     }
 797     bind_key Return {
 798         char_start_define_text
 799     }
 800     helptext [list                                              \
 801         {{<- ->}   {move cursor, adjusting area to define}}     \
 802         {Space     {switch to moving other cursor}}             \
 803         {Return    {confirm location, enter letter(s)}}         \
 804         {Backspace {switch to correcting earlier ocr}}          \
 805         {Q         {quit and abandon OCR run}}                  \
 806         $context_help                                           \
 807                   ]
 808 }
 809 proc othercursor {} {
 810     global cur_mode
 811     set cur_mode [expr {!$cur_mode}]
 812     recursor
 813 }
 814
 815 proc char_start_define_text {} {
 816     global cur_0 cur_1 cur_mode
 817     if {$cur_0 == $cur_1} return
 818     set cdgdca [char_get_definition_context_actual]
 819     if {![string length $cdgdca]} return
 820     .d.csr.csr.e delete 0 end
 821     set cur_mode text
 822     .d.csr.csr.l configure -text "define $cdgdca:"
 823     recursor
 824 }
 825
 826 proc recursor/text {} {
 827     global all_contexts
 828
 829     helptext {
 830         {Return   {confirm entry of new glyph}}
 831         {Escape   {abandon entry}}
 832     }
 833     unbind_all_keys
 834     pack .d.csr.csr.e -side left -padx 2
 835     focus .d.csr.csr.e
 836     bind .d.csr.csr.e <Key-Return> {
 837         set strq [.d.csr.csr.e get]
 838         if {[string length $strq]} {
 839             RETURN_RESULT DEFINE [list $strq]
 840         }
 841     }
 842     bind .d.csr.csr.e <Key-Escape> {
 843         bind_key Escape {}
 844         pack forget .d.csr.csr.e
 845         set cur_mode 1
 846         focus .d
 847         recursor
 848     }
 849 }
 850
 851 proc recursor/already {} {
 852     global mul
 853     global cur_already mul
 854     global glyphsdone cur_already mul
 855
 856     char_exactly_selctxts [lindex $glyphsdone [expr {$cur_already*5+2}]]
 857
 858     .d.csr.csr.l configure -text {correct}
 859     set rmax [lindex $glyphsdone [expr {$cur_already*5}]]
 860     place .d.csr.csr -x [expr {$rmax*$mul-3}]
 861     bind_key Return {}
 862     bind_leftright_q cur_already 0 [expr {[llength $glyphsdone]/5-1}]
 863     bind_key space { bind_key Delete {}; set cur_mode 1; recursor }
 864     bind_key Delete {
 865         RETURN_RESULT DELETE [lrange $glyphsdone \
 866                                   [expr $cur_already*5] \
 867                                   [expr $cur_already*5+2]]
 868     }
 869     helptext {
 870         {{<- ->}   {move cursor, selecting glyph to correct}}
 871         {Del       {clear this glyph from the recognition database}}
 872         {Space     {switch to selecting area to define as new glyph}}
 873         {Q         {quit and abandon OCR run}}
 874     }
 875 }
 876
 877 proc bind_leftright_q {var min max} {
 878     bind_key Left  [list leftright $var $min $max -1]
 879     bind_key Right [list leftright $var $min $max +1]
 880     bind_key q     {
 881         puts stderr "\nCharacter resolver quitting as you requested."
 882         exit 1
 883     }
 884 }
 885 proc leftright {var min max inc} {
 886     upvar #0 $var v
 887     set vnew $v
 888     incr vnew $inc
 889     if {$vnew < $min || $vnew > $max} return
 890     set v $vnew
 891     recursor
 892 }
 893
 894 proc recursor {} {
 895     global csrh cur_mode cur_0 cur_1 mul
 896     foreach z1 {0 1} {
 897         place .d.mi.csr_$z1 -y 0 -x [expr {[set cur_$z1] * $mul}]
 898     }
 899     recursor/$cur_mode
 900 }
 901
 902 #---------- character database read and write ----------
 903
 904 # OUT OF DATE
 905 # database format:
 906 # series of glyphs:
 907 #   <context> <ncharacters> <hex>...
 908 #   width
 909 #   <hex-bitmap>
 910
 911 # $database($context 0x<bits> 0x<bits>...) = $hex
 912
 913 set database_magic/char "# ypp-sc-tools pctb font v3 depth=$aadepth"
 914
 915 proc read_database_header/char {f} {
 916     global rows
 917     set l [db_getsl $f]
 918     if {$l+0 != $rows} { error "wrong h $l $rows ?" }
 919 }
 920 proc read_database_entry/char {f context} {
 921     global database
 922     set bm $context
 923     set strq [db_getsl $f]
 924     while 1 {
 925         set l [db_getsl $f]
 926         if {![string length $l]} break
 927         lappend bm $l
 928     }
 929     set database($bm) $strq
 930 }
 931
 932 proc write_database_header/char {f} {
 933     global rows
 934     puts $f "$rows\n"
 935 }
 936 proc format_database_entry/char {bm strq} {
 937     global database rows
 938     set o "[lindex $bm 0]\n$strq\n"
 939     foreach x [lrange $bm 1 end] { append o "$x\n" }
 940     return $o
 941 }
 942
 943 proc dbkey {ctx l r} {
 944     global charkey
 945     set bm $ctx
 946     for {set x $l} {$x <= $r} {incr x} {
 947         lappend bm $charkey($x)
 948     }
 949     return $bm
 950 }
 951
 952 proc char_get_definition_cursors {} {
 953     global cur_0 cur_1
 954     if {$cur_0 <= $cur_1} {
 955         set cl $cur_0; set cr $cur_1
 956     } else {
 957         set cl $cur_1; set cr $cur_0
 958     }
 959     incr cr -1
 960     debug "CGD CURSORS $cl $cr"
 961     return [list $cl $cr]
 962 }
 963
 964 proc char_get_definition_contexts {} {
 965     global glyphsdone unk_l unk_contexts database
 966
 967     manyset [char_get_definition_cursors] c0 c1
 968
 969     if {$c0 == $unk_l} {
 970         set ncontexts $unk_contexts
 971     } else {
 972         foreach {l r context contexts got} $glyphsdone {
 973             if {$l==$c0} { set ncontexts $contexts; break }
 974         }
 975         if {![info exists ncontexts]} {
 976             set ncontexts {}
 977         }
 978     }
 979     debug "CGD CONTEXTS $ncontexts"
 980     return $ncontexts
 981 }
 982
 983 proc char_get_definition_context_actual {} {
 984     global new_context
 985     set ncontexts [char_get_definition_contexts]
 986     if {[llength $ncontexts]==1} {
 987         set c [lindex $ncontexts 0]
 988     } elseif {[lsearch -exact $ncontexts $new_context]>=0} {
 989         set c $new_context
 990     } else {
 991         set c {}
 992     }
 993     debug "CDG CONTEXT ACTUAL $c FROM NEW $new_context ALLOW $ncontexts"
 994     return $c
 995 }
 996
 997 proc update_database/DEFINE {strq} {
 998     manyset [char_get_definition_cursors] c0 c1
 999     set c [char_get_definition_context_actual]
1000     if {![string length $c]} {
1001         error "Selected context is not one of the many possibilities."
1002     }
1003     debug "DEFINE $strq"
1004     set bm [dbkey $c $c0 $c1]
1005     do_database_update $bm $strq
1006 }
1007
1008 proc update_database/DELETE {l r ctxs} {
1009     global database
1010     if {[llength $ctxs]!=1} { error "$ctxs ?" }
1011     foreach ctx $ctxs {
1012         set bm [dbkey $ctx $l $r]
1013         catch { unset database($bm) }
1014     }
1015     write_database
1016 }
1017
1018 proc RETURN_RESULT {how what} {
1019     return_result_start
1020
1021     place forget .d.csr.csr
1022     pack forget .d.csr.csr.e
1023
1024     debug "$how $what"
1025     eval update_database/$how $what
1026
1027     return_result_finish
1028 }
1029
1030 #========== server for approving updates ==========
1031
1032 proc remote-serv-log {dict pirate caller file event} {
1033     global remoteserv_logf
1034     set t [clock format [clock seconds] -format {%Y-%m-%d %H:%M:%S %Z}]
1035     set s [format "%s %-6s %-31s %-31s %s %s\n" \
1036                $t $dict $pirate $caller [file tail $file] $event]
1037     puts -nonewline $remoteserv_logf $s
1038 }
1039
1040 proc remote-serv/list {} {
1041     global dropdir
1042     foreach file [glob -nocomplain -type f -directory $dropdir _update.*.rdy] {
1043         puts yes
1044         puts $file
1045         set f [open $file]
1046         set d [read $f]
1047         close $f
1048         puts_counted stdout d
1049     }
1050     puts end
1051 }
1052
1053 proc remote-serv/take {yesno file dict} {
1054     global dropdir dictdir rows reqkind database
1055     set rows ""
1056     debug "TAKE [list $yesno $file $dict]"
1057     read_counted stdin pirate
1058     read_counted stdin caller
1059     read_counted stdin key
1060     read_counted stdin val
1061
1062     must_gets_exactly stdin confirmed
1063
1064     manyset [dict2_reqkind_rows $dict] reqkind rows
1065
1066     if {$yesno} {
1067         read_database $dictdir/master-$dict.txt
1068         set database($key) $val
1069         write_database
1070         set desc approve
1071     } else {
1072         set desc reject
1073     }
1074     remote-serv-log $dict $pirate $caller $file "$desc $reqkind $rows"
1075     file delete -force $file
1076
1077     puts done
1078 }
1079
1080 proc remote-serv/noop {} {
1081     puts ok
1082 }
1083
1084 set remoteserv_banner {ypp-sc-tools pctb remote-server v1}
1085
1086 proc main/remoteserv {} {
1087     global argv dropdir remoteserv_banner remoteserv_logf dictdir
1088     manyset $argv dropdir dictdir
1089     puts $remoteserv_banner
1090     set remoteserv_logf [open $dropdir/_dict.log a]
1091     fconfigure $remoteserv_logf -buffering line
1092     while 1 {
1093         flush stdout
1094         if {[gets stdin l] < 0} break
1095         eval remote-serv/$l
1096     }
1097 }
1098
1099 #========== updates approver ==========
1100
1101 proc puts_server {s} {
1102     global server
1103     debug ">> $s"
1104     puts $server $s
1105 }
1106 proc must_gets_server {lv} {
1107     upvar 1 $lv l
1108     global server
1109     must_gets $server l
1110     debug "<< $l"
1111 }
1112
1113 proc must_gets_exactly_server {expected} {
1114     must_gets_server got
1115     if {[string compare $expected $got]} { error "$expected $got ?" }
1116 }
1117
1118 proc regsub-data {exp subspec args} {
1119     global data
1120     if {![eval regsub $args -- [list $exp $data $subspec data]]} {
1121         error "$exp >$data< ?"
1122     }
1123 }
1124
1125 proc dict2_reqkind_rows {dict} {
1126     if {![string compare pixmap $dict]} {
1127         return {pixmap {}}
1128         debug "DICT PIXMAP"
1129     } elseif {[regexp {^(char)([1-9]\d*)$} $dict dummy reqkind rows]} {
1130         debug "DICT CHAR rqk=$reqkind r=$rows."
1131         return [list $reqkind $rows]
1132     } else {
1133         error "$dict ?"
1134     }
1135 }
1136
1137 proc chop_counted {var} {
1138     upvar 1 $var val
1139     global data
1140     if {![regexp {^(0|[1-9]\d*)\n} $data dummy l]} { error "$data ?" }
1141     regsub-data {^.*\n} {} -line
1142     set val [string range $data 0 [expr {$l-1}]]
1143     set data [string range $data $l end]
1144     debug "CHOP_COUNTED $l $var"
1145     regsub-data {^\n} {}
1146 }
1147
1148 proc approve_decompose_data {specdata} {
1149     global data aadepth
1150     set data $specdata
1151
1152     regsub-data "^ypp-sc-tools dictionary update v3 depth=$aadepth\\n" {}
1153     uplevel 1 chop_counted pirate
1154     uplevel 1 chop_counted caller
1155     uplevel 1 chop_counted dict
1156     uplevel 1 chop_counted ctx
1157     uplevel 1 chop_counted def
1158     uplevel 1 chop_counted image
1159     uplevel 1 chop_counted key
1160     uplevel 1 chop_counted val
1161
1162     return [uplevel 1 {list $dict $ctx $def $image}]
1163 }
1164
1165 proc approve_compare {fd1 fd2} {
1166     manyset $fd1 file data; set sv1 [approve_decompose_data $data]
1167     manyset $fd2 file data; set sv2 [approve_decompose_data $data]
1168     return [string compare $sv1 $sv2]
1169 }
1170
1171 proc string2unicodenames {str} {
1172     return [exec perl -e {
1173         use Unicode::CharName qw(uname);
1174         $ARGV[0] =~ s/^ //;
1175         foreach $_ (split //,$ARGV[0]) {
1176             print uname(ord),"\n" or die $!
1177         }
1178     } " $str"]
1179 }
1180
1181 proc approve_showentry {ix file specdata} {
1182     global approve_ixes reqkind approve_entryhow
1183
1184     approve_decompose_data $specdata
1185
1186     set wb .app.e$ix
1187
1188     frame $wb-inf
1189     label $wb-inf.who -text $pirate
1190
1191     entry $wb-inf.file -font fixed -relief flat
1192     $wb-inf.file insert end [file tail $file]
1193     $wb-inf.file configure -state readonly -width -1
1194
1195     pack $wb-inf.who $wb-inf.file -side top
1196
1197     frame $wb-def
1198     label $wb-def.scope -text "$dict $ctx"
1199     label $wb-def.def -text $def
1200     pack $wb-def.scope $wb-def.def -side bottom
1201
1202     if {[regexp {^P2} $image]} {
1203         set image [exec pgmtoppm {#008-white} << $image | pnmnoraw]
1204         append image "\n"
1205     }
1206     set image [exec pnmscale 2 << $image]
1207
1208     image create photo approve/$ix -data $image
1209     label $wb-image -image approve/$ix -bd 2 -relief flat -bg black
1210
1211     manyset [dict2_reqkind_rows $dict] reqkind
1212     approve_showentry_xinfo/$reqkind $wb-xinfo $def
1213
1214     if {$ix} {
1215         label $wb-div -bd 1 -relief sunken -image image/empty
1216         grid configure $wb-div -columnspan 5 -sticky ew -padx 5
1217     }
1218
1219     frame $wb-act -bd 2 -relief groove
1220     set approve_entryhow($ix) approve
1221     foreach how {approve reject defer} {
1222         set w $wb-act.$how
1223         radiobutton $w -variable approve_entryhow($ix) \
1224             -text [string totitle $how] -value $how
1225         pack $w -side left
1226     }
1227
1228     grid $wb-def $wb-image $wb-xinfo $wb-act $wb-inf -padx 3
1229     grid configure $wb-image -ipadx 3 -ipady 3 -sticky w
1230
1231     lappend approve_ixes $ix
1232 }
1233
1234 proc approve_approve_reject_one {ix yesno} {
1235     global approve_list server
1236     manyset [lindex $approve_list $ix] file tdata
1237     approve_decompose_data $tdata
1238     puts_server "take $yesno $file $dict"
1239     puts_counted $server pirate
1240     puts_counted $server caller
1241     puts_counted $server key
1242     puts_counted $server val
1243     puts_server confirmed
1244     flush $server
1245     must_gets_exactly_server done
1246 }
1247
1248 proc approve_check_server {} {
1249     global server
1250     puts_server noop
1251     flush $server
1252     must_gets_exactly_server ok
1253 }
1254
1255 proc approve_confirm {} {
1256     global approve_ixes approve_entryhow
1257     .ok configure -state disabled
1258     update idletasks
1259     approve_check_server
1260     foreach ix $approve_ixes {
1261         set how $approve_entryhow($ix)
1262         switch -exact $how {
1263             approve { approve_approve_reject_one $ix 1 }
1264             reject  { approve_approve_reject_one $ix 0 }
1265             defer   { }
1266             default { error $how? }
1267         }
1268     }
1269     approve_fetch_list
1270 }
1271
1272 proc approve_fetch_list {} {
1273     global server approve_list
1274     set approve_list {}
1275     puts_server list
1276     flush $server
1277     while 1 {
1278         must_gets_server more
1279         switch -exact $more {
1280             yes { }
1281             end { break }
1282             default { error "$more ?" }
1283         }
1284         must_gets_server file
1285         read_counted $server data
1286         lappend approve_list [list $file $data]
1287     }
1288
1289     if {![llength $approve_list]} { puts "Nothing (more) to approve."; exit 0 }
1290
1291     set approve_list [lsort -command approve_compare $approve_list]
1292     approve_show_page 0
1293     .ok configure -state normal
1294 }
1295
1296 proc main/approve {} {
1297     global argv server remoteserv_banner data approve_list approve_page
1298     global userhost directory dictdir debug
1299
1300     if {[llength $argv] != 3} { error "wrong # args" }
1301     manyset $argv userhost directory dictdir
1302     debug "APPROVER FOR $userhost $directory $dictdir"
1303
1304     set cmd [list tclsh $directory/dictionary-manager]
1305     if {$debug} { lappend cmd --debug-server }
1306     lappend cmd --remote-server-1 $directory $dictdir
1307     switch -glob $userhost {
1308         {} { }
1309         {* *} { set cmd $userhost }
1310         * { set cmd [concat [list ssh -o compression=yes $userhost] $cmd] }
1311     }
1312     debug "APPROVER RUNS $cmd"
1313
1314     lappend cmd 2>@ stderr
1315     set server [open |$cmd r+]
1316     must_gets_exactly_server $remoteserv_banner
1317
1318     button .left -text {<<} -command {approve_show_page -1}
1319     button .right -text {>>} -command {approve_show_page +1}
1320
1321     label .title -text {}
1322     frame .app -bd 2 -relief groove
1323     button .ok -text "Confirm" -command approve_confirm
1324     pack .title .app -side top
1325     pack .left -side left
1326     pack .right -side right
1327     pack .ok -side bottom
1328
1329     image create bitmap image/empty
1330
1331     set approve_page 0
1332     approve_fetch_list
1333 }
1334
1335 proc approve_show_page {delta} {
1336     global approve_page approve_ixes approve_list userhost directory dictdir
1337
1338     eval destroy [winfo children .app]
1339     set approve_ixes {}
1340
1341     set per_page 10
1342     incr approve_page $delta
1343
1344     set ll [llength $approve_list]
1345     set npages [expr {($ll+$per_page-1)/$per_page}]
1346     if {$approve_page >= $npages} { incr approve_page -1 }
1347
1348     set page_start [expr {$approve_page*$per_page}]
1349     set page_end [expr {$page_start+$per_page-1}]
1350
1351     for {set ix $page_start} {$ix < $ll && $ix <= $page_end} {incr ix} {
1352         set fd [lindex $approve_list $ix]
1353         eval approve_showentry $ix $fd
1354     }
1355
1356     .title configure -text \
1357  "$userhost\n$directory => $dictdir\nPage [expr {$approve_page+1}]/$npages"
1358
1359     .left configure -state disabled
1360     .right configure -state disabled
1361     if {$approve_page>0} { .left configure -state normal }
1362     if {$approve_page<$npages-1} { .right configure -state normal }
1363 }
1364
1365 #========== main program ==========
1366
1367 proc return_result_start {} {
1368     helptext {{{ Processing }}}
1369     unbind_all_keys
1370     update idletasks
1371 }
1372 proc return_result_finish {} {
1373     global mainkind
1374     done/$mainkind
1375 }
1376
1377 proc main/default {} {
1378     puts stderr "Do not run this program directly."
1379     exit 12
1380 }
1381 proc done/default {} {
1382 }
1383
1384 proc required {} {
1385     global reqkind
1386
1387     fileevent stdin readable {}
1388     fconfigure stdin -blocking yes
1389
1390     if {[gets stdin reqkind]<0} {
1391         if {[eof stdin]} { fconfigure stdin -blocking yes; exit 0 }
1392         return
1393     }
1394     init_widgets
1395
1396     required/$reqkind
1397 }
1398
1399 proc main/automatic {} {
1400     fconfigure stdin -blocking no
1401     fileevent stdin readable required
1402 }
1403 proc done/automatic {} {
1404     exec sh -c {printf \\0 >&4}
1405     main/automatic
1406 }
1407
1408 proc debug {m} { }
1409
1410 set mainkind default
1411 set ai 0
1412 set debug 0
1413 set debug_rect 0
1414 set quiet 0
1415 foreach arg $argv {
1416     incr ai
1417     switch -exact -- $arg {
1418         {--quiet}           { set quiet 1 }
1419         {--debug}           { set debug 1 }
1420         {--debug-rect}      { set debug_rect 1 }
1421         {--debug-server}    { proc debug {m} { puts stderr "DICT-MGR-SVR $m" }}
1422         {--noop-arg}        { }
1423         {--approve-updates} { set mainkind approve; break }
1424         {--automatic-1}     { set mainkind automatic; break }
1425         {--remote-server-1} { set mainkind remoteserv; break }
1426         {--automatic*} - {--remote-server}
1427                             { error "incompatible versions - install problem" }
1428         default             { error "huh $argv ?" }
1429     }
1430 }
1431 if {$debug} {
1432     proc debug {m} { puts stderr "DICT-MGR $m" }
1433 }
1434 set argv [lrange $argv $ai end]
1435
1436 main/$mainkind