# 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: dbview.tcl,v 1.56 2006/09/26 19:44:46 jfontain Exp $


# A displayed container for module instances stored in database. Accepts drops from database modules instances dialog box.


class databaseInstances {

    proc databaseInstances {this parentPath args} composite {[new frame $parentPath] $args} {
        variable singleton

        if {[info exists singleton]} {
            error {only 1 database instances object can exist}
        }
        set singleton $this
        set path $widget::($this,path)
        set viewer [blt::stripchart $path.graph -title {} -leftmargin 1 -topmargin 1 -bufferelements 0 -plotborderwidth 1\
            -background $viewer::(background) -cursor {} -highlightthickness 0 -plotpadx 2 -plotpady 0 -width 400 -height 200\
        ]
        $viewer xaxis configure -hide 1
        $viewer yaxis configure -hide 1 -descending 1
        set graph [new bltGraph $viewer]
        bind $viewer <Configure> "+ databaseInstances::resized $this"                       ;# as BLT graph, also track size updates
        set ($this,cursors) [list\
            [new cursor $viewer -command "databaseInstances::cursorMoved $this" -hide 1]\
            [new cursor $viewer -command "databaseInstances::cursorMoved $this" -hide 1]\
        ]
        set ($this,labels) [frame $path.labels]
        grid $viewer -row 0 -column 0 -sticky nwes
        grid rowconfigure $path 0 -weight 1
        grid columnconfigure $path 0 -weight 1
        grid $($this,labels) -row 0 -column 1 -sticky nwes\
            -pady 5                              ;# plot padding plus border width plus a few extra pixels experimentally determined
        set ($this,drop)\
            [new dropSite -path $path -formats {INSTANCES DATETIME KILL} -command "databaseInstances::handleDrop $this"]
        set ($this,graph) $graph
        set ($this,viewer) $viewer
        composite::complete $this
        updateMessage $this
    }

    proc ~databaseInstances {this} {
        variable singleton
        variable ${this}instance

        eval delete [array names ${this}instance]                                                           ;# delete elements first
        if {[info exists ($this,drag)]} {
            delete $($this,drag)
        }
        eval delete $($this,drop) $($this,graph) $($this,cursors)
        eval delete [array names ${this}instance]
        if {[info exists ($this,selector)]} {
            delete $($this,selector)
        }
        if {$composite::($this,-deletecommand) ne ""} {
            uplevel #0 $composite::($this,-deletecommand)                                   ;# always invoke command at global level
        }
        if {[info exists ($this,selfDelete)] && ($composite::($this,-selfdeletecommand) ne "")} {
            uplevel #0 $composite::($this,-selfdeletecommand)                               ;# always invoke command at global level
        }
        unset singleton
    }

    proc options {this} {                                                                            ;# force X axis labels rotation
        return [list\
            [list -deletecommand {} {}]\
            [list -draggable 0 0]\
            [list -plotbackground $global::graphPlotBackground]\
            [list -selfdeletecommand {} {}]\
            [list -xlabelsrotation $global::graphXAxisLabelsRotation]\
        ]
    }

    proc set-deletecommand {this value} {}
    proc set-selfdeletecommand {this value} {}

    proc set-plotbackground {this value} {
        variable ${this}instance

        $($this,viewer) configure -plotbackground $value
        set color [visibleForeground $value]
        foreach element [array names ${this}instance] {
            switched::configure $element -color $color
        }
    }

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

    proc set-xlabelsrotation {this value} {
        bltGraph::xRotateLabels $($this,graph) $value
    }

    proc setLabelsState {this elements select} {
        variable ${this}label

        if {$select} {set relief sunken} else {set relief flat}
        foreach element $elements {
            [set ${this}label($element)] configure -relief $relief
        }
    }

    proc validateDrag {this element x y} {
        variable ${this}instance

        if {($element == 0) && ([array size ${this}instance] == 0)} {
            return 1                                                                                   ;# allow drag of empty viewer
        } elseif {[lsearch -exact [selector::selected $($this,selector)] $element] >= 0} {
            return 1                                                                     ;# also dragging from selected element only
        } else {
            return 0
        }
    }

