# copyright (C) 1997-2001 Jean-Luc Fontaine (mailto:jfontain@free.fr)
# this program is free software: please read the COPYRIGHT file enclosed in this package or use the Help Copyright menu

set rcsId {$Id: freetext.tcl,v 2.17 2001/02/03 17:20:11 jfontain Exp $}


class freeText {

    proc freeText {this parentPath args} composite {
        [new text $parentPath -font $font::(mediumNormal) -wrap word -borderwidth 0 -highlightthickness 0] $args
    } viewer {} {
        viewer::setupDropSite $this $widget::($this,path)                                            ;# allow dropping of data cells
        set ($this,labels) {}
        composite::complete $this
    }

    proc ~freeText {this} {
        if {[info exists ($this,drag)]} {
            delete $($this,drag)
        }
        eval delete $($this,labels)
        if {[info exists ($this,selector)]} {
            delete $($this,selector)
        }
        if {[string length $composite::($this,-deletecommand)]>0} {
            uplevel #0 $composite::($this,-deletecommand)                                   ;# always invoke command at global level
        }
    }

    proc iconData {} {
        return {
            R0lGODdhJAAkAIQAAPj8+Hh4eHh8eAAAANjc2Dg4OJicmICEgIiQiJCYkKCkoKisqLi8uMDEwMjQyNDY0ODk4Ojs6AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
            AAAAAAAAAAAAAAAAAAAAAAAAACwAAAAAJAAkAAAF/iAgjmJAnuY5pqVKsiqMvu4o1MBd6y0QBIKgcEgsGoU/mQ3HUzWVpOZJGqWpBtisdsvd9n7CAWFMLpvP
            5MFQJka73QMRFdB+29NyV/1uH5hSYEF7fHAFQyeDZViEfj56b1gGfI1QdVpjkYuYWWl/JUNtkQaLnKQDBqOhhkFsZKgEmaeps2OvlI+bWbSxkoqeV5uovLCn
            kWa3PqDBxKliw5oDqwKtucS8klq2v4hlqJLe370E4JjbJImEx79c6X1bROjtmEQH9fXx8mr2Bwj9/fjt1PhDkKBgwS4IE2IRYDCBgocQj0iUCFHBgosYM2rc
            yLEjg48gQ4ocSbJkg5MoK1OqXMmypYOXMGPKnEmz5oObOHPq3MmzJ4SfQIMKHUq0aISjSJMqXcq0aQgAOw==
        }
    }

    proc options {this} {
        # force size values
        return [list\
            [list -cellindices {} {}]\
            [list -deletecommand {} {}]\
            [list -draggable 0 0]\
            [list -endtext {} {}]\
            [list -height 1]\
            [list -width 40]\
        ]
    }

    proc set-cellindices {this value} {                           ;# indices of soon to be created cells when initializing from file
        if {$composite::($this,complete)} {
            error {option -cellindices cannot be set dynamically}
        }
        set ($this,nextCellIndex) 0                                      ;# initialize cell insertion index index in list of indices
    }

    proc set-endtext {this value} {
        $widget::($this,path) insert end $value
    }

    proc set-deletecommand {this value} {}

    proc set-draggable {this value} {
        if {$composite::($this,complete)} {
            error {option -draggable cannot be set dynamically}
        }
        if {!$value} return                                                                                           ;# no dragging
        set ($this,drag) [new dragSite -path $widget::($this,path) -validcommand "freeText::validateDrag $this 0"]
        dragSite::provide $($this,drag) OBJECTS "freeText::dragData $this"
        set ($this,selector) [new selector -selectcommand "freeText::setLabelsState $this"]
    }

    foreach option {-height -width} {
        proc set$option {this value} "\$widget::(\$this,path) configure $option \$value"
    }

    proc dragData {this format} {
        switch $format {
            OBJECTS {
                set list [selector::selected $($this,selector)]
                if {[llength $list]>0} {
                    return $list                                                          ;# return selected labels if there are any
                } elseif {[empty $this]} {
                    return $this                                                               ;# return text object itself if empty
                } else {
                    return {}                                                                            ;# return nothing otherwise
                }
            }
            DATACELLS {
                return [cellsFromLabels $this [selector::selected $($this,selector)]]
            }
        }
    }

    proc validateDrag {this label x y} {
        if {($label==0)&&[empty $this]} {                                                                 ;# dragging from text area
            return 1                                                                       ;# empty viewer may be dragged into trash
        } elseif {[lsearch -exact [selector::selected $($this,selector)] $label]>=0} {
            return 1                                                                      ;# allow dragging from selected label only
        } else {
            return 0
        }
    }

    proc supportedTypes {this} {
        return {ascii dictionary integer real clock}
    }

    proc monitorCell {this array row column} {                                                    ;# allow duplicate monitored cells
        viewer::registerTrace $this $array
        set path $widget::($this,path)
        if {[info exists ($this,nextCellIndex)]} {                ;# recreate data cell labels placement from recorded configuration
            set index [lindex $composite::($this,-cellindices) $($this,nextCellIndex)]
            if {[string length $index]==0} {                  ;# indices list exhausted: we are done initializing from recorded data
                unset ($this,nextCellIndex)
                set index insert                                                         ;# position cell window at insertion cursor
            } else {
                incr ($this,nextCellIndex)                                                            ;# get ready for upcoming cell
            }
        } else {
            set index insert                                                ;# insert cell label text and window at insertion cursor
            $path insert $index "[viewer::label $array $row $column]: "
        }
        set label [new label $path]
        set labelPath $label::($label,path)
        switched::configure $label -deletecommand "freeText::deletedLabel $this $array $label"      ;# keep track of label existence
        if {$composite::($this,-draggable)} {                                              ;# setup dragging and selection for label
            set drag [new dragSite -path $labelPath -validcommand "freeText::validateDrag $this $label"]
            dragSite::provide $drag OBJECTS "freeText::dragData $this"
            dragSite::provide $drag DATACELLS "freeText::dragData $this"
            set ($this,drag,$label) $drag
            set selector $($this,selector)
            selector::add $selector $label
            bind $labelPath <ButtonRelease-1> "selector::select $selector $label"
            bind $labelPath <Control-ButtonRelease-1> "selector::toggle $selector $label"
            bind $labelPath <Shift-ButtonRelease-1> "freeText::extendSelection $this $label"
        }
        lappend ($this,labels) $label
        $path window create $index -window $labelPath
        set ($this,cell,$label) ${array}($row,$column)
    }

