# copyright (C) 1997-2006 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

# $Id: freetext.tcl,v 2.57 2006/01/28 19:16:59 jfontain Exp $


class freeText {

    set (default,font) $font::(mediumNormal)
    set (default,font,size) [font actual $(default,font) -size]

    proc freeText {this parentPath args} composite {
        [new text $parentPath -background $viewer::(background) -wrap word -borderwidth 0 -highlightthickness 0] $args
    } viewer {} {
        set path $widget::($this,path)
        setupTextBindings $path
        viewer::setupDropSite $this $path                                                            ;# allow dropping of data cells
        set ($this,labels) {}
        set family [font actual $(default,font) -family]
        set size $(default,font,size)
        $path configure -font [set ($this,font) [font create -family $family -size $size]]
        $path tag configure bold -font [set ($this,font,bold) [font create -family $family -size $size -weight bold]]
        $path tag configure italic -font [set ($this,font,italic) [font create -family $family -size $size -slant italic]]
        $path tag configure bolditalic\
            -font [set ($this,font,bold,italic) [font create -family $family -size $size -weight bold -slant italic]]
        $path tag configure underline -underline 1
        $path tag configure overstrike -overstrike 1
        if {$global::readOnly} {
            $path configure -state disabled
        } else {
            set bindings [new bindings $path 0]
            # break from class bindings to avoid potentially harmful code and do not fail when there is no selection:
            bindings::set $bindings <Control-b>\
                "catch {$path tag add bold sel.first sel.last; freeText::mergeBoldItalic $path}; break"
            bindings::set $bindings <Control-i>\
                "catch {$path tag add italic sel.first sel.last; freeText::mergeBoldItalic $path}; break"
            bindings::set $bindings <Control-o> "catch {$path tag add overstrike sel.first sel.last}; break"
            bindings::set $bindings <Control-u> "catch {$path tag add underline sel.first sel.last}; break"
            bindings::set $bindings <Control-r> "
                catch {foreach name {bold italic bolditalic overstrike underline} {$path tag remove \$name sel.first sel.last}}
                break
            "
            bindings::set $bindings <Control-plus> "freeText::fontSize $this 1"
            bindings::set $bindings <Control-minus> "freeText::fontSize $this 0"
            set menu [menu $path.menu -tearoff 0]
            set ($this,help) [new menuContextHelp $menu]
            bind PopupMenu$this <ButtonPress-3> "if {\$::tk::Priv(popup) eq \"\"} {tk_popup $menu %X %Y}"
            $menu add command -label [mc {Bigger text}] -command "freeText::fontSize $this 1" -accelerator Ctrl++
            menuContextHelp::set $($this,help) 0 [mc {increase text size, including cells}]
            $menu add command -label [mc {Smaller text}] -command "freeText::fontSize $this 0" -accelerator Ctrl+-
            menuContextHelp::set $($this,help) 1 [mc {decrease text size including cells}]
            $menu add command -label [mc Background]... -command "freeText::chooseBackground $this"
            menuContextHelp::set $($this,help) 2 [mc {choose a background color}]
            bindtags $path [concat [bindtags $path] PopupMenu$this]
            set ($this,bindings) $bindings
            set ($this,tip) [new widgetTip -path $path -text\
                [mc "selection formatting Control keys:\nB(old), I(talic), U(nderline), O(verstrike), R(eset)"]\
            ]
        }
        composite::complete $this
        initializeTags $this
        if {$composite::($this,-endtext) eq ""} {                                                            ;# only in empty viewer
            centerMessage $path [mc "free text:\ndrop data cell(s), input text"] $viewer::(background) $global::viewerMessageColor
            set ($this,event) [after 2000 "centerMessage $path {}; unset freeText::($this,event)"]   ;# remove message after a while
        }
    }

    proc ~freeText {this} {
        catch {after cancel $($this,event)}
        if {[info exists ($this,bindings)]} {
            delete $($this,bindings) $($this,tip) $($this,help)
        }
        if {[info exists ($this,drag)]} {
            delete $($this,drag)
        }
        eval delete $($this,labels)
        if {[info exists ($this,selector)]} {
            delete $($this,selector)
        }
        font delete $($this,font) $($this,font,bold) $($this,font,italic) $($this,font,bold,italic)
        if {$composite::($this,-deletecommand) ne ""} {
            uplevel #0 $composite::($this,-deletecommand)                                   ;# always invoke command at global level
        }
    }

    proc iconData {} {
        return {
            R0lGODlhJAAkAMYAAAAAAAEBAQICAgMDAwQEBAUFBQYGBgcHBwgICAkJCQoKCgwMDA0NDQ4PDg8QDxAQEBISEhMTExUWFRgYGBobGh4fHiAhICIjIiMjIyYn
            JigpKC8vLy8wLzAxMDIzMjM0MzY3Njg4ODo8Oj4/Pj9AP0BBQENEQ0VHRUZIRk5PTk9QT1lbWVpbWmZoZnBycHJ0cnZ4dnh4eHd5d3h8eHt9e3x+fH2AfYCE
            gIKEgoaIhoeJh4iKiIiLiImMiYuNi4iQiI2PjY6RjpCTkJGUkZCYkJOWk5aZlpmcmZyfnJ6hnqCkoKSnpKisqKmtqa6yrrG0sbi8uLm8ubzAvMDEwMXIxcbK
            xsjQyMzQzM/Tz9DU0NHV0dLW0tDY0NPX09ba1tfb19jc2ODk4Ojs6Pj8+AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
            AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACwAAAAAJAAkAAAH/oBjgoOCMYSHhoeDiYWKhIyKkIiPjoMzlWOXlZqNYzExM6Gio6SlpqKf
            kpaYnIqtqoSth7KxlIcAuLm6u7y8nZ+hAJjDigCjkMLEymPJtMnLw83F0MQAhonAM8/FBtAAIaOE27fdy9ae05UA5crnqsJUKRACDidSzAYyCw8ugzkWAya8
            EOSukChhIwBIMJEBQAdmAAhwGABgx5ghABKUiADABjNwoZCNUYEiCpgqABBABAKGBwAOYzwAMDLmyQCYBW8JKsICRIN1zAJ0AaMFwIExC8YxuzZtBQARNZIA
            BSAUzJYA3ZIWY+rp4BgGAK6AWTIVQBAwPQBsGLMBgJAxrk4GfPiIStyYCwAwkFAQESKBDhSBjPFhtAQEADqWotPZRIOADEfAIgFQoEUCBzAG4agwgAINglzt
            UsOUc9do0rtGKT1NkNSN1zdWszYG+8aP2z9knzaG+weR30R6CR+eawZwIkqSJz/FvLlyJUyiS59Ovbr161Cya9/Ovbv371PCix9Pvrz581bSq1/Pvr3791zi
            y59Pv779+2Hy69/Pv7///2IEKOCABBZo4IGBAAA7
        }
    }

    proc options {this} {
        # force size values:
        return [list\
            [list -background $viewer::(background) $viewer::(background)]\
            [list -cellindices {} {}]\
            [list -deletecommand {} {}]\
            [list -draggable 0 0]\
            [list -endtext {} {}]\
            [list -fontsize $(default,font,size) $(default,font,size)]\
            [list -height 3]\
            [list -taginformation {} {}]\
            [list -width 40]\
        ]
    }

    proc set-background {this value} {
        $widget::($this,path) configure -background $value
    }

    proc set-cellindices {this value} {                           ;# indexes 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 in list of indexes
    }

    proc set-endtext {this value} {
        set path $widget::($this,path)
        set state [$path cget -state]
        $path configure -state normal
        $path insert end $value
        $path configure -state $state
    }

    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"]
    }

    proc set-fontsize {this value} {
        font configure $($this,font) -size $value
        font configure $($this,font,bold) -size $value
        font configure $($this,font,italic) -size $value
        font configure $($this,font,bold,italic) -size $value
    }

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

    proc set-taginformation {this value} {}   ;# actual tags initialization delayed after completion since text must be loaded first

    proc initializeTags {this} {
        set path $widget::($this,path)
        foreach {action tag index} $composite::($this,-taginformation) {
            switch $action {
                tagon {
                    set first($tag) $index
                }
                tagoff {
                    if {[info exists first($tag)]} {
                        $path tag add $tag $first($tag) $index
                        unset first($tag)
                    }
                }
            }
        }
    }

    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 $global::dataTypes
    }

    proc monitorCell {this array row column} {                                                    ;# allow duplicate monitored cells
        set path $widget::($this,path)
        if {[info exists ($this,event)]} {centerMessage $path {}}               ;# keep displaying help message only in empty viewer
        viewer::registerTrace $this $array
        if {[info exists ($this,nextCellIndex)]} {                ;# recreate data cell labels placement from recorded configuration
            set index [lindex $composite::($this,-cellindices) $($this,nextCellIndex)]
            if {$index eq ""} {                               ;# indexes list exhausted: we are done initializing from recorded data
                unset ($this,nextCellIndex)
                set index insert                                                         ;# position cell window at insertion cursor
            } else {
                if {[$path get $index] eq "$"} {  ;# backward compatibility: before version 20.4, there was no replacement character
                    set state [$path cget -state]
                    $path configure -state normal
                    $path delete $index                                                         ;# delete cell replacement character
                    $path configure -state $state
                }
                incr ($this,nextCellIndex)                                                            ;# get ready for upcoming cell
            }
        } else {
            set index insert                                                ;# insert cell label text and window at insertion cursor
            $path insert $index "[lindex [viewer::label $array $row $column] 0]: "
        }
        set label [new label $path -font $($this,font,bold)]   ;# labels contents display automatically updated as font size changes
        set labelPath $label::($label,path)
        if {!$global::readOnly} {
            bindtags $labelPath [concat [bindtags $labelPath] PopupMenu$this]
        }
        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 <ButtonPress-1> "freeText::buttonPress $selector $label"
            bind $labelPath <Control-ButtonPress-1> "selector::toggle $selector $label"
            bind $labelPath <Shift-ButtonPress-1> "freeText::extendSelection $this $label"
            bind $labelPath <ButtonRelease-1> "freeText::buttonRelease $selector $label 0"
            bind $labelPath <Control-ButtonRelease-1> "freeText::buttonRelease $selector $label 1"
            bind $labelPath <Shift-ButtonRelease-1> "freeText::buttonRelease $selector $label 1"
        }
        lappend ($this,labels) $label
        $path window create $index -window $labelPath
        set ($this,cell,$label) ${array}($row,$column)
    }

    proc update {this array} {                                                                    ;# update display using cells data
        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} {                                                               ;# note: always return cells in the same order
        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 position (index) in the text
            set list {}
            foreach {key path index} [$widget::($this,path) dump -window 1.0 end] {
                if {$path eq ""} 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 trim [$widget::($this,path) get 1.0 end]] eq "")}]
    }

    proc initializationConfiguration {this} {                                ;# note: always return configurations in the same order
        set options {}
        set text {}

        foreach {key value index} [$widget::($this,path) dump 1.0 end] {                    ;# note: same technique as formulas text
            switch $key {
                text {
                    append text $value
                }
                window {
                    append text $                                   ;# replace windows by a character since they increment the index
                    if {$value ne ""} {                                                                    ;# ignore deleted windows
                       set position($value) $index
                    }
                }
            }
        }
        lappend options -endtext [string trimright $text \n]                                        ;# remove useless trailing lines
        if {[info exists position]} {
            foreach label $($this,labels) {                                                          ;# get labels in creation order
                lappend indexes $position($label::($label,path))
            }
            lappend options -cellindices $indexes                  ;# so that labels may be placed properly when reloading from file
        }
        set list {}
        foreach {action tag index} [$widget::($this,path) dump -tag 1.0 end] {
            if {$tag eq "sel"} continue                                                                          ;# ignore selection
            lappend list $action $tag $index
        }
        if {[llength $list] > 0} {
            lappend options -taginformation $list
        }
        lappend options -background $composite::($this,-background) -fontsize $composite::($this,-fontsize)
        return $options
    }

    proc setCellColor {this cell color} {                                                                      ;# color can be empty
        foreach label $($this,labels) {
            if {$($this,cell,$label) eq $cell} {
                switched::configure $label -background $color
            }                                                               ;# not done since there can be duplicate monitored cells
        }
    }

    proc monitored {this cell} {
        foreach label $($this,labels) {
            if {$($this,cell,$label) eq $cell} {
                return 1
            }                                                               ;# not done since there can be duplicate monitored cells
        }
        return 0
    }

    proc mergeBoldItalic {path} {
        set end [$path index end]
        set index 1.0
        while {$index ne $end} {
            set names [$path tag names $index]
            if {([lsearch -exact $names bold] >= 0) && ([lsearch -exact $names italic] >= 0)} {
                $path tag remove bold $index
                $path tag remove italic $index
                $path tag add bolditalic $index
            }
            set index [$path index $index+1c]
        }
    }

    proc buttonPress {selector label} {
        foreach selected [selector::selected $selector] {
            if {$selected eq $label} return                                 ;# in an already selected label, do not change selection
        }
        selector::select $selector $label
    }

    proc buttonRelease {selector label extended} {                  ;# extended means that there is an extended selection in process
        if {$extended} return
        set list [selector::selected $selector]
        if {[llength $list] <= 1} return                                          ;# nothing to do if there is no multiple selection
        foreach selected $list {
            if {$selected eq $label} {                                                               ;# in an already selected label
                selector::select $selector $label                                                     ;# set selection to sole label
                return
            }
        }
    }

    proc fontSize {this increase} {
        if {![info exists ($this,font,sizes)]} {
            set ($this,font,sizes) [font::sizes [font actual $($this,font) -family] 1]
        }
        if {$increase} {
            foreach size $($this,font,sizes) {
                if {$size > $composite::($this,-fontsize)} break
            }
        } else {
            foreach size [lsort -integer -decreasing $($this,font,sizes)] {
                if {$size < $composite::($this,-fontsize)} break
            }
        }
        composite::configure $this -fontsize $size
    }

    proc chooseBackground {this} {
        set color\
            [tk_chooseColor -initialcolor $composite::($this,-background) -title [mc {Choose color}] -parent $widget::($this,path)]
        if {$color eq ""} return                                                                     ;# user cancellation: no change
        composite::configure $this -background $color
    }

}


class freeText {

    class label {

        proc label {this parentPath args} switched {$args} {
            set label [new label $parentPath -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 {$switched::($this,-deletecommand) ne ""} {
                uplevel #0 $switched::($this,-deletecommand)                                ;# always invoke command at global level
            }
        }

        proc options {this} {
            return [list\
                [list -background {}]\
                [list -deletecommand {} {}]\
                [list -font $font::(mediumBold)]\
                [list -text {} {}]\
            ]
        }

        proc set-background {this value} {
            if {$value eq ""} {
                $($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-font {this value} {
            $($this,path) configure -font $value
        }

        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
            }
        }

    }

}
