--- /dev/null
+
+#****h* imunes/annotations.tcl
+# NAME
+# annotations.tcl -- oval, rectangle, text, background, ...
+# FUNCTION
+# This module is used for configuration/image annotations, such as oval,
+# rectangle, text, background or some other.
+#****
+
+#****f* annotations.tcl/annotationConfig
+# NAME
+# annotationConfig --
+# SYNOPSIS
+# annotationConfig $canvas $target
+# FUNCTION
+# . . .
+# INPUTS
+# * canvas --
+# * target -- oval or rectangle object
+#****
+
+proc annotationConfig { c target } {
+ global newoval $target
+
+ set color [lindex [lsearch -inline [set $target] "color *"] 1]
+ set label [lindex [lsearch -inline [set $target] "label *"] 1]
+ set lcolor [lindex [lsearch -inline [set $target] "labelcolor *"] 1]
+
+ # set newoval $target
+ switch -exact -- [nodeType $target] {
+ oval {
+ popupOvalDialog $c $target "true" $color $label $lcolor
+ }
+ rectangle {
+ popupRectDialog $c $target "true" $color $label $lcolor
+ }
+ text {
+ textConfig $c $target
+ }
+ default {
+ puts "Unknown type [nodeType $target] for target $target"
+ }
+ }
+ redrawAll
+}
+
+
+#****f* annotations.tcl/popupOvalDialog
+# NAME
+# popupOvalDialog -- creates a new oval or modifies existing oval
+# SYNOPSIS
+# popupOvalDialog $canvas $modify $color $label $lcolor
+# FUNCTION
+# Called from:
+# - editor.tcl/button1-release when new oval is drawn
+# - annotationConfig which is called from popupConfigDialog bound to
+# Double-1 on various objects
+# - configureOval called from button3annotation procedure which creates
+# a menu for configuration and deletion (bound to 3 on oval,
+# rectangle and text)
+# INPUTS
+# * canvas --
+# * modify -- create new oval "newoval" if modify=false or
+# modify an existing oval "newoval" if modify=true
+# * color -- oval color
+# * label -- label text
+# * lcolor -- label (text) color
+#****
+
+proc popupOvalDialog { c target modify color label lcolor } {
+ global newoval defOvalColor $target
+
+
+ # do nothing, return, if coords are empty
+ if { $target == 0 && [$c coords "$newoval"] == "" } {
+ return
+ }
+ set wi .popup
+ catch {destroy $wi}
+ toplevel $wi
+
+ wm transient $wi .
+ wm resizable $wi 0 0
+
+ if { $modify == "true" } {
+ set windowtitle "Configure oval"
+ } else {
+ set windowtitle "Add a new oval"
+ }
+ wm title $wi $windowtitle
+ frame $wi.lab -borderwidth 4
+ label $wi.lab.name_label -text "Text for top of oval:"
+ entry $wi.lab.name -bg white -width 16 \
+ -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
+
+ # color selection controls
+ frame $wi.colors -borderwidth 4
+ label $wi.colors.label -text "Color:"
+ if { $color == "" } {
+ set color $defOvalColor
+ }
+ if { $lcolor == "" } {
+ set lcolor black
+ }
+ label $wi.colors.color -text $color -width 8 \
+ -bg $color -fg $lcolor
+ button $wi.colors.fg -text "fg" -command \
+ "popupColor fg $wi.colors.color false"
+ button $wi.colors.bg -text "bg" -command \
+ "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
+ pack $wi.colors -side top
+
+ set applycmd "popupOvalApply $c $wi $target"
+
+ # Add new oval or modify old one?
+ if { $modify == "true" } {
+ set cancelcmd "destroy $wi"
+ set applytext "Modify oval"
+ } else {
+ set cancelcmd "destroy $wi; destroyNewoval $c"
+ set applytext "Add oval"
+ }
+
+ frame $wi.butt -borderwidth 6
+ button $wi.butt.apply -text $applytext -command "$applycmd"
+ button $wi.butt.cancel -text "Cancel" -command $cancelcmd
+ bind $wi <Key-Escape> "$cancelcmd"
+ bind $wi <Key-Return> "$applycmd"
+ pack $wi.butt.cancel $wi.butt.apply -side right
+ pack $wi.butt -side bottom
+ after 100 {
+ grab .popup
+ }
+ return
+}
+
+
+#****f* annotations.tcl/destroyNewoval
+# NAME
+# destroyNewoval -- helper for popupOvalDialog and popupOvalApply
+# SYNOPSIS
+# destroyNewoval $canvas
+# FUNCTION
+# . . .
+# INPUTS
+# * canvas --
+#****
+
+proc destroyNewoval { c } {
+ global newoval
+ $c delete -withtags newoval
+ set newoval ""
+}
+
+
+# create a oval
+proc popupOvalApply { c wi target} {
+ global newoval oval_list
+ global $target
+ global changed
+
+ # oval attributes
+ set caption [string trim [$wi.lab.name get]]
+ set color [$wi.colors.color cget -text]
+ set labelcolor [$wi.colors.color cget -fg]
+ set coords [$c coords "$target"]
+ set iconcoords "iconcoords"
+
+ # build the oval object
+ if {$target == 0} {
+ set object [newObjectId "oval"]
+ lappend oval_list $object
+ set coords [$c coords "$newoval"]
+ } else {
+ set object $target
+ }
+ global $object
+ set $object {}
+ lappend $iconcoords $coords
+ lappend $object $iconcoords "color $color" \
+ "label {$caption}" "labelcolor $labelcolor"
+
+ # draw it
+ drawOval $object
+
+ destroyNewoval $c
+ destroy $wi
+ set changed 1
+ updateUndoLog
+ redrawAll
+}
+
+
+# oval/rectangle/text right-click menu
+
+proc button3annotation { type c x y } {
+
+ if { $type == "oval" } {
+ set procname "Oval"
+ set item [lindex [$c gettags {oval && current}] 1]
+ } elseif { $type == "rectangle" } {
+ set procname "Rectangle"
+ set item [lindex [$c gettags {rectangle && current}] 1]
+ } elseif { $type == "label" } {
+ set procname "Label"
+ set item [lindex [$c gettags {label && current}] 1]
+ } elseif { $type == "text" } {
+ set procname "Text"
+ set item [lindex [$c gettags {text && current}] 1]
+ } else {
+ # ???
+ return
+ }
+ if { $item == "" } {
+ return
+ }
+ set menutext "$type $item"
+
+ .button3menu delete 0 end
+
+ .button3menu add command -label "Configure $menutext" \
+ -command "annotationConfig $c $item"
+ .button3menu add command -label "Delete $menutext" \
+ -command "deleteAnnotation $c $type $item"
+
+ set x [winfo pointerx .]
+ set y [winfo pointery .]
+ tk_popup .button3menu $x $y
+}
+
+
+proc deleteAnnotation { c type target } {
+ upvar ${type}_list type_list
+ global changed
+
+ $c delete -withtags "$type && $target"
+ $c delete -withtags "new$type"
+ set i [lsearch -exact $type_list $target]
+ set type_list [lreplace $type_list $i $i]
+ set changed 1
+ updateUndoLog
+}
+
+
+proc drawOval {oval} {
+ global $oval defOvalColor defOvalLabelFont zoom curcanvas
+
+ set coords [getNodeCoords $oval]
+ set x1 [expr {[lindex $coords 0] * $zoom}]
+ set y1 [expr {[lindex $coords 1] * $zoom}]
+ set x2 [expr {[lindex $coords 2] * $zoom}]
+ set y2 [expr {[lindex $coords 3] * $zoom}]
+ set color [lindex [lsearch -inline [set $oval] "color *"] 1]
+ set label [lindex [lsearch -inline [set $oval] "label *"] 1]
+ set lcolor [lindex [lsearch -inline [set $oval] "labelcolor *"] 1]
+ set lx [expr $x1 + (($x2 - $x1) / 2)]
+ set ly [expr ($y1 + 20)]
+
+ if { $color == "" } {
+ set color $defOvalColor
+ }
+ 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"]
+ .c raise $newoval background
+ .c create text $lx $ly -tags "oval $oval" -text $label \
+ -justify center -font $defOvalLabelFont -fill $lcolor
+ setNodeCanvas $oval $curcanvas
+ setType $oval "oval"
+}
+
+
+# Color helper for popupOvalDialog and popupLabelDialog
+proc popupColor { type l settext } {
+ # popup color selection dialog with current color
+ if { $type == "fg" } {
+ set initcolor [$l cget -fg]
+ } else {
+ set initcolor [$l cget -bg]
+ }
+ set newcolor [tk_chooseColor -initialcolor $initcolor]
+
+ # set fg or bg of the "l" label control
+ if { $newcolor == "" } {
+ return
+ }
+ if { $settext == "true" } {
+ $l configure -text $newcolor -$type $newcolor
+ } else {
+ $l configure -$type $newcolor
+ }
+}
+
+
+#****f* annotations.tcl/roundRect
+# NAME
+# roundRect -- Draw a rounded rectangle in the canvas.
+# Called from drawRect procedure
+# SYNOPSIS
+# roundRect $w $x0 $y0 $x3 $y3 $radius $args
+# FUNCTION
+# Creates a rounded rectangle as a smooth polygon in the canvas
+# and returns the canvas item number of the rounded rectangle.
+# INPUTS
+# * w -- Path name of the canvas
+# * x0, y0 -- Coordinates of the upper left corner, in pixels
+# * x3, y3 -- Coordinates of the lower right corner, in pixels
+# * radius -- Radius of the bend at the corners, in any form
+# acceptable to Tk_GetPixels
+# * args -- Other args suitable to a 'polygon' item on the canvas
+# Example:
+# roundRect .c 100 50 500 250 $rad -fill white -outline black -tags rectangle
+#****
+
+proc roundRect { w x0 y0 x3 y3 radius args } {
+
+ set r [winfo pixels $w $radius]
+ set d [expr { 2 * $r }]
+
+ # Make sure that the radius of the curve is less than 3/8 size of the box
+
+ set maxr 0.75
+
+ if { $d > $maxr * ( $x3 - $x0 ) } {
+ set d [expr { $maxr * ( $x3 - $x0 ) }]
+ }
+ if { $d > $maxr * ( $y3 - $y0 ) } {
+ set d [expr { $maxr * ( $y3 - $y0 ) }]
+ }
+
+ set x1 [expr { $x0 + $d }]
+ set x2 [expr { $x3 - $d }]
+ set y1 [expr { $y0 + $d }]
+ set y2 [expr { $y3 - $d }]
+
+ set cmd [list $w create polygon]
+ lappend cmd $x0 $y0 $x1 $y0 $x2 $y0 $x3 $y0 $x3 $y1 $x3 $y2
+ lappend cmd $x3 $y3 $x2 $y3 $x1 $y3 $x0 $y3 $x0 $y2 $x0 $y1
+ lappend cmd -smooth 1
+ return [eval $cmd $args]
+ }
+
+proc drawRect {rectangle} {
+ global $rectangle defRectColor defRectLabelFont zoom curcanvas
+
+ set coords [getNodeCoords $rectangle]
+ if {$coords == ""} {
+ tk_messageBox -type ok -message "Prazne coords za $rectangle"
+ return
+ }
+
+ set x1 [expr {[lindex $coords 0] * $zoom}]
+ set y1 [expr {[lindex $coords 1] * $zoom}]
+ set x2 [expr {[lindex $coords 2] * $zoom}]
+ set y2 [expr {[lindex $coords 3] * $zoom}]
+ set color [lindex [lsearch -inline [set $rectangle] "color *"] 1]
+ set label [lindex [lsearch -inline [set $rectangle] "label *"] 1]
+ set lcolor [lindex [lsearch -inline [set $rectangle] "labelcolor *"] 1]
+ set lx [expr $x1 + (($x2 - $x1) / 2)]
+ set ly [expr ($y1 + 20)]
+
+ if { $color == "" } {
+ set color $defRectColor
+ }
+ if { $lcolor == "" } {
+ set lcolor black
+ }
+ # rounded-rectangle radius
+ set rad 25
+ set newrect [roundRect .c $x1 $y1 $x2 $y2 $rad \
+ -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
+ setNodeCanvas $rectangle $curcanvas
+ setType $rectangle "rectangle"
+}
+
+
+proc popupRectDialog { c rectangle modify color label lcolor } {
+ global newrect defRectColor
+ global $rectangle
+
+ # do nothing, return, if coords are empty
+ if { $rectangle == 0 && [$c coords "$newrect"] == "" } {
+ return
+ }
+ set wi .popup
+ catch {destroy $wi}
+ toplevel $wi
+
+ wm transient $wi .
+ wm resizable $wi 0 0
+
+ if { $modify == "true" } {
+ set windowtitle "Configure rectangle $rectangle"
+ } else {
+ set windowtitle "Add a new rectangle"
+ }
+ wm title $wi $windowtitle
+ 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"
+ $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
+
+ # color selection controls
+ frame $wi.colors -borderwidth 4
+ label $wi.colors.label -text "Color:"
+ if { $color == "" } {
+ set color $defRectColor
+ }
+ if { $lcolor == "" } {
+ set lcolor black
+ }
+ label $wi.colors.color -text $color -width 8 \
+ -bg $color -fg $lcolor
+ button $wi.colors.fg -text "fg" -command \
+ "popupColor fg $wi.colors.color false"
+ button $wi.colors.bg -text "bg" -command \
+ "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
+ pack $wi.colors -side top
+
+ # Add new oval or modify old one?
+ if { $modify == "true" } {
+ set cancelcmd "destroy $wi"
+ set applytext "Modify rectangle"
+ } else {
+ set cancelcmd "destroy $wi; destroyNewRect $c"
+ set applytext "Add rectangle"
+ }
+
+ frame $wi.butt -borderwidth 6
+ button $wi.butt.apply -text $applytext -command "popupRectApply $c $wi $rectangle"
+
+ button $wi.butt.cancel -text "Cancel" -command $cancelcmd
+ bind $wi <Key-Escape> "$cancelcmd"
+ bind $wi <Key-Return> "popupRectApply $c $wi $rectangle"
+ pack $wi.butt.cancel $wi.butt.apply -side right
+ pack $wi.butt -side bottom
+ after 100 {
+ grab .popup
+ }
+ return
+}
+
+
+# helper for popupOvalDialog and popupOvalApply
+proc destroyNewRect { c } {
+ global newrect
+ $c delete -withtags newrect
+ set newrect ""
+}
+
+# create a rectangle
+proc popupRectApply { c wi target } {
+ global newrect rectangle_list
+ global $target
+ global changed
+
+ # attributes
+ set caption [string trim [$wi.lab.name get]]
+ set color [$wi.colors.color cget -text]
+ set labelcolor [$wi.colors.color cget -fg]
+ set coords [$c coords "$target"]
+ set iconcoords "iconcoords"
+
+ # build the oval object
+ # Prije: set object [newObjectId "rectangle"]
+ set object $target
+ if { $target == 0 } {
+ # Create a new rectangle object
+ set target [newObjectId "rectangle"]
+ global $target
+ lappend rectangle_list $target
+ set coords [$c coords $newrect]
+ } else {
+ set coords [getNodeCoords $target]
+ }
+ set $target {}
+ lappend $iconcoords $coords
+ lappend $target $iconcoords "color $color" \
+ "label {$caption}" "labelcolor $labelcolor"
+
+ # draw it
+ drawRect $target
+ destroyNewRect $c
+
+ set changed 1
+ updateUndoLog
+ redrawAll
+ destroy $wi
+}
+
+
+proc backgroundImage { c file } {
+ global sizex sizey zoom
+
+ set e_sizex [expr {int($sizex * $zoom)}]
+ set e_sizey [expr {int($sizey * $zoom)}]
+
+ if {"$file" == ""} {
+ return
+ }
+
+ set error [catch "image create photo Photo -file $file" errorMsg]
+ if { $error == "1" } {
+ after idle {.dialog1.msg configure -wraplength 4i}
+ tk_dialog .dialog1 "IMUNES error" \
+ "Couldn\'t set canvas background image:\n$errorMsg" \
+ info 0 Dismiss
+ return 2
+ }
+ set image_h [image height Photo]
+ set image_w [image width Photo]
+
+ set rx [expr $e_sizex * 1.0 / $image_w]
+ set ry [expr $e_sizey * 1.0/ $image_h]
+
+ if { $rx < $ry } {
+ set faktor [expr $rx * 100]
+ } else {
+ set faktor [expr $ry * 100]
+ }
+
+ set faktor [expr int($faktor)]
+
+ if { $faktor > 100 || $image_w > 1280 || $image_h > 1024 } {
+ after idle {.dialog1.msg configure -wraplength 4i}
+ tk_dialog .dialog1 "IMUNES error" \
+ "Error: image should be >= $e_sizex*$e_sizey and <= 1280*1024 ($file is $image_h*$image_w)" \
+ info 0 Dismiss
+ image delete Photo
+ return 2
+ }
+
+ set image [image% Photo $faktor]
+ $c create image 0 0 -anchor nw -image $image -tags "background"
+}
+
+proc image% {image percent} {
+ set deno [gcd $percent 100]
+ set zoom [expr {$percent/$deno}]
+ set subsample [expr {100/$deno}]
+ set im1 [image create photo]
+ $im1 copy $image -zoom $zoom
+ set im2 [image create photo]
+ $im2 copy $im1 -subsample $subsample
+ image delete $im1
+ set im2
+}
+
+proc gcd {u v} {expr {$u? [gcd [expr $v%$u] $u]: $v}}
+
+proc selectmarkEnter {c x y} {
+ set obj [lindex [$c gettags current] 1]
+ set type [nodeType $obj]
+
+ if {$type != "oval" && $type != "rectangle"} { return }
+
+ set bbox [$c bbox $obj]
+ set x1 [lindex $bbox 0]
+ set y1 [lindex $bbox 1]
+ set x2 [lindex $bbox 2]
+ set y2 [lindex $bbox 3]
+ set l 0 ;# left
+ set r 0 ;# right
+ set u 0 ;# up
+ set d 0 ;# down
+
+ set x [$c canvasx $x]
+ set y [$c canvasy $y]
+
+ 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} {
+ $c config -cursor top_left_corner
+ } elseif {$d==1} {
+ $c config -cursor bottom_left_corner
+ } else {
+ $c config -cursor left_side
+ }
+ } elseif {$r==1} {
+ if {$u==1} {
+ $c config -cursor top_right_corner
+ } elseif {$d==1} {
+ $c config -cursor bottom_right_corner
+ } else {
+ $c config -cursor right_side
+ }
+ } elseif {$u==1} {
+ $c config -cursor top_side
+ } elseif {$d==1} {
+ $c config -cursor bottom_side
+ } else {
+ $c config -cursor left_ptr
+ }
+}
+
+proc selectmarkLeave {c x y} {
+ .bottom.textbox config -text {}
+ $c config -cursor left_ptr
+}
+
+
+proc textEnter { c x y } {
+ global text_list
+ global curcanvas
+
+ set object [newObjectId "text"]
+ set newtext [$c create text $x $y -text "" -anchor w -justify left -tags "text $object"]
+
+ set coords [$c coords "text && $object"]
+ set iconcoords "iconcoords"
+
+ global $object
+ set $object {}
+ setType $object "text"
+ lappend $iconcoords $coords
+ lappend $object $iconcoords
+ lappend $object "label {}"
+ setNodeCanvas $object $curcanvas
+
+ lappend text_list $object
+ textConfig $c $object
+}
+
+
+proc drawText {text} {
+ global $text defTextColor defTextFont defTextFontFamily defTextFontSize
+ global zoom curcanvas newfontsize
+
+ set coords [getNodeCoords $text]
+ if {$coords == ""} {
+ puts "Empty coordinates for text $text" ;# MM debug
+ return
+ }
+ set x [expr {[lindex $coords 0] * $zoom}]
+ set y [expr {[lindex $coords 1] * $zoom}]
+ set color [lindex [lsearch -inline [set $text] "color *"] 1]
+ if { $color == "" } {
+ set color $defTextColor
+ }
+ set label [lindex [lsearch -inline [set $text] "label *"] 1]
+ set fontfamily [lindex [lsearch -inline [set $text] "fontfamily *"] 1]
+ set fontsize [lindex [lsearch -inline [set $text] "fontsize *"] 1]
+ if { $fontfamily == "" } {
+ set fontfamily $defTextFontFamily
+ }
+ if { $fontsize == "" } {
+ set fontsize $defTextFontSize
+ }
+ set newfontsize $fontsize
+ 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"]
+
+ .c addtag text withtag $newtext
+ .c raise $text background
+ setNodeCanvas $text $curcanvas
+ setType $text "text"
+}
+
+
+proc textConfig { c target } {
+ global $target defTextColor defTextFont defTextFontFamily defTextFontSize
+ global fontfamily fontsize
+
+ set color [lindex [lsearch -inline [set $target] "color *"] 1]
+ set label [lindex [lsearch -inline [set $target] "label *"] 1]
+ set fontfamily [lindex [lsearch -inline [set $target] "fontfamily *"] 1]
+ set fontsize [lindex [lsearch -inline [set $target] "fontsize *"] 1]
+ set font [list "$fontfamily" $fontsize]
+
+ set textBold 0
+ set textItalic 0
+ set textUnderline 0
+ set effects [lindex [lsearch -inline [set $target] "effects *"] 1]
+ if { [lsearch $effects bold ] != -1} {set textBold 1}
+ if { [lsearch $effects italic ] != -1} {set textItalic 1}
+ if { [lsearch $effects underline ] != -1} {set textUnderline 1}
+
+ if { $fontfamily == "" } {
+ set fontfamily $defTextFontFamily
+ }
+ if { $fontsize == "" } {
+ set fontsize $defTextFontSize
+ }
+
+ set wi .popup
+ catch {destroy $wi}
+ toplevel $wi
+
+ wm transient $wi .
+ wm resizable $wi 1 1
+ wm title $wi "Configure text"
+
+ $wi configure -bd 2 -relief raised
+
+ entry $wi.text -background white
+ frame $wi.prop
+ frame $wi.action
+ pack $wi.text $wi.prop -anchor nw -side top -fill x
+ pack $wi.action -side top
+
+ frame $wi.prop.font -relief groove -bd 2
+ label $wi.prop.font.label -text "Font:"
+ 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
+
+ frame $wi.prop.format -relief groove -bd 2
+ label $wi.prop.format.label -text "Effects:"
+ pack $wi.prop.font $wi.prop.format -side top -pady 2 -anchor w -fill x
+
+ # color selection
+ if { $color == "" } {
+ set color $defTextColor
+ }
+ button $wi.prop.format.fg -text "Color" -command \
+ "popupColor fg $wi.text false"
+ checkbutton $wi.prop.format.bold -text "Bold" -variable textBold \
+ -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]
+
+ 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 \
+ $wi.prop.format.bold \
+ $wi.prop.format.italic \
+ $wi.prop.format.underline \
+ -side left -pady 2 ;# -fill both
+
+ $wi.text insert end $label
+ $wi.text configure -font [list "$fontfamily" $fontsize $effects] -fg $color
+
+ $fontmenu delete 0
+ foreach f [lsort -dictionary [font families]] {
+ $fontmenu add radiobutton -value "$f" -label $f \
+ -variable fontfamily \
+ -command [list fontupdate $wi.text fontfamily $f]
+ }
+
+ $sizemenu delete 0
+ foreach f {8 9 10 11 12 14 16 18 20 22 24 26 28 36 48 72} {
+ $sizemenu add radiobutton -value "$f" -label $f \
+ -variable fontsize \
+ -command [list fontupdate $wi.text fontsize $f]
+ }
+
+ set applycmd "textConfigApply $c $wi $target "
+ set cancelcmd "destroy $wi"
+
+ button $wi.action.apply -text "Apply" -command "$applycmd"
+ button $wi.action.cancel -text "Cancel" -command "$cancelcmd"
+ bind $wi <Key-Escape> "$cancelcmd"
+ bind $wi <Key-Return> "$applycmd"
+
+ pack $wi.action.apply $wi.action.cancel -side left ;# -fill x
+
+ after 100 {
+ focus .popup.text
+ grab .popup
+ }
+ return
+}
+
+proc fontupdate { label type args} {
+ global fontfamily fontsize
+ global textBold textItalic textUnderline
+
+ if {"$textBold" == 1} {set bold "bold"} else {set bold {} }
+ if {"$textItalic"} {set italic "italic"} else {set italic {} }
+ if {"$textUnderline"} {set underline "underline"} else {set underline {} }
+ switch $type {
+ fontsize {
+ set fontsize $args
+ }
+ fontfamily {
+ set fontfamily "$args"
+ }
+ }
+ set f [list "$fontfamily" $fontsize]
+ lappend f "$bold $italic $underline"
+ $label configure -font "$f"
+}
+
+
+proc textConfigApply { c wi target } {
+ global text_list
+ global $target
+ global fontfamily fontsize textBold textItalic textUnderline
+ global changed
+
+ # new text attributes
+ set caption [string trim [$wi.text get]]
+ # set color [$wi.prop.format.fg cget -fg]
+ set color [$wi.text cget -fg]
+ set iconcoords "iconcoords"
+
+ # build the oval object
+ if { $target == 0 } {
+ set target [newObjectId "target"]
+ global $target
+ lappend text_list $target
+ set coords [$c coords $newtext]
+ } else {
+ set coords [getNodeCoords $target]
+ }
+
+ set $target {}
+ lappend $iconcoords $coords
+ 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}"}
+
+ # draw it
+ drawText $target
+ set changed 1
+ updateUndoLog
+ redrawAll
+
+ destroy $wi
+}
+
+# from Practical Programming in Tcl and Tk, page 190
+proc Call_Trace {{file stdout}} {
+ puts $file "*** Tcl Call Trace:"
+ for {set x [expr [info level]-1]} {$x > 0} {incr x -1} {
+ puts $file " $x: [info level $x]"
+ }
+}
+
projects / imunes.git / commitdiff