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