plotter.tcl

rtai-3.1-test3的源代码(Real-Time Application Interface )

#  This file is part of the XENOMAI project.
#
#  Copyright (C) 1997-2000 Realiant Systems.  All rights reserved.
#  Copyright (C) 2001,2002 Philippe Gerum <[e-mail]>.
# 
#  This program is free software; you can redistribute it and/or
#  modify it under the terms of the GNU General Public License as
#  published by the Free Software Foundation; either version 2 of the
#  License, or (at your option) any later version.
# 
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
# 
#  Author(s): rwestrel
#  Contributor(s):
#
#  Adapted to XENOMAI by Philippe Gerum.

# global tcl_traceExec
# set tcl_traceExec 1

# name of hosting tool
set plotter:toolname "Plotter"

# borders
set plotter:leftb 60
set plotter:rightb 30
set plotter:topb 30
set plotter:bottomb 40

# colors
set plotter:axisColor black

# reticle color for histograms and time graphs
if {$tcl_platform(platform) != "windows"} {
    set plotter:reticleHistoColor white
    set plotter:reticleTimeColor black
} else {
    set plotter:reticleHistoColor red
    set plotter:reticleTimeColor red
}

# *** toolbar ***
# Calls the right user defined command when a button is pressed.
# Shouldn't be called directly.

proc toolbar:command {context button selected} {
    upvar #0 toolbar:$context:command cmdArray
    upvar #0 toolbar:c2w c2w
    upvar #0 toolbar:itsSide itsSide

    set master $c2w($context)

    if {$itsSide($button) == "left"} {
	set toolbar $master.tb.ltoolbar
    } else {
	set toolbar $master.tb.rtoolbar
    }

    if {$selected} {
	$toolbar invoke $button
	eval $cmdArray($button)
    }
}

# Builds a toolbar with a status bar to display help messages
# command: a list of commands to call when button is pressed
# icons: a list of icons (one for each button)
# help: a list of help messages
# gridToolbar & gridStatus: arguments for the grid geometry manager
proc toolbar:addToolBar {context master gridToolbar gridStatus} {

    global toolbar:$context:command
    global toolbar:var
    global toolbar:c2w 
    global toolbar:bs 

    set toolbar:c2w($context) $master

    set toolbar:var($context) ""
    label $master.status  -textvariable toolbar:var($context) -relief groove -borderwidth 2
    frame $master.tb -relief raised -borderwidth 2
    tixSelect $master.tb.ltoolbar -allowzero true -radio true -command "toolbar:command $context"
    tixSelect $master.tb.rtoolbar -allowzero true -radio true -command "toolbar:command $context"
    
    eval grid $master.tb $gridToolbar
    eval grid $master.status $gridStatus
    pack $master.tb.ltoolbar -pady 5 -side left -anchor w
    pack $master.tb.rtoolbar -pady 5 -side right -anchor e
    set toolbar:bs ""
}

proc toolbar:addButton {context name command help icon state side} {
    global toolbar:$context:command
    global toolbar:var
    upvar #0 toolbar:c2w c2w
    upvar #0 toolbar:itsSide itsSide

    set master $c2w($context)

    if {$side == "left"} {
	set toolbar $master.tb.ltoolbar
    } else {
	set toolbar $master.tb.rtoolbar
    }

    set itsSide($name) $side
    set shorthelp [lindex $help 0]
    set longhelp [lindex $help 1]

    set toolbar:$context:command($name) $command
    if {[string index $icon 0] == "@"} {
	$toolbar add $name -bitmap $icon
    } else {
	$toolbar add $name -image [fetchImage $icon]
    }
    set button [$toolbar subwidget $name]
    setStaticTooltip $button $shorthelp
    pack $button -expand false -side left
    $button configure -state $state
    # here, I build my own balloon since the tixBalloon widget is pretty f**ked up
    bind $button <Enter> \
	"+ set toolbar:bs $name; set toolbar:var($context) \"$longhelp\""
    bind $button <Leave> \
	"+ set toolbar:bs \"\"; set toolbar:var($context) \"\""
}

