mirror of
https://github.com/PDP-10/its.git
synced 2026-01-13 15:27:28 +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.
276 lines
10 KiB
Common Lisp
276 lines
10 KiB
Common Lisp
;;; -*- Mode:LISP; Package:MACSYMA -*-
|
||
|
||
; ** (c) Copyright 1979 Massachusetts Institute of Technology **
|
||
|
||
(macsyma-module symtry)
|
||
|
||
(declare (special symtypes $symmetries $allsym csign smlist $dummyx))
|
||
|
||
(setq symtypes '($SYM $ANTI $CYC) $symmetries '((MLIST SIMP)))
|
||
|
||
;$SYMMETRIES is a list of indexed objects with declared symmetries
|
||
;$ALLSYM if non-nil means that all indexed objects are assumed symmetric
|
||
|
||
(defun $DECSYM (name ncov ncontr covl contrl) ;DEClare SYMmetries
|
||
(prog (tensor)
|
||
(cond ((not (eq (typep name) 'SYMBOL))
|
||
(merror "First argument must be a possible tensor name"))
|
||
((not (and (eq (typep ncov) 'FIXNUM)
|
||
(eq (typep ncontr) 'FIXNUM)
|
||
(signp ge ncov)
|
||
(signp ge ncontr)))
|
||
(merror
|
||
"2nd and 3rd arguments must be non-negative integers"))
|
||
((not (and (eq (caar covl) 'MLIST)
|
||
(eq (caar contrl) 'MLIST)))
|
||
(merror "4th and 5th arguments must be lists"))
|
||
((and (< ncov 2) (< ncontr 2))
|
||
(merror "This object can have no symmetry properties"))
|
||
((or (and (< ncov 2) (not (null (cdr covl))))
|
||
(and (< ncontr 2) (not (null (cdr contrl)))))
|
||
(merror
|
||
"Non-null list associated with zero or single index specification")))
|
||
(setq tensor (implode (nconc (exploden name) (ncons 45)
|
||
(exploden ncov) (ncons 45)
|
||
(exploden ncontr))))
|
||
(do ((covl (cdr covl) (cdr covl)) (carl) (arglist) (prop))
|
||
((null covl))
|
||
(cond ((not (member (setq prop (caar (setq carl (car covl))))
|
||
symtypes))
|
||
(merror "Invalid symmetry operator: ~M" carl))
|
||
((and (null (cddr carl)) (eq (cadr carl) '$ALL))
|
||
(setq arglist (interval 1 ncov)))
|
||
(t (setq arglist (check-symargs (cdr carl) (1+ ncov)))))
|
||
(setq carl (get tensor prop))
|
||
(putprop tensor (cons (cons arglist (car carl)) (cdr carl))
|
||
prop))
|
||
(do ((contl (cdr contrl) (cdr contl)) (carl) (arglist) (prop))
|
||
((null contl))
|
||
(cond ((not (member (setq prop (caar (setq carl (car contl))))
|
||
symtypes))
|
||
(merror "Invalid symmetry operator: ~M" carl))
|
||
((and (null (cddr carl)) (eq (cadr carl) '$ALL))
|
||
(setq arglist (interval 1 ncontr)))
|
||
((setq arglist (check-symargs (cdr carl) (1+ ncontr)))))
|
||
(setq carl (get tensor prop))
|
||
(putprop tensor (cons (car carl) (cons arglist (cdr carl)))
|
||
prop))
|
||
(add2lnc tensor $symmetries)
|
||
(return '$DONE)))
|
||
|
||
(defun INTERVAL (i j) ;INTERVAL returns the list of integers from I thru J.
|
||
(do ((n i (1+ n)) (ans)) ;Thus (INTERVAL 3 5) yields (3 4 5)
|
||
((> n j) (nreverse ans))
|
||
(setq ans (cons n ans))))
|
||
|
||
(defun CHECK-SYMARGS (ll n) ;Returns an ascending list of the unique
|
||
;elements of LL and checks that they are
|
||
(do ((l ll (cdr l)) (c) (ans)) ;integers between 0 and N
|
||
((null l) (cond ((null (cdr ans))
|
||
(merror "Only one distinct index in symmetry property declaration"))
|
||
(t (sort ans '<))))
|
||
(setq c (car l))
|
||
(cond ((not (and (eq (typep c) 'FIXNUM) (> c 0) (< c n)))
|
||
(merror "Bad argument encountered for symmetry operator"))
|
||
((not (member c ans)) (setq ans (cons c ans))))))
|
||
|
||
(defun $DISPSYM (name ncov ncontr) ;DISPlay SYMmetries
|
||
(prog (tensor)
|
||
(setq tensor (implode (nconc (exploden name) (ncons 45)
|
||
(exploden ncov) (ncons 45)
|
||
(exploden ncontr))))
|
||
(cond ((not (member tensor (cdr $symmetries)))
|
||
(return (ncons smlist))))
|
||
(return
|
||
(do ((q symtypes (cdr q)) (l) (prop))
|
||
((null q) (consmlist l))
|
||
(cond ((not (null (setq prop (get tensor (car q)))))
|
||
(setq l
|
||
(append l
|
||
(ncons
|
||
(consmlist
|
||
(list
|
||
(car q)
|
||
(consmlist (mapcar 'consmlist (car prop)))
|
||
(consmlist (mapcar 'consmlist (cdr prop))))
|
||
))))))))))
|
||
|
||
(defun $REMSYM (name ncov ncontr)
|
||
;;REMove SYMmetries
|
||
(prog (tensor)
|
||
(setq tensor (implode (nconc (exploden name) (ncons 45)
|
||
(exploden ncov) (ncons 45)
|
||
(exploden ncontr))))
|
||
(cond ((not (member tensor (cdr $symmetries)))
|
||
(mtell "~&No symmetries have been declared for this tensor.~%"))
|
||
(t (delete tensor $symmetries)
|
||
(remprop tensor '$SYM) (remprop tensor '$ANTI)
|
||
(remprop tensor '$CYC)))
|
||
(return '$DONE)))
|
||
|
||
(defun $CANFORM (e) ;Convert E into CANonical FORM
|
||
(cond ((atom e) e)
|
||
((eq (caar e) 'MEQUAL)
|
||
(mysubst0 (list (car e) ($canform (cadr e)) ($canform (caddr e)))
|
||
e))
|
||
((eq (caar e) 'MPLUS)
|
||
(mysubst0 (simplus (cons '(MPLUS) (mapcar '$canform (cdr e)))
|
||
1 nil) e))
|
||
((eq (caar e) 'MTIMES) (mysubst0 (simplifya (canprod e) nil) e))
|
||
((rpobj e) (canten e t))
|
||
(t (mysubst0 (simplifya (cons (ncons (caar e))
|
||
(mapcar '$canform (cdr e))) t) e))))
|
||
|
||
(defun CANTEN (e nfprpobjs) ;CANonical TENsor
|
||
(prog (cov contr deriv tensor)
|
||
((lambda (dummy) (and nfprpobjs dummy (setq e (rename1 e dummy))))
|
||
(cdaddr ($indices2 e))) ;NFPRPOBJS is Not From Product
|
||
(setq cov (copy (cdadr e)) ;of RP (indexed) OBJects
|
||
contr (copy (cdaddr e))
|
||
deriv (copy (cdddr e))
|
||
tensor (implode (nconc (exploden (caar e)) (ncons 45)
|
||
(exploden (length cov)) (ncons 45)
|
||
(exploden (length contr))))
|
||
csign nil) ;Set when reordering antisymmetric indices.
|
||
;Indicates whether overall sign of
|
||
;expression needs changing.
|
||
(cond ($allsym (setq cov (mysort cov) contr (mysort contr)))
|
||
((member tensor (cdr $symmetries))
|
||
(do ((q symtypes (cdr q)) (type))
|
||
((null q))
|
||
(setq type (car q))
|
||
(do ((props (car (get tensor type)) (cdr props)) (p))
|
||
((null props))
|
||
(setq p (car props)
|
||
cov (inserts (symsort (extract p cov) type)
|
||
cov p)))
|
||
(do ((props (cdr (get tensor type)) (cdr props)) (p))
|
||
((null props))
|
||
(setq p (car props)
|
||
contr (inserts (symsort (extract p contr)
|
||
type)
|
||
contr p))))))
|
||
(setq tensor (mysubst0 (append (list (car e)
|
||
(consmlist cov)
|
||
(consmlist contr))
|
||
(mysort deriv)) e))
|
||
(cond (csign (setq tensor (neg tensor))))
|
||
(return tensor)))
|
||
|
||
(defun RENAME1 (e dummy) ;Renames dummy indices in a consistent manner
|
||
(sublis (cleanup0 dummy) e))
|
||
|
||
(defun CLEANUP0 (a)
|
||
(do ((b a (cdr b)) (n 1 (1+ n)) (l) (dumx))
|
||
((null b) l)
|
||
(setq dumx (concat $dummyx n))
|
||
(cond ((not (eq dumx (car b)))
|
||
(setq l (cons (cons (car b) dumx) l))))))
|
||
|
||
(defun EXTRACT (a b) ;Extracts the elements from B specified by the indices in
|
||
;i.e. (EXTRACT '(2 5) '(A B C D E F)) yields (B E)
|
||
(do ((a a) (b b (cdr b)) (n 1 (1+ n)) (l))
|
||
((null a) (nreverse l))
|
||
(cond ((equal (car a) n)
|
||
(setq l (cons (car b) l) a (cdr a))))))
|
||
|
||
(defun INSERTS (a b c) ;Substitutes A into B with respect to the index
|
||
(do ((a a) (b b (cdr b)) (c c) (n 1 (1+ n)) (l)) ;specification C
|
||
((null a) (nreconc l b))
|
||
(cond ((equal (car c) n)
|
||
(setq l (cons (car a) l) a (cdr a) c (cdr c)))
|
||
(t (setq l (cons (car b) l))))))
|
||
|
||
(defun SYMSORT (l type)
|
||
(cond ((eq type '$SYM) (sort l 'less)) ;SORT SYMmetric indices
|
||
((eq type '$ANTI) (antisort l))
|
||
(t (cycsort l))))
|
||
|
||
(defun ANTISORT (l) ;SORT ANTIsymmetric indices and set CSIGN as needed
|
||
((lambda (q) (cond ((equal ($lc (consmlist (mapcar 'cdr q))) -1)
|
||
(setq csign (not csign))))
|
||
(mapcar 'car q))
|
||
(sortcar (tindex l) 'less)))
|
||
|
||
(defun TINDEX (l) ;(INDEX '(A B C)) yields ((A . 1) (B . 2) (C . 3))
|
||
(do ((l l (cdr l)) (n 1 (1+ n)) (q))
|
||
((null l) (nreverse q))
|
||
(setq q (cons (cons (car l) n) q))))
|
||
|
||
(defun CYCSORT (l) ;SORT CYClic indices
|
||
((lambda (n) (cond ((equal n 0) l)
|
||
(t (append (nthcdr n l)
|
||
(reverse (nthcdr (- (length l) n)
|
||
(reverse l)))))))
|
||
(1- (cdr (least l)))))
|
||
|
||
(defun LEAST (l) ;Returns a dotted pair containing the alphanumerically least
|
||
;element in L in the car and its index in L in the cdr
|
||
(do ((l (cdr l) (cdr l)) (a (cons (car l) 1)) (n 2 (1+ n)))
|
||
((null l) a)
|
||
(cond ((less (car l) (car a)) (setq a (cons (car l) n))))))
|
||
|
||
(declare (special free-indices))
|
||
|
||
(defun CANPROD (e)
|
||
(prog (scalars indexed)
|
||
(cond ((catch (do ((f (cdr e) (cdr f)) (obj))
|
||
((null f)
|
||
(setq scalars (nreverse scalars)
|
||
indexed (nreverse indexed))
|
||
nil)
|
||
(setq obj (car f))
|
||
(cond ((atom obj)
|
||
(setq scalars (cons obj scalars)))
|
||
((rpobj obj)
|
||
(setq indexed (cons obj indexed)))
|
||
((eq (caar obj) 'MPLUS) (throw t))
|
||
(t (setq scalars (cons obj scalars))))))
|
||
(return ($canform ($expand e))))
|
||
((null indexed) (return e))
|
||
((null (cdr indexed))
|
||
(return (nconc (ncons '(MTIMES))
|
||
scalars
|
||
(ncons (canten (car indexed) t)))))
|
||
(t (return
|
||
(nconc (ncons '(MTIMES))
|
||
scalars
|
||
(mapcar (function (lambda (z) (canten z nil)))
|
||
((lambda (q)
|
||
(rename1 q
|
||
(cdaddr
|
||
($indices2
|
||
(cons '(MTIMES) q)))))
|
||
(mapcar 'cdr
|
||
(sortcar
|
||
(progn
|
||
(setq free-indices
|
||
(cdadr ($indices2 e)))
|
||
(mapcar 'describe-tensor
|
||
indexed))
|
||
'tensorpred))))))))))
|
||
|
||
(defun TENSORPRED (x y)
|
||
(do ((x x (cdr x)) (y y (cdr y)) (a) (b))
|
||
((null x))
|
||
(setq a (car x) b (car y))
|
||
(and (not (equal a b)) (return
|
||
(cond ((eq (typep a) 'FIXNUM) (> a b))
|
||
(t (alphalessp a b)))))))
|
||
|
||
(defun DESCRIBE-TENSOR (f)
|
||
(cons (tdescript f) f))
|
||
|
||
(defun TDESCRIPT (f)
|
||
(prog (name indices lcov lcontr lderiv)
|
||
(setq name (caar f)
|
||
indices (append (cdadr f) (cdaddr f) (cdddr f))
|
||
lcov (length (cdadr f))
|
||
lcontr (length (cdaddr f))
|
||
lderiv (length (cdddr f)))
|
||
(return (list (car (least (intersect indices free-indices)))
|
||
(+ lcov lcontr lderiv)
|
||
lderiv lcov name))))
|
||
|
||
(declare (unspecial free-indices))
|