chiark / gitweb /
database updates seem to work
authorIan Jackson <ian@liberator.(none)>
Wed, 3 Jun 2009 23:31:33 +0000 (00:31 +0100)
committerIan Jackson <ian@liberator.(none)>
Wed, 3 Jun 2009 23:31:33 +0000 (00:31 +0100)
pctb/database
pctb/show-thing.tcl

index 7ccee42..e69de29 100644 (file)
@@ -1,7 +0,0 @@
-0 1 57
-5
-1f0
-200
-200
-100
-3f0
index 19912cb..0b0b8f5 100755 (executable)
@@ -3,11 +3,12 @@
 # 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
 
+
 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
 
+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} {
-    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 {}
@@ -65,7 +107,7 @@ proc read_xpm {f} {
                    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]
@@ -98,7 +140,7 @@ proc read_xpm {f} {
        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
@@ -110,21 +152,13 @@ proc read_xpm {f} {
     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]
-    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
@@ -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
-    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
@@ -167,6 +178,9 @@ proc startup_cursor {} {
     set last_ht {}
 }
 
+
+#---------- runtime display and keystroke handling ----------
+
 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} {
-    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}]
-    if {[llength $foolist]} {
+    if {[llength $glyphsdone]} {
        bind_key Tab { set cur_mode already; recursor }
     } else {
        bind_key Tab {}
@@ -241,20 +255,20 @@ proc recursor/text {} {
 
 proc recursor/already {} {
     global mul
-    global foolist
+    global glyphsdone
     global cur_already mul
-    global foolist cur_already mul
+    global glyphsdone cur_already mul
     .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 {}
-    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 {
-       RETURN_RESULT DELETE [lrange $foolist \
+       RETURN_RESULT DELETE [lrange $glyphsdone \
                                  [expr $cur_already*4] \
-                                 [expr $cur_already*4+1]]
+                                 [expr $cur_already*4+2]]
     }
     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>...
@@ -342,27 +358,41 @@ proc write_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} {
-    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 {
-       foreach {l r context got} $foolist {
+       foreach {l r context got} $glyphsdone {
            if {$l==$c0} { set ncontext $context; break }
        }
-       if {![exists ncontext]} {
+       if {![info exists ncontext]} {
            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
 }
+
+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} {
@@ -378,9 +408,9 @@ proc RETURN_RESULT {how what} {
 #    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
@@ -393,11 +423,11 @@ proc test_main {} {
     read_xpm $f
     close $f
 
-    draw_foolist
+    draw_glyphsdone
     startup_cursor
-    
-    read_database
-    recursor
 }
 
+read_database
+init_widgets
 test_main
+recursor