package require compass_utils::math
package require math::linearalgebra
package require compass_utils
namespace eval m {
namespace import -force ::math::linearalgebra::*
}
namespace eval svgml {
}
# package re compass_utils::img
# cu::img::clipboard get -type image/x-inkscape-svg
# gid_groups_conds::apply_condition { args } {
# variable doc
#
# set optional {
# { -ov point|line|surface|volume "" }
# { -noactualizegroups "" 0 }
# }
# set compulsory "xpathCnd group_name values_dict"
# }
# set n1 {container[@n='Properties']/container[@n='Shells']/condition[@n='Isotropic_Shell']}
# set n2 {container[@n='Conditions']/container[@n='Constraints']/condition[@n='Fixed_constraints']}
# set n3 {container[@n='loadcases']/blockdata[@n='loadcase'][1]/container[@n='Shells']/condition[@n='Self_weight_shell']}
#
# <gidpost_batch version='1.0'>
# <a n="create_line" a="line {{{} 0.0 0.0 0.0} {{} 5 0.0 0.0} {{coords_type {relative {0.0 1 0.0}}}} {{coords_type {relative {-5 0.0 0.0}}}} {{coords_type close} 0.0 0.0 0.0}}" f="1"/>
# <a n='create_surface' a='by_contour {last-3 last-2 last-1 last}'/>
#
# <a n="start_group" a="" f=""/>
# <a n='create_group' a='-make_name_unique 1 {Name {Isotropic shell Auto}}' f='1'/>
# <a n='add_group_entities' a='{Isotropic shell Auto} {surface last}' f='1'/>
#
# <a n="gid_groups_conds::addF" a="{$n1} group {n {Isotropic shell Auto}}" f="1"/>
# <a n="gid_groups_conds::addF" a="{$n1/group[@n='Isotropic shell Auto']} value {n Thickness pn Thickness unit_magnitude L state {[check_state {Beams_shells Shells Plane_stress Plates Beams_shells_solids All}]} v 0.0 units m}" f="1"/>
# <a n="gid_groups_conds::addF" a="{$n1/group[@n='Isotropic shell Auto']} value {n Material pn Material editable 0 values_tree {[give_materials_list -no_has_container material_anisotropic_elastic -has_supra_container Structural]} state {} v {Steel S-355N}}" f="1"/>
# <a n="gid_groups_conds::addF" a="{$n1/group[@n='Isotropic shell Auto']} value {n E pn E help {Young modulus} unit_magnitude P state {} v 2.1e11 units N/m^2}" f="1"/>
# <a n="gid_groups_conds::addF" a="{$n1/group[@n='Isotropic shell Auto']} value {n nu pn {\u03bd} help {Poisson coefficient} string_is double state {} v 0.3}" f="1"/>
# <a n="gid_groups_conds::addF" a="{$n1/group[@n='Isotropic shell Auto']} value {n Specific_weight pn {Specific weight} unit_magnitude F/L^3 state {} v 76930 units N/m^3}" f="1"/>
# <a n="change_group_properties" a="{{Isotropic shell Auto}} type BC" f="1"/>
# <a n="end_group" pn="" a="" f=""/>
#
# <a n="gid_groups_conds::addF" a="{$n2} group {n {Fixed constraints Auto2} ov point}" f="1"/>
# <a n="gid_groups_conds::addF" a="{$n2/group[@n='Fixed constraints Auto2']} container {n Activation pn Activation}" f="1"/>
# <a n="gid_groups_conds::addF" a="{$n2/group[@n='Fixed constraints Auto2']/container[@n='Activation']} value {n X_Constraint pn {X Constraint} values 1,0 state {[check_state_inv Plates]} v 1}" f="1"/>
# <a n="gid_groups_conds::addF" a="{$n2/group[@n='Fixed constraints Auto2']/container[@n='Activation']} value {n Y_Constraint pn {Y Constraint} values 1,0 state {[check_state_inv Plates]} v 1}" f="1"/>
# <a n="gid_groups_conds::addF" a="{$n2/group[@n='Fixed constraints Auto2']/container[@n='Activation']} value {n Z_Constraint pn {Z Constraint} values 1,0 state {[check_state_inv {Plane_strain Plane_stress}]} v 1}" f="1"/>
# <a n="gid_groups_conds::addF" a="{$n2/group[@n='Fixed constraints Auto2']/container[@n='Activation']} value {n theta_x_Constraint pn {?x Constraint} values 1,0 state {[check_state_inv {Plane_strain Plane_stress Plates Solids}]} v 0}" f="1"/>
# <a n="gid_groups_conds::addF" a="{$n2/group[@n='Fixed constraints Auto2']/container[@n='Activation']} value {n theta_y_Constraint pn {?y Constraint} values 1,0 state {[check_state_inv {Plane_strain Plane_stress Solids}]} v 0}" f="1"/>
# <a n="gid_groups_conds::addF" a="{$n2/group[@n='Fixed constraints Auto2']/container[@n='Activation']} value {n theta_z_Constraint pn {?z Constraint} values 1,0 state {[check_state_inv {Plane_strain Plane_stress Solids}]} v 1}" f="1"/>
# <a n="gid_groups_conds::addF" a="{$n2/group[@n='Fixed constraints Auto2']/container[@n='Activation']} value {n Local_axes pn {Local axes} values 0,1 editable 0 local_axes disabled help {If the direction to define is not coincident with the global axes, it is possible to define a set of local axes and define the displacements related to that local axes} state {} v 0}" f="1"/>
# <a n="gid_groups_conds::addF" a="{$n2/group[@n='Fixed constraints Auto2']} container {n Values pn Values}" f="1"/>
# <a n="gid_groups_conds::addF" a="{$n2/group[@n='Fixed constraints Auto2']/container[@n='Values']} value {n X_Value pn {X value} unit_magnitude L state {[check_state_inv Plates]} v 0.0 units m}" f="1"/>
# <a n="gid_groups_conds::addF" a="{$n2/group[@n='Fixed constraints Auto2']/container[@n='Values']} value {n Y_Value pn {Y value} unit_magnitude L state {[check_state_inv Plates]} v 0.0 units m}" f="1"/>
# <a n="gid_groups_conds::addF" a="{$n2/group[@n='Fixed constraints Auto2']/container[@n='Values']} value {n Z_Value pn {Z value} unit_magnitude L state {[check_state_inv {Plane_strain Plane_stress}]} v 0.0 units m}" f="1"/>
# <a n="gid_groups_conds::addF" a="{$n2/group[@n='Fixed constraints Auto2']/container[@n='Values']} value {n theta_x_Value pn {?x value} unit_magnitude Rotation state {[check_state_inv {Plane_strain Plane_stress Plates Solids}]} v 0.0 units deg}" f="1"/>
# <a n="gid_groups_conds::addF" a="{$n2/group[@n='Fixed constraints Auto2']/container[@n='Values']} value {n theta_y_Value pn {?y value} unit_magnitude Rotation state {[check_state_inv {Plane_strain Plane_stress Solids}]} v 0.0 units deg}" f="1"/>
# <a n="gid_groups_conds::addF" a="{$n2/group[@n='Fixed constraints Auto2']/container[@n='Values']} value {n theta_z_Value pn {?z value} unit_magnitude Rotation state {[check_state_inv {Plane_strain Plane_stress Solids}]} v 0.0 units deg}" f="1"/>
#
# <a n="gid_groups_conds::addF" a="{$n3} group {n {Self weight load Auto}}" f="1"/>
# <a n="change_group_properties" pn="Change group properties to group Self weight load Auto - type = BC" a="{{Self weight load Auto}} type BC" f="1"/>
# <a n="gid_groups_conds::setAttributesF" pn="setattributes" a="{container[@n='loadcases']/blockdata[@n='loadcase'][1]} {active 1}" f="1"/>
#
# </gidpost_batch>
proc svgml::parse_props { content accept_add line } {
set props ""
if { !$accept_add } {
set rex {()\m([a-zA-Z][-\w]*)\s*:([^;]*);}
} else {
set rex {(\+)?\m([a-zA-Z][-\w]*)\s*:([^;]*);}
}
set c 0
foreach "allI addI nI vI" [regexp -inline -all -indices $rex $content] {
foreach i [list add n v] {
set $i [string range $content {*}[set ${i}I]]
}
regsub -all {(?i)(^|[^\\])\\003B} $v {\1;} v
regsub -all {(?i)\\(\\003B)} $v {\1} v
if { !$accept_add } {
lappend props $n $v
} else {
lappend props $add $n $v
}
set prev [string range $content $c [lindex $allI 0]-1]
if { [regexp {\w+} $prev] } {
error "error with data '$prev' --- $line"
}
set c [expr {[lindex $allI 1]+1}]
}
set prev [string range $content $c end]
if { [regexp {\w+} $prev] } {
error "error with data '$prev' --- $line"
}
return $props
}
proc svgml::append_line { d_name id line content } {
upvar $d_name d
dict set d ids $id line $line
dict set d ids $id props [parse_props $content 0 $line]
}
proc svgml::set_error { d id txt } {
error "error: $txt --- line:[dict get $d ids $id line]"
}
proc svgml::give_prop { d id name } {
if { ![dict exists $d ids $id props $name] } {
set_error $d $id "property '$name' does not exist"
}
return [dict get $d ids $id props $name]
}
proc svgml::give_propD { d id name default } {
if { ![dict exists $d ids $id props $name] } {
return $default
}
return [dict get $d ids $id props $name]
}
proc svgml::bbox_to_points { bbox } {
lassign $bbox x y w h
return [list "$x $y" [list [expr {$x+$w}] [expr {$y+$h}]]]
}
proc svgml::add_to_bbox { id bbox } {
variable d
if { [dict exists d ids $id bbox] } {
set pnts ""
lappend pnts {*}[bbox_to_points [dict get d ids $id bbox]]
lappend pnts {*}[bbox_to_points $bbox]
foreach pnt $pnts {
if { ![info exists x0] || [lindex $pnt 0]<$x0 } { set x0 [lindex $pnt 0] }
if { ![info exists y0] || [lindex $pnt 1]<$y0 } { set y0 [lindex $pnt 1] }
}
foreach pnt $pnts {
if { ![info exists w] || [lindex $pnt 0]-$x0 > $w } {
set w [expr {[lindex $pnt 0]-$x0}]
}
if { ![info exists h] || [lindex $pnt 1]-$y0 > $h } {
set h [expr {[lindex $pnt 1]-$y0}]
}
}
set bbox [list $x0 $y0 $w $h]
}
dict set d ids $id bbox $bbox
}
proc svgml::rotate_angles { anglexy anglez } {
set anglexy_R [expr {$m::degtorad*($anglexy+90.0)}]
set anglez_R [expr {-1.0*$m::degtorad*($anglez-90.0)}]
set a [m::quaternion::rotation [list 0.0 0.0 1.0] $anglexy_R]
set newaxis [m::quaternion::rotation [list 1.0 0.0 0.0] $anglez_R]
set rotation_vector [m::quaternion::multiply $a $newaxis]
return [m::quaternion::normalizeP $rotation_vector 6]
}
proc svgml::is_number { text } {
if { [scan $text "%f %n" number len] == 0 } { return 0 }
if { ![info exists len] } { return 0 }
if { $len != [string length $text] } { return 0 }
return 1
}
# x,y where values are: -1,0,1
proc svgml::give_anchor_axes { d id } {
set anchor [split [give_propD $d $id anchor ""] ""]
lassign "0 0" x y
if { "w" in $anchor && "e" in $anchor } {
set x 0
} elseif { "w" in $anchor } {
set x 1
} elseif { "e" in $anchor } {
set x -1
}
if { "n" in $anchor && "s" in $anchor } {
set y 0
} elseif { "n" in $anchor } {
set y 1
} elseif { "s" in $anchor } {
set y -1
}
return [list $x $y]
}
proc svgml::split_text { text } {
set ret ""
if { [regexp {\n} $text] } {
set iline 0
foreach line [split $text \n] {
set retL [split_text $line]
if { $iline > 0 && [llength $retL] } {
lset retL 0 0 [list {*}[lindex $retL 0 0] newline]
}
incr iline
lappend ret {*}$retL
}
} elseif { [regexp -indices {[~^*_]{1,2}} $text idxs] } {
set v [string range $text {*}$idxs]
set c [expr {[lindex $idxs 1]+1}]
set rex "\\[string index $v 0]\{[string length $v]\}"
if { ![regexp -start $c -indices $rex $text idxsN] } {
return [list [list "" $text]]
}
set str [string range $text 0 [lindex $idxs 0]-1]
set retL [split_text $str]
lappend ret {*}$retL
set types [list {~ sub} {^ sup} {* italic} {_ italic} {** bold} {__ bold}]
set ipos [lsearch -index 0 -exact $types $v]
set type [lindex $types $ipos 1]
set str [string range $text $c [lindex $idxsN 0]-1]
set retL [split_text $str]
foreach i $retL {
lset i 0 [list {*}[lindex $i 0] $type]
lappend ret $i
}
set str [string range $text [lindex $idxsN 1]+1 end]
set retL [split_text $str]
lappend ret {*}$retL
} elseif { [string length $text] } {
lappend ret [list "" $text]
}
return $ret
}
proc svgml::xml_quote { text } {
set map [list "<" "<" ">" ">" "&" "&"]
return [string map $map $text]
}
proc svgml::append_tspans { x text } {
regsub -all {[ \t]+} $text { } text
regsub -all {[ \t]*\n[ \t]*} $text "\n" text
set xml ""
foreach i [svgml::split_text $text] {
lassign $i types txt
append xml "<tspan"
set st ""
foreach type $types {
switch $type {
newline { append xml " x='$x' dy='1.2em'" }
sub { append st "font-size:65%;baseline-shift:sub;" }
sup { append st "font-size:65%;baseline-shift:sup;" }
italic { append st "font-style:italic;" }
bold { append st "font-weight:bold;" }
}
}
if { $st ne "" } {
append xml " style='$st'"
}
append xml ">[xml_quote $txt]</tspan>"
}
return $xml
}
proc svgml::create { txt } {
variable d
variable xml
#################################################################################
# initial parsing by lines
#################################################################################
lassign "" d line
dict set d classes ""
foreach ln [split $txt \n] {
regsub -all {<!--.*? -->} $ln {} ln
if { [regexp {(.*[^\\])\\\s*$} $ln {} prefix] } {
append line $prefix
continue
} else {
append line $ln
}
if { [regexp {^\s*\+svgml(\S+)\s+(.*)} $line {} version content] } {
append_line d 0 $line $content
dict set d version $version
set width [give_prop $d 0 width]
set height [give_prop $d 0 height]
if { [regexp {(\d+)%} $height {} p] } {
set height [expr {int($p/100.0*$width)}]
}
dict set d ids __ROOT bbox [list 0 0 100 100]
dict set d ids __ROOT props ""
dict set d ids 0 bbox [list 0 0 $width $height]
dict set d ids 0 bboxL [dict get $d ids 0 bbox]
dict set d ids 0 angle 0
} elseif { [regexp {^\s*\+alias\s+(\S.*)} $line {} content] } {
foreach "long short" [parse_props $content 0 $line] {
dict set d alias $short $long
}
} elseif { [regexp {^\s*\+variables\s+(\S.*)} $line {} content] } {
foreach "add n v" [parse_props $content 1 $line] {
if { $add ne "" } {
set vOld [dict get $d variables $n]
append vOld $v
dict set d variables $n $vOld
} elseif { [dict exists $d variables $n] } {
error "repeated variable '$line'"
} else {
dict set d variables $n $v
}
}
} elseif { [regexp {^\s*(\w\S*)\s+(\w+)\s+(\S.*)} $line {} id cmd content] } {
if { [dict exists $d ids $id] } {
set_error $d $id "repeated id in line"
}
append_line d $id $line $content
dict set d ids $id cmd $cmd
dict set d ids_short [lindex [split $id .] end] $id
} elseif { [regexp {^\s*\.(\S+)\s+(\S.*)} $line {} class content] } {
dict set d classes $class $content
} elseif { ![regexp {^\s*$|^\s*#} $line] } {
error "unknown line '$line'"
}
set line ""
}
#################################################################################
# substitute alias and variables
#################################################################################
foreach id [dict keys [dict get $d ids]] {
set p ""
foreach "n v" [dict get $d ids $id props] {
set n [dict_getd $d alias $n $n]
if { [regexp {^\s*:(\w[-\w]*)} $v {} variable] } {
if { ![dict exists $d variables $variable] } {
set_error $d $id "unknown variable '$variable'"
}
set v [dict get $d variables $variable]
}
set v [subst -nocommands -novariables $v]
lappend p $n $v
}
dict set d ids $id props $p
}
#################################################################################
# header
#################################################################################
if { ![dict exists $d ids 0] } {
error "there is no svgml header"
}
lassign [dict get $d ids 0 bbox] - - width height
set xmlH "<?xml version='1.0' encoding='UTF-8' standalone='no'?>\n"
append xmlH "<svg xmlns='http://www.w3.org/2000/svg' "
append xmlH "xmlns:xlink='http://www.w3.org/1999/xlink' version='1.1' "
append xmlH "width='$width' height='$height'>\n"
append xmlH "<!--created with svgml-RamDebugger <http://www.compassis.com/ramdebugger>-->"
append xmlH "<defs>\n"
set stP "stroke:#000000;stroke-width:1pt;fill:#000000;"
append xmlH "<marker orient='auto' refY='0.0' refX='-4.5' id='TriangleInL' style='overflow:visible'>\n"
append xmlH "<path d='M 4.5,0.0 L -2.3,4.0 L -2.3,-4.0 L 4.5,0.0 z' "
append xmlH "fill='context-stroke' stroke='context-stroke' style='$stP' transform='scale(-1.0)'/>\n"
append xmlH "</marker>\n"
append xmlH "<marker orient='auto' refY='0.0' refX='4.5' id='TriangleOutL' style='overflow:visible'>\n"
append xmlH "<path d='M 4.5,0.0 L -2.3,4.0 L -2.3,-4.0 L 4.5,0.0 z' "
append xmlH "fill='context-stroke' stroke='context-stroke' style='$stP'/>\n"
append xmlH "</marker>\n"
append xmlH "<marker orient='auto' refY='0.0' refX='0.0' id='circle' style='overflow:visible'>\n"
append xmlH "<circle cx='0.0' cy='0' r='1.5' "
append xmlH "fill='context-stroke' stroke='context-stroke' style='$stP'/>\n"
append xmlH "</marker>\n"
append xmlH "<filter id='shadow' x='-20%' y='-20%' width='140%' height='140%'>"
append xmlH "<feGaussianBlur stdDeviation='2 2' result='shadow'/>"
append xmlH "<feOffset dx='6' dy='6'/>"
append xmlH "</filter>"
append xmlH "<filter id='glow' x='-30%' y='-30%' width='160%' height='160%'>"
append xmlH "<feGaussianBlur stdDeviation='10 10' result='glow'/>"
append xmlH "<feMerge>"
append xmlH "<feMergeNode in='glow'/>"
append xmlH "<feMergeNode in='glow'/>"
append xmlH "<feMergeNode in='glow'/>"
append xmlH "</feMerge>"
append xmlH "</filter>"
dict for "class content" [dict get $d classes] {
set c ""
foreach contentI [split $content ";"] {
if { $contentI eq "" } { continue }
lassign [split $contentI :] n v
if { $n eq "fill" && [regexp {radial-gradient\((.*)\)} $v {} vs] } {
lassign [split $vs ,] color1 color2
if { ![info exists radial_gradient] } {
set radial_gradient 1
} else {
incr radial_gradient
}
set id radial_gradient$radial_gradient
append xmlH "<radialGradient id='$id' cx='50%' cy='50%' r='50%' fx='50%' fy='50%'>\n"
append xmlH "<stop offset='0%' style='stop-color:$color1;stop-opacity:0' />\n"
append xmlH "<stop offset='100%' style='stop-color:$color2;stop-opacity:1' />\n"
append xmlH "</radialGradient>\n"
set v "url(#$id)"
}
append c "$n:$v;"
}
dict set d classes $class $c
}
append xmlH "</defs>\n"
#################################################################################
# loop on entities. The tries are here to solve dependencies of dependencies
#################################################################################
for { set i_try 0 } { $i_try < 10 } { incr i_try } {
set xml $xmlH
dict set d needs_recalculate 0
dict for "id ent" [dict get $d ids] {
if { $id in "0 __ROOT" } { continue }
if 1 { puts "$i_try [dict get $ent line]" }
set ret [catch { create_entity $id "" } str opts]
if { $ret != 0 && $ret != 4 } {
error $str [dict get $opts -errorinfo]
} elseif { $ret == 4 } {
dict set d needs_recalculate 1
}
}
if { ![dict get $d needs_recalculate] } {
break
}
}
append xml "</svg>\n"
return $xml
}
proc svgml::resolve_id { id id_from } {
variable d
if { $id eq "" } { return 0 }
if { ![dict exists $d ids $id] && [dict exists $d ids_short $id] } {
set id [dict get $d ids_short $id]
}
if { ![dict exists $d ids $id] } {
set_error $d $id_from "unknown id #$id"
}
return $id
}
proc svgml::calculate_parent { id } {
variable d
set parent [join [lrange [split $id .] 0 end-1] "."]
return [resolve_id $parent $id]
}
proc svgml::copy_operation { id pnt npoint copy_info } {
variable d
set cmd [dict get $d ids $id cmd]
set c [dict_getd $copy_info operations ""]
lassign $pnt n x y z parameters
set p [list $x $y]
set p_prev $p
if { $n ni "z Z" } {
for { set i 0 } { $i < [llength $c] } { incr i } {
set cI [lindex $c $i]
if { [dict size [dict get $cI delta_points]] } {
set dist_max 0.0
set deltas ""
dict for "pL vL" [dict get $cI delta_points] {
set dist [m::norm_two [m::sub $p $pL]]
lappend deltas $dist $vL
if { $dist > $dist_max } {
set dist_max $dist
}
}
set delta "0 0"
set fac_tot 0.0
foreach "dist v" $deltas {
set fac [expr {($dist_max-$dist)**3}]
set delta [m::axpy $fac $v $delta]
set fac_tot [expr {$fac_tot+$fac}]
}
if { $fac_tot != 0 } {
set delta [m::scale [expr {1.0/$fac_tot}] $delta]
}
} else {
set delta [dict get $cI delta]
}
set p [m::add $p $delta]
if { $i < [llength $c]-1 } {
set p_prev [m::add $p_prev $delta]
}
}
}
if { [dict get $copy_info connect] ne "" && $cmd ne "copy" } {
regsub -all {\.} [dict get $copy_info id] _ idF
set idC __copy_${idF}_${npoint}_[llength $c]
set pList ""
if { [dict get $copy_info connect] eq "points" } {
if { $n in "point M L l A a" } {
set pList "point:#__ROOT,[join $p_prev ,],#__ROOT,[join $p ,];"
}
} elseif { [dict get $copy_info connect] eq "lines" } {
set ok "point M L l A a z Z"
if { $n in $ok && [dict exists $d prev_copy_info $idF] && $npoint > 0 } {
set c [dict_getd $d prev_copy_info $idF ""]
if { $n in "point M L l A a" } {
lappend c [list $n $p_prev $p $pnt]
} else {
lappend c [dict get $d prev_copy_info0 $idF]
}
set pList "point:"
set idx 0
foreach i $c {
lassign $i nL p_prevL pL pntL
if { $idx == 0 || $nL in "point M" } {
append pList #__ROOT,[join $p_prevL ,],
} else {
append pList "#__ROOT,$nL,"
if { [lindex $pntL 4] ne "" } {
append pList "[join [lindex $pntL 4] ,],"
}
append pList "[join $p_prevL ,],"
}
incr idx
}
lassign "" nL_prev pnt_prevL
foreach i [lreverse $c] {
lassign $i nL p_prevL pL pntL
if { $idx == 0 || $nL in "point M" } {
append pList #__ROOT,[join $pL ,],
} else {
append pList "#__ROOT,$nL,"
if { [lindex $pnt_prevL 4] ne "" } {
set params [lindex $pnt_prevL 4]
lset params 3 [expr {([lindex $params 3])?0:1}]
append pList "[join $params ,],"
}
append pList "[join $pL ,],"
}
set nL_prev $nL
set pnt_prevL $pntL
incr idx
}
append pList "z;"
set c [lrange $c end end]
dict set d prev_copy_info $idF $c
} elseif { $n ni "z Z" } {
if { $npoint == 0 } {
dict set d prev_copy_info0 $idF [list $n $p_prev $p $pnt]
set c ""
} else {
set c [dict_getd $d prev_copy_info $idF ""]
}
lappend c [list $n $p_prev $p $pnt]
dict set d prev_copy_info $idF $c
}
}
if { $pList ne "" } {
set content "$pList"
if { [dict get $copy_info style_name] ne "" } {
append content " class:[dict get $copy_info style_name];"
}
set line "$idC line $content"
if { ![dict exists $d ids $idC] } {
append_line d $idC $line $content
dict set d ids $idC cmd line
dict set d needs_recalculate 1
}
}
}
return [lreplace $pnt 1 2 {*}$p]
}
proc svgml::process_cube { id what args } {
variable d
lassign [dict get $d ids $id bbox] x0 y0 w h
set pnts [dict get $d ids $id pnts]
set angles [give_propD $d $id angles "45deg,45deg"]
set anglesList [split $angles ","]
if { [llength $anglesList] != 2 } {
set_error $d $id "properties angles must be: angles:45deg,45deg;"
}
set anglesN ""
foreach a $anglesList {
if { [regexp {^\s*([-+\d.e]+)\s*deg\s*$} $a {} value] } {
lappend anglesN $value
} elseif { [regexp {^\s*([-+\d.e]+)\s*rad\s*$} $a {} value] } {
lappend anglesN [expr {$m::radtodeg*$value}]
} else {
set_error $d $id "properties angles must be: angles:45deg,45deg;"
}
}
set q [svgml::rotate_angles {*}$anglesN]
set ipos [lsearch -index 0 $pnts "width-height"]
set height ""
if { $ipos != -1 } {
set height [lindex $pnts $ipos 3]
}
if { $height eq "" } {
set height $w
}
set point_to_axes {{0 0 0} {1 0 0} {1 1 0} {0 1 0} {0 0 1} {1 0 1} {1 1 1} {0 1 1}}
set face_to_points {{0 1 2 3} {0 4 5 1} {1 2 6 5} {3 7 6 2} {0 3 7 4} {4 5 6 7}}
set ariste_to_points {{0 1} {1 2} {3 2} {0 3} {0 4} {1 5} {2 6} {3 7} {4 5} {5 6} {7 6} {4 7}}
set face_to_normal {2 1 0 1 0 2}
set face_to_normal_prev_next {0 0 1 1 0 1}
set p0 [list [expr {$x0+0.5*$w}] [expr {$y0+0.5*$h}]]
if { $what eq "faces" } {
set idx_faces [list 0 1 4 2 3 5]
set faces ""
foreach idx_face $idx_faces {
set face "$idx_face"
set center_face "0 0"
for { set i 0 } { $i < 4 } { incr i } {
set idx_point [lindex $face_to_points $idx_face $i]
set vL [lindex $point_to_axes $idx_point]
set xL [expr {(-1+2*[lindex $vL 0])*0.5*$w}]
set yL [expr {(-1+2*[lindex $vL 1])*0.5*$h}]
set zL [expr {[lindex $vL 2]*$height}]
set v [m::matmul [m::transpose [m::quaternion::matrix $q]] [list $xL $yL $zL]]
set v [list [lindex $v 0] [expr {-1*[lindex $v 1]}]]
set pnt [m::add $p0 $v]
lappend face $pnt
set center_face [m::axpy 0.25 $pnt $center_face]
}
lappend faces $face
}
return $faces
} elseif { $what eq "draw_labels" } {
set xml ""
if { [lindex $args 0] in "face all" } {
for { set idx_face 0 } { $idx_face < 6 } { incr idx_face } {
set center_face "0 0"
for { set i 0 } { $i < 4 } { incr i } {
set idx_point [lindex $face_to_points $idx_face $i]
set vL [lindex $point_to_axes $idx_point]
set xL [expr {(-1+2*[lindex $vL 0])*0.5*$w}]
set yL [expr {(-1+2*[lindex $vL 1])*0.5*$h}]
set zL [expr {[lindex $vL 2]*$height}]
set v [m::matmul [m::transpose [m::quaternion::matrix $q]] [list $xL $yL $zL]]
set v [list [lindex $v 0] [expr {-1*[lindex $v 1]}]]
set pnt [m::add $p0 $v]
set center_face [m::axpy 0.25 $pnt $center_face]
}
lassign $center_face x y
append xml [format "<text x='%.4g' y='%.3g' style='fill: red;'>" $x $y]
append xml "[expr {$idx_face+1}]</text>"
set style "stroke-width: 1.0px; stroke: black;fill:none;marker-end:url(#TriangleOutL);"
set styleT "font-size: 18px; fill: black; font-family: sans-serif;"
set pnt [process_cube $id face [expr {$idx_face+1}] 70 50]
set pnt [m::add $center_face [m::scale 50 [m::unitLengthVector [m::sub $pnt $center_face]]]]
append xml "<path d='M$center_face L$pnt' style='$style'/>"
append xml [format "<text x='%.3g' y='%.3g' style='%s'>x'</text>" \
[lindex $pnt 0] [lindex $pnt 1] $styleT]
set pnt [process_cube $id face [expr {$idx_face+1}] 50 70]
set pnt [m::add $center_face [m::scale 50 [m::unitLengthVector [m::sub $pnt $center_face]]]]
append xml "<path d='M$center_face L$pnt' style='$style'/>"
append xml [format "<text x='%.3g' y='%.3g' style='%s'>y'</text>" \
[lindex $pnt 0] [lindex $pnt 1] $styleT]
}
}
if { [lindex $args 0] in "ariste all" } {
for { set idx_ariste 0 } { $idx_ariste < 12 } { incr idx_ariste } {
set center_ariste "0 0"
for { set i 0 } { $i < 2 } { incr i } {
set idx_point [lindex $ariste_to_points $idx_ariste $i]
set vL [lindex $point_to_axes $idx_point]
set xL [expr {(-1+2*[lindex $vL 0])*0.5*$w}]
set yL [expr {(-1+2*[lindex $vL 1])*0.5*$h}]
set zL [expr {[lindex $vL 2]*$height}]
set v [m::matmul [m::transpose [m::quaternion::matrix $q]] [list $xL $yL $zL]]
set v [list [lindex $v 0] [expr {-1*[lindex $v 1]}]]
set pnt [m::add $p0 $v]
set center_ariste [m::axpy 0.5 $pnt $center_ariste]
}
lassign $center_ariste x y
append xml [format "<text x='%.3g' y='%.3g' style='fill: blue;'>" $x $y]
append xml "[expr {$idx_ariste+1}]</text>"
}
}
if { [lindex $args 0] in "vertex all" } {
for { set idx_point 0 } { $idx_point < 8 } { incr idx_point } {
set vL [lindex $point_to_axes $idx_point]
set xL [expr {(-1+2*[lindex $vL 0])*0.5*$w}]
set yL [expr {(-1+2*[lindex $vL 1])*0.5*$h}]
set zL [expr {[lindex $vL 2]*$height}]
set v [m::matmul [m::transpose [m::quaternion::matrix $q]] [list $xL $yL $zL]]
set v [list [lindex $v 0] [expr {-1*[lindex $v 1]}]]
set pnt [m::add $p0 $v]
lassign $pnt x y
append xml [format "<text x='%.3g' y='%.3g' style='fill: green;'>" $x $y]
append xml "[expr {$idx_point+1}]</text>"
}
}
return $xml
} elseif { $what eq "face" } {
lassign $args idx_face x y z
incr idx_face -1
set x [expr {$x/100.0}]
set y [expr {$y/100.0}]
set z [expr {($z eq "")?0:$z/100.0}]
lappend p0 0.0
set face ""
for { set i 0 } { $i < 4 } { incr i } {
set idx_point [lindex $face_to_points $idx_face $i]
set vL [lindex $point_to_axes $idx_point]
set xL [expr {(-1+2*[lindex $vL 0])*0.5*$w}]
set yL [expr {(-1+2*[lindex $vL 1])*0.5*$h}]
set zL [expr {[lindex $vL 2]*$height}]
set v [m::matmul [m::transpose [m::quaternion::matrix $q]] [list $xL $yL $zL]]
set v [list [lindex $v 0] [expr {-1*[lindex $v 1]}] [lindex $v 2]]
set pnt [m::add $p0 $v]
lappend face $pnt
}
set normal [m::vector_normal_triangle {*}[lrange $face 0 2]]
set sign [expr {([lindex $face_to_normal_prev_next $idx_face]==1)?-1:1}]
set normal [m::scale [expr {$sign*$w}] [m::unitLengthVector $normal]]
set dx [m::scale $x [m::sub [lindex $face 1] [lindex $face 0]]]
set dy [m::scale $y [m::sub [lindex $face 3] [lindex $face 0]]]
set dz [m::scale $z $normal]
set p [m::add [lindex $face 0] [m::add $dx [m::add $dy $dz]]]
return [lrange $p 0 1]
} elseif { $what eq "vertex" } {
lappend p0 0.0
lassign $args idx_point
incr idx_point -1
set vL [lindex $point_to_axes $idx_point]
set xL [expr {(-1+2*[lindex $vL 0])*0.5*$w}]
set yL [expr {(-1+2*[lindex $vL 1])*0.5*$h}]
set zL [expr {[lindex $vL 2]*$height}]
set v [m::matmul [m::transpose [m::quaternion::matrix $q]] [list $xL $yL $zL]]
set v [list [lindex $v 0] [expr {-1*[lindex $v 1]}] [lindex $v 2]]
set pnt [m::add $p0 $v]
return [lrange $pnt 0 1]
}
}
proc svgml::get_geometry_point { id vertex_ariste_face pntsG num args } {
variable d
if { [dict get $d ids $id cmd] eq "cube" } {
return [process_cube $id $vertex_ariste_face $num {*}$args]
} else {
if { $vertex_ariste_face eq "face" } {
set_error $d $id "face only allowed for 'cube'"
}
if { $vertex_ariste_face eq "ariste" } {
if { [lindex $args 0] ne "normal" } {
set coord [expr {[lindex $args 0]/100.0}]
}
}
set idx 1
set pnts [dict_getd $d ids $id pnts ""]
for { set i 0 } { $i < [llength $pnts] } { incr i } {
lassign [lindex $pnts $i] type x y
if { $type in "z Z q Q c C C2" } { continue }
if { $num == $idx } {
if { $vertex_ariste_face eq "vertex" } {
return [list $x $y]
} else {
set i_next $i
for { set i_try 0 } { $i_try < 3 } { incr i_try } {
if { $i_next < [llength $pnts]-1 } {
set i_next [expr {$i_next+1}]
} else {
set i_next 0
}
if { [lindex $pnts $i_next] ni "z Z" } {
break
}
}
lassign [lindex $pnts $i_next] type_n x_n y_n
if { $type_n in "Q C" } {
if { [lindex $args 0] eq "normal" } {
set_error $d $id "not implemented ariste,n,normal in quadratic or cubic path"
}
set bpnts [list $x $y $x_n $y_n]
if { $type_n in "C" } {
lassign [lindex $pnts $i_next] type_n x_n y_n z_n xC yC zC
lappend bpnts $xC $yC
}
set i_next2 $i_next
for { set i_try 0 } { $i_try < 3 } { incr i_try } {
if { $i_next2 < [llength $pnts]-1 } {
set i_next2 [expr {$i_next2+1}]
} else {
set i_next2 0
}
if { [lindex $pnts $i_next2] ni "z Z" } {
break
}
}
lassign [lindex $pnts $i_next2] type_n2 x_n2 y_n2
if { $type_n2 ne "point" } { error "aa $type_n2" }
lappend bpnts $x_n2 $y_n2
if { $type_n in "Q" } {
set pnt [m::eval_quadratic_bezier {*}$bpnts $coord]
} else {
set pnt [m::eval_cubic_bezier {*}$bpnts $coord]
}
} else {
if { [lindex $args 0] eq "normal" } {
lassign [lindex $pntsG end] typeP xP yP
set v [m::sub "$x $y" "$xP $yP"]
set t [m::sub "$x_n $y_n" "$x $y"]
set n [list [expr {-1*[lindex $t 1]}] [lindex $t 0]]
set n0 [m::unitLengthVector $n]
set dot [m::dotproduct $v $n0]
set pnt [m::axpy $dot $n0 "$xP $yP"]
} else {
set pnt [m::eval_linear $x $y $x_n $y_n $coord]
}
}
if { [llength $args] > 1 } {
set t [m::sub "$x_n $y_n" "$x $y"]
set n [list [expr {-1*[lindex $t 1]}] [lindex $t 0]]
set coordY [expr {[lindex $args 1]/100.0}]
set pnt [m::axpy $coordY $n $pnt]
}
return $pnt
}
}
incr idx
}
}
if { $num <= 0 || $num > [llength $pnts] } {
set_error $d $id "incorrect point num must be >0 <npoints"
return
}
set_error $d $id "incorrect point"
}
proc svgml::transform { pnt type bboxPx bboxPy bboxPz } {
lassign $pnt x y z
if { $type in "point M L C Q A" } {
set x [expr {[lindex $bboxPx 0]+$x/100.0*[lindex $bboxPx 2]}]
set y [expr {[lindex $bboxPy 1]+$y/100.0*[lindex $bboxPy 3]}]
if { $z ne "" } {
set z [expr {[lindex $bboxPz 0]+$z/100.0*[lindex $bboxPz 2]}]
}
} else {
set x [expr {$x/100.0*[lindex $bboxPx 2]}]
set y [expr {$y/100.0*[lindex $bboxPy 3]}]
if { $z ne "" } {
set z [expr {$z/100.0*[lindex $bboxPz 2]}]
}
}
return [list $x $y $z]
}
proc svgml::calculate_points { id copy_info } {
variable d
set parent [calculate_parent $id]
set pnts ""
foreach "n v" [dict get $d ids $id props] {
if { $n ni "point delta-point width-height" } { continue }
#puts "---calculate_points $n --- $v"
set parentL $parent
set pnt ""
set nL $n
set parents ""
set calculate_type ""
set vList [split $v ,]
for { set i 0 } { $i < [llength $vList] } { incr i } {
set c [string trim [lindex $vList $i]]
if { [regexp {^#(\S+)$} $c {} idP] } {
set parentL [resolve_id $idP $id]
} elseif { [regexp {^([-+\d.]+)$} $c {} value] } {
lappend pnt $value
lappend parents $parentL
} elseif { [regexp {^normal$} $c value] } {
lappend pnt $value
lappend parents $parentL
} elseif { [regexp {^[mMCcqQzZlL]$} $c] } {
set nL $c
} elseif { [regexp {^[aA]$} $c] } {
set nL $c
set parameters [lrange $vList $i+1 $i+5]
incr i 5
continue
} elseif { [regexp {^AA$} $c] } {
set nL $c
set parameters [lrange $vList $i+1 $i+1]
incr i 1
continue
} elseif { [regexp {vertex|ariste|face} $c] } {
set calculate_type $c
} else {
set_error $d $id "incorrect format '$n:$v'"
}
if { $nL in "z Z" } {
lappend pnts [list z]
if { [dict size $copy_info] } {
lassign [copy_operation $id [list $nL "" ""] [llength $pnts] $copy_info]
}
continue
}
if { $calculate_type eq "vertex" } {
if { [llength $pnt] < 1 } {
continue
}
} elseif { $calculate_type eq "ariste" } {
if { [llength $pnt] < 2 } {
continue
}
if { [llength $pnt] == 2 && $i == [llength $vList]-2 &&
[is_number [lindex $vList $i+1]] } {
continue
}
} elseif { $calculate_type eq "face" } {
if { [llength $pnt] < 3 } {
continue
}
if { [llength $pnt] == 3 && $i == [llength $vList]-2 &&
[is_number [lindex $vList $i+1]] } {
continue
}
} elseif { $nL eq "width-height" && [llength $vList] == 3 && \
[llength $pnt] < 3 } {
continue
} elseif { [llength $pnt] < 2 } {
continue
}
lassign $pnt x y z
if { $calculate_type in "vertex ariste face" } {
if { ![dict exists $d ids $parentL bbox] } {
if { ![dict exists $d ids $parentL] } {
error "error: unknown parent id #$parentL for id #$id"
}
return -code continue
}
lassign [get_geometry_point $parentL $calculate_type $pnts {*}$pnt] x y
set calculate_type ""
} else {
foreach parentL $parents {
if { ![dict exists $d ids $parentL bbox] } {
if { ![dict exists $d ids $parentL] } {
error "error: unknown parent id #$parentL for id #$id"
}
return -code continue
}
}
set bboxPx [dict get $d ids [lindex $parents 0] bbox]
set bboxPy [dict get $d ids [lindex $parents 1] bbox]
if { $z ne "" } {
set bboxPz [dict get $d ids [lindex $parents 2] bbox]
} else {
set bboxPz ""
}
lassign [transform "$x $y $z" $nL $bboxPx $bboxPy $bboxPz] x y z
if { $nL in "a A" } {
lassign $parameters rx ry x-axis-rotation large-arc-flag sweep-flag
set rx [expr {$rx/100.0*[lindex $bboxPx 2]}]
set ry [expr {$ry/100.0*[lindex $bboxPx 3]}]
set parameters [list $rx $ry ${x-axis-rotation} ${large-arc-flag} ${sweep-flag}]
} elseif { $nL in "AA" } {
lassign $parameters r
set r [expr {$r/100.0*[lindex $bboxPx 2]}]
set parameters [list $r]
}
}
if { [lindex $pnts end 0] eq "C" } {
set nL C2
} elseif { [lindex $pnts end 0] eq "c" } {
set nL c2
}
set pnt [list $nL $x $y]
if { $z ne "" } {
lappend pnt $z
}
if { $nL in "a A AA" } {
if { $z eq "" } {
lappend pnt 0
}
lappend pnt $parameters
}
if { $nL in "point m M L C C2 Q A AA" && [dict size $copy_info] } {
set pnt [copy_operation $id $pnt [llength $pnts] $copy_info]
}
lappend pnts $pnt
set pnt ""
set nL $n
set parentL $parent
set parents ""
}
if { [llength $pnt] == 1 } {
set_error $d $id "bad number of components '$n:$v'"
}
}
#################################################################################
# converting AA to A
#################################################################################
for { set i 0 } { $i < [llength $pnts] } { incr i } {
lassign [lindex $pnts $i] type x y
if { $type ne "AA" } { continue }
lassign [lindex $pnts $i] type x2 y2 z parameters
lassign $parameters r
lassign [lindex $pnts $i-1] - x1 y1
lassign [lindex $pnts $i+1] - x3 y3
set p12 [m::sub "$x1 $y1" "$x2 $y2"]
set p32 [m::sub "$x3 $y3" "$x2 $y2"]
set norm12 [m::norm $p12]
set norm32 [m::norm $p32]
set angle [expr {acos([m::dotproduct $p12 $p32]/($norm12*$norm32))}]
set L [expr {$r/tan($angle/2.0)}]
set alpha [expr {$L/$norm12}]
set p1_n [m::axpy $alpha $p12 "$x2 $y2"]
set alpha [expr {$L/$norm32}]
set p2_n [m::axpy $alpha $p32 "$x2 $y2"]
set sweep_flag 0
set p12_3D [list {*}$p12 0]
set p32_3D [list {*}$p32 0]
set cross [m::crossproduct $p12_3D $p32_3D]
if { [lindex $cross 2] < 0 } {
set sweep_flag 1
}
lset pnts $i [list point {*}$p1_n]
set pnts [linsert $pnts $i+1 [list A {*}$p2_n 0 [list $r $r 0 0 $sweep_flag]]]
}
#################################################################################
# storing pnts
#################################################################################
if { [dict size $copy_info] == 0 } {
dict set d ids $id pnts $pnts
} else {
set idC [dict get $copy_info id]
set pntsO [dict_getd $idC pnts ""]
lappend pntsO {*}$pnts
dict set d ids $idC pnts $pnts
}
return $pnts
}
proc svgml::give_descendants { id id_avoid } {
variable d
set idsList ""
set idL [split $id "."]
set n [expr {[llength $idL]-1}]
foreach idC [dict keys [dict get $d ids]] {
if { $idC eq $id_avoid } { continue }
set idCL [split $idC "."]
if { [llength $idCL] <= [llength $idL] } { continue }
if { [lrange [split $idC "."] 0 $n] eq $idL } {
lappend idsList $idC
}
}
return $idsList
}
proc pngsize_data { data } {
if {[string length $data] < 33} {
error "File not large enough to contain PNG header"
}
# Read PNG file signature
binary scan [string range $data 0 7] c8 sig
foreach b1 $sig b2 {-119 80 78 71 13 10 26 10} {
if {$b1 != $b2} {
error "data is not a PNG file"
}
}
# Read IHDR chunk signature
binary scan [string range $data 8 15] c8 sig
foreach b1 $sig b2 {0 0 0 13 73 72 68 82} {
if {$b1 != $b2} {
error "data is missing a leading IHDR chunk"
}
}
# Read off the size of the image
binary scan [string range $data 16 23] II width height
# Ignore the rest of the data, including the chunk CRC!
#binary scan [read $f 5] ccccc depth type compression filter interlace
#binary scan [read $f 4] I chunkCRC
return [list $width $height]
}
proc svgml::create_entity { id copy_info } {
variable d
variable xml
set ret [catch { calculate_points $id $copy_info } pnts opts]
if { $ret != 0 } {
return -code $ret -errorinfo \
[dict_getd $opts -errorinfo ""] $pnts
}
lassign [give_anchor_axes $d $id] anchorX anchorY
set pntsBBOX ""
foreach p $pnts {
lassign $p type x y
if { $type eq "width-height" } {
lassign $p - b h
if { [llength $pntsBBOX] } {
lassign [lindex $pntsBBOX end] x y
} else {
set ipos [lsearch -index 0 $pnts point]
if { $ipos == -1 } {
set_error $d $id "property 'width-height' needs a 'point'"
}
lassign [lindex $pnts $ipos] - x y
}
set a1x [expr {-0.5*(1.0-$anchorX)}]
set a2x [expr {0.5*(1.0+$anchorX)}]
set a1y [expr {-0.5*(1.0-$anchorY)}]
set a2y [expr {0.5*(1.0+$anchorY)}]
lappend pntsBBOX [list [expr {$x+$a1x*$b}] [expr {$y+$a1y*$h}]]
lappend pntsBBOX [list [expr {$x+$a2x*$b}] [expr {$y+$a2y*$h}]]
} elseif { $type in "point L C Q A" } {
lappend pntsBBOX [list $x $y]
} elseif { $type in "delta-point q l c a" && [llength $pntsBBOX] } {
lassign [lindex $pntsBBOX end] xp yp
set x [expr {$x+$xp}]
set y [expr {$y+$yp}]
lappend pntsBBOX [list $x $y]
}
}
lassign "" x0 y0 x1 y1
if { [llength $pntsBBOX] } {
foreach p $pntsBBOX {
lassign $p x y
if { $x0 eq "" || $x < $x0 } { set x0 $x }
if { $x1 eq "" || $x > $x1 } { set x1 $x }
if { $y0 eq "" || $y < $y0 } { set y0 $y }
if { $y1 eq "" || $y > $y1 } { set y1 $y }
}
set w [expr {$x1-$x0}]
set h [expr {$y1-$y0}]
set bbox [list $x0 $y0 $w $h]
} else {
set bbox ""
}
if { [dict size $copy_info] == 0 } {
dict set d ids $id bbox $bbox
} else {
add_to_bbox [dict get $copy_info id] $bbox
}
set style ""
foreach "n v" [dict get $d ids $id props] {
if { $n eq "class" } {
append style "[dict get $d classes $v]"
}
}
append style [dict_getd $copy_info style ""]
set cmd [dict get $d ids $id cmd]
switch $cmd {
region {
if { $bbox eq "" } {
set_error $d $id "region needs a box definition"
}
}
image {
lassign $bbox x0 y0 w h
set txt [give_propD $d $id text ""]
set err [catch { open $txt rb } fin]
if { $err } {
set_error $d $id "image '$txt' not found"
}
set data [read $fin]
close $fin
package require base64
set href "data:image/png;base64,[base64::encode $data]"
set preserveAspectRatio "xMinYMin"
if { [give_propD $d $id anchor ""] ne "" && $anchorX == 0 && $anchorY == 0 } {
set preserveAspectRatio "none"
}
append xml "<image x='$x0' y='$y0' width='$w' height='$h' id='$id' style='$style' "
append xml "xlink:href='$href' preserveAspectRatio='$preserveAspectRatio'/>"
if { [regexp {border-stroke-width:\s*((\d+)[^;]+)} $style {} value num] && $num > 0 } {
if { [regexp {border-stroke:\s*([^;]+)} $style {} s] } {
set stroke $s
} else {
set stroke black
}
set styleB "$style;stroke-width:$value;stroke:$stroke;fill:none;"
if { $preserveAspectRatio ne "none" } {
lassign [pngsize_data $data] width height
set r1 [expr {double($w)/$h}]
set r2 [expr {double($width)/$height}]
if { $r2 > $r1 } {
set h [expr {$h*$r1/$r2}]
} else {
set w [expr {$w*$r2/$r1}]
}
}
append xml "<rect x='$x0' y='$y0' width='$w' height='$h' "
append xml "id='$id-border' style='$styleB'/>"
}
if { [dict size $copy_info] == 0 } {
dict set d ids $id bboxL $bbox
dict set d ids $id angle 0
}
}
rect {
lassign $bbox x0 y0 w h
append xml "<rect x='$x0' y='$y0' width='$w' height='$h' id='$id' style='$style'"
if { [regexp {border-radius\s*:\s*(\d+)} $style {} r] } {
append xml " rx='$r' ry='$r'"
}
append xml "/>\n"
if { [dict size $copy_info] == 0 } {
dict set d ids $id bboxL $bbox
dict set d ids $id angle 0
}
}
circle {
lassign $bbox x0 y0 w h
set cx [expr {$x0+0.5*$w}]
set cy [expr {$y0+0.5*$h}]
set r [expr {0.5*$w}]
append xml "<circle cx='$cx' cy='$cy' r='$r' id='$id' style='$style'/>\n"
if { [dict size $copy_info] == 0 } {
dict set d ids $id bboxL $bbox
dict set d ids $id angle 0
}
}
cube {
set labels [give_propD $d $id labels ""]
if { $labels in [list "" 0] && [dict exists $copy_info labels] } {
set labels [dict get $copy_info labels]
}
if { $labels ne "" && $labels ne "0" } {
if { $labels ni "vertex ariste face" } {
set labels all
}
append xml [process_cube $id draw_labels $labels]
append style "fill:none;"
}
set faces [process_cube $id faces]
foreach face $faces {
set ds ""
for { set i 0 } { $i < [llength $face] } { incr i } {
if { $i == 0 } {
set idx_face [lindex $face $i]
continue
}
set pnt [lindex $face $i]
if { $ds eq "" } {
append ds "M$pnt"
} else {
append ds " L$pnt"
}
}
append ds "z"
append xml "<path d='$ds' id='$id-$idx_face' style='$style'/>\n"
}
if { [dict size $copy_info] == 0 } {
dict set d ids $id bboxL $bbox
dict set d ids $id angle 0
}
}
line {
set labels [give_propD $d $id labels ""]
if { $labels in [list "" 0] && [dict exists $copy_info labels] } {
set labels [dict get $copy_info labels]
}
if { $labels ne "" && $labels ne "0" } {
set labelsFlag 1
} else {
set labelsFlag 0
}
set labelsList [split $labels ,]
if { [llength $labelsList] < 2 } {
set labelsList ""
}
lassign "" ds type_prev pnts_text
for { set i 0 } { $i < [llength $pnts] } { incr i } {
lassign [lindex $pnts $i] type x y
if { $ds eq "" } {
append ds [format "M%.3g,%.3g" $x $y]
lappend pnts_text "$x $y"
} elseif { $type in "point L" && $type_prev in "q Q C c C2 c2" } {
append ds [format " %.3g,%.3g" $x $y]
lappend pnts_text "$x $y"
} elseif { $type in "point L M" } {
append ds [format " L%.3g,%.3g" $x $y]
lappend pnts_text "$x $y"
} elseif { $type in "delta-point l c2" && $type_prev in "q Q C c C2 c2" } {
append ds [format " %.3g,%.3g" $x $y]
set pnt [m::add [lindex $pnts_text end] "$x $y"]
lappend pnts_text $pnt
} elseif { $type in "delta-point l m" } {
append ds [format " l%.3g,%.3g" $x $y]
if { [llength $pnts_text] } {
set pnt [m::add [lindex $pnts_text end] "$x $y"]
} else {
set pnt "$x $y"
}
lappend pnts_text $pnt
} elseif { $type in "q Q" } {
append ds [format " %s%.3g,%.3g" $type $x $y]
} elseif { $type in "c C" } {
append ds [format " %s%.3g,%.3g" $type $x $y]
} elseif { $type in "C2" } {
append ds [format " %.3g,%.3g" $x $y]
} elseif { $type in "a A" } {
lassign [lindex $pnts $i] type x y z parameters
append ds " $type [join $parameters ,]" [format " %.3g,%.3g" $x $y]
if { $type eq "A" } {
lappend pnts_text "$x $y"
} else {
set pnt [m::add [lindex $pnts_text end] "$x $y"]
lappend pnts_text $pnt
}
} elseif { $type in "z Z" } {
append ds " $type"
}
set type_prev $type
}
if { $labelsFlag } {
set idx 1
foreach i $pnts_text {
lassign $i x y
set x [expr {$x+5}]
set y [expr {$y-5}]
if { [llength $labelsList] } {
set txt [lindex $labelsList $idx-1]
} elseif { $idx == 1 } {
set txt "$id: $idx"
} else {
set txt "$idx"
}
set styleT "font-size: 18px; fill: black; font-family: sans-serif;"
append xml [format "<text x='%.3g' y='%.3g' text-anchor='start' style='%s'>\n" \
$x $y $styleT]
append xml [append_tspans $x $txt]
append xml "</text>\n"
incr idx
}
append style "marker-start:url(#circle);marker-mid:url(#circle);"
append style "marker-end:url(#circle);"
}
append xml "<path d='$ds' id='$id' style='$style'/>\n"
set pnt1 [lindex $pntsBBOX 1]
set pnt0 [lindex $pntsBBOX 0]
set L [m::norm [m::sub $pnt1 $pnt0]]
set angle [expr {atan2([lindex $pnt1 1]-[lindex $pnt0 1],
[lindex $pnt1 0]-[lindex $pnt0 0])}]
if { [dict size $copy_info] == 0 } {
dict set d ids $id bboxL [list $x0 $y0 $L $L]
dict set d ids $id angle $angle
}
}
label - dimension - text {
set text [give_propD $d $id text ""]
if { [regexp {font-family\s*:\s*(.+)} $style {} font_family] } {
set font_family [lindex [split $font_family ,] 0]
set font_family [string trim $font_family \"]
} else {
set font_family Verdana
append style "font-family: Verdana;sans-serif;"
}
if { ![regexp {font-size\s*:\s*(\d+)} $style {} font_size] } {
set font_size 14
append style "font-size: 14px;"
}
set err [catch {
load {C:\Users\ramsan\Documents\myTclTk\RamDebugger\utils\test_markdown\markdownLib.dll} markdown
set text_box [measure_text $text $font_family $font_size]
}]
if { $err } {
set text_box [list 0 [expr {-0.2*$font_size}] [expr {0.5*[string length $text]*$font_size}] \
[expr {0.85*$font_size}]]
}
set ipos [lsearch -index 0 $pnts delta-point]
if { $ipos != -1 } {
set delta [lrange [lindex $pnts $ipos] 1 2]
} else {
set delta ""
}
if { $cmd eq "dimension" } {
set parent [calculate_parent $id]
set cmdP [dict_getd $d ids $parent cmd ""]
set hv [give_propD $d $id horizontal-vertical ""]
if { [llength $pntsBBOX] >= 2 } {
set p0 [lindex $pntsBBOX 0]
set vT [m::sub [lindex $pntsBBOX 1] $p0]
set vN [m::unitLengthVector "[expr {-1*[lindex $vT 1]}] [lindex $vT 0]"]
if { $hv eq "v" } {
set vN [m::scale $anchorX "1 0"]
} elseif { $hv eq "h" } {
set vN [m::scale $anchorY "0 1"]
}
} elseif { $cmdP eq "rect" } {
set b [dict get $d ids $parent bbox]
set p0 [lrange $b 0 1]
set vT "[lindex $b 2] 0"
set vN "0 $anchorY"
set ariste [give_propD $d $id ariste "s"]
switch $ariste {
s {
set p0 [m::add $p0 "0 [lindex $b 3]"]
}
w {
set vT "0 [lindex $b 3]" ; set vN "$anchorX 0"
}
e {
set p0 [m::add $p0 "[lindex $b 2] 0"]
set vT "0 [lindex $b 3]" ; set vN "$anchorX 0"
}
}
}
set p1 [m::add $p0 $vT]
if { $hv eq "h" } {
lset vT 1 0
set vc [lindex $vN 1]
if { $vc != 0 } {
set vN "0 [expr {$vc/abs($vc)}]"
}
} elseif { $hv eq "v" } {
lset vT 0 0
set vc [lindex $vN 0]
if { $vc != 0 } {
set vN "[expr {$vc/abs($vc)}] 0"
}
}
set fac [expr {0.8*$font_size}]
set vN [m::scale $fac $vN]
if { $delta eq "" } {
set vNd $vN
} else {
set vNd $delta
}
set p0D1 [m::axpy 1 $vNd $p0]
set p1D1 [m::axpy 1 $vNd $p1]
set p0D2 [m::axpy 1 $vN $p0D1]
set p1D2 [m::axpy 1 $vN $p1D1]
if { $hv eq "h" } {
lset p1D1 1 [lindex $p0D1 1]
lset p1D2 1 [lindex $p0D2 1]
} elseif { $hv eq "v" } {
lset p1D1 0 [lindex $p0D1 0]
lset p1D2 0 [lindex $p0D2 0]
}
set pLabel [m::scale 0.5 [m::add $p0D1 $p1D1]]
set pLabel [m::axpy 0.7 $vN $pLabel]
} else {
set pLabel [lrange $bbox 0 1]
set vN "$anchorX $anchorY"
}
if { $cmd eq "dimension" } {
set st "stroke:black;stroke-width:1px;$style"
append xml "<path d='M$p0 L$p0D2' id='$id-DL1' style='$st'/>\n"
append xml "<path d='M$p1 L$p1D2' id='$id-DL2' style='$st'/>\n"
append st "marker-end:url(#TriangleOutL);" \
"marker-start:url(#TriangleInL);"
append xml "<path d='M$p0D1 L$p1D1' id='$id-DL' style='$st'/>\n"
} elseif { $delta ne "" && [m::norm_two $delta] > 20 } {
set p0D [m::add $pLabel $delta]
set p1D [m::axpy 0.1 $delta $pLabel]
set delta ""
set st "stroke:black;stroke-width:1px;$style"
append st "marker-end:url(#TriangleOutL);"
append xml "<path d='M$p0D L$p1D' id='$id-DL' style='$st'/>\n"
set pLabel $p0D
set cmd labelarrow
}
# if { $cmd eq "text" } {
# set fsX "0 0 0"
# set fsY "0 0 0.8"
# } elseif { $cmd eq "labelarrow" } {
# set fsX "0 0 0"
# set fsY "-0.2 0.0 1"
# } else {
# set fsX "-0.3 0 0.3"
# set fsY "-0.5 0.2 1"
# }
# catch {
# set vN [m::unitLengthVector $vN]
# }
# lassign "0 0" fac1 fac2
# if { abs([lindex $vN 0])>0.2 } {
# set fac1 [expr {abs([lindex $fsX $anchorX+1]*$font_size)}]
# }
# if { abs([lindex $vN 1])>0.2 } {
# set fac2 [expr {abs([lindex $fsY $anchorY+1]*$font_size)}]
# }
# set fac [expr {($fac1>$fac2)?$fac1:$fac2}]
# set pLabel [m::axpy $fac $vN $pLabel]
if { $anchorY == 1 } {
lset pLabel 1 [expr {[lindex $pLabel 1]+([lindex $text_box 1]+[lindex $text_box 3])}]
} elseif { $anchorY == -1 } {
lset pLabel 1 [expr {[lindex $pLabel 1]+[lindex $text_box 1]}]
}
if { $delta ne "" && $cmd ne "dimension" } {
set pLabel [m::add $pLabel $delta]
} elseif { $cmd eq "label" } {
lset pLabel 0 [expr {[lindex $pLabel 0]+0.5*$anchorX*$font_size}]
}
if { $anchorX == -1 } {
set ta "end"
} elseif { $anchorX == 1 } {
set ta "start"
} else {
set ta "middle"
}
lassign $pLabel x y
if { [regexp {border-stroke-width:\s*((\d+)[^;]+)} $style {} value num] && $num > 0 } {
if { [regexp {border-stroke:\s*([^;]+)} $style {} s] } {
set stroke $s
} else {
set stroke black
}
if { [regexp {padding:\s*((\d+)[^;]+)} $style {} padding] == 0 } {
set padding [expr {0.5*$font_size}]
}
lassign $pLabel xR yR
if { $anchorX == -1 } {
set xR [expr {$xR-[lindex $text_box 2]}]
} elseif { $anchorX == 0 } {
set xR [expr {$xR-0.5*[lindex $text_box 2]}]
}
set xR [expr {$xR-$padding}]
set yR [expr {$yR-([lindex $text_box 1]+[lindex $text_box 3])-$padding}]
set w [expr {[lindex $text_box 2]+2*$padding}]
set h [expr {[lindex $text_box 3]+2*$padding}]
set styleB "$style;stroke-width:$value;stroke:$stroke;fill:none;"
append xml "<rect x='$xR' y='$yR' width='$w' height='$h' "
append xml "id='$id-border' style='$styleB'"
if { [regexp {border-radius\s*:\s*(\d+)} $style {} r] } {
append xml " rx='$r' ry='$r'"
}
append xml "/>\n"
set bbox [list $xR $yR $w $h]
} else {
set w [lindex $text_box 2]
set h [lindex $text_box 3]
set xB $x
if { $anchorX == -1 } {
set xB [expr {$xB-[lindex $text_box 2]}]
} elseif { $anchorX == 0 } {
set xB [expr {$xB-0.5*[lindex $text_box 2]}]
}
set yB [expr {$y-([lindex $text_box 1]+[lindex $text_box 3])}]
set bbox [list $xB $yB $w $h]
}
if { [dict size $copy_info] == 0 } {
dict set d ids $id bbox $bbox
} else {
add_to_bbox [dict get $copy_info id] $bbox
}
append xml [format "<text x='%.3g' y='%.3g' text-anchor='%s' id='%s' style='%s'>" \
$x $y $ta $id $style]
append xml [append_tspans $x $text]
append xml "</text>\n"
if { [dict size $copy_info] == 0 } {
dict set d ids $id bboxL [dict_getd $d ids $id bbox ""]
dict set d ids $id angle 0
}
}
copy {
set idC [join [lrange [split $id .] 0 end-1] .]
set idC [resolve_id $idC $id]
set idsList [list $idC]
set ic [give_propD $d $id include_children 0]
if { $ic } {
lappend idsList {*}[give_descendants $idC $id]
}
set n [give_propD $d $id number 1]
set style_name ""
foreach "nL vL" [dict get $d ids $id props] {
if { $nL eq "class" } {
if { $style_name eq "" } {
set style_name $vL
}
} elseif { $nL eq "connect-class" } {
set style_name $vL
}
}
if { $style_name eq "" } {
set style_name [give_propD $d $idC class ""]
}
lassign [split [give_propD $d $id operation translation] ,] \
operation op
dict set copy_info style $style
dict set copy_info labels [give_propD $d $id labels ""]
if { ![dict exists $copy_info style_name] } {
dict set copy_info style_name $style_name
}
dict set copy_info id $id
if { ![dict exists $copy_info connect] } {
dict set copy_info connect [give_propD $d $id connect ""]
}
lassign "" delta delta_points points
for { set i 0 } { $i < [llength $pnts] } { incr i } {
lassign [lindex $pnts $i] type x y
if { $type eq "delta-point" } {
if { $i == 0 || [lindex $pnts $i-1 0] ne "point" } {
set delta "$x $y"
} else {
lassign [lindex $pnts $i-1] - xP yP
dict set delta_points "$xP $yP" "$x $y"
}
} else {
lappend points "$x $y"
}
}
if { $op ne "" } {
set delta "0 0"
set c 0
set rex {\A\s*([-+\de.]+)[*]P(\d+)}
while { [regexp -start $c -indices $rex $op all alphaI pI] } {
set alpha [string range $op {*}$alphaI]
set p [string range $op {*}$pI]
set v [lrange [lindex $pnts $p-1] 1 2]
set delta [m::axpy $alpha $v $delta]
set c [expr {[lindex $all 1]+1}]
}
if { ![regexp -start $c {\A\s*$} $op] } {
set_error $d $id "'copy' expression not correct"
}
} elseif { $delta eq "" && [dict size $delta_points] == 0 } {
if { [llength $points] == 2 } {
set delta [m::sub [lindex $points 1] [lindex $points 0]]
} else {
set_error $d $id "'copy' must have a delta-point property or two points"
}
}
for { set i 1 } { $i <= $n } { incr i } {
set c [dict_getd $copy_info operations ""]
lappend c [dict create operation $operation delta \
$delta delta_points $delta_points]
dict set copy_info operations $c
foreach idC $idsList {
set idC [resolve_id $idC $id]
create_entity $idC $copy_info
}
}
}
default {
set_error $d $id "unknown command '$cmd'"
}
}
}
proc svgml::paste_entity { node ent_type props text mT stylesN style_numN } {
upvar 1 $stylesN styles
upvar 1 $style_numN style_num
set propsV [list fill stroke opacity stroke-width stroke-dasharray \
font-style font-weight font-size font-family]
set nodes [list $node]
lappend nodes {*}[$node sn *]
set stylesD ""
foreach nodeI $nodes {
foreach nv [split [$nodeI @style ""] ";"] {
lassign [split $nv :] n v
if { $n in $propsV } {
if { $n eq "font-size" } {
regexp {([-+\de.]+)\s*(\w*)} $v {} vv unit
lassign [m::matmul $mT "$vv 0"] vv
set v "[format %.0f $vv]$unit"
}
dict set stylesD $n $v
}
}
}
set style ""
dict for "n v" $stylesD { append style "$n:$v;" }
if { [dict exists $styles v $style] } {
set style_name [dict get $styles v $style]
} else {
set style_name "style$style_num"
incr style_num
dict set styles n $style_name $style
dict set styles v $style $style_name
}
set id [$node @id ""]
set txt "$id"
if { [string length $id] < 15 } {
append txt [string repeat " " [expr {15-[string length $id]}]]
} else {
append txt " "
}
append txt "$ent_type $props cl:$style_name;\n"
$text insert insert $txt
}
proc svgml::paste { xml } {
package require compass_utils::c
set doc [p::xml parse $xml]
set widthG 800
set svgNode [$doc documentElement]
set width [$svgNode @width 100]
set height [$svgNode @height 100]
set viewBox [$svgNode @viewBox "0 0 $width $height"]
set text $RamDebugger::text
set idx [$text index insert]
regexp {^\d+} $idx line
set found_start 0
for { set i $line } { $i >= 1 } { incr i -1 } {
if { [regexp {^\s*~~~~\s*$} [$text get $i.0 "$i.0 lineend"]] } {
break
}
if { [regexp {^\s*~~~~.*svgml} [$text get $i.0 "$i.0 lineend"]] } {
set found_start 1
break
}
}
if { [$text compare $idx == "$idx linestart"] == 0 } {
$text insert insert "\n"
set idx [$text index "$idx + 1l linestart"]
}
if { [$text compare $idx == "$idx lineend"] == 0 } {
$text insert insert "\n"
$text mark set insert "insert-1c"
}
if { !$found_start } {
set r [expr {1.0*[$svgNode @width 800]/[$svgNode @height $widthG]}]
set heightG [format %0.f [expr {$widthG/$r}]]
$text insert insert "~~~~ { svgml=\"1\" file=\"image.svg\" }\n"
$text insert insert "+svgml1 width:$widthG; height:$heightG;\n"
$text insert insert "+alias point:p; delta-point:dp; width-height:wh; text:t;\n"
$text insert insert "+alias anchor:a; horizontal-vertical:hv; class:cl; number:n;\n\n"
}
set m [m::mkMatrix 3 3 0]
m::setelem m 0 0 [expr {100.0/[lindex $viewBox 2]}]
m::setelem m 0 2 [expr {-100.0*[lindex $viewBox 0]/[lindex $viewBox 2]}]
m::setelem m 1 1 [expr {100.0/[lindex $viewBox 3]}]
m::setelem m 1 2 [expr {-100.0*[lindex $viewBox 1]/[lindex $viewBox 3]}]
set mS [m::mkMatrix 2 2 0]
m::setelem mS 0 0 [m::getelem $m 0 0]
m::setelem mS 1 1 [m::getelem $m 1 1]
set mT [m::mkMatrix 2 2 0]
m::setelem mT 0 0 [expr {1.0*$widthG/[lindex $viewBox 2]}]
m::setelem mT 1 1 [expr {1.0*$widthG/[lindex $viewBox 3]}]
set styles ""; set style_num 1
foreach pathNode [$svgNode sn "path"] {
set vs [regexp -inline -all {[a-zA-Z]|[-+e0-9.]+} [$pathNode @d ""]]
set dN ""
set cmd_prev ""
set pnt_prev ""
for { set i 0 } { $i < [llength $vs] } { incr i } {
switch [lindex $vs $i] {
a - A {
lassign [lrange $vs $i $i+7] type rx ry x-axis-rotation large-arc-flag \
sweep-flag x y
lassign [m::matmul $mS "$rx $ry"] rx ry
if { $type eq "A" } {
lassign [m::matmul $m "$x $y 1"] x y
} else {
lassign [m::matmul $mS "$x $y"] x y
lassign [m::add $pnt_prev "$x $y"] x y
set type A
}
set pnt_prev "$x $y"
lappend dN $type {*}[format "%.0f %.0f" $rx $ry] ${x-axis-rotation} \
${large-arc-flag} ${sweep-flag} {*}[format "%.0f %.0f" $x $y]
set cmd_prev [lindex $vs $i]
incr i 7
}
m - M - l - L - q - Q - c - C - s - S {
switch [lindex $vs $i] {
m - M - l - L { set npoints 1 }
q - Q - s - S { set npoints 2 }
c - C { set npoints 3 }
}
set type [lindex $vs $i]
# if { $i == 0 && $type eq "m" } {
# set type "M"
# }
lappend dN [string toupper $type]
for { set j 0 } { $j < $npoints } { incr j } {
set idx [expr {$i+2*$j+1}]
lassign [lrange $vs $idx $idx+1] x y
if { $type in "M L Q C S" } {
lassign [m::matmul $m "$x $y 1"] x y
} elseif { $type eq "m" && $i == 0 } {
lassign [m::matmul $m "$x $y 1"] x y
} else {
lassign [m::matmul $mS "$x $y"] x y
lassign [m::add $pnt_prev "$x $y"] x y
}
if { $j == $npoints-1 } {
set pnt_prev "$x $y"
}
lappend dN {*}[format "%.0f %.0f" $x $y]
}
set cmd_prev $type
incr i [expr {2*$npoints}]
}
h - H - v - V {
lassign [lrange $vs $i $i+1] type xy
switch [lindex $vs $i] {
h - H { set x $xy ; set y 0 }
v - V { set x 0 ; set y $xy }
}
if { [lindex $vs $i] in "H V" } {
lassign [m::matmul $m "$x $y 1"] x y
if { [lindex $vs $i] eq "H" } {
set y [lindex $pnt_prev 1]
} else {
set x [lindex $pnt_prev 0]
}
} else {
lassign [m::matmul $mS "$x $y"] x y
lassign [m::add $pnt_prev "$x $y"] x y
}
set pnt_prev "$x $y"
lappend dN L {*}[format "%.0f %.0f" $x $y]
set cmd_prev [string toupper [lindex $vs $i]]
incr i 1
}
z - Z {
lappend dN [lindex $vs $i]
set cmd_prev [lindex $vs $i]
}
default {
if { $cmd_prev eq "" || $cmd_prev in "M m" } {
if { $cmd_prev eq "m" } {
set cmd_prev "l"
} else {
set cmd_prev "L"
}
}
set vs [linsert $vs $i $cmd_prev]
incr i -1
}
}
}
set ent_type "line"
set props "p:[join $dN ,];"
paste_entity $pathNode $ent_type $props $text $mT styles style_num
}
foreach circleNode [$svgNode sn "circle"] {
set x [$circleNode @cx 0]
set y [$circleNode @cy 0]
set r [$circleNode @r 0]
lassign [m::matmul $m "$x $y 1"] x y
lassign [m::matmul $mS "$r 0"] r
set d [expr {2*$r}]
set ent_type "circle"
set props "p:[format "%.0f,%.0f" $x $y]; wh:[format "%.0f,%.0f" $d $d];"
paste_entity $circleNode $ent_type $props $text $mT styles style_num
}
foreach rectNode [$svgNode sn "rect"] {
set x [$rectNode @x 0]
set y [$rectNode @y 0]
set width [$rectNode @width 0]
set height [$rectNode @height 0]
lassign [m::matmul $m "$x $y 1"] x y
lassign [m::matmul $mS "$width $height"] width height
set ent_type "rect"
set props "p:[format "%.0f,%.0f" $x $y]; a:nw; "
append props "wh:[format "%.0f,%.0f" $width $height];"
paste_entity $rectNode $ent_type $props $text $mT styles style_num
}
foreach textNode [$svgNode sn "text"] {
set x [$textNode @x 0]
set y [$textNode @y 0]
lassign [m::matmul $m "$x $y 1"] x y
set txtList ""
foreach node [$textNode sn {tspan}] {
lappend txtList [$node sn string(.)]
}
set txt [join $txtList \\n]
set ent_type "text"
set props "p:[format "%.0f,%.0f" $x $y]; a:w; "
append props "t:$txt;"
paste_entity $textNode $ent_type $props $text $mT styles style_num
}
dict for "n v" [dict_getd $styles n ""] {
$text insert insert ".$n $v\n"
}
if { !$found_start } {
$text insert insert "~~~~\n"
}
}
proc svgml::create_file { args } {
variable svgfile
set optional {
{ -file svgfile "" }
{ -inkscape "" 0 }
{ -samefile "" 0 }
{ -open "" 0 }
}
set compulsory "txt"
parse_args $optional $compulsory $args
set xml [create $txt]
if { $file ne "" } {
set svgfile $file
} elseif { $samefile } {
close [file tempfile tmp]
set svgfile [file dirname $tmp]/testfile.svg
} else {
close [file tempfile tmp]
set svgfile [file root $tmp].svg
}
file mkdir [file dirname $svgfile]
set write 1
if { [file exists $svgfile] } {
set fin [open $svgfile r]
set data [read $fin]
fconfigure $fin -encoding utf-8
close $fin
if { $data eq $xml } {
set write 0
}
}
if { $write } {
set fout [open $svgfile w]
fconfigure $fout -encoding utf-8
puts -nonewline $fout $xml
close $fout
}
if { $open } {
if { !$inkscape } {
cu::file::execute start $svgfile &
} else {
cu::file::execute exec inkscape $svgfile &
}
}
# puts svgfile=$svgfile
}
# U+0394 Greek Capital Letter Delta Unicode Character
set txt {
+svgml1 width:900; height:40%;
+alias point:p; delta-point:dp; width-height:wh; text:t;
+alias anchor:a; horizontal-vertical:hv; class:cl;
deb rect p:0,0; p:100,100; cl:line-debug;
#R1.deb rect p:0,0; p:100,100; cl:line-debug;
#debT rect p:50,10; wh:60,8; a:s; cl:line-debug;
title text p:50,10; t::TITLE; a:s; cl:textTITLE;
R1 region p:25,50; wh:35,90; a:nsew;
R1.box rect p:50,40; wh:65,30; a:nsew; cl:rounded_box;
R1.box.lyg line p:-10,90; p:110,90; cl:line1;
R1.box.lyg.l1 label p:0,100; t:y~g~; a:se; cl:text1;
R1.box.x0y0 label p:0,100; t:x~0~,y~0~; a:ne; cl:text1;
R1.box.dimx dimension ariste:s; a:n; t:\u0394x; cl:text1;
R1.box.dimy dimension ariste:e; a:w; t:\u0394y; cl:text1;
#R1.box.txt text p:2,80; t:acBj; cl:textint;
R1.tdesc text p:10,80; a:sw; t::BDESC; cl:textDESC;
R2 region p:75,50; wh:35,90; a:nsew;
R2.box rect p:50,40; wh:65,30; a:nsew; cl:rounded_box;
R2.box.lyg line p:-10,90; p:110,90; cl:line1;
R2.box.lyg.l1 label p:0,100; t:y~g,p~; a:se; cl:text1;
R2.box.x0y0 label p:0,100; t:x~0,p~,y~0,p~; a:ne; cl:text1;
R2.box.boxin rect p:92,10; wh:60,40; a:ne; cl:rounded_box;
R2.box.boxin.lyg line p:-10,80; p:110,80; cl:line1;
R2.box.boxin.lyg.l1 label p:0,100; t:y~g~; a:se; cl:text1;
R2.box.dimx dimension p:0,100; p:#R2.box.boxin,0,100; hv:h; a:n; t:x~0~; cl:text1;
R2.box.dim1 dimension p:#R2.box.lyg,100,0; p:#R2.box.boxin,100,100; hv:v; a:w; t:y~0~; cl:text1;
R2.box.dim2 dimension p:#R2.box.lyg,100,0; p:#R2.box.boxin.lyg,100,0; hv:v; a:w; t:y~g~; dp:30,0; cl:text1;
R2.tdesc text p:10,80; a:sw; t::BDESCP; cl:textDESC;
.rounded_box border-radius: 5px; stroke-width: 3px; stroke: orange; fill: yellow;
.line1 stroke-width: 2px; stroke: orange; fill:none;
.line-debug stroke-width: 1px; stroke: red; fill:none; stroke-dasharray: 5 5;
.textTITLE font-size: 24px; fill: #0800d8; stroke:#585858; stroke-width:0 font-family: sans-serif; text-decoration: underline;
.textDESC font-size: 16px; fill: black; font-family: sans-serif;
.textint font-size: 36px; fill: black; font-family: sans-serif;
.text1 font-size: 18px; fill: black; font-family: sans-serif;
+variables TITLE:Boxes definition for calculating HTML display;
+variables BDESC:**box**=[x~0~,y~0~,\u0394x,\u0394y]\n**box~0~**=[0,0,Page~width~,Page~height~];
+variables BDESCP: **x~0~, y~0~** and **y~g~** values are relative \n to parent **x~0,p~, y~g,p~**\n;
+variables +BDESCP: **\u0394x,\u0394y** are in the same scale than **\u0394x~p~,\u0394y~p~**;
}
if 0 {
svgml::create_file -open $txt
#svgml::create_file -inkscape $txt
#svgml::create_file -samefile -open=0 $txt
exit
}