#!/usr/bin/tclsh

package require Tk
if {[catch {
        set auto_path [concat . $auto_path]
        package require snit
        }]} {
    source snit.tcl
}

::snit::widgetadaptor acentry {
    # List of autocompletion words.
    option -aclist {}

    # Name of variable containing a list of autocompletion words.
    option -aclistvar ""

    # Name of a proc that returns a list of autocompletion words given this
    # widget's path as its sole argument.
    option -aclistproc ""

    # Display a popup containing a list of completions?
    option -popup 1

    # Maximum number of visible items in popup without scrolling.  0 indicates
    # no limit.
    option -popupheight 8

    # List of possible completions for the current word.  Only non-{} when
    # cycling through multiple completions.
    variable Completions {}

    # Index of current completion in completions list.
    variable CmpIndex 0

    # Index of beginning of suggested completion in text entry.
    variable CmpBegin 0

    # Index of end of suggested completion in text entry.
    variable CmpEnd 0

    # Offset of suggested completion from beginning of word.
    variable CmpOffset 0

    # If non-"", the path to the popup completion window.
    variable Popup ""

    # Wrap around an ordinary text entry widget.  Bind FocusIn and FocusOut to
    # terminate completion mode.
    constructor {args} {
        installhull [entry $self]
        bindtags $self [concat ACEntry [bindtags $self]]
        bind $self <FocusIn> [mymethod autocomplete -reset]
        bind $self <FocusOut> [mymethod autocomplete -reset]
        $self configurelist $args
    }

    # For now let's just allow the cached completion list to grow stale while
    # cycling through it if the real list changes on us.  It's too much bother
    # to ensure synchronization, and it's not very important anyway.

    # -aclist, -aclistvar, and -aclistproc are mutually exclusive.
    onconfigure -aclist {value} {
        set options(-aclist) $value
        set options(-aclistvar) ""
        set options(-aclistproc) ""
    }

    # -aclist, -aclistvar, and -aclistproc are mutually exclusive.
    onconfigure -aclistvar {value} {
        set options(-aclist) {}
        set options(-aclistvar) $value
        set options(-aclistproc) ""
    }

    # -aclist, -aclistvar, and -aclistproc are mutually exclusive.
    onconfigure -aclistproc {value} {
        set options(-aclist) {}
        set options(-aclistvar) ""
        set options(-aclistproc) $value
    }

    # Performs autocompletion.
    method autocomplete {args} {
        set delta 1
        set reset 0

        # Handle arguments.
        while 1 {
            if {![arg_pop arg args]} {break}
            switch -exact -- $arg {
            -reverse {set delta -1}
            -forward {set delta 1}
            -reset {set reset 1}
            default {
                error "bad option \"$arg\": must be -reverse, -forward, -reset"
            }}
        }

        if {$reset} {
            set Completions {}
            return
        }

        # It makes the most sense to clear the selection first.
        $self selection clear

        if {[llength $Completions] == 0} {
            # Not currently cycling through a list of possible completions.

            # Locate the beginning and end of the word in which the insertion
            # point currently is located.  Note: not using [string wordstart]
            # because it doesn't consider / to be part of a word.
            set str [$self get]
            set wordBegin [expr [string last " " $str\
                 [expr [$self index insert] - 1]] + 1]
            set wordEnd [string first " " "$str " $wordBegin]

            # Extract the current word and get the list of possible completions.
            set str [string range $str $wordBegin [expr {$wordEnd - 1}]]
            set Completions [filterPrefix [$self CompletionList] $str]

            switch -exact -- [llength $Completions] {
            0 {
                # No possible completions.  Beep and give up for now.

                bell
            } 1 {
                # One possible completion.  Use it and quit.

                set tail [string range "[lindex $Completions 0] " \
                        [expr {$wordEnd - $wordBegin}] end]
                $self Insert $wordEnd $tail
                $self Icursor [expr {$wordEnd + [string length $tail]}]
                $self autocomplete -reset
            } default {
                # More than one possible completion.  Insert the first one
                # and arrange for further calls to autocomplete to cycle
                # through the remaining completions.

                set CmpIndex 0
                set CmpOffset [commonPrefixLength $Completions]
                set CmpBegin [expr {$wordBegin + $CmpOffset}]
                set str "[lindex $Completions $CmpIndex] "
                set str [string range $str [expr {$wordEnd - $wordBegin}] end]
                set CmpEnd [expr {$CmpBegin + [string length $str]}]

                # Insert the first completion tail and move the cursor to the
                # end of the new word.
                $self Insert $wordEnd $str
                $self Icursor $CmpEnd
                $self xview $CmpEnd
            }}
        } else {
            # Currently cycling through a list of completions.  Go to the next
            # item in the list, or recycle to the first.

            incr CmpIndex $delta
            if {$CmpIndex == [llength $Completions]} {set CmpIndex 0}
            if {$CmpIndex == -1} {incr CmpIndex [llength $Completions]}

            # Find the tail of the new completion.
            set str "[lindex $Completions $CmpIndex] "
            set str [string range $str $CmpOffset end]

            # Replace the old completion with the new.
            $self Delete $CmpBegin $CmpEnd
            $self Insert $CmpBegin $str

            # Move the cursor to the end of the new completion.
            set CmpEnd [expr {$CmpBegin + [string length $str]}]
            $self Icursor $CmpEnd
            $self xview $CmpEnd
        }
    }

    # Stops completion cycling on cursor movement.
    method icursor {args} {
        $self autocomplete -reset
        eval [list $self Icursor] [lrange $args 0 end]
    }

    # Stops completion cycling on on insert.
    method insert {args} {
	$self autocomplete -reset
        eval [list $self Insert] [lrange $args 0 end]
    }

    # Stops copmletion cycling on delete.
    method delete {args} {
	$self autocomplete -reset
        eval [list $self Delete] [lrange $args 0 end]
    }

    # Returns the current completion list.
    method CompletionList {} {
        if {[string length [set data [$self cget -aclistvar]]] != 0} {
            return [set $data]
        } elseif {[string length [set data [$self cget -aclistproc]]] != 0} {
            return [$data $self]
        } else {
            return [$self cget -aclist]
        }
    }

    method CreatePopup {} {
        set rootx [winfo rootx $self]
        set rooty [winfo rooty $self]
        set left [lindex [$self bbox $CmdBegin] 0]
        set right [lindex [$self bbox $CmdEnd] 2]

        set Popup [popuplist $self.popup -borderwidth 2\
                -left [expr {$left + $rootx - 3}]\
                -top [expr {[winfo height $self] + $rooty + 3]}]\
                -right [expr {$right + $rootx + 3}]\
                -bottom [expr {$rooty - 3}]\
                -preferredgravity nw]

        bind [winfo toplevel $self] <Configure> [mymethod MovePopup]
        bind $self <Configure> [mymethod MovePopup]

        return $Popup
    }

    method KillPopup {} {
        if {$Popup == ""} {return}

        destroy $Popup
    }

    method MovePopup {} {
        if {$Popup == ""} {return}

        set rootx [winfo rootx $self]
        set rooty [winfo rooty $self]
        $Popup configure\
                -left [expr {[lindex [$self bbox $CmdBegin] 0] + $rootx - 2}]\
                -top [expr {[winfo height $self] + $rooty + 2]}]\
                -right [expr {[lindex [$self bbox $CmdEnd] 2] + $rootx + 2}]\
                -bottom [expr {$rooty - 2}]
    }

    # This is based on code by RS from the Wiki.
    # http://mini.net/tcl/44
    proc commonPrefixLength {sList} {
        # Find and return the length of a common prefix to all strings in sList.

        set result 0
        foreach char [split [lindex $sList 0] ""] {
            foreach s [lrange $sList 1 end] {
                if {[string index $s $result] != $char} {return $result}
            }
            incr result
        }
        return $result
    }

    # Returns a list containing all entries in sList that begin with prefix.
    proc filterPrefix {sList prefix} {
        set result {}
        set prefixLen [string length $prefix]
        foreach elem $sList {
            if {[string compare -length $prefixLen $elem $prefix] == 0} {
                lappend result $elem
            }
        }
        return $result
    }

    delegate method Delete to hull as delete
    delegate method Icursor to hull as icursor
    delegate method Insert to hull as insert
    delegate method * to hull
    delegate option * to hull
}

