X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?p=ypp-sc-tools.db-live.git;a=blobdiff_plain;f=pctb%2Fshow-thing.tcl;h=440f9c6a13a0cc88b994e7bbfd7f76defb9d9dff;hp=0d2ec0c94ba202998858e3e539dc3673c3020bbf;hb=8787ee59f6840de63bac432b516a30d0dfe22c84;hpb=cd6a4f773c32f73aff27f97e8994c6b7c1019bb7 diff --git a/pctb/show-thing.tcl b/pctb/show-thing.tcl index 0d2ec0c..440f9c6 100755 --- a/pctb/show-thing.tcl +++ b/pctb/show-thing.tcl @@ -3,7 +3,7 @@ # usage: # run show-thing without args # then on stdin write -# one line which is a Tcl list for glyphsdone +# one line which is a Tcl list for unk_{l,r} unk_contexts glyphsdone # the xpm in the format expected # then expect child to raise SIGSTOP or exit 0 or exit nonzero # if child raised SIGSTOP, check database was updated @@ -24,10 +24,11 @@ set inter 1 set gotsh 20 set csrh 20 +set ctxh 20 proc init_widgets {} { # idempotent - global csrh gotsh + global csrh gotsh ctxh if {[winfo exists .d]} return @@ -38,6 +39,7 @@ proc init_widgets {} { 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 \ {#define csr_width 11 @@ -52,22 +54,54 @@ static unsigned char csr_bits[] = { entry .d.csr.csr.e -bd 0 pack .d.csr.csr.l -side left - frame .d.csr_0 -bg white -width 1 - frame .d.csr_1 -bg white -width 1 + frame .d.mi.csr_0 -bg white -width 1 + frame .d.mi.csr_1 -bg white -width 1 - place .d.csr -x 0 -y 0 - place .d.mi -x 0 -y $csrh + pack .d.csr .d.mi .d.got .d.ctx -side top pack .d frame .help pack .help } +proc show_context {maxhv x ctxs} { + global mul + upvar 1 $maxhv maxh + set w .d.ctx.at$x + if {[llength $ctxs]==1} { set fg blue } { set fg yellow } + label $w -bg black -fg $fg -text [join $ctxs "/\n "] + place $w -x [expr {$x*$mul}] -y 0 + set wh [winfo reqheight $w] + if {$wh > $maxh} { set maxh $wh } +} + +proc resize_widgets {} { + global mulcols mulrows csrh gotsh ctxh glyphsdone + global unk_l unk_contexts + + foreach w {.d.csr .d.got .d.ctx} { + $w configure -width $mulcols + } + #.d configure -height [expr {$csrh+$mulrows+$gotsh+$ctxh}] + foreach w {0 1} { + .d.mi.csr_$w configure -height $mulrows + } + + eval destroy [winfo children .d.ctx] + + set maxh 0 + foreach {min max context got} $glyphsdone { + show_context maxh $min [list $context] + } + show_context maxh $unk_l $unk_contexts + .d.ctx configure -height $maxh +} + #---------- xpm input processor ---------- proc read_xpm {f} { - global glyphsdone mul inter rhsmost_max unk_l unk_r gotsh csrh + global glyphsdone mul inter rhsmost_max unk_l unk_r mulcols mulrows global cols rows wordmap set o {} @@ -144,15 +178,6 @@ proc read_xpm {f} { } set data [exec xpmtoppm << $o] image create photo image/main -data $data - - foreach w {.d .d.csr .d.got} { - $w configure -width $mulcols - } - .d configure -height [expr {$csrh+$mulrows+$gotsh}] - foreach w {0 1} { - .d.csr_$w configure -height $mulrows - } - place .d.got -x 0 -y [expr {$csrh+$mulrows}] } @@ -245,9 +270,10 @@ proc recursor/text {} { pack .d.csr.csr.e -side left focus .d.csr.csr.e bind_key Return { - binary scan [.d.csr.csr.e get] H* hex - if {[string length $hex]} { - RETURN_RESULT DEFINE "$cur_0 $cur_1 $hex" + set strq [.d.csr.csr.e get] + if {[regexp {^(?:[!-[]|[]-~]|\\\\|\\x[0-9a-f]{2})+} $strq]} { + .d.csr.csr.e delete 0 end + RETURN_RESULT DEFINE "$cur_0 $cur_1 $strq" } } bind_key Escape { @@ -308,7 +334,7 @@ proc leftright {var min max inc} { proc recursor {} { global csrh cur_mode cur_0 cur_1 mul foreach z1 {0 1} { - place .d.csr_$z1 -y $csrh -x [expr {[set cur_$z1] * $mul}] + place .d.mi.csr_$z1 -y 0 -x [expr {[set cur_$z1] * $mul}] } recursor/$cur_mode } @@ -324,43 +350,55 @@ proc recursor {} { # $database($context 0x 0x...) = $hex +set database_header {# ypp-sc-tools pctb font v1} + +proc db_getsl {f} { + if {[gets $f l] < 0} { error "unexpected db eof" } + return $l +} + proc read_database {} { - global database - set f [open database r] - while {[gets $f l] >= 0} { - if {![regexp {^(\w+) (\d+) ((?:[0-9a-f]{2})+)$} $l \ - dummy context strl strh]} { - error "bad syntax" - } - if {[string length $strh] != $strl*2} { error "$strh $strl" } - gets $f l; set width [format %d $l] + global database database_header rows database_fn + catch { unset database } + set database_fn ./charset-$rows.txt + set f [open $database_fn r] + if {[string compare [db_getsl $f] $database_header]} { error "$l ?" } + if {([db_getsl $f])+0 != $rows} { error "wrong h ?" } + while 1 { + set context [db_getsl $f] + if {![string length $context]} continue + if {[regexp {^\#} $context]} continue + if {![string compare . $context]} break + set bm $context - for {set x 0} {$x < $width} {incr x} { - gets $f l; lappend bm [format %x 0x$l] + set strq [db_getsl $f] + while 1 { + set l [db_getsl $f] + if {![string length $l]} break + lappend bm [format %x 0x$l] } - set database($bm) $strh + set database($bm) $strq } close $f } proc write_database {} { - global database + global database rows database_fn database_header set ol {} foreach bm [array names database] { - set strh $database($bm) - set strs [binary format H* $strh] - set strdo [format "%d %s" [expr {[string length $strh]/2}] $strh] - set o "[lindex $bm 0] $strdo\n" - append o [format "%d\n" [expr {[llength $bm]-1}]] + set strq $database($bm) + set o "[lindex $bm 0]\n$strq\n" foreach x [lrange $bm 1 end] { append o "$x\n" } + lappend ol $o } - set f [open database.new w] + set f [open $database_fn.new w] + puts $f "$database_header\n$rows\n" foreach o [lsort $ol] { - puts -nonewline $f $o + puts $f $o } close $f - file rename -force database.new database + file rename -force $database_fn.new $database_fn } proc dbkey {ctx l r} { @@ -372,23 +410,25 @@ proc dbkey {ctx l r} { return $bm } -proc update_database/DEFINE {c0 c1 strh} { - global glyphsdone unk_l unk_context wordmap database +proc update_database/DEFINE {c0 c1 strq} { + global glyphsdone unk_l unk_contexts wordmap database if {$c0 > $c1} { manyset [list $c0 $c1] c1 c0 } if {$c0 == $unk_l} { - set ncontext $unk_context + set ncontexts $unk_contexts } else { foreach {l r context got} $glyphsdone { - if {$l==$c0} { set ncontext $context; break } + if {$l==$c0} { set ncontexts [list $context]; break } } - if {![info exists ncontext]} { + if {![info exists ncontexts]} { puts stderr "must start at letter LHS!" return } } incr c1 -1 - set bm [dbkey $ncontext $c0 $c1] - set database($bm) $strh + foreach c $ncontexts { + set bm [dbkey $c $c0 $c1] + set database($bm) $strq + } write_database } @@ -415,7 +455,7 @@ proc RETURN_RESULT {how what} { #---------- main progrm ---------- proc main/test {} { - global glyphsdone unk_l unk_r unk_context + global glyphsdone unk_l unk_r unk_contexts set glyphsdone { 7 11 1 M @@ -424,12 +464,14 @@ proc main/test {} { } set unk_l 25 set unk_r 29 - set unk_context 0 + set unk_contexts Test set f [open text.xpm] read_xpm $f close $f + read_database + resize_widgets draw_glyphsdone startup_cursor } @@ -437,20 +479,22 @@ proc done/test {} { } proc required {} { - global glyphsdone unk_l unk_r unk_context + global glyphsdone unk_l unk_r unk_contexts if {[gets stdin l]<0} { if {[eof stdin]} { fconfigure stdin -blocking yes; exit 0 } return } init_widgets - manyset [lrange $l 0 3] unk_l unk_r unk_context + manyset [lrange $l 0 3] unk_l unk_r unk_contexts set glyphsdone [lrange $l 3 end] puts stderr "SHOW-THING GOT $l" fileevent stdin readable {} read_xpm stdin + resize_widgets + read_database draw_glyphsdone startup_cursor } @@ -471,5 +515,4 @@ switch -exact -- $argv { default { error "huh $argv ?" } } -read_database main/$mainkind