chiark / gitweb /
WIP new dictionary arrangements
[ypp-sc-tools.main.git] / 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 # invocation:
29 # OUT OF DATE
30 #  run this without args
31 #  then on stdin write
32 #     one line which is a Tcl list for unk_{l,r} unk_contexts glyphsdone etc.
33 #     the xpm in the format expected
34 #  then expect child to exit 0, or write a single 0 byte to fd 4
35 #  if it wrote a byte to fd 4, it can take another question
36
37
38 #---------- library routines ----------
39
40 proc manyset {list args} {
41     foreach val $list var $args {
42         upvar 1 $var my
43         set my $val
44     }
45 }
46
47 proc must_gets {f lvar} {
48     upvar 1 $lvar l
49     if {[gets $f l] < 0} { error "huh?" }
50 }
51
52 proc must_gets_exactly {f expected} {
53     must_gets $f got
54     if {[string compare $expected $got]} { error "$expected $got ?" }
55 }
56
57 proc read_counted {f var} {
58     upvar 1 $var val
59     must_gets $f count
60     set val [read $f $count]
61     must_gets $f eol
62     if {[string length $eol]} { error "$eol ?" }
63     debug "READ_COUNTED $count $var"
64 }
65
66 proc puts_counted {f dvar} {
67     upvar 1 $dvar d
68     set count [string length $d]
69     puts $f $count
70     puts $f $d
71     debug "PUTS_COUNTED $count $dvar"
72 }
73
74 #---------- display core ----------
75
76 set mul 6
77 set inter 1
78
79 set gotsh 20
80 set csrh 20
81 set ctxh 20
82
83 proc init_widgets {} {
84     # idempotent
85     global csrh gotsh ctxh
86
87     if {[winfo exists .d]} return
88     
89     frame .d
90
91     image create bitmap image/main
92     label .d.mi -image image/main -borderwidth 0
93
94     frame .d.csr -bg black -height $csrh
95     frame .d.got -bg black -height $gotsh
96     frame .d.ctx -bg black
97
98     image create bitmap image/cursor -data \
99 {#define csr_width 11
100 #define csr_height 11
101 static unsigned char csr_bits[] = {
102    0x20, 0x00, 0x20, 0x00, 0x20, 0x00, 0x21, 0x04, 0x22, 0x02, 0x25, 0x05,
103    0xaa, 0x02, 0x74, 0x01, 0xa8, 0x00, 0x70, 0x00, 0x20, 0x00};
104 }
105
106     frame .d.csr.csr
107     label .d.csr.csr.l -image image/cursor -compound left
108     entry .d.csr.csr.e -bd 0
109     pack .d.csr.csr.l -side left
110
111     frame .d.mi.csr_0 -bg white -width 1
112     frame .d.mi.csr_1 -bg white -width 1
113     frame .d.pe
114     frame .d.pe.grid
115     button .d.pe.ok -text OK
116     pack .d.pe.grid .d.pe.ok -side left
117
118     pack .d.mi .d.ctx -side top
119     pack .d
120
121     frame .help
122     pack .help
123 }
124
125 proc resize_widgets_core {} {
126     global mulcols mulrows csrh gotsh ctxh glyphsdone
127     global unk_l unk_contexts
128     
129     foreach w {.d.csr .d.got .d.ctx} {
130         $w configure -width $mulcols
131     }
132
133     eval destroy [winfo children .d.ctx]
134 }
135
136 set last_ht {}
137
138 proc helptext {t} {
139     global last_ht
140     if {![string compare $t $last_ht]} return
141     eval destroy [grid slaves .help]
142     set y 0; foreach l $t {
143         set x 0; foreach c $l {
144             set w .help.at${x}x${y}
145             label $w -text $c
146             grid $w -row $y -column $x -padx 5
147             incr x
148         }
149         incr y
150     }
151     set last_ht $t
152 }
153
154 proc bind_key {k proc} {
155     global keybindings
156     bind . <Key-$k> $proc
157     set keybindings($k) [expr {!![string length $proc]}]
158 }
159 proc unbind_all_keys {} {
160     global keybindings
161     foreach k [array names keybindings] { bind_key $k {} }
162 }
163
164 #---------- database read and write common wrapper ----------
165
166 proc db_getsl {f} {
167     if {[gets $f l] < 0} { error "unexpected db eof" }
168     return $l
169 }
170
171 proc read_database {fn} {
172     global reqkind database database_fn
173     upvar #0 database_magic/$reqkind magic
174     catch { unset database }
175
176     set database_fn $fn
177     if {![file exists $database_fn]} return
178     set f [open $database_fn r]
179     if {[string compare [db_getsl $f] $magic]} { error "$l $reqkind ?" }
180
181     read_database_header/$reqkind $f
182     while 1 {
183         set l1 [db_getsl $f]
184     
185         if {![string length $l1]} continue
186         if {[regexp {^\#} $l1]} continue
187         if {![string compare . $l1]} break
188
189         read_database_entry/$reqkind $f $l1
190     }
191     close $f
192 }
193
194 proc write_database {} {
195     global reqkind database_fn database
196     upvar #0 database_magic/$reqkind magic
197     
198     set f [open $database_fn.new w]
199     puts $f $magic
200
201     write_database_header/$reqkind $f
202
203     set ol {}
204     foreach bm [array names database] {
205         lappend ol [format_database_entry/$reqkind $bm $database($bm)]
206     }
207     foreach o [lsort $ol] {
208         puts $f $o
209     }
210     puts $f "."
211     close $f
212     file rename -force $database_fn.new $database_fn
213 }
214
215 proc required/char {} {
216     global mulrows glyphsdone unk_l unk_r unk_contexts rows
217     
218     must_gets stdin l
219
220     manyset [lrange $l 0 3] unk_l unk_r unk_contexts
221     set glyphsdone [lrange $l 3 end]
222     debug "GOT $l"
223
224     char_read_xpm stdin
225
226     resize_widgets_core
227     foreach w {0 1} {
228         .d.mi.csr_$w configure -height $mulrows
229     }
230     set maxh 0
231     foreach {min max contexts got} $glyphsdone {
232         show_context maxh $min $contexts
233     }
234     show_context maxh $unk_l $unk_contexts
235     .d.ctx configure -height $maxh
236     pack forget .d.pe
237     pack .d.csr -side top -before .d.mi
238     pack .d.got .d.ctx -side top -after .d.mi
239
240     read_database "./#local-char$rows#.txt"
241     draw_glyphsdone
242     startup_cursor
243 }
244
245 #========== PIXMAPS ==========
246
247 #---------- pixmap database read and write ----------
248
249 set database_magic/pixmap {# ypp-sc-tools pctb pixmaps v1}
250
251 proc read_database_header/pixmap {f} { }
252 proc read_database_entry/pixmap {f def} {
253     global database
254
255     set im ""
256     
257     set p3 [db_getsl $f];       append im $p3    "\n"
258     if {[string compare $p3 P3]} { error "$p3 ?" }
259
260     set wh [db_getsl $f];       append im $wh    "\n";   manyset $wh w h
261     set depth [db_getsl $f];    append im $depth "\n"
262
263     for {set y 0} {$y < $h} {incr y} {
264         set line [db_getsl $f]; append im $line  "\n"
265     }
266     set database($im) $def
267 }
268 proc write_database_header/pixmap {f} { puts $f "" }
269 proc format_database_entry/pixmap {im def} {
270     return "$def\n$im"
271 }
272
273 #---------- pixmap display and input handling ----------
274
275 proc foreach_pixmap_col {var body} {
276     global alloptions
277     upvar 1 $var col
278     for {set col 0} {$col < [llength $alloptions]/3} {incr col} {
279         uplevel 1 $body
280     }
281 }
282
283 proc pixmap_select {ncol} {
284     global alloptions
285     debug "PIX SELECT $ncol [llength $alloptions]"
286     foreach_pixmap_col col {
287         if {$col==$ncol} continue
288         .d.pe.grid.l$col selection clear 0 end
289     }
290     pixmap_maybe_ok
291 }
292 proc pixmap_maybe_ok {} {
293     global alloptions pixmap_selcol pixmap_selrow
294     set nsel 0
295     foreach_pixmap_col col {
296         set cs [.d.pe.grid.l$col curselection]
297         set lcs [llength $cs]
298         if {!$lcs} continue
299         incr nsel $lcs
300         set pixmap_selcol $col
301         set pixmap_selrow [lindex $cs 0]
302     }
303     if {$nsel==1} {
304         debug "MAYBE_OK YES col=$pixmap_selcol row=$pixmap_selrow."
305         .d.pe.ok configure -state normal -command pixmap_ok
306     } else {
307         .d.pe.ok configure -state disabled -command {}
308     }
309 }
310 proc pixmap_ok {} {
311     global database ppm pixmap_selcol pixmap_selrow mainkind alloptions
312     foreach_pixmap_col col {
313         .d.pe.grid.l$col configure -state disabled
314     }
315     .d.pe.ok configure -state disabled
316     helptext {{{ Processing }}}
317     manyset [lrange $alloptions [expr {$pixmap_selcol*3}] end] \
318         colname coldesc rows
319     manyset [lrange $rows [expr {$pixmap_selrow*2}] end] \
320         rowname rowdesc
321     set result "$colname - $rowname"
322     debug "UPDATE PIXMAP AS >$result<"
323     set database($ppm) $result
324     write_database
325     done/$mainkind
326 }
327
328 proc required/pixmap {} {
329     global unk_what ppm mulcols alloptions
330     must_gets stdin unk_what
331     debug "GOT pixmap $unk_what"
332     set ppm {}
333     while 1 {
334         must_gets stdin ppml
335         if {![string length $ppml]} break
336         append ppm $ppml "\n"
337     }
338     set data [exec pnmscale 2 << $ppm]
339     image create photo image/main -data $data
340
341     set alloptions [exec ./dictionary-pixmap-options $unk_what]
342
343     read_database "./#local-pixmap#.txt"
344
345     set mulcols [image width image/main]
346     set mulrows [image height image/main]
347     resize_widgets_core
348     place forget .d.mi.csr_0
349     place forget .d.mi.csr_1
350
351     pack forget .d.csr .d.got
352     pack .d.pe -side top -before .d.mi -pady 10
353
354     eval destroy [winfo children .d.pe.grid]
355     set col 0; foreach {colname coldesc rows} $alloptions {
356         debug "INIT $col $colname \"$coldesc\""
357         label .d.pe.grid.t$col -text $colname
358         listbox .d.pe.grid.l$col
359         foreach {rowname rowdesc} $rows {
360             debug "INIT $col $colname \"$coldesc\" $rowname \"$rowdesc\""
361             .d.pe.grid.l$col insert end $rowdesc
362         }
363         bind .d.pe.grid.l$col <<ListboxSelect>> [list pixmap_select $col]
364         grid .d.pe.grid.t$col -column $col -row 0
365         grid .d.pe.grid.l$col -column $col -row 1
366         incr col
367     }
368     pixmap_maybe_ok
369     
370     helptext {
371         {{Indicate the correct parse of this image, and click OK.}}
372     }
373 }
374
375 #========== CHARACTER SET ==========
376
377 #---------- xpm input processor ----------
378
379 proc char_read_xpm {f} {
380     global glyphsdone mul inter rhsmost_max unk_l unk_r mulcols mulrows
381     global cols rows wordmap
382     
383     set o {}
384     set y -3
385     while 1 {
386         must_gets $f l
387         if {![regexp {^"(.*)",$} $l dummy l]} {
388             append o "$l\n"
389             if {[regexp {^\}\;$} $l]} break
390             continue
391         }
392         if {$y==-3} {
393             manyset $l cols rows colours cpp
394             if {$colours!=2 || $cpp!=1} { error "$l ?" }
395
396             set chop_l [expr {$unk_l - 80}]
397             set chop_r [expr {$cols - $unk_l - 100}]
398             if {$chop_l<0} { set chop_l 0 }
399
400             set unk_l [expr {$unk_l - $chop_l}]
401             set unk_r [expr {$unk_r - $chop_l}]
402             set ngd {}
403             foreach {min max contexts got} $glyphsdone {
404                 lappend ngd \
405                     [expr {$min-$chop_l}] \
406                     [expr {$max-$chop_l}] \
407                     $contexts $got
408             }
409             set glyphsdone $ngd
410
411             set realcols $cols
412             set cols [expr {$cols - $chop_l - $chop_r}]
413             debug "NOW cols=$cols chop_l,r=$chop_l,$chop_r rows=$rows\
414                 $unk_l $unk_r $ngd"
415             
416             set mulcols [expr {$cols*$mul+$inter}]
417             set mulrows [expr {$rows*$mul+$inter}]
418             append o "\"$mulcols $mulrows 9 1\",\n"
419             for {set x 0} {$x<$cols} {incr x} { set wordmap($x) 0 }
420         } elseif {$y==-2} { # first pixel
421             append o \
422 "\"+ c #111\",
423 \"a c #800\",
424 \"A c #fcc\",
425 \"b c #00c\",
426 \"B c #fff\",
427 \"u c #000\",
428 \"U c #ff0\",
429 \"q c #000\",
430 \"Q c #ff0\",\n"
431         } elseif {$y==-1} { # 2nd pixel but we've already printed ours
432         } else {
433             set ybit [expr {1<<$y}]
434             set x 0
435             set ol "\"+"
436             set olh $ol
437             if {$chop_r>=0} {
438                 set l [string range $l $chop_l end-$chop_r]
439             } else {
440                 set l [string range $l $chop_l end]
441                 append l [string repeat " " [expr -$chop_r]]
442             }
443             foreach c [split $l ""] {
444                 set how "u"
445                 if {$x >= $unk_l && $x <= $unk_r} {
446                     set how q
447                 } else {
448                     set ab 0
449                     foreach {min max contexts got} $glyphsdone {
450                         set rhsmost_max $max
451                         if {$x >= $min && $x <= $max} {
452                             set how [lindex {a b} $ab]
453                             break
454                         }
455                         set ab [expr {!$ab}]
456                     }
457                 }
458                 switch -exact $c {
459                     " " { set p $how }
460                     "o" {
461                         set p [string toupper $how]
462                         incr wordmap($x) $ybit
463                     }
464                     default { error "$c ?" }
465                 }
466                 append ol "[string repeat $p [expr {$mul-$inter}]][
467                          string repeat + $inter]"
468                 append olh [string repeat + $mul]
469                 incr x
470             }
471             set ole "\",\n"
472             append ol $ole
473             append olh $ole
474             set olhn [string repeat $olh $inter]
475             if {!$y} { append o $olhn }
476             append o [string repeat $ol [expr {$mul-1}]]
477             append o $olhn
478         }
479         incr y
480     }
481     set data [exec xpmtoppm << $o]
482     image create photo image/main -data $data
483 }
484
485 #---------- character set editor display ----------
486
487 proc show_context {maxhv x ctxs} {
488     global mul
489     upvar 1 $maxhv maxh
490     set w .d.ctx.at$x
491     if {[llength $ctxs]==1} { set fg blue } { set fg yellow }
492     label $w -bg black -fg $fg -text [join $ctxs "/\n"] -justify left
493     place $w -x [expr {($x-1)*$mul}] -y 0
494     set wh [winfo reqheight $w]
495     if {$wh > $maxh} { set maxh $wh }
496 }
497
498 proc draw_glyphsdone {} {
499     global glyphsdone mul inter
500     eval destroy [winfo children .d.got]
501     foreach {min max contexts got} $glyphsdone {
502         frame .d.got.m$min -bd 0 -background \#888
503         label .d.got.m$min.l -text "$got" -fg white -bg black -bd 0
504         pack .d.got.m$min.l -padx 1 -pady 1
505         place .d.got.m$min -x [expr {$min*$mul+$inter}] -y 0
506     }
507 }
508
509 proc startup_cursor {} {
510     global cur_already cur_mode cur_0 cur_1 last_ht
511     global glyphsdone unk_l unk_r
512     
513     set cur_already [expr {[llength $glyphsdone]/4-1}]
514     set cur_mode 1 ;# one of:   0 1 already text
515
516     set cur_0 $unk_l
517     set cur_1 [expr {$unk_r+1}]
518
519     recursor
520 }
521
522 #---------- character set runtime display and keystroke handling ----------
523
524 proc recursor/0 {} { recursor//01 0 }
525 proc recursor/1 {} { recursor//01 1 }
526 proc recursor//01 {z1} {
527     global mul rhsmost_max cols glyphsdone
528     upvar #0 cur_$z1 cur
529     .d.csr.csr.l configure -text {adjust}
530     place .d.csr.csr -x [expr {$cur*$mul - 7}]
531     bind_key space { othercursor }
532     bind_leftright_q cur_$z1 0 [expr {$cols-1}]
533     if {[llength $glyphsdone]} {
534         bind_key Tab { set cur_mode already; recursor }
535     } else {
536         bind_key Tab {}
537     }
538     bind_key Return {
539         if {$cur_0 != $cur_1} {
540             .d.csr.csr.e delete 0 end
541             set cur_mode text
542             recursor
543         }
544     }
545     helptext {
546         {{<- ->}   {move cursor, adjusting area to define}}
547         {Space     {switch to moving other cursor}}
548         {Return    {confirm location, enter letter(s)}}
549         {Tab       {switch to correcting earlier ocr}}
550         {Q         {quit and abandon OCR run}}
551     }
552 }
553 proc othercursor {} {
554     global cur_mode
555     set cur_mode [expr {!$cur_mode}]
556     recursor
557 }
558
559 proc recursor/text {} {
560     helptext {
561         {Return   {confirm entry of new glyph}}
562         {Escape   {abandon entry}}
563     }
564     unbind_all_keys
565     .d.csr.csr.l configure -text {define:}
566     pack .d.csr.csr.e -side left
567     focus .d.csr.csr.e
568     bind_key Return {
569         set strq [.d.csr.csr.e get]
570         if {[regexp -line {^(?:[!-[]|[]-~]|\\\\|\\x[0-9a-f]{2})+} $strq]} {
571             RETURN_RESULT DEFINE "$cur_0 $cur_1 $strq"
572         }
573     }
574     bind_key Escape {
575         bind_key Escape {}
576         pack forget .d.csr.csr.e
577         set cur_mode 1
578         recursor
579     }
580 }
581
582 proc recursor/already {} {
583     global mul
584     global glyphsdone
585     global cur_already mul
586     global glyphsdone cur_already mul
587     .d.csr.csr.l configure -text {correct}
588     set rmax [lindex $glyphsdone [expr {$cur_already*4}]]
589     place .d.csr.csr -x [expr {$rmax*$mul-3}]
590     bind_key Return {}
591     bind_key space {}
592     bind_leftright_q cur_already 0 [expr {[llength $glyphsdone]/4-1}]
593     bind_key Tab { bind_key Delete {}; set cur_mode 1; recursor }
594     bind_key Delete {
595         RETURN_RESULT DELETE [lrange $glyphsdone \
596                                   [expr $cur_already*4] \
597                                   [expr $cur_already*4+2]]
598     }
599     helptext {
600         {{<- ->}   {move cursor, selecting glyph to correct}}
601         {Del       {clear this glyph from the recognition database}}
602         {Tab       {switch to selecting area to define as new glyph}}
603         {Q         {quit and abandon OCR run}}
604     }
605 }
606
607 proc bind_leftright_q {var min max} {
608     bind_key Left  [list leftright $var $min $max -1]
609     bind_key Right [list leftright $var $min $max +1]
610     bind_key q     {
611         puts stderr "\nCharacter resolver quitting as you requested."
612         exit 1
613     }
614 }
615 proc leftright {var min max inc} {
616     upvar #0 $var v
617     set vnew $v
618     incr vnew $inc
619     if {$vnew < $min || $vnew > $max} return
620     set v $vnew
621     recursor
622 }
623
624 proc recursor {} {
625     global csrh cur_mode cur_0 cur_1 mul
626     foreach z1 {0 1} {
627         place .d.mi.csr_$z1 -y 0 -x [expr {[set cur_$z1] * $mul}]
628     }
629     recursor/$cur_mode
630 }
631
632 #---------- character database read and write ----------
633
634 # OUT OF DATE
635 # database format:
636 # series of glyphs:
637 #   <context> <ncharacters> <hex>...
638 #   width
639 #   <hex-bitmap>
640
641 # $database($context 0x<bits> 0x<bits>...) = $hex
642
643 set database_magic/char {# ypp-sc-tools pctb font v1}
644     
645 proc read_database_header/char {f} {
646     global rows
647     if {([db_getsl $f])+0 != $rows} { error "wrong h ?" }
648 }
649 proc read_database_entry/char {f context} {
650     global database
651     set bm $context
652     set strq [db_getsl $f]
653     while 1 {
654         set l [db_getsl $f]
655         if {![string length $l]} break
656         lappend bm [format %x 0x$l]
657     }
658     set database($bm) $strq
659 }
660
661 proc write_database_header/char {f} {
662     global rows
663     puts $f "$rows\n"
664 }
665 proc format_database_entry/char {bm strq} {
666     global database rows
667     set o "[lindex $bm 0]\n$strq\n"
668     foreach x [lrange $bm 1 end] { append o "$x\n" }
669     return $o
670 }
671
672 proc dbkey {ctx l r} {
673     global wordmap
674     set bm $ctx
675     for {set x $l} {$x <= $r} {incr x} {
676         lappend bm [format %x $wordmap($x)]
677     }
678     return $bm
679 }
680
681 proc update_database/DEFINE {c0 c1 strq} {
682     global glyphsdone unk_l unk_contexts wordmap database
683     if {$c0 > $c1} { manyset [list $c0 $c1] c1 c0 }
684     if {$c0 == $unk_l} {
685         set ncontexts $unk_contexts
686     } else {
687         foreach {l r contexts got} $glyphsdone {
688             if {$l==$c0} { set ncontexts $contexts; break }
689         }
690         if {![info exists ncontexts]} {
691             puts stderr "must start at letter LHS!"
692             return
693         }
694     }
695     incr c1 -1
696     foreach c $ncontexts {
697         set bm [dbkey $c $c0 $c1]
698         set database($bm) $strq
699     }
700     write_database
701 }
702
703 proc update_database/DELETE {l r ctxs} {
704     global database
705     foreach ctx $ctxs {
706         set bm [dbkey $ctx $l $r]
707         catch { unset database($bm) }
708     }
709     write_database
710 }
711     
712 proc RETURN_RESULT {how what} {
713     global mainkind
714     place forget .d.csr.csr
715     pack forget .d.csr.csr.e
716     helptext {{{ Processing }}}
717     unbind_all_keys
718     update idletasks
719     debug "$how $what"
720     eval update_database/$how $what
721     done/$mainkind
722 }
723
724 #========== server for approving updates ==========
725
726 proc remote-serv-log {dict pirate file event} {
727     global remoteserv_logf
728     set t [clock format [clock seconds] -format {%Y-%m-%d %H:%M:%S %Z}]
729     set s [format "%s %-6s %-31s %s %s\n" \
730                $t $dict $pirate [file tail $file] $event]
731     puts -nonewline $remoteserv_logf $s
732 }
733
734 proc remote-serv/list {} {
735     global dropdir
736     foreach file [glob -nocomplain -type f -directory $dropdir _update.*.rdy] {
737         puts yes
738         puts $file
739         set f [open $file]
740         set d [read $f]
741         close $f
742         puts_counted stdout d
743     }
744     puts end
745 }
746
747 proc remote-serv/take {yesno file dict} {
748     global dropdir dictdir rows reqkind database
749     set rows ""
750     debug "TAKE [list $yesno $file $dict]"
751     read_counted stdin pirate
752     read_counted stdin key
753     read_counted stdin val
754
755     must_gets_exactly stdin confirmed
756
757     if {![string compare pixmap $dict]} {
758         set reqkind pixmap
759         debug "DICT PIXMAP"
760     } elseif {[regexp {^(char)([1-9]\d*)$} $dict dummy reqkind rows]} {
761         debug "DICT CHAR rqk=$reqkind r=$rows."
762     } else {
763         error "$dict ?"
764     }
765     
766     if {$yesno} {
767         read_database $dictdir/master-$dict.txt
768         set database($key) $val
769         write_database
770         set desc approve
771     } else {
772         set desc reject
773     }
774     remote-serv-log $dict $pirate $file "$desc $reqkind $rows"
775     file delete -force $file
776
777     puts done
778 }
779
780 proc remote-serv/noop {} {
781     puts ok
782 }
783
784 set remoteserv_banner {ypp-sc-tools pctb remote-server v1}
785
786 proc main/remoteserv {} {
787     global argv dropdir remoteserv_banner remoteserv_logf dictdir
788     manyset $argv dropdir dictdir
789     puts $remoteserv_banner
790     set remoteserv_logf [open $dropdir/_dict.log a]
791     fconfigure $remoteserv_logf -buffering line
792     while 1 {
793         flush stdout
794         if {[gets stdin l] < 0} break
795         eval remote-serv/$l
796     }
797 }
798
799 #========== updates approver ==========
800
801 proc puts_server {s} {
802     global server
803     debug ">> $s"
804     puts $server $s
805 }
806 proc must_gets_server {lv} {
807     upvar 1 $lv l
808     global server
809     must_gets $server l
810     debug "<< $l"
811 }
812
813 proc must_gets_exactly_server {expected} {
814     must_gets_server got
815     if {[string compare $expected $got]} { error "$expected $got ?" }
816 }
817
818 proc regsub-data {exp subspec args} {
819     global data
820     if {![eval regsub $args -- [list $exp $data $subspec data]]} {
821         error "$exp >$data< ?"
822     }
823 }
824
825 proc chop_counted {var} {
826     upvar 1 $var val
827     global data
828     if {![regexp {^(0|[1-9]\d*)\n} $data dummy l]} { error "$data ?" }
829     regsub-data {^.*\n} {} -line
830     set val [string range $data 0 [expr {$l-1}]]
831     set data [string range $data $l end]
832     debug "CHOP_COUNTED $l $var"
833     regsub-data {^\n} {}
834 }
835
836 proc approve_decompose_data {specdata} {
837     global data
838     set data $specdata
839     
840     regsub-data {^ypp-sc-tools dictionary update v1\n} {}
841     uplevel 1 chop_counted pirate
842     uplevel 1 chop_counted dict
843     uplevel 1 chop_counted ctx
844     uplevel 1 chop_counted def
845     uplevel 1 chop_counted image
846     uplevel 1 chop_counted key
847     uplevel 1 chop_counted val
848
849     return [uplevel 1 {list $dict $def $image}]
850 }
851
852 proc approve_compare {fd1 fd2} {
853     manyset $fd1 file data; set sv1 [approve_decompose_data $data]
854     manyset $fd2 file data; set sv2 [approve_decompose_data $data]
855     return [string compare $sv1 $sv2]
856 }
857
858 proc approve_showentry {ix file specdata} {
859     global approve_ixes
860     
861     approve_decompose_data $specdata
862
863     set wb .app.e$ix
864
865     frame $wb-inf
866     label $wb-inf.who -text $pirate
867
868     entry $wb-inf.file -font fixed -relief flat
869     $wb-inf.file insert end [file tail $file]
870     $wb-inf.file configure -state readonly -width -1
871
872     pack $wb-inf.who $wb-inf.file -side top
873
874     frame $wb-def
875     label $wb-def.scope -text "$dict $ctx"
876     label $wb-def.def -text $def
877     pack $wb-def.scope $wb-def.def -side bottom
878
879     set ppm [exec pnmscale 2 << $image]
880     image create photo approve/$ix -data $ppm
881     label $wb-image -image approve/$ix -bd 2 -relief sunken
882
883     frame $wb-act
884     button $wb-act.rej -text Reject -command [list approve_reject $ix]
885     pack $wb-act.rej
886
887     grid $wb-def $wb-image $wb-act $wb-inf -padx 3
888     grid configure $wb-image -ipadx 3 -ipady 3 -sticky w
889
890     lappend approve_ixes $ix
891 }
892
893 proc approve_approve_reject_one {ix yesno} {
894     global approve_list server
895     manyset [lindex $approve_list $ix] file tdata
896     approve_decompose_data $tdata
897     puts_server "take $yesno $file $dict"
898     puts_counted $server pirate
899     puts_counted $server key
900     puts_counted $server val
901     puts_server confirmed
902     flush $server
903     must_gets_exactly_server done
904 }
905
906 proc approve_check_server {} {
907     global server
908     puts_server noop
909     flush $server
910     must_gets_exactly_server ok
911 }
912
913 proc approve_reject {ix} {
914     approve_check_server
915     approve_approve_reject_one $ix 0
916     approve_fetch_list
917 }
918
919 proc approve_these {} {
920     global approve_ixes
921     approve_check_server
922     foreach ix $approve_ixes { approve_approve_reject_one $ix 1 }
923     approve_fetch_list
924 }
925
926 proc approve_fetch_list {} {
927     global server approve_list
928     set approve_list {}
929     puts_server list
930     flush $server
931     while 1 {
932         must_gets_server more
933         switch -exact $more {
934             yes { }
935             end { break }
936             default { error "$more ?" }
937         }
938         must_gets_server file
939         read_counted $server data
940         lappend approve_list [list $file $data]
941     }
942
943     if {![llength $approve_list]} { puts "Nothing (more) to approve."; exit 0 }
944
945     set approve_list [lsort -command approve_compare $approve_list]
946     approve_show_page 0
947 }
948
949 proc main/approve {} {
950     global argv server remoteserv_banner data approve_list approve_page
951     global userhost directory dictdir debug
952
953     if {[llength $argv] != 3} { error "wrong # args" }
954     manyset $argv userhost directory dictdir
955     set cmd [list tclsh $directory/dictionary-manager]
956     if {$debug} { lappend cmd --debug-server }
957     lappend cmd --remote-server-1 $directory $dictdir
958     switch -glob $userhost {
959         {} { }
960         {* *} { set cmd $userhost }
961         * { set cmd [append [list ssh $userhost] $cmd] }
962     }
963     lappend cmd 2>@ stderr
964     set server [open |$cmd r+]
965     must_gets_exactly_server $remoteserv_banner
966
967     button .left -text {<<} -command {approve_show_page -1}
968     button .right -text {>>} -command {approve_show_page +1}
969
970     label .title -text {}
971     frame .app -bd 2 -relief groove
972     button .ok -text "Approve These" -command approve_these
973     pack .title .app -side top
974     pack .left -side left
975     pack .right -side right
976     pack .ok -side bottom
977
978     set approve_page 0
979     approve_fetch_list
980 }
981
982 proc approve_show_page {delta} {
983     global approve_page approve_ixes approve_list userhost directory dictdir
984
985     eval destroy [winfo children .app]
986     set approve_ixes {}
987
988     set per_page 10
989     incr approve_page $delta
990
991     set ll [llength $approve_list]
992     set npages [expr {($ll+$per_page-1)/$per_page}]
993     if {$approve_page >= $npages} { incr approve_page -1 }
994
995     set page_start [expr {$approve_page*$per_page}]
996     set page_end [expr {$page_start+$per_page-1}]
997     
998     for {set ix $page_start} {$ix < $ll && $ix <= $page_end} {incr ix} {
999         set fd [lindex $approve_list $ix]
1000         eval approve_showentry $ix $fd
1001     }
1002
1003     .title configure -text \
1004  "$userhost\n$directory => $dictdir\nPage [expr {$approve_page+1}]/$npages"
1005
1006     .left configure -state disabled
1007     .right configure -state disabled
1008     if {$approve_page>0} { .left configure -state normal }
1009     if {$approve_page<$npages-1} { .right configure -state normal }
1010 }
1011
1012 #========== main program ==========
1013
1014 proc main/default {} {
1015     puts stderr "Do not run this program directly."
1016     exit 12
1017 }
1018 proc done/default {} {
1019 }
1020
1021 proc required {} {
1022     global reqkind
1023
1024     fileevent stdin readable {}
1025     fconfigure stdin -blocking yes
1026     
1027     if {[gets stdin reqkind]<0} {
1028         if {[eof stdin]} { fconfigure stdin -blocking yes; exit 0 }
1029         return
1030     }
1031     init_widgets
1032
1033     required/$reqkind
1034 }
1035
1036 proc main/automatic {} {
1037     fconfigure stdin -blocking no
1038     fileevent stdin readable required
1039 }
1040 proc done/automatic {} {
1041     exec sh -c {printf \\0 >&4}
1042     main/automatic
1043 }
1044
1045 proc debug {m} { }
1046
1047 set mainkind default
1048 set ai 0
1049 set debug 0
1050 foreach arg $argv {
1051     incr ai
1052     switch -exact -- $arg {
1053         {--debug}           { set debug 1 }
1054         {--debug-server}    { proc debug {m} { puts stderr "DICT-MGR-SVR $m" }}
1055         {--noop-arg}        { }
1056         {--approve-updates} { set mainkind approve; break }
1057         {--automatic-1}     { set mainkind automatic; break }
1058         {--remote-server-1} { set mainkind remoteserv; break }
1059         {--automatic*} - {--remote-server}
1060                             { error "incompatible versions - install problem" }
1061         default             { error "huh $argv ?" }
1062     }
1063 }
1064 if {$debug} {
1065     proc debug {m} { puts stderr "DICT-MGR $m" }
1066 }
1067 set argv [lrange $argv $ai end]
1068
1069 debug [exec printenv]
1070 main/$mainkind