    proc dragData {this format} {                                                                      ;# format can only be OBJECTS
        variable ${this}instance

        set elements [selector::selected $($this,selector)]
        if {[llength $elements] > 0} {
            return $elements                                                            ;# return selected elements if there are any
        } elseif {[array size ${this}instance] == 0} {
            set ($this,selfDelete) {}                                                       ;# consider this action as self deletion
            return $this                                                           ;# return instances viewer object itself if empty
        } else {
            return {}                                                                                    ;# return nothing otherwise
        }
    }

    proc handleDrop {this} {
        if {[info exists dragSite::data(KILL)]} {
            set ($this,selfDelete) {}
            delete $this                                                                                           ;# self destructs
        } elseif {[info exists dragSite::data(INSTANCES)]} {
            foreach instance $dragSite::data(INSTANCES) {
                monitor $this $instance
            }
        } else {                                                                                                 ;# must be DATETIME
            set value $dragSite::data(DATETIME)                                                                        ;# in seconds
            foreach cursor $($this,cursors) {
                lappend list [list $cursor [expr {abs([switched::cget $cursor -x] - $value)}]]
            }
            switched::configure [lindex [lindex [lsort -real -index end $list] 0] 0] -x $value       ;# move closest cursor to value
        }
    }

    proc monitor {this instanceData {launch 1}} {                                                     ;# module instance in database
        variable ${this}label
        variable ${this}instance
        variable ${this}tip

        foreach {instance module identifier arguments} $instanceData {}
        foreach {element value} [array get ${this}instance] {
            if {$value == $instance} return                                                                     ;# already displayed
        }
        # retrieve instance range from database, which may take a while:
        foreach {start end} [database::instanceRange $global::database $instance] {}
        if {$database::($global::database,error) ne ""} return                                            ;# abort if database error
        set label [label $($this,labels).$instance -font $font::(mediumNormal)]
        if {$identifier ne ""} {set title $identifier} else {set title $module}
        regsub {<0>$} $title {} title                              ;# remove trailing namespace index for first instance of a module
        $label configure -text $title
        pack $label -anchor w
        if {![info exists (labelHeight)]} {
            set (labelHeight) [winfo reqheight $label]
        }
        set element [new element $($this,viewer) -color [visibleForeground $composite::($this,-plotbackground)]]
        if {$end ne ""} {
            set start [clock scan $start]; set end [clock scan $end]
            switched::configure $element -start $start -end $end
        }                                                           ;# else no recorded data for that instance (start is also empty)
        switched::configure $element -deletecommand "databaseInstances::deleted $this $element"
        set ${this}instance($element) $instance
        set ${this}label($element) $label
        set ${this}tip($element) [new widgetTip -path $label -text "$module: $arguments"]
        if {$composite::($this,-draggable)} {
            set drag [new dragSite -path $label -validcommand "databaseInstances::validateDrag $this $element"]
            dragSite::provide $drag OBJECTS "databaseInstances::dragData $this"
            set ($this,drag,$element) $drag
            set selector $($this,selector)
            selector::add $selector $element
            bind $label <ButtonPress-1> "databaseInstances::buttonPress $selector $element"
            bind $label <Control-ButtonPress-1> "selector::toggle $selector $element"
            bind $label <Shift-ButtonPress-1> "selector::extend $selector $element"
            bind $label <ButtonRelease-1> "databaseInstances::buttonRelease $selector $element 0"
            bind $label <Control-ButtonRelease-1> "databaseInstances::buttonRelease $selector $element 1"
            bind $label <Shift-ButtonRelease-1> "databaseInstances::buttonRelease $selector $element 1"
        }
        resized $this
        updateElements $this
        $($this,viewer) xaxis configure -hide 0
        updateAxis $this
        if {$end ne ""} {
            foreach cursor $($this,cursors) {switched::configure $cursor -hide 0}
            setCursors $this $start $end
        }
        if {$launch} {
            launchInstanceModule $instance $module $identifier $arguments
            updateViewObjectsMenu
        }
        updateMessage $this
    }

