initial import (Boeing r1752, NRL r878)
This commit is contained in:
ahrenholz
commit
f8f46d28be
394 changed files with 99738 additions and 0 deletions
411
gui/canvas.tcl
Executable file
411
gui/canvas.tcl
Executable file
|
|
@ -0,0 +1,411 @@
|
|||
#
|
||||
# Copyright 2005-2013 the Boeing Company.
|
||||
# See the LICENSE file included in this distribution.
|
||||
#
|
||||
|
||||
#
|
||||
# Copyright 2005-2008 University of Zagreb, Croatia.
|
||||
#
|
||||
# Redistribution and use in source and binary forms, with or without
|
||||
# modification, are permitted provided that the following conditions
|
||||
# are met:
|
||||
# 1. Redistributions of source code must retain the above copyright
|
||||
# notice, this list of conditions and the following disclaimer.
|
||||
# 2. Redistributions in binary form must reproduce the above copyright
|
||||
# notice, this list of conditions and the following disclaimer in the
|
||||
# documentation and/or other materials provided with the distribution.
|
||||
#
|
||||
# THIS SOFTWARE IS PROVIDED BY AUTHOR AND CONTRIBUTORS ``AS IS'' AND
|
||||
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
||||
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
||||
# ARE DISCLAIMED. IN NO EVENT SHALL AUTHOR OR CONTRIBUTORS BE LIABLE
|
||||
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
||||
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
||||
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
|
||||
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
|
||||
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
|
||||
# SUCH DAMAGE.
|
||||
#
|
||||
#
|
||||
|
||||
#****h* imunes/canvas.tcl
|
||||
# NAME
|
||||
# canvas.tcl -- file used for manipultaion with canvases in IMUNES
|
||||
# FUNCTION
|
||||
# This module is used to define all the actions used for configuring
|
||||
# canvases in IMUNES. On each canvas a part of the simulation is presented
|
||||
# If there is no additional canvas defined, simulation is presented on the
|
||||
# defalut canvas.
|
||||
#
|
||||
#****
|
||||
|
||||
#****f* canvas.tcl/removeCanvas
|
||||
# NAME
|
||||
# removeCanvas -- remove canvas
|
||||
# SYNOPSIS
|
||||
# removeCanvas $canvas_id
|
||||
# FUNCTION
|
||||
# Removes the canvas from simulation. This function does not change the
|
||||
# configuration of the nodes, i.e. nodes attached to the removed canvas
|
||||
# remain attached to the same non existing canvas.
|
||||
# INPUTS
|
||||
# * canvas_id -- canvas id
|
||||
#****
|
||||
|
||||
proc removeCanvas { canvas } {
|
||||
global canvas_list $canvas
|
||||
|
||||
set i [lsearch $canvas_list $canvas]
|
||||
set canvas_list [lreplace $canvas_list $i $i]
|
||||
set $canvas {}
|
||||
}
|
||||
|
||||
#****f* canvas.tcl/newCanvas
|
||||
# NAME
|
||||
# newCanvas -- craete new canvas
|
||||
# SYNOPSIS
|
||||
# set canvas_id [newCanvas $canvas_name]
|
||||
# FUNCTION
|
||||
# Creates new canvas. Returns the canvas_id of the new canvas.
|
||||
# If the canvas_name parameter is empty, the name of the new canvas
|
||||
# is set to CanvasN, where N represents the canvas_id of the new canvas.
|
||||
# INPUTS
|
||||
# * canvas_name -- canvas name
|
||||
# RESULT
|
||||
# * canvas_id -- canvas id
|
||||
#****
|
||||
|
||||
proc newCanvas { name } {
|
||||
global canvas_list
|
||||
|
||||
set canvas [newObjectId canvas]
|
||||
global $canvas
|
||||
lappend canvas_list $canvas
|
||||
set $canvas {}
|
||||
if { $name != "" } {
|
||||
setCanvasName $canvas $name
|
||||
} else {
|
||||
setCanvasName $canvas Canvas[string range $canvas 1 end]
|
||||
}
|
||||
|
||||
return $canvas
|
||||
}
|
||||
|
||||
|
||||
proc setCanvasSize { canvas x y } {
|
||||
global $canvas
|
||||
|
||||
set i [lsearch [set $canvas] "size *"]
|
||||
if { $i >= 0 } {
|
||||
set $canvas [lreplace [set $canvas] $i $i "size {$x $y}"]
|
||||
} else {
|
||||
set $canvas [linsert [set $canvas] 1 "size {$x $y}"]
|
||||
}
|
||||
}
|
||||
|
||||
proc getCanvasSize { canvas } {
|
||||
global $canvas g_prefs
|
||||
|
||||
set entry [lrange [lsearch -inline [set $canvas] "size *"] 1 end]
|
||||
set size [string trim $entry \{\}]
|
||||
if { $size == "" } {
|
||||
return "$g_prefs(gui_canvas_x) $g_prefs(gui_canvas_y)"
|
||||
} else {
|
||||
return $size
|
||||
}
|
||||
}
|
||||
|
||||
#****f* canvas.tcl/getCanvasName
|
||||
# NAME
|
||||
# getCanvasName -- get canvas name
|
||||
# SYNOPSIS
|
||||
# set canvas_name [getCanvasName $canvas_id]
|
||||
# FUNCTION
|
||||
# Returns the name of the canvas.
|
||||
# INPUTS
|
||||
# * canvas_id -- canvas id
|
||||
# RESULT
|
||||
# * canvas_name -- canvas name
|
||||
#****
|
||||
|
||||
proc getCanvasName { canvas } {
|
||||
global $canvas
|
||||
|
||||
set entry [lrange [lsearch -inline [set $canvas] "name *"] 1 end]
|
||||
return [string trim $entry \{\}]
|
||||
}
|
||||
|
||||
#****f* canvas.tcl/setCanvasName
|
||||
# NAME
|
||||
# setCanvasName -- set canvas name
|
||||
# SYNOPSIS
|
||||
# setCanvasName $canvas_id $canvas_name
|
||||
# FUNCTION
|
||||
# Sets the name of the canvas.
|
||||
# INPUTS
|
||||
# * canvas_id -- canvas id
|
||||
# * canvas_name -- canvas name
|
||||
#****
|
||||
|
||||
proc setCanvasName { canvas name } {
|
||||
global $canvas
|
||||
|
||||
set i [lsearch [set $canvas] "name *"]
|
||||
if { $i >= 0 } {
|
||||
set $canvas [lreplace [set $canvas] $i $i "name {$name}"]
|
||||
} else {
|
||||
set $canvas [linsert [set $canvas] 1 "name {$name}"]
|
||||
}
|
||||
}
|
||||
|
||||
# Boeing: canvas wallpaper support
|
||||
proc getCanvasWallpaper { canvas } {
|
||||
global $canvas
|
||||
|
||||
set entry [lrange [lsearch -inline [set $canvas] "wallpaper *"] 1 end]
|
||||
set entry2 [lrange [lsearch -inline \
|
||||
[set $canvas] "wallpaper-style *"] 1 end]
|
||||
return [list [string trim $entry \{\}] [string trim $entry2 \{\}]]
|
||||
}
|
||||
|
||||
proc setCanvasWallpaper { canvas file style} {
|
||||
global $canvas
|
||||
|
||||
set i [lsearch [set $canvas] "wallpaper *"]
|
||||
if { $i >= 0 } {
|
||||
set $canvas [lreplace [set $canvas] $i $i "wallpaper {$file}"]
|
||||
} else {
|
||||
set $canvas [linsert [set $canvas] 1 "wallpaper {$file}"]
|
||||
}
|
||||
|
||||
set i [lsearch [set $canvas] "wallpaper-style *"]
|
||||
if { $i >= 0 } {
|
||||
set $canvas [lreplace [set $canvas] $i $i "wallpaper-style {$style}"]
|
||||
} else {
|
||||
set $canvas [linsert [set $canvas] 1 "wallpaper-style {$style}"]
|
||||
}
|
||||
}
|
||||
|
||||
# Boeing: manage canvases
|
||||
proc manageCanvasPopup { x y } {
|
||||
global curcanvas CORE_DATA_DIR
|
||||
|
||||
set w .entry1
|
||||
catch {destroy $w}
|
||||
toplevel $w -takefocus 1
|
||||
|
||||
if { $x == 0 && $y == 0 } {
|
||||
set screen [wm maxsize .]
|
||||
set x [expr {[lindex $screen 0] / 4}]
|
||||
set y [expr {[lindex $screen 1] / 4}]
|
||||
} else {
|
||||
set x [expr {$x + 10}]
|
||||
set y [expr {$y - 250}]
|
||||
}
|
||||
wm geometry $w +$x+$y
|
||||
wm title $w "Manage Canvases"
|
||||
wm iconname $w "Manage Canvases"
|
||||
|
||||
|
||||
ttk::frame $w.name
|
||||
ttk::label $w.name.lab -text "Canvas name:"
|
||||
ttk::entry $w.name.ent
|
||||
$w.name.ent insert 0 [getCanvasName $curcanvas]
|
||||
pack $w.name.lab $w.name.ent -side left -fill x
|
||||
pack $w.name -side top -padx 4 -pady 4
|
||||
|
||||
global canvas_list
|
||||
ttk::frame $w.canv
|
||||
listbox $w.canv.cl -bg white -yscrollcommand "$w.canv.scroll set"
|
||||
ttk::scrollbar $w.canv.scroll -orient vertical -command "$w.canv.cl yview"
|
||||
foreach canvas $canvas_list {
|
||||
$w.canv.cl insert end [getCanvasName $canvas]
|
||||
if { $canvas == $curcanvas } {
|
||||
set curindex [expr {[$w.canv.cl size] - 1}]
|
||||
}
|
||||
}
|
||||
pack $w.canv.cl -side left -pady 4 -fill both -expand true
|
||||
pack $w.canv.scroll -side left -fill y
|
||||
pack $w.canv -side top -fill both -expand true -padx 4 -pady 4
|
||||
$w.canv.cl selection set $curindex
|
||||
$w.canv.cl see $curindex
|
||||
bind $w.canv.cl <Double-1> "manageCanvasSwitch $w"
|
||||
|
||||
ttk::frame $w.buttons2
|
||||
foreach b {up down} {
|
||||
set fn "$CORE_DATA_DIR/icons/tiny/arrow.${b}.gif"
|
||||
set img$b [image create photo -file $fn]
|
||||
ttk::button $w.buttons2.$b -image [set img${b}] \
|
||||
-command "manageCanvasUpDown $w $b"
|
||||
}
|
||||
pack $w.buttons2.up $w.buttons2.down -side left -expand 1
|
||||
pack $w.buttons2 -side top -fill x -pady 2
|
||||
|
||||
# hidden list of canvas numbers
|
||||
ttk::label $w.list -text $canvas_list
|
||||
|
||||
ttk::frame $w.buttons
|
||||
ttk::button $w.buttons.apply -text "Apply" -command "manageCanvasApply $w"
|
||||
ttk::button $w.buttons.cancel -text "Cancel" -command "destroy $w"
|
||||
pack $w.buttons.apply $w.buttons.cancel -side left -expand 1
|
||||
pack $w.buttons -side bottom -fill x -pady 2m
|
||||
|
||||
bind $w <Key-Escape> "destroy $w"
|
||||
bind $w <Key-Return> "manageCanvasApply $w"
|
||||
|
||||
}
|
||||
|
||||
# Boeing: manage canvases helper
|
||||
# called when a canvas in the list is double-clicked
|
||||
proc manageCanvasSwitch { w } {
|
||||
global canvas_list curcanvas
|
||||
set i [$w.canv.cl curselection]
|
||||
if {$i == ""} { return}
|
||||
set i [lindex $i 0]
|
||||
set item [$w.canv.cl get $i]
|
||||
|
||||
foreach canvas $canvas_list {
|
||||
if {[getCanvasName $canvas] == $item} {
|
||||
$w.name.ent delete 0 end
|
||||
$w.name.ent insert 0 $item
|
||||
set curcanvas $canvas
|
||||
switchCanvas none
|
||||
return
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# manage canvases helper
|
||||
# handle the move up/down buttons for the canvas selection window
|
||||
proc manageCanvasUpDown { w dir } {
|
||||
global canvas_list
|
||||
# get the currently selected item
|
||||
set i [$w.canv.cl curselection]
|
||||
if {$i == ""} { return}
|
||||
set i [lindex $i 0]
|
||||
set item [$w.canv.cl get $i]
|
||||
|
||||
if {$dir == "down" } {
|
||||
set max [expr {[llength $canvas_list] - 1}]
|
||||
if {$i >= $max } { return }
|
||||
set newi [expr {$i + 1}]
|
||||
} else {
|
||||
if {$i <= 0} { return }
|
||||
set newi [expr {$i - 1}]
|
||||
}
|
||||
|
||||
# change the position
|
||||
$w.canv.cl delete $i
|
||||
$w.canv.cl insert $newi $item
|
||||
$w.canv.cl selection set $newi
|
||||
$w.canv.cl see $newi
|
||||
|
||||
# update hidden list of canvas numbers
|
||||
set new_canvas_list [$w.list cget -text]
|
||||
set item [lindex $new_canvas_list $i]
|
||||
set new_canvas_list [lreplace $new_canvas_list $i $i]
|
||||
set new_canvas_list [linsert $new_canvas_list $newi $item]
|
||||
$w.list configure -text $new_canvas_list
|
||||
}
|
||||
|
||||
# manage canvases helper
|
||||
# called when apply button is pressed - changes the order of the canvases
|
||||
proc manageCanvasApply { w } {
|
||||
global canvas_list curcanvas changed
|
||||
# we calculated this list earlier, making life easier here
|
||||
set new_canvas_list [$w.list cget -text]
|
||||
if {$canvas_list != $new_canvas_list} {
|
||||
set canvas_list $new_canvas_list
|
||||
}
|
||||
set newname [$w.name.ent get]
|
||||
destroy $w
|
||||
if { $newname != [getCanvasName $curcanvas] } {
|
||||
set changed 1
|
||||
}
|
||||
setCanvasName $curcanvas $newname
|
||||
switchCanvas none
|
||||
updateUndoLog
|
||||
}
|
||||
|
||||
proc setCanvasScale { canvas scale } {
|
||||
global $canvas
|
||||
|
||||
set i [lsearch [set $canvas] "scale *"]
|
||||
if { $i >= 0 } {
|
||||
set $canvas [lreplace [set $canvas] $i $i "scale $scale"]
|
||||
} else {
|
||||
set $canvas [linsert [set $canvas] 1 "scale $scale"]
|
||||
}
|
||||
}
|
||||
|
||||
proc getCanvasScale { canvas } {
|
||||
global $canvas g_prefs
|
||||
|
||||
set entry [lrange [lsearch -inline [set $canvas] "scale *"] 1 end]
|
||||
set scale [string trim $entry \{\}]
|
||||
if { $scale == "" } {
|
||||
if { ![info exists g_prefs(gui_canvas_scale)] } { return 150.0 }
|
||||
return "$g_prefs(gui_canvas_scale)"
|
||||
} else {
|
||||
return $scale
|
||||
}
|
||||
}
|
||||
|
||||
proc setCanvasRefPoint { canvas refpt } {
|
||||
global $canvas
|
||||
|
||||
set i [lsearch [set $canvas] "refpt *"]
|
||||
if { $i >= 0 } {
|
||||
set $canvas [lreplace [set $canvas] $i $i "refpt {$refpt}"]
|
||||
} else {
|
||||
set $canvas [linsert [set $canvas] 1 "refpt {$refpt}"]
|
||||
}
|
||||
}
|
||||
|
||||
proc getCanvasRefPoint { canvas } {
|
||||
global $canvas g_prefs DEFAULT_REFPT
|
||||
|
||||
set entry [lrange [lsearch -inline [set $canvas] "refpt *"] 1 end]
|
||||
set altitude [string trim $entry \{\}]
|
||||
if { $altitude == "" } {
|
||||
if { ![info exists g_prefs(gui_canvas_refpt)] } {
|
||||
return $DEFAULT_REFPT
|
||||
}
|
||||
return "$g_prefs(gui_canvas_refpt)"
|
||||
} else {
|
||||
return $altitude
|
||||
}
|
||||
}
|
||||
|
||||
# from http://wiki.tcl.tk/1415 (MAK)
|
||||
proc canvasSee { hWnd items } {
|
||||
set box [eval $hWnd bbox $items]
|
||||
|
||||
if {$box == ""} { return }
|
||||
|
||||
if {[string match {} [$hWnd cget -scrollregion]] } {
|
||||
# People really should set -scrollregion you know...
|
||||
foreach {x y x1 y1} $box break
|
||||
|
||||
set x [expr round(2.5 * ($x1+$x) / [winfo width $hWnd])]
|
||||
set y [expr round(2.5 * ($y1+$y) / [winfo height $hWnd])]
|
||||
|
||||
$hWnd xview moveto 0
|
||||
$hWnd yview moveto 0
|
||||
$hWnd xview scroll $x units
|
||||
$hWnd yview scroll $y units
|
||||
} else {
|
||||
# If -scrollregion is set properly, use this
|
||||
foreach { x y x1 y1 } $box break
|
||||
foreach { top btm } [$hWnd yview] break
|
||||
foreach { left right } [$hWnd xview] break
|
||||
foreach { p q xmax ymax } [$hWnd cget -scrollregion] break
|
||||
|
||||
set xpos [expr (($x1+$x) / 2.0) / $xmax - ($right-$left) / 2.0]
|
||||
set ypos [expr (($y1+$y) / 2.0) / $ymax - ($btm-$top) / 2.0]
|
||||
|
||||
$hWnd xview moveto $xpos
|
||||
$hWnd yview moveto $ypos
|
||||
}
|
||||
}
|
||||
Loading…
Add table
Add a link
Reference in a new issue