X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?a=blobdiff_plain;f=pctb%2Fshow-thing.tcl;h=d71c36ef6381c54a885ab038dd55ef5b9840c280;hb=5a2c03e2e4f52b8329f45cf67afc3edec1f2c65b;hp=440f9c6a13a0cc88b994e7bbfd7f76defb9d9dff;hpb=8787ee59f6840de63bac432b516a30d0dfe22c84;p=ypp-sc-tools.main.git

diff --git a/pctb/show-thing.tcl b/pctb/show-thing.tcl
index 440f9c6..d71c36e 100755
--- 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}]
+	    puts stderr "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
@@ -397,6 +423,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 +443,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 +459,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
 }