proc toolbar:modifyButton {context name command help icon state} {
    global toolbar:$context:command
    upvar #0 toolbar:var var
    upvar #0 toolbar:c2w c2w
    upvar #0 toolbar:bs bs
    upvar #0 toolbar:itsSide itsSide

    set master $c2w($context)

    if {$itsSide($name) == "left"} {
	set toolbar $master.tb.ltoolbar
    } else {
	set toolbar $master.tb.rtoolbar
    }

    set toolbar:$context:command($name) $command
    set button [$toolbar subwidget $name]
    set shorthelp [lindex $help 0]
    set longhelp [lindex $help 1]

    if {[string index $icon 0] == "@"} {
	$button configure -bitmap $icon
    } else {
	$button configure -image [fetchImage $icon]
    }

    setStaticTooltip $button $shorthelp
    bind $button <Enter> "+ set toolbar:bs $name; set toolbar:var($context) \"$longhelp\""
    bind $button <Leave> "+ set toolbar:bs \"\"; set toolbar:var($context) \"\""
    
    if {$bs == $name} {
	set var($context) $longhelp
    }
    $button configure -state $state
}

proc toolbar:destroy {context} {
    upvar #0 toolbar:$context:command command
    
    destroy $context.status
    destroy $context.tb.ltoolbar
}

# *** chklist ***
proc chklist:getSelection {chkListId} {
    upvar #0 chklist:selection2context s2c
    
    set selected [$chkListId getselection]
    
    set selectedContext {}
    foreach i $selected {
	lappend selectedContext $s2c($i)
    }
    
    return $selectedContext
}


proc chklist:addInHList {list chkListId level contextList onList} {
    upvar #0 chklist:selection2context s2c

    set hlistId [$chkListId subwidget hlist]
    set size [llength $list]
    if {$level == ""} {
	set level ""
    } else {
	set level $level.
    }
    set j 0
    set subtree 0
    set entry {}
    for {set i 0} {$i < $size} {incr i} {
	set sublist [lindex $list $i]
	if {$subtree} {
	    incr j
	    set contextList [chklist:addInHList $sublist $chkListId $level[expr $i -$j] $contextList $onList]
	    set subtree 0
	} else {
	    if {[llength $sublist] != 0 } {
		set entry $level[expr $i - $j]
		$hlistId add $entry -itemtype imagetext -text $sublist -style leafImageStyle
		set el [FIFOget contextList]
		if {[plotter:lremove onList $el]} {
		    $chkListId setstatus $level[expr $i -$j] on
		    chklist:selectAll $chkListId $level[expr $i -$j]
		} else {
		    $chkListId setstatus $level[expr $i -$j] off
		    chklist:selectAll $chkListId $level[expr $i -$j]
		}
		set s2c($level[expr $i -$j]) $el
	    } else {
		set sublist [lindex $list [expr $i + 1]]
		if {[llength $sublist] != 0 } {
		    if {$entry != {}} {
			$hlistId entryconfig $entry -style rootImageStyle
		    }
		    set subtree 1
		} else {
		    $hlistId add $level[expr $i - $j] -itemtype imagetext 
		    set el [FIFOget contextList]
		    if {[plotter:lremove onList $el]} {
			$chkListId setstatus $level[expr $i -$j] on
			chklist:selectAll $chkListId $level[expr $i -$j]
		    } else {
			$chkListId setstatus $level[expr $i -$j] off
			chklist:selectAll $chkListId $level[expr $i -$j]
		    }
		    set s2c($level[expr $i -$j]) $el 
		    incr i 
		}
		incr j
	    }
	}
    }
    return $contextList
}

proc chklist:changeChildrenState {chkListId level newState first} {
    set hListId [$chkListId subwidget hlist]

    set nextfirst 0
    if {$level == ""} {
	set nextlevel [$hListId info children]
    } else {
	if {! $first} {
	    $chkListId setstatus $level $newState
	    set nextfirst 0
	}
	set nextlevel [$hListId info children $level]
    }
    foreach i $nextlevel {
	chklist:changeChildrenState $chkListId $i $newState $nextfirst
    }
}

proc chklist:changeParentState {chkListId entry} {
    set status [$chkListId getstatus $entry]
    
    
    set isoff 0
    if {$status == "on"} {
	set hListId [$chkListId subwidget hlist]
	set parent [$hListId info parent $entry]
	if {$parent != ""} {
	    set nextlevel [$hListId info children $parent]
	    foreach i $nextlevel {
		if {[$chkListId getstatus $i] == "off"} {
		    incr isoff
		}
	    }
	    if {! $isoff} {
		$chkListId setstatus $parent on
		chklist:changeParentState $chkListId $parent
	    }
	}
    }
}

