From 6315f68c56c74065f402f2378cb2d4419d3ff34c Mon Sep 17 00:00:00 2001 From: pserver Date: Wed, 11 Jul 2007 07:57:48 +0000 Subject: [PATCH] Rectangle, oval (circle) and text annotations. Bug found by: Submitted by: Requested by: Reviewed by: Approved by: Obtained from: --- annotations.tcl | 872 +++++++++++++++++++++++++++++++++++++++ icons/tiny/oval.gif | Bin 0 -> 639 bytes icons/tiny/rectangle.gif | Bin 0 -> 607 bytes 3 files changed, 872 insertions(+) create mode 100644 annotations.tcl create mode 100644 icons/tiny/oval.gif create mode 100644 icons/tiny/rectangle.gif diff --git a/annotations.tcl b/annotations.tcl new file mode 100644 index 0000000..f8fee43 --- /dev/null +++ b/annotations.tcl @@ -0,0 +1,872 @@ + +#****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 "$cancelcmd" + bind $wi "$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 + lappend $object "color $color" + lappend $object "label {$caption}" + lappend $object "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 + } + 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 "$cancelcmd" + bind $wi "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 + lappend $target "color $color" + lappend $target "label {$caption}" + lappend $target "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 "$cancelcmd" + bind $wi "$applycmd" + + pack $wi.action.apply $wi.action.cancel -side left ;# -fill x + + after 100 { + 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 + lappend $target "color $color" + lappend $target "label {$caption}" + lappend $target "fontfamily {$fontfamily}" + lappend $target "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]" + } +} + diff --git a/icons/tiny/oval.gif b/icons/tiny/oval.gif new file mode 100644 index 0000000000000000000000000000000000000000..1a7b806c93192953d3b1459df31b03040be29498 GIT binary patch literal 639 zcmd6jJr06E5QPVo#9A7(Fe_MWVF8RW7&}QYcErlo16X(i1noVlvC_n_?k{L#W#JYK z!_K_-K33~Ap6^C5gc|^3>^kV*_Xh^{)19%3fjpx}#}Y3S@es4nuDSp@@BXALkBAA~ zG?7RcV{$@7YI2ei$1*NKU#F(n(hTRGqfjENCdy8};LFN(gPDbLA*ecfQ55P6-=KEl z9Z?pJU8_MJwS+|>MO9GZD3!3_DsnQ5Vx4!I=#K?j>JEs@kvwndqObOZ3W*U*#PQZ} cN@?mDvSw1N{Gy~LZ}Vq9?BA%rOkQB|0tAjq{Qv*} literal 0 HcmV?d00001 diff --git a/icons/tiny/rectangle.gif b/icons/tiny/rectangle.gif new file mode 100644 index 0000000000000000000000000000000000000000..c9b03d2f04fd84d1e764231e47d7241cc1594e98 GIT binary patch literal 607 zcmZ?wbhEHbRAi82_{hNU|Ns9VxrP53SpP_vDgI<(WB>vk5CM{BVEV_xA)w&Uz`)2f z=oxB0GYk?BwQvf97>Xb_yG_vuT;$Rzr0NA?H~~eJLXfJD}kr$P8o{Bq4