interfaces/xmaxima/Tkmaxima/Plotconf.tcl

   1 ############################################################
   2 # Plotconf.tcl                                             #
   3 # Copyright (C) 1998 William F. Schelter                   #
   4 # For distribution under GNU public License.  See COPYING. #
   5 #                                                          #
   6 #     Modified by Jaime E. Villate                         #
   7 #     Time-stamp: "2024-03-25 21:11:14 villate"            #
   8 ############################################################
   9
  10 proc makeFrame { w type } {
  11     # If the plot was produced by Xmaxima's console, it will be in a frame
  12     # inserted in the console. Otherwise it will be a toplevel window
  13     global doExit fontSize buttonfont maxima_priv
  14     set win $w
  15     if { "$w" == "." } {
  16         set w ""
  17     } else {
  18         catch { destroy $w}
  19         if { [regexp {^\.(plot|versust)} $w] } {
  20             tk::toplevel $w
  21         } else {
  22             ttk::frame $w
  23         }
  24     }
  25     # hide the parent window and destroy it when the canvas is destroyed
  26     set dismiss "destroy $win"
  27     catch { set parent [winfo parent $w]
  28         if { "$parent" == "." } {
  29             set dismiss "destroy ."
  30         }
  31         if { [regexp {^\.(plot|versust)} [winfo toplevel $win]] } {
  32             set top [winfo parent $win]
  33             set dismiss "destroy $top"
  34             wm withdraw $top
  35         }
  36     }
  37     if { "$doExit" != "" } {set dismiss $doExit }
  38     set dismiss [concat $dismiss "; clearLocal $win "]
  39
  40     # Win is the name of the window and w its name without a final period
  41     oset $win type $type
  42     set c $w.c
  43     oset $win c $c
  44     bboxToRadius $win
  45     set buttonFont $buttonfont
  46     oset $win buttonFont $buttonfont
  47
  48     # widgets for the menu buttons and (x, y) coordinates label
  49     if { $type == {df} } {
  50         set ltext [mc "Click on the graph\nto trace a curve"]
  51     } else {
  52         set ltext [mc "Pointer Coordinates"]
  53     }
  54     ttk::label $w.position -text $ltext -background white -font $buttonFont
  55     set mb [frame $w.menubar]
  56     pack $mb -fill x
  57     ttk::button $mb.close -text [mc "Close"] -command $dismiss
  58     ttk::button $mb.config -text [mc "Config"] -command "doConfig$type $win"
  59     ttk::button $mb.save -text [mc "Save"] \
  60         -command "mkPrintDialog .dial -canvas $c -buttonfont $buttonFont "
  61     pack $mb.close $mb.config $mb.save -side left
  62     set buttonsLeft 1
  63
  64     # c is the canvas where the plot will be drawn
  65     tk::canvas $c -cursor arrow -background white \
  66         -width [oget $win width] -height [oget $win height]
  67     pack $c -side top -expand 1 -fill both
  68     bind $c <Motion> "showPosition $w %x %y"
  69     bind $c <Configure> "reConfigure %W %w %h"
  70
  71     $w.position config -background [$c cget -background]
  72     place $w.position -in $w.c -relx 0.03 -rely 0.99 -anchor sw
  73     raise $w.position
  74     focus $w
  75     addSliders $win
  76     if { [regexp {^\.(plot|versust)} [winfo toplevel $win]] } {
  77         pack [ttk::sizegrip $w.szgr] -side bottom -anchor se
  78         bind $win <Control-w> $dismiss
  79         wm protocol $w WM_DELETE_WINDOW $dismiss
  80     }
  81     return $win
  82 }
  83
  84 proc mkentry { newframe textvar text buttonFont } {
  85     frame $newframe
  86     set parent $newframe
  87     set found 0
  88     while { !$found } {
  89         set parent [winfo parent $parent]
  90         if { "$parent" == "" } { break }
  91         if { ![catch {  set type [oget $parent type] } ] } {
  92             global plot[set type]Options
  93             foreach v [set plot[set type]Options] {
  94                 if { "[oloc $parent [lindex $v 0]]" == "$textvar" } {
  95                     setBalloonhelp $parent $newframe [lindex $v 2]
  96                     set found 1
  97                     break}}}}
  98     label $newframe.lab1
  99     label $newframe.lab -text "$text:" -font $buttonFont -width 0
 100     entry $newframe.e -width 20 -textvariable $textvar -font $buttonFont
 101     pack $newframe.lab1 -side left -expand 1 -fill x
 102     pack $newframe.lab -side left
 103     pack $newframe.e -side right -padx 3 -fill x
 104     # pack $newframe.lab $newframe.e -side left -padx 3 -expand 1 -fill x}
 105
 106 proc pushBind { win key action } {
 107     pushl [bind $win $key] [list $win $key ]
 108     bind $win $key $action}
 109
 110 proc popBind { win key  } {
 111     set binding [popl [list $win $key] {}]
 112     bind $win $key $binding}
 113
 114 proc showPosition { win x y } {
 115     # global position c
 116     makeLocal $win c
 117     # we catch so that in case have no functions or data..
 118     catch {
 119         $win.position config -text \
 120             "[format {(%.6g,%.6g)}  [storx$win [$c canvasx $x]] [story$win [$c canvasy $y]]]"}}
 121
 122 proc reConfigure { c width height  } {
 123     set win [winfo parent $c]
 124     set w [oget $win width]
 125     set h [oget $win height]
 126     set wscale [expr double($width)/$w]
 127     set hscale [expr double($height)/$h]
 128     $c scale all 0 0 $wscale $hscale
 129     oset $win width $width
 130     oset $win height $height
 131     set_xy_transforms $win}
 132
 133 proc writePostscript { win } {
 134     global  printOption argv
 135     makeLocal $win c transform transform0 xmin ymin xmax ymax
 136     set rtosx rtosx$win ; set rtosy rtosy$win
 137     drawPointsForPrint $c
 138     if { "[$c find withtag printrectangle]" == "" } {
 139         $c create rectangle [$c canvasx 0] [$c canvasy 0] \
 140           [$c canvasx [$c cget -width ]] [$c canvasy [$c cget -height ]] \
 141           -tags printrectangle -outline white}
 142     set bbox [eval $c bbox [$c find withtag printrectangle]]
 143     desetq "x1 y1 x2 y2" $bbox
 144     # set title "unknown plot"
 145     # catch { set title [eval $printOption(maintitle)] }
 146     # $c create text [expr {($x1 + $x2)/2}]  [expr {$y1 + .04 * ($y2 - $y1)}] \
 147     #       -anchor center -text $title -tag title
 148     update
 149     #set diag [vectorlength [expr {$y1-$x1}] [expr {$y2-$x2}]]
 150     #  get rid of little arrows that creep onto the outside, ie let
 151     #  the blank rectangle cover them.
 152     #set x1 [expr {$x1+.01 * $diag}]
 153     #set x2 [expr {$x2-.01 * $diag}]
 154     #set y1 [expr {$y1+.01 * $diag}]
 155     #set y2 [expr {$y2-.01 * $diag}]
 156     # Set up font replacement list
 157     catch {set fontMap([font create -family {BitstreamVeraSansMono} -size 10]) [list Courier 14]}
 158     catch {set fontMap([font create {helvetica 16 normal}]) [list Helvetica 16]}
 159     set com "$c postscript  \
 160             -x [expr {($x1 - 35)}] -y [expr {($y1 -25)}] \
 161             -width [expr {($x2 - $x1 + 60)}] \
 162             -height [expr {($y2 - $y1 + 45)}] \
 163             -fontmap fontMap \
 164             [getPageOffsets [expr {($x2 - $x1 + 55)/(1.0*($y2 - $y1 + 45))}] ]"
 165
 166     #puts com=$com
 167     set output [eval $com]
 168     set fi [open $printOption(psfilename) w]
 169     puts $fi $output
 170     close $fi}
 171
 172 proc vectorlength {a b} {return [expr {sqrt($a*$a+$b*$b)}]}
 173
 174 proc setupCanvas { win } {
 175     makeLocal $win xcenter xradius ycenter yradius
 176     oset $win xmin [expr {$xcenter - $xradius}]
 177     oset $win xmax [expr { $xcenter + $xradius}]
 178     oset $win ymin [expr { $ycenter - $yradius}]
 179     oset $win ymax [expr { $ycenter + $yradius} ]}
 180
 181 #
 182 #-----------------------------------------------------------------
 183 #
 184 # compose --  A and B are transformations of the form "origin scalefac"
 185 # and composing them means applying first b then a, as in a.b.x
 186 #  "o s" . x ==> (x-o)*s + o
 187 #  Results: the "origin scalefac" which corresponds to the composition.
 188 #
 189 #----------------------------------------------------------------
 190 #
 191 proc compose { a b } {
 192     return  "[expr {-[lindex $a 1]*[lindex $b 0]*[lindex $b 1] \
 193       +[lindex $a 1]*[lindex $b 0]-[lindex $a 0]*[lindex $a 1] \
 194       +[lindex $a 0]}] [expr {[lindex $a 1]*[lindex $b 1]}]"
 195 }
 196
 197 proc sparseListWithParams { form variables paramlist } {
 198     set tem [parseConvert $form -doall 1]
 199     # puts tem=$tem
 200     set params [splitParams $paramlist]
 201     if { [catch {set res [substParams [lindex $tem 0] $variables $params] }\
 202               err ] } {
 203         set vars [lindex $tem 1]
 204         set all $variables
 205         foreach { v val }  $params { lappend all $v}
 206         foreach v $vars { if { [lsearch $all [string range $v 1 end]] < 0 } {
 207             error [mc "The variable %s appeared in %s but was not in allowed variables: %s or in parameters: %s" "`[string range $v 1 end]'" $form $variables $paramlist] }}
 208         error [mc "The form %s may involve variables other than %s or the parameters %s, or the latter may have invalid expressions: %s" $form $variables $paramlist $err] }
 209     return $res
 210 }
 211
 212 proc sparseWithParams { form variables params } {
 213     set tem [sparseListWithParams $form $variables $params]
 214     if { [llength $tem ] > 1 } { error [concat [mc "only wanted one function:"] "$form"]}
 215     lindex $tem 0}
 216
 217 #-----------------------------------------------------------------
 218 #
 219 # myVarSubst --  into FORM substitute where
 220 # listVarsVals where each element of this list may mention
 221 # the previous values eg "k 7 ll sin(k+8)"
 222 # eg:
 223 #myVarSubst [lindex [parseConvert "k*x+l" -doall 1] 0] {x $x k 27+4 l 93+k^3}
 224 # ==> {((31 * $x) + 29884.0)}
 225 #
 226 #  Results: FORM with the substitutions done
 227 #
 228 #----------------------------------------------------------------
 229 proc myVarSubst { form listVarsVals } {
 230     foreach {_u _v} $listVarsVals {
 231         if { "\$$_u" == "$_v" } {
 232             set $_u $_v
 233         } else {
 234             set _f1 [lindex [parseConvert  $_v -doall 1] 0]
 235             set $_u [expr [lindex $_f1 0]]
 236             # puts "$_u = [set $_u]"
 237         }}
 238     subst -nobackslashes -nocommands $form}
 239
 240 proc splitParams { paramlist } {
 241     set params ""
 242     foreach v [split $paramlist ,] {
 243         set tem [split $v =]
 244         if { [llength $tem] == 2 } {
 245             lappend params [lindex $tem 0] [lindex $tem 1]}}
 246     return $params}
 247
 248 #-----------------------------------------------------------------
 249 #
 250 # substParams --  substitute into FORM keeping VARIABLES as they are
 251 # and the PARAMLIST (of the form k=23, l=k+7,...) into FORM
 252 #
 253 #  Results: substituted FORM
 254 #
 255 #----------------------------------------------------------------
 256 proc substParams { form variables params } {
 257     foreach v $variables { lappend params $v \$$v}
 258     set res [myVarSubst $form $params]
 259     return $res}
 260
 261 #-----------------------------------------------------------------
 262 #
 263 # set_xy_region --  set up the bounds of the x and y coordinates
 264 # that will appear on the plot and the part of the window that will
 265 # be filled by the plot (fac, a number between 0 and 1).
 266 #
 267 #----------------------------------------------------------------
 268 proc set_xy_region { win fac } {
 269     makeLocal $win xcenter ycenter xradius yradius c
 270     set xmin [expr {$xcenter - $xradius}]
 271     set xmax [expr {$xcenter + $xradius}]
 272     set ymin [expr {$ycenter - $yradius}]
 273     set ymax [expr {$ycenter + $yradius}]
 274     oset $win fac $fac
 275     oset $win xmin $xmin
 276     oset $win xmax $xmax
 277     oset $win ymin $ymin
 278     oset $win ymax $ymax}
 279
 280 #-----------------------------------------------------------------
 281 #
 282 # set_xy_transforms --  set up transformations for the canvas of WINDOW
 283 # so that the plot is a fraction of the window (fac).
 284 # these transformations are used to convert from real values of x and y
 285 # to screen coordinates in pixels and vice versa.
 286 #
 287 #  Side Effects: transform functions rtosx$win rtosy$win storx$win story$win
 288 #  are defined.
 289 #
 290 # $rtosx,$rtosy --  convert Real coordinate to screen coordinate
 291 # $storx,$story --  Convert a screen coordinate to a Real coordinate.
 292 #
 293 #----------------------------------------------------------------
 294 proc set_xy_transforms { win } {
 295     makeLocal $win xmin ymin xmax ymax width height fac
 296     if { [oget $win type] == {3d} } {
 297         set f1 [expr {(1 - $fac)/2.0}]
 298         set x1 [expr {$f1 *$width}]
 299     } else {
 300         set f1 [expr {(1 - $fac)/3.0}]
 301         set x1 [expr {2* $f1 *$width}]}
 302     set y1 [expr {$f1 *$height}]
 303     set x2 [expr {$x1 + $fac*$width}]
 304     set y2 [expr {$y1 + $fac*$height}]
 305     # Do not use the extra vertical space for sliders
 306     linkLocal $win sliders
 307     if {[string length $sliders] > 0} {
 308         set y2 [expr {$y2 - 40*[llength [split $sliders ,]]}]}
 309
 310     set transform [makeTransform "$xmin $ymin $x1 $y2" "$xmin $ymax $x1 $y1 " \
 311                        "$xmax $ymin $x2 $y2"]
 312     oset $win transform $transform
 313     oset $win transform0 $transform
 314     getXtransYtrans $transform rtosx$win rtosy$win
 315     getXtransYtrans [inverseTransform $transform] storx$win story$win}
 316
 317 proc inputParse { in } {
 318     if { [regexp -indices \
 319               {D\[([a-zA-Z][0-9a-zA-Z]*[ ]*),([a-zA-Z][0-9a-zA-Z]*[ ]*)\] *=} \
 320               $in all1 i1 i2] } {
 321         set v1 [getOneMatch $in $i1]
 322         set v2 [getOneMatch $in $i2]
 323         set s1 [string range $in [lindex $all1 1] end]
 324
 325         if { [regexp -indices {,[ \n]*D\[([a-zA-Z][0-9a-zA-Z]*[ ]*),([a-zA-Z][0-9a-zA-Z]*[ ]*)\] *=} \
 326                   $s1 all2 i1 i2] } {
 327             set v3  [getOneMatch $s1 $i1]
 328             set v4 [getOneMatch $s1 $i2]
 329             set end [string first \} $s1 ]
 330             set form2 [string range $s1 [expr {1 + [lindex $all2 1]}] [expr {$end -1}]]
 331             if { "$v4" != "$v2" } {error [concat [mc "different variables"] "$v2" [mc "and"] "$v4"]}
 332
 333             set form1 [string range $in [expr {1 + [lindex $all1 1]}] [expr {[lindex $all2 0] + -1 + [lindex $all1 1]}]]
 334             # puts "v1=$v1,form1=$form1,form2=$form2"
 335             return [list  $v2 $v1 $v3 $form1 $form2]}}}
 336
 337 proc composeTransform { t1 t2  } {
 338     desetq "a11 a12 a21 a22 e1 e2" $t1
 339     desetq "b11 b12 b21 b22 f1 f2" $t2
 340     return  [list \
 341                  [expr {$a11*$b11+$a12*$b21}] \
 342                  [expr {$a11*$b12+$a12*$b22}] \
 343                  [expr {$a21*$b11+$a22*$b21}] \
 344                  [expr {$a22*$b22+$a21*$b12}] \
 345                  [expr {$a11*$f1+$a12*$f2+$e1}] \
 346                  [expr {$a21*$f1+$a22*$f2+$e2}]]}
 347
 348 #-----------------------------------------------------------------
 349 #
 350 # makeTransform --  Given three points mapped to three other points
 351 # write down the affine transformation (A.X+B) which performs this.
 352 # the arguments are of the form "x1 y1 u1 v1" "x2 y2 u2 v2" "x3 y3 u3 v3"
 353 # where (x1,y1) --> (u1,v1)  etc.
 354 #  Results: an affine transformation "a b c d e f" which is
 355 #     [ a  b ]  [ x1 ] + [ e ]
 356 #     [ c  d ]  [ y1 ]   [ f ]
 357 #  Side Effects: none
 358 #
 359 #----------------------------------------------------------------
 360 proc makeTransform { P1 P2 P3 } {
 361     desetq  {X1 Y1 U1 V1} $P1
 362     desetq  {X2 Y2 U2 V2} $P2
 363     desetq  {X3 Y3 U3 V3} $P3
 364     set tem [expr {double((($X2-$X1)*$Y3+($X1-$X3)*$Y2+($X3-$X2)*$Y1))}]
 365     set A [expr {(($U2-$U1)*$Y3+($U1-$U3)*$Y2+($U3-$U2)*$Y1) \
 366                      /$tem}]
 367     set B [expr {-(($U2-$U1)*$X3+($U1-$U3)*$X2+($U3-$U2)*$X1) \
 368                      /$tem}]
 369     set E [expr {(($U1*$X2-$U2*$X1)*$Y3+($U3*$X1-$U1*$X3)*$Y2+($U2*$X3-$U3*$X2)*$Y1) \
 370                      /$tem}]
 371     set C [expr {(($V2-$V1)*$Y3+($V1-$V3)*$Y2+($V3-$V2)*$Y1) \
 372                      /$tem}]
 373     set D [expr {-(($V2-$V1)*$X3+($V1-$V3)*$X2+($V3-$V2)*$X1) \
 374                      /$tem}]
 375     set F [expr {(($V1*$X2-$V2*$X1)*$Y3+($V3*$X1-$V1*$X3)*$Y2+($V2*$X3-$V3*$X2)*$Y1) \
 376                      /$tem}]
 377     return [list $A $B $C $D $E $F]}
 378
 379 #-----------------------------------------------------------------
 380 #
 381 # getXtransYtrans --   If the x coordinate transforms independently
 382 #  of the y and vice versa, give expressions suitable for building a
 383 # proc.
 384 #
 385 #----------------------------------------------------------------
 386 #
 387 proc getXtransYtrans { transform p1 p2 } {
 388     desetq "a b c d e f"  $transform
 389     if { $b == 0  && $c == 0 } {
 390         proc $p1 { x } "return \[expr {$a*\$x+$e}\]"
 391         proc $p2 { y } "return \[expr {$d*\$y+$f} \]"
 392         return 1}
 393     return 0}
 394
 395 #-----------------------------------------------------------------
 396 #
 397 # inverseTransform --   Find the inverse of an affine transformation.
 398 #
 399 #----------------------------------------------------------------
 400 proc inverseTransform { transform } {
 401     desetq "a b c d e f" $transform
 402     set det [expr {double($a*$d - $b*$c)}]
 403     return [list [expr {$d/$det}] [expr {- $b / $det }] [expr {- $c / $det}] \
 404                 [expr {$a / $det}]  [expr {($b*$f-$d*$e)/ $det }] \
 405                 [expr {-($a*$f-$c*$e)/ $det}]]}
 406
 407 #-----------------------------------------------------------------
 408 #
 409 # getTicks --  given an interval (a,b) subdivide it and
 410 # calculate where to put the ticks and what to print there.
 411 # we want DESIRED number of ticks, but we also want the ticks
 412 # to be at points in the real coords of the form .2*10^i or .5*10^j
 413 #  Results: the ticks
 414 #
 415 #----------------------------------------------------------------
 416 proc getTicks { a b n } {
 417     set len [expr {(($b - $a))}]
 418     if { $len < [expr {pow(10,-40)}] } { return ""}
 419     set best 0
 420     foreach v { .1 .2 .5 } {
 421         # want $len/(.1*10^i) == $n
 422         set val($v)  [expr {ceil(log10($len/(double($n)*$v)))}]
 423         set use [expr {$v*pow(10,$val($v))}]
 424         set fac [expr {1/$use}]
 425         set aa [expr {$a * $fac}]
 426         set bb [expr {$b * $fac}]
 427         set j [expr {round(ceil($aa)) }]
 428         set upto [expr {floor($bb) }]
 429         if { $upto-$j > 14} {
 430             set step 5
 431         } else {
 432             set step 2
 433         }
 434         set ticks ""
 435         while { $j <= $upto } {
 436             set tt [expr {$j / $fac}]
 437             if { $j%$step == 0 } {
 438                 append ticks " { $tt $tt }"
 439             } else  {append ticks " $tt"}
 440             incr j}
 441         set answer($v) $ticks
 442         set this [llength $ticks]
 443         if { $this  > $best } {
 444             set best $this
 445             set at $v}
 446         #puts "for $v [llength $ticks] ticks"
 447     }
 448     #puts "using $at [llength $answer($at)]"
 449     return $answer($at)}
 450
 451 proc axisTicks { win c }  {
 452     $c delete axisTicks
 453     if { ![catch {oget $win noaxisticks}] } { return }
 454     set swid [$c cget -width]
 455     set shei [$c cget -height]
 456     set x1 [storx$win [$c canvasx 0]]
 457     set y1 [story$win [$c canvasy 0]]
 458     set x2 [storx$win [$c canvasx $swid]]
 459     set y2 [story$win [$c canvasy $shei]]
 460     #puts "x1=$x1,y1=$y1,y2=$y2,x2=$x2"
 461     if { $y1 > 0  &&  $y2 < 0 } {
 462         set ticks [getTicks $x1 $x2 [expr {$swid/50}] ]
 463         #puts "ticks=$ticks"
 464         set eps [expr {.005 * abs($y1 - $y2)}]
 465         set neps [expr {-.005 * abs($y1 - $y2)}]
 466         set donext 0
 467         foreach v $ticks {
 468             set x [lindex $v 0]
 469             set text [lindex $v 1]
 470             if { $donext } {set text [lindex $v 0] ; set donext 0 }
 471             if { [lindex $v 0] == 0 } { set text "" ; set donext 1 }
 472             #puts " drawTick $c $x 0 0 $neps 0 $eps  $text axisTicks"
 473             drawTick $c $x 0 0 $neps 0 $eps  $text axisTicks}}
 474     if { 0 < $x2 && 0 > $x1 } {
 475         set ticks [getTicks $y2 $y1 [expr {$shei/50}]]
 476         set eps [expr {.005 * ($x2 - $x1)}]
 477         set neps [expr {-.005 * ($x2 - $x1)}]
 478         set donext 0
 479         foreach v $ticks {
 480             set y [lindex $v 0]
 481             set text [lindex $v 1]
 482             if { $donext } {set text [lindex $v 0] ; set donext 0}
 483             if { [lindex $v 0] == 0 } { set text "" ; set donext 1}
 484             drawTick $c 0 $y $neps 0 $eps 0  $text axisTicks}}}
 485
 486 #-----------------------------------------------------------------
 487 #
 488 # marginTicks --  draw ticks around the border of window
 489 #  x1,y1  top left x2,y2 bottom right.
 490 #
 491 #----------------------------------------------------------------
 492 proc marginTicks { c x1 y1 x2 y2 tag }  {
 493     global printOption
 494     set win [winfo parent $c]
 495
 496     if { ![catch {oget $win noaxisticks}] } { return }
 497     $c delete marginTicks
 498     set ticks [getTicks $x1 $x2 $printOption(xticks)]
 499     # puts "x=$x1 $x2"
 500     set eps [expr {.008 * ($y1 - $y2)}]
 501     set neps [expr {-.008 * ($y1 - $y2)}]
 502     foreach v $ticks {
 503         set x [lindex $v 0]
 504         set text [lindex $v 1]
 505         drawTick $c $x $y1 0 0 0 $eps $text $tag
 506         drawTick $c $x $y2 0 0 0 $neps {} $tag}
 507     #puts "y=$y2,$y1"
 508     set ticks [getTicks $y1 $y2 $printOption(yticks)]
 509     set eps [expr {.005 * ($x2 - $x1)}]
 510     set neps [expr {-.005 * ($x2 - $x1)}]
 511     set donext 0
 512     foreach v $ticks {
 513         set y [lindex $v 0]
 514         set text [lindex $v 1]
 515         drawTick $c $x1 $y 0 0 $neps 0 $text $tag
 516         drawTick $c $x2 $y 0 0 $eps 0 {} $tag}}
 517
 518 proc drawTick {c x y dx dy ex ey n tags} {
 519     global axisGray     fontCourier8
 520     set win [winfo parent $c]
 521     set rtosx rtosx$win ; set rtosy rtosy$win
 522     set it [$c create line [$rtosx [expr {$x +$dx}]] [$rtosy [expr {$y +$dy}]] [$rtosx [expr {$x +$ex}]] [$rtosy [expr {$y +$ey}]] -fill $axisGray -tags $tags]
 523     $c lower $it
 524     if { "$n" != "" } {
 525         if { $ey > 0 } { set anch s
 526         } elseif { $ex > 0 } {set anch w
 527         } elseif { $ex < 0 } {set anch e
 528         } elseif { $ey < 0 } {set anch n}
 529         $c create text  [$rtosx [expr {$x +1.5*$ex}]] [$rtosy [expr {$y +1.5*$ey}]] \
 530             -text [format "%.8g" $n] -font $fontCourier8 -tags $tags \
 531             -anchor $anch}}
 532
 533 proc doConfig { win }  {
 534     makeLocal $win c buttonFont
 535     $c delete configoptions
 536     set canv $c
 537     # set w $c.config
 538     set w $win.config
 539     catch {destroy $w}
 540     frame $w -borderwidth 2 -relief raised
 541
 542     label $w.msg  -wraplength 600 -justify left -text [mc "Plot Setup"] -font $buttonFont
 543     pack $w
 544     pack $w.msg -side top
 545     set wb1 $w.choose1
 546     frame $wb1
 547     set wb2 $w.choose2
 548     frame $wb2
 549     pack $wb1 $wb2 -side left -fill x -pady 2m
 550     set item [$canv create window [$canv canvasx 10] [$canv canvasy  10] -window $w -anchor nw -tags configoptions]
 551     button $wb1.dismiss -command  "$canv delete $item; destroy $w " -text "ok" -font $buttonFont
 552 #    button $wb1.printoptions -text [mc "Print Options"] -command "mkPrintDialog .dial -canvas $c -buttonfont $buttonFont " -font $buttonFont
 553
 554     pack $wb1.dismiss -side top
 555     return "$wb1 $wb2"}
 556 # mkentry { newframe textvar text }
 557
 558 # turn off the horrible show_balloons by default.
 559 global show_balloons
 560 set show_balloons 0
 561
 562 proc balloonhelp { win subwin msg } {
 563     global show_balloons
 564
 565     if { $show_balloons == 0 } {return}
 566     linkLocal  [oget $win c] helpPending
 567     if { [info exists helpPending] } {after cancel $helpPending}
 568     set helpPending [after 1000 [list balloonhelp1 $win $subwin $msg]]
 569 }
 570
 571 proc balloonhelp1 { win subwin msg } {
 572     if { ![winfo exists $win] } { return }
 573     makeLocal $win c buttonFont
 574     set x0 [winfo rootx $win]
 575     set y0 [winfo rooty $win]
 576     set atx [expr {[winfo rootx $subwin] + [winfo width $subwin] - $x0} ]
 577     set aty [expr {[winfo rooty $subwin] + [winfo height $subwin] - $y0} ]
 578     set wid [$c cget -width]
 579     set wid2 [expr {round ($wid /2.0)}]
 580     set wid10 [expr {round ($wid /10.0)}]
 581     if { $aty <=1 } { set aty 30 }
 582     incr aty 10
 583     incr atx 10
 584     set atx [$c canvasx $atx]
 585     set aty [$c canvasy $aty]
 586     #puts "$atx $aty"
 587     $c delete balloon
 588     $c create text $atx $aty -anchor nw -text $msg -font $buttonFont -width $wid2 -fill white -fill black -tags "balloon btext"
 589     desetq "x1 y1 x2 y2" [$c bbox btext]
 590     set x1 [expr {$x1 - .3*($x2-$x1)}]
 591     set x2 [expr {$x2 + .3*($x2-$x1)}]
 592     set y1 [expr {$y1 - .3*($y2-$y1)}]
 593     set y2 [expr {$y2 + .3*($y2-$y1)}]
 594
 595     eval $c create polygon $x1 $y1  $x2 $y1 $x2 $y2 $x1 $y2  -fill beige -tags balloon -smooth 1
 596     $c raise btext}
 597
 598 proc setBalloonhelp { win subwin msg } {
 599     makeLocal $win c
 600     bind $subwin <Enter> "balloonhelp $win $subwin [list $msg]"
 601     bind $subwin <Leave> "deleteBalloon $c"
 602 }
 603
 604 proc deleteBalloon { c } {
 605     linkLocal $c helpPending
 606     if { [info exists helpPending] } {
 607         after cancel $helpPending
 608         unset helpPending}
 609     $c delete balloon}
 610
 611 #-----------------------------------------------------------------
 612 #
 613 # minMax --  Compute the max and min of the arguments, which may
 614 # be vectors or numbers
 615 #
 616 #----------------------------------------------------------------
 617 proc minMax { args } {
 618     set max [lindex [lindex $args 0] 0] ; set min $max ;
 619     foreach vec $args {
 620         foreach v $vec {
 621             if { $v > $max } {set max $v }}}
 622     return [list $min $max]}
 623
 624 proc matrixMinMax { list } {
 625     # compute the min max of the list
 626     set min +10e300
 627     set max -10e300
 628     foreach mat $list {
 629         foreach row $mat {
 630             foreach v [ldelete nam $row] {
 631                 if { $v > $max } {catch  { set max [expr {$v + 0}] }}
 632                 if { $v < $min} {catch  { set min [expr {$v + 0}] }}}}}
 633     list $min $max}
 634
 635 proc omPlotAny { data args } {
 636     # puts "data=<[lindex $data 0]>"
 637     set command [list [lindex [lindex $data 0] 0]  -data [lindex $data 0] ]
 638     if { "[lindex $command 0]" == "plot2d" } {
 639         lappend command -xfun {}}
 640     foreach v $args { lappend command $v }
 641     eval $command
 642     #eval [lindex [lindex $data 0] 0] -xfun [list {}] -data [list [lindex $data 0]] $args
 643 }
 644
 645 proc resizeSubPlotWindows { win wid height } {
 646     set at [$win yview "@0,0"]
 647     foreach w [winfo children $win] {
 648         if { [string match plot* [lindex [split $w .] end]] } {
 649             resizePlotWindow $w [winfo width $w] $height}}
 650     if { "$at" != "" } { $win yview $at}}
 651
 652 proc resizePlotWindow  { w width height } {
 653     if { [winfo width $w.c] <= 1 } {
 654         after 100 update ;
 655         return }
 656     if { ![catch { set tem [oget $w lastResize] } ] && [expr {[clock seconds] - $tem }] < 2 } { return
 657     } else {
 658         oset $w lastResize [clock seconds ]
 659     }
 660     #puts "resizePlotWindow $w $width $height"
 661     # return
 662     set par [winfo parent $w]
 663     set facx 1.0
 664     set facy 1.0
 665     set wid [winfo width $par]
 666     set hei [winfo height $par]
 667     if { "[winfo class $par]" == "Text" } {
 668         set dif 10
 669         set wid1 $wid ; set hei1 $hei
 670         #puts "now w=$w"
 671         #set wid1 [getPercentDim [oget $w widthDesired] width $par]
 672         catch {set wid1 [getPercentDim [oget $w widthDesired] width $par] }
 673         catch {set hei1 [getPercentDim [oget $w heightDesired] height $par] }
 674         set wid [expr {($wid1 > $wid - 30 ? $wid - 30 : $wid1 )}]
 675         set hei [expr {($hei1 > $hei - 30 ? $hei - 30 : $hei1 )}]
 676     } else {set dif 10}
 677     #     if { $width > $wid -20 || $wid > $width -20 }
 678     if { (abs($width-$wid) > $dif ||  abs($height-$hei) > $dif)
 679          &&  [winfo width $w.c] > 1 } {
 680         set eps [expr {2 * [$w.c cget -insertborderwidth] + [$w.c cget -borderwidth] }]
 681         set epsx $eps
 682         set epsy $eps
 683         set extrawidth [expr {([winfo width $w] - [winfo width  $w.c]) +$epsx}]
 684         set extraheight [expr {([winfo height $w] - [winfo height  $w.c]) +$epsy}]
 685         set nwidth [expr {$wid - ($extrawidth > 0  ? $extrawidth : 0)}]
 686         set nheight [expr {$hei - ($extraheight > 0  ? $extraheight : 0)}]
 687
 688         #puts "$w.c config -width $nwidth  -height $nheight, extraheight=$extraheight,epsy=$epsy"
 689         $w.c config -width $nwidth  -height $nheight}}
 690
 691 proc bboxToRadius { win  } {
 692     makeLocal $win bbox
 693     if { "$bbox" != "" } {
 694         linkLocal $win xradius yradius xcenter ycenter
 695         set i 0
 696         foreach v { x y z } {
 697             set min [lindex $bbox $i]
 698             set max [lindex $bbox [expr {$i+2}]]
 699             if { "$min" != "" } {
 700                 if { $min >= $max } {error "bad bbox $bbox since $min >= $max"}
 701                 set ${v}radius [expr { ($max - $min) /2.0}]
 702                 set ${v}center [expr { ($max + $min) /2.0}]}}}}
 703
 704 proc updateParameters { win var value} {
 705     linkLocal $win parameters
 706     # puts "$win $var $value"
 707     set ans ""
 708     set comma ""
 709     foreach {v val} [splitParams $parameters] {
 710         if { "$v" == "$var" } {set val $value}
 711         append ans $comma $v=$val
 712         set comma ","}
 713     #    puts "parameters=$ans"
 714     set parameters $ans}
 715
 716 proc addSliders { win } {
 717     linkLocal $win sliders c width parameters
 718     set i 0
 719     if { "$sliders" == "" } { return }
 720     catch { destroy $c.sliders }
 721     set bg "#9ce"
 722     set trough "#9df"
 723     frame $c.sliders -relief raised -highlightthickness 2 -highlightbackground $trough
 724     foreach v [split $sliders ,] {
 725         if { [regexp {([a-zA-Z0-9]+)[ ]*=?(([---0-9.]+):([---0-9.]+))?} $v  junk var junk x0 x1] } {
 726             incr i
 727             if { "$x0" == "" } { set x0 -5  ; set x1 5}
 728             set fr $c.sliders.fr$i
 729             frame $fr -background $bg
 730             label $fr.lab -text $var: -background $bg
 731             label $fr.labvalue -textvariable [oloc $win slidevalue$i]  -background $bg -relief sunken -justify left
 732             scale $fr.scale -command "sliderUpdate $win $var" \
 733                 -from "$x0" -to $x1 -orient horizontal \
 734                 -resolution [expr ($x1 - $x0) < 1 ? ($x1-$x0)/100.0 : .01] \
 735                 -length [expr {$width/2}] -showvalue 0 -variable \
 736                 [oloc $win slidevalue$i] -background $bg -troughcolor "#9ad" \
 737                 -highlightthickness 0
 738             pack $fr.lab -side left -expand 1 -fill x
 739             pack $fr.labvalue $fr.scale -side left
 740             pack  $fr -side top -expand 1 -fill x
 741             set found 0
 742             set val  [assoc $var [splitParams $parameters] no]
 743             if { "$val" == "no" } {
 744                 set val  [expr ($x1 + $x0)/2.0]
 745                 if { "$parameters" != "" }  { append parameters , }
 746                 append parameters $var=$val}
 747             $fr.scale set $val}}
 748     place $c.sliders -in $c -relx 1.0 -x -4 -rely 1.0 -y -4 -anchor se}
 749
 750 proc sliderUpdate { win var val } {
 751     linkLocal $win sliderCommand parameters
 752     set params $parameters
 753     updateParameters $win $var $val
 754     if {"$params" ne "$parameters" && [info exists sliderCommand] } {
 755         $sliderCommand $win $var $val}}
 756
 757 ## endsource plotconf.tcl