set lcolor black
}
label $wi.colors.color -text $color -width 8 \
- -bg $color -fg $lcolor
+ -bg $color -fg $lcolor
button $wi.colors.fg -text "fg" -command \
- "popupColor fg $wi.colors.color false"
+ "popupColor fg $wi.colors.color false"
button $wi.colors.bg -text "bg" -command \
- "popupColor bg $wi.colors.color true"
+ "popupColor bg $wi.colors.color true"
pack $wi.colors.fg $wi.colors.bg $wi.colors.color $wi.colors.label \
- -side right -padx 4 -pady 4
+ -side right -padx 4 -pady 4
pack $wi.colors -side top
set applycmd "popupOvalApply $c $wi $target"
global $object
set $object {}
lappend $iconcoords $coords
- lappend $object $iconcoords
- lappend $object "color $color"
- lappend $object "label {$caption}"
- lappend $object "labelcolor $labelcolor"
+ lappend $object $iconcoords "color $color" \
+ "label {$caption}" "labelcolor $labelcolor"
# draw it
drawOval $object
if { $lcolor == "" } {
set lcolor black
}
+ # -outline red -stipple gray50
set newoval [.c create oval $x1 $y1 $x2 $y2 \
- -fill $color -width 2 -tags "oval $oval"]
+ -fill $color -width 2 -tags "oval $oval"]
.c raise $newoval background
.c create text $lx $ly -tags "oval $oval" -text $label \
- -justify center -font $defOvalLabelFont -fill $lcolor
+ -justify center -font $defOvalLabelFont -fill $lcolor
setNodeCanvas $oval $curcanvas
setType $oval "oval"
}
# set fg or bg of the "l" label control
if { $newcolor == "" } {
- return
+ return
}
if { $settext == "true" } {
- $l configure -text $newcolor -$type $newcolor
+ $l configure -text $newcolor -$type $newcolor
} else {
- $l configure -$type $newcolor
+ $l configure -$type $newcolor
}
}
# rounded-rectangle radius
set rad 25
set newrect [roundRect .c $x1 $y1 $x2 $y2 $rad \
- -fill $color -outline blue -tags "rectangle $rectangle"]
+ -fill $color -outline blue -tags "rectangle $rectangle"]
.c raise $newrect background
.c create text $lx $ly -tags "rectangle $rectangle" -text $label \
- -justify center -font $defRectLabelFont -fill $lcolor
+ -justify center -font $defRectLabelFont -fill $lcolor
setNodeCanvas $rectangle $curcanvas
setType $rectangle "rectangle"
}
frame $wi.lab -borderwidth 4
label $wi.lab.name_label -text "Text for top of rectangle:"
entry $wi.lab.name -bg white -width 16 \
- -validate focus -invcmd "focusAndFlash %W"
+ -validate focus -invcmd "focusAndFlash %W"
$wi.lab.name insert 0 $label
pack $wi.lab.name $wi.lab.name_label -side right -padx 4 -pady 4
pack $wi.lab -side top
set lcolor black
}
label $wi.colors.color -text $color -width 8 \
- -bg $color -fg $lcolor
+ -bg $color -fg $lcolor
button $wi.colors.fg -text "fg" -command \
- "popupColor fg $wi.colors.color false"
+ "popupColor fg $wi.colors.color false"
button $wi.colors.bg -text "bg" -command \
- "popupColor bg $wi.colors.color true"
+ "popupColor bg $wi.colors.color true"
pack $wi.colors.fg $wi.colors.bg $wi.colors.color $wi.colors.label \
- -side right -padx 4 -pady 4
+ -side right -padx 4 -pady 4
pack $wi.colors -side top
# Add new oval or modify old one?
}
frame $wi.butt -borderwidth 6
- button $wi.butt.apply -text $applytext -command "popupRectApply $c $wi $rectangle"
+ button $wi.butt.apply -text $applytext \
+ -command "popupRectApply $c $wi $rectangle"
button $wi.butt.cancel -text "Cancel" -command $cancelcmd
bind $wi <Key-Escape> "$cancelcmd"
}
set $target {}
lappend $iconcoords $coords
- lappend $target $iconcoords
- lappend $target "color $color"
- lappend $target "label {$caption}"
- lappend $target "labelcolor $labelcolor"
+ lappend $target $iconcoords "color $color" \
+ "label {$caption}" "labelcolor $labelcolor"
# draw it
drawRect $target
global curcanvas
set object [newObjectId "text"]
- set newtext [$c create text $x $y -text "" -anchor w -justify left -tags "text $object"]
+ set newtext [$c create text $x $y -text "" \
+ -anchor w -justify left -tags "text $object"]
set coords [$c coords "text && $object"]
set iconcoords "iconcoords"
set font [list "$fontfamily" $fontsize]
set effects [lindex [lsearch -inline [set $text] "effects *"] 1]
set newtext [.c create text $x $y -text $label -anchor w \
- -font "$font $effects" -justify left -fill $color \
- -tags "text $text"]
+ -font "$font $effects" -justify left -fill $color -tags "text $text"]
.c addtag text withtag $newtext
.c raise $text background
set fontmenu [tk_optionMenu $wi.prop.font.menu fontfamily "$fontfamily"]
set sizemenu [tk_optionMenu $wi.prop.font.size fontsize "$fontsize"]
- pack $wi.prop.font.label \
- $wi.prop.font.menu \
- $wi.prop.font.size -side left -pady 2
+ pack $wi.prop.font.label $wi.prop.font.menu \
+ $wi.prop.font.size -side left -pady 2
frame $wi.prop.format -relief groove -bd 2
label $wi.prop.format.label -text "Effects:"
set color $defTextColor
}
button $wi.prop.format.fg -text "Color" -command \
- "popupColor fg $wi.text false"
+ "popupColor fg $wi.text false"
checkbutton $wi.prop.format.bold -text "Bold" -variable textBold \
- -command [list fontupdate $wi.text bold]
+ -command [list fontupdate $wi.text bold]
checkbutton $wi.prop.format.italic -text "Italic" -variable textItalic \
- -command [list fontupdate $wi.text italic]
- checkbutton $wi.prop.format.underline -text "Underline" -variable textUnderline \
- -command [list fontupdate $wi.text underline]
+ -command [list fontupdate $wi.text italic]
+ checkbutton $wi.prop.format.underline -text "Underline" \
+ -variable textUnderline \
+ -command [list fontupdate $wi.text underline]
- if {$textBold == 1} { $wi.prop.format.bold select
- } else { $wi.prop.format.bold deselect }
- if {$textItalic == 1} { $wi.prop.format.italic select
- } else { $wi.prop.format.italic deselect }
- if {$textUnderline == 1} { $wi.prop.format.underline select
- } else { $wi.prop.format.underline deselect }
+ if {$textBold == 1} {
+ $wi.prop.format.bold select
+ } else {
+ $wi.prop.format.bold deselect
+ }
+ if {$textItalic == 1} {
+ $wi.prop.format.italic select
+ } else {
+ $wi.prop.format.italic deselect
+ }
+ if {$textUnderline == 1} {
+ $wi.prop.format.underline select
+ } else {
+ $wi.prop.format.underline deselect
+ }
pack $wi.prop.format.label \
$wi.prop.format.fg \
pack $wi.action.apply $wi.action.cancel -side left ;# -fill x
after 100 {
+ focus .popup.text
grab .popup
}
return
set $target {}
lappend $iconcoords $coords
- lappend $target $iconcoords
- lappend $target "color $color"
- lappend $target "label {$caption}"
- lappend $target "fontfamily {$fontfamily}"
- lappend $target "fontsize $fontsize"
+ lappend $target $iconcoords "color $color" "label {$caption}"\
+ "fontfamily {$fontfamily}" "fontsize $fontsize"
set ef {}
- if {"$textBold" == 1} { lappend ef bold}
- if {"$textItalic" == 1} { lappend ef italic}
- if {"$textUnderline" == 1} { lappend ef underline}
- if {"$ef" != ""} { lappend $target "effects {$ef}"}
+ if {"$textBold" == 1} {
+ lappend ef bold
+ }
+ if {"$textItalic" == 1} {
+ lappend ef italic
+ }
+ if {"$textUnderline" == 1} {
+ lappend ef underline
+ }
+ if {"$ef" != ""} {
+ lappend $target "effects {$ef}"
+ }
# draw it
drawText $target
-# $Id: cfgparse.tcl,v 1.33 2007/07/19 03:17:12 marko Exp $
+# $Id: cfgparse.tcl,v 1.34 2007/07/19 08:08:58 marko Exp $
#
# Copyright 2005 University of Zagreb, Croatia. All rights reserved.
#
# Puts a sting to the file or appends the string configuration (used for
# undo functions), the choice depends on the value of method parameter.
# INPUTS
-# * method -- used method. Possiable values are file (if saving the string
+# * method -- method used. Possiable values are file (if saving the string
# to the file) and string (if appending the string configuration)
# * dest -- destination used. File_id for files, and string name for string
# configuration
global showIfNames showNodeLabels showLinkLabels
global showIfIPaddrs showIfIPv6addrs
global showIPsecConfig
+ global showBkgImage showGrid showAnnotations
+ global oval_list rectangle_list text_list
foreach node $node_list {
global $node
dumpputs $method $dest ""
}
- foreach link $link_list {
- global $link
- upvar 0 $link llink
- dumpputs $method $dest "link $link \{"
- foreach element $llink {
- dumpputs $method $dest " $element"
+ foreach obj "rectangle oval text link canvas" {
+ upvar 0 ${obj}_list obj_list
+ foreach elem $obj_list {
+ global $elem
+ upvar 0 $elem lelem
+ dumpputs $method $dest "$obj $elem \{"
+ foreach element $lelem {
+ dumpputs $method $dest " $element"
+ }
+ dumpputs $method $dest "\}"
+ dumpputs $method $dest ""
}
- dumpputs $method $dest "\}"
- dumpputs $method $dest ""
- }
-
- foreach canvas $canvas_list {
- global $canvas
- upvar 0 $canvas lcanvas
- dumpputs $method $dest "canvas $canvas \{"
- foreach element $lcanvas {
- dumpputs $method $dest " $element"
- }
- dumpputs $method $dest "\}"
- dumpputs $method $dest ""
}
dumpputs $method $dest "option show \{"
dumpputs $method $dest " ipsec_configs no"
} else {
dumpputs $method $dest " ipsec_configs yes" }
+ if {$showBkgImage == 0} {
+ dumpputs $method $dest " background_images no"
+ } else {
+ dumpputs $method $dest " background_images yes" }
+ if {$showAnnotations == 0} {
+ dumpputs $method $dest " annotations no"
+ } else {
+ dumpputs $method $dest " annotations yes" }
+ if {$showGrid == 0} {
+ dumpputs $method $dest " grid no"
+ } else {
+ dumpputs $method $dest " grid yes" }
dumpputs $method $dest "\}"
dumpputs $method $dest ""
}
global showIfNames showNodeLabels showLinkLabels
global showIfIPaddrs showIfIPv6addrs
global showIPsecConfig
+ global showBkgImage showGrid showAnnotations
+ global oval_list rectangle_list text_list
# Cleanup first
set node_list {}
set link_list {}
set canvas_list {}
-
+ set oval_list {}
+ set rectangle_list {}
+ set text_list {}
set class ""
set object ""
foreach entry $cfg {
# for future use
lappend prefs $object
}
+ if {"$class" == "rectangle"} {
+ lappend rectangle_list $object
+ }
+ if {"$class" == "oval"} {
+ lappend oval_list $object
+ }
+ if {"$class" == "text"} {
+ lappend text_list $object
+ }
continue
} else {
set line [concat $entry]
lappend cfg $zline
}
set cfg [lrange $cfg 1 [expr {[llength $cfg] - 2}]]
- lappend $object "ipsec-config {$cfg}"
+ lappend $object "ipsec-config {$cfg}"
}
iconcoords {
lappend $object "iconcoords {$value}"
size {
lappend $object "size {$value}"
}
+ bkgImage {
+ lappend $object "bkgImage {$value}"
+ }
}
} elseif {"$class" == "option"} {
switch -exact -- $field {
set showIPsecConfig 1
}
}
+ background_images {
+ if { $value == "no" } {
+ set showBkgImage 0
+ } elseif { $value == "yes" } {
+ set showBkgImage 1
+ }
+ }
+ annotations {
+ if { $value == "no" } {
+ set showAnnotations 0
+ } elseif { $value == "yes" } {
+ set showAnnotations 1
+ }
+ }
+ grid {
+ if { $value == "no" } {
+ set showGrid 0
+ } elseif { $value == "yes" } {
+ set showGrid 1
+ }
+ }
+ }
+ } elseif {"$class" == "oval" \
+ || "$class" == "rectangle" \
+ || "$class" == "text"} {
+ switch -exact -- $field {
+ iconcoords {
+ lappend $object "iconcoords {$value}"
+ }
+ color {
+ lappend $object "color $value"
+ }
+ label {
+ lappend $object "label {$value}"
+ }
+ labelcolor {
+ lappend $object "labelcolor $value"
+ }
+ size {
+ lappend $object "size $value"
+ }
+ canvas {
+ lappend $object "canvas $value"
+ }
+ font {
+ lappend $object "font {$value}"
+ }
+ fontfamily {
+ lappend $object "fontfamily {$value}"
+ }
+ fontsize {
+ lappend $object "fontsize {$value}"
+ }
+ effects {
+ lappend $object "effects {$value}"
+ }
}
}
}
proc newObjectId { type } {
global node_list link_list canvas_list
+ global oval_list rectangle_list text_list
set mark [string range [set type] 0 0]
set id 0
}
return $mark$id
}
+
-# $Id: editor.tcl,v 1.69 2007/07/19 04:44:34 marko Exp $
+# $Id: editor.tcl,v 1.70 2007/07/19 08:08:58 marko Exp $
#
# Copyright 2004, 2005 University of Zagreb, Croatia. All rights reserved.
#
proc redrawAll {} {
global node_list link_list background sizex sizey grid
global curcanvas zoom
-
+ global showBkgImage showAnnotations showGrid bkgImage
+ global oval_list label_list rectangle_list text_list
.bottom.zoom config -text "zoom [expr {int($zoom * 100)}]%"
set e_sizex [expr {int($sizex * $zoom)}]
set e_sizey [expr {int($sizey * $zoom)}]
[expr {$e_sizey + $border}]"
.c delete all
- set background [.c create rectangle 0 0 $e_sizex $e_sizey \
- -fill white -tags "background"]
+
+ set canvasBkgImage [getCanvasBkg $curcanvas]
+ if { $showBkgImage == 1 && "$canvasBkgImage" != ""} {
+ set ret [backgroundImage .c $canvasBkgImage]
+ if { "$ret" == 2 } {
+ set background [.c create rectangle 0 0 $e_sizex $e_sizey \
+ -fill white -tags "background"]
+ } else {
+ set background [.c create rectangle 0 0 $e_sizex $e_sizey \
+ -tags "background"]
+ }
+ } else {
+ set background [.c create rectangle 0 0 $e_sizex $e_sizey \
+ -fill white -tags "background"]
+ }
+
+ if { $showAnnotations == 1 } {
+ foreach rect $rectangle_list {
+ if { [getNodeCanvas $rect] == $curcanvas } {
+ drawRect $rect
+ }
+ }
+ foreach oval $oval_list {
+ if { [getNodeCanvas $oval] == $curcanvas } {
+ drawOval $oval
+ }
+ }
+ foreach text $text_list {
+ if { [getNodeCanvas $text] == $curcanvas } {
+ drawText $text
+ }
+ }
+ }
# Grid
set e_grid [expr {int($grid * $zoom)}]
set e_grid2 [expr {$e_grid * 2}]
- if { 1 } {
+ if { $showGrid } {
for { set x $e_grid } { $x < $e_sizex } { incr x $e_grid } {
if { [expr {$x % $e_grid2}] != 0 } {
if { $zoom > 0.5 } {
.c create line $x 1 $x $e_sizey \
- -fill gray -dash {1 7} -tags "background"
+ -fill gray -dash {1 7} -tags "grid"
}
} else {
.c create line $x 1 $x $e_sizey -fill gray -dash {1 3} \
- -tags "background"
+ -tags "grid"
}
}
for { set y $e_grid } { $y < $e_sizey } { incr y $e_grid } {
if { [expr {$y % $e_grid2}] != 0 } {
if { $zoom > 0.5 } {
.c create line 1 $y $e_sizex $y \
- -fill gray -dash {1 7} -tags "background"
+ -fill gray -dash {1 7} -tags "grid"
}
} else {
.c create line 1 $y $e_sizex $y -fill gray -dash {1 3} \
- -tags "background"
+ -tags "grid"
}
}
}
}
.c config -cursor left_ptr
+ raiseAll .c
}
#****f* editor.tcl/drawNode
#****
proc selectNode { c obj } {
set node [lindex [$c gettags $obj] 1]
+
$c addtag selected withtag "node && $node"
if { [nodeType $node] == "pseudo" } {
set bbox [$c bbox "nodelabel && $node"]
+ } elseif { [nodeType $node] == "rectangle" } {
+ $c addtag selected withtag "rectangle && $node"
+ set bbox [$c bbox "rectangle && $node"]
+ } elseif { [nodeType $node] == "text" } {
+ $c addtag selected withtag "text && $node"
+ set bbox [$c bbox "text && $node"]
+ } elseif { [nodeType $node] == "oval" } {
+ $c addtag selected withtag "oval && $node"
+ set bbox [$c bbox "oval && $node"]
} else {
set bbox [$c bbox "node && $node"]
}
foreach obj [.c find withtag "node && selected"] {
lappend selected [lindex [.c gettags $obj] 1]
}
+ foreach obj [.c find withtag "oval && selected"] {
+ lappend selected [lindex [.c gettags $obj] 1]
+ }
+ foreach obj [.c find withtag "rectangle && selected"] {
+ lappend selected [lindex [.c gettags $obj] 1]
+ }
+ foreach obj [.c find withtag "text && selected"] {
+ lappend selected [lindex [.c gettags $obj] 1]
+ }
return $selected
}
global node_list curcanvas zoom
global activetool newlink curobj changed def_router_model
global router pc host lanswitch frswitch rj45 hub
+ global oval rectangle text
global lastX lastY
global background selectbox
global defLinkColor defLinkWidth
+ global resizemode resizeobj
set x [$c canvasx $x]
set y [$c canvasy $y]
set curobj [$c find withtag current]
set curtype [lindex [$c gettags current] 0]
- if { $curtype == "node" || ( $curtype == "nodelabel" &&
+ if { $curtype == "node" ||
+ $curtype == "oval" || $curtype == "rectangle" || $curtype == "text"
+ || ( $curtype == "nodelabel" &&
[nodeType [lindex [$c gettags $curobj] 1]] == "pseudo") } {
set node [lindex [$c gettags current] 1]
set wasselected \
if { $activetool == "select" && !$wasselected} {
selectNode $c $curobj
}
+ } elseif { $curtype == "selectmark" } {
+
+ set t1 [$c gettags current]
+ set o1 [lindex $t1 1]
+ set type1 [nodeType $o1]
+
+ if {$type1== "oval" || $type1== "rectangle"} {
+ set resizeobj $o1
+ set bbox1 [$c bbox $o1]
+ set x1 [lindex $bbox1 0]
+ set y1 [lindex $bbox1 1]
+ set x2 [lindex $bbox1 2]
+ set y2 [lindex $bbox1 3]
+ set l 0 ;# left
+ set r 0 ;# right
+ set u 0 ;# up
+ set d 0 ;# down
+
+ if { $x < [expr $x1+($x2-$x1)/8.0]} { set l 1 }
+ if { $x > [expr $x2-($x2-$x1)/8.0]} { set r 1 }
+ if { $y < [expr $y1+($y2-$y1)/8.0]} { set u 1 }
+ if { $y > [expr $y2-($y2-$y1)/8.0]} { set d 1 }
+
+ if {$l==1} {
+ if {$u==1} {
+ set resizemode lu
+ } elseif {$d==1} {
+ set resizemode ld
+ } else {
+ set resizemode l
+ }
+ } elseif {$r==1} {
+ if {$u==1} {
+ set resizemode ru
+ } elseif {$d==1} {
+ set resizemode rd
+ } else {
+ set resizemode r
+ }
+ } elseif {$u==1} {
+ set resizemode u
+ } elseif {$d==1} {
+ set resizemode d
+ } else {
+ set resizemode false
+ }
+ }
+
} elseif { $button != "ctrl" || $activetool != "select" } {
$c dtag node selected
$c delete -withtags selectmark
}
- if { [lsearch [.c gettags $curobj] background] != -1 } {
- if { [lsearch {select link} $activetool] < 0 } {
+ if { [lsearch [.c gettags $curobj] background] != -1 ||
+ [lsearch [.c gettags $curobj] grid] != -1 } {
+ if { [lsearch {select link oval rectangle text} $activetool] < 0 } {
set node [newNode $activetool]
setNodeCanvas $node $curcanvas
setNodeCoords $node "[expr {$x / $zoom}] [expr {$y / $zoom}]"
$c delete $selectbox
set selectbox ""
}
+ } elseif { $activetool == "oval" || $activetool == "rectangle" } {
+ $c config -cursor cross
+ set lastX $x
+ set lastY $y
+ } elseif { $activetool == "text" } {
+ $c config -cursor xterm
+ set lastX $x
+ set lastY $y
}
} else {
if {$curtype == "node" || $curtype == "nodelabel"} {
-tags "link"]
}
}
- $c raise link background
- $c raise linklabel "link || background"
- $c raise interface "linklabel || link || background"
- $c raise node "interface || linklabel || link || background"
- $c raise nodelabel "node || interface || linklabel || link || background"
+
+ raiseAll $c
}
proc button1-motion { c x y } {
global activetool newlink changed
global lastX lastY sizex sizey selectbox background
-
+ global oper_mode newoval newrect resizemode
set x [$c canvasx $x]
set y [$c canvasy $y]
if {$activetool == "link" && $newlink != ""} {
$c coords $newlink $lastX $lastY $x $y
} elseif { $activetool == "select" && \
- ( $curobj == $selectbox || $curtype == "background" )} {
+ ( $curobj == $selectbox || $curtype == "background" || $curtype == "grid")} {
if {$selectbox == ""} {
set selectbox [$c create line \
$lastX $lastY $x $lastY $x $y $lastX $y $lastX $lastY \
$c coords $selectbox \
$lastX $lastY $x $lastY $x $y $lastX $y $lastX $lastY
}
+ } elseif { $activetool == "select" && $curtype == "text" } {
+ $c move $curobj [expr {$x - $lastX}] [expr {$y - $lastY}]
+ set changed 1
+ set lastX $x
+ set lastY $y
+ $c delete [$c find withtag "selectmark"]
} elseif { $activetool == "select" && $curtype == "nodelabel" \
- && [nodeType [lindex [$c gettags $curobj] 1]] != "pseudo" } {
+ && [nodeType [lindex [$c gettags $curobj] 1]] != "pseudo" } {
$c move $curobj [expr {$x - $lastX}] [expr {$y - $lastY}]
set changed 1
set lastX $x
set lastY $y
+ # actually we should check if curobj==bkgImage
+ } elseif { $activetool == "oval" && \
+ ( $curobj == $newoval || $curobj == $background || $curtype == "background" || $curtype == "grid")} {
+ # Draw a new oval
+ if {$newoval == ""} {
+ set newoval [$c create oval $lastX $lastY $x $y \
+ -dash {10 4} -width 1 -tags "newoval"]
+ $c raise $newoval "background || link || linklabel || interface"
+ } else {
+ $c coords $newoval \
+ $lastX $lastY $x $y
+ }
+ # actually we should check if curobj==bkgImage
+ } elseif { $activetool == "rectangle" && \
+ ( $curobj == $newrect || $curobj == $background || $curtype == "background") || $curtype == "grid"} {
+ # Draw a new rectangle
+ if {$newrect == ""} {
+ set newrect [$c create rectangle $lastX $lastY $x $y \
+ -outline blue \
+ -dash {10 4} -width 1 -tags "newrect"]
+ $c raise $newrect "oval || background || link || linklabel || interface"
+ } else {
+ $c coords $newrect $lastX $lastY $x $y
+ }
+ } elseif { $curtype == "selectmark" } {
+ foreach o [$c find withtag "selected"] {
+ set node [lindex [$c gettags $o] 1]
+ set tagovi [$c gettags $o]
+ set koord [getNodeCoords $node]
+
+ set oldX1 [lindex $koord 0]
+ set oldY1 [lindex $koord 1]
+ set oldX2 [lindex $koord 2]
+ set oldY2 [lindex $koord 3]
+ switch -exact -- $resizemode {
+ lu {
+ set oldX1 $x
+ set oldY1 $y
+ }
+ ld {
+ set oldX1 $x
+ set oldY2 $y
+ }
+ l {
+ set oldX1 $x
+ }
+ ru {
+ set oldX2 $x
+ set oldY1 $y
+ }
+ rd {
+ set oldX2 $x
+ set oldY2 $y
+ }
+ r {
+ set oldX2 $x
+ }
+ u {
+ set oldY1 $y
+ }
+ d {
+ set oldY2 $y
+ }
+ }
+ if {$selectbox == ""} {
+ set selectbox [$c create line \
+ $oldX1 $oldY1 $oldX2 $oldY1 $oldX2 $oldY2 $oldX1 $oldY2 $oldX1 $oldY1 \
+ -dash {10 4} -fill black -width 1 -tags "selectbox"]
+ $c raise $selectbox "background || link || linklabel || interface"
+ } else {
+ $c coords $selectbox \
+ $oldX1 $oldY1 $oldX2 $oldY1 $oldX2 $oldY2 $oldX1 $oldY2 $oldX1 $oldY1
+ }
+ }
} else {
foreach img [$c find withtag "selected"] {
set node [lindex [$c gettags $img] 1]
set img [$c find withtag "selectmark && $node"]
- $c move $img [expr {$x - $lastX}] [expr {$y - $lastY}]
- set img [$c find withtag "node && $node"]
- $c move $img [expr {$x - $lastX}] [expr {$y - $lastY}]
- set img [$c find withtag "nodelabel && $node"]
- $c move $img [expr {$x - $lastX}] [expr {$y - $lastY}]
- $c addtag need_redraw withtag "link && $node"
+ if {$curtype == "oval" || $curtype == "rectangle"} {
+ $c move $img [expr {($x - $lastX) / 2}] [expr {($y - $lastY) / 2}]
+ } else {
+ $c move $img [expr {$x - $lastX}] [expr {$y - $lastY}]
+ set img [$c find withtag "node && $node"]
+ $c move $img [expr {$x - $lastX}] [expr {$y - $lastY}]
+ set img [$c find withtag "nodelabel && $node"]
+ $c move $img [expr {$x - $lastX}] [expr {$y - $lastY}]
+ $c addtag need_redraw withtag "link && $node"
+ }
}
foreach link [$c find withtag "link && need_redraw"] {
redrawLink [lindex [$c gettags $link] 1]
global changed undolog undolevel redolevel selectbox
global lastX lastY sizex sizey zoom
global autorearrange_enabled
+ global resizemode resizeobj
+ set redrawNeeded 0
set x [$c canvasx $x]
set y [$c canvasy $y]
}
}
}
+ } elseif {$activetool == "rectangle" } {
+ popupRectDialog $c 0 "false" "" "" ""
+ } elseif {$activetool == "oval" } {
+ popupOvalDialog $c 0 "false" "" "" ""
+ } elseif {$activetool == "text" } {
+ textEnter $c $x $y
}
if { $changed == 1 } {
if {$x < 0 || $y < 0 || $x > $sizex || $y > $sizey} {
set regular false
}
- $c move "nodelabel && $node" $dx $dy
- set coords [$c coords "nodelabel && $node"]
- set x [expr {[lindex $coords 0] / $zoom}]
- set y [expr {[lindex $coords 1] / $zoom}]
- setNodeLabelCoords $node "$x $y"
- if {$x < 0 || $y < 0 || $x > $sizex || $y > $sizey} {
- set regular false
+ if { [lindex [$c gettags $node] 0] == "oval" ||
+ [lindex [$c gettags $node] 0] == "rectangle" } {
+ set bbox [$c bbox "selectmark && $node"]
+ setNodeCoords $node "$bbox"
+ set redrawNeeded 1
+ }
+ if {[$c find withtag "nodelabel && $node"] != "" } {
+ $c move "nodelabel && $node" $dx $dy
+ set coords [$c coords "nodelabel && $node"]
+ set x [expr {[lindex $coords 0] / $zoom}]
+ set y [expr {[lindex $coords 1] / $zoom}]
+ setNodeLabelCoords $node "$x $y"
+ if {$x < 0 || $y < 0 || $x > $sizex || $y > $sizey} {
+ set regular false
+ }
}
$c move "selectmark && $node" $dx $dy
$c addtag need_redraw withtag "link && $node"
- }
+ set changed 1
+ } ;# end of: foreach img selected
if {$regular == "true"} {
foreach link [$c find withtag "link && need_redraw"] {
redrawLink [lindex [$c gettags $link] 1]
set changed 0
}
$c dtag link need_redraw
- } elseif {$activetool == "select" } {
+
+ # $changed!=1
+ } elseif {$activetool == "select" } {
if {$selectbox == ""} {
set x1 $x
set y1 $y
$c delete $selectbox
set selectbox ""
}
- set enclosed {}
- foreach obj [$c find enclosed $x $y $x1 $y1] {
- set tags [$c gettags $obj]
- if {[lindex $tags 0] == "node" && [lsearch $tags selected] == -1} {
- lappend enclosed $obj
+
+ if { $resizemode == "false" } {
+ set enclosed {}
+ foreach obj [$c find enclosed $x $y $x1 $y1] {
+ set tags [$c gettags $obj]
+ if {[lindex $tags 0] == "node" && [lsearch $tags selected] == -1} {
+ lappend enclosed $obj
+ }
+ if {[lindex $tags 0] == "oval" && [lsearch $tags selected] == -1} {
+ lappend enclosed $obj
+ }
+ if {[lindex $tags 0] == "rectangle" && [lsearch $tags selected] == -1} {
+ lappend enclosed $obj
+ }
+ if {[lindex $tags 0] == "text" && [lsearch $tags selected] == -1} {
+ lappend enclosed $obj
+ }
}
- }
- foreach obj $enclosed {
- selectNode $c $obj
+ foreach obj $enclosed {
+ selectNode $c $obj
+ }
+ } else {
+ setNodeCoords $resizeobj "$x $y $x1 $y1"
+ set redrawNeeded 1
+ set resizemode false
}
}
- $c raise link background
- $c raise linklabel "link || background"
- $c raise interface "linklabel || link || background"
- $c raise node "interface || linklabel || link || background"
- $c raise nodelabel "node || interface || linklabel || link || background"
+
+ if { $redrawNeeded } {
+ set redrawNeeded 0
+ redrawAll
+ } else {
+ raiseAll $c
+ }
update
updateUndoLog
}
+proc raiseAll { c } {
+ $c raise rectangle background
+ $c raise oval "rectangle || background"
+ $c raise grid "oval || rectangle || background"
+ $c raise link "grid || oval || rectangle || background"
+ $c raise linklabel "link || grid || oval || rectangle || background"
+ $c raise interface "linklabel || link || grid || oval || rectangle || background"
+ $c raise node "interface || linklabel || link || grid || oval || rectangle || background"
+ $c raise nodelabel "node || interface || linklabel || link || grid || oval || rectangle || background"
+ $c raise menuBubble "nodelabel || node || interface || linklabel || link || grid || oval || rectangle || background"
+ $c raise text "menuBubble || nodelabel || node || interface || linklabel || link || grid || oval || rectangle || background"
+}
#****f* editor.tcl/nodeEnter
# NAME
if { [lsearch {link linklabel} $tk_type] > -1 } {
set object_type link
}
+ if { [lsearch {oval} $tk_type] > -1 } {
+ set object_type oval
+ }
+ if { [lsearch {rectangle} $tk_type] > -1 } {
+ set object_type rectangle
+ }
+ if { [lsearch {text} $tk_type] > -1 } {
+ set object_type text
+ }
if { "$object_type" == ""} {
destroy $wi
return
pack $wi.cpu -side top -anchor w -fill both
}
}
+ oval {
+ destroy $wi
+ annotationConfig $c $target
+ return
+ }
+ rectangle {
+ destroy $wi
+ annotationConfig $c $target
+ return
+ }
+ text {
+ destroy $wi
+ textConfig $c $target
+ return
+ }
link {
wm title $wi "link configuration"
frame $wi.ftop -borderwidth 6
"set badentry -1 ; destroy $wi"
pack $wi.butt.cancel $wi.butt.apply -side right
pack $wi.butt -side bottom
+ bind $wi <Key-Escape> "set badentry -1; destroy $wi"
+ bind $wi <Key-Return> "popupConfigApply $wi $object_type $target 0"
after 100 {
grab .popup
}
}
set changed 1
}
- .c raise link background
- .c raise linklabel "link || background"
- .c raise interface "linklabel || link || background"
- .c raise node "interface || linklabel || link || background"
- .c raise nodelabel "node || interface || linklabel || link || background"
+ raiseAll .c
updateUndoLog
.c config -cursor left_ptr
.bottom.textbox config -text ""
set w .entry1
catch {destroy $w}
toplevel $w -takefocus 1
- update
- grab $w
+
+ if { $x == 0 && $y == 0 } {
+ set screen [wm maxsize .]
+ set x [expr {[lindex $screen 0] / 2}]
+ set y [expr {[lindex $screen 1] / 2}]
+ } else {
+ set x [expr {$x + 10}]
+ set y [expr {$y - 90}]
+ }
+ wm geometry $w +$x+$y
wm title $w "Canvas rename"
wm iconname $w "Canvas rename"
+ update
+ grab $w
label $w.msg -wraplength 5i -justify left -text "Canvas name:"
pack $w.msg -side top
button $w.buttons.cancel -text "Cancel" -command "destroy $w"
pack $w.buttons.print $w.buttons.cancel -side left -expand 1
+ bind $w <Key-Escape> "destroy $w"
+ bind $w <Key-Return> "renameCanvasApply $w"
+
entry $w.e1 -bg white
$w.e1 insert 0 [getCanvasName $curcanvas]
pack $w.e1 -side top -pady 5 -padx 10 -fill x
button $w.buttons.print -text "Apply" -command "resizeCanvasApply $w"
button $w.buttons.cancel -text "Cancel" -command "destroy $w"
pack $w.buttons.print $w.buttons.cancel -side left -expand 1
+ bind $w <Key-Escape> "destroy $w"
+ bind $w <Key-Return> "resizeCanvasApply $w"
frame $w.size
pack $w.size -side top -fill x -pady 2m
global zoom
set stops ".25 .5 .75 1.0 1.5 2.0 4.0"
- set i [lsearch $stops $zoom]
+ # set i [lsearch $stops $zoom]
+ set minzoom [lindex $stops 0]
+ set maxzoom [lindex $stops [expr [llength $stops] - 1]]
switch -exact -- $dir {
"down" {
- if { $i >0 } {
- set zoom [lindex $stops [expr $i - 1]]
- redrawAll
+ if {$zoom > $maxzoom} {
+ set zoom $maxzoom
+ } elseif {$zoom < $minzoom} {
+ ; # leave it unchanged
+ } else {
+ set newzoom $minzoom
+ foreach z $stops {
+ if {$zoom <= $z} {
+ break
+ } else {
+ set newzoom $z
+ }
+ }
+ set zoom $newzoom
}
+ redrawAll
}
"up" {
+ if {$zoom < $minzoom} {
+ set zoom $minzoom
+ } elseif {$zoom > $maxzoom} {
+ ; # leave it unchanged
+ } else {
+ foreach z [lrange $stops 1 end] {
+ set newzoom $z
+ if {$zoom < $z} {
+ break
+ }
+ }
+ set zoom $newzoom
+ }
+ redrawAll
+ }
+ default {
if { $i < [expr [llength $stops] - 1] } {
set zoom [lindex $stops [expr $i + 1]]
redrawAll
}
+#****h* editor.tcl/double1onGrid
+# NAME
+# double1onGrid.tcl -- called on Double-1 click on grid (bind command)
+# SYNOPSIS
+# double1onGrid $c %x %y
+# FUNCTION
+# As grid is layered above annotations this procedure is used to find
+# annotation object closest to cursor
+#****
+
+proc double1onGrid { c x y } {
+ set obj [$c find closest $x $y]
+ set tags [$c gettags $obj]
+ set node [lindex $tags 1]
+ if {[lsearch $tags grid] != -1 || [lsearch $tags background] != -1} {
+ return
+ }
+ # Is this really necessary?
+ set coords [getNodeCoords $node]
+ set x1 [lindex $coords 0]
+ set y1 [lindex $coords 1]
+ set x2 [lindex $coords 2]
+ set y2 [lindex $coords 3]
+ if {$x < $x1 || $x > $x2 || $y < $y1 || $y > $y2} {
+ # cursor is not ON the closest object
+ return
+ } else {
+ annotationConfig $c $node
+ }
+}
+
+proc setZoom { x y } {
+ global curcanvas
+ global zoom
+
+ 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] / 2}]
+ set y [expr {[lindex $screen 1] / 2}]
+ } else {
+ set x [expr {$x + 10}]
+ set y [expr {$y - 90}]
+ }
+ wm geometry $w +$x+$y
+ wm title $w "Set zoom %"
+ wm iconname $w "Set zoom %"
+
+ update
+ grab $w
+ label $w.msg -wraplength 5i -justify left -text "Zoom percentage:"
+ pack $w.msg -side top
+
+ frame $w.buttons
+ pack $w.buttons -side bottom -fill x -pady 2m
+ button $w.buttons.print -text "Apply" -command "setZoomApply $w"
+ button $w.buttons.cancel -text "Cancel" -command "destroy $w"
+ pack $w.buttons.print $w.buttons.cancel -side left -expand 1
+
+ bind $w <Key-Escape> "destroy $w"
+ bind $w <Key-Return> "setZoomApply $w"
+
+ entry $w.e1 -bg white
+ $w.e1 insert 0 [expr {int($zoom * 100)}]
+ pack $w.e1 -side top -pady 5 -padx 10 -fill x
+}
+
+proc setZoomApply { w } {
+ global zoom changed
+
+ set newzoom [expr [$w.e1 get] / 100.0]
+ if { $newzoom != $zoom } {
+ set zoom $newzoom
+ redrawAll
+ }
+ destroy $w
+}
+
+proc selectZoom { x y } {
+ global curcanvas
+ global zoom
+
+ set stops ".25 .5 .75 1.0 1.5 2.0 4.0"
+
+ 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] / 2}]
+ set y [expr {[lindex $screen 1] / 2}]
+ } else {
+ set x [expr {$x + 10}]
+ set y [expr {$y - 90}]
+ }
+ wm geometry $w +$x+$y
+ wm title $w "Select zoom %"
+ wm iconname $w "Select zoom %"
+
+ update
+ grab $w
+
+ frame $w.buttons
+ pack $w.buttons -side bottom -fill x -pady 2m
+ button $w.buttons.print -text "Apply" -command "setZoomApply $w"
+ button $w.buttons.cancel -text "Cancel" -command "destroy $w"
+ pack $w.buttons.print $w.buttons.cancel -side left -expand 1
+
+ bind $w <Key-Escape> "destroy $w"
+ bind $w <Key-Return> "setZoomApply $w"
+
+ entry $w.e1 -bg white
+ $w.e1 insert 0 [expr {int($zoom * 100)}]
+ pack $w.e1 -side top -pady 5 -padx 10 -fill x
+}
+
projects / imunes.git / commitdiff