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 #---------- display core ----------
61 proc init_widgets {} {
63 global csrh gotsh ctxh
65 if {[winfo exists .d]} return
69 image create bitmap image/main
70 label .d.mi -image image/main -borderwidth 0
72 frame .d.csr -bg black -height $csrh
73 frame .d.got -bg black -height $gotsh
74 frame .d.ctx -bg black
76 image create bitmap image/cursor -data \
79 static unsigned char csr_bits[] = {
80 0x20, 0x00, 0x20, 0x00, 0x20, 0x00, 0x21, 0x04, 0x22, 0x02, 0x25, 0x05,
81 0xaa, 0x02, 0x74, 0x01, 0xa8, 0x00, 0x70, 0x00, 0x20, 0x00};
85 label .d.csr.csr.l -image image/cursor -compound left
86 entry .d.csr.csr.e -bd 0
87 pack .d.csr.csr.l -side left
89 frame .d.mi.csr_0 -bg white -width 1
90 frame .d.mi.csr_1 -bg white -width 1
93 button .d.pe.ok -text OK
94 pack .d.pe.grid .d.pe.ok -side left
96 pack .d.mi .d.ctx -side top
103 proc resize_widgets_core {} {
104 global mulcols mulrows csrh gotsh ctxh glyphsdone
105 global unk_l unk_contexts
107 foreach w {.d.csr .d.got .d.ctx} {
108 $w configure -width $mulcols
111 eval destroy [winfo children .d.ctx]
118 if {![string compare $t $last_ht]} return
119 eval destroy [grid slaves .help]
120 set y 0; foreach l $t {
121 set x 0; foreach c $l {
122 set w .help.at${x}x${y}
124 grid $w -row $y -column $x -padx 5
132 proc bind_key {k proc} {
134 bind . <Key-$k> $proc
135 set keybindings($k) [expr {!![string length $proc]}]
137 proc unbind_all_keys {} {
139 foreach k [array names keybindings] { bind_key $k {} }
142 #---------- database read and write common wrapper ----------
145 if {[gets $f l] < 0} { error "unexpected db eof" }
149 proc read_database {fn} {
150 global reqkind database database_fn
151 upvar #0 database_magic/$reqkind magic
152 catch { unset database }
155 if {![file exists $database_fn]} return
156 set f [open $database_fn r]
157 if {[string compare [db_getsl $f] $magic]} { error "$l $reqkind ?" }
159 read_database_header/$reqkind $f
163 if {![string length $l1]} continue
164 if {[regexp {^\#} $l1]} continue
165 if {![string compare . $l1]} break
167 read_database_entry/$reqkind $f $l1
172 proc write_database {} {
173 global reqkind database_fn database
174 upvar #0 database_magic/$reqkind magic
176 set f [open $database_fn.new w]
179 write_database_header/$reqkind $f
182 foreach bm [array names database] {
183 lappend ol [format_database_entry/$reqkind $bm $database($bm)]
185 foreach o [lsort $ol] {
190 file rename -force $database_fn.new $database_fn
193 proc required/char {} {
194 global mulrows glyphsdone unk_l unk_r unk_contexts rows
198 manyset [lrange $l 0 3] unk_l unk_r unk_contexts
199 set glyphsdone [lrange $l 3 end]
206 .d.mi.csr_$w configure -height $mulrows
209 foreach {min max contexts got} $glyphsdone {
210 show_context maxh $min $contexts
212 show_context maxh $unk_l $unk_contexts
213 .d.ctx configure -height $maxh
215 pack .d.csr -side top -before .d.mi
216 pack .d.got .d.ctx -side top -after .d.mi
218 read_database ./charset-$rows.txt
223 #========== PIXMAPS ==========
225 #---------- pixmap database read and write ----------
227 set database_magic/pixmap {# ypp-sc-tools pctb pixmaps v1}
229 proc read_database_header/pixmap {f} { }
230 proc read_database_entry/pixmap {f def} {
235 set p3 [db_getsl $f]; append im $p3 "\n"
236 if {[string compare $p3 P3]} { error "$p3 ?" }
238 set wh [db_getsl $f]; append im $wh "\n"; manyset $wh w h
239 set depth [db_getsl $f]; append im $depth "\n"
241 for {set y 0} {$y < $h} {incr y} {
242 set line [db_getsl $f]; append im $line "\n"
244 set database($im) $def
246 proc write_database_header/pixmap {f} { puts $f "" }
247 proc format_database_entry/pixmap {im def} {
251 #---------- pixmap display and input handling ----------
253 proc foreach_pixmap_col {var body} {
256 for {set col 0} {$col < [llength $alloptions]/3} {incr col} {
261 proc pixmap_select {ncol} {
263 debug "PIX SELECT $ncol [llength $alloptions]"
264 foreach_pixmap_col col {
265 if {$col==$ncol} continue
266 .d.pe.grid.l$col selection clear 0 end
270 proc pixmap_maybe_ok {} {
271 global alloptions pixmap_selcol pixmap_selrow
273 foreach_pixmap_col col {
274 set cs [.d.pe.grid.l$col curselection]
275 incr nsel [llength $cs]
276 set pixmap_selcol $col
277 set pixmap_selrow [lindex $cs 0]
280 .d.pe.ok configure -state normal -command pixmap_ok
282 .d.pe.ok configure -state disabled -command {}
286 global database ppm pixmap_selcol pixmap_selrow mainkind alloptions
287 foreach_pixmap_col col {
288 .d.pe.grid.l$col configure -state disabled
290 .d.pe.ok configure -state disabled
291 helptext {{{ Processing }}}
292 manyset [lrange $alloptions [expr {$pixmap_selcol*3}] end] \
294 manyset [lrange $rows [expr {$pixmap_selrow*2}] end] \
296 set result "$colname - $rowname"
297 debug "UPDATE PIXMAP AS >$result<"
298 set database($ppm) $result
303 proc required/pixmap {} {
304 global unk_what ppm mulcols alloptions
305 must_gets stdin unk_what
306 debug "GOT pixmap $unk_what"
310 if {![string length $ppml]} break
311 append ppm $ppml "\n"
313 set data [exec pnmscale 2 << $ppm]
314 image create photo image/main -data $data
316 set alloptions [exec ./yppsc-resolver-pixoptions $unk_what]
318 read_database ./pixmaps.txt
320 set mulcols [image width image/main]
321 set mulrows [image height image/main]
323 place forget .d.mi.csr_0
324 place forget .d.mi.csr_1
326 pack forget .d.csr .d.got
327 pack .d.pe -side top -before .d.mi -pady 10
329 eval destroy [winfo children .d.pe.grid]
330 set col 0; foreach {colname coldesc rows} $alloptions {
331 debug "INIT $col $colname \"$coldesc\""
332 label .d.pe.grid.t$col -text $colname
333 listbox .d.pe.grid.l$col
334 foreach {rowname rowdesc} $rows {
335 debug "INIT $col $colname \"$coldesc\" $rowname \"$rowdesc\""
336 .d.pe.grid.l$col insert end $rowdesc
338 bind .d.pe.grid.l$col <<ListboxSelect>> [list pixmap_select $col]
339 grid .d.pe.grid.t$col -column $col -row 0
340 grid .d.pe.grid.l$col -column $col -row 1
346 {{Indicate the correct parse of this image, and click OK.}}
350 #========== CHARACTER SET ==========
352 #---------- xpm input processor ----------
354 proc char_read_xpm {f} {
355 global glyphsdone mul inter rhsmost_max unk_l unk_r mulcols mulrows
356 global cols rows wordmap
362 if {![regexp {^"(.*)",$} $l dummy l]} {
364 if {[regexp {^\}\;$} $l]} break
368 manyset $l cols rows colours cpp
369 if {$colours!=2 || $cpp!=1} { error "$l ?" }
371 set chop_l [expr {$unk_l - 80}]
372 set chop_r [expr {$cols - $unk_l - 100}]
373 if {$chop_l<0} { set chop_l 0 }
375 set unk_l [expr {$unk_l - $chop_l}]
376 set unk_r [expr {$unk_r - $chop_l}]
378 foreach {min max contexts got} $glyphsdone {
380 [expr {$min-$chop_l}] \
381 [expr {$max-$chop_l}] \
387 set cols [expr {$cols - $chop_l - $chop_r}]
388 debug "NOW cols=$cols chop_l,r=$chop_l,$chop_r rows=$rows\
391 set mulcols [expr {$cols*$mul+$inter}]
392 set mulrows [expr {$rows*$mul+$inter}]
393 append o "\"$mulcols $mulrows 9 1\",\n"
394 for {set x 0} {$x<$cols} {incr x} { set wordmap($x) 0 }
395 } elseif {$y==-2} { # first pixel
406 } elseif {$y==-1} { # 2nd pixel but we've already printed ours
408 set ybit [expr {1<<$y}]
413 set l [string range $l $chop_l end-$chop_r]
415 set l [string range $l $chop_l end]
416 append l [string repeat " " [expr -$chop_r]]
418 foreach c [split $l ""] {
420 if {$x >= $unk_l && $x <= $unk_r} {
424 foreach {min max contexts got} $glyphsdone {
426 if {$x >= $min && $x <= $max} {
427 set how [lindex {a b} $ab]
436 set p [string toupper $how]
437 incr wordmap($x) $ybit
439 default { error "$c ?" }
441 append ol "[string repeat $p [expr {$mul-$inter}]][
442 string repeat + $inter]"
443 append olh [string repeat + $mul]
449 set olhn [string repeat $olh $inter]
450 if {!$y} { append o $olhn }
451 append o [string repeat $ol [expr {$mul-1}]]
456 set data [exec xpmtoppm << $o]
457 image create photo image/main -data $data
460 #---------- character set editor display ----------
462 proc show_context {maxhv x ctxs} {
466 if {[llength $ctxs]==1} { set fg blue } { set fg yellow }
467 label $w -bg black -fg $fg -text [join $ctxs "/\n"] -justify left
468 place $w -x [expr {($x-1)*$mul}] -y 0
469 set wh [winfo reqheight $w]
470 if {$wh > $maxh} { set maxh $wh }
473 proc draw_glyphsdone {} {
474 global glyphsdone mul inter
475 eval destroy [winfo children .d.got]
476 foreach {min max contexts got} $glyphsdone {
477 frame .d.got.m$min -bd 0 -background \#888
478 label .d.got.m$min.l -text "$got" -fg white -bg black -bd 0
479 pack .d.got.m$min.l -padx 1 -pady 1
480 place .d.got.m$min -x [expr {$min*$mul+$inter}] -y 0
484 proc startup_cursor {} {
485 global cur_already cur_mode cur_0 cur_1 last_ht
486 global glyphsdone unk_l unk_r
488 set cur_already [expr {[llength $glyphsdone]/4-1}]
489 set cur_mode 1 ;# one of: 0 1 already text
492 set cur_1 [expr {$unk_r+1}]
497 #---------- character set runtime display and keystroke handling ----------
499 proc recursor/0 {} { recursor//01 0 }
500 proc recursor/1 {} { recursor//01 1 }
501 proc recursor//01 {z1} {
502 global mul rhsmost_max cols glyphsdone
504 .d.csr.csr.l configure -text {adjust}
505 place .d.csr.csr -x [expr {$cur*$mul - 7}]
506 bind_key space { othercursor }
507 bind_leftright_q cur_$z1 0 [expr {$cols-1}]
508 if {[llength $glyphsdone]} {
509 bind_key Tab { set cur_mode already; recursor }
514 if {$cur_0 != $cur_1} {
515 .d.csr.csr.e delete 0 end
521 {{<- ->} {move cursor, adjusting area to define}}
522 {Space {switch to moving other cursor}}
523 {Return {confirm location, enter letter(s)}}
524 {Tab {switch to correcting earlier ocr}}
525 {Q {quit and abandon OCR run}}
528 proc othercursor {} {
530 set cur_mode [expr {!$cur_mode}]
534 proc recursor/text {} {
536 {Return {confirm entry of new glyph}}
537 {Escape {abandon entry}}
540 .d.csr.csr.l configure -text {define:}
541 pack .d.csr.csr.e -side left
544 set strq [.d.csr.csr.e get]
545 if {[regexp {^(?:[!-[]|[]-~]|\\\\|\\x[0-9a-f]{2})+} $strq]} {
546 RETURN_RESULT DEFINE "$cur_0 $cur_1 $strq"
551 pack forget .d.csr.csr.e
557 proc recursor/already {} {
560 global cur_already mul
561 global glyphsdone cur_already mul
562 .d.csr.csr.l configure -text {correct}
563 set rmax [lindex $glyphsdone [expr {$cur_already*4}]]
564 place .d.csr.csr -x [expr {$rmax*$mul-3}]
567 bind_leftright_q cur_already 0 [expr {[llength $glyphsdone]/4-1}]
568 bind_key Tab { bind_key Delete {}; set cur_mode 1; recursor }
570 RETURN_RESULT DELETE [lrange $glyphsdone \
571 [expr $cur_already*4] \
572 [expr $cur_already*4+2]]
575 {{<- ->} {move cursor, selecting glyph to correct}}
576 {Del {clear this glyph from the recognition database}}
577 {Tab {switch to selecting area to define as new glyph}}
578 {Q {quit and abandon OCR run}}
582 proc bind_leftright_q {var min max} {
583 bind_key Left [list leftright $var $min $max -1]
584 bind_key Right [list leftright $var $min $max +1]
586 puts stderr "\nCharacter resolver quitting as you requested."
590 proc leftright {var min max inc} {
594 if {$vnew < $min || $vnew > $max} return
600 global csrh cur_mode cur_0 cur_1 mul
602 place .d.mi.csr_$z1 -y 0 -x [expr {[set cur_$z1] * $mul}]
607 #---------- character database read and write ----------
612 # <context> <ncharacters> <hex>...
616 # $database($context 0x<bits> 0x<bits>...) = $hex
618 set database_magic/char {# ypp-sc-tools pctb font v1}
620 proc read_database_header/char {f} {
622 if {([db_getsl $f])+0 != $rows} { error "wrong h ?" }
624 proc read_database_entry/char {f context} {
627 set strq [db_getsl $f]
630 if {![string length $l]} break
631 lappend bm [format %x 0x$l]
633 set database($bm) $strq
636 proc write_database_header/char {f} {
639 proc format_database_entry/char {bm strq} {
641 set o "[lindex $bm 0]\n$strq\n"
642 foreach x [lrange $bm 1 end] { append o "$x\n" }
646 proc dbkey {ctx l r} {
649 for {set x $l} {$x <= $r} {incr x} {
650 lappend bm [format %x $wordmap($x)]
655 proc update_database/DEFINE {c0 c1 strq} {
656 global glyphsdone unk_l unk_contexts wordmap database
657 if {$c0 > $c1} { manyset [list $c0 $c1] c1 c0 }
659 set ncontexts $unk_contexts
661 foreach {l r contexts got} $glyphsdone {
662 if {$l==$c0} { set ncontexts $contexts; break }
664 if {![info exists ncontexts]} {
665 puts stderr "must start at letter LHS!"
670 foreach c $ncontexts {
671 set bm [dbkey $c $c0 $c1]
672 set database($bm) $strq
677 proc update_database/DELETE {l r ctxs} {
680 set bm [dbkey $ctx $l $r]
681 catch { unset database($bm) }
686 proc RETURN_RESULT {how what} {
688 place forget .d.csr.csr
689 pack forget .d.csr.csr.e
690 helptext {{{ Processing }}}
694 eval update_database/$how $what
698 #========== main program ==========
700 proc main/default {} {
701 puts stderr "Do not run this program directly."
704 proc done/default {} {
710 fileevent stdin readable {}
711 fconfigure stdin -blocking yes
713 if {[gets stdin reqkind]<0} {
714 if {[eof stdin]} { fconfigure stdin -blocking yes; exit 0 }
722 proc main/automatic {} {
723 fconfigure stdin -blocking no
724 fileevent stdin readable required
726 proc done/automatic {} {
727 exec sh -c {printf \\0 >&4}
735 switch -exact -- $arg {
736 {--debug} { proc debug {m} { puts stderr "SHOW-THING $m" } }
738 {--automatic-1} { set mainkind automatic }
739 {--automatic*} { error "incompatible versions - install problem" }
740 default { error "huh $argv ?" }