mirror of
https://github.com/PDP-10/its.git
synced 2026-05-04 07:09:12 +00:00
Added files to support building and running Macsyma.
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.
This commit is contained in:
Eric Swenson
275
src/tensor/symtry.102
Normal file
275
src/tensor/symtry.102
Normal file
@@ -0,0 +1,275 @@
|
||||
;;; -*- 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))
|
||||
Reference in New Issue
Block a user