1# *- tcl -*- 2# ### ### ### ######### ######### ######### 3 4# Copyright (c) 2010 Wolf-Dieter Busch 5# Origin http://wiki.tcl.tk/26859 [23-08-2010] 6# OLL licensed (http://wiki.tcl.tk/10892). 7 8# ### ### ### ######### ######### ######### 9## Requisites 10 11package require Tcl 8.5 12package require Tk 8.5 13 14namespace eval ::canvas {} 15 16# ### ### ### ######### ######### ######### 17## Implementation. 18 19proc ::canvas::mvg {canvas} { 20 21 #raise [winfo toplevel $canvas] 22 #update 23 24 # Initialize drawing state... This array is keyed by the MVG 25 # commands for the attribute, not by the canvas options, and not 26 # by something third. 27 array set mode { 28 fill {} 29 stroke {} 30 stroke-width {} 31 stroke-linejoin {} 32 stroke-linecap {} 33 font {} 34 font-size {} 35 } 36 37 # Get the bounding box of all item, and compute the translation 38 # required to put the lower-left corner at the origin. 39 set dx 0 40 set dy 0 41 set box [$canvas bbox {*}[$canvas find all]] 42 lassign $box zx zy ex ey 43 if {$zx < 0} { set dx [expr {- $zx}] ; set ex [expr {$ex + $dx}] } 44 if {$zy < 0} { set dy [expr {- $zy}] ; set ey [expr {$ey + $dy}] } 45 set box [list 0 0 $ex $ey] 46 47 # Standard prelude... 48 mvg::Emit [list viewbox {*}$box] 49 mvg::EmitChanged stroke none 50 mvg::EmitChanged fill [mvg::Col2Hex $canvas] 51 mvg::Emit [list rectangle {*}$box] 52 53 # Introspect the canvas, i.e. convert each item to MVG 54 foreach item [$canvas find all] { 55 set type [$canvas type $item] 56 57 # Info to help debugging... 58 mvg::Emit "# $type ... [$canvas gettags $item]" 59 60 # Dump the item's attributes, as they are supported by it. 61 # Note how the code is not sliced by item type which then 62 # handles each of its attributes, but by attribute name, which 63 # then checks if the type of the current item supports it. 64 65 # Further note that the current attribute state is stored in 66 # the mode array and actually emitted if and only if it is 67 # different from the previously drawn state. This optimizes 68 # the number of commands needed to set the drawing state for a 69 # particular item. 70 71 # outline width 72 if {$type in {polygon oval arc rectangle line}} then { 73 mvg::EmitValue $item -width stroke-width 74 } 75 76 # fill, stroke 77 if {$type in {polygon oval arc rectangle}} { 78 mvg::EmitColor $item -fill fill 79 mvg::EmitColor $item -outline stroke 80 } 81 82 # joinstyle 83 if {$type in {polygon}} then { 84 mvg::EmitValue $item -joinstyle stroke-linejoin 85 } 86 87 # line color, capstyle 88 if {$type in {line}} then { 89 mvg::EmitChanged fill none 90 mvg::EmitColor $item -fill stroke 91 mvg::EmitCap $item -capstyle stroke-linecap 92 } 93 94 # text color, font, size 95 if {$type in {text}} then { 96 # Compute font-family, font-size 97 set font [$canvas itemcget $item -font] 98 if {$font in [font names]} { 99 set fontsize [font configure $font -size] 100 set fontfamily [font configure $font -family] 101 } else { 102 if {[llength $font] == 1} then { 103 set fontsize 12 104 } else { 105 set fontsize [lindex $font 1] 106 } 107 set fontfamily [lindex $font 0] 108 } 109 if {$fontsize < 0} { 110 set fontsize [expr {int(-$fontsize / [tk scaling])}] 111 } 112 113 mvg::EmitChanged stroke none 114 mvg::EmitColor $item -fill fill 115 mvg::EmitChanged font-size $fontsize 116 mvg::EmitChanged font $fontfamily 117 118 # 119 # Attention! In some cases ImageMagick assumes 72dpi where 120 # 90dpi is necessary. If that happens use the switch 121 # -density to force the correct dpi setting, like % 122 # convert -density 90 test.mvg test.png 123 # 124 # Attention! Make sure that ImageMagick has access to the 125 # used fonts. If it has not, an error msg will be shown, 126 # and then switches silently to the default font. 127 # 128 } 129 130 # After the attributes we can emit the command actually 131 # drawing the item, in the its place. 132 133 set line {} 134 set coords [mvg::Translate [$canvas coords $item]] 135 136 switch -exact -- $type { 137 line { 138 # start of path 139 lappend line path 'M 140 141 # smooth can be any boolean value, plus the name of a 142 # line smoothing method. Core supports only 'raw'. 143 # This however is extensible through packages. 144 145 switch -exact -- [mvg::Smooth $item] { 146 0 { 147 lappend line {*}[lrange $coords 0 1] L {*}[lrange $coords 2 end] 148 } 149 1 { 150 if {[$canvas itemcget $item -arrow] eq "none"} { 151 lappend line {*}[mvg::Spline2MVG $coords] 152 } else { 153 lappend line {*}[mvg::Spline2MVG $coords false] 154 } 155 } 156 2 { 157 lappend line {*}[lrange $coords 0 1] C {*}[lrange $coords 2 end] 158 } 159 } 160 161 append line ' 162 mvg::Emit $line 163 } 164 polygon { 165 # start of path. 166 lappend line path 'M 167 168 switch -exact -- [mvg::Smooth $item] { 169 0 { 170 lassign $coords x0 y0 171 lassign [lrange $coords end-1 end] x1 y1 172 set x [expr {($x0+$x1)/2.0}] 173 set y [expr {($y0+$y1)/2.0}] 174 lappend line $x $y L {*}$coords $x $y Z 175 } 176 1 { 177 lassign $coords x0 y0 178 lassign [lrange $coords end-1 end] x1 y1 179 if {($x0 != $x1) || ($y0 != $y1)} { 180 lappend coords {*}[lrange $coords 0 1] 181 } 182 lappend line {*}[mvg::Spline2MVG $coords] 183 } 184 2 { 185 lappend line {*}[lrange $coords 0 1] C {*}[lrange $coords 2 end] 186 } 187 } 188 189 append line ' 190 mvg::Emit $line 191 } 192 oval { 193 lassign $coords x0 y0 x1 y1 194 set xc [expr {($x0+$x1)/2.0}] 195 set yc [expr {($y0+$y1)/2.0}] 196 197 mvg::Emit [list ellipse $xc $yc [expr {$x1-$xc}] [expr {$y1-$yc}] 0 360] 198 } 199 arc { 200 lassign $coords x0 y0 x1 y1 201 202 set rx [expr {($x1-$x0)/2.0}] 203 set ry [expr {($y1-$y0)/2.0}] 204 set x [expr {($x0+$x1)/2.0}] 205 set y [expr {($y0+$y1)/2.0}] 206 set f [expr {acos(0)/90}] 207 208 set start [$canvas itemcget $item -start] 209 set startx [expr {cos($start*$f)*$rx+$x}] 210 set starty [expr {sin(-$start*$f)*$ry+$y}] 211 set angle [expr {$start+[$canvas itemcget $item -extent]}] 212 set endx [expr {cos($angle*$f)*$rx+$x}] 213 set endy [expr {sin(-$angle*$f)*$ry+$y}] 214 215 # start path 216 lappend line path 'M 217 # start point 218 lappend line $startx $starty 219 lappend line A 220 # radiusx, radiusy 221 lappend line $rx $ry 222 # angle -- always 0 223 lappend line 0 224 # "big" or "small"? 225 lappend line [expr {($angle-$start) > 180}] 226 # right side (always) 227 lappend line 0 228 # end point 229 lappend line $endx $endy 230 # close path 231 lappend line L $x $y Z 232 append line ' 233 234 mvg::Emit $line 235 } 236 rectangle { 237 mvg::Emit [list rectangle {*}$coords] 238 } 239 text { 240 lassign [mvg::Translate [$canvas bbox $item]] x0 y0 x1 y1 241 mvg::Emit "text $x0 $y1 '[$canvas itemcget $item -text]'" 242 } 243 image - bitmap { 244 set img [$canvas itemcget $item -image] 245 set file [$img cget -file] 246 lassign [mvg::Translate [$canvas bbox $item]] x0 y0 247 mvg::Emit "image over $x0 $y0 0 0 '$file'" 248 } 249 default { 250 set line "# not yet done:" 251 append line " " [$canvas type $item] 252 append line " " [mvg::Translate [$canvas coords $item]] 253 append line " (" [$canvas gettags $item] ")" 254 mvg::Emit $line 255 } 256 } 257 } 258 259 # At last, return the fully assembled snapshot 260 return [join $result \n] 261} 262 263# ### ### ### ######### ######### ######### 264## Helper commands. Internal. 265 266namespace eval ::canvas::mvg {} 267 268proc ::canvas::mvg::Translate {coords} { 269 upvar 1 dx dx dy dy 270 set tmp {} 271 foreach {x y} $coords { 272 lappend tmp [expr {$x + $dx}] [expr {$y + $dy}] 273 } 274 return $tmp 275} 276 277 278proc ::canvas::mvg::Smooth {item} { 279 upvar 1 canvas canvas 280 281 # Force smooth to canonical values we can then switch on. 282 set smooth [$canvas itemcget $item -smooth] 283 if {[string is boolean $smooth]} { 284 if {$smooth} { 285 return 1 286 } else { 287 return 0 288 } 289 } else { 290 return 2 291 } 292} 293 294proc ::canvas::mvg::EmitValue {item option cmd} { 295 upvar 1 mode mode result result canvas canvas 296 297 EmitChanged $cmd \ 298 [$canvas itemcget $item $option] 299 return 300} 301 302proc ::canvas::mvg::EmitColor {item option cmd} { 303 upvar 1 mode mode result result canvas canvas 304 305 EmitChanged $cmd \ 306 [Col2Hex [$canvas itemcget $item $option]] 307 return 308} 309 310proc ::canvas::mvg::EmitCap {item option cmd} { 311 upvar 1 mode mode result result canvas canvas 312 313 EmitChanged $cmd \ 314 [dict get { 315 butt butt 316 projecting square 317 round round 318 } [$canvas itemcget $item $option]] 319 return 320} 321 322proc ::canvas::mvg::EmitChanged {cmd value} { 323 upvar 1 mode mode result result 324 325 if {$mode($cmd) eq $value} return 326 set mode($cmd) $value 327 Emit [list $cmd $value] 328 return 329} 330 331proc ::canvas::mvg::Emit {command} { 332 upvar 1 result result 333 lappend result $command 334 return 335} 336 337proc ::canvas::mvg::Col2Hex {color} { 338 # This command or similar functionality we might have somewhere 339 # in tklib already ... 340 341 # Special handling of canvas widgets, use their background color. 342 if {[winfo exists $color] && [winfo class $color] eq "Canvas"} { 343 set color [$color cget -bg] 344 } 345 if {$color eq ""} { 346 return none 347 } 348 set result # 349 foreach x [winfo rgb . $color] { 350 append result [format %02x [expr {int($x / 256)}]] 351 } 352 return $result 353} 354 355proc ::canvas::mvg::Spline2MVG {coords {canBeClosed yes}} { 356 set closed [expr {$canBeClosed && 357 [lindex $coords 0] == [lindex $coords end-1] && 358 [lindex $coords 1] == [lindex $coords end]}] 359 360 if {$closed} { 361 lassign [lrange $coords end-3 end] x0 y0 x1 y1 362 363 set x [expr {($x0+$x1)/2.0}] 364 set y [expr {($y0+$y1)/2.0}] 365 366 lset coords end-1 $x 367 lset coords end $y 368 369 set coords [linsert $coords 0 $x $y] 370 } 371 372 if {[llength $coords] != 6} { 373 lappend tmp {*}[lrange $coords 0 1] 374 375 set co1 [lrange $coords 2 end-4] 376 set co2 [lrange $coords 4 end-2] 377 378 foreach {x1 y1} $co1 {x2 y2} $co2 { 379 lappend tmp $x1 $y1 [expr {($x1+$x2)/2.0}] [expr {($y1+$y2)/2.0}] 380 } 381 lappend tmp {*}[lrange $coords end-3 end] 382 set coords $tmp 383 } 384 385 return [lreplace $coords 2 1 Q] 386} 387 388# ### ### ### ######### ######### ######### 389## Ready 390 391package provide canvas::mvg 1 392return 393