if false {wdb: For my cartoon project, I need some output for graphics ideas. I found out that ImageMagick provides a pretty command-line vector graphics system. So, I wrote this quick'n'dirty routine to freeze current canvas state in an ImageMagick vector file.
Usage:
% canvas2mvg .c viewbox 0 0 342 240 stroke none fill #ffffff rectangle 0 0 342 240 stroke-width 10.0 fill #ffff00 stroke #0000ff stroke-linejoin miter # polygon ... current path 'M 165.0 65.0 L 120.0 20.0 120.0 110.0 210.0 110.0 165.0 65.0 Z' %
Write it to a file named image.mvg, then check it with display image.mvg or convert it to any format, e.g. convert image.mvg image.png.
Supported: line, polygon, rectangle, oval, image (photo), arc.
Restricted support: text. See comments in procedure body below.
Not supported: window.
License: OLL. Have fun!
Attention: copy&paste in browser window is dangerous because render reformatter of source code has "optimized" some line breaks. It is preferable to copy&paste from edit mode!
}
proc canvas2mvg canvas {
set col2hex {color {
if {winfo exists $color && winfo class $color eq "Canvas"} then {
set color $color cget -bg
}
if {$color eq ""} then {
set result none
} else {
set result #
foreach x winfo rgb . $color {
append result [format %02x [expr {int($x / 256)}]
}
}
set result
}}
set splinecoords2mvg {{coords {canBeClosed yes}} {
set closed [expr {$canBeClosed &&
lindex $coords 0 == lindex $coords end-1 &&
lindex $coords 1 == lindex $coords end}]
if {$closed} then {
lassign lrange $coords end-3 end x0 y0 x1 y1
set x expr {($x0+$x1)/2.0}
set y expr {($y0+$y1)/2.0}
lset coords end-1 $x
lset coords end $y
set coords concat $x $y $coords
}
if {llength $coords == 6} then {
lreplace $coords 2 1 Q
} else {
lappend result {*}lrange $coords 0 1
set co1 lrange $coords 2 end-4
set co2 lrange $coords 4 end-2
foreach {x1 y1} $co1 {x2 y2} $co2 {
lappend result $x1 $y1 expr {($x1+$x2)/2.0} expr {($y1+$y2)/2.0}
}
lappend result {*}lrange $coords end-3 end
lreplace $result 2 1 Q
}
}}
array set mode {fill ""
stroke ""
strokewidth ""
joinstyle ""
capstyle ""
fontfamily ""
fontsize ""}
lappend result list viewbox 0 0 [winfo width $canvas [winfo height $canvas]\
list stroke none\
[list fill [apply $col2hex $canvas]\
list rectangle 0 0 [winfo width $canvas [winfo height $canvas]
foreach item $canvas find all {
set type $canvas type $item
lappend result "# $type ... $canvas gettags $item"
# outline width
if {$type in {polygon oval arc rectangle line}} then {
set width $canvas itemcget $item -width
if {$width != $mode(strokewidth)} then {
set mode(strokewidth) $width
lappend result list stroke-width $width
}
}
# fill, stroke
if {$type in {polygon oval arc rectangle}} then {
set fill [apply $col2hex [$canvas itemcget $item -fill]
if {$mode(fill) ne $fill} then {
set mode(fill) $fill
lappend result list fill $fill
}
set stroke [apply $col2hex [$canvas itemcget $item -outline]
if {$mode(stroke) ne $stroke} then {
set mode(stroke) $stroke
lappend result list stroke $stroke
}
}
# joinstyle
if {$type in {polygon line}} then {
set joinstyle $canvas itemcget $item -joinstyle
if {$mode(joinstyle) ne $joinstyle} then {
set mode(joinstyle) $joinstyle
lappend result list stroke-linejoin $joinstyle
}
}
# line color, capstyle
if {$type in {line}} then {
if {$mode(fill) ne "none"} then {
set mode(fill) none
lappend result list fill none
}
set stroke [apply $col2hex [$canvas itemcget $item -fill]
if {$mode(stroke) ne $stroke} then {
set mode(stroke) $stroke
lappend result list stroke $stroke
}
set capstyle [dict get {butt butt
projecting square
round round} [$canvas itemcget $item -capstyle]
if {$mode(capstyle) ne $capstyle} then {
set mode(capstyle) $capstyle
lappend result list stroke-linecap $capstyle
}
}
# text color, font, size
if {$type in {text}} then {
if {$mode(stroke) ne "none"} then {
set mode(stroke) none
lappend result list stroke none
}
set fill [apply $col2hex [$canvas itemcget $item -fill]
if {$mode(fill) ne $fill} then {
set mode(fill) $fill
lappend result list fill $fill
}
set font $canvas itemcget $item -font
# font-family, font-size
if {$font in font names} then {
set fontsize font configure $font -size
set fontfamily font configure $font -family
} else {
if {llength $font == 1} then {
set fontsize 12
} else {
set fontsize lindex $font 1
}
set fontfamily lindex $font 0
}
if {$fontsize < 0} then {
set fontsize expr {int(-$fontsize / [tk scaling)}]
}
if {$mode(fontsize) ne $fontsize} then {
set mode(fontsize) $fontsize
lappend result list font-size $fontsize
}
#
# Attention! In some cases, IM assumes 72dpi,
# where 90dpi is necessary.
# Then, on cmd line, use switch -density as follows:
# convert -density 90 test.mvg test.png
#
if {$mode(fontfamily) ne $fontfamily} then {
set mode(fontfamily) $fontfamily
lappend result list font $fontfamily
}
#
# Attention! Care that IM has access to fonts.
# If not, an error msg is shown,
# then the default font is used silently.
#
}
set line {}
set coords $canvas coords $item
switch -exact -- $type {
line {
# start of path
lappend line path 'M
set smooth $canvas itemcget $item -smooth
if {string is true -strict $smooth} then {
if {$canvas itemcget $item -arrow eq "none"} then {
lappend line {*}apply $splinecoords2mvg $coords
} else {
lappend line {*}apply $splinecoords2mvg $coords false
}
} elseif {string is false -strict $smooth} then {
lappend line {*}lrange $coords 0 1 L {*}lrange $coords 2 end
} else {
lappend line {*}lrange $coords 0 1 C {*}lrange $coords 2 end
}
append line '
#
# Workaround for bug at ImageMagick
# with open line and joinstyle round.
#
# If bug is fixed by IM team,
# replace by this line:
# lappend result $line
#
if {$mode(joinstyle) ne "round" ||
(lindex $coords 0 == lindex $coords end-1 &&
lindex $coords 1 == lindex $coords end &&
$canvas itemcget $item -arrow eq "none")} then {
lappend result $line
} else {
# first store graphics settings
lappend result list push graphic-context
# then switch linejoin
lappend result list stroke-linejoin bevel
# now, line is not closed:
lappend result $line
lappend result list stroke none list fill $mode(stroke)
set r expr {$mode(strokewidth) / 2.0}
# finally add "round" join elements.
if {string is false -strict $smooth} then {
# -smooth no
foreach {x y} lrange $coords 2 end-2 {
lappend result list ellipse $x $y $r $r 0 360
}
} elseif {string is true -strict $smooth} then {
# -smooth yes
foreach\
{x0 y0} lrange $coords 2 end-4\
{x1 y1} lrange $coords 4 end-2 {
lappend result [list ellipse\
expr {($x0+$x1)/2.0}\
expr {($y0+$y1)/2.0}\
$r $r 0 360]
}
} else {
# -smooth raw
foreach {- - - - x y} lrange $coords 2 end-6 {
lappend result list ellipse $x $y $r $r 0 360
}
}
# restore graphics settings
lappend result list pop graphic-context
}
}
polygon {
lappend line path 'M
set smooth $canvas itemcget $item -smooth
if {string is false -strict $smooth} then {
lassign $coords x0 y0
lassign lrange $coords end-1 end x1 y1
set x expr {($x0+$x1)/2.0}
set y expr {($y0+$y1)/2.0}
lappend line $x $y L {*}$coords $x $y Z
} elseif {string is true -strict $smooth} then {
if {lindex $coords 0 != lindex $coords end-1 ||
lindex $coords 1 != lindex $coords end} then {
lappend coords {*}lrange $coords 0 1
}
lappend line {*}apply $splinecoords2mvg $coords
} else {
lappend line {*}lrange $coords 0 1 C {*}lrange $coords 2 end
}
append line '
lappend result $line
}
oval {
lassign $coords x0 y0 x1 y1
lappend line ellipse expr {($x0+$x1)/2.0} expr {($y0+$y1)/2.0}\
expr {$x1-($x0+$x1)/2.0} expr {$y1-($y0+$y1)/2.0} 0 360
lappend result $line
}
arc {
lappend result list push graphic-context
lappend result list stroke-linejoin miter
# lappend result list stroke-linejoin bevel
# lappend result list stroke-linejoin round
lappend line path 'M
lassign $coords x0 y0 x1 y1
set rx expr {($x1-$x0)/2.0}
set ry expr {($y1-$y0)/2.0}
set x expr {($x0+$x1)/2.0}
set y expr {($y0+$y1)/2.0}
set f expr {acos(0)/90}
set start $canvas itemcget $item -start
set startx expr {cos($start*$f)*$rx+$x}
set starty expr {sin(-$start*$f)*$ry+$y}
set angle expr {$start+[$canvas itemcget $item -extent}]
set endx expr {cos($angle*$f)*$rx+$x}
set endy expr {sin(-$angle*$f)*$ry+$y}
# start point
lappend line\
expr {($startx+$x)/2.0} expr {($starty+$y)/2.0}\
$startx $starty
lappend line A
# radiusx, radiusy
lappend line $rx $ry
# angle -- always 0
lappend line 0
# "big" or "small"?
lappend line expr {$angle-$start > 180}
# right side (always)
lappend line 0
# end point
lappend line $endx $endy
# close path
lappend line L $x $y Z
append line '
lappend result $line
lappend result list pop graphic-context
}
rectangle {
lappend result\
list push graphic-context\
list stroke-linejoin miter\
concat rectangle $coords\
list pop graphic-context
}
text {
lassign $canvas bbox $item x0 y0 x1 y1
lappend line text $x0 $y1
append line " '$canvas itemcget $item -text'"
lappend result $line
}
image - bitmap {
set img $canvas itemcget $item -image
set file $img cget -file
lassign $canvas bbox $item x0 y0
lappend result list image over $x0 $y0 0 0 '$file'
}
default {
lappend result\
"# not yet done:\
$canvas type $item $canvas coords $item ($canvas gettags $item)"
}
}
}
join $result \n
}
AK - 2010-08-23 18:06:30
How difficult would it be to implement arc and label support ?
I am asking because these two are the only pieces missing (I believe) to make this code a viable backend for the dia application based on the tklib diagram package derived from Drawing diagrams. The application currently uses the canvas::snap package derived from Canvas2Image to convert to tk photo and then the raster formats supported by Img.
wdb: arc -- done (had some mental blocks of drawing model at ImageMagick).
wdb: text -- works with these restrictions:
Attention: copy&paste in browser window is dangerous because render reformatter of source code has "optimized" some line breaks. It is preferable to copy&paste from edit mode!
From my point of view, all necessary is done. If necessary, feel free to extend to your needs. (But don't forget to comment your improvements!) I hope that my code is readable.
wdb (later): Currently, there is a bug in IM (just discovered): line objects where stroke-joinstyle is set to round are unwantedly always closed. Only work-around: avoid stroke-joinstyle round. Just have reported in IM forum; hopefully it will be fixed soon.
Btw -- Why did'nt I do all that with the canvas postscript sub-command? I found that the width of lines drawn with option -smooth raw were really crazy, and I was not willed to wait until this bug is recognized and fixed. Additionally, text in resulting postscript was head-under such that I preferred to write sth myself.
AK - 2010-08-30 11:36:23
Just a quick note, the tklib modules/canvas directory now contains a package canvas::mvg which is derived from the code on this page. Currently only in CVS. It requires Tcl 8.5, using {*}-operator, lassign, and other such stuff. Cleaned the internals a bit.
wdb added workaround for IM bug: open line elements with joinstyle round aren't unwantedly closed anymore.