mirror of
https://github.com/PDP-10/its.git
synced 2026-03-02 01:50:24 +00:00
85994ed770
Resolves #284. Commented out uses of time-origin in maxtul; mcldmp (init) until we can figure out why it gives arithmetic overflows under the emulators. Updated the expect script statements in build_macsyma_portion to not attempt to match expected strings, but simply sleep for some time since in some cases the matching appears not to work.
1559 lines
54 KiB
Common Lisp
1559 lines
54 KiB
Common Lisp
;;;-*-Lisp-*-
|
||
|
||
; (c) Copyright 1976, 1983 Massachusetts Institute of Technology.
|
||
; All Rights Reserved. Enhancements (c) Copyright 1983 Symbolics Inc.
|
||
; All Rights Reserved.
|
||
;
|
||
; The data and information in the Enhancements is proprietary to, and a
|
||
; valuable trade secret of, SYMBOLICS, INC., a Delaware corporation. It is
|
||
; given in confidence by SYMBOLICS, and may not be used as the basis of
|
||
; manufacture, or be reproduced or copied, or distributed to any other
|
||
; party, in whole or in part, without the prior written consent of SYMBOLICS.
|
||
|
||
|
||
(macsyma-module aplot2)
|
||
|
||
;; This is a new-io version.
|
||
|
||
(declare (special $float $numer $%enumer $ratprint $title $txtype $typel $window $xfun $xlabel
|
||
$yfun $ylabel &/3d $plotnum $plotnum0 $plotnum1 $clear
|
||
$contours $noprint $plotnumprec $howclose $plots $ticknum $ticksize
|
||
$wait $window $xaxis $xfun $yaxis $yfun char-height char-width
|
||
dsk-graphics max-x max-y min-x min-y plot-size plot-opts plot-vals
|
||
plot-window sameflg firstflg lastflg savemarks scale-x scale-y
|
||
size-x size-xf size-y size-yf tekplt-opts tekplt-vals tty-graphics
|
||
x-arrv y-arrv z-arrv $xmax $xmin $ymax $ymin $equalscale $viewpt
|
||
$centerplot $reverse $underside $loadprint $myoptions $values
|
||
dontflg vertflg sideflg $perspective $xmax1 $xmin1 $ymax1
|
||
$ymin1 $zmax1 $viewpt1 $centerplot1 $zmax1 $zmin1 $xmax3d $xmin3d
|
||
$ymax3d $ymin3d $zmax3d $zmin3d $window1 $dateplot $labelcontours
|
||
$float2bf $plotheight linel $plot2error plot-^/] lisperrprint
|
||
user-timesofar $plotgap $crclear $plotundefined print-mode
|
||
$device $direc)
|
||
(flonum a b del dist fcal ft inc infin high logsgn low max min org pt xdist
|
||
xf xhigh xlow xmax xmaxp xmin xminp xminp1
|
||
ydist ymax ymin yminp scale-x
|
||
scale-y size-xf size-yf val val1 $xmax1 $xmin1 $ymax1 $zmax1 $zmax1
|
||
$zmin1 $xmax3d $xmin3d $ymax3d $ymin3d $zmax3d $zmin3d
|
||
$plotundefined
|
||
(fmeval notype)
|
||
(call-x flonum flonum flonum flonum)
|
||
(call-y flonum flonum flonum))
|
||
(fixnum cnt cx cy gap i j k len m mask mn-x mn-y mx-x mx-y n num prec rept runl
|
||
symtype type xbeg xinc xlen xnum xstart ybeg yinc ylen ystart zbeg
|
||
zinc zinc1 zinc2 zlen zstart max-x
|
||
max-y min-x min-y size-x size-y linel (tek-x flonum flonum)
|
||
(tek-y flonum flonum) ($exitgraph))
|
||
(notype ($setpoint flonum flonum) ($setpoint3 flonum flonum flonum)
|
||
($point flonum flonum) ($point3 flonum flonum flonum)
|
||
($vector flonum flonum) ($vector3 flonum flonum flonum)
|
||
($line flonum flonum flonum flonum)
|
||
($line3 flonum flonum flonum flonum flonum flonum))
|
||
(array* (flonum x-arr 1. y-arr 1. z-arr 1. vint 1. sqr 1. cont-arr 1.))
|
||
(*expr dumpp)
|
||
(*expr $clear arrfunp)
|
||
(setq nfunvars t)
|
||
|
||
;;; (or (get 'lockf 'version) (load '|dsk:numer;lockf|))
|
||
;;; (defprop tick-timer (timech fasl dsk numer) autoload)
|
||
;;; see note below.
|
||
)
|
||
|
||
;;;(eval-when (compile eval)
|
||
;;; (or (get 'timecm 'version) (load '|dsk:numer;timecm|)))
|
||
;;; This macro was not all that informative, the data-base update was
|
||
;;; too slow using APPEND MODE files. File-locking etc problems. A message
|
||
;;; sending method queued in plot2 but working at the new-c-line hook is
|
||
;;; more in order. Anyway, the macro placement is evident.
|
||
;;;(defvar *ticks-so-far* 0)
|
||
;;;(defvar *runtime-at-start* 0)
|
||
;;;(defvar *gctime-at-start* 0)
|
||
;;;(defvar $tick_time_unit_in_seconds 10.)
|
||
;;;(defvar $ticks_per_warning 5)
|
||
;;;(defvar *type-of-evaluation* 'macsyma)
|
||
;;;(defvar *things-being-evaluated* ())
|
||
;;;(defvar *time-messages* nil)
|
||
(defmacro time-monitor-protect (ignore-filename &rest forms)
|
||
`(progn ,@forms))
|
||
(defmacro time-check-protect (ignore-type-of-eval ignore-things &rest forms)
|
||
; unpopular time-reminder to catch inefficient things like
|
||
; PLOT2(X*SIN(X)*ROMBERG(F(A,X),A,0,N),X,0,10) interpreted.
|
||
; don't seem to have enough programming environment to do
|
||
; things like this without making users mad.
|
||
`(progn ,@forms))
|
||
|
||
;; Define where files are kept
|
||
#+franz
|
||
(defmacro fasl-file (name) `(concat vaxima-main-dir '|//share//| ',name '|.o|))
|
||
#-franz
|
||
(defmacro fasl-file (name) `'((dsk share) ,name fasl))
|
||
|
||
(setq $plotundefined (*$ 2.0 -8.5070591e+37))
|
||
|
||
(defun setopt (plotvar plotval)
|
||
(cond ((boundp plotvar)
|
||
(cond ((memq plotvar (cdr $values))
|
||
(delq plotvar $values 1)
|
||
(add2lnc plotvar $myoptions))))
|
||
(t (set plotvar plotval))))
|
||
|
||
(DEFMFUN $plotinit nil
|
||
(setq plot-opts
|
||
'($perspective $ticksize $ticknum $underside $plotnum1
|
||
$reverse $equalscale $noprint $plotnum $xaxis $yaxis $plotnumprec
|
||
$contours $xfun $yfun $crosshatch $labelcontours $dateplot
|
||
$plot2error $plotgap)
|
||
plot-vals
|
||
'(t 6. 10. t 20. nil nil nil 20. $all $all 7.
|
||
20. nil nil t t t t 20.))
|
||
(mapc 'setopt (append plot-opts '($crclear)) (append plot-vals '(t)))
|
||
(setopt 'tekplt-opts nil) (setopt 'tekplt-vals nil)
|
||
(setq firstflg nil lastflg nil sameflg nil)
|
||
(setq plot-window (list 0. 0. 1023. 1023.)
|
||
plot-size (list 0.0 0.0 1023.0 1023.0))
|
||
(array vint flonum 4.)
|
||
(array sqr flonum 3.)
|
||
#-franz (progn
|
||
(or (get 'x-arr 'array) (array x-arr flonum 1.))
|
||
(or (get 'y-arr 'array) (array y-arr flonum 1.))
|
||
(or (get 'z-arr 'array) (array z-arr flonum 1.))
|
||
(setq x-arrv (get 'x-arr 'array)
|
||
y-arrv (get 'y-arr 'array)
|
||
z-arrv (get 'z-arr 'array)))
|
||
#+franz (progn
|
||
(or (arrayp (getd 'x-arr)) (setq x-arrv (array x-arr flonum 1.)))
|
||
(or (arrayp (getd 'y-arr)) (setq y-arrv (array y-arr flonum 1.)))
|
||
(or (arrayp (getd 'z-arr)) (setq z-arrv (array z-arr flonum 1.))))
|
||
(defprop $calcompnum calcompset assign)
|
||
(defprop $calcompnum0 calcompset assign)
|
||
(defprop $calcompnum1 calcompset assign)
|
||
t)
|
||
|
||
($plotinit)
|
||
(defun calcompset (c-var c-val)
|
||
(princ '|In the future set PLOTNUM, PLOTNUM0, or PLOTNUM1|)
|
||
(cond ((eq c-var '$calcompnum) (mset '$plotnum c-val))
|
||
((eq c-var '$calcompnum0) (mset '$plotnum0 c-val))
|
||
((eq c-var '$calcompnum1) (mset '$plotnum1 c-val))))
|
||
|
||
(DEFMFUN $plotreset nil
|
||
(mapc 'set plot-opts plot-vals)
|
||
(mapc 'set tekplt-opts tekplt-vals)
|
||
(setq firstflg nil lastflg nil sameflg nil dontflg nil
|
||
vertflg nil sideflg nil)
|
||
(mapc (function
|
||
(lambda (x) (cond ((boundp x)
|
||
(and (memq x (cdr $values)) (delq x $values 1))
|
||
(makunbound x)))))
|
||
'($xmin $xmax $ymin $ymax $zmax $zmin $window $viewpt
|
||
$centerplot $plotnum0))
|
||
(setq plot-window (get-window))
|
||
'$done)
|
||
|
||
(defun fmeval (y)
|
||
(let ((x (cond ((eq $plot2error t) (meval y))
|
||
(t (setq y (cdr (let ((lisperrprint nil))
|
||
(meval `(($errcatch) ,y)))))
|
||
(cond (y (car y))
|
||
((null $plot2error) $plotundefined)
|
||
(t $plot2error))))))
|
||
(cond ((fixp x) (float x))
|
||
((floatp x) x)
|
||
(($bfloatp x) ($float x))
|
||
((eq $plot2error t)
|
||
(let (($plot2error y))
|
||
(merror "~M = ~M which is not floating pt."
|
||
Y X)))
|
||
((null $plot2error) $plotundefined)
|
||
(t (float $plot2error)))))
|
||
|
||
(defun fmeval1 (x)
|
||
(cond ((fixp (setq x (meval x))) (float x)) (($bfloatp x) ($float x)) (t x)))
|
||
|
||
;;; Plot-^/] is the user-timesofar handler.
|
||
(defun plot-^/] () (setq plot-^/] t)) ; *** Disable this it bombs Macsyma
|
||
|
||
;;; Pl^/] does the printout for timesofar.
|
||
(defun pl^/] (fun valu valu1)
|
||
(setq plot-^/] nil)
|
||
(princ '|Plot: calculating |)
|
||
(cond ((atom fun) (princ fun)) (t (princ '|f|)))
|
||
(princ '|(|)
|
||
(princ valu)
|
||
(cond (valu1 (princ '|,|) (princ valu1)))
|
||
(princ '|)/
|
||
|))
|
||
|
||
(defun arraychk (x i)
|
||
(and (#-franz get #+franz mget x 'array)
|
||
(setq x (arraydims x))
|
||
(eq (car x) 'flonum)
|
||
(null (cond ((= i 1.) (cddr x)) (t (cdddr x))))))
|
||
|
||
(defun range-comp (funl arrv l num #+franz name)
|
||
(let ((arg3 (car l)) (high 0.0) (low 0.0) (inc 0.0) (xlen 0.)
|
||
(intflg) (logflg) (logsgn -1.0) (var) ($plot2error t))
|
||
(cond ((and (apply 'and
|
||
(mapcar
|
||
(function
|
||
(lambda (fun)
|
||
(cons 'quote
|
||
(list #-franz (or (get fun 'expr)
|
||
(get fun 'subr))
|
||
#+franz (and (atom fun)
|
||
(getd fun))))))
|
||
funl))
|
||
(or (numberp (fmeval1 arg3))
|
||
($listp arg3)
|
||
(arraychk arg3 1.)))
|
||
(setq l (cdr l)))
|
||
(t (setq var arg3 arg3 (cadr l) l (cddr l))))
|
||
(cond ((not (numberp (setq arg3 (fmeval1 arg3))))
|
||
(cond ((arraychk arg3 1.) (setq xlen (cadr (arraydims arg3))))
|
||
(($listp arg3)
|
||
(setq arg3 (mapcar 'fmeval (cdr arg3))
|
||
xlen (length arg3)))
|
||
(t
|
||
(merror "Invalid arg to PLOT ~M" ARG3)))
|
||
#-franz (*rearray arrv 'flonum xlen)
|
||
#+franz (progn (*rearray name 'flonum xlen)
|
||
(setq arrv
|
||
(set (cond ((eq name 'x-arr) 'x-arrv)
|
||
((eq name 'y-arr) 'y-arrv)
|
||
((eq name 'z-arr) 'z-arrv))
|
||
(getd name))))
|
||
(fillarray arrv arg3))
|
||
(t (cond ((null l) (merror "Too few args to PLOT")))
|
||
(cond ((< num 2.) (setq num 2.)))
|
||
(setq high (fmeval (car l)) low arg3 l (cdr l))
|
||
(cond ((eq (cond (l (car l))) '$integer)
|
||
(setq intflg t l (cdr l)))
|
||
((or (memq '%log l) (memq '$loglin l))
|
||
(setq logflg t)))
|
||
(cond (intflg
|
||
(cond ((< high low)
|
||
(setq inc -1.0
|
||
low (float (fix low))
|
||
high (float (- (fix (-$ high))))))
|
||
(t (setq inc 1.0
|
||
high (float (fix high))
|
||
low (float (- (fix (-$ low)))))))))
|
||
(cond (logflg (cond ((< (*$ high low) 0.0)
|
||
(merror "Invalid args to PLOT: ~M"
|
||
(list '(mlist) low high))))
|
||
(cond ((> (+$ high low) 0.0)
|
||
(setq logsgn 1.0)))
|
||
(setq high (cond ((= high 0.0) -90.0)
|
||
(t (log (abs high))))
|
||
low (cond ((= low 0.0) -90.0)
|
||
(t (log (abs low)))))))
|
||
(cond ((not intflg) (setq inc (-$ high low))))
|
||
(cond (intflg (setq xlen (1+ (fix (//$ (-$ high low) inc))))
|
||
(cond ((< xlen 0) (setq xlen 1.))))
|
||
(t (setq xlen num)))
|
||
#-franz (*rearray arrv 'flonum xlen)
|
||
#+franz (progn (*rearray name 'flonum xlen)
|
||
(setq arrv
|
||
(set (cond ((eq name 'x-arr) 'x-arrv)
|
||
((eq name 'y-arr) 'y-arrv)
|
||
((eq name 'z-arr) 'z-arrv))
|
||
(getd name))))
|
||
(do ((i 0. (1+ i))
|
||
(fcal (//$ (float (1- num))))
|
||
(val low
|
||
(cond (intflg (+$ val inc))
|
||
(t (+$ low (*$ inc (float (1+ i)) fcal))))))
|
||
((= i xlen))
|
||
(cond (logflg (setq val (*$ logsgn (exp val)))))
|
||
(store (arraycall flonum arrv i) val))))
|
||
(list var xlen l intflg)))
|
||
|
||
(DEFMSPEC $plot2 (l) (setq l (cdr l))
|
||
(if (< (length l) 2) (merror "Too few arguments to PLOT2"))
|
||
(let ((funl (if (and (symbolp (car l)) (not (eq (car l) (cadr l))))
|
||
(meval (car l))
|
||
(car l)))
|
||
(var) ($numer t) ($%enumer t) ($float t) ($float2bf t) (intflg) ($ratprint)
|
||
(xlen 0.) (ylen 0.)
|
||
;(user-timesofar (cons 'plot-^/] user-timesofar))
|
||
(plot-^/]))
|
||
(time-monitor-protect
|
||
"dsk:numer;PLOT2 USERS"
|
||
(setq l (cdr l)
|
||
funl (cond (($listp funl) (cdr funl)) (t (list funl)))
|
||
l (range-comp funl x-arrv l (fix $plotnum)
|
||
#+franz 'x-arr)
|
||
var (car l)
|
||
xlen (cadr l)
|
||
intflg (cadddr l)
|
||
l (caddr l)
|
||
ylen (length funl))
|
||
(*rearray 'y-arr 'flonum (* xlen ylen))
|
||
#+franz (setq y-arrv (getd 'y-arr))
|
||
(time-check-protect
|
||
(cond (var 'macsyma) (t 'lisp))
|
||
funl
|
||
(do ((i 0. (1+ i)) (val))
|
||
((= i xlen))
|
||
(setq val (x-arr i))
|
||
(do ((j 0. (1+ j)) (funl funl (cdr funl)))
|
||
((= j ylen))
|
||
(cond (plot-^/] (pl^/] (car funl) val nil)))
|
||
(store (y-arr (+ (* j xlen) i))
|
||
(cond (var (fmeval (list '($ev) (car funl)
|
||
(list '(mequal) var
|
||
(cond (intflg (fix val))
|
||
(t val))))))
|
||
(t (funcall (car funl)
|
||
(cond (intflg (fix val))
|
||
(t val)))))))))
|
||
(*rearray 'z-arr 'flonum 1.)
|
||
#+franz (setq z-arrv (getd 'z-arr))
|
||
(store (z-arr 0.) 0.0)
|
||
(graph2 (do ((funl nil) (j (1- ylen) (1- j)))
|
||
((< j 0.) funl)
|
||
(setq funl
|
||
(cons (list xlen 0. (* xlen j) 0. 1. 1. 0.) funl)))
|
||
(graphopts2 l nil)))))
|
||
|
||
(DEFMSPEC $plot3d (l) (setq l (cdr l))
|
||
(cond ((< (length l) 3.) (merror "Too few args to PLOT3D")))
|
||
(let ((funl (cond ((atom (car l)) (meval (car l)))
|
||
(t (car l))))
|
||
(var) (var1) ($numer t) ($%enumer t) ($float t) ($float2bf t) (intflg) (intflg1)
|
||
($ratprint) (xlen 0.) (ylen 0.) (zlen 0.)
|
||
;(user-timesofar (cons 'plot-^/] user-timesofar))
|
||
(plot-^/]))
|
||
(time-monitor-protect
|
||
"dsk:numer;plot3d users"
|
||
(setq funl (cond (($listp funl) (cdr funl)) (t (list funl)))
|
||
l (range-comp funl x-arrv (cdr l)
|
||
(cond ((numberp (meval1 '$plotnum0))
|
||
(fix $plotnum0))
|
||
(t (fix $plotnum)))
|
||
#+franz 'x-arr)
|
||
var (car l)
|
||
xlen (cadr l)
|
||
intflg (cadddr l)
|
||
l (caddr l)
|
||
l (range-comp funl y-arrv l (fix $plotnum1) #+franz 'y-arr)
|
||
var1 (cond ((null var) nil) (t (car l)))
|
||
ylen (cadr l)
|
||
intflg1 (cadddr l)
|
||
l (caddr l)
|
||
zlen (length funl))
|
||
(*rearray 'z-arr 'flonum (* xlen ylen zlen))
|
||
#+franz (setq z-arrv (getd 'z-arr))
|
||
(time-check-protect
|
||
(cond (var 'macsyma) (t 'lisp))
|
||
funl
|
||
(do ((k 0. (1+ k)) (val1))
|
||
((= k ylen))
|
||
(setq val1 (y-arr k))
|
||
(do ((i 0. (1+ i)) (val))
|
||
((= i xlen))
|
||
(setq val (x-arr i))
|
||
(do ((j 0. (1+ j)) (funl funl (cdr funl)))
|
||
((= j zlen))
|
||
(cond (plot-^/] (pl^/] (car funl) val val1)))
|
||
(store (z-arr (+ (* k xlen zlen) (* j xlen) i))
|
||
(cond (var
|
||
(fmeval (list '($ev) (car funl)
|
||
(list '(mequal) var
|
||
(cond (intflg (fix val))
|
||
(t val)))
|
||
(list '(mequal)
|
||
var1
|
||
(cond (intflg1 (fix val1))
|
||
(t val1))))))
|
||
(t (funcall (car funl)
|
||
(cond (intflg (fix val)) (t val))
|
||
(cond (intflg1 (fix val1))
|
||
(t val1))))))))))
|
||
(graph2 (do ((funl nil) (k (1- zlen) (1- k)))
|
||
((< k 0.) funl)
|
||
(setq funl (cons (list nil xlen ylen 0. 0. 0. (* xlen k)
|
||
1. 1. 1. (* zlen xlen))
|
||
funl)))
|
||
(graphopts2 (cons '$hide l) nil)))))
|
||
|
||
(DEFMSPEC $contourplot2 (form)
|
||
(meval `(($plot3d) ,@(cdr form) $contour)))
|
||
|
||
(DEFMSPEC $paramplot2 (l) (setq l (cdr l))
|
||
(cond ((< (length l) 3.) (merror "Too few args to PARAMPLOT2")))
|
||
(let ((funlx (cond ((atom (car l)) (meval (car l)))
|
||
(t (car l))))
|
||
(funly (cond ((atom (cadr l)) (meval (cadr l)))
|
||
(t (cadr l))))
|
||
(var) ($numer t) ($%enumer t) ($float t) ($float2bf t) (intflg) ($ratprint)
|
||
(xlen 0.) (ylen 0.) (zlen 0.)
|
||
;(user-timesofar (cons 'plot-^/] user-timesofar))
|
||
(plot-^/]))
|
||
(time-monitor-protect
|
||
"dsk:numer;paramp users"
|
||
(setq l (cddr l)
|
||
funlx (cond (($listp funlx) (cdr funlx)) (t (list funlx)))
|
||
funly (cond (($listp funly) (cdr funly)) (t (list funly))))
|
||
(setq l (range-comp (append funlx funly) z-arrv l (fix $plotnum)
|
||
#+franz 'z-arr)
|
||
var (car l) zlen (cadr l)
|
||
intflg (cadddr l)
|
||
l (caddr l)
|
||
xlen (length funlx)
|
||
ylen (length funly))
|
||
(*rearray 'x-arr 'flonum (* xlen zlen))
|
||
#+franz (setq x-arrv (getd 'x-arr))
|
||
(*rearray 'y-arr 'flonum (* ylen zlen))
|
||
#+franz (setq y-arrv (getd 'y-arr))
|
||
(time-check-protect
|
||
(cond (var 'macsyma) (t 'lisp))
|
||
(append funlx funly)
|
||
(do ((i 0. (1+ i)) (val))
|
||
((= i zlen))
|
||
(setq val (z-arr i))
|
||
(do ((j 0. (1+ j)) (funlx funlx (cdr funlx)))
|
||
((= j xlen))
|
||
(cond (plot-^/] (pl^/] (car funlx) val nil)))
|
||
(store (x-arr (+ (* j zlen) i))
|
||
(cond (var
|
||
(fmeval (list '($ev)
|
||
(car funlx)
|
||
(list '(mequal)
|
||
var
|
||
(cond (intflg (fix val))
|
||
(t val))))))
|
||
(t (funcall (car funlx)
|
||
(cond (intflg (fix val))
|
||
(t val)))))))
|
||
(do ((j 0. (1+ j)) (funly funly (cdr funly)))
|
||
((= j ylen))
|
||
(cond (plot-^/] (pl^/] (car funly) val nil)))
|
||
(store (y-arr (+ (* j zlen) i))
|
||
(cond (var
|
||
(fmeval (list '($ev)
|
||
(car funly)
|
||
(list '(mequal)
|
||
var
|
||
(cond (intflg (fix val))
|
||
(t val))))))
|
||
(t (funcall (car funly)
|
||
(cond (intflg (fix val))
|
||
(t val)))))))))
|
||
(*rearray 'z-arr 'flonum 1.)
|
||
#+franz (setq z-arrv (getd 'z-arr))
|
||
(store (z-arr 0.) 0.0)
|
||
(graph2 (do ((funlx nil)
|
||
(j (1- (max xlen ylen)) (1- j))
|
||
(xlen (1- xlen))
|
||
(ylen (1- ylen)))
|
||
((< j 0.) funlx)
|
||
(setq funlx (cons (list zlen
|
||
(* zlen (min j xlen))
|
||
(* zlen (min j ylen))
|
||
0. 1. 1. 0.)
|
||
funlx)))
|
||
(graphopts2 l nil)))))
|
||
|
||
(defun arg-comp (arg1 arrv #+franz name)
|
||
(let ((xnum 0.) (xlen 0.) (funlx))
|
||
(cond ((arraychk arg1 1.)
|
||
(setq xlen (cadr (arraydims arg1))
|
||
xnum 1.
|
||
funlx (list (list xlen 0.)))
|
||
#-franz (*rearray arrv 'flonum xlen)
|
||
#+franz (progn (*rearray name 'flonum xlen)
|
||
(setq arrv
|
||
(set (cond ((eq name 'x-arr) 'x-arrv)
|
||
((eq name 'y-arr) 'y-arrv)
|
||
((eq name 'z-arr) 'z-arrv))
|
||
(getd name))))
|
||
(fillarray arrv arg1))
|
||
((arraychk arg1 2.)
|
||
(setq xlen (caddr (arraydims arg1))
|
||
xnum (cadr (arraydims arg1))
|
||
funlx (do ((i (1- xnum) (1- i)) (funlx nil))
|
||
((< i 0.) funlx)
|
||
(setq funlx
|
||
(cons (list xlen (* i xlen)) funlx))))
|
||
#-franz (*rearray arrv 'flonum (* xnum xlen))
|
||
#+franz (progn (*rearray name 'flonum (* xnum xlen))
|
||
(setq arrv
|
||
(set (cond ((eq name 'x-arr) 'x-arrv)
|
||
((eq name 'y-arr) 'y-arrv)
|
||
((eq name 'z-arr) 'z-arrv))
|
||
(getd name))))
|
||
(fillarray arrv arg1))
|
||
(($listp arg1)
|
||
(setq arg1 (cdr arg1))
|
||
(cond ((or (numberp (fmeval1 (car arg1)))
|
||
(eq (car arg1) '$same)
|
||
(eq (car arg1) '$integer))
|
||
(setq arg1 (list (cons '(mlist) arg1)))))
|
||
(setq xnum (length arg1))
|
||
(do ((i 0. (1+ i)) (arg1 arg1 (cdr arg1)) (j 0.) (l))
|
||
((= i xnum))
|
||
(setq l (car arg1))
|
||
(cond ((arraychk l 1.)
|
||
(setq xlen (cadr (arraydims l))
|
||
funlx (cons (list xlen j) funlx))
|
||
#-franz (*rearray arrv 'flonum (+ j xlen))
|
||
#+franz (progn (*rearray name 'flonum (+ j xlen))
|
||
(setq arrv
|
||
(set (cond ((eq name 'x-arr) 'x-arrv)
|
||
((eq name 'y-arr) 'y-arrv)
|
||
((eq name 'z-arr) 'z-arrv))
|
||
(getd name))))
|
||
(setq l (#-franz get #+franz mget l 'array))
|
||
(do ((k 0. (1+ k))) ((= k xlen))
|
||
(store (arraycall flonum arrv j)
|
||
(arraycall flonum l k))
|
||
(setq j (1+ j))))
|
||
(($listp l)
|
||
(setq l (cdr l) xlen (length l)
|
||
funlx (cons (list xlen j) funlx))
|
||
#-franz (*rearray arrv 'flonum (+ j xlen))
|
||
#+franz (progn (*rearray name 'flonum (+ j xlen))
|
||
(setq arrv
|
||
(set (cond ((eq name 'x-arr) 'x-arrv)
|
||
((eq name 'y-arr) 'y-arrv)
|
||
((eq name 'z-arr) 'z-arrv))
|
||
(getd name))))
|
||
(do ((k 0. (1+ k)) (l l (cdr l)))
|
||
((= k xlen))
|
||
(store (arraycall flonum arrv j)
|
||
(fmeval (car l)))
|
||
(setq j (1+ j))))
|
||
(t
|
||
(merror "Invalid arg to GRAPH: ~M" l))))
|
||
(setq funlx (nreverse funlx)))
|
||
(t (merror "invalid arg to graph: ~M" arg1)))
|
||
funlx))
|
||
|
||
(DEFMSPEC $graph2 (l) (setq l (cdr l))
|
||
(let ((funlx) (funly) ($numer t) ($%enumer t) ($float t) ($float2bf t))
|
||
(setq funlx (arg-comp (meval (car l)) x-arrv #+franz 'x-arr)
|
||
funly (arg-comp (meval (cadr l)) y-arrv #+franz 'y-arr))
|
||
(setq l (cddr l))
|
||
(*rearray 'z-arr 'flonum 1.)
|
||
#+franz (setq z-arrv (getd 'z-arr))
|
||
(store (z-arr 0.) 0.0)
|
||
(graph2 (do ((i (max (length funlx) (length funly)) (1- i))
|
||
(l1)
|
||
(funlx funlx
|
||
(cond ((null (cdr funlx)) funlx) (t (cdr funlx))))
|
||
(funly funly
|
||
(cond ((null (cdr funly)) funly) (t (cdr funly)))))
|
||
((= i 0.) (nreverse l1))
|
||
(setq l1 (cons (list (min (caar funlx) (caar funly))
|
||
(cadar funlx)
|
||
(cadar funly)
|
||
0. 1. 1. 0.)
|
||
l1)))
|
||
(graphopts2 l nil))))
|
||
|
||
(DEFMSPEC $graph3d (l) (setq l (cdr l))
|
||
(let ((funlx) (funly) (funlz) ($numer t) ($%enumer t) ($float t) ($float2bf t))
|
||
(setq funlx (arg-comp (meval (car l)) x-arrv #+franz 'x-arr)
|
||
funly (arg-comp (meval (cadr l)) y-arrv #+franz 'y-arr)
|
||
funlz (arg-comp (meval (caddr l)) z-arrv #+franz 'z-arr))
|
||
(setq l (cdddr l))
|
||
(graph2 (do ((i (max (length funlx) (length funly)) (1- i))
|
||
(l1)
|
||
(funlx funlx
|
||
(cond ((null (cdr funlx)) funlx) (t (cdr funlx))))
|
||
(funly funly
|
||
(cond ((null (cdr funly)) funly) (t (cdr funly))))
|
||
(funlz funlz
|
||
(cond ((null (cdr funlz)) funlz) (t (cdr funlz)))))
|
||
((= i 0.) (nreverse l1))
|
||
(setq l1 (cons (list (min (caar funlx) (caar funly)
|
||
(caar funlz))
|
||
(cadar funlx) (cadar funly)
|
||
(cadar funlz) 1. 1. 1.)
|
||
l1)))
|
||
(graphopts2 (cons '&/3d l) nil))))
|
||
|
||
(defun graphopts2 (l oldl)
|
||
(setq l (mapcar (function
|
||
(lambda (el)
|
||
(cond ((null el) '$false)
|
||
((memq el '($first $last $not3d $contour
|
||
&/3d $same $false $polar %log
|
||
$loglin $linlog $lin $none
|
||
$hide $special $loglog
|
||
$top $bottom $left $right))
|
||
el)
|
||
(t (labeleval el)))))
|
||
l))
|
||
(setq firstflg nil lastflg nil sameflg nil dontflg nil
|
||
vertflg nil sideflg nil)
|
||
(prog (/3d typel oxlabel oylabel otitle txtyp)
|
||
(cond (oldl (setq /3d (car oldl) typel (cadr oldl) oxlabel (caddr oldl)
|
||
oylabel (cadddr oldl) otitle (car (cddddr oldl))
|
||
txtyp (cadr (cddddr oldl)))))
|
||
(return (do ((l l (cdr l)) (l1) (xlabel) (ylabel) (title))
|
||
((null l)
|
||
(setq typel (mapcar (function
|
||
(lambda (el)
|
||
(cond ((fixp (meval el))
|
||
(meval el))
|
||
(t el))))
|
||
typel))
|
||
(cond ((null typel) (setq typel '((mlist) 0.))))
|
||
(cond ((eq txtyp '$lin) (setq txtyp nil)))
|
||
(append (list /3d typel)
|
||
(mapcar (function (lambda (el oel)
|
||
(cond ((eq el '$none) nil)
|
||
((or (null el)
|
||
(eq el '$false))
|
||
oel)
|
||
(t el))))
|
||
(list xlabel ylabel title)
|
||
(list oxlabel oylabel otitle))
|
||
(list txtyp)))
|
||
(setq l1 (car l))
|
||
(cond ((eq l1 '$first) (setq firstflg t lastflg nil))
|
||
((eq l1 '$last) (setq lastflg t firstflg nil))
|
||
((eq l1 '&/3d) (setq /3d t))
|
||
((eq l1 '$hide) (setq /3d '$hide))
|
||
((eq l1 '$not3d) (setq /3d nil txtyp '$not3d))
|
||
((eq l1 '$contour) (setq /3d '$contour))
|
||
((eq l1 '$same) (setq sameflg t))
|
||
((eq l1 '$dont) (setq dontflg t))
|
||
((memq l1 '($top $bottom)) (setq vertflg l1))
|
||
((memq l1 '($left $right)) (setq sideflg l1))
|
||
((eq l1 '$loglog) (setq txtyp '%log))
|
||
((memq l1
|
||
'($polar %log $loglin $linlog $lin $special))
|
||
(setq txtyp l1))
|
||
(($listp l1) (setq typel l1))
|
||
(xlabel (cond (ylabel (setq title l1))
|
||
(t (setq ylabel l1))))
|
||
(t (setq xlabel l1)))))))
|
||
|
||
(defun labeleval (el)
|
||
(cond ((or (atom el) (memq (caar el) '($ev $concat mquote $label)))
|
||
(setq el (errset (meval el)))
|
||
(cond ((null el) (print "Error in evaluating label")
|
||
'$false)
|
||
(t (car el))))
|
||
(t el)))
|
||
|
||
(declare (special el* el1))
|
||
(DEFMSPEC $label (l) (setq l (cdr l))
|
||
#-franz (or (getl 'print-fixed-field-floating '(lsubr subr lexpr expr))
|
||
(loadfile (cond ((status feature its)
|
||
'(FFORMAT fasl dsk liblsp))
|
||
(t '(FFORMAT fasl dsk share)))
|
||
t $loadprint))
|
||
(setq l (mapcar (function
|
||
(lambda (el)
|
||
(cond ((eq (caar el) 'mquote) (list (cdr el) '/ ))
|
||
(t (LET ((el1 (MEVAL EL))
|
||
(el* EL)
|
||
(same NIL))
|
||
(setq same
|
||
(meval '(($is) ((mequal) el* el1))))
|
||
(and (floatp el1)
|
||
(setq el1
|
||
(pfp1 el1 (fix $plotnumprec))))
|
||
(cond (same (list el1 '/ ))
|
||
(t (list el '= el1 '/ ))))))))
|
||
l)
|
||
l (apply 'append l)
|
||
l (nreverse (cdr (nreverse l)))
|
||
l (mapcar (function (lambda (el) (cond ((atom el) (string* el))
|
||
(t (mstring el)))))
|
||
l)
|
||
l (cons '& (apply 'append l)))
|
||
(maknam l))
|
||
|
||
(defun graph2 (marks opts)
|
||
(prog (l i $typel $xlabel $ylabel $title &/3d $txtype)
|
||
(setq &/3d (car opts) $typel (cadr opts) $xlabel (caddr opts)
|
||
$ylabel (cadddr opts) opts (cddddr opts) $title (car opts)
|
||
$txtype (cadr opts))
|
||
(or (cdr $typel) (setq $typel '((mlist simp) 0.)))
|
||
(and firstflg (setq $clear t $wait nil))
|
||
(and lastflg (setq $wait t))
|
||
beg (setq savemarks (list marks
|
||
(list &/3d $typel $xlabel $ylabel $title $txtype)))
|
||
(and dontflg (go end))
|
||
(or #-franz (get '$clear 'subr) #+franz (getd '$clear)
|
||
(loadfile (fasl-file tekplt) t $loadprint))
|
||
(cond ((and (not (or (eq &/3d t) (eq &/3d '$hide)))
|
||
(or (eq $xaxis '$all) (eq $yaxis '$all) (not $noprint)
|
||
$labelcontours))
|
||
#-franz (or (getl 'print-fixed-field-floating
|
||
'(lsubr subr lexpr expr))
|
||
(loadfile (cond ((status feature its)
|
||
'(FFORMAT fasl dsk liblsp))
|
||
(t '(FFORMAT fasl dsk share)))
|
||
t $loadprint))))
|
||
(cond (&/3d (or #-franz (get 'hide3d 'subr) #-franz (get 'hide3d 'expr)
|
||
#+franz (getd 'hide3d)
|
||
(loadfile (fasl-file plot3d) t $loadprint))))
|
||
(cond ((eq &/3d '$contour)
|
||
(contour-set $contours (meval1 '$zmin) (meval1 '$zmax))))
|
||
(setfuns &/3d $txtype (meval1 '$xfun) (meval1 '$yfun)
|
||
(meval1 '$centerplot))
|
||
($entergraph)
|
||
(doscales marks &/3d $xlabel $ylabel $title)
|
||
(cond ((or (null &/3d) (eq &/3d t)) (graph2d marks (cdr $typel)))
|
||
((eq &/3d '$hide) (hide-drive marks (cdr $typel)))
|
||
((eq &/3d '$contour) (contour-drive marks (cdr $typel))))
|
||
(setq i ($exitgraph))
|
||
loop (cond ((= i 9.) (go beg))
|
||
((= i 127.)
|
||
(princ "/<2F>Enter name of plot")
|
||
(terpri)
|
||
(setq l (retrieve nil nil))
|
||
(or (errset (meval `(($nameplot) ,l))) (go loop)))
|
||
((= i 13.) (cond ($crclear ($clear)))))
|
||
end (setq sameflg nil dontflg nil vertflg nil sideflg nil)
|
||
(and firstflg (setq $clear nil firstflg nil))
|
||
(and lastflg (setq $clear t lastflg nil))
|
||
(return '$done)))
|
||
|
||
(defun graph2d (marks typel)
|
||
(do ((typel1 typel (cdr typel1)) (mark) (type))
|
||
((null marks))
|
||
(or typel1 (setq typel1 typel))
|
||
(setq mark (car marks)
|
||
type (LET ((arf (car typel1)))
|
||
(cond ((numberp arf)
|
||
(abs (fix arf)))
|
||
(t 0.))))
|
||
(or (car mark)
|
||
(setq marks (append (surf-expand mark t) (cdr marks))
|
||
mark (car marks)))
|
||
(let ((runl (car mark))
|
||
(xlen (cadr mark))
|
||
(ylen (caddr mark))
|
||
(zlen (cadddr mark))
|
||
(xinc 0.) (yinc 0.) (zinc 0.)
|
||
(symtype (\ (// type 10.) 10.))
|
||
(rept (1+ (\ (// type 100.) 100.)))
|
||
(cnt (// type 10000.)))
|
||
(setq mark (cddddr mark) xinc (car mark)
|
||
yinc (cadr mark) zinc (caddr mark))
|
||
(cond ((= rept 99.) (setq rept (1- runl)))
|
||
((= rept 100.) (setq rept runl)))
|
||
(setq cnt (\ cnt rept) type (\ type 10.))
|
||
($changedash type)
|
||
(cond ((not (and (eq (dasharray type) t) ;skip if line type [9]
|
||
(or (not print-mode)
|
||
(zerop (print-dasharray type)))
|
||
(null (symbolarray symtype))
|
||
(or (not print-mode)
|
||
(zerop (print-symbolarray symtype)))))
|
||
($setpoint3 (x-arr xlen) (y-arr ylen) (z-arr zlen))
|
||
(cond ((and (> symtype 0.) (= cnt 0.))
|
||
($drawsymbol3 (x-arr xlen) (y-arr ylen) (z-arr zlen)
|
||
symtype)))
|
||
(do ((k 1. (1+ k))
|
||
(i (+ xinc xlen) (+ xinc i))
|
||
(j (+ yinc ylen) (+ yinc j))
|
||
(m (+ zinc zlen) (+ zinc m))
|
||
(prev-point t)
|
||
(x-point 0.0)
|
||
(y-point 0.0)
|
||
(z-point 0.0))
|
||
((= k runl))
|
||
(declare (flonum x-point y-point z-point))
|
||
(setq x-point (x-arr i) y-point (y-arr j)
|
||
z-point (z-arr m)
|
||
cnt (\ (1+ cnt) rept))
|
||
(cond ((or (= x-point $plotundefined)
|
||
(= y-point $plotundefined)
|
||
(= z-point $plotundefined))
|
||
(setq prev-point nil))
|
||
(t (cond (prev-point
|
||
($vector3 x-point y-point z-point)
|
||
(cond ((and (> symtype 0.) (= cnt 0.))
|
||
($drawsymbol3 x-point y-point
|
||
z-point symtype))))
|
||
(t ($setpoint3 x-point y-point z-point)
|
||
(setq prev-point t)))))))))
|
||
(setq marks (cdr marks))))
|
||
|
||
(defun surf-expand (mark flg)
|
||
(setq mark (cdr mark))
|
||
(let ((xlen (car mark))
|
||
(ylen (cadr mark))
|
||
(xstart (cadddr mark))
|
||
(ystart 0.) (zstart 0.) (xinc 0.) (yinc 0.) (zinc1 0.) (zinc2 0.))
|
||
(setq mark (cddddr mark) ystart (car mark) zstart (cadr mark)
|
||
xinc (caddr mark) yinc (cadddr mark) mark (cddddr mark)
|
||
zinc1 (car mark) zinc2 (cadr mark))
|
||
(do ((l) (i 0. (1+ i)))
|
||
((cond (flg (= i ylen)) (t (= i xlen))) (nreverse l))
|
||
(cond (flg (setq l (cons (list xlen xstart (+ ystart (* yinc i))
|
||
(+ zstart (* zinc2 i)) xinc 0. zinc1)
|
||
l)))
|
||
(t (setq l (cons (list ylen (+ xstart (* xinc i)) ystart
|
||
(+ zstart (* zinc1 i)) 0. yinc zinc2)
|
||
l)))))))
|
||
|
||
(defun setfuns (/3d txtyp xfun yfun cp)
|
||
(cond ((eq txtyp '$special))
|
||
((and (or (null /3d) (eq /3d '$contour)) (not txtyp))
|
||
(setq xfun nil yfun nil))
|
||
((or (eq /3d t) (eq /3d '$hide))
|
||
(cond ((null cp)
|
||
(cond ($perspective
|
||
(cond ($reverse (setq xfun '$old3dxr yfun '$old3dyr))
|
||
(t (setq xfun '$old3dx yfun '$old3dy)))
|
||
(setq $howclose '$howcloseold3d))
|
||
(t (cond ($reverse
|
||
(setq xfun '$oldnp3dxr yfun '$oldnp3dyr))
|
||
(t (setq xfun '$oldnp3dx yfun '$oldnp3dy)))
|
||
(setq $howclose '$howcloseoldnp3d))))
|
||
(t (cond ($perspective
|
||
(cond ($reverse (setq xfun '$p3dxr yfun '$p3dyr))
|
||
(t (setq xfun '$p3dx yfun '$p3dy)))
|
||
(setq $howclose '$howclose3d))
|
||
(t (cond ($reverse (setq xfun '$np3dxr yfun '$np3dyr))
|
||
(t (setq xfun '$np3dx yfun '$np3dy)))
|
||
(setq $howclose '$howclosenp3d))))))
|
||
((eq txtyp '$polar) (setq xfun '$polarx yfun '$polary))
|
||
((eq txtyp '%log) (setq xfun '$clog yfun '$clog))
|
||
((eq txtyp '$loglin) (setq xfun '$clog yfun nil))
|
||
((eq txtyp '$not3d) (setq yfun '$ztoy xfun nil))
|
||
((eq txtyp '$linlog) (setq yfun '$clog xfun nil)))
|
||
(cond ((or xfun yfun)
|
||
(or #-franz (get '$clog 'subr) #+franz (getd '$clog)
|
||
(loadfile (fasl-file iffun) t $loadprint))))
|
||
(call-init xfun yfun)
|
||
nil)
|
||
|
||
(defun date (long-form)
|
||
#-franz (let ((time (status daytime))
|
||
(day (and long-form (status dow)))
|
||
(date (status date))
|
||
(userid (status userid)))
|
||
(setq time (mapcar (function
|
||
(lambda (i)
|
||
(cond ((< i base) (cons 48. (explodec i)))
|
||
(t (explodec i)))))
|
||
time)
|
||
time (append (car time) '(58.) (cadr time)
|
||
(and long-form (append '(58.) (caddr time)))))
|
||
(and long-form
|
||
(setq day (exploden day)
|
||
day (cons (car day)
|
||
(mapcar (function (lambda (i) (+ i 32.)))
|
||
(cdr day)))))
|
||
(setq date (cond (long-form
|
||
(append ((lambda (l i)
|
||
(setq i (- (car (last l)) 48.))
|
||
(append l
|
||
(explodec
|
||
(cond ((and (= (length l) 2.)
|
||
(= (car l) 49.))
|
||
"th")
|
||
((= i 1.) "st")
|
||
((= i 2.) "nd")
|
||
((= i 3.) "rd")
|
||
(t "th")))))
|
||
(exploden (caddr date)) 0.)
|
||
'(32.)
|
||
(explodec (cdr (assoc (cadr date)
|
||
'((1. . "January")
|
||
(2. . "February")
|
||
(3. . "March")
|
||
(4. . "April")
|
||
(5. . "May")
|
||
(6. . "June")
|
||
(7. . "July")
|
||
(8. . "August")
|
||
(9. . "September")
|
||
(10. . "October")
|
||
(11. . "November")
|
||
(12. . "December")))))
|
||
'(44. 32. 49. 57.) (explodec (car date))))
|
||
(t (append (exploden (caddr date)) '(46.)
|
||
; ((lambda (base)
|
||
; (mapcar (function
|
||
; (lambda (i) (+ i 32.)))
|
||
; (exploden (cadr date))))
|
||
; 'roman)
|
||
(explodec (cdr (assoc (cadr date)
|
||
'((1. . "i")
|
||
(2. . "ii")
|
||
(3. . "iii")
|
||
(4. . "iv")
|
||
(5. . "v")
|
||
(6. . "vi")
|
||
(7. . "vii")
|
||
(8. . "viii")
|
||
(9. . "ix")
|
||
(10. . "x")
|
||
(11. . "xi")
|
||
(12. . "xii")))))
|
||
'(46.) (explodec (car date))))))
|
||
(maknam (append (exploden userid) '(32.) time '(32.)
|
||
(and long-form (append day '(44. 32.)))
|
||
date)))
|
||
#+franz (status ctime))
|
||
|
||
(defun dolabels (/3d xlabel ylabel title)
|
||
(cond (sameflg
|
||
($screensize (- (car plot-window)
|
||
(cond (ylabel (* 2. char-width)) (t 0.)))
|
||
(- (cadr plot-window)
|
||
(cond (xlabel (* 2. char-height)) (t 0.)))
|
||
(caddr plot-window)
|
||
(+ (cadddr plot-window)
|
||
(cond ((or title (and (not sameflg) $dateplot))
|
||
(* 2. char-height)) (t 0.)))))
|
||
(t (apply '$screensize (get-window))))
|
||
(cond (title ($ghprint (cond ((atom title) title)
|
||
(t (maknam (makstring title))))
|
||
(// (+ min-x max-x) 2.)
|
||
(- max-y char-height) 11.)))
|
||
(cond ((and (not sameflg) $dateplot)
|
||
($ghprint (date (not title)) max-x (- max-y char-height) 2.)))
|
||
(cond ((or title (and (not sameflg) $dateplot))
|
||
(setq max-y (- max-y (* 2. char-height)))))
|
||
(cond ((not (or sameflg $noprint (or (eq /3d '$hide) (eq /3d t))))
|
||
((lambda (l)
|
||
($ghprint (cond ((< (* (length l) char-width) (- max-x min-x))
|
||
(maknam l))
|
||
(t (list (pfp1 (car plot-size)
|
||
(fix $plotnumprec))
|
||
'/
|
||
(pfp1 (caddr plot-size)
|
||
(fix $plotnumprec))
|
||
'/
|
||
(pfp1 (cadr plot-size)
|
||
(fix $plotnumprec))
|
||
'/
|
||
(pfp1 (cadddr plot-size)
|
||
(fix $plotnumprec)))))
|
||
(// (+ min-x max-x) 2.) min-y 1.))
|
||
(apply 'append
|
||
(mapcar 'exploden
|
||
(list "Xmin = "
|
||
(pfp1 (car plot-size) (fix $plotnumprec))
|
||
" Xmax = "
|
||
(pfp1 (caddr plot-size) (fix $plotnumprec))
|
||
" Ymin = "
|
||
(pfp1 (cadr plot-size) (fix $plotnumprec))
|
||
" Ymax = "
|
||
(pfp1 (cadddr plot-size) (fix $plotnumprec))))))
|
||
(setq min-y (+ min-y char-height))))
|
||
(cond (xlabel ($ghprint (cond ((atom xlabel) xlabel)
|
||
(t (maknam (makstring $xlabel))))
|
||
(// (+ min-x max-x) 2.)
|
||
min-y 1.)
|
||
(setq min-y (+ min-y char-height))))
|
||
(cond ((or xlabel (not $noprint)) (setq min-y (+ min-y char-height))))
|
||
(cond (ylabel ($gvprint (cond ((atom ylabel) ylabel)
|
||
(t (maknam (makstring ylabel))))
|
||
min-x
|
||
(// (+ min-y max-y) 2.)
|
||
1.)
|
||
(setq min-x (+ min-x (* 2. char-width)))))
|
||
(or sameflg (setq plot-window (list min-x min-y max-x max-y)))
|
||
(apply '$screensize plot-window))
|
||
|
||
(defun get-window nil
|
||
(or #-franz (get '$clear 'subr) #+franz (getd '$clear)
|
||
(loadfile (fasl-file tekplt) t $loadprint))
|
||
(let ((window (cond (($listp (meval1 '$window))
|
||
(mapcar 'fix (list (cadr $window) (cadddr $window) (caddr $window)
|
||
(car (cddddr $window)))))
|
||
(dsk-graphics (list 0. 5. 1023. 790.))
|
||
((eq tty-graphics 'tek) (list 0. 5. 1023. 790.))
|
||
((eq tty-graphics 'imlac) (list 0. 200. 1023. 1006.))
|
||
((eq tty-graphics 'grinnell) (list 0 22. 1023. 1020.))
|
||
((or (eq tty-graphics 'print) (eq tty-graphics 'disp))
|
||
(list 0. 0. (1- (* char-width linel))
|
||
(1- (* char-height $plotheight))))
|
||
(t (list 0. 0. 1023. 1023.))))
|
||
(mn-x 0) (mn-y 0) (mx-x 0) (mx-y 0) (cx 0) (cy 0) (gap 0))
|
||
(cond ((null (or vertflg sideflg)) window)
|
||
(t (setq mn-x (car window) mn-y (cadr window)
|
||
mx-x (caddr window) mx-y (cadddr window)
|
||
cx (// (+ mn-x mx-x) 2) cy (// (+ mn-y mx-y) 2)
|
||
gap (// (fix $plotgap) 2))
|
||
(cond (vertflg (cond ((eq vertflg '$top)
|
||
(setq mn-y (+ cy gap)))
|
||
(t (setq mx-y (- cy gap))))))
|
||
(cond (sideflg (cond ((eq sideflg '$left)
|
||
(setq mx-x (- cx gap)))
|
||
(t (setq mn-x (+ cx gap))))))
|
||
(list mn-x mn-y mx-x mx-y)))))
|
||
|
||
(defun doscales (marks /3d xlabel ylabel title)
|
||
($changedash 0.)
|
||
(let ((l) (l1))
|
||
(cond ((not sameflg)
|
||
(and (or (eq /3d t) (eq /3d '$hide))
|
||
(/3d-scale (meval1 '$centerplot) (meval1 '$viewpt)))
|
||
(setq l (scale0 marks (meval1 '$xmin) (meval1 '$xmax)
|
||
#-franz (get 'call-x 'subr)
|
||
#+franz (getd 'call-x))
|
||
l (apply 'scale1
|
||
(cons (cond ((or (eq /3d t) (eq /3d '$hide)) 0.)
|
||
((atom $ticknum)
|
||
(fix $ticknum))
|
||
(t (fix (cadr $ticknum))))
|
||
l)))
|
||
(setq l1 (scale0 marks (meval1 '$ymin) (meval1 '$ymax)
|
||
#-franz (get 'call-y 'subr)
|
||
#+franz (getd 'call-y))
|
||
l1 (apply 'scale1
|
||
(cons (cond ((or (eq /3d t) (eq /3d '$hide)) 0.)
|
||
((atom $ticknum)
|
||
(fix $ticknum))
|
||
(t (fix (caddr $ticknum))))
|
||
l1)))
|
||
(setq plot-size (list (caddr l) (caddr l1) (cadddr l)
|
||
(cadddr l1)))))
|
||
(dolabels /3d xlabel ylabel title)
|
||
(apply '$size plot-size)
|
||
(setq $xmin1 (car plot-size) $ymin1 (cadr plot-size)
|
||
$xmax1 (caddr plot-size) $ymax1 (cadddr plot-size))
|
||
(cond ((and (not sameflg) $equalscale)
|
||
(cond ((> scale-y scale-x)
|
||
(setq plot-window
|
||
(list (+ min-x
|
||
(fix (//$ (-$ (float size-x)
|
||
(//$ size-xf scale-y)) 2.0)))
|
||
min-y
|
||
(- max-x
|
||
(fix (//$ (-$ (float size-x)
|
||
(//$ size-xf scale-y)) 2.0)))
|
||
max-y)))
|
||
(t
|
||
(setq plot-window
|
||
(list min-x
|
||
(+ min-y
|
||
(fix (//$ (-$ (float size-y)
|
||
(//$ size-yf scale-x)) 2.0)))
|
||
max-x
|
||
(- max-y (fix (//$ (-$ (float size-y)
|
||
(//$ size-yf scale-x))
|
||
2.0)))))))
|
||
(apply '$screensize plot-window)))
|
||
(setq $window1 (list '(mlist) (car plot-window) (caddr plot-window)
|
||
(cadr plot-window) (cadddr plot-window)))
|
||
(cond ((not (or sameflg (eq /3d t) (eq /3d '$hide)))
|
||
(apply 'axes (append l l1))))))
|
||
|
||
(defun /3d-scale (cp vp)
|
||
(let ((cpflg (and ($listp cp)
|
||
(numberp (cadr cp))
|
||
(numberp (caddr cp))
|
||
(numberp (cadddr cp))))
|
||
(vpflg (and ($listp vp)
|
||
(numberp (cadr vp))
|
||
(numberp (caddr vp))
|
||
(numberp (cadddr vp)))))
|
||
(cond ((not (and cpflg vpflg))
|
||
(do ((arrs (list z-arrv y-arrv x-arrv) (cdr arrs))
|
||
(arr)
|
||
(lmin)
|
||
(lmax)
|
||
(infin (#-franz ^$ #+franz expt 8.0 42.)))
|
||
((null arrs)
|
||
(cond (vpflg (setq vp (mapcar 'float (cdr vp))))
|
||
(t (setq vp (mapcar
|
||
(function
|
||
(lambda (max min)
|
||
(+$ (cond ($perspective max)
|
||
(t 0.0))
|
||
(*$ 3.0 (-$ max min)))))
|
||
lmax lmin))))
|
||
(cond (cpflg (setq cp (mapcar 'float (cdr cp))))
|
||
(t (cond ((null cp)
|
||
(setq cp (list (car vp)
|
||
(*$ 0.5 (+$ (cadr lmax)
|
||
(cadr lmin)))
|
||
(caddr vp))))
|
||
(t (setq cp (mapcar
|
||
(function
|
||
(lambda (max min)
|
||
(*$ 0.5 (+$ max min))))
|
||
lmax lmin))))))
|
||
(setq $xmin3d (car lmin) $ymin3d (cadr lmin)
|
||
$zmin3d (caddr lmin) $xmax3d (car lmax)
|
||
$ymax3d (cadr lmax) $zmax3d (caddr lmax))
|
||
nil)
|
||
(setq arr (car arrs))
|
||
(do ((i 0. (1+ i)) (max (-$ infin)) (min infin)
|
||
(len (cadr (arraydims arr))) (pt))
|
||
((= i len) (setq lmin (cons min lmin) lmax (cons max lmax))
|
||
nil)
|
||
(setq pt (arraycall flonum arr i))
|
||
(and (> pt max) (setq max pt))
|
||
(and (< pt min) (setq min pt)))))
|
||
(t (setq vp (mapcar 'float (cdr vp)) cp (mapcar 'float (cdr cp)))))
|
||
(apply '$initperspec (append cp vp))
|
||
(setq $centerplot1 (cons '(mlist) cp) $viewpt1 (cons '(mlist) vp))
|
||
nil))
|
||
|
||
(defun scale0 (marks l l1 call-fun)
|
||
(let ((infin (#-franz ^$ #+franz expt 8.0 42.))
|
||
(xmin 0.0)
|
||
(xmax 0.0))
|
||
(cond ((not (and (numberp l) (numberp l1)))
|
||
(setq xmin infin xmax (-$ infin))
|
||
(do ((marks marks (cdr marks)) (mark) (len)
|
||
(xbeg) (ybeg) (zbeg))
|
||
((null marks))
|
||
(setq mark (car marks))
|
||
(or (car mark)
|
||
(setq marks (append (surf-expand mark t) (cdr marks))
|
||
mark (car marks)))
|
||
(setq len (car mark) xbeg (cadr mark)
|
||
ybeg (caddr mark) zbeg (cadddr mark)
|
||
mark (cddddr mark))
|
||
(do ((xinc (car mark))
|
||
(yinc (cadr mark))
|
||
(zinc (caddr mark))
|
||
(pt)
|
||
(i 0 (1+ i))
|
||
(x-pt 0.0) (y-pt 0.0) (z-pt 0.0) )
|
||
((= i len))
|
||
(declare (flonum x-pt y-pt z-pt))
|
||
(setq x-pt (x-arr xbeg)
|
||
y-pt (y-arr ybeg)
|
||
z-pt (z-arr zbeg))
|
||
(cond ((not (or (= x-pt $plotundefined)
|
||
(= y-pt $plotundefined)
|
||
(= z-pt $plotundefined)))
|
||
(setq pt #-franz (subrcall flonum call-fun x-pt y-pt z-pt)
|
||
#+franz (funcall call-fun x-pt y-pt z-pt))
|
||
(and (> pt xmax) (setq xmax pt))
|
||
(and (< pt xmin) (setq xmin pt))))
|
||
(setq xbeg (+ xbeg xinc) ybeg (+ ybeg yinc)
|
||
zbeg (+ zbeg zinc))))))
|
||
(and (numberp l) (setq xmin (float l)))
|
||
(and (numberp l1) (setq xmax (float l1)))
|
||
(cond ((< xmax xmin) (setq xmax (prog2 nil xmin (setq xmin xmax)))))
|
||
(cond ((= xmax xmin)
|
||
(cond ((= xmax 0.0) (setq xmax 1.0 xmin -1.0))
|
||
(t (setq xmax (+$ xmax (*$ (abs xmax) 0.1))
|
||
xmin (-$ xmin (*$ (abs xmin) 0.1)))))))
|
||
(list xmin xmax)))
|
||
|
||
(defun scale1 (n xmin xmax)
|
||
(cond ((not (= n 0))
|
||
(fillarray 'vint '(1.0 2.0 5.0 10.0))
|
||
(do ((i 0. (1+ i)))
|
||
((> i 2.))
|
||
(store (sqr i) (sqrt (*$ (vint i) (vint (1+ i))))))
|
||
(let ((del 2.0e-5) (a 0.0) (b 0.0) (xminp 0.0) (xmaxp 0.0)
|
||
(dist 0.0)
|
||
(sign (> n 0.)))
|
||
(setq n (abs n)
|
||
a (//$ (-$ xmax xmin) (float n))
|
||
n (fix (//$ (log a) (log 10.0)))
|
||
b (//$ a (#-franz ^$ #+franz expt 10.0 n)))
|
||
(do ((i 0. (1+ i)))
|
||
((> i 2.) (setq b (vint 3.)))
|
||
(cond ((< b (sqr i)) (return (setq b (vint i))))))
|
||
(setq dist (*$ b (#-franz ^$ #+franz expt 10.0 n))
|
||
a (//$ xmin dist) n (fix a))
|
||
(and (< (abs (-$ (float (1+ n)) a)) del) (setq n (1+ n)))
|
||
(setq xminp (*$ dist (float n)) a (//$ xmax dist)
|
||
n (1+ (fix a)))
|
||
(and (< (abs (-$ a (float (1- n)))) del) (setq n (1- n)))
|
||
(setq xmaxp (*$ dist (float n)))
|
||
(and (> xminp xmin) (setq xminp xmin))
|
||
(and (< xmaxp xmax) (setq xmaxp xmax))
|
||
(or sign (cond ((< (+$ xminp (*$ dist del)) xmin)
|
||
(setq xminp (+$ xminp dist)))))
|
||
(and sign (setq xmin xminp xmax xmaxp))
|
||
(list xminp dist xmin xmax)))
|
||
(t (list xmin (-$ xmax xmin) xmin xmax))))
|
||
|
||
(defun axis (xlow xhigh xminp xdist org horiz)
|
||
(let ((ft (cond ((atom $ticksize) (float $ticksize))
|
||
(horiz (float (cadr $ticksize)))
|
||
(t (float (caddr $ticksize)))))
|
||
(del 2.0e-5))
|
||
(cond (horiz ($line xlow org xhigh org) (setq ft (*$ ft scale-y)))
|
||
(t ($line org xlow org xhigh) (setq ft (*$ ft scale-x))))
|
||
(and (> ft 0.0) (> xdist 0.0)
|
||
(setq ft (prog2 nil (+$ org ft) (setq org (-$ org ft))))
|
||
(do ((i 0 (1+ i))
|
||
(xminp1 xminp (max (+$ xminp (*$ (float i) xdist))
|
||
(+$ xminp1 xdist)))
|
||
(xmaxp (+$ (min xdist (*$ del xdist)) xhigh)))
|
||
;; (*$ del xdist) can underflow. The (min ..)
|
||
;; minimizes the consequences of this.
|
||
((> xminp1 xmaxp))
|
||
(cond (horiz ($line xminp1 org xminp1 ft))
|
||
(t ($line org xminp1 ft xminp1)))))))
|
||
|
||
(defun axes (xminp xdist xmin xmax yminp ydist ymin ymax)
|
||
(let ((org 0.0))
|
||
(cond ($xaxis (cond ((or (< ymax 0.0) (> ymin 0.0)) (setq org ymin))
|
||
(t (setq org 0.0)))
|
||
(axis xmin xmax xminp xdist org t)
|
||
(cond ((eq $xaxis '$all)
|
||
($ghprint (pfp1 xmin (fix $plotnumprec))
|
||
(tek-x xmin) (- (tek-y org) char-height)
|
||
0.)
|
||
($ghprint (pfp1 xmax (fix $plotnumprec))
|
||
(tek-x xmax) (- (tek-y org) char-height)
|
||
2.)))))
|
||
(cond ($yaxis (cond ((or (< xmax 0.0) (> xmin 0.0)) (setq org xmin))
|
||
(t (setq org 0.0)))
|
||
(axis ymin ymax yminp ydist org nil)
|
||
(cond ((eq $yaxis '$all)
|
||
($ghprint (pfp1 ymin (fix $plotnumprec))
|
||
(tek-x org) (tek-y ymin) 2.)
|
||
($ghprint (pfp1 ymax (fix $plotnumprec))
|
||
(tek-x org) (tek-y ymax) 2.)))))))
|
||
|
||
(DEFMSPEC $replot (l1) (setq l1 (cdr l1))
|
||
(let ((l2 (cond ((atom (car l1))
|
||
(cond (($listp (meval1 (car l1)))
|
||
(cdr (meval1 (car l1))))
|
||
(t (list (car l1)))))
|
||
(($listp (car l1)) (cdar l1))
|
||
(t (list (car l1))))))
|
||
(do ((l2 l2 (cdr l2)) (l)) ((null l2) '$done) (setq l (car l2))
|
||
(cond ((or (null l) (eq l 't) (eq l '$true)) (setq l savemarks))
|
||
(t (cond ((setq l (plot2p l t))
|
||
(setq l (cdr l))
|
||
(*rearray 'x-arr 'flonum (cadr (arraydims (car l))))
|
||
#+franz (setq x-arrv (getd 'x-arr))
|
||
(fillarray 'x-arr (car l))
|
||
(setq l (cdr l))
|
||
(*rearray 'y-arr 'flonum (cadr (arraydims (car l))))
|
||
#+franz (setq y-arrv (getd 'y-arr))
|
||
(fillarray 'y-arr (car l))
|
||
(setq l (cdr l))
|
||
(*rearray 'z-arr 'flonum (cadr (arraydims (car l))))
|
||
#+franz (setq z-arrv (getd 'z-arr))
|
||
(fillarray 'z-arr (car l))
|
||
(setq l (cdr l)))
|
||
;;; old-plotname.
|
||
((eq (car (setq l (PLOTNAME-EVAL (car l2))))
|
||
'this-is-a-plot)
|
||
(setq l (cdr l))
|
||
(*rearray 'x-arr 'flonum (length (car l)))
|
||
#+franz (setq x-arrv (getd 'x-arr))
|
||
(fillarray 'x-arr (car l))
|
||
(setq l (cdr l))
|
||
(*rearray 'y-arr 'flonum (length (car l)))
|
||
#+franz (setq y-arrv (getd 'y-arr))
|
||
(fillarray 'y-arr (car l))
|
||
(setq l (cdr l))
|
||
(*rearray 'z-arr 'flonum (length (car l)))
|
||
#+franz (setq z-arrv (getd 'z-arr))
|
||
(fillarray 'z-arr (car l))
|
||
(setq l (cdr l)))
|
||
(t
|
||
(merror "not a plot: ~M"
|
||
(quote-subs (car l2)) )))))
|
||
(apply 'graph2 (list (car l) (graphopts2 (cdr l1) (cadr l)))))))
|
||
|
||
(DEFMSPEC $replot4 (l) (setq l (cdr l))
|
||
(cond ((> (length l) 4.) (merror "Too many args to REPLOT4")))
|
||
(let ((l1 (get-window))
|
||
(mn-x 0.) (mx-x 0.) (mn-y 0.) (mx-y 0.) (cx 0.) (cy 0.)
|
||
(datel (list nil $dateplot nil nil)))
|
||
(setq mn-x (car l1) mn-y (cadr l1) mx-x (caddr l1) mx-y (cadddr l1))
|
||
(setq cx (// (+ mn-x mx-x) 2.) cy (// (+ mn-y mx-y) 2.))
|
||
(setq l1 (list (list mn-x (- cx 10.) (+ cy 5.) mx-y)
|
||
(list (+ cx 10.) mx-x (+ cy 5.) mx-y)
|
||
(list mn-x (- cx 10.) mn-y (- cy 5.))
|
||
(list (+ cx 10.) mx-x mn-y (- cy 5.))))
|
||
(do ((l l (cdr l))
|
||
(flag '$first '$false)
|
||
($window (cons '(mlist) (car l1)) (cons '(mlist) (car l1)))
|
||
($dateplot (cond ((null (cdr l)) $dateplot)
|
||
(t (car datel)))
|
||
(car datel)))
|
||
((null (cdr l))
|
||
(meval `(($replot) ,(car l) $last)))
|
||
(setq l1 (cdr l1) datel (cdr datel))
|
||
(meval `(($replot) ,(car l) ,flag)))))
|
||
|
||
(comment
|
||
(DEFFUN $oldnameplot fexpr (l)
|
||
(PLOTNAME-SET (car l)
|
||
(list 'this-is-a-plot
|
||
(listarray 'x-arr)
|
||
(listarray 'y-arr)
|
||
(listarray 'z-arr)
|
||
(car savemarks)
|
||
(cadr savemarks)))
|
||
(car l)))
|
||
(comment
|
||
(defun pff (xf i j l)
|
||
(maknam (delq '/
|
||
(delq '+
|
||
(print-fixed-field-floating xf i j
|
||
(cons 'explode l)))))))
|
||
|
||
#-franz (defun pfp (xf i j l)
|
||
(maknam ((lambda (l)
|
||
(setq l (nreverse l))
|
||
(cond ((and (eq (car l) '/0)
|
||
(eq (cadr l) '/.))
|
||
(setq l (cddr l))))
|
||
(nreverse l))
|
||
(delq '/
|
||
(delq '+
|
||
(print-fixed-precision-floating xf i j
|
||
(cons 'explode l)
|
||
1.))))))
|
||
|
||
#-franz (defun pfp1 (xf prec) (pfp xf (+ 6. prec) prec nil))
|
||
#+franz (defun pfp1 (xf prec) (maknam (exploden xf)))
|
||
|
||
(or (boundp '$plots) (setq $plots '((mlist))))
|
||
|
||
#-franz
|
||
(defun list-to-array (l)
|
||
(let ((ary) (base 10.) (*nopoint))
|
||
(setq l (explode l)
|
||
ary (*array (gensym) 'fixnum (// (+ (length l) 4.) 5.)))
|
||
(do ((l1 (cond ((= (\ (length l) 5.) 0.) l)
|
||
(t (append l (do ((i (\ (length l) 5.) (1+ i))
|
||
(l2 nil (cons 0. l2)))
|
||
((= i 5.) l2)))))
|
||
(cdr l1))
|
||
(j 0. (1+ j)) (aryv #-franz (get ary 'array)
|
||
#+franz (getd ary)))
|
||
((null l1) ary)
|
||
(store (arraycall fixnum aryv j)
|
||
(car (pnget
|
||
(maknam
|
||
(list (car l1) (cadr l1) (caddr l1) (cadddr l1)
|
||
(prog2 (setq l1 (cddddr l1)) (car l1))))
|
||
7.))))))
|
||
|
||
#-franz
|
||
(defun array-to-list (ary)
|
||
(setq ary #-franz (get ary 'array)
|
||
#+franz (getd ary))
|
||
(do ((l) (i (1- (cadr (arraydims ary))) (1- i)) (n) (mask (lsh -1. -29.)))
|
||
((< i 0.) (*rearray ary) (readlist l))
|
||
(setq n (lsh (arraycall fixnum ary i) -1.))
|
||
(do ((j 0. (1+ j)) (k)) ((= j 5.))
|
||
(setq k (boole 1. mask n) n (lsh n -7.))
|
||
(or (= k 0.) (setq l (cons k l))))))
|
||
|
||
;;; a plot used to be associated with an object through its value cell
|
||
;;; this had to be change for atoms so that it didn't press too much upon
|
||
;;; the semantics of the language. Since the user has no use for the plot
|
||
;;; object, it really should be saved in a place private to PLOT2, since
|
||
;;; the name is always on the $PLOTS list anyway.
|
||
|
||
(DEFUN PLOTNAME-SET (OB VAL)
|
||
(COND ((ATOM OB)
|
||
($PUT OB VAL '$PLOT))
|
||
(T
|
||
(MSET OB VAL))))
|
||
|
||
(DEFUN PLOTNAME-EVAL (OB)
|
||
(COND ((ATOM OB)
|
||
($GET OB '$PLOT))
|
||
(T
|
||
(MEVAL1 OB))))
|
||
(DECLARE (*LEXPR $REMOVE))
|
||
(DEFUN PLOTNAME-REMVAL (OB)
|
||
(COND ((ATOM OB)
|
||
($REM OB '$PLOT))
|
||
(T
|
||
(I-$REMVALUE (LIST OB)))))
|
||
|
||
(defun quote-subs (pval) ;;; sigh. didn't this hint at possible lossage?
|
||
(cond ((OR (ATOM PVAL) (ATOM (CAR PVAL))) PVAL)
|
||
;;; didn't use to have the atom check. I couldn't run it with *RSET T.
|
||
((memq 'array (cdar pval))
|
||
(cons (car pval)
|
||
(mapcar (function (lambda (l)
|
||
(setq l (meval l))
|
||
(cond ((numberp l) l)
|
||
(t (list '(mquote) l)))))
|
||
(cdr pval))))
|
||
(t pval)))
|
||
|
||
(DEFMSPEC $NAMEPLOT (pval) (setq pval (cdr pval))
|
||
(or (= (length pval) 1.) (merror "Wrong number of args to NAMEPLOT"))
|
||
(setq pval (quote-subs (car pval)))
|
||
(PLOTNAME-SET pval nil) ; test for error here
|
||
(cond ((member pval $plots) (killplot pval)))
|
||
(let ((l savemarks) (ary))
|
||
(setq ary (*array (gensym) 'flonum (cadr (arraydims 'z-arr))))
|
||
(fillarray ary 'z-arr)
|
||
(setq l (cons ary l)
|
||
ary (*array (gensym) 'flonum (cadr (arraydims 'y-arr))))
|
||
(fillarray ary 'y-arr)
|
||
(setq l (cons ary l)
|
||
ary (*array (gensym) 'flonum (cadr (arraydims 'x-arr))))
|
||
(fillarray ary 'x-arr)
|
||
(PLOTNAME-set pval (cons (list 'plot2-/#2 'simp) (cons ary l)))
|
||
(nconc $plots (ncons pval))
|
||
pval))
|
||
|
||
(DEFMSPEC $SAVEPLOTS (l) (setq l (cdr l))
|
||
(let ((filespec (#-franz filestrip #+franz stripdollar #-franz
|
||
(cond (($listp (car l))
|
||
(prog2 nil
|
||
(cdar l)
|
||
(setq l (cdr l))))
|
||
(t (list '$plots '$> $device $direc)))
|
||
#+franz (prog2 nil (car l) (setq l (cdr l)))))
|
||
(file))
|
||
#-franz (defaultf filespec)
|
||
(or l (merror "SAVEPLOTS given nothing to save"))
|
||
(cond ((or (memq '$all l) (memq '$plots l)) (setq l (cdr $plots))))
|
||
(setq file (open #-franz defaultf
|
||
#+franz filespec '(out)))
|
||
(setq filespec (truename file))
|
||
#-franz (close file)
|
||
#-franz (deletef filespec)
|
||
#+franz (progn (print "Saved plots from PLOT2" file) (terpri file))
|
||
(do ((l l (cdr l)) (arys nil) (l1) (l2) (pval))
|
||
((null l) #-franz (dumparrays arys filespec)
|
||
#+franz (close file)
|
||
(cons '(mlist)
|
||
(cons #-franz
|
||
(cons '(mlist)
|
||
(append (cdr filespec) (car filespec)))
|
||
#+franz filespec
|
||
(nreverse l2))))
|
||
(setq pval (quote-subs (car l)))
|
||
(cond ((setq l1 (plot2p pval nil))
|
||
(rplacd (cdar l1) filespec)
|
||
(setq l1 (cdr l1))
|
||
#-franz
|
||
(setq arys (append arys
|
||
(list (list-to-array
|
||
(cons pval (cdddr l1)))
|
||
(car l1) (cadr l1) (caddr l1)))
|
||
l2 (cons pval l2))
|
||
#+franz
|
||
(progn (print (cons pval (cdddr l1)) file) (terpri file)
|
||
(array-print (car l1) file)
|
||
(array-print (cadr l1) file)
|
||
(array-print (caddr l1) file)
|
||
(terpri file)))
|
||
(t (delete pval $plots 1.))))))
|
||
|
||
; print a 1d array on a file, but avoid the cost of listarraying
|
||
#+franz
|
||
(defun array-print (array file)
|
||
(let ((l (arraydims array)))
|
||
(print l file) (terpri file)
|
||
(do ((i 0 (1+ i)) (n (cadr l)))
|
||
((not (< i n)))
|
||
(print (arraycall flonum array i) file)
|
||
(terpri file))))
|
||
|
||
; read a 1d array from a file and return it
|
||
#+franz
|
||
(defun array-read (file)
|
||
(let ((l (read file)))
|
||
(do ((i 0 (1+ i)) (n (cadr l))
|
||
(array (*array (gensym) 'flonum (cadr l))))
|
||
((not (< i n)) array)
|
||
(store (arraycall flonum array i) (read file)))))
|
||
|
||
(defun plot2p (l1 reload)
|
||
(let ((pval (PLOTNAME-EVAL l1)))
|
||
(cond ((and (eq (typep pval) 'list) (eq (caar pval) 'plot2-/#2))
|
||
(cond ((and (> (length pval) 4.)
|
||
#-franz (get (cadr pval) 'array) #+franz (arrayp (cadr pval))
|
||
#-franz (get (caddr pval) 'array) #+franz (arrayp (caddr pval))
|
||
#-franz (get (cadddr pval) 'array) #+franz (arrayp (cadddr pval)))
|
||
pval)
|
||
((and reload #-franz (eq (typep (cddar pval)) 'list)
|
||
#-franz (= (length (cddar pval)) 3.)
|
||
#+franz (cddar pval))
|
||
(loadplots (cddar pval) t (memq $loadprint '(t $autoload)))
|
||
(plot2p l1 nil)))))))
|
||
|
||
(defun loadplots (l pushdef prinflg)
|
||
(let ((arrs) (file))
|
||
#-franz (setq l (namelist l))
|
||
#-franz (or pushdef (defaultf l))
|
||
(cond ((null #-franz (setq arrs (probef l)) #+franz (probef l))
|
||
(merror "~A file not found" (namestring l))))
|
||
#-franz (setq l arrs)
|
||
#+franz (setq file (open l '(in)))
|
||
(cond ((null (dumpp #-franz l #+franz file))
|
||
#+franz (close file)
|
||
(merror "~A not a file of saved plots"
|
||
(namestring l))))
|
||
(cond (prinflg
|
||
(mtell "~%~A being loaded." (namestring l))))
|
||
#-franz(progn (setq arrs (mapcar 'car (loadarrays l)))
|
||
(cond (prinflg (mtell "~%loading done")))
|
||
(do ((l1) (pval))
|
||
((null arrs))
|
||
(setq l1 (array-to-list (car arrs)) arrs (cdr arrs)
|
||
pval (car l1))
|
||
(cond ((or (atom pval) (not (arrfunp (caar pval))))
|
||
(killplot pval)))
|
||
(nconc $plots (ncons pval))
|
||
(PLOTNAME-SET pval (cons (cons 'plot2-/#2 (cons 'simp l))
|
||
(cons (car arrs)
|
||
(cons (cadr arrs)
|
||
(cons (caddr arrs) (cdr l1))))))
|
||
(setq arrs (cdddr arrs))))
|
||
#+franz(progn (do ((l1 (read file) (read file)) (ar1) (ar2) (ar3) (pval))
|
||
((null l1) (cond (prinflg (mtell "~%loading done")))
|
||
(close file) nil)
|
||
(setq ar1 (array-read file)
|
||
ar2 (array-read file)
|
||
ar3 (array-read file)
|
||
pval (car l1))
|
||
(cond ((or (atom pval) (not (arrfunp (caar pval))))
|
||
(killplot pval)))
|
||
(nconc $plots (ncons pval))
|
||
(PLOTNAME-SET pval
|
||
(cons (cons 'plot2-/#2 (cons 'simp l))
|
||
(cons ar1 (cons ar2 (cons ar3 (cdr l1))))))))))
|
||
|
||
(DEFMSPEC $loadplots (l) (setq l (cdr l))
|
||
#-franz
|
||
(cond ((> (length l) 4.) (merror "Too many args to LOADPLOTS")))
|
||
#+franz
|
||
(or (= (length l) 1.) (merror "Wrong number of args to LOADPLOTS"))
|
||
#+franz
|
||
(setq l (car l))
|
||
(loadplots (#-franz filestrip #+franz stripdollar l)
|
||
nil (memq $loadprint '(t $loadfile)))
|
||
'$done)
|
||
|
||
(DEFMSPEC $KILLPLOTS (l) (setq l (cdr l))
|
||
(do ((l1 l (cdr l1))) ((null l1) '$done)
|
||
(cond ((memq (car l1) '($plots $all))
|
||
(setq l1 (append (cdr $plots) (cdr l1)))))
|
||
(killplot (quote-subs (car l1)))))
|
||
|
||
(defun killplot (plot)
|
||
(let ((pval) (file))
|
||
(cond ((setq pval (plot2p plot nil))
|
||
(setq file (car pval))
|
||
(*rearray (cadr pval)) (*rearray (caddr pval))
|
||
(*rearray (cadddr pval))
|
||
#-franz (remprop (cadr pval) 'array)
|
||
#-franz (remprop (caddr pval) 'array)
|
||
#-franz (remprop (cadddr pval) 'array)
|
||
(PLOTNAME-REMVAL plot)
|
||
(PLOTNAME-set plot (list file))))
|
||
(delete plot $plots 1.)))
|
||
|
||
;; checks to see if file is dumparray'ed by looking at the first word of the file
|
||
|
||
(defun dumpp (l)
|
||
#-franz
|
||
(cond ((setq l (open l '(in fixnum)))
|
||
(prog2 nil (= (in l) -262143.) (close l))))
|
||
#+franz
|
||
(equal (read l) "Saved plots from PLOT2"))
|