database updates seem to work

diff --git a/pctb/database b/pctb/database
index 7ccee42bc5ede9bbbdebd538d0ffdb9fbf18fff6..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 100644 (file)
--- a/pctb/database
+++ b/pctb/database
@@ -1,7 +0,0 @@
-0 1 57
-5
-1f0
-200
-200
-100
-3f0

diff --git a/pctb/show-thing.tcl b/pctb/show-thing.tcl
index 19912cbb47aab980855ea38e441fb577ddd27e5b..0b0b8f553616109d21da2d96a99f70bf33809a1f 100755 (executable)
--- a/pctb/show-thing.tcl
+++ b/pctb/show-thing.tcl
@@ -3,11 +3,12 @@
 # usage:
 #  run show-thing without args
 #  then on stdin write
 # usage:
 #  run show-thing without args
 #  then on stdin write

-#     one line which is a Tcl list for foolist
+#     one line which is a Tcl list for 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
 
 #     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
 

+

 proc manyset {list args} {
     foreach val $list var $args {
         upvar 1 $var my
 proc manyset {list args} {
     foreach val $list var $args {
         upvar 1 $var my


@@ -15,14 +16,55 @@ proc manyset {list args} {
     }
 }
 
     }
 }
 

+
+#---------- display core ----------
+

 set mul 6
 set inter 1
 
 set gotsh 20
 set csrh 20
 
 set mul 6
 set inter 1
 
 set gotsh 20
 set csrh 20
 

+proc init_widgets {} {
+    global csrh gotsh
+    
+    frame .d
+
+    image create bitmap image/main
+    label .d.mi -image image/main -borderwidth 0
+
+    frame .d.csr -bg black -height $csrh
+    frame .d.got -bg black -height $gotsh
+
+    image create bitmap image/cursor -data \
+{#define csr_width 11
+#define csr_height 11
+static unsigned char csr_bits[] = {
+   0x20, 0x00, 0x20, 0x00, 0x20, 0x00, 0x21, 0x04, 0x22, 0x02, 0x25, 0x05,
+   0xaa, 0x02, 0x74, 0x01, 0xa8, 0x00, 0x70, 0x00, 0x20, 0x00};
+}
+
+    frame .d.csr.csr
+    label .d.csr.csr.l -image image/cursor -compound left
+    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
+
+    place .d.csr -x 0 -y 0
+    place .d.mi -x 0 -y $csrh
+    pack .d
+
+    frame .help
+    pack .help
+}
+
+
+#---------- xpm input processor ----------
+

 proc read_xpm {f} {
 proc read_xpm {f} {

-    global foolist mul inter rhsmost_max unk_l unk_r gotsh csrh
+    global glyphsdone mul inter rhsmost_max unk_l unk_r gotsh csrh

     global cols rows wordmap
     
     set o {}
     global cols rows wordmap
     
     set o {}


@@ -65,7 +107,7 @@ proc read_xpm {f} {
                    set how q
                } else {
                    set ab 0
                    set how q
                } else {
                    set ab 0

-                   foreach {min max context got} $foolist {
+                   foreach {min max context got} $glyphsdone {

                        set rhsmost_max $max
                        if {$x >= $min && $x <= $max} {
                            set how [lindex {a b} $ab]
                        set rhsmost_max $max
                        if {$x >= $min && $x <= $max} {
                            set how [lindex {a b} $ab]


@@ -98,7 +140,7 @@ proc read_xpm {f} {
        incr y
     }
     set data [exec xpmtoppm << $o]
        incr y
     }
     set data [exec xpmtoppm << $o]

-    image create photo main_image -data $data
+    image create photo image/main -data $data

     
     foreach w {.d .d.csr .d.got} {
        $w configure -width $mulcols
     
     foreach w {.d .d.csr .d.got} {
        $w configure -width $mulcols


@@ -110,21 +152,13 @@ proc read_xpm {f} {
     place .d.got -x 0 -y [expr {$csrh+$mulrows}]
 }
 
     place .d.got -x 0 -y [expr {$csrh+$mulrows}]
 }
 

-#puts $o
-
-frame .d

 
 

-set mi main_image
-image create bitmap main_image
-label .d.mi -image $mi -borderwidth 0
+#---------- per-invocation display ----------

 
 

-frame .d.csr -bg black -height $csrh
-frame .d.got -bg black -height $gotsh
-
-proc draw_foolist {} {
-    global foolist mul inter
+proc draw_glyphsdone {} {
+    global glyphsdone mul inter

     eval destroy [winfo children .d.got]
     eval destroy [winfo children .d.got]

-    foreach {min max context got} $foolist {
+    foreach {min max context 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
        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


@@ -132,34 +166,11 @@ proc draw_foolist {} {
     }
 }
 
     }
 }
 

-set imcsr [image create bitmap -data \
-{#define csr_width 11
-#define csr_height 11
-static unsigned char csr_bits[] = {
-   0x20, 0x00, 0x20, 0x00, 0x20, 0x00, 0x21, 0x04, 0x22, 0x02, 0x25, 0x05,
-   0xaa, 0x02, 0x74, 0x01, 0xa8, 0x00, 0x70, 0x00, 0x20, 0x00};
-}]
-
-frame .d.csr.csr
-label .d.csr.csr.l -image $imcsr -compound left
-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
-
-place .d.csr -x 0 -y 0
-place .d.mi -x 0 -y $csrh
-pack .d
-
-frame .help
-pack .help
-

 proc startup_cursor {} {
     global cur_already cur_mode cur_0 cur_1 last_ht
 proc startup_cursor {} {
     global cur_already cur_mode cur_0 cur_1 last_ht

-    global foolist unk_l unk_r
+    global glyphsdone unk_l unk_r

     
     

-    set cur_already [expr {[llength $foolist]/4-1}]
+    set cur_already [expr {[llength $glyphsdone]/4-1}]

     set cur_mode 1 ;# one of:   0 1 already text
 
     set cur_0 $unk_l
     set cur_mode 1 ;# one of:   0 1 already text
 
     set cur_0 $unk_l


@@ -167,6 +178,9 @@ proc startup_cursor {} {
     set last_ht {}
 }
 
     set last_ht {}
 }
 

+
+#---------- runtime display and keystroke handling ----------
+

 proc helptext {t} {
     global last_ht
     if {![string compare $t $last_ht]} return
 proc helptext {t} {
     global last_ht
     if {![string compare $t $last_ht]} return


@@ -186,13 +200,13 @@ proc helptext {t} {
 proc recursor/0 {} { recursor//01 0 }
 proc recursor/1 {} { recursor//01 1 }
 proc recursor//01 {z1} {
 proc recursor/0 {} { recursor//01 0 }
 proc recursor/1 {} { recursor//01 1 }
 proc recursor//01 {z1} {

-    global mul rhsmost_max cols foolist
+    global mul rhsmost_max cols glyphsdone

     upvar #0 cur_$z1 cur
     .d.csr.csr.l configure -text {adjust}
     place .d.csr.csr -x [expr {$cur*$mul - 7}]
     bind_key space { othercursor }
     bind_leftright cur_$z1 0 [expr {$cols-1}]
     upvar #0 cur_$z1 cur
     .d.csr.csr.l configure -text {adjust}
     place .d.csr.csr -x [expr {$cur*$mul - 7}]
     bind_key space { othercursor }
     bind_leftright cur_$z1 0 [expr {$cols-1}]

-    if {[llength $foolist]} {
+    if {[llength $glyphsdone]} {

        bind_key Tab { set cur_mode already; recursor }
     } else {
        bind_key Tab {}
        bind_key Tab { set cur_mode already; recursor }
     } else {
        bind_key Tab {}


@@ -241,20 +255,20 @@ proc recursor/text {} {
 
 proc recursor/already {} {
     global mul
 
 proc recursor/already {} {
     global mul

-    global foolist
+    global glyphsdone

     global cur_already mul
     global cur_already mul

-    global foolist cur_already mul
+    global glyphsdone cur_already mul

     .d.csr.csr.l configure -text {correct}
     .d.csr.csr.l configure -text {correct}

-    set rmax [lindex $foolist [expr {$cur_already*4}]]
+    set rmax [lindex $glyphsdone [expr {$cur_already*4}]]

     place .d.csr.csr -x [expr {$rmax*$mul-3}]
     bind_key Return {}
     bind_key space {}
     place .d.csr.csr -x [expr {$rmax*$mul-3}]
     bind_key Return {}
     bind_key space {}

-    bind_leftright cur_already 0 [expr {[llength $foolist]/4-1}]
+    bind_leftright cur_already 0 [expr {[llength $glyphsdone]/4-1}]

     bind_key Tab { bind_key Delete {}; set cur_mode 1; recursor }
     bind_key Delete {
     bind_key Tab { bind_key Delete {}; set cur_mode 1; recursor }
     bind_key Delete {

-       RETURN_RESULT DELETE [lrange $foolist \
+       RETURN_RESULT DELETE [lrange $glyphsdone \

                                  [expr $cur_already*4] \
                                  [expr $cur_already*4] \

-                                 [expr $cur_already*4+1]]
+                                 [expr $cur_already*4+2]]

     }
     helptext {
        {{<- ->}   {move cursor, selecting glyph to correct}}
     }
     helptext {
        {{<- ->}   {move cursor, selecting glyph to correct}}


@@ -295,6 +309,8 @@ proc recursor {} {
 }
 
 
 }
 
 

+#---------- database read and write ----------
+

 # database format:
 # series of glyphs:
 #   <context> <ncharacters> <hex>...
 # database format:
 # series of glyphs:
 #   <context> <ncharacters> <hex>...


@@ -342,27 +358,41 @@ proc write_database {} {
     file rename -force database.new database
 }
 
     file rename -force database.new database
 }
 

+proc dbkey {ctx l r} {
+    global wordmap
+    set bm $ctx
+    for {set x $l} {$x <= $r} {incr x} {
+       lappend bm [format %x $wordmap($x)]
+    }
+    return $bm
+}
+

 proc update_database/DEFINE {c0 c1 strh} {
 proc update_database/DEFINE {c0 c1 strh} {

-    global foolist unk_l unk_context wordmap database
+    global glyphsdone unk_l unk_context wordmap database

     if {$c0 > $c1} { manyset [list $c0 $c1] c1 c0 }
     if {$c0 == $unk_l} {
        set ncontext $unk_context
     } else {
     if {$c0 > $c1} { manyset [list $c0 $c1] c1 c0 }
     if {$c0 == $unk_l} {
        set ncontext $unk_context
     } else {

-       foreach {l r context got} $foolist {
+       foreach {l r context got} $glyphsdone {

            if {$l==$c0} { set ncontext $context; break }
        }
            if {$l==$c0} { set ncontext $context; break }
        }

-       if {![exists ncontext]} {
+       if {![info exists ncontext]} {

            puts stderr "must start at letter LHS!"
            return
        }
     }
            puts stderr "must start at letter LHS!"
            return
        }
     }

-    set bm $ncontext
-    for {set x $c0} {$x < $c1} {incr x} {
-       lappend bm [format %x $wordmap($x)]
-    }
+    incr c1 -1
+    set bm [dbkey $ncontext $c0 $c1]

     set database($bm) $strh
     write_database
 }
     set database($bm) $strh
     write_database
 }

+
+proc update_database/DELETE {l r ctx} {
+    global database
+    set bm [dbkey $ctx $l $r]
+    unset database($bm)
+    write_database
+}

     
 
 proc RETURN_RESULT {how what} {
     
 
 proc RETURN_RESULT {how what} {


@@ -378,9 +408,9 @@ proc RETURN_RESULT {how what} {
 #    bind . <Key-space> {}
 
 proc test_main {} {
 #    bind . <Key-space> {}
 
 proc test_main {} {

-    global foolist unk_l unk_r unk_context
-    
-    set foolist {
+    global glyphsdone unk_l unk_r unk_context
+
+    set glyphsdone {

        7 11 1 M
        13 17 0 a
        19 23 0 n
        7 11 1 M
        13 17 0 a
        19 23 0 n


@@ -393,11 +423,11 @@ proc test_main {} {
     read_xpm $f
     close $f
 
     read_xpm $f
     close $f
 

-    draw_foolist
+    draw_glyphsdone

     startup_cursor
     startup_cursor

-    
-    read_database
-    recursor

 }
 
 }
 

+read_database
+init_widgets

 test_main
 test_main

+recursor