if 0 {
Copyright 2004, 2005 George Peter Staplin.  

The following terms apply to all files associated with the software unless
explicitly disclaimed in individual files.

The authors hereby grant permission to use, copy, modify, distribute,
and license this software and its documentation for any purpose, provided
that existing copyright notices are retained in all copies and that this
notice is included verbatim in any distributions. No written agreement,
license, or royalty fee is required for any of the authorized uses.
Modifications to this software may be copyrighted by their authors
and need not follow the licensing terms described here, provided that
the new terms are clearly indicated on the first page of each file where
they apply.

IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.

THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE
IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
MODIFICATIONS.

}
# By George Peter Staplin
# See also the README for a list of contributors
# RCS: @(#) $Id: ctext.tcl,v 1.3 2004/08/18 03:45:18 andreas_kupries Exp $

package require Tk
package provide ctext 3.1

namespace eval ctext {}

#win is used as a unique token to create arrays for each ctext instance
proc ctext::getAr {win suffix name} {
        set arName __ctext[set win][set suffix]
        uplevel [list upvar #0 $arName $name]
        return $arName
}

proc ctext {win args} { 
        if {[llength $args] & 1} {
                return -code error "invalid number of arguments given to ctext (uneven number after window) : $args"
        }
        
        frame $win -class Ctext

        set tmp [text .__ctextTemp]
        
        ctext::getAr $win config ar

        set ar(-fg) [$tmp cget -foreground]
        set ar(-bg) [$tmp cget -background]
        set ar(-font) [$tmp cget -font]
        set ar(-relief) [$tmp cget -relief]
        destroy $tmp
        set ar(-yscrollcommand) ""
        set ar(-linemap) 1
        set ar(-linemapfg) $ar(-fg)
        set ar(-linemapbg) $ar(-bg)
        set ar(-linemap_mark_command) {}
        set ar(-linemap_markable) 1
        set ar(-linemap_select_fg) black
        set ar(-linemap_select_bg) yellow
        set ar(-highlight) 1
        set ar(win) $win
        set ar(modified) 0
        
        set ar(ctextFlags) [list -yscrollcommand -linemap -linemapfg -linemapbg \
-font -linemap_mark_command -highlight -linemap_markable -linemap_select_fg \
-linemap_select_bg]
        
        array set ar $args
        
        foreach flag {foreground background} short {fg bg} {
                if {[info exists ar(-$flag)] == 1} {
                        set ar(-$short) $ar(-$flag)
                        unset ar(-$flag)
                }
        }
        
        #Now remove flags that will confuse text and those that need modification:
        foreach arg $ar(ctextFlags) {
                if {[set loc [lsearch $args $arg]] >= 0} {
                        set args [lreplace $args $loc [expr {$loc + 1}]]
                }
        }
        
        text $win.l -font $ar(-font) -width 1 -height 1 \
                -relief $ar(-relief) -fg $ar(-linemapfg) \
                -bg $ar(-linemapbg) -takefocus 0

        set topWin [winfo toplevel $win]
        bindtags $win.l [list $win.l $topWin all]

        if {$ar(-linemap) == 1} {
                grid $win.l -sticky ns -row 0 -column 0
        }
        
        set args [concat $args [list -yscrollcommand [list ctext::event:yscroll $win $ar(-yscrollcommand)]]]

        #escape $win, because it could have a space
        eval text \$win.t -font \$ar(-font) $args
        
        grid $win.t -row 0 -column 1 -sticky news
        grid rowconfigure $win 0 -weight 100
        grid columnconfigure $win 1 -weight 100

        bind $win.t <Configure> [list ctext::linemapUpdate $win]
        bind $win.l <ButtonPress-1> [list ctext::linemapToggleMark $win %y]
        bind $win.t <KeyRelease-Return> [list ctext::linemapUpdate $win]
        rename $win __ctextJunk$win
        rename $win.t $win._t

        bind $win <Destroy> [list ctext::event:Destroy $win %W]
        bindtags $win.t [linsert [bindtags $win.t] 0 $win]

        interp alias {} $win {} ctext::instanceCmd $win
        interp alias {} $win.t {} $win
        
        #If the user wants C comments they should call ctext::enableComments
        ctext::disableComments $win
        ctext::modified $win 0
        ctext::buildArgParseTable $win

        return $win
}

proc ctext::event:yscroll {win clientData args} {
        ctext::linemapUpdate $win

        if {$clientData == ""} {
                return
        }
        uplevel #0 $clientData $args
}

proc ctext::event:Destroy {win dWin} {
        if {![string equal $win $dWin]} {
                return
        }
        catch {rename $win {}}
        interp alias {} $win.t {}
        ctext::clearHighlightClasses $win
        array unset [ctext::getAr $win config ar]
}

#This stores the arg table within the config array for each instance.
#It's used by the configure instance command.
proc ctext::buildArgParseTable win {
        set argTable [list]

        lappend argTable any -linemap_mark_command {
                set configAr(-linemap_mark_command) $value
                break
        }

        lappend argTable {1 true yes} -linemap {
                grid $self.l -sticky ns -row 0 -column 0
                grid columnconfigure $self 0 \
                        -minsize [winfo reqwidth $self.l]
                set configAr(-linemap) 1
                break
        }

        lappend argTable {0 false no} -linemap {
                grid forget $self.l
                grid columnconfigure $self 0 -minsize 0
                set configAr(-linemap) 0
                break
        }

        lappend argTable any -yscrollcommand {
                set cmd [list $self._t config -yscrollcommand [list ctext::event:yscroll $self $value]]

                if {[catch $cmd res]} {
                        return $res
                }
                set configAr(-yscrollcommand) $value
                break
        }

        lappend argTable any -linemapfg {
                if {[catch {winfo rgb $self $value} res]} {
                        return -code error $res
                }
                $self.l config -fg $value
                set configAr(-linemapfg) $value
                break
        }

        lappend argTable any -linemapbg {
                if {[catch {winfo rgb $self $value} res]} {
                        return -code error $res
                }
                $self.l config -bg $value
                set configAr(-linemapbg) $value
                break
        }

        lappend argTable any -font {
                if {[catch {$self.l config -font $value} res]} {
                        return -code error $res
                }
                $self._t config -font $value
                set configAr(-font) $value
                break
        }

        lappend argTable {0 false no} -highlight {
                set configAr(-highlight) 0
                break
        }

        lappend argTable {1 true yes} -highlight {
                set configAr(-highlight) 1
                break
        }

        lappend argTable {0 false no} -linemap_markable {
                set configAr(-linemap_markable) 0
                break
        }

        lappend argTable {1 true yes} -linemap_markable {
                set configAr(-linemap_markable) 1
                break
        }

        lappend argTable any -linemap_select_fg {
                if {[catch {winfo rgb $self $value} res]} {
                        return -code error $res
                }
                set configAr(-linemap_select_fg) $value
                $self.l tag configure lmark -foreground $value
                break
        }

        lappend argTable any -linemap_select_bg {
                if {[catch {winfo rgb $self $value} res]} {
                        return -code error $res
                }
                set configAr(-linemap_select_bg) $value
                $self.l tag configure lmark -background $value
                break
        }

        ctext::getAr $win config ar
        set ar(argTable) $argTable
}

proc ctext::instanceCmd {self cmd args} {
        #slightly different than the RE used in ctext::comments
        set commentRE {\"|\\|'|/|\*}

        switch -glob -- $cmd {
                append {
                        if {[catch {$self._t get sel.first sel.last} data] == 0} {
                                clipboard append -displayof $self $data
                        }
                }

                cget {
                        set arg [lindex $args 0]
                        ctext::getAr $self config configAr

                        foreach flag $configAr(ctextFlags) {
                                if {[string match ${arg}* $flag]} {
                                        return [set configAr($flag)]
                                }
                        }
                        return [$self._t cget $arg]
                }

                conf* {
                        ctext::getAr $self config configAr

                        if {0 == [llength $args]} {
                                set res [$self._t configure]
                                set del [lsearch -glob $res -yscrollcommand*]                
                                set res [lreplace $res $del $del]
                        
                                foreach flag $configAr(ctextFlags) {
                                        lappend res [list $flag [set configAr($flag)]]
                                }                                
                                return $res
                        }
                        
                        array set flags {}
                        foreach flag $configAr(ctextFlags) {
                                set loc [lsearch $args $flag]
                                if {$loc < 0} {
                                        continue
                                }
                                
                                if {[llength $args] <= ($loc + 1)} {
                                        #.t config -flag
                                        return [set configAr($flag)]
                                }

                                set flagArg [lindex $args [expr {$loc + 1}]]
                                set args [lreplace $args $loc [expr {$loc + 1}]]
                                set flags($flag) $flagArg
                        }

                        foreach {valueList flag cmd} $configAr(argTable) {
                                if {[info exists flags($flag)]} {
                                        foreach valueToCheckFor $valueList {
                                                set value [set flags($flag)]
                                                if {[string equal "any" $valueToCheckFor]} $cmd \
                                                elseif {[string equal $valueToCheckFor [set flags($flag)]]} $cmd 
                                        }
                                }
                        }
                        
                        if {[llength $args]} {
                                #we take care of configure without args at the top of this branch
                                uplevel 1 [linsert $args 0 $self._t configure]
                        }
                }

                copy {
                        tk_textCopy $self
                } 

                cut {
                        if {[catch {$self.t get sel.first sel.last} data] == 0} {
                                clipboard clear -displayof $self.t
                                clipboard append -displayof $self.t $data
                                $self delete [$self.t index sel.first] [$self.t index sel.last]
                                ctext::modified $self 1
                        }
                }

                delete {
                        #delete n.n ?n.n
                        
                        #first deal with delete n.n
                        set argsLength [llength $args]
                        
                        if {$argsLength == 1} {
                                set deletePos [lindex $args 0]
                                set prevChar [$self._t get $deletePos]
                                
                                $self._t delete $deletePos
                                set char [$self._t get $deletePos]
                                
                                set prevSpace [ctext::findPreviousSpace $self._t $deletePos]
                                set nextSpace [ctext::findNextSpace $self._t $deletePos]
                                
                                set lineStart [$self._t index "$deletePos linestart"]
                                set lineEnd [$self._t index "$deletePos + 1 chars lineend"]
                                
                                if {[string equal $prevChar "#"] || [string equal $char "#"]} {
                                        set removeStart $lineStart
                                        set removeEnd $lineEnd
                                } else {
                                        set removeStart $prevSpace
                                        set removeEnd $nextSpace
                                }
                                
                                foreach tag [$self._t tag names] {
                                        if {[string equal $tag "_cComment"] != 1} {
                                                $self._t tag remove $tag $removeStart $removeEnd
                                        }
                                }
                                
                                set checkStr "$prevChar[set char]"
                                
                                if {[regexp $commentRE $checkStr]} {
                                        after idle [list ctext::comments $self]
                                }
                                ctext::highlight $self $lineStart $lineEnd
                                ctext::linemapUpdate $self
                        } elseif {$argsLength == 2} {
                                #now deal with delete n.n ?n.n?
                                set deleteStartPos [lindex $args 0]
                                set deleteEndPos [lindex $args 1]
                                
                                set data [$self._t get $deleteStartPos $deleteEndPos]
                                
                                set lineStart [$self._t index "$deleteStartPos linestart"]
                                set lineEnd [$self._t index "$deleteEndPos + 1 chars lineend"]
                                eval \$self._t delete $args
                                
                                foreach tag [$self._t tag names] {
                                        if {[string equal $tag "_cComment"] != 1} {
                                                $self._t tag remove $tag $lineStart $lineEnd
                                        }
                                }
                                
                                if {[regexp $commentRE $data]} {
                                        after idle [list ctext::comments $self]
                                }
                                
                                ctext::highlight $self $lineStart $lineEnd
                                if {[string first "\n" $data] >= 0} {
                                        ctext::linemapUpdate $self
                                }
                        } else {
                                return -code error "invalid argument(s) sent to $self delete: $args"
                        }
                        ctext::modified $self 1
                }

                fastdelete {
                        eval \$self._t delete $args
                        ctext::modified $self 1
                        ctext::linemapUpdate $self
                }
                
                fastinsert {
                        eval \$self._t insert $args
                        ctext::modified $self 1
                        ctext::linemapUpdate $self
                }
                
                highlight {
                        ctext::highlight $self [lindex $args 0] [lindex $args 1]
                        ctext::comments $self
                }

                insert {
                        if {[llength $args] < 2} {
                                return -code error "please use at least 2 arguments to $self insert"
                        }
                        set insertPos [lindex $args 0]  
                        set prevChar [$self._t get "$insertPos - 1 chars"]
                        set nextChar [$self._t get $insertPos]
                        set lineStart [$self._t index "$insertPos linestart"]
                        set prevSpace [ctext::findPreviousSpace $self._t ${insertPos}-1c]
                        set data [lindex $args 1]   
                        eval \$self._t insert $args 

                        set nextSpace [ctext::findNextSpace $self._t insert]
                        set lineEnd [$self._t index "insert lineend"] 
                         
                        if {[$self._t compare $prevSpace < $lineStart]} {
                                set prevSpace $lineStart
                        }

                        if {[$self._t compare $nextSpace > $lineEnd]} {
                                set nextSpace $lineEnd
                        }
                        
                        foreach tag [$self._t tag names] { 
                                if {[string equal $tag "_cComment"] != 1} {
                                        $self._t tag remove $tag $prevSpace $nextSpace 
                                }
                        } 

                        set REData $prevChar
                        append REData $data
                        append REData $nextChar
                        if {[regexp $commentRE $REData]} {
                                after idle [list ctext::comments $self]
                        }
                        
                        after idle [list ctext::highlight $self $lineStart $lineEnd]
                        switch -- $data {
                                "\}" {
                                        ctext::matchPair $self "\\\{" "\\\}" "\\"
                                }
                                "\]" {
                                        ctext::matchPair $self "\\\[" "\\\]" "\\"
                                }
                                "\)" {
                                        ctext::matchPair $self "\\(" "\\)" ""
                                }
                                "\"" {
                                        ctext::matchQuote $self
                                }
                        }
                        ctext::modified $self 1
                        ctext::linemapUpdate $self
                }

                paste {
                        tk_textPaste $self 
                        ctext::modified $self 1
                }

                edit {
                        set subCmd [lindex $args 0]
                        set argsLength [llength $args]
                        
                        ctext::getAr $self config ar

                        if {"modified" == $subCmd} {
                                if {$argsLength == 1} {
                                        return $ar(modified)
                                } elseif {$argsLength == 2} {
                                        set value [lindex $args 1]
                                        set ar(modified) $value
                                } else {
                                        return -code error "invalid arg(s) to $self edit modified: $args"
                                }
                        } else {
                                #Tk 8.4 has other edit subcommands that I don't want to emulate.
                                return [uplevel 1 [linsert $args 0 $self._t $cmd]]
                        }
                }
                
                default { 
                        return [uplevel 1 [linsert $args 0 $self._t $cmd]]
                }
        }
}

proc ctext::tag:blink {win count} {
        if {$count & 1} {
                $win tag configure __ctext_blink -foreground [$win cget -bg] -background [$win cget -fg]
        } else {
                $win tag configure __ctext_blink -foreground [$win cget -fg] -background [$win cget -bg]
        }

        if {$count == 4} {
                $win tag delete __ctext_blink 1.0 end
                return
        }
        incr count
        after 50 [list ctext::tag:blink $win $count]
}

proc ctext::matchPair {win str1 str2 escape} {
        set prevChar [$win get "insert - 2 chars"]
        
        if {[string equal $prevChar $escape]} {
                #The char that we thought might be the end is actually escaped.
                return
        }

        set searchRE "[set str1]|[set str2]"
        set count 1
        
        set pos [$win index "insert - 1 chars"]
        set endPair $pos
        set lastFound ""
        while 1 {
                set found [$win search -backwards -regexp $searchRE $pos]
                
                if {$found == "" || [$win compare $found > $pos]} {
                        return
                }

                if {$lastFound != "" && [$win compare $found == $lastFound]} {
                        #The search wrapped and found the previous search
                        return
                }
                
                set lastFound $found
                set char [$win get $found]
                set prevChar [$win get "$found - 1 chars"]
                set pos $found

                if {[string equal $prevChar $escape]} {
                        continue
                } elseif {[string equal $char [subst $str2]]} {
                        incr count
                } elseif {[string equal $char [subst $str1]]} {
                        incr count -1
                        if {$count == 0} {
                                set startPair $found
                                break
                        } 
                } else {
                        #This shouldn't happen.  I may in the future make it return -code error
                        puts stderr "ctext seems to have encountered a bug in ctext::matchPair"
                        return
                }
        }
        
        $win tag add __ctext_blink $startPair
        $win tag add __ctext_blink $endPair
        ctext::tag:blink $win 0
}

proc ctext::matchQuote {win} {
        set endQuote [$win index insert]
        set start [$win index "insert - 1 chars"]
        
        if {[$win get "$start - 1 chars"] == "\\"} {
                #the quote really isn't the end
                return
        }
        set lastFound ""
        while 1 {
                set startQuote [$win search -backwards \" $start]
                if {$startQuote == "" || [$win compare $startQuote > $start]} {
                        #The search found nothing or it wrapped.
                        return
                }

                if {$lastFound != "" && [$win compare $lastFound == $startQuote]} {
                        #We found the character we found before, so it wrapped.
                        return
                }
                set lastFound $startQuote
                set start [$win index "$startQuote - 1 chars"]
                set prevChar [$win get $start]

                if {$prevChar == "\\"} {
                        continue
                }
                break
        }
        
        if {[$win compare $endQuote == $startQuote]} {
                #probably just \"
                return
        }
        
        $win tag add __ctext_blink $startQuote $endQuote
        ctext::tag:blink $win 0
}

proc ctext::enableComments {win} {
        $win tag configure _cComment -foreground khaki
}
proc ctext::disableComments {win} {
        catch {$win tag delete _cComment}
}

proc ctext::comments {win} {
        if {[catch {$win tag cget _cComment -foreground}]} {
                #C comments are disabled
                return
        }

        set startIndex 1.0
        set commentRE {\\\\|\"|\\\"|\\'|'|/\*|\*/}
        set commentStart 0
        set isQuote 0
        set isSingleQuote 0
        set isComment 0
        $win tag remove _cComment 1.0 end
        while 1 {
                set index [$win search -count length -regexp $commentRE $startIndex end]
                
                if {$index == ""} {
                        break
                }
                
                set endIndex [$win index "$index + $length chars"]
                set str [$win get $index $endIndex]
                set startIndex $endIndex

                if {$str == "\\\\"} {
                        continue
                } elseif {$str == "\\\""} {
                        continue
                } elseif {$str == "\\'"} {
                        continue
                } elseif {$str == "\"" && $isComment == 0 && $isSingleQuote == 0} {
                        if {$isQuote} {
                                set isQuote 0
                        } else {
                                set isQuote 1
                        }
                } elseif {$str == "'" && $isComment == 0 && $isQuote == 0} {
                        if {$isSingleQuote} {
                                set isSingleQuote 0
                        } else {
                                set isSingleQuote 1
                        }
                } elseif {$str == "/*" && $isQuote == 0 && $isSingleQuote == 0} {
                        if {$isComment} {
                                #comment in comment
                                break
                        } else {
                                set isComment 1
                                set commentStart $index
                        }
                } elseif {$str == "*/" && $isQuote == 0 && $isSingleQuote == 0} {
                        if {$isComment} {
                                set isComment 0
                                $win tag add _cComment $commentStart $endIndex
                                $win tag raise _cComment
                        } else {
                                #comment end without beginning
                                break
                        }
                }
        }
}

proc ctext::addHighlightClass {win class color keywords} { 
        set ref [ctext::getAr $win highlight ar]
        foreach word $keywords {
                set ar($word) [list $class $color]
        }
        $win tag configure $class 

        ctext::getAr $win classes classesAr
        set classesAr($class) [list $ref $keywords]
}

#For [ ] { } # etc.
proc ctext::addHighlightClassForSpecialChars {win class color chars} {  
        set charList [split $chars ""]

        set ref [ctext::getAr $win highlightSpecialChars ar]
        foreach char $charList {
                set ar($char) [list $class $color]
        }
        $win tag configure $class 

        ctext::getAr $win classes classesAr
        set classesAr($class) [list $ref $charList]
}

proc ctext::addHighlightClassForRegexp {win class color re} {  
        set ref [ctext::getAr $win highlightRegexp ar]

        set ar($class) [list $re $color]
        $win tag configure $class 

        ctext::getAr $win classes classesAr
        set classesAr($class) [list $ref $class]
}

#For things like $blah 
proc ctext::addHighlightClassWithOnlyCharStart {win class color char} { 
        set ref [ctext::getAr $win highlightCharStart ar]

        set ar($char) [list $class $color]
        $win tag configure $class 

        ctext::getAr $win classes classesAr
        set classesAr($class) [list $ref $char]
}

proc ctext::deleteHighlightClass {win classToDelete} {
        ctext::getAr $win classes classesAr

        if {![info exists classesAr($classToDelete)]} {
                return -code error "$classToDelete doesn't exist"
        }
        
        foreach {ref keyList} [set classesAr($classToDelete)] {
                upvar #0 $ref refAr
                foreach key $keyList {
                        if {![info exists refAr($key)]} {
                                continue
                        }
                        unset refAr($key)
                }
        }
        unset classesAr($classToDelete)
}

proc ctext::getHighlightClasses win {
        ctext::getAr $win classes classesAr

        array names classesAr
}

proc ctext::findNextChar {win index char} {
        set i [$win index "$index + 1 chars"]
        set lineend [$win index "$i lineend"]
        while 1 {
                set ch [$win get $i]
                if {[$win compare $i >= $lineend]} {
                        return ""
                }
                if {$ch == $char} {
                        return $i
                }
                set i [$win index "$i + 1 chars"]
        }
}

proc ctext::findNextSpace {win index} {
        set i [$win index $index]
        set lineStart [$win index "$i linestart"]
        set lineEnd [$win index "$i lineend"]
        #Sometimes the lineend fails (I don't know why), so add 1 and try again.
        if {[$win compare $lineEnd == $lineStart]} {
                set lineEnd [$win index "$i + 1 chars lineend"]
        }

        while {1} {
                set ch [$win get $i]

                if {[$win compare $i >= $lineEnd]} {
                        set i $lineEnd
                        break
                }

                if {[string is space $ch]} { 
                        break
                }
                set i [$win index "$i + 1 chars"]
        }
        return $i
}

proc ctext::findPreviousSpace {win index} {
        set i [$win index $index]
        set lineStart [$win index "$i linestart"]
        while {1} {
                set ch [$win get $i]

                if {[$win compare $i <= $lineStart]} {
                        set i $lineStart
                        break
                }

                if {[string is space $ch]} {
                        break
                }
                
                set i [$win index "$i - 1 chars"]
        }
        return $i
}

proc ctext::clearHighlightClasses {win} {
        #no need to catch, because array unset doesn't complain
        #puts [array exists ::ctext::highlight$win]

        ctext::getAr $win highlight ar
        array unset ar
        
        ctext::getAr $win highlightSpecialChars ar
        array unset ar
        
        ctext::getAr $win highlightRegexp ar
        array unset ar
        
        ctext::getAr $win highlightCharStart ar
        array unset ar
        
        ctext::getAr $win classes ar
        array unset ar
}

#This is a proc designed to be overwritten by the user.
#It can be used to update a cursor or animation while
#the text is being highlighted.
proc ctext::update {} {

}

proc ctext::highlight {win start end} {
        ctext::getAr $win config configAr

        if {!$configAr(-highlight)} {
                return
        }

        set si $start
        set twin "$win._t"
        
        #The number of times the loop has run.
        set numTimesLooped 0
        set numUntilUpdate 600

        ctext::getAr $win highlight highlightAr
        ctext::getAr $win highlightSpecialChars highlightSpecialCharsAr
        ctext::getAr $win highlightRegexp highlightRegexpAr
        ctext::getAr $win highlightCharStart highlightCharStartAr

        while 1 {
                set res [$twin search -count length -regexp -- {([^\s\(\{\[\}\]\)\.\t\n\r;\"'\|,]+)} $si $end]
                if {$res == ""} { 
                        break 
                } 
                
                set wordEnd [$twin index "$res + $length chars"]
                set word [$twin get $res $wordEnd] 
                set firstOfWord [string index $word 0]

                if {[info exists highlightAr($word)] == 1} {
                        set wordAttributes [set highlightAr($word)]
                        foreach {tagClass color} $wordAttributes break
                        
                        $twin tag add $tagClass $res $wordEnd
                        $twin tag configure $tagClass -foreground $color

                } elseif {[info exists highlightCharStartAr($firstOfWord)] == 1} {
                        set wordAttributes [set highlightCharStartAr($firstOfWord)]
                        foreach {tagClass color} $wordAttributes break
                        
                        $twin tag add $tagClass $res $wordEnd 
                        $twin tag configure $tagClass -foreground $color
                }
                set si $wordEnd

                incr numTimesLooped
                if {$numTimesLooped >= $numUntilUpdate} {
                        ctext::update
                        set numTimesLooped 0
                }
        }
        
        foreach {ichar tagInfo} [array get highlightSpecialCharsAr] {
                set si $start
                foreach {tagClass color} $tagInfo break

                while 1 {
                        set res [$twin search -- $ichar $si $end] 
                        if {"" == $res} { 
                                break 
                        } 
                        set wordEnd [$twin index "$res + 1 chars"]
        
                        $twin tag add $tagClass $res $wordEnd
                        $twin tag configure $tagClass -foreground $color
                        set si $wordEnd

                        incr numTimesLooped
                        if {$numTimesLooped >= $numUntilUpdate} {
                                ctext::update
                                set numTimesLooped 0
                        }
                }
        }
        
        foreach {tagClass tagInfo} [array get highlightRegexpAr] {
                set si $start
                foreach {re color} $tagInfo break
                while 1 {
                        set res [$twin search -count length -regexp -- $re $si $end] 
                        if {"" == $res} { 
                                break 
                        } 
                
                        set wordEnd [$twin index "$res + $length chars"]
                        $twin tag add $tagClass $res $wordEnd
                        $twin tag configure $tagClass -foreground $color
                        set si $wordEnd
                        
                        incr numTimesLooped
                        if {$numTimesLooped >= $numUntilUpdate} {
                                ctext::update
                                set numTimesLooped 0
                        }
                }
        }
}

proc ctext::linemapToggleMark {win y} {
        ctext::getAr $win config configAr
        
        if {!$configAr(-linemap_markable)} {
                return
        }
        
        set markChar [$win.l index @0,$y] 
        set lineSelected [lindex [split $markChar .] 0]
        set line [$win.l get $lineSelected.0 $lineSelected.end]

        if {$line == ""} {
                return
        }

        ctext::getAr $win linemap linemapAr
        
        if {[info exists linemapAr($line)] == 1} { 
                #It's already marked, so unmark it.
                array unset linemapAr $line
                ctext::linemapUpdate $win
                set type unmarked
        } else {
                #This means that the line isn't toggled, so toggle it.
                array set linemapAr [list $line {}]
                $win.l tag add lmark $markChar [$win.l index "$markChar lineend"] 
                $win.l tag configure lmark -foreground $configAr(-linemap_select_fg) \
-background $configAr(-linemap_select_bg)
                set type marked
        }

        if {[string length $configAr(-linemap_mark_command)]} {
                uplevel #0 [linsert $configAr(-linemap_mark_command) end $win $type $line]
        }
}

#args is here because -yscrollcommand may call it
proc ctext::linemapUpdate {win args} {
        if {[winfo exists $win.l] != 1} { 
                return
        }

        set pixel 0
        set lastLine {}
        set lineList [list]
        set fontMetrics [font metrics [$win._t cget -font]]
        set incrBy [expr {1 + ([lindex $fontMetrics 5] / 2)}]

        while {$pixel < [winfo height $win.l]} {
                set idx [$win._t index @0,$pixel]

                if {$idx != $lastLine} {
                        set line [lindex [split $idx .] 0]
                        set lastLine $idx
                        $win.l config -width [string length $line]
                        lappend lineList $line
                }
                incr pixel $incrBy 
        } 

        ctext::getAr $win linemap linemapAr
        
        $win.l delete 1.0 end
        set lastLine {}
        foreach line $lineList {
                if {$line == $lastLine} {
                        $win.l insert end "\n" 
                } else {
                        if {[info exists linemapAr($line)]} { 
                                $win.l insert end "$line\n" lmark
                        } else {
                                $win.l insert end "$line\n"
                        }
                }
                set lastLine $line
        }
}

proc ctext::modified {win value} {
        ctext::getAr $win config ar
        set ar(modified) $value
        event generate $win <<Modified>>
        return $value
}


proc docproc {plan name arguments body} {
 proc $name $arguments $body
}
 
docproc {} ?set {v_name val} {

 upvar $v_name v
 if {![info exists v]} {
  return -code error "error: variable $v_name doesn't exist."
 }
 set v $val}

docproc {Pointer warping doesn't work well with draggable mice, because it requires lifting the mouse after a while.  It would work better with the type of mouse that doesn't require such things, such as a trackball.  For now, I have disabled the warping.} activate.widget {w} {

 #event generate $w <Motion> -warp 1 -x 0 -y 5
 focus $w}

docproc {} add.function.dialog {} {

 set w .aft
 toplevel $w
 wm transient $w .
 wm geometry $w +[winfo pointerx .]+[winfo pointery .]
 
 label $w.l -text "Function name:"
 set ::new_function_name ""
 entry $w.e -textvariable ::new_function_name
 bind $w.e <ButtonPress-3> {display.entry.selection.menu %W %X %Y}
 
 button $w.cr -text Create -command [list create.function.callback $w]
 button $w.ca -text Cancel -command [list destroy $w]

 grid $w.l $w.e $w.cr $w.ca -sticky we

 bind $w.e <Return> [list create.function.callback $w]}

docproc {} add.to.history {code cmd result} {

 set i 0

 while {[winfo exists [set w .cons.history.f.$i]]} {
  incr i
 }

 if {"ok" eq $code} {
   pack [::tk::label $w -text $cmd -fg black -bg gray60 \
     -anchor w] -anchor w -fill x
 } else {
   pack [::tk::label $w -text $cmd -fg red -bg black \
     -anchor w] -anchor w -fill x
 }

 # We allow clicking errors to make corrections, and save typing.
 bind $w <ButtonPress-1> {.cons.e insert insert [%W cget -text]}

 if {![winfo exists .selection_owner]} {
  entry .selection_owner
 }

 pack [message ${w}_msg -text $result -anchor w -aspect 800] -anchor w -fill x
 bind ${w}_msg <ButtonPress-1> [string map [list TEXT $result] {
   .selection_owner delete 0 end
   .selection_owner insert end {TEXT}
   .selection_owner select range 0 end
   clipboard clear -displayof %W
   clipboard append -displayof %W {TEXT}
   flash.widget %W [%W cget -bg] 0
 }]}

docproc {} bind.tree {w type callback} {

 bind $w $type $callback
 foreach c [winfo children $w] {
  bind.tree $c $type $callback
 }}

docproc {} copy.entry.selection {w} {

 if {![$w selection present]} return
 clipboard clear -displayof $w
 clipboard append -displayof $w \
  [string range [$w get] [$w index sel.first] [$w index sel.last]]
}

docproc {
XXX do the verification of a function while the dialog is visible that is used for editing the name. XXX} create.function.callback {w} {

 if {[regexp {[[:space:]]} $::new_function_name]} {
  tk_messageBox -message "Your function name has a space in it.  This isn't valid." -icon error -type ok
  return
 }

 create.new.function.file $::new_function_name
 destroy $w

 refresh.listbox}

docproc {I want to add hyperlinking in the $::edit_widget, so that it's possible to click on a function and have Fed Builder load the csrc file for that function (if possible).

A graph of the interdependencies would be nice as well.} create.gui {} {

 set max_width [winfo screenwidth .]
 set max_height [winfo screenheight .]

 frame .reg

 label .reg.lf1 -text "F1:" -fg red
 entry .reg.ef1 -textvariable ::f1_cmd
 bind .reg.ef1 <ButtonPress-3> {display.entry.selection.menu %W %X %Y}
 
 label .reg.lf2 -text "F2:" -fg darkgreen
 entry .reg.ef2 -textvariable ::f2_cmd
 bind .reg.ef2 <ButtonPress-3> {display.entry.selection.menu %W %X %Y}

 label .reg.lf3 -text "F3:" -fg blue
 entry .reg.ef3 -textvariable ::f3_cmd
 bind .reg.ef3 <ButtonPress-3> {display.entry.selection.menu %W %X %Y}

 panedwindow .m -orient vertical -showhandle 1
 panedwindow .m.pw -orient horizontal -showhandle 1

 frame .m.pw.fattr
 frame .m.pw.flist
 create.gui.listbox .m.pw.flist
 create.gui.attr .m.pw.fattr

 .m.pw add .m.pw.flist -width [expr {($max_width / 10) * 2}] -sticky news
 .m.pw add .m.pw.fattr -width [expr {($max_width / 10) * 6}] -sticky news

 frame .m.fedit

 frame .m.fedit.tools
 
 label .m.fedit.tools.l -text "Indent level (F5/F6):"
 label .m.fedit.tools.level -textvariable ::indent_level

 button .m.fedit.tools.console -text "Scripting Console" \
  -command scripting.console

 scrollbar .m.fedit.yview -orient vertical \
  -command [list .m.fedit.t yview]
 ?set ::edit_widget \
  [ctext .m.fedit.t -yscrollcommand [list .m.fedit.yview set]]

 editable.widget $::edit_widget

 bind $::edit_widget <ButtonPress-3> {create.text.selection.menu %W %X %Y}

 #XXX we should see if the next line already has an indent
 bind $::edit_widget <Return> {
   %W insert insert \n[string repeat " " [expr {1 + ($::indent_level * 2)}]]
   break
 }

 .m add .m.pw -height [expr {($max_height / 12) * 4}] -sticky news
 .m add .m.fedit -height [expr {($max_height / 10) * 4}] -sticky news

 bind all <F1> {exec.register 1 $::f1_cmd}
 bind all <F2> {exec.register 2 $::f2_cmd}
 bind all <F3> {exec.register 3 $::f3_cmd}
 bind all <F4> {eval.selection %W}

 bind all <F5> {
   if {$::indent_level > 0} {
     incr ::indent_level -1
   }
 }
 bind all <F6> {incr ::indent_level}

 #bind all <F5> {activate.widget .m.pw.fattr.ince}
 #bind all <F6> {activate.widget .m.pw.fattr.arge}
 #bind all <F7> {activate.widget .m.pw.fattr.rete}
 bind all <F8> {activate.widget .m.pw.fattr.plan}

 # We have a bit of a problem, because edit_widget is a
 # megawidget and the child we want to be active is $::edit_widget.t
 # This violates some encapsulation, but there isn't much we can do
 # about it, other than redirect focus via FocusIn in ctext.

 bind all <F9> [list activate.widget $::edit_widget.t]
}

docproc {} create.gui.attr {w} {

 label $w.incl -text "Include: F5" 
 scrollbar $w.incxview -command [list $w.ince xview] -orient horizontal
 entry $w.ince -textvariable ::include -xscrollcommand [list $w.incxview set]
 bind $w.ince <ButtonPress-3> {display.entry.selection.menu %W %X %Y}
 editable.widget $w.ince

 label $w.argl -text "Arguments:"
 entry $w.arge -textvariable ::arguments
 bind $w.arge <ButtonPress-3> {display.entry.selection.menu %W %X %Y}
 editable.widget $w.arge

 label $w.retl -text "Return type:"
 entry $w.rete -textvariable ::return_type
 bind $w.rete <ButtonPress-3> {display.entry.selection.menu %W %X %Y}
 editable.widget $w.rete

 label $w.planl -text "Plan:"
 text $w.plan
 bind $w.plan <ButtonPress-3> {create.text.selection.menu %W %X %Y}
 ?set ::plan_widget $w.plan
 editable.widget $::plan_widget}

docproc {} create.gui.listbox {w} {

 scrollbar $w.yview -orient vertical -command [list $w.list yview]
 listbox $w.list -yscrollcommand [list $w.yview set] -exportselection 0
 bind $w.list <<ListboxSelect>> {load.function.from.selection %W}
 bind $w.list <ButtonPress-3> {create.listbox.popup.menu %W %x %y %X %Y}}

docproc {} create.listbox.popup.menu {w wx wy X Y} {

 set item [set.listbox.selection $w $wx $wy]

 set m .lpopup
 destroy $m
 menu $m -tearoff 0

 if {"" eq $item} {
  # The listbox may be empty, so display a minimal menu.
  $m add command -label "Add Function" -command add.function.dialog
  $m add command -label "Refresh Listbox" \
   -command refresh.listbox
  tk_popup $m $X $Y
  return
 }
 
 $m add command -label "Add Function" -command add.function.dialog
 $m add command -label "Remove Function" \
  -command [list create.remove.function.dialog $item]
 $m add command -label "Rename Function" \
  -command [list create.rename.dialog $item]
 $m add command -label "Refresh Listbox" \
  -command refresh.listbox
 tk_popup $m $X $Y
}

docproc {} create.new.function.file {f} {

 if {[file exists $f.csrc]} return

 write \
  [K [set fd [open $f.csrc w]] [fconfigure $fd -encoding utf-8]] \
  "REVISION 1 1
INCLUDE 0
ARGUMENTS 0
RETURN_TYPE 0
BODY 0\n" 

 close $fd}

docproc {} create.remove.function.dialog {f} {

 set r [tk_messageBox -icon question -type yesno \
  -message "Are you sure you want to remove $f?" -title "Are you sure?"]

 if {"yes" eq $r} {
  remove.function $f
 }
 }

docproc {This is based on some code I took from my ProcMeUp.} create.rename.dialog {from} {
 destroy .trename
 set t [toplevel .trename]
 wm transient $t .
 wm title $t Rename

 frame $t.top

 label $t.top.from -text $from
 label $t.top.lto -text to:
 entry $t.top.to 

 bind $t.top.to <ButtonPress-3> {display.entry.selection.menu %W %X %Y}

 frame $t.fdone

 button $t.fdone.cancel \
  -text Cancel \
  -command [list destroy $t]

 button $t.fdone.ok -text OK \
  -command [string map [list FROM $from ENTRY $t.top.to DIALOG $t] {
  rename.function FROM [ENTRY get]
  destroy DIALOG
 }]

 bind $t.top.to <Return> [list $t.fdone.ok invoke]

 grid $t.top \
  -row 0 \
  -column 0

 grid $t.top.from \
  -row 0 \
  -column 0
 grid $t.top.lto \
  -row 0 \
  -column 1

 grid $t.top.to \
  -row 0 \
  -column 2 

 grid $t.fdone \
  -row 1 \
  -column 0 \
  -sticky e

 grid $t.fdone.cancel \
  -row 0 \
  -column 0
 
 grid $t.fdone.ok \
  -row 0 \
  -column 1

}

docproc {} create.text.selection.menu {w X Y} {

 set m $w._menu
 destroy $m
 menu $m -tearoff 0
 $m add command -label "Select All" -command [list $w tag add sel 1.0 end]
 $m add separator
 $m add command -label Cut -command [list tk_textCut $w]
 $m add command -label Copy -command [list tk_textCopy $w]
 $m add command -label Paste -command [list tk_textPaste $w]
 $m add command -label Delete -command \
  [list catch [list $w delete sel.first sel.last]]
 tk_popup $m $X $Y
 bind $m <Enter> {focus %W}
 focus $m
}

docproc {} cut.entry.selection {w} {

 copy.entry.selection $w
 $w delete sel.first sel.last
}

docproc {} decr {v_name} {

 upvar $v_name v
 incr v -1}

docproc {} disable.editing {} {

 foreach w $::editable_widgets {
  $w configure -state disabled
 }}

docproc {} display.entry.selection.menu {w x y} {

 set m $w._menu
 if {[winfo exists $m]} {
  tk_popup $m $x $y
  return
 }
 menu $m -tearoff 0
 $m add command -label "Select All" -command [list $w selection range 0 end]
 $m add separator
 $m add command -label Cut -command [list cut.entry.selection $w]
 $m add command -label Copy -command [list copy.entry.selection $w]
 $m add command -label Paste -command [list paste.into.entry $w]
 tk_popup $m $x $y
}

docproc {We call this on each widget that should have disabled state when our editor doesn't have a file loaded.} editable.widget {w} {

 lappend ::editable_widgets $w}

docproc {} enable.editing {} {

 foreach w $::editable_widgets {
  $w configure -state normal
 }}

docproc {} eval.selection {w} {

 if {[catch {$w get sel.first sel.last} res]} {
  return
 }
 puts RES:[uplevel #0 $res]
}

docproc {} every {n body} {

 uplevel #0 $body
 after $n [list every $n $body]}

docproc {} exec.register {reg cmd} {

 if {[catch [list eval exec $cmd] res] && "NONE" ne $::errorCode} {
  error $res
  return
 }
 puts RES:$res}

docproc {} file.data {f} {
 set fd [open $f r]
 fconfigure $fd -encoding utf-8
 set data [read $fd]
 close $fd

 return $data

 }

docproc {} fill.listbox {} {

 set w .m.pw.flist.list
 set y [lindex [$w yview] 0]
 $w delete 0 end
 foreach f [lsort -dictionary [glob -nocomplain *.csrc]] {
  $w insert end [file rootname $f]
 }
 $w yview moveto $y}

docproc {} flash.widget {win color i} {


 if {$i >= 4} {
   $win configure -bg $color
   return
 }

 if {$i & 1} {
   $win configure -bg gray40
 } else {
   $win configure -bg white
 }

 after 50 [list flash.widget $win $color [incr i]]}

docproc {It's bad style to use spaces in an include, and I would rather not spend time writing a tokenizer/parser for such a thing.  If you write a patch I would most likely use it though.} generate.c {body} {

 set s ""
 append s "/* REVISION $::revision */\n"
 
 foreach inc [split $::include " \t"] {
  if {"" == [string trim $inc]} { continue; }
  append s "#include $inc\n"
 }
 set sym [string toupper $::function]_C
 append s "#ifndef $sym\n"
 append s "#define $sym\n"
 append s "$::return_type\n$::function ( $::arguments ) \{\n"
 append s $body
 append s "\n\}\n"
 append s "#endif /* $sym */\n"
 return $s}

docproc {} generate.csrc {body} {

 return "REVISION [string length $::revision] $::revision
INCLUDE [string length $::include] $::include
ARGUMENTS [string length $::arguments] $::arguments
RETURN_TYPE [string length $::return_type] $::return_type
BODY [string length $body] $body\n"}

docproc {} get.header {s iStart tokPtr} {

 upvar $tokPtr tok
 set tok ""
 set sLen [string length $s]
 for {set i $iStart} {$i < $sLen} {incr i} {
  set c [string index $s $i]
  if {"\t" == $c || " " == $c || "\n" == $c || "\r" == $c} {
   if {[string length $tok]} {
    return $i
   }
  } else {
   append tok $c
  }
 }
 return $i}

docproc {I'm not sure if I'm doing this concat right.} global.source {f} {

 uplevel #0 [concat source [list $f]]}

docproc {} K {a b} {

 set a}

docproc {} load.function {f} {

 if {![file exists $f.csrc]} {
  return -code error "$f.csrc doesn't exist"
 }
 enable.editing
 save.plan
 save
 $::edit_widget delete 1.0 end
 $::edit_widget insert end [parse.data [file.data $f.csrc]]
 load.plan $f.plan
 set ::function $f

 # We don't want our changes to result in the file being saved immediately after loading. 
 # We only save when we really had changes.
 set ::changed 0
 $::edit_widget edit modified 0}

docproc {} load.function.from.selection {w} {

 set sel [$w curselection]
 if {"" == $sel} {
  return
 }
 load.function [$w get $sel]
}

docproc {} load.plan {f} {

 #puts LOAD_PLAN:$f

 $::plan_widget delete 1.0 end
 $::plan_widget insert end [read [set fd [open $f "CREAT RDONLY"]]]
 close $fd

 # We don't want to save the plan after no changes have occured, so we do this:
 $::plan_widget edit modified 0}

docproc {} main {argc argv} {

 if {$argc > 0} {
  cd [lindex $argv 0]
 }
 #uncomment this and run bld.tcl for hardcoded colors
 #set.gui.defaults

 try.tile 

 set ::f1_cmd ""
 set ::f2_cmd ""
 set ::f3_cmd ""
 set ::indent_level 0

 tk_focusFollowsMouse

 create.gui
 disable.editing
 manage.gui
 refresh.listbox
 setup.variable.traces
 every 800 save.plan
 every 800 save}

docproc { frame .m.fedit.tools
 
 label .m.fedit.tools.l -text "Indent level (F5/F6):"
 label .m.fedit.tools.level -textvariable ::indent_level

 button .m.fedit.tools.console -text "Scripting Console" -command scripting.console} manage.gui {} {

 set r 0
 grid .reg -row $r -column 0 -sticky we
 incr r
  
 foreach {lab ent} [list lf1 ef1 lf2 ef2 lf3 ef3]  {
  pack .reg.$lab -side left
  pack .reg.$ent -side left -fill x -expand 1
 }

 grid .m -row $r -column 0 -sticky news
 
 grid .m.pw.flist.yview -row 0 -column 0 -sticky ns
 grid .m.pw.flist.list -row 0 -column 1 -sticky news
 grid rowconfigure .m.pw.flist 0 -weight 100
 grid columnconfigure .m.pw.flist 1 -weight 100

 manage.gui.attr .m.pw.fattr
 
 grid .m.fedit.tools -row 0 -column 0 -columnspan 2 -sticky we
 grid .m.fedit.tools.l -row 0 -column 0 -sticky w
 grid .m.fedit.tools.level -row 0 -column 1 -stick we
 grid columnconfigure .m.fedit.tools 2 -minsize 10
 grid .m.fedit.tools.console -row 0 -column 3
 

 grid .m.fedit.yview -row 1 -column 0 -sticky ns
 grid .m.fedit.t -row 1 -column 1 -sticky news

 grid rowconfigure . 1 -weight 100
 grid columnconfigure . 0 -weight 100

 grid rowconfigure .m 0 -weight 100
 grid columnconfigure .m 0 -weight 100

 grid rowconfigure .m.fedit 1 -weight 100
 grid columnconfigure .m.fedit 1 -weight 100
}

docproc {} manage.gui.attr {w} {

 grid columnconfigure $w 0 -weight 100
 set r 0
 grid $w.incl -row $r -column 0 -sticky w
 incr r
 grid $w.ince -row $r -column 0 -stick we
 incr r
 grid $w.incxview -row $r -column 0 -sticky we
 incr r
 grid $w.argl -row $r -column 0 -sticky w
 incr r
 grid $w.arge -row $r -column 0 -sticky we
 incr r
 grid $w.retl -row $r -column 0 -sticky w
 incr r
 grid $w.rete -row $r -column 0 -sticky we
 incr r
 grid $w.planl -row $r -column 0 -sticky w
 incr r 
 grid $w.plan -row $r -column 0 -sticky news
 grid rowconfigure $w $r -weight 100}

docproc {} parse.data {data} {

 set i 0
 set tok ""
 set body ""
 while 1 {
  set i [get.header $data $i tok]
  if {"" eq $tok} { 
   return $body
  }
  switch -- $tok {
   REVISION {
    ?set ::revision [parse.data.get.block $data i]
   }
   INCLUDE {
    ?set ::include [parse.data.get.block $data i]
   }
   ARGUMENTS {
    ?set ::arguments [parse.data.get.block $data i]
   }
   RETURN_TYPE {
    ?set ::return_type [parse.data.get.block $data i]
   }
   BODY {
    ?set body [parse.data.get.block $data i]
   }
   default {
    return -code "file contains an unknown directive: $tok"
   }
  }
 }}

docproc {This gets headers in the format of HEADER N VALUE} parse.data.get.block {data i_name} {

 upvar $i_name i
 set len ""
 set i [get.header $data $i len]
 #puts LEN:$len
 if {$len <= 0} {
  return ""
 }
 incr i ;#advance past the space
 #subtract 1 to account for the 0 start
 set end [expr {$i + $len - 1}]
 set r [string range $data $i $end]
 set i [expr {$end + 1}]
 #puts R:$r'
 return $r}

docproc {} paste.into.entry {w} {

 if {[catch {selection get -displayof $w -selection CLIPBOARD} data]} {
  return
 }
 $w insert insert $data}

docproc {} refresh.listbox {} {

 fill.listbox}

docproc {} remove.function {f} {

 if {$::function eq $f} {
  # The function is currently loaded into the editor.
  # Remove the existing state and disable editing (until the user selects another).
  reset.state
 }

 catch {file delete $f.c}
 catch {file delete $f.csrc}
 catch {file delete $f.plan}

 refresh.listbox
 }

docproc {} rename.function {from to} {

 catch {file rename $from.csrc $to.csrc}
 catch {file rename $from.c $to.c}
 catch {file rename $from.plan $to.plan}

 if {$::function eq $from || $::function eq $to} {
  # The currently loaded file happens to be one of the operands.
  # We should clear the state, and let the user select another.
  reset.state
 }

 refresh.listbox}

docproc {} reset.state {} {
 $::plan_widget delete 1.0 end
 $::edit_widget delete 1.0 end
 ?set ::arguments ""
 ?set ::include ""
 ?set ::function ""
 ?set ::return_type ""
 ?set ::revision 1
 ?set ::changed 0
 disable.editing}

docproc {} save {} {

 if {"" eq $::function \
  || (!$::changed && ![$::edit_widget edit modified])} return

 incr ::revision

 write \
  [K [set fd [open $::function.csrc w]] [fconfigure $fd -encoding utf-8]] \
  [generate.csrc [set body [$::edit_widget get 1.0 end-1c]]]
 close $fd

 write \
  [K [set fd [open $::function.c w]] \
   [fconfigure $fd -encoding utf-8]] \
  [generate.c $body]
 close $fd

 ?set ::changed 0
 $::edit_widget edit modified 0}

docproc {} save.plan {} {

 if {"" eq $::function || ![$::plan_widget edit modified]} return

 write \
  [K [set fd [open $::function.plan w]] \
   [fconfigure $fd -encoding utf-8]] \
  [$::plan_widget get 1.0 end-1c]

 close $fd
 $::plan_widget edit modified 0}

docproc {} scripting.console {} {

 if {[winfo exists .cons]} {
  wm deiconify .cons
  raise .cons
  return
 }

 toplevel .cons
 wm transient .cons .

 label .cons.help -text {useful variables: $edit_widget $f1_cmd}

 scrollbar .cons.yview -orient vertical -command {.cons.history yview}
 scrollbar .cons.xview -orient horizontal -command {.cons.history xview}
 canvas .cons.history \
   -yscrollcommand {.cons.yview set} \
   -xscrollcommand {.cons.xview set} -width 300 -height 180
 entry .cons.e

 bind .cons.e <ButtonPress-3> {display.entry.selection.menu %W %X %Y}

 set id [.cons.history create window 0 0 -window [frame .cons.history.f]]

 bind .cons.history.f <Configure> [string map [list ID $id] {
  .cons.history configure -scrollregion [.cons.history bbox ID]
 }]

 bind .cons.e <Return> { 
   if {[catch [%W get] res]} {
     add.to.history error [%W get] $res
   } else  {
     add.to.history ok [%W get] $res
   }
   .cons.e delete 0 end
   after idle {.cons.history yview moveto 1.0}
 }

 grid .cons.help -row 0 -column 0 -columnspan 2 -sticky we
 grid .cons.yview -row 1 -column 0 -sticky ns
 grid .cons.history -row 1 -column 1 -sticky nesw
 grid .cons.xview -row 2 -column 1 -sticky we
 grid .cons.e -row 3 -column 1 -sticky we

 grid rowconfigure .cons 1 -weight 100
 grid columnconfigure .cons 1 -weight 100
 }

docproc {This is typically called by a variable trace callback.

The global ::changed that it alters is used with save and save.plan.} set.changed {args} {

 ?set ::changed 1}

docproc {} set.gui.defaults {} {

 set active_bg #7579a0
 set button_bg #b7b7b7
 set button_fg black
 set frame_bg #ccccba
 set label_bg $frame_bg
 set label_fg black
 set text_bg black
 set text_fg cyan

 option add *highlightThickness 1
 option add *highlightColor black
 option add *highlightBackground black
 option add *insertBackground yellow
 option add *background $frame_bg 
 option add *foreground $text_bg
 option add *borderWidth 1
 option add *border black
 option add *font -*-lucidatypewriter-medium-*-*-*-12-*-*-*-*-*-*-*
 option add *selectColor #ff0000
 option add *activeBackground $active_bg
 
 option add *Button.background $button_bg
 option add *Button.foreground $button_fg
 option add *Button.padX 1
 option add *Button.padY 1

 option add *Checkbutton.selectColor #8690a5
 option add *Checkbutton.background $button_bg
 option add *Checkbutton.foreground $button_fg

 option add *Entry.background $text_bg
 option add *Entry.foreground $text_fg

 option add *Frame.background $frame_bg

 option add *Label.borderWidth 0
 option add *Label.highlightThickness 0
 option add *Label.background $label_bg
 option add *Label.foreground $label_fg
 option add *Label.padX 1
 option add *Label.padY 1

 option add *Listbox.background $text_bg
 option add *Listbox.foreground $text_fg

 option add *Text.background $text_bg
 option add *Text.foreground $text_fg
}

docproc {This is typically called by a mouse pointer binding.  It sets the selection to the area clicked, and then returns the value for the cell/line clicked.} set.listbox.selection {w x y} {

 $w selection clear 0 end
 set i [$w index @[set x],[set y]]
 $w selection set $i
 $w get $i}

docproc {} set.theme {name} {
 if {[catch {tile::setTheme $name} err]} {
  puts stderr "error while setting the theme to $name: $err"
 }}

docproc {} setup.variable.traces {} {

 trace variable ::arguments w set.changed
 trace variable ::include w set.changed
 trace variable ::return_type w set.changed}

docproc {We import ttk::*, because apparently importing tile::* is deprecated.

XXX factor this XXX} try.tile {} {

 
 interp alias {} ::tk::label {} ::label

 if {![catch {package require tile}]} {
   # We should now have tile.
   set.theme plastik

   rename ::tk::label {}
   rename ::label ::tk::label
   uplevel #0 {namespace import -force ttk::*}
   return
 }

 # Now attempt to use a starkit if possible.
 if {[llength [set files [glob -nocomplain ~/tile*.kit]]]} {
   if {[catch {source [lindex [lsort -dictionary $files] end]} err]} {
     puts stderr "tile error:$err"
     return
   }
   package require tile
   set.theme plastik
   rename ::tk::label {}
   rename ::label ::tk::label
   uplevel #0 {namespace import -force ttk::*}
 }
}

docproc {} write {fd data} {

 puts -nonewline $fd $data}



package require Tk

set ::arguments ""
set ::include ""
set ::function ""
set ::return_type ""
set ::revision 1
set ::changed 1

set ::editable_widgets [list]
set ::edit_widget ""
set ::plan_widget ""

main $::argc $::argv