chiark / gitweb /
f2055f44aca83b55c64aefafd1906aa493e90e5a
[ypp-sc-tools.web-live.git] / pctb / show-thing.tcl
1 #!/usr/bin/wish
2
3 # usage:
4 #  run show-thing without args
5 #  then on stdin write
6 #     one line which is a Tcl list for foolist
7 #     the xpm in the format expected
8 #  then expect child to raise SIGSTOP or exit 0 or exit nonzero
9 #  if child raised SIGSTOP, check database was updated
10
11 proc manyset {list args} {
12     foreach val $list var $args {
13         upvar 1 $var my
14         set my $val
15     }
16 }
17
18 set mul 6
19 set inter 1
20 set rhsmost_max -1
21
22 proc read_xpm {f} {
23     set o {}
24     set y -3
25     while 1 {
26         if {[gets $f l] < 0} { error "huh? "}
27         if {![regexp {^"(.*)",$} $l dummy l]} {
28             append o "$l\n"
29             if {[regexp {^\}\;$} $l]} break
30             continue
31         }
32         if {$y==-3} {
33             manyset $l cols rows colours cpp
34             #assert {$colours==2}
35             #assert {$cpp==1}
36             set mulcols [expr {$cols*$mul+$inter}]
37             set mulrows [expr {$rows*$mul+$inter}]
38             append o "\"$mulcols $mulrows 9 1\",\n"
39             for {set x 0} {$x<$cols} {incr x} { set wordmap($x) 0 }
40         } elseif {$y==-2} { # first pixel
41             append o \
42 "\"+ c #111\",
43 \"a c #800\",
44 \"A c #fcc\",
45 \"b c #00c\",
46 \"B c #fff\",
47 \"u c #000\",
48 \"U c #ff0\",
49 \"q c #000\",
50 \"Q c #ff0\",\n"
51         } elseif {$y==-1} { # 2nd pixel but we've already printed ours
52         } else {
53             set ybit [expr {1<<$y}]
54             set x 0
55             set ol "\"+"
56             set olh $ol
57             foreach c [split $l ""] {
58                 set how "u"
59                 if {$x >= $unk_l && $x <= $unk_r} {
60                     set how q
61                 } else {
62                     set ab 0
63                     foreach {min max context got} $foolist {
64                         set rhsmost_max $max
65                         if {$x >= $min && $x <= $max} {
66                             set how [lindex {a b} $ab]
67                             break
68                         }
69                         set ab [expr {!$ab}]
70                     }
71                 }
72                 switch -exact $c {
73                     " " { set p $how }
74                     "o" {
75                         set p [string toupper $how]
76                         incr wordmap($x) $ybit
77                     }
78                     default { error "$c ?" }
79                 }
80                 append ol "[string repeat $p [expr {$mul-$inter}]][
81                          string repeat + $inter]"
82                 append olh [string repeat + $mul]
83                 incr x
84             }
85             set ole "\",\n"
86             append ol $ole
87             append olh $ole
88             set olhn [string repeat $olh $inter]
89             if {!$y} { append o $olhn }
90             append o [string repeat $ol [expr {$mul-1}]]
91             append o $olhn
92         }
93         incr y
94     }
95     set data [exec xpmtoppm << $o]
96     image create photo main_image -data $xpm
97 }
98
99 #puts $o
100
101 set gotsh 20
102 set csrh 20
103
104 frame .d -width $mulcols -height [expr {$csrh+$mulrows+$gotsh}]
105
106 set mi main_image
107 image create bitmap main_image
108 label .d.mi -image $mi -borderwidth 0
109
110 frame .d.csr -bg black -width $mulcols -height $csrh
111 frame .d.got -bg black -width $mulcols -height $gotsh
112
113 foreach {min max context got} $foolist {
114     frame .d.got.m$min -bd 0 -background \#888
115     label .d.got.m$min.l -text "$got" -fg white -bg black -bd 0
116     pack .d.got.m$min.l -padx 1 -pady 1
117     place .d.got.m$min -x [expr {$min*$mul+$inter}] -y 0
118 }
119
120 set imcsr [image create bitmap -data \
121 {#define csr_width 11
122 #define csr_height 11
123 static unsigned char csr_bits[] = {
124    0x20, 0x00, 0x20, 0x00, 0x20, 0x00, 0x21, 0x04, 0x22, 0x02, 0x25, 0x05,
125    0xaa, 0x02, 0x74, 0x01, 0xa8, 0x00, 0x70, 0x00, 0x20, 0x00};
126 }]
127
128 frame .d.csr.csr
129 label .d.csr.csr.l -image $imcsr -compound left
130 entry .d.csr.csr.e -bd 0
131 pack .d.csr.csr.l -side left
132
133 frame .d.csr_0 -bg white -height $mulrows -width 1
134 frame .d.csr_1 -bg white -height $mulrows -width 1
135
136 place .d.csr -x 0 -y 0
137 place .d.mi -x 0 -y $csrh
138 place .d.got -x 0 -y [expr {$csrh+$mulrows}]
139 pack .d
140
141 frame .help
142 pack .help
143
144 set cur_already [expr {[llength $foolist]/4-1}]
145 set cur_mode 1 ;# one of:   0 1 already text
146
147 set cur_0 $unk_l
148 set cur_1 [expr {$unk_r+1}]
149 set last_ht {}
150
151 proc helptext {t} {
152     global last_ht
153     if {![string compare $t $last_ht]} return
154     eval destroy [grid slaves .help]
155     set y 0; foreach l $t {
156         set x 0; foreach c $l {
157             set w .help.at${x}x${y}
158             label $w -text $c
159             grid $w -row $y -column $x -padx 5
160             incr x
161         }
162         incr y
163     }
164     set last_ht $t
165 }
166
167 proc recursor/0 {} { recursor//01 0 }
168 proc recursor/1 {} { recursor//01 1 }
169 proc recursor//01 {z1} {
170     global mul rhsmost_max cols foolist
171     upvar #0 cur_$z1 cur
172     .d.csr.csr.l configure -text {adjust}
173     place .d.csr.csr -x [expr {$cur*$mul - 7}]
174     bind_key space { othercursor }
175     bind_leftright cur_$z1 0 [expr {$cols-1}]
176     if {[llength $foolist]} {
177         bind_key Tab { set cur_mode already; recursor }
178     } else {
179         bind_key Tab {}
180     }
181     bind_key Return {
182         if {$cur_0 != $cur_1} {
183             set cur_mode text
184             recursor
185         }
186     }
187     helptext {
188         {{<- ->}   {move cursor, adjusting area to define}}
189         {Space     {switch to moving other cursor}}
190         {Return    {confirm location, enter letter(s)}}
191         {Tab       {switch to correcting earlier ocr}}
192     }
193 }
194 proc othercursor {} {
195     global cur_mode
196     set cur_mode [expr {!$cur_mode}]
197     recursor
198 }
199
200 proc recursor/text {} {
201     helptext {
202         {Return   {confirm entry of new glyph}}
203         {Escape   {abandon entry}}
204     }
205     unbind_all_keys
206     .d.csr.csr.l configure -text {define:}
207     pack .d.csr.csr.e -side left
208     focus .d.csr.csr.e
209     bind_key Return {
210         binary scan [.d.csr.csr.e get] h* hex
211         if {[string length $hex]} {
212             RETURN_RESULT DEFINE "$cur_0 $cur_1 $hex"
213         }
214     }
215     bind_key Escape {
216         bind_key Escape {}
217         pack forget .d.csr.csr.e
218         set cur_mode 1
219         recursor
220     }
221 }
222
223 proc recursor/already {} {
224     global mul
225     global foolist
226     global cur_already mul
227     global foolist cur_already mul
228     .d.csr.csr.l configure -text {correct}
229     set rmax [lindex $foolist [expr {$cur_already*4}]]
230     place .d.csr.csr -x [expr {$rmax*$mul-3}]
231     bind_key Return {}
232     bind_key space {}
233     bind_leftright cur_already 0 [expr {[llength $foolist]/4-1}]
234     bind_key Tab { bind_key Delete {}; set cur_mode 1; recursor }
235     bind_key Delete {
236         RETURN_RESULT DELETE [lrange $foolist \
237                                   [expr $cur_already*4] \
238                                   [expr $cur_already*4+1]]
239     }
240     helptext {
241         {{<- ->}   {move cursor, selecting glyph to correct}}
242         {Del       {clear this glyph from the recognition database}}
243         {Tab       {switch to selecting area to define as new glyph}}
244     }
245 }
246
247 proc bind_key {k proc} {
248     global keybindings
249     bind . <Key-$k> $proc
250     set keybindings($k) [expr {!![string length $proc]}]
251 }
252 proc unbind_all_keys {} {
253     global keybindings
254     foreach k [array names keybindings] { bind_key $k {} }
255 }
256
257 proc bind_leftright {var min max} {
258     bind_key Left  [list leftright $var $min $max -1]
259     bind_key Right [list leftright $var $min $max +1]
260 }
261 proc leftright {var min max inc} {
262     upvar #0 $var v
263     set vnew $v
264     incr vnew $inc
265     if {$vnew < $min || $vnew > $max} return
266     set v $vnew
267     recursor
268 }
269
270 proc recursor {} {
271     global csrh cur_mode cur_0 cur_1 mul
272     foreach z1 {0 1} {
273         place .d.csr_$z1 -y $csrh -x [expr {[set cur_$z1] * $mul}]
274     }
275     recursor/$cur_mode
276 }
277
278
279 # database format:
280 # series of glyphs:
281 #   <context> <ncharacters> <hex>...
282 #   width
283 #   <hex-bitmap>
284
285 # $database($context 0x<bits> 0x<bits>...) = $hex
286
287 proc read_database {} {
288     global database
289     set f [open database r]
290     while {[gets $f l] >= 0} {
291         if {![regexp {^(\w+) (\d+) ((?:[0-9a-f]{2})+)$} $l \
292                   dummy context strl strh]} {
293             error "bad syntax"
294         }
295         if {[string length $strh] != $strl*2} { error "$strh $strl" }
296         gets $f l; set width [format %d $l]
297         set bm $context
298         for {set x 0} {$x < $width} {incr x} {
299             gets $f l; lappend bm [format %x 0x$l]
300         }
301         set database($bm) $strh
302     }
303     close $f
304 }
305
306 proc write_database {} {
307     global database
308     set ol {}
309     foreach bm [array names database] {
310         set strh $database($bm)
311         set strs [binary format h* $strh]
312         set strdo [format "%d %s" [expr {[string length $strh]/2}] $strh]
313         set o "[lindex $bm 0] $strdo\n"
314         append o [format "%d\n" [expr {[llength $bm]-1}]]
315         foreach x [lrange $bm 1 end] { append o "$x\n" }
316         lappend ol $o
317     }
318     set f [open database.new w]
319     foreach o [lsort $ol] {
320         puts -nonewline $f $o
321     }
322     close $f
323     file rename -force database.new database
324 }
325
326 proc update_database/DEFINE {c0 c1 strh} {
327     global foolist unk_l unk_context wordmap database
328     if {$c0 > $c1} { manyset [list $c0 $c1] c1 c0 }
329     if {$c0 == $unk_l} {
330         set ncontext $unk_context
331     } else {
332         foreach {l r context got} $foolist {
333             if {$l==$c0} { set ncontext $context; break }
334         }
335         if {![exists ncontext]} {
336             puts stderr "must start at letter LHS!"
337             return
338         }
339     }
340     set bm $ncontext
341     for {set x $c0} {$x < $c1} {incr x} {
342         lappend bm [format %x $wordmap($x)]
343     }
344     set database($bm) $strh
345     write_database
346 }
347     
348
349 proc RETURN_RESULT {how what} {
350     place forget .d.csr.csr
351     pack forget .d.csr.csr.e
352     helptext {{{ Processing }}}
353     unbind_all_keys
354     update idletasks
355     puts "$how $what"
356     eval update_database/$how $what
357 }
358
359 #    bind . <Key-space> {}
360
361 proc test_main {} {
362     global foolist
363     
364     set foolist {
365         7 11 1 M
366         13 17 0 a
367         19 23 0 n
368     }
369     set unk_l 25
370     set unk_r 29
371     set unk_context 0
372
373     set f [open text.xpm]
374     read_xpm $f
375     close $f
376
377     read_database
378     recursor
379 }