    proc deleted {this element} {
        variable ${this}label
        variable ${this}instance
        variable ${this}tip

        if {$composite::($this,-draggable)} {
            delete $($this,drag,$element)
            selector::remove $($this,selector) $element
        }
        destroy [set ${this}label($element)]
        delete [set ${this}tip($element)]
        set namespace instance<[set ${this}instance($element)]>
        if {[modules::loadedNamespace $namespace]} {  ;# may have been unloaded already when, for example, user unloaded all modules
            dynamicallyUnloadModule $namespace                                       ;# happens when dragging and dropping in eraser
        }
        unset ${this}instance($element) ${this}label($element)
        if {[array size ${this}instance] == 0} {                                                                ;# no more instances
            $($this,viewer) xaxis configure -hide 1
            foreach cursor $($this,cursors) {
                switched::configure $cursor -hide 1 -x $global::32BitIntegerMinimum
            }
            $($this,labels) configure -width 1                                         ;# so that frame does not keep its last width
        } else {
            updateElements $this
            foreach {minimum maximum} [updateAxis $this] {}
            foreach cursor $($this,cursors) {                                                    ;# confine cursors to visible range
                set x [switched::cget $cursor -x]
                if {$x < $minimum} {
                    switched::configure $cursor -x $minimum
                } elseif {$x > $maximum} {
                    switched::configure $cursor -x $maximum
                }
            }
        }
        updateMessage $this
    }

    proc updateElements {this} {                ;# vertically realign time lines relative to their corresponding labels (idempotent)
        variable ${this}label

        set index 0
        foreach label [pack slaves $($this,labels)] {
            foreach {element value} [array get ${this}label] {
                if {$value eq $label} break
            }
            switched::configure $element -ordinate [expr {$index * $(labelHeight)}]
            incr index
        }
    }

    proc elementLimits {this} {                                                  ;# return minimum and maximum timestamps in seconds
        variable ${this}instance

        set minimum $global::32BitIntegerMaximum
        set maximum $global::32BitIntegerMinimum
        foreach {element instance} [array get ${this}instance] {
            foreach {start end} [element::range $element] {}
            if {($start == $global::32BitIntegerMinimum) && ($end == $global::32BitIntegerMinimum)} {
                continue                                                                                 ;# element contains no data
            }
            if {$start < $minimum} {set minimum $start}
            if {$end > $maximum} {set maximum $end}
        }
        if {$maximum == $global::32BitIntegerMinimum} {                                                        ;# nothing to display
            set minimum $global::32BitIntegerMinimum
        }
        return [list $minimum $maximum]
    }

    proc updateAxis {this {minimum {}} {maximum {}}} {
        variable ${this}instance

        foreach {start end} [elementLimits $this] {}
        if {$minimum eq ""} {set minimum $start}
        if {$maximum eq ""} {set maximum $end}
        if {($minimum > $global::32BitIntegerMinimum) && ($minimum == $maximum)} {                                    ;# sole sample
            set minimum [expr {$maximum - 60}]                                                     ;# use a reasonable minimum range
        }
        if {$minimum > $start} {set minimum $start}                             ;# make sure that all instance ranges remain visible
        if {$maximum < $end} {set maximum $end}
        set graph $($this,graph)
        bltGraph::setRange $graph [expr {$maximum - $minimum}]
        bltGraph::xUpdateGraduations $graph
        bltGraph::xAxisUpdateRange $graph $maximum
        return [list $minimum $maximum]
    }

    proc resized {this} {                                                ;# synchronize y axis with labels according to their height
        variable ${this}instance

        if {[array size ${this}instance] == 0} return                                                           ;# nothing displayed
        set half [expr {$(labelHeight) / 2.0}]
        $($this,viewer) yaxis configure -min -$half -max [expr {[$($this,viewer) extents plotheight] - $half}]
    }

