From f7f8eb8c629bbd9978f02e2a95d3e719814d6225 Mon Sep 17 00:00:00 2001 From: Eric Swenson Date: Tue, 5 Jun 2018 21:36:03 -0700 Subject: [PATCH] Added support for macsyma translate_file. Also added ctensr fasl. Now tsetup() should work. --- Makefile | 4 +- bin/macsym/transs.fasl | Bin 0 -> 12865 bytes bin/macsym/trhook.fasl | Bin 0 -> 1584 bytes bin/maxer1/transs.80 | Bin 0 -> 3126 bytes build/lisp.tcl | 18 ++ src/munfas/transs.unfasl | 51 ++++ src/munfas/trhook.unfasl | 23 ++ src/sharem/packg.7 | 50 +++ src/tensor/ctensr.funcs | 643 +++++++++++++++++++++++++++++++++++++++ 9 files changed, 787 insertions(+), 2 deletions(-) create mode 100644 bin/macsym/transs.fasl create mode 100644 bin/macsym/trhook.fasl create mode 100755 bin/maxer1/transs.80 create mode 100755 src/munfas/transs.unfasl create mode 100755 src/munfas/trhook.unfasl create mode 100755 src/sharem/packg.7 create mode 100644 src/tensor/ctensr.funcs diff --git a/Makefile b/Makefile index 298d7f73..8652b6f4 100644 --- a/Makefile +++ b/Makefile @@ -10,12 +10,12 @@ SRC = system syseng sysen1 sysen2 sysen3 sysnet kshack dragon channa \ spcwar rwg libmax rat z emaxim rz maxtul aljabr cffk das ell ellen \ jim jm jpg macrak maxdoc maxsrc mrg munfas paulw reh rlb rlb% share \ tensor transl wgd zz graphs lmlib pratt quux scheme gsb ejs mudsys \ - draw wl taa tj6 budd + draw wl taa tj6 budd sharem DOC = info _info_ sysdoc sysnet syshst kshack _teco_ emacs emacs1 c kcc \ chprog sail draw wl pc tj6 share _glpr_ _xgpr_ inquir mudman system \ xfont BIN = sys2 emacs _teco_ lisp liblsp alan inquir sail comlap c decsys moon \ - graphs draw datdrw fonts fonts1 fonts2 games + graphs draw datdrw fonts fonts1 fonts2 games macsym maxer1 SUBMODULES = dasm itstar klh10 mldev simh sims supdup tapeutils diff --git a/bin/macsym/transs.fasl b/bin/macsym/transs.fasl new file mode 100644 index 0000000000000000000000000000000000000000..bca1aa026dba2f3493bdcbc444675c995e2e3cd7 GIT binary patch literal 12865 zcmcgzeQaFEao>H9Je^8XI*L+slI`Y6q-^TMCmuz~QYhKFJKiI8(tYVZOnq49$+ApK zwq!T5Y`Jb-8bKi#MdGAMQy6X01chrPfzbv+kp@PP6h%-JLC^%P(Lef6{%YX@kxtf; zZtNP@`Th3pJ(4E%@lPM1$JyQ4nc3Ny*_nN(5C8h={;o#pkUCn8or+bJJUZ=76ibC7 zV0m<4d0HH~*(t?gw z3l*;#tH!1{pB%GpvRWx*3&}K*2YjfQFIFoN@JN@BjO7R=$IHhJv>%h%SI#=gDj|>| z%P!37z$;XjR}Y|7fYt&Ee<-g`%+P2mH0`S|C^Z#3b-oHTUG^$RF{Dyywyiz`yb<34fCO_%slBFY_=z%mjAFn=4=m8~PZ=L9}F}Mm4d94Np zCFDw|Xu}#PoUuSAB2zFz{)UM1v%ptYOQwlT)^qd8oQFA%37>hqwn)X310p#RmWs;z|dky@&`~ZdCV(~n1)h;y+nYwg+z#l zrX8r21HNvPd9!S>mrAlyrSEXogeT1sH7spCUdR=*C5+(F<)Sy9Nt#`eeTlW)fE$zc zQq{?rx;%Dj=M<28AwWN%b%3@}6g2zLe2DV+3q`+96{`7k5g;D==z2i36*Gae&`0Zj z2#|3CpAv|74pd6hg=$5-a2m2rOT0){vo!ZR3ATM1!Gv5kQ*KMPL@+a9v0&RF7foeD zK<=|5QnpIv_;k)Imy?s8&*JvF+Y!*jhF;!Zy-1BO5zL@17HkIuTcR=aXlQIIlTRN< z>o$9b(a$aBkFEu*1B`$*`|9%UqY@TtqGd(NibQHxysqp*FXb2}-9{3Sb8jn2fI&2n zquIECmM8(ZHk1$?8N^z7CosHmG5_UuB0vj-U>`W%P00ML#_R=d2U2)emJ@u27t4tW z3wA8PAR0!gr(r-#^n@NgfUqzr=LCbu%B+DLy)EkiBVf%wyq00zfi0?(s@^otf$748 z@$Zx;XO{F!8jwv^yjE;mSum`4WU*kE5o*D7iDC>|ARVUyZ;5p1rvV|Ldee_3OD3qU zECgt5S}X*J=$yowN}HUl2+9_RFh`zY;pH-Zuf$ABP7G(MGFA>BFv$c+R*c_Ned(pXt0nSwl|$5=a2&5y%K+W-2WT&#`vH9c&;x+>1Nv=1j{xEs9Eu2J&T2nKVNeoIsvRHYCjfIg3-736qj2s}=FwHUocJ+xl9Pl8P}=q!SdQ ze6*TL1L_o!3*!=@-B!-!$|>eS1QF8Fkv36oiH_x9i^+;Rihf-(W>A?hrdcUSnS`n# z$*ROuDQyDgkc64AN9SmQF)^(Z9bu)0_6fa)HLD)!)#w$1aHv-~hanZ3fcj6OkgL~b)zSH{&MMatNk4~m*q!Z!zU~~{-4BM6@u0S~oU8tce@^U(6ZoJY6&#IHRc6E$sas%GZMnq;b^l0-Y zMo(d2c>Zr^)#-+Ht$B0)k7w0c6&ZBmC&PncSv~TamyMnVx1CT`{FB5_)bvnPvIOW> zL*|<*+P$^6p#<_*9`g0V-8cwjnwK#anV}Um87x15_9kYoVnJ`6v}M1cm3k;LIx-je zQuCvSVcK{)f$=K1Hldo+Sl$SrGZ=VNCu&<9j$&Y!p(3MaX-M-oMI7K=#iB-ucS~>S z?603zYQ{;;+_*w2dnLL>0e!il!AL1}PX3u%><$$&@b^ML%KnH&nH?4kpRz0gT z9jPre2g;pDNFD1SUNzRus+=Rr7f1wk9t6}os}8D;?vQgrv?3x>MbFRur!b)TU{m;5 zSd*BUm_W3XXT^|<6nr#E4bc57h}VEK%&n!2GP)@E|?82 z$+v((rE~$1Bfu+_3MF@heVV6Jb+B87A*X&6IDlF;84ec4eD+C3-Kt1frnqrn%VSd^ z&KlAF?u$x2?(|4!yi>v?Mms)9d_!p%@ehr4{5jZa-INJ*HH8H$|yfEXLhts08o~#uyO|0myeF?~y z7THNedSvC|+hcp%EG{)f$Nvsd?4f-#H(ujW5nW$<%I0~&6@b#+o(SNuX)vndjA572 z+z-AuOq}Gv(-L=ay5fm4w9`ZxY!Poh^+!V=MnX=nlM)4BA3i|5Suo0hcF?UH{5dL*K8CojU(As7wAlSyo`dhsWIY$eT?d zBP&*qG~~rJDR4FnvQnJ%^3#>1P&CiV9*Y^Tk~(b!WfGnR9vff~4Wq1(UInzoV}UFF zHz9Y|$x_8VR45!F*2?@b{OE1@2N(f=_TjaJ|Ht3`R=f}0lE4;H3u;^x4JhVKh|rP) znMVo^-#4E7)mhyGcR4s1t##0#{{XWCgZ7?k8MH=!H_Tud zL013ouVy639-0U6+R$*VL;S=dA5`f`7Y?*U#? zk^m^V^RolcdBrm!kR^gteyzLeg;{@ROtjiE3gK~c%WXpl&^nxWvKLL889p+gJ0$mhNKc+`n(Li2i%_UxUY&5Xf&~MheXfNDW{4uw&F2M~U(%+(n{wFfpyyb*MW^lWw-<>i>Vab`G>Ax*RRy$5p{+&D~gFX zogV44&MSSv85mTG19RVN-Rg7`MWyAaB3}K(to{$I?`^IRKHupVyoXNMHA%8l@(M@Q zt}ra&>p@6n&4)F=4EY}Rm39pYh1wjhjjQ^MXbHOc8WM-sftT@3`0Hp6@yzEcH>;3} z62)Y5s3)AmSYS;Yfzb(gbQ9C8k6MvY^xX&?hIsTxZ0gg#KN@$kJB5iKG)AzZpPRh% zm|*+1y`YYc>%$?@{AX)x?3lT*MRqneb!GR0{3ob+Y$*)mD14-TT~zo$k*1ImLCs^0 z;cw^pYOJ`QJ*)PisEBBOa@0@oE13*vIopt>OHhXt`iT;;1&ZYh#e!TynYQL9ecmUb zL(6Al*W6K2OA;HOlrmZh^gtt2z2CI)0snAaQ2qqakzQ4MmUp0k3VK<;LV7D$f(k{= zQ7mb>uneyGDXDj~n#|%vD{>UK`tH;r$sX9u}>|NJFvxQJkfqsQtJpSL!&W17kLqiN+t5!b#Aj5XrL)*2rJ3LM@lj?JsEqYObk z-HtPHdDw@o7GC3CZ zB`5`Ps72}uNm=}+ZkfWBzf>ugoqh4?k(~-e?;}yIYPD0m>RY_5r9|u2H~2#cOLj|E zj#SuO=N6-(4h99C_pNeCb&QBq=3=n*ZwDK0TbEC3YGXlZWBs{dbU$_-kG=twm|6zV zI~b5dSj-MhrgN1B`Z&Oo17!&G@A;Y=)~U-EF9(}oR3)B#T|&C$V5)NP0?jS}r2ZX{ zGlbE%%(Xv12+>%pi}`~P#blUZRS{hK8-6dH{oO$1fphZN$<4~wPjqfxb2(OIG(d1TR)0oOrq%)g@PZ@RuQ0gc0fE6D9hRxLH9Nx5p?r z=NKm@$9KaTmHgqG5=rLl__qFgk_pJ~EhE!h;##w5%l8#oplm$oM4wE=;rRdH=hso> z3ixhfy+a2Ka$&~LQ>v%`lJ`p@whSA#>lG zfeLud;RdDB5-U&=LL}}+t*NR`gm`S~9hKu5A1bINIaly$!F+-+er)M5KQeHioV7Do zM=r`)g8lb#0{x3git*KF?2E9>_})mO1q|HQ8! z4$hXas;#&8aj>H%=DAh+5L=%5=qLM|P4IcioHF+dTavTY#+_9hI<1=Uim33TraX0f zy~zVFMxa*g1249MJn*L&U~m!+a-9v7e_kdJ#GsUalCc&6Viuon|5me=BlC+->*r4` zJm=gc=QL+rbk05Z9HFx_r=K(V;^{BWT)trXF23lzNa%S-j($S?0UIH2r!ahZtYW@2 zb%8sRwVwl;smtqM06hcfmw?Uz`d2{bL7)RKu5_8)?|q<=-1|hM{UQGa4d#CD1L^}> z4>0(9Z?y3Fu;R(@KFlL$b^9Av@VkcHazA48*8;aTjC72^mCi~{Wpgj?+A$!&&lWib z1d$yTa${l^_Wcg*1(9(Y_A_o$wKg9nX F`9BSGROJ8w literal 0 HcmV?d00001 diff --git a/bin/macsym/trhook.fasl b/bin/macsym/trhook.fasl new file mode 100644 index 0000000000000000000000000000000000000000..4d90e4864d57e793e412f21bf1ab7d4a6f089434 GIT binary patch literal 1584 zcmZuyOKTHR6h1dMjVWn0^+6*(7^Mq|jZLU8sEe646OBzXX)>dwwU~m?ickbwbm1f5 zA`3xWh;CiE7Wzm06)tsXClxGZJl~nv*y>qa&g*{PdCW~VKes1R!SFqr^|Fguk62XE zF4gKz4LXZ*>$e1X#0O17i=}b2pFtN8tJg$jiE>P-w}qs+?z6DuP7n&)senoF8dXa>=Vsxl*LyHN43> z1^q;Qowr=oLM%xn$Cjy8LC3jxL=P?KW;Xy|T#~onwP?_9wy6IiQ=|eanA#X&sGa6k z7z&CcU!FviQBwN@2~AJ4)cMA|KIt&*e1NvnqCTHa(;yKh#-eJT+Z_&S)-zVEkYiu2 zT*_6;6{%(PI_@SEEy2_Hm;E9{tC;cn+Gr!Dlc z)0kZT@iG`14?`oq+zx0X45f?hFD)7)YA$Ib!G6X0Q82;d`Kt+rI5U>vRSUhoDS@U zs1#1@TUzB7l9Wgc0;CbBjc}Kz_2Z=xV_Rb)7(ujFly}ZJ&!>*9XYclAGy05uKAALx zJ&fZ}R{dr}Mx|yw$Fv}1@Q5n!UO$-^Z&5x^&bP1ZCX-LFq+C0A9W zW>1wZycXoD5{53_1}UQZ_;RAj!?$#vKNzKNFppNlMzXhODW30B%BMLRh9=*Z%2w>T zS{?Qt=tBYZ)A{DK_;5VxA^!(-z^7&eTByY-osmkj0Nw+AvcJ;x197tkFu z(Mg{kM4(qup30W~sq{q;G&wL3Uj*B$1IRs4pnUgfB?6t0B4?bUO&%EvpDn48QhBcG z%|K^SJxls9cx1&MB{Um>H^DS-A(Kf?doue269UmG;2rj9Eh0BzG8_LOx=S8|W@i2><{9 literal 0 HcmV?d00001 diff --git a/bin/maxer1/transs.80 b/bin/maxer1/transs.80 new file mode 100755 index 0000000000000000000000000000000000000000..a77f50ecb21ebec6f490fc1b4409237e4904f87f GIT binary patch literal 3126 zcmb7G%Wm676lJorx81b6iy%U1!IWQdYS=&n0^G4@LBz9+EqDfOipyK2Ac@I8`Js4$rQ|RcXa(KSwClbD7G{Yu*W)oy z(HA^f@^CfJ!|)0CNfe<9n#M3!X|hOJ6b11DmI2P*C#AxIOr)Ge8P;zBzunxkIKv<<*h>fvI(G#Clt}671x9JA8>vn-KL-1$? zUnxY)PZJ~x*2}c-Q^m@a)v^x6^3(eChNN6UP||m} zOT(h9B(x8%*>jXd!~vNo=~4UXg8)7YM3PF22xx6@C|6rmD9ly~ehqkJWy%*h7CO?i z70|Szanyv@EDhKcD<6wRAV(RjIp*6uDjF4ySIDo?G{8<~{1OIOhF5US{2Sa(mtZqL z+eC~6DtS#Kjf!{NmOd&RDm#UVbSa*9f}u*oRaK&xq!cR}dJy|zj@1CVY&W`|2`2Ik<{V#$NZ)l1 z;MrZr`RQ`de`T9*uiWdgHSplOyMxMztgPDbi4hwMKJYU#v~64eL*0vm52PCg(};aI z61e@tycPb31p&J3t*GS1w54OnHW@bQLnNF-@5lB_yYCuy`|bdL#eOY#!seq-oxf+H zv0ftPh*7kneo0fiY5+Q7yo(>TuV@D;9gFT3nn6sv$)J5_-0)5F0XTI%WYKiSK;Me* z*sFzm{})Sz4kf@Y=ikUOj1&v42mIWtZfk+xf-W{IzLHx_Mv6ROO5#f*PzH6%51T(V z!utfiSYKD2P5CCOsJx3tE!gs}F4COK9;R?5Vo|&%_$AElYM{De>#0a58IOXh0-hDl zgR;2SqRbG9Q3@NkInO!hp9!czB}MHX$lkX1s9vH@-4KrqKV*3PVq4E3<+pi|VtbKi z$NeRsY5~-Bs&1&!$pdqSWj2$ym`WULpau-$S(xf@#U_C5Fz1Ibt5j(GqD_t8w&gfx&obI0Z|K75bCRj%T_4}?yf^c?bcz}bOvZfMujLD{b9#?ixaQSu|eM^p2IHa zcz2letl>nSvKYiE`F2sn>YCob?P8iI5<(KB%i@GmoQ%5i9yWPp^@ly2FE3FY6qi`Z z+goppPI2aivPm*BXq=KMlF2tH@(w2?1vEhcPw-wjDfw`&arKNW(5gyZ36&w@vJASZ bqEN7OtXE#IiAyJ~146+=n5(35f=cLL>+Vu@ literal 0 HcmV?d00001 diff --git a/build/lisp.tcl b/build/lisp.tcl index 17f12065..7f25c59c 100644 --- a/build/lisp.tcl +++ b/build/lisp.tcl @@ -533,6 +533,24 @@ respond "(C1)" "quit();" respond "*" ":link sys3;ts macsym,maxdmp;loser >\r" +### build ctensr for macsyma +respond "*" "macsym\013" +respond "(C1)" "translate_file(\"sharem\\;packg >\");" +respond "(C2)" "quit();" +respond ":KILL" "complr\013" +respond "_" "sharem;packg fasl_packg trlisp\r" +respond "_" "\032" +type ":kill\r" +respond "*" "macsym\013" +respond "(C1)" "translate_file(\"tensor\\;ctensr funcs\");" +respond "Type ALL;" "all;" +respond "Type ALL;" "all;" +respond "(C2)" "quit();" +respond ":KILL" "complr\013" +respond "_" "share;ctensr fasl_tensor;ctensr trlisp\r" +respond "_" "\032" +type ":kill\r" + ### more lisplib stuff respond "*" "complr\013" respond "_" "liblsp;_libdoc;%print\r" diff --git a/src/munfas/transs.unfasl b/src/munfas/transs.unfasl new file mode 100755 index 00000000..87355add --- /dev/null +++ b/src/munfas/transs.unfasl @@ -0,0 +1,51 @@ + +'(THIS IS THE UNFASL FOR ((DSK TRANSL) TRANSS /80)) +'(ASSEMBLED BY FASLAP /392) +'(COMPILED BY LISP COMPILER /936 COMAUX /25 PHAS1 /86 MAKLAP /80 INITIA /118) + +;COMPILED ON TUESDAY, JUNE 8, 1982, AT 2:01 PM + +;; Macsyma installation compilation by GJC. +;; Macsyma compilation environment version 28 +;; dumped on Sunday the thirtieth of May, 1982; 10:30:13 pm by GJC +;; Macro files: UMLMAC 35, DCL 5/29/82 8:19:42, NUMERM 12, PROCS 15, +;; TRANSM 128, ERMSGC 210, DEFOPT 5, MOPERS 47, DEFINE 64, +;; MFORMA 100, MAXMAC 198, LMMAC 82, MACSYMA-MODULE 7 +;initializing error messages. + +'*TRANSL-FILE-DEBUG* +'$TR_OUTPUT_FILE_DEFAULT +'$TR_FILE_TTY_MESSAGESP +'$TR_WINDY +'*TRANSLATION-MSGS-FILES* +'$TR_VERSION +'TRANSL-FILE +'$COMPGRIND +'$TR_TRUE_NAME_OF_FILE_BEING_TRANSLATED +'$TR_STATE_VARS +'DECLARES + (COMMENT **FASL** 0. (LAP $COMPFILE MFEXPR*S)) + (COMMENT **FASL** 165. (LAP COMPILE-FUNCTION SUBR)) +'TR-DEFAULTF + (COMMENT **FASL** 177. (LAP $TRANSLATE_FILE LSUBR)) +'$TR_GEN_TAGS +'TRF-START-HOOK + (COMMENT **FASL** 258. (LAP DELETE-OLD-AND-OPEN SUBR)) + (COMMENT **FASL** 275. (LAP TRANSLATE-FILE SUBR)) + (COMMENT **FASL** 476. (LAP PRINT* SUBR)) + (COMMENT **FASL** 489. (LAP SUB-PRINT* SUBR)) + (COMMENT **FASL** 551. (LAP PRINC* SUBR)) + (COMMENT **FASL** 560. (LAP |TRANSL;TRANSS 80_1.| LSUBR)) + (COMMENT **FASL** 568. (LAP NPRINC* LSUBR)) + (COMMENT **FASL** 576. (LAP TERPRI* SUBR)) + (COMMENT **FASL** 582. (LAP PRINT-MODULE SUBR)) + (COMMENT **FASL** 597. (LAP NEW-COMMENT-LINE SUBR)) + (COMMENT **FASL** 600. (LAP PRINT-TRANSL-MODULES SUBR)) + (COMMENT **FASL** 633. (LAP PRINT-TRANSL-HEADER SUBR)) + (COMMENT **FASL** 681. (LAP PRINT-ABORT-MSG SUBR)) + (COMMENT **FASL** 686. (LAP RENAME-TF SUBR)) + (COMMENT **FASL** 732. (LAP PUMP-STREAM LSUBR)) + (COMMENT **FASL** 765. (LAP $TRANSLATE MFEXPR*S)) +(COMMENT **** (UPDATE-GLOBAL-DECLARES TO-MACSYMA-NAMESTRING) + have been used but remain undefined in this file) + (COMMENT **FASL** TOTAL = 827. WORDS) \ No newline at end of file diff --git a/src/munfas/trhook.unfasl b/src/munfas/trhook.unfasl new file mode 100755 index 00000000..10c9657e --- /dev/null +++ b/src/munfas/trhook.unfasl @@ -0,0 +1,23 @@ + +'(THIS IS THE UNFASL FOR ((DSK TRANSL) TRHOOK /6)) +'(ASSEMBLED BY FASLAP /389) +'(COMPILED BY LISP COMPILER /925 COMAUX /22 PHAS1 /73 MAKLAP /72 INITIA /106) + +;COMPILED ON MONDAY, MARCH 9, 1981, AT 1:34 PM + +;; Macsyma installation compilation by GJC. +;; Prelude file: LIBMAX;PRELUD 112 +;; Macro files: LMMAC 78, MAXMAC 156, MFORMA 80, DEFINE 60, MOPERS 41, ;; ERMSGC 206 + + (COMMENT **FASL** 0. (LAP AUTOLOAD-TRANSLATE SUBR)) + (COMMENT **FASL** 25. (LAP MAP1-PUT-IF-NIL SUBR)) + (COMMENT **FASL** 51. (LAP PUT-MAP LSUBR)) + (COMMENT **FASL** 88. (LAP SPECIAL FSUBR)) + (COMMENT **FASL** 98. (LAP *LEXPR FSUBR)) + (COMMENT **FASL** 108. (LAP *EXPR FSUBR)) + (COMMENT **FASL** 118. (LAP *FEXPR FSUBR)) + (COMMENT **FASL** 128. (LAP FIXNUM FSUBR)) + (COMMENT **FASL** 140. (LAP FLONUM FSUBR)) +(COMMENT **** (LOAD-AND-TELL) + have been used but remain undefined in this file) + (COMMENT **FASL** TOTAL = 152. WORDS) \ No newline at end of file diff --git a/src/sharem/packg.7 b/src/sharem/packg.7 new file mode 100755 index 00000000..364aaae7 --- /dev/null +++ b/src/sharem/packg.7 @@ -0,0 +1,50 @@ +/*-*-macsyma-*-*/ + +/* Macros for organizing packages. */ + +eval_when(translate,transcompile:true)$ + +/* HERALD_PACKAGE(MYJUNK)$ will tell the macsyma user and the system + which VERSION of your MYJUNK package is being loaded. */ + +eval_when([translate,demo,batch,loadfile], + + HERALD_PACKAGE(NAME)::= + BUILDQ([NAME, + VERSION_NO:TR_TRUE_NAME_OF_FILE_BEING_TRANSLATED], + (IF LOADPRINT#false THEN PRINT('name,"source",'version_no), + PUT('NAME,'VERSION_NO,'VERSION))) +)$ + +/* next, a macro that is convenient for making sure a HERALDed package + is loaded. It saves a bit of typing. e.g. + LOAD_PACKAGE(FOO_STUFF,FOO,FASL,DSK,SHARE) */ + +HERALD_PACKAGE(PACKG)$ + +LOAD_PACKAGE(NAME,FILE_NAME)::= + BUILDQ([NAME,FILE_NAME], + IF GET('NAME,'VERSION)=FALSE THEN LOAD(FILE_NAME))$ + + +/* For address space reasons on MC things which have an autoload + property are loaded during translation time only if they + have a TRANSLOAD property. This isn't all bad because the + the presence of the property can tell you that the form has + special handling during translation. Which is not a bad thing to + know. */ + +SETUP_AUTOLOAD_MACRO(FILENAME,[L])::= + BUILDQ([PROPSETS:MAPLIST(LAMBDA([U],BUILDQ([U],PUT('U,TRUE,'TRANSLOAD))),L), + FILENAME,L], + (SETUP_AUTOLOAD(FILENAME,SPLICE(L)),SPLICE(PROPSETS)) )$ + +/* Now, here are the big ones */ + +/* Should have a DEFINE_PACKAGE which sets up + (1) Entry points & autoloads. + (2) Bulk Translate & compile aids. + (3) Tags aids. + +*/ + diff --git a/src/tensor/ctensr.funcs b/src/tensor/ctensr.funcs new file mode 100644 index 00000000..e79b075b --- /dev/null +++ b/src/tensor/ctensr.funcs @@ -0,0 +1,643 @@ +/*-*macsyma-*-*/ + +/* (c) Copyright 1978, 1979, 1980, 1981, 1982, 1983, 1984, 1985 Richard Pavelle */ + +EVAL_WHEN(TRANSLATE,TRANSBIND:TRUE,PACKAGEFILE:TRUE)$ + +EVAL_WHEN([TRANSLATE,BATCH,DEMO], + IF GET('PACKG,'VERSION)=FALSE THEN LOADFILE(PACKG,FASL,DSK,SHAREM))$ + +HERALD_PACKAGE(CTENSR)$ + +EVAL_WHEN(TRANSLATE, +MODEDECLARE(FUNCTION(SYMMETRICP,DIAGMATRIXP),BOOLEAN))$ + +TENSORKILL:TRUE$ +DEFINE_VARIABLE(DIM,4,FIXNUM,"The dimension of the problem.")$ +DEFINE_VARIABLE(DIAGMETRIC,FALSE,BOOLEAN, + "True if the metric entered is a diagonal matrix.")$ + +READVALUE(MESSAGE,PRED,[BADBOY]):= + BLOCK([VALUE], + LOOP, + VALUE:READ(MESSAGE), + IF APPLY(PRED,[VALUE])=TRUE THEN RETURN(VALUE), + IF BADBOY#[] THEN APPLY('PRINT,BADBOY), + GO(LOOP))$ + +MODEDECLARE(FUNCTION(YESP),BOOLEAN)$ + +YESP([MESSAGES]):= + BLOCK([REPLY], + LOOP, + REPLY:APPLY('READ,MESSAGES), + IF MEMBER(REPLY,['YES,'YE,'Y]) THEN RETURN(TRUE), + IF MEMBER(REPLY,['NO,'N]) THEN RETURN(FALSE), + PRINT("Please reply YES or NO."), + GO(LOOP))$ + +SWAPOUT(FILE,[FUNCTIONS]):=APPLY('KILL,FUNCTIONS)$ +/* Temporary until SWAPOUT is written by GJC */ + +RESIMP(EXP):=APPLY('EV,[EXP,'NOEVAL,'SIMP])$ + +/* 62 lines between ^L's can be used with GACHA10 ,68 with GACHA9 */ + +/* The convention for the sign of the Riemann tensor is the same as in + Landau-Lifshits, Misner-Thorne-Wheeler */ + +/* Kronecker delta function */ + +KDELT(I,J):=(MODEDECLARE([I,J],FIXNUM),IF I = J THEN 1 ELSE 0)$ + +/* TTRANSFORM transforms second rank covariant tensors given the components and + the transformation law. The latter is in the form YI=YI(X1,...,XDIM) */ + +TTRANSFORM(QXYZ):=BLOCK([],LOCAL(TTEMP,OMTEMP,VARTEMP,NEWTEMP), + FOR I THRU DIM DO + (FOR J THRU DIM DO + (TTEMP[I,J]:QXYZ[I,J], + FOR K THRU DIM DO + TTEMP[I,J]:SUBST(OMTEMP[K],OMEGA[K],TTEMP[I,J]))), + FOR I THRU DIM DO VARTEMP[I]:READ("Transform #",I), + FOR I THRU DIM DO + (FOR J THRU DIM DO + (FOR K THRU DIM DO + TTEMP[I,J]:SUBST(VARTEMP[K],OMTEMP[K],TTEMP[I,J]))), + FOR A THRU DIM DO + (FOR B THRU DIM DO + NEWTEMP[A,B]:TXYZSUM(VARTEMP,OMEGA,A,B,TTEMP)), + GENMATRIX(NEWTEMP,DIM,DIM))$ + +TXYZSUM(VARTEMP,OMEGA,A,B,TTEMP):=BLOCK([TEMP:0],FOR I FROM 1 THRU DIM DO + FOR J FROM 1 THRU DIM DO + TEMP:TEMP+DIFF(VARTEMP[I],OMEGA[A])* + DIFF(VARTEMP[J],OMEGA[B])* + TTEMP[I,J],TEMP)$ + +/* Setup function */ + +DEFINE_VARIABLE(DERIVABBREV,TRUE,BOOLEAN)$ +DEFINE_VARIABLE(TETRADCALEQ,FALSE,BOOLEAN)$ +DEFINE_VARIABLE(TAYSWITCH,FALSE,BOOLEAN)$ +DEFINE_VARIABLE(RATCHRISTOF,TRUE,BOOLEAN)$ +DEFINE_VARIABLE(RATEINSTEIN,TRUE,BOOLEAN)$ +DEFINE_VARIABLE(RATRIEMAN,TRUE,BOOLEAN)$ +DEFINE_VARIABLE(RATWEYL,TRUE,BOOLEAN)$ + +SETFLAGS():=(DERIVABBREV:TRUE,TETRADCALEQ:FALSE,TAYSWITCH:FALSE, + RATCHRISTOF:TRUE,RATEINSTEIN:TRUE,RATRIEMAN:TRUE,RATWEYL:TRUE)$ + +TSETUP():=BLOCK([],IF TENSORKILL # TRUE THEN + ERROR("Type KILL(ALL)\; and then TENSORKILL:TRUE\; before you enter a new metric."), + TENSORKILL:FALSE, + SETFLAGS(), + DIM:MODE_IDENTITY(FIXNUM, + READVALUE("Enter the dimension of the coordinate system:", + LAMBDA([V], + IF INTEGERP(V) THEN + BLOCK([U:V],MODEDECLARE(U,FIXNUM), + IF U>0 THEN TRUE)), + "Must be a positive integer!")), + + OMEGA:IF DIM = 2 THEN [X,Y] + ELSE (IF DIM = 3 THEN [X,Y,Z] + ELSE (IF DIM = 4 THEN [X,Y,Z,T] + ELSE READ("Enter a list containing the names of the coordinates in order"))), + + IF YESP("Do you wish to change the coordinate names?") + THEN +OMEGA:READ("Enter a list containing the names of the coordinates in order"), + IF LENGTH(OMEGA) # DIM + THEN ERROR("Length of the coordinate list is not equal to the dimension"), + + READVALUE("Do you want to +1. Enter a new metric? +2. Enter a metric from a file? +3. Approximate a metric with a Taylor series?", + LAMBDA([OPT], + IF OPT = 1 THEN(NEWMET(),TRUE) + ELSE IF OPT = 2 THEN(FILEMET(),TRUE) + ELSE IF OPT = 3 THEN(SERMET(),TRUE) + ELSE FALSE), + "Invalid option, please enter 1, 2, or 3."), + DONE)$ + +/* Enter a new metric */ + +NEWMET():=BLOCK([],LG:ENTERMATRIX(DIM,DIM), +READ("Enter functional dependencies with the DEPENDS function or 'N' if none"), + IF YESP("Do you wish to see the metric?") + THEN DISP(LG),METRIC())$ + +/* Enter a metric from a file */ + +FILEMET():=BLOCK([FILE,FPOS], + FILE:READ("Specify the file as [filename1,filename2,directory]?"), + FPOS:(PRINT("What is the ordinal position of the metric in this file?"), + READ("(Note, the name LG must be assigned to your metric in the file)")), + APPLY(BATCH,[FILE,OFF,FPOS,FPOS]),METRIC())$ + +/* Approximate a metric with a Taylor series */ + +SERMET():=BLOCK([],TAYSWITCH:TRUE, + PARAM:READ("Enter expansion parameter"), + MINP:READ("Enter minimum power to drop"), + TAYPT:READ("Enter the point to expand the series around"), + IF YESP("Is the metric in a file?") THEN FILEMET() + ELSE NEWMET())$ + +/* Checks diagonality of a matrix or 2D array */ + +DIAGMATRIXP(MAT,NLIM):=(MODEDECLARE(NLIM,FIXNUM), + BLOCK([DIAGFLAG:TRUE], + FOR I THRU NLIM DO + (FOR J THRU NLIM DO + (IF I # J AND MAT[I,J] # 0 + THEN RETURN(DIAGFLAG:FALSE))),DIAGFLAG))$ + +/* Used for Taylor series approximation */ + +DLGTAYLOR(X):=IF TAYSWITCH THEN RATDISREP(TAYLOR(X,PARAM,TAYPT,MINP-1)) ELSE X$ + +/* Routine for computing contravariant metric from the covariant but if the + metric is diagonal then no out of core files are loaded. UG is defined so +that for display purposes it appears with DETOUT and is then evaluated again */ + +METRIC():=BLOCK([], + IF LENGTH(LG) # DIM OR LENGTH(TRANSPOSE(LG)) # DIM THEN + ERROR("The rank of the metric is not equal to the dimension of the space") + ELSE (IF NOT SYMMETRICP(LG,DIM) THEN ERROR( + "You must be working in a new gravity theory not supported by this program")), + DIAGMETRIC:DIAGMATRIXP(LG,DIM),GDET:FACTOR(DETERMINANT(LG)), + UG:IDENT(LENGTH(FIRST(LG))), + IF DIAGMETRIC THEN FOR II:1 THRU LENGTH(FIRST(LG)) DO + (UG[II,II]:1/LG[II,II]) ELSE + UG:BLOCK([DETOUT:TRUE],LG^^(-1)), + IF YESP("Do you wish to see the metric inverse?") + THEN LDISP(UG),UG:RESIMP(UG),DONE)$ + +/* Following returns TRUE if M is an NxN symmetric matrix or array */ + +SYMMETRICP(M,N):=(MODEDECLARE(N,FIXNUM), + BLOCK([SYMFLAG:TRUE], + IF N # 1 + THEN FOR I THRU N-1 DO + (FOR J FROM I+1 THRU N DO + (IF M[J,I] # M[I,J] THEN SYMFLAG:FALSE)), + SYMFLAG))$ + +/* Computes geodesic equations of motion */ + +MOTION(DIS):=BLOCK([S],DEPENDS(OMEGA,S), + FOR I THRU DIM DO + EM[I]:IF DIAGMETRIC + THEN RATSIMP(1/2*SUM( + DIFF(LG[A,A],OMEGA[I]) + *DIFF(OMEGA[A],S)^2,A,1,DIM)) + ELSE 1/2*SUM(SUM(DIFF(LG[A,B],OMEGA[I]) + *DIFF(OMEGA[A],S)*DIFF(OMEGA[B],S),A, + 1,DIM),B,1,DIM), + IF DIS#FALSE THEN FOR I THRU DIM DO LDISPLAY(EM[I]),DONE)$ + +/* Computes d'Alembertian of a 2nd rank covariant tensor AND DOES NOT WORK + FEB. 10, 1980 */ +/* Computes covariant and contravariant gradients where the :: allows the + user to define the array name*/ + +COGRAD(F,XYZ):=BLOCK([], + FOR MM THRU DIM DO + (ARRAYSETAPPLY(XYZ,[MM],RATSIMP(DIFF(F,OMEGA[MM])))))$ + +CONTRAGRAD(F,XYZ):=BLOCK([], + IF DIAGMETRIC THEN + FOR MM THRU DIM DO + (ARRAYSETAPPLY(XYZ,[MM],RATSIMP(RATSIMP(UG[MM,MM]*DIFF(F,OMEGA[MM]))))) + ELSE + FOR MM THRU DIM DO + (ARRAYSETAPPLY(XYZ,[MM],SUM(UG[M,N]*DIFF(F,OMEGA[NN]),NN,1,DIM))))$ + +/* DALEM(P,I,J):=IF DIAGMETRIC + THEN RATSIMP(SUM(CONTRAGRAD(COGRAD(P[I,J],M),M),M,1,DIM) + +1/SQRT(-GDET)*SUM(COGRAD(SQRT(-GDET)*UG[M,M],M)*COGRAD(P[I,J],M),M,1,DIM)) + ELSE SUM(CONTRAGRAD(COGRAD(P[I,J],M),M),M,1,DIM) + +1/SQRT(-GDET)*SUM(SUM(COGRAD(SQRT(-GDET)*UG[M,N],N)*COGRAD(P[I,J],M),N,1, + DIM),M,1,DIM)$ */ + +/* Routine for computing the Christoffel symbols +COMMENT: Change routine so GDET is not evaluated until the end +*/ + +CHRISTOF(DIS):=BLOCK([], + FOR I THRU DIM DO + (FOR J FROM I THRU DIM DO + (FOR K THRU DIM DO + LCS[J,I,K]:LCS[I,J,K] + :(DIFF(LG[J,K],OMEGA[I]) + +DIFF(LG[I,K],OMEGA[J]) + -DIFF(LG[I,J],OMEGA[K]))/2, + FOR K THRU DIM DO + (MCS[J,I,K]:MCS[I,J,K] + :DLGTAYLOR( + IF DIAGMETRIC + THEN RATSIMP(UG[K,K]*LCS[I,J,K]) + ELSE SUM(UG[K,L]*LCS[I,J,L],L,1,DIM)), + IF RATCHRISTOF + THEN MCS[J,I,K] + :MCS[I,J,K]:RATSIMP(MCS[I,J,K])))), + IF DIS = ALL OR DIS = LCS + THEN FOR I THRU DIM DO + (FOR J:I THRU DIM DO + (FOR K THRU DIM DO + (IF LCS[I,J,K] # 0 + THEN LDISPLAY(LCS[I,J,K])))), + REMARRAY(LCS), + + IF DIS = MCS OR DIS = ALL + THEN FOR I THRU DIM DO + (FOR J:I THRU DIM DO + (FOR K THRU DIM DO + (IF MCS[I,J,K] # 0 + THEN LDISPLAY(MCS[I,J,K])))),DONE)$ + +/* Covariant components of the Ricci tensor */ + +LRICCICOM(DIS):=BLOCK([SUMA,SUMB,FLAT:TRUE], + MODEDECLARE(FLAT,BOOLEAN), + IF MEMBER('MCS,ARRAYS) THEN (TRUE) ELSE (CHRISTOF(FALSE)), + FOR I THRU DIM DO + (FOR J FROM I THRU DIM DO + (SUMA:0,SUMB:0, + FOR K THRU DIM DO + (IF K # I + THEN SUMA:SUMA + +(DIFF(MCS[I,J,K],OMEGA[K]) + -DIFF(MCS[J,K,K],OMEGA[I])), + SUMB:SUMB+SUM( + MCS[K,L,K]*MCS[I,J,L] + -MCS[I,K,L]*MCS[J,L,K],L,1,DIM)), + LR[I,J]:DLGTAYLOR(SUMA+SUMB), + IF RATFAC + THEN LR[I,J]:FACTOR(DLGTAYLOR(RATSIMP(LR[I,J]))), + LR[J,I]:LR[I,J])), + IF DIS#FALSE + THEN (FOR I THRU DIM DO + (FOR J FROM I THRU DIM DO + (IF LR[I,J] # 0 + THEN (FLAT:FALSE,LDISPLAY(LR[I,J])))), + IF FLAT + THEN PRINT("This spacetime is empty and/or flat")), + TRACER:IF DIAGMETRIC THEN DLGTAYLOR(RATSIMP(SUM(LR[I,I]*UG[I,I],I,1,DIM))) + ELSE DLGTAYLOR(SUM(SUM(LR[I,J]*UG[I,J],I,1,DIM),J,1,DIM)),DONE)$ + +/* Forms a scalar from the inner product of the two arguments assumed to be + second rank matrices */ + +CONTRACT(BLU,BLA):= + BLOCK(MODEDECLARE([I,J],FIXNUM), + RATSIMP(DLGTAYLOR(SUM(SUM(BLU[I,J]*BLA[I,J],I,1,DIM),J,1,DIM)),DONE))$ + +/* Computes mixed Ricci tensor where the first index is covariant */ + +RICCICOM(DIS):=BLOCK([FLAT:TRUE],MODEDECLARE(FLAT,BOOLEAN), + IF MEMBER('LR,ARRAYS) THEN (TRUE) ELSE (LRICCICOM(FALSE)), + FOR I THRU DIM DO FOR J THRU DIM DO (RICCI[I,J]:0), + FOR I THRU DIM DO + (FOR J THRU DIM DO + (RICCI[I,J]:IF DIAGMETRIC THEN RATSIMP(DLGTAYLOR(LR[I,J]*UG[J,J])) + ELSE DLGTAYLOR(SUM(LR[I,K]*UG[K,J],K,1,DIM)), + IF RATFAC + THEN RICCI[I,J] + :FACTOR(DLGTAYLOR(RATSIMP(RICCI[I,J]))))), + IF DIS#FALSE + THEN (FOR I THRU DIM DO + (FOR J THRU DIM DO + (IF RICCI[I,J] # 0 + THEN (FLAT:FALSE,LDISPLAY(RICCI[I,J])))), + IF FLAT + THEN PRINT("This spacetime is empty and/or flat")), + DONE)$ + +/* Computes scalar curvature */ + +SCURVATURE():=IF RATFAC THEN FACTOR(TRACER) ELSE TRACER$ + +/* Computes mixed Einstein tensor where the first index is covariant */ + +EINSTEIN(DIS):=BLOCK([FLAT:TRUE],MODEDECLARE(FLAT,BOOLEAN), + IF MEMBER('RICCI,ARRAYS) THEN (TRUE) ELSE (RICCICOM(FALSE)), + FOR I THRU DIM DO + (FOR J THRU DIM DO + (IF I = J THEN G[I,J]:DLGTAYLOR(RICCI[I,J]-TRACER/2) + ELSE G[I,J]:DLGTAYLOR(RICCI[I,J]), + IF RATFAC + THEN G[I,J]:FACTOR(RATSIMP(G[I,J])) + ELSE (IF RATEINSTEIN + THEN G[I,J]:RATSIMP(G[I,J])), + IF DIS#FALSE AND G[I,J] # 0 + THEN (FLAT:FALSE,LDISPLAY(G[I,J])))), +IF DIS#FALSE AND FLAT THEN PRINT("This spacetime is empty and/or flat"),DONE)$ + +/* Computes covariant Riemann curvature tensor */ + +RIEMANN(DIS):=BLOCK([FLAT:TRUE], + MODEDECLARE(FLAT,BOOLEAN), + IF MEMBER('MCS,ARRAYS) THEN (TRUE) ELSE (CHRISTOF(FALSE)), + FOR I THRU DIM DO + (FOR J THRU DIM DO + (FOR K THRU DIM DO (FOR L THRU DIM DO R[I,J,K,L]:0))), + FOR I THRU DIM DO + (FOR J FROM I+1 THRU DIM DO + (FOR K FROM I THRU DIM DO + (FOR L FROM K+1 THRU (IF K = I THEN J ELSE DIM) DO + (R[I,J,K,L]:DLGTAYLOR( + 1/2 + *(DIFF(LG[I,L],OMEGA[J],1,OMEGA[K],1) + +DIFF(LG[J,K],OMEGA[I],1,OMEGA[L],1) + -DIFF(LG[I,K],OMEGA[J],1,OMEGA[L],1) + -DIFF(LG[J,L],OMEGA[I],1,OMEGA[K],1)) + +(IF DIAGMETRIC + THEN RATSIMP( + SUM( + LG[U,U] + *(MCS[J,K,U]*MCS[I,L,U] + -MCS[J,L,U]*MCS[I,K,U]),U,1, + DIM)) + ELSE SUM( + SUM( + LG[U,V] + *(MCS[J,K,U]*MCS[I,L,V] + -MCS[J,L,U]*MCS[I,K,V]),V,1, + DIM),U,1,DIM))), + IF RATFAC + THEN R[I,J,K,L] + :FACTOR(RATSIMP(R[I,J,K,L])) + ELSE (IF RATRIEMAN + THEN R[I,J,K,L] + :RATSIMP(R[I,J,K,L])), + R[J,I,L,K]:R[I,J,K,L], + R[I,J,L,K]:R[J,I,K,L]:-R[I,J,K,L], + IF I # K OR J > L + THEN (R[K,L,I,J]:R[L,K,J,I]:R[I,J,K,L], + R[L,K,I,J]:R[K,L,J,I]:-R[I,J,K,L]), + IF DIS#FALSE AND R[I,J,K,L] # 0 + THEN (FLAT:FALSE,LDISPLAY(R[I,J,K,L])))))), + IF DIS#FALSE AND FLAT THEN PRINT("This spacetime is flat"),DONE)$ + +/* Computes contravariant Riemann tensor from covariant form */ + +RAISERIEMANN(DIS):=BLOCK([], + IF MEMBER('R,ARRAYS) THEN (TRUE) ELSE (RIEMANN(FALSE)), + FOR I THRU DIM DO + (FOR J THRU DIM DO + (FOR K THRU DIM DO (FOR L THRU DIM DO UR[I,J,K,L]:0))), + FOR I THRU DIM DO + (FOR J FROM I+1 THRU DIM DO + (FOR K FROM I THRU DIM DO + (FOR L FROM K+1 THRU (IF K = I THEN J ELSE DIM) DO + (UR[I,J,K,L] + :IF DIAGMETRIC + THEN RATSIMP( + R[I,J,K,L]*UG[I,I]*UG[J,J]*UG[K,K] + *UG[L,L]) + ELSE SUM( + SUM( + SUM( + SUM( + R[A,B,C,D]*UG[I,A]*UG[J,B]*UG[K,C] + *UG[L,D],A,1,DIM),B,1, + DIM),C,1,DIM),D,1,DIM), + IF RATRIEMAN + THEN UR[I,J,K,L]:RATSIMP(UR[I,J,K,L]), + UR[J,I,L,K]:UR[I,J,K,L], + UR[I,J,L,K]:UR[J,I,K,L]:-UR[I,J,K,L], + IF I # K OR J > L + THEN ( + UR[K,L,I,J]:UR[L,K,J,I]:UR[I,J,K,L], + UR[L,K,I,J]:UR[K,L,J,I]:-UR[I,J,K,L]), + IF DIS#FALSE AND UR[I,J,K,L] # 0 + THEN LDISPLAY(UR[I,J,K,L]))))))$ + +/* Computes the Kretchmann invariant R[i,j,k,l]*UR[i,j,k,l] */ + +/* old definition + +RINVARIANT():=KINVARIANT:SUM( + SUM(SUM(SUM(R[I,J,K,L]*UR[I,J,K,L],I,1,DIM),J, + 1,DIM),K,1,DIM),L,1,DIM)$ */ + +RINVARIANT():=IF MEMBER('UR,ARRAYS) THEN + KINVARIANT:SUM( + SUM(SUM(SUM(R[I,J,K,L]*UR[I,J,K,L],I,1,DIM),J, + 1,DIM),K,1,DIM),L,1,DIM) + ELSE (RAISERIEMANN(FALSE),KINVARIANT:SUM( + SUM(SUM(SUM(R[I,J,K,L]*UR[I,J,K,L],I,1,DIM),J, + 1,DIM),K,1,DIM),L,1,DIM))$ + + +/* Computes covariant Weyl tensor */ + +WEYL(DIS):=BLOCK([FLAT:TRUE],MODEDECLARE(FLAT,BOOLEAN), + IF DIM = 2 THEN + (PRINT("All 2 dimensional spacetimes are conformally flat"), + RETURN(DONE)), + IF (MEMBER('LR,ARRAYS),MEMBER('R,ARRAYS)) THEN + TRUE ELSE (LRICCICOM(FALSE),RIEMANN(FALSE)), + FOR I THRU DIM DO + (FOR J THRU DIM DO + (FOR K THRU DIM DO (FOR L THRU DIM DO W[I,J,K,L]:0))), + FOR I THRU DIM DO + (FOR J FROM I+1 THRU DIM DO + (FOR K FROM I THRU DIM DO + (FOR L FROM K+1 THRU (IF K = I THEN J ELSE DIM) DO + (W[I,J,K,L]:DLGTAYLOR( + R[I,J,K,L] + +1/(DIM-2) + *(LG[I,L]*LR[J,K]-LG[I,K]*LR[L,J] + +LG[J,K]*LR[L,I] + -LG[J,L]*LR[K,I]) + -TRACER/((DIM-1)*(DIM-2)) + *(LG[I,L]*LG[K,J]-LG[I,K]*LG[L,J])), + IF RATFAC + THEN W[I,J,K,L] + :FACTOR(RATSIMP(W[I,J,K,L])) + ELSE (IF RATWEYL + THEN W[I,J,K,L]:RATSIMP(W[I,J,K,L])), + W[J,I,L,K]:W[I,J,K,L], + W[I,J,L,K]:W[J,I,K,L]:-W[I,J,K,L], + IF I # K OR J > L + THEN (W[K,L,I,J]:W[L,K,J,I]:W[I,J,K,L], + W[L,K,I,J]:W[K,L,J,I]:-W[I,J,K,L]), + IF DIS#FALSE AND W[I,J,K,L] # 0 + THEN (FLAT:FALSE,LDISPLAY(W[I,J,K,L])))))), + IF DIS#FALSE AND FLAT THEN PRINT("This spacetime is conformally flat"),DONE)$ + +/* Number of terms per component of the array F */ + +NTERMST(F):=FOR I THRU DIM DO + (FOR J THRU DIM DO PRINT([[I,J],NTERMS(F[I,J])]))$ + +/* Computes d'Alembertian of the scalar PHI */ + +DSCALAR(PHI):=IF DIAGMETRIC + THEN RATSIMP(1/SQRT(-GDET)*SUM( + DIFF( + UG[I,I]*SQRT(-GDET)*DIFF(PHI,OMEGA[I]), + OMEGA[I]),I,1,DIM)) + ELSE RATSIMP(1/SQRT(-GDET)*SUM( + SUM( + DIFF( + UG[I,J]*SQRT(-GDET)*DIFF(PHI,OMEGA[J]), + OMEGA[I]),I,1,DIM),J,1,DIM))$ + +/* Computes the covariant divergence of the object GXYZ which must +be a mixed 2nd rank tensor whose first index is covariant- a check should +be put in to see if GXYZ has the correct dimensions Apr.9,80 */ + +CHECKDIV(GXYZ):=BLOCK(MODEDECLARE([I,J],FIXNUM), + IF DIAGMATRIXP(GXYZ,DIM) THEN FOR I THRU DIM DO + PRINT(DIV[I]:RATSIMP(DLGTAYLOR(1/SQRT(-GDET) + *DIFF(SQRT(-GDET)*GXYZ[I,I],OMEGA[I]) + -SUM(MCS[I,J,J]*GXYZ[J,J],J,1,DIM)))) + ELSE FOR I THRU DIM DO + PRINT(DIV[I]:RATSIMP(DLGTAYLOR(1/SQRT(-GDET) + *SUM(DIFF(SQRT(-GDET)*GXYZ[I,J],OMEGA[J]),J,1,DIM) + -SUM(SUM(MCS[I,J,A]*GXYZ[A,J],A,1,DIM),J,1,DIM)))))$ + + +/* FINDDE returns a list of the unique differential equations in the list or + 2 or 3 dimensional array A. DEINDEX is a global list containing the indices + of A corresponding to these unique differential equations. */ + +FINDDE1(LIST):=BLOCK([INFLAG:TRUE,DERIV:NOUNIFY('DERIVATIVE),L:[],L1,Q], + DEINDEX:[], + FOR I WHILE LIST # [] DO + (L1:FACTOR(NUM(FIRST(LIST))),LIST:REST(LIST), + IF NOT FREEOF(DERIV,L1) + THEN (DEINDEX:CONS(I,DEINDEX), + IF INPART(L1,0) # "*" THEN L:CONS(L1,L) + ELSE (Q:1, + FOR J THRU LENGTH(L1) DO + (IF NOT FREEOF(DERIV,INPART(L1,J)) + THEN Q:Q*INPART(L1,J)), + L:CONS(Q,L)))), + CLEANUP(L))$ + +FINDDE2(A):=BLOCK([INFLAG:TRUE,DERIV:NOUNIFY('DERIVATIVE),L:[],T,Q], + DEINDEX:[], + FOR I THRU DIM DO + (FOR J THRU DIM DO + (T:FACTOR(NUM(A[I,J])), + IF NOT FREEOF(DERIV,T) + THEN (DEINDEX:CONS([I,J],DEINDEX), + IF INPART(T,0) # "*" THEN L:CONS(T,L) + ELSE (Q:1, + FOR N THRU LENGTH(T) DO + (IF NOT FREEOF(DERIV,INPART(T,N)) + THEN Q:Q*INPART(T,N)), + L:CONS(Q,L))))), + CLEANUP(L))$ + +FINDDE3(A):=BLOCK([INFLAG:TRUE,DERIV:NOUNIFY('DERIVATIVE),L:[],T,Q], + DEINDEX:[], + FOR I THRU DIM DO + (FOR J THRU DIM DO + (FOR K THRU DIM DO + (T:FACTOR(NUM(A[I,J,K])), + IF NOT FREEOF(DERIV,T) + THEN (DEINDEX:CONS([I,J,K],DEINDEX), + IF INPART(T,0) # "*" THEN L:CONS(T,L) + ELSE (Q:1, + FOR N THRU LENGTH(T) DO + (IF + NOT FREEOF(DERIV,INPART(T,N)) + THEN Q:Q*INPART(T,N)), + L:CONS(Q,L)))))), + CLEANUP(L))$ + +CLEANUP(LL):=BLOCK([A,L:[],INDEX:[]], + WHILE LL # [] DO + (A:FIRST(LL),LL:REST(LL), + IF NOT MEMBER(A,LL) + THEN (L:CONS(A,L),INDEX:CONS(FIRST(DEINDEX),INDEX)), + DEINDEX:REST(DEINDEX)),DEINDEX:INDEX,L)$ + +FINDDE(A,N):=(MODEDECLARE(N,FIXNUM), + IF N = 1 THEN FINDDE1(A) + ELSE (IF N = 2 THEN FINDDE2(A) + ELSE (IF N = 3 THEN FINDDE3(A) + ELSE ERROR("Invalid dimension:",N))))$ + +DELETEN(L,N):=(MODEDECLARE(N,FIXNUM), + BLOCK([LEN],MODEDECLARE(LEN,FIXNUM), + IF L = [] THEN L + ELSE (LEN:LENGTH(L), + IF N > LEN OR N < 1 + THEN ERROR("Second argument out of range") + ELSE (IF N = 1 THEN REST(L) + ELSE (IF N = LEN THEN REST(L,-1) + ELSE APPEND(REST(L,N-LEN-1), + REST(L,N)))))))$ + +GETRID():= +(MAPLIST(LAMBDA([U],U::FALSE), +'[TAYSWITCH,RATCHRISTOF,EXPANDCHRISTOF,RATEINSTEIN,RATRIEMAN, +HALFC,CHRSUB,MOTION,DLGTAYLOR,TSETUP,CHRISTOF,RICCICOM,TESTINDEX,EINSTEIN, +TTRANSFORM,RIEMANN,DIAGMATRIXP,RAISERIEMANN,RSCALAR,LRICCICOM,WEYL,METRIC]), +SWAPOUT([], +TETRADCALEQ,RATWEYL,NICEPRINT,KDELT,SETFLAGS,BDVAC,INVARIANT1,INVARIANT2, +TSETUP,NEWMET,FILEMET,SERMET,SYMMETRICP,DL,DU,DALEM,SCURVATURE,RINVARIANT, +NTERMST,DSCALAR,CHECKDIV,SETUPTETRAD,CONTRACT4,PSI,PETROV,FINDDE1,FINDDE2, +FINDDE3,CLEANUP,FINDDE,DELETEN,GETRID))$ + + +/* The 4 dimensional Brans- Dicke vacuum field equations are represented by +the array BD and the scalar equation is generated by setting the d'Alembertian +of the scalar field to zero. That is one calls the function DSCALAR on the +scalar field. */ + +BDVAC():=BLOCK([], + IF DIM # 4 THEN ERROR(" THIS PROGRAM IS RESTRICTED TO 4 DIMENSIONS"), + ZZ:READ("give a name to the scalar field and + declare its functional dependencies"), + BOXQ:0, +FOR I:1 THRU 4 DO FOR J:1 THRU 4 DO (ADDD[I,J]: + W/ZZ^2*( + DIFF(ZZ,OMEGA[I])*DIFF(ZZ,OMEGA[J])- +LG[I,J]*SUM(DIFF(ZZ,OMEGA[KK])*DIFF(ZZ,OMEGA[KK])*UG[KK,KK],KK,1,4)/2)+ +(DIFF(DIFF(ZZ,OMEGA[I]),OMEGA[J])-SUM(MCS[I,J,KK]*DIFF(ZZ,OMEGA[KK]),KK,1,4)- +LG[I,J]*BOXQ)/ZZ), +FOR I:1 THRU 4 DO FOR J:1 THRU 4 DO (BD[I,J]:RATSIMP( + LR[I,J]-R*LG[I,J]/2-0*T[I,J]-ADDD[I,J])), +REMARRAY(ADDD))$ + +/* This gives the Euler- Lagrange equations for the density of the +invariant R^2. The form is (where D is the Kronecker delta) + b 2 b b bc + (1/2)*D R - 2 R R + 2 D []R -2 g R + a a a ;ac +The equations are sometimes less complex if +TRACER is given a parametric name with dependencies corresponding +to those of the Scalar Curvature */ + +INVARIANT1():=BLOCK([], + FOR AA THRU DIM DO FOR BB THRU DIM DO (INV1[AA,BB]:0), +IF DIAGMETRIC THEN + FOR AA THRU DIM DO FOR BB THRU DIM DO (INV1[AA,BB]:RATSIMP( + KDELT(AA,BB)*TRACER^2/2- + 2*TRACER*RICCI[AA,BB]- + 2*KDELT(AA,BB)*DSCALAR(TRACER)+ + 2*UG[AA,AA]*( + DIFF(DIFF(TRACER,OMEGA[BB]),OMEGA[AA]) + -SUM(MCS[BB,AA,KK]*DIFF(TRACER,OMEGA[KK]),KK,1,DIM)))) +ELSE + FOR AA THRU DIM DO FOR BB THRU DIM DO (INV1[AA,BB]:RATSIMP( + KDELT(AA,BB)*TRACER^2/2- + 2*TRACER*RICCI[AA,BB]- + 2*KDELT(AA,BB)*DSCALAR(TRACER)+ + 2*SUM(UG[BB,CC]*( + DIFF(DIFF(TRACER,OMEGA[AA]),OMEGA[CC]) + -SUM(MCS[AA,CC,KK]*DIFF(TRACER,OMEGA[KK]),KK,1,DIM)),CC,1,DIM))))$ + +INVARIANT2():="NOT YET IMPLEMENTED"; +BIMETRIC():="NOT YET IMPLEMENTED"; \ No newline at end of file