X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?p=ypp-sc-tools.db-test.git;a=blobdiff_plain;f=pctb%2Fdictionary-manager;h=e7aaff5831520a1ca03c9a1d571ae9d257f566ab;hp=10c87a83c0ac7810f4700190d71a9d8f71e01fc0;hb=b05af1cf15783891b7fff50f516c19111edd07f7;hpb=12dab98558133719e1c624dd2d7bf7b5fa93ae07 diff --git a/pctb/dictionary-manager b/pctb/dictionary-manager index 10c87a8..e7aaff5 100755 --- a/pctb/dictionary-manager +++ b/pctb/dictionary-manager @@ -269,7 +269,7 @@ proc required/char {} { } foreach ctx $unk_contexts { set all_contexts($ctx) 1 } - destroy [winfo children .d.selctx] + eval destroy [winfo children .d.selctx] label .d.selctx.title -text \ {Select match context for altering dictionary:} pack .d.selctx.title -side left @@ -372,11 +372,13 @@ proc pixmap_maybe_ok {} { } 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 } .d.pe.ok configure -state disabled - helptext {{{ Processing }}} + manyset [lrange $alloptions [expr {$pixmap_selcol*3}] end] \ colname coldesc rows manyset [lrange $rows [expr {$pixmap_selrow*2}] end] \ @@ -385,7 +387,8 @@ proc pixmap_ok {} { debug "UPDATE PIXMAP AS >$result<" do_database_update $ppm $result - done/$mainkind + + return_result_finish } proc required/pixmap {} { @@ -401,7 +404,7 @@ proc required/pixmap {} { set data [exec pnmscale 2 << $ppm] image create photo image/main -data $data - set alloptions [exec ./dictionary-pixmap-options $unk_what] + set alloptions [exec ./database-info-fetch $unk_what] select_database pixmap @@ -736,12 +739,28 @@ proc recursor/0 {} { recursor//01 0 } proc recursor/1 {} { recursor//01 1 } proc recursor//01 {z1} { 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}] - manyset [char_get_definition_info $cur_0 $cur_1] contexts - char_exactly_selctxts $contexts + 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] + recursor + " + } else { + bind_key [string tolower $key] {} + } + lappend context_help $key + } + set context_help [list [join $context_help " "] \ + {Set match context for new glyph.}] bind_key space { othercursor } bind_leftright_q cur_$z1 0 [expr {$cols-1}] @@ -751,19 +770,16 @@ proc recursor//01 {z1} { 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)}} - {Backspace {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 @@ -771,6 +787,17 @@ 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 @@ -779,13 +806,12 @@ proc recursor/text {} { {Escape {abandon entry}} } unbind_all_keys - .d.csr.csr.l configure -text {define:} pack .d.csr.csr.e -side left focus .d.csr.csr.e bind .d.csr.csr.e { set strq [.d.csr.csr.e get] if {[string length $strq]} { - RETURN_RESULT DEFINE [list $cur_0 $cur_1 $strq] + RETURN_RESULT DEFINE [list $strq] } } bind .d.csr.csr.e { @@ -802,7 +828,7 @@ proc recursor/already {} { global cur_already mul global glyphsdone cur_already mul - char_exactly_selctxts [lindex $glyphsdone [expr {$cur_already*5+3}]] + char_exactly_selctxts [lindex $glyphsdone [expr {$cur_already*5+2}]] .d.csr.csr.l configure -text {correct} set rmax [lindex $glyphsdone [expr {$cur_already*5}]] @@ -897,11 +923,22 @@ proc dbkey {ctx l r} { return $bm } -proc char_get_definition_info {c0 c1} { - # => ncontexts cl cr +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 wordmap database - - if {$c0 > $c1} { manyset [list $c0 $c1] c1 c0 } + + manyset [char_get_definition_cursors] c0 c1 if {$c0 == $unk_l} { set ncontexts $unk_contexts @@ -913,43 +950,55 @@ proc char_get_definition_info {c0 c1} { set ncontexts {} } } - incr c1 -1 - set r [list $ncontexts $c0 $c1] - debug "CDGI $r" - return $r + debug "CGD CONTEXTS $ncontexts" + return $ncontexts } -proc update_database/DEFINE {c0 c1 strq} { - manyset [char_get_definition_info $c0 $c1] ncontexts c0 c1 - if {![llength $ncontexts]} { - puts stderr "must start at letter LHS!" - return +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 {} } - foreach c $ncontexts { - set bm [dbkey $c $c0 $c1] - do_database_update $bm $strq + 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 ========== @@ -986,7 +1035,7 @@ proc remote-serv/take {yesno file dict} { must_gets_exactly stdin confirmed - manyset [dict2_reqkind_rows reqkind rows] + manyset [dict2_reqkind_rows $dict] reqkind rows if {$yesno} { read_database $dictdir/master-$dict.txt @@ -1274,6 +1323,16 @@ proc approve_show_page {delta} { #========== 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