############################################################################### # # graph.tcl # # Copyright (C) 2017 Joerg Mehring, Bochum, 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 } ###############################################################################