############################################# ##### Copyright William Schelter 1997 ####### ############################################# set ws_openMath(date) 01/29/2001 ###### preamble.tcl ###### ############################################################ # Netmath Copyright (C) 1998 William F. Schelter # # For distribution under GNU public License. See COPYING. # ############################################################ set ws_openMath(clicks_per_second) 1000000 # get the number of clicks per second on this machine.. after idle {after 1000 "set ws_openMath(clicks_per_second) \[expr 1.0 *( \[clock clicks\] - [clock clicks])\]" } catch { # the following will be defined only in the plugin array set embed_args [getattr browserArgs] proc wm { args } {} } proc myrand {} { return .[string range [expr abs([clock clicks]*[clock clicks])] 1 end] } ## source send-some.tcl ###### send-some.tcl ###### ############################################################ # Netmath Copyright (C) 1998 William F. Schelter # # For distribution under GNU public License. See COPYING. # ############################################################ # Usage: # catch {close $socket} # source send-some.tcl ; openConnection $tohost $port $magic $program # one linux14 do # run-one.tcl octave 4448 billy1 # then from any machine do: # can also open maxima at same time # source send-some.tcl ; openConnection linux14 4448 billy1 octave # then # sendOneWait octave 2+3 # 5 # If you specified -debug when starting the server then you can # evaluate tcl commands in the process controlling 'program' # eg: sendCommand octave "list 1 1" ## source readdata.tcl ###### readdata.tcl ###### ############################################################ # Netmath Copyright (C) 1998 William F. Schelter # # For distribution under GNU public License. See COPYING. # ############################################################ # #----------------------------------------------------------------- # # readDataTilEof -- read data from CHANNEL appending to VAR # allowing no more than TIMEOUT milliseconds between reads. # # Results: 1 on success, and -1 if it fails or times out. # # Side Effects: CHANNEL will be closed and the global variable VAR will # be set.. # #---------------------------------------------------------------- # proc readDataTilEof { channel var timeout } { global readDataDone_ _readDataData global readDataDone_ upvar 1 $var variable set _readDataData "" set readDataDone_ 0 set $var "" after $timeout "set readDataDone_ -1" fconfigure $channel -blocking 0 fileevent $channel readable "readDataTilEof1 $channel _readDataData $timeout" myVwait readDataDone_ after cancel "set readDataDone_ -1" catch { close $channel} set res $readDataDone_ if {$res > 0 } { append variable $_readDataData } return $res } proc readDataTilEof1 { channel var timeout} { global readDataDone_ $var set new [read $channel] append $var $new if { [eof $channel] } { set readDataDone_ 1 close $channel } else { after cancel "set readDataDone_ -1" after $timeout "set readDataDone_ -1" } } ## endsource readdata.tcl ## source getdata1.tcl ###### getdata1.tcl ###### ############################################################ # Netmath Copyright (C) 1998 William F. Schelter # # For distribution under GNU public License. See COPYING. # ############################################################ # #----------------------------------------------------------------- # # readAllData -- read data from CHANNEL. # Options: -tovar variable (store in this global variable) # -mimeheader store in alist the mime values # and oset $sock contentlength if # -tochannel (store in channel) # -timeout (for non action) # -translation (for the sock) # -chunksize size to do for each read between updating % # -command a call back run on each chunk # If -command is not specified, wait and return the result code. # Value of -1 means a timeout, and value of >1 means success. # If command is specified, call command each time data is read, # with 1 argument appended, the result code. # allowing no more than TIMEOUT millisconds between reads. # We set up local variables for the $CHANNEL # result # bytesread (after the header if one specified) # mimeheader (extracted) # length (0 if not provied by mime header) # COMMAND can access # to examine the data read so far. # # Results: 1 on success, and -1 if it fails or times out. # # Side Effects: CHANNEL will be closed and the global variable VAR will # be set.. # #---------------------------------------------------------------- # proc readAllData { sock args } { global readAllData [oarray $sock] ws_openMath array set [oarray $sock] { timeout 5000 command "" tochannel "" translation binary chunksize 2024 mimeheader "" tovar "" result "" done 0 usecache 0 percent 0 bytesread 0 headervalue "" contentlength -1 } oset $sock begin [clock clicks] foreach { key val } $args { #puts " oset $sock [string range $key 1 end] $val" oset $sock [string range $key 1 end] $val } #puts "locals:[array get [oarray $sock]]" # puts "args=$args" if { "[oget $sock translation]" != "" } { fconfigure $sock -translation [oget $sock translation] } fconfigure $sock -blocking 0 catch { $ws_openMath(status_window).scale \ config -variable [oloc $sock percent] } lappend [oloc $sock after] [after [oget $sock timeout] "oset $sock done -1"] if { "[oget $sock mimeheader]" != "" } { fileevent $sock readable "readMimeHeader $sock" } else { fileevent $sock readable "readAllData1 $sock" } if { "[oget $sock command]" == "" } { oset $sock docommand 0 return [wrWaitRead $sock] } else { oset $sock docommand 1 # the command will do things and maybe caller will vwait.. return "" } } # #----------------------------------------------------------------- # # readMimeHeader -- read from SOCK until end of mime header. # this is done as a fileevent. Store result in $sock local HEADERVALUE. # # Results: none # # Side Effects: data read, and the mime header decoded and stored. # #---------------------------------------------------------------- # proc readMimeHeader { sock } { global [oarray $sock] set result "" set ans "" while { 1 } { set n [gets $sock line] if { $n < 0 } { if { [eof $sock] } { oset $sock done -1 close $sock return } append [oloc $sock result] $result\n break } if { $n <=1 && ($n==0 || "$line" == "\r") } { # we are done the header append [oloc $sock result] $result\n regsub -all "\r" [oget $sock result] "" result set lis [split $result \n] foreach v $lis { if { [regexp "^(\[^:]*):\[ \t]*(.*)\$" $v junk key val] } { lappend ans [string tolower $key] $val } } oset $sock headervalue $ans oset $sock contentlength [assoc content-length $ans -1] if { [oget $sock usecache] } { set result [tryCache [oget $sock cachename] $ans] if { "$result" != "" } { oset $sock bytesread [string length $result] wrFinishRead $sock return } } oset $sock percent 0 oset $sock bytesread 0 oset $sock result "" #puts "mimeheader = <$ans>" #puts "switching to readAllData1 $sock, [eof $sock]" fileevent $sock readable "readAllData1 $sock" #puts "doing readAllData1 $sock" #if { [ catch { readAllData1 $sock } err ] } { # puts "err=$err" #} return } append result $line\n } } proc readAllData1 { sock } { #puts "readAllData1 $sock" ; flush stdout global ws_openMath [oarray $sock] makeLocal $sock timeout tovar tochannel docommand chunksize after contentlength begin upvar #0 [oloc $sock bytesread] bytesread #puts "readAllData1 $sock, bytes=$bytesread" ; flush stdout if { [catch { foreach v $after { after cancel $v } while { 1 } { if { "$tochannel" != "" } { if { [eof $sock] } { wrFinishRead $sock return finished } else { set amt [expr { $contentlength >= 0 ? ($chunksize < $contentlength - $bytesread ? $chunksize : ($contentlength -$bytesread)) : $chunksize } ] set chunksize $amt set n [unsupported0 $sock $tochannel $chunksize] } } else { set res [read $sock $chunksize] set n [string length $res] append [oloc $sock result] $res } incr bytesread $n if { $n == 0 } { if { [eof $sock] } { wrFinishRead $sock return finished } } set ws_openMath(load_rate) "[expr {round ($bytesread * ($ws_openMath(clicks_per_second)*1.0 / ([clock clicks] - $begin)))}] bytes/sec" if { $contentlength > 0 } { oset $sock percent \ [expr {$bytesread * 100.0 / $contentlength }] } if { $docommand } { catch { uplevel #0 [oget $sock command] } } # puts "percent=[oget $sock percent],bytes=[oget $sock bytesread]" if { $contentlength >= 0 && $bytesread >= $contentlength } { wrFinishRead $sock return finished } if { $n <= $chunksize } { break } } } errmsg ] } { if { "$errmsg" == "finished" } { return } else { global errorInfo ; error "error: $errmsg , $errorInfo" } } lappend [oloc $sock after] \ [after $timeout "oset $sock done -1"] } # #----------------------------------------------------------------- # # wrFinishRead -- run at the EOF. It will run the COMMAND one last # time and look after setting the global variables with the result, # closing the channel(s). # # Results: the $sock variable 'done', 1 for success, -1 for failure. # # Side Effects: many! # #---------------------------------------------------------------- # proc wrFinishRead { sock } { makeLocal $sock mimeheader contentlength tovar tochannel headervalue \ bytesread docommand #puts "entering wrFinishRead" ; flush stdout if { "$mimeheader" != "" } { uplevel #0 set $mimeheader \[oget $sock headervalue\] } if { "$tovar" != "" } { uplevel #0 set $tovar \[oget $sock result\] } else { catch { close $tochannel } } if { $contentlength < 0 || $bytesread >= $contentlength } { oset $sock done 1 } else { oset $sock done -1 } catch { close $sock } if { $docommand } { catch { uplevel #0 [oget $sock command] } } set res [oget $sock done] #puts "wrFinishRead, tovar=$tovar,tochannel=$tochannel,res=$res,bytesread=$bytesread" clearLocal $sock oset $sock done $res return $res } proc wrWaitRead { sock } { #puts "entering wrWaitRead" global [oarray $sock] if { [oget $sock done] == 0 } { myVwait [oloc $sock done] } #vwait [oloc $sock done] set res [oget $sock done] return $res } proc testit { addr usecommand args } { if { [regexp {//([^/]+)(/.*)$} $addr junk server path] } { set sock [socket $server 80] #puts "server=$server" # fconfigure $sock -translation binary #puts "GET $path HTTP/1.0\n" puts $sock "GET $path HTTP/1.0\nMIME-Version: 1.0\nAccept: text/html\n\nhi there" ; flush $sock proc _joe { sock } { makeLocal $sock percent contentlength bytesread puts "percent=$percent,contentlength=$contentlength,bytesread=$bytesread"} if { $usecommand } { eval readAllData $sock -command [list "_joe $sock"] $args wrWaitRead $sock } else { eval readAllData $sock $args } catch { close $sock } } } # #----------------------------------------------------------------- # # tryGetCache -- look up PATH (eg http://www.ma.utexas.edu:80/...) # in the cache, and if you find success and a matching ETAG, # then return the data in the file # # Results: The cached data in FILE or "" # # Side Effects: Will remove the file if the current etag differs. # #---------------------------------------------------------------- # proc tryGetCache { path alist } { global ws_Cache ws_openMath set tem [ws_Cache($path)] if { "$tem" != "" } { set filename [file join $ws_openMath(cachedir) [lindex $tem 1]] set etag [assoc etag $alist] if { "$etag" != "" } { if { "[lindex $tem 0]" == "$etag" } { if { ! [catch { set fi [open $filename r] }] } { fconfigure $fi -translation binary set result [read $fi] close $fi return $result } } else { # cache out of date. if { [file exists $filename] } { file delete $filename return "" } } } } } set ws_openMath(cachedir) ~/.netmath/cache proc saveInCache { path etag result} { global ws_Cache ws_openMath set cachedir $ws_openMath(cachedir) # todo add a catch set type [lindex [split [file tail $path] .] 1] set count 0 while [ file exists [set tem [file join $cachedir $count$etag.$type]]] { incr count } set fi [open $tem w] #puts "writing $tem" fconfigure $fi -translation binary puts -nonewline $fi $result close $fi set ws_Cache($path) [list $etag [file tail $tem]] set fi [open [cacheName index.dat] a] puts $fi "[list [list $path]] {$ws_Cache($path)}" close $fi } proc cleanCache { } { global ws_Cache catch { foreach v [glob [cacheName *]] { catch { file delete $v } } } catch { unset ws_Cache } } proc cacheName { name } { global ws_openMath return [ file join $ws_openMath(cachedir) $name] } # #----------------------------------------------------------------- # # readAndSyncCache -- read the cache index.dat # and remove duplicates removing files, and if necessary save # the file out. Normally this would be done at start up. # # Results: # # Side Effects: # #---------------------------------------------------------------- # proc readAndSyncCache { } { global ws_openMath ws_Cache if { [catch { set fi [open [cacheName index.dat] r] } ] } { return } set all [read $fi] #puts "all=$all" set lis [split $all \n] #puts "lis=$lis" set doWrite 0 foreach v $lis { set key [lindex $v 0] set val [lindex $v 1] if { "$v" == ""} { continue} if { [info exists ws_Cache($key)] } { set doWrite 1 catch {file delete [cacheName [lindex $ws_Cache($key) 1] ] } } if { "$val" != "badvalue" } { set ws_Cache($key) $val } } close $fi if { $doWrite} { set fi [open [cacheName index.dat] w] puts "writing [cacheName index.dat]" foreach { key val } [array get ws_Cache *] { puts $fi "[list [list $key]] {$val}" } close $fi } } if { "[info command unsupported0]" == "" } { # then we have binary strings!!, since the release that removed # unsupported0 added binary strings.. # #----------------------------------------------------------------- # # unsupported0 -- copy from FROM to TO copying at most SIZE # bytes. Like fcopy $from $to -size $SIZE # except it does not block if there are not $SIZE bytes immediately # available. # # Results: The number of bytes copied is returned. # # Side Effects: bytes moved from one channel to other. # #---------------------------------------------------------------- # proc unsupported0 {from to size} { # puts "entering> unsupported0 $from $to $size " ; flush stdout; set tem [read $from $size] #DONT comment next puts -nonewline $to $tem # puts "exiting> unsupported0 $from $to $size --> [string length $tem]" ; flush stdout; return [string length $tem] } # endif unsupported0 not defined } ## endsource getdata1.tcl ## source macros.tcl ###### macros.tcl ###### ############################################################ # Netmath Copyright (C) 1998 William F. Schelter # # For distribution under GNU public License. See COPYING. # ############################################################ proc desetq {lis lis2} { set i 0 foreach v $lis { uplevel 1 set $v [list [lindex $lis2 $i]] set i [expr {$i + 1}] } } proc assoc { key lis args } { foreach { k val } $lis { if { "$k" == "$key" } { return $val } } return [lindex $args 0] } proc delassoc { key lis } { foreach { k val } $lis { if { "$k" != "$key" } { lappend new $k $val } } return $new } proc putassoc {key lis value } { set done 0 foreach { k val } $lis { if { "$k" == "$key" } { set done 1 set val $value } lappend new $k $val } if { !$done } { lappend new $key $value } return $new } proc intersect { lis1 lis2 } { set new "" foreach v $lis1 { set there($v) 1 } foreach v $lis2 { if { [info exists there($v)] } { lappend new $v }} return $new } # #----------------------------------------------------------------- # # ldelete -- remove all copies of ITEM from LIST # # Results: new list without item # # Side Effects: # #---------------------------------------------------------------- # proc ldelete { item list } { while { [set ind [lsearch $list $item]] >= 0 } { set list [concat [lrange $list 0 [expr {$ind -1}]] [lrange $list [expr {$ind +1}] end]] } return $list } # apply f a1 a2 a3 [list u1 u2 ..un] , should call # f with n+3 arguments. proc apply {f args } { set lis1 [lrange $args 0 [expr {[llength $args] -2}]] foreach v [lindex $args end] { lappend lis1 $v} set lis1 [linsert $lis1 0 $f] uplevel 1 $lis1 } ## endsource macros.tcl ## source proxy.tcl ###### proxy.tcl ###### # #----------------------------------------------------------------- # # openSocketAndSend -- open a Socket to HOST on PORT and then # send the message MSG to it. If verify is non 0, then read # up through the end of the http header and verify this is not # an error. # # Results: returns a socket which you can read from using ordinary # read and write, but to which you should write only using s # # Side Effects: # #---------------------------------------------------------------- # proc openSocketAndSend { host port msg { verify 0}} { global ws_openMath pdata dtrace if { [info exists ws_openMath(proxy,http)] } { global pdata set magic "billy-[clock clicks]" debugsend "sendViaProxy $msg $host $port $magic" set sock [sendViaProxy $msg $host $port $magic] if { $verify } { fconfigure $sock -blocking 1 -translation {crlf binary} gets $sock tem if { [regexp "503" $tem] } { error "Could not connect $host $port" } while { 1 } { gets $sock tem if { [string length $tem] == 0 } { break } } } set pdata($sock,proxyto) [list $host $port $magic] fconfigure $sock -blocking 0 return $sock } else { set sock [socket $host $port] if {[info exists pdata($sock,proxyto)]} { unset pdata($sock,proxyto) } fconfigure $sock -blocking 0 puts -nonewline $sock $msg flush $sock return $sock } } # #----------------------------------------------------------------- # # proxyPuts -- send the MESSAGE to SOCK, not appending a newline. # # Results: none # # Side Effects: message sent # #---------------------------------------------------------------- # proc proxyPuts { sock message } { global pdata debugsend "proxyPuts $sock $message useproxy=[info exists pdata($sock,proxyto)]" if { [info exists pdata($sock,proxyto)] } { desetq "host port magic" $pdata($sock,proxyto) close [sendViaProxy $message $host $port $magic] } else { puts -nonewline $sock $message flush $sock } } # #----------------------------------------------------------------- # # sendViaProxy -- send a message. # this is a private function. # # Results: a socket one can read the answer from. # Caller is responsible for closing the socket. # # Side Effects: socket opened and message sent as the body # of a post. The magic is put in the http header request as the # filename # #---------------------------------------------------------------- # proc sendViaProxy { message host port magic } { global ws_openMath dtrace set ss [eval socket $ws_openMath(proxy,http)] fconfigure $ss -blocking 0 fconfigure $ss -translation {crlf binary} set request [getURLrequest http://$host:$port/$magic $host $port "" $message] debugsend "<$ss request=$request>" puts $ss $request flush $ss return $ss } ## endsource proxy.tcl if { $argc == 0 } { set port 4444 set magic "billyboy" } set interrupt_signal "<>" set _waiting 0 set _debugSend 0 # #----------------------------------------------------------------- # # myVwait -- this is a replacement for vwait which is missing from # the plugin tcl. It is 'supposed' to be the same but in fact if it # is a fileevent handler that is supposed to do the setting, then the # fileevent handler might indeed get called continuously because the # file becomes readable, and myVwait which was checking a variable that # the handler set, never gets a chance to return, since the handler # is called again and again. So Remove the handler when it is invoked. # Note this uses tracing of the variable or array, and may interfere # with other tracing. # Results: # # Side Effects: waits till the variable is set if it was unset, or # until its value is different. # #---------------------------------------------------------------- # proc myVwait { var } { global _waiting ws_openMath set tem [split $var "(" ] set variable [lindex $tem 0] global $variable lappend ws_openMath(myVwait) $variable set index "" if { [llength $tem ] > 1 } { set index [lindex [split [lindex $tem 1] ")" ] 0] } set action "_myaction [list $index]" trace variable $variable w $action set _waiting 1 while { [set _waiting] } { #puts "still waiting _waiting=$_waiting" update } set ws_openMath(myVwait) [ ldelete $variable $ws_openMath(myVwait)] trace vdelete $variable w $action } proc _myaction { ind name1 name2 op } { global _waiting # puts "action $ind $name1 $name2 $op" if { "$ind" == "$name2" } { global $name1 set _waiting 0 } } # proc myVwait { x args } {uplevel #0 vwait $x } if { "[info commands vwait]" == "vwait" } { proc myVwait { x } { global ws_openMath $x lappend ws_openMath(myVwait) $x vwait $x set ws_openMath(myVwait) [ ldelete $x $ws_openMath(myVwait)] } } proc omDoInterrupt { win } { foreach v [ $win tag names] { if { [regexp "com:pdata\\((\[a-z_A-Z]*)," $v junk program] } { set var [string range $v 4 end] # puts "interrupt program=$program,$var" after 10 uplevel #0 set $var catch { sendInterrupt $program } } } } proc omDoAbort { win } { foreach v [ $win tag names] { set var [string range $v 4 end] if { [regexp "com:pdata\\((\[a-z_A-Z]*)," $v junk program] } { set prog [programName $program] if { "[info command abort_$prog]" != "" } { abort_$prog $program after 200 uplevel #0 set $var } cleanPdata $program set var [string range $v 4 end] # rputs "interrupt program=$program,$var" after 200 uplevel #0 set $var } } } proc msleep { n } { global Msleeping set Msleeping 1 after $n "set Msleeping 0" debugsend "waiting Msleeping.." myVwait Msleeping debugsend "..donewaiting Msleeping" } proc message { msg } { global ws_openMath _debugSend if { $_debugSend } { puts "setting message=<$msg>" } catch { set ws_openMath(load_rate) $msg } } proc sendOne { program com } { global pdata ws_openMath incr pdata($program,currentExpr) set socket $pdata($program,socket) if { [eof $socket] } { error "connection closed" } # puts "sending $program ([lindex [fconfigure $socket -peername] 1])" message "sending $program on [lindex [fconfigure $socket -peername] 1]" debugsend "sending.. {$com<$pdata($program,currentExpr)\|fayve>}" set msg "$com<$pdata($program,currentExpr)\|fayve>\n" proxyPuts $socket $msg } # #----------------------------------------------------------------- # # sendOneDoCommand -- sends to PROGRAM the COMMAND and then # when the result comes back it invokes the script CALLBACK with # one argument appended: the global LOCATION where the result # will be. [uplevel #0 set $LOCATION] would retrieve it. # # Results: returns immediately the location that will be # watched. # # Side Effects: CALLBACK is invoked later by tracing the # result field # #---------------------------------------------------------------- # proc sendOneDoCommand {program command callback } { global pdata if { ![assureProgram $program 5000 2] } { return "cant connect"} set ii [expr {$pdata($program,currentExpr) + 1}] catch { unset pdata($program,results,$ii)} trace variable pdata($program,results,$ii) w \ [list invokeAndUntrace $callback] sendOne $program $command return pdata($program,results,$ii) } proc testit { program com } { sendOneDoCommand $program $com "jimmy" proc jimmy {s} { puts "" ; flush stdout} } proc invokeAndUntrace { callback name1 name2 op args} { #puts "callback:$callback $name1 $name2 $op, args=$args" #puts "trace vdelete [set name1]($name2) w [list invokeAndUntrace $callback]" trace vdelete [set name1]($name2) w [list invokeAndUntrace $callback] lappend callback [set name1]($name2) # puts "callback=$callback" ; flush stdout if { [catch { eval $callback } errmsg ] } { global errorInfo # report the error in the background set com [list error "had error in $callback:[string range $errmsg 0 300].." $errorInfo] after 1 $com } } proc sendOneWait { program com } { global pdata if { ![assureProgram $program 5000 2] } { return "cant connect"} set ii [expr {$pdata($program,currentExpr) + 1}] catch { unset pdata($program,results,$ii)} sendOne $program $com set i $pdata($program,currentExpr) set socket $pdata($program,socket) if { $ii != $i } { error "expected $ii got $i as expression number " } debugsend "waiting for pdata($program,results,$i)" myVwait pdata($program,results,$i) debugsend "..done waiting for pdata($program,results,$i)" return $pdata($program,results,$i) } proc closeConnection { program } { global pdata catch { set sock $pdata($program,socket) set pdata(input,$sock) "" cleanPdata $program close $sock } } proc dtrace { } { global _debugSend if { $_debugSend } { puts "at: [info level -1]" if { [info level]>2 } {puts " from:[info level -2 ]"} } } proc openConnection { tohost port magic program } { global pdata dtrace set msg "magic: $magic\n" set retries 2 message "connecting to nmtp($port)://$tohost/$program" debugsend "openConnection { $tohost $port $magic $program }" while { [incr retries -1] > 0 \ && [catch { set socket [openSocketAndSend $tohost $port $msg 1] }] } { debugsend retries=$retries msleep 400 } if { $retries == 0 } { return 0} message "connected to nmtp//$tohost:$port/$program" set pdata($program,socket) $socket set pdata($program,currentExpr) 0 set pdata(input,$socket) "" catch { fconfigure $socket -blocking 0 } fileevent $socket readable "getResults $program $socket" return 1 } proc sendInterrupt { program } { global pdata interrupt_signal set socket $pdata($program,socket) puts $socket $interrupt_signal ; flush $socket } proc sendCommand { program c } {w global pdata set socket $pdata($program,socket) puts $socket "" flush $socket } proc dumpInfo {program } { sendCommand $program dumpInfo } proc getResults { program socket } { # debugsend "enter:getResults" global pdata next_command_available next_command results ii if { [eof $socket] } { close $socket ; debugsend "closed $socket" cleanPdata $program return "<$program exitted>" } set s [read $socket] if { "[string index $s 0]" != "" } { set s [append pdata(input,$socket) $s] while { [set inds [testForFayve $s]] != "" } { set input $pdata(input,$socket) # set next_command_available 1 debugsend "input=$input" set gotback [string range $input 0 [expr {[lindex $inds 0] -1}]] set index [lindex $inds 2] set pdata($program,results,$index) $gotback if { [string first "exitted>" $gotback] > 0 } { close $socket cleanPdata $program } debugsend "gotback{$index:$gotback}" set s \ [string range $input [expr {1 + [lindex $inds 1]}] end ] set pdata(input,$socket) $s } } return "" } proc cleanPdata { program } { global pdata catch { close $pdata($program,socket) } catch { unset pdata($program,socket) } catch { unset pdata($program,preeval) } catch { foreach v [array names $program,results,*] { unset pdata($v) } } } # number from run-main.tcl set MathServer { genie1.ma.utexas.edu 4443 } # set MathServer { linux1.ma.utexas.edu 4443 } proc currentTextWinWidth { } { set width 79 catch { set t [oget [omPanel .] textwin] set width [expr {round([winfo width $t]*1.0 / [font measure [$t cget -font] 0]) - 12 }] } return $width } # #----------------------------------------------------------------- # # assureProgram -- # # Results: return 2 if the program was already open, and 1 if it is just # now opened. 0 if cant open it. # # Side Effects: program is started. # #---------------------------------------------------------------- # proc assureProgram { program timeout tries } { # puts "assure: program=$program" global pdata MathServer if { $tries <= 0 } { return 0} if { [catch { set socket $pdata($program,socket) } ] || [catch { eof $socket}] || [eof $socket] || [catch { set s [read $socket] ; append pdata(input,$socket) $s }] } { cleanPdata $program message "connecting [lindex $MathServer 0]" set msg "OPEN [programName $program] MMTP/1.0\nLineLength: [currentTextWinWidth]\n\n\n" if { [catch { set sock [openSocketAndSend [lindex $MathServer 0] \ [lindex $MathServer 1] $msg\n ] } ] } { error "Can't connect to $MathServer. You can try another host by altering Base Program under the \"file\" menu." } set pdata($program,currentExpr) 0 fconfigure $sock -blocking 0 if { [eof $sock] } {return 0} message "connected to [lindex $MathServer 0]" debugsend $msg set result "" set pdata(waiting,$sock) 1 set script "close $sock ; debugsend {after closing} ; set pdata(waiting,$sock) -1" debugsend "script=$script,timeout=$timeout" set af [after $timeout $script ] debugsend "after=$af" while {1 } { debugsend "waiting pdata(waiting,$sock)=$pdata(waiting,$sock)" # puts "pdata=[array get pdata *$sock* ]" fileevent $sock readable "if { [eof $sock] } {set pdata(waiting,$sock) -2} else { set pdata(waiting,$sock) 0 ;} ;fileevent $sock readable {} " set pdata(waiting,$sock) 1 debugsend "waiting on pdata(waiting,$sock)" myVwait pdata(waiting,$sock) debugsend "..done now pdata(waiting,$sock)=$pdata(waiting,$sock)" if { $pdata(waiting,$sock) < 0 } { debugsend "timed out,$pdata(waiting,$sock)" return 0 } set me [read $sock] if { "[string index $me 0]" == "" && [eof $sock] } { debugsend "nothing there" return 0} append result $me debugsend "result=<$result>" if { [regexp "RUNNING (\[^ \]+) MMTP\[^\n\]*\nHost: (\[^\n ]+)\nPort: (\[0-9\]+)\nMagic: (\[^\n \]+)\n" \ $result junk prog tohost port magic] } { after cancel $af debugsend "doing openConnection $tohost $port $magic $program" close $sock ; return [openConnection $tohost $port $magic $program] } } } elseif { [eof $socket] } { close $socket unset pdata($program,socket) return [assureProgram $program $timeout [expr {$tries -1}]] } else { # already open return 2 } } # name may look like "maxima#1.2" proc programName { name } { set name [file tail $name] return [lindex [split $name #] 0] } set EOFexpr "|fayve>" proc getMatch { s inds } { return [string range $s [lindex $inds 0] [lindex $inds 1]] } proc testForFayve { input } { global EOFexpr set ind [string first $EOFexpr $input] if { $ind < 0 } { return "" } else { regexp -indices {<([0-9]+)\|fayve>} $input all first set n [getMatch $input $first] return "$all $n" } } #### the following is correct but just a fair bit slower.. #### ##### because of all the arguments to be parsed for the other.. proc statServer1 {server {timeout 1000}} { global statServer set ans "" if { ![catch { set s [eval socket $server]} ] } { puts $s "STAT MMTP/1.0\n" ; flush $s if { [readAllData $s -tovar statServer(data) \ -mimeheader statServer(header) -timeout $timeout ] > 0 } { set head $statServer(header) # puts "data=<$statServer(data)>" set res $statServer(header)\n\n$statServer(data) unset statServer return $res } } return "" } # #----------------------------------------------------------------- # # needToDo -- Check if we have already done OPERATION for NAME into data # # Results: returns 0 if the data for name is not preloaded, and 1 otherwise # # Side Effects: adds NAME to those preloaded for PROGRAM if not there # #---------------------------------------------------------------- # proc preeval { program name } { global pdata assureProgram $program 5000 2 if { ![info exists pdata($program,preeval)] || [lsearch $pdata($program,preeval) $name] < 0 } { lappend pdata($program,preeval) $name return 0 } else { return 1 } } proc statServer {server {timeout 1000}} { global statServer1_ set ans "" if { ![catch { set s [eval socket $server]} ] } { puts $s "STAT MMTP/1.0\n" ; flush $s if { [readDataTilEof $s data $timeout ] } { foreach v { jobs currentjobs } { if { [regexp "\n$v: (\[^\n]*)\n" $data junk val] } { lappend ans $v $val } } } } return $ans } proc isAlive1 { s } { global ws_openMath if { [catch { read $s } ] } { set ws_openMath(isalive) -1 } else { set ws_openMath(isalive) 1 } close $s } proc isAlive { server {timeout 1000} } { global ws_openMath if { [ catch { set s [eval socket -async $server] } ] } { return -1 } set ws_openMath(isalive) 0 fconfigure $s -blocking 0 fileevent $s writable "isAlive1 $s" set c1 "set ws_openMath(isalive) -2" after $timeout $c1 myVwait ws_openMath(isalive) catch { close $s} after cancel $c1 return $ws_openMath(isalive) } proc debugsend { s } { global _debugSend if { $_debugSend } { puts $s flush stdout } } ## endsource send-some.tcl # source showcode.tcl # source /home/wfs/java/server/allplot.tcl # catch { cd /home/wfs/java/server} ## source plotting.tcl ###### plotting.tcl ###### ############################################################ # Netmath Copyright (C) 1998 William F. Schelter # # For distribution under GNU public License. See COPYING. # ############################################################ ## source plotconf.tcl ###### plotconf.tcl ###### ############################################################ # Netmath Copyright (C) 1998 William F. Schelter # # For distribution under GNU public License. See COPYING. # ############################################################ ## source private.tcl ###### private.tcl ###### ############################################################ # Netmath Copyright (C) 1998 William F. Schelter # # For distribution under GNU public License. See COPYING. # ############################################################ # a private way of storing variables on a window by window # basis proc makeLocal { win args } { foreach v $args { uplevel 1 set $v \[oget $win $v\] } } proc linkLocal { win args } { foreach v $args { uplevel 1 upvar #0 _WinInfo${win}\($v) $v } } proc clearLocal { win } { global _WinInfo$win # puts "clearing info for $win in [info level 1]" catch { unset _WinInfo$win } } proc oset { win var val } { global _WinInfo$win set _WinInfo[set win]($var) $val } proc oarraySet { win vals } { global _WinInfo$win array set _WinInfo$win $vals } proc oloc { win var } { return _WinInfo[set win]($var) } proc oarray { win } { return _WinInfo[set win] } proc oget { win var } { global _WinInfo$win return [set _WinInfo[set win]($var)] } ## endsource private.tcl ## source parse.tcl ###### parse.tcl ###### ############################################################ # Netmath Copyright (C) 1998 William F. Schelter # # For distribution under GNU public License. See COPYING. # ############################################################ ## source getopt.tcl ###### getopt.tcl ###### ############################################################ # Netmath Copyright (C) 1998 William F. Schelter # # For distribution under GNU public License. See COPYING. # ############################################################ #####sample option list. Error will be signalled if "Required" option ##### not given. #set dfplotOptions { # {xdot Required {specifies dx/dt = xdot. eg -xdot "x+y+sin(x)^2"} } # {ydot Required {specifies dy/dt = ydot. eg -ydot "x-y^2+exp(x)"} } # {xradius 10 "Width in x direction of the x values" } # {yradius 10 "Height in y direction of the y values"} #} # #----------------------------------------------------------------- # # optLoc -- if $usearray is not 0, then the OPTION is stored # in a hashtable, otherwise in the variable whose name is the # same as OPTION. # Results: a form which when 'set' will allow storing value. # # Side Effects: none # #---------------------------------------------------------------- # proc optLoc { op ar } { # puts "$ar,[lindex $op 0]" # puts "return=$ar\([lindex $op 0]\)" if { "$ar" == 0 } { return [lindex $op 0] } else { #puts "$ar\([lindex $op 0]\)" return "$ar\([lindex $op 0]\)" } } # #----------------------------------------------------------------- # # getOptions -- given OPTLIST a specification for the options taken, # parse the alternating keyword1 value1 keyword2 value2 options_supplied # to make sure they are allowed, and not just typos, and to supply defaults # for ones not given. Give an error message listing options. # a specification is { varname default_value "doc string" } # and optlist, is a list of these. the key should be -varname # # -debug 1 "means print the values on standard out" # -allowOtherKeys 1 "dont signal an error if -option is supplied but not in # the list" # -usearray "should give a NAME, so that options are stored in NAME(OPTION) # -setdefaults "if not 0 (default is 1) do `set OPTION dflt' for all options" # If a key is specified twice eg. -key1 val1 -key1 val2, then the first # value val1 will be used # Results: # # Side Effects: set the values in the callers environment # #---------------------------------------------------------------- # proc getOptions { optlist options_supplied args } { # global getOptionSpecs set ar [assoc -usearray $args 0] set help [assoc -help $args ""] if { "$ar" != "0" } { global $ar } set debug [assoc -debug $args 0] set allowOtherKeys [assoc -allowOtherKeys $args 0] set setdefaults [assoc -setdefaults $args 1] set supplied "" foreach {key val } $options_supplied { if { [info exists already($key)] } { continue } set already($key) 1 set found 0 foreach op $optlist { if { "$key" == "-[lindex $op 0]" } { uplevel 1 set [optLoc $op $ar] [list $val] append supplied " [lindex $op 0]" set found 1 break } } set caller global if { $found == 0 && !$allowOtherKeys } { catch {set caller [lindex [info level -1] 0]} error "`$caller' does not take the key `$key':\n[optionHelpMessage $optlist]\n$help" } } foreach op $optlist { if { [lsearch $supplied [lindex $op 0]] < 0 } { if { "[lindex $op 1]" == "Required" } { catch {set caller [lindex [info level -1] 0]} error "`-[lindex $op 0]' is required option for `$caller':\n[optionHelpMessage $optlist]" } if { $setdefaults } { uplevel 1 set [optLoc $op $ar] [list [lindex $op 1]] } } # for debugging see them. # if { $debug } { uplevel 1 puts "[optLoc $op $ar]=\$[optLoc $op $ar]"} if { $debug } { puts "[optLoc $op $ar]=[safeValue [optLoc $op $ar] 2]"} } } proc getOptionDefault { key optionList } { foreach v $optionList { if { "[lindex $v 0]" == "$key" } { return [lindex $v 1]} } return "" } proc assq {key list {dflt ""}} { foreach v $list { if { "[lindex $v 0]" == "$key" } { return $v }} return $dflt } proc safeValue { loc level} { if { ![catch { set me [uplevel $level set $loc] } ] } { return $me } else {return "`unset'" } } proc optionFirstItems { lis } { set ans "" foreach v $lis { append ans " [list [lindex $v 0]]" } return $ans } proc optionHelpMessage { optlist } { set msg "" foreach op $optlist { append msg \ " -[lindex $op 0] \[ [lindex $op 1] \] --[lindex $op 2]\n" } return $msg } # #----------------------------------------------------------------- # # setSplittingOptionsRest -- takes ARGLIST and splits it into # two lists, the first part it stores in KEYPAIRS and the second in REST # # # Results: none # # # Side Effects: sets the variables in the local frame passed to KEYPAIRS # #---------------------------------------------------------------- # proc setSplittingOptionsRest { keypairs rest arglist } { upvar 1 $keypairs keys upvar 1 $rest res set i 0 while { 1 } { if { $i >= [llength $arglist] } { break } if { "[string range [lindex $arglist $i] 0 0]" == "-" } { incr i 2 } else { break } } set keys [lrange $arglist 0 [expr $i -1]] set res [lrange $arglist $i end] } ## endsource getopt.tcl catch { unset Parser } foreach v { { ( 120 } { \[ 120 } { ) 120 } { \] 120 } { ^ 110} {* 100} { / 100} {% 100} {- 90 } { + 90 } { << 80} { >> 80 } { < 70 } { > 70 } { <= 70 } {>= 70} { == 60 } { & 50} { | 40 } { , 40 } {= 40} { && 30 } { || 20 } { ? 10 } { : 10 } { ; 5 }} { set parse_table([lindex $v 0]) [lindex $v 1] set getOp([lindex $v 0]) doBinary } proc binding_power {s} { global parse_table billy set billy $s if { [catch { set tem $parse_table($s) }] } { return 0 } else { return $tem } } proc getOneMatch { s inds } { return [string range $s [lindex $inds 0] [lindex $inds 1]] } proc parseTokenize { str } { regsub -all {[*][*]} $str "^" str set ans "" while { [string length $str ] > 0 } { # puts "ans=$ans,str=$str" set str [string trimleft $str " \t\n" ] set s [string range $str 0 1] set bp [binding_power $s] if { $bp > 0 } { append ans " $s" set str [string range $str 2 end] continue } else { set s [string range $s 0 0] set bp [binding_power $s] if { $bp > 0 } { append ans " $s" set str [string range $str 1 end] continue } } if { "$s" == "" } { return $ans } if { [regexp -indices {^[0-9.]+([eE][+---]?[0-9]+)?} $str all] } { append ans " { number [getOneMatch $str $all] }" # append ans " [getOneMatch $str $all]" set str [string range $str [expr {1+ [lindex $all 1]}] end] } elseif { [regexp -indices {^[$a-zA-Z][a-zA-Z0-9]*} $str all] } { append ans " { id [getOneMatch $str $all] } " # append ans " [getOneMatch $str $all]" set str [string range $str [expr {1+ [lindex $all 1]}] end] } else { error "parser unrecognized: $str" } } return $ans } 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" set Parser(help) [join [list { The syntax is like C except that it is permitted to write x^n instead of pow(x,n). } "\nFunctions: $Parser(reserved)\n\nOperators: == % & || ( << <= ) : * >= + && , | < >> - > ^ ? /" ] ""] proc nexttok { } { global Parser set x [lindex $Parser(tokenlist) [incr Parser(tokenind) ]] # puts "nexttok=$x" if {[llength $x ] > 1 } { set Parser(tokenval) [lindex $x 1] return [lindex $x 0] } else { return $x } } # #----------------------------------------------------------------- # # parseToSuffixLists -- Convert EXPR1; EXPR2; .. # to a list of suffix lists. Each suffix list is suitable for # evaluating on a stack machine (like postscript) or for converting # further into another form. see parseFromSuffixList. # "1+2-3^4;" ==> # {number 1} {number 2} + {number 3} {number 4} ^ - # Results: suffix list form of the original EXPR # # Side Effects: none # #---------------------------------------------------------------- # proc parseToSuffixLists { a } { global Parser set Parser(result) "" set Parser(tokenlist) [parseTokenize $a] set Parser(tokenind) -1 set Parser(lookahead) [nexttok] #puts tokenlist=$Parser(tokenlist) set ans "" while { "$Parser(lookahead)" != "" } { getExpr ; parseMatch ";" #puts "here: $Parser(result) " append ans "[list $Parser(result)] " set Parser(result) "" } return $ans } proc parseMatch { t } { global Parser if { "$t" == "$Parser(lookahead)" } { set Parser(lookahead) [nexttok] } else { error "syntax error: wanted $t"} } proc emit { s args } { global Parser if { "$args" == "" } { append Parser(result) " $s" # puts " $s " } else { append Parser(result) " {[lindex $args 0 ] $s}" #puts " {[lindex $args 0 ] $s} " } } proc getExpr { } { getExprn 0 } proc getExprn { n } { global Parser #puts "getExpr $n, $Parser(tokenind),$Parser(tokenlist)" if { $n == 110 } { getExpr120 return } incr n 10 if { $n == 110 } { if { "$Parser(lookahead)" == "-" || "$Parser(lookahead)" == "+" } { if { "$Parser(lookahead)" == "-" } { set this PRE_MINUS } else { set this PRE_PLUS } parseMatch $Parser(lookahead) getExprn $n #puts "l=$Parser(lookahead),pl=$Parser(result)" emit $this return } } getExprn $n while { 1 } { if { [binding_power $Parser(lookahead)] == $n } { set this $Parser(lookahead) parseMatch $Parser(lookahead) getExprn $n if { $n == 110 } { set toemit "" while { "$this" == "^" && "$Parser(lookahead)" == "^" } { # puts "p=$Parser(result),$ set this $Parser(lookahead) append toemit " $this" parseMatch $Parser(lookahead) getExprn $n } foreach v $toemit { emit $v } } emit $this } else { return } } } proc getExpr120 { } { global Parser #puts "getExpr120, $Parser(tokenind),[lrange $Parser(tokenlist) $Parser(tokenind) end]" while { 1 } { if { "$Parser(lookahead)" == "(" } { parseMatch $Parser(lookahead) getExpr parseMatch ")" break; } elseif { $Parser(lookahead) == "id" } { emit $Parser(tokenval) id parseMatch $Parser(lookahead) if { "$Parser(lookahead)" == "(" } { getExpr120 emit funcall } break; } elseif { $Parser(lookahead) == "number" } { emit $Parser(tokenval) number parseMatch $Parser(lookahead) break; } else { error "syntax error" } } } set getOp(PRE_PLUS) doPrefix set getOp(PRE_MINUS) doPrefix set getOp(funcall) doFuncall set getOp(^) doPower set getOp(:) doConditional set getOp(?) doConditional proc doBinary { } { uplevel 1 {set s $nargs; incr nargs -1 ; if { "$x" == "," } { set a($nargs) "$a($nargs) $x $a($s)"} else { set a($nargs) "($a($nargs) $x $a($s))"} } } proc doPower { } { uplevel 1 {set s $nargs; incr nargs -1 ; set a($nargs) "pow($a($nargs),$a($s))" } } proc doFuncall {} { uplevel 1 { #puts nargs=$nargs set s $nargs; incr nargs -1 ; set a($nargs) "$a($nargs)($a($s))"} } proc doPrefix {} { uplevel 1 { if { "$x" == "PRE_MINUS" } { set a($nargs) "-$a($nargs)" } } } proc doConditional { } { set x [uplevel 1 set x] if { "$x" == "?" } { return } # must be : uplevel 1 { set s $nargs ; incr nargs -2 ; set a($nargs) "($a($nargs) ? $a([expr {$nargs + 1}]) : $a($s))" } } # #----------------------------------------------------------------- # # parseFromSuffixList -- takes a token list, and turns # it into a suffix form. eg: 1 + 2 - 3 ^ 4 --> 1 2 + 3 4 ^ - # Results: # # Side Effects: # #---------------------------------------------------------------- # proc parseFromSuffixList { list } { global getOp set stack "" set lim [llength $list] set i 0 set nargs 0 while { $i < $lim } { set x [lindex $list $i ] set bp [binding_power $x] incr i # all binary if { [llength $x] > 1 } { set a([incr nargs]) [lindex $x 1] } else { $getOp($x) } } return $a(1) } # #----------------------------------------------------------------- # # parseConvert -- given an EXPRESSION, parse it and find out # what are the variables, and convert a^b to pow(a,b). If # -variables "x y" is given, then x and y will be replaced by $x $y # doall 1 is giv # Results: # # Side Effects: # #---------------------------------------------------------------- # set Parser(convertOptions) { { doall 0 "convert all variables x to \$x" } { variables "" "list of variables to change from x to \$x" } } proc parseConvert { expr args } { global Parser getOptions $Parser(convertOptions) $args if { "$expr" == "" } { return [list {} {}] } set parselist [parseToSuffixLists "$expr;"] #puts "parselist=$parselist" catch { unset allvars } set new "" set answers "" foreach lis $parselist { foreach v $lis { if { ("[lindex $v 0]" == "id") && ([llength $v] == 2) && ([lsearch $Parser(reserved) [set w [lindex $v 1]]] < 0) } { if { ($doall != 0) || ([lsearch $variables $w] >= 0) } { append new " {id \$$w}" set allvars(\$$w) 1 } else { set allvars($w) 1 append new " {$v}" } } else { if { [llength $v] > 1 } { append new " {$v}" } else { append new " $v" } } } #puts "new=$new" append answers "[list [parseFromSuffixList $new]] " set new "" } return [list $answers [array names allvars]] } proc test { s } { set me [parseFromSuffixList [lindex [parseToSuffixLists "$s;"] 0]] puts $me return "[eval expr $s] [eval expr $me]" } # # Local Variables: # mode: tcl # version-control: t # End: ## endsource parse.tcl ## source textinsert.tcl ###### textinsert.tcl ###### ############################################################ # Netmath Copyright (C) 1998 William F. Schelter # # For distribution under GNU public License. See COPYING. # ############################################################ proc mkTextItem { c x y args } { set font [assoc -font $args {Helvetica 14}] set tags [assoc -tags $args {}] set item [$c create text $x $y -text " " -width 440 -anchor n -font $font -justify left] append tags text foreach v $tags { $c addtag $v withtag $item} $c bind text <1> "textB1Press $c %x %y" $c bind text "textB1Move $c %x %y" $c bind text "$c select adjust current @%x,%y" $c bind text "textB1Move $c %x %y" $c bind text "textInsert $c %A" $c bind text "textInsert $c \\n" $c bind text "textBs $c" $c bind text "textBs $c" $c bind text "textDel $c" $c bind text <2> "textPaste $c @%x,%y" } ## endsource textinsert.tcl ## source printops.tcl ###### printops.tcl ###### ############################################################ # Netmath Copyright (C) 1998 William F. Schelter # # For distribution under GNU public License. See COPYING. # ############################################################ ### fix a4 size ! set paperSizes {{letter 8.5 11} { A4 8.5 11} {legal 8.5 13}} set printOptions { { landscape 1 "Non zero means use landscape mode in printing" } { tofile 1 "Non zero means print to file" } { pagewidth "" "Figure width" } { pageheight "" "Figure height" } { papersize letter "letter, legal or A4"} { hoffset .5 "Left margin for printing"} { voffset .5 "Right margin for printing"} { xticks 20 "Rough number of ticks on x axis"} { yticks 20 "Rough number of ticks on y axis"} { domargin 1 "Print the frame and the margin ticks"} { printer "" "Printer to print to, eg lw8b " } { title "" "Title" } { psfilename "~/sdfplot.ps" "Postscript filename" } { gsview "gsview32" "postscript viewer, used for printing under Windows" } { centeronpage 1 ""} } # proc getPageOffsets { widthbyheight} { # global printOption paperSizes # puts "wbh=$widthbyheight" # set pwid 8.5 # set phei 11.0 # foreach v $paperSizes { # if { "[lindex $v 0]" == "$printOption(papersize)" } { # set pwid [lindex $v 1] # set phei [lindex $v 2] # } # } # set wid [expr {$pwid - 2* $printOption(hoffset)}] # set hei [expr {$phei - 2* $printOption(voffset)}] # # if { $printOption(landscape) } {set widthbyheight [expr {1.0 /$widthbyheight}]} # # set w $wid ; set hei $wid ; set wid $w # puts "pw=$wid,ph=$hei,w/h=$widthbyheight,hh=[expr {$hei * $widthbyheight}], ww=[expr {$wid / $widthbyheight}]" # set fac $widthbyheight # puts "fac=$fac" # if { $fac * $hei < $wid } { # set iwid [expr {$fac *$hei}] # set ihei $hei # } else { # set ihei [expr {$wid / $fac}] # set iwid $wid # } # if { $printOption(landscape) } { set fac1 [expr {1/$fac}] } # if { $wid/$hei > $fac } { # set ihei $hei # set iwid [expr {$hei / $fac }] # } else { # set iwid $wid # set ihei [expr {$wid * $fac }] # } # #-pagex = left margin (whether landscape or not) # #-pagey = right margin (whether landscape or not) # #-pagewidth becomes vertical height if landscape # #-pageheight becomes horiz width if landscape # set xoff [expr {($pwid-$iwid)/2.0}] # set yoff [expr {($phei-$ihei)/2.0}] # if { $printOption(landscape) } { # set h $ihei # set ihei $iwid # set iwid $h # } # puts "phei=$phei,ihei=$ihei,yoff=$yoff,voff=$printOption(voffset)" # set ans "-pagex [set xoff]i -pagey [set yoff]i \ # -pagewidth [set iwid]i -pageheight [set ihei]i" # set ans "-pagex [set xoff]i -pagey [set yoff]i \ # -pagewidth [set iwid]i -pageheight [set ihei]i" # return $ans # } proc swap { a b } { set me [uplevel 1 set $b] uplevel 1 set $b \[set $a\] uplevel 1 set $a [list $me] } proc getPageOffsets { widthbyheight} { global printOption paperSizes #puts "wbh=$widthbyheight" set pwid 8.5 set phei 11.0 foreach v $paperSizes { if { "[lindex $v 0]" == "$printOption(papersize)" } { set pwid [lindex $v 1] set phei [lindex $v 2] } } set wid [expr {$pwid - 2* $printOption(hoffset)}] set hei [expr {$phei - 2* $printOption(voffset)}] if { $printOption(landscape) } { swap wid hei # swap pwid phei } if { $wid / $hei < $widthbyheight } { # width dominates set iwid $wid set ihei [expr {$wid / $widthbyheight }] append opts " -pagewidth [set wid]i" } else { set ihei $hei set iwid [expr {$hei * $widthbyheight }] append opts " -pageheight [set hei]i" } #-pagex = left margin (whether landscape or not) #-pagey = right margin (whether landscape or not) #-pagewidth becomes vertical height if landscape #-pageheight becomes horiz width if landscape append opts " -pagex [expr {$pwid / 2.0}]i -pagey [expr {$phei / 2.0}]i " if { $printOption(landscape) } { append opts " -rotate $printOption(landscape)" } return $opts } set printOption(setupDone) 0 proc getEnv { name } { global env if { [catch { set tem $env($name) } ] } { return "" } return $tem } proc setPrintOptions { lis } { global browser_version global printOptions printOption printSetUpDone if { !$printOption(setupDone) } { set printOption(setupDone) 1 getOptions $printOptions $lis -allowOtherKeys 1 \ -setdefaults [catch { source [getEnv HOME]/.printOptions }] -usearray printOption if { "$printOption(printer)" == "" } {set printOption(printer) [getEnv PRINTER] } else { set printOption(printer) lw8b } } if { [info exists browser_version] } { set printOption(tofile) 2 } } proc mkentryPr { w var text buttonFont } { set fr $w ; frame $fr uplevel 1 append topack [list " $fr"] label $fr.lab -text "$text" -font $buttonFont entry $fr.e -width 20 -textvariable $var -font $buttonFont pack $fr.lab $fr.e -side left -expand 1 -padx 3 -fill x } proc mkPrintDialog { name args } { global printSet argv env printOptions printOption printSetUpDone paperSizes buttonfont set canv [assoc -canvas $args ] set buttonFont [assoc -buttonfont $args $buttonfont] catch { destroy $name } set dismiss "destroy $name" if { "$canv" == "" } { catch {destroy $name} toplevel $name wm geometry $name -0+20 } else { $canv delete printoptions set name [winfo parent $canv].printoptions # set name $canv.fr1 catch {destroy $name} frame $name -borderwidth 2 -relief raised set item [$canv create window [$canv canvasx 10] [$canv canvasy 10] -window $name -anchor nw -tags printoptions] $canv raise printoptions set dismiss "$canv delete $item; destroy $name " } frame $name.fr set w $name.fr label $w.msg -wraplength 600 -justify left -text "Printer Setup" pack $w pack $w.msg set wb $w.buttons frame $wb pack $wb -side left -fill x -pady 2m set topack "" catch { set printOption(psfilename) \ [file nativename $printOption(psfilename)]} button $wb.ok -text "ok" -font $buttonFont -command "destroy $name ; $canv delete printoptions" radiobutton $wb.b0 -text "Save via ftp" -variable printOption(tofile) -relief flat -value 2 -command {set writefile "Save"} -font $buttonFont -highlightthickness 0 radiobutton $wb.b1 -text "Save as Postscript File" -variable printOption(tofile) -relief flat -value 1 -command {set writefile "Save"} -font $buttonFont -highlightthickness 0 radiobutton $wb.b2 -text "Print To Printer" -variable printOption(tofile) -relief flat -value 0 -command {set writefile "Print"} -font $buttonFont -highlightthickness 0 checkbutton $wb.b3 -text "Center on Page" -variable printOption(centeronpage) -relief flat -font $buttonFont -highlightthickness 0 checkbutton $wb.b4 -text "Landscape Mode" -variable printOption(landscape) -relief flat -font $buttonFont -highlightthickness 0 mkentryPr $wb.pagewidth printOption(pagewidth) "Figure width" $buttonFont mkentryPr $wb.pageheight printOption(pageheight) "Figure height" $buttonFont mkentryPr $wb.hoffset printOption(hoffset) "Left margin for printing" $buttonFont mkentryPr $wb.voffset printOption(voffset) "bottom margin for printing" $buttonFont mkentryPr $wb.psfilename printOption(psfilename) "postscript filename" $buttonFont mkentryPr $wb.printer printOption(printer) "Printer to print to" $buttonFont mkentryPr $wb.gsview printOption(gsview) "postscript viewer, used for printing under Windows" $buttonFont mkentryPr $wb.xticks printOption(xticks) "Rough number of xticks" $buttonFont mkentryPr $wb.yticks printOption(yticks) "Rough number of yticks" $buttonFont eval pack $wb.ok $wb.b0 $wb.b1 $wb.b2 $wb.b3 $wb.b4 eval pack $topack -expand 1 foreach v $paperSizes { set papersize [lindex $v 0] set lower [string tolower $papersize] radiobutton $wb.$lower -text [lindex $v 0] -variable printOption(papersize) \ -value [lindex $v 0] -font $buttonFont -highlightthickness 0 pack $wb.$lower -pady 2 -anchor w -fill x } checkbutton $wb.domargin -variable printOption(domargin) -text "do margin" pack $wb.domargin -pady 2 -anchor w -fill x frame $w.grid pack $w.grid -expand yes -fill both -padx 1 -pady 1 grid rowconfig $w.grid 0 -weight 1 -minsize 0 grid columnconfig $w.grid 0 -weight 1 -minsize 0 } proc markToPrint { win tag title } { # puts "$win $tag" # bind $win <1> "bindBeginDrag $win %x %y $tag [list $title]" pushBind $win <1> "$win delete printrectangle ; popBind $win <1>" pushBind $win <1> "bindBeginDrag $win %x %y $tag [list $title]; popBind $win <1>" } proc bindBeginDrag { win x y tag title } { $win delete $tag printrectangle set beginRect "[$win canvasx $x] [$win canvasy $y]" set it1 [eval $win create rectangle $beginRect $beginRect -tags $tag -width 3] set old [bind $win ] set new "eval $win coords $it1 \ $beginRect \[$win canvasx %x\] \[$win canvasy %y\]; \ " if { "$old" == "$new" } {set old ""} bind $win $new bind $win "bind $win [list $old];\ bind $win {} ; unbindAdjustWidth $win $tag [list $title];" } proc unbindAdjustWidth { canv tag title } { set win [winfo parent $canv] global printOption set it [$canv find withtag $tag] set co1 [$canv coords $tag] set co [$canv coords $it] # if { "$co" != "$co1" } {puts differ,$co1,$co} desetq "x1 y1 x2 y2" $co set center [expr { ($x1+$x2 )/2}] set h [expr {$y2 - $y1}] set it [$canv find withtag $tag] set new [$canv create rectangle $x1 $y1 $x2 $y2 -outline white -width [expr {$h* .04}] -tags [concat $tag bigger] ] # puts "" marginTicks $canv [storx$win $x1] [story$win $y2] [storx$win $x2] [story$win $y1] "printrectangle marginticks" desetq "a1 b1 a2 b2" [$canv bbox $new] set textit [$canv create text $center [expr {$y1 - $h *.03}] \ -font [font create -family Courier -size 14 -weight bold] -text "$title" \ -anchor s -tags [concat $tag bigger title]] set bb [$canv bbox $textit] $canv create rectangle $a1 [lindex $bb 1] $a2 [expr {$y1 - 0.02 * $h}] -tags $tag -fill white -outline {} $canv itemconfig $it -width [expr {$h *.002}] $canv raise $it $canv raise $textit $canv raise marginticks if { $printOption(domargin) == 0 } { $canv delete marginticks } $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 # puts h=$h } proc getPSBbox { } { set fi [open /home/wfs/sdfplot.ps r] set me [read $fi 500] regexp {BoundingBox: (-*[0-9]+) (-*[0-9]+) (-*[0-9]+) (-*[0-9]+)} $me junk x1 y1 x2 y2 set w [expr {72 * 8.5}] set h [expr {72 * 11}] # puts "hei=[expr {$y2-$y1}],tm=[expr {$h - $y2}],bm=$y1" # puts "wid=[expr {$x2-$x1}],lm=$x1,rm=[expr {$w - $x2}]" # puts "hei=[expr {($y2-$y1)/72.0}],tm=[expr {($h - $y2)/72.0}],bm=([expr {$y1/72.0}])" #puts "wid=[expr {($x2-$x1)/72.0}],lm=([expr {$x1/72.0}]),rm=[expr {($w - $x2)/72.0}]" close $fi } ## endsource printops.tcl # set font {Courier 8} set fontCourier8 "-*-Courier-Medium-R-Normal--*-120-*-*-*-*-*-*" if { "[winfo screenvisual .]" == "staticgray" } { set axisGray black } else { set axisGray gray60} set writefile "Save" # make printing be by ftp'ing a file.. if {[catch { set doExit }] } { set doExit ""} set width_ [winfo screenwidth .] if { $width_ >= 1280 } { set fontSize 12 } elseif { $width_ <= 640} { set fontSize 8 } else { set fontSize 10} unset width_ proc makeFrame { w type } { global writefile doExit fontSize buttonfont ws_openMath set win $w if { "$w" == "." } { set w "" } else { catch { destroy $w} frame $w # toplevel $w # set w $w.new # frame $w # puts "making $w" } set dismiss "destroy $win" catch { set parent [winfo parent $win] if { "$parent" == "." } { set dismiss "destroy ." } if { [string match .plot* [winfo toplevel $win]] } { set dismiss "destroy [winfo toplevel $win]" } } if { "$doExit" != "" } {set dismiss $doExit } oset $w type $type frame $w.grid #positionWindow $w set c $w.c oset $win c $c bboxToRadius $win if { [catch { set buttonfont} ] } { set buttonfont [font create -family Helvetica -size $fontSize] } set buttonFont $buttonfont oset $win buttonFont $buttonfont # puts "children wb=[winfo children $w]" set wb $w.buttons frame $wb set dismiss [concat $dismiss "; clearLocal $win "] button $wb.dismiss -text Dismiss -command $dismiss -font $buttonFont setBalloonhelp $win $wb.dismiss {Close this plot window} button $wb.zoom -text "Zoom" -command "showZoom $w" -font $buttonFont 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} oset $w position "" # button $w.position -textvariable [oloc $w position] -font $buttonFont -width 10 label $w.position -textvariable [oloc $w position] -font $buttonFont -width 10 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.} button $wb.help -text "Help" -command "doHelp$type $win" -font $buttonFont setBalloonhelp $win $wb.help {Give more help about this plot window} button $wb.postscript -textvariable writefile -command "writePostscript $w" -font $buttonFont 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 } button $wb.markrect -text "Mark" -command "markToPrint $c printrectangle \[eval \[oget $win maintitle\]\]" -font $buttonFont 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} button $wb.replot -text "Replot" -command "replot$type $win" -font $buttonFont setBalloonhelp $win $wb.replot {Use the current settings and recompute the plot. The settings may be altered in Config} button $wb.config -text "Config" -command "doConfig$type $win" -font $buttonFont 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} bind $win.position "+place $win.buttons -in $win.position -x 0 -rely 1.0 ; after cancel lower $win.position ; raise $win.buttons " bind $win.buttons "deleteBalloon $c ; place forget $win.buttons" # pack $wb scrollbar $w.hscroll -orient horiz -command "$c xview" scrollbar $w.vscroll -command "$c yview" # -relief sunken canvas $c -borderwidth 2 \ -scrollregion {-1200 -1200 1200 1200} \ -xscrollcommand "$w.hscroll set" \ -yscrollcommand "$w.vscroll set" -cursor arrow -background white # puts "$c config -height [oget $win height] -width [oget $win width] " set buttonsLeft 1 set wid [oget $win width] catch {$c config -height [oget $win height] -width $wid oset $win oldCheight [oget $win height] oset $win oldCwidth $wid } # puts "$c height =[$c cget -height],$c width =[$c cget -width]" # bind $c <2> "$c scan mark %x %y" bind $c "$c scan dragto %x %y" bind $c <3> "$c scan mark %x %y" bind $c "$c scan dragto %x %y" bind $c "showPosition $w %x %y" bind $c "reConfigure $c %w %h" bind $c "raise $win.position" bind $c "after 200 lower $win.position" $w.position config -background [$c cget -background] pack $wb.dismiss $wb.help $wb.zoom \ $wb.postscript $wb.markrect $wb.replot $wb.config -side top -expand 1 -fill x if { 0 } { pack $w.hscroll -side bottom -expand 1 -fill x pack $w.vscroll -side right -expand 1 -fill y } pack $w.c -side right -expand 1 -fill both pack $w place $w.position -in $w -x 2 -y 2 -anchor nw oset $w position "Menu Here" if { ![info exists ws_openMath(showedplothelp)] || [llength $ws_openMath(showedplothelp)] < 2 } { lappend ws_openMath(showedplothelp) 1 after 100 balloonhelp $w $w.position [list \ "Initial help: Moving the mouse over the position \ window (top left corner), will bring up a menu. Holding down \ right mouse button and dragging will translate the plot"] after 2000 $w.c delete balloon } raise $w.position pack [winfo parent $wb] # update # set wid [ winfo width $win] # if { $wid > [ $c cget -width ] } { # $c config -width $wid # oset $win width $wid # } addSliders $w bind $w "resizePlotWindow $w %w %h" return $w } proc mkentry { newframe textvar text buttonFont } { frame $newframe set parent $newframe set found 0 while { !$found } { set parent [winfo parent $parent] if { "$parent" == "" } { break } if { ![catch { set type [oget $parent type] } ] } { global plot[set type]Options foreach v [set plot[set type]Options] { if { "[oloc $parent [lindex $v 0]]" == "$textvar" } { setBalloonhelp $parent $newframe [lindex $v 2] set found 1 break } } } } label $newframe.lab1 label $newframe.lab -text "$text:" -font $buttonFont -width 0 entry $newframe.e -width 20 -textvariable $textvar -font $buttonFont pack $newframe.lab1 -side left -expand 1 -fill x pack $newframe.lab -side left pack $newframe.e -side right -padx 3 -fill x # pack $newframe.lab $newframe.e -side left -padx 3 -expand 1 -fill x } proc doHelp { win msg } { makeLocal $win c set atx [$c canvasx 0] set aty [$c canvasy 0] $c create rectangle [expr {$atx -1000}] [expr {$aty -1000}] 10000 10000 -fill white -tag help $c create text [expr {$atx +10}] [expr {$aty + 10.0}] -tag help -anchor nw -width 400 -text $msg pushBind $c <1> "$c delete help; popBind $c <1>" } ## source push.tcl ###### push.tcl ###### ############################################################ # Netmath Copyright (C) 1998 William F. Schelter # # For distribution under GNU public License. See COPYING. # ############################################################ # #----------------------------------------------------------------- # # pushl -- push VALUE onto a stack stored under KEY # # Results: # # Side Effects: # #---------------------------------------------------------------- # global __pushl_ar proc pushl { val key } { global __pushl_ar append __pushl_ar($key) " [list $val]" } # #----------------------------------------------------------------- # # peekl -- if a value has been pushl'd under KEY return the # last value otherwise return DEFAULT. If M is supplied, get the # M'th one pushed... M == 1 is the last one pushed. # Results: a previously pushed value or DEFAULT # # Side Effects: none # #---------------------------------------------------------------- # proc peekl {key default {m 1}} { global __pushl_ar if { [catch { set val [set __pushl_ar($key) ] } ] } { return $default } else { set n [llength $val] if { $m > 0 && $m <= $n } { return [lindex $val [incr n -$m]] } else { return $default } } } # #----------------------------------------------------------------- # # popl -- pop off last value stored under KEY, or else return DFLT # # Results: last VALUE stored or DEFAULT # # Side Effects: List stored under KEY becomes one shorter # #---------------------------------------------------------------- # proc popl { key dflt} { global __pushl_ar if { [catch { set val [set __pushl_ar($key) ] } ] } { return $dflt } else { set n [llength $val] set result [lindex $val [incr n -1]] if { $n > 0 } { set __pushl_ar($key) [lrange $val 0 [expr {$n -1}]] } else {unset __pushl_ar($key) } return $result } } # #----------------------------------------------------------------- # # clearl -- clear the list stored under KEY # # Result: none # # Side Effects: clear the list stored under KEY # #---------------------------------------------------------------- # proc clearl { key } { global __pushl_ar catch { unset __pushl_ar($key) } } ## endsource push.tcl proc pushBind { win key action } { pushl [bind $win $key] [list $win $key ] bind $win $key $action } proc popBind { win key } { set binding [popl [list $win $key] {}] bind $win $key $binding } # exit if not part of openmath browser proc maybeExit { n } { if { "[info proc OpenMathOpenUrl]" != "" } { uplevel 1 return } else { exit 0 } } proc showPosition { win x y } { # global position c makeLocal $win c # we catch so that in case have no functions or data.. catch { oset $win position \ "[format {(%.2f,%.2f)} [storx$win [$c canvasx $x]] [story$win [$c canvasy $y]]]" } } proc showZoom { win } { # global c position makeLocal $win c oset $win position "Click to Zoom\nShift+Click Unzoom" bind $c <1> "doZoom $win %x %y 1" bind $c "doZoom $win %x %y -1" } proc doZoom { win x y direction } { set zf [oget $win zoomfactor] if { $direction < 0 } { set zf "[expr {1/[lindex $zf 0]}] [expr {1/[lindex $zf 1]}]" } eval doZoomXY $win $x $y $zf } # #----------------------------------------------------------------- # # doZoomXY -- given screen coordinates (x,y) and factors (f1,f2) # perform a scaling on the canvas, centered at (x,y) so that # the distance in the x direction from this origin is multiplied by f1 # and similarly in the y direction # Results: # # Side Effects: scale the canvas, and set new transforms for translation # from real to canvas coordinates. #---------------------------------------------------------------- # proc doZoomXY { win x y facx facy } { if { [catch { makeLocal $win c transform } ] } { # not ready return } set x [$c canvasx $x] set y [$c canvasy $y] $c scale all $x $y $facx $facy set ntransform [composeTransform \ "$facx 0 0 $facy [expr {(1-$facx)* $x}] [expr {(1-$facy)* $y}]" \ $transform ] oset $win transform $ntransform getXtransYtrans $ntransform rtosx$win rtosy$win getXtransYtrans [inverseTransform $ntransform] storx$win story$win axisTicks $win $c } # #----------------------------------------------------------------- # # scrollPointTo -- attempt to scroll the canvas so that point # x,y on the canvas appears at screen (sx,sy) # # Results: none # # Side Effects: changes x and y view of canvas # #---------------------------------------------------------------- # proc scrollPointTo { c x y sx sy } { desetq "x0 y0 x1 y1" [$c cget -scrollregion] $c xview moveto [expr { 1.0*($x-$x0-$sx)/($x1-$x0)} ] $c yview moveto [expr { 1.0*($y-$y0-$sy)/($y1-$y0)} ] } # #----------------------------------------------------------------- # # reConfigure -- # # Results: # # Side Effects: # #---------------------------------------------------------------- # proc reConfigure { c width height } { set w [winfo parent $c] if { [catch { makeLocal $w oldCwidth oldCheight } ] } { oset $w oldCwidth $width oset $w oldCheight $height return } set oldx [$c canvasx [expr {$oldCwidth/2.0}]] set oldy [$c canvasy [expr {$oldCheight/2.0}]] doZoomXY $w [expr {$oldCwidth/2.0}] [expr {$oldCheight/2.0}] \ [expr {1.0*$width/$oldCwidth}] [expr {1.0*$height/$oldCheight}] scrollPointTo $c $oldx $oldy [expr {$width/2.0}] [expr {$height/2.0}] # update oset $w oldCwidth $width oset $w oldCheight $height } proc writePostscript { win } { global printOption argv makeLocal $win c transform transform0 xmin ymin xmax ymax set rtosx rtosx$win ; set rtosy rtosy$win drawPointsForPrint $c if { "[$c find withtag printrectangle]" == "" } { # $c create rectangle [$rtosx $xmin] [$rtosy $ymin] [$rtosx $xmax] [$rtosy $ymax] -tags printrectangle -width .5 $c create rectangle [$c canvasx 0] [$c canvasy 0] [$c canvasx [$c cget -width ]] [$c canvasy [$c cget -height ]] -tags printrectangle -width .5 unbindAdjustWidth $c printrectangle [eval [oget $win maintitle]] } $c delete balloon set bbox [eval $c bbox [$c find withtag printrectangle]] desetq "x1 y1 x2 y2" $bbox # set title "unknown plot" # catch { set title [eval $printOption(maintitle)] } # $c create text [expr {($x1 + $x2)/2}] [expr {$y1 + .04 * ($y2 - $y1)}] \ # -anchor center -text $title -tag title update set diag [vectorlength [expr {$y1-$x1}] [expr {$y2-$x2}]] # get rid of little arrows that creep onto the outside, ie let # the blank rectangle cover them. set x1 [expr {$x1+.01 * $diag}] set x2 [expr {$x2-.01 * $diag}] set y1 [expr {$y1+.01 * $diag}] set y2 [expr {$y2-.01 * $diag}] set com "$c postscript \ -x $x1 -y $y1 \ -width [expr {($x2 - $x1)}] \ -height [expr {($y2 - $y1)}] \ [getPageOffsets [expr {($x2 - $x1)/(1.0*($y2 - $y1))}] ] " #puts com=$com set output [eval $com] switch $printOption(tofile) { 0 { global tcl_platform set usegsview 0 if { "$tcl_platform(platform)" == "windows" } { set usegsview 1 } if { $usegsview } { set fi [open $printOption(psfilename) w] puts $fi $output close $fi exec "$printOption(gsview) /S $printOption(psfilename)" } else { set fi [open "|lpr -P[set printOption(printer)]" w] puts $fi $output close $fi } } 1 { set fi [open $printOption(psfilename) w] puts $fi $output close $fi } 2 { global ftpInfo set ftpInfo(data) $output ftpDialog $win } } # if { $printOption(tofile) } { # set fi [open $printOption(psfilename) w] # } else { set fi [open "|lpr -P[set printOption(printer)]" w] } # puts $fi $output # close $fi } # #----------------------------------------------------------------- # # ftpDialog -- open up a dialog to send ftpInfo(data) to a file # via http and ftp. The http server can be specified. # # Results: # # Side Effects: # #---------------------------------------------------------------- # set ftpInfo(host) genie1.ma.utexas.edu set ftpInfo(viahost) genie1.ma.utexas.edu proc ftpDialog { win args } { global ftpInfo buttonFont fontSize set fr ${win}plot set usefilename [assoc -filename $args 0] if { "$usefilename" != "0"} { set ftpInfo(filename) $usefilename set usefilename 1 } catch { destroy $fr } set ftpInfo(percent) 0 set buttonFont [font create -family Courier -size $fontSize] frame $fr -borderwidth 2 -relief raised if { [catch { set ftpInfo(directory) } ] } { set ftpInfo(directory) homework } label $fr.title -text "Ftp Dialog Box" -font [font create -family Helvetica -size [expr {2+ $fontSize}]] mkentry $fr.host ftpInfo(host) "host to write file on" $buttonFont mkentry $fr.viahost ftpInfo(viahost) "host to write to via" $buttonFont mkentry $fr.username ftpInfo(username) "Your User ID on host" $buttonFont mkentry $fr.password ftpInfo(password) "Your password on host" $buttonFont $fr.password.e config -show * mkentry $fr.directory ftpInfo(directory) "remote subdirectory for output" $buttonFont if { $usefilename } { mkentry $fr.filename ftpInfo(filename) "filename " $buttonFont } else { mkentry $fr.chapter ftpInfo(chapter) "chapter " $buttonFont mkentry $fr.section ftpInfo(section) "section" $buttonFont mkentry $fr.problemnumber ftpInfo(number) "Problem number" $buttonFont } scale $fr.scale -orient horizontal -variable ftpInfo(percent) -length 100 button $fr.doit -text "Send it" -command "doFtpSend $fr" -font $buttonFont button $fr.cancel -text "Cancel" -command "destroy $fr" -font $buttonFont set ftpInfo(message) "" label $fr.message -width 30 -height 3 -textvariable ftpInfo(message) -font $buttonFont eval pack [winfo children $fr] -side top raise $fr place $fr -in $win -relx .5 -rely .5 -anchor center } proc doFtpSend { fr } { global ftpInfo om_ftp set error "" if { [winfo exists $fr.filename] } { set filename $ftpInfo(filename) set check "host username directory filename" } else { set check "host username directory chapter section number" } foreach v $check { if { $ftpInfo($v) == "" } { if { "$error" == "" } { set error "Failed to specify $v " } else { append error ", $v"} } } if { "$error" != "" } { set ftpInfo(message) $error return -1 } if { [winfo exists $fr.chapter] } { set filename "$ftpInfo(chapter).$ftpInfo(section)-$ftpInfo(number).ps" } set res [submitFtp $ftpInfo(viahost) $ftpInfo(host) $ftpInfo(username) $ftpInfo(password) $ftpInfo(directory) $filename] if { "$res" == 1 } { after 1000 "destroy $fr" } return $res # set counter [ ftp $ftpInfo(host) $ftpInfo(username) $ftpInfo(password)] # if { $counter < 0 } { # set ftpInfo(message) [concat "Failed:" $om_ftp($counter,log)] # return -1 # } # if { [ftpDoCd $counter $ftpInfo(directory)] < 0 && # [ftpDoMkdir $counter $ftpInfo(directory)] > -10 && # [ftpDoCd $counter $ftpInfo(directory)] < 0 } { # set ftpInfo(message) [concat "Failed:" $om_ftp($counter,log)] # return -1 # } # set res [ftpDoStore $counter $ftpInfo(chapter).$ftpInfo(section)-$ftpInfo(number).ps $ftpInfo(data)] # if { $res < 0 } { # set ftpInfo(message) "Failed: $om_ftp($counter,log)" # return -1 # } else { # set ftpInfo(message) "Wrote $ftpInfo(directory)/$ftpInfo(chapter).$ftpInfo(section)-$ftpInfo(number).ps" # after 1000 destroy $fr # } # ftpClose $counter } proc vectorlength { a b } { return [expr {sqrt($a*$a + $b * $b)} ] } proc setupCanvas { win } { makeLocal $win xcenter xradius ycenter yradius oset $win xmin [expr {$xcenter - $xradius}] oset $win xmax [expr { $xcenter + $xradius}] oset $win ymin [expr { $ycenter - $yradius}] oset $win ymax [expr { $ycenter + $yradius} ] } # #----------------------------------------------------------------- # # compose -- A and B are transformations of the form "origin scalefac" # and composing them means applying first b then a, as in a.b.x # "o s" . x ==> (x-o)*s + o # Results: the "origin scalefac" which corresponds to the composition. # # Side Effects: # #---------------------------------------------------------------- # proc compose { a b } { return "[expr {-[lindex $a 1]*[lindex $b 0]*[lindex $b 1] \ +[lindex $a 1]*[lindex $b 0]-[lindex $a 0]*[lindex $a 1] \ +[lindex $a 0]}] [expr {[lindex $a 1]*[lindex $b 1]}]" } # the following two have been replaced # proc sparseList { s } { # if { [catch { # set val [parseConvert "$s" -variables "x y t"] } err ] } { # error "Syntax error with `$s'\n $err" # } # return [lindex $val 0] # } # # proc sparse { s } { # set val [sparseList $s] # set first $val # if { [llength $first] != 1 } { # error "only one function wanted" } # # return [lindex $first 0] # } proc sparseListWithParams { form variables paramlist } { set tem [parseConvert $form -doall 1] #puts tem=$tem set params [splitParams $paramlist] if { [catch {set res [substParams [lindex $tem 0] $variables $params] }\ err ] } { set vars [lindex $tem 1] set all $variables foreach { v val } $params { lappend all $v} foreach v $vars { if { [lsearch $all [string range $v 1 end]] < 0 } { error "The variable `[string range $v 1 end]' appeared in $form but was not in allowed variables:{$variables} or in parameters: {$paramlist}" } } error "The form $form may involve variables other than {$variables} or the parameters {$paramlist}, or the latter may have invalid expressions:\n $err" } return $res } proc sparseWithParams { form variables params } { set tem [sparseListWithParams $form $variables $params] if { [llength $tem ] > 1 } { error "only wanted one function: $form"} lindex $tem 0 } # #----------------------------------------------------------------- # # myVarSubst -- into FORM substitute where # listVarsVals where each element of this list may mention # the previous values eg "k 7 ll sin(k+8)" # eg: #myVarSubst [lindex [parseConvert "k*x+l" -doall 1] 0] {x $x k 27+4 l 93+k^3} # ==> {((31 * $x) + 29884.0)} # # Results: FORM with the substitutions done # # Side Effects: # #---------------------------------------------------------------- # proc myVarSubst { form listVarsVals } { foreach {_u _v} $listVarsVals { if { "\$$_u" == "$_v" } { set $_u $_v } else { set _f1 [lindex [parseConvert $_v -doall 1] 0] set $_u [expr [lindex $_f1 0]] # puts "$_u = [set $_u]" } } subst -nobackslashes -nocommands $form } proc splitParams { paramlist } { set params "" foreach v [split $paramlist ,] { set tem [split $v =] if { [llength $tem] == 2 } { lappend params [lindex $tem 0] [lindex $tem 1] } } return $params } # #----------------------------------------------------------------- # # substParams -- substitute into FORM keeping VARIABLES as they are # and the PARAMLIST (of the form k=23, l=k+7,...) into FORM # # Results: substituted FORM # # Side Effects: none # #---------------------------------------------------------------- # proc substParams { form variables params } { foreach v $variables { lappend params $v \$$v} set res [myVarSubst $form $params] return $res } # #----------------------------------------------------------------- # # setUpTransforms -- set up transformations for the canvas of WINDOW # so that the image is on FACTOR fractionof the window # these transforms are used for real to screen and vice versa. # Results: # # Side Effects: transform functions rtosx$win rtosy$win storx$win story$win # are defined. # #---------------------------------------------------------------- # proc setUpTransforms { win fac } { makeLocal $win xcenter ycenter xradius yradius c set delx [$c cget -width] set dely [$c cget -height] set f1 [expr {(1 - $fac)/2.0}] set x1 [expr {$f1 *$delx}] set y1 [expr {$f1 *$dely}] set x2 [expr {$x1 + $fac*$delx}] set y2 [expr {$x1 + $fac*$dely}] set xmin [expr {$xcenter - $xradius}] set xmax [expr {$xcenter + $xradius}] set ymin [expr {$ycenter - $yradius}] set ymax [expr {$ycenter + $yradius}] oset $win xmin $xmin oset $win xmax $xmax oset $win ymin $ymin oset $win ymax $ymax oset $win transform [makeTransform "$xmin $ymin $x1 $y2" "$xmin $ymax $x1 $y1 " "$xmax $ymin $x2 $y2"] set transform [makeTransform "$xmin $ymin $x1 $y2" "$xmin $ymax $x1 $y1 " "$xmax $ymin $x2 $y2"] oset $win transform $transform oset $win transform0 $transform getXtransYtrans $transform rtosx$win rtosy$win getXtransYtrans [inverseTransform $transform] storx$win story$win } proc inputParse { in } { if { [regexp -indices \ {D\[([a-zA-Z][0-9a-zA-Z]*[ ]*),([a-zA-Z][0-9a-zA-Z]*[ ]*)\] *=} \ $in all1 i1 i2] } { set v1 [getOneMatch $in $i1] set v2 [getOneMatch $in $i2] set s1 [string range $in [lindex $all1 1] end] if { [regexp -indices {,[ \n]*D\[([a-zA-Z][0-9a-zA-Z]*[ ]*),([a-zA-Z][0-9a-zA-Z]*[ ]*)\] *=} \ $s1 all2 i1 i2] } { set v3 [getOneMatch $s1 $i1] set v4 [getOneMatch $s1 $i2] set end [string first \} $s1 ] set form2 [string range $s1 [expr {1 + [lindex $all2 1]}] [expr {$end -1}]] if { "$v4" != "$v2" } {error "different variable $v2 and $v4"} set form1 [string range $in [expr {1 + [lindex $all1 1]}] [expr {[lindex $all2 0] + -1 + [lindex $all1 1]}]] return [list $v2 $v1 $v3 $form1 $form2] # puts "v1=$v1,form1=$form1,form2=$form2" } } } proc composeTransform { t1 t2 } { desetq "a11 a12 a21 a22 e1 e2" $t1 desetq "b11 b12 b21 b22 f1 f2" $t2 return [list \ [expr {$a11*$b11+$a12*$b21}] \ [expr {$a11*$b12+$a12*$b22}] \ [expr {$a21*$b11+$a22*$b21}] \ [expr {$a22*$b22+$a21*$b12}] \ [expr {$a11*$f1+$a12*$f2+$e1}] \ [expr {$a21*$f1+$a22*$f2+$e2}] ] } # #----------------------------------------------------------------- # # makeTransform -- Given three points mapped to three other points # write down the affine transformation (A.X+B) which performs this. # the arguments are of the form "x1 y1 u1 v1" "x2 y2 u2 v2" "x3 y3 u3 v3" # where (x1,y1) --> (u1,v1) etc. # Results: an affine transformation "a b c d e f" which is # [ a b ] [ x1 ] + [ e ] # [ c d ] [ y1 ] [ f ] # Side Effects: none # #---------------------------------------------------------------- # proc makeTransform { P1 P2 P3 } { desetq "X1 Y1 U1 V1" $P1 desetq "X2 Y2 U2 V2" $P2 desetq "X3 Y3 U3 V3" $P3 set tem [expr {double((($X2-$X1)*$Y3+($X1-$X3)*$Y2+($X3-$X2)*$Y1))}] set A [expr {(($U2-$U1)*$Y3+($U1-$U3)*$Y2+($U3-$U2)*$Y1) \ /$tem}] set B [expr {-(($U2-$U1)*$X3+($U1-$U3)*$X2+($U3-$U2)*$X1) \ /$tem}] set E [expr {(($U1*$X2-$U2*$X1)*$Y3+($U3*$X1-$U1*$X3)*$Y2+($U2*$X3-$U3*$X2)*$Y1) \ /$tem}] set C [expr {(($V2-$V1)*$Y3+($V1-$V3)*$Y2+($V3-$V2)*$Y1) \ /$tem}] set D [expr {-(($V2-$V1)*$X3+($V1-$V3)*$X2+($V3-$V2)*$X1) \ /$tem}] set F [expr {(($V1*$X2-$V2*$X1)*$Y3+($V3*$X1-$V1*$X3)*$Y2+($V2*$X3-$V3*$X2)*$Y1) \ /$tem}] set xf "" set yf "" if { $B == 0 && $C == 0 } { set xf "$A*\$X+$E" set yf "$D*\$Y+$F" } return [list $A $B $C $D $E $F] } # #----------------------------------------------------------------- # # getXtransYtrans -- If the x coordinate transforms independently # of the y and vice versa, give expressions suitable for building a # proc. # Results: # # Side Effects: # #---------------------------------------------------------------- # proc getXtransYtrans { transform p1 p2 } { desetq "a b c d e f" $transform if { $b == 0 && $c == 0 } { proc $p1 { x } "return \[expr {$a*\$x+$e}\]" proc $p2 { y } "return \[expr {$d*\$y+$f} \]" return 1 } return 0 } # #----------------------------------------------------------------- # # inverseTransform -- Find the inverse of an affine transformation. # # Results: # # Side Effects: # #---------------------------------------------------------------- # proc inverseTransform { transform } { desetq "a b c d e f" $transform set det [expr {double($a*$d - $b*$c)}] 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}]] } # #----------------------------------------------------------------- # # getTicks -- given an interval (a,b) subdivide it and # calculate where to put the ticks and what to print there. # we want DESIRED number of ticks, but we also want the ticks # to be at points in the real coords of the form .2*10^i or .5*10^j # Results: the ticks # # Side Effects: # #---------------------------------------------------------------- # proc getTicks { a b n } { set len [expr {(($b - $a))}] if { $len < [expr {pow(10,-40)}] } { return ""} set best 0 foreach v { .1 .2 .5 } { # want $len/(.1*10^i) == $n set val($v) [expr {ceil(log10($len/(double($n)*$v)))}] set use [expr {$v*pow(10,$val($v))}] set fac [expr {1/$use}] set aa [expr {$a * $fac + .03}] set bb [expr {$b * $fac -.03}] set j [expr {round(ceil($aa)) }] set upto [expr {floor($bb) }] set ticks "" while { $j <= $upto } { set tt [expr {$j / $fac}] if { $j%5 == 0 } { append ticks " { $tt $tt }" } else { append ticks " $tt" } incr j } set answer($v) $ticks set this [llength $ticks] if { $this > $best } { set best $this set at $v } #puts "for $v [llength $ticks] ticks" } #puts "using $at [llength $answer($at)]" return $answer($at) } proc axisTicks { win c } { $c delete axisTicks if { ![catch {oget $win noaxisticks}] } { return } set swid [$c cget -width] set shei [$c cget -height] set x1 [storx$win [$c canvasx 0]] set y1 [story$win [$c canvasy 0]] set x2 [storx$win [$c canvasx $swid]] set y2 [story$win [$c canvasy $shei]] #puts "x1=$x1,y1=$y1,y2=$y2,x2=$x2" if { $y1 > 0 && $y2 < 0 } { set ticks [getTicks $x1 $x2 [expr {$swid/50}] ] #puts "ticks=$ticks" set eps [expr {.005 * abs($y1 - $y2)}] set neps [expr {-.005 * abs($y1 - $y2)}] set donext 0 foreach v $ticks { set x [lindex $v 0] set text [lindex $v 1] if { $donext } {set text [lindex $v 0] ; set donext 0 } if { [lindex $v 0] == 0 } { set text "" ; set donext 1 } #puts " drawTick $c $x 0 0 $neps 0 $eps $text axisTicks" drawTick $c $x 0 0 $neps 0 $eps $text axisTicks } } if { 0 < $x2 && 0 > $x1 } { set ticks [getTicks $y2 $y1 [expr {$shei/50}]] set eps [expr {.005 * ($x2 - $x1)}] set neps [expr {-.005 * ($x2 - $x1)}] set donext 0 foreach v $ticks { set y [lindex $v 0] set text [lindex $v 1] if { $donext } {set text [lindex $v 0] ; set donext 0} if { [lindex $v 0] == 0 } { set text "" ; set donext 1} drawTick $c 0 $y $neps 0 $eps 0 $text axisTicks } } } # #----------------------------------------------------------------- # # marginTicks -- draw ticks around the border of window # x1,y1 top left x2,y2 bottom right. # # Results: # # Side Effects: # #---------------------------------------------------------------- # proc marginTicks { c x1 y1 x2 y2 tag } { global printOption set win [winfo parent $c] if { ![catch {oget $win noaxisticks}] } { return } $c delete marginTicks set ticks [getTicks $x1 $x2 $printOption(xticks)] # puts "x=$x1 $x2" set eps [expr {.008 * ($y1 - $y2)}] set neps [expr {-.008 * ($y1 - $y2)}] foreach v $ticks { set x [lindex $v 0] set text [lindex $v 1] drawTick $c $x $y1 0 0 0 $neps $text $tag drawTick $c $x $y2 0 0 0 $eps $text $tag } #puts "y=$y2,$y1" set ticks [getTicks $y1 $y2 $printOption(yticks)] set eps [expr {.005 * ($x2 - $x1)}] set neps [expr {-.005 * ($x2 - $x1)}] set donext 0 foreach v $ticks { set y [lindex $v 0] set text [lindex $v 1] drawTick $c $x1 $y 0 0 $eps 0 $text $tag drawTick $c $x2 $y 0 0 $neps 0 $text $tag } } proc drawTick {c x y dx dy ex ey n tags} { global axisGray fontCourier8 set win [winfo parent $c] set rtosx rtosx$win ; set rtosy rtosy$win 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] $c lower $it if { "$n" != "" } { if { $ey > 0 } { set anch s } elseif { $ex > 0 } {set anch w } elseif { $ex < 0 } {set anch e } elseif { $ey < 0 } {set anch n} $c create text [$rtosx [expr {$x +1.5*$ex}]] [$rtosy [expr {$y +1.5*$ey}]] \ -text [format "%.8g" $n] -font $fontCourier8 -tags $tags \ -anchor $anch } } proc doConfig { win } { makeLocal $win c buttonFont $c delete configoptions set canv $c # set w $c.config set w $win.config catch {destroy $w} frame $w -borderwidth 2 -relief raised label $w.msg -wraplength 600 -justify left -text "Plot Setup" -font $buttonFont pack $w pack $w.msg -side top set wb1 $w.choose1 frame $wb1 set wb2 $w.choose2 frame $wb2 pack $wb1 $wb2 -side left -fill x -pady 2m set item [$canv create window [$canv canvasx 10] [$canv canvasy 10] -window $w -anchor nw -tags configoptions] button $wb1.dismiss -command "$canv delete $item; destroy $w " -text "ok" -font $buttonFont button $wb1.printoptions -text "Print Options" -command "mkPrintDialog .dial -canvas $c -buttonfont $buttonFont " -font $buttonFont pack $wb1.dismiss $wb1.printoptions -side top return "$wb1 $wb2" } # mkentry { newframe textvar text } set show_balloons 1 proc balloonhelp { win subwin msg } { global show_balloons if { $show_balloons == 0 } return; linkLocal [oget $win c] helpPending if { [info exists helpPending] } {after cancel $helpPending} set helpPending [after 1000 [list balloonhelp1 $win $subwin $msg]] } proc balloonhelp1 { win subwin msg } { if { ![winfo exists $win] } { return } makeLocal $win c buttonFont set x0 [winfo rootx $win] set y0 [winfo rooty $win] set atx [expr {[winfo rootx $subwin] + [winfo width $subwin] - $x0} ] set aty [expr {[winfo rooty $subwin] + [winfo height $subwin] - $y0} ] set wid [$c cget -width] set wid2 [expr {round ($wid /2.0)}] set wid10 [expr {round ($wid /10.0)}] if { $aty <=1 } { set aty 30 } incr aty 10 incr atx 10 set atx [$c canvasx $atx] set aty [$c canvasy $aty] #puts "$atx $aty" $c delete balloon $c create text $atx $aty -anchor nw -text $msg -font $buttonFont -width $wid2 -fill white -fill black -tags "balloon btext" desetq "x1 y1 x2 y2" [$c bbox btext] set x1 [expr {$x1 - .3*($x2-$x1)}] set x2 [expr {$x2 + .3*($x2-$x1)}] set y1 [expr {$y1 - .3*($y2-$y1)}] set y2 [expr {$y2 + .3*($y2-$y1)}] eval $c create polygon $x1 $y1 $x2 $y1 $x2 $y2 $x1 $y2 -fill beige -tags balloon -smooth 1 $c raise btext } proc setBalloonhelp { win subwin msg } { makeLocal $win c bind $subwin "balloonhelp $win $subwin [list $msg]" bind $subwin "deleteBalloon $c" } proc deleteBalloon { c } { linkLocal $c helpPending if { [info exists helpPending] } { after cancel $helpPending unset helpPending } $c delete balloon } # #----------------------------------------------------------------- # # minMax -- Compute the max and min of the arguments, which may # be vectors or numbers # # Results: list of MIN and MAX # # Side Effects: none # #---------------------------------------------------------------- # proc minMax { args } { set max [lindex [lindex $args 0] 0] ; set min $max ; foreach vec $args { foreach v $vec { if { $v > $max } {set max $v } if { $v < $min} {set min $v } } } return [list $min $max] } proc matrixMinMax { list } { # compute the min max of the list set min +10e300 set max -10e300 foreach mat $list { foreach row $mat { foreach v [ldelete nam $row] { if { $v > $max } {catch { set max [expr {$v + 0}] }} if { $v < $min} {catch { set min [expr {$v + 0}] }} } } } list $min $max } proc omPlotAny { data args } { # puts "data=<[lindex $data 0]>" set command [list [lindex [lindex $data 0] 0] -data [lindex $data 0] ] if { "[lindex $command 0]" == "plot2d" } { lappend command -xfun {} } foreach v $args { [lappend command $v] } eval $command #eval [lindex [lindex $data 0] 0] -xfun [list {}] -data [list [lindex $data 0]] $args } proc resizeSubPlotWindows { win wid height } { set at [$win yview "@0,0"] foreach w [winfo children $win] { if { [string match plot* [lindex [split $w .] end]] } { resizePlotWindow $w [winfo width $w] $height } } if { "$at" != "" } { $win yview $at} } proc resizePlotWindow { w width height } { if { [winfo width $w.c] <= 1 } { after 100 update ; return } if { ![catch { set tem [oget $w lastResize] } ] && [expr {[clock seconds] - $tem }] < 2 } { return } else { oset $w lastResize [clock seconds ] } #puts "resizePlotWindow $w $width $height" # return set par [winfo parent $w] set facx 1.0 set facy 1.0 set wid [winfo width $par] set hei [winfo height $par] if { "[winfo class $par]" == "Text" } { set dif 10 set wid1 $wid ; set hei1 $hei #puts "now w=$w" #set wid1 [getPercentDim [oget $w widthDesired] width $par] catch {set wid1 [getPercentDim [oget $w widthDesired] width $par] } catch {set hei1 [getPercentDim [oget $w heightDesired] height $par] } set wid [expr {($wid1 > $wid - 30 ? $wid - 30 : $wid1 )}] set hei [expr {($hei1 > $hei - 30 ? $hei - 30 : $hei1 )}] } else { set dif 10 } #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]" # if { $width > $wid -20 || $wid > $width -20 } if { (abs($width-$wid) > $dif || abs($height-$hei) > $dif) && [winfo width $w.c] > 1 } { set eps [expr {2 * [$w.c cget -insertborderwidth] + [$w.c cget -borderwidth] }] set epsx $eps set epsy $eps #puts "reconfiguring: w=$w,par=$par,dif=$dif,widths=$wid, \ $width,[winfo width $par],[winfo width $w],[winfo width $w.c]\ heights=$hei,$height,[winfo height $par],[winfo height $w],\ [winfo height $w.c]" set extrawidth [expr {([winfo width $w] - [winfo width $w.c]) +$epsx}] set extraheight [expr {([winfo height $w] - [winfo height $w.c]) +$epsy}] set nwidth [expr {$wid - ($extrawidth > 0 ? $extrawidth : 0)}] set nheight [expr {$hei - ($extraheight > 0 ? $extraheight : 0)}] #puts "$w.c config -width $nwidth -height $nheight, extraheight=$extraheight,epsy=$epsy" $w.c config -width $nwidth -height $nheight } } proc bboxToRadius { win } { makeLocal $win bbox if { "$bbox" != "" } { linkLocal $win xradius yradius xcenter ycenter set i 0 foreach v { x y z } { set min [lindex $bbox $i] set max [lindex $bbox [expr $i +2]] if { "$min" != "" } { if { $min >= $max } {error "bad bbox $bbox since $min >= $max"} set ${v}radius [expr { ($max - $min) /2.0}] set ${v}center [expr { ($max + $min) /2.0}] } } } } proc updateParameters { win var value} { linkLocal $win parameters # puts "$win $var $value" set ans "" set comma "" foreach {v val} [splitParams $parameters] { if { "$v" == "$var" } { set val $value } append ans $comma $v=$val set comma "," } # puts "parameters=$ans" set parameters $ans } proc addSliders { win } { linkLocal $win sliders c width parameters set i 0 if { "$sliders" == "" } { return } catch { destroy $c.sliders } set bg "#22aaee" set trough "#22ccff" frame $c.sliders -relief raised -highlightthickness 2 -highlightbackground $trough foreach v [split $sliders ,] { if { [regexp {([a-zA-Z0-9]+)[ ]*=?(([---0-9.]+):([---0-9.]+))?} $v junk var junk x0 x1] } { incr i if { "$x0" == "" } { set x0 -5 ; set x1 5} set fr $c.sliders.fr$i frame $fr -background $bg label $fr.lab -text $var: -background $bg label $fr.labvalue -textvariable [oloc $win slidevalue$i] -background $bg -relief sunken -justify left scale $fr.scale -command "sliderUpdate $win $var" \ -from "$x0" -to $x1 -orient horizontal \ -resolution [expr ($x1 - $x0) < 1 ? ($x1-$x0)/100.0 : .01] \ -length [expr {$width/2}] -showvalue 0 -variable [oloc $win slidevalue$i] -background $bg -troughcolor "#22ccff" -highlightthickness 0 pack $fr.lab -side left -expand 1 -fill x pack $fr.labvalue $fr.scale -side left pack $fr -side top -expand 1 -fill x set found 0 set val [assoc $var [splitParams $parameters] no] if { "$val" == "no" } { set val [expr ($x1 + $x0)/2.0] if { "$parameters" != "" } { append parameters , } append parameters $var=$val } $fr.scale set $val } } place $c.sliders -in $c -x 4 -rely 1.0 -y -4 -anchor sw } proc sliderUpdate { win var val } { linkLocal $win sliderCommand parameters set params $parameters updateParameters $win $var $val if { "$params" != "$parameters" && [info exists sliderCommand] } { $sliderCommand $win $var $val } } ## endsource plotconf.tcl ## source plotdf.tcl ###### plotdf.tcl ###### ####################################################################### ####### Copyright William F. Schelter. All rights reserved. ######## ####################################################################### set plotdfOptions { {dxdt "x-y^2+sin(x)*.3" {specifies dx/dt = dxdt. eg -dxdt "x+y+sin(x)^2"} } {dydt "x+y" {specifies dy/dt = dydt. eg -dydt "x-y^2+exp(x)"} } {dydx "" { may specify dy/dx = x^2+y,instead of dy/dt = x^2+y and dx/dt=1 }} {adamsMoulton red "Color to do adams moulton integration in. None means dont do" } {rungeKuttaA "" "Color to do Runge Kutta adaptive integration in. None means dont do" } {xradius 10 "Width in x direction of the x values" } {yradius 10 "Height in y direction of the y values"} {width 500 "Width of canvas in pixels"} {height 500 "Height of canvas in pixels" } {scrollregion {} "Area to show if canvas is larger" } {xcenter 0.0 {(xcenter,ycenter) is the origin of the window}} {ycenter 0.0 "see xcenter"} {bbox "" "xmin ymin xmax ymax .. overrides the -xcenter etc"} {tinitial 0.0 "The initial value of variable t"} {nsteps 100 "Number of steps to do in one pass"} {xfun "" "A semi colon separated list of functions to plot as well"} {tstep "" "t step size"} {direction "both" "May be both, forward or backward" } {versus_t 0 "Plot in a separate window x and y versus t, after each trajectory" } {windowname ".dfplot" "window name"} {parameters "" "List of parameters and values eg k=3,l=7+k"} {sliders "" "List of parameters ranges k=3:5,u"} {linecolors { green black brown gray black} "colors to use for lines in data plots"} {doTrajectoryAt "" "Place to calculate trajectory"} {linewidth "1.0" "Width of integral lines" } {nolines 0 "If not 0, plot points and nolines"} {bargraph 0 "If not 0 this is the width of the bars on a bar graph" } {plotpoints 0 "if not 0 plot the points at pointsize" } {pointsize 2 "radius in pixels of points" } {autoscale "x y" "Set {x,y}center and {x,y}range depending on data and function. "} {zoomfactor "1.6 1.6" "Factor to zoom the x and y axis when zooming. Zoom out will be reciprocal" } {errorbar 0 "If not 0 width in pixels of errorbar. Two y values supplied for each x: {y1low y1high y2low y2high .. }"} {data "" "List of data sets to be plotted. Has form { {xversusy {x1 x2 ... xn} {y1 .. yn ... ym}} .. {againstIndex {y1 y2 .. yn}} .. }"} {labelposition "10 35" "Position for the curve labels nw corner"} } if { "[info proc makeFrame]" == "" } { source "plotconf.tcl" } proc makeFrameDf { win } { set w [makeFrame $win df] makeLocal $win c dydx set top $win # puts "w=$w,win=$win" catch { set top [winfo parent $win]} catch { wm title $top "Direction Fields" wm iconname $top "DF plot" # wm geometry $top 750x700-0+20 } set wb $w.buttons makeLocal $win buttonFont label $w.msg -wraplength 600 -justify left -text "A direction field plotter by William Schelter" -font $buttonFont button $wb.integrate -text "Integrate" -command "setForIntegrate $w" -font $buttonFont 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.} button $wb.plotversust -text "Plot Versus t" -command "plotVersusT $w" -font $buttonFont setBalloonhelp $win $wb.plotversust {Plot the x and y values for the last trajectory versus t.} setForIntegrate $w pack $wb.integrate -side top -expand 1 -fill x pack $wb.plotversust -side top -expand 1 -fill x # pack $w.msg -side top pack $w return $win } proc swapChoose {win msg winchoose } { # global dydx dxdt dydt if { "$msg" == "dydt" } { pack $winchoose.dxdt -before $winchoose.dydt -side bottom oset $win dydx "" $winchoose.dydt.lab config -text "dy/dt" } else { pack forget $winchoose.dxdt oset $win dxdt 1 oset $win dydx " " $winchoose.dydt.lab config -text "dy/dx" } } proc doHelpdf { win } { global Parser doHelp $win [join [list \ { William Schelter's solver/plotter for ode systems. To QUIT this HELP click here. Clicking at a point computes the trajectory (x(t),y(t)) starting at that point, and satisfying the differential equation dx/dt = dxdt dy/dt = dydt By clicking on Zoom, the mouse now allows you to zoom in on a region of the plot. Each click near a point magnifies the plot, keeping the center at the point you clicked. Depressing the SHIFT key while clicking zooms in the opposite direction. To resume computing trajectories click on Integrate. To change the differential equation, click on Config and enter new values in the entry windows, and then click on Replot in the main menu bar. Holding the right mouse button down allows you to drag (translate) the plot sideways or up and down. Additional parameters such as the number of steps (nsteps), the initial t value (tinitial), and the x and y centers and radii, may be set under the Config menu. You may print to a postscript printer, or save the plot \ as a postscript file, by clicking on save. To change \ between printing and saving see the Print Options under Config. } $Parser(help)]] } proc setForIntegrate { win} { makeLocal $win c $c delete printrectangle bind $c <1> "doIntegrateScreen $win %x %y " } ## source rk.tcl ###### rk.tcl ###### ####################################################################### ####### Copyright William F. Schelter. All rights reserved. ######## ####################################################################### #proc try { } { # proc ff { a b c } { return [expr {$b + $c}] } # proc gg { a b c } { return [expr {$b - $c}] } # rungeKutta ff gg 0.2 0.2 0 .01 10 #} proc rungeKutta { f g t0 x0 y0 h nsteps } { set n $nsteps set ans "$x0 $y0" set xn $x0 set yn $y0 set tn $t0 set h2 [expr {$h / 2.0 }] set h6 [expr {$h / 6.0 }] catch { while { [incr nsteps -1] >= 0 } { set kn1 [$f $tn $xn $yn] set ln1 [$g $tn $xn $yn] set arg [list [expr {$tn + $h2}] [expr {$xn + $h2 * $kn1}] [expr {$yn + $h2*$ln1}]] set kn2 [eval $f $arg] set ln2 [eval $g $arg] set arg [list [expr {$tn + $h2}] [expr {$xn + $h2 * $kn2}] [expr {$yn +$h2*$ln2}]] set kn3 [eval $f $arg] set ln3 [eval $g $arg] set arg [list [expr {$tn + $h}] [expr {$xn + $h * $kn3}] [expr {$yn + $h*$ln3}]] set kn4 [eval $f $arg] set ln4 [eval $g $arg] set xn [expr {$xn + $h6 * ($kn1+2*$kn2+2*$kn3+$kn4)}] set yn [expr {$yn + $h6 * ($ln1+2*$ln2+2*$ln3+$ln4)}] set tn [expr {$tn+ $h}] lappend ans $xn $yn } } return $ans } proc pathLength { list } { set sum 0 foreach { x y } $list { set sum [expr {$sum + sqrt($x*$x+$y*$y)}] } return $sum } proc rungeKuttaA { f g t0 x0 y0 h nsteps } { set ans [rungeKutta $f $g $t0 $x0 $y0 $h $nsteps] set count 0 # puts "retrying([llength $ans]) .." while { [llength $ans] < $nsteps * .5 && $count < 7 } { incr count #set leng [pathLength $ans] #if { $leng == 0 } {set leng .001} set th [expr {$h / 3.0}] if { $th < $h } { set h $th } set ans [rungeKutta $f $g $t0 $x0 $y0 $h $nsteps] # puts -nonewline "..(h=[format "%.5f" $h],pts=[llength $ans])" # flush stdout } return $ans } ## endsource rk.tcl ## source adams.tcl ###### adams.tcl ###### proc adamsMoulton { f g t0 x0 y0 h nsteps } { set ans [rungeKutta $f $g $t0 $x0 $y0 $h 3] catch { set i 0 set h24 [expr {$h /24.0}] foreach { x y } $ans { lappend listXff [xff [expr {$t0 + $i * $h} ] $x $y] lappend listYff [yff [expr {$t0 + $i * $h} ] $x $y] incr i set xn $x set yn $y } set n [expr $nsteps -3] while { [incr n -1] >= 0 } { #puts "listXff = $listXff" #puts "listYff = $listYff" # adams - bashford formula: set xp [expr {$xn + ($h24)*(55 *[lindex $listXff 3]-59*[lindex $listXff 2]+37*[lindex $listXff 1]-9*[lindex $listXff 0]) }] set yp [expr {$yn + ($h24)*(55 *[lindex $listYff 3]-59*[lindex $listYff 2]+37*[lindex $listYff 1]-9*[lindex $listYff 0]) }] #puts "i=$i,xp=$xp,yp=$yp" # adams-moulton corrector-predictor: # compute the yp = yn+1 value.. set t [expr {$t0 + $i * $h}] incr i if { 1 } { set xap [expr { $xn+($h24)*(9*[xff $t $xp $yp]+19*[lindex $listXff 3]-5*[lindex $listXff 2]+[lindex $listXff 1]) }] set yap [expr { $yn+($h24)*(9*[yff $t $xp $yp]+19*[lindex $listYff 3]-5*[lindex $listYff 2]+[lindex $listYff 1]) }] set xn $xap set yn $yap # puts "after correct:i=[expr $i -1],xn=$xn,yn=$yn" # could repeat it, or check against previous to see if changes too much. } set listXff [lrange $listXff 1 end] set listYff [lrange $listYff 1 end] lappend listXff [xff $t $xn $yn] lappend listYff [yff $t $xn $yn] lappend ans $xn $yn # puts "ans=$ans" } #puts "adams:t=$t" } return $ans } ## endsource adams.tcl # sample procedures # proc xff { t x y } { return [expr {$x + $y }] } # proc yff { t x y } { return [expr {$x - $y }] } proc doIntegrateScreen { win sx sy } { makeLocal $win c doIntegrate $win [storx$win [$c canvasx $sx]] [story$win [$c canvasy $sy]] } proc doIntegrate { win x0 y0 } { # global xradius yradius c tstep nsteps # puts "dointegrate $win $x0 $y0" makeLocal $win xradius yradius c tstep nsteps direction linewidth tinitial versus_t linecolors linkLocal $win didLast trajectoryStarts set rtosx rtosx$win ; set rtosy rtosy$win oset $win doTrajectoryAt [format "%.10g %.10g" $x0 $y0] lappend trajectoryStarts [list $x0 $y0] set didLast {} # puts "doing at $doTrajectoryAt" set steps $nsteps if { "$tstep" == "" } { set h [expr {[vectorlength $xradius $yradius] / 200.0}] set tstep $h } else {set h $tstep } # puts h=$h set todo $h switch $direction { forward { set todo "$h" } backward { set todo "[expr {- $h}]" } both { set todo "$h [expr {- $h}]" } } foreach method { adamsMoulton rungeKuttaA } { set color [oget $win $method] if { "$color" != "" } { lappend methods $method lappend useColors $method $color } } set methodNo -1 foreach method $methods { incr methodNo # puts method=$method foreach h $todo { set form [list $method xff yff $tinitial $x0 $y0 $h $steps] set ans [eval $form] lappend didLast $form #puts "doing: $form" set i -1 set xn1 [$rtosx [lindex $ans [incr i]]] set yn1 [$rtosy [lindex $ans [incr i]]] set lim [expr {$steps * 2}] set mee [expr {pow(10.0,9)}] set ptColor [assoc $method $useColors ] set linecolor [lindex $linecolors $methodNo] #set im [getPoint 2 green] #set im1 [getPoint 2 purple] set im [getPoint 2 $ptColor] #set im1 [getPoint 2 purple] catch { while { $i <= $lim } { set xn2 [$rtosx [lindex $ans [incr i]]] set yn2 [$rtosy [lindex $ans [incr i]]] # puts "$xn1 $yn1" # xxxxxxxx following is for a bug in win95 version if { abs($xn1) + abs($yn1) +abs($xn2)+abs($yn2) < $mee } { $c create line $xn1 $yn1 $xn2 $yn2 -tags path -width $linewidth -fill $linecolor } if { "$im" != "" } { #puts hi $c create image $xn1 $yn1 -image $im -anchor center \ -tags "point" } else { $c create oval [expr $xn1 -2] [expr $yn1 -2] [expr $xn1 +2] [expr $yn1 +2] -fill $color } # puts "$xn1 $yn1" set xn1 $xn2 set yn1 $yn2 } } } } if { $versus_t } { plotVersusT $win} } proc plotVersusT {win } { linkLocal $win didLast dydt dxdt parameters xcenter xradius set nwin .versust.plot2d if { "$parameters" != "" } { set pars ", $parameters"} else { set pars ""} oset $nwin themaintitle "dy/dt=$dydt, dx/dt=$dxdt $pars" lappend plotdata [list maintitle [list oget $nwin themaintitle]] foreach v $didLast { set ans [eval $v] desetq "tinitial x0 y0 h" [lrange $v 3 end] set this [lrange $v 0 5] if { [info exists doing($this) ] } { set tem $doing($this) } else { set tem "" } set doing($this) "" set allx "" ; set ally "" ; set allt "" set ii 0 foreach {x y } $ans { lappend allx $x lappend ally $y lappend allt [expr $tinitial + $h*$ii] incr ii } foreach u $tem v [list $allx $ally $allt] { if { $h > 0 } { lappend doing($this) [concat $u $v]} else { lappend doing($this) [concat [lreverse $v] $u] } } } foreach {na val } [array get doing] { lappend plotdata [list label "x versus t"] [list plotpoints 2] lappend plotdata [list xversusy [lindex $val 2] [lindex $val 0] ] lappend plotdata [list label "y versus t"] lappend plotdata [list xversusy [lindex $val 2] [lindex $val 1] ] } if { ![winfo exists .versust] } { toplevel .versust } plot2d -data $plotdata -windowname $nwin -ycenter $xcenter -yradius $xradius wm title .versust "X and Y versus t" } proc lreverse { lis } { set ans "" set i [llength $lis] while { [incr i -1]>=0 } { lappend ans [lindex $lis $i] } return $ans } # #----------------------------------------------------------------- # # $rtosx,$rtosy -- convert Real coordinate to screen coordinate # # Results: a window coordinate # # Side Effects: # #---------------------------------------------------------------- # #----------------------------------------------------------------- # # $storx,$story -- Convert a screen coordinate to a Real coordinate. # # Results: # # Side Effects: # #---------------------------------------------------------------- # proc drawArrowScreen { c atx aty dfx dfy } { set x1 [expr {$atx + $dfx}] set y1 [expr {$aty + $dfy}] # set x2 [expr {$atx + .8*$dfx +.1* $dfy}] # set y2 [expr {$aty + .8*$dfy - .1* $dfx}] # set x3 [expr {$atx + .8*$dfx -.1* $dfy}] # set y3 [expr {$aty + .8*$dfy + .1* $dfx}] $c create line $atx $aty $x1 $y1 -tags arrow -fill blue -arrow last -arrowshape {3 5 2} # $c create line $x2 $y2 $x1 $y1 -tags arrow -fill red # $c create line $x3 $y3 $x1 $y1 -tags arrow -fill red } proc drawDF { win tinitial } { global axisGray makeLocal $win xmin xmax xcenter ycenter c ymin ymax transform # flush stdout set rtosx rtosx$win ; set rtosy rtosy$win set storx storx$win ; set story story$win set stepsize 30 set min 100000000000.0 set max 0.0 set t0 $tinitial set xfactor [lindex $transform 0] set yfactor [lindex $transform 3] set extra $stepsize set uptox [expr {[$rtosx $xmax] + $extra}] set uptoy [expr {[$rtosy $ymin] + $extra}] # draw the axes: #puts "draw [$rtosx $xmin] to $uptox" for { set x [expr {[$rtosx $xmin] - $extra}] } { $x < $uptox } { set x [expr {$x +$stepsize}] } { for { set y [expr {[$rtosy $ymax] - $extra}] } { $y < $uptoy } { set y [expr {$y + $stepsize}] } { set args "$t0 [$storx $x] [$story $y]" set dfx [expr {$xfactor * [eval xff $args]}] # screen y is negative of other y set dfy [expr {$yfactor * [eval yff $args]}] # puts "$dfx $dfy" set len [vectorlength $dfx $dfy] append all " $len $dfx $dfy " if { $min > $len } { set min $len } if { $max < $len } {set max $len} } } set fac [expr {($stepsize -5 -8)/($max - $min)}] set arrowmin 8 set arrowrange [expr {$stepsize -4 - $arrowmin}] set s1 [expr {($arrowrange*$min+$arrowmin*$min-$arrowmin*$max)/($min-$max)}] set s2 [expr {$arrowrange/($max-$min) }] # we calculate fac for each length, so that # when we multiply the vector times fac, its length # will fall somewhere in [arrowmin,arrowmin+arrowrange]. # vectors of length min and max resp. should get mapped # to the two end points. # To do this we set fac [expr {$s1/$len + $s2}] # puts "now to draw,s1=$s1 s2=$s2,max=$max,min=$min" # puts "xfactor=$xfactor,yfactor=$yfactor" set i -1 for { set x [expr {[$rtosx $xmin] - $stepsize}] } { $x < $uptox } { set x [expr {$x +$stepsize}] } { for { set y [expr {[$rtosy $ymax] - $stepsize}] } { $y < $uptoy } { set y [expr {$y + $stepsize}] } { set len [lindex $all [incr i]] set fac [expr {$s1/$len + $s2}] set dfx [lindex $all [incr i]] set dfy [lindex $all [incr i]] #puts "[$storx $x] [$story $y] x=$x y=$y dfx=$dfx dfy=$dfy fac=$fac" # puts "$len $dfx $dfy" drawArrowScreen $c $x $y [expr {$fac * $dfx}] [expr {$fac * $dfy}] } } $c create line [$rtosx 0 ] [$rtosy -1000] [$rtosx 0] [$rtosy 1000] \ -fill $axisGray $c create line [$rtosx -1000] [$rtosy 0] [$rtosx 1000] [$rtosy 0] \ -fill $axisGray axisTicks $win $c } proc parseOdeArg { s } { set orig $s set w "\[ ]*" set exp "\[dD]$w\\($w\(\[xyz])$w,$w\(\[xyt])$w\\)$w=(\[^;]+)" while { [regexp $exp $s junk x t expr ] } { lappend ans -d${x}d$t lappend ans $expr regexp -indices $exp $s junk x t expr set s [string range $s [lindex $junk 1] end] } if { ![info exists ans] || ([llength $ans] == 2 && "[lindex $ans 0]" != "-dydx") } { 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) " } return $ans } proc plotdf { args } { global plotdfOptions printOption printOptions plot2dOptions # puts "args=$args" # to see options add: -debug 1 set win [assoc -windowname $args] if { "$win" == "" } {set win [getOptionDefault windowname $plotdfOptions] } if { "[lindex $args 0]" == "-ode" } { set tem [parseOdeArg [lindex $args 1]] set args [lrange $args 2 end] set args [concat $tem $args] } global [oarray $win] getOptions $plotdfOptions $args -usearray [oarray $win] makeLocal $win dydx if { "$dydx" !="" } { oset $win dxdt 1 ; oset $win dydt $dydx } setPrintOptions $args foreach v {trajectoryStarts recompute} { catch { unset [oloc $win $v] } } makeFrameDf $win oset $win sliderCommand sliderCommandDf oset $win trajectoryStarts "" oset $win maintitle [concat "makeLocal $win dxdt dydt dydx ;" \ {if { "$dydx" == "" } { concat "dx/dt = $dxdt , dy/dt = $dydt"} else { concat "dy/dx = $dydt" } } ] replotdf $win } proc replotdf { win } { global plotdfOptions linkLocal $win xfundata data if { ![info exists data] } { set data "" } makeLocal $win c dxdt dydt tinitial nsteps xfun doTrajectoryAt parameters setUpTransforms $win 1.0 setXffYff $dxdt $dydt $parameters $c delete all setForIntegrate $win oset $win curveNumber -1 drawDF $win $tinitial if { "$doTrajectoryAt" != "" } { eval doIntegrate $win $doTrajectoryAt } set xfundata "" foreach v [sparseListWithParams $xfun {x y t} $parameters ] { proc _xf { x } "return \[expr { $v } \]" regsub "\\$" $v "" label lappend xfundata [list label $label] \ [linsert [calculatePlot $win _xf $nsteps] \ 0 xversusy] } redraw2dData $win -tags path } proc setXffYff { dxdt dydt parameters } { proc xff { t x y } "expr { [sparseWithParams $dxdt { x y} $parameters] }" proc yff { t x y } "expr { [sparseWithParams $dydt { x y} $parameters] } " } proc doConfigdf { win } { desetq "wb1 wb2" [doConfig $win] makeLocal $win buttonFont frame $wb1.choose1 set frdydx $wb1.choose1 button $frdydx.dydxbut -command "swapChoose $win dydx $frdydx " \ -text "dy/dx" -font $buttonFont button $frdydx.dydtbut -command "swapChoose $win dydt $frdydx" \ -text "dy/dt,dx/dt" -font $buttonFont mkentry $frdydx.dxdt [oloc $win dxdt] "dx/dt" $buttonFont mkentry $frdydx.dydt [oloc $win dydt] "dy/dt" $buttonFont pack $frdydx.dxdt $frdydx.dydt -side bottom -fill x -expand 1 pack $frdydx.dydxbut $frdydx.dydtbut -side left -fill x -expand 1 foreach w {versus_t parameters linewidth xradius yradius xcenter ycenter tinitial nsteps tstep direction xfun linecolors rungeKuttaA adamsMoulton } { mkentry $wb1.$w [oloc $win $w] $w $buttonFont pack $wb1.$w -side bottom -expand 1 -fill x } mkentry $wb1.doTrajectoryAt [oloc $win doTrajectoryAt] \ "Trajectory at" $buttonFont bind $wb1.doTrajectoryAt.e \ "eval doIntegrate $win \[oget $win doTrajectoryAt\] " pack $wb1.doTrajectoryAt $frdydx -side bottom -expand 1 -fill x if { "[oget $win dydx]" != "" } { swapChoose $win dydx $frdydx } setForIntegrate $win } proc sliderCommandDf { win var val } { linkLocal $win recompute updateParameters $win $var $val set com "recomputeDF $win" # allow for fast move of slider... after cancel $com after 50 $com } proc recomputeDF { win } { linkLocal $win recompute if { [info exists recompute] } { incr recompute return } else { # puts "set recompute 1" set recompute 1 } linkLocal $win trajectoryStarts c tinitial dxdt dydt parameters set redo 0 set trajs "" catch { set trajs $trajectoryStarts} while { $redo != $recompute } { # puts " setXffYff $dxdt $dydt $parameters" setXffYff $dxdt $dydt $parameters # $c delete path point arrow $c delete all catch { unset trajectoryStarts } set redo $recompute foreach pt $trajs { desetq "x0 y0" $pt catch { doIntegrate $win $x0 $y0 } update if { $redo != $recompute } { break } } if { $redo == $recompute } { catch { drawDF $win $tinitial } } } # puts " unset recompute" unset recompute } ## endsource plotdf.tcl ## source plot2d.tcl ###### plot2d.tcl ###### ############################################################ # Netmath Copyright (C) 1998 William F. Schelter # # For distribution under GNU public License. See COPYING. # ############################################################ set p .plot catch { destroy $p } set plot2dOptions { {xradius 10 "Width in x direction of the x values" } {yradius 10 "Height in y direction of the y values"} {width 500 "Width of canvas in pixels"} {height 500 "Height of canvas in pixels" } {xcenter 0.0 {(xcenter,ycenter) is the origin of the window}} {xfun "" {function of x to plot eg: sin(x) or "sin(x);x^2+3" }} {parameters "" "List of parameters and values eg k=3,l=7+k"} {sliders "" "List of parameters ranges k=3:5,u"} {nsteps "100" "mininmum number of steps in x direction"} {ycenter 0.0 "see xcenter"} {bbox "" "xmin ymin xmax ymax .. overrides the -xcenter etc"} {screenwindow "20 20 700 700" "Part of canvas on screen"} {windowname ".plot2d" "window name"} {nolines 0 "If not 0, plot points and nolines"} {bargraph 0 "If not 0 this is the width of the bars on a bar graph" } {linewidth "0.6" "Width of plot lines" } {plotpoints 0 "if not 0 plot the points at pointsize" } {pointsize 2 "radius in pixels of points" } {linecolors {blue green red brown gray black} "colors to use for lines in data plots"} {labelposition "10 35" "Position for the curve labels nw corner"} {xaxislabel "" "Label for the x axis"} {yaxislabel "" "Label for the y axis"} {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."} {zoomfactor "1.6 1.6" "Factor to zoom the x and y axis when zooming. Zoom out will be reciprocal" } {errorbar 0 "If not 0 width in pixels of errorbar. Two y values supplied for each x: {y1low y1high y2low y2high .. }"} {data "" "List of data sets to be plotted. Has form { {xversusy {x1 x2 ... xn} {y1 .. yn ... ym}} .. {againstIndex {y1 y2 .. yn}} .. }"} } proc argSuppliedp { x } { upvar 1 args a return [expr [set i [lsearch $a $x]] >= 0 && $i%2 == 0] } proc mkPlot2d { args } { global plot2dOptions printOption axisGray #puts "args=<$args>" # global screenwindow c xmax xmin ymin ymax # eval global [optionFirstItems $plot2dOptions] set win [assoc -windowname $args] if { "$win" == "" } { set win [getOptionDefault windowname $plot2dOptions] } global [oarray $win] set data [assoc -data $args ] # puts ranges=[plot2dGetDataRange $data] getOptions $plot2dOptions $args -usearray [oarray $win] linkLocal $win autoscale if { [argSuppliedp -data] && ![argSuppliedp -autoscale] && ![argSuppliedp -xradius] } { lappend autoscale x } if { ![argSuppliedp -autoscale] & [argSupp