Artifact d12412e3855269c391c299bfae140322541ca854:
###############################################################################
#
# pdf4tcl_graph.tcl
#
# Copyright (C) 2017 Joerg Mehring, Bochum, DE, <j.mehring@sesam-gmbh.de>
# All rights reserved. (BSD-3 license)
#
# Redistribution and use in source and binary forms, with or without modification,
# are permitted provided that the following conditions are met:
#
# 1. Redistributions of source code must retain the above copyright notice, this
# list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright notice,
# this list of conditions and the following disclaimer in the documentation
# and/or other materials provided with the distribution.
# 3. Neither the name of the project nor the names of its contributors may be used
# to endorse or promote products derived from this software without specific
# prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY
# EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
# OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT
# SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
# INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
# TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
# BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
# ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
# SUCH DAMAGE.
#
#
# This is an output engine for "graph.tcl" to implement BLT (or RBC) commands for
# generating PDF output using the "pdf4tcl" Package.
#
# Noice: So far, "pdf4tcl" must be patched to support functions such as
# non-closed polygons and clipping. You can download a patched
# version from here (I hope the author of "pdf4tcl" incorporates
# this patch into his sources):
#
# http://sesam-gmbh.org/images/Downloads/public/pdf4tcl091p1.tar.bz2
#
# Usage example:
#
# package require pdf4tcl::graph
#
# pdf4tcl::new mypdf -paper a4 -unit mm
# mypdf startPage
# mypdf setFont 4 Helvetica
# mypdf text "Hello World" -x 10 -y 10
#
# graph::setup pdf4tcl mypdf
#
# set mydata {21 17 5 9 25.4}
#
# set g [graph::graph -title "Example"]
# $g axis create y3 -color blue
# $g element create line1 -label "Data" -ydata mydata -fill red
# $g grid configure -hide no
# $g axis configure x -min 0 -max 100
# $g axis configure y -loose no -hide no -max 25 -title Alpha
# $g draw 15 15
# $g destroy
#
# mypdf write -file graph.pdf
# mypdf destroy
#
#
###############################################################################
package require pdf4tcl
package require graph
package provide pdf4tcl::graph 1.0
namespace eval pdf4tcl::graph {
namespace export \
GetOrigin \
CalcXY \
rgbdarken \
rgblighten \
GetRGB \
SetFont \
SetColor \
SetLinewidth \
LineHeight \
TextWidth \
MakeSplineData \
SetDash \
Line \
ClipRect \
UnclipRect \
Rect \
Arc \
PolyObject \
Text \
Pict \
LoadPict \
PictSize
}
proc pdf4tcl::graph::GetOrigin { g } {
set orient [graph::execute cget -orient]
set paper [graph::execute cget -paper]
lassign [pdf4tcl::getPaperSize $paper] wPt hPt
set width [expr {25.5 * $wPt / 72.0}]
set height [expr {25.5 * $hPt / 72.0}]
graph::set_opt $g orient $orient
graph::set_opt $g paper $paper
graph::set_opt $g width $width
graph::set_opt $g height $height
return $orient ;# false = bottom, true = top
}
proc pdf4tcl::graph::CalcXY { g v_x v_y } {
upvar $v_x x
upvar $v_y y
if {[graph::get_opt $g orient]} {
set y [expr {[graph::get_opt $g height] - $y}]
}
}
proc pdf4tcl::graph::rgbdarken { rgb percent } { # internal use only
lassign $rgb r g b
set diff [expr {256.0 * $percent / 100.0}]
set r [expr {$r - $diff}]; if {$r < 0} { set r 0 }
set g [expr {$g - $diff}]; if {$g < 0} { set g 0 }
set b [expr {$b - $diff}]; if {$b < 0} { set b 0 }
return [list $r $g $b]
}
proc pdf4tcl::graph::rgblighten { rgb percent } { # internal use only
lassign $rgb r g b
set diff [expr {256.0 * $percent / 100.0}]
set r [expr {$r + $diff}]; if {$r > 255} { set r 255 }
set g [expr {$g + $diff}]; if {$g > 255} { set g 255 }
set b [expr {$b + $diff}]; if {$b > 255} { set b 255 }
return [list $r $g $b]
}
proc pdf4tcl::graph::GetRGB { color } { # internal use only
set color [string tolower [string trim $color]]
if {[regexp {^\d+\s+\d+\s+\d+$} $color all]} {
return [join $color]
} else {
set rgb {0 0 0}
if {[info commands tk] != {}} {
# fine, tk can tell us the right rgb values
set rc [catch { set rgb16 [winfo rgb . $color] }]
if {$rc == 0} {
set r [expr {round([lindex $rgb16 0] / 256.0)}]
set g [expr {round([lindex $rgb16 1] / 256.0)}]
set b [expr {round([lindex $rgb16 2] / 256.0)}]
set rgb [list $r $g $b]
}
} else {
# oh shit, no color names available, let's give some basic colors
switch -glob -- $color {
{black} { set rgb { 0 0 0} }
{white} { set rgb {255 255 255} }
{red} { set rgb {255 0 0} }
{green} { set rgb { 0 255 0} }
{blue} { set rgb { 0 0 255} }
{cyan} { set rgb { 0 255 255} }
{magenta} { set rgb {255 0 255} }
{yellow} { set rgb {255 255 0} }
{orange} { set rgb {255 128 0} }
{pink} { set rgb {255 128 192} }
{purple} { set rgb {160 0 128} }
{brown} { set rgb {128 0 0} }
{gold} { set rgb {255 215 0} }
{violet} { set rgb {128 0 128} }
{gr[ae]y} { set rgb {190 190 190} }
{gr[ae]y*} {
set x [string range $color 4 end]
if {[string is integer $x]} {
set x [expr {round(($x / 100.0) * 255.0)}]
if {$x > 255} { set x 255 }
if {$x < 0} { set x 0 }
set rgb [list $x $x $x]
}
}
{dark*} {
set rgb [GetRGB [string range $color 4 end]]
set r [expr {[lindex $rgb 0] / 2}]
set g [expr {[lindex $rgb 1] / 2}]
set b [expr {[lindex $rgb 2] / 2}]
set rgb [list $r $g $b]
}
{light*} {
set rgb [GetRGB [string range $color 5 end]]
set r [expr {255 - ((255 - [lindex $rgb 0]) / 2)}]
set g [expr {255 - ((255 - [lindex $rgb 1]) / 2)}]
set b [expr {255 - ((255 - [lindex $rgb 2]) / 2)}]
set rgb [list $r $g $b]
}
}
}
return [join $rgb]
}
}
proc pdf4tcl::graph::SetFont { g name size {attrib ""} } {
set font [list $name $size $attrib]
if {[graph::get_opt $g font] == $font} return
set bold [regexp bold $attrib]
set italic [regexp italic $attrib]
switch $name {
Helvetica - Arial - Courier {
if {$bold && $italic} {
append name -BoldOblique
} elseif {$bold} {
append name -Bold
} elseif {$italic} {
append name -Oblique
}
}
Times {
if {$bold && $italic} {
append name -BoldItalic
} elseif {$bold} {
append name -Bold
} elseif {$italic} {
append name -Italic
} else {
append name -Roman
}
}
}
graph::execute setFont $size $name
graph::set_opt $g font $font
}
proc pdf4tcl::graph::LineHeight {} {
return [graph::execute getFontMetric height]
}
proc pdf4tcl::graph::TextWidth { str } {
return [graph::execute getStringWidth $str]
}
proc pdf4tcl::graph::SetColor { g color } {
graph::set_opt $g color $color
set rgb [GetRGB $color]
graph::set_opt $g rgbcolor $rgb
lassign $rgb r g b
graph::execute setStrokeColor $r $g $b
graph::execute setFillColor $r $g $b
}
proc pdf4tcl::graph::SetLinewidth { g width } {
if {$width != {}} {
if {$width <= 0} {
set width 0.01
}
graph::execute setLineWidth [expr {72 * $width / 25.4}]
}
graph::set_opt $g linewidth $width
}
proc pdf4tcl::graph::SplineInterpolate {y0 y1 y2 y3 mu {tension 0.0} {bias 0.0}} {
set mu2 [expr {$mu * $mu}]
set mu3 [expr {$mu2 * $mu}]
set m0 [expr {($y1-$y0)*(1+$bias)*(1-$tension)/2 +
($y2-$y1)*(1-$bias)*(1-$tension)/2}]
set m1 [expr {($y2-$y1)*(1+$bias)*(1-$tension)/2 +
($y3-$y2)*(1-$bias)*(1-$tension)/2}]
set a0 [expr { 2*$mu3 - 3*$mu2 + 1}]
set a1 [expr { $mu3 - 2*$mu2 + $mu}]
set a2 [expr { $mu3 - $mu2}]
set a3 [expr {-2*$mu3 + 3*$mu2}]
return [expr {$a0*$y1+$a1*$m0+$a2*$m1+$a3*$y2}]
}
proc pdf4tcl::graph::MakeSplineData { v_xdata1 v_ydata1 v_xdata2 v_ydata2
{steps 0} {tension 0.0} {bias 0.0} } {
upvar $v_xdata1 xdata1
upvar $v_ydata1 ydata1
upvar $v_xdata2 xdata2
upvar $v_ydata2 ydata2
set xdata2 {}
set ydata2 {}
set xcnt [llength $xdata1]
set ycnt [llength $ydata1]
if {$xcnt != $ycnt} {
return -code error "x and y data count mismatch"
}
if {$ycnt < 3} {
set xdata2 $xdata1
set ydata2 $ydata1
return
}
if {$steps == 0} {
set steps [expr {200 / $xcnt}]
if {$steps < 2} {
set xdata2 $xdata1
set ydata2 $ydata1
return
}
}
set y3 [lindex $ydata1 2]
set y2 [lindex $ydata1 1]
set y1 [lindex $ydata1 0]
set dy [expr {$y2 - $y1}]
set y0 [expr {$y1 - $dy}]
if {$y3 == {}} {
set y3 [expr {$y2 + $dy}]
}
set x0 [lindex $xdata1 0]
set dmu [expr {1.0 / $steps}]
for {set idx 1} {$idx <= $ycnt} {incr idx} {
set x1 [lindex $xdata1 $idx]
if {$x1 == {}} {
set x1 [expr {$x0 + $dx}]
} else {
set dx [expr {$x1 - $x0}]
}
set mu 0.0
for {set j 0} {$j < $steps} {incr j} {
set x [expr {$x0 + $mu * $dx}]
set y [SplineInterpolate $y0 $y1 $y2 $y3 $mu $tension $bias]
set mu [expr {$mu + $dmu}]
lappend xdata2 $x
lappend ydata2 $y
if {$idx == $ycnt} break
}
if {$idx == $ycnt} break
set x0 $x1
set y0 $y1
set y1 $y2
set y2 $y3
set y [lindex $ydata1 [expr {$idx+2}]]
if {$y == {}} {
set dy [expr {$y2 - $y1}]
set y3 [expr {$y2 + $dy}]
} else {
set y3 $y
}
}
}
proc pdf4tcl::graph::SetDash { g {pattern {}} } {
if {[regexp {^[\.\-,_ ]+$} $pattern]} {
set patlst {}
foreach item [split $pattern {}] {
switch -- $item {
"." { lappend patlst 2 4 }
"," { lappend patlst 4 4 }
"-" { lappend patlst 6 4 }
"_" { lappend patlst 8 4 }
" " {
if {$patlst != {}} {
set last [lindex $patlst end]
set patlst [lreplace $patlst end end [expr {$last +4}]]
}
}
}
}
set pattern $patlst
}
graph::set_opt $g dashpattern $pattern
set pat {}
foreach item $pattern {
lappend pat [expr {$item/3.0}]
}
graph::execute setLineDash {*}$pat
return [graph::get_opt $g dashpattern]
}
proc pdf4tcl::graph::Line { g x1 y1 x2 y2 } {
CalcXY $g x1 y1
CalcXY $g x2 y2
if {[graph::get_opt $g linewidth] >= 0} {
graph::execute line $x1 $y1 $x2 $y2
}
}
proc pdf4tcl::graph::ClipRect { g x1 y1 x2 y2 } {
CalcXY $g x1 y1
CalcXY $g x2 y2
graph::execute gsave
set w [expr {abs($x2 - $x1)}]
set h [expr {abs($y2 - $y1)}]
set xl [expr {($x1 < $x2)? $x1 : $x2}]
set yb [expr {($y1 < $y2)? $y1 : $y2}]
graph::execute clip $xl $yb $w $h
}
proc pdf4tcl::graph::UnclipRect { g } {
graph::execute grestore
}
proc pdf4tcl::graph::Rect { g x1 y1 x2 y2 { fillcolor {} } } {
CalcXY $g x1 y1
CalcXY $g x2 y2
if {$fillcolor != ""} {
set rgborg [graph::get_opt $g rgbcolor]
set rgb [GetRGB $fillcolor]
}
set w [expr {abs($x2 - $x1)}]
set h [expr {abs($y2 - $y1)}]
set yb [expr {($y1 < $y2)? $y1 : $y2}]
set stroke [expr {[graph::get_opt $g linewidth] >= 0}]
if {$fillcolor != ""} {
lassign $rgb r g b
graph::execute setFillColor $r $g $b
graph::execute rectangle $x1 $yb $w $h -stroke $stroke -filled 1
} else {
graph::execute rectangle $x1 $yb $w $h -stroke $stroke -filled 0
}
if {$fillcolor != ""} {
SetColor $g $rgborg
}
}
proc pdf4tcl::graph::Arc { g x y r alpha beta {fillcolor ""} {slines no} } {
CalcXY $g x y
if {$fillcolor != ""} {
set rgborg [graph::get_opt $g rgbcolor]
set rgb [GetRGB $fillcolor]
}
set delta [expr {$beta - $alpha}]
if {$fillcolor != ""} {
lassign $rgb rd gn bl
graph::execute setFillColor $rd $gn $bl
graph::execute arc $x $y $r $r $alpha $delta -stroke 1 -filled 1
} else {
graph::execute arc $x $y $r $r $alpha $delta -stroke 1 -filled 0
}
if {$fillcolor != ""} {
SetColor $g $rgborg
}
}
proc pdf4tcl::graph::PolyObject { g argv {fillcolor {}} } {
if {$fillcolor != ""} {
set rgborg [graph::get_opt $g rgbcolor]
set rgb [GetRGB $fillcolor]
}
set argc [llength $argv]
if {$argc != 2 && $argc != 3} {
error "syntax error in PolyObject $argv"
}
if {$argc == 2} {
set xLst [lindex $argv 0]
set yLst [lindex $argv 1]
set cnt [llength $xLst]
set mode xy
} else {
set xLst [lindex $argv 0]
if {[llength $xLst] > 1} {
set yLst {}
set cnt [llength $xLst]
set yVal [lindex $argv 1]
set yAdd [lindex $argv 2]
set mode yincr
} else {
set xLst {}
set xVal [lindex $argv 0]
set xAdd [lindex $argv 1]
set yLst [lindex $argv 2]
set cnt [llength $yLst]
set mode xincr
}
}
if {$cnt == 0} return
set poly {}
switch $mode {
xy {
set idx 0
foreach x $xLst y $yLst {
set x [format %.2f [lindex $xLst $idx]]
set y [format %.2f [lindex $yLst $idx]]
CalcXY $g x y
lappend poly $x $y
incr idx
}
}
xincr {
for {set idx 0} {$idx < $cnt} {incr idx} {
set y [format %.2f [lindex $yLst $idx]]
if {$idx == 0} {
set x $xVal
CalcXY $g x y
lappend poly $x $y
} else {
set x [format %.2f [expr {$x + $xAdd}]]
CalcXY $g x y
lappend poly $x $y
}
}
}
yincr {
for {set idx 0} {$idx < $cnt} {incr idx} {
set x [format %.2f [lindex $xLst $idx]]
if {$idx == 0} {
set y $yVal
CalcXY $g x y
lappend poly $x $y
} else {
set y [format %.2f [expr {$y + $yAdd}]]
CalcXY $g x y
lappend poly $x $y
}
}
}
}
if {$fillcolor != {}} {
lassign $fillcolor r g b
graph::execute setFillColor $r $g $b
graph::execute polygon {*}$poly -stroke 1 -filled 1
} else {
graph::execute polygon {*}$poly -stroke 1 -closed 0
}
if {$fillcolor != ""} {
SetColor $g $rgborg
}
}
proc pdf4tcl::graph::Text { g x y text args } {
if {$text == ""} return
CalcXY $g x y
set rotation [graph::get_opt $g rotation]
if {$args != {}} {
if {[set idx [lsearch $args "right"]] != -1} {
set width [lindex $args [incr idx]]
set tw [TextWidth $text]
set x [expr {$x + $width - $tw}]
}
if {[set idx [lsearch $args "center"]] != -1} {
set width [lindex $args [incr idx]]
set tw [TextWidth $text]
set x [expr {$x + ($width - $tw) / 2.0}]
}
if {[set idx [lsearch $args "rotate"]] != -1} {
set angle [lindex $args [incr idx]]
set rotation [expr {$rotation + $angle}]
}
}
if {$rotation == 0} {
graph::execute text $text -x $x -y $y
} else {
graph::execute text $text -x $x -y $y -angle $rotation
}
}
proc pdf4tcl::graph::Pict { g x y name { scale 1.0 } } {
CalcXY $g x y
if {[lsearch [graph::get_opt $g picts] $name] == -1} {
LoadPict $g $name
}
set id [file tail $name]
if {$scale != 1.0} {
set w [expr {[graph::get_opt $g pict,$name,width] * $scale}]
set h [expr {[graph::get_opt $g pict,$name,height] * $scale}]
graph::execute putImage $id $x $y -width $w -height $h
} else {
graph::execute putImage $id $x $y
}
}
proc pdf4tcl::graph::LoadPict { g name } {
set dirname [file dirname $name]
set filename [file tail $name]
set extension [file extension $filename]
set filename [file rootname $filename]
set extexpect {.jpeg .jpg .png {}}
set id [file tail $name]
set rc 0
foreach ext $extexpect {
set filepath [file join $dirname $filename$ext]
if {[file readable $filepath]} {
graph::execute addImage $filepath -id $id -type [string range $ext 1 end]
set rc 1
break
}
}
if {$rc == 0} {
error "image file \"$name\[$extexpect\]\" not found"
} else {
foreach {w h} [graph::execute getImageSize $id] {}
graph::set_opt $g pict,$name,data {}
graph::set_opt $g pict,$name,width [expr {25.4 * $w / 72}]
graph::set_opt $g pict,$name,height [expr {25.4 * $h / 72}]
graph::append_opt picts $name
}
}
proc pdf4tcl::graph::PictSize { g name } {
if {[info exists graph($g,opts,pict,$name,data)]} {
return [list [graph::get_opt $g pict,$name,width] [graph::get_opt $g pict,$name,height]]
}
return {}
}