# Useful procedure...
proc arg_pop {out in} {
	upvar $in inList
	if {[llength $inList] - [llength $out] < 0} {return 0}
	set idx 0
	foreach outVar $out {
		upvar $outVar var
		set var [lindex $inList $idx]
		incr idx
	}
	set inList [lrange $inList [llength $out] end]
	return 1
}

# Default completion list.
proc completionList {args} {
    return {/clear /connect /setup /server Echo Eclipse Unununium}
}

proc main {} {
    # Using an inline list
    #acentry .e -aclist {/clear /connect /setup /server Echo Eclipse Unununium}

    # Using a list variable
    #acentry .e -aclistvar ::completionList

    # Using a list generator proc
    acentry .e -aclistproc ::completionList -width 30 -highlightthickness 0

    bind ACEntry <Key-Tab> "%W autocomplete; break"
    bind ACEntry <Shift-Key-Tab> "%W autocomplete -reverse; break"
    bind ACEntry <Control-Key-u> "%W delete 0 end"
    pack .e -fill x -padx 5 -pady 5
    focus .e
    wm resizable . 1 0
    update

    set geom [lrange [split [wm geometry .] +-x] 0 1]
    wm minsize . [lindex $geom 0] [lindex $geom 1]
}
main

# vi:sw=4 sts=4 ts=8 et