home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / libexec / maxima / 5.9.0 / omplotdata < prev   
Encoding:
Text File  |  2003-02-09  |  155.8 KB  |  5,297 lines
  1. #!/bin/sh
  2. # comment \
  3. exec wish "$0" "$@"
  4. #############################################
  5. ##### Copyright William Schelter 1997 #######
  6. #############################################
  7. set ws_openMath(date) 12/09/2000
  8.  
  9. ###### plotting.tcl ######
  10. ############################################################
  11. # Netmath       Copyright (C) 1998 William F. Schelter     #
  12. # For distribution under GNU public License.  See COPYING. # 
  13. ############################################################
  14. ## source plotconf.tcl
  15.  
  16. ###### plotconf.tcl ######
  17. ############################################################
  18. # Netmath       Copyright (C) 1998 William F. Schelter     #
  19. # For distribution under GNU public License.  See COPYING. # 
  20. ############################################################
  21.  
  22. ## source private.tcl
  23.  
  24. ###### private.tcl ######
  25. ############################################################
  26. # Netmath       Copyright (C) 1998 William F. Schelter     #
  27. # For distribution under GNU public License.  See COPYING. # 
  28. ############################################################
  29.  
  30. # a private way of storing variables on a window by window
  31. # basis
  32.  
  33. proc makeLocal { win args } {
  34.   foreach v $args {
  35.      uplevel 1 set  $v \[oget $win $v\]
  36.  }
  37. }
  38.  
  39. proc linkLocal { win args } {
  40.   foreach v $args {
  41.       uplevel 1 upvar #0 _WinInfo${win}\($v) $v
  42.  }
  43. }
  44.  
  45. proc clearLocal { win } {
  46.     global _WinInfo$win
  47.        # puts "clearing info for $win in [info level 1]"
  48.  
  49.     catch { unset _WinInfo$win }
  50. }
  51.  
  52.  
  53. proc oset { win var val } {
  54.   global _WinInfo$win
  55.   set _WinInfo[set win]($var) $val
  56. }
  57.  
  58. proc oarraySet { win vals } {
  59.   global _WinInfo$win
  60.   array set  _WinInfo$win $vals
  61. }
  62.  
  63. proc oloc { win var } {
  64.   return _WinInfo[set win]($var)
  65. }
  66.  
  67. proc oarray { win  } {
  68.   return _WinInfo[set win]
  69. }
  70.  
  71. proc oget { win var } {
  72.   global _WinInfo$win
  73.   return [set _WinInfo[set win]($var)]
  74. }
  75.  
  76.  
  77. ## endsource private.tcl
  78. ## source parse.tcl
  79.  
  80. ###### parse.tcl ######
  81. ############################################################
  82. # Netmath       Copyright (C) 1998 William F. Schelter     #
  83. # For distribution under GNU public License.  See COPYING. # 
  84. ############################################################
  85.  
  86. ## source getopt.tcl
  87.  
  88. ###### getopt.tcl ######
  89. ############################################################
  90. # Netmath       Copyright (C) 1998 William F. Schelter     #
  91. # For distribution under GNU public License.  See COPYING. # 
  92. ############################################################
  93. ## source macros.tcl
  94.  
  95. ###### macros.tcl ######
  96. ############################################################
  97. # Netmath       Copyright (C) 1998 William F. Schelter     #
  98. # For distribution under GNU public License.  See COPYING. # 
  99. ############################################################
  100. proc desetq {lis lis2} {
  101.     set i 0
  102.     foreach v $lis {
  103.     uplevel 1 set $v [list [lindex $lis2 $i]]
  104.     set i [expr {$i + 1}]
  105.     }
  106. }
  107.  
  108. proc assoc { key lis args } {
  109.     foreach { k val } $lis {
  110.     if { "$k" == "$key" } {
  111.         return $val }
  112.     }
  113.     return [lindex $args 0]
  114. }
  115.  
  116. proc delassoc { key lis } {
  117.     foreach { k val } $lis {
  118.     if { "$k" != "$key" } {
  119.     lappend new $k $val
  120.     }
  121.     }
  122.     return $new
  123. }
  124.  
  125.  
  126. proc putassoc {key lis value } {
  127.     set done 0
  128.     foreach { k val } $lis {
  129.     if { "$k" == "$key" } {
  130.         set done 1
  131.         set val $value
  132.     }
  133.     lappend new $k $val
  134.     }
  135.     if { !$done } {
  136.     lappend new $key $value
  137.     }
  138.     return $new
  139. }
  140.  
  141. proc intersect { lis1 lis2 } {
  142.     set new ""
  143.     foreach v $lis1 { set there($v) 1 }
  144.     foreach v $lis2 { if { [info exists there($v)] } { lappend new $v }}
  145.     return $new
  146. }
  147.  
  148.  
  149.  
  150. #
  151.  #-----------------------------------------------------------------
  152.  #
  153.  # ldelete --  remove all copies of ITEM from LIST
  154.  #
  155.  #  Results: new list without item
  156.  #
  157.  #  Side Effects: 
  158.  #
  159.  #----------------------------------------------------------------
  160. #
  161. proc ldelete { item list } {
  162.     while { [set ind [lsearch $list $item]] >= 0  } {
  163.     set list [concat [lrange $list 0 [expr {$ind -1}]] [lrange $list [expr {$ind +1}] end]]
  164.     }
  165.     return $list
  166. }
  167.  
  168. # apply f a1 a2 a3 [list  u1 u2 ..un]   , should call
  169. # f with n+3 arguments.
  170. proc apply {f args } {
  171.     set lis1 [lrange $args 0 [expr {[llength $args] -2}]]
  172.     foreach v [lindex $args end] { lappend lis1 $v}
  173.     set lis1 [linsert $lis1  0 $f]
  174.     uplevel 1 $lis1
  175. }
  176.  
  177.  
  178.  
  179.  
  180.  
  181.  
  182. ## endsource macros.tcl
  183.  
  184. #####sample option list.   Error will be signalled if "Required" option
  185. ##### not given.
  186. #set dfplotOptions {
  187. #    {xdot Required {specifies dx/dt = xdot.  eg -xdot "x+y+sin(x)^2"} }
  188. #    {ydot Required {specifies dy/dt = ydot.  eg -ydot "x-y^2+exp(x)"} }
  189. #    {xradius 10 "Width in x direction of the x values" }
  190. #    {yradius 10 "Height in y direction of the y values"}
  191. #}
  192.  
  193.  
  194. #
  195.  #-----------------------------------------------------------------
  196.  #
  197.  # optLoc --  if $usearray is not 0, then the OPTION is stored 
  198.  # in a hashtable, otherwise in the variable whose name is the
  199.  # same as OPTION.  
  200.  #  Results: a form which when 'set' will allow storing value.
  201.  #
  202.  #  Side Effects: none
  203.  #
  204.  #----------------------------------------------------------------
  205. #
  206. proc optLoc { op ar }  {
  207.   #  puts "$ar,[lindex $op 0]"
  208.   # puts "return=$ar\([lindex $op 0]\)"
  209.    if { "$ar" == 0 } {
  210.        return [lindex $op 0]
  211.    } else {
  212.      #puts "$ar\([lindex $op 0]\)"
  213.     return "$ar\([lindex $op 0]\)" }
  214.  
  215. }
  216.  
  217.  
  218. #
  219.  #-----------------------------------------------------------------
  220.  #
  221.  # getOptions --  given OPTLIST a specification for the options taken,
  222.  # parse the alternating keyword1 value1 keyword2 value2 options_supplied
  223.  # to make sure they are allowed, and not just typos, and to supply defaults
  224.  # for ones not given.   Give an error message listing options.
  225.  # a specification is  { varname default_value "doc string" }
  226.  # and optlist, is a list of these.   the key should be -varname
  227.  # 
  228.  #  -debug 1 "means print the values on standard out"
  229.  #  -allowOtherKeys 1 "dont signal an error if -option is supplied but not in
  230.  #                     the list"
  231.  #  -usearray "should give a NAME, so that options are stored in NAME(OPTION)
  232.  #  -setdefaults "if not 0 (default is 1) do `set OPTION dflt' for all options"
  233.  # If a key is specified twice eg.  -key1 val1 -key1 val2, then the first
  234.  # value val1 will be used 
  235.  #  Results:
  236.  #
  237.  #  Side Effects: set the values in the callers environment
  238.  #
  239.  #----------------------------------------------------------------
  240. #
  241.  
  242. proc getOptions { optlist options_supplied args } {
  243.    # global  getOptionSpecs
  244.  
  245.     set ar [assoc -usearray $args 0]
  246.     set help [assoc -help $args ""]
  247.     if { "$ar" != "0" } { global $ar }
  248.     set debug [assoc -debug $args 0]
  249.     set allowOtherKeys [assoc -allowOtherKeys $args 0]
  250.     set setdefaults [assoc -setdefaults $args 1]
  251.     set supplied ""
  252.  
  253.     foreach {key val } $options_supplied {
  254.     if { [info exists already($key)] } { continue }
  255.     set already($key) 1
  256.     set found 0
  257.     foreach op $optlist {
  258.         if { "$key" == "-[lindex $op 0]" } {
  259.         uplevel 1 set [optLoc $op $ar] [list $val]
  260.         
  261.         append supplied " [lindex $op 0]"
  262.         set found 1
  263.         break
  264.         }
  265.     }
  266.     set caller global
  267.  
  268.     if { $found == 0  && !$allowOtherKeys } {
  269.         catch {set caller [lindex [info level -1] 0]}
  270.              error "`$caller' does not take the key `$key':\n[optionHelpMessage $optlist]\n$help"
  271.  
  272.         }
  273.     }
  274.     foreach op $optlist {
  275.      if { [lsearch $supplied [lindex $op 0]] < 0 } {
  276.            if { "[lindex $op 1]" == "Required" } {
  277.            catch {set caller [lindex [info level -1] 0]}           
  278.               error "`-[lindex $op 0]' is required option for `$caller':\n[optionHelpMessage $optlist]"
  279.             }
  280.               if { $setdefaults }  {
  281.             
  282.         uplevel 1 set [optLoc $op $ar] [list [lindex $op 1]]
  283.           }
  284.     }
  285.     # for debugging see them.
  286.     # if { $debug } {   uplevel 1 puts "[optLoc $op $ar]=\$[optLoc $op $ar]"}
  287.      if { $debug } {   puts "[optLoc $op $ar]=[safeValue [optLoc $op $ar] 2]"}
  288.     
  289.     }
  290. }
  291.  
  292. proc getOptionDefault { key optionList } {
  293.  foreach v $optionList {
  294.   if { "[lindex $v 0]" == "$key" } { return [lindex $v 1]}
  295.    }
  296.  return ""
  297. }
  298.  
  299. proc assq {key list {dflt ""}} {
  300.     foreach v $list { if { "[lindex $v 0]" == "$key" } { return $v }}
  301.     return $dflt
  302. }
  303.  
  304. proc safeValue { loc level} {
  305.   if { ![catch { set me [uplevel $level set $loc] } ] } {
  306.      return $me  }  else {return "`unset'" }
  307. }
  308.      
  309.   
  310.  
  311. proc optionFirstItems { lis } {
  312.     set ans ""
  313.     foreach v $lis { append ans " [list [lindex $v 0]]" }
  314.     return $ans
  315. }
  316.  
  317. proc optionHelpMessage { optlist } {
  318.     set msg ""
  319.     foreach op $optlist  {    
  320.     append msg \
  321.         " -[lindex $op 0] \[ [lindex $op 1] \] --[lindex $op 2]\n"
  322.         }
  323.     return $msg
  324.     }
  325.  
  326.  
  327. #
  328.  #-----------------------------------------------------------------
  329.  #
  330.  # setSplittingOptionsRest --  takes ARGLIST and splits it into
  331.  # two lists, the first part it stores in KEYPAIRS and the second in REST
  332.  # 
  333.  #
  334.  #  Results: none
  335.  #  
  336.  #
  337.  #  Side Effects: sets the variables in the local frame passed to KEYPAIRS 
  338.  #
  339.  #----------------------------------------------------------------
  340. #    
  341. proc setSplittingOptionsRest {  keypairs rest arglist } {
  342.     upvar 1 $keypairs keys
  343.     upvar 1 $rest res
  344.     set i 0
  345.     while { 1 } {
  346.     if { $i >= [llength $arglist] } { break } 
  347.     if { "[string range [lindex $arglist $i] 0 0]" == "-" } {
  348.         incr i 2
  349.     } else { break }
  350.     }
  351.     set keys [lrange $arglist 0 [expr $i -1]]
  352.     set res [lrange $arglist  $i end]
  353. }
  354.     
  355.     
  356.     
  357.     
  358.  
  359.  
  360. ## endsource getopt.tcl
  361.  
  362. catch { unset Parser }
  363.  
  364. foreach v  { { ( 120 } { \[ 120 } { ) 120 } { \] 120 }  { ^ 110}
  365.          {* 100} { / 100} {% 100}  {- 90 } { + 90 }
  366.            { << 80} { >> 80 } { < 70 } { > 70 } { <= 70 } {>= 70}
  367.        { == 60 } { & 50} { | 40 } { , 40 } {= 40}
  368.        { && 30 } { || 20 } { ? 10 } { : 10 }  { ; 5 }}  {
  369.            set parse_table([lindex $v 0]) [lindex $v 1]
  370.            set getOp([lindex $v 0]) doBinary
  371.            
  372.        }
  373.  
  374. proc binding_power {s} {
  375.     global parse_table billy
  376.     set billy $s
  377.     if { [catch { set tem $parse_table($s) }] } { return 0 } else { return $tem }
  378. }
  379.  
  380. proc getOneMatch { s inds } {
  381.     return [string range $s [lindex $inds 0] [lindex $inds 1]]
  382. }
  383. proc parseTokenize { str } {
  384.     regsub  -all {[*][*]} $str "^" str
  385.     set ans ""
  386.     while { [string length $str ] > 0 } {
  387. #    puts "ans=$ans,str=$str"    
  388.     set str [string trimleft $str " \t\n" ]
  389.     set s [string range $str 0 1]
  390.     set bp [binding_power $s]
  391.     if { $bp > 0 } { append ans " $s"
  392.        set str [string range $str 2 end]
  393.     continue
  394.     } else {
  395.     set s [string range $s 0 0]
  396.         set bp [binding_power $s]
  397.         if { $bp > 0 } { append ans " $s"
  398.        set str [string range $str 1 end]
  399.     continue
  400.    }
  401.   }
  402.   if { "$s" == "" } {
  403.       return $ans
  404.   }
  405.   if { [regexp -indices {^[0-9.]+([eE][+---]?[0-9]+)?} $str all] } {
  406.       append ans " { number [getOneMatch $str $all] }"
  407.      # append ans " [getOneMatch $str $all]"
  408.       set str [string range $str [expr {1+ [lindex $all 1]}] end]
  409.   }  elseif { [regexp -indices {^[$a-zA-Z][a-zA-Z0-9]*} $str all] } {
  410.        append ans " { id [getOneMatch $str $all] } "
  411.       # append ans " [getOneMatch $str $all]"
  412.       set str [string range $str [expr {1+ [lindex $all 1]}] end]
  413.   }  else { error "parser unrecognized: $str"
  414.   }
  415.   }
  416.   return $ans
  417. }
  418.  
  419. set Parser(reserved) " acos cos hypo sinh asin cosh log sqrt atan exp log10 tan atan2 floor pow tanh ceil fmod sin abs double int round"
  420.  
  421. set Parser(help) [join [list {
  422. The syntax is like C except that it is permitted to write x^n
  423. instead of pow(x,n).
  424. } "\nFunctions: $Parser(reserved)\n\nOperators: == % & || ( << <= ) : * >=  + && , | < >> - > ^ ? /" ] ""]
  425.  
  426.     
  427.  
  428. proc nexttok { } {
  429.     global Parser
  430.     set x [lindex $Parser(tokenlist) [incr Parser(tokenind) ]]
  431.     # puts "nexttok=$x"
  432.     if {[llength $x ] > 1 } {
  433.     set Parser(tokenval) [lindex $x 1]
  434.     return [lindex $x 0]
  435.     } else { return $x }
  436. }
  437.  
  438.  
  439. #
  440.  #-----------------------------------------------------------------
  441.  #
  442.  # parseToSuffixLists -- Convert EXPR1; EXPR2; ..
  443.  # to a list of suffix lists.  Each suffix list is suitable for
  444.  # evaluating on a stack machine (like postscript) or for converting
  445.  # further into another form.  see parseFromSuffixList.
  446.  #  "1+2-3^4;" ==>
  447.  #   {number 1} {number 2} + {number 3} {number 4} ^ -
  448.  #  Results: suffix list form of the original EXPR
  449.  #
  450.  #  Side Effects: none
  451.  #
  452.  #----------------------------------------------------------------
  453. #
  454. proc parseToSuffixLists { a }  {
  455.     global    Parser 
  456.     set Parser(result) ""
  457.     set Parser(tokenlist) [parseTokenize $a]
  458.     set Parser(tokenind) -1
  459.     set Parser(lookahead)  [nexttok]
  460.     #puts tokenlist=$Parser(tokenlist)
  461.     set ans ""
  462.     while { "$Parser(lookahead)" != ""  } {
  463.       getExpr  ; parseMatch ";"
  464.       #puts "here: $Parser(result) "    
  465.       append ans "[list    $Parser(result)] "
  466.       set Parser(result) ""     
  467.     }
  468.     return $ans
  469. }
  470.  
  471. proc parseMatch { t } {
  472.     global Parser
  473.     if { "$t" == "$Parser(lookahead)" } {
  474.     set Parser(lookahead)  [nexttok]
  475.     } else { error "syntax error: wanted $t"}
  476. }
  477.  
  478. proc emit { s args } {
  479.     global Parser
  480.     if { "$args" == "" }   {
  481.     append Parser(result) " $s"
  482.     # puts " $s "
  483.     } else {
  484.     append Parser(result) " {[lindex $args 0 ] $s}"
  485.     #puts " {[lindex $args 0 ] $s} "
  486.     }
  487. }
  488.  
  489. proc getExpr { } { getExprn 0 }
  490.  
  491. proc getExprn { n } {
  492.     global Parser
  493.     #puts "getExpr $n, $Parser(tokenind),$Parser(tokenlist)"
  494.     if { $n == 110 } {
  495.       getExpr120
  496.       return
  497.      }
  498.  
  499.     incr n 10
  500.     if  { $n == 110 } {
  501.        if { "$Parser(lookahead)" == "-" || "$Parser(lookahead)" == "+"  } {
  502.             if { "$Parser(lookahead)" == "-" } { set this PRE_MINUS } else {
  503.                set this PRE_PLUS }
  504.         parseMatch $Parser(lookahead)
  505.             getExprn $n
  506.         #puts "l=$Parser(lookahead),pl=$Parser(result)"
  507.             emit $this
  508.             return
  509.            } 
  510.            
  511.     }
  512.  
  513.     getExprn $n
  514.     while { 1 } {
  515.     if { [binding_power $Parser(lookahead)] == $n } {
  516.         set this $Parser(lookahead)
  517.         parseMatch $Parser(lookahead)
  518.             getExprn $n
  519.         if { $n == 110 } {
  520.         set toemit ""
  521.         while { "$this" == "^" &&  "$Parser(lookahead)" == "^" } {
  522.             # puts "p=$Parser(result),$
  523.             set this $Parser(lookahead)
  524.             append toemit " $this"
  525.             parseMatch $Parser(lookahead)
  526.             getExprn $n
  527.         }
  528.         foreach v $toemit { emit $v }
  529.         }
  530.         emit $this
  531.            
  532.     } else { return }
  533.     }
  534. }
  535.  
  536. proc getExpr120 { } {
  537.     global Parser
  538.     #puts "getExpr120, $Parser(tokenind),[lrange $Parser(tokenlist) $Parser(tokenind) end]"
  539.     while { 1 } {
  540.     if { "$Parser(lookahead)" == "(" } {
  541.         parseMatch $Parser(lookahead)
  542.         getExpr
  543.         parseMatch ")"
  544.         break;
  545.     } elseif { $Parser(lookahead) == "id" } {
  546.         emit $Parser(tokenval) id
  547.  
  548.         parseMatch $Parser(lookahead)
  549.         if { "$Parser(lookahead)" == "(" } {
  550.         getExpr120
  551.         emit funcall
  552.         }
  553.         break;
  554.     } elseif { $Parser(lookahead) == "number" } {
  555.         emit $Parser(tokenval) number
  556.         parseMatch $Parser(lookahead)
  557.         break;
  558.     } else { error "syntax error" }
  559.     }
  560. }
  561.  
  562. set getOp(PRE_PLUS) doPrefix
  563. set getOp(PRE_MINUS) doPrefix
  564. set getOp(funcall) doFuncall
  565. set getOp(^) doPower
  566. set getOp(:) doConditional
  567. set getOp(?) doConditional
  568.  
  569. proc doBinary { } {
  570.     uplevel 1 {set s $nargs; incr nargs -1 ;
  571.     if { "$x" == "," } {    set a($nargs) "$a($nargs) $x $a($s)"} else { 
  572.  
  573.     set a($nargs) "($a($nargs) $x $a($s))"} }
  574. }
  575.  
  576. proc doPower { } {
  577.     uplevel 1 {set s $nargs; incr nargs -1 ; set a($nargs) "pow($a($nargs),$a($s))" }
  578. }
  579. proc doFuncall {} {
  580.     uplevel 1 {
  581.     #puts nargs=$nargs
  582.     set s $nargs; incr nargs -1 ; set a($nargs) "$a($nargs)($a($s))"}
  583. }
  584.  
  585. proc doPrefix {} {
  586.   uplevel 1  { if { "$x" == "PRE_MINUS" } { set a($nargs) "-$a($nargs)" } }
  587. }
  588.  
  589. proc doConditional { } {
  590.     set x [uplevel 1 set x]
  591.     if { "$x" == "?" } { return }
  592.     # must be :
  593.     uplevel 1 { 
  594.     set s $nargs ; incr nargs -2 ;
  595.     set a($nargs) "($a($nargs) ? $a([expr {$nargs + 1}]) : $a($s))"
  596.  }
  597. }
  598.  
  599.  
  600. #
  601.  #-----------------------------------------------------------------
  602.  #
  603.  # parseFromSuffixList --  takes a token list, and turns
  604.  # it into a suffix form.  eg: 1 + 2 - 3 ^ 4 --> 1 2 + 3 4 ^ -
  605.  #  Results:
  606.  #
  607.  #  Side Effects: 
  608.  #
  609.  #----------------------------------------------------------------
  610. #
  611. proc parseFromSuffixList { list } {
  612.     global getOp
  613.   set stack ""
  614.   set lim [llength $list]
  615.   set i 0
  616.   set nargs 0
  617.   while { $i < $lim } {
  618.     set x [lindex $list $i ]
  619.     set bp [binding_power $x]
  620.     incr i
  621.    # all binary
  622.     if { [llength $x] > 1 } {
  623.     
  624.     set a([incr nargs]) [lindex $x 1]
  625.  
  626.      } else {
  627.      $getOp($x) }
  628.    }
  629.  
  630.   return $a(1)
  631. }
  632.     
  633.  
  634. #
  635.  #-----------------------------------------------------------------
  636.  #
  637.  # parseConvert --  given an EXPRESSION, parse it and find out
  638.  # what are the variables, and convert a^b to pow(a,b).  If
  639.  # -variables "x y" is given, then x and y will be replaced by $x $y
  640.  #  doall 1 is giv 
  641.  #  Results:
  642.  #
  643.  #  Side Effects: 
  644.  #
  645.  #----------------------------------------------------------------
  646. #
  647. set Parser(convertOptions) {
  648.     { doall 0 "convert all variables x to \$x" }
  649.     { variables "" "list of variables to change from x to \$x" }
  650. }
  651. proc parseConvert { expr args } {
  652.     global   Parser 
  653.     getOptions $Parser(convertOptions) $args
  654.     if { "$expr" == "" } { return [list {} {}] }
  655.     set parselist [parseToSuffixLists "$expr;"]
  656.     #puts "parselist=$parselist"
  657.     catch { unset allvars }
  658.     set new ""
  659.     set answers ""
  660.     foreach lis $parselist {
  661.       
  662.      foreach v $lis {
  663.  
  664.     if { ("[lindex $v 0]" == "id")
  665.     && ([llength $v] == 2)
  666.     && ([lsearch  $Parser(reserved) [set w [lindex $v 1]]] < 0)
  667.     } {  
  668.     if { ($doall != 0)  || ([lsearch  $variables $w] >= 0) } {
  669.         append new " {id \$$w}"
  670.         set allvars(\$$w) 1
  671.     } else {
  672.         set allvars($w) 1
  673.         append new " {$v}"
  674.     }   }  else {
  675.     if { [llength $v] > 1 } { 
  676.         append new " {$v}" } else {
  677.         append new " $v" }
  678.         }
  679.     }
  680.     #puts "new=$new"
  681.     append answers "[list [parseFromSuffixList $new]] "
  682.     set new ""
  683.  }
  684.     return [list $answers [array names allvars]]
  685. }
  686.  
  687. proc test { s } {
  688.     set me [parseFromSuffixList [lindex [parseToSuffixLists "$s;"] 0]]
  689.     puts $me
  690.     return "[eval expr $s] [eval expr $me]"
  691. }
  692.  
  693.  
  694.  
  695.  
  696. # 
  697. # Local Variables:
  698. # mode: tcl
  699. # version-control: t
  700. # End:
  701.  
  702.  
  703. ## endsource parse.tcl
  704. ## source textinsert.tcl
  705.  
  706. ###### textinsert.tcl ######
  707. ############################################################
  708. # Netmath       Copyright (C) 1998 William F. Schelter     #
  709. # For distribution under GNU public License.  See COPYING. # 
  710. ############################################################
  711.  
  712. proc mkTextItem { c x y args  } {
  713.     set font [assoc -font $args {Helvetica 14}]
  714.     set tags [assoc -tags $args {}]
  715.     set item [$c create text $x $y -text " " -width 440 -anchor n -font $font -justify left]
  716.     append tags text
  717.     foreach v $tags { $c addtag $v withtag $item}
  718.     $c bind text <1> "textB1Press $c %x %y"
  719.     $c bind text <B1-Motion> "textB1Move $c %x %y"
  720.     $c bind text <Shift-1> "$c select adjust current @%x,%y"
  721.     $c bind text <Shift-B1-Motion> "textB1Move $c %x %y"
  722.     $c bind text <KeyPress> "textInsert $c %A"
  723.     $c bind text <Return> "textInsert $c \\n"
  724.     $c bind text <Control-h> "textBs $c"
  725.     $c bind text <BackSpace> "textBs $c"
  726.     $c bind text <Delete> "textDel $c"
  727.     $c bind text <2> "textPaste $c @%x,%y" 
  728. }
  729.  
  730.  
  731. ## endsource textinsert.tcl
  732. ## source printops.tcl
  733.  
  734. ###### printops.tcl ######
  735. ############################################################
  736. # Netmath       Copyright (C) 1998 William F. Schelter     #
  737. # For distribution under GNU public License.  See COPYING. # 
  738. ############################################################
  739.  
  740. ### fix a4 size !
  741. set paperSizes {{letter 8.5 11} { A4 8.5 11} {legal 8.5 13}} 
  742.  
  743. set printOptions { 
  744.     { landscape  1 "Non zero means use landscape mode in printing" }
  745.     { tofile 1 "Non zero means print to file" }
  746.     { pagewidth "" "Figure width" }
  747.     { pageheight "" "Figure height" }
  748.     { papersize letter "letter, legal or A4"}
  749.     { hoffset .5 "Left margin for printing"}
  750.     { voffset .5 "Right margin for printing"}
  751.     { xticks 20 "Rough number of ticks on x axis"}
  752.     { yticks 20 "Rough number of ticks on y axis"}
  753.     { domargin 1 "Print the frame and the margin ticks"}
  754.     { printer "" "Printer to print to, eg lw8b " }
  755.     { title "" "Title" }
  756.     { psfilename "~/sdfplot.ps" "Postscript filename" }
  757.     { gsview "gsview32" "postscript viewer, used for printing under Windows" }
  758.     { centeronpage 1 ""} 
  759. }
  760.  
  761. # proc getPageOffsets { widthbyheight} {
  762. #     global printOption paperSizes
  763. #     puts "wbh=$widthbyheight"
  764. #     set pwid 8.5
  765. #     set phei 11.0
  766.  
  767. #     foreach v $paperSizes {
  768. #     if { "[lindex $v 0]" == "$printOption(papersize)" } {
  769. #         set pwid [lindex $v 1]
  770. #         set phei [lindex $v 2]
  771. #     }
  772. #     }
  773. #     set wid [expr {$pwid - 2* $printOption(hoffset)}]
  774. #     set hei [expr {$phei - 2* $printOption(voffset)}]
  775. # #    if { $printOption(landscape) } {set widthbyheight [expr  {1.0 /$widthbyheight}]}
  776. # #    set w $wid ; set hei $wid ; set wid $w
  777.  
  778. #     puts "pw=$wid,ph=$hei,w/h=$widthbyheight,hh=[expr {$hei * $widthbyheight}], ww=[expr {$wid / $widthbyheight}]"
  779.  
  780. #     set fac   $widthbyheight
  781. #     puts "fac=$fac"
  782. #     if { $fac * $hei < $wid } {
  783.     #     set iwid [expr {$fac *$hei}]
  784. #     set ihei $hei
  785.  
  786. #     } else {
  787.     #     set ihei [expr {$wid / $fac}]
  788.  
  789. #     set iwid $wid
  790.  
  791. #     }
  792.  
  793. #     if { $printOption(landscape) } { set fac1 [expr {1/$fac}] }
  794. #     if { $wid/$hei > $fac } {
  795. #     set ihei $hei
  796.     #     set iwid   [expr {$hei / $fac }]
  797.  
  798. #     } else {
  799. #      set iwid $wid
  800.     #      set ihei [expr {$wid * $fac }]
  801. #     }
  802.  
  803. #     #-pagex = left margin (whether landscape or not)
  804. #     #-pagey = right margin (whether landscape or not)
  805. #     #-pagewidth becomes vertical height if landscape
  806. #     #-pageheight becomes horiz width if landscape
  807.     
  808. #     set xoff [expr {($pwid-$iwid)/2.0}]
  809. #     set yoff [expr  {($phei-$ihei)/2.0}]
  810.  
  811. #     if { $printOption(landscape) } {
  812. #     set h $ihei
  813. #     set ihei $iwid
  814. #     set iwid $h
  815. #     }
  816.  
  817. #     puts "phei=$phei,ihei=$ihei,yoff=$yoff,voff=$printOption(voffset)"
  818. #     set ans "-pagex [set xoff]i -pagey [set yoff]i \
  819. #         -pagewidth [set iwid]i -pageheight [set ihei]i"
  820. #     set ans "-pagex [set xoff]i -pagey [set yoff]i \
  821. #         -pagewidth [set iwid]i -pageheight [set ihei]i"    
  822. #     return $ans
  823. # }
  824.  
  825. proc swap { a b } {
  826.     set me [uplevel 1 set $b]
  827.     uplevel 1 set $b \[set $a\]
  828.     uplevel 1 set $a [list $me]
  829. }
  830.  
  831. proc getPageOffsets { widthbyheight} {
  832.     global printOption paperSizes
  833.     #puts "wbh=$widthbyheight"
  834.     set pwid 8.5
  835.     set phei 11.0
  836.  
  837.     foreach v $paperSizes {
  838.     if { "[lindex $v 0]" == "$printOption(papersize)" } {
  839.         set pwid [lindex $v 1]
  840.         set phei [lindex $v 2]
  841.     }
  842.     }
  843.     set wid [expr {$pwid - 2* $printOption(hoffset)}]
  844.     set hei [expr {$phei - 2* $printOption(voffset)}]
  845.     if { $printOption(landscape) } {
  846.     swap wid hei
  847. #    swap pwid phei
  848.     }
  849.     if { $wid / $hei  < $widthbyheight  } {
  850.     # width dominates
  851.     set iwid $wid
  852.     set ihei [expr {$wid / $widthbyheight }]
  853.     append opts " -pagewidth [set wid]i"
  854.     } else {
  855.     set ihei $hei
  856.     set iwid [expr {$hei * $widthbyheight }]
  857.     append opts " -pageheight [set hei]i"
  858.     }
  859.  
  860.     #-pagex = left margin (whether landscape or not)
  861.     #-pagey = right margin (whether landscape or not)
  862.     #-pagewidth becomes vertical height if landscape
  863.     #-pageheight becomes horiz width if landscape
  864.     
  865.     append opts " -pagex [expr {$pwid / 2.0}]i -pagey [expr {$phei / 2.0}]i "
  866.  
  867.     if { $printOption(landscape) } {
  868.         append opts " -rotate $printOption(landscape)" 
  869.     }
  870.     return $opts
  871. }
  872.  
  873. set printOption(setupDone) 0
  874.  
  875. proc getEnv { name } {
  876.   global env
  877.  if { [catch { set tem $env($name) } ] } { return "" }
  878.  return $tem
  879. }
  880. proc setPrintOptions { lis } {
  881.     global browser_version
  882.    global printOptions printOption printSetUpDone 
  883.     if { !$printOption(setupDone) } {
  884.     set printOption(setupDone) 1
  885.     getOptions $printOptions $lis -allowOtherKeys 1 \
  886.         -setdefaults [catch { source [getEnv HOME]/.printOptions }] -usearray printOption
  887.         if { "$printOption(printer)" == "" } {set printOption(printer) [getEnv PRINTER] } else { set printOption(printer) lw8b }
  888.     
  889.     }
  890.     if { [info exists browser_version] } { set printOption(tofile) 2 }
  891. }
  892.  
  893. proc mkentryPr { w var text buttonFont }  {
  894.      set fr $w ; frame $fr
  895.     uplevel 1 append topack [list " $fr"]
  896.     label $fr.lab -text "$text" -font $buttonFont
  897.     entry $fr.e -width 20 -textvariable $var -font $buttonFont
  898.     pack $fr.lab $fr.e -side left -expand 1 -padx 3 -fill x
  899. }
  900.  
  901.  
  902. proc mkPrintDialog { name args } {
  903.     global printSet argv env printOptions printOption printSetUpDone paperSizes buttonfont
  904.  
  905.     set canv [assoc -canvas $args ]
  906.     set buttonFont [assoc -buttonfont $args $buttonfont]
  907.     catch { destroy $name }
  908.     set dismiss "destroy $name"
  909.     if { "$canv" == "" } {
  910.      catch {destroy $name}
  911.     toplevel $name
  912.     wm geometry $name -0+20
  913.    
  914.     } else {
  915.         $canv delete printoptions
  916.         set name [winfo parent $canv].printoptions
  917.     # set name $canv.fr1
  918.         catch {destroy $name}
  919.     frame $name -borderwidth 2 -relief raised
  920.     
  921.     set item [$canv create window [$canv canvasx 10] [$canv canvasy  10] -window $name -anchor nw -tags printoptions]
  922.         $canv raise printoptions
  923.     set dismiss "$canv delete $item; destroy $name "
  924.     }
  925.     
  926.     frame $name.fr
  927.  
  928.     set w $name.fr
  929.     label $w.msg  -wraplength 600 -justify left -text "Printer Setup"
  930.     pack $w
  931.     pack $w.msg
  932.     set wb $w.buttons
  933.     frame $wb 
  934.     pack $wb -side left -fill x -pady 2m
  935.     set topack ""
  936.     catch { set printOption(psfilename) \
  937.         [file nativename $printOption(psfilename)]}
  938.     button $wb.ok -text "ok" -font $buttonFont  -command "destroy $name ; $canv delete printoptions"
  939.     radiobutton $wb.b0 -text "Save via ftp" -variable printOption(tofile) -relief flat -value 2 -command {set writefile "Save"} -font $buttonFont  -highlightthickness 0 
  940.     radiobutton $wb.b1 -text "Save as Postscript File" -variable printOption(tofile) -relief flat -value 1 -command {set writefile "Save"} -font $buttonFont  -highlightthickness 0 
  941.     radiobutton $wb.b2 -text "Print To Printer" -variable printOption(tofile) -relief flat -value 0 -command {set writefile "Print"} -font $buttonFont -highlightthickness 0 
  942.     checkbutton $wb.b3 -text "Center on Page" -variable printOption(centeronpage) -relief flat -font $buttonFont -highlightthickness 0 
  943.     checkbutton $wb.b4 -text "Landscape Mode" -variable printOption(landscape) -relief flat -font $buttonFont -highlightthickness 0 
  944.  
  945.     mkentryPr  $wb.pagewidth printOption(pagewidth) "Figure width" $buttonFont
  946.     mkentryPr  $wb.pageheight printOption(pageheight) "Figure height" $buttonFont
  947.     mkentryPr  $wb.hoffset printOption(hoffset) "Left margin for printing" $buttonFont
  948.     mkentryPr  $wb.voffset printOption(voffset) "bottom margin for printing" $buttonFont
  949.     mkentryPr  $wb.psfilename printOption(psfilename) "postscript filename" $buttonFont
  950.     mkentryPr  $wb.printer printOption(printer) "Printer to print to" $buttonFont
  951.     mkentryPr  $wb.gsview printOption(gsview) "postscript viewer, used for printing under Windows" $buttonFont
  952.    mkentryPr  $wb.xticks printOption(xticks) "Rough number of xticks" $buttonFont
  953.    mkentryPr  $wb.yticks printOption(yticks) "Rough number of yticks" $buttonFont
  954.     eval pack $wb.ok $wb.b0 $wb.b1 $wb.b2 $wb.b3 $wb.b4
  955.     eval pack $topack -expand 1
  956.  
  957.     foreach v  $paperSizes {
  958.     set papersize [lindex $v 0]
  959.         set lower [string tolower $papersize]
  960.         radiobutton $wb.$lower -text [lindex $v 0] -variable printOption(papersize) \
  961.        -value [lindex $v 0] -font $buttonFont -highlightthickness 0 
  962.     pack $wb.$lower -pady 2 -anchor w -fill x
  963.     }
  964.     checkbutton $wb.domargin -variable printOption(domargin) -text "do margin" 
  965.     pack $wb.domargin -pady 2 -anchor w -fill x
  966.  
  967.     frame $w.grid
  968.     pack $w.grid -expand yes -fill both -padx 1 -pady 1
  969.     grid rowconfig    $w.grid 0 -weight 1 -minsize 0
  970.     grid columnconfig $w.grid 0 -weight 1 -minsize 0
  971. }
  972.  
  973. proc markToPrint { win tag title } {
  974.     # puts "$win $tag"
  975.    # bind $win <1> "bindBeginDrag $win %x %y $tag [list $title]"
  976.     pushBind $win <1> "$win delete printrectangle ; popBind $win <1>"
  977.     pushBind $win <1> "bindBeginDrag $win %x %y $tag [list $title]; popBind $win <1>"    
  978. }
  979.  
  980. proc bindBeginDrag { win x y tag title } {
  981.     $win delete $tag printrectangle
  982.     set beginRect "[$win canvasx $x] [$win canvasy $y]"
  983.     set it1 [eval $win create rectangle $beginRect $beginRect -tags $tag -width 3]
  984.     set old [bind $win <B1-Motion>]
  985.     set new "eval $win coords $it1 \
  986.         $beginRect \[$win canvasx %x\] \[$win canvasy %y\]; \
  987.         "
  988.     if { "$old" == "$new" } {set old ""}
  989.     bind $win <B1-Motion> $new
  990.     bind $win <ButtonRelease-1> "bind $win <B1-Motion> [list $old];\
  991.         bind $win <ButtonRelease-1> {} ; unbindAdjustWidth $win $tag [list $title];"
  992. }
  993.  
  994. proc unbindAdjustWidth { canv tag title } {
  995.     set win [winfo parent $canv]
  996.     global printOption
  997.  
  998.     set it [$canv find withtag $tag]
  999.     set co1 [$canv coords $tag]
  1000.     set co [$canv coords $it]
  1001.    # if { "$co" != "$co1" } {puts differ,$co1,$co}
  1002.     desetq "x1 y1 x2 y2" $co
  1003.     set center [expr { ($x1+$x2 )/2}]
  1004.    set h [expr {$y2 - $y1}]
  1005.     set it [$canv find withtag $tag]
  1006.    set new [$canv create rectangle $x1 $y1 $x2 $y2 -outline white -width [expr {$h* .04}] -tags [concat $tag bigger] ]
  1007.  
  1008.     # puts "<marginTicks $canv $x1 $y1 $x2 $y2 printrectangle>"
  1009.     marginTicks $canv [storx$win $x1] [story$win $y2] [storx$win $x2] [story$win $y1] "printrectangle marginticks"
  1010.     desetq "a1 b1 a2 b2" [$canv bbox $new]
  1011.    set textit [$canv create text $center [expr {$y1 - $h *.03}] \
  1012.         -font [font create -family Courier -size 14 -weight bold] -text "$title" \
  1013.         -anchor s -tags [concat $tag bigger title]]
  1014.  
  1015.     set bb [$canv bbox $textit]
  1016.    $canv create rectangle $a1 [lindex $bb 1]  $a2 [expr {$y1 - 0.02 * $h}]  -tags $tag -fill white -outline {}
  1017.    $canv itemconfig $it -width [expr {$h *.002}]
  1018.     $canv raise $it
  1019.     $canv raise $textit
  1020.     $canv raise marginticks
  1021.     if { $printOption(domargin) == 0 } {
  1022.     $canv delete marginticks
  1023.     }
  1024.  
  1025.     $canv create text [expr {($a1 + $a2)/2.0}] [expr {$y2 + .01*$h  }] -anchor nw -text "For [getEnv USER] [clock format [clock seconds]]" -font [font create -family Courier -size 10 -weight normal] -tag $tag
  1026.     # puts h=$h
  1027.  
  1028. }
  1029.     
  1030.  
  1031. proc getPSBbox  { } {
  1032.   set fi [open /home/wfs/sdfplot.ps r]
  1033.   set me [read $fi 500]
  1034.   regexp {BoundingBox: (-*[0-9]+) (-*[0-9]+) (-*[0-9]+) (-*[0-9]+)} $me junk x1 y1 x2 y2
  1035.     set w [expr {72 * 8.5}]
  1036.     set h [expr {72 * 11}]
  1037.     # puts "hei=[expr {$y2-$y1}],tm=[expr {$h - $y2}],bm=$y1"
  1038.     # puts "wid=[expr {$x2-$x1}],lm=$x1,rm=[expr {$w - $x2}]"
  1039.     # puts "hei=[expr {($y2-$y1)/72.0}],tm=[expr {($h - $y2)/72.0}],bm=([expr {$y1/72.0}])"
  1040.     #puts "wid=[expr {($x2-$x1)/72.0}],lm=([expr {$x1/72.0}]),rm=[expr {($w - $x2)/72.0}]"    
  1041.   close $fi
  1042. }
  1043.  
  1044.  
  1045. ## endsource printops.tcl
  1046. # set font {Courier 8}
  1047. set fontCourier8 "-*-Courier-Medium-R-Normal--*-120-*-*-*-*-*-*"
  1048.  
  1049. if { "[winfo screenvisual .]" == "staticgray" } { set axisGray black
  1050. }     else  { set axisGray gray60}
  1051.  
  1052. set writefile  "Save"
  1053. # make printing be by ftp'ing a file..
  1054.  
  1055. if {[catch { set doExit }] } { set doExit ""}
  1056. set width_ [winfo screenwidth .]
  1057. if { $width_ >= 1280 } { set fontSize 12
  1058.   } elseif { $width_ <= 640} { set fontSize 8 } else {
  1059.     set fontSize 10}
  1060. unset width_    
  1061.  
  1062. proc makeFrame { w type } {
  1063.     global   writefile doExit fontSize buttonfont ws_openMath   
  1064.     set win $w
  1065.     if { "$w" == "." } {
  1066.         set w "" } else {
  1067.         catch { destroy $w}
  1068.         
  1069.         frame $w
  1070.         # toplevel $w
  1071.         # set w $w.new
  1072.             # frame $w
  1073.            # puts "making $w"    
  1074.         
  1075.     }
  1076.  
  1077.     set dismiss "destroy $win"
  1078.     catch { set  parent [winfo parent $win] 
  1079.     if { "$parent" == "." } {
  1080.     set dismiss "destroy ."
  1081.     }
  1082.     if { [string match .plot* [winfo toplevel $win]] } {
  1083.     set dismiss "destroy [winfo toplevel $win]"
  1084.     }
  1085.     }
  1086.     
  1087.     if { "$doExit" != "" } {set dismiss $doExit }     
  1088.     oset $w type $type
  1089.  
  1090.     frame $w.grid
  1091.    #positionWindow $w
  1092.     set c $w.c
  1093.     oset $win c $c
  1094.     bboxToRadius $win
  1095.     
  1096.     if { [catch { set buttonfont} ] } {
  1097.     set buttonfont [font create -family Helvetica -size $fontSize]
  1098.     }
  1099.     set buttonFont $buttonfont    
  1100.     oset $win buttonFont $buttonfont
  1101.  
  1102. #    puts "children wb=[winfo children $w]"
  1103.     set wb $w.buttons
  1104.     frame $wb
  1105.     set dismiss [concat $dismiss "; clearLocal $win "]
  1106.  
  1107.     button $wb.dismiss -text Dismiss -command $dismiss -font $buttonFont
  1108.     setBalloonhelp $win $wb.dismiss {Close this plot window}
  1109.     button $wb.zoom -text "Zoom" -command "showZoom $w" -font $buttonFont
  1110.     setBalloonhelp $win $wb.zoom {Magnify the plot.  Causes clicking with the left mouse button on the plot, to magnify (zoom in) the plot where you click.  Also causes Shift+Click to  it to unmagnify (zoom out) at that point}
  1111.     oset $w position "" 
  1112. #    button $w.position -textvariable [oloc $w position] -font $buttonFont -width 10
  1113.     label $w.position  -textvariable [oloc $w position] -font $buttonFont -width 10
  1114.     setBalloonhelp $win $w.position {Position of the pointer in real x y coordinates.  For 3d it is the position of the nearest vertex of the polygon the pointer is over.}
  1115.  
  1116.     button $wb.help -text "Help" -command "doHelp$type $win" -font $buttonFont
  1117.     setBalloonhelp $win $wb.help {Give more help about this plot window}
  1118.     button $wb.postscript -textvariable writefile -command "writePostscript $w" -font $buttonFont
  1119.     setBalloonhelp $win $wb.postscript {Prints or Saves the plot in postscript format.  The region to be printed is marked using Mark.   Other print options can be obtained by using "Print Options" in the Config menu }
  1120.     
  1121.     button $wb.markrect -text "Mark" -command "markToPrint $c printrectangle \[eval \[oget $win maintitle\]\]" -font $buttonFont
  1122.     setBalloonhelp $win $wb.markrect {Mark the region to be printed.  Causes the left mouse button to allow marking of a rectangle by clicking at the upper left corner, and dragging the mouse to the lower right corner.  The title can be set under "Print Options" under Config}
  1123.     button $wb.replot -text "Replot" -command "replot$type $win" -font $buttonFont
  1124.     setBalloonhelp $win $wb.replot {Use the current settings and recompute the plot.  The settings may be altered in Config}
  1125.     
  1126.     
  1127.     
  1128.     button $wb.config -text "Config" -command "doConfig$type $win" -font $buttonFont
  1129.     setBalloonhelp $win $wb.config {Configure various options about the plot window.  After doing this one may do replot.  Hint: you may leave the config menu on the screen and certain actions take place immediately, such as rotating or computing a trajectory at a point.  To make room for the window you might slide the graph to the right, and possibly shrink it using the unzoom feature}    
  1130.     
  1131.  
  1132.  
  1133.     bind $win.position <Enter> "+place $win.buttons -in $win.position -x 0 -rely 1.0 ;  after cancel lower $win.position ; raise $win.buttons "
  1134.     bind $win.buttons <Leave> "deleteBalloon $c ; place forget $win.buttons"
  1135.  
  1136.     # pack $wb
  1137.     scrollbar $w.hscroll -orient horiz -command "$c xview"
  1138.     scrollbar $w.vscroll -command "$c yview"
  1139.     # -relief sunken
  1140.     canvas $c  -borderwidth 2 \
  1141.         -scrollregion {-1200 -1200 1200 1200} \
  1142.     -xscrollcommand "$w.hscroll set" \
  1143.     -yscrollcommand "$w.vscroll set" -cursor arrow -background white
  1144.     # puts "$c config  -height [oget $win height] -width [oget $win width] "
  1145.     set buttonsLeft 1
  1146.     set wid [oget $win width]
  1147.     catch {$c config  -height [oget $win height] -width  $wid
  1148.            oset $win oldCheight [oget $win height]
  1149.            oset $win oldCwidth $wid
  1150.      }
  1151.     # puts "$c height =[$c cget   -height],$c width =[$c cget   -width]"
  1152.     # bind $c <2> "$c scan mark %x %y"
  1153.     bind $c <B3-Motion> "$c scan dragto %x %y"
  1154.     bind $c <3> "$c scan mark %x %y"
  1155.     bind $c <B3-Motion> "$c scan dragto %x %y"    
  1156.     bind $c <Motion> "showPosition $w %x %y"
  1157.     bind $c <Configure> "reConfigure $c %w %h"
  1158.     bind $c <Enter> "raise $win.position"
  1159.     bind $c <Leave> "after 200 lower $win.position"
  1160.     $w.position config -background [$c cget -background]
  1161.      
  1162.      
  1163.     pack  $wb.dismiss $wb.help $wb.zoom   \
  1164.         $wb.postscript $wb.markrect $wb.replot $wb.config -side top -expand 1 -fill x
  1165.     if { 0 } {
  1166.     pack $w.hscroll -side bottom -expand 1 -fill x
  1167.     pack $w.vscroll -side right -expand 1 -fill y
  1168.     }
  1169.     pack $w.c -side right -expand 1 -fill both
  1170.     
  1171.     pack $w
  1172.     place $w.position -in $w -x 2 -y 2 -anchor nw
  1173.     oset $w position "Menu Here"
  1174.     if { ![info exists ws_openMath(showedplothelp)] ||
  1175.     [llength $ws_openMath(showedplothelp)] < 2 } {
  1176.     lappend ws_openMath(showedplothelp) 1
  1177.     
  1178.     after 100 balloonhelp $w $w.position [list \
  1179.         "Initial help: Moving the mouse over the position \
  1180.         window (top left corner), will bring up a menu.  Holding down \
  1181.         right mouse button and dragging will translate the plot"]
  1182.     after 2000 $w.c delete balloon
  1183.     
  1184.  
  1185.     }
  1186.     
  1187.     raise $w.position
  1188.     
  1189.     pack [winfo parent $wb]
  1190.    # update
  1191. #    set wid [ winfo width $win]
  1192. #    if { $wid > [      $c cget -width ] } {
  1193. #    $c config -width $wid
  1194. #        oset $win width $wid
  1195. #    }
  1196.  
  1197.    addSliders $w 
  1198.  
  1199.    bind $w <Configure> "resizePlotWindow $w %w %h"
  1200.     return $w    
  1201. }
  1202.  
  1203. proc mkentry { newframe textvar text buttonFont } {
  1204.     frame $newframe
  1205.     set parent $newframe
  1206.     set found 0
  1207.     while { !$found } {
  1208.     set parent [winfo parent $parent]
  1209.     if { "$parent" == "" } { break }
  1210.     if { ![catch {  set type [oget $parent type] } ] } {
  1211.         global plot[set type]Options
  1212.         foreach v [set plot[set type]Options] {
  1213.         if { "[oloc $parent [lindex $v 0]]" == "$textvar" } {
  1214.              setBalloonhelp $parent $newframe [lindex $v 2]
  1215.             set found 1
  1216.              break
  1217.  
  1218.         }
  1219.         }
  1220.     }
  1221.     }
  1222.     label $newframe.lab1 
  1223.     label $newframe.lab -text "$text:" -font $buttonFont -width 0
  1224.     entry $newframe.e -width 20 -textvariable $textvar -font $buttonFont
  1225.     pack $newframe.lab1 -side left -expand 1 -fill x 
  1226.     pack $newframe.lab -side left
  1227.     pack $newframe.e -side right -padx 3 -fill x
  1228.    # pack $newframe.lab $newframe.e -side left -padx 3 -expand 1 -fill x
  1229. }
  1230.     
  1231.  
  1232. proc doHelp { win msg } {
  1233.     makeLocal $win c
  1234.     set atx [$c canvasx 0]
  1235.     set aty [$c canvasy 0]
  1236.     $c create rectangle [expr {$atx -1000}] [expr  {$aty -1000}] 10000 10000 -fill white -tag help
  1237.  
  1238.     $c create text [expr {$atx +10}] [expr {$aty + 10.0}] -tag help  -anchor nw  -width 400 -text $msg 
  1239.  
  1240.     pushBind $c <1> "$c delete help; popBind $c <1>"
  1241. }
  1242.  
  1243. ## source push.tcl
  1244.  
  1245. ###### push.tcl ######
  1246. ############################################################
  1247. # Netmath       Copyright (C) 1998 William F. Schelter     #
  1248. # For distribution under GNU public License.  See COPYING. # 
  1249. ############################################################
  1250.  
  1251.  
  1252.  
  1253. #
  1254.  #-----------------------------------------------------------------
  1255.  #
  1256.  # pushl --  push VALUE onto a stack stored under KEY
  1257.  #
  1258.  #  Results:
  1259.  #
  1260.  #  Side Effects: 
  1261.  #
  1262.  #----------------------------------------------------------------
  1263. #
  1264.  
  1265. global __pushl_ar
  1266. proc pushl { val key  } {
  1267.     global __pushl_ar
  1268.   append __pushl_ar($key) " [list $val]"
  1269. }
  1270.  
  1271.  
  1272. #
  1273.  #-----------------------------------------------------------------
  1274.  #
  1275.  # peekl --  if a value has been pushl'd under KEY return the 
  1276.  # last value otherwise return DEFAULT.   If M is supplied, get the
  1277.  # M'th one pushed... M == 1 is the last one pushed.
  1278.  #  Results:  a previously pushed value or DEFAULT
  1279.  #
  1280.  #  Side Effects: none
  1281.  #
  1282.  #----------------------------------------------------------------
  1283. #
  1284. proc peekl {key default {m 1}} {
  1285.     global __pushl_ar
  1286.     if { [catch { set val [set __pushl_ar($key) ] } ] } {
  1287.     return $default } else {
  1288.         set n [llength $val]
  1289.         if { $m > 0 && $m <= $n } {
  1290.         return [lindex $val [incr n -$m]]
  1291.         } else { return $default }
  1292.     }
  1293.     }
  1294.     
  1295.     
  1296.  
  1297. #
  1298.  #-----------------------------------------------------------------
  1299.  #
  1300.  # popl --  pop off  last value stored under KEY, or else return DFLT
  1301.  #
  1302.  #  Results: last VALUE stored or DEFAULT
  1303.  #
  1304.  #  Side Effects: List stored under KEY becomes one shorter
  1305.  #
  1306.  #----------------------------------------------------------------
  1307. #
  1308. proc popl { key  dflt} {
  1309.     global __pushl_ar
  1310.     
  1311.     if { [catch { set val [set __pushl_ar($key) ] } ] } {
  1312.     return $dflt } else {
  1313.         set n [llength $val]
  1314.            set result [lindex $val [incr n -1]]
  1315.  
  1316.         if { $n > 0 } {
  1317.         set __pushl_ar($key) [lrange $val 0 [expr {$n -1}]]
  1318.         } else {unset __pushl_ar($key) }
  1319.         return $result
  1320.     }
  1321.     }
  1322.  
  1323.  
  1324. #
  1325.  #-----------------------------------------------------------------
  1326.  #
  1327.  # clearl --  clear the list stored under KEY
  1328.  # 
  1329.  #  Result: none
  1330.  #
  1331.  #  Side Effects:  clear the list stored under KEY
  1332.  #
  1333.  #----------------------------------------------------------------
  1334. #
  1335. proc clearl { key } {
  1336.     global __pushl_ar
  1337.     catch { unset __pushl_ar($key) }
  1338. }
  1339.     
  1340.  
  1341.  
  1342. ## endsource push.tcl
  1343. proc pushBind { win key action } {
  1344.     pushl [bind $win $key] [list $win $key ] 
  1345.     bind $win $key $action
  1346. }
  1347.  
  1348. proc popBind { win key  } {
  1349.     set binding [popl [list $win $key] {}]
  1350.    
  1351.     bind $win $key $binding
  1352. }
  1353.  
  1354. # exit if not part of openmath browser
  1355. proc maybeExit { n } {
  1356.     if { "[info proc OpenMathOpenUrl]" != "" } {
  1357.     uplevel 1 return
  1358.     } else { exit 0 }
  1359. }
  1360.  
  1361. proc showPosition { win x y } {
  1362.    # global position c
  1363.     makeLocal $win c
  1364.     # we catch so that in case have no functions or data..
  1365.     catch {
  1366.     oset $win position \
  1367.       "[format {(%.2f,%.2f)}  [storx$win [$c canvasx $x]] [story$win [$c canvasy $y]]]"
  1368. }   }
  1369.  
  1370. proc showZoom  { win } {
  1371.   #  global c position
  1372.     makeLocal $win c
  1373.     oset $win position "Click to Zoom\nShift+Click Unzoom"
  1374.      
  1375.     bind $c <1> "doZoom $win %x %y 1"
  1376.     bind $c  <Shift-1> "doZoom $win %x %y -1"
  1377. }
  1378.  
  1379. proc doZoom { win x y direction } {
  1380.     set zf [oget $win zoomfactor]
  1381.     if { $direction < 0 } {
  1382.     set zf     "[expr {1/[lindex $zf 0]}] [expr {1/[lindex $zf 1]}]"
  1383.     }
  1384.     eval doZoomXY $win $x $y $zf
  1385. }
  1386.     
  1387.  
  1388.  
  1389. #
  1390.  #-----------------------------------------------------------------
  1391.  #
  1392.  # doZoomXY --  given screen coordinates (x,y) and factors (f1,f2)
  1393.  #  perform a scaling on the canvas, centered at (x,y) so that
  1394.  #  the distance in the x direction from this origin is multiplied by f1
  1395.  #  and similarly in the y direction
  1396.  #  Results:
  1397.  #
  1398.  #  Side Effects: scale the canvas, and set new transforms for translation
  1399.  #   from real to canvas coordinates.
  1400.  #----------------------------------------------------------------
  1401. #
  1402.  
  1403. proc doZoomXY { win x y facx facy } {
  1404.     if { [catch {
  1405.     makeLocal $win c transform
  1406.     } ] } {
  1407.     # not ready
  1408.     return
  1409.     }
  1410.     
  1411.     set x [$c canvasx $x]
  1412.     set y [$c canvasy $y]
  1413.  
  1414.     $c scale all $x $y $facx $facy
  1415.  
  1416.     set ntransform [composeTransform \
  1417.         "$facx 0 0 $facy [expr {(1-$facx)* $x}] [expr {(1-$facy)* $y}]" \
  1418.         $transform  ]
  1419.     oset $win transform $ntransform
  1420.     getXtransYtrans $ntransform rtosx$win rtosy$win
  1421.     getXtransYtrans [inverseTransform $ntransform] storx$win story$win
  1422.     axisTicks $win $c
  1423. }
  1424.  
  1425.  
  1426. #
  1427.  #-----------------------------------------------------------------
  1428.  #
  1429.  # scrollPointTo --  attempt to scroll the canvas so that point
  1430.  #  x,y on the canvas appears at screen (sx,sy)
  1431.  #
  1432.  #  Results: none
  1433.  #
  1434.  #  Side Effects: changes x and y view of canvas 
  1435.  #
  1436.  #----------------------------------------------------------------
  1437. #
  1438. proc scrollPointTo { c x y sx sy } {
  1439.     desetq "x0 y0 x1 y1" [$c cget -scrollregion]
  1440.     $c xview moveto [expr { 1.0*($x-$x0-$sx)/($x1-$x0)} ]
  1441.     $c yview moveto [expr { 1.0*($y-$y0-$sy)/($y1-$y0)} ]
  1442. }
  1443.  
  1444.  
  1445.  
  1446. #
  1447.  #-----------------------------------------------------------------
  1448.  #
  1449.  # reConfigure --  
  1450.  #
  1451.  #  Results:
  1452.  #
  1453.  #  Side Effects: 
  1454.  #
  1455.  #----------------------------------------------------------------
  1456. #
  1457.  
  1458. proc reConfigure { c width height  } {
  1459.     set w [winfo parent $c]
  1460.     if { [catch { makeLocal $w oldCwidth oldCheight } ] } {
  1461.     oset $w oldCwidth $width
  1462.     oset $w oldCheight $height
  1463.     return
  1464.     }
  1465.     set oldx [$c canvasx [expr {$oldCwidth/2.0}]]
  1466.     set oldy [$c canvasy [expr {$oldCheight/2.0}]]
  1467.     doZoomXY $w [expr {$oldCwidth/2.0}] [expr {$oldCheight/2.0}] \
  1468.         [expr {1.0*$width/$oldCwidth}] [expr {1.0*$height/$oldCheight}]
  1469.     
  1470.     scrollPointTo $c $oldx $oldy [expr {$width/2.0}] [expr {$height/2.0}]
  1471.    # update
  1472.     oset $w oldCwidth $width
  1473.     oset $w oldCheight $height
  1474. }
  1475.  
  1476. proc writePostscript { win } {
  1477.     global  printOption argv
  1478.     makeLocal $win c transform transform0 xmin ymin xmax ymax
  1479.     set rtosx rtosx$win ; set rtosy rtosy$win
  1480.     drawPointsForPrint $c
  1481.     if { "[$c find withtag printrectangle]" == "" } {
  1482.     # $c create rectangle [$rtosx $xmin] [$rtosy $ymin] [$rtosx $xmax] [$rtosy $ymax] -tags printrectangle -width .5
  1483.     $c create rectangle [$c canvasx 0] [$c canvasy 0] [$c canvasx [$c cget -width ]] [$c canvasy [$c cget -height ]]   -tags printrectangle -width .5    
  1484.     unbindAdjustWidth $c printrectangle [eval [oget $win maintitle]]
  1485.     }
  1486.     $c delete balloon
  1487.     
  1488.     
  1489.     set bbox [eval $c bbox [$c find withtag printrectangle]]
  1490.     desetq "x1 y1 x2 y2" $bbox
  1491. #     set title "unknown plot"
  1492. #     catch { set title [eval $printOption(maintitle)] }
  1493.  
  1494. #     $c create text [expr {($x1 + $x2)/2}]  [expr {$y1 + .04 * ($y2 - $y1)}] \
  1495. #         -anchor center -text $title -tag title
  1496.  
  1497.     update
  1498. set diag [vectorlength [expr {$y1-$x1}] [expr {$y2-$x2}]]
  1499. #  get rid of little arrows that creep onto the outside, ie let
  1500. #  the blank rectangle cover them.
  1501. set x1 [expr {$x1+.01 * $diag}]
  1502. set x2 [expr {$x2-.01 * $diag}]
  1503. set y1 [expr {$y1+.01 * $diag}]
  1504. set y2 [expr {$y2-.01 * $diag}]
  1505.  
  1506.     set com "$c postscript  \
  1507.               -x  $x1  -y $y1 \
  1508.         -width [expr {($x2 - $x1)}] \
  1509.             -height [expr {($y2 - $y1)}] \
  1510.         [getPageOffsets [expr {($x2 - $x1)/(1.0*($y2 - $y1))}] ] "
  1511.  
  1512.     #puts com=$com
  1513.     set output [eval $com]
  1514.     switch $printOption(tofile) {
  1515.     0 { global tcl_platform
  1516.         set usegsview 0  
  1517.         if { "$tcl_platform(platform)" == "windows" } {
  1518.         set usegsview 1
  1519.         }
  1520.         if { $usegsview } {
  1521.         set fi [open $printOption(psfilename) w]
  1522.         puts $fi $output
  1523.         close $fi
  1524.         exec "$printOption(gsview) /S $printOption(psfilename)"
  1525.         } else {
  1526.         set fi [open "|lpr -P[set printOption(printer)]" w]
  1527.         puts $fi $output
  1528.         close $fi
  1529.         }
  1530.     }
  1531.     1 { set fi [open $printOption(psfilename) w]
  1532.     puts $fi $output
  1533.     close $fi }
  1534.     2 { global ftpInfo
  1535.         set ftpInfo(data) $output
  1536.         ftpDialog $win
  1537.     }
  1538.     }
  1539. #    if { $printOption(tofile) } {
  1540. #    set fi [open $printOption(psfilename) w]
  1541. #    } else { set fi [open "|lpr -P[set printOption(printer)]" w] }
  1542.  #   puts $fi $output
  1543. #    close $fi
  1544. }
  1545.  
  1546.  
  1547. #
  1548.  #-----------------------------------------------------------------
  1549.  #
  1550.  # ftpDialog --  open up a dialog to send ftpInfo(data) to a file
  1551.  # via http and ftp.   The http server can be specified.
  1552.  #
  1553.  #  Results:
  1554.  #
  1555.  #  Side Effects: 
  1556.  #
  1557.  #----------------------------------------------------------------
  1558. #
  1559.  
  1560. set ftpInfo(host) genie1.ma.utexas.edu
  1561. set ftpInfo(viahost) genie1.ma.utexas.edu
  1562.  
  1563. proc ftpDialog { win args } {
  1564.     global ftpInfo buttonFont fontSize
  1565.     set fr ${win}plot
  1566.     set usefilename [assoc -filename $args  0]
  1567.     if { "$usefilename" != "0"} {
  1568.     set ftpInfo(filename) $usefilename
  1569.     set usefilename 1
  1570.     }
  1571.     catch { destroy $fr }
  1572.     set ftpInfo(percent) 0
  1573.     set buttonFont [font create -family Courier -size $fontSize]
  1574.     frame $fr -borderwidth 2 -relief raised
  1575.     if { [catch { set ftpInfo(directory) } ] } { set ftpInfo(directory) homework }
  1576.     label $fr.title -text "Ftp Dialog Box" -font [font create -family Helvetica -size [expr {2+ $fontSize}]]
  1577.     mkentry $fr.host ftpInfo(host) "host to write file on" $buttonFont
  1578.     mkentry $fr.viahost ftpInfo(viahost) "host to write to via" $buttonFont
  1579.     mkentry $fr.username ftpInfo(username) "Your User ID on host" $buttonFont
  1580.     mkentry $fr.password ftpInfo(password) "Your password on host" $buttonFont
  1581.     $fr.password.e config -show *
  1582.     mkentry $fr.directory ftpInfo(directory) "remote subdirectory for output" $buttonFont
  1583.  
  1584.     if { $usefilename } {
  1585.     mkentry $fr.filename ftpInfo(filename) "filename " $buttonFont
  1586.     } else {
  1587.     mkentry $fr.chapter ftpInfo(chapter) "chapter " $buttonFont
  1588.     mkentry $fr.section ftpInfo(section) "section" $buttonFont
  1589.     mkentry $fr.problemnumber ftpInfo(number) "Problem number" $buttonFont
  1590.     }
  1591.     scale   $fr.scale -orient horizontal -variable ftpInfo(percent) -length 100 
  1592.     button $fr.doit -text "Send it" -command "doFtpSend $fr" -font $buttonFont
  1593.     button $fr.cancel -text "Cancel" -command "destroy $fr" -font $buttonFont
  1594.     set ftpInfo(message) ""
  1595.     label $fr.message  -width 30 -height 3 -textvariable ftpInfo(message) -font $buttonFont
  1596.     eval pack  [winfo  children $fr] -side top 
  1597.     raise $fr
  1598.     place $fr -in $win -relx .5 -rely .5 -anchor center
  1599.    }
  1600.  
  1601. proc doFtpSend { fr } {
  1602.     global ftpInfo om_ftp
  1603.     set error ""
  1604.     if { [winfo exists $fr.filename] } {
  1605.     set filename $ftpInfo(filename)
  1606.     set check "host username directory filename"
  1607.     } else {
  1608.     set check "host username directory chapter section number"
  1609.     }
  1610.     foreach v $check {
  1611.     if { $ftpInfo($v) == "" } {
  1612.         if  { "$error" == "" } { set error "Failed to specify $v " } else {
  1613.         append error ", $v"}
  1614.     }   
  1615.     }
  1616.     if { "$error" != "" } {
  1617.     set ftpInfo(message) $error
  1618.     return -1
  1619.     }
  1620.     if { [winfo exists $fr.chapter] } {
  1621.     set filename "$ftpInfo(chapter).$ftpInfo(section)-$ftpInfo(number).ps"
  1622.     }
  1623.     
  1624.     
  1625.     set res [submitFtp $ftpInfo(viahost) $ftpInfo(host) $ftpInfo(username) $ftpInfo(password) $ftpInfo(directory) $filename]
  1626.     if { "$res" == 1 }  {
  1627.        after 1000 "destroy $fr"
  1628.     }
  1629.     return $res
  1630.     
  1631. #    set counter [ ftp $ftpInfo(host) $ftpInfo(username) $ftpInfo(password)]
  1632. #    if { $counter < 0 } {
  1633. #    set ftpInfo(message) [concat "Failed:" $om_ftp($counter,log)]
  1634. #    return -1
  1635. #    }
  1636.  
  1637. #     if { [ftpDoCd $counter $ftpInfo(directory)] < 0 &&
  1638. #          [ftpDoMkdir $counter $ftpInfo(directory)] > -10 &&
  1639. #        [ftpDoCd $counter $ftpInfo(directory)] < 0 } {
  1640. #     set ftpInfo(message) [concat "Failed:" $om_ftp($counter,log)]
  1641. #     return -1
  1642. #     }
  1643.  
  1644.     
  1645. #     set res [ftpDoStore $counter $ftpInfo(chapter).$ftpInfo(section)-$ftpInfo(number).ps $ftpInfo(data)]
  1646. #     if { $res < 0 } {
  1647. #     set ftpInfo(message) "Failed: $om_ftp($counter,log)"
  1648. #     return -1
  1649. #     } else {
  1650. #     set ftpInfo(message) "Wrote $ftpInfo(directory)/$ftpInfo(chapter).$ftpInfo(section)-$ftpInfo(number).ps"
  1651. #     after 1000 destroy $fr
  1652. #     }
  1653. #     ftpClose $counter
  1654. }
  1655.  
  1656. proc vectorlength { a b } {
  1657.     return [expr {sqrt($a*$a + $b * $b)} ]
  1658. }
  1659.  
  1660. proc setupCanvas { win } {
  1661.   makeLocal $win   xcenter xradius ycenter yradius
  1662.  
  1663.   oset $win xmin [expr {$xcenter - $xradius}]
  1664.   oset $win xmax [expr { $xcenter + $xradius}]
  1665.   oset $win ymin [expr { $ycenter - $yradius}]
  1666.   oset $win ymax [expr { $ycenter + $yradius} ]
  1667.  
  1668. }
  1669.  
  1670.  
  1671. #
  1672.  #-----------------------------------------------------------------
  1673.  #
  1674.  # compose --  A and B are transformations of the form "origin scalefac"
  1675.  # and composing them means applying first b then a, as in a.b.x
  1676.  #  "o s" . x ==> (x-o)*s + o
  1677.  #  Results: the "origin scalefac" which corresponds to the composition.
  1678.  #
  1679.  #  Side Effects: 
  1680.  #
  1681.  #----------------------------------------------------------------
  1682. #
  1683. proc compose { a b } {
  1684.   return  "[expr {-[lindex $a 1]*[lindex $b 0]*[lindex $b 1] \
  1685.       +[lindex $a 1]*[lindex $b 0]-[lindex $a 0]*[lindex $a 1] \
  1686.       +[lindex $a 0]}] [expr {[lindex $a 1]*[lindex $b 1]}]"
  1687. }
  1688.  
  1689. # the following two have been replaced 
  1690. # proc sparseList { s } {
  1691. #     if  { [catch {
  1692. #     set val [parseConvert "$s" -variables "x y t"] } err ] } {
  1693. #         error "Syntax error with `$s'\n $err"
  1694. #     }
  1695. #     return [lindex $val 0]
  1696. #     }
  1697. # 
  1698. # proc sparse { s } {
  1699. #     set val [sparseList $s]
  1700. #     set first $val
  1701. #     if { [llength $first] != 1 } {
  1702. #     error "only one function wanted" }
  1703. #     
  1704. #     return [lindex $first 0]
  1705. #    }
  1706.  
  1707. proc sparseListWithParams { form variables paramlist } {
  1708.     set tem [parseConvert $form -doall 1]
  1709.     #puts tem=$tem
  1710.     set params [splitParams $paramlist]
  1711.     if { [catch {set res [substParams [lindex $tem 0] $variables $params] }\
  1712.         err ] } {
  1713.     set vars [lindex $tem 1]
  1714.     set all $variables
  1715.     foreach { v val }  $params { lappend all $v}
  1716.     foreach v $vars { if { [lsearch $all [string range $v 1 end]] < 0 } {
  1717.         error "The variable `[string range $v 1 end]' appeared in $form but was not in allowed variables:{$variables} or in parameters: {$paramlist}"
  1718.     }
  1719.     }
  1720.     error "The form $form may involve variables other than {$variables} or the parameters {$paramlist}, or the latter may have invalid expressions:\n $err"
  1721.     }
  1722.     return $res
  1723. }
  1724.  
  1725. proc sparseWithParams { form variables params } {
  1726.     set tem [sparseListWithParams $form $variables $params]
  1727.     if { [llength $tem ] > 1 } { error "only wanted one function: $form"}
  1728.     lindex $tem 0
  1729. }
  1730.  
  1731.  
  1732.  
  1733. #
  1734.  #-----------------------------------------------------------------
  1735.  #
  1736.  # myVarSubst --  into FORM substitute where
  1737.  # listVarsVals where each element of this list may mention
  1738.  # the previous values eg "k 7 ll sin(k+8)"
  1739.  # eg:
  1740.  #myVarSubst [lindex [parseConvert "k*x+l" -doall 1] 0] {x $x k 27+4 l 93+k^3}
  1741.  # ==> {((31 * $x) + 29884.0)}  
  1742.  #
  1743.  #  Results: FORM with the substitutions done
  1744.  #
  1745.  #  Side Effects: 
  1746.  #
  1747.  #----------------------------------------------------------------
  1748. #
  1749. proc myVarSubst { form listVarsVals } {
  1750.     foreach {_u _v} $listVarsVals {
  1751.     if { "\$$_u" == "$_v" } {
  1752.         set $_u $_v
  1753.     } else {
  1754.         set _f1 [lindex [parseConvert  $_v -doall 1] 0]
  1755.         set $_u [expr [lindex $_f1 0]]
  1756.         # puts "$_u = [set $_u]"
  1757.     }
  1758.    }
  1759.    subst -nobackslashes -nocommands $form
  1760.  
  1761. }
  1762.  
  1763. proc splitParams { paramlist } {
  1764.     set params ""
  1765.     foreach v [split $paramlist ,] {
  1766.     set tem [split $v =]
  1767.     if { [llength $tem] == 2 } {
  1768.         lappend params [lindex $tem 0] [lindex $tem 1]
  1769.     }
  1770.     }
  1771.     return $params
  1772. }
  1773.  
  1774.     
  1775.  
  1776. #
  1777.  #-----------------------------------------------------------------
  1778.  #
  1779.  # substParams --  substitute into FORM keeping VARIABLES as they are
  1780.  # and the PARAMLIST (of the form k=23, l=k+7,...) into FORM
  1781.  #
  1782.  #  Results: substituted FORM
  1783.  #
  1784.  #  Side Effects: none
  1785.  #
  1786.  #----------------------------------------------------------------
  1787. #
  1788. proc substParams { form variables params } {
  1789.    foreach v $variables { lappend params $v \$$v}
  1790.    set res [myVarSubst $form $params]
  1791.     return $res
  1792. }
  1793.     
  1794.     
  1795.     
  1796.  
  1797.  
  1798. #
  1799.  #-----------------------------------------------------------------
  1800.  #
  1801.  # setUpTransforms --  set up transformations for the canvas of WINDOW
  1802.  # so that the image is on FACTOR fractionof the window
  1803.  # these transforms are used for real to screen and vice versa.
  1804.  #  Results: 
  1805.  #
  1806.  #  Side Effects: transform functions rtosx$win rtosy$win storx$win story$win
  1807.  #  are defined.
  1808.  #
  1809.  #----------------------------------------------------------------
  1810. #    
  1811. proc setUpTransforms { win fac } {
  1812.     makeLocal $win xcenter ycenter xradius yradius c
  1813.  
  1814.     set delx [$c cget -width]
  1815.     set dely [$c cget -height]
  1816.     set f1 [expr {(1 - $fac)/2.0}]
  1817.     
  1818.     set x1 [expr {$f1 *$delx}]
  1819.     set y1 [expr {$f1 *$dely}]
  1820.     set x2 [expr {$x1 + $fac*$delx}]
  1821.     set y2 [expr {$x1 + $fac*$dely}]
  1822.  
  1823.     
  1824.     
  1825.     set xmin [expr {$xcenter - $xradius}]
  1826.     set xmax [expr {$xcenter + $xradius}]
  1827.     set ymin [expr {$ycenter - $yradius}]
  1828.     set ymax [expr {$ycenter + $yradius}]
  1829.     
  1830.     oset $win xmin $xmin
  1831.     oset $win xmax $xmax
  1832.     oset  $win ymin $ymin
  1833.     oset $win ymax $ymax
  1834.     
  1835.     oset $win transform [makeTransform "$xmin $ymin $x1 $y2" "$xmin $ymax $x1 $y1 " "$xmax $ymin $x2 $y2"]
  1836.     set transform [makeTransform "$xmin $ymin $x1 $y2" "$xmin $ymax $x1 $y1 " "$xmax $ymin $x2 $y2"]
  1837.     oset $win transform $transform
  1838.     oset $win transform0 $transform
  1839.     
  1840.     getXtransYtrans $transform rtosx$win rtosy$win
  1841.     getXtransYtrans [inverseTransform $transform] storx$win story$win 
  1842.     
  1843. }
  1844.  
  1845. proc inputParse { in } {
  1846.   if { [regexp -indices \
  1847.        {D\[([a-zA-Z][0-9a-zA-Z]*[ ]*),([a-zA-Z][0-9a-zA-Z]*[ ]*)\] *=} \
  1848.       $in all1 i1 i2] } {
  1849.    set v1 [getOneMatch $in $i1]
  1850.    set v2 [getOneMatch $in $i2]
  1851.    set s1 [string range $in [lindex $all1 1] end]
  1852.  
  1853.      if { [regexp -indices {,[ \n]*D\[([a-zA-Z][0-9a-zA-Z]*[ ]*),([a-zA-Z][0-9a-zA-Z]*[ ]*)\] *=} \
  1854.       $s1 all2 i1 i2] } {
  1855.    set v3  [getOneMatch $s1 $i1]
  1856.    set v4 [getOneMatch $s1 $i2]
  1857.    set end [string first \} $s1 ]
  1858.       set form2 [string range $s1 [expr {1 + [lindex $all2 1]}] [expr {$end -1}]]
  1859.     if { "$v4" != "$v2" } {error "different variable $v2 and $v4"}
  1860.  
  1861.     set form1 [string range $in [expr {1 + [lindex $all1 1]}] [expr {[lindex $all2 0] + -1 + [lindex $all1 1]}]]
  1862.     return [list  $v2 $v1 $v3 $form1 $form2]
  1863.     # puts "v1=$v1,form1=$form1,form2=$form2"  
  1864.   } 
  1865.  }
  1866. }
  1867.  
  1868. proc composeTransform { t1 t2  } {
  1869.     desetq "a11 a12 a21 a22 e1 e2" $t1
  1870.     desetq "b11 b12 b21 b22 f1 f2" $t2
  1871.    return  [list \
  1872.        [expr {$a11*$b11+$a12*$b21}] \
  1873.        [expr {$a11*$b12+$a12*$b22}] \
  1874.        [expr {$a21*$b11+$a22*$b21}] \
  1875.        [expr {$a22*$b22+$a21*$b12}] \
  1876.        [expr {$a11*$f1+$a12*$f2+$e1}] \
  1877.        [expr {$a21*$f1+$a22*$f2+$e2}] ]
  1878. }
  1879.     
  1880.  
  1881.  
  1882. #
  1883.  #-----------------------------------------------------------------
  1884.  #
  1885.  # makeTransform --  Given three points mapped to three other points
  1886.  # write down the affine transformation (A.X+B) which performs this.
  1887.  # the arguments are of the form "x1 y1 u1 v1" "x2 y2 u2 v2" "x3 y3 u3 v3"
  1888.  # where (x1,y1) --> (u1,v1)  etc.
  1889.  #  Results: an affine transformation "a b c d e f" which is
  1890.  #     [ a  b ]  [ x1 ] + [ e ]     
  1891.  #     [ c  d ]  [ y1 ]   [ f ]
  1892.  #  Side Effects: none
  1893.  #
  1894.  #----------------------------------------------------------------
  1895. #
  1896. proc makeTransform { P1 P2 P3 } {
  1897.     desetq  "X1 Y1 U1 V1" $P1
  1898.     desetq  "X2 Y2 U2 V2" $P2
  1899.     desetq  "X3 Y3 U3 V3" $P3
  1900.     set tem [expr {double((($X2-$X1)*$Y3+($X1-$X3)*$Y2+($X3-$X2)*$Y1))}]
  1901.     set A [expr {(($U2-$U1)*$Y3+($U1-$U3)*$Y2+($U3-$U2)*$Y1) \
  1902.         /$tem}]
  1903.     set B [expr {-(($U2-$U1)*$X3+($U1-$U3)*$X2+($U3-$U2)*$X1) \
  1904.         /$tem}]
  1905.     set E [expr {(($U1*$X2-$U2*$X1)*$Y3+($U3*$X1-$U1*$X3)*$Y2+($U2*$X3-$U3*$X2)*$Y1) \
  1906.         /$tem}]
  1907.     set C [expr {(($V2-$V1)*$Y3+($V1-$V3)*$Y2+($V3-$V2)*$Y1) \
  1908.         /$tem}]
  1909.     set D [expr {-(($V2-$V1)*$X3+($V1-$V3)*$X2+($V3-$V2)*$X1) \
  1910.         /$tem}]
  1911.     set F [expr {(($V1*$X2-$V2*$X1)*$Y3+($V3*$X1-$V1*$X3)*$Y2+($V2*$X3-$V3*$X2)*$Y1) \
  1912.         /$tem}]
  1913.     set xf ""
  1914.     set yf ""
  1915.     if { $B == 0  && $C == 0 } {
  1916.     set xf "$A*\$X+$E"
  1917.     set yf "$D*\$Y+$F"
  1918.     }
  1919.     return [list $A $B $C $D $E $F]
  1920. }
  1921.  
  1922.  
  1923. #
  1924.  #-----------------------------------------------------------------
  1925.  #
  1926.  # getXtransYtrans --   If the x coordinate transforms independently
  1927.  #  of the y and vice versa, give expressions suitable for building a
  1928.  # proc. 
  1929.  #  Results:
  1930.  #
  1931.  #  Side Effects: 
  1932.  #
  1933.  #----------------------------------------------------------------
  1934. #
  1935. proc getXtransYtrans { transform p1 p2 } {
  1936.     desetq "a b c d e f"  $transform
  1937.     if { $b == 0  && $c == 0 } {
  1938.     proc $p1 { x } "return \[expr {$a*\$x+$e}\]" 
  1939.     proc $p2 { y } "return \[expr {$d*\$y+$f} \]"
  1940.     return 1
  1941.     }
  1942.     return 0
  1943. }
  1944.  
  1945.  
  1946. #
  1947.  #-----------------------------------------------------------------
  1948.  #
  1949.  # inverseTransform --   Find the inverse of an affine transformation.
  1950.  #
  1951.  #  Results:
  1952.  #
  1953.  #  Side Effects: 
  1954.  #
  1955.  #----------------------------------------------------------------
  1956. #
  1957. proc inverseTransform { transform } {
  1958.     desetq "a b c d e f" $transform
  1959.     set det [expr {double($a*$d - $b*$c)}]
  1960.     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}]]
  1961.  
  1962. }
  1963.  
  1964.  
  1965. #
  1966.  #-----------------------------------------------------------------
  1967.  #
  1968.  # getTicks --  given an interval (a,b) subdivide it and 
  1969.  # calculate where to put the ticks and what to print there.
  1970.  # we want DESIRED number of ticks, but we also want the ticks
  1971.  # to be at points in the real coords of the form .2*10^i or .5*10^j
  1972.  #  Results: the ticks
  1973.  #
  1974.  #  Side Effects: 
  1975.  #
  1976.  #----------------------------------------------------------------
  1977. #
  1978.  
  1979. proc getTicks { a b n } {
  1980.     set len [expr {(($b - $a))}]
  1981.     if { $len < [expr {pow(10,-40)}] } { return ""}
  1982.     set best 0
  1983.     foreach v { .1 .2 .5 } {
  1984.     # want $len/(.1*10^i) == $n
  1985.     set val($v)  [expr {ceil(log10($len/(double($n)*$v)))}]
  1986.     set use [expr {$v*pow(10,$val($v))}]
  1987.     set fac [expr {1/$use}]
  1988.     set aa [expr {$a * $fac + .03}]
  1989.     set bb [expr {$b * $fac -.03}]
  1990.     set j [expr {round(ceil($aa)) }]
  1991.     set upto [expr {floor($bb) }]
  1992.     set ticks ""
  1993.     while { $j <= $upto } {
  1994.         set tt [expr {$j / $fac}]
  1995.         if { $j%5 == 0 } {
  1996.         append ticks " { $tt $tt }"
  1997.         } else  {
  1998.         append ticks " $tt"
  1999.         }
  2000.         incr j   
  2001.     }
  2002.     set answer($v) $ticks
  2003.     set this [llength $ticks]
  2004.     if { $this  > $best } {
  2005.         set best $this
  2006.         set at $v
  2007.     }
  2008.     #puts "for $v [llength $ticks] ticks"
  2009.     }
  2010.     #puts "using $at [llength $answer($at)]"
  2011.      
  2012.     return $answer($at)
  2013. }
  2014.      
  2015. proc axisTicks { win c }  {
  2016.     $c delete axisTicks
  2017.     if { ![catch {oget $win noaxisticks}] } { return }
  2018.     set swid [$c cget -width]
  2019.     set shei [$c cget -height]
  2020.     set x1 [storx$win [$c canvasx 0]]
  2021.     set y1 [story$win [$c canvasy 0]]
  2022.     set x2 [storx$win [$c canvasx $swid]]
  2023.     set y2 [story$win [$c canvasy $shei]]
  2024.     #puts "x1=$x1,y1=$y1,y2=$y2,x2=$x2"
  2025.     if { $y1 > 0  &&  $y2 < 0 } {
  2026.     set ticks [getTicks $x1 $x2 [expr {$swid/50}] ]
  2027.     #puts "ticks=$ticks"
  2028.     set eps [expr {.005 * abs($y1 - $y2)}]
  2029.     set neps [expr {-.005 * abs($y1 - $y2)}]
  2030.     set donext 0
  2031.     foreach v $ticks {
  2032.         set x [lindex $v 0]
  2033.         set text [lindex $v 1]
  2034.         if { $donext } {set text [lindex $v 0] ; set donext 0 }
  2035.         if { [lindex $v 0] == 0 } { set text "" ; set donext 1 }
  2036.         #puts " drawTick $c $x 0 0 $neps 0 $eps  $text axisTicks"
  2037.         drawTick $c $x 0 0 $neps 0 $eps  $text axisTicks
  2038.         }
  2039.     }
  2040.     if { 0 < $x2 && 0 > $x1 } {
  2041.     set ticks [getTicks $y2 $y1 [expr {$shei/50}]]
  2042.     set eps [expr {.005 * ($x2 - $x1)}]
  2043.     set neps [expr {-.005 * ($x2 - $x1)}]
  2044.     set donext 0
  2045.     foreach v $ticks {
  2046.         set y [lindex $v 0]
  2047.         set text [lindex $v 1]
  2048.         if { $donext } {set text [lindex $v 0] ; set donext 0}
  2049.         if { [lindex $v 0] == 0 } { set text "" ; set donext 1}
  2050.  
  2051.         drawTick $c 0 $y $neps 0 $eps 0  $text axisTicks
  2052.         }
  2053.     }
  2054.  
  2055.     }
  2056.  
  2057.  
  2058. #
  2059.  #-----------------------------------------------------------------
  2060.  #
  2061.  # marginTicks --  draw ticks around the border of window
  2062.  #  x1,y1  top left x2,y2 bottom right.
  2063.  #
  2064.  #  Results:
  2065.  #
  2066.  #  Side Effects: 
  2067.  #
  2068.  #----------------------------------------------------------------
  2069. #    
  2070. proc marginTicks { c x1 y1 x2 y2 tag }  {
  2071.     global printOption
  2072.     set win [winfo parent $c]
  2073.  
  2074.     if { ![catch {oget $win noaxisticks}] } { return }
  2075.     $c delete marginTicks
  2076.     set ticks [getTicks $x1 $x2 $printOption(xticks)]
  2077.     # puts "x=$x1 $x2"
  2078.     set eps [expr {.008 * ($y1 - $y2)}]
  2079.     set neps [expr {-.008 * ($y1 - $y2)}]
  2080.     foreach v $ticks {
  2081.     set x [lindex $v 0]
  2082.     set text [lindex $v 1]
  2083.     drawTick $c $x $y1 0 0 0 $neps  $text $tag
  2084.     drawTick $c $x $y2 0 0 0 $eps  $text $tag
  2085.     
  2086.     }
  2087.     #puts "y=$y2,$y1"
  2088.     set ticks [getTicks $y1 $y2 $printOption(yticks)]
  2089.     set eps [expr {.005 * ($x2 - $x1)}]
  2090.     set neps [expr {-.005 * ($x2 - $x1)}]
  2091.     set donext 0
  2092.     foreach v $ticks {
  2093.     set y [lindex $v 0]
  2094.     set text [lindex $v 1]
  2095.     drawTick $c $x1 $y 0 0 $eps 0  $text $tag
  2096.     drawTick $c $x2 $y 0 0 $neps 0  $text $tag
  2097.         }
  2098.     }
  2099.  
  2100. proc drawTick {c x y dx dy ex ey n tags} {
  2101.     global axisGray     fontCourier8
  2102.     set win [winfo parent $c]
  2103.     set rtosx rtosx$win ; set rtosy rtosy$win
  2104.     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]
  2105.     $c lower $it
  2106.     
  2107.     if { "$n" != "" } {
  2108.    if { $ey > 0 } { set anch s
  2109.     } elseif { $ex > 0 } {set anch w 
  2110.     } elseif { $ex < 0 } {set anch e
  2111.     } elseif { $ey < 0 } {set anch n}
  2112.     
  2113.     $c create text  [$rtosx [expr {$x +1.5*$ex}]] [$rtosy [expr {$y +1.5*$ey}]] \
  2114.         -text [format "%.8g" $n] -font $fontCourier8 -tags $tags \
  2115.         -anchor $anch
  2116. }   }
  2117.  
  2118. proc doConfig { win }  {
  2119.     makeLocal $win c buttonFont
  2120.     $c delete configoptions
  2121.     set canv $c
  2122.    # set w $c.config
  2123.      set w $win.config
  2124.     catch {destroy $w}
  2125.     frame $w -borderwidth 2 -relief raised
  2126.  
  2127.     label $w.msg  -wraplength 600 -justify left -text "Plot Setup" -font $buttonFont
  2128.     pack $w
  2129.     pack $w.msg -side top
  2130.     set wb1 $w.choose1
  2131.     frame $wb1
  2132.     set wb2 $w.choose2
  2133.     frame $wb2
  2134.     pack $wb1 $wb2 -side left -fill x -pady 2m
  2135.     set item [$canv create window [$canv canvasx 10] [$canv canvasy  10] -window $w -anchor nw -tags configoptions]
  2136.     button $wb1.dismiss -command  "$canv delete $item; destroy $w " -text "ok" -font $buttonFont
  2137.     button $wb1.printoptions -text "Print Options" -command "mkPrintDialog .dial -canvas $c -buttonfont $buttonFont " -font $buttonFont
  2138.  
  2139.     pack $wb1.dismiss  $wb1.printoptions -side top 
  2140.     return "$wb1 $wb2"
  2141. }
  2142. # mkentry { newframe textvar text } 
  2143.  
  2144. set show_balloons 1
  2145.  
  2146. proc balloonhelp { win subwin msg } {
  2147.     global show_balloons
  2148.     if { $show_balloons == 0 } return;
  2149.     linkLocal  [oget $win c] helpPending
  2150.     if { [info exists helpPending] } {after cancel $helpPending}
  2151.     set helpPending [after 1000 [list balloonhelp1 $win $subwin $msg]]
  2152. }
  2153.  
  2154. proc balloonhelp1 { win subwin msg } {
  2155.     if { ![winfo exists $win] } { return }
  2156.     makeLocal $win c buttonFont
  2157.     set x0 [winfo rootx $win]
  2158.     set y0 [winfo rooty $win]
  2159.     
  2160.     
  2161.     set atx [expr {[winfo rootx $subwin] + [winfo width $subwin] - $x0} ]
  2162.     set aty [expr {[winfo rooty $subwin] + [winfo height $subwin] - $y0} ]
  2163.  
  2164.     set wid [$c cget -width]
  2165.     set wid2 [expr {round ($wid /2.0)}]
  2166.     set wid10 [expr {round ($wid /10.0)}]
  2167.  
  2168.     if { $aty <=1 } { set aty 30 } 
  2169.     incr aty 10
  2170.     incr atx 10
  2171.     set atx [$c canvasx $atx]
  2172.     set aty [$c canvasy $aty]
  2173.     #puts "$atx $aty"
  2174.     $c delete balloon
  2175.     $c create text $atx $aty -anchor nw -text $msg -font $buttonFont -width $wid2 -fill white -fill black -tags "balloon btext"
  2176.     desetq "x1 y1 x2 y2" [$c bbox btext]
  2177.  
  2178.     set x1 [expr {$x1 - .3*($x2-$x1)}]
  2179.     set x2 [expr {$x2 + .3*($x2-$x1)}]
  2180.     
  2181.     set y1 [expr {$y1 - .3*($y2-$y1)}]
  2182.     set y2 [expr {$y2 + .3*($y2-$y1)}]
  2183.  
  2184.     eval $c create polygon $x1 $y1  $x2 $y1 $x2 $y2 $x1 $y2  -fill beige -tags balloon -smooth 1
  2185.     $c raise btext
  2186.     
  2187. }
  2188.  
  2189. proc setBalloonhelp { win subwin msg } {
  2190.     makeLocal $win c
  2191.     bind $subwin <Enter> "balloonhelp $win $subwin [list $msg]"
  2192.     bind $subwin <Leave> "deleteBalloon $c"
  2193. }
  2194.     
  2195. proc deleteBalloon { c } {
  2196.     linkLocal $c helpPending
  2197.     if { [info exists helpPending] } {
  2198.     after cancel $helpPending
  2199.     unset helpPending
  2200.     }
  2201.     $c delete balloon
  2202. }
  2203.  
  2204.  
  2205. #
  2206.  #-----------------------------------------------------------------
  2207.  #
  2208.  # minMax --  Compute the max and min of the arguments, which may
  2209.  # be vectors or numbers
  2210.  #
  2211.  #  Results: list of MIN and MAX
  2212.  #
  2213.  #  Side Effects: none
  2214.  #
  2215.  #----------------------------------------------------------------
  2216. #
  2217. proc minMax { args } {
  2218.     set max [lindex [lindex $args 0] 0] ; set min $max ;
  2219.     foreach vec $args {
  2220.     foreach v $vec {
  2221.         if { $v > $max } {set max $v }
  2222.         if { $v < $min} {set min $v }
  2223.     }
  2224.     }
  2225.     return [list $min $max]
  2226. }
  2227.  
  2228. proc matrixMinMax { list } {
  2229. # compute the min max of the list    
  2230.     set min +10e300
  2231.     set max -10e300
  2232.     foreach mat $list {
  2233.     foreach row $mat {
  2234.         foreach v [ldelete nam $row] {
  2235.         if { $v > $max } {catch  { set max [expr {$v + 0}] }}
  2236.         if { $v < $min} {catch  { set min [expr {$v + 0}] }}
  2237.         }
  2238.         }
  2239.     }
  2240.     list $min $max
  2241. }
  2242.     
  2243. proc omPlotAny { data args } {
  2244.     # puts "data=<[lindex $data 0]>"
  2245.     set command [list [lindex [lindex $data 0] 0]  -data [lindex $data 0] ]
  2246.     if { "[lindex $command 0]" == "plot2d" } {
  2247.     lappend command -xfun {}
  2248.     }
  2249.     foreach v $args { [lappend command $v] }
  2250.     eval $command
  2251.     #eval [lindex [lindex $data 0] 0] -xfun [list {}] -data [list [lindex $data 0]] $args
  2252. }
  2253.  
  2254.  
  2255. proc resizeSubPlotWindows { win wid height } {
  2256.     set at [$win yview "@0,0"]
  2257.     foreach w [winfo children $win] {
  2258.     if { [string match plot* [lindex [split $w .] end]] } {
  2259.         resizePlotWindow $w [winfo width $w] $height
  2260.     }
  2261.   }
  2262.   if { "$at" != "" } { $win yview $at} 
  2263.  }
  2264.  
  2265.  
  2266.         
  2267. proc resizePlotWindow  { w width height } {
  2268.     if { [winfo width $w.c] <= 1 } {
  2269.     after 100 update ;
  2270.     return }
  2271.     if { ![catch { set tem [oget $w lastResize] } ] && [expr {[clock seconds] - $tem }] < 2 } { return
  2272. } else { oset $w lastResize [clock seconds ]
  2273.     }
  2274.     #puts "resizePlotWindow $w $width $height"
  2275.     
  2276.    # return
  2277.    set par [winfo parent $w]
  2278.    set facx 1.0
  2279.    set facy 1.0    
  2280.     set wid [winfo width $par]
  2281.     set hei [winfo height $par]
  2282.     
  2283.    if { "[winfo class $par]" == "Text" } {
  2284.    set dif 10
  2285.  
  2286.    set wid1 $wid ; set hei1 $hei
  2287.    #puts "now w=$w"
  2288.    #set wid1 [getPercentDim [oget $w widthDesired] width $par]        
  2289.    catch {set wid1 [getPercentDim [oget $w widthDesired] width $par] }
  2290.    catch {set hei1 [getPercentDim [oget $w heightDesired] height $par] }
  2291.    set wid [expr {($wid1 > $wid - 30 ? $wid - 30 : $wid1 )}]
  2292.    set hei [expr {($hei1 > $hei - 30 ? $hei - 30 : $hei1 )}]
  2293.    } else {
  2294.        set dif 10
  2295.  
  2296.    }
  2297.    
  2298.  
  2299.     #puts "width arg=$width,width $w=[winfo width $w],wid of $par=$wid,height=$height,hei=$hei,\[winfo width \$w.c\]=[winfo width $w.c]"
  2300. #     if { $width > $wid -20 || $wid > $width -20 }
  2301.     if { (abs($width-$wid) > $dif ||  abs($height-$hei) > $dif)
  2302. &&  [winfo width $w.c] > 1 } {
  2303.     set eps [expr {2 * [$w.c cget -insertborderwidth] + [$w.c cget -borderwidth] }]
  2304.     set epsx $eps
  2305.     set epsy $eps
  2306.     #puts "reconfiguring: w=$w,par=$par,dif=$dif,widths=$wid, \
  2307.     $width,[winfo width $par],[winfo width $w],[winfo width $w.c]\
  2308.     heights=$hei,$height,[winfo height $par],[winfo height $w],\
  2309.     [winfo height $w.c]"
  2310.     
  2311.     set extrawidth [expr {([winfo width $w] - [winfo width  $w.c]) +$epsx}]
  2312.     set extraheight [expr {([winfo height $w] - [winfo height  $w.c]) +$epsy}]
  2313.     set nwidth [expr {$wid - ($extrawidth > 0  ? $extrawidth : 0)}]
  2314.     set nheight [expr {$hei - ($extraheight > 0  ? $extraheight : 0)}]
  2315.     
  2316.     #puts "$w.c config -width $nwidth  -height $nheight, extraheight=$extraheight,epsy=$epsy"
  2317.     $w.c config -width $nwidth  -height $nheight
  2318.  
  2319.         }
  2320.             
  2321.  }
  2322.  
  2323.  
  2324.  
  2325. proc bboxToRadius { win  } {
  2326.     makeLocal $win bbox
  2327.     if { "$bbox" != "" } {
  2328.     linkLocal $win       xradius yradius xcenter ycenter
  2329.     set i 0
  2330.     foreach v { x y z } {
  2331.  
  2332.         set min [lindex $bbox $i]
  2333.         set max [lindex $bbox [expr $i +2]]
  2334.         if { "$min" != "" } {
  2335.         if { $min >= $max } {error "bad bbox $bbox since $min >= $max"}
  2336.         set ${v}radius [expr { ($max - $min) /2.0}]
  2337.         set ${v}center [expr { ($max + $min) /2.0}]
  2338.         }
  2339.     }
  2340.     }
  2341. }
  2342.  
  2343. proc updateParameters { win var value} {
  2344.     linkLocal $win parameters
  2345. #    puts "$win $var $value"
  2346.     set ans ""
  2347.     set comma ""
  2348.     
  2349.     foreach {v val} [splitParams $parameters] {
  2350.         if { "$v" == "$var" } {
  2351.         set val $value
  2352.     }
  2353.     append ans $comma $v=$val
  2354.     set comma ","
  2355.     }
  2356. #    puts "parameters=$ans"
  2357.     set parameters $ans
  2358. }
  2359.  
  2360. proc addSliders { win } {
  2361.     linkLocal $win sliders c width parameters
  2362.     set i 0
  2363.     if { "$sliders" == "" } { return }
  2364.     catch { destroy $c.sliders }
  2365.     set bg "#22aaee"
  2366.     set trough "#22ccff"
  2367.     frame $c.sliders -relief raised -highlightthickness 2 -highlightbackground $trough
  2368.     foreach v [split $sliders ,] {
  2369.     if { [regexp {([a-zA-Z0-9]+)[ ]*=?(([---0-9.]+):([---0-9.]+))?} $v  junk var junk x0 x1] } {
  2370.         incr i
  2371.         if { "$x0" == "" } { set x0 -5  ; set x1 5}
  2372.  
  2373.         set fr $c.sliders.fr$i
  2374.         frame $fr -background $bg 
  2375.         label $fr.lab -text $var: -background $bg 
  2376.         label $fr.labvalue -textvariable [oloc $win slidevalue$i]  -background $bg -relief sunken -justify left
  2377.         scale $fr.scale -command "sliderUpdate $win $var" \
  2378.             -from "$x0" -to $x1 -orient horizontal \
  2379.         -resolution [expr ($x1 - $x0) < 1 ? ($x1-$x0)/100.0 : .01] \
  2380.         -length [expr {$width/2}] -showvalue 0 -variable [oloc $win slidevalue$i] -background $bg -troughcolor "#22ccff" -highlightthickness 0
  2381.         pack $fr.lab -side left -expand 1 -fill x
  2382.         pack $fr.labvalue $fr.scale -side left
  2383.         pack  $fr -side top -expand 1 -fill x
  2384.         set found 0
  2385.         set val  [assoc $var [splitParams $parameters] no]
  2386.         if { "$val" == "no" } {
  2387.         set val  [expr ($x1 + $x0)/2.0]
  2388.         if { "$parameters" != "" }  { append parameters , } 
  2389.         append parameters $var=$val
  2390.         }
  2391.         $fr.scale set $val
  2392.     }
  2393.     }
  2394.  
  2395.     place  $c.sliders -in $c -x 4 -rely 1.0 -y -4 -anchor sw
  2396.  
  2397.     }
  2398.     
  2399.  
  2400. proc sliderUpdate { win var val } {
  2401.     linkLocal $win sliderCommand parameters
  2402.     set params $parameters
  2403.     updateParameters $win $var $val
  2404.     if { "$params" != "$parameters" &&
  2405.     [info exists sliderCommand] } {
  2406.  
  2407.     $sliderCommand $win $var $val
  2408. }   }
  2409.     
  2410.  
  2411.  
  2412.  
  2413. ## endsource plotconf.tcl
  2414. ## source plotdf.tcl
  2415.  
  2416. ###### plotdf.tcl ######
  2417. #######################################################################
  2418. #######  Copyright William F. Schelter.  All rights reserved.  ########
  2419. #######################################################################
  2420.  
  2421. set plotdfOptions {
  2422.     {dxdt "x-y^2+sin(x)*.3" {specifies dx/dt = dxdt.  eg -dxdt "x+y+sin(x)^2"} }
  2423.     {dydt "x+y" {specifies dy/dt = dydt.  eg -dydt "x-y^2+exp(x)"} }
  2424.     {dydx "" { may specify dy/dx = x^2+y,instead of dy/dt = x^2+y and dx/dt=1 }}
  2425.     {adamsMoulton red "Color to do adams moulton integration in. None means dont do" }
  2426.     {rungeKuttaA "" "Color to do Runge Kutta adaptive integration in. None means dont do" }
  2427.     
  2428.     {xradius 10 "Width in x direction of the x values" }
  2429.     {yradius 10 "Height in y direction of the y values"}
  2430.     {width 500 "Width of canvas in pixels"}
  2431.     {height 500 "Height of canvas in pixels" }
  2432.     {scrollregion {} "Area to show if canvas is larger" }
  2433.     {xcenter 0.0 {(xcenter,ycenter) is the origin of the window}}
  2434.     {ycenter 0.0 "see xcenter"}
  2435.     {bbox "" "xmin ymin xmax ymax .. overrides the -xcenter etc"}
  2436.     {tinitial 0.0 "The initial value of variable t"}
  2437.     {nsteps 100 "Number of steps to do in one pass"}
  2438.     {xfun "" "A semi colon separated list of functions to plot as well"}
  2439.     {tstep "" "t step size"}
  2440.     {direction "both" "May be both, forward or backward" }
  2441.     {versus_t 0 "Plot in a separate window x and y versus t, after each trajectory" }
  2442.     {windowname ".dfplot" "window name"}
  2443.     {parameters "" "List of parameters and values eg k=3,l=7+k"}
  2444.     {sliders "" "List of parameters ranges k=3:5,u"}
  2445.     {linecolors { green black  brown gray black} "colors to use for lines in data plots"}
  2446.     {doTrajectoryAt "" "Place to calculate trajectory"}
  2447.     {linewidth "1.0" "Width of integral lines" }
  2448.     {nolines 0 "If not 0, plot points and nolines"}
  2449.     {bargraph 0 "If not 0 this is the width of the bars on a bar graph" }
  2450.     {plotpoints 0 "if not 0 plot the points at pointsize" }
  2451.     {pointsize 2 "radius in pixels of points" }
  2452.     {autoscale "x y" "Set {x,y}center and {x,y}range depending on data and function. "}
  2453.     {zoomfactor "1.6 1.6" "Factor to zoom the x and y axis when zooming.  Zoom out will be reciprocal" }
  2454.     {errorbar 0 "If not 0 width in pixels of errorbar.  Two y values supplied for each x: {y1low y1high y2low y2high  .. }"}
  2455.      {data "" "List of data sets to be plotted.  Has form { {xversusy {x1 x2 ... xn} {y1 .. yn ... ym}} .. {againstIndex {y1 y2 .. yn}}  .. }"}
  2456.     {labelposition "10 35" "Position for the curve labels nw corner"}
  2457. }
  2458.  
  2459. if { "[info proc makeFrame]" == "" } { source "plotconf.tcl" }
  2460.  
  2461.  
  2462.  
  2463.  
  2464.  proc makeFrameDf { win } {
  2465.    set w [makeFrame $win df]
  2466.     makeLocal $win c dydx
  2467.  
  2468.     set top $win
  2469.    # puts "w=$w,win=$win"
  2470.     catch { set top [winfo parent $win]}
  2471.     catch {
  2472.  
  2473.     wm title $top "Direction Fields"
  2474.     wm iconname $top "DF plot"
  2475. #    wm geometry $top 750x700-0+20
  2476.    }
  2477.     set wb $w.buttons
  2478.    makeLocal $win buttonFont 
  2479.    label $w.msg  -wraplength 600 -justify left -text "A direction field plotter by William Schelter" -font $buttonFont
  2480.    
  2481.   button $wb.integrate -text "Integrate" -command "setForIntegrate $w" -font $buttonFont
  2482.    setBalloonhelp $win $wb.integrate {Causes clicking on the  plot with the left mouse button at a point, to draw a trajectory passing through that point.   Under Config there is an entry box which allows entering exact x,y coordinates, and which also records the place of the last trajectory computed.}
  2483.  
  2484.   button $wb.plotversust -text "Plot Versus t" -command "plotVersusT $w" -font $buttonFont
  2485.    setBalloonhelp $win $wb.plotversust {Plot the x and y values for the  last trajectory versus t.}   
  2486.    
  2487.    
  2488.   setForIntegrate $w
  2489.   pack $wb.integrate -side top -expand 1 -fill x
  2490.   pack $wb.plotversust -side top -expand 1 -fill x
  2491.  # pack $w.msg -side top
  2492.   pack $w
  2493.   return $win
  2494. }
  2495.  
  2496. proc swapChoose {win msg winchoose } {
  2497.    # global dydx dxdt dydt
  2498.     
  2499.     if { "$msg" == "dydt" } {
  2500.     pack $winchoose.dxdt -before $winchoose.dydt -side bottom
  2501.     oset $win dydx ""
  2502.     $winchoose.dydt.lab config -text "dy/dt"
  2503.     } else {
  2504.     pack forget $winchoose.dxdt
  2505.     oset $win dxdt 1
  2506.     oset $win dydx " "
  2507.     $winchoose.dydt.lab config -text "dy/dx"
  2508.     }
  2509. }
  2510.     
  2511.  
  2512. proc doHelpdf { win } {
  2513.     global Parser
  2514.  doHelp $win [join [list \
  2515. {
  2516. William Schelter's solver/plotter for ode systems.
  2517.  
  2518. To QUIT this HELP click here.
  2519.  
  2520. Clicking at a point computes the trajectory
  2521. (x(t),y(t)) starting at that point, and satisfying
  2522. the differential equation
  2523.     
  2524.   dx/dt = dxdt
  2525.   dy/dt = dydt
  2526.  
  2527. By clicking on Zoom, the mouse now allows you to zoom
  2528. in on a region of the plot.  Each click near a point
  2529. magnifies the plot, keeping the center at the point
  2530. you clicked.  Depressing the SHIFT key while clicking
  2531. zooms in the opposite direction.
  2532.  
  2533. To resume computing trajectories click on Integrate.
  2534.  
  2535. To change the differential equation, click on Config and
  2536. enter new values in the entry windows, and then click on
  2537. Replot in the main menu bar.
  2538.  
  2539. Holding the right mouse button down allows you to drag
  2540. (translate) the plot sideways or up and down.
  2541.  
  2542. Additional parameters such as the number of steps (nsteps),
  2543. the initial t value (tinitial), and the x and y centers
  2544. and radii, may be set under the  Config menu.
  2545.  
  2546. You may print to a postscript printer, or save the plot \
  2547. as a postscript file, by clicking on save.   To change \
  2548. between printing and saving see the Print Options under Config.
  2549.     
  2550. } $Parser(help)]]
  2551. }
  2552.  
  2553. proc setForIntegrate { win} {
  2554.     makeLocal $win c
  2555.     $c delete printrectangle
  2556.     bind $c  <1> "doIntegrateScreen $win %x %y "
  2557. }
  2558.  
  2559. ## source rk.tcl
  2560.  
  2561. ###### rk.tcl ######
  2562. #######################################################################
  2563. #######  Copyright William F. Schelter.  All rights reserved.  ########
  2564. #######################################################################
  2565.  
  2566. #proc try { } {
  2567.     #  proc ff { a b c } { return [expr {$b + $c}] }
  2568.     #  proc gg { a b c } { return [expr {$b - $c}] }
  2569. #  rungeKutta ff gg 0.2 0.2 0 .01 10
  2570. #}
  2571.  
  2572. proc rungeKutta { f g t0 x0 y0  h nsteps } {
  2573.   set n $nsteps
  2574.   set ans "$x0 $y0"
  2575.   set xn $x0
  2576.   set yn $y0
  2577.   set tn $t0
  2578.     set h2 [expr {$h / 2.0 }]
  2579.     set h6 [expr {$h / 6.0 }]
  2580.  catch {
  2581.   while { [incr nsteps -1] >= 0 } {
  2582.   
  2583.  
  2584.   set kn1 [$f $tn $xn $yn]
  2585.   set ln1 [$g $tn $xn $yn]
  2586.  
  2587.       set arg [list [expr {$tn + $h2}] [expr {$xn + $h2 * $kn1}] [expr {$yn + $h2*$ln1}]]
  2588.   set kn2 [eval $f $arg]
  2589.   set ln2 [eval $g $arg]
  2590.  
  2591.       set arg [list [expr {$tn + $h2}] [expr {$xn + $h2 * $kn2}] [expr {$yn +$h2*$ln2}]]
  2592.   set kn3 [eval $f $arg]
  2593.   set ln3 [eval $g $arg]
  2594.  
  2595.       set arg [list [expr {$tn + $h}] [expr {$xn + $h * $kn3}] [expr {$yn + $h*$ln3}]]
  2596.   set kn4 [eval $f $arg]
  2597.   set ln4 [eval $g $arg]
  2598.  
  2599.       set xn [expr {$xn + $h6 * ($kn1+2*$kn2+2*$kn3+$kn4)}]
  2600.       set yn [expr {$yn + $h6 * ($ln1+2*$ln2+2*$ln3+$ln4)}]
  2601.       set tn [expr {$tn+ $h}]
  2602.  
  2603.   lappend ans  $xn $yn
  2604.   }
  2605.  }
  2606.  
  2607.  return $ans 
  2608. }
  2609.  
  2610. proc pathLength { list } {
  2611.   set sum 0
  2612.   foreach { x y } $list {
  2613.       set sum [expr {$sum + sqrt($x*$x+$y*$y)}]
  2614.  }
  2615.   return $sum
  2616. }
  2617. proc rungeKuttaA { f g t0 x0 y0  h nsteps } {
  2618.   set ans [rungeKutta $f $g $t0 $x0 $y0 $h $nsteps]
  2619.   set count 0
  2620.   # puts "retrying([llength $ans]) .."
  2621.   while { [llength $ans] < $nsteps * .5  && $count < 7 } {
  2622.        incr count
  2623.        #set leng [pathLength $ans]
  2624.        #if { $leng == 0 } {set leng .001}
  2625.        set th [expr {$h / 3.0}]
  2626.        if { $th  < $h }  { set h $th }
  2627.        set ans  [rungeKutta $f $g $t0 $x0 $y0 $h $nsteps]
  2628.       # puts -nonewline "..(h=[format "%.5f" $h],pts=[llength $ans])"
  2629.        # flush stdout
  2630.   }
  2631.   return $ans
  2632. }
  2633.  
  2634.   
  2635.  
  2636. ## endsource rk.tcl
  2637. ## source adams.tcl
  2638.  
  2639. ###### adams.tcl ######
  2640.  
  2641.  
  2642. proc adamsMoulton { f g t0 x0 y0  h nsteps } {
  2643.     set ans [rungeKutta $f $g $t0 $x0 $y0 $h 3]
  2644.     catch { 
  2645.     set i 0
  2646.     set h24 [expr {$h /24.0}]
  2647.     foreach { x y } $ans {
  2648.     lappend listXff [xff  [expr {$t0 + $i * $h} ] $x $y]
  2649.     lappend listYff [yff  [expr {$t0 + $i * $h} ] $x $y]
  2650.     incr i
  2651.     set xn $x
  2652.     set yn $y
  2653.     }
  2654.  
  2655.     set n [expr $nsteps -3]
  2656.  
  2657.     while { [incr n -1] >= 0 } {
  2658.  
  2659.     #puts "listXff = $listXff"
  2660.     #puts "listYff = $listYff"        
  2661.     # adams - bashford formula:
  2662.     set xp [expr {$xn + ($h24)*(55 *[lindex $listXff 3]-59*[lindex $listXff 2]+37*[lindex $listXff 1]-9*[lindex $listXff 0]) }]
  2663.     set yp [expr {$yn + ($h24)*(55 *[lindex $listYff 3]-59*[lindex $listYff 2]+37*[lindex $listYff 1]-9*[lindex $listYff 0]) }]
  2664.     #puts "i=$i,xp=$xp,yp=$yp"
  2665.     # adams-moulton corrector-predictor:
  2666.     # compute the yp = yn+1 value..
  2667.     set t [expr {$t0 + $i * $h}]
  2668.     incr i
  2669.     if { 1 } {
  2670.     set xap [expr { $xn+($h24)*(9*[xff $t $xp $yp]+19*[lindex $listXff 3]-5*[lindex $listXff 2]+[lindex $listXff 1]) }]
  2671.     set yap [expr { $yn+($h24)*(9*[yff $t $xp $yp]+19*[lindex $listYff 3]-5*[lindex $listYff 2]+[lindex $listYff 1]) }]
  2672.  
  2673.     set xn $xap
  2674.     set yn $yap
  2675.    # puts "after correct:i=[expr $i -1],xn=$xn,yn=$yn"    
  2676.     # could repeat it, or check against previous to see if changes too much.
  2677.     }
  2678.     set listXff [lrange $listXff 1 end]
  2679.     set listYff [lrange $listYff 1 end]
  2680.  
  2681.     lappend listXff [xff $t $xn $yn]
  2682.     lappend listYff [yff $t $xn $yn]
  2683.  
  2684.     lappend ans $xn $yn
  2685.    # puts "ans=$ans"    
  2686.     }
  2687.     #puts "adams:t=$t"
  2688.   }
  2689.     return $ans
  2690. }
  2691.  
  2692. ## endsource adams.tcl
  2693.  
  2694. # sample procedures
  2695. # proc xff { t x y } { return [expr {$x + $y }] }
  2696. # proc yff { t x y } { return [expr {$x - $y }] }
  2697.  
  2698. proc doIntegrateScreen { win sx sy  } {
  2699.     makeLocal $win c
  2700.     doIntegrate $win [storx$win [$c canvasx $sx]] [story$win [$c canvasy $sy]]
  2701. }
  2702.  
  2703. proc doIntegrate { win x0 y0 } {
  2704.     # global xradius yradius c tstep  nsteps
  2705. #    puts "dointegrate $win $x0 $y0"
  2706.     makeLocal $win xradius yradius c tstep  nsteps direction linewidth tinitial versus_t linecolors
  2707.     linkLocal $win didLast trajectoryStarts
  2708.     set rtosx rtosx$win ; set rtosy rtosy$win      
  2709.     oset $win doTrajectoryAt [format "%.10g  %.10g" $x0 $y0]
  2710.     lappend trajectoryStarts [list $x0 $y0]
  2711.     
  2712.     set didLast {}
  2713.     # puts "doing at $doTrajectoryAt"
  2714.     set steps $nsteps
  2715.     if { "$tstep" == "" } {  
  2716.     set h [expr {[vectorlength $xradius $yradius] / 200.0}]
  2717.     set tstep $h
  2718.     } else {set h $tstep }
  2719.     
  2720.     # puts h=$h
  2721.     set todo $h
  2722.     switch $direction {
  2723.     forward { set todo "$h" }
  2724.     backward { set todo "[expr {- $h}]" }
  2725.     both { set todo "$h [expr {- $h}]" }
  2726.     }
  2727.     foreach method { adamsMoulton rungeKuttaA  } {
  2728.     set color [oget $win $method]
  2729.     if { "$color" != "" } {
  2730.         lappend methods $method
  2731.         lappend useColors $method $color
  2732.     }
  2733.     }
  2734.     set methodNo -1
  2735.     foreach method $methods {
  2736.     incr methodNo
  2737. #    puts method=$method
  2738.     foreach h $todo {
  2739.     set form [list $method xff yff $tinitial $x0 $y0 $h $steps]
  2740.     set ans [eval $form]
  2741.     lappend didLast $form
  2742.  
  2743.     #puts "doing: $form"
  2744.     set i -1
  2745.     set xn1 [$rtosx [lindex $ans [incr i]]]
  2746.     set yn1 [$rtosy [lindex $ans [incr i]]]
  2747.     set lim [expr {$steps * 2}]
  2748.     set mee [expr {pow(10.0,9)}]
  2749.     set ptColor [assoc $method $useColors ]
  2750.     set linecolor [lindex $linecolors $methodNo]
  2751.     #set im [getPoint 2 green]
  2752.     #set im1 [getPoint 2 purple]
  2753.     set im [getPoint 2 $ptColor]
  2754.     #set im1 [getPoint 2 purple]        
  2755.     catch  { 
  2756.         while { $i <= $lim } {
  2757.         set xn2  [$rtosx [lindex $ans [incr i]]]
  2758.         set yn2  [$rtosy [lindex $ans [incr i]]]
  2759.         # puts "$xn1 $yn1"
  2760.         # xxxxxxxx following is for a bug in win95 version
  2761.         if { abs($xn1) + abs($yn1) +abs($xn2)+abs($yn2) < $mee    } {
  2762.             $c create line $xn1 $yn1 $xn2 $yn2 -tags path -width $linewidth -fill $linecolor
  2763.             
  2764.         }
  2765.         
  2766.                 if { "$im" != "" } {
  2767.             #puts hi
  2768.             $c create image $xn1 $yn1 -image $im -anchor center \
  2769.                 -tags "point"
  2770.             
  2771.             } else {
  2772.             $c create oval [expr $xn1 -2] [expr $yn1 -2] [expr $xn1 +2] [expr $yn1 +2] -fill $color
  2773.  
  2774.         }
  2775.         
  2776.             
  2777.             
  2778.  
  2779.         # puts "$xn1 $yn1"
  2780.         set xn1 $xn2
  2781.         set yn1 $yn2
  2782.         }
  2783.     }   }
  2784.   }
  2785.   if { $versus_t } { plotVersusT $win}
  2786. }
  2787.  
  2788.  
  2789. proc plotVersusT {win } {
  2790.     linkLocal $win didLast dydt dxdt parameters xcenter xradius
  2791.     set nwin .versust.plot2d
  2792.     if { "$parameters" != ""  } { set pars ", $parameters"} else { set pars ""}
  2793.     oset $nwin themaintitle "dy/dt=$dydt, dx/dt=$dxdt $pars"
  2794.     lappend plotdata [list maintitle [list oget $nwin themaintitle]]
  2795.  
  2796.  
  2797.     foreach v $didLast {
  2798.     set ans [eval $v]
  2799.     desetq "tinitial x0 y0 h" [lrange $v 3 end]
  2800.     set this [lrange $v 0 5]
  2801.     if { [info exists doing($this) ] } { set tem $doing($this) } else {
  2802.         set tem ""
  2803.     }
  2804.     set doing($this) ""
  2805.     set allx "" ; set ally "" ; set allt ""
  2806.     set ii 0 
  2807.     foreach {x y } $ans {
  2808.         lappend allx $x
  2809.         lappend ally $y
  2810.         lappend allt [expr $tinitial + $h*$ii]
  2811.         incr ii
  2812.     }
  2813.     
  2814.     foreach u $tem v [list $allx $ally $allt] {
  2815.         if { $h > 0 } { lappend doing($this) [concat $u $v]} else {
  2816.             lappend doing($this) [concat [lreverse $v] $u]
  2817.         }   }
  2818.     }
  2819.  
  2820.     foreach {na val } [array get doing] {
  2821.     lappend plotdata [list label "x versus t"] [list plotpoints 2]
  2822.     lappend plotdata [list xversusy [lindex $val 2] [lindex $val 0] ]
  2823.     lappend plotdata [list label "y versus t"]    
  2824.     lappend plotdata [list xversusy [lindex $val 2] [lindex $val 1] ]
  2825.     }
  2826.     if { ![winfo exists .versust] } {
  2827.     toplevel .versust
  2828.     }
  2829.     
  2830.  
  2831.     plot2d -data $plotdata -windowname $nwin -ycenter $xcenter -yradius $xradius
  2832.     wm title .versust "X and Y versus t"
  2833. }
  2834.  
  2835. proc lreverse { lis } {
  2836.     set ans ""
  2837.     set i [llength $lis]
  2838.     while { [incr i -1]>=0 } {
  2839.     lappend ans [lindex $lis $i]
  2840.     }
  2841.     return $ans
  2842. }
  2843.  
  2844.  
  2845. #
  2846.  #-----------------------------------------------------------------
  2847.  #
  2848.  # $rtosx,$rtosy --  convert Real coordinate to screen coordinate
  2849.  #
  2850.  #  Results: a window coordinate
  2851.  #
  2852.  #  Side Effects: 
  2853.  #
  2854.  #----------------------------------------------------------------
  2855.  
  2856.  
  2857. #
  2858.  #-----------------------------------------------------------------
  2859.  #
  2860.  # $storx,$story --  Convert a screen coordinate to a Real coordinate.
  2861.  #
  2862.  #  Results:
  2863.  #
  2864.  #  Side Effects: 
  2865.  #
  2866.  #----------------------------------------------------------------
  2867. #
  2868.  
  2869. proc drawArrowScreen { c atx aty dfx dfy } {
  2870.  
  2871.     set x1 [expr {$atx + $dfx}]
  2872.     set y1 [expr {$aty + $dfy}]
  2873.     #   set x2 [expr {$atx + .8*$dfx +.1* $dfy}]
  2874.     #   set y2 [expr {$aty + .8*$dfy - .1* $dfx}]
  2875.     #   set x3 [expr {$atx + .8*$dfx -.1* $dfy}]
  2876.     #   set y3 [expr {$aty + .8*$dfy + .1* $dfx}]
  2877.   $c create line $atx $aty $x1 $y1 -tags arrow -fill blue -arrow last -arrowshape {3 5 2}
  2878. #  $c create line $x2 $y2  $x1 $y1 -tags arrow -fill red
  2879. #  $c create line $x3 $y3 $x1 $y1 -tags arrow -fill red
  2880. }
  2881.  
  2882. proc drawDF { win tinitial } {
  2883.     global  axisGray
  2884.     makeLocal  $win xmin xmax   xcenter ycenter c ymin ymax transform
  2885.  
  2886.     # flush stdout
  2887.     set rtosx rtosx$win ; set rtosy rtosy$win
  2888.     set storx   storx$win  ;   set story   story$win  
  2889.     set stepsize 30
  2890.     set min 100000000000.0
  2891.     set max 0.0
  2892.     set t0 $tinitial
  2893.     set xfactor [lindex $transform 0]
  2894.     set yfactor [lindex $transform 3]
  2895.     set extra $stepsize  
  2896.     set uptox [expr {[$rtosx $xmax] + $extra}]
  2897.     set uptoy [expr {[$rtosy $ymin] + $extra}]
  2898.     # draw the axes:
  2899.     #puts "draw [$rtosx $xmin] to $uptox"
  2900.     for { set x [expr {[$rtosx $xmin] - $extra}] } { $x < $uptox } { set x [expr {$x +$stepsize}] } {
  2901.     for { set y [expr {[$rtosy $ymax] - $extra}] } { $y < $uptoy } { set y [expr {$y + $stepsize}] } {
  2902.         set args "$t0 [$storx $x] [$story $y]"
  2903.         set dfx [expr {$xfactor * [eval xff $args]}]
  2904.         # screen y is negative of other y
  2905.         set dfy [expr  {$yfactor * [eval yff $args]}]
  2906.         #     puts "$dfx $dfy"
  2907.         set len  [vectorlength $dfx $dfy]
  2908.         append all " $len $dfx $dfy "
  2909.         if { $min > $len } { set min $len }
  2910.         if { $max < $len } {set  max $len}
  2911.     }   }
  2912.     set fac [expr {($stepsize -5 -8)/($max - $min)}]
  2913.     set arrowmin 8
  2914.     set arrowrange [expr {$stepsize -4 - $arrowmin}]
  2915.     set s1 [expr {($arrowrange*$min+$arrowmin*$min-$arrowmin*$max)/($min-$max)}]
  2916.     set s2 [expr {$arrowrange/($max-$min) }]
  2917.     # we calculate fac for each length, so that
  2918.     # when we multiply the vector times fac, its length
  2919.     # will fall somewhere in [arrowmin,arrowmin+arrowrange].
  2920.     # vectors of length min and max resp. should get mapped
  2921.     # to the two end points.
  2922.     # To do this we set fac [expr {$s1/$len + $s2}]
  2923.     # puts "now to draw,s1=$s1 s2=$s2,max=$max,min=$min"
  2924.     # puts "xfactor=$xfactor,yfactor=$yfactor"
  2925.  
  2926.     
  2927.     set i -1
  2928.     for { set x [expr {[$rtosx $xmin] - $stepsize}] } { $x < $uptox } { set x [expr {$x +$stepsize}] } {
  2929.     for { set y [expr {[$rtosy $ymax] - $stepsize}] } { $y < $uptoy } { set y [expr {$y + $stepsize}] } {
  2930.         
  2931.         
  2932.         set len [lindex $all [incr i]]
  2933.         
  2934.         set fac [expr {$s1/$len + $s2}]
  2935.         set dfx [lindex $all [incr i]]
  2936.         set dfy [lindex $all [incr i]]
  2937.         #puts "[$storx $x] [$story $y] x=$x y=$y dfx=$dfx dfy=$dfy fac=$fac"
  2938.         # puts "$len $dfx $dfy" 
  2939.         drawArrowScreen $c $x $y [expr {$fac * $dfx}] [expr {$fac * $dfy}]
  2940.         }
  2941.     }
  2942.     
  2943.     $c create line [$rtosx 0 ] [$rtosy -1000] [$rtosx 0] [$rtosy 1000] \
  2944.         -fill $axisGray
  2945.     $c create line [$rtosx -1000] [$rtosy 0] [$rtosx 1000] [$rtosy 0] \
  2946.         -fill $axisGray
  2947.     axisTicks $win $c
  2948. }
  2949.  
  2950. proc parseOdeArg {  s } {
  2951.     set orig $s
  2952.     set w "\[ ]*"
  2953.     set exp "\[dD]$w\\($w\(\[xyz])$w,$w\(\[xyt])$w\\)$w=(\[^;]+)"
  2954.     while { [regexp $exp $s junk x t expr ] } {
  2955.     lappend ans  -d${x}d$t
  2956.     lappend ans $expr
  2957.     regexp -indices $exp $s junk x t expr
  2958.     set s [string range $s [lindex $junk 1] end]
  2959.     }
  2960.     if { ![info exists ans] || ([llength $ans] == 2 && "[lindex $ans 0]" != "-dydx") } {
  2961.     error "bad -ode argument: $orig\nwant d(y,x)=f(x,y) \n   OR d(x,t)=f(x,y) d(y,t)=g(x,y) "
  2962.     }
  2963.     return $ans
  2964. }
  2965.  
  2966.  
  2967.  
  2968. proc plotdf { args } {
  2969.     global plotdfOptions   printOption printOptions plot2dOptions
  2970.     # puts "args=$args"
  2971.     # to see options add: -debug 1
  2972.     set win [assoc -windowname $args]
  2973.     if { "$win" == "" } {set win [getOptionDefault windowname $plotdfOptions] }
  2974.     if { "[lindex $args 0]" == "-ode" } {
  2975.     set tem [parseOdeArg [lindex $args 1]]
  2976.     set args [lrange $args 2 end]
  2977.     set args [concat $tem  $args]
  2978.     }
  2979.     global [oarray $win]
  2980.     getOptions $plotdfOptions $args -usearray [oarray $win]
  2981.  
  2982.     makeLocal $win dydx
  2983.  
  2984.     if { "$dydx" !="" } { oset $win dxdt 1 ; oset $win dydt $dydx }
  2985.     setPrintOptions $args
  2986.     foreach v {trajectoryStarts recompute} {
  2987.         catch { unset [oloc $win $v]  }
  2988.     }
  2989.     
  2990.     makeFrameDf $win
  2991.     oset $win sliderCommand sliderCommandDf
  2992.     oset $win trajectoryStarts ""
  2993.     
  2994.  
  2995.     oset $win maintitle [concat "makeLocal $win  dxdt dydt dydx ;"  \
  2996.         {if { "$dydx" == "" } { concat "dx/dt = $dxdt , dy/dt = $dydt"}  else {
  2997.     concat "dy/dx = $dydt" } } ]
  2998.     replotdf $win
  2999.     }
  3000.  
  3001. proc replotdf { win } {
  3002.     global plotdfOptions
  3003.     linkLocal $win xfundata data
  3004.     if { ![info exists data] } {
  3005.     set data ""
  3006.     
  3007.     }
  3008.     makeLocal $win c dxdt dydt tinitial nsteps xfun     doTrajectoryAt parameters 
  3009.  
  3010.     setUpTransforms $win 1.0
  3011.     setXffYff $dxdt $dydt $parameters
  3012.     $c delete all
  3013.     setForIntegrate $win
  3014.     oset $win curveNumber -1
  3015.     drawDF $win $tinitial
  3016.     if { "$doTrajectoryAt" != "" } {
  3017.          eval doIntegrate $win  $doTrajectoryAt
  3018.     }
  3019.     set xfundata ""
  3020.     foreach v [sparseListWithParams $xfun {x y t} $parameters ] {
  3021.     proc _xf {  x  } "return \[expr { $v } \]"
  3022.     regsub "\\$" $v "" label
  3023.     lappend xfundata [list label $label] \
  3024.       [linsert [calculatePlot $win _xf $nsteps]  \
  3025.         0 xversusy]
  3026.     }
  3027.     redraw2dData $win -tags path
  3028.     
  3029. }    
  3030.  
  3031. proc setXffYff { dxdt dydt parameters } {
  3032.     
  3033.     proc xff { t x y } "expr { [sparseWithParams $dxdt { x y} $parameters] }"    
  3034.     proc yff { t x y } "expr { [sparseWithParams $dydt { x y} $parameters] } "
  3035. }
  3036.  
  3037. proc doConfigdf { win } {
  3038.     desetq "wb1 wb2" [doConfig $win]
  3039.     makeLocal $win buttonFont 
  3040.     frame $wb1.choose1
  3041.     set frdydx $wb1.choose1
  3042.     button $frdydx.dydxbut -command "swapChoose $win dydx $frdydx " \
  3043.         -text "dy/dx" -font $buttonFont
  3044.     button $frdydx.dydtbut -command "swapChoose $win dydt $frdydx" \
  3045.         -text "dy/dt,dx/dt" -font $buttonFont
  3046.     mkentry $frdydx.dxdt [oloc $win dxdt] "dx/dt" $buttonFont
  3047.     mkentry $frdydx.dydt [oloc $win dydt] "dy/dt" $buttonFont
  3048.     pack $frdydx.dxdt  $frdydx.dydt -side bottom  -fill x -expand 1
  3049.     pack $frdydx.dydxbut $frdydx.dydtbut -side left -fill x -expand 1
  3050.     
  3051.     foreach w {versus_t parameters linewidth xradius yradius xcenter ycenter tinitial nsteps tstep direction xfun linecolors rungeKuttaA adamsMoulton } {
  3052.     mkentry $wb1.$w [oloc $win $w] $w $buttonFont
  3053.     pack $wb1.$w -side bottom -expand 1 -fill x
  3054.     }
  3055.     mkentry $wb1.doTrajectoryAt [oloc $win doTrajectoryAt] \
  3056.         "Trajectory at" $buttonFont
  3057.     bind $wb1.doTrajectoryAt.e <KeyPress-Return> \
  3058.         "eval doIntegrate $win \[oget $win doTrajectoryAt\] "
  3059.     pack  $wb1.doTrajectoryAt   $frdydx    -side bottom -expand 1 -fill x
  3060.     if { "[oget $win dydx]" != "" } { swapChoose $win dydx $frdydx }
  3061.     setForIntegrate $win
  3062.  }
  3063.  
  3064.  
  3065.  
  3066. proc sliderCommandDf { win var val } {
  3067.     linkLocal $win recompute
  3068.     updateParameters $win $var $val
  3069.     set com "recomputeDF $win"
  3070. # allow for fast move of slider...    
  3071.     after cancel $com
  3072.     after 50 $com
  3073. }
  3074.  
  3075. proc recomputeDF { win } {
  3076.     linkLocal $win  recompute 
  3077.     if { [info exists recompute]  } {
  3078.     incr recompute
  3079.     return
  3080.     } else {
  3081. #    puts "set recompute 1"
  3082.     set recompute 1
  3083.     }
  3084.     linkLocal $win trajectoryStarts  c tinitial dxdt dydt parameters
  3085.     set redo 0
  3086.     set trajs ""
  3087.  
  3088.     catch {     set trajs $trajectoryStarts} 
  3089.  
  3090.  
  3091.     while { $redo != $recompute } {
  3092. #    puts "    setXffYff $dxdt $dydt $parameters"
  3093.     setXffYff $dxdt $dydt $parameters
  3094. #    $c delete path point arrow
  3095.     $c delete all
  3096.     catch { unset  trajectoryStarts }
  3097.     set redo $recompute
  3098.     foreach pt $trajs {
  3099.         desetq "x0 y0" $pt
  3100.         catch { doIntegrate $win $x0 $y0 }
  3101.         update
  3102.         if { $redo != $recompute } { break }
  3103.     }
  3104.     if  { $redo == $recompute } {
  3105.         catch { drawDF $win $tinitial }
  3106.     }
  3107.     }
  3108. #    puts "    unset recompute"
  3109.     unset recompute
  3110. }
  3111.     
  3112.  
  3113.     
  3114.         
  3115.     
  3116.     
  3117.     
  3118.  
  3119. ## endsource plotdf.tcl
  3120. ## source plot2d.tcl
  3121.  
  3122. ###### plot2d.tcl ######
  3123. ############################################################
  3124. # Netmath       Copyright (C) 1998 William F. Schelter     #
  3125. # For distribution under GNU public License.  See COPYING. # 
  3126. ############################################################
  3127.  
  3128. set p .plot
  3129. catch { destroy $p }
  3130.  
  3131. set plot2dOptions { 
  3132.     {xradius 10 "Width in x direction of the x values" }
  3133.     {yradius 10 "Height in y direction of the y values"}
  3134.     {width 500 "Width of canvas in pixels"}
  3135.     {height 500 "Height of canvas in pixels" }
  3136.     {xcenter 0.0 {(xcenter,ycenter) is the origin of the window}}
  3137.     {xfun "" {function of x to plot eg: sin(x) or "sin(x);x^2+3" }}
  3138.     {parameters "" "List of parameters and values eg k=3,l=7+k"}
  3139.     {sliders "" "List of parameters ranges k=3:5,u"}
  3140.     {nsteps "100" "mininmum number of steps in x direction"}
  3141.     {ycenter 0.0 "see xcenter"}
  3142.     {bbox "" "xmin ymin xmax ymax .. overrides the -xcenter etc"}
  3143.     {screenwindow "20 20 700 700" "Part of canvas on screen"}
  3144.  
  3145.     {windowname ".plot2d" "window name"}
  3146.     {nolines 0 "If not 0, plot points and nolines"}
  3147.     {bargraph 0 "If not 0 this is the width of the bars on a bar graph" }
  3148.     {linewidth "0.6" "Width of plot lines" }
  3149.     {plotpoints 0 "if not 0 plot the points at pointsize" }
  3150.     {pointsize 2 "radius in pixels of points" }
  3151.     {linecolors {blue green red brown gray black} "colors to use for lines in data plots"}
  3152.     {labelposition "10 35" "Position for the curve labels nw corner"}
  3153.     {xaxislabel "" "Label for the x axis"}
  3154.     {yaxislabel "" "Label for the y axis"}
  3155.     {autoscale "y" "Set {x,y}center and {x,y}range depending on data and function. Value of y means autoscale in y direction, value of {x y} means scale in both.  Supplying data will automatically turn this on."}
  3156.     {zoomfactor "1.6 1.6" "Factor to zoom the x and y axis when zooming.  Zoom out will be reciprocal" }
  3157.     {errorbar 0 "If not 0 width in pixels of errorbar.  Two y values supplied for each x: {y1low y1high y2low y2high  .. }"} 
  3158.     {data "" "List of data sets to be plotted.  Has form { {xversusy {x1 x2 ... xn} {y1 .. yn ... ym}} .. {againstIndex {y1 y2 .. yn}}  .. }"}
  3159. }
  3160.  
  3161. proc argSuppliedp { x } {
  3162.   upvar 1 args a
  3163.   return [expr [set i [lsearch $a $x]] >= 0 && $i%2 == 0] 
  3164. }
  3165.     
  3166. proc mkPlot2d { args } {
  3167.     global plot2dOptions  printOption axisGray
  3168.     #puts "args=<$args>"
  3169.     # global  screenwindow c xmax xmin ymin ymax 
  3170.     # eval global [optionFirstItems $plot2dOptions]
  3171.     set win [assoc -windowname $args]
  3172.     if { "$win" == "" } {
  3173.     set win [getOptionDefault windowname $plot2dOptions] }
  3174.     global  [oarray $win]
  3175.     set data [assoc -data $args ]
  3176.     # puts ranges=[plot2dGetDataRange $data]
  3177.  
  3178.     getOptions $plot2dOptions $args -usearray [oarray $win]
  3179.     linkLocal $win autoscale 
  3180.     if { [argSuppliedp -data] && ![argSuppliedp -autoscale] &&
  3181.     ![argSuppliedp -xradius] } {
  3182.     lappend autoscale x
  3183.     }
  3184.     if { ![argSuppliedp -autoscale] & [argSuppliedp -yradius] } {
  3185.     set autoscale [ldelete y $autoscale]
  3186.     }    
  3187.     
  3188.     oset $win curveNumber -1
  3189.     setPrintOptions $args
  3190.     oset $win maintitle ""    
  3191.     setupCanvas $win 
  3192.     catch { destroy $windowname }
  3193.     
  3194.     makeFrame2d $win
  3195.     oset $win sliderCommand sliderCommandPlot2d
  3196.     makeLocal $win c
  3197.     return $win
  3198.     
  3199. }
  3200.  
  3201. proc  makeFrame2d  { win } {
  3202.     set w [makeFrame $win 2d]
  3203.     set top $w
  3204.     catch { set top [winfo parent $w]}
  3205.     catch {
  3206.     wm title $top "Schelter's 2d Plot Window"
  3207.     wm iconname $top "2d plot"
  3208.    # wm geometry $top 750x700-0+20
  3209.    }
  3210.     pack $w
  3211.    return $w
  3212.  
  3213. }
  3214.  
  3215. proc doConfig2d { win } {
  3216.     desetq "wb1 wb2" [doConfig $win]
  3217.     makeLocal $win buttonFont 
  3218.     mkentry $wb1.nsteps [oloc $win nsteps]  "Number of mesh grids"  $buttonFont
  3219.     mkentry $wb1.xfun [oloc $win xfun]  "y=f(x)"  $buttonFont
  3220.     bind $wb1.xfun.e <Return> "replot2d $win"
  3221.     # button .jim.buttons.rot "rotate" -command "bindForRotation"
  3222.     # pack .jim.buttons.rot
  3223.     pack $wb1.xfun  $wb1.nsteps -expand 1 -fill x
  3224.     foreach w {xradius yradius xcenter ycenter linecolors autoscale linewidth parameters} {
  3225.     mkentry $wb1.$w [oloc $win $w] $w $buttonFont
  3226.     pack $wb1.$w -side bottom -expand 1 -fill x
  3227.     }
  3228. }
  3229.  
  3230. proc doHelp2d {win } {
  3231.  global Parser
  3232.  
  3233. doHelp $win [join [list \
  3234. {
  3235.  
  3236. William Schelter's plotter for two dimensional graphics.
  3237.  
  3238. to QUIT this HELP click here.
  3239.  
  3240. By clicking on Zoom, the mouse now allows you to zoom \
  3241. in on a region of the plot.  Each click near a point \
  3242. magnifies the plot, keeping the center at the point \
  3243. you clicked.  Depressing the SHIFT key while clicking \
  3244. zooms in the opposite direction. 
  3245.  
  3246. To change the functions plotted, click on Config and \
  3247. enter new values in the entry windows, and then click on \
  3248. Replot in the main menu bar.
  3249.  
  3250. Holding the right mouse button down allows you to drag
  3251. (translate) the plot sideways or up and down.
  3252.  
  3253. Additional parameters such as the number of steps (nsteps), \
  3254. and the x and y centers and radii, may be set under the \
  3255. Config menu.
  3256.  
  3257. You may print to a postscript printer, or save the plot \
  3258. as a postscript file, by clicking on save.   To change \
  3259. between printing and saving see the Print Options under Config.
  3260.     
  3261.  
  3262.  
  3263.  
  3264.  
  3265. } $Parser(help)]]
  3266. }
  3267.  
  3268.  
  3269. set   plot(numberPlots) 4
  3270. proc mkExtraInfo { name args } {
  3271.     # global plot     
  3272.     catch { destroy $name }
  3273.  
  3274.     toplevel $name
  3275.     wm geometry $name -10+10
  3276.  # pack $name
  3277.     set canv [assoc -canvas $args ]
  3278.     set i 0
  3279.     set w $name
  3280.     frame $w.grid
  3281.     pack $w.grid -expand yes -fill both -padx 1 -pady 1
  3282.     grid $w.grid
  3283.     grid rowconfig    $w.grid 0 -weight 1 -minsize 0
  3284.     grid columnconfig $w.grid 0 -weight 2 -minsize 0
  3285.     
  3286.     set i 0
  3287.     label $w.title -text "Extra Plotting Information" -width 50
  3288.     grid $w.title -in $w.grid -columnspan 2 -row 0 -column 0
  3289.     incr i
  3290.     label $w.labppl -text "Plot Function f(x)"
  3291.     label $w.labcol -text "plot color"
  3292.     grid $w.labppl -padx 1 -in $w.grid  -pady 1 -row $i -column 0 -sticky news
  3293.     grid $w.labcol -padx 1 -in $w.grid  -pady 1 -row $i -column 1 -sticky news
  3294.     incr i
  3295.     set k 1
  3296.     proc mkPlotEntry { w k i } {
  3297.       entry $w.plot$k -textvariable plot(fun$k)
  3298.       entry $w.color$k -textvariable plot(col$k)
  3299.       grid $w.plot$k -padx 10 -in $w.grid  -pady 1 -row $i -column 0 -sticky news
  3300.       grid $w.color$k -padx 4 -in $w.grid  -pady 1 -row $i -column 1 -sticky news
  3301.     }
  3302.     while { $k <= $plot(numberPlots) } { mkPlotEntry $w $i $k ; incr i ; incr k}
  3303.    }
  3304.  
  3305. proc calculatePlot { win fun  nsteps } {
  3306.   #  global xmin xmax  ymax ymin
  3307.     makeLocal $win xmin xmax  ymax ymin
  3308.     set h0 [expr {($xmax - $xmin)/double($nsteps )}]
  3309.     set x0 $xmin
  3310.     set res ""
  3311.     set limit [expr {100 * (abs($ymax)> abs($ymin) ? abs($ymax) : abs($ymin))}]
  3312.     while { $x0 < $xmax } {
  3313.     set lastx0 $x0
  3314.     #puts xmax=$xmax
  3315.     append res " " [calculatePlot1 $win $x0 $h0 $fun $limit]
  3316.     #puts res:[lrange $res [expr [llength $res] -10] end]
  3317.     if { $x0 <= $lastx0 }    {
  3318.         # puts "x0=$x0,($lastx0)"
  3319.         set x0 [expr {$x0 + $h0/4}]
  3320.         #error "how is this?"
  3321.     }
  3322.     }
  3323.     # puts "plength=[llength $res]"
  3324.     return $res
  3325. }
  3326.  
  3327.  
  3328. #
  3329.  #-----------------------------------------------------------------
  3330.  #
  3331.  # calculatePlot1 --   must advance x0 in its caller
  3332.  #
  3333.  #  Results: one connected line segment as "x0 y0 x1 y1 x2 y2 .."
  3334.  #
  3335.  #  Side Effects: must advance x0 in its caller
  3336.  #
  3337.  #----------------------------------------------------------------
  3338. #
  3339. proc  calculatePlot1 { win x0 h0 fun  limit } {
  3340.      #puts "calc:$win $x0 $h0 $limit $fun"
  3341.     makeLocal $win xmax
  3342.     set ansx ""
  3343.     set ansy ""
  3344.    while { [catch { set y0 [$fun $x0] } ] && $x0 <= $xmax }  {
  3345.        set x0 [expr {$x0 + $h0}] }
  3346.     if { $x0 > $xmax } {
  3347.     # puts "catching {$fun $x0}"
  3348.     uplevel 1 set x0 $x0
  3349.     return ""
  3350.     }
  3351.     set ans "$x0 $y0"
  3352.     set delta 0
  3353.     set littleLimit [expr {$limit/50.0 }]
  3354.     set veryLittleLimit [expr {$littleLimit * 10}]
  3355.     # now have one point..
  3356.     # this is really set below for subsequent iterations.
  3357.     set count 10
  3358.     set heps [expr {$h0/pow(2,6)}]
  3359.     set h2 [expr {$h0 *2 }]
  3360.     set ii 0
  3361.     set x1 [expr {$x0 + $h0}]
  3362.     while { $x1 <= $xmax  && $ii < 5000 } {
  3363.         # puts $x1
  3364.         incr ii
  3365.     if { [catch { set y1 [$fun $x1] } ] } {
  3366.             #puts "catching1 {$fun $x1}"
  3367.         if { $count > 0 } {
  3368.         # try a shorter step.
  3369.         set x1 [expr {($x1 -$x0)/2 + $x0}]
  3370.         incr count -1
  3371.         continue
  3372.         } else {
  3373.         uplevel 1 set x0 [expr {$x0 + $heps}]
  3374.         return [list $ansx $ansy]
  3375.         }
  3376.     }
  3377.     # ok have x1,y1
  3378.     # do this on change in slope!! not change in limit..
  3379.  
  3380.     set nslope [expr {($y1-$y0)/($x1-$x0)}]
  3381.     catch { set delta [expr {($slope * $nslope < 0 ? abs($slope-$nslope) : .1*abs($slope-$nslope))}]} 
  3382.     # catch { set delta [expr {abs($slope - ($y1-$y0)/($x1-$x0))}] }
  3383.     
  3384.     if { $count > 0 && (abs($y1 - $y0) > $h2 || $delta > $h2)  && (0 || abs($y1) < $littleLimit)
  3385.             } {
  3386.             #puts "too  big $y1 [expr {abs($y1-$y0)}] at $x1"
  3387.             set x1 [expr {($x1 -$x0)/2 + $x0}]
  3388.         incr count -1
  3389.              continue 
  3390.              } elseif { abs($y1) > $limit || abs($y1-$y0) > $limit
  3391.             || $delta > $littleLimit } {
  3392.         incr ii
  3393.         if { $count == 0 } {
  3394.             uplevel 1 set x0 [expr {$x0 + $heps}]
  3395.             return [list $ansx $ansy]
  3396.         } else {
  3397.             
  3398.             set x1 [expr {($x1 -$x0)/2 + $x0}]
  3399.             incr count -1
  3400.             continue
  3401.         }
  3402.         } else {
  3403.          if {   abs($y1-$y0) > $limit/4} {
  3404.          
  3405.         # puts "x0=$x0,x1=$x1,y0=$y0,y1=$y1"
  3406.         uplevel 1 set x0 $x1
  3407.         return [list $ansx $ansy]
  3408.     }
  3409.  
  3410.     
  3411.         # hopefully common case!!
  3412.         # puts "got it: $x1,$y1,"
  3413.             lappend ansx $x1
  3414.             lappend ansy $y1
  3415.         #append ans " $x1 $y1"
  3416.                   set slope [expr {($y1-$y0)/($x1-$x0)} ]
  3417.         set x0 $x1
  3418.         set y0 $y1
  3419.     set x1 [expr {$x0 + $h0}]
  3420.         set count 4
  3421.         }
  3422.     }
  3423.     uplevel 1 set x0 $x1
  3424.     return [list $ansx $ansy]
  3425.     }
  3426.  
  3427.     
  3428.  
  3429.     
  3430.  
  3431. #proc setup_xf { vars form } {
  3432. #    set s [sparse $form ] 
  3433. #    proc _xf  $vars  "return \[ expr { $s } \]"
  3434. #}
  3435.  
  3436.  
  3437. #
  3438.  #-----------------------------------------------------------------
  3439.  #
  3440.  # nextColor --  get next COLOR and advance the curveNumber
  3441.  #
  3442.  #  Results: a color
  3443.  #
  3444.  #  Side Effects: the local variable for WIN called curveNumber is incremented
  3445.  #
  3446.  #----------------------------------------------------------------
  3447. #
  3448. proc nextColor { win } {
  3449.     makeLocal $win linecolors 
  3450.     if { [catch { set i [oget $win curveNumber] } ] } { set i -1 }
  3451.     set color [lindex $linecolors [expr {[incr i]%[llength $linecolors]}]]
  3452.     oset $win curveNumber $i
  3453.     return $color
  3454. }
  3455.     
  3456.  
  3457. proc plot2d {args } {
  3458.     #puts "args=$args"
  3459.     set win [apply mkPlot2d $args]
  3460.     replot2d $win
  3461.     return $win
  3462. }
  3463.  
  3464. proc replot2d {win } {
  3465.     global printOption axisGray plot2dOptions
  3466.     linkLocal $win xfundata data
  3467.     foreach v $data {
  3468.     if { "[assq [lindex $v 0] $plot2dOptions notthere]" != "notthere" } {
  3469.         oset $win [lindex $v 0] [lindex $v 1]
  3470.     }
  3471.     }
  3472.     linkLocal $win parameters 
  3473.     makeLocal $win xfun nsteps c linecolors xaxislabel yaxislabel  autoscale sliders
  3474.     if { "$sliders" != "" && ![winfo exists $c.sliders] } {
  3475.     addSliders $win
  3476.     }
  3477.     set xfundata ""
  3478. #   puts xfun=$xfun,parameters=$parameters,[oget $win xradius],[oget $win xmax]
  3479.     foreach v [sparseListWithParams $xfun x $parameters] {
  3480. #    puts v=$v
  3481. #    proc _xf {  x  } "return \[expr { $v } \]"
  3482.     proc _xf {  x  } "expr { $v }"    
  3483.     regsub "\\$" $v "" label
  3484.     lappend xfundata [list label $label] \
  3485.       [linsert [calculatePlot $win _xf $nsteps]  \
  3486.         0 xversusy]
  3487.     }
  3488.  
  3489.     # in case only functions and no y autoscale dont bother.
  3490.     if { "$data" != "" || [lsearch $autoscale y]>=0  } {
  3491.     set ranges [plot2dGetDataRange [concat $data $xfundata]]
  3492. #    puts ranges=$ranges
  3493.     foreach {v k} [eval plot2dRangesToRadius $ranges] {
  3494.         if { [lsearch $autoscale [string index $v 1] ] >= 0 } {
  3495.         oset $win [string range $v 1 end] $k
  3496.         }
  3497.     }
  3498.     }
  3499.     
  3500.     setUpTransforms $win 1.0
  3501.     set rtosx rtosx$win ; set rtosy rtosy$win
  3502.     $c del axes
  3503.     $c create line [$rtosx 0 ] [$rtosy -1000] [$rtosx 0] [$rtosy 1000] -fill $axisGray -tags axes
  3504.     $c create line [$rtosx -1000] [$rtosy 0] [$rtosx 1000] [$rtosy 0] -fill $axisGray -tags axes
  3505.     axisTicks $win $c
  3506.  
  3507.     if { "$xfun" != "" } {
  3508.      oset $win maintitle [concat list "Plot of y = \[oget $win xfun\]" ]
  3509.     }
  3510.     $c del path
  3511.     $c del label
  3512.     oset  $win curveNumber -1
  3513.     redraw2dData $win -tags path
  3514.     $c create text    [expr {[$rtosx 0] + 10}] [expr {[$rtosy [oget $win ymax]] +20}] -text [oget $win yaxislabel] -anchor nw
  3515.     $c create text     [expr {[$rtosx [oget $win xmax]] -20}] [expr {[$rtosy 0] - 10}] -text [oget $win xaxislabel] -anchor se
  3516.  
  3517.     
  3518. }
  3519.  
  3520.  
  3521.  
  3522. #
  3523.  #-----------------------------------------------------------------
  3524.  #  Should change name to plotData since works for 3d to now..
  3525.  # plot2dData --  create WIN and plot 2d OR 3d DATA which is a list of 
  3526.  #  data sets.  Each data set must begin with xversusy or againstIndex
  3527.  #  In the first case the data set looks like:
  3528.  #       { xversusy {x1 x2 ...xn} {y1 ... yn yn+1 ... ym} }
  3529.  #  and will be plotted as m/n curves : (x1,y1) (x2,y2) .. (xn,yn)
  3530.  #  and (x1,yn+1) (x2,yn+2) ..
  3531.  #  In the againstIndex case the x values are replace by the indices
  3532.  #  0,1,2,... [length $yvalues]-1 
  3533.  #  Results: none
  3534.  #
  3535.  #  Side Effects: curves draw
  3536.  #
  3537.  #----------------------------------------------------------------
  3538. #
  3539. proc plot2dData { win data args } {
  3540.    clearLocal $win
  3541.     #puts "data=$data, [regexp plot2d $data junk ]"
  3542.     if { [regexp plot2d $data junk] } {
  3543.   # eval plot2d $args -windowname $win  [plot2dGetRanges $data] -xfun [list {}] -data [list $data]
  3544.    eval plot2d $args -windowname $win   -xfun [list {}] -data [list $data]    
  3545.     } else {
  3546.     # puts data=$data
  3547.     set com [concat \
  3548.         plot3d $args -windowname $win -zfun {{}} -data [lrange $data 1 end]]
  3549.     # puts com=$com
  3550.     eval $com
  3551.     }
  3552.  }
  3553.  
  3554.  
  3555.  
  3556. proc plot2dGetDataRange { data } {
  3557.     set rangex ""
  3558.     set rangey ""
  3559.      #puts "data=$data"
  3560.     set extra ""
  3561.     foreach d $data {
  3562.     #puts first=[lindex $d 0]
  3563.       if { [catch {     
  3564.     switch -exact -- [lindex $d 0] {
  3565.        xversusy {
  3566.            foreach { xx yy } [lrange $d 1 end] {
  3567.           # puts "hi xx=[llength $xx],yy=[llength $yy]"
  3568.            if { [llength $xx] > 0 } {
  3569.                set rangex [minMax $xx $rangex]
  3570.                set rangey [minMax $yy $rangey]
  3571.            }
  3572.            }
  3573.            #puts "rangex=$rangex,rangey=$rangey"
  3574.        }
  3575.        againstIndex {
  3576.            set rangex [minMax [list 0 [llength [lindex $d 1]]] $rangex]
  3577.            set rangey [minMax [lindex $d 1] $rangey]
  3578.        }
  3579.        default {
  3580.            set vv [lindex $d 0]
  3581.            if { [lsearch {xrange yrange   } $vv] >= 0 } {
  3582.            set radius [expr {([lindex $d 2] -[lindex $d 1])/2.0 }]
  3583.            set center [expr {([lindex $d 2] +[lindex $d 1])/2.0 }]
  3584.            set var [string range $vv 0 0]
  3585.            lappend extra -${var}radius $radius -${var}center $center
  3586.            }
  3587.            if { [lsearch bargraph $vv] >= 0 } {
  3588.                set rangey [minMax 0 $rangey]
  3589.            }
  3590.  
  3591.  
  3592.            if { [lsearch {xradius yradius xcenter ycenter } $vv] >= 0 } {
  3593.            lappend extra -$vv [list [lindex $d 1]]
  3594.            }
  3595.  
  3596.         }
  3597.        }
  3598.    } errmsg ] } {
  3599.        set com [list error "bad data: [string range $d 0 200].." $errmsg]
  3600.        after 1 $com
  3601.    }
  3602.  }
  3603.  
  3604.    list $rangex $rangey $extra
  3605. }
  3606.  
  3607.  
  3608.  
  3609. proc plot2dRangesToRadius  { rangex rangey extra } {
  3610.    set ranges ""
  3611.   # puts "extra=$extra"
  3612.    foreach u { x y } {
  3613.        if { "[assoc -[set u]radius $extra]" == "" } {
  3614.        desetq "min max" [set range$u]
  3615.        if { "$min" == "$max" } {
  3616.            set min [expr {$min - .5}]
  3617.            set max [expr {$max + .5}]
  3618.        }
  3619.        #puts "$u has $min,$max"
  3620.        # use 1.7 to get a bit bigger radius than really necessary.
  3621.        if { "$max" != "" } {
  3622.        
  3623.            lappend extra -[set u]radius [expr {($max-$min)/1.7}] \
  3624.                -[set u]center [expr {($max+$min)/2.0}]
  3625.        }
  3626.    }
  3627.  }
  3628.  # puts "extra=$extra"
  3629.  return $extra
  3630. }
  3631.    
  3632.  
  3633. proc redraw2dData { win  args } {
  3634.    makeLocal $win c linecolors data xfundata errorbar linewidth
  3635.    set tags [assoc -tags $args {} ]
  3636.    set rtosx rtosx$win ; set rtosy rtosy$win  
  3637.    set i -1
  3638.    set label _default
  3639.    append data " " $xfundata
  3640. #    set linewidth 2.4
  3641.     
  3642.    #puts "data=$data"
  3643.    foreach d $data {
  3644.        set type [lindex $d 0]
  3645.        switch  $type {
  3646.        xversusy {
  3647.             #puts "starting .. [oget $win curveNumber]"
  3648.            set curvenumber [oget $win curveNumber]
  3649.            # the data can be multiple lists and each list
  3650.            # will not be line connected to previous
  3651.            foreach {xvalues yvalues} [lrange $d 1 end] {
  3652.            # puts "xvalues=$xvalues"
  3653.            #puts "here:$curvenumber,[oget $win curveNumber]"
  3654.            oset $win curveNumber $curvenumber
  3655.            set n [expr {[llength $xvalues] -1}]
  3656.            while { [llength $yvalues] > 0 } {
  3657.                set ans ""
  3658.                set color [nextColor $win]
  3659.                catch { set color [oget $win color] }
  3660.                
  3661.                if { [info exists didLabel([oget $win curveNumber])] } {
  3662.                set label "" } else { set didLabel([oget $win curveNumber]) 1
  3663.                }
  3664.                set errorbar [oget $win errorbar]
  3665.                # puts "errorbar=$errorbar"
  3666.                if { $errorbar != 0 } {
  3667.                set j 0
  3668.               # puts "xvalues=$xvalues,yvalues=$yvalues"
  3669.                     for { set i 0 } { $i <= $n } {incr i} {
  3670.                    set x [lindex $xvalues $i]
  3671.                    set y1 [lindex $yvalues [expr {$i * 2}]]
  3672.                    set y2 [lindex $yvalues [expr { $i * 2 +1}]]
  3673.                if { 1 } {
  3674.                   # puts "x=$x,y1=$y1,y2=$y2"
  3675.                    set xx [$rtosx $x]
  3676.                    set y1 [$rtosy $y1]
  3677.                    set y2 [$rtosy $y2]
  3678.                    $c create line [expr {$xx - $errorbar}] $y1 [expr {$xx +$errorbar}] $y1 $xx $y1 $xx $y2 [expr {$xx -$errorbar}] $y2 [expr {$xx + $errorbar}] $y2  -tags [list [concat $tags line[oget $win curveNumber]]]  -fill $color
  3679.                }
  3680.                }
  3681.                
  3682.                    
  3683.                set yvalues [lrange $yvalues [llength $xvalues] end]
  3684.                } else { 
  3685.  
  3686.                foreach x $xvalues y [lrange $yvalues 0 $n] {
  3687.                append ans "[$rtosx $x] [$rtosy $y] "
  3688.                
  3689.                }
  3690.  
  3691.                drawPlot $win [list $ans] -tags [list [concat $tags line[oget $win curveNumber]]]  -fill $color -label $label
  3692.                }
  3693.                set label _default
  3694.  
  3695.                set yvalues [lrange $yvalues [llength $xvalues] end]
  3696.            }
  3697.  
  3698.          } }
  3699.        againstIndex {
  3700.                set color [nextColor $win]
  3701.            set ind 0
  3702.            set ans ""
  3703.            foreach y [lindex $d 1] {
  3704.            append ans "[$rtosx $ind] [$rtosy $y] "
  3705.            incr ind
  3706.            }
  3707.            
  3708.            drawPlot $win [list $ans] -tags \
  3709.                [list [concat $tags line[oget $win curveNumber]]] \
  3710.                -fill $color -width $linewidth -label $label
  3711.            set label _default
  3712.  
  3713. #           eval $c create line $ans -tags \
  3714. #                [list [concat $tags line[oget $win curveNumber]]] \
  3715. #               -fill $color -width .2
  3716.        }
  3717.        label {
  3718.            set label [lindex $d 1]
  3719.        }
  3720.        default {
  3721.  
  3722.            # puts "$type,[lindex $d 1]"
  3723.            if { [lsearch { xfun color plotpoints linecolors pointsize nolines bargraph errorbar maintitle linewidth
  3724.            labelposition
  3725.            xaxislabel yaxislabel } $type] >= 0 } {
  3726.            # puts "setting oset $win $type [lindex $d 1]"
  3727.            oset $win $type [lindex $d 1]
  3728.            } elseif { "$type" == "text" } {
  3729.            desetq "x y text" [lrange $d 1 end]
  3730.            $c create text [$rtosx $x] [$rtosy $y] -anchor nw -text $text -tags "text all" -font times-roman
  3731.            }
  3732.  
  3733.        }
  3734.  
  3735.        }
  3736.    }
  3737.  
  3738. }
  3739.  
  3740. proc plot2dDrawLabel { win label color } {
  3741.     makeLocal $win c labelposition
  3742.     #puts "$win $label $color"
  3743.     if { "$label" == ""} {return }
  3744.     set bb [$c bbox label]
  3745.     desetq "a0 b0" $labelposition
  3746.     if { "$bb" == "" } { set bb "$a0 $b0 $a0 $b0" }
  3747.     desetq "x0 y0 x1 y1" $bb
  3748.     set leng  15
  3749.     set last [$c create text [expr {$a0 +$leng +4}] \
  3750.         [expr {2 + $y1}] \
  3751.         -anchor nw       -text "$label" -tags label]
  3752.     desetq "ux0 uy0 ux1 uy1" [$c bbox $last]
  3753.     $c create line $a0 [expr {($uy0+$uy1) /2}] [expr {$a0 +$leng}] [expr {($uy0+$uy1) /2}]   -tags "label" -fill $color
  3754. }
  3755.     
  3756.  
  3757. proc RealtoScreen { win listPts } {
  3758.     set rtosx rtosx$win ; set rtosy rtosy$win  
  3759.     set ans ""
  3760.     if { [llength [lindex $listPts  0]] != 1 } {
  3761.     foreach v $listPts {
  3762.         append ans " {"
  3763.         append ans [RealtoScreen $win $v]
  3764.         append ans "}"
  3765.     }
  3766.     }    else {
  3767.     foreach {x y } $listPts {
  3768.         append ans " [$rtosx $x] [$rtosy $y]"
  3769.     }
  3770.     }
  3771.     return $ans
  3772. }
  3773.  
  3774. proc drawPlot {win listpts args } {
  3775.     makeLocal $win  c nolines plotpoints  pointsize bargraph linewidth
  3776. #    set linewidth 2.4
  3777.     # puts ll:[llength $listpts]
  3778.     set tags [assoc -tags $args ""]
  3779.     if { [lsearch $tags path] < 0 } {lappend tags path}
  3780.     set fill [assoc -fill $args black]
  3781.     set label [assoc -label $args ""]
  3782.     if { "$label" == "_default" } {
  3783.     set label line[oget $win curveNumber]
  3784.     }
  3785.  
  3786.     catch { set fill [oget $win color] }
  3787.     
  3788.     if { $nolines == 1 && $plotpoints == 0 && $bargraph == 0} {
  3789.     set plotpoints 1
  3790.     }
  3791.  
  3792.     catch { 
  3793.     foreach pts $listpts {
  3794.     if { $bargraph } {
  3795.         set rtosy rtosy$win
  3796.         set rtosx rtosx$win
  3797.         set width [expr {abs([$rtosx $bargraph] - [$rtosx 0])}]
  3798.         set w2 [expr {$width/2.0}]
  3799.         # puts "width=$width,w2=$w2"
  3800.         set ry0 [$rtosy 0]
  3801.         foreach { x y } $pts {
  3802.         $c create rectangle [expr {$x-$w2}] $y  [expr {$x+$w2}] \
  3803.             $ry0 -tags $tags -fill $fill }
  3804.         } else {
  3805.         if { $plotpoints } {
  3806.             set im [getPoint $pointsize $fill]
  3807.             
  3808.             # there is no eval, so we need this.
  3809.             if { "$im" != "" } {
  3810.             foreach { x y } $pts {
  3811.             $c create image $x $y -image $im -anchor center \
  3812.                 -tags "$tags point"
  3813.             }
  3814.             } else {
  3815.             foreach { x y } $pts {
  3816.             $c create oval [expr {$x -$pointsize}] \
  3817.                 [expr {$y -$pointsize}] [expr {$x +$pointsize}] \
  3818.                 [expr {$y +$pointsize}] -tags $tags \
  3819.                 -fill $fill -outline {}
  3820.             
  3821.             }
  3822.         }
  3823.         }
  3824.         
  3825.         if { $nolines == 0 } {
  3826.             set n [llength $pts]
  3827.             set i 0
  3828.             set res "$win create line "
  3829.             #puts npts:[llength $pts]
  3830.             if { $n >= 6 } {
  3831.             eval $c create line $pts      -tags [list $tags] -width $linewidth -fill $fill
  3832.             }
  3833.         }
  3834.         }
  3835.         
  3836.     }
  3837.     }
  3838.     plot2dDrawLabel $win $label $fill
  3839. }
  3840.  
  3841.     
  3842.  
  3843. proc drawPointsForPrint { c } {
  3844.     global ws_openMath
  3845.     foreach v [$c find withtag point] {
  3846.     set tags [ldelete point [$c gettags $v]]
  3847.     desetq "x y" [$c coords $v]
  3848.     
  3849.     
  3850.     desetq "pointsize fill" $ws_openMath(pointimage,[$c itemcget $v -image])
  3851.     catch { 
  3852.         $c create oval [expr {$x -$pointsize}] \
  3853.             [expr {$y -$pointsize}] [expr {$x +$pointsize}] \
  3854.             [expr {$y +$pointsize}] -tags $tags \
  3855.                 -fill $fill -outline {}
  3856.          $c delete $v            
  3857.     }
  3858.  
  3859.  
  3860.     }
  3861.  
  3862. }
  3863.  
  3864. array set ws_openMath { bitmap,disc4 {#define disc4_width 4
  3865. #define disc4_height 4
  3866. static unsigned char disc4_bits[] = {
  3867.     0x06, 0x0f, 0x0f, 0x06};}
  3868.     bitmap,disc6 {#define disc_width 6
  3869. #define disc_height 6
  3870. static unsigned char disc_bits[] = {
  3871.     0xde, 0xff, 0xff, 0xff, 0xff, 0xde};}
  3872. }
  3873.  
  3874.  
  3875. proc getPoint { size color } {
  3876.     global ws_openMath
  3877.     set im ""
  3878.     if { ![catch { set im $ws_openMath(pointimage,$size,$color) }] } {
  3879.     return $im
  3880.     }
  3881.     catch { set data $ws_openMath(bitmap,disc[expr {$size * 2}]) 
  3882.     set im [image create bitmap -data $data -foreground $color]
  3883.     set ws_openMath(pointimage,$size,$color) $im
  3884.     set ws_openMath(pointimage,$im) "$size $color"
  3885.    }
  3886.     return $im
  3887. }
  3888.     
  3889.  
  3890.  
  3891.  
  3892. proc sliderCommandPlot2d { win var val } {
  3893.     linkLocal $win recompute
  3894.     updateParameters $win $var $val
  3895.     set com "recomputePlot2d $win"
  3896. # allow for fast move of slider...    
  3897.     after cancel $com
  3898.     after 10 $com
  3899. }
  3900.  
  3901. proc recomputePlot2d { win } {
  3902.        replot2d $win
  3903. }
  3904.  
  3905.  
  3906. ## endsource plot2d.tcl
  3907. ## source plot3d.tcl
  3908.  
  3909. ###### plot3d.tcl ######
  3910. ############################################################
  3911. # Netmath       Copyright (C) 1998 William F. Schelter     #
  3912. # For distribution under GNU public License.  See COPYING. # 
  3913. ############################################################
  3914.  
  3915.  
  3916. set ws_openMath(speed) [expr {(9700.0 / (1 + [lindex [time {set i 0 ; while { [incr i] < 1000} {}} 1] 0]))}]
  3917.  
  3918.  
  3919. set plot3dOptions { 
  3920.     {xradius 1 "Width in x direction of the x values" }
  3921.     {yradius 1 "Height in y direction of the y values"}
  3922.  
  3923.     {width 500 "Width of canvas in pixels"}
  3924.     {height 500 "Height of canvas in pixels" }
  3925.     {xcenter 0.0 {(xcenter,ycenter) is the origin of the window}}
  3926.     {ycenter 0.0 "see xcenter"}
  3927.     {zcenter 0.0 "see xcenter"}
  3928.     {bbox "" "xmin ymin xmax ymax zmin zmax overrides the -xcenter etc"}
  3929.     {zradius auto " Height in z direction of the z values"}
  3930.     {az 60 "azimuth angle" }
  3931.     {el 30 "elevantion angle" }
  3932.     
  3933.     {thetax 10.0 "ignored is obsolete: use az and el"}
  3934.     {thetay 20.0 "ignored is obsolete: use az and el"}
  3935.     {thetaz 30.0 "ignored is obsolete: use az and el"}
  3936.  
  3937.     {flatten 0 "Flatten surface when zradius exceeded" }
  3938.     {zfun "" "a function of z to plot eg: x^2-y^2"}
  3939.     {parameters "" "List of parameters and values eg k=3,l=7"}
  3940.     {sliders "" "List of parameters ranges k=3:5,u"}
  3941.     {data  "" "a data set of type { variable_grid xvec yvec zmatrix}
  3942.     or {matrix_mesh xmat ymat zmat} or {grid {xmin xmax} {ymin ymax} zmatrix}"}
  3943.     {nsteps "10 10" "steps in x and y direction"}
  3944.     {rotationcenter "" "Origin about which rotation will be done"}
  3945.     {zoomfactor "1.6 1.6" "Factor to zoom the x and y axis when zooming.  Zoom out will be reciprocal" }
  3946.     {screenwindow "20 20 700 700" "Part of canvas on screen"}
  3947.     {windowname ".plot3d" "window name"}
  3948. }
  3949.     
  3950.  
  3951. ## source matrix.tcl
  3952.  
  3953. ###### matrix.tcl ######
  3954. ############################################################
  3955. # Netmath       Copyright (C) 1998 William F. Schelter     #
  3956. # For distribution under GNU public License.  See COPYING. # 
  3957. ############################################################
  3958.  
  3959. # In this file a matrix is represented by a list of M*N entries together
  3960. # with an integer N giving the number of columns: {1 0 0 1} 2  would give
  3961. # the two by two identity
  3962.  
  3963. proc comment {args } { }
  3964.   set mee " } \] \[ expr { "  
  3965.  
  3966. proc mkMultLeftExpr { mat n prefix { constant "" } } {
  3967. #create a function body that does MAT (prefix1,prefix2,..) + constant 
  3968.     global mee
  3969.     set all ""
  3970.     
  3971.     set vars ""
  3972.     for { set i 0} { $i < $n} {incr i} { append vars " $prefix$i" }
  3973.     set j 0
  3974.     set k 0
  3975.     
  3976.     foreach v $mat {
  3977.     if { $j == 0 } {
  3978.         set ro ""
  3979.         # append ans ""
  3980.         set op ""
  3981.     }
  3982.         append ro " $op $v*\$$prefix$j"
  3983.     set op "+"
  3984.     if { $j == [expr {$n -1}] } {
  3985.          append ans " "
  3986.         if { "[lindex $constant $k]" != "" } {
  3987.         append ro " + [lindex $constant $k] "
  3988.         }
  3989.         incr k
  3990.         append ans [concat \[ expr [list $ro] \]]
  3991.         set j -1
  3992.     }
  3993.     incr j
  3994.     }
  3995.     # puts [list $vars $ans]
  3996.      return [list $vars $ans]
  3997. }
  3998.  
  3999. proc mkMultLeftFun { mat n name { constant ""} } {
  4000.     set expr [mkMultLeftExpr $mat $n _a $constant]
  4001.     set bod1 [string trim [lindex $expr 1] " "]
  4002. #    set bod "return \"$bod1\""
  4003.     set bod [concat list [lindex $expr 1]]
  4004.     proc $name [lindex $expr 0] $bod
  4005. }
  4006.  
  4007. proc rotationMatrix { th ph } {
  4008.    return [list \
  4009.        [expr {cos($ph)*cos($th)}] [expr {- cos($ph)*sin($th)}] [expr {sin($ph)}] \
  4010.        [expr {sin($th)}] [expr {cos($th)}] 0.0 \
  4011.        [expr {- sin($ph)*cos($th)}] [expr {sin($ph)*sin($th)}] [expr {cos($ph)}]]
  4012. }
  4013.  
  4014. # proc rotationMatrix { thx thy thz } {
  4015. #   return [list  \
  4016. #  [expr { cos($thy)*cos($thz)} ]  \
  4017. #  [expr { cos($thy)*sin($thz)} ]  \
  4018. #  [expr { sin($thy)} ]  \
  4019. #  [expr { sin($thx)*sin($thy)*cos($thz)-cos($thx)*sin($thz)} ]  \
  4020. #  [expr { sin($thx)*sin($thy)*sin($thz)+cos($thx)*cos($thz)} ]  \
  4021. #  [expr { -sin($thx)*cos($thy)} ]  \
  4022. #  [expr { -sin($thx)*sin($thz)-cos($thx)*sin($thy)*cos($thz)} ]  \
  4023. #  [expr { -cos($thx)*sin($thy)*sin($thz)+sin($thx)*cos($thz)} ]  \
  4024. #  [expr { cos($thx)*cos($thy)} ] ]
  4025. # }
  4026.  
  4027. proc rotationMatrix { thx thy thz } {
  4028.     return \
  4029.  [list  \
  4030.  [expr { cos($thy)*cos($thz) } ] \
  4031.  [expr { cos($thy)*sin($thz) } ] \
  4032.  [expr { sin($thy) } ] \
  4033.  [expr { sin($thx)*sin($thy)*cos($thz)-cos($thx)*sin($thz) } ] \
  4034.  [expr { sin($thx)*sin($thy)*sin($thz)+cos($thx)*cos($thz) } ] \
  4035.  [expr { -sin($thx)*cos($thy) } ] \
  4036.  [expr { -sin($thx)*sin($thz)-cos($thx)*sin($thy)*cos($thz) } ] \
  4037.  [expr { sin($thx)*cos($thz)-cos($thx)*sin($thy)*sin($thz) } ] \
  4038.  [expr { cos($thx)*cos($thy) } ] ]
  4039. }
  4040.  
  4041. # cross [a,b,c] [d,e,f] == [B*F-C*E,C*D-A*F,A*E-B*D]
  4042. # cross_product([a,b,c],[d,e,f]):=[B*F-C*E,C*D-A*F,A*E-B*D]
  4043. # cross_product(u,v):=sublis([a=u[1],b=u[2],c=u[3],d=v[1],e=v[2],f=v[3]],[B*F-C*E,C*D-A*F,A*E-B*D]);
  4044. # the rotation by azimuth th, and elevation ph
  4045. # MATRIX([COS(TH),SIN(TH),0],[-COS(PH)*SIN(TH),COS(PH)*COS(TH),SIN(PH)],
  4046. #        [SIN(PH)*SIN(TH),-SIN(PH)*COS(TH),COS(PH)]);
  4047.  
  4048. proc rotationMatrix { th ph {ignore {} } } {
  4049.     return \
  4050. [list \
  4051. [        expr {cos($th)   } ]\
  4052. [expr {sin($th)   } ]\
  4053. 0 \
  4054. [expr {-cos($ph)*sin($th)   } ]\
  4055. [expr {cos($ph)*cos($th)   } ]\
  4056. [expr {sin($ph)   } ]\
  4057. [expr {sin($ph)*sin($th)   } ]\
  4058. [expr {-sin($ph)*cos($th)   } ]\
  4059. [expr {cos($ph)   } ]]
  4060. }
  4061.  
  4062. proc setMatFromList {name lis n} {
  4063.     set i 1
  4064.     set j 1
  4065.     foreach v $lis {
  4066.     uplevel 1 set [set name]($i,$j) $v
  4067.     if { $j == $n } {set j 1; incr i} else { incr j}
  4068. }   }
  4069.  
  4070. proc matRef { mat cols i j } { [lindex $mat [expr {$i*$cols + $j}]] }
  4071. proc matTranspose { mat cols } {
  4072.     set j 0
  4073.     set m [expr {[llength $mat ] / $cols}]
  4074.     while { $j < $cols} {
  4075.     set i 0
  4076.     while { $i < $m } {
  4077.         append ans " [lindex $mat [expr {$i*$cols + $j}]]"
  4078.         incr i
  4079.     }
  4080.     incr j
  4081.     }
  4082.     return $ans
  4083. }
  4084.  
  4085.  
  4086. proc matMul { mat1 cols1 mat2 cols2 } {
  4087.     mkMultLeftFun $mat1 $cols1 __tem
  4088.     set tr [matTranspose $mat2 $cols2]
  4089.     set rows1 [expr {[llength $mat1] / $cols1}]
  4090.     #puts "tr=$tr"
  4091.     set upto [llength $tr]
  4092.     set j 0
  4093.     set ans ""
  4094.     set i 0
  4095.     while { $j < $cols2  } {
  4096.     append ans " [eval __tem [lrange $tr $i [expr {$i+$cols1 -1}]]]"
  4097.     incr i $cols1
  4098.     incr j
  4099.     }
  4100.  #   return $ans
  4101.    # puts "matTranspose $ans $rows1"
  4102.     return [matTranspose $ans $rows1]
  4103. }
  4104.  
  4105.  
  4106.  
  4107. proc invMat3 { mat } {
  4108.     setMatFromList xx $mat 3
  4109.     set det [expr { double($xx(1,1))*($xx(2,2)*$xx(3,3)-$xx(2,3)*$xx(3,2))-$xx(1,2)* \
  4110.         ($xx(2,1)*$xx(3,3)-$xx(2,3)*$xx(3,1))+$xx(1,3)*($xx(2,1)*$xx(3,2)\
  4111.         -$xx(2,2)*$xx(3,1)) }]
  4112.     
  4113.     return [list   [expr { ($xx(2,2)*$xx(3,3)-$xx(2,3)*$xx(3,2))/$det}] \
  4114.         [expr { ($xx(1,3)*$xx(3,2)-$xx(1,2)*$xx(3,3))/$det}] \
  4115.         [expr { ($xx(1,2)*$xx(2,3)-$xx(1,3)*$xx(2,2))/$det}] \
  4116.         \
  4117.         [expr { ($xx(2,3)*$xx(3,1)-$xx(2,1)*$xx(3,3))/$det}] \
  4118.         [expr { ($xx(1,1)*$xx(3,3)-$xx(1,3)*$xx(3,1))/$det}] \
  4119.         [expr { ($xx(1,3)*$xx(2,1)-$xx(1,1)*$xx(2,3))/$det}] \
  4120.         \
  4121.         [expr { ($xx(2,1)*$xx(3,2)-$xx(2,2)*$xx(3,1))/$det}] \
  4122.         [expr { ($xx(1,2)*$xx(3,1)-$xx(1,1)*$xx(3,2))/$det}] \
  4123.         [expr { ($xx(1,1)*$xx(2,2)-$xx(1,2)*$xx(2,1))/$det}]]
  4124. }
  4125.  
  4126.  
  4127. proc vectorOp { a op b} {
  4128.     set i [llength $a]
  4129.     set k 0
  4130.     set ans [expr [list [lindex $a 0]  $op [lindex $b 0]]]
  4131.     while { [incr k] < $i } {
  4132.     lappend ans  [expr  [list [lindex $a $k] $op [lindex $b $k]]]
  4133.     }
  4134.     return $ans
  4135. }
  4136. ## endsource matrix.tcl
  4137.  
  4138. proc transformPoints { pts fun } {
  4139.   set ans ""
  4140.   foreach { x y z } $pts {
  4141.       append ans " "
  4142.       append ans [$fun $x $y $z]
  4143.   }
  4144.   return $ans
  4145. }
  4146.  
  4147. proc calculatePlot3d {win fun  nx ny } {
  4148.     global plot3dMeshes$win
  4149.     set meshes  plot3dMeshes$win
  4150.     makeLocal $win xradius xmin yradius ymin zradius zcenter flatten
  4151.     
  4152.     set stepx [expr { 2*$xradius / double($nx)}]
  4153.     set stepy [expr { 2*$yradius / double($ny)} ]
  4154.     set i 0
  4155.     set j 0
  4156.     set zmax -1000000000
  4157.     set zmin 1000000000
  4158.     # check if zradius is a number
  4159.     set dotruncate [expr ![catch {expr {$zradius + 1} }]]
  4160.     if { $dotruncate } {
  4161.     if { $flatten } { set dotruncate 0 }
  4162.     set zzmax [expr {$zcenter + $zradius}]
  4163.     set zzmin [expr {$zcenter - $zradius}]
  4164.     #puts "zzmax=$zzmax,$zzmin"
  4165.    } else { set flatten 0 }
  4166.  
  4167.     catch { unset  $meshes }
  4168.     set k 0
  4169.     for {set i 0} { $i <= $nx } { incr i} {
  4170.     set x [expr { $xmin + $i * $stepx }]
  4171.     for {set j 0} { $j <= $ny } { incr j} {
  4172.         set y [expr { $ymin + $j *$stepy }]
  4173.        if { [catch {  set z [$fun $x $y] }] } {
  4174.            set z nam
  4175.        } elseif { $dotruncate  &&  ($z > $zzmax || $z < $zzmin) } {
  4176.            set z nam
  4177.  
  4178.         } else {
  4179.         if { $flatten } {
  4180.             if { $z > $zzmax } { set z $zzmax } elseif {
  4181.             $z < $zzmin } { set z $zzmin }}
  4182.             
  4183.            if { $z < $zmin }  { set zmin $z } elseif {
  4184.         $z > $zmax } { set zmax $z }
  4185.         if { $j != $ny && $i != $nx } {
  4186.             set [set meshes]($k) \
  4187.                       "$k [expr { $k+3 }] [expr { $k+3+($ny+1)*3 }] \
  4188.               [expr { $k+($ny+1)*3 }]"} else {
  4189.           # set plot3dMeshes($k) ""
  4190.           }
  4191.       }
  4192.           incr k 3
  4193.         append ans " $x $y $z"
  4194.     }
  4195.     }
  4196.     oset $win zmin $zmin
  4197.     oset $win zmax $zmax
  4198.     oset $win points $ans
  4199.     oset $win nx $nx
  4200.     oset $win ny $ny
  4201.     oset $win colorfun plot3dcolorFun
  4202.     addAxes $win
  4203.     setupPlot3dColors $win
  4204. }
  4205.  
  4206. proc calculatePlot3data {win fun  nx ny } {
  4207. # calculate the 3d data from function:
  4208.     makeLocal $win xradius xmin xmax ymax yradius ymin zradius zcenter flatten
  4209.     
  4210.     set rowx [linspace $xmin $xmax $nx]
  4211.     set rowy [linspace $ymin $ymax $ny]
  4212.     foreach  y $rowy {
  4213.     set row ""
  4214.     foreach x $rowx {
  4215.         if { [catch {  set z [$fun $x $y] }] } {
  4216.         set z nam
  4217.         }
  4218.         lappend row $z
  4219.     }
  4220.     lappend matrix $row
  4221.     }
  4222.     global silly
  4223.     set silly [list variable_grid $rowx $rowy $matrix ]
  4224.     return [list variable_grid $rowx $rowy $matrix ]
  4225.     
  4226. }
  4227.  
  4228. proc addAxes { win } {
  4229.     #global plot3dPoints plot3dMeshes xradius yradius xcenter ycenter
  4230.     global [oarray $win] plot3dMeshes$win
  4231.     linkLocal $win lmesh
  4232.     makeLocal $win   xradius yradius xcenter ycenter  points zmax zcenter zmin
  4233.     set meshes plot3dMeshes$win
  4234.     set ll [llength $points]
  4235.  
  4236.     # puts "oset $win  axisstart  $ll"
  4237.     oset $win  axisstart  $ll
  4238.     set nx2 5
  4239.     set ny2 5
  4240.     set xstep [expr { 1.2 * $xradius/double($nx2) }]
  4241.     set ystep [expr { 1.2 * $yradius/double($ny2) }]
  4242.     set nz2 $ny2
  4243.  
  4244.     set ans " "
  4245.     set x0 $xcenter
  4246.     set y0 $ycenter
  4247.     set z0 $zcenter
  4248.  
  4249.     set k $ll
  4250.     for { set i 0 } { $i < $nx2 } { incr i } {
  4251.     append ans "[expr {$x0 +$i * $xstep}] $y0 $z0 "
  4252.     lappend lmesh [list $k [incr k 3]]
  4253.     #set [set meshes]($k) "$k [incr k 3]"
  4254.     }
  4255.     append ans "[expr {$x0 +$nx2 * $xstep}] $y0 $z0 "
  4256.     incr k 3
  4257.     # set plot3dMeshes($k) ""
  4258.  
  4259.     for { set i 0 } { $i < $ny2 } { incr i } {
  4260.     append ans "$x0 [expr {$y0 +$i * $ystep}] $z0 "
  4261.     lappend lmesh [list $k [incr k 3]]
  4262.     #set [set meshes]($k) "$k [incr k 3]"
  4263.     }
  4264.     append ans "$x0 [expr {$y0 +$ny2 * $ystep}] $z0 "
  4265.     incr k 3
  4266.     # set $meshes($k) ""
  4267.  
  4268.     set zstep [expr {1.2 * $zmax/double($nz2)}]
  4269.     if { $zstep < $ystep } { set zstep $ystep }
  4270.     
  4271.     for { set i 0 } { $i < $ny2 } { incr i } {
  4272.     append ans "$x0 $y0 [expr {$z0 +$i * $zstep}] "
  4273.     # puts "set [set meshes]($k) \"$k [incr k 3]\""
  4274.     lappend lmesh [list $k [incr k 3]]
  4275.     # set [set meshes]($k) "$k [incr k 3]"
  4276.     }
  4277.     append ans "$x0 $y0 [expr {$z0 +$nz2 * $zstep}] "
  4278.     incr k 3
  4279.     # puts "ans=$ans"
  4280.     append [oloc $win points] $ans
  4281.     
  4282.    # set $meshes($k) ""
  4283.  
  4284. }
  4285.  
  4286. proc addBbox { win } {
  4287.     global plot3dMeshes$win
  4288.     makeLocal $win xmin xmax ymin ymax zmin zmax  cmap
  4289.     linkLocal $win points lmesh 
  4290.     set ll [llength $points]
  4291.      append points " $xmin $ymin $zmin \
  4292.         $xmax $ymin $zmin \
  4293.             $xmin $ymax $zmin \
  4294.             $xmax $ymax $zmin \
  4295.             $xmin $ymin $zmax \
  4296.         $xmax $ymin $zmax \
  4297.             $xmin $ymax $zmax \
  4298.             $xmax $ymax $zmax "
  4299.     foreach  { a b } { 0 1 0 2 2 3 3 1
  4300.                        4 5 4 6 6 7 7 5
  4301.     0 4 1 5 2 6 3 7  }  {
  4302.     set k [expr {$a*3 + $ll}]
  4303.     set l [expr {$b*3 + $ll}]
  4304.     # set plot3dMeshes${win}($k) [list $k $l]
  4305.     lappend lmesh [list $k $l]
  4306.     }
  4307.     lappend lmesh [list $ll]
  4308.     oset $win $cmap,[list $ll [expr {$ll + 3}]] red
  4309.     oset $win $cmap,[list $ll [expr {$ll + 6}]] blue
  4310.     oset $win $cmap,[list $ll [expr {$ll + 12}]] green
  4311.     
  4312.     oset $win special($ll) "drawOval [oget $win c] 3 -fill red -tags axis"
  4313. }
  4314.  
  4315. proc drawOval { c radius args } {
  4316.     set ll [llength $args]
  4317.     set x [lindex $args [expr {$ll -2}]]
  4318.     set y [lindex $args [expr {$ll -1}]]
  4319.     set rest [lrange $args 0 [expr {$ll -3}]]
  4320.     set com [concat $c create oval [expr {$x - $radius}]  [expr {$y - $radius}] [expr {$x + $radius}]  [expr {$y + $radius}] $rest]
  4321.     eval $com
  4322. }
  4323.     
  4324.  
  4325. proc plot3dcolorFun {win z } {
  4326.     makeLocal $win zmin zmax
  4327.     set ncolors 180
  4328.     set tem [expr {(180/$ncolors)*round(($z - $zmin)*$ncolors/($zmax - $zmin+.001))}]
  4329.     #puts "tem=$tem,z=[format %3g $z],[format "#%.2x%.2x%.2x" 50 50 $tem]"
  4330.     return [format "#%.2x%.2x%.2x" [expr {180 -$tem}] [expr {240 - $tem}] $tem]
  4331. }
  4332.  
  4333. proc setupPlot3dColors { win } {
  4334.     upvar #0 [oarray $win] wvar
  4335.     # the default prefix for cmap
  4336.     set wvar(cmap) c1
  4337.     set k 0
  4338.     makeLocal $win colorfun points
  4339.     foreach { x y z } $points {
  4340.     catch { set wvar(c1,$k) [$colorfun $win $z] }
  4341.     incr k 3 
  4342.     }
  4343. }
  4344.  
  4345. proc calculateRotated { win } {
  4346.     set pideg [expr {3.14159/180.0}]
  4347.     linkLocal $win scale
  4348.     makeLocal $win az el rotationcenter xradius zradius yradius
  4349.     set rotmatrix [rotationMatrix [expr {$az * $pideg }] \
  4350.         [expr {$el * $pideg }] \
  4351.       ]
  4352.  
  4353.     # shrink by .2 on z axis
  4354.     # set fac [expr  {[vectorlength $xradius $yradius] / (sqrt(2) * $zradius)}]
  4355.  
  4356.     set rotmatrix [ matMul  $rotmatrix 3 $scale 3 ]
  4357.     set tem [matMul $scale 3 $rotationcenter 1]
  4358.     
  4359.     mkMultLeftFun  $rotmatrix 3 _rot$win
  4360.     set rot _rot$win
  4361.     set ans ""
  4362.     # puts "points=[oget $win points]"
  4363.     if { "$rotationcenter" != "" } {
  4364.     #puts "rotationcenter = $rotationcenter"
  4365.     set constant [vectorOp $tem - [eval $rot $rotationcenter]]
  4366.     mkMultLeftFun  $rotmatrix 3 _rot$win $constant
  4367.     }
  4368.     #puts "win $win"
  4369.     foreach { x y z } [oget $win points] {
  4370.     if { [catch { append ans " " [$rot $x $y $z] } ] } {
  4371.         append ans "  nam nam nam " }
  4372.     }
  4373.     oset $win rotatefun $rot
  4374.     oset $win rotated $ans 
  4375. }
  4376.  
  4377. proc getOrderedMeshIndices { win } {
  4378.  #   global  plot3dMeshes$win
  4379.  #    set meshes plot3dMeshes$win
  4380.     linkLocal $win lmesh
  4381.     # puts "array names $meshes =[array names $meshes ]"
  4382.     # get the list offset by 2, so the lindex indices grab the Z coordinate.
  4383.     # without having to add 2.
  4384.     set pts2 [lrange [oget $win rotated] 2 end]
  4385.     set i 0
  4386.     foreach tem $lmesh {
  4387.         set k [llength $tem]
  4388.        if { [catch {
  4389.         if {  $k == 4 } {
  4390.         set z [expr { ([lindex $pts2 [lindex $tem 0]] \
  4391.             +[lindex $pts2 [lindex $tem 1]] \
  4392.             + [lindex $pts2 [lindex $tem 2]] \
  4393.             + [lindex $pts2 [lindex $tem 3]])/4.0 }]
  4394.     } elseif { $k == 2 } {
  4395.             set z [expr { ([lindex $pts2 [lindex $tem 0]] \
  4396.             +[lindex $pts2 [lindex $tem 1]])/2.0 }]
  4397.     } else {
  4398.         set z 0
  4399.             foreach w $tem {
  4400.         set z [expr {$z + [lindex $pts2 $w] }  ]
  4401.         
  4402.         }    
  4403.         set z [expr { $z/double($k)}]
  4404.         }
  4405.     lappend ans [list $z $i]
  4406.     # append pp($z) "$i "
  4407.     incr i
  4408.     
  4409.          } ]} {
  4410.         set lmesh [lreplace $lmesh $i $i]
  4411.      }
  4412.     }
  4413.     set ttem [lsort -real -index 0 $ans]
  4414.     set ans {}
  4415.     foreach v $ttem {
  4416.     lappend ans [lindex $v 1]
  4417.     }
  4418.     oset $win meshes $ans
  4419.     return
  4420. }
  4421.  
  4422.  
  4423. proc setUpTransforms3d { win } {
  4424.     global screenwindow
  4425.     #set scr $screenwindow
  4426.     # setUpTransforms $win .7
  4427.     # set screenwindow $scr
  4428.     linkLocal $win scale
  4429.         makeLocal $win xcenter ycenter xradius yradius c zmin zmax xmin xmax ymin ymax zradius
  4430.     #dshow xcenter ycenter xradius yradius c zmin zmax xmin xmax ymin ymax zradius
  4431.     set fac .5
  4432.  
  4433.     set delx [$c cget -width]
  4434.     set dely [$c cget -height]
  4435.     set f1 [expr {(1 - $fac)/2.0}]
  4436.  
  4437.     set scale [list [expr {1.5/($xradius)}] 0 0 0 [expr {1.5/($yradius)}] 0 0 0 [expr {1.5/($zradius)}] ]
  4438.  
  4439.     set x1 [expr {$f1 *$delx}]
  4440.     set y1 [expr {$f1 *$dely}]
  4441.     set x2 [expr {$x1 + $fac*$delx}]
  4442.     set y2 [expr {$y1 + $fac*$dely}]
  4443.     # set xmin [expr {($xcenter - $xradius) * 1.5/ ($xradius)}]
  4444.     # set ymin [expr {($ycenter - $yradius) * 1.5/ ($yradius)}]
  4445.     # set xmax [expr {($xcenter + $xradius) * 1.5/ ($xradius)}]
  4446.     # set ymax [expr {($ycenter + $yradius) * 1.5/ ($yradius)}]
  4447.     #puts "RANGES=$xmin,$xmax $ymin,$ymax $zmin,$zmax"
  4448.     desetq "xmin ymin" [matMul $scale 3 "$xmin $ymin 0" 1]
  4449.     desetq "xmax ymax" [matMul $scale 3 "$xmax $ymax 0" 1]
  4450.     #puts "RANGES=$xmin,$xmax $ymin,$ymax $zmin,$zmax"
  4451.     # set transform [makeTransform "$xmin $ymin $x1 $y2" "$xmin $ymax $x1 $y1 " "$xmax $ymin $x2 $y2"]
  4452.    # desetq "xmin xmax ymin ymax" "-2 2 -2 2"
  4453.  
  4454.     set transform [makeTransform "$xmin $ymin $x1 $y2" "$xmin $ymax $x1 $y1 " "$xmax $ymin $x2 $y2"]
  4455.     oset $win transform $transform
  4456.     oset $win transform0 $transform
  4457.     
  4458.     getXtransYtrans $transform rtosx$win rtosy$win
  4459.     getXtransYtrans [inverseTransform $transform] storx$win story$win 
  4460.  
  4461. }
  4462.  
  4463. # 
  4464.  
  4465. proc plot3d { args } {
  4466.     global  plot3dOptions
  4467.     set win [assoc -windowname $args]
  4468.     if { "$win" == "" } {
  4469.     set win [getOptionDefault windowname $plot3dOptions] }
  4470.     clearLocal $win
  4471.     apply mkPlot3d  $win $args
  4472. #    bind $win <Configure> {}    
  4473.     replot3d $win
  4474. }
  4475.  
  4476. proc replot3d { win } {
  4477.     global   printOption plot2dOptions
  4478.     makeLocal $win nsteps zfun data c
  4479.     linkLocal $win parameters sliders
  4480.     
  4481.     oset $win maintitle    "concat \"Plot of z = [oget $win zfun]\""
  4482.     if { [llength $nsteps] == 1 }    {
  4483.     oset $win nsteps \
  4484.         [set nsteps  [list [lindex $nsteps 0] [lindex $nsteps 0]]]
  4485.     }
  4486.     foreach v $data {
  4487.     if { "[assq [lindex $v 0] $plot2dOptions notthere]" != "notthere" } {
  4488.         oset $win [lindex $v 0] [lindex $v 1]
  4489.     }
  4490.     }
  4491.     if { "$sliders" != "" && ![winfo exists $c.sliders] } {
  4492.     addSliders $win
  4493.     }
  4494.  
  4495.     if { "$zfun" != "" } {
  4496.     proc _xf {  x  y } "return \[expr { [sparseWithParams $zfun {x y} $parameters ] } \]"
  4497.     addOnePlot3d $win [calculatePlot3data $win _xf  [lindex $nsteps 0] [lindex $nsteps 1]]
  4498.     # calculatePlot3d $win _xf [lindex $nsteps 0] [lindex $nsteps 1]
  4499.     }
  4500.  
  4501.     if { "$data" != "" } {
  4502.     if { 0 } {
  4503.         puts "here"
  4504.     set ranges [ plot3dGetDataRange [list $data]]
  4505.     linkLocal $win zmin zmax
  4506.     desetq "zmin zmax" [lindex $ranges 2]
  4507.     puts "ranges=$ranges"
  4508.     set some [plot2dRangesToRadius [lindex $ranges 0] [lindex $ranges 1] ""]
  4509.     puts "and now"
  4510.     foreach {v k} $some {
  4511.         puts "oset $win [string range $v 1 end] $k"
  4512.         oset $win [string range $v 1 end] $k
  4513.     }
  4514.         }
  4515.     
  4516.     addOnePlot3d $win $data
  4517.     }
  4518.  
  4519.  
  4520.     setUpTransforms3d $win
  4521.  
  4522.     oset $win colorfun plot3dcolorFun
  4523. #    addAxes $win
  4524.     oset $win cmap c1
  4525.     setupPlot3dColors $win
  4526.     addBbox $win
  4527.     # grab the bbox just as itself
  4528.     global ws_openMath
  4529.     linkLocal $win lmesh
  4530.     if { [llength $lmesh] >   100 * $ws_openMath(speed)  } {
  4531.     # if we judge that rotation would be too slow, we make a secondary list
  4532.     # of meshes (random) including the bbox, and display those. 
  4533.     linkLocal $win  points lmeshBbox pointsBbox
  4534.     set n [llength $lmesh]
  4535.     set lmeshBbox [lrange $lmesh [expr {$n -13}] end]
  4536.     set i 0 ;
  4537.     while { [incr i ] < ( 35*$ws_openMath(speed)) } {
  4538.         set j [expr {round(floor(rand()*($n-13))) }]
  4539.         if { ![info exists temm($j)] } {
  4540.         lappend lmeshBbox [lindex $lmesh $j ]
  4541.         set temm(j) 1
  4542.         }
  4543.     }
  4544.     resetPtsForLmesh $win
  4545.     }
  4546.     oset $win lastAnglesPlotted ""
  4547.     setView $win ignore
  4548. } 
  4549.  
  4550. proc setView { win ignore } {
  4551.     global timer
  4552.     foreach v [after info] {
  4553.      #puts "$v=<[after info $v]>"
  4554.     if { "[lindex [after info $v] 0]" == "setView1" } {
  4555.         after cancel $v
  4556.     }
  4557.     }
  4558.     after 2 setView1 $win
  4559. }
  4560.  
  4561. proc setView1 { win  } {
  4562.     linkLocal $win lastAnglesPlotted points
  4563.     set new [list [oget  $win az] [oget  $win el] ]
  4564.     if { "$new" != "$lastAnglesPlotted" } {
  4565.        makeLocal $win c
  4566.     calculateRotated $win
  4567.     getOrderedMeshIndices $win
  4568.     drawMeshes $win $c
  4569.     oset $win lastAnglesPlotted $new
  4570.     }
  4571. }
  4572.  
  4573. proc setQuick { win on } {
  4574.   linkLocal $win  lmesh  points savedData cmap     lmeshBbox pointsBbox
  4575.     if { $on } {
  4576.     if { ![info exists savedData] && [info exists lmeshBbox] } {
  4577.         set savedData [list $lmesh $points $cmap]
  4578.         set lmesh $lmeshBbox
  4579.         set points $pointsBbox
  4580.         set cmap c2
  4581.     }
  4582.     } else {
  4583.     if { [info exists savedData] } {
  4584.         desetq "lmesh points cmap" $savedData
  4585.         unset savedData
  4586.         oset $win lastAnglesPlotted ""
  4587. }   }   }
  4588.  
  4589.  
  4590. # reduce the set of pointsBbox to include only those needed by lmeshBbox
  4591. proc resetPtsForLmesh { win } {
  4592.     upvar 1 lmeshBbox lmeshBbox
  4593.     upvar 1 pointsBbox pointsBbox
  4594.     upvar 1 points points
  4595.     upvar #0 [oarray $win] wvar
  4596.     set k 0
  4597.     foreach v $lmeshBbox {
  4598.     if { [llength $v] == 1 } {
  4599.         lappend nmesh $v
  4600.     } else {
  4601.         set s ""
  4602.         foreach w $v {
  4603.         if { [info exists tem($w)] } {
  4604.             lappend s $tem($w)
  4605.         } else {
  4606.             set tem($w) $k
  4607.             lappend s $k
  4608.             lappend pointsBbox \
  4609.                 [lindex $points $w] \
  4610.                 [lindex $points [expr {$w +1}]] \
  4611.                 [lindex $points [expr {$w +2}]]
  4612.             catch {set wvar(c2,$k) $wvar(c1,$w)}
  4613.             incr k 3
  4614.         
  4615.         }
  4616.             
  4617.         }
  4618.         lappend nmesh $s
  4619.         if { [info exists wvar(c1,$v)] } {
  4620.         set wvar(c2,$s) $wvar(c1,$v)
  4621.         }
  4622.     }
  4623.     }
  4624.     set lmeshBbox  $nmesh
  4625. }
  4626.  
  4627. proc drawMeshes {win canv} {
  4628.     # $canv delete poly
  4629.     # only delete afterwards, to avoid relinquishing the colors
  4630.     $canv addtag oldpoly withtag poly 
  4631.     $canv delete axis
  4632.     makeLocal $win lmesh rotated cmap
  4633.     upvar #0 [oarray $win] ar
  4634.     proc _xf { x} [info body rtosx$win]
  4635.     proc _yf { y} [info body rtosy$win]
  4636.     foreach { x y z} $rotated { lappend rotatedxy [_xf $x] [_yf $y] 0 }
  4637.  
  4638.     foreach k [oget $win meshes] {
  4639.     #puts "drawOneMesh $win $canv $k"
  4640.     #puts "drawOneMesh $win $canv $k"
  4641.     set mesh [lindex $lmesh $k]
  4642.     set col gray70
  4643.     catch { set col $ar($cmap,[lindex $mesh 0]) }
  4644.     drawOneMesh $win $canv $k $mesh $col
  4645.     }
  4646.     $canv delete oldpoly
  4647. }
  4648.  
  4649.  
  4650. #
  4651.  #-----------------------------------------------------------------
  4652.  # plot3dMeshes  --  given K an index in plot3dPoints(points) 
  4653.  # if this is the index of a lower grid corner, return the other points.
  4654.  # k takes values 0,3,6,9,... the values returned all have a 3 factor,  
  4655.  # and so are true lindex indices into the list of points.
  4656.  # returns {} if this is not a mesh point.
  4657.  #  Results:
  4658.  #
  4659.  #  Side Effects: none... NOTE we should maybe cash this in an array. 
  4660.  #
  4661.  #----------------------------------------------------------------
  4662. #
  4663.  
  4664. proc drawOneMesh { win  canv k mesh color } {
  4665.     #k=i*(ny+1)+j
  4666.     # k,k+1,k+1+nyp,k+nyp
  4667.     upvar 1 rotatedxy ptsxy
  4668.     set n [llength $mesh]
  4669.  
  4670.     foreach kk $mesh {
  4671.     lappend coords [lindex $ptsxy $kk] [lindex $ptsxy [expr {$kk + 1}]]
  4672.     }
  4673.     if { $n <= 2 } {
  4674.     #puts "drawing $k,n=$n $coords, points $mesh "
  4675.     #desetq "a b" $mesh
  4676.     #puts "<[lrange $points $a [expr {$a +2}]]> <[lrange $points $b [expr {$b +2}]]"
  4677.     if { $n == 2 } {
  4678. #        set color gray70
  4679. #        catch { set color [oget $win $cmap,$mesh]}
  4680.             
  4681.         eval $canv create line $coords -tags [list [list axis mesh.$k]] \
  4682.             -fill $color -width 5 
  4683.     } else {
  4684.        # puts "doing special $mesh, $coords"
  4685.         catch { set tem [oget $win special([lindex $mesh 0])]
  4686.         eval [concat $tem $coords]
  4687.     }
  4688.     }
  4689.     } else {
  4690.      eval $canv create polygon $coords -tags [list [list poly mesh.$k]] \
  4691.         -fill $color \
  4692.         -outline black
  4693.     }
  4694. }
  4695.  
  4696. proc doHelp3d { win } {
  4697.  global Parser
  4698.  doHelp $win [join [list \
  4699. { 
  4700.  
  4701. William Schelter's plotter for three dimensional graphics.
  4702.  
  4703. To QUIT this HELP click here.
  4704.  
  4705. By clicking on Zoom, the mouse now allows you \
  4706. to zoom in on a region of the plot.  Each click \
  4707. near a point magnifies the plot, keeping the \
  4708. center at the point you clicked.  Depressing \
  4709. the SHIFT key while clicking zooms in the \
  4710. opposite direction.
  4711.  
  4712. Clicking on Rotate, makes the left mouse button  \
  4713. cause rotation of the image.   The current position \
  4714. can be determined by azimuth and elevation angles \
  4715. which are given under the Config menu.   They may also \
  4716. be specified on the command line.
  4717.  
  4718. To change the equations enter in the entry \
  4719. windows, and click on replot.
  4720.  
  4721. You may print to a postscript printer, or save the plot \
  4722. as a postscript file, by clicking on save.   To change \
  4723. between printing and saving see the Print Options under Config.
  4724.     
  4725. Clicking with the right mouse button and dragging may be used \
  4726. instead of the scroll bars to slide the plot \
  4727. around.
  4728.  
  4729.  
  4730. } $Parser(help)]]
  4731. }
  4732.  
  4733. proc     makeFrame3d { win } {
  4734.   global plot3dPoints
  4735.    set w [makeFrame $win 3d]
  4736.     set top $w
  4737.     catch { set top [winfo parent $w]}
  4738.     catch {
  4739.  
  4740.     wm title $top "Schelter's 3d Plot Window"
  4741.     wm iconname $top "DF plot"
  4742.  #   wm geometry $top 750x700-0+20
  4743.    }
  4744.   
  4745.     pack $w
  4746.  
  4747. }
  4748.     
  4749. proc mkPlot3d { win  args } {
  4750.     global plot3dOptions  printOption [oarray $win] axisGray
  4751.  
  4752.     getOptions $plot3dOptions $args -usearray [oarray $win]
  4753.     #puts "$win width=[oget $win width],args=$args"
  4754.     setPrintOptions $args
  4755.     set printOption(maintitle) ""
  4756.     set wb $win.buttons
  4757.     setupCanvas $win
  4758.    # catch { destroy $win }
  4759.     makeFrame3d $win
  4760.     oset $win sliderCommand sliderCommandPlot3d
  4761.    oset $win noaxisticks 1
  4762.    
  4763.    makeLocal $win buttonFont c
  4764.     bind $c <Motion> "showPosition3d $win %x %y"
  4765.     button $wb.rotate -text "Rotate" -command "setForRotate $win" -font $buttonFont
  4766.    setBalloonhelp $win $wb.rotate {Dragging the mouse with the left button depressed will cause the object to rotate.  The rotation keeps the z axis displayed in an upright position (ie parallel to the sides of the screen), but changes the viewpoint.   Moving right and left changes the azimuth (rotation about the z axis), and up and down changes the elevation (inclination of z axis).   The red,blue and green sides of the bounding box are parallel to the X, Y and Z axes, and are on the smaller side.} 
  4767.  
  4768.    $win.position config -width 15
  4769.     pack $wb.rotate -expand 1 -fill x
  4770.    setForRotate $win
  4771.  
  4772.     
  4773. }   
  4774.  
  4775. proc doConfig3d { win } {
  4776.  
  4777.     
  4778.     desetq "wb1 wb2" [doConfig $win]
  4779.  
  4780.     makeLocal $win buttonFont
  4781.  
  4782.     mkentry $wb1.zfun [oloc $win zfun]  "z=f(x,y)" $buttonFont 
  4783.     mkentry $wb1.nsteps [oloc $win nsteps]  "Number of mesh grids"  $buttonFont 
  4784.     # button .jim.buttons.rot "rotate" -command "bindForRotation"
  4785.     # pack .jim.buttons.rot
  4786.     pack $wb1.zfun  $wb1.nsteps
  4787.     pack        $wb1.zfun  $wb1.nsteps 
  4788.    foreach w {xradius yradius xcenter ycenter zcenter zradius parameters } {
  4789.     mkentry $wb1.$w [oloc $win $w] $w $buttonFont
  4790.     pack $wb1.$w 
  4791.     }
  4792.  
  4793.     scale $wb1.rotxscale -label "azimuth"  \
  4794.         -orient horizontal -length 150 -from -180 -to 180 -resolution 1 \
  4795.         -command "setView $win" -variable [oloc $win az] -tickinterval 120 -font $buttonFont 
  4796.  
  4797.     scale $wb1.rotyscale -label "elevation"  \
  4798.         -orient horizontal -length 150 -from -180 -to 180 -resolution 1 \
  4799.         -command "setView $win" -variable [oloc $win el] -tickinterval 120 -font $buttonFont 
  4800.  
  4801.  
  4802. #    scale $wb1.rotzscale -label "thetaz"  \
  4803. #        -orient horizontal -length 150 -from -180 -to 180 \
  4804. #        -command "setView $win" -variable [oloc $win thetaz] -tickinterval 120 -font $buttonFont 
  4805.  
  4806.     pack   $wb1.rotxscale   $wb1.rotyscale   
  4807.  
  4808. }
  4809.  
  4810.  
  4811. proc showPosition3d { win x y } {
  4812.    # global position c
  4813.     makeLocal $win c
  4814.     set x [$c canvasx $x]
  4815.     set y [$c canvasy $y]
  4816.     set it [ $c find closest $x $y]
  4817.     set tags [$c gettags $it]
  4818.     if { [regexp {mesh[.]([0-9]+)} $tags junk k] } {
  4819.     set i 0
  4820.     set min 1000000
  4821.     set at 0
  4822.     # find closest.
  4823.     foreach {x1 y1} [$c coords $it] {
  4824.         set d [expr {($x1 - $x)*($x1 - $x)+($y1 - $y)*($y1 - $y)}]
  4825.         if { $d < $min} { set at $i ; set min $d }
  4826.         incr i
  4827.     }
  4828.     set mesh [lindex [oget $win lmesh] $k]
  4829.     set ll [lindex $mesh $at]
  4830.     set pt [lrange [oget $win points] $ll [expr {$ll + 2}]]
  4831.     # puts pt=$pt
  4832.     catch { oset $win position [eval [concat "format {(%.2f %.2f %.2f)}" $pt]] }
  4833.     }
  4834. #    oset $win position [format {(%.1f %.1f)} $x $y]
  4835. #    oset $win position \
  4836. #      "[format {(%.2f,%.2f)}  [storx$win [$c canvasx $x]] [story$win [$c canvasy $y]]]"
  4837. }
  4838.  
  4839.  
  4840.  
  4841. #
  4842.  #-----------------------------------------------------------------
  4843.  #
  4844.  # rotateRelative --  do a rotation indicated by a movement
  4845.  # of dx,dy on the screen.  
  4846.  #
  4847.  #  Results:
  4848.  #
  4849.  #  Side Effects: 
  4850.  #
  4851.  #----------------------------------------------------------------
  4852. #
  4853.  
  4854. proc rotateRelative { win x1 x2 y1 y2 } {
  4855.     makeLocal $win c az el rotatefun
  4856.     set x1 [$c canvasx $x1]
  4857.     set x2 [$c canvasx $x2]
  4858.     set y1 [$c canvasy $y1]
  4859.     set y2 [$c canvasy $y2]
  4860.     set xx [expr {$x2-$x1}]
  4861.     set yy [expr {($y2-$y1)}]
  4862.     set res [$rotatefun 0 0 1]
  4863.     set res1 [$rotatefun 0 0 0]
  4864.     set fac [expr {([lindex $res 1] > [lindex $res1 1] ? -1 : 1) }] ;
  4865.    # puts "fac=$fac,[lindex $res 1],[lindex $res1 1]"
  4866.     oset $win az [reduceMode360 [expr   {round($az + $fac *  $xx /2.0) }]]
  4867.     oset $win el [reduceMode360 [expr   {round($el -  $yy /2.0) }]]
  4868.     setView $win ignore
  4869.  
  4870.  
  4871. }
  4872.  
  4873. proc reduceMode360 { n } {
  4874.   return [  expr fmod(($n+180+5*360),360)-180]
  4875.  
  4876. }
  4877.  
  4878. proc setForRotate { win} {
  4879.     makeLocal $win c
  4880.     $c delete printrectangle
  4881.     bind $c  <Button-1> "setQuick $win 1 ; doRotateScreen $win %x %y "
  4882.     bind $c  <ButtonRelease-1> "setQuick $win 0 ; setView $win ignore"
  4883. }
  4884. proc doRotateScreen { win x y } {
  4885.     makeLocal $win c
  4886.     oset $win lastx $x
  4887.     oset $win lasty $y
  4888.     bind $c <B1-Motion> "doRotateScreenMotion $win %x %y"
  4889.     
  4890.  
  4891. }
  4892.  
  4893. proc doRotateScreenMotion {win x y } {
  4894.     makeLocal $win lastx lasty
  4895.     set dx [expr {$x - $lastx}]
  4896.     set dy [expr {$y - $lasty}]
  4897.     if { [vectorlength $dx $dy] < 4 } { return }
  4898.     rotateRelative $win $lastx $x $lasty $y
  4899.     oset $win lastx $x
  4900.     oset $win lasty $y
  4901.     
  4902. }
  4903.  
  4904.     
  4905. proc sliderCommandPlot3d { win var val } {
  4906.     linkLocal $win recompute
  4907.     updateParameters $win $var $val
  4908.     set com "recomputePlot3d $win"
  4909. # allow for fast move of slider...    
  4910.     after cancel $com
  4911.     after 10 $com
  4912. }
  4913.  
  4914. proc recomputePlot3d { win } {
  4915.     linkLocal $win  recompute
  4916.     if { [info exists recompute]  } {
  4917.     incr recompute
  4918.     return
  4919.     } else {
  4920.         set recompute 1
  4921.     }
  4922.     set redo 0
  4923.     while { $redo != $recompute } {
  4924.     set redo $recompute
  4925. #    puts "replot3d $win,[oget $win parameters]"
  4926.     catch {replot3d $win }
  4927.     update
  4928.     }
  4929.     unset recompute
  4930. }
  4931.  
  4932.  
  4933. ## endsource plot3d.tcl
  4934. ## source nplot3d.tcl
  4935.  
  4936. ###### nplot3d.tcl ######
  4937. ############################################################
  4938. # Netmath       Copyright (C) 1998 William F. Schelter     #
  4939. # For distribution under GNU public License.  See COPYING. # 
  4940. ############################################################
  4941.  
  4942. # source plotting.tcl ; source nplot3d.tcl ; catch { destroy .plot3d} ;  plot3d -zfun "" -data $sample -xradius 10 -yradius 10
  4943. # newidea:
  4944. # { plot3d
  4945. #  { gridequal {minx maxx} {miny maxy}
  4946. #   {{z00 z01 z02 .. z0n } { z10 z11 z12 .. z1n} {..  } ...}
  4947. #  { grid {x0 x1  xm} {y0 y1 yn } miny maxy}
  4948. #   {{z00 z01 z02 .. z0n } { z10 z11 z12 .. z1n} {..  } ...}
  4949. #  { xyzgrid {{x00 y00 z00 x01 y01 z01 .. x0  }{x0 x1  xm} {y0 y1 yn } miny maxy}
  4950. #   {{z00 z01 z02 .. z0n } { z10 z11 z12 .. z1n} {..  } ...}
  4951. # tclMesh(2*[0,0,0,0,0;1,1,1,1,1]-1,2*[0,1,1,0,0;0,1,1,0,0]-1,2*[0,0,1,1,0;0,0,1,1,0]-1)
  4952.   
  4953. #     { gridequal { 
  4954.  
  4955. # z00 z01 .. all belong to x=minx and y = miny,.... up y=maxy in n+1 steps
  4956. #{ grid {minx maxx} {miny maxy}
  4957. #  {{z00 z01 z02 .. z0n } { z10 z11 z12 .. z1n} {..  } ...}
  4958. # }
  4959. # where a mesh(1) {z00 z01 z11 z10} above 
  4960.  
  4961.  
  4962.  
  4963. # { mesh {{{x00 y00 z00 } { x01 y01 z01} { x02 y02 z02}  ..}{{x10 y10 z10} {x11 y11 z11} ......} ..}}
  4964. # mesh(1) = P00 P01 P11 P10
  4965.  
  4966. set sample { variable_grid { 0 1 2 } { 3 4 5} { {21 111 2} {3 4 5 } {6 7 8 }}}
  4967. set sample { variable_grid { 0 1 2 } { 3 4 5} { {0 1 2} {3 4 5 } {6 7 8 }}}
  4968. set sample { matrix_mesh {{0 1} { 2 3 } {4 5 }}  {{0 1} { 2 3 } {4 5 }}  {{0 1} { 2 3 } {4 5 }} }
  4969. set sample { matrix_mesh {{0 1 2} {0 1 2 } {0 1 2 }} {{3 4 5} {3 4 5} {3 4 5}} { {0 1 2} {3 4 5 } {6 7 8 }}}
  4970. set sample1 { variable_grid  { 1 2 3 4 5 6 7 8 9 10 }
  4971.  { 1 2 3 }
  4972.  {  { 0 0 0 0 0 0 0 0 0 0 }
  4973.  { 0 0.68404 1.28558 1.73205 1.96962 1.96962 1.73205 1.28558 0.68404 2.44921e-16 }
  4974.  { 0 1.36808 2.57115 3.4641 3.93923 3.93923 3.4641 2.57115 1.36808 4.89843e-16 }
  4975.  }  }
  4976.  
  4977. set sample { matrix_mesh  {  { 0 0 0 0 0 }
  4978.  { 1 1 1 1 1 }
  4979.  }  {  { 0 1 1 0 0 }
  4980.  { 0 1 1 0 0 }
  4981.  }  {  { 0 0 1 1 0 }
  4982.  { 0 0 1 1 0 }
  4983.  }  } 
  4984.  
  4985.     
  4986. proc  fixupZ { } {
  4987.     uplevel 1 {
  4988.     if { [catch { expr $z + 0 } ] } {
  4989.         set z nam
  4990.     }  elseif { $dotruncate  &&  ($z > $zzmax || $z < $zzmin) } {
  4991.         set z nam
  4992.         
  4993.     } else {
  4994.         if { $flatten } {
  4995.         if { $z > $zzmax } { set z $zzmax } elseif {
  4996.             $z < $zzmin } { set z $zzmin }}
  4997.             
  4998.             if { $z < $zmin }  { set zmin $z } elseif {
  4999.             $z > $zmax } { set zmax $z }
  5000.             }
  5001.         }
  5002. }
  5003.  
  5004.  
  5005. proc vectorLength { v } {
  5006.     expr { sqrt(1.0 * [lindex $v 0]*[lindex $v 0] + [lindex $v 1]*[lindex $v 1] + [lindex $v 2]*[lindex $v 2]) }
  5007. }
  5008.  
  5009. proc normalizeToLengthOne { v } {
  5010.     set norm [expr { sqrt(1.0 * [lindex $v 0]*[lindex $v 0] + [lindex $v 1]*[lindex $v 1] + [lindex $v 2]*[lindex $v 2]) }]
  5011.     if { $norm != 0.0 } {
  5012.     return [list [expr { [lindex $v 0] / $norm  } ] \
  5013.         [expr { [lindex $v 1] / $norm  } ] \
  5014.         [expr { [lindex $v 2] / $norm  } ] ]
  5015.      
  5016.     } else { return "1.0 0.0 0.0 " }
  5017. }
  5018.     
  5019.     
  5020.  
  5021. proc vectorCross { x1 x2 }  {
  5022.      list \
  5023.       [expr { [lindex $x1 1]*[lindex $x2 2]- [lindex $x2 1]*[lindex $x1 2]}] \
  5024.       [expr { [lindex $x1 2]*[lindex $x2 0]- [lindex $x2 2]*[lindex $x1 0] } ] \
  5025.       [expr { [lindex $x1 0]*[lindex $x2 1]- [lindex $x2 0]*[lindex $x1 1] }]
  5026. }
  5027.     
  5028. proc linspace { a b n } {
  5029.     if { $n < 2 } { error "from $a to $b requires at least 2 points" }
  5030.     set del [expr {($b - $a)*1.0/($n -1)  }]
  5031.     for { set i 0 } { $i < $n } { incr i } {
  5032.     lappend ans [expr {$a + $del * $i}]
  5033.     }
  5034.     return $ans
  5035. }
  5036.  
  5037.  
  5038. proc addOnePlot3d { win data } {
  5039.     upvar #0 plot3dMeshes$win meshes 
  5040.     #puts " adding meshes = plot3dMeshes$win"
  5041.     #puts "data=$data"
  5042.     linkLocal $win points zmax zmin zcenter zradius rotationcenter xradius yradius xmin xmax ymin ymax lmesh
  5043.     makeLocal $win flatten 
  5044.     catch { unset  meshes }
  5045.     set points ""
  5046.  
  5047.  
  5048.     set dotruncate [expr ![catch {expr {$zradius + 1} }]]
  5049.     set k [llength $points]
  5050.     set type [lindex $data 0]
  5051.     # in general the data should be a list of plots..
  5052.     if { [lsearch {grid mesh variable_grid matrix_mesh }  $type ]>=0 } {
  5053.     set alldata [list $data]
  5054.     } else {set alldata $data}
  5055.     foreach data $alldata {    
  5056.     set type [lindex $data 0]
  5057.     if { "$type" == "grid" } {
  5058.     desetq "xmin xmax" [lindex $data 1]
  5059.     desetq "ymin ymax" [lindex $data 2]
  5060.     set pts [lindex $data 3]
  5061.     
  5062.     set ncols [llength $pts]
  5063.     set nrows  [llength [lindex $pts 0]]
  5064.     set data [list variable_grid [linspace $xmin $xmax $ncols] \
  5065.         [linspace $ymin $ymax $nrows] \
  5066.         $pts ]
  5067.     }
  5068.     if { "$type" == "variable_grid" } {
  5069.     desetq "xrow yrow zmat" [lrange $data 1 end]
  5070.     # puts "xrow=$xrow,yrow=$yrow,zmat=$zmat"
  5071.     set nx [expr {[llength $xrow] -1}]
  5072.     set ny [expr {[llength $yrow] -1}]
  5073.     #puts "nx=$nx,ny=$ny"
  5074. #    set xmin [lindex $xrow 0]
  5075. #    set xmax [lindex $xrow $nx]
  5076. #    set ymin [lindex $yrow 0]
  5077. #    set ymax [lindex $yrow $ny]
  5078.     desetq "xmin xmax" [minMax $xrow ""]
  5079.     desetq "ymin ymax" [minMax $yrow ""]
  5080.     desetq "zmin zmax" [matrixMinMax [list $zmat]]
  5081. #    puts "and now"
  5082. #    dshow nx xmin xmax ymin ymax zmin zmax
  5083.     if { $dotruncate } {
  5084.         if { $flatten } { set dotruncate 0 }
  5085.  
  5086.         set zzmax [expr {$zcenter + $zradius}]
  5087.         set zzmin [expr {$zcenter - $zradius}]
  5088.         #puts "zzmax=$zzmax,$zzmin"
  5089.     } else { set flatten 0 }
  5090.  
  5091.  
  5092.  
  5093.     for {set j 0} { $j <= $ny } { incr j} {
  5094.         set y [lindex $yrow $j]
  5095.         set row [lindex $zmat $j]    
  5096.     for {set i 0} { $i <= $nx } { incr i} {
  5097.         set x [lindex $xrow $i]
  5098.         set z [lindex $row $i]
  5099.         #puts "x=$x,y=$y,z=$z, at ($i,$j)"
  5100.         fixupZ 
  5101.         if { $j != $ny && $i != $nx } {
  5102.         lappend lmesh [list $k [expr { $k+3 }] \
  5103.             [expr { $k+3+($nx+1)*3 }] \
  5104.               [expr { $k+($nx+1)*3 }]]
  5105.         }
  5106.           incr k 3
  5107.       lappend points $x $y $z
  5108.       }
  5109.     }
  5110.     } elseif { "$type" == "matrix_mesh" } {
  5111.     
  5112.     desetq "xmat ymat zmat" [lrange $data 1 end]
  5113.     foreach v {x y z} {
  5114.         
  5115.         
  5116.         desetq "${v}min ${v}max" [matrixMinMax [list [set ${v}mat]]]
  5117.         
  5118.     }
  5119.     #puts "zrange=$zmin,$zmax"
  5120.     set nj [expr {[llength [lindex $xmat 0]] -1 }]
  5121.     set ni [expr {[llength $xmat ] -1 }]
  5122.     set i -1
  5123.     set k [llength $points]
  5124.     foreach rowx $xmat rowy $ymat rowz $zmat {
  5125.         set j -1
  5126.         incr i
  5127.         if { [llength $rowx] != [llength $rowy] } {
  5128.         error "mismatch rowx:$rowx,rowy:$rowy"
  5129.         }
  5130.         if { [llength $rowx] != [llength $rowz] } {
  5131.         error "mismatch rowx:$rowx,rowz:$rowz"
  5132.         }
  5133.         foreach x $rowx y $rowy z $rowz {
  5134.         incr j
  5135.         if { $j != $nj && $i != $ni } {
  5136.         #puts "tes=($i,$j) $x, $y, $z"
  5137.             lappend lmesh [ list \
  5138.                 $k [expr { $k+3 } ] [expr { $k + 3  + ($nj+1)*3}] \
  5139.                 [expr { $k+($nj+1)*3 }] ]
  5140.         }
  5141.         incr k 3
  5142.         lappend points $x $y $z
  5143.         }
  5144.     }
  5145.     } elseif { 0 && "$type" == "mesh" } {
  5146.   # walk thru compute the xmin, xmax, ymin , ymax...
  5147.   # and then go thru setting up the mesh array..
  5148.   # and maybe setting up the color map for these meshes..
  5149.   #
  5150.     # { mesh {{{x00 y00 z00 } { x01 y01 z01} { x02 y02 z02}  ..}{{x10 y10 z10} {x11 y11 z11} ......} ..}}
  5151. # mesh(1) = P00 P01 P11 P10
  5152.     set mdata [lindex $data 1]
  5153.     set nx [llength $mdata]
  5154.     set ny [llength [lindex $mdata 0]]
  5155.     
  5156.     for {set i 0} { $i <= $nx } { incr i} {
  5157.     set pts [lindex $mdata $i]
  5158.     set j 0
  5159.     foreach { x y z} $pts {
  5160.         fixupZ $z
  5161.         if { $j != $ny && $i != $nx } {
  5162.         lappend lmesh [list 
  5163.             $k [expr { $k+3 }] [expr { $k+3+($ny+1)*3 }] \
  5164.             [expr { $k+($ny+1)*3 }] ]
  5165.         }
  5166.         }
  5167.         incr k 3
  5168.         lappend points $x $y $z
  5169.         incr j
  5170.     }
  5171.     }
  5172.    }
  5173.     foreach v { x y z } {
  5174.     set a [set ${v}min]
  5175.     set b  [set ${v}max]
  5176.     if { $a == $b } {
  5177.         set ${v}min [expr {$a -1}]
  5178.         set ${v}max [expr {$a +1}]
  5179.     }
  5180.     set ${v}radius [expr {($b - $a)/2.0}]
  5181.     set ${v}center [expr {($b + $a)/2.0}]
  5182.     }
  5183.     if { "$rotationcenter" == "" } {
  5184.     set rotationcenter "[expr {.5*($xmax + $xmin)}] [expr {.5*($ymax + $ymin)}]   [expr {.5*($zmax + $zmin)}] "
  5185.     }
  5186.     
  5187.     #puts "meshes data=[array get meshes]"
  5188.     #global plot3dMeshes.plot3d
  5189.     #puts "array names plot3dMeshes.plot3d = [array names plot3dMeshes.plot3d]"
  5190. }
  5191.  
  5192. proc vectorDiff { x1 x2 } {
  5193.     list [expr { [lindex $x1 0] - [lindex $x2 0] }] \
  5194.         [expr { [lindex $x1 1] - [lindex $x2 1] }] \
  5195.         [expr { [lindex $x1 2] - [lindex $x2 2] }]
  5196. }
  5197.  
  5198.  
  5199. proc oneCircle { old2 old1 pt radius nsides { angle 0 } } {
  5200.     set dt  [expr {  3.14159265358979323*2.0/($nsides-1.0) + $angle }]
  5201.     for  { set i 0 } { $i < $nsides } { incr i } {
  5202.     set t [expr {$dt*$i }]
  5203.     lappend ans [expr { $radius*([lindex $old2 0]*cos($t) + [lindex $old1 0] * sin($t)) + [lindex $pt 0] } ] \
  5204.         [expr { $radius*([lindex $old2 1]*cos($t) + [lindex $old1 1] * sin($t)) + [lindex $pt 1] } ] \
  5205.         [expr { $radius*([lindex $old2 2]*cos($t) + [lindex $old1 2] * sin($t)) + [lindex $pt 2] } ]
  5206.     }
  5207.     return $ans
  5208. }
  5209.  
  5210. proc curve3d { xfun yfun zfun trange } {
  5211.     foreach u { x y z} {
  5212.     set res [parseConvert [set ${u}fun] -variables t]
  5213.     proc _${u}fun { t } [list expr [lindex [lindex $res 0] 0]]
  5214. }   }
  5215.  
  5216. proc tubeFromCurveData { pts nsides radius } {
  5217.     set n [llength $pts] ;
  5218.     set closed [ expr { [vectorLength [vectorDiff [lindex $pts 0] [lindex $pts end]]] < .02} ]
  5219.     if { $closed } {
  5220.     set f1 [expr {$n -2}]
  5221.     set f2 1
  5222.     } else { set f1 0
  5223.      set f2 1
  5224.     }
  5225.     set delta [vectorDiff [lindex $pts $f2] [lindex $pts $f1]]
  5226.     if { [lindex $delta 0] == 0 && [lindex $delta 1] == 0 && [lindex $delta 2] == 0 } { set delta "0 0 1.0" }
  5227.     set old ".6543654 0.0765456443 0.2965433"
  5228.     set old1 [normalizeToLengthOne [vectorCross $delta $old]]
  5229.     set n1 $old1
  5230.     set n2 [normalizeToLengthOne [vectorCross $delta $old1]]
  5231.     set first1 $n1 ; set first2 $n2
  5232.     
  5233.     lappend ans [oneCircle $n2   old1 [lindex $pts 0]]
  5234.     for { set j 1 } { $j < $n -1 } { incr j } {
  5235.     set delta [vectorDiff [lindex $pts $j] [lindex $pts [expr {$j+1}]]]
  5236.     if { [lindex $delta 0] == 0 && [lindex $delta 1] == 0 && [lindex $delta 2] == 0 } { set delta $old
  5237.     }
  5238.     set old $delta
  5239.     set old1 [normalizeToLengthOne [vectorCross $delta $n1]]
  5240.     set old2 [normalizeToLengthOne [vectorCross $delta $n2]]
  5241.     set n2 $old1
  5242.     set n1 $old2
  5243.     lappend ans [oneCircle $n2 $n1 [lindex $pts $j] $radius $nsides]
  5244. }
  5245.     if { $closed } {
  5246.     set f2 1 ; set f1 [expr {$n -2}] ; set f3 0
  5247.     } else {
  5248.     set f1 [expr {$n -2}] ; set f2 [expr {$n-1}] ; set f3 $f2
  5249.     }
  5250.  
  5251.     set delta [vectorDiff [lindex $pts $f2] [lindex $pts $f1]]
  5252.     if { [lindex $delta 0] == 0 && [lindex $delta 1] == 0 && \
  5253.         [lindex $delta 2] == 0 } { set delta $old }
  5254.     set old1 [normalizeToLengthOne [vectorCross delta $n1]]
  5255.     set old2 [normalizeToLengthOne [vectorCross $n2 $delta]]
  5256.     set n2 $old1 ; set n1 $old2
  5257.     if { $closed } {
  5258.     set angle [vangle $first1 $n1]
  5259.     set n1 $first1 ; st n2 $first2;
  5260.     }
  5261.     lappend ans [oneCircle $n2 $n1 [lindex $pts $f3] $radius $nsides $angle]
  5262.    return $ans
  5263. }
  5264.  
  5265.  
  5266. #
  5267.  #-----------------------------------------------------------------
  5268.  #
  5269.  # vangle --  angle between two unit vectors
  5270.  #
  5271.  #  Results: an angle
  5272.  #
  5273.  #  Side Effects: none.
  5274.  #
  5275.  #----------------------------------------------------------------
  5276. #
  5277. proc vangle { x1 x2 } {
  5278.     set dot [expr { [lindex $x1 0]*[lindex $x2 0] +\
  5279.          [lindex $x1 1]*[lindex $x2 1] +\
  5280.          [lindex $x1 2]*[lindex $x2 2]} ]
  5281.     if { $dot >= 1 } { return 0.0 }
  5282.     if { $dot <= -1.0 } { return 3.141592653589 }
  5283.     return [expr { acos($dot) } ]
  5284. }
  5285.  
  5286. ## endsource nplot3d.tcl
  5287.  
  5288. # from shell 
  5289. # wish8.0 plotting.tcl -eval {plot2d -xfun  x^2+3}
  5290. # or in html
  5291. # <embed src=plotting.tcl eval="plot2d -xfun  x^2+3" >
  5292. #
  5293.  
  5294.  
  5295.  
  5296. omPlotAny [exec cat [lindex $argv 0]]
  5297.