mirror of
https://github.com/PDP-10/its.git
synced 2026-03-23 09:19: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.
307 lines
13 KiB
Common Lisp
307 lines
13 KiB
Common Lisp
;;; -*- Mode:LISP; Package:MACSYMA -*-
|
||
|
||
; ** (c) Copyright 1981 Massachusetts Institute of Technology **
|
||
|
||
(macsyma-module plot)
|
||
|
||
(DECLARE (SPLITFILE GRAPH2)
|
||
(SPECIAL $RATPRINT $XAXIS $YAXIS LINEL $PLOTHEIGHT $NUMER $FLOAT
|
||
$BFLOAT ^W ^R TTY $CALCOMPNUM $MULTGRAPH $FLOAT2BF $%ENUMER)
|
||
(FLONUM LOW HIGH INC XLOW XHIGH XINC YLOW YHIGH YINC VAL
|
||
(ROUNDUP FLONUM) (FMEVAL))
|
||
(FIXNUM LINEL $PLOTHEIGHT I M N ORG)
|
||
(NOTYPE (POINTSUBST NOTYPE FLONUM FLONUM FIXNUM))
|
||
(*EXPR $FLOAT)
|
||
(*LEXPR MAP1)
|
||
(ARRAY* (NOTYPE PLOTARY 1)))
|
||
|
||
(DEFUN VERTCHAR MACRO (X)
|
||
(COND ((STATUS FEATURES ITS) ''/[) (T ''/|))) ; ascii 124.
|
||
|
||
(DEFMSPEC $PARAMPLOT (L) (SETQ L (CDR L))
|
||
(IF (NOT (MFBOUNDP '$PLOT)) (LOAD-FUNCTION '$PLOT T))
|
||
(IF (< (LENGTH L) 4) (MERROR "Too few arguments to PARAMPLOT"))
|
||
((LAMBDA (FUNLX FUNLY VAR ARG4 $NUMER $FLOAT $BFLOAT LOW HIGH INTFLG INC
|
||
$RATPRINT $FLOAT2BF $%ENUMER)
|
||
(SETQ L (CDDDDR L)
|
||
FUNLX (COND (($LISTP FUNLX) (CDR FUNLX)) (T (LIST FUNLX)))
|
||
FUNLY (COND (($LISTP FUNLY) (CDR FUNLY)) (T (LIST FUNLY))))
|
||
(COND ((NOT (= (LENGTH FUNLX) (LENGTH FUNLY)))
|
||
(MERROR "Arguments to PARAMPLOT are of unequal length"))
|
||
((NOT (NUMBERP (SETQ ARG4 (FMEVAL1 ARG4))))
|
||
(IF (NOT ($LISTP ARG4)) (MERROR "Invalid argument to PARAMPLOT:~%~M" ARG4))
|
||
(SETQ L (GRAPHOPTS L))
|
||
(GRAPH (DO ((FUNLX FUNLX (CDR FUNLX)) (XSETS)) ((NULL FUNLX) XSETS)
|
||
(SETQ XSETS
|
||
(NCONC XSETS
|
||
(NCONS (CDR (MAP1 (LIST '(LAMBDA) (LIST '(MLIST) VAR)
|
||
(LIST '(FMEVAL) (CAR FUNLX)))
|
||
ARG4))))))
|
||
(DO ((FUNLY FUNLY (CDR FUNLY)) (YSETS)) ((NULL FUNLY) YSETS)
|
||
(SETQ YSETS
|
||
(NCONC YSETS
|
||
(NCONS (CDR (MAP1 (LIST '(LAMBDA) (LIST '(MLIST) VAR)
|
||
(LIST '(FMEVAL) (CAR FUNLY)))
|
||
ARG4))))))
|
||
L '$DONE))
|
||
(T (IF (NULL L) (MERROR "Too few arguments to PARAMPLOT"))
|
||
(SETQ HIGH (FMEVAL (CAR L)) LOW ARG4 L (CDR L))
|
||
(SETQ L (GRAPHOPTS (COND ((AND L (EQ (CAR L) '$INTEGER))
|
||
(SETQ INTFLG T) (CDR L))
|
||
(T L))))
|
||
(COND (INTFLG (SETQ HIGH (FLOAT (FIX HIGH))
|
||
LOW (COND ((ZEROP (*DIF LOW (FIX LOW))) LOW)
|
||
(T (FLOAT (FIX (+$ LOW 0.999999))))))))
|
||
(SETQ INC (//$ (-$ HIGH LOW) (COND #+MULTICS ($MULTGRAPH (FLOAT $CALCOMPNUM))
|
||
(T (FLOAT (- LINEL 5))))))
|
||
(IF (NOT (PLUSP INC))
|
||
(MERROR "Invalid arguments to PARAMPLOT:~%~M"
|
||
(LIST '(MLIST SIMP) LOW HIGH)))
|
||
(SETQ INC (COND (INTFLG (FLOAT (FIX (+$ INC 0.999999))))
|
||
(T (ROUNDUP INC))))
|
||
(DO ((VAL LOW (+$ VAL INC))
|
||
(XSETS (DO ((FUNLX FUNLX (CDR FUNLX)) (LL NIL (CONS (LIST NIL) LL)))
|
||
((NULL FUNLX) LL)))
|
||
(YSETS (DO ((FUNLY FUNLY (CDR FUNLY)) (LL NIL (CONS (LIST NIL) LL)))
|
||
((NULL FUNLY) LL))))
|
||
((> VAL HIGH) (GRAPH (MAPCAR 'CDR XSETS) (MAPCAR 'CDR YSETS) L '$DONE))
|
||
(DO ((FUNLX FUNLX (CDR FUNLX)) (XSETS XSETS (CDR XSETS)))
|
||
((NULL FUNLX))
|
||
(RPLACD (CAR XSETS)
|
||
(CONS (FMEVAL (LIST '($EV) (CAR FUNLX)
|
||
(LIST '(MEQUAL) VAR
|
||
(COND (INTFLG (FIX VAL)) (T VAL)))))
|
||
(CDAR XSETS))))
|
||
(DO ((FUNLY FUNLY (CDR FUNLY)) (YSETS YSETS (CDR YSETS)))
|
||
((NULL FUNLY))
|
||
(RPLACD (CAR YSETS)
|
||
(CONS (FMEVAL (LIST '($EV) (CAR FUNLY)
|
||
(LIST '(MEQUAL) VAR
|
||
(COND (INTFLG (FIX VAL)) (T VAL)))))
|
||
(CDAR YSETS))))))))
|
||
(COND ((ATOM (CAR L)) (MEVAL (CAR L))) (T (CAR L)))
|
||
(COND ((ATOM (CADR L)) (MEVAL (CADR L))) (T (CADR L)))
|
||
(CADDR L) (CADDDR L) T T NIL 0.0 0.0 NIL 0.0 NIL T T))
|
||
|
||
(DEFMSPEC $MULTIGRAPH (L) (SETQ L (CDR L))
|
||
(IF (NOT (MFBOUNDP '$PLOT)) (LOAD-FUNCTION '$PLOT T))
|
||
((LAMBDA (ARG1 XSETS YSETS $NUMER $FLOAT $BFLOAT $FLOAT2BF $%ENUMER)
|
||
(IF (NOT ($LISTP ARG1)) (MERROR "Invalid first argument to MULTIGRAPH"))
|
||
(DO ((ARG1 (CDR ARG1) (CDR ARG1)) (LL) (XSET) (YSET))
|
||
((NULL ARG1))
|
||
(IF (OR (NOT ($LISTP (SETQ LL (MEVAL (CAR ARG1)))))
|
||
(NOT (= (LENGTH LL) 3))
|
||
(NOT ($LISTP (SETQ XSET (MEVAL (CADR LL)))))
|
||
(NOT ($LISTP (SETQ YSET (MEVAL (CADDR LL)))))
|
||
(NOT (= (LENGTH XSET) (LENGTH YSET))))
|
||
(MERROR "Invalid first argument to MULTIGRAPH"))
|
||
(SETQ XSETS (NCONC XSETS (NCONS (MAPCAR 'FMEVAL (CDR XSET))))
|
||
YSETS (NCONC YSETS (NCONS (MAPCAR 'FMEVAL (CDR YSET))))))
|
||
(GRAPH XSETS YSETS (GRAPHOPTS (CDR L)) '$DONE))
|
||
(MEVAL (CAR L)) NIL NIL T T NIL T T))
|
||
|
||
(DECLARE (SPLITFILE GRAPH))
|
||
|
||
(COND ((NOT (BOUNDP '$XAXIS)) (SETQ $XAXIS NIL)))
|
||
(COND ((NOT (BOUNDP '$YAXIS)) (SETQ $YAXIS NIL)))
|
||
|
||
(DEFMSPEC $PLOT (L) (SETQ L (CDR L))
|
||
(IF (< (LENGTH L) 3) (MERROR "Too few arguments to PLOT"))
|
||
((LAMBDA (FUNL VAR ARG3 $NUMER $FLOAT $BFLOAT LOW HIGH INTFLG INC $RATPRINT $FLOAT2BF $%ENUMER)
|
||
(SETQ L (CDDDR L) FUNL (COND (($LISTP FUNL) (CDR FUNL)) (T (LIST FUNL))))
|
||
(COND ((NOT (NUMBERP (SETQ ARG3 (FMEVAL1 ARG3))))
|
||
(IF (NOT ($LISTP ARG3)) (MERROR "Invalid argument to PLOT:~%~M" ARG3))
|
||
(SETQ L (GRAPHOPTS L))
|
||
(GRAPH (MAPCAR 'FMEVAL (CDR ARG3))
|
||
(DO ((FUNL FUNL (CDR FUNL)) (YSETS)) ((NULL FUNL) YSETS)
|
||
(SETQ YSETS
|
||
(NCONC YSETS
|
||
(NCONS (CDR (MAP1 (LIST '(LAMBDA) (LIST '(MLIST) VAR)
|
||
(LIST '(FMEVAL) (CAR FUNL)))
|
||
ARG3))))))
|
||
L (CONS '(MLIST) FUNL)))
|
||
(T (IF (NULL L) (MERROR "Too few arguments to PLOT"))
|
||
(SETQ HIGH (FMEVAL (CAR L)) LOW ARG3 L (CDR L))
|
||
(SETQ L (GRAPHOPTS (COND ((AND L (EQ (CAR L) '$INTEGER))
|
||
(SETQ INTFLG T) (CDR L))
|
||
(T L))))
|
||
(COND (INTFLG (SETQ HIGH (FLOAT (FIX HIGH))
|
||
LOW (COND ((ZEROP (*DIF LOW (FIX LOW))) LOW)
|
||
(T (FLOAT (FIX (+$ LOW 0.999999))))))))
|
||
(SETQ INC (//$ (-$ HIGH LOW) (COND #+MULTICS ($MULTGRAPH (FLOAT $CALCOMPNUM))
|
||
(T (FLOAT (- LINEL 5))))))
|
||
(IF (NOT (PLUSP INC))
|
||
(MERROR "Invalid arguments to PLOT:~%~M"
|
||
(LIST '(MLIST SIMP) LOW HIGH)))
|
||
(SETQ INC (COND (INTFLG (FLOAT (FIX (+$ INC 0.999999))))
|
||
(T (ROUNDUP INC))))
|
||
(DO ((VAL LOW (+$ VAL INC)) (XSET)
|
||
(YSETS (DO ((FUNL FUNL (CDR FUNL)) (LL NIL (CONS (LIST NIL) LL)))
|
||
((NULL FUNL) LL))))
|
||
((> VAL HIGH) (GRAPH XSET (MAPCAR 'CDR YSETS) L (CONS '(MLIST) FUNL)))
|
||
(SETQ XSET (CONS VAL XSET))
|
||
(DO ((FUNL FUNL (CDR FUNL)) (YSETS YSETS (CDR YSETS)))
|
||
((NULL FUNL))
|
||
(RPLACD (CAR YSETS)
|
||
(CONS (FMEVAL (LIST '($EV) (CAR FUNL)
|
||
(LIST '(MEQUAL) VAR
|
||
(COND (INTFLG (FIX VAL)) (T VAL)))))
|
||
(CDAR YSETS))))))))
|
||
(IF (AND (SYMBOLP (CAR L)) (NOT (EQ (CAR L) (CADR L))))
|
||
(MEVAL (CAR L))
|
||
(CAR L))
|
||
(CADR L) (CADDR L) T T NIL 0.0 0.0 NIL 0.0 NIL T T))
|
||
|
||
(DEFUN FMEVAL (X)
|
||
(COND ((FIXP (SETQ X (MEVAL X))) (FLOAT X))
|
||
((FLOATP X) X)
|
||
(($BFLOATP X) ($FLOAT X))
|
||
(T (MERROR "Not floating point:~%~M" X))))
|
||
|
||
(DEFUN FMEVAL1 (X)
|
||
(COND ((FIXP (SETQ X (MEVAL X))) (FLOAT X)) (($BFLOATP X) ($FLOAT X)) (T X)))
|
||
|
||
(DEFMSPEC $GRAPH (L) (SETQ L (CDR L))
|
||
((LAMBDA (ARG1 XSET YSET $NUMER $FLOAT $BFLOAT $FLOAT2BF $%ENUMER)
|
||
(SETQ L (CDR L))
|
||
(COND ((NOT ($LISTP ARG1)) (MERROR "Invalid first argument to GRAPH"))
|
||
(($LISTP (CADR ARG1))
|
||
(DO ARG1 (CDR ARG1) (CDR ARG1) (NULL ARG1)
|
||
(IF (OR (NOT ($LISTP (CAR ARG1))) (CDDDAR ARG1))
|
||
(MERROR "Invalid first argument to GRAPH"))
|
||
(SETQ XSET (CONS (FMEVAL (CADAR ARG1)) XSET)
|
||
YSET (CONS (FMEVAL (CADDAR ARG1)) YSET)))
|
||
(SETQ YSET (LIST YSET)))
|
||
(T (COND ((NOT ($LISTP (SETQ YSET (MEVAL (CAR L)))))
|
||
(MERROR "Invalid second argument to GRAPH"))
|
||
(($LISTP (CADR YSET)) (SETQ YSET (CDR YSET)))
|
||
(T (SETQ YSET (LIST YSET))))
|
||
(SETQ L (CDR L) XSET (MAPCAR 'FMEVAL (CDR ARG1))
|
||
YSET (DO ((YSET YSET (CDR YSET)) (YSETS)) ((NULL YSET) YSETS)
|
||
(COND ((NOT ($LISTP (CAR YSET)))
|
||
(MERROR "Invalid second argument to GRAPH"))
|
||
((NOT (= (LENGTH ARG1) (LENGTH (CAR YSET))))
|
||
(MERROR "Arguments to GRAPH are of unequal length")))
|
||
(SETQ YSETS (NCONC YSETS (NCONS (MAPCAR 'FMEVAL (CDAR YSET)))))))))
|
||
(GRAPH XSET YSET (GRAPHOPTS L) '$DONE))
|
||
(MEVAL (CAR L)) NIL NIL T T NIL T T))
|
||
|
||
(DEFUN GRAPHOPTS (L)
|
||
(IF (> (LENGTH L) 3) (MERROR "Too many arguments to GRAPH or PLOT"))
|
||
(DO ((L L (CDR L)) (CHARL) (XLABEL) (YLABEL))
|
||
((NULL L) (CONS CHARL (SUBST NIL '$FALSE (LIST XLABEL YLABEL))))
|
||
(COND (($LISTP (CAR L))
|
||
(IF CHARL (MERROR "Invalid argument to GRAPH or PLOT:~%~M" (CAR L)))
|
||
(SETQ CHARL (FULLSTRIP (CDAR L))))
|
||
(XLABEL (SETQ YLABEL (CAR L)))
|
||
(T (SETQ XLABEL (COND ((NULL (CAR L)) '$FALSE) (T (CAR L))))))))
|
||
|
||
(DEFUN GRAPH (XSET YSETS OPTL RETVAL)
|
||
((LAMBDA (1SETP CHARL XLABEL YLABEL XHIGH XLOW XINC YHIGH YLOW YINC)
|
||
(PROG (L)
|
||
(COND #+MULTICS
|
||
($MULTGRAPH
|
||
(RETURN (MULTPLOT (CAR CHARL) (STRIPDOLLAR XLABEL) (STRIPDOLLAR YLABEL)
|
||
(SETQ XSET (COND (1SETP XSET) (T (APPLY 'APPEND XSET))))
|
||
(APPLY 'APPEND YSETS) (LENGTH XSET) RETVAL)))
|
||
(T (SETQ L (COND (1SETP XSET) (T (APPLY 'APPEND XSET))))
|
||
(SETQ XLOW (APPLY 'MIN L) XHIGH (APPLY 'MAX L))
|
||
(SETQ XINC (ROUNDUP (//$ (-$ XHIGH XLOW) (FLOAT (- LINEL 5)))))
|
||
(SETQ L (APPLY 'APPEND YSETS) YLOW (APPLY 'MIN L) YHIGH (APPLY 'MAX L))
|
||
(SETQ YINC (ROUNDUP (//$ (-$ YHIGH YLOW) (FLOAT (- $PLOTHEIGHT 6)))))
|
||
(COND ((ZEROP XINC)
|
||
(PRINC (COND (XLABEL (MAKNAM (MAKSTRING XLABEL)))
|
||
(T '|X-coordinate|)))
|
||
(PRINC '| is constant value |) (PRINC XLOW) (RETURN '$DONE))
|
||
((ZEROP YINC)
|
||
(PRINC (COND (YLABEL (MAKNAM (MAKSTRING YLABEL)))
|
||
(T '|Y-coordinate|)))
|
||
(PRINC '| is constant value |) (PRINC YLOW) (RETURN '$DONE)))
|
||
(*ARRAY 'PLOTARY T (1+ $PLOTHEIGHT))
|
||
(COND (1SETP (SETQ XSET (POINTSUBST XSET XLOW XINC 5))))
|
||
(DO ((YSETS YSETS (CDR YSETS)) (CHARL CHARL (AND CHARL (CDR CHARL))))
|
||
((NULL YSETS))
|
||
(DO ((XSET (COND (1SETP XSET)
|
||
(T (PROG2 NIL (POINTSUBST (CAR XSET) XLOW XINC 5)
|
||
(SETQ XSET (CDR XSET)))))
|
||
(CDR XSET))
|
||
(YSET (POINTSUBST (CAR YSETS) YLOW YINC 6) (CDR YSET))
|
||
(CHAR (OR (AND CHARL (CAR CHARL)) '*)))
|
||
((NULL XSET))
|
||
(GRAPHINSERT (CAR XSET) (CAR YSET) CHAR)))
|
||
(COND ($XAXIS
|
||
(COND ((OR (PLUSP YLOW) (MINUSP YHIGH))
|
||
(MTELL "X-axis is off graph") (SLEEP 2))
|
||
(T (DO ((N LINEL (1- N))
|
||
(YCOORD (CAR (POINTSUBST (NCONS 0.0) YLOW YINC 6))))
|
||
((< N 5))
|
||
(GRAPHINSERT N YCOORD '|.|))))))
|
||
(COND ($YAXIS
|
||
(COND ((OR (PLUSP XLOW) (MINUSP XHIGH))
|
||
(MTELL "Y-axis is off graph") (SLEEP 2))
|
||
(T (DO ((N 6 (1+ N))
|
||
(XCOORD (CAR (POINTSUBST (NCONS 0.0) XLOW XINC 5))))
|
||
((> N $PLOTHEIGHT))
|
||
(GRAPHINSERT XCOORD N '|.|))))))
|
||
(STORE (PLOTARY 5) (DO ((N LINEL (1- N)) (L)) ((< N 4) L)
|
||
(SETQ L (CONS N (CONS '- L)))))
|
||
(STORE (PLOTARY 4)
|
||
(DO ((N 5 (+ N 2)) (I 0 (+ I 2)) (L)) ((> N LINEL) (NREVERSE L))
|
||
(SETQ L (CONS I (CONS N L))) (COND ((= I 8) (SETQ I -2)))))
|
||
(SETQ L (CONS NIL (APPEND '(X O R G =) (EXPLODEC XLOW)
|
||
'(/ Y O R G =) (EXPLODEC YLOW)
|
||
'(/ X D E L T A =) (EXPLODEC XINC)
|
||
'(/ Y D E L T A =) (EXPLODEC YINC))))
|
||
(STORE (PLOTARY 3) (GRAPHDO L))
|
||
(SETQ L (CONS NIL (APPEND '(X M A X =) (EXPLODEC XHIGH)
|
||
'(/ Y M A X =) (EXPLODEC YHIGH))))
|
||
(STORE (PLOTARY 2) (GRAPHDO L))
|
||
(DO ((N 6 (1+ N))) ((> N $PLOTHEIGHT))
|
||
(STORE (PLOTARY N) (CONS 4 (CONS (VERTCHAR) (PLOTARY N)))))
|
||
(DO ((N 6 (+ N 2)) (I 0 (+ I 2))) ((> N $PLOTHEIGHT))
|
||
(STORE (PLOTARY N) (CONS 3 (CONS I (PLOTARY N))))
|
||
(COND ((= I 8) (SETQ I -2))))
|
||
(AND YLABEL
|
||
(DO ((I (+ 7 (// $PLOTHEIGHT 2)) (1- I)) (YL (MAKSTRING YLABEL) (CDR YL)))
|
||
((OR (NULL YL) (= I 4)))
|
||
(STORE (PLOTARY I) (CONS 1 (CONS (CAR YL) (PLOTARY I))))))
|
||
(AND XLABEL (SETQ XLABEL (CONS NIL (MAKSTRING XLABEL)))
|
||
(DO ((N (- (// LINEL 2) 4) (1+ N)) (XL XLABEL (CDDR XL)))
|
||
((OR (NULL (CDR XL)) (> N LINEL))
|
||
(STORE (PLOTARY 1) (CDR XLABEL)))
|
||
(RPLACD XL (CONS N (CDR XL)))))
|
||
(CURSORPOS 'C)
|
||
(DO ((N $PLOTHEIGHT (1- N))) ((= N 0))
|
||
(TERPRI)
|
||
(DO ((I 1 (1+ I)) (L (PLOTARY N)))
|
||
((OR (> I LINEL) (NULL L)))
|
||
(COND ((= I (CAR L)) (PRINC (CADR L)) (SETQ L (CDDR L)))
|
||
(T (PRINC '/ )))))
|
||
(COND ((AND (NOT (ZEROP TTY)) (NULL ^W)) (TYI*)))
|
||
(TERPRI) (TERPRI) (*REARRAY 'PLOTARY) (RETURN '$DONE)))))
|
||
(FLOATP (CAR XSET)) (CAR OPTL) (CADR OPTL) (CADDR OPTL) 0.0 0.0 0.0 0.0 0.0 0.0))
|
||
|
||
(DEFUN POINTSUBST (SET LOW INC ORG)
|
||
(DO ((SET SET (CDR SET)) (L)) ((NULL SET) L)
|
||
(SETQ L (CONS (+ ORG (FIX (+$ 0.5 (//$ (-$ (CAR SET) LOW) INC)))) L))))
|
||
|
||
(DEFUN GRAPHINSERT (XCOORD YCOORD CHAR)
|
||
((LAMBDA (L)
|
||
(STORE (PLOTARY YCOORD)
|
||
(DO LL L (CDDR LL) NIL
|
||
(COND ((AND (CDR LL) (= XCOORD (CADR LL))) (RETURN (CDR L)))
|
||
((OR (NULL (CDR LL)) (NOT (> XCOORD (CADR LL))))
|
||
(RPLACD LL (NCONC (LIST XCOORD CHAR) (CDR LL)))
|
||
(RETURN (CDR L)))))))
|
||
(CONS NIL (PLOTARY YCOORD))))
|
||
|
||
(DEFUN ROUNDUP (INC)
|
||
(COND ((= INC 0.0) 0.0)
|
||
((> INC 10.0) (*$ 10.0 (ROUNDUP (//$ INC 10.0))))
|
||
((< INC 1.0) (//$ (ROUNDUP (*$ INC 10.0)) 10.0))
|
||
(T (*QUO (FIX (+$ (*$ INC 10.0) 0.999999)) 10.0))))
|
||
|
||
(DEFUN GRAPHDO (L)
|
||
(DO ((LL L (CDDR LL)) (N 1 (1+ N))) ((NULL (CDR LL)) (CDR L))
|
||
(RPLACD LL (CONS N (CDR LL)))))
|
||
|