###############################################################################
#
# 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.
#
#
# Graph is a pure tcl library executing BLT (99% compatible) commands for
# outputs other than the screen. It needs a driver to produce for example PDF
# output. Therefore you can use the package pdf4tcl::graph. It uses the pdf4tcl
# library to generate the output. The graph library itself only calls procedures
# like "Line", "Rect", "Arc", "Text" and "Pict". They have to do the real drawing
# job. Drivers exists for generating PostScript, PDF with pdf4tcl and also for
# the Debenu PDF Library (commercial).
#
# For an example of usage please have look at package pdf4tcl::graph.
#
###############################################################################
package provide graph 1.0
namespace eval graph {
variable graph_idx -1
variable marker_idx -1
variable symbols
variable graph
variable graph_defaults
variable element_defaults
variable axis_defaults
variable legend_defaults
variable marker_defaults
variable grid_defaults
variable num_ticks 8
# the output instance for the current PDF generating engine:
variable graphOutInst {}
array set graph_defaults {
background {239 239 239}
borderwidth 0.2
bottommargin 0
font {Helvetica 4}
height 101
justify center
leftmargin 0
plotbackground {255 255 255}
plotborderwidth 0.1
plotpadx 2.0
plotpady 2.0
plotrelief solid
relief solid
rightmargin 0
title ""
topmargin 0
width 127
_elements {}
_axises {}
_markers {}
_margin 0.7
_xaxis x
_yaxis y
_x2axis x2
_y2axis y2
_cliprect {}
}
array set element_defaults {
color {0 0 128}
barcommand {}
barwidth 0.9
borderwidth 0.5
dashes {}
data {}
fill {0 0 128}
hide no
label {}
linewidth 0.2
mapx x
mapy y
outline {0 0 0}
outlinewidth 0.1
pixels 2.75
relief raised
smooth linear
symbol circle
symbolcommand {}
type line
xdata {}
ydata {}
_valid no
_xmin 0.0
_xmax 1.0
_ymin 0.0
_ymax 1.0
}
array set axis_defaults {
color {0 0 0}
command {}
descending 0
hide no
justify center
linewidth 0.1
logscale no
loose yes
majorticks {}
max {}
min {}
minorticks {}
rotate 0
stepsize 0.0
subdivisions {}
tickfont {Helvetica 2.6}
ticklength 2.5
title ""
titlecolor {0 0 0}
titlefont {Helvetica 4}
_valid no
_width {}
_height {}
_format %.15g
_min 0.0
_max 1.0
}
array set legend_defaults {
anchor n
background {239 239 239}
borderwidth 0.2
font {Helvetica 2.6}
foreground {0 0 0}
hide no
ipadx 0.5
ipady 0.5
padx 0.35
pady 0.35
position right
raised no
relief sunken
}
array set marker_defaults {
anchor center
coords {}
dashes {}
element {}
fill {239 239 239}
font {Helvetica 2.6}
hide no
image {}
justify center
linewidth 0.2
mapx x
mapy y
name {}
outline {0 0 0}
padx 0.5
pady 0.5
rotate 0
text ""
under false
xoffset 0
yoffset 0
}
array set grid_defaults {
color {200 200 200}
dashes {}
hide yes
linewidth 0.1
mapx x
mapy y
minor yes
}
array set symbols {}
array set opt_defaults {
linewidth 0.1
rgbcolor {255 255 255}
dashpattern {}
picts {}
rotation 0
xpos 0
ypos 0
font {Helvetica 4 {}}
}
}
###############################################################################
#
# basic glue routines to combine drawing engine with graph calls
#
proc graph::graph { args } {
return [graph_proc $args]
}
proc graph::get_opt { g optName } {
variable graph
return $graph($g,opts,$optName)
}
proc graph::set_opt { g optName value } {
variable graph
set graph($g,opts,$optName) $value
}
proc graph::append_opt { g optName value } {
variable graph
lappend graph($g,opts,$optName) $value
}
proc graph::setup { engine instance } {
variable graphOutInst
set graphOutInst $instance
namespace import ::${engine}::graph::*
}
proc graph::execute {args} {
variable graphOutInst
return [$graphOutInst {*}$args]
}
###############################################################################
#
# graph proc called by graph
#
proc graph::graph_proc { params } {
variable graph_idx
variable graph
variable opt_defaults
init_symbols
set g g[incr graph_idx]
obj_defaults $g graph_defaults
obj_configure $g $params
axis $g create x
axis $g create {x2 -hide 1}
axis $g create y
axis $g create {y2 -hide 1}
obj_defaults $g,legend legend_defaults
obj_defaults $g,grid grid_defaults
obj_defaults $g,opts opt_defaults
proc ::graph::$g {command args} "command $g \$command \$args"
return ::graph::$g
}
###############################################################################
#
# graph command proc (configure, cget, element, axis, etc.)
#
proc graph::command { g command params } {
variable graph
switch -- $command {
configure {
obj_configure $g $params
}
cget {
return [obj_cget $g [lindex $params 0]]
}
draw {
draw $g [lindex $params 0] [lrange $params 1 end]
}
element {
element $g [lindex $params 0] [lrange $params 1 end]
}
axis {
axis $g [lindex $params 0] [lrange $params 1 end]
}
xaxis - yaxis - x2axis - y2axis {
return [axisusage $g $command $params]
}
legend {
legend $g [lindex $params 0] [lrange $params 1 end]
}
marker {
marker $g [lindex $params 0] [lrange $params 1 end]
}
grid {
grid $g [lindex $params 0] [lrange $params 1 end]
}
destroy {
rename ::graph::$g {}
array unset graph $g,*
}
default {
return -code error "unknown command \"$command\""
}
}
}
###############################################################################
#
# some utilities for internal use only
#
proc graph::init_symbols {} {
variable symbols
if {[array size symbols] > 0} return
array set symbols {
square { {-1.0 1.0 1.0 -1.0 -1.0}
{-1.0 -1.0 1.0 1.0 -1.0} }
plus { {-1.0 -0.3 -0.3 0.3 0.3 1.0 1.0 0.3 0.3 -0.3 -0.3 -1.0 -1.0}
{-0.3 -0.3 -1.0 -1.0 -0.3 -0.3 0.3 0.3 1.0 1.0 0.3 0.3 -0.3} }
splus { {-1.0 -0.1 -0.1 0.1 0.1 1.0 1.0 0.1 0.1 -0.1 -0.1 -1.0 -1.0}
{-0.1 -0.1 -1.0 -1.0 -0.1 -0.1 0.1 0.1 1.0 1.0 0.1 0.1 -0.1} }
triangle { {-1.1 1.1 0.0 -1.1}
{-1.0 -1.0 1.0 -1.0} }
}
# create some symbols by turning others by 45 degrees
set sc45 0.707106781185 ;# sin/cos 45 degrees
foreach {src dst} {square diamond plus cross splus scross triangle arrow0
arrow0 arrow1 arrow1 arrow2 arrow2 arrow } {
foreach {px py} $symbols($src) {}
set lx {}
set ly {}
foreach x $px y $py {
lappend lx [expr {($x - $y) * $sc45}]
lappend ly [expr {($x + $y) * $sc45}]
}
set symbols($dst) [list $lx $ly]
}
# create a circle with a 20-edge (18 degrees):
#
# set lx {}
# set ly {}
# for {set angle 0} {$angle <= 360} {incr angle 18} {
# lappend lx [expr {1.2 * sin(0.0174532925199 * $angle)}]
# lappend ly [expr {1.2 * cos(0.0174532925199 * $angle)}]
# }
# set symbols(circle) [list $lx $ly]
}
proc graph::draw_symbol { g x0 y0 symbol size fillcolor outlinecolor } {
variable symbols
if {$symbol == {} || $symbol == "none" || $size == 0} return
if {$symbol == "circle"} {
SetColor $g $outlinecolor
Arc $g $x0 $y0 [expr {1.2 * $size}] 0 360 $fillcolor
return
}
if {[regexp {^@(.+)$} $symbol all pname]} {
if {[PictSize $g $pname] == {}} {
LoadPict $g $pname
}
if {[set psize [PictSize $g $pname]] == {}} return
foreach {dx dy} $psize {}
set x [expr {$x0 - $dx / 2.0}]
set y [expr {$y0 - $dy / 2.0}]
Pict $g $x $y $pname
return
}
if {![info exists symbols($symbol)]} return
foreach {lx ly} $symbols($symbol) {}
set px {}
set py {}
foreach x $lx y $ly {
lappend px [expr {$x0 + $x * $size}]
lappend py [expr {$y0 + $y * $size}]
}
PolyObject $g [list $px $py] [GetRGB $fillcolor]
if {$outlinecolor != {}} {
SetColor $g $outlinecolor
PolyObject $g [list $px $py]
}
}
proc graph::transform { x a b c d {log no} } {
if {$log} { set x [expr {($x > 0.0)? log10($x) : $a}] }
return [expr {$c + ($d - $c) * ($x - $a) / ($b - $a)}]
}
proc graph::set_linewidth { g width } {
variable graph
set org_linewidth [get_opt $g linewidth]
set_opt $g linewidth $width
return $org_linewidth
}
proc graph::calc_box { dx dy angle v_box_w v_box_h } {
upvar $v_box_w box_w
upvar $v_box_h box_h
if {$angle == 0} {
set box_w $dx
set box_h $dy
return
}
set alpha [expr {0.01745329252 * $angle}]
set sin_alpha [expr {sin($alpha)}]
set cos_alpha [expr {cos($alpha)}]
set box_w [expr {$dy * $sin_alpha + $dx * $cos_alpha}]
set box_h [expr {$dy * $cos_alpha + $dx * $sin_alpha}]
return [expr {sqrt($box_w * $box_w + $box_h * $box_h)}]
}
proc graph::swap { v_a v_b } {
upvar $v_a a
upvar $v_b b
set tmp $a; set a $b; set b $tmp
}
proc graph::turn_vector { v_x v_y x0 y0 xr yr angle } {
upvar $v_x x
upvar $v_y y
set alpha [expr {0.01745329252 * $angle}]
set sin_a [expr {sin($alpha)}]
set cos_a [expr {cos($alpha)}]
set x [expr {$x0 + $xr * $cos_a - $yr * $sin_a}]
set y [expr {$y0 + $xr * $sin_a + $yr * $cos_a}]
}
proc graph::text_rot { g txt xc yc tw th angle } {
set dx [expr {-0.5 * $tw}]
set dy [expr {-0.3 * $th}]
if {$angle != 0} {
turn_vector x y $xc $yc $dx $dy $angle
Text $g $x $y $txt rotate $angle
} else {
set x [expr {$xc + $dx}]
set y [expr {$yc + $dy}]
Text $g $x $y $txt
}
}
proc graph::draw_frame { g x_left y_top x_right y_bottom background relief borderwidth } {
if {$borderwidth > 0} {
set bgc [GetRGB $background]
if {$y_top < $y_bottom} { swap y_top y_bottom }
if {$x_right < $x_left} { swap x_left x_right }
set xl [expr {$x_left + $borderwidth}]
set xr [expr {$x_right - $borderwidth}]
set yt [expr {$y_top - $borderwidth}]
set yb [expr {$y_bottom + $borderwidth}]
switch $relief {
sunken {
set color [rgbdarken $bgc 35]
PolyObject $g [list [list $x_left $x_left $x_right $xr $xl $xl $x_left ] \
[list $y_bottom $y_top $y_top $yt $yt $yb $y_bottom]] $color
set color [rgblighten $bgc 35]
PolyObject $g [list [list $x_left $x_right $x_right $xr $xr $xl $x_left ] \
[list $y_bottom $y_bottom $y_top $yt $yb $yb $y_bottom]] $color
}
raised {
set color [rgblighten $bgc 35]
PolyObject $g [list [list $x_left $x_left $x_right $xr $xl $xl $x_left ] \
[list $y_bottom $y_top $y_top $yt $yt $yb $y_bottom]] $color
set color [rgbdarken $bgc 35]
PolyObject $g [list [list $x_left $x_right $x_right $xr $xr $xl $x_left ] \
[list $y_bottom $y_bottom $y_top $yt $yb $yb $y_bottom]] $color
}
solid {
Rect $g $xr $y_bottom $x_right $y_top black
Rect $g $x_left $yt $x_right $y_top black
Rect $g $x_left $y_bottom $xl $y_top black
Rect $g $x_left $y_bottom $x_right $yb black
}
default {
# nix
}
}
}
}
proc graph::obj_defaults { index defaults_name } {
upvar #0 graph::$defaults_name defaults
variable graph
foreach item [array names defaults] {
set graph($index,$item) $defaults($item)
}
}
proc graph::obj_configure { index params } {
variable graph
foreach {name value} $params {
if {[regexp {^\-(\w+)$} $name all option]} {
if {[info exists graph($index,$option)]} {
set graph($index,$option) $value
} else {
return -code error "unknown option \"$option\""
}
} else {
return -code error "syntax error in option \"$option\""
}
}
}
proc graph::obj_cget { index option } {
variable graph
regexp {^\-(\w+)$} $option all option
if {[info exists graph($index,$option)]} {
return $graph($index,$option)
} else {
return -code error "unknown option \"$option\""
}
}
proc graph::obj_names { index {params *} } {
variable graph
if {$params == "*"} {
return $graph($index)
}
set lst {}
foreach item $graph($index) {
foreach pattern $params {
if {[string match $pattern $item]} {
lappend lst $name
break
}
}
}
return $lst
}
proc graph::obj_delete { itemindex listindex params } {
variable graph
foreach name $params {
if {[set idx [lsearch -exact $graph($itemindex) $name]] != -1} {
array unset graph $listindex-$name,*
set graph($itemindex) [lreplace $graph($itemindex) $idx $idx]
}
}
}
###############################################################################
#
# element components
#
proc graph::element { g operation params } {
variable graph
switch -- $operation {
create {
set name [lindex $params 0]
set index $g,elem-$name
obj_defaults $index element_defaults
set graph($index,label) $name
element $g configure $params
lappend graph($g,_elements) $name
}
configure {
set name [lindex $params 0]
set index $g,elem-$name
obj_configure $index [lrange $params 1 end]
set calc no
if {[lsearch -exact $params "-data"] != -1} {
set graph($index,xdata) {}
set graph($index,ydata) {}
}
if {[lsearch -exact $params "-xdata"] != -1 ||
[lsearch -exact $params "-ydata"] != -1 } {
set graph($index,data) {}
set calc yes
}
set graph($index,_valid) no
axis_invalidate $g
}
cget {
set name [lindex $params 0]
return [obj_cget $g,elem-$name [lindex $params 1]]
}
delete {
obj_delete $g,_elements $g,elem $params
axis_invalidate $g
}
exists {
set name [lindex $params 0]
return [info exists graph($g,elem-$name,label)]
}
names {
if {$params == {}} { set params * }
return [obj_names $g,_elements $params]
}
type {
set name [lindex $params 0]
return $graph($g,elem-$name,type)
}
bardata {
set values [lindex $params 0]
set min [lindex $params 1]
set max [lindex $params 2]
set clcnt [lindex $params 3]
set scale [lindex $params 4]
return [data_to_bar_values $values $min $max $clcnt $scale]
}
default {
return -code error "unknown operation \"$operation\""
}
}
}
proc graph::is_var_ref { varname } {
upvar $varname var
if {[llength $var] == 1 &&
[regexp {^[a-zA-Z_]} $var] &&
[info exists ::$var]} {
return yes
}
return no
}
proc graph::elem_calc { g name } {
variable graph
set index $g,elem-$name
set x_min 1e300
set x_max -1e300
set y_min 1e300
set y_max -1e300
if {$graph($index,data) != {}} {
if {[is_var_ref graph($index,data)]} {
upvar #0 $graph($index,data) xydata
} else {
upvar 0 graph($index,data) xydata
}
foreach {x y} $xydata {
if {$x > $x_max} { set x_max $x }
if {$x < $x_min} { set x_min $x }
if {$y > $y_max} { set y_max $y }
if {$y < $y_min} { set y_min $y }
}
} else {
if {[is_var_ref graph($index,xdata)]} {
upvar #0 $graph($index,xdata) xdata
} else {
upvar 0 graph($index,xdata) xdata
}
if {$xdata != {}} {
foreach x $xdata {
if {$x > $x_max} { set x_max $x }
if {$x < $x_min} { set x_min $x }
}
}
if {[is_var_ref graph($index,ydata)]} {
upvar #0 $graph($index,ydata) ydata
} else {
upvar 0 graph($index,ydata) ydata
}
if {$ydata != {}} {
foreach y $ydata {
if {$y > $y_max} { set y_max $y }
if {$y < $y_min} { set y_min $y }
}
}
}
if {$x_min > $x_max} {
set graph($index,_xmin) 0.0
set graph($index,_xmax) 1.0
} else {
set graph($index,_xmin) $x_min
set graph($index,_xmax) $x_max
}
if {$y_min > $y_max} {
set graph($index,_ymin) 0.0
set graph($index,_ymax) 1.0
} else {
set graph($index,_ymin) $y_min
set graph($index,_ymax) $y_max
}
if {$graph($index,label) == ""} {
set graph($index,_title) $name
} else {
set graph($index,_title) $graph($index,label)
}
set graph($index,_valid) yes
}
proc graph::elem_draw { g elem xl_graph yt_graph xr_graph yb_graph } {
variable graph
set index $g,elem-$elem
set mapx $graph($index,mapx)
set mapy $graph($index,mapy)
set x_min $graph($g,axis-$mapx,_min)
set x_max $graph($g,axis-$mapx,_max)
set x_log $graph($g,axis-$mapx,logscale)
set y_min $graph($g,axis-$mapy,_min)
set y_max $graph($g,axis-$mapy,_max)
set y_log $graph($g,axis-$mapy,logscale)
set type $graph($index,type)
set linewidth $graph($index,linewidth)
set symbol $graph($index,symbol)
set symbolcmd $graph($index,symbolcommand)
set color $graph($index,color)
set outlcolor $graph($index,outline)
set outlwidth $graph($index,outlinewidth)
set fillcolor $graph($index,fill)
set dashes $graph($index,dashes)
set smooth $graph($index,smooth)
set symsize $graph($index,pixels)
set symsize_2 [expr {$symsize / 2.0}]
set x_points {}
set y_points {}
if {$graph($index,data) != {}} {
if {[is_var_ref graph($index,data)]} {
upvar #0 $graph($index,data) xydata
} else {
upvar 0 graph($index,data) xydata
}
set count 0
foreach {x y} $xydata {
lappend x_points [transform $x $x_min $x_max $xl_graph $xr_graph $x_log]
lappend y_points [transform $y $y_min $y_max $yb_graph $yt_graph $y_log]
incr count
}
} else {
if {[is_var_ref graph($index,xdata)]} {
upvar #0 $graph($index,xdata) xdata
} else {
upvar 0 graph($index,xdata) xdata
}
if {[is_var_ref graph($index,ydata)]} {
upvar #0 $graph($index,ydata) ydata
} else {
upvar 0 graph($index,ydata) ydata
}
if {$xdata != {} && $ydata != {}} {
set count 0
foreach x $xdata y $ydata {
lappend x_points [transform $x $x_min $x_max $xl_graph $xr_graph $x_log]
lappend y_points [transform $y $y_min $y_max $yb_graph $yt_graph $y_log]
incr count
}
} else {
set count [llength $ydata]
set x 1
foreach y $ydata {
lappend x_points [transform $x 1 $count $xl_graph $xr_graph $x_log]
lappend y_points [transform $y $y_min $y_max $yb_graph $yt_graph $y_log]
incr x
}
}
}
if {$count == 0} return
if {$type == "bar"} {
SetColor $g $color
SetLinewidth $g $linewidth
set rel $graph($index,relief)
set baw $graph($index,barwidth)
set cmd $graph($index,barcommand)
set bdw $graph($index,borderwidth)
set dx [expr {$baw * ($xr_graph - $xl_graph) / ($count +1)}]
set dx2 [expr {$dx / 2.0}]
set y0 [transform 0 $y_min $y_max $yb_graph $yt_graph]
set idx 0
foreach x $x_points y $y_points {
set xl [expr {$x - $dx2}]
set xr [expr {$x + $dx2}]
if {$y >= $y0} {
set yt $y
set yb $y0
if {$yt - $yb < 2 * $bdw} {
set yt [expr {$yb + 2 * $bdw}]
}
} else {
set yt $y0
set yb $y
if {$yt - $yb < 2 * $bdw} {
set yb [expr {$yb - 2 * $bdw}]
}
}
if {$cmd != {}} {
$cmd $idx [lindex $ydata $idx] $xl $yt $xr $yb $fillcolor $rel $bdw
} else {
Rect $g $xl $yt $xr $yb $fillcolor
draw_frame $g $xl $yt $xr $yb $fillcolor $rel $bdw
}
incr idx
}
return
}
if {$type == "line"} {
SetColor $g $color
SetLinewidth $g $linewidth
SetDash $g $dashes
if {$linewidth != {} && $linewidth > 0.0} {
switch $smooth {
step {
set x_points2 {}
set y_points2 {}
set last_y {}
foreach x $x_points y $y_points {
if {$last_y != {}} {
lappend x_points2 $x
lappend y_points2 $last_y
}
lappend x_points2 $x
lappend y_points2 $y
set last_y $y
}
PolyObject $g [list $x_points2 $y_points2]
}
natural - quadratic {
MakeSplineData x_points y_points x_points2 y_points2
PolyObject $g [list $x_points2 $y_points2]
}
default {
PolyObject $g [list $x_points $y_points]
}
}
}
SetDash $g {}
if {$symbol == {} || $symbol == "none" || $symsize == 0} return
SetLinewidth $g $outlwidth
foreach x0 $x_points y0 $y_points {
if {$symbolcmd != {}} {
set name $symbol
set size $symsize_2
set fill $fillcolor
set outline $outlcolor
eval "$symbolcmd $x0 $y0 name size fill outline"
draw_symbol $g $x0 $y0 $name $size $fill $outline
} else {
draw_symbol $g $x0 $y0 $symbol $symsize_2 $fillcolor $outlcolor
}
}
return
}
return -code error "unknown element type \"$type\""
}
proc graph::data_to_bar_values { values min max clcnt {scale 1.0} } {
if {[is_var_ref values]} {
upvar #0 $values data
} else {
upvar 0 values data
}
set count [llength $data]
set range [expr {$max - $min}]
set clmax [expr {$clcnt -1}]
set delta [expr {$range / $clcnt}]
array set classes {}
for {set class 0} {$class < $clcnt} {incr class} {
set classes($class) 0
}
foreach val $data {
set class [expr {round($clcnt * ($val - $min) / $range)}]
if {$class < 0} { set class 0 }
if {$class > $clmax} { set class $clmax }
incr classes($class)
}
set clvals {}
set bars {}
set value $min
for {set class 0} {$class < $clcnt} {incr class} {
lappend clvals $value
set value [expr {$value + $delta}]
lappend bars [expr {$scale * $classes($class) / $count}]
}
return [list $clvals $bars $delta]
}
###############################################################################
#
# axis components
#
proc graph::axis { g operation params } {
variable graph
switch -- $operation {
create {
set name [lindex $params 0]
obj_defaults $g,axis-$name axis_defaults
axis $g configure $params
lappend graph($g,_axises) $name
}
configure {
set name [lindex $params 0]
obj_configure $g,axis-$name [lrange $params 1 end]
foreach item {min max} {
if {$graph($g,axis-$name,$item) != {}} {
set graph($g,axis-$name,_$item) $graph($g,axis-$name,$item)
}
}
}
cget {
set name [lindex $params 0]
return [obj_cget $g,axis-$name [lindex $params 1]]
}
delete {
obj_delete $g,_axises $g,axis $params
}
names {
if {$params == {}} { set params * }
return [obj_names $g,_axises $params]
}
default {
return -code error "unknown operation \"$operation\""
}
}
}
proc graph::axisusage { g axisplace params } {
variable graph
# example moving the x-axis to the right side: $g x2axis use x
if {[lindex $params 0] != "use"} {
return -code error "invalid command \"$params\" to $axisplace"
}
set alist [lrange $params 1 end]
if {[llength $alist] == 1} { set alist [lindex $params 1] }
foreach axis $alist {
if {[lsearch {xaxis yaxis x2axis y2axis} $axisplace] == -1} {
return -code error "unknown axis place \"$axisplace\""
}
if {$axis != {}} {
foreach place {xaxis yaxis x2axis y2axis} {
if {[set idx [lsearch $graph($g,_$place) $axis]] != -1} {
set graph($g,_$place) [lreplace $graph($g,_$place) $idx $idx]
}
}
lappend graph($g,_$axisplace) $axis
}
}
return $graph($g,_$axisplace)
}
proc graph::axis_getplace { g name } {
variable graph
foreach place {xaxis yaxis x2axis y2axis} {
if {[lsearch $graph($g,_$place) $name] != -1} {
return $place
}
}
}
# Reference: Paul Heckbert "Nice Numbers for Graph Labels", Graphics Gems, pp 61-63
proc graph::nicenum { x round } {
set expt [expr {floor(log10($x))}]
set frac [expr {$x / pow(10,$expt)}]
if {$round} {
if {$frac < 1.5} {
set nice 1.0
} elseif {$frac < 3.0} {
set nice 2.0
} elseif {$frac < 7.0} {
set nice 5.0
} else {
set nice 10.0
}
} else {
if {$frac < 1.0} {
set nice 1.0
} elseif {$frac < 2.0} {
set nice 2.0
} elseif {$frac < 5.0} {
set nice 5.0
} else {
set nice 10.0
}
}
set val [expr {$nice * pow(10,$expt)}]
return $val
}
# Reference: BLT bltGrAxis.c LogScaleAxis()
proc graph::axis_logscale { index min max } {
variable graph
variable num_ticks
if {$graph($index,min) != {}} { set min $graph($index,min) }
if {$graph($index,max) != {}} { set max $graph($index,max) }
set min [expr {($min != 0.0)? log10(abs($min)) : 0.0}]
set max [expr {($max != 0.0)? log10(abs($max)) : 1.0}]
set nMajor 0; set nMinor 0
set majorStep 0.0; set minorStep 0.0
set tickMin [expr {floor($min)}]
set tickMax [expr {ceil($max)}]
set range [expr {$tickMax - $tickMin}]
if {$range > 10} {
set range [nicenum $range no]
set majorStep [nicenum [expr {$range / double($num_ticks)}] yes]
set tickMin [expr {floor($tickMin / $majorStep) * $majorStep}]
set tickMax [expr {ceil($tickMax / $majorStep) * $majorStep}]
set nMajor [expr {int(($tickMax - $tickMin) / $majorStep) +1}]
set minorStep [expr {pow(10, floor(log10($majorStep)))}]
if {$minorStep == $majorStep} {
set nMinor 4
set minorStep 0.2
} else {
set nMinor [expr {round($majorStep / $minorStep) -1}]
}
} else {
if {$tickMin == $tickMax} { incr tickMax }
set majorStep 1.0
set nMajor [expr {int($tickMax - $tickMin +1)}]
set minorStep 0.0
set nMinor 10
}
if {$graph($index,loose)} {
set graph($index,_min) $min
set graph($index,_max) $max
} else {
set graph($index,_min) $tickMin
set graph($index,_max) $tickMax
}
set graph($index,_step) $majorStep
set graph($index,_first) [expr {floor($tickMin)}]
set graph($index,_range) [expr {$graph($index,_max) - $graph($index,_min)}]
set graph($index,_steps) $nMajor
}
# Reference: BLT bltGrAxis.c LinearScaleAxis()
proc graph::axis_linearscale { index min max } {
variable graph
variable num_ticks
if {$graph($index,min) != {}} { set min $graph($index,min) }
if {$graph($index,max) != {}} { set max $graph($index,max) }
set nTicks 0
set tickMin 0.0
set tickMax 0.0
set range [expr {$max - $min}]
# Calculate the major tick stepping.
if {$graph($index,stepsize) > 0.0} {
set step $graph($index,stepsize)
while {2 * $step >= $range} {
set step [expr {$step * 0.5}]
}
} else {
set range [nicenum $range no]
set step [nicenum [expr {$range / double($num_ticks)}] yes]
}
set graph($index,_step) $step
# Find the outer tick values.
set tickMin [expr {floor($min / $step) * $step}]
set tickMax [expr {ceil($max / $step) * $step}]
if {$graph($index,loose)} {
set graph($index,_min) $min
set graph($index,_max) $max
} else {
set graph($index,_min) $tickMin
set graph($index,_max) $tickMax
}
set graph($index,_first) $tickMin
set graph($index,_range) [expr {$graph($index,_max) - $graph($index,_min)}]
set graph($index,_steps) [expr {round(($tickMax - $tickMin) / $step) +1}]
}
proc graph::axis_calc { g name } {
variable graph
set index $g,axis-$name
set place [axis_getplace $g $name]
set graph($index,_place) $place
if {$place == {}} return
switch $place {
xaxis - x2axis { set orient horizontal; set minitem _xmin; set maxitem _xmax }
yaxis - y2axis { set orient vertical; set minitem _ymin; set maxitem _ymax }
}
set min 1e300
set max -1e300
set bargraph false
foreach elem $graph($g,_elements) {
if {$graph($g,elem-$elem,_valid)} {
set val $graph($g,elem-$elem,$minitem)
if {$val < $min} { set min $val }
set val $graph($g,elem-$elem,$maxitem)
if {$val > $max} { set max $val }
if {$graph($g,elem-$elem,type) == "bar"} {
set bargraph true
if {$orient == "horizontal"} {
set min [expr {$min - 0.5}]
set max [expr {$max + 0.5}]
}
}
}
}
if {$graph($index,min) != {}} { set min $graph($index,min) }
if {$graph($index,max) != {}} { set max $graph($index,max) }
if {$min == $max} return
if {$min > $max} { set min 0.0; set max 1.0 }
if {$bargraph} {
if {$orient == "horizontal"} {
if {$graph($index,stepsize) == 0.0} {
set graph($index,stepsize) 1.0
}
if {$graph($index,subdivisions) == {}} {
set graph($index,subdivisions) 1
}
}
if {$orient == "vertical"} {
if {$graph($index,min) == {} && $min > 0.0} {
set graph($index,min) 0.0
}
if {$graph($index,max) == {} && $max < 0.0} {
set graph($index,max) 0.0
}
}
}
set logscale $graph($index,logscale)
if {$logscale} {
axis_logscale $index $min $max
} else {
axis_linearscale $index $min $max
}
set step $graph($index,_step)
set steps $graph($index,_steps)
set first $graph($index,_first)
set format $graph($index,_format)
set angle $graph($index,rotate)
set majorticks $graph($index,majorticks)
set value $first
if {$graph($index,hide)} {
set graph($index,_width) 0
set graph($index,_height) 0
} else {
if {$graph($index,title) != ""} {
foreach {font size attr} $graph($index,titlefont) {}
SetFont $g $font $size $attr
set margin1 0.25
set title_h [expr {[LineHeight] + $margin1}]
} else {
set title_h 0
}
foreach {font size attr} $graph($index,tickfont) {}
SetFont $g $font $size $attr
set dy [LineHeight]
set box_h 0; set box_w 0
set max_h 0; set max_w 0
set graph($index,_txts) {}
if {$majorticks == {}} {
for {set idx 0} {$idx < $steps} {incr idx} {
if {$graph($index,command) != {}} {
set txt [eval "$graph($index,command) $g $value"]
} else {
if {$logscale} {
set txt [format $format [expr {pow(10,round($value))}]]
} else {
set txt [format $format $value]
}
}
set dx [TextWidth $txt]
set size [calc_box $dx $dy $angle box_w box_h]
lappend graph($index,_txts) [list $txt $dx $dy $box_w $box_h $size]
set box_w [expr {abs($box_w)}]
set box_h [expr {abs($box_h)}]
if {$box_w > $max_w} { set max_w $box_w }
if {$box_h > $max_h} { set max_h $box_h }
set value [expr {$value + $step}]
}
} else {
foreach value $majorticks {
if {$graph($index,command) != {}} {
set txt [eval "$graph($index,command) $g $value"]
} else {
set txt [format $format $value]
}
set dx [TextWidth $txt]
set size [calc_box $dx $dy $angle box_w box_h]
lappend graph($index,_txts) [list $txt $dx $dy $box_w $box_h $size]
set box_w [expr {abs($box_w)}]
set box_h [expr {abs($box_h)}]
if {$box_w > $max_w} { set max_w $box_w }
if {$box_h > $max_h} { set max_h $box_h }
}
}
set graph($index,_width) $max_w
set graph($index,_height) $max_h
set ticklen $graph($index,ticklength)
set margin2 0.35
if {$orient == "horizontal"} {
set graph($index,_height) [expr {$max_h + $ticklen + $margin2 + $title_h}]
} else {
set graph($index,_width) [expr {$max_w + $ticklen + $margin2 + $title_h}]
}
}
set graph($index,_valid) yes
}
proc graph::axis_draw_tick { g axis value min max p1 p2 tick1 tick2 margin
ticktxt angle dogrid_major
grid_color grid_linew grid_dashes p3 p4 } {
switch $axis {
x - y { set factor -1 }
x2 - y2 { set factor 1 }
}
switch $axis {
x - x2 {
set x [transform $value $min $max $p1 $p2]
if {$x >= $p1 && $x <= $p2} {
Line $g $x $tick1 $x $tick2
foreach {txt tw th bw bh size} $ticktxt {}
set xc $x
set yc [expr {$tick2 + $factor * ($margin + 0.5 * abs($bh))}]
text_rot $g $txt $xc $yc $tw $th $angle
if {$dogrid_major} {
gridline $g $grid_color $grid_linew $grid_dashes $x $p3 $x $p4
}
}
}
y - y2 {
set y [transform $value $min $max $p1 $p2]
if {$y >= $p1 && $y <= $p2} {
Line $g $tick1 $y $tick2 $y
foreach {txt tw th bw bh size} $ticktxt {}
set xc [expr {$tick2 + $factor * ($margin + 0.5 * abs($bw))}]
set yc $y
text_rot $g $txt $xc $yc $tw $th $angle
if {$dogrid_major} {
gridline $g $grid_color $grid_linew $grid_dashes $p3 $y $p4 $y
}
}
}
}
}
proc graph::axis_draw_subticks { g axis val div interval step min max p1 p2
logscale tick1 tick3 dogrid_minor
grid_color grid_linew grid_dashes
minorticks p3 p4 } {
if {$logscale} {
set step [expr {10 * $step * pow(10,$val)}]
set val 0
}
switch $axis {
x - x2 {
if {$minorticks == {}} {
for {set subidx 1} {$subidx < $div} {incr subidx} {
set val [expr {$val + $step}]
set x [transform $val $min $max $p1 $p2 $logscale]
if {$x >= $p1 && $x <= $p2} {
Line $g $x $tick1 $x $tick3
if {$dogrid_minor} {
gridline $g $grid_color $grid_linew $grid_dashes $x $p3 $x $p4
}
}
}
} else {
foreach minorval $minorticks {
set x [transform [expr {$val+$minorval*$interval}] $min $max $p1 $p2 $logscale]
if {$x >= $p1 && $x <= $p2} {
Line $g $x $tick1 $x $tick3
if {$dogrid_minor} {
gridline $g $grid_color $grid_linew $grid_dashes $x $p3 $x $p4
}
}
}
}
}
y - y2 {
if {$minorticks == {}} {
for {set subidx 1} {$subidx < $div} {incr subidx} {
set val [expr {$val + $step}]
set y [transform $val $min $max $p1 $p2 $logscale]
if {$y >= $p1 && $y <= $p2} {
Line $g $tick1 $y $tick3 $y
if {$dogrid_minor} {
gridline $g $grid_color $grid_linew $grid_dashes $p3 $y $p4 $y
}
}
}
} else {
foreach minorval $minorticks {
set y [transform [expr {$val+$minorval*$interval}] $min $max $p1 $p2 $logscale]
if {$y >= $p1 && $y <= $p2} {
Line $g $tick1 $y $tick3 $y
if {$dogrid_minor} {
gridline $g $grid_color $grid_linew $grid_dashes $p3 $y $p4 $y
}
}
}
}
}
}
}
proc graph::axis_draw { g name xl yt xr yb
xl_graph yt_graph xr_graph yb_graph } {
variable graph
set index $g,axis-$name
if {!$graph($index,_valid)} return
if {$graph($index,hide)} return
if {$graph($index,title) != ""} {
set txt $graph($index,title)
SetColor $g $graph($index,titlecolor)
foreach {font size attr} $graph($index,titlefont) {}
SetFont $g $font $size $attr
set tw [TextWidth $txt]
set th [LineHeight]
switch $graph($index,_place) {
yaxis {
set yc [expr {$yb + 0.5 * ($yt - $yb)}]
set xc [expr {$xl + 0.7 * $th}]
text_rot $g $txt $xc $yc $tw $th 90
}
y2axis {
set yc [expr {$yb + 0.5 * ($yt - $yb)}]
set xc [expr {$xr - 0.7 * $th}]
text_rot $g $txt $xc $yc $tw $th -90
}
xaxis {
set xc [expr {$xl + 0.5 * ($xr - $xl)}]
set yc [expr {$yb + 0.7 * $th}]
text_rot $g $txt $xc $yc $tw $th 0
}
x2axis {
set xc [expr {$xl + 0.5 * ($xr - $xl)}]
set yc [expr {$yt - 0.7 * $th}]
text_rot $g $txt $xc $yc $tw $th 0
}
}
}
SetColor $g $graph($index,color)
SetLinewidth $g $graph($index,linewidth)
foreach {font size attr} $graph($index,tickfont) {}
SetFont $g $font $size $attr
set asc2 [expr {$size * 0.33}]
set margin 0.7
set ticklen $graph($index,ticklength)
set command $graph($index,command)
set subdiv $graph($index,subdivisions)
set angle $graph($index,rotate)
set logscale $graph($index,logscale)
set majorticks $graph($index,majorticks)
set minorticks $graph($index,minorticks)
set first $graph($index,_first)
set min $graph($index,_min)
set max $graph($index,_max)
set step $graph($index,_step)
set steps $graph($index,_steps)
set format $graph($index,_format)
set value $first
if {$subdiv == {}} {
if {$logscale} {
set subdiv 10
} else {
set subdiv 2
}
}
set substep [expr {double($step) / $subdiv}]
set dogrid_major no
set dogrid_minor no
if {!$graph($g,grid,hide) &&
($graph($g,grid,mapx) == $name || $graph($g,grid,mapy) == $name)} {
set dogrid_major yes
set dogrid_minor $graph($g,grid,minor)
}
set axis_linew $graph($index,linewidth)
set grid_color [GetRGB $graph($g,grid,color)]
set grid_linew $graph($g,grid,linewidth)
set grid_dashes $graph($g,grid,dashes)
if {$axis_linew == 0} {
set dogrid_major false
set dogrid_minor false
}
switch $graph($index,_place) {
xaxis {
Line $g $xl $yt $xr $yt
set y_tick1 $yt
set y_tick2 [expr {$yt - $ticklen}]
set y_tick3 [expr {$yt - $ticklen / 2.0}]
set y_text $yb
if {$majorticks == {}} {
for {set idx 0} {$idx < $steps} {incr idx} {
set txt [lindex $graph($index,_txts) $idx]
axis_draw_tick $g x $value $min $max $xl $xr $y_tick1 $y_tick2 $margin \
$txt $angle $dogrid_major $grid_color $grid_linew $grid_dashes $yt_graph $yb_graph
axis_draw_subticks $g x $value $subdiv $step $substep $min $max $xl $xr $logscale \
$y_tick1 $y_tick3 $dogrid_minor $grid_color $grid_linew $grid_dashes $minorticks \
$yt_graph $yb_graph
set value [expr {$value + $step}]
}
} else {
set idx 0
foreach value $majorticks {
set txt [lindex $graph($index,_txts) $idx]
axis_draw_tick $g x $value $min $max $xl $xr $y_tick1 $y_tick2 $margin \
$txt $angle $dogrid_major $grid_color $grid_linew $grid_dashes $yt_graph $yb_graph
incr idx
}
}
}
x2axis {
Line $g $xl $yb $xr $yb
set y_tick1 $yb
set y_tick2 [expr {$yb + $ticklen}]
set y_tick3 [expr {$yt + $ticklen / 2.0}]
set y_text [expr {$yt - [LineHeight]}]
if {$majorticks == {}} {
for {set idx 0} {$idx < $steps} {incr idx} {
set txt [lindex $graph($index,_txts) $idx]
axis_draw_tick $g x2 $value $min $max $xl $xr $y_tick1 $y_tick2 $margin \
$txt $angle $dogrid_major $grid_color $grid_linew $grid_dashes $yt_graph $yb_graph
axis_draw_subticks $g x2 $value $subdiv $step $substep $min $max $xl $xr $logscale \
$y_tick1 $y_tick3 $dogrid_minor $grid_color $grid_linew $grid_dashes $minorticks \
$yt_graph $yb_graph
set value [expr {$value + $step}]
}
} else {
set idx 0
foreach value $majorticks {
set txt [lindex $graph($index,_txts) $idx]
axis_draw_tick $g x2 $value $min $max $xl $xr $y_tick1 $y_tick2 $margin \
$txt $angle $dogrid_major $grid_color $grid_linew $grid_dashes $yt_graph $yb_graph
incr idx
}
}
}
yaxis {
Line $g $xr $yt $xr $yb
set x_tick1 $xr
set x_tick2 [expr {$xr - $ticklen}]
set x_tick3 [expr {$xr - $ticklen / 2.0}]
set x_text [expr {$x_tick2 - $margin}]
if {$majorticks == {}} {
for {set idx 0} {$idx < $steps} {incr idx} {
set txt [lindex $graph($index,_txts) $idx]
axis_draw_tick $g y $value $min $max $yb $yt $x_tick1 $x_tick2 $margin \
$txt $angle $dogrid_major $grid_color $grid_linew $grid_dashes $xl_graph $xr_graph
axis_draw_subticks $g y $value $subdiv $step $substep $min $max $yb $yt $logscale \
$x_tick1 $x_tick3 $dogrid_minor $grid_color $grid_linew $grid_dashes $minorticks \
$xl_graph $xr_graph
set value [expr {$value + $step}]
}
} else {
set idx 0
foreach value $majorticks {
set txt [lindex $graph($index,_txts) $idx]
axis_draw_tick $g y $value $min $max $yb $yt $x_tick1 $x_tick2 $margin \
$txt $angle $dogrid_major $grid_color $grid_linew $grid_dashes $xl_graph $xr_graph
incr idx
}
}
}
y2axis {
Line $g $xl $yt $xl $yb
set x_tick1 $xl
set x_tick2 [expr {$xl + $ticklen}]
set x_tick3 [expr {$xl + $ticklen / 2.0}]
set x_text [expr {$x_tick2 + $margin}]
if {$majorticks == {}} {
for {set idx 0} {$idx < $steps} {incr idx} {
set txt [lindex $graph($index,_txts) $idx]
axis_draw_tick $g y2 $value $min $max $yb $yt $x_tick1 $x_tick2 $margin \
$txt $angle $dogrid_major $grid_color $grid_linew $grid_dashes $xl_graph $xr_graph
axis_draw_subticks $g y2 $value $subdiv $step $substep $min $max $yb $yt $logscale \
$x_tick1 $x_tick3 $dogrid_minor $grid_color $grid_linew $grid_dashes $minorticks \
$xl_graph $xr_graph
set value [expr {$value + $step}]
}
} else {
set idx 0
foreach value $majorticks {
set txt [lindex $graph($index,_txts) $idx]
axis_draw_tick $g y2 $value $min $max $yb $yt $x_tick1 $x_tick2 $margin \
$txt $angle $dogrid_major $grid_color $grid_linew $grid_dashes $xl_graph $xr_graph
incr idx
}
}
}
}
}
proc graph::axis_invalidate { g } {
variable graph
foreach name $graph($g,_axises) {
set graph($g,axis-$name,_valid) no
}
}
###############################################################################
#
# legend components
#
proc graph::legend { g operation params } {
variable graph
switch -- $operation {
configure {
obj_configure $g,legend $params
}
cget {
return [obj_cget $g,legend $params 1]
}
default {
return -code error "unknown operation \"$operation\""
}
}
}
proc graph::legend_calc { g } {
variable graph
set titles {}
foreach elem $graph($g,_elements) {
set index $g,elem-$elem
if {$graph($index,_valid)} {
lappend titles $graph($index,_title)
}
}
set index $g,legend
if {$graph($index,hide)} {
set graph($index,_valid) no
return
}
switch $graph($index,position) {
left - right { set inmargin yes; set graph($index,_orientation) vertical }
top - bottom { set inmargin yes; set graph($index,_orientation) horizontal }
default { set inmargin no; set graph($index,_orientation) vertical }
}
set graph($index,_inmargin) $inmargin
if {$titles == {}} {
set graph($index,_width) 0
set graph($index,_height) 0
set graph($index,_valid) no
return
}
set count [llength $titles]
foreach {font size attr} $graph($index,font) {}
SetFont $g $font $size $attr
set objwidth [expr {1.5 * $size}]
set objsize [expr {$size / 3.0}]
set graph($index,_objwidth) $objwidth
set graph($index,_objsize) $objsize
set padx $graph($index,padx)
set pady $graph($index,pady)
set ipadx $graph($index,ipadx)
set ipady $graph($index,ipady)
set bdw $graph($index,borderwidth)
if {$graph($index,_orientation) == "vertical"} {
set graph($index,_height) [expr {$count * ([LineHeight] + $ipady) + $ipady}]
set maxwidth 0
foreach title $titles {
set txtwidth [TextWidth $title]
set width [expr {$objwidth + $ipadx + $txtwidth}]
if {$width > $maxwidth} { set maxwidth $width }
}
set graph($index,_width) [expr {$ipadx + $maxwidth + $ipadx}]
} else {
set graph($index,_height) [expr {[LineHeight] + 2 * $ipady}]
set sumwidth 0
foreach title $titles {
set txtwidth [TextWidth $title]
set width [expr {$objwidth + $ipadx + $txtwidth}]
set sumwidth [expr {$sumwidth + $ipadx + $width}]
}
set graph($index,_width) [expr {$sumwidth + $ipadx}]
}
set graph($index,_width) [expr {$graph($index,_width) + 2 * ($bdw + $padx)}]
set graph($index,_height) [expr {$graph($index,_height) + 2 * ($bdw + $pady)}]
set graph($index,_valid) yes
}
proc graph::legend_draw { g x_left y_top x_right y_bottom } {
variable graph
set index $g,legend
set padx $graph($index,padx)
set pady $graph($index,pady)
set ipadx $graph($index,ipadx)
set ipady $graph($index,ipady)
set bdw $graph($index,borderwidth)
set bgc $graph($index,background)
set fgc $graph($index,foreground)
set rel $graph($index,relief)
set anchor $graph($index,anchor)
set pos $graph($index,position)
if {$pos == "plotarea"} { set pos top }
set width $graph($index,_width)
set height $graph($index,_height)
set objwidth $graph($index,_objwidth)
set objsize $graph($index,_objsize)
set orientation $graph($index,_orientation)
set xl $x_left
set xr [expr {$xl + $width}]
set yt $y_top
set yb [expr {$yt - $height}]
switch -glob -- $pos {
left {
set xl $x_left
set xr [expr {$xl + $width}]
}
right {
set xr $x_right
set xl [expr {$xr - $width}]
}
top - bottom {
switch $anchor {
n - s - center {
set xl [expr {$x_left + ($x_right - $x_left - $width) / 2.0}]
set xr [expr {$xl + $width}]
}
w {
set xl $x_left
set xr [expr {$xl + $width}]
}
e {
set xr $x_right
set xl [expr {$xr - $width}]
}
}
}
@*,* {
if {[regexp {@([\d\.\-mcpi]+),([\d\.\-mcpi]+)$} $pos all pos_x pos_y]} {
if {$pos_x > 0} {
set xl [expr {$x_left + $pos_x}]
set xr [expr {$xl + $width}]
} else {
set xr [expr {$x_right - $pos_x}]
set xl [expr {$xr - $width}]
}
}
}
}
switch -glob -- $graph($index,position) {
left - right {
switch $anchor {
n {
set yt $y_top
set yb [expr {$yt - $height}]
}
s {
set yb $y_bottom
set yt [expr {$yb + $height}]
}
e - w - center {
set yb [expr {$x_bottom + ($x_top - $x_bottom - $height) / 2.0}]
set yt [expr {$yb + $height}]
}
}
}
top {
set yt $y_top
set yb [expr {$yt - $height}]
}
bottom {
set yb $y_bottom
set yt [expr {$yb + $height}]
}
@*,* {
if {[regexp {@([\d\.\-mcpi]+),([\d\.\-mcpi]+)$} $pos all pos_x pos_y]} {
if {$pos_y > 0} {
set yt [expr {$y_top - $pos_y}]
set yb [expr {$yt - $height}]
} else {
set yb [expr {$y_bottom - $pos_y}]
set yt [expr {$yb + $height}]
}
}
}
}
# shrink area with padding
set xl [expr {$xl + $padx}]
set xr [expr {$xr - $padx}]
set yt [expr {$yt - $pady}]
set yb [expr {$yb + $pady}]
# draw background rect
set_linewidth $g -1
Rect $g $xl $yt $xr $yb $bgc
set_linewidth $g 0
# draw border frame
if {$bdw > 0} {
draw_frame $g $xl $yt $xr $yb $bgc $rel $bdw
# shrink area with border width
set xl [expr {$xl + $bdw}]
set xr [expr {$xr - $bdw}]
set yt [expr {$yt - $bdw}]
set yb [expr {$yb + $bdw}]
}
foreach {font size attr} $graph($index,font) {}
SetFont $g $font $size $attr
set fh [LineHeight]
set yt [expr {$yt - $ipady}]
set xl [expr {$xl + $ipadx}]
foreach elem $graph($g,_elements) {
set eidx $g,elem-$elem
if {!$graph($eidx,_valid)} continue
set e_color $graph($eidx,color)
set e_fcolor $graph($eidx,fill)
set e_ocolor $graph($eidx,outline)
set e_symbol $graph($eidx,symbol)
set e_type $graph($eidx,type)
set e_dashes $graph($eidx,dashes)
set title $graph($eidx,_title)
set yb [expr {$yt - $fh}]
set ym [expr {$yt - $fh * 0.5}]
set yT [expr {$yt - $fh * 0.8}]
set xs [expr {$xl + $objwidth / 2.0}]
set xr [expr {$xl + $objwidth}]
SetColor $g $e_color
SetLinewidth $g 0.5
if {$e_type == "line"} {
SetDash $g $e_dashes
Line $g $xl $ym $xr $ym
SetDash $g {}
}
SetLinewidth $g 0.2
if {$e_type == "bar"} { set e_symbol square }
draw_symbol $g $xs $ym $e_symbol $objsize $e_fcolor $e_ocolor
SetColor $g $fgc
set xT [expr {$xr + $ipadx}]
Text $g $xT $yT $title
if {$orientation == "vertical"} {
set yt [expr {$yb - $ipady}]
} else {
set txtwidth [TextWidth $title]
set xl [expr {$xr + $ipadx + $txtwidth + $ipadx}]
}
}
}
###############################################################################
#
# marker components
#
proc graph::marker { g operation params } {
variable graph
switch -- $operation {
create {
variable marker_idx
set name m[incr marker_idx]
obj_defaults $g,marker-$name marker_defaults
set graph($g,marker-$name,type) [lindex $params 0]
set graph($g,marker-$name,name) $name
set params [lreplace $params 0 0 $name]
marker $g configure $params
lappend graph($g,_markers) $name
return $name
}
configure {
set name [lindex $params 0]
obj_configure $g,marker-$name [lrange $params 1 end]
}
cget {
set name [lindex $params 0]
return [obj_cget $g,marker-$name [lindex $params 1]]
}
delete {
obj_delete $g,_markers $g,marker $params
}
exists {
if {[lsearch [marker $g names] [lindex $params 0]] != -1} {
return yes
} else {
return no
}
}
names {
if {$params == {}} { set params * }
return [obj_names $g,_markers $params]
}
default {
return -code error "unknown operation \"$operation\""
}
}
}
proc graph::marker_draw { g marker xl_graph yt_graph xr_graph yb_graph } {
variable graph
set index $g,marker-$marker
if {$graph($index,hide) ||
$graph($index,coords) == {}} continue
set mapx $graph($index,mapx)
set mapy $graph($index,mapy)
set coords $graph($index,coords)
set type $graph($index,type)
set xsub $graph($index,xoffset)
set ysub $graph($index,yoffset)
set elem $graph($index,element)
if {$elem != {}} {
if {[lsearch $graph($g,_elements) $elem] == -1} continue
if {!$graph($g,elem-$elem,_valid)} continue
}
if {[lsearch -exact $graph($g,_axises) $mapx] == -1 ||
[lsearch -exact $graph($g,_axises) $mapy] == -1 } continue
set x_min $graph($g,axis-$mapx,_min)
set x_max $graph($g,axis-$mapx,_max)
set x_log $graph($g,axis-$mapx,logscale)
set y_min $graph($g,axis-$mapy,_min)
set y_max $graph($g,axis-$mapy,_max)
set y_log $graph($g,axis-$mapy,logscale)
set clist {}
foreach {x y} $coords {
lappend clist [transform [expr {$x - $xsub}] $x_min $x_max $xl_graph $xr_graph $x_log]
lappend clist [transform [expr {$y - $ysub}] $y_min $y_max $yb_graph $yt_graph $y_log]
}
switch -- $type {
line {
SetDash $g $graph($index,dashes)
SetColor $g $graph($index,outline)
SetLinewidth $g $graph($index,linewidth)
foreach {xl yt xr yb} $clist {}
Line $g $xl $yt $xr $yb
SetDash $g {}
}
polygon {
SetDash $g $graph($index,dashes)
SetColor $g $graph($index,outline)
SetLinewidth $g $graph($index,linewidth)
set x_list {}
set y_list {}
foreach {x y} $clist {
lappend x_list $x
lappend y_list $y
}
PolyObject $g [list $x_list $y_list] [GetRGB $graph($index,fill)]
SetDash $g {}
}
text {
set text $graph($index,text)
if {$text != {}} {
set fill $graph($index,fill)
set anchor $graph($index,anchor)
set justify $graph($index,justify)
set padx $graph($index,padx)
set pady $graph($index,pady)
SetColor $g $graph($index,outline)
foreach {font size attr} $graph($index,font) {}
SetFont $g $font $size $attr
foreach {x y} $clist {}
set lines [split $text \n]
set lcnt [llength $lines]
set tw 0
foreach line $lines {
set w [TextWidth $line]
if {$w > $tw} { set tw $w }
}
set lh [LineHeight]
set dx [expr {$tw + 2 * $padx}]
set dy [expr {$lcnt * $lh + 2 * $pady}]
set xl [expr {$x - $dx / 2.0}]
set yt [expr {$y + $dy / 2.0}]
if {$anchor != "center"} {
foreach item [split $anchor {}] {
switch $item {
n { set yt $y }
s { set yt [expr {$y + $dy}] }
w { set xl $x }
e { set xl [expr {$x - $dx}] }
}
}
}
if {$fill != {}} {
SetLinewidth $g -1
set xr [expr {$xl + $dx}]
set yb [expr {$yt - $dy}]
Rect $g $xl $yt $xr $yb $fill
}
set x [expr {$xl + $padx}]
set y [expr {$yt - $pady - 0.8 * $lh}]
set w [expr {$dx - 2 * $padx}]
foreach line $lines {
switch $justify {
left { Text $g $x $y $line }
center { Text $g $x $y $line center $w }
right { Text $g $x $y $line right $w }
}
set y [expr {$y - $lh}]
}
}
}
image {
set pname $graph($index,image)
if {[PictSize $g $pname] == {}} {
LoadPict $g $pname
}
if {[set psize [PictSize $g $pname]] == {}} return
foreach {dx dy} $psize {}
foreach {x0 y0} $clist {}
set x [expr {$x0 - $dx / 2.0}]
set y [expr {$y0 - $dy / 2.0}]
Pict $g $x $y $pname
}
}
}
###############################################################################
#
# grid components
#
proc graph::grid { g operation params } {
variable graph
switch -- $operation {
configure {
obj_configure $g,grid $params
}
cget {
return [obj_cget $g,grid [lindex $params 0]]
}
on {
set graph($g,grid,hide) no
}
off {
set graph($g,grid,hide) yes
}
toggle {
if {$graph($g,grid,hide)} {
grid $g on
} else {
grid $g off
}
}
default {
return -code error "unknown operation \"$operation\""
}
}
}
proc graph::gridline { g color linewidth dashes x1 y1 x2 y2 } {
variable graph
set org_linewidth [get_opt $g linewidth]
set org_rgbcolor [get_opt $g rgbcolor]
SetLinewidth $g $linewidth
SetColor $g $color
SetDash $g $dashes
Line $g $x1 $y1 $x2 $y2
SetLinewidth $g $org_linewidth
SetColor $g $org_rgbcolor
SetDash $g {}
}
###############################################################################
#
# graph drawing proc
#
proc graph::draw { g x0 y0 } {
variable graph
set origin [GetOrigin $g]
set org_font [get_opt $g font]
set org_linewidth [get_opt $g linewidth]
set org_rgbcolor [get_opt $g rgbcolor]
set org_dashpattern [get_opt $g dashpattern]
foreach elem $graph($g,_elements) {
elem_calc $g $elem
}
foreach axis $graph($g,_axises) {
axis_calc $g $axis
}
legend_calc $g
set margin $graph($g,_margin)
set g_width $graph($g,width)
set g_height $graph($g,height)
CalcXY $g x0 y0 ;# page coords to bottom-left related
if {$origin} { ;# 0/0 = top-left
set x_left $x0
set x_right [expr {$x_left + $g_width}]
set y_bottom [expr {$y0 - $g_height}]
set y_top $y0
} else { ;# 0/0 = bottom-left
set x_left $x0
set x_right [expr {$x_left + $g_width}]
set y_bottom $y0
set y_top [expr {$y0 + $g_height}]
}
set bgc $graph($g,background)
set bdw $graph($g,borderwidth)
set rel $graph($g,relief)
set_opt $g linewidth -1
Rect $g $x_left $y_top $x_right $y_bottom $bgc
set_opt $g linewidth 0
draw_frame $g $x_left $y_top $x_right $y_bottom $bgc $rel $bdw
set x_left [expr {$x_left + $bdw + $margin}]
set x_right [expr {$x_right - $bdw - $margin}]
set y_top [expr {$y_top - $bdw - $margin}]
set y_bottom [expr {$y_bottom + $bdw + $margin}]
# draw graph title:
if {$graph($g,title) != ""} {
foreach {font size attr} $graph($g,font) {}
SetFont $g $font $size $attr
set fh [LineHeight]
set y_text [expr {$y_top - $margin - $fh * 0.8}]
set txtlen [TextWidth $graph($g,title)]
switch $graph($g,justify) {
left {
set x_text [expr {$x_left + $margin}]
}
center {
set x_text [expr {$x_left + ($x_right - $x_left - $txtlen) / 2.0}]
}
right {
set x_text [expr {$x_right - $margin - $txtlen}]
}
}
Text $g $x_text $y_text $graph($g,title)
set y_top [expr {$y_top - $fh - 2 * $margin}]
}
# draw legend in margin:
if {$graph($g,legend,_valid)} {
if {$graph($g,legend,_inmargin)} {
legend_draw $g $x_left $y_top $x_right $y_bottom
}
set width $graph($g,legend,_width)
set height $graph($g,legend,_height)
switch $graph($g,legend,position) {
left { set x_left [expr {$x_left + $width + $margin}] }
right { set x_right [expr {$x_right - $width - $margin}] }
top { set y_top [expr {$y_top - $height - $margin}] }
bottom { set y_bottom [expr {$y_bottom + $height + $margin}] }
}
}
# calc drawing area:
set xl_draw $x_left
set xr_draw $x_right
set yt_draw $y_top
set yb_draw $y_bottom
if {$graph($g,bottommargin) > 0} {
set yb_draw [expr {$yb_draw + $graph($g,bottommargin) + $margin}]
} else {
foreach axis $graph($g,_xaxis) {
set index $g,axis-$axis
if {!$graph($index,_valid)} continue
set yb_draw [expr {$yb_draw + $graph($index,_height) + $margin}]
}
}
if {$graph($g,topmargin) > 0} {
set yt_draw [expr {$yt_draw - $graph($g,topmargin) - $margin}]
} else {
foreach axis $graph($g,_x2axis) {
set index $g,axis-$axis
if {!$graph($index,_valid)} continue
set yt_draw [expr {$yt_draw - $graph($index,_height) - $margin}]
}
}
if {$graph($g,leftmargin) > 0} {
set xl_draw [expr {$xl_draw + $graph($g,leftmargin) + $margin}]
} else {
foreach axis $graph($g,_yaxis) {
set index $g,axis-$axis
if {!$graph($index,_valid)} continue
set xl_draw [expr {$xl_draw + $graph($index,_width) + $margin}]
}
}
if {$graph($g,rightmargin) > 0} {
set xr_draw [expr {$xr_draw - $graph($g,rightmargin) - $margin}]
} else {
foreach axis $graph($g,_y2axis) {
set index $g,axis-$axis
if {!$graph($index,_valid)} continue
set xr_draw [expr {$xr_draw - $graph($index,_width) - $margin}]
}
}
set xl_draw [expr {$xl_draw + $margin}]
set xr_draw [expr {$xr_draw - $margin}]
set yt_draw [expr {$yt_draw - $margin}]
set yb_draw [expr {$yb_draw + $margin}]
# calc graph area:
set padx $graph($g,plotpadx)
set pady $graph($g,plotpady)
set xl_graph [expr {$xl_draw + $graph($g,borderwidth) + $padx}]
set xr_graph [expr {$xr_draw - $graph($g,borderwidth) - $padx}]
set yt_graph [expr {$yt_draw - $graph($g,borderwidth) - $pady}]
set yb_graph [expr {$yb_draw + $graph($g,borderwidth) + $pady}]
set graph($g,_xl_graph) $xl_graph
set graph($g,_xr_graph) $xr_graph
set graph($g,_yt_graph) $yt_graph
set graph($g,_yb_graph) $yb_graph
# parray graph $g,*
# draw graph background and frame
set bgc $graph($g,plotbackground)
set rel $graph($g,plotrelief)
set bdw $graph($g,plotborderwidth)
set_opt $g linewidth -1
Rect $g $xl_draw $yt_draw $xr_draw $yb_draw $bgc
set_opt $g linewidth 0
draw_frame $g $xl_draw $yt_draw $xr_draw $yb_draw $bgc $rel $bdw
set xl_draw [expr {$xl_draw + $bdw}]
set xr_draw [expr {$xr_draw - $bdw}]
set yt_draw [expr {$yt_draw - $bdw}]
set yb_draw [expr {$yb_draw + $bdw}]
# draw axes (and grid lines):
set xl $xl_graph
set xr $xr_graph
set yb $y_bottom
foreach axis $graph($g,_xaxis) {
set index $g,axis-$axis
if {!$graph($index,_valid)} continue
set yt [expr {$yb + $graph($index,_height) + $margin}]
axis_draw $g $axis $xl $yt $xr $yb \
$xl_graph $yt_graph $xr_graph $yb_graph
set yb $yt
}
set yt $y_top
foreach axis $graph($g,_x2axis) {
set index $g,axis-$axis
if {!$graph($index,_valid)} continue
set yb [expr {$yt - $graph($index,_height) - $margin}]
axis_draw $g $axis $xl $yt $xr $yb \
$xl_graph $yt_graph $xr_graph $yb_graph
set yt $yb
}
set yt $yt_graph
set yb $yb_graph
set xl $x_left
foreach axis $graph($g,_yaxis) {
set index $g,axis-$axis
if {!$graph($index,_valid)} continue
set xr [expr {$xl + $graph($index,_width) + $margin}]
axis_draw $g $axis $xl $yt $xr $yb \
$xl_graph $yt_graph $xr_graph $yb_graph
set xl $xr
}
set xr $x_right
foreach axis $graph($g,_y2axis) {
set index $g,axis-$axis
if {!$graph($index,_valid)} continue
set xl [expr {$xr - $graph($index,_width) - $margin}]
axis_draw $g $axis $xl $yt $xr $yb \
$xl_graph $yt_graph $xr_graph $yb_graph
set xr $xl
}
ClipRect $g $xl_draw $yt_draw $xr_draw $yb_draw
set graph($g,_cliprect) [list $xl_draw $yt_draw $xr_draw $yb_draw]
# draw marker elements under data elements
foreach marker $graph($g,_markers) {
if {$graph($g,marker-$marker,under)} {
marker_draw $g $marker $xl_graph $yt_graph $xr_graph $yb_graph
}
}
# draw graph elements
foreach elem $graph($g,_elements) {
if {!$graph($g,elem-$elem,_valid)} continue
elem_draw $g $elem $xl_graph $yt_graph $xr_graph $yb_graph
}
# draw marker elements above data elements
foreach marker $graph($g,_markers) {
if {!$graph($g,marker-$marker,under)} {
marker_draw $g $marker $xl_graph $yt_graph $xr_graph $yb_graph
}
}
# draw legend in plotarea:
if {$graph($g,legend,_valid)} {
SetColor $g black
if {!$graph($g,legend,_inmargin)} {
legend_draw $g $xl_draw $yt_draw $xr_draw $yb_draw
}
}
UnclipRect $g
foreach {font size attr} $org_font {}
SetFont $g $font $size $attr
SetLinewidth $g $org_linewidth
SetDash $g $org_dashpattern
SetColor $g $org_rgbcolor
return $g
}
###############################################################################