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: "2022-04-02 10:25:09 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 writefile 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 to 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
  99                 }
 100             }
 101         }
 102     }
 103     label $newframe.lab1
 104     label $newframe.lab -text "$text:" -font $buttonFont -width 0
 105     entry $newframe.e -width 20 -textvariable $textvar -font $buttonFont
 106     pack $newframe.lab1 -side left -expand 1 -fill x
 107     pack $newframe.lab -side left
 108     pack $newframe.e -side right -padx 3 -fill x
 109     # pack $newframe.lab $newframe.e -side left -padx 3 -expand 1 -fill x
 110 }
 111
 112 proc pushBind { win key action } {
 113     pushl [bind $win $key] [list $win $key ]
 114     bind $win $key $action
 115 }
 116
 117 proc popBind { win key  } {
 118     set binding [popl [list $win $key] {}]
 119
 120     bind $win $key $binding
 121 }
 122
 123 # exit if not part of openmath browser
 124 proc maybeExit { n } {
 125     if { "[info proc OpenMathOpenUrl]" != "" } {
 126         uplevel 1 return
 127     } else {
 128         exit 0
 129     }
 130 }
 131
 132 proc showPosition { win x y } {
 133     # global position c
 134     makeLocal $win c
 135     # we catch so that in case have no functions or data..
 136     catch {
 137         $win.position config -text \
 138             "[format {(%.6g,%.6g)}  [storx$win [$c canvasx $x]] [story$win [$c canvasy $y]]]"
 139     }
 140 }
 141
 142 proc reConfigure { c width height  } {
 143     set win [winfo parent $c]
 144     set w [oget $win width]
 145     set h [oget $win height]
 146     set wscale [expr double($width)/$w]
 147     set hscale [expr double($height)/$h]
 148     $c scale all 0 0 $wscale $hscale
 149     oset $win width $width
 150     oset $win height $height
 151     set_xy_transforms $win
 152 }
 153
 154 proc writePostscript { win } {
 155     global  printOption argv
 156     makeLocal $win c transform transform0 xmin ymin xmax ymax
 157     set rtosx rtosx$win ; set rtosy rtosy$win
 158     drawPointsForPrint $c
 159     if { "[$c find withtag printrectangle]" == "" } {
 160         $c create rectangle [$c canvasx 0] [$c canvasy 0] \
 161           [$c canvasx [$c cget -width ]] [$c canvasy [$c cget -height ]] \
 162           -tags printrectangle -outline white
 163     }
 164
 165     set bbox [eval $c bbox [$c find withtag printrectangle]]
 166     desetq "x1 y1 x2 y2" $bbox
 167     # set title "unknown plot"
 168     # catch { set title [eval $printOption(maintitle)] }
 169     # $c create text [expr {($x1 + $x2)/2}]  [expr {$y1 + .04 * ($y2 - $y1)}] \
 170     #       -anchor center -text $title -tag title
 171
 172     update
 173     #set diag [vectorlength [expr {$y1-$x1}] [expr {$y2-$x2}]]
 174     #  get rid of little arrows that creep onto the outside, ie let
 175     #  the blank rectangle cover them.
 176     #set x1 [expr {$x1+.01 * $diag}]
 177     #set x2 [expr {$x2-.01 * $diag}]
 178     #set y1 [expr {$y1+.01 * $diag}]
 179     #set y2 [expr {$y2-.01 * $diag}]
 180
 181     # Set up font replacement list
 182     catch {set fontMap([font create -family {BitstreamVeraSansMono} -size 10]) [list Courier 14]}
 183     catch {set fontMap([font create {helvetica 16 normal}]) [list Helvetica 16]}
 184     set com "$c postscript  \
 185             -x [expr {($x1 - 35)}] -y [expr {($y1 -25)}] \
 186             -width [expr {($x2 - $x1 + 60)}] \
 187             -height [expr {($y2 - $y1 + 45)}] \
 188             -fontmap fontMap \
 189             [getPageOffsets [expr {($x2 - $x1 + 55)/(1.0*($y2 - $y1 + 45))}] ]"
 190
 191     #puts com=$com
 192     set output [eval $com]
 193     set fi [open $printOption(psfilename) w]
 194     puts $fi $output
 195     close $fi
 196 }
 197
 198
 199 #
 200 #-----------------------------------------------------------------
 201 #
 202 # ftpDialog --  open up a dialog to send ftpInfo(data) to a file
 203 # via http and ftp.   The http server can be specified.
 204 #
 205 #  Results:
 206 #
 207 #  Side Effects:
 208 #
 209 #----------------------------------------------------------------
 210 #
 211
 212 proc ftpDialog { win args } {
 213     global ftpInfo buttonFont fontSize
 214     set fr ${win}plot
 215     set usefilename [assoc -filename $args  0]
 216     if { "$usefilename" != "0"} {
 217         set ftpInfo(filename) $usefilename
 218         set usefilename 1
 219     }
 220     catch { destroy $fr }
 221     set ftpInfo(percent) 0
 222
 223     frame $fr -borderwidth 2 -relief raised
 224     if { [catch { set ftpInfo(directory) } ] } { set ftpInfo(directory) homework }
 225     label $fr.title -text [mc "Ftp Dialog Box"]
 226     mkentry $fr.host ftpInfo(host) [mc "host to write file on"] $buttonFont
 227     mkentry $fr.viahost ftpInfo(viahost) [mc "host to write to via"] $buttonFont
 228     mkentry $fr.username ftpInfo(username) [mc "Your User ID on host"] $buttonFont
 229     mkentry $fr.password ftpInfo(password) [mc "Your password on host"] $buttonFont
 230     $fr.password.e config -show *
 231     mkentry $fr.directory ftpInfo(directory) [mc "remote subdirectory for output"] $buttonFont
 232
 233     if { $usefilename } {
 234         mkentry $fr.filename ftpInfo(filename) [mc "filename "] $buttonFont
 235     } else {
 236         mkentry $fr.chapter ftpInfo(chapter) [mc "chapter "] $buttonFont
 237         mkentry $fr.section ftpInfo(section) [mc "section"] $buttonFont
 238         mkentry $fr.problemnumber ftpInfo(number) [mc "Problem number"] $buttonFont
 239     }
 240     scale   $fr.scale -orient horizontal -variable ftpInfo(percent) -length 100
 241     button $fr.doit -text [mc "Send it"] -command "doFtpSend $fr" -font $buttonFont
 242     button $fr.cancel -text [mc "Cancel"] -command "destroy $fr" -font $buttonFont
 243     set ftpInfo(message) ""
 244     label $fr.message  -width 30 -height 3 -textvariable ftpInfo(message) -font $buttonFont
 245     eval pack  [winfo  children $fr] -side top
 246     raise $fr
 247     place $fr -in $win -relx .5 -rely .5 -anchor center
 248 }
 249
 250 proc doFtpSend { fr } {
 251     global ftpInfo om_ftp
 252
 253     set error ""
 254     if { [winfo exists $fr.filename] } {
 255         set filename $ftpInfo(filename)
 256         set check "host username directory filename"
 257     } else {
 258         set check "host username directory chapter section number"
 259     }
 260     foreach v $check {
 261         if { $ftpInfo($v) == "" } {
 262             if  { "$error" == "" } { set error [concat [mc "Failed to specify"] "$v " } else {
 263                 append error ", $v"}
 264         }
 265     }
 266     if { "$error" != "" } {
 267         set ftpInfo(message) $error
 268         return -1
 269     }
 270     if { [winfo exists $fr.chapter] } {
 271         set filename "$ftpInfo(chapter).$ftpInfo(section)-$ftpInfo(number).ps"
 272     }
 273
 274
 275     set res [submitFtp $ftpInfo(viahost) $ftpInfo(host) $ftpInfo(username) $ftpInfo(password) $ftpInfo(directory) $filename]
 276     if { "$res" == 1 }  {
 277         after 1000 "destroy $fr"
 278     }
 279     return $res
 280
 281     #    set counter [ ftp $ftpInfo(host) $ftpInfo(username) $ftpInfo(password)]
 282     #    if { $counter < 0 } {
 283     #   set ftpInfo(message) [concat "Failed:" $om_ftp($counter,log)]
 284     #   return -1
 285     #    }
 286
 287     #     if { [ftpDoCd $counter $ftpInfo(directory)] < 0 &&
 288     #          [ftpDoMkdir $counter $ftpInfo(directory)] > -10 &&
 289     #        [ftpDoCd $counter $ftpInfo(directory)] < 0 } {
 290     #   set ftpInfo(message) [concat "Failed:" $om_ftp($counter,log)]
 291     #   return -1
 292     #     }
 293
 294
 295     #     set res [ftpDoStore $counter $ftpInfo(chapter).$ftpInfo(section)-$ftpInfo(number).ps $ftpInfo(data)]
 296     #     if { $res < 0 } {
 297     #   set ftpInfo(message) "Failed: $om_ftp($counter,log)"
 298     #   return -1
 299     #     } else {
 300     #   set ftpInfo(message) "Wrote $ftpInfo(directory)/$ftpInfo(chapter).$ftpInfo(section)-$ftpInfo(number).ps"
 301     #   after 1000 destroy $fr
 302     #     }
 303     #     ftpClose $counter
 304 }
 305
 306 proc vectorlength { a b } {
 307     return [expr {sqrt($a*$a + $b * $b)} ]
 308 }
 309
 310 proc setupCanvas { win } {
 311     makeLocal $win   xcenter xradius ycenter yradius
 312
 313     oset $win xmin [expr {$xcenter - $xradius}]
 314     oset $win xmax [expr { $xcenter + $xradius}]
 315     oset $win ymin [expr { $ycenter - $yradius}]
 316     oset $win ymax [expr { $ycenter + $yradius} ]
 317
 318 }
 319
 320
 321 #
 322 #-----------------------------------------------------------------
 323 #
 324 # compose --  A and B are transformations of the form "origin scalefac"
 325 # and composing them means applying first b then a, as in a.b.x
 326 #  "o s" . x ==> (x-o)*s + o
 327 #  Results: the "origin scalefac" which corresponds to the composition.
 328 #
 329 #  Side Effects:
 330 #
 331 #----------------------------------------------------------------
 332 #
 333 proc compose { a b } {
 334     return  "[expr {-[lindex $a 1]*[lindex $b 0]*[lindex $b 1] \
 335       +[lindex $a 1]*[lindex $b 0]-[lindex $a 0]*[lindex $a 1] \
 336       +[lindex $a 0]}] [expr {[lindex $a 1]*[lindex $b 1]}]"
 337 }
 338
 339 proc sparseListWithParams { form variables paramlist } {
 340     set tem [parseConvert $form -doall 1]
 341     #puts tem=$tem
 342     set params [splitParams $paramlist]
 343     if { [catch {set res [substParams [lindex $tem 0] $variables $params] }\
 344               err ] } {
 345         set vars [lindex $tem 1]
 346         set all $variables
 347         foreach { v val }  $params { lappend all $v}
 348         foreach v $vars { if { [lsearch $all [string range $v 1 end]] < 0 } {
 349             error [M [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}" ]
 350         }
 351         }
 352         error [M [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" ]
 353     }
 354     return $res
 355 }
 356
 357 proc sparseWithParams { form variables params } {
 358     set tem [sparseListWithParams $form $variables $params]
 359     if { [llength $tem ] > 1 } { error [concat [mc "only wanted one function:"] "$form"]}
 360     lindex $tem 0
 361 }
 362
 363 #
 364 #-----------------------------------------------------------------
 365 #
 366 # myVarSubst --  into FORM substitute where
 367 # listVarsVals where each element of this list may mention
 368 # the previous values eg "k 7 ll sin(k+8)"
 369 # eg:
 370 #myVarSubst [lindex [parseConvert "k*x+l" -doall 1] 0] {x $x k 27+4 l 93+k^3}
 371 # ==> {((31 * $x) + 29884.0)}
 372 #
 373 #  Results: FORM with the substitutions done
 374 #
 375 #  Side Effects:
 376 #
 377 #----------------------------------------------------------------
 378 #
 379 proc myVarSubst { form listVarsVals } {
 380     foreach {_u _v} $listVarsVals {
 381         if { "\$$_u" == "$_v" } {
 382             set $_u $_v
 383         } else {
 384             set _f1 [lindex [parseConvert  $_v -doall 1] 0]
 385             set $_u [expr [lindex $_f1 0]]
 386             # puts "$_u = [set $_u]"
 387         }
 388     }
 389     subst -nobackslashes -nocommands $form
 390
 391 }
 392
 393 proc splitParams { paramlist } {
 394     set params ""
 395     foreach v [split $paramlist ,] {
 396         set tem [split $v =]
 397         if { [llength $tem] == 2 } {
 398             lappend params [lindex $tem 0] [lindex $tem 1]
 399         }
 400     }
 401     return $params
 402 }
 403 #
 404 #-----------------------------------------------------------------
 405 #
 406 # substParams --  substitute into FORM keeping VARIABLES as they are
 407 # and the PARAMLIST (of the form k=23, l=k+7,...) into FORM
 408 #
 409 #  Results: substituted FORM
 410 #
 411 #  Side Effects: none
 412 #
 413 #----------------------------------------------------------------
 414 #
 415 proc substParams { form variables params } {
 416     foreach v $variables { lappend params $v \$$v}
 417     set res [myVarSubst $form $params]
 418     return $res
 419 }
 420 #
 421 #-----------------------------------------------------------------
 422 #
 423 # set_xy_region --  set up the bounds of the x and y coordinates
 424 # that will appear on the plot and the part of the window that will
 425 # be filled by the plot (fac, a number between 0 and 1).
 426 #
 427 #----------------------------------------------------------------
 428 #
 429 proc set_xy_region { win fac } {
 430     makeLocal $win xcenter ycenter xradius yradius c
 431
 432     set xmin [expr {$xcenter - $xradius}]
 433     set xmax [expr {$xcenter + $xradius}]
 434     set ymin [expr {$ycenter - $yradius}]
 435     set ymax [expr {$ycenter + $yradius}]
 436
 437     oset $win fac $fac
 438     oset $win xmin $xmin
 439     oset $win xmax $xmax
 440     oset $win ymin $ymin
 441     oset $win ymax $ymax
 442 }
 443
 444 #-----------------------------------------------------------------
 445 #
 446 # set_xy_transforms --  set up transformations for the canvas of WINDOW
 447 # so that the plot is a fraction of the window (fac).
 448 # these transformations are used to convert from real values of x and y
 449 # to screen coordinates in pixels and vice versa.
 450 #
 451 #  Side Effects: transform functions rtosx$win rtosy$win storx$win story$win
 452 #  are defined.
 453 #
 454 #----------------------------------------------------------------
 455 #
 456 proc set_xy_transforms { win } {
 457     makeLocal $win xmin ymin xmax ymax width height fac
 458     if { [oget $win type] == {3d} } {
 459         set f1 [expr {(1 - $fac)/2.0}]
 460         set x1 [expr {$f1 *$width}]
 461     } else {
 462         set f1 [expr {(1 - $fac)/3.0}]
 463         set x1 [expr {2* $f1 *$width}]
 464     }
 465     set y1 [expr {$f1 *$height}]
 466     set x2 [expr {$x1 + $fac*$width}]
 467     set y2 [expr {$y1 + $fac*$height}]
 468
 469     set transform [makeTransform "$xmin $ymin $x1 $y2" "$xmin $ymax $x1 $y1 " \
 470                        "$xmax $ymin $x2 $y2"]
 471     oset $win transform $transform
 472     oset $win transform0 $transform
 473
 474     getXtransYtrans $transform rtosx$win rtosy$win
 475     getXtransYtrans [inverseTransform $transform] storx$win story$win
 476 }
 477
 478 proc inputParse { in } {
 479     if { [regexp -indices \
 480               {D\[([a-zA-Z][0-9a-zA-Z]*[ ]*),([a-zA-Z][0-9a-zA-Z]*[ ]*)\] *=} \
 481               $in all1 i1 i2] } {
 482         set v1 [getOneMatch $in $i1]
 483         set v2 [getOneMatch $in $i2]
 484         set s1 [string range $in [lindex $all1 1] end]
 485
 486         if { [regexp -indices {,[ \n]*D\[([a-zA-Z][0-9a-zA-Z]*[ ]*),([a-zA-Z][0-9a-zA-Z]*[ ]*)\] *=} \
 487                   $s1 all2 i1 i2] } {
 488             set v3  [getOneMatch $s1 $i1]
 489             set v4 [getOneMatch $s1 $i2]
 490             set end [string first \} $s1 ]
 491             set form2 [string range $s1 [expr {1 + [lindex $all2 1]}] [expr {$end -1}]]
 492             if { "$v4" != "$v2" } {error [concat [mc "different variables"] "$v2" [mc "and"] "$v4"]}
 493
 494             set form1 [string range $in [expr {1 + [lindex $all1 1]}] [expr {[lindex $all2 0] + -1 + [lindex $all1 1]}]]
 495             return [list  $v2 $v1 $v3 $form1 $form2]
 496             # puts "v1=$v1,form1=$form1,form2=$form2"
 497         }
 498     }
 499 }
 500
 501 proc composeTransform { t1 t2  } {
 502     desetq "a11 a12 a21 a22 e1 e2" $t1
 503     desetq "b11 b12 b21 b22 f1 f2" $t2
 504     return  [list \
 505                  [expr {$a11*$b11+$a12*$b21}] \
 506                  [expr {$a11*$b12+$a12*$b22}] \
 507                  [expr {$a21*$b11+$a22*$b21}] \
 508                  [expr {$a22*$b22+$a21*$b12}] \
 509                  [expr {$a11*$f1+$a12*$f2+$e1}] \
 510                  [expr {$a21*$f1+$a22*$f2+$e2}] ]
 511 }
 512
 513
 514
 515 #
 516 #-----------------------------------------------------------------
 517 #
 518 # makeTransform --  Given three points mapped to three other points
 519 # write down the affine transformation (A.X+B) which performs this.
 520 # the arguments are of the form "x1 y1 u1 v1" "x2 y2 u2 v2" "x3 y3 u3 v3"
 521 # where (x1,y1) --> (u1,v1)  etc.
 522 #  Results: an affine transformation "a b c d e f" which is
 523 #     [ a  b ]  [ x1 ] + [ e ]
 524 #     [ c  d ]  [ y1 ]   [ f ]
 525 #  Side Effects: none
 526 #
 527 #----------------------------------------------------------------
 528 #
 529 proc makeTransform { P1 P2 P3 } {
 530     desetq  "X1 Y1 U1 V1" $P1
 531     desetq  "X2 Y2 U2 V2" $P2
 532     desetq  "X3 Y3 U3 V3" $P3
 533     set tem [expr {double((($X2-$X1)*$Y3+($X1-$X3)*$Y2+($X3-$X2)*$Y1))}]
 534     set A [expr {(($U2-$U1)*$Y3+($U1-$U3)*$Y2+($U3-$U2)*$Y1) \
 535                      /$tem}]
 536     set B [expr {-(($U2-$U1)*$X3+($U1-$U3)*$X2+($U3-$U2)*$X1) \
 537                      /$tem}]
 538     set E [expr {(($U1*$X2-$U2*$X1)*$Y3+($U3*$X1-$U1*$X3)*$Y2+($U2*$X3-$U3*$X2)*$Y1) \
 539                      /$tem}]
 540     set C [expr {(($V2-$V1)*$Y3+($V1-$V3)*$Y2+($V3-$V2)*$Y1) \
 541                      /$tem}]
 542     set D [expr {-(($V2-$V1)*$X3+($V1-$V3)*$X2+($V3-$V2)*$X1) \
 543                      /$tem}]
 544     set F [expr {(($V1*$X2-$V2*$X1)*$Y3+($V3*$X1-$V1*$X3)*$Y2+($V2*$X3-$V3*$X2)*$Y1) \
 545                      /$tem}]
 546     set xf ""
 547     set yf ""
 548     if { $B == 0  && $C == 0 } {
 549         set xf "$A*\$X+$E"
 550         set yf "$D*\$Y+$F"
 551     }
 552     return [list $A $B $C $D $E $F]
 553 }
 554
 555
 556 #
 557 #-----------------------------------------------------------------
 558 #
 559 # getXtransYtrans --   If the x coordinate transforms independently
 560 #  of the y and vice versa, give expressions suitable for building a
 561 # proc.
 562 #  Results:
 563 #
 564 #  Side Effects:
 565 #
 566 #----------------------------------------------------------------
 567 #
 568 proc getXtransYtrans { transform p1 p2 } {
 569     desetq "a b c d e f"  $transform
 570     if { $b == 0  && $c == 0 } {
 571         proc $p1 { x } "return \[expr {$a*\$x+$e}\]"
 572         proc $p2 { y } "return \[expr {$d*\$y+$f} \]"
 573         return 1
 574     }
 575     return 0
 576 }
 577
 578
 579 #
 580 #-----------------------------------------------------------------
 581 #
 582 # inverseTransform --   Find the inverse of an affine transformation.
 583 #
 584 #  Results:
 585 #
 586 #  Side Effects:
 587 #
 588 #----------------------------------------------------------------
 589 #
 590 proc inverseTransform { transform } {
 591     desetq "a b c d e f" $transform
 592     set det [expr {double($a*$d - $b*$c)}]
 593     return [list [expr {$d/$det}] [expr {- $b / $det }] [expr {- $c / $det}] [expr {$a / $det}]  [expr {($b*$f-$d*$e)/ $det }] [expr {-($a*$f-$c*$e)/ $det}]]
 594
 595 }
 596
 597
 598 #
 599 #-----------------------------------------------------------------
 600 #
 601 # getTicks --  given an interval (a,b) subdivide it and
 602 # calculate where to put the ticks and what to print there.
 603 # we want DESIRED number of ticks, but we also want the ticks
 604 # to be at points in the real coords of the form .2*10^i or .5*10^j
 605 #  Results: the ticks
 606 #
 607 #  Side Effects:
 608 #
 609 #----------------------------------------------------------------
 610 #
 611
 612 proc getTicks { a b n } {
 613     set len [expr {(($b - $a))}]
 614     if { $len < [expr {pow(10,-40)}] } { return ""}
 615     set best 0
 616     foreach v { .1 .2 .5 } {
 617         # want $len/(.1*10^i) == $n
 618         set val($v)  [expr {ceil(log10($len/(double($n)*$v)))}]
 619         set use [expr {$v*pow(10,$val($v))}]
 620         set fac [expr {1/$use}]
 621         set aa [expr {$a * $fac}]
 622         set bb [expr {$b * $fac}]
 623         set j [expr {round(ceil($aa)) }]
 624         set upto [expr {floor($bb) }]
 625         if { $upto-$j > 14} {
 626             set step 5
 627         } else {
 628             set step 2
 629         }
 630         set ticks ""
 631         while { $j <= $upto } {
 632             set tt [expr {$j / $fac}]
 633             if { $j%$step == 0 } {
 634                 append ticks " { $tt $tt }"
 635             } else  {
 636                 append ticks " $tt"
 637             }
 638             incr j
 639         }
 640         set answer($v) $ticks
 641         set this [llength $ticks]
 642         if { $this  > $best } {
 643             set best $this
 644             set at $v
 645         }
 646         #puts "for $v [llength $ticks] ticks"
 647     }
 648     #puts "using $at [llength $answer($at)]"
 649
 650     return $answer($at)
 651 }
 652
 653 proc axisTicks { win c }  {
 654     $c delete axisTicks
 655     if { ![catch {oget $win noaxisticks}] } { return }
 656     set swid [$c cget -width]
 657     set shei [$c cget -height]
 658     set x1 [storx$win [$c canvasx 0]]
 659     set y1 [story$win [$c canvasy 0]]
 660     set x2 [storx$win [$c canvasx $swid]]
 661     set y2 [story$win [$c canvasy $shei]]
 662     #puts "x1=$x1,y1=$y1,y2=$y2,x2=$x2"
 663     if { $y1 > 0  &&  $y2 < 0 } {
 664         set ticks [getTicks $x1 $x2 [expr {$swid/50}] ]
 665         #puts "ticks=$ticks"
 666         set eps [expr {.005 * abs($y1 - $y2)}]
 667         set neps [expr {-.005 * abs($y1 - $y2)}]
 668         set donext 0
 669         foreach v $ticks {
 670             set x [lindex $v 0]
 671             set text [lindex $v 1]
 672             if { $donext } {set text [lindex $v 0] ; set donext 0 }
 673             if { [lindex $v 0] == 0 } { set text "" ; set donext 1 }
 674             #puts " drawTick $c $x 0 0 $neps 0 $eps  $text axisTicks"
 675             drawTick $c $x 0 0 $neps 0 $eps  $text axisTicks
 676         }
 677     }
 678     if { 0 < $x2 && 0 > $x1 } {
 679         set ticks [getTicks $y2 $y1 [expr {$shei/50}]]
 680         set eps [expr {.005 * ($x2 - $x1)}]
 681         set neps [expr {-.005 * ($x2 - $x1)}]
 682         set donext 0
 683         foreach v $ticks {
 684             set y [lindex $v 0]
 685             set text [lindex $v 1]
 686             if { $donext } {set text [lindex $v 0] ; set donext 0}
 687             if { [lindex $v 0] == 0 } { set text "" ; set donext 1}
 688
 689             drawTick $c 0 $y $neps 0 $eps 0  $text axisTicks
 690         }
 691     }
 692
 693 }
 694
 695
 696 #
 697 #-----------------------------------------------------------------
 698 #
 699 # marginTicks --  draw ticks around the border of window
 700 #  x1,y1  top left x2,y2 bottom right.
 701 #
 702 #  Results:
 703 #
 704 #  Side Effects:
 705 #
 706 #----------------------------------------------------------------
 707 #
 708 proc marginTicks { c x1 y1 x2 y2 tag }  {
 709     global printOption
 710     set win [winfo parent $c]
 711
 712     if { ![catch {oget $win noaxisticks}] } { return }
 713     $c delete marginTicks
 714     set ticks [getTicks $x1 $x2 $printOption(xticks)]
 715     # puts "x=$x1 $x2"
 716     set eps [expr {.008 * ($y1 - $y2)}]
 717     set neps [expr {-.008 * ($y1 - $y2)}]
 718     foreach v $ticks {
 719         set x [lindex $v 0]
 720         set text [lindex $v 1]
 721         drawTick $c $x $y1 0 0 0 $eps $text $tag
 722         drawTick $c $x $y2 0 0 0 $neps {} $tag
 723
 724     }
 725     #puts "y=$y2,$y1"
 726     set ticks [getTicks $y1 $y2 $printOption(yticks)]
 727     set eps [expr {.005 * ($x2 - $x1)}]
 728     set neps [expr {-.005 * ($x2 - $x1)}]
 729     set donext 0
 730     foreach v $ticks {
 731         set y [lindex $v 0]
 732         set text [lindex $v 1]
 733         drawTick $c $x1 $y 0 0 $neps 0 $text $tag
 734         drawTick $c $x2 $y 0 0 $eps 0 {} $tag
 735     }
 736 }
 737
 738 proc drawTick {c x y dx dy ex ey n tags} {
 739     global axisGray     fontCourier8
 740     set win [winfo parent $c]
 741     set rtosx rtosx$win ; set rtosy rtosy$win
 742     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]
 743     $c lower $it
 744
 745     if { "$n" != "" } {
 746         if { $ey > 0 } { set anch s
 747         } elseif { $ex > 0 } {set anch w
 748         } elseif { $ex < 0 } {set anch e
 749         } elseif { $ey < 0 } {set anch n}
 750
 751         $c create text  [$rtosx [expr {$x +1.5*$ex}]] [$rtosy [expr {$y +1.5*$ey}]] \
 752             -text [format "%.8g" $n] -font $fontCourier8 -tags $tags \
 753             -anchor $anch
 754     }
 755 }
 756
 757 proc doConfig { win }  {
 758     makeLocal $win c buttonFont
 759     $c delete configoptions
 760     set canv $c
 761     # set w $c.config
 762     set w $win.config
 763     catch {destroy $w}
 764     frame $w -borderwidth 2 -relief raised
 765
 766     label $w.msg  -wraplength 600 -justify left -text [mc "Plot Setup"] -font $buttonFont
 767     pack $w
 768     pack $w.msg -side top
 769     set wb1 $w.choose1
 770     frame $wb1
 771     set wb2 $w.choose2
 772     frame $wb2
 773     pack $wb1 $wb2 -side left -fill x -pady 2m
 774     set item [$canv create window [$canv canvasx 10] [$canv canvasy  10] -window $w -anchor nw -tags configoptions]
 775     button $wb1.dismiss -command  "$canv delete $item; destroy $w " -text "ok" -font $buttonFont
 776 #    button $wb1.printoptions -text [mc "Print Options"] -command "mkPrintDialog .dial -canvas $c -buttonfont $buttonFont " -font $buttonFont
 777
 778     pack $wb1.dismiss -side top
 779     return "$wb1 $wb2"
 780 }
 781 # mkentry { newframe textvar text }
 782
 783 # turn off the horrible show_balloons by default.
 784 global show_balloons
 785 set show_balloons 0
 786
 787 proc balloonhelp { win subwin msg } {
 788     global show_balloons
 789
 790     if { $show_balloons == 0 } {return}
 791     linkLocal  [oget $win c] helpPending
 792     if { [info exists helpPending] } {after cancel $helpPending}
 793     set helpPending [after 1000 [list balloonhelp1 $win $subwin $msg]]
 794 }
 795
 796 proc balloonhelp1 { win subwin msg } {
 797     if { ![winfo exists $win] } { return }
 798     makeLocal $win c buttonFont
 799     set x0 [winfo rootx $win]
 800     set y0 [winfo rooty $win]
 801
 802
 803     set atx [expr {[winfo rootx $subwin] + [winfo width $subwin] - $x0} ]
 804     set aty [expr {[winfo rooty $subwin] + [winfo height $subwin] - $y0} ]
 805
 806     set wid [$c cget -width]
 807     set wid2 [expr {round ($wid /2.0)}]
 808     set wid10 [expr {round ($wid /10.0)}]
 809
 810     if { $aty <=1 } { set aty 30 }
 811     incr aty 10
 812     incr atx 10
 813     set atx [$c canvasx $atx]
 814     set aty [$c canvasy $aty]
 815     #puts "$atx $aty"
 816     $c delete balloon
 817     $c create text $atx $aty -anchor nw -text $msg -font $buttonFont -width $wid2 -fill white -fill black -tags "balloon btext"
 818     desetq "x1 y1 x2 y2" [$c bbox btext]
 819
 820     set x1 [expr {$x1 - .3*($x2-$x1)}]
 821     set x2 [expr {$x2 + .3*($x2-$x1)}]
 822
 823     set y1 [expr {$y1 - .3*($y2-$y1)}]
 824     set y2 [expr {$y2 + .3*($y2-$y1)}]
 825
 826     eval $c create polygon $x1 $y1  $x2 $y1 $x2 $y2 $x1 $y2  -fill beige -tags balloon -smooth 1
 827     $c raise btext
 828
 829 }
 830
 831 proc setBalloonhelp { win subwin msg } {
 832     makeLocal $win c
 833     bind $subwin <Enter> "balloonhelp $win $subwin [list $msg]"
 834     bind $subwin <Leave> "deleteBalloon $c"
 835 }
 836
 837 proc deleteBalloon { c } {
 838     linkLocal $c helpPending
 839     if { [info exists helpPending] } {
 840         after cancel $helpPending
 841         unset helpPending
 842     }
 843     $c delete balloon
 844 }
 845
 846
 847 #
 848 #-----------------------------------------------------------------
 849 #
 850 # minMax --  Compute the max and min of the arguments, which may
 851 # be vectors or numbers
 852 #
 853 #  Results: list of MIN and MAX
 854 #
 855 #  Side Effects: none
 856 #
 857 #----------------------------------------------------------------
 858 #
 859 proc minMax { args } {
 860     set max [lindex [lindex $args 0] 0] ; set min $max ;
 861     foreach vec $args {
 862         foreach v $vec {
 863             if { $v > $max } {set max $v }
 864             if { $v < $min} {set min $v }
 865         }
 866     }
 867     return [list $min $max]
 868 }
 869
 870 proc matrixMinMax { list } {
 871     # compute the min max of the list
 872     set min +10e300
 873     set max -10e300
 874     foreach mat $list {
 875         foreach row $mat {
 876             foreach v [ldelete nam $row] {
 877                 if { $v > $max } {catch  { set max [expr {$v + 0}] }}
 878                 if { $v < $min} {catch  { set min [expr {$v + 0}] }}
 879             }
 880         }
 881     }
 882     list $min $max
 883 }
 884
 885 proc omPlotAny { data args } {
 886     # puts "data=<[lindex $data 0]>"
 887     set command [list [lindex [lindex $data 0] 0]  -data [lindex $data 0] ]
 888     if { "[lindex $command 0]" == "plot2d" } {
 889         lappend command -xfun {}
 890     }
 891     foreach v $args { lappend command $v }
 892     eval $command
 893     #eval [lindex [lindex $data 0] 0] -xfun [list {}] -data [list [lindex $data 0]] $args
 894 }
 895
 896 proc resizeSubPlotWindows { win wid height } {
 897     set at [$win yview "@0,0"]
 898     foreach w [winfo children $win] {
 899         if { [string match plot* [lindex [split $w .] end]] } {
 900             resizePlotWindow $w [winfo width $w] $height
 901         }
 902     }
 903     if { "$at" != "" } { $win yview $at}
 904 }
 905
 906 proc resizePlotWindow  { w width height } {
 907     if { [winfo width $w.c] <= 1 } {
 908         after 100 update ;
 909         return }
 910     if { ![catch { set tem [oget $w lastResize] } ] && [expr {[clock seconds] - $tem }] < 2 } { return
 911     } else {
 912         oset $w lastResize [clock seconds ]
 913     }
 914     #puts "resizePlotWindow $w $width $height"
 915
 916     # return
 917     set par [winfo parent $w]
 918     set facx 1.0
 919     set facy 1.0
 920     set wid [winfo width $par]
 921     set hei [winfo height $par]
 922
 923     if { "[winfo class $par]" == "Text" } {
 924         set dif 10
 925
 926         set wid1 $wid ; set hei1 $hei
 927         #puts "now w=$w"
 928         #set wid1 [getPercentDim [oget $w widthDesired] width $par]
 929         catch {set wid1 [getPercentDim [oget $w widthDesired] width $par] }
 930         catch {set hei1 [getPercentDim [oget $w heightDesired] height $par] }
 931         set wid [expr {($wid1 > $wid - 30 ? $wid - 30 : $wid1 )}]
 932         set hei [expr {($hei1 > $hei - 30 ? $hei - 30 : $hei1 )}]
 933     } else {
 934         set dif 10
 935
 936     }
 937
 938     #     if { $width > $wid -20 || $wid > $width -20 }
 939     if { (abs($width-$wid) > $dif ||  abs($height-$hei) > $dif)
 940          &&  [winfo width $w.c] > 1 } {
 941         set eps [expr {2 * [$w.c cget -insertborderwidth] + [$w.c cget -borderwidth] }]
 942         set epsx $eps
 943         set epsy $eps
 944         set extrawidth [expr {([winfo width $w] - [winfo width  $w.c]) +$epsx}]
 945         set extraheight [expr {([winfo height $w] - [winfo height  $w.c]) +$epsy}]
 946         set nwidth [expr {$wid - ($extrawidth > 0  ? $extrawidth : 0)}]
 947         set nheight [expr {$hei - ($extraheight > 0  ? $extraheight : 0)}]
 948
 949         #puts "$w.c config -width $nwidth  -height $nheight, extraheight=$extraheight,epsy=$epsy"
 950         $w.c config -width $nwidth  -height $nheight
 951
 952     }
 953
 954 }
 955
 956 proc bboxToRadius { win  } {
 957     makeLocal $win bbox
 958     if { "$bbox" != "" } {
 959         linkLocal $win xradius yradius xcenter ycenter
 960         set i 0
 961         foreach v { x y z } {
 962             set min [lindex $bbox $i]
 963             set max [lindex $bbox [expr {$i+2}]]
 964             if { "$min" != "" } {
 965                 if { $min >= $max } {error "bad bbox $bbox since $min >= $max"}
 966                 set ${v}radius [expr { ($max - $min) /2.0}]
 967                 set ${v}center [expr { ($max + $min) /2.0}]
 968             }
 969         }
 970     }
 971 }
 972
 973 proc updateParameters { win var value} {
 974     linkLocal $win parameters
 975     #    puts "$win $var $value"
 976     set ans ""
 977     set comma ""
 978
 979     foreach {v val} [splitParams $parameters] {
 980         if { "$v" == "$var" } {
 981             set val $value
 982         }
 983         append ans $comma $v=$val
 984         set comma ","
 985     }
 986     #    puts "parameters=$ans"
 987     set parameters $ans
 988 }
 989
 990 proc addSliders { win } {
 991     linkLocal $win sliders c width parameters
 992     set i 0
 993     if { "$sliders" == "" } { return }
 994     catch { destroy $c.sliders }
 995     set bg "#22aaee"
 996     set trough "#22ccff"
 997     frame $c.sliders -relief raised -highlightthickness 2 -highlightbackground $trough
 998     foreach v [split $sliders ,] {
 999         if { [regexp {([a-zA-Z0-9]+)[ ]*=?(([---0-9.]+):([---0-9.]+))?} $v  junk var junk x0 x1] } {
1000             incr i
1001             if { "$x0" == "" } { set x0 -5  ; set x1 5}
1002
1003             set fr $c.sliders.fr$i
1004             frame $fr -background $bg
1005             label $fr.lab -text $var: -background $bg
1006             label $fr.labvalue -textvariable [oloc $win slidevalue$i]  -background $bg -relief sunken -justify left
1007             scale $fr.scale -command "sliderUpdate $win $var" \
1008                 -from "$x0" -to $x1 -orient horizontal \
1009                 -resolution [expr ($x1 - $x0) < 1 ? ($x1-$x0)/100.0 : .01] \
1010                 -length [expr {$width/2}] -showvalue 0 -variable [oloc $win slidevalue$i] -background $bg -troughcolor "#22ccff" -highlightthickness 0
1011             pack $fr.lab -side left -expand 1 -fill x
1012             pack $fr.labvalue $fr.scale -side left
1013             pack  $fr -side top -expand 1 -fill x
1014             set found 0
1015             set val  [assoc $var [splitParams $parameters] no]
1016             if { "$val" == "no" } {
1017                 set val  [expr ($x1 + $x0)/2.0]
1018                 if { "$parameters" != "" }  { append parameters , }
1019                 append parameters $var=$val
1020             }
1021             $fr.scale set $val
1022         }
1023     }
1024
1025     place  $c.sliders -in $c -x 4 -rely 1.0 -y -4 -anchor sw
1026
1027 }
1028
1029
1030 proc sliderUpdate { win var val } {
1031     linkLocal $win sliderCommand parameters
1032     set params $parameters
1033     updateParameters $win $var $val
1034     if { "$params" != "$parameters" &&
1035          [info exists sliderCommand] } {
1036
1037         $sliderCommand $win $var $val
1038     }
1039 }
1040
1041
1042
1043
1044 ## endsource plotconf.tcl