github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-01-26 12:12:12 +00:00
Code Issues Releases Wiki Activity

Added files to support building and running Macsyma.

Browse Source 
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
2018-03-08 22:06:53 -08:00
parent e88df80ca3
commit 85994ed770
231 changed files with 108800 additions and 8 deletions
Download Patch File Download Diff File Expand all files Collapse all files

451
src/tensor/canten.8 Normal file
View File

@@ -0,0 +1,451 @@
;;; -*- Mode:LISP; Package:MACSYMA -*-
; ** (c) Copyright 1979 Massachusetts Institute of Technology **
(macsyma-module canten)
(DECLARE (SPECIAL FREI BOUNI $CANTERM BREAKLIST SMLIST $DUMMYX))
(SETQ NODOWN '($CHR2 $CHR1 %CHR2 %CHR1 $KDELTA %KDELTA))
(DEFUN NDOWN (X) (PUTPROP X T 'NODOWN))
(DEFUN NDOWNL (L) (MAPCAR 'NDOWN L))
(NDOWNL NODOWN)
(SETQ BREAKLIST NIL $CANTERM NIL)
(DEFUN BREK (I) (COND ((MEMBER I BREAKLIST) T) ))
;L IS A LIST OF FACTORS WHICH RPOBS SEPARATES INTO A LIST OF TWO LISTS. THE
;FIRST IS A LIST OF THE RPOBECTS IN L. THE SECOND IS A LIST OF NON-RP OBJECTS
(DEFUN RPOBS (L)
(DO ( (X L (CDR X))
(Y NIL (COND ((RPOBJ (CAR X)) (APPEND (LIST (CAR X)) Y) )
(T Y) ) )
(Z NIL (COND ((RPOBJ (CAR X)) Z)
(T (APPEND (LIST (CAR X)) Z)) ) ) )
( (NULL X) (CONS Y (LIST Z))) ))
(DEFUN NAME (RP) (COND ((RPOBJ RP) (CAAR RP) )
(T (MERROR "NOT RPOBJECT"))))
(DEFUN CONTI (RP) (COND ((RPOBJ RP) (CDADDR RP))
(T (MERROR "NOT RPOBJECT"))))
(DEFUN COVI (RP) (COND ((RPOBJ RP) (CDADR RP))
(T (MERROR "NOT RPOBJECT"))))
(DEFUN DERI (RP) (COND ((RPOBJ RP) (CDDDR RP))
(T (MERROR "NOT RPOBJECT"))))
(DEFUN FRE (L) (INT L FREI))
(DEFUN BOUN (L) (INT L BOUNI))
(DEFUN GRADE (RP) (+ (LENGTH (COVI RP))
(LENGTH (CONTI RP)) (LENGTH (DERI RP)) ))
;MON IS A MONOMIAL WHOSE "APPARENT" RANK IS ARANK
(DEFUN ARANK (MON)
(DO ( (I 0 (+ (LENGTH (ALLIND (CAR L))) I))
(L (CDR MON) (CDR L) ) )
((NULL L) I) ))
(DEFUN EQARANK (M1 M2) (= (ARANK M1) (ARANK M2)))
;RP1 AND RP2 ARE RPOBJECTS WITH THE SAME GRADE
(DEFUN ALPHADI (RP1 RP2)
(ALPHALESSP
(TCATENATE (INDLIS RP1))
(TCATENATE (INDLIS RP2))))
(DEFUN TCATENATE (LIS) (IMPLODE (EXPLODEN LIS)))
(DEFUN INDLIS (RP) (PROG (F1 F2 F3 B1 B2 B3)
(SETQ F1 (FRE (COVI RP))
F2 (FRE (CONTI RP))
F3 (FRE (DERI RP))
B1 (BOUN (COVI RP))
B2 (BOUN (CONTI RP))
B3 (BOUN (DERI RP)))
(RETURN
(APPEND (SORT (APPEND F1 F2 F3 NIL) 'ALPHALESSP)
(LIST (CAAR RP))
(SORT (APPEND B1 B2 B3 NIL) 'ALPHALESSP)))))
;HOW TO USE ARRAY NAME AS PROG VARIABLE?
(DEFUN ASORT (L P ) (COND ((LESSP (LENGTH L) 2) L)
(T
(PROG (I J K AZ)
(SETQ I 0 J 0 K (LENGTH L) AZ (ARRAY NIL T K))
(FILLARRAY AZ L)
A (COND ((EQUAL J (+ -1 K))
(RETURN (LISTARRAY AZ)))
((EQUAL I (- K 1)) (SETQ I 0) (GO A))
((APPLY P (LIST (ARRAYCALL T AZ I) (ARRAYCALL T AZ (+ 1 I))))
(SETQ I (+ 1 I) J (+ 1 J)) (GO A))
((APPLY P (LIST (ARRAYCALL T AZ (+ 1 I)) (ARRAYCALL T AZ I)))
(PERMUTE AZ I (+ 1 I))
(SETQ I (+ 1 I) J 0) (GO A) )) ))))
(DEFUN PERMUTE (ARRA I J) (PROG (X) (SETQ X (ARRAYCALL T ARRA I))
(STORE (ARRAYCALL T ARRA I) (ARRAYCALL T ARRA J))
(STORE (ARRAYCALL T ARRA J) X) ))
(DEFUN PRANK (RP1 RP2) (COND
((> (GRADE RP1) (GRADE RP2)) T)
((EQUAL (GRADE RP1) (GRADE RP2)) (ALPHADI RP1 RP2)) ))
(DEFUN SA (X) (SORT (APPEND X NIL) 'ALPHALESSP))
(DEFUN TOP (RP) (CDADDR RP))
(DEFUN BOT (RP) (APPEND (CDADR RP) (CDDDR RP)))
(DEFUN ALLIND (RP) (COND ((NOT (RPOBJ RP)) NIL)
(T (APPEND (CDADR RP) (CDADDR RP) (CDDDR RP)))))
;MON IS A MONOMIAL WHOSE FACTORS ARE ANYBODY
;$IRPMON AND IRPMON RETURN LIST IS FREE AND DUMMY INDICES
(DEFUN $IRPMON (MON) (PROG (L CF DUM FREE CL CI)
(SETQ L (CDR MON)
CF (CAR L)
DUM NIL
FREE NIL
CL (ALLIND CF)
CI NIL )
A (COND ((NULL L) (BREAK 19 (BREK 19))
(RETURN (APPEND (LIST SMLIST)
(LA (LIST SMLIST) FREE)
(LA (LIST SMLIST) DUM) ) ))
((NULL CL) (BREAK 18 (BREK 18))
(SETQ L (CDR L) CF (CAR L) CL (ALLIND CF))
(GO A) )
(T (SETQ CI (CAR CL))
(COND ((NOT (MEMQ CI FREE)) (BREAK 17 (BREK 17))
(SETQ FREE (ENDCONS CI FREE)
CL (CDR CL)) (GO A) )
(T (BREAK 16 (BREK 16))
(SETQ FREE (COMP FREE (LIST CI))
DUM (ENDCONS CI DUM)
CL (CDR CL)) (GO A) ) ) ))))
(DEFUN IRPMON (MON) (PROG (L CF DUM FREE UNIO CL CI)
(SETQ L (CDR MON)
CF (CAR L)
DUM NIL
FREE NIL
UNIO NIL
CL (ALLIND CF)
CI NIL )
A (COND ((NULL L) (BREAK 15 (BREK 15))
(SETQ FREE (COMP UNIO DUM)
DUM (COMP UNIO FREE))
(RETURN (APPEND (LIST FREE) (LIST DUM)) ))
((NULL CL) (BREAK 14 (BREK 14))
(SETQ L (CDR L) CF (CAR L) CL (ALLIND CF))
(GO A) )
(T (SETQ CI (CAR CL))
(COND ((NOT (MEMQ CI UNIO)) (BREAK 13 (BREK 13))
(SETQ UNIO (ENDCONS CI UNIO)
CL (CDR CL)) (GO A) )
(T (BREAK 12 (BREK 12))
(SETQ DUM (ENDCONS CI DUM)
CL (CDR CL)) (GO A) ) ) ))))
;THE ARGUMENT E IS A PRODUCT OF FACTORS SOME OF WHICH ARE NOT RPOBJECTS. THE
;FUNCTION RPOBS SEPARATES THESE AND PUTS THEM INTO NRPFACT. THE RPFACTORS ARE
;SORTED AND PUT IN A
(DEFUN REDCAN (E)
(PROG (A B C D L NRPFACT CCI COI CT CIL OCIL) (BREAK 6 (BREK 6))
(SETQ NRPFACT (CADR (RPOBS (CDR E)))
D (IRPMON E)
FREI (CAR D) BOUNI (CADR D)
A (SORT (APPEND (CAR (RPOBS (CDR E))) NIL) 'PRANK)
L (LENGTH A)
B (ARRAY NIL T L)
C (ARRAY NIL T L 4))
(FILLARRAY B A) (BREAK 7 (BREK 7))
(DO ( (I 0 (+ 1 I)) )
( (EQUAL I L) )
(STORE (ARRAYCALL T C I 0) (NAME (ARRAYCALL T B I)))
(STORE (ARRAYCALL T C I 1) (CONTI (ARRAYCALL T B I)))
(STORE (ARRAYCALL T C I 2) (COVI (ARRAYCALL T B I)))
(STORE (ARRAYCALL T C I 3) (DERI (ARRAYCALL T B I))) )
(SETQ OCIL (DO ((I 0 (+ 1 I))
(M NIL (APPEND (ARRAYCALL T C I 3) M) ) )
((EQUAL I L) M) )
OCIL (APPEND OCIL (ARRAYCALL T C 0 2) (CAR D))
CT 0
CIL (ARRAYCALL T C CT 1)
CCI (CAR CIL) )
(STORE (ARRAYCALL T C CT 1) NIL)
A (COND
((EQUAL CT (+ -1 L))
(BREAK 1 (BREK 1))
(STORE (ARRAYCALL T C CT 1) CIL)
(RETURN
(APPEND NRPFACT
(DO ((I 0 (+ 1 I))
(LIS (APDVAL C 0) (APPEND LIS (APDVAL C (+ 1 I))) ) )
((EQUAL I (+ -1 L)) LIS ) ))) )
((GET (ARRAYCALL T C CT 0) 'NODOWN)
(STORE (ARRAYCALL T C CT 1) CIL)
(SETQ CT (+ 1 CT) CIL (ARRAYCALL T C CT 1)
OCIL (APPEND (ARRAYCALL T C CT 2) OCIL))
(STORE (ARRAYCALL T C CT 1) NIL) (GO A))
((NULL CIL)
(BREAK 2 (BREK 2))
(SETQ CT (+ 1 CT) CIL (ARRAYCALL T C CT 1)
OCIL (APPEND (ARRAYCALL T C CT 2) OCIL) )
(STORE (ARRAYCALL T C CT 1) NIL) (GO A) )
(T (SETQ CCI (CAR CIL)) (BREAK 5 (BREK 5))
(COND ((NOT (MEMQ CCI OCIL))
(BREAK 3 (BREK 3))
(SETQ COI (DO ((I (+ 1 CT) (+ 1 I) ) )
((MEMQ CCI (ARRAYCALL T C I 2)) I)))
(STORE (ARRAYCALL T C CT 2)
(CONS CCI (ARRAYCALL T C CT 2)))
(STORE (ARRAYCALL T C COI 1)
(CONS CCI (ARRAYCALL T C COI 1)))
(STORE (ARRAYCALL T C COI 2)
(COMP (ARRAYCALL T C COI 2) (LIST CCI)))
(SETQ OCIL (CONS CCI OCIL)
CIL (CDR CIL) ) (GO A) )
(T (BREAK 4 (BREK 4))
(STORE (ARRAYCALL T C CT 1) (CONS CCI (ARRAYCALL T C CT 1)) )
(SETQ CIL (CDR CIL) ) (GO A) ) )) ) ) )
(DEFUN LA (X Y) (LIST (APPEND X Y)))
(DEFUN APDVAL (C I) (LIST (APPEND (LIST (CONS (ARRAYCALL T C I 0)
(LIST 'SIMP)))
(LA (LIST SMLIST)
(SA (ARRAYCALL T C I 2)))
(LA (LIST SMLIST)
(SA (ARRAYCALL T C I 1)))
(SA (ARRAYCALL T C I 3) ))))
(DEFUN CANFORM (E)
(COND ((ATOM E) E)
((RPOBJ E) E)
((AND (EQ (CAAR E) 'MTIMES)
(= 0 (LENGTH (CAR (RPOBS (CDR E))))) ) E)
((EQ (CAAR E) 'MTIMES)
(CONS '(MTIMES) (REDCAN E)) )
((EQ (CAAR E) 'MPLUS)
(MYSUBST0
(SIMPLUS (CONS '(MPLUS)
(MAPCAR '(LAMBDA (V) (CONS '(MPLUS) (CANARANK V)))
(STRATA (CDR E) 'EQARANK) ))
1. NIL) E) )
(T E) ))
(DEFUN ENDCONS (X L) (REVERSE (CONS X (REVERSE L))))
(DEFUN COMP (X Y)
(DO ((Z (COND ((ATOM Y) (NCONS Y)) (Y)));patch for case when Y is not a list
(L X (CDR L))
(A NIL (COND ((MEMBER (CAR L) Z) A)
(T (ENDCONS (CAR L) A)) )))
((NULL L) A) ) )
(DEFUN APDUNION (X Y)
(DO ((L Y (CDR L))
(A X (COND ((MEMBER (CAR L) A) A)
(T (ENDCONS (CAR L) A)) )))
((NULL L) A) ))
(DEFUN INT (A B) (PROG (A1 B1 C)
(SETQ A1 A B1 B C NIL)
A (COND ((NULL A1) (RETURN C))
((MEMBER (CAR A1) B1)
(SETQ C (CONS (CAR A1) C))
(SETQ B1 (COMP B1 (CAR A1)))
(SETQ A1 (CDR A1))
(GO B))
(T (SETQ A1 (CDR A1)) (GO B)))
B (COND ((NULL B1) (RETURN C))
((MEMBER (CAR B1) A1)
(SETQ C (CONS (CAR B1) C))
(SETQ A1 (COMP A1 (CAR B1)))
(SETQ B1 (CDR B1))
(GO A))
(T (SETQ B1 (CDR B1)) (GO A)))))
;LIST IS A LIST OF CANFORMED MONOMIALS OF THE SAME ARANK
;CANARANK FINDS THE EQUIVALENT ONES
(DEFUN CANARANK (LIS) (PROG (A B C D CT CNT I)
(SETQ A LIS
B NIL
C (CDR A)
D (ARRAY NIL T (LENGTH A))
CT (CANFORM (CAR A))
CNT (CANFORM (CAR C))
I 1 )
(FILLARRAY D A)
A (COND ((NULL A)
(RETURN B))
((AND (NULL (CDR A)) (NULL C))
(SETQ B (CONS CT B))
(RETURN B) )
((NULL C) (BREAK 9 (BREK 9))
(SETQ B (CONS CT B))
(STORE (ARRAYCALL T D 0) NIL)
(SETQ A (COMP (LISTARRAY D) (LIST NIL))
C (CDR A)
I 1
CT (CANFORM (CAR A))
CNT (CANFORM (CAR C)) )
(COND ((NULL A) (RETURN B))
(T (SETQ D (ARRAY NIL T (LENGTH A)))
(FILLARRAY D A)))
(GO A))
((SAMESTRUC CT CNT) (BREAK 10.(BREK 10.))
(SETQ B (CONS (CANFORM (TRANSFORM CNT CT)) B))
(STORE (ARRAYCALL T D I) NIL)
(SETQ C (CDR C)
CNT (CANFORM (CAR C))
I (+ 1 I) ) (GO A) )
(T (BREAK 11 (BREK 11))
(SETQ C (CDR C)
CNT (CANFORM (CAR C))
I (+ 1 I)) (GO A)) )))
;M1,M2 ARE (CANFORMED) MONOMIALS WHOSE INDEX STRUCTURE MAY BE THE SAME
(DEFUN SAMESTRUC (M1 M2) (EQUAL (INDSTRUC M1) (INDSTRUC M2)))
;MON IS (MTIMES) A LIST OF RP AND NON-RP FACTORS IN A MONOMIAL. THE NEXT
;FUNCTION RETURNS A LIST WHOSE ELEMENTS ARE 4-ELEMENT LISTS GIVING THE NAME
;(MON) AND THE LENGTHS OF THE COVARIANT,CONTRAVARIANT,DERIVATIVE INDICES.
(DEFUN INDSTRUC (MON)
(DO ( (L (CDR MON) (CDR L))
(B NIL (COND ((RPOBJ (CAR L))
(APPEND B (LIST (FINDSTRUC (CAR L))) ))
(T B) )) )
( (NULL L) B) ) )
;FACT IS AN RP FACTOR IN MON. HERE WE FIND ITS INDEX STRUCTURE
(DEFUN FINDSTRUC (FACT)
(APPEND (LIST (CAAR FACT) )
(LIST (LENGTH (CDADR FACT)))
(LIST (LENGTH (CDADDR FACT)))
(LIST (LENGTH (CDDDR FACT))) ))
;M1,M2 ARE MONOMIALS WITH THE SAMESTRUC TURE. THE NEXT FUNCTION TRANSFORMS
;(PERMUTES) THE FORM OF M1 INTO M2.
(DEFUN TRANSFORM (M1 M2)
(SUBLIS (FINDPERM M1 M2) M1))
(DEFUN STRATA (LIS P)
(COND ((OR (NULL LIS) (NULL (CDR LIS))) (LIST LIS))
(T
(PROG (L BL CS) (SETQ L LIS CS NIL BL NIL)
A (COND ((NULL L) (BREAK 1 (BREK 1))
(RETURN (COND ((NULL CS) BL)
(T (ENDCONS CS BL)))))
((AND (NULL (CDR L)) (NULL CS)) (BREAK 2 (BREK 2))
(SETQ BL (ENDCONS (LIST (CAR L)) BL))
(RETURN BL) )
((AND (NULL (CDR L)) (NOT (NULL CS))) (BREAK 3 (BREK 3))
(RETURN (COND ((FUNCALL P (CAR L) (CAR CS))
(SETQ CS (CONS (CAR L) CS)
BL (ENDCONS CS BL)))
(T (SETQ BL (ENDCONS (LIST (CAR L)) (ENDCONS CS BL)))))))
((NULL CS) (BREAK 4 (BREK 4))
(SETQ CS (LIST (CAR L)) L (CDR L)) (GO A))
((FUNCALL P (CAR L) (CAR CS)) (BREAK 5 (BREK 5))
(SETQ CS (CONS (CAR L) CS)
L (CDR L)) (GO A) )
(T (BREAK 6 (BREK 6))
(SETQ BL (ENDCONS CS BL)
CS (LIST (CAR L))
L (CDR L) ) (GO A) ) ) ))))
(DEFUN TINDSTRUC (MON)
(DO ( (L (CDR MON) (CDR L))
(B NIL (COND ((RPOBJ (CAR L))
(APPEND B (TFINDSTRUC (CAR L)) ))
(T B) )))
((NULL L) B)))
(DEFUN TFINDSTRUC (FACT)
(APPEND (CDADR FACT) (CDADDR FACT) (CDDDR FACT) ))
(DEFUN DUMM (X) (EQUAL (CADR (EXPLODEC X)) $DUMMYX))
(DEFUN FINDPERMUT (I1 I2)
(COMP (MAPCAR 'PIJ I1 I2) (LIST NIL)))
(DEFUN PIJ (X Y)
(COND ((AND (DUMM X) (DUMM Y) (NOT (EQ X Y))) (CONS X Y))))
;(SAMESTRUC M1 M2) IS T FOR THE ARGUMENTS BELOW
;THE RESULTING PERMUTATION IS GIVEN TO TRANSFORM
(DEFUN FINDPERM (M1 M2)
(DO ((D1 (CADR (IRPMON M1)) )
(D2 (CADR (IRPMON M2)) )
(I1 (TINDSTRUC M1) (CDR I1) )
(I2 (TINDSTRUC M2) (CDR I2) )
(L NIL (COND ((AND (MEMQ (CAR I1) D1) (MEMQ (CAR I2) D2)
(NOT (EQ (CAR I1) (CAR I2)))
(NOT (MEMQ (CAR I1) (CAR L)))
(NOT (MEMQ (CAR I2) (CADR L))) )
(CONS (ENDCONS (CAR I1) (CAR L))
(LIST (ENDCONS (CAR I2) (CADR L))) ) )
(T L))))
((NULL I1) (MAPCAR 'CONS
(APPEND (CAR L) (COMP D1 (CAR L)))
(APPEND (CADR L) (COMP D2 (CADR L)))))))
(DEFUN $CANTEN (X) (DO ((I ($NTERMS X) ($NTERMS L))
(L (CANFORM X) (CANFORM L)) )
((= I ($NTERMS L)) L)
(COND ((EQ $CANTERM T) (PRINT I))) ))
(DEFUN $CONCAN (X) (DO ((I ($NTERMS X) ($NTERMS L))
(L (CANFORM X) ($CONTRACT (CANFORM L))))
((= I ($NTERMS L)) L)
(COND ((EQ $CANTERM T) (PRINT I))) ))

344
src/tensor/gener.51 Normal file
View File

@@ -0,0 +1,344 @@
;;; -*- Mode:LISP; Package:MACSYMA -*-
; ** (c) Copyright 1979 Massachusetts Institute of Technology **
(macsyma-module gener)
(declare (special $metric $metricconvert indlist empty))
;$METRICCONVERT if non-NIL will allow $GENERATE to rename the metric tensor
; ($METRIC must be bound) with 2 covariant indices to LG and with 2
; contravariant indices to UG.
(defun $GENERATE (e)
(prog (free lhs rhs)
(cond ((or (atom e) (not (eq (caar e) 'MEQUAL)))
(merror "GENERATE requires an equation as an argument"))
((equal (setq free ($indices e)) empty)
(return (cons '(MSETQ) (cdr e))))
((or (eq (typep (cadr e)) 'SYMBOL) ;If a symbol or
(and (rpobj (cadr e)) ;an indexed object with no dummy
(null (cdaddr ($indices2 (cadr e)))))) ;indices
(setq lhs (cadr e) rhs (caddr e)))
((or (eq (typep (caddr e)) 'SYMBOL)
(and (rpobj (caddr e))
(null (cdaddr ($indices2 (caddr e))))))
(setq lhs (caddr e) rhs (cadr e)))
(t (merror "At least one side of the equation must be a~
~%symbol or a single indexed object")))
(cond ((and (not (eq (typep lhs) 'SYMBOL))
(not (null (cdddr lhs))))
(merror "Cannot assign to indexed objects with derivative ~
indices:~%~M"
(show lhs))))
(setq free (nreverse (mysort (cdadr free))) ;Set FREE to just the
indlist nil) ;free indices
(and $METRICCONVERT (boundp '$METRIC)
(setq lhs (changename $METRIC t 0 2 '$UG
(changename $METRIC t 2 0 '$LG lhs))
rhs (changename $METRIC t 0 2 '$UG
(changename $METRIC t 2 0 '$LG rhs))))
(tabulate rhs)
(setq indlist (unique indlist))
(do ((q (mapcar 'car indlist) (cdr q)))
((null q))
(cond ((memq (car q) (cdr q))
(merror "~
GENERATE cannot currently handle indexed objects of the same name~
~%with different numbers of covariant and//or contravariant indices:~%~M"
(car q)))))
(cond ((not (eq (typep lhs) 'SYMBOL))
(do ((test) (flag) (name))
(flag)
(setq test (list (caar lhs) (length (cdadr lhs))
(length (cdaddr lhs))))
(cond ((or (member test indlist)
(not (memq (car test)
(mapcar 'car indlist))))
(setq flag t))
(t
(mtell "Assignment is to be made to ~M~
~%This name with a different number of covariant and//or contravariant~
~%indices appears on the other side of the equation. To avoid array name~
~%conflicts, choose a new name for this object:~%"
(show lhs))
(cond ((not (eq (typep
(setq name
(retrieve nil nil)))
'SYMBOL))
(merror "Name not an atom")))
(setq lhs (cons (ncons name) (cdr lhs))))))))
(return (do ((free free (cdr free))
(equ (cons '(MSETQ) (list (changeform lhs)
(t-convert
(summer1 rhs))))))
((null free) equ)
(setq equ (append '((MDO)) (ncons (car free))
'(1 1 NIL $DIM NIL)
(ncons equ)))))))
(defun TABULATE (e) ;For each indexed object in E, appends a list of the
(cond ((atom e)) ;name of that object and the number of covariant and
((rpobj e) ;contravariant indices to the global list INDLIST
(setq indlist (cons (list (caar e) (length (cdadr e))
(length (cdaddr e)))
indlist)))
((or (eq (caar e) 'MPLUS) (eq (caar e) 'MTIMES))
(mapcar 'tabulate (cdr e)))))
(defun UNIQUE (l) ;Returns a list of the unique elements of L
(do ((a l (cdr a)) (b))
((null a) b)
(cond ((not (member (car a) b))
(setq b (cons (car a) b))))))
(defun SUMMER1 (e) ;Applies SUMMER to the products and indexed objects in E
(cond ((atom e) e)
((eq (caar e) 'MPLUS)
(cons (car e) (mapcar 'summer1 (cdr e))))
((or (eq (caar e) 'MTIMES) (rpobj e))
(summer e (cdaddr ($indices e))))
(t e)))
(defun SUMMER (p dummy) ;Makes implicit sums explicit in the product or indexed
;object P where DUMMY is the list of dummy indices of P
(prog (dummy2 scalars indexed s) ;at this level
(setq dummy2 (intersect (all ($indices2 p)) dummy))
(do ((p (cond ((eq (caar p) 'MTIMES) (cdr p))
(t (ncons p))) (cdr p))
(obj))
((null p))
(setq obj (car p))
(cond ((atom obj)
(setq scalars (cons obj scalars)))
((rpobj obj)
(cond ((null (intersect dummy2 (all ($indices2 obj))))
(setq scalars (cons obj scalars)))
(t (setq indexed (cons obj indexed)))))
((eq (caar obj) 'MPLUS)
(setq s t)
(cond ((null (intersect dummy (all ($indices obj))))
(setq scalars
(cons (summer1 obj) scalars)))
(t (setq indexed
(cons (summer1 obj) indexed)))))
(t (setq scalars (cons obj scalars)))))
(cond ((and s
(not (samelists dummy2
(setq s
(cdaddr
($indices
(append '((MTIMES))
scalars indexed)))))))
(setq dummy2 s
s scalars
scalars nil)
(do ((p s (cdr p)) (obj))
((null p))
(setq obj (car p))
(cond ((null (intersect dummy2 (all ($indices obj))))
(setq scalars (cons obj scalars)))
(t (setq indexed (cons obj indexed)))))))
(return
(simptimes
(nconc (ncons '(MTIMES))
scalars
(cond ((not (null indexed))
(do ((indxd (simptimes (cons '(MTIMES) indexed)
1 nil))
(dummy (mysort dummy2) (cdr dummy)))
((null dummy) (ncons indxd))
(setq indxd (nconc (ncons '($SUM))
(ncons indxd)
(ncons (car dummy))
'(1 $DIM)))))
(t nil)))
1 nil))))
(defun ALL (l) ;Converts [[A, B], [C, D]] into (A B C D)
(append (cdadr l) (cdaddr l)))
(defun T-CONVERT (e) ;Applies CHANGEFORM to each individual object in an
(cond ((atom e) e) ;expression
((or (eq (caar e) 'MPLUS) (eq (caar e) 'MTIMES))
(cons (car e) (mapcar 't-convert (cdr e))))
((eq (caar e) '$SUM)
(append (ncons (car e)) (ncons (t-convert (cadr e))) (cddr e)))
(t (changeform e))))
(defun CHANGEFORM (e) ;Converts a single object from ITENSR format to
(cond ((atom e) e) ;ETENSR format
((rpobj e)
(do ((deriv (cdddr e) (cdr deriv))
(new (cond ((and (null (cdadr e)) (null (cdaddr e)))
(caar e)) ;If no covariant and contravariant
;indices then make into an atom
(t (cons (cons (equiv-table (caar e)) '(ARRAY))
(append (cdadr e) (cdaddr e)))))))
((null deriv) new)
(setq new (append '(($DIFF)) (ncons new)
(ncons (cons '($OMEGA ARRAY)
(ncons (car deriv))))))))
(t e)))
(defun EQUIV-TABLE (a) ;Makes appropiate name changes converting
(cond ((memq a '($CHR1 %CHR1)) '$LCS) ;from ITENSR to ETENSR
((memq a '($CHR2 %CHR2)) '$MCS)
(t a)))
(declare (unspecial indlist))
(declare (special SMLIST $FUNCS))
(setq $funcs '((MLIST)))
(DEFUN $MAKEBOX (E NAME)
(COND ((ATOM E) E)
((MTIMESP E) (MAKEBOX E NAME))
((MPLUSP E)
(MYSUBST0 (SIMPLIFYA (CONS '(MPLUS)
(MAPCAR
(FUNCTION
(LAMBDA (Q) ($MAKEBOX Q NAME)))
(CDR E)))
NIL)
E))
((MEXPTP E) (LIST (CAR E) ($MAKEBOX (CADR E) NAME) (CADDR E)))
(T E)))
(DEFUN MAKEBOX (E NAME)
(PROG (L1 L2 X L3 L)
(SETQ L (CDR E))
AGAIN(SETQ X (CAR L))
(COND ((RPOBJ X)
(COND ((AND (EQ (CAAR X) NAME) (NULL (CDDDR X))
(NULL (CDADR X)) (= (LENGTH (CDADDR X)) 2))
(SETQ L1 (CONS X L1)))
((CDDDR X) (SETQ L2 (CONS X L2)))
(T (SETQ L3 (CONS X L3)))))
(T (SETQ L3 (CONS X L3))))
(AND (SETQ L (CDR L)) (GO AGAIN))
(COND ((OR (NULL L1) (NULL L2)) (RETURN E)))
(DO L2 L2 (CDR L2)
(NULL L2)
(SETQ L L1)
LOOP
(SETQ X (CAR L))
(COND
((AND (MEMQ (CAR (CDADDR X)) (CDDDAR L2))
(MEMQ (CADR (CDADDR X))(CDDDAR L2)))
(SETQ
L3
(CONS (NCONC
(LIST
(NCONS
(IMPLODE (APPEND '([ ])
(CDR (EXPLODEC (CAAAR L2))))))
(CADAR L2)
(CADDAR L2)) (SETDIFF (CDDDAR L2)(CDADDR X)))
L3))
(SETQ L1 (DELETE X L1 1.)))
((SETQ L (CDR L)) (GO LOOP))
(T (SETQ L3 (CONS (CAR L2) L3)))))
(RETURN (SIMPTIMES (CONS '(MTIMES) (NCONC L1 L3))
1.
NIL))))
(DECLARE (SPECIAL TENSR))
(DEFUN $AVERAGE N ((LAMBDA (TENSR) (SIMPLIFYA (AVERAGE (ARG 1)) NIL))
(AND (= N 2) (ARG 2))))
(DEFUN AVERAGE (E)
(COND ((ATOM E ) E)
((RPOBJ E) (COND ((OR (NOT TENSR) (EQ (CAAR E) TENSR))
(AVERAGE1 E))
(T E)))
(T (CONS (NCONS (CAAR E)) (MAPCAR (FUNCTION AVERAGE) (CDR E))))))
(DEFUN AVERAGE1 (E)
(COND ((= (LENGTH (CDADR E)) 2)
(SETQ E (LIST '(MTIMES) '((RAT SIMP) 1 2)
(LIST '(MPLUS)
(CONS (CAR E)
(CONS (AREV (CADR E)) (CDDR E))) E))))
((= (LENGTH (CDADDR E)) 2)
(SETQ E (LIST '(MTIMES) '((RAT SMP) 1 2)
(LIST '(MPLUS)
(CONS (CAR E)
(CONS (CADR E)
(CONS (AREV (CADDR E))
(CDDDR E)))) E)))))
E)
(DEFUN AREV (L) (LIST (CAR L) (CADDR L) (CADR L)))
(DECLARE (UNSPECIAL TENSR))
(add2lnc '(($AVERAGE) $TENSOR) $funcs)
(defun $CONMETDERIV (e g)
(cond ((not (eq (typep g) 'SYMBOL))
(merror "Invalid metric name: ~M" g))
(t (conmetderiv e g ((lambda (l) (append (cdadr l) (cdaddr l)))
($indices e))))))
(defun CONMETDERIV (e g indexl)
(cond ((atom e) e)
((rpobj e)
(cond ((and (eq (caar e) g) (null (cdadr e))
(equal (length (cdaddr e)) 2)
(not (null (cdddr e))))
(do ((e (cmdexpand (car e) (car (cdaddr e))
(cadr (cdaddr e)) (cadddr e) indexl))
(deriv (cddddr e) (cdr deriv)))
((null deriv) e)
(setq e (conmetderiv ($diff e (car deriv))
g indexl))))
(t e)))
(t (mysubst0 (cons (car e)
(mapcar
(function (lambda (q)
(conmetderiv q g indexl)))
(cdr e))) e))))
(defun CMDEXPAND (g i j k indexl)
(do ((dummy) (flag))
(flag (list '(MPLUS SIMP)
(list '(MTIMES SIMP) -1
(list g (ncons SMLIST) (list SMLIST dummy i))
(list '($CHR2 SIMP) (list SMLIST dummy k)
(list SMLIST j)))
(list '(MTIMES SIMP) -1
(list g (ncons SMLIST) (list SMLIST dummy j))
(list '($CHR2 SIMP) (list SMLIST dummy k)
(list SMLIST i)))))
(setq dummy ($dummy))
(and (not (memq dummy indexl)) (setq flag t))))
(add2lnc '(($CONMETDERIV) $EXP $NAME) $funcs)
(defun $FLUSH1DERIV (e g)
(cond ((not (eq (typep g) 'SYMBOL))
(merror "Invalid metric name: ~M" g))
(t (flush1deriv e g))))
(defun FLUSH1DERIV (e g)
(cond ((atom e) e)
((rpobj e)
(cond ((and (eq (caar e) g) (equal (length (cdddr e)) 1)
(or (and (equal (length (cdadr e)) 2)
(null (cdaddr e)))
(and (equal (length (cdaddr e)) 2)
(null (cdadr e)))))
0)
(t e)))
(t (subst0 (cons (ncons (caar e))
(mapcar
(function (lambda (q) (flush1deriv q g)))
(cdr e))) e))))
(add2lnc '(($FLUSH1DERIV) $EXP $NAME) $funcs)
(defun $GEODESIC (exp g)
($flush1deriv ($flush exp '$CHR2 '%CHR2) g))
(add2lnc '(($GEODESIC) $EXP $NAME) $funcs)

1164
src/tensor/itensr.119 Normal file
View File

File diff suppressed because it is too large Load Diff

275
src/tensor/symtry.102 Normal file
View 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))