X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?p=ypp-sc-tools.web-live.git;a=blobdiff_plain;f=pctb%2Fdictionary-manager;h=5e108a7ea72583e29a958ac60027dac37f73f845;hp=f15c99ed731f63016fd8c6b0b48fbd00e077645c;hb=d44517d863e2336f82299f7d3f5fcb68a84fe595;hpb=f9e9ccb00d5761e861ead0795c711f595d8db3ff diff --git a/pctb/dictionary-manager b/pctb/dictionary-manager index f15c99e..5e108a7 100755 --- a/pctb/dictionary-manager +++ b/pctb/dictionary-manager @@ -25,6 +25,13 @@ # sponsored by Three Rings. +# ./dictionary-manager --approve-updates ijackson@login.chiark.greenend.org.uk /home/ijackson/things/ypp-sc-tools.pctb-dict/pctb /home/ftp/users/ijackson/pctb + +# ./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 + +# ./dictionary-manager --approve-updates '' . . + + # invocation: # OUT OF DATE # run this without args @@ -35,6 +42,9 @@ # if it wrote a byte to fd 4, it can take another question +set aadepth 2 + + #---------- library routines ---------- proc manyset {list args} { @@ -49,11 +59,39 @@ proc must_gets {f lvar} { if {[gets $f l] < 0} { error "huh?" } } +proc must_gets_imagel {f lvar} { + global debug_rect + upvar 1 $lvar l + must_gets $f l + if {$debug_rect} { debug "<< $l" } +} + +proc must_gets_exactly {f expected} { + must_gets $f got + if {[string compare $expected $got]} { error "$expected $got ?" } +} + proc read_counted {f var} { - upvar 1 $var var + upvar 1 $var val must_gets $f count - set var [read $f $count] - if {[eof $f]} { error ? } + set val [read $f $count] + must_gets $f eol + if {[string length $eol]} { error "$eol ?" } + debug "READ_COUNTED $count $var" +} + +proc puts_counted {f dvar} { + upvar 1 $dvar d + set count [string length $d] + puts $f $count + puts $f $d + debug "PUTS_COUNTED $count $dvar" +} + +proc bgerror {m} { + global errorCode errorInfo + puts stderr "ERROR: $m\n[list $errorCode]\n$errorInfo\n"; + exit 16 } #---------- display core ---------- @@ -70,17 +108,23 @@ proc init_widgets {} { global csrh gotsh ctxh if {[winfo exists .d]} return + + frame .privacy -bd 2 -relief groove + pack .privacy -side top -padx 2 -pady 2 -fill x + + upload_init - frame .d + frame .d -pady 2 -padx 2 -bg black -bd 2 -relief sunken image create bitmap image/main - label .d.mi -image image/main -borderwidth 0 + label .d.mi -image image/main -bd 0 frame .d.csr -bg black -height $csrh frame .d.got -bg black -height $gotsh frame .d.ctx -bg black - image create bitmap image/cursor -data \ + image create bitmap image/cursor -foreground white -background black \ + -data \ {#define csr_width 11 #define csr_height 11 static unsigned char csr_bits[] = { @@ -89,31 +133,35 @@ static unsigned char csr_bits[] = { } frame .d.csr.csr - label .d.csr.csr.l -image image/cursor -compound left + label .d.csr.csr.l -image image/cursor -compound left -fg white -bg black entry .d.csr.csr.e -bd 0 pack .d.csr.csr.l -side left + frame .selctx -bd 2 -relief groove frame .d.mi.csr_0 -bg white -width 1 frame .d.mi.csr_1 -bg white -width 1 - frame .d.pe - frame .d.pe.grid - button .d.pe.ok -text OK - pack .d.pe.grid .d.pe.ok -side left + frame .pe + frame .pe.grid + + button .pe.ok -text OK + pack .pe.grid .pe.ok -side left + bind .pe.ok { .pe.ok invoke } - pack .d.mi .d.ctx -side top - pack .d + pack .d.mi .d.ctx -side top -anchor w + pack .d -fill x -padx 2 -pady 2 - frame .help - pack .help + frame .help -bd 2 -relief groove + pack .help -pady 2 -padx 2 } proc resize_widgets_core {} { - global mulcols mulrows csrh gotsh ctxh glyphsdone + global mulcols mulrows csrh gotsh ctxh global unk_l unk_contexts foreach w {.d.csr .d.got .d.ctx} { $w configure -width $mulcols } + .d.csr configure -width [expr {$mulcols+150}] eval destroy [winfo children .d.ctx] } @@ -128,7 +176,7 @@ proc helptext {t} { set x 0; foreach c $l { set w .help.at${x}x${y} label $w -text $c - grid $w -row $y -column $x -padx 5 + grid $w -row $y -column $x -padx 5 -sticky w incr x } incr y @@ -138,12 +186,14 @@ proc helptext {t} { proc bind_key {k proc} { global keybindings - bind . $proc + bind .d $proc set keybindings($k) [expr {!![string length $proc]}] + .d configure -takefocus 1 } proc unbind_all_keys {} { global keybindings foreach k [array names keybindings] { bind_key $k {} } + .d configure -takefocus 0 } #---------- database read and write common wrapper ---------- @@ -161,7 +211,7 @@ proc read_database {fn} { set database_fn $fn if {![file exists $database_fn]} return set f [open $database_fn r] - if {[string compare [db_getsl $f] $magic]} { error "$l $reqkind ?" } + if {[string compare [db_getsl $f] $magic]} { error "$magic $reqkind ?" } read_database_header/$reqkind $f while 1 { @@ -180,7 +230,7 @@ proc write_database {} { global reqkind database_fn database upvar #0 database_magic/$reqkind magic - set f [open $database_fn.new w] + set f [open $database_fn.tmp w] puts $f $magic write_database_header/$reqkind $f @@ -194,39 +244,84 @@ proc write_database {} { } puts $f "." close $f - file rename -force $database_fn.new $database_fn + file rename -force $database_fn.tmp $database_fn +} + +proc select_database {dbname_spec} { + global dbname + set dbname $dbname_spec + read_database "./#local-$dbname#.txt" } +proc do_database_update {im def} { + global database + maybe_upload_entry $im $def + set database($im) $def + write_database +} + proc required/char {} { - global mulrows glyphsdone unk_l unk_r unk_contexts rows + global mulrows glyphsdone unk_l unk_r unk_contexts rows new_context + global all_contexts debug_rect must_gets stdin l + debug "GOT $l" manyset [lrange $l 0 3] unk_l unk_r unk_contexts set glyphsdone [lrange $l 3 end] - debug "GOT $l" - char_read_xpm stdin + char_read_pgm stdin + + catch { unset all_contexts } resize_widgets_core foreach w {0 1} { .d.mi.csr_$w configure -height $mulrows } set maxh 0 - foreach {min max contexts got} $glyphsdone { - show_context maxh $min $contexts + foreach {min max context contexts got} $glyphsdone { + show_context maxh $min $context + foreach ctx $contexts { set all_contexts($ctx) 1 } } + foreach ctx $unk_contexts { set all_contexts($ctx) 1 } + + eval destroy [winfo children .selctx] + label .selctx.title -text \ + {Select match context for altering dictionary:} + pack .selctx.title -side left + set new_context {} + + set ci 0; foreach ctx [lsort [array names all_contexts]] { + set all_contexts($ctx) $ci + set selw .selctx.c$ci + set seltxt $ctx + radiobutton $selw -variable new_context -value $ctx -text $seltxt + pack $selw -side left + incr ci + } + $selw configure -text "$seltxt." + label .selctx.warning -text {See README.charset.} + pack .selctx.warning -side left + show_context maxh $unk_l $unk_contexts .d.ctx configure -height $maxh - pack forget .d.pe - pack .d.csr -side top -before .d.mi - pack .d.got .d.ctx -side top -after .d.mi - - read_database ./charset-$rows.txt + pack forget .pe + pack .selctx -before .d -padx 2 -fill x + pack .d.csr -side top -before .d.mi -anchor w + pack .d.got .d.ctx -side top -after .d.mi -anchor w + pack configure .selctx -fill x + focus .d + + select_database char$rows draw_glyphsdone startup_cursor } +proc approve_showentry_xinfo/char {w def} { + set unic [string2unicodenames $def] + label $w -text $unic +} + #========== PIXMAPS ========== #---------- pixmap database read and write ---------- @@ -270,41 +365,51 @@ proc pixmap_select {ncol} { debug "PIX SELECT $ncol [llength $alloptions]" foreach_pixmap_col col { if {$col==$ncol} continue - .d.pe.grid.l$col selection clear 0 end + .pe.grid.l$col selection clear 0 end + } + if {[pixmap_maybe_ok]} { + focus .pe.ok } - pixmap_maybe_ok } proc pixmap_maybe_ok {} { global alloptions pixmap_selcol pixmap_selrow set nsel 0 foreach_pixmap_col col { - set cs [.d.pe.grid.l$col curselection] - incr nsel [llength $cs] + set cs [.pe.grid.l$col curselection] + set lcs [llength $cs] + if {!$lcs} continue + incr nsel $lcs set pixmap_selcol $col set pixmap_selrow [lindex $cs 0] } if {$nsel==1} { - .d.pe.ok configure -state normal -command pixmap_ok + debug "MAYBE_OK YES col=$pixmap_selcol row=$pixmap_selrow." + .pe.ok configure -state normal -command pixmap_ok + return 1 } else { - .d.pe.ok configure -state disabled -command {} + .pe.ok configure -state disabled -command {} + return 0 } } proc pixmap_ok {} { global database ppm pixmap_selcol pixmap_selrow mainkind alloptions + + return_result_start foreach_pixmap_col col { - .d.pe.grid.l$col configure -state disabled + .pe.grid.l$col configure -state disabled } - .d.pe.ok configure -state disabled - helptext {{{ Processing }}} + .pe.ok configure -state disabled + manyset [lrange $alloptions [expr {$pixmap_selcol*3}] end] \ colname coldesc rows manyset [lrange $rows [expr {$pixmap_selrow*2}] end] \ rowname rowdesc set result "$colname - $rowname" debug "UPDATE PIXMAP AS >$result<" - set database($ppm) $result - write_database - done/$mainkind + + do_database_update $ppm $result + + return_result_finish } proc required/pixmap {} { @@ -313,16 +418,18 @@ proc required/pixmap {} { debug "GOT pixmap $unk_what" set ppm {} while 1 { - must_gets stdin ppml + must_gets_imagel stdin ppml if {![string length $ppml]} break append ppm $ppml "\n" } - set data [exec pnmscale 2 << $ppm] - image create photo image/main -data $data + set tmpfile ./#dictimage#.tmp + exec pnmscale 2 << $ppm >$tmpfile + image create photo image/main -file $tmpfile + file delete $tmpfile - set alloptions [exec ./yppsc-resolver-pixoptions $unk_what] + set alloptions [exec ./database-info-fetch $unk_what] - read_database ./pixmaps.txt + select_database pixmap set mulcols [image width image/main] set mulrows [image height image/main] @@ -330,138 +437,276 @@ proc required/pixmap {} { place forget .d.mi.csr_0 place forget .d.mi.csr_1 - pack forget .d.csr .d.got - pack .d.pe -side top -before .d.mi -pady 10 + pack forget .selctx .d.csr .d.got + pack .pe -side top -before .d -pady 2 + .d configure -takefocus 0 + #-pady 2 -fill x - eval destroy [winfo children .d.pe.grid] + eval destroy [winfo children .pe.grid] set col 0; foreach {colname coldesc rows} $alloptions { debug "INIT $col $colname \"$coldesc\"" - label .d.pe.grid.t$col -text $colname - listbox .d.pe.grid.l$col + label .pe.grid.t$col -text $colname + listbox .pe.grid.l$col foreach {rowname rowdesc} $rows { debug "INIT $col $colname \"$coldesc\" $rowname \"$rowdesc\"" - .d.pe.grid.l$col insert end $rowdesc + .pe.grid.l$col insert end $rowdesc } - bind .d.pe.grid.l$col <> [list pixmap_select $col] - grid .d.pe.grid.t$col -column $col -row 0 - grid .d.pe.grid.l$col -column $col -row 1 + bind .pe.grid.l$col <> [list pixmap_select $col] + grid .pe.grid.t$col -column $col -row 0 + grid .pe.grid.l$col -column $col -row 1 incr col } pixmap_maybe_ok helptext { - {{Indicate the correct parse of this image, and click OK.}} + {{Indicate the meaning of this image; then click OK or hit Return.}} + } +} + +proc approve_showentry_xinfo/pixmap {w def} { + label $w -image image/empty +} + +#========== UPLOADS TO DICTIONARY SERVER ========== + +proc upload_init {} { + global privacy_setting + + set privacy_setting [upload_status] + + label .privacy.warn -text " Privacy " + if {$privacy_setting} { + .privacy.warn configure -background yellow -foreground black + } + label .privacy.overall -text " Upload new dictionary entry:" + label .privacy.reference -text " See README.privacy." + + pack .privacy.warn .privacy.overall -side left + + foreach {setting string} { + 0 {No} + 1 {Yes, anonymously} + 2 {Yes, quoting my pirate name.} + } { + radiobutton .privacy.o$setting -text $string \ + -value $setting -variable privacy_setting + pack .privacy.o$setting -side left + if {$setting > $privacy_setting} { + .privacy.o$setting configure -state disabled + } + } + pack .privacy.reference -side left + + if {!$privacy_setting} { + foreach w [winfo children .privacy] { + $w configure -state disabled + } + } + if {$privacy_setting} { + package require http + ::http::config -urlencoding utf-8 + } +} + +proc upload_status {} { + # returns 0, 1, 2 for none, anon, with pirate name + global env + + if {![info exists env(YPPSC_PCTB_DICT_SUBMIT)]} { debug a; return 0 } + if {![string compare 0 $env(YPPSC_PCTB_DICT_SUBMIT)]} { debug b; return 0 } + + if {![info exists env(YPPSC_PIRATE)]} { return 1 } + if {![info exists env(YPPSC_OCEAN)]} { return 1 } + if {![string length $env(YPPSC_PIRATE)]} { return 1 } + if {![string length $env(YPPSC_OCEAN)]} { return 1 } + + return 2 +} + +proc maybe_upload_entry {im def} { + global reqkind privacy_setting env dbname quiet aadepth + + debug "DB-UPDATE PRIVACY $privacy_setting" + if {!$privacy_setting} return + + debug "DB-UPDATE UPLOADING" + + set pl {} + lappend pl dict $dbname + lappend pl version 3 + lappend pl depth $aadepth + + if {$privacy_setting>=2} { + set pirate [string totitle $env(YPPSC_PIRATE)] + set ocean [string totitle $env(YPPSC_OCEAN)] + debug "DB-UPDATE NON-ANON $ocean $pirate" + lappend pl \ + pirate $pirate \ + ocean $ocean + } + lappend pl entry [format_database_entry/$reqkind $im $def] + + set url $env(YPPSC_PCTB_DICT_SUBMIT) + append url dictionary-update-receiver + + set query [eval ::http::formatQuery $pl] + regsub -all {%0d} $query {} query + debug "DB-UPDATE QUERY $query" + + if {[regexp {^\.?/} $url]} { + set cmd [list $url $query] + debug "SUBMIT CMD [string range $cmd 0 200]..." + set body [eval exec $cmd 2>@ stderr] + regsub {^Content-Type: text/plain.*\n\n} $body {} body + } else { + + if {[catch { + set req [::http::geturl $url -query $query] + } emsg]} { + puts stderr \ + "\nWARNING: Cannot do dictionary upload: $emsg\n" + return + } + upvar #0 $req s + debug "DB-UPDATE DONE $req $s(status) [array names s]" + set ncode [::http::ncode $req] + + if {!(![string compare ok $s(status)] && + ![string compare 200 $ncode])} { + set m "\nWARNING: Dictionary upload failed:" + foreach v {status http error posterror} { + if {[info exists s($v)]} { append m "\n $v: $s($v)" } + } + puts stderr $m + return + } + set body $s(body) + ::http::cleanup $req + } + + if {![string match {OK *} $body]} { + set m "\nWARNING: Dictionary upload went wrong:\n" + append m "\n " [join [split $body "\n"] "\n "] + puts stderr $m + return + } + + if {!$quiet} { + puts stderr \ + "Uploaded $dbname `$def': $body" } } #========== CHARACTER SET ========== -#---------- xpm input processor ---------- +#---------- pgm input processor ---------- -proc char_read_xpm {f} { +proc char_read_pgm {f} { global glyphsdone mul inter rhsmost_max unk_l unk_r mulcols mulrows - global cols rows wordmap + global cols rows charkey - set o {} - set y -3 - while 1 { - must_gets $f l - if {![regexp {^"(.*)",$} $l dummy l]} { - append o "$l\n" - if {[regexp {^\}\;$} $l]} break - continue - } - if {$y==-3} { - manyset $l cols rows colours cpp - if {$colours!=2 || $cpp!=1} { error "$l ?" } - - set chop_l [expr {$unk_l - 80}] - set chop_r [expr {$cols - $unk_l - 100}] - if {$chop_l<0} { set chop_l 0 } - - set unk_l [expr {$unk_l - $chop_l}] - set unk_r [expr {$unk_r - $chop_l}] - set ngd {} - foreach {min max contexts got} $glyphsdone { - lappend ngd \ - [expr {$min-$chop_l}] \ - [expr {$max-$chop_l}] \ - $contexts $got - } - set glyphsdone $ngd + must_gets_imagel $f l + if {[string compare $l P2]} { error "magic $l ?" } - set realcols $cols - set cols [expr {$cols - $chop_l - $chop_r}] - debug "NOW cols=$cols chop_l,r=$chop_l,$chop_r rows=$rows\ + must_gets_imagel $f l + if {![regexp {^([1-9]\d{0,3}) ([1-9]\d{0,3}) ([1-9]\d?)$} \ + $l dummy cols rows maxval]} { error "head $l ?" } + + for {set depth 1} {$maxval != (1<<$depth)-1} {incr depth} { + if {$depth >= 16} { error "maxval $maxval ?" } + } + + set chop_l [expr {$unk_l - 80}] + set chop_r [expr {$cols - $unk_l - 100}] + if {$chop_l<0} { set chop_l 0 } + if {$chop_r<0} { set chop_r 0 } + + set unk_l [expr {$unk_l - $chop_l}] + set unk_r [expr {$unk_r - $chop_l}] + set ngd {} + foreach {min max context contexts got} $glyphsdone { + lappend ngd \ + [expr {$min-$chop_l}] \ + [expr {$max-$chop_l}] \ + $context $contexts $got + } + set glyphsdone $ngd + + set realcols $cols + set cols [expr {$cols - $chop_l - $chop_r}] + debug "NOW cols=$cols chop_l,r=$chop_l,$chop_r rows=$rows\ $unk_l $unk_r $ngd" - - set mulcols [expr {$cols*$mul+$inter}] - set mulrows [expr {$rows*$mul+$inter}] - append o "\"$mulcols $mulrows 9 1\",\n" - for {set x 0} {$x<$cols} {incr x} { set wordmap($x) 0 } - } elseif {$y==-2} { # first pixel - append o \ -"\"+ c #111\", -\"a c #800\", -\"A c #fcc\", -\"b c #00c\", -\"B c #fff\", -\"u c #000\", -\"U c #ff0\", -\"q c #000\", -\"Q c #ff0\",\n" - } elseif {$y==-1} { # 2nd pixel but we've already printed ours - } else { - set ybit [expr {1<<$y}] - set x 0 - set ol "\"+" - set olh $ol - if {$chop_r>=0} { - set l [string range $l $chop_l end-$chop_r] + + set mulcols [expr {$cols*$mul+$inter}] + set mulrows [expr {$rows*$mul+$inter}] + + set o "P3\n$mulcols $mulrows 15\n" + + for {set x 0} {$x<$cols} {incr x} { set charkey($x) {} } + + set ointer1 " 1 1 1" + set ointer [string repeat $ointer1 $inter] + set ointerl "[string repeat $ointer1 $mulcols]\n" + + append o $ointerl + + for {set y 0} {$y<$rows} {incr y} { + must_gets_imagel $f l + if {[llength $l] != $realcols} { error "realcols=$realcols $l ?" } + + set ol $ointer + + for {set x 0} {$x<$cols} {incr x} { + set realx [expr {$x + $chop_l}] + set c [lindex $l $realx] + append charkey($x) [format %x $c] + + set how "u" + if {$x >= $unk_l && $x <= $unk_r} { + set how q } else { - set l [string range $l $chop_l end] - append l [string repeat " " [expr -$chop_r]] - } - foreach c [split $l ""] { - set how "u" - if {$x >= $unk_l && $x <= $unk_r} { - set how q - } else { - set ab 0 - foreach {min max contexts got} $glyphsdone { - set rhsmost_max $max - if {$x >= $min && $x <= $max} { - set how [lindex {a b} $ab] - break - } - set ab [expr {!$ab}] - } - } - switch -exact $c { - " " { set p $how } - "o" { - set p [string toupper $how] - incr wordmap($x) $ybit + set ab 0 + foreach {min max context contexts got} $glyphsdone { + set rhsmost_max $max + if {$x >= $min && $x <= $max} { + set how [lindex {a b} $ab] + break } - default { error "$c ?" } + set ab [expr {!$ab}] } - append ol "[string repeat $p [expr {$mul-$inter}]][ - string repeat + $inter]" - append olh [string repeat + $mul] - incr x } - set ole "\",\n" - append ol $ole - append olh $ole - set olhn [string repeat $olh $inter] - if {!$y} { append o $olhn } - append o [string repeat $ol [expr {$mul-1}]] - append o $olhn + set c15 [expr {$c << (16-$depth)}] + set c15 [expr {$c15 | ($c15 >> $depth)}] + set c15 [expr {$c15 | ($c15 >> $depth*2)}] + set c15 [expr {$c15 >> 12}] + + foreach rgb {r g b} { set $rgb {$c15} } + switch -exact $how { + a { set r {$c15>>1 | 0x8} } + b { set b {$c15>>2 | 0xc} } + u { set b 0 } + q { set b 0 } + default { error "how $how ?" } + } +#debug "PIXEL $x,$y how=$how c=$c c15=$c15 $r $g $b" + + set opixel " " + foreach rgb {r g b} { + append opixel [format " %2d" [expr [set $rgb]]] + } + append ol [string repeat $opixel [expr {$mul-$inter}]] + append ol $ointer } - incr y + append ol "\n" + append o [string repeat $ol [expr {$mul-$inter}]] + append o $ointerl } - set data [exec xpmtoppm << $o] - image create photo image/main -data $data + + debug "DATA1 $o" + set tmpfile ./#dictimage#.tmp + exec pnmscale 1 << $o >$tmpfile + image create photo image/main -file $tmpfile + file delete $tmpfile } #---------- character set editor display ---------- @@ -480,7 +725,7 @@ proc show_context {maxhv x ctxs} { proc draw_glyphsdone {} { global glyphsdone mul inter eval destroy [winfo children .d.got] - foreach {min max contexts got} $glyphsdone { + foreach {min max context contexts got} $glyphsdone { frame .d.got.m$min -bd 0 -background \#888 label .d.got.m$min.l -text "$got" -fg white -bg black -bd 0 pack .d.got.m$min.l -padx 1 -pady 1 @@ -492,8 +737,8 @@ proc startup_cursor {} { global cur_already cur_mode cur_0 cur_1 last_ht global glyphsdone unk_l unk_r - set cur_already [expr {[llength $glyphsdone]/4-1}] - set cur_mode 1 ;# one of: 0 1 already text + set cur_already [expr {[llength $glyphsdone]/5-1}] + set cur_mode 0 ;# one of: 0 1 already text set cur_0 $unk_l set cur_1 [expr {$unk_r+1}] @@ -503,34 +748,65 @@ proc startup_cursor {} { #---------- character set runtime display and keystroke handling ---------- +proc char_exactly_selctxts {contexts} { + global all_contexts + foreach ctx [array names all_contexts] { + set ci $all_contexts($ctx) + set selw .selctx.c$ci + if {[lsearch -exact $contexts $ctx]>=0} { + set state normal + } else { + set state disabled + } + $selw configure -state $state + } +} + proc recursor/0 {} { recursor//01 0 } proc recursor/1 {} { recursor//01 1 } proc recursor//01 {z1} { - global mul rhsmost_max cols glyphsdone + global mul rhsmost_max cols glyphsdone cur_0 cur_1 + global all_contexts upvar #0 cur_$z1 cur - .d.csr.csr.l configure -text {adjust} + .d.csr.csr.l configure -text "adjust [char_get_definition_context_actual]" place .d.csr.csr -x [expr {$cur*$mul - 7}] + + set okctxts [char_get_definition_contexts] + char_exactly_selctxts $okctxts + + foreach ctx [lsort [array names all_contexts]] { + set key [string range $ctx 0 0] + if {[lsearch -exact $okctxts $ctx] >= 0} { + bind_key [string tolower $key] " + [list set new_context $ctx] + char_start_define_text + " + } else { + bind_key [string tolower $key] {} + } + lappend context_help $key + } + set context_help [list [join $context_help " "] \ + {Set match context for new glyph, confirm location, and start entry.}] + bind_key space { othercursor } bind_leftright_q cur_$z1 0 [expr {$cols-1}] if {[llength $glyphsdone]} { - bind_key Tab { set cur_mode already; recursor } + bind_key BackSpace { set cur_mode already; recursor } } else { - bind_key Tab {} + bind_key BackSpace {} } bind_key Return { - if {$cur_0 != $cur_1} { - .d.csr.csr.e delete 0 end - set cur_mode text - recursor - } - } - helptext { - {{<- ->} {move cursor, adjusting area to define}} - {Space {switch to moving other cursor}} - {Return {confirm location, enter letter(s)}} - {Tab {switch to correcting earlier ocr}} - {Q {quit and abandon OCR run}} + char_start_define_text } + helptext [list \ + {{<- ->} {move cursor, adjusting area to define}} \ + {Space {switch to moving other cursor}} \ + {Return {confirm location, enter letter(s)}} \ + {Backspace {switch to correcting earlier ocr}} \ + {Q {quit and abandon OCR run}} \ + $context_help \ + ] } proc othercursor {} { global cur_mode @@ -538,50 +814,64 @@ proc othercursor {} { recursor } +proc char_start_define_text {} { + global cur_0 cur_1 cur_mode + if {$cur_0 == $cur_1} return + set cdgdca [char_get_definition_context_actual] + if {![string length $cdgdca]} return + .d.csr.csr.e delete 0 end + set cur_mode text + .d.csr.csr.l configure -text "define $cdgdca:" + recursor +} + proc recursor/text {} { + global all_contexts + helptext { {Return {confirm entry of new glyph}} {Escape {abandon entry}} } unbind_all_keys - .d.csr.csr.l configure -text {define:} - pack .d.csr.csr.e -side left + pack .d.csr.csr.e -side left -padx 2 focus .d.csr.csr.e - bind_key Return { + bind .d.csr.csr.e { set strq [.d.csr.csr.e get] - if {[regexp {^(?:[!-[]|[]-~]|\\\\|\\x[0-9a-f]{2})+} $strq]} { - RETURN_RESULT DEFINE "$cur_0 $cur_1 $strq" + if {[string length $strq]} { + RETURN_RESULT DEFINE [list $strq] } } - bind_key Escape { + bind .d.csr.csr.e { bind_key Escape {} pack forget .d.csr.csr.e set cur_mode 1 + focus .d recursor } } proc recursor/already {} { global mul - global glyphsdone global cur_already mul global glyphsdone cur_already mul + + char_exactly_selctxts [lindex $glyphsdone [expr {$cur_already*5+2}]] + .d.csr.csr.l configure -text {correct} - set rmax [lindex $glyphsdone [expr {$cur_already*4}]] + set rmax [lindex $glyphsdone [expr {$cur_already*5}]] place .d.csr.csr -x [expr {$rmax*$mul-3}] bind_key Return {} - bind_key space {} - bind_leftright_q cur_already 0 [expr {[llength $glyphsdone]/4-1}] - bind_key Tab { bind_key Delete {}; set cur_mode 1; recursor } + bind_leftright_q cur_already 0 [expr {[llength $glyphsdone]/5-1}] + bind_key space { bind_key Delete {}; set cur_mode 1; recursor } bind_key Delete { RETURN_RESULT DELETE [lrange $glyphsdone \ - [expr $cur_already*4] \ - [expr $cur_already*4+2]] + [expr $cur_already*5] \ + [expr $cur_already*5+2]] } helptext { {{<- ->} {move cursor, selecting glyph to correct}} {Del {clear this glyph from the recognition database}} - {Tab {switch to selecting area to define as new glyph}} + {Space {switch to selecting area to define as new glyph}} {Q {quit and abandon OCR run}} } } @@ -622,11 +912,12 @@ proc recursor {} { # $database($context 0x 0x...) = $hex -set database_magic/char {# ypp-sc-tools pctb font v1} +set database_magic/char "# ypp-sc-tools pctb font v3 depth=$aadepth" proc read_database_header/char {f} { global rows - if {([db_getsl $f])+0 != $rows} { error "wrong h ?" } + set l [db_getsl $f] + if {$l+0 != $rows} { error "wrong h $l $rows ?" } } proc read_database_entry/char {f context} { global database @@ -635,12 +926,13 @@ proc read_database_entry/char {f context} { while 1 { set l [db_getsl $f] if {![string length $l]} break - lappend bm [format %x 0x$l] + lappend bm $l } set database($bm) $strq } proc write_database_header/char {f} { + global rows puts $f "$rows\n" } proc format_database_entry/char {bm strq} { @@ -651,62 +943,100 @@ proc format_database_entry/char {bm strq} { } proc dbkey {ctx l r} { - global wordmap + global charkey set bm $ctx for {set x $l} {$x <= $r} {incr x} { - lappend bm [format %x $wordmap($x)] + lappend bm $charkey($x) } return $bm } -proc update_database/DEFINE {c0 c1 strq} { - global glyphsdone unk_l unk_contexts wordmap database - if {$c0 > $c1} { manyset [list $c0 $c1] c1 c0 } +proc char_get_definition_cursors {} { + global cur_0 cur_1 + if {$cur_0 <= $cur_1} { + set cl $cur_0; set cr $cur_1 + } else { + set cl $cur_1; set cr $cur_0 + } + incr cr -1 + debug "CGD CURSORS $cl $cr" + return [list $cl $cr] +} + +proc char_get_definition_contexts {} { + global glyphsdone unk_l unk_contexts database + + manyset [char_get_definition_cursors] c0 c1 + if {$c0 == $unk_l} { set ncontexts $unk_contexts } else { - foreach {l r contexts got} $glyphsdone { + foreach {l r context contexts got} $glyphsdone { if {$l==$c0} { set ncontexts $contexts; break } } if {![info exists ncontexts]} { - puts stderr "must start at letter LHS!" - return + set ncontexts {} } } - incr c1 -1 - foreach c $ncontexts { - set bm [dbkey $c $c0 $c1] - set database($bm) $strq + debug "CGD CONTEXTS $ncontexts" + return $ncontexts +} + +proc char_get_definition_context_actual {} { + global new_context + set ncontexts [char_get_definition_contexts] + if {[llength $ncontexts]==1} { + set c [lindex $ncontexts 0] + } elseif {[lsearch -exact $ncontexts $new_context]>=0} { + set c $new_context + } else { + set c {} } - write_database + debug "CDG CONTEXT ACTUAL $c FROM NEW $new_context ALLOW $ncontexts" + return $c +} + +proc update_database/DEFINE {strq} { + manyset [char_get_definition_cursors] c0 c1 + set c [char_get_definition_context_actual] + if {![string length $c]} { + error "Selected context is not one of the many possibilities." + } + debug "DEFINE $strq" + set bm [dbkey $c $c0 $c1] + do_database_update $bm $strq } proc update_database/DELETE {l r ctxs} { global database + if {[llength $ctxs]!=1} { error "$ctxs ?" } foreach ctx $ctxs { set bm [dbkey $ctx $l $r] catch { unset database($bm) } } write_database } - + proc RETURN_RESULT {how what} { - global mainkind + return_result_start + place forget .d.csr.csr pack forget .d.csr.csr.e - helptext {{{ Processing }}} - unbind_all_keys - update idletasks + debug "$how $what" eval update_database/$how $what - done/$mainkind + + return_result_finish } #========== server for approving updates ========== -proc remote-serv-log {pirate event} { +proc remote-serv-log {dict pirate caller file event} { + global remoteserv_logf set t [clock format [clock seconds] -format {%Y-%m-%d %H:%M:%S %Z}] - set s [format "%s %15s %s" $t $pirate $event] + set s [format "%s %-6s %-31s %-31s %s %s\n" \ + $t $dict $pirate $caller [file tail $file] $event] + puts -nonewline $remoteserv_logf $s } proc remote-serv/list {} { @@ -717,41 +1047,335 @@ proc remote-serv/list {} { set f [open $file] set d [read $f] close $f - puts [string length $d] - puts -nonewline $d + puts_counted stdout d } puts end } -proc remote-serv/take {f args} { - global dropdir rows reqkind +proc remote-serv/take {yesno file dict} { + global dropdir dictdir rows reqkind database set rows "" - manyset $args yesno file pirate reqkind rows - read_counted stdin desc + debug "TAKE [list $yesno $file $dict]" + read_counted stdin pirate + read_counted stdin caller read_counted stdin key read_counted stdin val + + must_gets_exactly stdin confirmed + + manyset [dict2_reqkind_rows $dict] reqkind rows + if {$yesno} { - read_database + read_database $dictdir/master-$dict.txt set database($key) $val write_database + set desc approve + } else { + set desc reject } - set ar [lindex {reject approve} $yesno] - remote-serv-log $pirate "$ar $reqkind $rows $desc" - file remove $file + remote-serv-log $dict $pirate $caller $file "$desc $reqkind $rows" + file delete -force $file + + puts done +} + +proc remote-serv/noop {} { + puts ok } +set remoteserv_banner {ypp-sc-tools pctb remote-server v1} + proc main/remoteserv {} { - global argv dropdir - manyset $argv dropdir + global argv dropdir remoteserv_banner remoteserv_logf dictdir + manyset $argv dropdir dictdir + puts $remoteserv_banner + set remoteserv_logf [open $dropdir/_dict.log a] + fconfigure $remoteserv_logf -buffering line while 1 { - puts {ypp-sc-tools pctb remote-server v1} + flush stdout if {[gets stdin l] < 0} break eval remote-serv/$l } } +#========== updates approver ========== + +proc puts_server {s} { + global server + debug ">> $s" + puts $server $s +} +proc must_gets_server {lv} { + upvar 1 $lv l + global server + must_gets $server l + debug "<< $l" +} + +proc must_gets_exactly_server {expected} { + must_gets_server got + if {[string compare $expected $got]} { error "$expected $got ?" } +} + +proc regsub-data {exp subspec args} { + global data + if {![eval regsub $args -- [list $exp $data $subspec data]]} { + error "$exp >$data< ?" + } +} + +proc dict2_reqkind_rows {dict} { + if {![string compare pixmap $dict]} { + return {pixmap {}} + debug "DICT PIXMAP" + } elseif {[regexp {^(char)([1-9]\d*)$} $dict dummy reqkind rows]} { + debug "DICT CHAR rqk=$reqkind r=$rows." + return [list $reqkind $rows] + } else { + error "$dict ?" + } +} + +proc chop_counted {var} { + upvar 1 $var val + global data + if {![regexp {^(0|[1-9]\d*)\n} $data dummy l]} { error "$data ?" } + regsub-data {^.*\n} {} -line + set val [string range $data 0 [expr {$l-1}]] + set data [string range $data $l end] + debug "CHOP_COUNTED $l $var" + regsub-data {^\n} {} +} + +proc approve_decompose_data {specdata} { + global data aadepth + set data $specdata + + regsub-data "^ypp-sc-tools dictionary update v3 depth=$aadepth\\n" {} + uplevel 1 chop_counted pirate + uplevel 1 chop_counted caller + uplevel 1 chop_counted dict + uplevel 1 chop_counted ctx + uplevel 1 chop_counted def + uplevel 1 chop_counted image + uplevel 1 chop_counted key + uplevel 1 chop_counted val + + return [uplevel 1 {list $dict $ctx $def $image}] +} + +proc approve_compare {fd1 fd2} { + manyset $fd1 file data; set sv1 [approve_decompose_data $data] + manyset $fd2 file data; set sv2 [approve_decompose_data $data] + return [string compare $sv1 $sv2] +} + +proc string2unicodenames {str} { + return [exec perl -e { + use Unicode::CharName qw(uname); + $ARGV[0] =~ s/^ //; + foreach $_ (split //,$ARGV[0]) { + print uname(ord),"\n" or die $! + } + } " $str"] +} + +proc approve_showentry {ix file specdata} { + global approve_ixes reqkind approve_entryhow + + approve_decompose_data $specdata + + set wb .app.e$ix + + frame $wb-inf + label $wb-inf.who -text $pirate + + entry $wb-inf.file -font fixed -relief flat + $wb-inf.file insert end [file tail $file] + $wb-inf.file configure -state readonly -width -1 + + pack $wb-inf.who $wb-inf.file -side top + + frame $wb-def + label $wb-def.scope -text "$dict $ctx" + label $wb-def.def -text $def + pack $wb-def.scope $wb-def.def -side bottom + + if {[regexp {^P2} $image]} { + set image [exec pgmtoppm {#008-white} << $image | pnmnoraw] + append image "\n" + } + set image [exec pnmscale 2 << $image] + + image create photo approve/$ix -data $image + label $wb-image -image approve/$ix -bd 2 -relief flat -bg black + + manyset [dict2_reqkind_rows $dict] reqkind + approve_showentry_xinfo/$reqkind $wb-xinfo $def + + if {$ix} { + label $wb-div -bd 1 -relief sunken -image image/empty + grid configure $wb-div -columnspan 5 -sticky ew -padx 5 + } + + frame $wb-act -bd 2 -relief groove + set approve_entryhow($ix) approve + foreach how {approve reject defer} { + set w $wb-act.$how + radiobutton $w -variable approve_entryhow($ix) \ + -text [string totitle $how] -value $how + pack $w -side left + } + + grid $wb-def $wb-image $wb-xinfo $wb-act $wb-inf -padx 3 + grid configure $wb-image -ipadx 3 -ipady 3 -sticky w + + lappend approve_ixes $ix +} + +proc approve_approve_reject_one {ix yesno} { + global approve_list server + manyset [lindex $approve_list $ix] file tdata + approve_decompose_data $tdata + puts_server "take $yesno $file $dict" + puts_counted $server pirate + puts_counted $server caller + puts_counted $server key + puts_counted $server val + puts_server confirmed + flush $server + must_gets_exactly_server done +} + +proc approve_check_server {} { + global server + puts_server noop + flush $server + must_gets_exactly_server ok +} + +proc approve_confirm {} { + global approve_ixes approve_entryhow + .ok configure -state disabled + update idletasks + approve_check_server + foreach ix $approve_ixes { + set how $approve_entryhow($ix) + switch -exact $how { + approve { approve_approve_reject_one $ix 1 } + reject { approve_approve_reject_one $ix 0 } + defer { } + default { error $how? } + } + } + approve_fetch_list +} + +proc approve_fetch_list {} { + global server approve_list + set approve_list {} + puts_server list + flush $server + while 1 { + must_gets_server more + switch -exact $more { + yes { } + end { break } + default { error "$more ?" } + } + must_gets_server file + read_counted $server data + lappend approve_list [list $file $data] + } + + if {![llength $approve_list]} { puts "Nothing (more) to approve."; exit 0 } + + set approve_list [lsort -command approve_compare $approve_list] + approve_show_page 0 + .ok configure -state normal +} + +proc main/approve {} { + global argv server remoteserv_banner data approve_list approve_page + global userhost directory dictdir debug + + if {[llength $argv] != 3} { error "wrong # args" } + manyset $argv userhost directory dictdir + debug "APPROVER FOR $userhost $directory $dictdir" + + set cmd [list tclsh $directory/dictionary-manager] + if {$debug} { lappend cmd --debug-server } + lappend cmd --remote-server-1 $directory $dictdir + switch -glob $userhost { + {} { } + {* *} { set cmd $userhost } + * { set cmd [concat [list ssh -o compression=yes $userhost] $cmd] } + } + debug "APPROVER RUNS $cmd" + + lappend cmd 2>@ stderr + set server [open |$cmd r+] + must_gets_exactly_server $remoteserv_banner + + button .left -text {<<} -command {approve_show_page -1} + button .right -text {>>} -command {approve_show_page +1} + + label .title -text {} + frame .app -bd 2 -relief groove + button .ok -text "Confirm" -command approve_confirm + pack .title .app -side top + pack .left -side left + pack .right -side right + pack .ok -side bottom + + image create bitmap image/empty + + set approve_page 0 + approve_fetch_list +} + +proc approve_show_page {delta} { + global approve_page approve_ixes approve_list userhost directory dictdir + + eval destroy [winfo children .app] + set approve_ixes {} + + set per_page 10 + incr approve_page $delta + + set ll [llength $approve_list] + set npages [expr {($ll+$per_page-1)/$per_page}] + if {$approve_page >= $npages} { incr approve_page -1 } + + set page_start [expr {$approve_page*$per_page}] + set page_end [expr {$page_start+$per_page-1}] + + for {set ix $page_start} {$ix < $ll && $ix <= $page_end} {incr ix} { + set fd [lindex $approve_list $ix] + eval approve_showentry $ix $fd + } + + .title configure -text \ + "$userhost\n$directory => $dictdir\nPage [expr {$approve_page+1}]/$npages" + + .left configure -state disabled + .right configure -state disabled + if {$approve_page>0} { .left configure -state normal } + if {$approve_page<$npages-1} { .right configure -state normal } +} + #========== main program ========== +proc return_result_start {} { + helptext {{{ Processing }}} + unbind_all_keys + update idletasks +} +proc return_result_finish {} { + global mainkind + done/$mainkind +} + proc main/default {} { puts stderr "Do not run this program directly." exit 12 @@ -787,18 +1411,28 @@ proc debug {m} { } set mainkind default set ai 0 +set debug 0 +set debug_rect 0 +set quiet 0 foreach arg $argv { incr ai switch -exact -- $arg { - {--debug} { proc debug {m} { puts stderr "SHOW-THING $m" } } + {--quiet} { set quiet 1 } + {--debug} { set debug 1 } + {--debug-rect} { set debug_rect 1 } + {--debug-server} { proc debug {m} { puts stderr "DICT-MGR-SVR $m" }} {--noop-arg} { } - {--automatic-1} { set mainkind automatic } + {--approve-updates} { set mainkind approve; break } + {--automatic-1} { set mainkind automatic; break } {--remote-server-1} { set mainkind remoteserv; break } {--automatic*} - {--remote-server} { error "incompatible versions - install problem" } default { error "huh $argv ?" } } } +if {$debug} { + proc debug {m} { puts stderr "DICT-MGR $m" } +} set argv [lrange $argv $ai end] main/$mainkind