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

 # eof

To 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:
   * unfortunately there is a bug (no, sadly it cannot declared a feature) with the replace code. If just before the word to be replaced by a longer one from the dict is a lineend, the lineend will be deleted. Since I use ''wordstart'' for the beginning of the current word, I can't see where the ''\n'' vanishes

----
!!!!!!
%| [Category GUI] | [Category Text Widget] |%
!!!!!!