3 # helper program for OCR in PCTB upload client
5 # This is part of ypp-sc-tools, a set of third-party tools for assisting
6 # players of Yohoho Puzzle Pirates.
8 # Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
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.
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.
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/>.
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.
30 # run this without args
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
38 #---------- library routines ----------
40 proc manyset {list args} {
41 foreach val $list var $args {
47 proc must_gets {f lvar} {
49 if {[gets $f l] < 0} { error "huh?" }
52 proc read_counted {f var} {
55 set var [read $f $count]
56 if {[eof $f]} { error ? }
59 #---------- display core ----------
68 proc init_widgets {} {
70 global csrh gotsh ctxh
72 if {[winfo exists .d]} return
76 image create bitmap image/main
77 label .d.mi -image image/main -borderwidth 0
79 frame .d.csr -bg black -height $csrh
80 frame .d.got -bg black -height $gotsh
81 frame .d.ctx -bg black
83 image create bitmap image/cursor -data \
86 static unsigned char csr_bits[] = {
87 0x20, 0x00, 0x20, 0x00, 0x20, 0x00, 0x21, 0x04, 0x22, 0x02, 0x25, 0x05,
88 0xaa, 0x02, 0x74, 0x01, 0xa8, 0x00, 0x70, 0x00, 0x20, 0x00};
92 label .d.csr.csr.l -image image/cursor -compound left
93 entry .d.csr.csr.e -bd 0
94 pack .d.csr.csr.l -side left
96 frame .d.mi.csr_0 -bg white -width 1
97 frame .d.mi.csr_1 -bg white -width 1
100 button .d.pe.ok -text OK
101 pack .d.pe.grid .d.pe.ok -side left
103 pack .d.mi .d.ctx -side top
110 proc resize_widgets_core {} {
111 global mulcols mulrows csrh gotsh ctxh glyphsdone
112 global unk_l unk_contexts
114 foreach w {.d.csr .d.got .d.ctx} {
115 $w configure -width $mulcols
118 eval destroy [winfo children .d.ctx]
125 if {![string compare $t $last_ht]} return
126 eval destroy [grid slaves .help]
127 set y 0; foreach l $t {
128 set x 0; foreach c $l {
129 set w .help.at${x}x${y}
131 grid $w -row $y -column $x -padx 5
139 proc bind_key {k proc} {
141 bind . <Key-$k> $proc
142 set keybindings($k) [expr {!![string length $proc]}]
144 proc unbind_all_keys {} {
146 foreach k [array names keybindings] { bind_key $k {} }
149 #---------- database read and write common wrapper ----------
152 if {[gets $f l] < 0} { error "unexpected db eof" }
156 proc read_database {fn} {
157 global reqkind database database_fn
158 upvar #0 database_magic/$reqkind magic
159 catch { unset database }
162 if {![file exists $database_fn]} return
163 set f [open $database_fn r]
164 if {[string compare [db_getsl $f] $magic]} { error "$l $reqkind ?" }
166 read_database_header/$reqkind $f
170 if {![string length $l1]} continue
171 if {[regexp {^\#} $l1]} continue
172 if {![string compare . $l1]} break
174 read_database_entry/$reqkind $f $l1
179 proc write_database {} {
180 global reqkind database_fn database
181 upvar #0 database_magic/$reqkind magic
183 set f [open $database_fn.new w]
186 write_database_header/$reqkind $f
189 foreach bm [array names database] {
190 lappend ol [format_database_entry/$reqkind $bm $database($bm)]
192 foreach o [lsort $ol] {
197 file rename -force $database_fn.new $database_fn
200 proc required/char {} {
201 global mulrows glyphsdone unk_l unk_r unk_contexts rows
205 manyset [lrange $l 0 3] unk_l unk_r unk_contexts
206 set glyphsdone [lrange $l 3 end]
213 .d.mi.csr_$w configure -height $mulrows
216 foreach {min max contexts got} $glyphsdone {
217 show_context maxh $min $contexts
219 show_context maxh $unk_l $unk_contexts
220 .d.ctx configure -height $maxh
222 pack .d.csr -side top -before .d.mi
223 pack .d.got .d.ctx -side top -after .d.mi
225 read_database ./charset-$rows.txt
230 #========== PIXMAPS ==========
232 #---------- pixmap database read and write ----------
234 set database_magic/pixmap {# ypp-sc-tools pctb pixmaps v1}
236 proc read_database_header/pixmap {f} { }
237 proc read_database_entry/pixmap {f def} {
242 set p3 [db_getsl $f]; append im $p3 "\n"
243 if {[string compare $p3 P3]} { error "$p3 ?" }
245 set wh [db_getsl $f]; append im $wh "\n"; manyset $wh w h
246 set depth [db_getsl $f]; append im $depth "\n"
248 for {set y 0} {$y < $h} {incr y} {
249 set line [db_getsl $f]; append im $line "\n"
251 set database($im) $def
253 proc write_database_header/pixmap {f} { puts $f "" }
254 proc format_database_entry/pixmap {im def} {
258 #---------- pixmap display and input handling ----------
260 proc foreach_pixmap_col {var body} {
263 for {set col 0} {$col < [llength $alloptions]/3} {incr col} {
268 proc pixmap_select {ncol} {
270 debug "PIX SELECT $ncol [llength $alloptions]"
271 foreach_pixmap_col col {
272 if {$col==$ncol} continue
273 .d.pe.grid.l$col selection clear 0 end
277 proc pixmap_maybe_ok {} {
278 global alloptions pixmap_selcol pixmap_selrow
280 foreach_pixmap_col col {
281 set cs [.d.pe.grid.l$col curselection]
282 incr nsel [llength $cs]
283 set pixmap_selcol $col
284 set pixmap_selrow [lindex $cs 0]
287 .d.pe.ok configure -state normal -command pixmap_ok
289 .d.pe.ok configure -state disabled -command {}
293 global database ppm pixmap_selcol pixmap_selrow mainkind alloptions
294 foreach_pixmap_col col {
295 .d.pe.grid.l$col configure -state disabled
297 .d.pe.ok configure -state disabled
298 helptext {{{ Processing }}}
299 manyset [lrange $alloptions [expr {$pixmap_selcol*3}] end] \
301 manyset [lrange $rows [expr {$pixmap_selrow*2}] end] \
303 set result "$colname - $rowname"
304 debug "UPDATE PIXMAP AS >$result<"
305 set database($ppm) $result
310 proc required/pixmap {} {
311 global unk_what ppm mulcols alloptions
312 must_gets stdin unk_what
313 debug "GOT pixmap $unk_what"
317 if {![string length $ppml]} break
318 append ppm $ppml "\n"
320 set data [exec pnmscale 2 << $ppm]
321 image create photo image/main -data $data
323 set alloptions [exec ./yppsc-resolver-pixoptions $unk_what]
325 read_database ./pixmaps.txt
327 set mulcols [image width image/main]
328 set mulrows [image height image/main]
330 place forget .d.mi.csr_0
331 place forget .d.mi.csr_1
333 pack forget .d.csr .d.got
334 pack .d.pe -side top -before .d.mi -pady 10
336 eval destroy [winfo children .d.pe.grid]
337 set col 0; foreach {colname coldesc rows} $alloptions {
338 debug "INIT $col $colname \"$coldesc\""
339 label .d.pe.grid.t$col -text $colname
340 listbox .d.pe.grid.l$col
341 foreach {rowname rowdesc} $rows {
342 debug "INIT $col $colname \"$coldesc\" $rowname \"$rowdesc\""
343 .d.pe.grid.l$col insert end $rowdesc
345 bind .d.pe.grid.l$col <<ListboxSelect>> [list pixmap_select $col]
346 grid .d.pe.grid.t$col -column $col -row 0
347 grid .d.pe.grid.l$col -column $col -row 1
353 {{Indicate the correct parse of this image, and click OK.}}
357 #========== CHARACTER SET ==========
359 #---------- xpm input processor ----------
361 proc char_read_xpm {f} {
362 global glyphsdone mul inter rhsmost_max unk_l unk_r mulcols mulrows
363 global cols rows wordmap
369 if {![regexp {^"(.*)",$} $l dummy l]} {
371 if {[regexp {^\}\;$} $l]} break
375 manyset $l cols rows colours cpp
376 if {$colours!=2 || $cpp!=1} { error "$l ?" }
378 set chop_l [expr {$unk_l - 80}]
379 set chop_r [expr {$cols - $unk_l - 100}]
380 if {$chop_l<0} { set chop_l 0 }
382 set unk_l [expr {$unk_l - $chop_l}]
383 set unk_r [expr {$unk_r - $chop_l}]
385 foreach {min max contexts got} $glyphsdone {
387 [expr {$min-$chop_l}] \
388 [expr {$max-$chop_l}] \
394 set cols [expr {$cols - $chop_l - $chop_r}]
395 debug "NOW cols=$cols chop_l,r=$chop_l,$chop_r rows=$rows\
398 set mulcols [expr {$cols*$mul+$inter}]
399 set mulrows [expr {$rows*$mul+$inter}]
400 append o "\"$mulcols $mulrows 9 1\",\n"
401 for {set x 0} {$x<$cols} {incr x} { set wordmap($x) 0 }
402 } elseif {$y==-2} { # first pixel
413 } elseif {$y==-1} { # 2nd pixel but we've already printed ours
415 set ybit [expr {1<<$y}]
420 set l [string range $l $chop_l end-$chop_r]
422 set l [string range $l $chop_l end]
423 append l [string repeat " " [expr -$chop_r]]
425 foreach c [split $l ""] {
427 if {$x >= $unk_l && $x <= $unk_r} {
431 foreach {min max contexts got} $glyphsdone {
433 if {$x >= $min && $x <= $max} {
434 set how [lindex {a b} $ab]
443 set p [string toupper $how]
444 incr wordmap($x) $ybit
446 default { error "$c ?" }
448 append ol "[string repeat $p [expr {$mul-$inter}]][
449 string repeat + $inter]"
450 append olh [string repeat + $mul]
456 set olhn [string repeat $olh $inter]
457 if {!$y} { append o $olhn }
458 append o [string repeat $ol [expr {$mul-1}]]
463 set data [exec xpmtoppm << $o]
464 image create photo image/main -data $data
467 #---------- character set editor display ----------
469 proc show_context {maxhv x ctxs} {
473 if {[llength $ctxs]==1} { set fg blue } { set fg yellow }
474 label $w -bg black -fg $fg -text [join $ctxs "/\n"] -justify left
475 place $w -x [expr {($x-1)*$mul}] -y 0
476 set wh [winfo reqheight $w]
477 if {$wh > $maxh} { set maxh $wh }
480 proc draw_glyphsdone {} {
481 global glyphsdone mul inter
482 eval destroy [winfo children .d.got]
483 foreach {min max contexts got} $glyphsdone {
484 frame .d.got.m$min -bd 0 -background \#888
485 label .d.got.m$min.l -text "$got" -fg white -bg black -bd 0
486 pack .d.got.m$min.l -padx 1 -pady 1
487 place .d.got.m$min -x [expr {$min*$mul+$inter}] -y 0
491 proc startup_cursor {} {
492 global cur_already cur_mode cur_0 cur_1 last_ht
493 global glyphsdone unk_l unk_r
495 set cur_already [expr {[llength $glyphsdone]/4-1}]
496 set cur_mode 1 ;# one of: 0 1 already text
499 set cur_1 [expr {$unk_r+1}]
504 #---------- character set runtime display and keystroke handling ----------
506 proc recursor/0 {} { recursor//01 0 }
507 proc recursor/1 {} { recursor//01 1 }
508 proc recursor//01 {z1} {
509 global mul rhsmost_max cols glyphsdone
511 .d.csr.csr.l configure -text {adjust}
512 place .d.csr.csr -x [expr {$cur*$mul - 7}]
513 bind_key space { othercursor }
514 bind_leftright_q cur_$z1 0 [expr {$cols-1}]
515 if {[llength $glyphsdone]} {
516 bind_key Tab { set cur_mode already; recursor }
521 if {$cur_0 != $cur_1} {
522 .d.csr.csr.e delete 0 end
528 {{<- ->} {move cursor, adjusting area to define}}
529 {Space {switch to moving other cursor}}
530 {Return {confirm location, enter letter(s)}}
531 {Tab {switch to correcting earlier ocr}}
532 {Q {quit and abandon OCR run}}
535 proc othercursor {} {
537 set cur_mode [expr {!$cur_mode}]
541 proc recursor/text {} {
543 {Return {confirm entry of new glyph}}
544 {Escape {abandon entry}}
547 .d.csr.csr.l configure -text {define:}
548 pack .d.csr.csr.e -side left
551 set strq [.d.csr.csr.e get]
552 if {[regexp {^(?:[!-[]|[]-~]|\\\\|\\x[0-9a-f]{2})+} $strq]} {
553 RETURN_RESULT DEFINE "$cur_0 $cur_1 $strq"
558 pack forget .d.csr.csr.e
564 proc recursor/already {} {
567 global cur_already mul
568 global glyphsdone cur_already mul
569 .d.csr.csr.l configure -text {correct}
570 set rmax [lindex $glyphsdone [expr {$cur_already*4}]]
571 place .d.csr.csr -x [expr {$rmax*$mul-3}]
574 bind_leftright_q cur_already 0 [expr {[llength $glyphsdone]/4-1}]
575 bind_key Tab { bind_key Delete {}; set cur_mode 1; recursor }
577 RETURN_RESULT DELETE [lrange $glyphsdone \
578 [expr $cur_already*4] \
579 [expr $cur_already*4+2]]
582 {{<- ->} {move cursor, selecting glyph to correct}}
583 {Del {clear this glyph from the recognition database}}
584 {Tab {switch to selecting area to define as new glyph}}
585 {Q {quit and abandon OCR run}}
589 proc bind_leftright_q {var min max} {
590 bind_key Left [list leftright $var $min $max -1]
591 bind_key Right [list leftright $var $min $max +1]
593 puts stderr "\nCharacter resolver quitting as you requested."
597 proc leftright {var min max inc} {
601 if {$vnew < $min || $vnew > $max} return
607 global csrh cur_mode cur_0 cur_1 mul
609 place .d.mi.csr_$z1 -y 0 -x [expr {[set cur_$z1] * $mul}]
614 #---------- character database read and write ----------
619 # <context> <ncharacters> <hex>...
623 # $database($context 0x<bits> 0x<bits>...) = $hex
625 set database_magic/char {# ypp-sc-tools pctb font v1}
627 proc read_database_header/char {f} {
629 if {([db_getsl $f])+0 != $rows} { error "wrong h ?" }
631 proc read_database_entry/char {f context} {
634 set strq [db_getsl $f]
637 if {![string length $l]} break
638 lappend bm [format %x 0x$l]
640 set database($bm) $strq
643 proc write_database_header/char {f} {
646 proc format_database_entry/char {bm strq} {
648 set o "[lindex $bm 0]\n$strq\n"
649 foreach x [lrange $bm 1 end] { append o "$x\n" }
653 proc dbkey {ctx l r} {
656 for {set x $l} {$x <= $r} {incr x} {
657 lappend bm [format %x $wordmap($x)]
662 proc update_database/DEFINE {c0 c1 strq} {
663 global glyphsdone unk_l unk_contexts wordmap database
664 if {$c0 > $c1} { manyset [list $c0 $c1] c1 c0 }
666 set ncontexts $unk_contexts
668 foreach {l r contexts got} $glyphsdone {
669 if {$l==$c0} { set ncontexts $contexts; break }
671 if {![info exists ncontexts]} {
672 puts stderr "must start at letter LHS!"
677 foreach c $ncontexts {
678 set bm [dbkey $c $c0 $c1]
679 set database($bm) $strq
684 proc update_database/DELETE {l r ctxs} {
687 set bm [dbkey $ctx $l $r]
688 catch { unset database($bm) }
693 proc RETURN_RESULT {how what} {
695 place forget .d.csr.csr
696 pack forget .d.csr.csr.e
697 helptext {{{ Processing }}}
701 eval update_database/$how $what
705 #========== server for approving updates ==========
707 proc remote-serv-log {pirate event} {
708 set t [clock format [clock seconds] -format {%Y-%m-%d %H:%M:%S %Z}]
709 set s [format "%s %15s %s" $t $pirate $event]
712 proc remote-serv/list {} {
714 foreach file [glob -nocomplain -type f -directory $dropdir _update.*.rdy] {
720 puts [string length $d]
726 proc remote-serv/take {f args} {
727 global dropdir rows reqkind
729 manyset $args yesno file pirate reqkind rows
730 read_counted stdin desc
731 read_counted stdin key
732 read_counted stdin val
735 set database($key) $val
738 set ar [lindex {reject approve} $yesno]
739 remote-serv-log $pirate "$ar $reqkind $rows $desc"
743 proc main/remoteserv {} {
745 manyset $argv dropdir
747 puts {ypp-sc-tools pctb remote-server v1}
748 if {[gets stdin l] < 0} break
753 #========== main program ==========
755 proc main/default {} {
756 puts stderr "Do not run this program directly."
759 proc done/default {} {
765 fileevent stdin readable {}
766 fconfigure stdin -blocking yes
768 if {[gets stdin reqkind]<0} {
769 if {[eof stdin]} { fconfigure stdin -blocking yes; exit 0 }
777 proc main/automatic {} {
778 fconfigure stdin -blocking no
779 fileevent stdin readable required
781 proc done/automatic {} {
782 exec sh -c {printf \\0 >&4}
792 switch -exact -- $arg {
793 {--debug} { proc debug {m} { puts stderr "SHOW-THING $m" } }
795 {--automatic-1} { set mainkind automatic }
796 {--remote-server-1} { set mainkind remoteserv; break }
797 {--automatic*} - {--remote-server}
798 { error "incompatible versions - install problem" }
799 default { error "huh $argv ?" }
802 set argv [lrange $argv $ai end]