    proc launchInstanceModule {instance module identifier arguments} {               ;# instance is index in database instance table
        set database $global::database
        foreach list [database::cellsData $database $instance] {            ;# list: row entry label comment, none if database error
            lappend cellsData $list
        }
        if {$database::($database,error) ne ""} return                                                    ;# abort if database error
        set entries {}; set indexes {}; set labels {}; set types {}; set messages {}; set anchors {}
        foreach list [database::moduleData $database $instance] {
            if {[llength $list] == 0} break
            foreach {entry indexed label type message anchor} $list {}
            lappend entries $entry
            lappend indexes $indexed
            lappend labels $label
            lappend types $type
            lappend messages $message
            lappend anchors $anchor
        }
        if {[llength $entries] == 0} return                                                                 ;# database error: abort
        # carry instance number with module name so that for example, history data can be retrieved from a cell name, storing and
        # restoring modules work, ...
        # wrap arguments in a list so that the first character of switch value is not a - (disallowed by the getopt implementation)
        # note: relax validity checking for instance module
        dynamicallyLoadModules 1 [list instance<$instance>\
            -module $module -identifier $identifier -arguments \{$arguments\} -instance $instance -cellsdata $cellsData\
            -entries $entries -types $types -messages $messages -anchors $anchors\
        ]
        if {$global::pollTime != 0} {error {poll time should be 0}}     ;# poll time should have been set above to flag history mode
    }

    # cell history between cursors (actual intersection between database history and period determined by the cursors)
    # note: directly invoked by instance module
    proc cellHistory {instance row entry {last 0}} {                    ;# return a list of: timestamp, value, timestamp, value, ...
        variable singleton

        if {![info exists singleton] || ($global::database == 0)} {                      ;# (just in case check database connection)
            return {}       ;# happens when loading from a configuration file and database instances viewer has not been created yet
        }
        foreach {start end} [cursorsRange] {}
        if {$last} {                     ;# return sample at cursor (actually at the time or before what the right cursor points to)
            return [database::cellHistory $global::database $instance $row $entry $start $end 1]
        } else {                                                                               ;# return all samples between cursors
            return [database::cellHistory $global::database $instance $row $entry $start $end 0]
        }
    }

    proc history {cell} {                                                                                 ;# invoked by viewers, ...
        foreach {instance row entry} [cellIndex $cell] {}
        if {[info exists instance]} {
            return [cellHistory $instance $row $entry]
        } else {                                                                                     ;# instance module was unloaded
            return {}
        }
    }

    proc range {cell} {                                          ;# range from database (list of 2 empty strings if no history data)
        foreach {instance row entry} [cellIndex $cell] {}
        if {![info exists instance] || ($global::database == 0)} {          ;# instance module was unloaded or database disconnected
            return [list {} {}]
        }
        foreach {start end} [cursorsRange] {}
        set list [database::cellRange $global::database $instance $row $entry $start $end]        ;# limit timestamps (may be empty)
        if {$database::($global::database,error) ne ""} {
            set list [list {} {}]                                                    ;# return empty range in case of database error
        }
        return $list
    }

    proc cellIndex {cell} {             ;# cell index in database history table (cell must be data from an instance module instance)
        if {([scan $cell {%[^<]<%u>::data(%u,%u)} module instance row column] != 4) || ($module ne "instance")} {
            error "invalid database instance cell: $cell"
        }
        if {[modules::loadedNamespace instance<$instance>]} {                  ;# get database row and entry kept in instance module
            foreach {row entry} [::instance<$instance>::mapping $row $column] {}
            return [list $instance $row $entry]
        } else {                                                                                     ;# instance module was unloaded
            return {}
        }
    }

    proc fromTo {this} {
        return [lsort -integer [list\
            [expr {round([switched::cget [lindex $($this,cursors) 0] -x])}]\
            [expr {round([switched::cget [lindex $($this,cursors) 1] -x])}]\
        ]]                                                                                ;# make sure to return seconds as integers
    }

    proc cursorsRange {} {                               ;# return start and end timestamps in seconds from cursors current position
        variable singleton

        return [fromTo $singleton]
    }

