a simple package for extending a text widget with autocompletion
For a simple translation utility I needed an autocomplete feature for the text widget to provide the editor with the matching already typed words to help in typing in words with many special chars (IPA code in this case).
The package is a simple extension for any text widget (though for the moment it can only serve one text widget per application). At the end of the page is a simple demo application.
Here is the code for the package. Save it as autocomplete.tcl
# ------------------------------------------------------------------------
# autocomplete package, version 1.0
# a simple package for extending a text widget with autocompletion
#
# Copyright (c) 2007 Uwe Koloska, voice INTER connect GmbH
# ------------------------------------------------------------------------
#
# This library is free software; you can use, modify, and redistribute it
# for any purpose, provided that existing copyright notices are retained
# in all copies and that this notice is included verbatim in any
# distributions.
#
# This software is distributed WITHOUT ANY WARRANTY; without even the
# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
# ------------------------------------------------------------------------
package provide autocomplete 1.0
package require wcb
namespace eval acmpl {}
proc acmpl::getWordlistVar {} {
return [namespace current]::run(words)
}
proc acmpl::getCurrentWord {w {back ""}} {
set startidx "insert -1c $back wordstart"
set endidx "insert $back -1c wordend"
set word [string trim [$w get $startidx $endidx]]
return $word
}
proc acmpl::replaceCurrentWord {w word} {
# FIXME: a leading lineend mysteriously vanishes
set startidx "insert -1c wordstart"
set endidx "insert wordend"
$w delete $startidx $endidx
$w insert insert $word
}
proc acmpl::processCurrentWord {w word} {
variable run
if {$word ne "" && ![string is punct $word]} {
if {[lsearch $run(words) $word] == -1} {
lappend run(words) $word
}
}
}
proc acmpl::getScreenCoordsForCurrentWord {w idx} {
lassign [$w bbox $idx] x1 y1 width height
set wx [winfo rootx $w]
set wy [winfo rooty $w]
set x [expr $x1 + $wx]
set y [expr $y1 + $wy + $height]
return [list $x $y]
}
proc acmpl::showWordVariants {w word {back ""}} {
variable run
# puts "showWordVariants $w $word"
if {[string length $word] >= $run(minWordlen)} {
set match [lsearch -all -inline $run(words) "${word}?*"]
if {[llength $match] > 0} {
if {[llength $match] > $run(maxEntries)} {
set match [concat [lrange $match 0 [expr $run(maxEntries) - 1]] "..."]
}
set run(match) $match
lassign [getScreenCoordsForCurrentWord $w "insert -1c $back wordstart"] x y
showWordVariantsPopup $w $x $y $match
} else {
catch {deleteWordVariantsPopup}
}
} else {
catch {deleteWordVariantsPopup}
}
}
proc acmpl::processInput {mode w args} {
variable run
# FIXME: w (from wcb callback) contains the prefix "::_" and this leads to errors
# with some tk commands
regsub {^(::_)} $w "" w
# puts "processInput $mode $w $args"
switch -exact $mode {
"insert" {
set idx [lindex $args 0]
set str [lindex $args 1]
if {![string is wordchar $str]} {
set word [getCurrentWord $w "-1c"]
processCurrentWord $w $word
deleteWordVariantsPopup
} else {
set word [getCurrentWord $w]
showWordVariants $w $word
}
}
"delete" {
set word [getCurrentWord $w]
showWordVariants $w $word
}
}
}
proc acmpl::saveWordlist {fname {enc utf-8}} {
variable run
if {[llength $run(words)] == 0} return
if {[file exists $fname]} {
file copy -force $fname ${fname}~
}
set fp [open $fname "w"]
fconfigure $fp -encoding $enc
puts $fp "\# tdict '[file tail $fname]'; encoding: $enc"
set words [lsort -dictionary $run(words)]
puts $fp [join $words \n]
puts $fp "\n\# eof"
close $fp
}
proc acmpl::loadWordlist {fname {append 0} {enc utf-8}} {
variable run
if {[catch {open $fname} fp] || $fp eq ""} {
return
}
fconfigure $fp -encoding $enc
set data [read -nonewline $fp]
close $fp
if {!$append} {
set run(words) {}
}
foreach line [split $data \n] {
set line [string trim $line]
if {[string length $line] == 0 || [string index $line 0] eq "\#"} continue
lappend run(words) $line
}
return [llength $run(words)]
}
proc acmpl::init {} {
bind CompletionPopup <Key-Escape> [namespace code deleteWordVariantsPopup]
bind CompletionPopup <1> [namespace code deleteWordVariantsPopup]
bind CompletionPopup <Key> [namespace code {processPopupKey %A}]
}
proc acmpl::attachTo {w args} {
variable run
array set opts {
-font {Helvetica 11}
-minwlen 3
-maxent 6
}
array set opts $args
set run(attachedTo) $w
set run(words) ""
set run(font-popup) $opts(-font)
set run(maxEntries) $opts(-maxent)
set run(minWordlen) $opts(-minwlen)
wcb::callback $w after insert [namespace code {processInput insert}]
wcb::callback $w after delete [namespace code {processInput delete}]
}
proc acmpl::processPopupKey {key} {
variable run
if {$key ne ""} {
#puts "key: $key"
if {$key > 0 && $key <= $run(maxEntries)} {
chooseWordVariant $key
return -code break
}
}
}
proc acmpl::chooseWordVariant {idx} {
variable run
if {$idx > 0 && $idx <= [llength $run(match)]} {
replaceCurrentWord $run(attachedTo) [lindex $run(match) [expr $idx - 1]]
}
}
proc acmpl::showWordVariantsPopup {w x y wordlist} {
variable run
# puts "showWordVariantsPopup $w $x $y '$wordlist'"
set t .cmplPopup
catch {destroy $t}
toplevel $t
wm overrideredirect $t yes
if {$::tcl_platform(platform) == "macintosh"} {
unsupported1 style $t floating sideTitlebar
}
set msg {}
for {set i 0} {$i < [llength $wordlist]} {incr i} {
set word [lindex $wordlist $i]
if {$word ne "..."} {
lappend msg "[expr $i + 1] $word"
} else {
lappend msg "..."
}
}
set msg [join $msg \n]
pack [label $t.l -text [subst $msg] -bg lightblue -font $run(font-popup) -justify left] \
-padx 0 -pady 0
set width [expr {[winfo reqwidth $t.l] + 2}]
set height [expr {[winfo reqheight $t.l] + 2}]
set xMax [expr {[winfo screenwidth .] - $width}]
set yMax [expr {[winfo screenheight .] - $height}]
if {$x > $xMax} then {
set x $xMax
}
if {$y > $yMax} then {
set y $yMax
}
wm geometry $t +$x+$y
bind $run(attachedTo) <FocusOut> [namespace code deleteWordVariantsPopup]
# Bindings Popup und Textwidget
foreach w [list $run(attachedTo) $t] {
set bindings [bindtags $w]
if {[lsearch $bindings CompletionPopup] == -1} {
set bindings [concat CompletionPopup $bindings]
bindtags $w $bindings
}
}
}
proc acmpl::deleteWordVariantsPopup {args} {
variable run
# delete bindings for Popup
set bindings [bindtags $run(attachedTo)]
while {[set idx [lsearch -exact $bindings "CompletionPopup"]] != -1} {
set bindings [lreplace $bindings $idx $idx]
}
bindtags $run(attachedTo) $bindings
catch {destroy .cmplPopup}
}
acmpl::init
# eofTo use this as a package, you have to provide a pkgIndex.tcl looking like this
package ifneeded autocomplete 1.0 [list source -encoding utf-8 [file join $dir autocomplete.tcl]]
For the example application to work you additionally have to provide the two excellent packages tablelist and Wcb. For convenience the application has the necessary setting to find the packages in a directory named lib just beside the script.
#! /usr/bin/env wish
# testapplication for autocomplete-package
package require Tk 8.5
set mydir [file dirname [info script]]
# use this to add the libdir of wcb, tablelist and autocomplete packages
lappend auto_path [file join $mydir "lib"]
package require autocomplete 1.0
package require tablelist
font create cmpl -family Verdana -size 14
proc createGui {font} {
text .t -width 40 -height 10 -wrap word -font $font
# scrollbar
tablelist::tablelist .l -exportselection false -stretch 0 \
-listvariable [acmpl::getWordlistVar] -columns {0 "word"} \
-background gray96 -stripebackground \#e0e8f0 -width 20 \
-showlabels 0 -selectmode single -yscrollcommand
grid .t .l -sticky ewns
grid columnconfigure . 0 -weight 1
grid rowconfigure . 0 -weight 1
}
createGui cmpl
acmpl::attachTo .t -font cmpl
# show the last inserted word
proc showListEnd {args} {
.l see end
}
proc Quit {} {
acmpl::saveWordlist "~/.tdict"
exit
}
wm protocol . WM_DELETE_WINDOW Quit
trace add variable [acmpl::getWordlistVar] write showListEnd
acmpl::loadWordlist "~/.tdict"BUGS: