-
Notifications
You must be signed in to change notification settings - Fork 1
/
tdict.tcl
365 lines (326 loc) · 9.38 KB
/
tdict.tcl
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
#!//usr/bin/env wish8.5
# Tickle Dict
# T-Dictionary, by tonybaldwin
# http://tonyb.us/tdict
# This program is provided according to the terms of the GNU GPL version 3,
# or at your option any later version. All terms and conditions therein apply. \
package require Tk
package require Ttk
global file_types
# user definable
set host dict.org
set port 2628
set linkcolor blue
set activecolor red
set resetonfail 1
# Proxy use is untested
set proxyinit {}
# don't touch
set DICT "All"
set DICTS(All) "*"
set CODE 0
set HIST ""
set HIND -1
set ERR 0
set QUIT 0
proc back {} {
global HIST
global HIND
if {$HIND <= 0} {return}
incr HIND -1
sendquery [lindex $HIST $HIND] 1
}
proc forward {} {
global HIST
global HIND
if {$HIND == [expr [llength $HIST] - 1]} {return}
incr HIND
sendquery [lindex $HIST $HIND] 1
}
proc connect {} {
global server
global host
global port
global proxyinit
set server [socket -async $host $port]
fconfigure $server -blocking 0 -buffering line -translation crlf
fileevent $server readable readsock
if [string length $proxyinit] {
puts -nonewline $server $proxyinit
}
}
proc sendquery {string args} {
global server
global DICT
global DICTS
global HIST
global HIND
regsub -all "\n" $string { } string
regsub -all " +" $string " " string
regsub -all "\"" $string {} string
if [regexp {(\(|\)|\||\+|\*|\.|\?|\[|\]|\$|\^)} $string] {
set mode 1
} {set mode 0}
if {$mode == 0} {
puts $server "define $DICTS($DICT) \"$string\""
} {puts $server "match $DICTS($DICT) re \"$string\""}
if {$args == 1} {return}
set HIST [lrange $HIST 0 $HIND]
lappend HIST $string
incr HIND
}
proc readsock {} {
global server
global CODE
global ERR
set lines ""
if [eof $server] {
global QUIT
if {$QUIT} {exit}
catch {close $server}
connect
}
set line [gets $server]
if {$CODE == 151} {
if [string compare $line "."] {
show "$line\n" word
return
} {
show "\n" {}
}
}
if {$CODE == 110} {
if [string compare $line "."] {
global DICTS
.query.options.menu add radiobutton -label [lindex $line 1] -variable DICT
set DICTS([lindex $line 1]) [lindex $line 0]
return
}
}
if {$CODE == 152} {
global DICTS
if [string compare $line "."] {
foreach of [array names DICTS] {
if ![string compare $DICTS($of) [lindex $line 0]] {
set dict $of
break
}
}
catch {
show "\t" {}
show "[lindex $line 1]" link
show " : $dict\n" {}
}
return
}
}
set CODE 0
regexp {^[1-5][0-8][0-9]} $line tempcode
catch {set CODE $tempcode}
if {$CODE == 151} {
catch {show "[lindex $line 3]\n" bold}
}
if {$CODE == 150} {
.main.text config -state normal
.main.text delete 0.0 end
.main.text config
}
if {$CODE == 250} {
set startTag 0.0
.main.text config -state normal
while {[string compare [.main.text search \{ $startTag end] ""] != 0} {
set beginTag [.main.text search \{ $startTag end]
.main.text delete $beginTag "$beginTag + 1 char"
set startTag $beginTag
set endTag [.main.text search \} $startTag end]
set nextBr [.main.text search \{ $startTag end]
if {[string compare $nextBr ""] != 0} {
if [.main.text compare $nextBr < $endTag] {continue}
}
.main.text delete $endTag "$endTag + 1 char"
set startTag "$endTag+1c"
.main.text tag add link $beginTag $endTag
set endTag [.main.text search \} "$startTag -1c" end]
set nextBr [.main.text search \{ "$startTag -1c" end]
if {[string compare $nextBr ""] != 0 && [string compare $endTag ""] != 0} {
if [.main.text compare $nextBr > $endTag] {
.main.text delete $endTag "$endTag + 1 char"
}
}
}
.main.text config
}
}
proc show {line flags} {
.main.text config -state normal
.main.text insert end $line $flags
.main.text config
# -state disabled
}
proc ApplySetting {win name var} {
$win config -$name $var
foreach of [winfo children $win] {
ApplySetting $of $name $var
catch {$of config -$name $var}
}
}
catch {source /TPDictrc}
catch {source ::TPDictrc}
catch {source ~/.TPDictrc}
frame .main
text .main.text -yscrollcommand ".main.yscroll set" -bg #e7ebcf
# -state disabled -width 80
# -bg white
scrollbar .main.yscroll -orient vertical -command ".main.text yview" -takefocus 0
grid .main.text .main.yscroll -sticky news
grid rowconfigure .main 0 -weight 1
grid columnconfigure .main 0 -weight 1
.main.text tag config link -foreground $linkcolor
.main.text tag config active -foreground $activecolor
.main.text tag config word -font "[.main.text cget -font]"
.main.text tag bind link <Enter> {
.main.text tag add active {@%x,%y wordstart} {@%x,%y wordend}
}
.main.text tag bind link <Leave> {
.main.text tag remove active 0.0 end
}
.main.text tag bind link <Motion> {
.main.text tag remove active 0.0 end
set ind [.main.text index {@%x,%y}]
set marks [.main.text tag nextrange link $ind]
if ![string length $marks] {
set marks [.main.text tag prevrange link $ind]
}
if {[.main.text compare $ind >= [lindex $marks 0]] && [.main.text compare $ind <= [lindex $marks 1]]} {
.main.text tag add active [lindex $marks 0] [lindex $marks 1]
} {
set marks [.main.text tag prevrange link $ind]
.main.text tag add active [lindex $marks 0] [lindex $marks 1]
}
unset marks
unset ind
}
.main.text tag bind link <1> {
set ind [.main.text index {@%x,%y}]
set marks [.main.text tag nextrange link $ind]
if ![string length $marks] {
set marks [.main.text tag prevrange link $ind]
}
if {[.main.text compare $ind >= [lindex $marks 0]] && [.main.text compare $ind <= [lindex $marks 1]]} {
sendquery [.main.text get [lindex $marks 0] [lindex $marks 1]]
} {
set marks [.main.text tag prevrange link $ind]
sendquery [.main.text get [lindex $marks 0] [lindex $marks 1]]
}
unset marks
unset ind
break
}
frame .query
label .query.label -text "Enter term:"
pack .query.label -side left
entry .query.query
pack .query.query -side left
tk::button .query.go -text "Seek" -command {
sendquery [.query.query get]
.query.query delete 0 end
}
pack .query.go -side left
label .query.lbl1 -text "Resource:"
pack .query.lbl1 -side left
tk_optionMenu .query.options DICT All
pack .query.options -side left
bind .query.query <Return> {
sendquery [.query.query get]
.query.query delete 0 end
}
tk::button .query.back -text "Back" -command back
tk::button .query.forward -text "Forward" -command forward
tk::button .query.quit -text "Quit" -command exit
pack .query.quit -side right
pack .query.forward -side right
pack .query.back -side right
focus .query.query
pack .query -side top -fill x
.main.text tag bind word <3> {
sendquery [.main.text get {@%x,%y wordstart} {@%x,%y wordend} ]
}
bind . <Escape> exit
bind . <Next> {.main.text yview scroll 1 pages}
bind . <Prior> {.main.text yview scroll -1 pages}
bind . <Down> {.main.text yview scroll 1 units}
bind . <Up> {.main.text yview scroll -1 units}
bind . <Left> back
bind . <Right> forward
bind . <Control-Key-u> {.query.query delete 0 end}
pack .main -side top -fill both -expand true
frame .query2
tk::button .query2.bgcor -text "Background Color" -command setbg
tk::button .query2.sav -text "Save" -command {savedef}
tk::button .query2.sel -text "Select All" -command {.main.text tag add sel 1.0 end}
label .query2.2cp -text " -Ctrl-C to copy text- "
label .query2.fs -text "Font size:"
ttk::combobox .query2.size -width 4 -value [list 8 10 12 14 16 18] -state readonly
bind .query2.size <<ComboboxSelected>> [list sizeFont .main.text .query2.size]
proc sizeFont {txt combo} {
set font [$txt cget -font]
font configure $font -size [list [$combo get]]
}
pack .query2.bgcor -side right
pack .query2.sav -side left
pack .query2.sel -side left
pack .query2.2cp -side left
pack .query2.fs -side left
pack .query2.size -side left
pack .query2 -in . -fill x
proc setbg { } {
global i
set color [tk_chooseColor -initialcolor [.main.text cget -background]]
if {$color != ""} {.main.text configure -background $color}
}
set file_types {
{"All Files" * }
{"Text Files" { .txt .TXT}}
{"Html" {.html}}
}
proc savedef {} {
global filename
set filename [tk_getSaveFile -filetypes $::file_types]
set data [.main.text get 1.0 {end -1c}]
wm title . "Now Tickling: $::filename"
set fileid [open $::filename w]
puts -nonewline $fileid $data
close $fileid
}
wm protocol . WM_DELETE_WINDOW {
set QUIT 1
catch {puts $server quit}
wm protocol . WM_DELETE_WINDOW exit
}
wm title . "Tickle Dict"
tk_setPalette background seashell1
if [catch {connect}] {
wm withdraw .
tk_dialog .error "Critical Error" "Could not contact remote server. Terminating." error 0
exit
}
puts $server "client TPDict"
puts $server "show databases"
if {$argc > 0} {
sendquery $argv
}
proc about {} {
tk_messageBox -type ok -title "About T-Dict" -message "Tcl Dictionary\n by Tony Baldwin\n tonytraductor\n @\n linguasos.org"
}
# This program was written by Anthony Baldwin / [email protected]
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.