    proc cursorMoved {this x} {
        eval database::setRange [fromTo $this]                                                   ;# update database range dialog box
    }

    proc deleteEmpty {} {                                                            ;# delete singleton if it displays no instances
        variable singleton

        if {![info exists singleton]} return                                                                      ;# already deleted
        variable ${singleton}instance
        if {[array size ${singleton}instance] == 0} {
            set ($singleton,selfDelete) {}                                                  ;# consider this action as self deletion
            delete $singleton                                                                                     ;# delete if empty
        }
    }

    proc setCursors {this from to} {
        foreach {minimum maximum} [$($this,viewer) xaxis limits] {}
        if {$from < $minimum} {set from $minimum} elseif {$from > $maximum} {set from $maximum}                              ;# clip
        if {$to < $minimum} {set to $minimum} elseif {$to > $maximum} {set to $maximum}
        switched::configure [lindex $($this,cursors) 0] -x $from
        switched::configure [lindex $($this,cursors) 1] -x $to
    }

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

    proc buttonRelease {selector element extended} {               ;# extended means that there is an extended selection in progress
        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 $element} {                                                           ;# in an already selected element
                selector::select $selector $element                                                 ;# set selection to sole element
                return
            }
        }
    }

    proc entryData {cell} {                         ;# return label, type, message, anchor, for module column of the cell, in a list
        foreach {instance row entry} [cellIndex $cell] {}
        if {![info exists instance]} {                                                               ;# instance module was unloaded
            return {}
        }
        foreach list [database::moduleData $global::database $instance] {
            if {[llength $list] == 0} break
            foreach {index indexed label type message anchor} $list {}
            if {$index == $entry} {                                                                                   ;# found entry
                return [list $label $type $message $anchor]
            }
        }
        return {}                                                                                     ;# must be some database error
    }

    proc updateMessage {this} {
        variable ${this}instance

        if {[array size ${this}instance] == 0} {
            centerMessage $widget::($this,path) "database instances viewer:\ndrop or load instance(s)"\
                $composite::($this,-plotbackground) $global::viewerMessageColor
        } else {
            centerMessage $widget::($this,path) {}
        }
    }

    class element {

        proc element {this path args} switched {$args} {
            variable x$this
            variable y$this

            blt::vector create x${this}(2)
            blt::vector create y${this}(2)
            # use object identifier as element identifier and a reasonably sized dot at each end
            $path element create $this -label {} -xdata x$this -ydata y$this -pixels 2 -dashes 3      ;# show dashes till valid data
            set ($this,path) $path
            switched::complete $this
        }

        proc ~element {this} {
            variable x$this
            variable y$this

            blt::vector destroy x$this y$this
            $($this,path) element delete $this
            if {$switched::($this,-deletecommand) ne ""} {
                uplevel #0 $switched::($this,-deletecommand)                                ;# always invoke command at global level
            }
        }

        proc options {this} {                                                            ;# force default color, start and end range
            return [list\
                [list -color white]\
                [list -deletecommand {} {}]\
                [list -end $global::32BitIntegerMinimum]\
                [list -start $global::32BitIntegerMinimum]\
                [list -ordinate 0 0]\
            ]
        }

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

        proc set-deletecommand {this value} {}

        proc set-ordinate {this value} {
            variable y$this
            y${this} index : $value
        }

        proc set-start {this value} {     ;# (note: a 32 integer minimum for both start and end means that element contains no data)
            variable x$this

            x${this} index 0 $value
            if {[x${this} index 1] > $global::32BitIntegerMinimum} {                       ;# data complete and valid: remove dashes
                $($this,path) element configure $this -dash {}
            }
        }

        proc set-end {this value} {       ;# (note: a 32 integer minimum for both start and end means that element contains no data)
            variable x$this

            x${this} index 1 $value
            if {[x${this} index 0] > $global::32BitIntegerMinimum} {                       ;# data complete and valid: remove dashes
                $($this,path) element configure $this -dash {}
            }
        }

        proc range {this} {
            variable x$this
            return [x${this} index :]
        }

    }


    class cursor {

        variable downArrow [image create photo -data {R0lGODlhCQAEAIAAAAAA/////yH5BAEAAAEALAAAAAAJAAQAAAIIhH+BGYoNWSgAOw==}]
        variable upArrow [image create photo -data {R0lGODlhCQAEAIAAAP///wAA/yH5BAEAAAAALAAAAAAJAAQAAAIIhIOmyMv9YgEAOw==}]

        proc cursor {this path args} switched {$args} {
            variable downArrow
            variable upArrow

            $path marker create line -name ${this}line -outline blue
            $path marker create image -name ${this}top -image $downArrow -anchor nw -xoffset -4   ;# as BLT does not properly center
            $path marker create image -name ${this}bottom -image $upArrow -anchor sw -xoffset -4
            foreach marker [list ${this}line ${this}top ${this}bottom] {
                $path marker bind $marker <Enter> "$path configure -cursor sb_h_double_arrow"             ;# horizontal double arrow
                $path marker bind $marker <Leave> "$path configure -cursor {}"
                $path marker bind $marker <ButtonPress-1> "databaseInstances::cursor::button $this 1 %x"
                $path marker bind $marker <ButtonRelease-1> "databaseInstances::cursor::button $this 0 %x"
                $path marker bind $marker <Button1-Motion> "databaseInstances::cursor::motion $this %x"
            }
            set ($this,path) $path
            switched::complete $this
        }

        proc ~cursor {this} {
            set path $($this,path)
            foreach marker [list ${this}line ${this}top ${this}bottom] {
                $path marker delete $marker
            }
        }

        proc options {this} {                                                                              ;# force x initialization
            return [list\
                [list -command {} {}]\
                [list -hide 0 0]\
                [list -x $global::32BitIntegerMinimum]\
            ]
        }

        proc set-command {this value} {}                         ;# callback invoked when cursor was moved by user to a new abscissa

        proc set-hide {this value} {
            set path $($this,path)
            foreach marker [list ${this}line ${this}top ${this}bottom] {
                $path marker configure $marker -hide $value
            }
        }

        proc set-x {this value} {
            regexp {^[\d\.]+} $::tcl_patchLevel version                                 ;# ignore extra characters, such as in 8.5a2
            if {($value == $global::32BitIntegerMinimum) && ([package vcompare $version 8.4.12] < 0)} {
                incr value         ;# otherwise -2147483648 generates an "expression didn't have numeric value" error with Tcl 8.4.9
            }
            set path $($this,path)
            $path marker configure ${this}line -coords [list $value -Inf $value Inf]
            $path marker configure ${this}top -coords [list $value -Inf]
            $path marker configure ${this}bottom -coords [list $value Inf]
        }

        proc button {this pressed x} {                                                         ;# or released, abscissa is in pixels
            set x [$($this,path) xaxis invtransform $x]                                                     ;# convert to axis units
            if {$pressed} {                                                       ;# show displayed value, not value at mouse cursor
                lifoLabel::push $global::messenger [bltGraph::axisTime $($this,path) $switched::($this,-x)]
            } else {                                                                                                     ;# released
                lifoLabel::pop $global::messenger
                if {($x != $($this,x)) && ($switched::($this,-command) ne "")} {                          ;# do nothing if no change
                    uplevel #0 $switched::($this,-command) $x                               ;# always invoke command at global level
                }
            }
            set ($this,x) $x
        }

        proc motion {this x} {                                                                                          ;# in pixels
            set x [$($this,path) xaxis invtransform $x]                                                     ;# convert to axis units
            foreach {minimum maximum} [$($this,path) xaxis limits] {}
            if {$x < $minimum} {set x $minimum} elseif {$x > $maximum} {set x $maximum}                                      ;# clip
            switched::configure $this -x $x
            lifoLabel::pop $global::messenger
            lifoLabel::push $global::messenger [bltGraph::axisTime $($this,path) $x]
        }

    }


}
