progress printing and bugfixing and build system improvements

[ypp-sc-tools.web-live.git] / pctb / show-thing.tcl

diff --git a/pctb/show-thing.tcl b/pctb/show-thing.tcl
index 440f9c6a13a0cc88b994e7bbfd7f76defb9d9dff..5356c3292c7c58a276944752d6b16c325b1f5090 100755 (executable)
--- a/pctb/show-thing.tcl
+++ b/pctb/show-thing.tcl
@@ -69,8 +69,8 @@ proc show_context {maxhv x ctxs} {
     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
+    label $w -bg black -fg $fg -text [join $ctxs "/\n"] -justify left
+    place $w -x [expr {($x-1)*$mul}] -y 0
     set wh [winfo reqheight $w]
     if {$wh > $maxh} { set maxh $wh }
 }
@@ -90,8 +90,8 @@ proc resize_widgets {} {
     eval destroy [winfo children .d.ctx]
 
     set maxh 0
-    foreach {min max context got} $glyphsdone {
-       show_context maxh $min [list $context]
+    foreach {min max contexts got} $glyphsdone {
+       show_context maxh $min $contexts
     }
     show_context maxh $unk_l $unk_contexts
     .d.ctx configure -height $maxh
@@ -115,8 +115,28 @@ proc read_xpm {f} {
        }
        if {$y==-3} {
            manyset $l cols rows colours cpp
-           #assert {$colours==2}
-           #assert {$cpp==1}
+           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
+
+           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"
@@ -138,13 +158,19 @@ proc read_xpm {f} {
            set x 0
            set ol "\"+"
            set olh $ol
+           if {$chop_r>=0} {
+               set l [string range $l $chop_l end-$chop_r]
+           } 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 context got} $glyphsdone {
+                   foreach {min max contexts got} $glyphsdone {
                        set rhsmost_max $max
                        if {$x >= $min && $x <= $max} {
                            set how [lindex {a b} $ab]
@@ -186,7 +212,7 @@ proc read_xpm {f} {
 proc draw_glyphsdone {} {
     global glyphsdone mul inter
     eval destroy [winfo children .d.got]
-    foreach {min max context got} $glyphsdone {
+    foreach {min max 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
@@ -243,6 +269,7 @@ proc recursor//01 {z1} {
     }
     bind_key Return {
        if {$cur_0 != $cur_1} {
+           .d.csr.csr.e delete 0 end
            set cur_mode text
            recursor
        }
@@ -272,7 +299,6 @@ proc recursor/text {} {
     bind_key Return {
        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"
        }
     }
@@ -361,6 +387,7 @@ proc read_database {} {
     global database database_header rows database_fn
     catch { unset database }
     set database_fn ./charset-$rows.txt
+    if {![file exists $database_fn]} return
     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 ?" }
@@ -397,6 +424,7 @@ proc write_database {} {
     foreach o [lsort $ol] {
        puts $f $o
     }
+    puts $f "."
     close $f
     file rename -force $database_fn.new $database_fn
 }
@@ -416,8 +444,8 @@ proc update_database/DEFINE {c0 c1 strq} {
     if {$c0 == $unk_l} {
        set ncontexts $unk_contexts
     } else {
-       foreach {l r context got} $glyphsdone {
-           if {$l==$c0} { set ncontexts [list $context]; break }
+       foreach {l r contexts got} $glyphsdone {
+           if {$l==$c0} { set ncontexts $contexts; break }
        }
        if {![info exists ncontexts]} {
            puts stderr "must start at letter LHS!"
@@ -432,10 +460,12 @@ proc update_database/DEFINE {c0 c1 strq} {
     write_database
 }
 
-proc update_database/DELETE {l r ctx} {
+proc update_database/DELETE {l r ctxs} {
     global database
-    set bm [dbkey $ctx $l $r]
-    unset database($bm)
+    foreach ctx $ctxs {
+       set bm [dbkey $ctx $l $r]
+       catch { unset database($bm) }
+    }
     write_database
 }
     
@@ -447,7 +477,7 @@ proc RETURN_RESULT {how what} {
     helptext {{{ Processing }}}
     unbind_all_keys
     update idletasks
-    puts stderr "$how $what"
+    debug "$how $what"
     eval update_database/$how $what
     done/$mainkind
 }
@@ -488,9 +518,10 @@ proc required {} {
     init_widgets
     manyset [lrange $l 0 3] unk_l unk_r unk_contexts
     set glyphsdone [lrange $l 3 end]
-    puts stderr "SHOW-THING GOT $l"
+    debug "GOT $l"
 
     fileevent stdin readable {}
+    fconfigure stdin -blocking yes
 
     read_xpm stdin
     resize_widgets
@@ -505,14 +536,20 @@ proc main/automatic {} {
 }
 proc done/automatic {} {
     exec sh -c {printf \\0 >&4}
-    fileevent stdin readable required
+    main/automatic
 }
 
-switch -exact -- $argv {
-    {}               { set mainkind test }
-    {--automatic 1}  { set mainkind automatic }
-    {--automatic*}   { error "incompatible versions - install problem" }
-    default          { error "huh $argv ?" }
+proc debug {m} { }
+
+set mainkind test
+foreach arg $argv {
+    switch -exact -- $arg {
+       {--debug}        { proc debug {m} { puts stderr "SHOW-THING $m" } }
+       {--noop-arg}     { }
+       {--automatic-1}  { set mainkind automatic }
+       {--automatic*}   { error "incompatible versions - install problem" }
+       default          { error "huh $argv ?" }
+    }
 }
 
 main/$mainkind