    proc update {this array args} {                              ;# update display using cells data. ignore eventual trace arguments
        foreach label $($this,labels) {
            set cell $($this,cell,$label)
            if {[string first $array $cell]<0} continue                                  ;# check that cell belongs to updated array
            if {[info exists $cell]} {
                switched::configure $label -text [set $cell]                                               ;# may be the ? character
            } else {
                switched::configure $label -text ?
            }
        }
    }

    proc deletedLabel {this array label} {
        if {$composite::($this,-draggable)} {
            delete $($this,drag,$label)
            selector::remove $($this,selector) $label
        }
        viewer::unregisterTrace $this $array                                          ;# trace may no longer be needed on this array
        ldelete ($this,labels) $label
        unset ($this,cell,$label)
    }

    proc cellsFromLabels {this labels} {
        set cells {}
        foreach label $labels {
            lappend cells $($this,cell,$label)
        }
        return $cells                                                                                      ;# may contain duplicates
    }

    proc cells {this} {
        return [cellsFromLabels $this $($this,labels)]
    }

    proc setLabelsState {this labels select} {
        foreach label $labels {
            label::select $label $select
        }
    }

    proc extendSelection {this endLabel} {
        set selector $($this,selector)
        if {[info exists selector::($selector,lastSelected)]} {                             ;# extend from previously selected label
            # build path to label mapping table (reasonable since it is likely that there is only a few embedded labels in the text)
            foreach label $($this,labels) {
                set labelFromPath($label::($label,path)) $label
            }
            # build ordered label list from windows returned ordered according to their postion (index) in the text
            set list {}
            foreach {key path index} [$widget::($this,path) dump -window 1.0 end] {
                if {[string length $path]==0} continue                                                     ;# ignore deleted windows
                lappend list $labelFromPath($path)
            }
            set start [lsearch -exact $list $selector::($selector,lastSelected)]
            set end [lsearch -exact $list $endLabel]
            if {$end<$start} {                                                           ;# make sure limits are in increasing order
                set index $start
                set start $end
                set end $index
            }
            selector::clear $selector
            selector::set $selector [lrange $list $start $end] 1
        } else {
            selector::select $selector $endLabel
        }
    }

    proc empty {this} {                                                      ;# if no labels exist and there is no visible text left
        return [expr {([llength $($this,labels)]==0)&&([string length [string trim [$widget::($this,path) get 1.0 end]]]==0)}]
    }

    proc initializationConfiguration {this} {
        set options {}
        set text {}
        foreach {key string index} [$widget::($this,path) dump -text 1.0 end] {
            append text $string
        }
        lappend options -endtext $text
        foreach {key path index} [$widget::($this,path) dump -window 1.0 end] {
            if {[string length $path]==0} continue                                                         ;# ignore deleted windows
            set position($path) $index
        }
        if {[info exists position]} {
            foreach label $($this,labels) {                                                          ;# get labels in creation order
                lappend indices $position($label::($label,path))
            }
            lappend options -cellindices $indices                  ;# so that labels may be placed properly when reloading from file
        }
        return $options
    }

    proc setCellColor {this array row column color} {
        set cell ${array}($row,$column)
        foreach label $($this,labels) {
            if {[string equal $($this,cell,$label) $cell]} {
                switched::configure $label -background $color
            }                                                               ;# not done since there can be duplicate monitored cells
        }
    }

}

class freeText {

    class label {

        proc label {this parentPath args} switched {$args} {
            set label [new label $parentPath -font $font::(mediumBold) -padx 0 -pady 0 -borderwidth 1 -cursor left_ptr]
            # keep track of label existence as it may be deleted by directly editing in the parent text widget
            bind $widget::($label,path) <Destroy> "delete $this"
            set ($this,path) $widget::($label,path)
            set ($this,label) $label
            switched::complete $this
        }

        proc ~label {this} {
            bind $($this,path) <Destroy> {}                                                     ;# remove binding to avoid recursion
            delete $($this,label)
            if {[string length $switched::($this,-deletecommand)]>0} {
                uplevel #0 $switched::($this,-deletecommand)                                ;# always invoke command at global level
            }
        }

        proc options {this} {
            return [list\
                [list -background {}]\
                [list -deletecommand {} {}]\
                [list -text {} {}]\
            ]
        }

        proc set-background {this value} {
            if {[string length $value]==0} {
                $($this,path) configure -background $widget::option(label,background)
            } else {
                $($this,path) configure -background $value
            }
        }

        proc set-deletecommand {this value} {}                                                   ;# data is stored at switched level

        proc set-text {this value} {
            $($this,path) configure -text $value
        }

        proc select {this select} {
            if {$select} {
                $($this,path) configure -relief sunken
            } else {
                $($this,path) configure -relief flat
            }
        }

    }

}
