| What | svg2can.tcl |
| Description | Package from the coccinella application. Provides translation from XML/SVG format to canvas commands. For example go to the bottom of the page. |
| Where | svg2can.tcl |
| Requires | uriencode.tcl |
| Updated | 24.02.2010 |
# svg2can.tcl ---
#
# This file provides translation from canvas commands to XML/SVG format.
#
# Copyright (c) 2004-2007 Mats Bengtsson
#
# This file is distributed under BSD style license.
#
# $Id: svg2can.tcl,v 1.42 2008-02-06 13:57:24 matben Exp $
#
# ########################### USAGE ############################################
#
# NAME
# svg2can - translate XML/SVG to canvas command.
#
# SYNOPSIS
# svg2can::parsesvgdocument xmllist
# svg2can::parseelement xmllist
#
#
# ########################### CHANGES ##########################################
#
# 0.1 first release
# 0.2 starting support for tkpath package
#
# ########################### TODO #############################################
#
# A lot...
#
# ########################### INTERNALS ########################################
#
# The whole parse tree is stored as a hierarchy of lists as:
#
# xmllist = {tag attrlist isempty cdata {child1 child2 ...}}
# We need URN decoding for the file path in images. From my whiteboard code.
package require uriencode
package provide svg2can 1.0
namespace eval svg2can {
variable confopts
array set confopts {
-foreignobjecthandler ""
-httphandler ""
-imagehandler ""
-imagehandlerex ""
}
variable textAnchorMap
array set textAnchorMap {
start w
middle c
end e
}
variable fontWeightMap
array set fontWeightMap {
normal normal
bold bold
bolder bold
lighter normal
100 normal
200 normal
300 normal
400 normal
500 normal
600 bold
700 bold
800 bold
900 bold
}
# We need to have a temporary tag for doing transformations.
variable tmptag _tmp_transform
variable pi 3.14159265359
variable degrees2Radians [expr {2*$pi/360.0}]
variable systemFont
switch -- $::tcl_platform(platform) {
unix {
set systemFont {Helvetica 10}
if {[package vcompare [info tclversion] 8.3] == 1} {
if {[string equal [tk windowingsystem] "aqua"]} {
set systemFont system
}
}
}
windows {
set systemFont system
}
}
variable priv
set priv(havetkpath) 0
if {![catch {package require tkpath 0.2.8}]} {
set priv(havetkpath) 1
}
# We don't want it now.
set priv(havetkpath) 0
variable chache
variable cache_key ""
}
# svg2can::config --
#
# Processes the configuration options.
proc svg2can::config {args} {
variable confopts
set options [lsort [array names confopts -*]]
set usage [join $options ", "]
if {[llength $args] == 0} {
set result {}
foreach name $options {
lappend result $name $confopts($name)
}
return $result
}
regsub -all -- - $options {} options
set pat ^-([join $options |])$
if {[llength $args] == 1} {
set flag [lindex $args 0]
if {[regexp -- $pat $flag]} {
return $confopts($flag)
} else {
return -code error "Unknown option $flag, must be: $usage"
}
} else {
foreach {flag value} $args {
if {[regexp -- $pat $flag]} {
set confopts($flag) $value
} else {
return -code error "Unknown option $flag, must be: $usage"
}
}
}
}
# svg2can::cache_* --
#
# A few routines to handle the caching of images and gradients.
# Useful for garbage collection. Cache stuff per key which is typically
# a widget path, and then do:
# svg2can::cache_set_key $w
# bind $w <Destroy> +[list svg2can::cache_free $w]
# This works only if parsing svg docs in one shot.
proc svg2can::cache_set_key {key} {
variable cache_key
set cache_key $key
}
proc svg2can::cache_get_key {} {
variable cache_key
return $cache_key
}
proc svg2can::cache_get {$key} {
variable cache
if {[info exists cache($key)]} {
return $cache($key)
} else {
return [list]
}
}
proc svg2can::cache_add {type token} {
variable cache
variable cache_key
lappend cache($cache_key) [list $type $token]
}
proc svg2can::cache_free {key} {
variable cache
if {![info exists cache($key)]} {
return
}
foreach spec $cache($key) {
set type [lindex $spec 0]
set token [lindex $spec 1]
switch -- $type {
image {
image delete $token
}
gradient {
::tkpath::gradient delete $token
}
}
}
set cache($key) [list]
}
proc svg2can::cache_reset {key} {
variable cache
set cache($key) [list]
}
# svg2can::parsesvgdocument --
#
#
# Arguments:
# xmllist the parsed document as a xml list
# args configuration options
# -httphandler
# -imagehandler
#
# Results:
# a list of canvas commands without the widgetPath
proc svg2can::parsesvgdocument {xmllist args} {
variable confopts
variable priv
array set argsA [array get confopts]
array set argsA $args
set paropts [array get argsA]
set ans {}
foreach c [getchildren $xmllist] {
if {$priv(havetkpath)} {
set ans [concat $ans [ParseElemRecursiveEx $c $paropts {}]]
} else {
set ans [concat $ans [ParseElemRecursive $c $paropts {}]]
}
}
return $ans
}
# svg2can::parseelement --
#
# External interface for parsing a single element.
#
# Arguments:
# xmllist the elements xml list
# args configuration options
# -httphandler
# -imagehandler
# -imagehandlerex
#
# Results:
# a list of canvas commands without the widgetPath
proc svg2can::parseelement {xmllist args} {
variable confopts
variable priv
array set argsA [array get confopts]
array set argsA $args
set paropts [array get argsA]
if {$priv(havetkpath)} {
return [ParseElemRecursiveEx $xmllist $paropts {}]
} else {
return [ParseElemRecursive $xmllist $paropts {}]
}
}
# svg2can::ParseElemRecursive --
#
# Parses element for internal usage.
#
# Arguments:
# xmllist the elements xml list
# paropts parse options
# transformL
# args list of attributes from any enclosing element (g).
#
# Results:
# a list of canvas commands without the widgetPath
proc svg2can::ParseElemRecursive {xmllist paropts transformL args} {
set cmdList [list]
set tag [gettag $xmllist]
# Handle any transform attribute; may be recursive, so keep a list.
set transformL [concat $transformL [ParseTransformAttr [getattr $xmllist]]]
switch -- $tag {
circle - ellipse - image - line - polyline - polygon - rect - path - text {
set func [string totitle $tag]
set cmdL [eval {Parse${func} $xmllist $paropts $transformL} $args]
set cmdList [concat $cmdList $cmdL]
}
a - g {
# Need to collect the attributes for the g element since
# the child elements inherit them. g elements may be nested!
# Must parse any style to the actual attribute names.
array set attrA $args
array set attrA [getattr $xmllist]
unset -nocomplain attrA(id)
if {[info exists attrA(style)]} {
array set attrA [StyleAttrToList $attrA(style)]
}
foreach c [getchildren $xmllist] {
set cmdList [concat $cmdList [eval {
ParseElemRecursive $c $paropts $transformL
} [array get attrA]]]
}
}
foreignObject {
array set parseArr $paropts
if {[string length $parseArr(-foreignobjecthandler)]} {
set elem [uplevel #0 $parseArr(-foreignobjecthandler) \
[list $xmllist $paropts $transformL] $args]
if {$elem != ""} {
set cmdList [concat $cmdList $elem]
}
}
}
use - defs - marker - symbol {
# todo
}
}
return $cmdList
}
# svg2can::ParseElemRecursiveEx --
#
# Same for tkpath...
#
# Arguments:
# transAttr this is a list of transform attributes
proc svg2can::ParseElemRecursiveEx {xmllist paropts transAttr args} {
set cmdList [list]
set tag [gettag $xmllist]
switch -- $tag {
circle - ellipse - image - line - polyline - polygon - rect - path - text {
set func [string totitle $tag]
set cmd [eval {Parse${func}Ex $xmllist $paropts $transAttr} $args]
if {[llength $cmd]} {
lappend cmdList $cmd
}
}
a - g {
# Need to collect the attributes for the g element since
# the child elements inherit them. g elements may be nested!
# Must parse any style to the actual attribute names.
array set attrA $args
array set attrA [getattr $xmllist]
unset -nocomplain attrA(id)
if {[info exists attrA(style)]} {
array set attrA [StyleAttrToList $attrA(style)]
}
if {[info exists attrA(transform)]} {
eval {lappend transAttr} [TransformAttrToList $attrA(transform)]
unset attrA(transform)
}
foreach c [getchildren $xmllist] {
set cmdList [concat $cmdList [eval {
ParseElemRecursiveEx $c $paropts $transAttr
} [array get attrA]]]
}
}
linearGradient {
CreateLinearGradient $xmllist
}
radialGradient {
CreateRadialGradient $xmllist
}
foreignObject {
array set parseArr $paropts
if {[string length $parseArr(-foreignobjecthandler)]} {
set elem [uplevel #0 $parseArr(-foreignobjecthandler) \
[list $xmllist $paropts $transformL] $args]
if {$elem != ""} {
set cmdList [concat $cmdList $elem]
}
}
}
defs {
eval {ParseDefs $xmllist $paropts $transAttr} $args
}
use - marker - symbol {
# todo
}
}
return $cmdList
}
proc svg2can::ParseDefs {xmllist paropts transAttr args} {
# @@@ Only gradients so far.
foreach c [getchildren $xmllist] {
set tag [gettag $c]
switch -- $tag {
linearGradient {
CreateLinearGradient $c
}
radialGradient {
CreateRadialGradient $c
}
}
}
}
# svg2can::ParseCircle, ParseEllipse, ParseLine, ParseRect, ParsePath,
# ParsePolyline, ParsePolygon, ParseImage --
#
# Makes the necessary canvas commands needed to reproduce the
# svg element.
#
# Arguments:
# xmllist
# paropts parse options
# transformL
# args list of attributes from any enclosing element (g).
#
# Results:
# list of canvas create command without the widgetPath.
proc svg2can::ParseCircle {xmllist paropts transformL args} {
variable tmptag
set opts {}
set presAttr {}
set cx 0
set cy 0
set r 0
array set attrA $args
array set attrA [getattr $xmllist]
# We need to have a temporary tag for doing transformations.
set tags {}
if {[llength $transformL]} {
lappend tags $tmptag
}
foreach {key value} [array get attrA] {
switch -- $key {
cx - cy - r {
set $key [parseLength $value]
}
id {
set tags [concat $tags $value]
}
style {
set opts [StyleToOpts oval [StyleAttrToList $value]]
}
default {
# Valid itemoptions will be sorted out below.
lappend presAttr $key $value
}
}
}
lappend opts -tags $tags
set coords [list [expr {$cx - $r}] [expr {$cy - $r}] \
[expr {$cx + $r}] [expr {$cy + $r}]]
set opts [MergePresentationAttr oval $opts $presAttr]
set cmdList [list [concat create oval $coords $opts]]
return [AddAnyTransformCmds $cmdList $transformL]
}
proc svg2can::ParseCircleEx {xmllist paropts transAttr args} {
set opts {}
set cx 0
set cy 0
set presAttr {}
array set attrA $args
array set attrA [getattr $xmllist]
foreach {key value} [array get attrA] {
switch -- $key {
cx - cy {
set $key [parseLength $value]
}
id {
lappend opts -tags $value
}
style {
eval {lappend opts} [StyleToOptsEx [StyleAttrToList $value]]
}
transform {
eval {lappend transAttr} [TransformAttrToList $value]
}
default {
lappend presAttr $key $value
}
}
}
if {[llength $transAttr]} {
lappend opts -matrix [TransformAttrListToMatrix $transAttr]
}
set opts [StrokeFillDefaults [MergePresentationAttrEx $opts $presAttr]]
return [concat create circle $cx $cy $opts]
}
proc svg2can::ParseEllipse {xmllist paropts transformL args} {
variable tmptag
set opts {}
set presAttr {}
set cx 0
set cy 0
set rx 0
set ry 0
array set attrA $args
array set attrA [getattr $xmllist]
set tags {}
if {[llength $transformL]} {
lappend tags $tmptag
}
foreach {key value} [array get attrA] {
switch -- $key {
cx - cy - rx - ry {
set $key [parseLength $value]
}
id {
set tags [concat $tags $value]
}
style {
set opts [StyleToOpts oval [StyleAttrToList $value]]
}
default {
lappend presAttr $key $value
}
}
}
lappend opts -tags $tags
set coords [list [expr $cx - $rx] [expr $cy - $ry] \
[expr $cx + $rx] [expr $cy + $ry]]
set opts [MergePresentationAttr oval $opts $presAttr]
set cmdList [list [concat create oval $coords $opts]]
return [AddAnyTransformCmds $cmdList $transformL]
}
proc svg2can::ParseEllipseEx {xmllist paropts transAttr args} {
set opts {}
set cx 0
set cy 0
set presAttr {}
array set attrA $args
array set attrA [getattr $xmllist]
foreach {key value} [array get attrA] {
switch -- $key {
cx - cy {
set $key [parseLength $value]
}
id {
lappend opts -tags $value
}
style {
eval {lappend opts} [StyleToOptsEx [StyleAttrToList $value]]
}
transform {
eval {lappend transAttr} [TransformAttrToList $value]
}
default {
lappend presAttr $key $value
}
}
}
if {[llength $transAttr]} {
lappend opts -matrix [TransformAttrListToMatrix $transAttr]
}
set opts [StrokeFillDefaults [MergePresentationAttrEx $opts $presAttr]]
return [concat create ellipse $cx $cy $opts]
}
proc svg2can::ParseImage {xmllist paropts transformL args} {
variable tmptag
set x 0
set y 0
set presAttr {}
set photo {}
array set attrA $args
array set attrA [getattr $xmllist]
array set paroptsA $paropts
set tags {}
if {[llength $transformL]} {
lappend tags $tmptag
}
foreach {key value} [array get attrA] {
switch -- $key {
x - y - height - width {
# The canvas image item does not have width and height.
# These are REQUIRED in SVG.
set $key [parseLength $value]
}
id {
set tags [concat $tags $value]
}
style {
set opts [StyleToOpts image [StyleAttrToList $value]]
}
xlink:href {
set xlinkhref $value
}
default {
lappend presAttr $key $value
}
}
}
lappend opts -tags $tags -anchor nw
set opts [MergePresentationAttr image $opts $presAttr]
if {[string length $paroptsA(-imagehandlerex)]} {
uplevel #0 $paroptsA(-imagehandlerex) [list $xmllist $opts]
return
}
# Handle the xlink:href attribute.
if {[info exists xlinkhref]} {
switch -glob -- $xlinkhref {
file:/* {
set path [::uri::urn::unquote $xlinkhref]
set path [string map {file:/// /} $path]
if {[string length $paroptsA(-imagehandler)]} {
set cmd [concat create image $x $y $opts]
lappend cmd -file $path -height $height -width $width
set photo [uplevel #0 $paroptsA(-imagehandler) [list $cmd]]
lappend opts -image $photo
} else {
if {[string tolower [file extension $path]] eq ".gif"} {
set photo [image create photo -file $path -format gif]
cache_add image $photo
} else {
set photo [image create photo -file $path]
cache_add image $photo
}
lappend opts -image $photo
}
}
http:/* {
if {[string length $paroptsA(-httphandler)]} {
set cmd [concat create image $x $y $opts]
lappend cmd -url $xlinkhref -height $height -width $width
uplevel #0 $paroptsA(-httphandler) [list $cmd]
}
return
}
default {
return
}
}
}
set cmd [concat create image $x $y $opts]
set cmdList [list $cmd]
return [AddAnyTransformCmds $cmdList $transformL]
}
proc svg2can::ParseImageEx {xmllist paropts transAttr args} {
set x 0
set y 0
set width 0
set height 0
set opts {}
set presAttr {}
array set attrA $args
array set attrA [getattr $xmllist]
array set paroptsA $paropts
foreach {key value} [array get attrA] {
switch -- $key {
x - y {
set $key [parseLength $value]
}
height - width {
# A value of 0 disables rendering in SVG.
# tkpath uses 0 for using natural sizes.
if {$value == 0.0} {
return
}
set $key [parseLength $value]
}
id {
lappend opts -tags $value
}
style {
eval {lappend opts} [StyleToOptsEx [StyleAttrToList $value]]
}
transform {
eval {lappend transAttr} [TransformAttrToList $value]
}
xlink:href {
set xlinkhref $value
}
default {
lappend presAttr $key $value
}
}
}
lappend opts -width $width -height $height
if {[llength $transAttr]} {
lappend opts -matrix [TransformAttrListToMatrix $transAttr]
}
if {[string length $paroptsA(-imagehandlerex)]} {
uplevel #0 $paroptsA(-imagehandlerex) [list $xmllist $opts]
return
}
# Handle the xlink:href attribute.
if {[info exists xlinkhref]} {
switch -glob -- $xlinkhref {
file:/* {
set path [::uri::urn::unquote $xlinkhref]
set path [string map {file:/// /} $path]
if {[string length $paroptsA(-imagehandler)]} {
set cmd [concat create image $x $y $opts]
lappend cmd -file $path -height $height -width $width
set photo [uplevel #0 $paroptsA(-imagehandler) [list $cmd]]
lappend opts -image $photo
} else {
if {[string tolower [file extension $path]] eq ".gif"} {
set photo [image create photo -file $path -format gif]
cache_add image $photo
} else {
set photo [image create photo -file $path]
cache_add image $photo
}
lappend opts -image $photo
}
}
http:/* {
if {[string length $paroptsA(-httphandler)]} {
set cmd [concat create image $x $y $opts]
lappend cmd -url $xlinkhref -height $height -width $width
uplevel #0 $paroptsA(-httphandler) [list $cmd]
}
return
}
default {
return
}
}
}
set opts [MergePresentationAttrEx $opts $presAttr]
return [concat create pimage $x $y $opts]
}
proc svg2can::ParseLine {xmllist paropts transformL args} {
variable tmptag
set opts {}
set coords {0 0 0 0}
set presAttr {}
array set attrA $args
array set attrA [getattr $xmllist]
set tags {}
if {[llength $transformL]} {
lappend tags $tmptag
}
foreach {key value} [array get attrA] {
switch -- $key {
id {
set tags [concat $tags $value]
}
style {
set opts [StyleToOpts line [StyleAttrToList $value]]
}
x1 {
lset coords 0 [parseLength $value]
}
y1 {
lset coords 1 [parseLength $value]
}
x2 {
lset coords 2 [parseLength $value]
}
y2 {
lset coords 3 [parseLength $value]
}
default {
lappend presAttr $key $value
}
}
}
lappend opts -tags $tags
set opts [MergePresentationAttr line $opts $presAttr]
set cmdList [list [concat create line $coords $opts]]
return [AddAnyTransformCmds $cmdList $transformL]
}
proc svg2can::ParseLineEx {xmllist paropts transAttr args} {
set x1 0
set y1 0
set x2 0
set y2 0
set opts {}
set presAttr {}
array set attrA $args
array set attrA [getattr $xmllist]
foreach {key value} [array get attrA] {
switch -- $key {
x1 - y1 - x2 - y2 {
set $key [parseLength $value]
}
id {
lappend opts -tags $value
}
style {
eval {lappend opts} [StyleToOptsEx [StyleAttrToList $value]]
}
transform {
eval {lappend transAttr} [TransformAttrToList $value]
}
default {
lappend presAttr $key $value
}
}
}
if {[llength $transAttr]} {
lappend opts -matrix [TransformAttrListToMatrix $transAttr]
}
set opts [StrokeFillDefaults [MergePresentationAttrEx $opts $presAttr] 1]
return [concat create pline $x1 $y1 $x2 $y2 $opts]
}
proc svg2can::ParsePath {xmllist paropts transformL args} {
variable tmptag
set cmdList {}
set opts {}
set presAttr {}
set path {}
set styleList {}
set lineopts {}
set polygonopts {}
array set attrA $args
array set attrA [getattr $xmllist]
set tags {}
if {[llength $transformL]} {
lappend tags $tmptag
}
foreach {key value} [array get attrA] {
switch -- $key {
d {
set path $value
}
id {
set tags [concat $tags $value]
}
style {
# Need to parse separately for each canvas item since different
# default values.
set lineopts [StyleToOpts line [StyleAttrToList $value]]
set polygonopts [StyleToOpts polygon [StyleAttrToList $value]]
}
default {
lappend presAttr $key $value
}
}
}
# The resulting canvas items are typically lines and polygons.
# Since the style parsing is different keep separate copies.
lappend lineopts -tags $tags
lappend polygonopts -tags $tags
set lineopts [MergePresentationAttr line $lineopts $presAttr]
set polygonopts [MergePresentationAttr polygon $polygonopts $presAttr]
# Parse the actual path data.
set co {}
set cantype line
set itemopts {}
regsub -all -- {([a-zA-Z])([0-9])} $path {\1 \2} path
regsub -all -- {([0-9])([a-zA-Z])} $path {\1 \2} path
set path [string map {- " -"} $path]
set path [string map {, " "} $path]
set i 0
set len [llength $path]
set len1 [expr $len - 1]
set len2 [expr $len - 2]
set len4 [expr $len - 4]
set len6 [expr $len - 6]
# 'i' is the index into the path list; points to the command (character).
while {$i < $len} {
set elem [lindex $path $i]
set isabsolute 1
if {[string is lower $elem]} {
set isabsolute 0
}
switch -glob -- $elem {
A - a {
# Not part of Tiny SVG.
incr i
foreach {rx ry phi fa fs x y} [lrange $path $i [expr $i + 6]] break
if {!$isabsolute} {
set x [expr $cpx + $x]
set y [expr $cpy + $y]
}
set arcpars \
[EllipticArcParameters $cpx $cpy $rx $ry $phi $fa $fs $x $y]
# Handle special cases.
switch -- $arcpars {
skip {
# Empty
}
lineto {
lappend co [lindex $path [expr $i + 5]] \
[lindex $path [expr $i + 6]]
}
default {
# Need to end any previous path.
if {[llength $co] > 2} {
set opts [concat [set ${cantype}opts] $itemopts]
lappend cmdList [concat create $cantype $co $opts]
}
# Cannot handle rotations.
foreach {cx cy rx ry theta delta phi} $arcpars break
set box [list [expr $cx-$rx] [expr $cy-$ry] \
[expr $cx+$rx] [expr $cy+$ry]]
set itemopts [list -start $theta -extent $delta]
# Try to interpret any subsequent data as a
# -style chord | pieslice.
# Z: chord; float float Z: pieslice.
set ia [expr $i + 7]
set ib [expr $i + 10]
if {[regexp -nocase {z} [lrange $path $ia $ia]]} {
lappend itemopts -style chord
incr i 1
} elseif {[regexp -nocase {l +([-0-9\.]+) +([-0-9\.]+) +z} \
[lrange $path $ia $ib] m mx my] && \
[expr hypot($mx-$cx, $my-$cy)] < 4.0} {
lappend itemopts -style pieslice
incr i 4
} else {
lappend itemopts -style arc
}
set opts [concat $polygonopts $itemopts]
lappend cmdList [concat create arc $box $opts]
set co {}
set itemopts {}
}
}
incr i 6
}
C - c {
# We could have a sequence of pairs of points here...
# Approximate by quadratic bezier.
# There are three options here:
# C (p1 p2 p3) (p4 p5 p6)... finalize item
# C (p1 p2 p3) S (p4 p5)... let S trigger below
# C p1 p2 p3 anything else finalize here
while {![regexp {[a-zA-Z]} [lindex $path [expr $i+1]]] && \
($i < $len6)} {
set co [list $cpx $cpy]
if {$isabsolute} {
lappend co [lindex $path [incr i]] [lindex $path [incr i]]
lappend co [lindex $path [incr i]] [lindex $path [incr i]]
lappend co [lindex $path [incr i]] [lindex $path [incr i]]
set cpx [lindex $co end-1]
set cpy [lindex $co end]
} else {
PathAddRelative $path co i cpx cpy
PathAddRelative $path co i cpx cpy
PathAddRelative $path co i cpx cpy
}
# Do not finalize item if S instruction.
if {![string equal -nocase [lindex $path [expr $i+1]] "S"]} {
lappend itemopts -smooth 1
set opts [concat $lineopts $itemopts]
lappend cmdList [concat create line $co $opts]
set co {}
set itemopts {}
}
}
incr i
}
H {
while {![regexp {[a-zA-Z]} [lindex $path [expr $i+1]]] && \
($i < $len1)} {
lappend co [lindex $path [incr i]] $cpy
}
incr i
}
h {
while {![regexp {[a-zA-Z]} [lindex $path [expr $i+1]]] && \
($i < $len1)} {
lappend co [expr $cpx + [lindex $path [incr i]]] $cpy
}
incr i
}
L - {[0-9]+} - {-[0-9]+} {
while {![regexp {[a-zA-Z]} [lindex $path [expr $i+1]]] && \
($i < $len2)} {
lappend co [lindex $path [incr i]] [lindex $path [incr i]]
}
incr i
}
l {
while {![regexp {[a-zA-Z]} [lindex $path [expr $i+1]]] && \
($i < $len2)} {
lappend co [expr $cpx + [lindex $path [incr i]]] \
[expr $cpy + [lindex $path [incr i]]]
}
incr i
}
M - m {
# Make a fresh canvas item and finalize any previous command.
if {[llength $co]} {
set opts [concat [set ${cantype}opts] $itemopts]
lappend cmdList [concat create $cantype $co $opts]
}
if {!$isabsolute && [info exists cpx]} {
set co [list \
[expr $cpx + [lindex $path [incr i]]]
[expr $cpy + [lindex $path [incr i]]]]
} else {
set co [list [lindex $path [incr i]] [lindex $path [incr i]]]
}
set itemopts {}
incr i
}
Q - q {
# There are three options here:
# Q p1 p2 p3 p4... finalize item
# Q p1 p2 T p3... let T trigger below
# Q p1 p2 anything else finalize here
# We may have a sequence of pairs of points following the Q.
# Make a fresh item for each.
while {![regexp {[a-zA-Z]} [lindex $path [expr $i+1]]] && \
($i < $len4)} {
set co [list $cpx $cpy]
if {$isabsolute} {
lappend co [lindex $path [incr i]] [lindex $path [incr i]]
lappend co [lindex $path [incr i]] [lindex $path [incr i]]
set cpx [lindex $co end-1]
set cpy [lindex $co end]
} else {
PathAddRelative $path co i cpx cpy
PathAddRelative $path co i cpx cpy
}
# Do not finalize item if T instruction.
if {![string equal -nocase [lindex $path [expr $i+1]] "T"]} {
lappend itemopts -smooth 1
set opts [concat $lineopts $itemopts]
lappend cmdList [concat create line $co $opts]
set co {}
set itemopts {}
}
}
incr i
}
S - s {
# Must annihilate last point added and use its mirror instead.
while {![regexp {[a-zA-Z]} [lindex $path [expr $i+1]]] && \
($i < $len4)} {
# Control point from mirroring.
set ctrlpx [expr 2 * $cpx - [lindex $co end-3]]
set ctrlpy [expr 2 * $cpy - [lindex $co end-2]]
lset co end-1 $ctrlpx
lset co end $ctrlpy
if {$isabsolute} {
lappend co [lindex $path [incr i]] [lindex $path [incr i]]
lappend co [lindex $path [incr i]] [lindex $path [incr i]]
set cpx [lindex $co end-1]
set cpy [lindex $co end]
} else {
PathAddRelative $path co i cpx cpy
PathAddRelative $path co i cpx cpy
}
}
# Finalize item.
lappend itemopts -smooth 1
set dx [expr [lindex $co 0] - [lindex $co end-1]]
set dy [expr [lindex $co 1] - [lindex $co end]]
# Check endpoints to see if closed polygon.
# Remove first AND end points if closed!
if {[expr hypot($dx, $dy)] < 0.5} {
set opts [concat $polygonopts $itemopts]
set co [lrange $co 2 end-2]
lappend cmdList [concat create polygon $co $opts]
} else {
set opts [concat $lineopts $itemopts]
lappend cmdList [concat create line $co $opts]
}
set co {}
set itemopts {}
incr i
}
T - t {
# Must annihilate last point added and use its mirror instead.
while {![regexp {[a-zA-Z]} [lindex $path [expr $i+1]]] && \
($i < $len2)} {
# Control point from mirroring.
set ctrlpx [expr 2 * $cpx - [lindex $co end-3]]
set ctrlpy [expr 2 * $cpy - [lindex $co end-2]]
lset co end-1 $ctrlpx
lset co end $ctrlpy
if {$isabsolute} {
lappend co [lindex $path [incr i]] [lindex $path [incr i]]
set cpx [lindex $co end-1]
set cpy [lindex $co end]
} else {
PathAddRelative $path co i cpx cpy
}
}
# Finalize item.
lappend itemopts -smooth 1
set dx [expr [lindex $co 0] - [lindex $co end-1]]
set dy [expr [lindex $co 1] - [lindex $co end]]
# Check endpoints to see if closed polygon.
# Remove first AND end points if closed!
if {[expr hypot($dx, $dy)] < 0.5} {
set opts [concat $polygonopts $itemopts]
set co [lrange $co 2 end-2]
lappend cmdList [concat create polygon $co $opts]
} else {
set opts [concat $lineopts $itemopts]
lappend cmdList [concat create line $co $opts]
}
set co {}
set itemopts {}
incr i
}
V {
while {![regexp {[a-zA-Z]} [lindex $path [expr $i+1]]] && \
($i < $len1)} {
lappend co $cpx [lindex $path [incr i]]
}
incr i
}
v {
while {![regexp {[a-zA-Z]} [lindex $path [expr $i+1]]] && \
($i < $len1)} {
lappend co $cpx [expr $cpy + [lindex $path [incr i]]]
}
incr i
}
Z - z {
if {[llength $co]} {
set opts [concat $polygonopts $itemopts]
lappend cmdList [concat create polygon $co $opts]
}
set cantype line
set itemopts {}
incr i
set co {}
}
default {
# ?
incr i
}
} ;# End switch.
# Keep track of the pens current point.
if {[llength $co]} {
set cpx [lindex $co end-1]
set cpy [lindex $co end]
}
} ;# End while loop.
# Finalize the last element if any.
if {[llength $co]} {
set opts [concat [set ${cantype}opts] $itemopts]
lappend cmdList [concat create $cantype $co $opts]
}
return [AddAnyTransformCmds $cmdList $transformL]
}
proc svg2can::ParsePathEx {xmllist paropts transAttr args} {
set opts {}
set presAttr {}
set path {}
array set attrA $args
array set attrA [getattr $xmllist]
foreach {key value} [array get attrA] {
switch -- $key {
d {
set path [parsePathAttr $value]
}
id {
lappend opts -tags $value
}
style {
eval {lappend opts} [StyleToOptsEx [StyleAttrToList $value]]
}
transform {
eval {lappend transAttr} [TransformAttrToList $value]
}
default {
lappend presAttr $key $value
}
}
}
if {[llength $transAttr]} {
lappend opts -matrix [TransformAttrListToMatrix $transAttr]
}
set opts [StrokeFillDefaults [MergePresentationAttrEx $opts $presAttr]]
return [concat create path [list $path] $opts]
}
# Handle different defaults for fill and stroke.
proc svg2can::StrokeFillDefaults {opts {noFill 0}} {
array set optsA $opts
if {!$noFill && ![info exists optsA(-fill)]} {
set optsA(-fill) black
}
if {[info exists optsA(-fillgradient)]} {
unset -nocomplain optsA(-fill)
}
if {![info exists optsA(-stroke)]} {
set optsA(-stroke) {}
}
return [array get optsA]
}
proc svg2can::ParsePolyline {xmllist paropts transformL args} {
variable tmptag
set coords {}
set opts {}
set presAttr {}
array set attrA $args
array set attrA [getattr $xmllist]
set tags {}
if {[llength $transformL]} {
lappend tags $tmptag
}
foreach {key value} [array get attrA] {
switch -- $key {
points {
set coords [PointsToList $value]
}
id {
set tags [concat $tags $value]
}
style {
set opts [StyleToOpts line [StyleAttrToList $value]]
}
default {
lappend presAttr $key $value
}
}
}
lappend opts -tags $tags
set opts [MergePresentationAttr line $opts $presAttr]
set cmdList [list [concat create line $coords $opts]]
return [AddAnyTransformCmds $cmdList $transformL]
}
proc svg2can::ParsePolylineEx {xmllist paropts transAttr args} {
set opts {}
set points {0 0}
set presAttr {}
array set attrA $args
array set attrA [getattr $xmllist]
foreach {key value} [array get attrA] {
switch -- $key {
points {
set points [PointsToList $value]
}
id {
lappend opts -tags $value
}
style {
eval {lappend opts} [StyleToOptsEx [StyleAttrToList $value]]
}
transform {
eval {lappend transAttr} [TransformAttrToList $value]
}
default {
lappend presAttr $key $value
}
}
}
if {[llength $transAttr]} {
lappend opts -matrix [TransformAttrListToMatrix $transAttr]
}
set opts [StrokeFillDefaults [MergePresentationAttrEx $opts $presAttr]]
return [concat create polyline $points $opts]
}
proc svg2can::ParsePolygon {xmllist paropts transformL args} {
variable tmptag
set coords {}
set opts {}
set presAttr {}
array set attrA $args
array set attrA [getattr $xmllist]
set tags {}
if {[llength $transformL]} {
lappend tags $tmptag
}
foreach {key value} [array get attrA] {
switch -- $key {
points {
set coords [PointsToList $value]
}
id {
set tags [concat $tags $value]
}
style {
set opts [StyleToOpts polygon [StyleAttrToList $value]]
}
default {
lappend presAttr $key $value
}
}
}
lappend opts -tags $tags
set opts [MergePresentationAttr polygon $opts $presAttr]
set cmdList [list [concat create polygon $coords $opts]]
return [AddAnyTransformCmds $cmdList $transformL]
}
proc svg2can::ParsePolygonEx {xmllist paropts transAttr args} {
set opts {}
set points {0 0}
set presAttr {}
array set attrA $args
array set attrA [getattr $xmllist]
foreach {key value} [array get attrA] {
switch -- $key {
points {
set points [PointsToList $value]
}
id {
lappend opts -tags $value
}
style {
eval {lappend opts} [StyleToOptsEx [StyleAttrToList $value]]
}
transform {
eval {lappend transAttr} [TransformAttrToList $value]
}
default {
lappend presAttr $key $value
}
}
}
if {[llength $transAttr]} {
lappend opts -matrix [TransformAttrListToMatrix $transAttr]
}
set opts [StrokeFillDefaults [MergePresentationAttrEx $opts $presAttr]]
return [concat create ppolygon $points $opts]
}
proc svg2can::ParseRect {xmllist paropts transformL args} {
variable tmptag
set opts {}
set coords {0 0 0 0}
set presAttr {}
array set attrA $args
array set attrA [getattr $xmllist]
set tags {}
if {[llength $transformL]} {
lappend tags $tmptag
}
foreach {key value} [array get attrA] {
switch -- $key {
id {
set tags [concat $tags $value]
}
rx - ry {
# unsupported :-(
}
style {
set opts [StyleToOpts rectangle [StyleAttrToList $value]]
}
x - y - width - height {
set $key [parseLength $value]
}
default {
lappend presAttr $key $value
}
}
}
if {[info exists x]} {
lset coords 0 $x
}
if {[info exists y]} {
lset coords 1 $y
}
if {[info exists width]} {
lset coords 2 [expr [lindex $coords 0] + $width]
}
if {[info exists height]} {
lset coords 3 [expr [lindex $coords 1] + $height]
}
lappend opts -tags $tags
set opts [MergePresentationAttr rectangle $opts $presAttr]
set cmdList [list [concat create rectangle $coords $opts]]
return [AddAnyTransformCmds $cmdList $transformL]
}
proc svg2can::ParseRectEx {xmllist paropts transAttr args} {
set opts {}
set x 0
set y 0
set width 0
set height 0
set presAttr {}
array set attrA $args
array set attrA [getattr $xmllist]
foreach {key value} [array get attrA] {
switch -- $key {
x - y - width - height {
set $key [parseLength $value]
}
id {
lappend opts -tags $value
}
style {
eval {lappend opts} [StyleToOptsEx [StyleAttrToList $value]]
}
transform {
eval {lappend transAttr} [TransformAttrToList $value]
}
default {
lappend presAttr $key $value
}
}
}
if {[llength $transAttr]} {
lappend opts -matrix [TransformAttrListToMatrix $transAttr]
}
set x2 [expr {$x + $width}]
set y2 [expr {$y + $height}]
set opts [StrokeFillDefaults [MergePresentationAttrEx $opts $presAttr]]
return [concat create prect $x $y $x2 $y2 $opts]
}
# svg2can::ParseText --
#
# Takes a text element and returns a list of canvas create text commands.
# Assuming that chdata is not mixed with elements, we should now have
# either chdata OR more elements (tspan).
proc svg2can::ParseText {xmllist paropts transformL args} {
set x 0
set y 0
set xAttr 0
set yAttr 0
set cmdList [ParseTspan $xmllist $transformL x y xAttr yAttr {}]
return $cmdList
}
proc svg2can::ParseTextEx {xmllist paropts transAttr args} {
return [eval {ParseText $xmllist $paropts {}} $args]
}
# svg2can::ParseTspan --
#
# Takes a tspan or text element and returns a list of canvas
# create text commands.
proc svg2can::ParseTspan {xmllist transformL xVar yVar xAttrVar yAttrVar opts} {
variable tmptag
variable systemFont
upvar $xVar x
upvar $yVar y
upvar $xAttrVar xAttr
upvar $yAttrVar yAttr
# Nested tspan elements do not inherit x, y, dx, or dy attributes set.
# Sibling tspan elements do inherit x, y attributes.
# Keep two separate sets of x and y; (x,y) and (xAttr,yAttr):
# (x,y)
# Inherit opts.
array set optsA $opts
array set optsA [ParseTextAttr $xmllist xAttr yAttr baselineShift]
set tag [gettag $xmllist]
set childList [getchildren $xmllist]
set cmdList {}
if {[string equal $tag "text"]} {
set x $xAttr
set y $yAttr
}
if {[llength $childList]} {
# Nested tspan elements do not inherit x, y set via attributes.
if {[string equal $tag "tspan"]} {
set xAttr $x
set yAttr $y
}
set opts [array get optsA]
foreach c $childList {
switch -- [gettag $c] {
tspan {
set cmdList [concat $cmdList \
[ParseTspan $c $transformL x y xAttr yAttr $opts]]
}
default {
# empty
}
}
}
} else {
set str [getcdata $xmllist]
set optsA(-text) $str
if {[llength $transformL]} {
lappend optsA(-tags) $tmptag
}
set opts [array get optsA]
set theFont $systemFont
if {[info exists optsA(-font)]} {
set theFont $optsA(-font)
}
# Need to adjust the text position so that the baseline matches y.
# nw to baseline
set ascent [font metrics $theFont -ascent]
set cmdList [list [concat create text \
$xAttr [expr $yAttr - $ascent + $baselineShift] $opts]]
set cmdList [AddAnyTransformCmds $cmdList $transformL]
# Each text insert moves both the running coordinate sets.
# newlines???
set deltax [font measure $theFont $str]
set x [expr $x + $deltax]
set xAttr [expr $xAttr + $deltax]
}
return $cmdList
}
# svg2can::ParseTextAttr --
#
# Parses the attributes in xmllist and returns the translated canvas
# option list.
proc svg2can::ParseTextAttr {xmllist xVar yVar baselineShiftVar} {
variable systemFont
upvar $xVar x
upvar $yVar y
upvar $baselineShiftVar baselineShift
# svg defaults to start with y being the baseline while tk default is c.
#set opts {-anchor sw}
# Anchor nw is simplest when newlines.
set opts {-anchor nw}
set presAttr {}
set baselineShift 0
foreach {key value} [getattr $xmllist] {
switch -- $key {
baseline-shift {
set baselineShiftSet $value
}
dx {
set x [expr $x + $value]
}
dy {
set y [expr $y + $value]
}
id {
lappend opts -tags $value
}
style {
set opts [concat $opts \
[StyleToOpts text [StyleAttrToList $value]]]
}
x - y {
set $key $value
}
default {
lappend presAttr $key $value
}
}
}
array set optsA $opts
set theFont $systemFont
if {[info exists optsA(-font)]} {
set theFont $optsA(-font)
}
if {[info exists baselineShiftSet]} {
set baselineShift [BaselineShiftToDy $baselineShiftSet $theFont]
}
return [MergePresentationAttr text $opts $presAttr]
}
# svg2can::AttrToCoords --
#
# Returns coords from SVG attributes.
#
# Arguments:
# type SVG type
# attr list of geometry attributes
#
# Results:
# list of coordinates
proc svg2can::AttrToCoords {type attrlist} {
# Defaults.
array set attr {
cx 0
cy 0
height 0
r 0
rx 0
ry 0
width 0
x 0
x1 0
x2 0
y 0
y1 0
y2 0
}
array set attr $attrlist
switch -- $type {
circle {
set coords [list \
[expr $attr(cx) - $attr(r)] [expr $attr(cy) - $attr(r)] \
[expr $attr(cx) + $attr(r)] [expr $attr(cy) + $attr(r)]]
}
ellipse {
set coords [list \
[expr $attr(cx) - $attr(rx)] [expr $attr(cy) - $attr(ry)] \
[expr $attr(cx) + $attr(rx)] [expr $attr(cy) + $attr(ry)]]
}
image {
set coords [list $attr(x) $attr(y)]
}
line {
set coords [list $attr(x1) $attr(y1) $attr(x2) $attr(y2)]
}
path {
# empty
}
polygon {
set coords [PointsToList $attr(points)]
}
polyline {
set coords [PointsToList $attr(points)]
}
rect {
set coords [list $attr(x) $attr(y) \
[expr $attr(x) + $attr(width)] [expr $attr(y) + $attr(height)]]
}
text {
set coords [list $attr(x) $attr(y)]
}
}
return $coords
}
# @@@ There is a lot TODO here!
proc svg2can::CreateLinearGradient {xmllist} {
variable gradientIDToToken
set x1 0
set y1 0
set x2 1
set y2 0
set method pad
set units bbox
set stops {}
# We first need to find out if any xlink:href attribute since:
# Any 'linearGradient' attributes which are defined on the
# referenced element which are not defined on this element are
# inherited by this element.
set attr [getattr $xmllist]
set idx [lsearch -exact $attr xlink:href]
if {$idx >= 0 && [expr {$idx % 2 == 0}]} {
set value [lindex $attr [incr idx]]
if {![string match {\#*} $value]} {
return -code error "unrecognized gradient uri \"$value\""
}
set uri [string range $value 1 end]
if {![info exists gradientIDToToken($uri)]} {
return -code error "unrecognized gradient uri \"$value\""
}
set hreftoken $gradientIDToToken($uri)
set units [::tkpath::gradient cget $hreftoken -units]
set method [::tkpath::gradient cget $hreftoken -method]
set hrefstops [::tkpath::gradient cget $hreftoken -stops]
foreach {x1 y1 x2 y2} \
[::tkpath::gradient cget $hreftoken -lineartransition] { break }
}
foreach {key value} $attr {
switch -- $key {
x1 - y1 - x2 - y2 {
set $key [parseUnaryOrPercentage $value]
}
id {
set id $value
}
gradientUnits {
set units [string map \
{objectBoundingBox bbox userSpaceOnUse userspace} $value]
}
spreadMethod {
set method $value
}
}
}
if {![info exists id]} {
return
}
# If this element has no defined gradient stops, and the referenced element
# does, then this element inherits the gradient stop from the referenced
# element.
set stops [ParseGradientStops $xmllist]
if {$stops eq {}} {
if {[info exists hrefstops]} {
set stops $hrefstops
}
}
set token [::tkpath::gradient create linear -method $method -units $units \
-lineartransition [list $x1 $y1 $x2 $y2] -stops $stops]
set gradientIDToToken($id) $token
cache_add gradient $token
}
proc svg2can::CreateRadialGradient {xmllist} {
variable gradientIDToToken
set cx 0.5
set cy 0.5
set r 0.5
set fx 0.5
set fy 0.5
set method pad
set units bbox
set stops {}
# We first need to find out if any xlink:href attribute since:
# Any 'linearGradient' attributes which are defined on the
# referenced element which are not defined on this element are
# inherited by this element.
set attr [getattr $xmllist]
set idx [lsearch -exact $attr xlink:href]
if {$idx >= 0 && [expr {$idx % 2 == 0}]} {
set value [lindex $attr [incr idx]]
if {![string match {\#*} $value]} {
return -code error "unrecognized gradient uri \"$value\""
}
set uri [string range $value 1 end]
if {![info exists gradientIDToToken($uri)]} {
return -code error "unrecognized gradient uri \"$value\""
}
set hreftoken $gradientIDToToken($uri)
set units [::tkpath::gradient cget $hreftoken -units]
set method [::tkpath::gradient cget $hreftoken -method]
set hrefstops [::tkpath::gradient cget $hreftoken -stops]
set transL [::tkpath::gradient cget $hreftoken -radialtransition]
set cx [lindex $transL 0]
set cy [lindex $transL 1]
if {[llength $transL] > 2} {
set r [lindex $transL 2]
if {[llength $transL] == 5} {
set fx [lindex $transL 3]
set fy [lindex $transL 4]
}
}
}
foreach {key value} [getattr $xmllist] {
switch -- $key {
cx - cy - r - fx - fy {
set $key [parseUnaryOrPercentage $value]
}
id {
set id $value
}
gradientUnits {
set units [string map \
{objectBoundingBox bbox userSpaceOnUse userspace} $value]
}
spreadMethod {
set method $value
}
}
}
if {![info exists id]} {
return
}
# If this element has no defined gradient stops, and the referenced element
# does, then this element inherits the gradient stop from the referenced
# element.
set stops [ParseGradientStops $xmllist]
if {$stops eq {}} {
if {[info exists hrefstops]} {
set stops $hrefstops
}
}
set token [::tkpath::gradient create radial -method $method -units $units \
-radialtransition [list $cx $cy $r $fx $fy] -stops $stops]
set gradientIDToToken($id) $token
cache_add gradient $token
}
proc svg2can::ParseGradientStops {xmllist} {
set stops {}
foreach stopE [getchildren $xmllist] {
if {[gettag $stopE] eq "stop"} {
set opts {}
set offset 0
set color black
set opacity 1
foreach {key value} [getattr $stopE] {
switch -- $key {
offset {
set offset [parseUnaryOrPercentage $value]
}
stop-color {
set color [parseColor $value]
}
stop-opacity {
set opacity $value
}
style {
set opts [StopsStyleToStopSpec [StyleAttrToList $value]]
}
}
}
# Style takes precedence.
array set stopA [list color $color opacity $opacity]
array set stopA $opts
lappend stops [list $offset $stopA(color) $stopA(opacity)]
}
}
return $stops
}
proc svg2can::parseUnaryOrPercentage {offset} {
if {[string is double -strict $offset]} {
return $offset
} elseif {[regexp {(.+)%} $offset - percent]} {
return [expr {$percent/100.0}]
}
}
# svg2can::parseColor --
#
# Takes a SVG color definition and turns it into a Tk color.
#
# Arguments:
# color SVG color
#
# Results:
# tk color
proc svg2can::parseColor {color} {
if {[regexp {rgb\(([0-9]{1,3})%, *([0-9]{1,3})%, *([0-9]{1,3})%\)} \
$color - r g b]} {
set col "#"
foreach c [list $r $g $b] {
append col [format %02x [expr round(2.55 * $c)]]
}
} elseif {[regexp {rgb\(([0-9]{1,3}), *([0-9]{1,3}), *([0-9]{1,3})\)} \
$color - r g b]} {
set col "#"
foreach c [list $r $g $b] {
append col [format %02x $c]
}
} else {
set col [MapNoneToEmpty $color]
}
return $col
}
proc svg2can::parseFillToList {value} {
variable gradientIDToToken
if {[regexp {url\(#(.+)\)} $value - id]} {
#puts "\t id=$id"
if {[info exists gradientIDToToken($id)]} {
#puts "\t gradientIDToToken=$gradientIDToToken($id)"
return [list -fill $gradientIDToToken($id)]
} else {
puts "--------> missing gradientIDToToken id=$id"
return [list -fill black]
}
} else {
return [list -fill [parseColor $value]]
}
}
proc svg2can::parseLength {length} {
if {[string is double -strict $length]} {
return $length
}
# SVG is using: px, pt, mm, cm, em, ex, in, %.
# @@@ Incomplete!
set length [string map {px "" pt p mm m cm c in i} $length]
return [winfo fpixels . $length]
}
proc svg2can::parsePathAttr {path} {
regsub -all -- {([a-zA-Z])([0-9])} $path {\1 \2} path
regsub -all -- {([0-9])([a-zA-Z])} $path {\1 \2} path
regsub -all -- {([a-zA-Z])([a-zA-Z])} $path {\1 \2} path
return [string map {- " -" , " "} $path]
}
# svg2can::StyleToOpts --
#
# Takes the style attribute as a list and parses it into
# resonable canvas drawing options.
# Discards all attributes that don't map to an item option.
#
# Arguments:
# type tk canvas item type
# styleList
#
# Results:
# list of canvas options
proc svg2can::StyleToOpts {type styleList args} {
variable textAnchorMap
array set argsA {
-setdefaults 1
-origfont {Helvetica 12}
}
array set argsA $args
# SVG and canvas have different defaults.
if {$argsA(-setdefaults)} {
switch -- $type {
oval - polygon - rectangle {
array set optsA {-fill black -outline ""}
}
line {
array set optsA {-fill black}
}
}
}
set fontSpec $argsA(-origfont)
set haveFont 0
foreach {key value} $styleList {
switch -- $key {
fill {
switch -- $type {
arc - oval - polygon - rectangle - text {
set optsA(-fill) [parseColor $value]
}
}
}
font-family {
lset fontSpec 0 $value
set haveFont 1
}
font-size {
# Use pixels instead of points.
if {[regexp {([0-9\.]+)pt} $value match pts]} {
set pix [expr int($pts * [tk scaling] + 0.01)]
lset fontSpec 1 "-$pix"
} elseif {[regexp {([0-9\.]+)px} $value match pix]} {
lset fontSpec 1 [expr int(-$pix)]
} else {
lset fontSpec 1 [expr int(-$value)]
}
set haveFont 1
}
font-style {
switch -- $value {
italic {
lappend fontSpec italic
}
}
set haveFont 1
}
font-weight {
switch -- $value {
bold {
lappend fontSpec bold
}
}
set haveFont 1
}
marker-end {
set optsA(-arrow) last
}
marker-start {
set optsA(-arrow) first
}
stroke {
switch -- $type {
arc - oval - polygon - rectangle {
set optsA(-outline) [parseColor $value]
}
line {
set optsA(-fill) [parseColor $value]
}
}
}
stroke-dasharray {
set dash [split $value ,]
if {[expr [llength $dash]%2 == 1]} {
set dash [concat $dash $dash]
}
}
stroke-linecap {
# canvas: butt (D), projecting , round
# svg: butt (D), square, round
if {[string equal $value "square"]} {
set optsA(-capstyle) "projecting"
}
if {![string equal $value "butt"]} {
set optsA(-capstyle) $value
}
}
stroke-linejoin {
set optsA(-joinstyle) $value
}
stroke-miterlimit {
# empty
}
stroke-opacity {
if {[expr {$value == 0}]} {
}
}
stroke-width {
if {![string equal $type "text"]} {
set optsA(-width) $value
}
}
text-anchor {
set optsA(-anchor) $textAnchorMap($value)
}
text-decoration {
switch -- $value {
line-through {
lappend fontSpec overstrike
}
underline {
lappend fontSpec underline
}
}
set haveFont 1
}
}
}
if {$haveFont} {
set optsA(-font) $fontSpec
}
return [array get optsA]
}
proc svg2can::StyleToOptsEx {styleList args} {
foreach {key value} $styleList {
switch -- $key {
fill {
foreach {name val} [parseFillToList $value] { break }
set optsA($name) $val
}
opacity {
# @@@ This is much more complicated than this for groups!
set optsA(-fillopacity) $value
set optsA(-strokeopacity) $value
}
stroke {
set optsA(-$key) [parseColor $value]
}
stroke-dasharray {
if {$value eq "none"} {
set optsA(-strokedasharray) {}
} else {
set dash [split $value ,]
set optsA(-strokedasharray) $dash
}
}
fill-opacity - stroke-linejoin - stroke-miterlimit - stroke-opacity {
set name [string map {"-" ""} $key]
set optsA(-$name) $value
}
stroke-linecap {
# svg: butt (D), square, round
# canvas: butt (D), projecting , round
if {$value eq "square"} {
set value "projecting"
}
set name [string map {"-" ""} $key]
set optsA(-$name) $value
}
stroke-width {
set name [string map {"-" ""} $key]
set optsA(-$name) [parseLength $value]
}
r - rx - ry - width - height {
set optsA(-$key) [parseLength $value]
}
}
}
return [array get optsA]
}
# svg2can::StopsStyleToStopSpec --
#
# Takes the stop style attribute as a list and parses it into
# a flat array for the gradient stopSpec: {offset color ?opacity?}
proc svg2can::StopsStyleToStopSpec {styleList} {
foreach {key value} $styleList {
switch -- $key {
stop-color {
set optsA(color) [parseColor $value]
}
stop-opacity {
set optsA(opacity) $value
}
}
}
return [array get optsA]
}
# svg2can::EllipticArcParameters --
#
# Conversion from endpoint to center parameterization.
# From: http://www.w3.org/TR/2003/REC-SVG11-20030114
proc svg2can::EllipticArcParameters {x1 y1 rx ry phi fa fs x2 y2} {
variable pi
# NOTE: direction of angles are opposite for Tk and SVG!
# F.6.2 Out-of-range parameters
if {($x1 == $x2) && ($y1 == $y2)} {
return skip
}
if {[expr $rx == 0] || [expr $ry == 0]} {
return lineto
}
set rx [expr abs($rx)]
set ry [expr abs($ry)]
set phi [expr fmod($phi, 360) * $pi/180.0]
if {$fa != 0} {
set fa 1
}
if {$fs != 0} {
set fs 1
}
# F.6.5 Conversion from endpoint to center parameterization
set dx [expr ($x1-$x2)/2.0]
set dy [expr ($y1-$y2)/2.0]
set x1prime [expr cos($phi) * $dx + sin($phi) * $dy]
set y1prime [expr -sin($phi) * $dx + cos($phi) * $dy]
# F.6.6 Correction of out-of-range radii
set rx [expr abs($rx)]
set ry [expr abs($ry)]
set x1prime2 [expr $x1prime * $x1prime]
set y1prime2 [expr $y1prime * $y1prime]
set rx2 [expr $rx * $rx]
set ry2 [expr $ry * $ry]
set lambda [expr $x1prime2/$rx2 + $y1prime2/$ry2]
if {$lambda > 1.0} {
set rx [expr sqrt($lambda) * $rx]
set ry [expr sqrt($lambda) * $ry]
set rx2 [expr $rx * $rx]
set ry2 [expr $ry * $ry]
}
# Compute cx' and cy'
set sign [expr {$fa == $fs} ? -1 : 1]
set square [expr ($rx2 * $ry2 - $rx2 * $y1prime2 - $ry2 * $x1prime2) / \
($rx2 * $y1prime2 + $ry2 * $x1prime2)]
set root [expr sqrt(abs($square))]
set cxprime [expr $sign * $root * $rx * $y1prime/$ry]
set cyprime [expr -$sign * $root * $ry * $x1prime/$rx]
# Compute cx and cy from cx' and cy'
set cx [expr $cxprime * cos($phi) - $cyprime * sin($phi) + ($x1 + $x2)/2.0]
set cy [expr $cxprime * sin($phi) + $cyprime * cos($phi) + ($y1 + $y2)/2.0]
# Compute start angle and extent
set ux [expr ($x1prime - $cxprime)/double($rx)]
set uy [expr ($y1prime - $cyprime)/double($ry)]
set vx [expr (-$x1prime - $cxprime)/double($rx)]
set vy [expr (-$y1prime - $cyprime)/double($ry)]
set sign [expr {$uy > 0} ? 1 : -1]
set theta [expr $sign * acos( $ux/hypot($ux, $uy) )]
set sign [expr {$ux * $vy - $uy * $vx > 0} ? 1 : -1]
set delta [expr $sign * acos( ($ux * $vx + $uy * $vy) / \
(hypot($ux, $uy) * hypot($vx, $vy)) )]
# To degrees
set theta [expr $theta * 180.0/$pi]
set delta [expr $delta * 180.0/$pi]
#set delta [expr fmod($delta, 360)]
set phi [expr fmod($phi, 360)]
if {($fs == 0) && ($delta > 0)} {
set delta [expr $delta - 360]
} elseif {($fs ==1) && ($delta < 0)} {
set delta [expr $delta + 360]
}
# NOTE: direction of angles are opposite for Tk and SVG!
set theta [expr -1*$theta]
set delta [expr -1*$delta]
return [list $cx $cy $rx $ry $theta $delta $phi]
}
# svg2can::MergePresentationAttr --
#
# Let the style attribute override the presentation attributes.
proc svg2can::MergePresentationAttr {type opts presAttr} {
if {[llength $presAttr]} {
array set optsA [StyleToOpts $type $presAttr]
array set optsA $opts
set opts [array get optsA]
}
return $opts
}
proc svg2can::MergePresentationAttrEx {opts presAttr} {
if {[llength $presAttr]} {
array set optsA [StyleToOptsEx $presAttr]
array set optsA $opts
set opts [array get optsA]
}
return $opts
}
proc svg2can::StyleAttrToList {style} {
return [split [string trim [string map {" " ""} $style] \;] :\;]
}
proc svg2can::BaselineShiftToDy {baselineshift fontSpec} {
set linespace [font metrics $fontSpec -linespace]
switch -regexp -- $baselineshift {
sub {
set dy [expr 0.8 * $linespace]
}
super {
set dy [expr -0.8 * $linespace]
}
{-?[0-9]+%} {
set dy [expr 0.01 * $linespace * [string trimright $baselineshift %]]
}
default {
# 0.5em ?
set dy $baselineshift
}
}
return $dy
}
# svg2can::PathAddRelative --
#
# Utility function to add a relative point from the path to the
# coordinate list. Updates iVar, and the current point.
proc svg2can::PathAddRelative {path coVar iVar cpxVar cpyVar} {
upvar $coVar co
upvar $iVar i
upvar $cpxVar cpx
upvar $cpyVar cpy
set newx [expr $cpx + [lindex $path [incr i]]]
set newy [expr $cpy + [lindex $path [incr i]]]
lappend co $newx $newy
set cpx $newx
set cpy $newy
}
proc svg2can::PointsToList {points} {
return [string map {, " "} $points]
}
# svg2can::ParseTransformAttr --
#
# Parse the svg syntax for the transform attribute to a simple tcl
# list.
proc svg2can::ParseTransformAttr {attrlist} {
set cmd ""
set idx [lsearch -exact $attrlist "transform"]
if {$idx >= 0} {
set cmd [TransformAttrToList [lindex $attrlist [incr idx]]]
}
return $cmd
}
proc svg2can::TransformAttrToList {cmd} {
regsub -all -- {\( *([-0-9.]+) *\)} $cmd { \1} cmd
regsub -all -- {\( *([-0-9.]+)[ ,]+([-0-9.]+) *\)} $cmd { {\1 \2}} cmd
regsub -all -- {\( *([-0-9.]+)[ ,]+([-0-9.]+)[ ,]+([-0-9.]+) *\)} \
$cmd { {\1 \2 \3}} cmd
regsub -all -- {,} $cmd {} cmd
return $cmd
}
# svg2can::TransformAttrListToMatrix --
#
# Processes a SVG transform attribute to a transformation matrix.
# Used by tkpath only.
#
# | a c tx |
# | b d ty |
# | 0 0 1 |
#
# linear form : {a b c d tx ty}
proc svg2can::TransformAttrListToMatrix {transform} {
variable degrees2Radians
# @@@ I don't have 100% control of multiplication order!
set i 0
foreach {op value} $transform {
switch -- $op {
matrix {
set m([incr i]) $value
}
rotate {
set phi [lindex $value 0]
set cosPhi [expr cos($degrees2Radians*$phi)]
set sinPhi [expr sin($degrees2Radians*$phi)]
set msinPhi [expr {-1.0*$sinPhi}]
if {[llength $value] == 1} {
set m([incr i]) \
[list $cosPhi $sinPhi $msinPhi $cosPhi 0 0]
} else {
set cx [lindex $value 1]
set cy [lindex $value 2]
set m([incr i]) [list $cosPhi $sinPhi $msinPhi $cosPhi \
[expr {-$cx*$cosPhi + $cy*$sinPhi + $cx}] \
[expr {-$cx*$sinPhi - $cy*$cosPhi + $cy}]]
}
}
scale {
set sx [lindex $value 0]
if {[llength $value] > 1} {
set sy [lindex $value 1]
} else {
set sy $sx
}
set m([incr i]) [list $sx 0 0 $sy 0 0]
}
skewx {
set tana [expr {tan($degrees2Radians*[lindex $value 0])}]
set m([incr i]) [list 1 0 $tana 1 0 0]
}
skewy {
set tana [expr {tan($degrees2Radians*[lindex $value 0])}]
set m([incr i]) [list 1 $tana 0 1 0 0]
}
translate {
set tx [lindex $value 0]
if {[llength $value] > 1} {
set ty [lindex $value 1]
} else {
set ty 0
}
set m([incr i]) [list 1 0 0 1 $tx $ty]
}
}
}
if {$i == 1} {
# This is the most common case.
set mat $m($i)
} else {
set mat {1 0 0 1 0 0}
foreach i [lsort -integer [array names m]] {
set mat [MMult $mat $m($i)]
}
}
foreach {a b c d tx ty} $mat { break }
return [list [list $a $c] [list $b $d] [list $tx $ty]]
}
proc svg2can::MMult {m1 m2} {
foreach {a1 b1 c1 d1 tx1 ty1} $m1 { break }
foreach {a2 b2 c2 d2 tx2 ty2} $m2 { break }
return [list \
[expr {$a1*$a2 + $c1*$b2}] \
[expr {$b1*$a2 + $d1*$b2}] \
[expr {$a1*$c2 + $c1*$d2}] \
[expr {$b1*$c2 + $d1*$d2}] \
[expr {$a1*$tx2 + $c1*$ty2 + $tx1}] \
[expr {$b1*$tx2 + $d1*$ty2 + $ty1}]]
}
# svg2can::CreateTransformCanvasCmdList --
#
# Takes a parsed list of transform attributes and turns them
# into a sequence of canvas commands.
# Standard items only which miss a matrix option.
proc svg2can::CreateTransformCanvasCmdList {tag transformL} {
set cmdList {}
foreach {key argument} $transformL {
switch -- $key {
translate {
lappend cmdList [concat [list move $tag] $argument]
}
scale {
switch -- [llength $argument] {
1 {
set xScale $argument
set yScale $argument
}
2 {
foreach {xScale yScale} $argument break
}
default {
set xScale 1.0
set yScale 1.0
}
}
lappend cmdList [list scale $tag 0 0 $xScale $yScale]
}
}
}
return $cmdList
}
proc svg2can::AddAnyTransformCmds {cmdList transformL} {
variable tmptag
if {[llength $transformL]} {
set cmdList [concat $cmdList \
[CreateTransformCanvasCmdList $tmptag $transformL]]
lappend cmdList [list dtag $tmptag]
}
return $cmdList
}
proc svg2can::MapNoneToEmpty {val} {
if {[string equal $val "none"]} {
return
} else {
return $val
}
}
proc svg2can::FlattenList {hilist} {
set flatlist {}
FlatListRecursive $hilist flatlist
return $flatlist
}
proc svg2can::FlatListRecursive {hilist flatlistVar} {
upvar $flatlistVar flatlist
if {[string equal [lindex $hilist 0] "create"]} {
set flatlist [list $hilist]
} else {
foreach c $hilist {
if {[string equal [lindex $c 0] "create"]} {
lappend flatlist $c
} else {
FlatListRecursive $c flatlist
}
}
}
}
# svg2can::gettag, getattr, getcdata, getchildren --
#
# Accesor functions to the specific things in a xmllist.
proc svg2can::gettag {xmllist} {
return [lindex $xmllist 0]
}
proc svg2can::getattr {xmllist} {
return [lindex $xmllist 1]
}
proc svg2can::getcdata {xmllist} {
return [lindex $xmllist 3]
}
proc svg2can::getchildren {xmllist} {
return [lindex $xmllist 4]
}
proc svg2can::_DrawSVG {fileName w} {
set fd [open $fileName r]
set xml [read $fd]
close $fd
set xmllist [tinydom::documentElement [tinydom::parse $xml]]
set cmdList [svg2can::parsesvgdocument $xmllist]
foreach c $cmdList {
puts $c
eval $w $c
}
}
# Tests...
if {0} {
# load /Users/matben/C/cvs/tkpath/macosx/build/tkpath0.2.1.dylib
package require svg2can
toplevel .t
pack [canvas .t.c -width 600 -height 500]
set i 0
set xml([incr i]) {<polyline points='400 10 10 10 10 400' \
style='stroke: #000000; stroke-width: 1.0; fill: none;'/>}
# Text
set xml([incr i]) {<text x='10.0' y='20.0' \
style='stroke-width: 0; font-family: Helvetica; font-size: 12; \
fill: #000000;' id='std text t001'>\
<tspan>Start</tspan><tspan>Mid</tspan><tspan>End</tspan></text>}
set xml([incr i]) {<text x='10.0' y='40.0' \
style='stroke-width: 0; font-family: Helvetica; font-size: 12; \
fill: #000000;' id='std text t002'>One\
straight text data</text>}
set xml([incr i]) {<text x='10.0' y='60.0' \
style='stroke-width: 0; font-family: Helvetica; font-size: 12; \
fill: #000000;' id='std text t003'>\
<tspan>Online</tspan><tspan dy='6'>dy=6</tspan><tspan dy='-6'>End</tspan></text>}
set xml([incr i]) {<text x='10.0' y='90.0' \
style='stroke-width: 0; font-family: Helvetica; font-size: 16; \
fill: #000000;' id='std text t004'>\
<tspan>First</tspan>\
<tspan dy='10'>Online (dy=10)</tspan>\
<tspan><tspan>Nested</tspan></tspan><tspan>End</tspan></text>}
# Paths
set xml([incr i]) {<path d='M 200 100 L 300 100 300 200 200 200 Z' \
style='fill-rule: evenodd; fill: none; stroke: black; stroke-width: 1.0;\
stroke-linejoin: round;' id='std poly t005'/>}
set xml([incr i]) {<path d='M 30 100 Q 80 30 100 100 130 65 200 80' \
style='fill-rule: evenodd; fill: none; stroke: #af5da8; stroke-width: 4.0;\
stroke-linejoin: round;' id='std poly t006'/>}
set xml([incr i]) {<polyline points='30 100,80 30,100 100,130 65,200 80' \
style='fill: none; stroke: red;'/>}
set xml([incr i]) {<path d='M 10 200 H 100 200 v20h 10'\
style='fill-rule: evenodd; fill: none; stroke: black; stroke-width: 2.0;\
stroke-linejoin: round;' id='std t008'/>}
set xml([incr i]) {<path d='M 20 200 V 300 310 h 10 v 10'\
style='fill-rule: evenodd; fill: none; stroke: blue; stroke-width: 2.0;\
stroke-linejoin: round;' id='std t008'/>}
set xml([incr i]) {<path d='M 30 100 Q 80 30 100 100 T 200 80' \
style='fill: none; stroke: green; stroke-width: 2.0;' id='t006'/>}
set xml([incr i]) {<path d='M 30 200 Q 80 130 100 200 T 150 180 200 180 250 180 300 180' \
style='fill: none; stroke: gray50; stroke-width: 2.0;' id='t006'/>}
set xml([incr i]) {<path d='M 30 300 Q 80 230 100 300 t 50 0 50 0 50 0 50 0' \
style='fill: none; stroke: gray50; stroke-width: 1.0;' id='std poly t006'/>}
set xml([incr i]) {<path d="M100,200 C100,100 250,100 250,200 \
S400,300 400,200" style='fill: none; stroke: black'/>}
set xml([incr i]) {<path d="M 125 75 A 100 50 0 0 0 225 125" \
style='fill: none; stroke: blue; stroke-width: 2.0;'/>}
set xml([incr i]) {<path d="M 125 75 A 100 50 0 0 1 225 125" \
style='fill: none; stroke: red; stroke-width: 2.0;'/>}
set xml([incr i]) {<path d="M 125 75 A 100 50 0 1 0 225 125" \
style='fill: none; stroke: green; stroke-width: 2.0;'/>}
set xml([incr i]) {<path d="M 125 75 A 100 50 0 1 1 225 125" \
style='fill: none; stroke: gray50; stroke-width: 2.0;'/>}
# g
set xml([incr i]) {<g fill="none" stroke="red" stroke-width="3" > \
<line x1="300" y1="10" x2="350" y2="10" /> \
<line x1="300" y1="10" x2="300" y2="50" /> \
</g>}
# translate
set xml([incr i]) {<rect id="t0012" x="10" y="10" width="20" height="20" \
style="stroke: yellow; fill: none; stroke-width: 2.0;" \
transform="translate(200,200)"/>}
set xml([incr i]) {<rect id="t0013" x="10" y="10" width="20" height="20" \
style="stroke: yellow; fill: none; stroke-width: 2.0;" transform="scale(4)"/>}
set xml([incr i]) {<circle id="t0013" cx="10" cy="10" r="20" \
style="stroke: yellow; fill: none; stroke-width: 2.0;"\
transform="translate(200,300)"/>}
set xml([incr i]) {<text x='10.0' y='40.0' transform="translate(200,300)" \
style='font-family: Helvetica; font-size: 24; \
fill: #000000;'>Translated Text</text>}
# tkpath tests...
set xml([incr i]) {<rect x='10' y='10' height='15' width='20' \
transform='translate(30, 20) scale(2)' style='fill: gray;'/>}
set xml([incr i]) {<rect x='10' y='10' height='15' width='20' \
transform='scale(2) translate(30, 20)' style='fill: black;'/>}
set xml([incr i]) {<g transform='translate(30, 20)'> \
<g transform='scale(2)'> \
<rect x='10' y='10' height='15' width='20' style='stroke: blue; fill: none;'/> \
</g> \
</g>}
.t.c create path "M 30 20 h 100 M 30 20 v 100"
.t.c create prect 10 10 30 25 -stroke {} -fill gray
foreach i [lsort -integer [array names xml]] {
set xmllist [tinydom::documentElement [tinydom::parse $xml($i)]]
set cmdList [svg2can::parseelement $xmllist]
foreach c $cmdList {
puts $c
eval .t.c $c
}
}
}
#-------------------------------------------------------------------------------kpv - 2010-02-23 20:13:33
has anyone gotten this to work? It calls for package require uriencode, tinydom::parse, and <canvas widget> create prect 10 10 30 25 -stroke {} -fill gray.