wdb The script canvasEditor .c creates the canvas .c the bindings of which are prepared for simple vector graphics editor (not a megawidget!).
Example:
if true then {
pack [canvasEditor .c] -expand yes -fill both
.c create rectangle 10 10 100 100 -fill yellow
.c create oval 50 50 150 150 -fill red
.c itemconfigure all -width 5
}Outside the figures, context menu Line manages that next mouse-press-motion draws a line. Inside the figures, context menu Create → Line does the same.
Having drawn the line, it appears with white dots as end points. Move them for fine-tuning the line. Inside the white dots, context menu Add adds a new dot, and Delete removes current dot (if more than 2).
Outside dots, context menu Done finishes edit mode.
With mouse inside figure, context menu Edit → Coordinates starts coordinates editing mode again.
Select item by click or shift-click. Outside figures, press-motion manages selection area.
No arcs, no text items. No area scaling, no area rotating. Simple little tool if you want to design some graphics the smart way for your own application. If you add arc or text items with command such as .c create text {50 50} -text howdy, you can move it by mouse as well as lines etc.
Use canvasdump to transfer it to your app.
License OLL als always. Have fun.
Code:
# vectorgraphics.tcl
package require Tk
bind [winfo class .] <Destroy> exit
#
# Elementary mouse actions: select, move
#
namespace eval ::canvasEditorBindings {
variable canvasMouse ""
namespace import ::tcl::mathop::*
namespace export canvasEditor
}
proc ::canvasEditorBindings::canvasEditor {canvas args} {
variable canvasMouse
dict set canvasMouse $canvas motion "0 0"
dict set canvasMouse $canvas action press
::canvas $canvas {*}$args
createContextMenu $canvas
canvasBindings $canvas on
canvasBindingsSelect $canvas on
::set canvas
}
namespace import ::canvasEditorBindings::canvasEditor
proc ::canvasEditorBindings::canvasBindings {canvas {onOff on}} {
variable canvasMouse
dict set canvasMouse $canvas motion "0 0"
dict set canvasMouse $canvas action press
dict set canvasMouse $canvas current ""
if {$onOff} then {
bind $canvas <1> {
apply {
{canvas x y} {
variable canvasMouse
dict set canvasMouse $canvas position\
"[$canvas canvasx $x] [$canvas canvasy $y]"
dict set canvasMouse $canvas selStart\
"[$canvas canvasx $x] [$canvas canvasy $y]"
dict set canvasMouse $canvas action press
set current [$canvas find withtag current]
dict set canvasMouse $canvas current $current
if {$current eq ""} then {
# $canvas dtag all sel
canvasUnselect $canvas all
}
} ::canvasEditorBindings
} %W %x %y
}
bind $canvas <B1-Motion> {
apply {
{canvas x y} {
variable canvasMouse
lassign [dict get $canvasMouse $canvas position] x0 y0
set x1 [$canvas canvasx $x]
set y1 [$canvas canvasy $y]
dict set canvasMouse $canvas motion "[- $x1 $x0] [- $y1 $y0]"
dict set canvasMouse $canvas position "$x1 $y1"
dict set canvasMouse $canvas action move
if {[dict get $canvasMouse $canvas current] eq ""} then {
if {[$canvas find withtag selRect] eq ""} then {
$canvas create rectangle 10 10 100 100\
-dash "_ " -tags selRect
}
$canvas coords selRect "[dict get $canvasMouse $canvas selStart] $x1 $y1"
}
} ::canvasEditorBindings
} %W %x %y
}
bind $canvas <ButtonRelease> {
apply {
canvas {
if {[$canvas find withtag selRect] ne ""} then {
# $canvas dtag all sel
# $canvas addtag sel enclosed {*}[$canvas coords selRect]
canvasSelect $canvas enclosed {*}[$canvas coords selRect]
$canvas delete selRect
}
} ::canvasEditorBindings
} %W
}
} else {
bind $canvas <1> ""
bind $canvas <B1-Motion> ""
bind $canvas <ButtonRelease> ""
}
}
proc ::canvasEditorBindings::canvasSelect {canvas tagOrItem args} {
if {$args ne ""} then {
$canvas addtag sel $tagOrItem {*}$args
} else {
$canvas addtag sel withtag $tagOrItem
}
foreach item [$canvas find withtag sel] {
$canvas itemconfigure $item -stipple gray50
# if {[$canvas type $item] ne "line"} then
catch {
$canvas itemconfigure $item -outlinestipple gray50
}
}
}
proc ::canvasEditorBindings::canvasUnselect {canvas tagOrItem} {
$canvas itemconfigure $tagOrItem -stipple {}
foreach item [$canvas find withtag $tagOrItem] {
# if {[$canvas type $item] ni {line}} then
catch {
$canvas itemconfigure $item -outlinestipple {}
}
}
$canvas dtag $tagOrItem sel
}
proc ::canvasEditorBindings::createContextMenu canvas {
set colors {white black red green blue yellow}
destroy $canvas.context
menu $canvas.context -tearoff no
#
$canvas.context add cascade -label Edit\
-menu [menu $canvas.context.edit -tearoff no]
$canvas.context.edit add command -label Coordinates\
-command "canvasEditorBindings::canvasEditItemCoords $canvas current"
#
$canvas.context.edit add cascade -label Fill\
-menu [menu $canvas.context.edit.fill -tearoff no]
foreach color $colors {
$canvas.context.edit.fill add command -label [string totitle $color] -command "
$canvas itemconfigure current -fill $color
"
}
$canvas.context.edit.fill add command -label Transparent -command [list apply {
canvas {
$canvas itemconfigure current -fill ""
}
} $canvas]
$canvas.context.edit.fill add separator
$canvas.context.edit.fill add command -label Choose -command [list apply {
{canvas item} {
set currentColor [$canvas itemcget $item -fill]
if {$currentColor ne ""} then {
set newColor [tk_chooseColor -initialcolor $currentColor]
} else {
set newColor [tk_chooseColor]
}
if {$newColor ne ""} then {
$canvas itemconfigure $item -fill $newColor
}
}
} $canvas current]
#
$canvas.context.edit add cascade -label Outline\
-menu [menu $canvas.context.edit.outline -tearoff no]
foreach color $colors {
$canvas.context.edit.outline add command -label [string totitle $color]\
-command "catch {[subst -nocommand {
if {[$canvas type current] eq {line}} then {
$canvas itemconfigure current -fill $color
} else {
$canvas itemconfigure current -outline $color
}
}]}"
}
$canvas.context.edit.outline add command -label Transparent -command "catch {
$canvas itemconfigure current -outline {}
}"
$canvas.context.edit.outline add separator
$canvas.context.edit.outline add command -label Choose -command [list apply {
{canvas item} {
if {[$canvas type $item] eq "line"} then {
set outline -fill
} else {
set outline -outline
}
set currentColor [$canvas itemcget $item $outline]
if {$currentColor ne ""} then {
set newColor [tk_chooseColor -initialcolor $currentColor]
} else {
set newColor [tk_chooseColor]
}
if {$newColor ne ""} then {
$canvas itemconfigure $item $outline $newColor
}
}
} $canvas current]
#
$canvas.context.edit add cascade -label Linewidth\
-menu [menu $canvas.context.edit.width -tearoff no]
for {set i 0} {$i <= 10} {incr i} {
$canvas.context.edit.width add command -label $i\
-command "$canvas itemconfigure current -width $i"
}
#
$canvas.context.edit add cascade -label Joinstyle\
-menu [menu $canvas.context.edit.joinstyle -tearoff no]
foreach style {bevel miter round} {
$canvas.context.edit.joinstyle add command -label [string totitle $style]\
-command "catch {
$canvas itemconfigure current -joinstyle $style
}"
}
#
$canvas.context.edit add cascade -label Capstyle\
-menu [menu $canvas.context.edit.capstyle -tearoff no]
foreach style {butt round projecting} {
$canvas.context.edit.capstyle add command -label [string totitle $style]\
-command "catch {
$canvas itemconfigure current -capstyle $style
}"
}
#
$canvas.context add cascade -label Create\
-menu [menu $canvas.context.create -tearoff no]
$canvas.context.create add command -label Line\
-command "::canvasEditorBindings::canvasCreate $canvas line"
$canvas.context.create add command -label Rectangle\
-command "::canvasEditorBindings::canvasCreate $canvas rectangle"
$canvas.context.create add command -label Oval\
-command "::canvasEditorBindings::canvasCreate $canvas oval"
$canvas.context.create add command -label Polygon\
-command "::canvasEditorBindings::canvasCreate $canvas polygon"
#
$canvas.context add separator
$canvas.context add command -label Raise -command "$canvas raise current"
$canvas.context add command -label Lower -command "$canvas lower current"
$canvas.context add command -label Delete -command "$canvas delete current"
}
proc ::canvasEditorBindings::canvasBindingsSelect {canvas {onOff on}} {
if {$onOff} then {
bind $canvas <3> {
apply {
{canvas x y} {
if {[$canvas find withtag current] eq ""} then {
tk_popup $canvas.context.create $x $y
} else {
tk_popup $canvas.context $x $y
}
} ::canvasEditorBindings
} %W %X %Y
}
$canvas bind sel <Button-1><B1-Motion> {
apply {
canvas {
variable canvasMouse
$canvas move sel {*}[dict get $canvasMouse $canvas motion]
} ::canvasEditorBindings
} %W
}
$canvas bind current <Button-1> {
apply {
canvas {
variable canvasMouse
if {[dict get $canvasMouse $canvas action] eq "press"} then {
# $canvas dtag all sel
canvasUnselect $canvas all
}
# $canvas addtag sel withtag current
canvasSelect $canvas current
} ::canvasEditorBindings
} %W
}
$canvas bind current <Shift-1> {
apply {
canvas {
variable canvasMouse
# %W addtag sel withtag current
if {"sel" in [$canvas gettags current]} then {
canvasUnselect $canvas current
} else {
canvasSelect $canvas current
}
} ::canvasEditorBindings
} %W
}
} else {
bind $canvas <3> ""
$canvas bind sel <Button-1><B1-Motion> ""
$canvas bind current <Button-1> ""
$canvas bind current <Shift-1> ""
}
}
proc ::canvasEditorBindings::canvasCreate {canvas {line line}} {
variable canvasMouse
canvasBindings $canvas off
canvasBindingsSelect $canvas off
# $canvas dtag all sel
canvasUnselect $canvas all
bind $canvas <Button-1> [list apply {
{canvas line x y} {
variable canvasMouse
dict set canvasMouse $canvas selStart "[$canvas canvasx $x] [$canvas canvasy $y]"
$canvas create $line\
"[$canvas canvasx $x] [$canvas canvasy $y]\
[$canvas canvasx $x] [$canvas canvasy $y]"\
-width 5 -tags sel
if {$line in {polygon oval rectangle arc}} then {
$canvas itemconfigure sel -outline black -fill white
}
} ::canvasEditorBindings
} %W $line %x %y]
bind $canvas <B1-Motion> [list apply {
{canvas x y} {
variable canvasMouse
$canvas coords sel {*}[dict get $canvasMouse $canvas selStart]\
[$canvas canvasx $x] [$canvas canvasy $y]
} ::canvasEditorBindings
} %W %x %y]
bind $canvas <B1-Motion><ButtonRelease> [list apply {
canvas {
bind $canvas <1> ""
bind $canvas <B1-Motion> ""
bind $canvas <B1-Motion><ButtonRelease> ""
canvasEditItemCoords $canvas sel on
if {[$canvas type sel] in {polygon}} then {
addCoord $canvas sel 0
}
} ::canvasEditorBindings
} %W]
}
proc ::canvasEditorBindings::canvasEditItemCoords {canvas item {onOff on}} {
if {$onOff} then {
#
destroy $canvas.context.handle
menu $canvas.context.handle -tearoff no
#
set item [$canvas find withtag $item]
canvasUnselect $canvas all
canvasSelect $canvas $item
canvasBindings $canvas off
canvasBindingsSelect $canvas off
set i -1
foreach {x y} [$canvas coords $item] {
createCoordHandle $canvas $item [incr i]
}
#
destroy $canvas.context.done
menu $canvas.context.done -tearoff no
$canvas.context.done add command -label done\
-command "::canvasEditorBindings::canvasEditItemCoords $canvas $item off"
bind $canvas <3> [subst -nocommand {
if {[$canvas find withtag current&&handle] eq ""} then {
tk_popup $canvas.context.done %X %Y
}
}]
} else {
bind $canvas <3> ""
destroy $canvas.context.done
$canvas delete handle
canvasBindings $canvas on
canvasBindingsSelect $canvas on
}
}
proc ::canvasEditorBindings::createCoordHandle {canvas item count} {
set i [* $count 2]
set j [+ $i 1]
set coords [$canvas coords $item]
set x [lindex $coords $i]
set y [lindex $coords $j]
set handle [$canvas create oval [list [- $x 5] [- $y 5] [+ $x 5] [+ $y 5]]\
-fill white -outline black -tags handle]
$canvas bind $handle <Button-1> [subst -nocommand {
%W delete handle
bind $canvas <Button-1><B1-Motion> {
$canvas coords $item\
[lreplace [$canvas coords $item] $i $j\
[$canvas canvasx %%x] [$canvas canvasy %%y]]
}
bind $canvas <ButtonRelease> {
bind $canvas <Button-1><B1-Motion> ""
bind $canvas <ButtonRelease> ""
::canvasEditorBindings::canvasEditItemCoords $canvas $item on
}
}]
if {[$canvas type $item] in {line polygon}} then {
$canvas.context.handle add cascade -label $count\
-menu [menu $canvas.context.handle.$count -tearoff no]
$canvas.context.handle.$count add command -label Add\
-command "::canvasEditorBindings::addCoord $canvas $item $count"
$canvas.context.handle.$count add command -label Delete\
-command "::canvasEditorBindings::delCoord $canvas $item $count"
$canvas.context.handle.$count add separator
$canvas.context.handle.$count add command -label Linear\
-command "$canvas itemconfigure $item -smooth false"
$canvas.context.handle.$count add command -label Spline\
-command "$canvas itemconfigure $item -smooth true"
$canvas.context.handle.$count add command -label Bézier\
-command "$canvas itemconfigure $item -smooth raw"
$canvas bind $handle <Button-3> "
tk_popup $canvas.context.handle.$count %X %Y
"
}
}
proc ::canvasEditorBindings::addCoord {canvas item count} {
canvasEditItemCoords $canvas $item off
set coords [$canvas coords $item]
if {($count+1) * 2 < [llength $coords]} then {
set li [lrange $coords [* $count 2] [+ [* $count 2] 3]]
} else {
lappend li\
[lindex $coords end-1] [lindex $coords end] [lindex $coords 0] [lindex $coords 1]
}
lassign $li x0 y0 x1 y1
set x [/ [+ $x0 $x1] 2]
set y [/ [+ $y0 $y1] 2]
if {($count+1) * 2 < [llength $coords]} then {
set newCoords [lreplace $coords [* [+ $count 1] 2] [- [* [+ $count 1] 2] 1] $x $y]
} else {
set newCoords [concat $coords $x $y]
}
$canvas coords $item $newCoords
canvasEditItemCoords $canvas $item on
}
proc ::canvasEditorBindings::delCoord {canvas item count} {
set type [$canvas type $item]
if {$type ni {line polygon}} then return
set coords [$canvas coords $item]
if {$type eq "line" && [llength $coords] <= 4} then return
if {$type eq "polygon" && [llength $coords] <= 6} then return
#
canvasEditItemCoords $canvas $item off
$canvas coords $item [lreplace $coords [* $count 2] [+ [* $count 2] 1]]
canvasEditItemCoords $canvas $item on
}