proc chklist:selectAll {chkListId entry} {

    set status [$chkListId getstatus $entry]

    # change the state of the parent nodes if the current one is on and all its brothers are on
    chklist:changeParentState $chkListId $entry

    # change the state of all the children nodes 
    chklist:changeChildrenState $chkListId $entry $status 1
    
    # change the state of the parent nodes if the current one is off
    if {$status == "off"} {
	set hListId [$chkListId subwidget hlist]
	set parent [$hListId info parent $entry]
	while {$parent != ""} {
	    $chkListId setstatus $parent $status
	    set parent [$hListId info parent $parent]
	}
    }
}

# *** layout ***

# The following procedures are used to display the group in the display layout.
# The code for the display layout was designed to use context (one context per node)
# so here I add "dummy contexts" (for each group) in order to make sure that each node 
# is equivalent to a context. That's quite heavy and not very smart.
proc layout:addInArray {arrayName element val} {
    upvar 1 $arrayName array
    if {![plotter:lempty [array names array $element]]} {
	plotter:ladd array($element) $val
    } else {
	set array($element) $val
    }
}

proc layout:buildModifiedHierarchy {context} {
    upvar #0 plotter:hierarchy hierarchy
    upvar #0 plotter:invertedHierarchy invertedHierarchy
    upvar #0 plotter:modifiedHierarchy modifiedHierarchy
    upvar #0 plotter:nameArray nameArray
    upvar #0 plotter:properties properties

    set id [array startsearch hierarchy]

    while {[array anymore hierarchy $id]} {
	set el [array nextelement hierarchy $id]
	if {[plotter:pathDepth $el] == 3} {
	    
	    set inv $invertedHierarchy($el)	    
	    set nameList [lindex $properties($el) 0]
	    set s [llength $nameList]
	    set last $inv
	    
	    for {set i 1} {$i < $s} {incr i} {
		set name [lindex $nameList $i]
		set dummyContext [plotter:removeSpaces $name]
		layout:addInArray modifiedHierarchy $last $last-$dummyContext 
		set nameArray($last-$dummyContext) $name
		set last $last-$dummyContext
	    }
	    layout:addInArray modifiedHierarchy $last $el
	    set nameArray($el) [lindex [lindex $properties($el) 0] 0]
	    set modifiedHierarchy($el) {}
	} else {
	    if {[plotter:pathDepth $el] != 2} {
		set modifiedHierarchy($el) $hierarchy($el)
	    }
	    set nameArray($el) [lindex [lindex $properties($el) 0] 0]
	}
    }
    layout:sortModifiedHierarchy $context 0 ;# don't sort the first level
}

proc layout:sortCmd {el1 el2} {
    upvar #0 plotter:nameArray nameArray

    return [string compare $nameArray($el1) $nameArray($el2)]
}

proc layout:sortModifiedHierarchy {context sortThisLevel} {
    upvar #0 plotter:modifiedHierarchy modifiedHierarchy
  
    if {! [plotter:lempty $modifiedHierarchy($context)]} {
	if {$sortThisLevel} {
	    set sortedList [lsort -command layout:sortCmd $modifiedHierarchy($context)]
	    set modifiedHierarchy($context) $sortedList
	}
	
	foreach i $modifiedHierarchy($context) {
	    layout:sortModifiedHierarchy $i 1
	}
    }
}

proc layout:modifiedHierarchyCleanUp {contextList} {
    upvar #0 plotter:hierarchy hierarchy
    upvar #0 plotter:modifiedHierarchy modifiedHierarchy
    upvar #0 plotter:nameArray nameArray

    set res {}
    foreach i $contextList {
	if {![plotter:lempty [array names hierarchy $i]]} {
	    lappend res $i
	}
    }
    unset modifiedHierarchy
    unset nameArray
    return $res
    
}

proc layout:buildChklistArg {level contextList} {
    upvar #0 plotter:nameArray nameArray
    upvar #0 plotter:modifiedHierarchy hierarchy
    upvar 1 $contextList list
    
    foreach i $level {
	lappend list $i
	if {$nameArray($i) == ""} {
	    lappend result {} {}
	} else {
	    lappend result $nameArray($i)
	}
	
	if {[llength $hierarchy($i)] != 0} {
	    lappend result {}
	    lappend result [layout:buildChklistArg $hierarchy($i) list]
	}
    }