1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081 |
- %==========================================================================%
- % GRGclass.sl Assignment, Macro Functions, Classification %
- %==========================================================================%
- % GRG 3.2 Standard Lisp Source Code (C) 1988-96 Vadim V. Zhytnikov %
- %==========================================================================%
- % This file is distributed without any warranty. You may modify it but you %
- % are not allowed to remove author's name and/or distribute modified file. %
- %==========================================================================%
- %------- Assignment Command 09.91,03.94 -------------------------------
- %
- % Assignment Command in forms
- % Tetrad T0=..., ...;
- % Tetrad T(j)=..., ...;
- % T(j)=..., ...;
- % T0=..., ...;
- %
- (de seti!> (lst)
- (prog (w wl wa wr was)
- (setq ![newabbr!] nil)
- (setq w (seek!> lst '(!=)))
- (cond ((or (null w) (null(car w)) (null(cdr w)))
- (prog2 (setq ![er!] 2204) (return !!er!!))))
- (setq wa (car w))
- (setq wl (length wa))
- (cond
- ((or (eqn wl 1) % t0 = ...
- (and(eqn wl 2)(pairp(car wa)))) % t(j) = ...
- (progn
- (setq wa(cond((eqn wl 1) (car wa))
- (t (cadr wa))))
- (cond((not(idp wa))
- (prog2(setq ![er!] 2204)(return !!er!!))))
- (setq was wa)
- (setq wa (explode2 wa))
- (cond((eqn wl 1)(setq wr(selid!> wa nil))))
- (setq wa(incomiv!> wa))
- (cond((not(flagp wa '!+ivar))
- (cond
- (wr(progn(doub!> was)(setq ![er!] 8604)(return !!er!!)))
- ((or(flagp wa '!+grgmac)(gettype!> wa))
- (progn(doub!> was)(setq ![er!] 3000)(return !!er!!)))
- (t(progn
- (cond((flagp was '!+grg)(prog2(doub!> was)(msg!> 8603))))
- (setq ![abbr!] (cons wa ![abbr!]))
- (setq ![newabbr!] wa)
- (global (ncons wa))
- (flag (ncons wa) '!+ivar)
- (flag (ncons wa) '!+abbr))))))
- (return(datr!> lst wa)))) % ---> datr> ...
- ((atom(car wa))(prog2
- (setq w(cons(car wa)(cdr w)))
- (setq wa(cdr wa))))
- (t (prog2 (setq w(cons(cadr wa)(cons(car wa)(cdr w))))
- (setq wa(cddr wa)))))
- (setq wa(reverse wa))
- (setq was wa)
- (setq wa (assocf!> wa ![datl!]))
- (cond((or(null wa)(pairp(car wa)))
- (progn(setq ![er!] 6030)(doubl!> was)(return !!er!!))))
- (setq wa(car wa))
- (return(datr!> w wa)))) % ---> datr> ...
- % 03.94, 05.96 ... WN - Internal Variable, LST - Text
- (de datr!> (lst wn)
- (proc (w wl wr ww)
- (cond ((null lst) (return nil))
- ((setq w (constrp!> wn)) % constrained!
- (progn (doubo!> wn) (setq ![er!] w) (return !!er!!))))
- (setq lst (memlistbr!> '!, lst))
- (cond ((eq lst !!er!!) (prog2 (setq ![er!] 2202) (return !!er!!))))
- (while!> lst
- (setq w (seek1!> (car lst) '!=))
- (cond((or (null w) (null(car w)) (null(cdr w)))
- (prog2 (setq ![er!] 2204) (return !!er!!))))
- (setq wl (reverse (car w)))
- (setq wr (cdr w))
- (cond((or (not(idp(car wl)))
- (and (cdr wl) (not(pairp(cadr wl))))
- (greaterp (length wl) 2))
- (prog2 (setq ![er!] 2204) (return !!er!!))))
- (setq ww
- (cond ((cdr wl) (transi!> wn wl wr))
- (t (trans!> wn (car wl) wr))))
- (cond ((eq ww !!er!!) (cond (![newabbr!] (forget1!> ![newabbr!])))
- (return !!er!!)))
- (cond
- ((eq wn '!#!G) (mtype!>))
- ((eq wn '!#!G!I) (mitype!>))
- ((eq wn '!#!T) (ftype!>))
- ((eq wn '!#!D) (fitype!>)))
- (setq lst (cdr lst)) )))
- % Normal Form ...
- % 11.94 ... WN Internal var, WL Left, WR Right
- (de trans!> (wn wl wr)
- (prog (wi wc)
- (cond((and (flagp wn '!+equ) (not(memq '!= wr)))
- (prog2 (setq ![er!] 2208) (return !!er!!))))
- (setq wi (get wn '!=idxl)) % index types list
- (setq wc (transn!> wl wn wi)) % id = ... translation
- (cond ((eq wc !!er!!) (return !!er!!)))
- (return (trans0!> wn wc wr)) ))
- % 11.94 ... WN Internal var, WL indices, WR Right
- (de trans0!> (wn wc wr)
- (prog (wss wi wt we wnn)
- (setq wss (get wn '!=sidxl)) % symmetry list
- (setq wi (get wn '!=idxl)) % index types list
- (setq wt (gettype!> wn)) % expression type
- (cond((null(eval wn)) % prepare space for storing if not exists
- (prog2(setq wnn t)(set wn (mkbox!> wn)))))
- (cond (wc (setq wc (syaidx!> wc wss))))
- (cond((and wi (null wc)) (return nil)))
- (setq wr (cschtr!> wr (flagp wn '!+equ)))
- (setq ![extvar!] nil)
- (cond((flagp wn '!+equ) (setq we (translateeq!> wr))) % expr translation
- (t (setq we (translate!> wr))))
- (cond ((equal we !!er!!)
- (cond (wnn (set wn nil)))
- (return !!er!!))
- ((null we)
- (cond ((null wt) (put wn '!=type 0))))
- ((null wt)
- (setq wt (car we))
- (put wn '!=type wt))
- ((not(eqn wt (car we))) % incorrect expression type
- (cond(wnn(set wn nil)))
- (expects!> wt)
- (setq ![er!] 2100) (return !!er!!)))
- % storing of the data component
- (putel!> (cond(we(cdr we))(t nil)) (eval wn) (cond(wc wc)(t '(0))))
- (return t)))
- % Perform Sign Changing [CS] and Complex Conjugations [CH] ...
- (de cschtr!> (wr we)
- (cond((and ![ch!] ![cs!])
- (cond (we (progn (setq wr (seek1!> wr '!=))
- (list (csch0!>(reverse(car wr))) (csch0!>(cdr wr)))))
- (t (csch0!> wr))))
- (![cs!]
- (cond (we (progn (setq wr (seek1!> wr '!=))
- (list (cs0!>(reverse(car wr))) (cs0!>(cdr wr)))))
- (t (cs0!> wr))))
- (![ch!]
- (cond (we (progn (setq wr (seek1!> wr '!=))
- (list (ch0!>(reverse(car wr))) (ch0!>(cdr wr)))))
- (t (ch0!> wr))))
- (t wr)))
- % aux functions ...
- (de cs0!> (w) (list2 '!- (ncons w)))
- (de ch0!> (w) (list2 '!~ (ncons w)))
- (de csch0!> (w) (list '!- '!~ (ncons w)))
- % Message about wrong type of the expression ...
- (de expects!> (wt)
- (progn
- (cond((eqn wt 0) (prin2 "Algebraic expression"))
- ((eqn wt -1) (prin2 "Vector"))
- (t (prin2 wt) (prin2 "-form")))
- (prin2 " is expected.")
- (terpri)))
- % w - id = ... wn - internal variable wi - index types list
- (de transn!> (w wn wi)
- (prog(wa wb wc wd wl wf)
- (setq wb(explode2 w))
- (setq wa(cdr(explode2 wn)))
- (setq wf(selid!> wb nil)) % wb - id wf - indices
- (cond((not(equal wb wa))
- (progn(expid!> wa)(setq ![er!] 2101)(return !!er!!))))
- (cond((null wf)(cond((null wi)(return nil)) % scalar data ...
- (t(prog2(setq ![er!] 2102)(return !!er!!))))))
- (setq wf (mapcar wf 'digorerr!>))
- (cond((memq !!er!! wf)
- (prog2(setq ![er!] 2102)(return !!er!!))))
- (cond ((eq (goodidxl!> wf wi) !!er!!) (return !!er!!)))
- (return wf)))
- % aux fun ...
- (de digorerr!> (w)
- (cond((digit w)(compress (ncons w)))
- (t !!er!!)))
- % w is expected ...
- (de expid!> (w)
- (progn (mapc w 'prin2)
- (prin2 " is expected.")
- (terpri)))
- % Verifies correct range of indices ...
- (de goodidxl!> (wb wi)
- (cond ((and (null wb) (null wi)) t)
- ((null wb) (setq ![er!] 21023) !!er!!)
- ((null wi) (setq ![er!] 21024) !!er!!)
- ((lessp (dimid!>(car wi) )(car wb)) (setq ![er!] 21022) !!er!!)
- (t (goodidxl!> (cdr wb) (cdr wi)))))
- % Verifies correct range the index ...
- (de goodid1!> (w wt)
- (cond((lessp(dimid!> wt)w) nil)
- (t t)))
- % Tensorial Form ...
- % WN - Internal Variable WL - Left WR - Right
- (de transi!> (wn wl wr)
- (proc (wt wi w wll wa wii)
- (setq wll(cons nil(get wn '!=idxl)))
- (setq wt (car wl))
- (setq wi (cadr wl))
- (setq wt (explode2 wt))
- (cond((not(equal wt(cdr(explode2 wn))))
- (progn(expid!>(cdr(explode2 wn)))
- (setq ![er!] 2101)(return !!er!!))))
- (setq wi(memlist!> '!, wi))
- (cond((eq wi !!er!!) (prog2(setq ![er!] 2202)(return !!er!!))))
- (cond((not(eqn(length wi)(length(get wn '!=idxl))))
- (prog2 (cond (![newabbr!] (doubo!> ![newabbr!])
- (setq ![er!] 22071))
- (t (setq ![er!] 2207)))
- (return !!er!!))))
- (setq wii nil)
- (while!> wi
- (setq wii
- (cons (prog2 (setq wll(cdr wll)) (sumintr!> (car wi) (car wll)))
- wii))
- (setq wi (cdr wi)))
- (setq wi (reverse wii)) % here now the list of indices in lhs
- (cond((memq !!er!! wi)(return !!er!!)))
- (setq ![extvar!] (mkextvars!> wi)) % prepare list of ext. vars.
- (cond((memq !!er!! ![extvar!]) (return !!er!!))
- ((null ![extvar!]) % only numerical indices ...
- (return (trans0!> wn (mklitind!> wi) wr))))
- (cond((flagp wn '!+equ)(setq wr (pretranseq!> wr))) % pre translation
- (t (setq wr (pretrans!> wr))))
- (cond((eq wr !!er!!)(return !!er!!)))
- (setq ![idl!] wi) (setq ![texpr!] wr)
- (setq w(cond((null(eval wn))(mkbox!> wn))
- (t(eval wn))))
- (setq w (errorset!> (list 'allcoll!> (list 'quote w)
- (list 'quote wn)
- nil
- (list 'quote (get wn '!=idxl))
- (list 'function 'transel!>)
- ) ![erst1!] ![erst2!] ))
- (remsubindex!> ![idl!])(setq ![texpr!] nil)
- (cond((atom w)(prog2(setq ![er!] w)(return !!er!!)))
- (t(set wn(car w))))
- (return t)))
- % Prepare List of Ext. vars ...
- (de mkextvars!> (lst)
- (cond((null lst) nil)
- ((atom(car lst))(consmemer!>(car lst)(mkextvars!>(cdr lst))))
- (t(appmemer!>(car lst)(mkextvars!>(cdr lst))))))
- (de appmemer!> (wa wb)
- (prog2 (while!> wa
- (setq wb (consmemer!> (car wa)wb))
- (setq wa (cdr wa)))
- wb))
- (de consmemer!> (w lst)
- (cond((and(idp w)(memq w lst))
- (prog2(setq ![er!] 2205)(cons !!er!! lst)))
- ((idp w) (cons w lst))
- (t lst)))
- (de mklitind!> (lst)
- (mapcar lst 'mklitind1!>))
- (de mklitind1!> (w)
- (cond ((numberp w) w)
- (t (eval(cons 'plus w)))))
- % Translate the element ...
- (de transel!> (lst wi wn)
- (cond((and (syaidxp!> wi (get wn '!=sidxl))
- (coidxp!> wi ![idl!]) )
- (progn
- (putindex!> wi)
- (cond((flagp wn '!+equ)(setq lst(unievaluateeq!> ![texpr!])))
- (t (setq lst(unievaluate!> ![texpr!]))))
- (remsubindex!> ![idl!])
- (cond((null(gettype!> wn))(put wn '!=type (car lst))))
- (cond((and lst(not(eqn(car lst)(gettype!> wn))))
- (prog2 (expects!>(gettype!> wn))
- (err!> 2100))))
- (cond(lst(cdr lst))
- (t nil))))
- (t lst)))
- % Summed index treatment if exists ...
- (de sumintr!> (w wl)
- (cond((atom wl) % tetrad or holonomic index
- (cond((or(cdr w)(not(or(idp(car w))(numberp(car w)))))
- (prog2(setq ![er!] 2206) !!er!!))
- ((and(numberp(car w))(not(goodid1!>(car w)wl)))
- (prog2(setq ![er!] 21022) !!er!!))
- (t(car w))))
- ((null(cdr w)) % spinor or enumerating index
- (cond((not(or(idp(car w))(numberp(car w))))
- (prog2(setq ![er!] 2206) !!er!!))
- ((and(numberp(car w))(not(goodid1!>(car w)wl)))
- (prog2(setq ![er!] 21022) !!er!!))
- (t(car w))))
- (t(prog nil % summed spinor index
- (setq w(memlist!> '!+ w))
- (cond((or(eq w !!er!!)(not(eqn(length w)(dimid!> wl))))
- (prog2(setq ![er!] 2206) (return !!er!!))))
- (setq w (mapcar w 'auxfun1!>))
- (cond((memq !!er!! w)
- (prog2(setq ![er!] 2206)(return !!er!!)))
- (t(return w)))))))
- (de auxfun1!> (w)
- (cond((or (cdr w) (and (not(idp(car w))) (not(numberp(car w)))))
- !!er!!)
- ((and (numberp(car w)) (greaterp(car w)1)) !!er!!)
- (t(car w))))
- % Compares current list of indices WI with concrete values in WL ...
- (de coidxp!> (wi wl)
- (cond((and(null wi)(null wl)) t)
- (t(and (coidxp1!> (car wi)(car wl))
- (coidxp!> (cdr wi)(cdr wl))))))
- (de coidxp1!> (wi wl)
- (cond((numberp wl)
- (cond((eqn wi wl)t)
- (t nil)))
- ((pairp wl)
- (prog2 (setq wl (putindex2!> wl))
- (cond((or (lessp wi (car wl))
- (lessp(length(cdr wl))(difference wi (car wl))))
- nil)
- (t t))))
- (t t)))
- % Preparing Ext. vars for translator ...
- (de putindex!> (wi)
- (proc(w)
- (setq w ![idl!])
- (while!> wi
- (cond((numberp(car w)) nil)
- ((atom(car w))(put (car w) '!=subind (car wi)))
- (t(putindex1!> (car w) (car wi))))
- (setq w(cdr w)) (setq wi(cdr wi)))))
- (de putindex1!> (wa wb)
- (proc nil
- (setq wa (putindex2!> wa))
- (setq wb (difference wb (car wa)))
- (setq wa (cdr wa))
- (setq wb (add1 wb))
- (while!> wa
- (put (car wa) '!=subind
- (cond((lessp(length wa)wb) 1)
- (t 0)))
- (setq wa(cdr wa)))))
- (de putindex2!> (w)
- (proc (wn wr)
- (setq wn 0)
- (while!> w
- (cond
- ((numberp(car w)) (setq wn (plus wn (car w))))
- (t(setq wr (cons(car w)wr))))
- (setq w (cdr w)))
- (return(cons wn (reversip wr)))))
- % Removing Ext. vars. after translation ...
- (de remsubindex!> (w)
- (cond((null w) nil)
- ((pairp(car w))
- (prog2 (remsubindex!>(car w)) (remsubindex!>(cdr w))))
- ((idp(car w))(prog2
- (remprop (car w) '!=subind)
- (remsubindex!>(cdr w))))
- (t(remsubindex!>(cdr w)))))
- %----- Macro Functions. 08.01.91, 05.96 -------------------------------
- % Solution ...
- (de getsoln!> (lst)
- (cond((cdr lst) (prog2(doub!> '!S!o!l)(err!> 2105)))
- ((null(car lst)) (getsoln1!> 0))
- ((not(zerop(caar lst))) (prog2(doub!> '!S!o!l)(err!> 2023)))
- ((not(numberp(cdar lst))) (prog2(doub!> '!S!o!l)(err!> 2106)))
- (t(getsoln1!> (cdar lst)))))
- (de getsoln1!> (wn)
- (cond((null ![sol!]) (err!> 2113))
- (t(proc (w wnn)
- (setq wnn wn)
- (setq w ![sol!])
- (while!> (and w (not(zerop wn)))
- (setq w (cdr w))
- (setq wn (sub1 wn)))
- (cond((or(null w)(not(zerop wn)))
- (prog2 (doub!> wnn) (err!> 2114))))
- (return(cona1!> 0 (get1equ!>(car w))))))))
- %----- Classify command 06.96 ------------------------------------------
- (de classify!> (lst)
- (proc (w wc wi)
- (cond ((null lst) (return nil)))
- (cond ((eq (setq w (dgood!> lst)) !!er!!) (return !!er!!)))
- (setq w (altdata!> w))
- (while!> w
- (setq wc (car w))
- (cond
- ((not(zerop(get wc '!=type)))
- (setq ![er!] 9100) (doubo!> wc) (return !!er!!))
- ((null(eval wc))
- (abse!> wc) (go lab)))
- (setq wi (get wc '!=idxl))
- (cond
- ((null wi) (cmsg!> wc) (scaltype!> (eval wc)))
- ((eqn (length wi) 1)
- (cond
- ((eqn (dimid!> (car wi)) 2) (cmsg!> wc) (emtype!> (eval wc)))
- ((eqn (dimid!> (car wi)) 4) (cmsg!> wc) (petrov!> (eval wc)))
- (t (setq ![er!] 9101) (doubo!> wc) (return !!er!!))))
- ((eqn (length wi) 2)
- (cond
- ((and (eqn (dimid!> (car wi)) 2) (eqn (dimid!> (cadr wi)) 2))
- (cmsg!> wc) (riccisclass!> (eval wc)))
- ((and (eqn (dimid!> (car wi)) 1) (eqn (dimid!> (cadr wi)) 1))
- (cmsg!> wc) (vectype!> (eval wc)))
- (t (setq ![er!] 9101) (doubo!> wc) (return !!er!!))))
- (t (setq ![er!] 9101) (doubo!> wc) (return !!er!!)))
- lab
- (setq w (cdr w)))))
- (de cmsg!> (w)
- (progn (gprinreset!>)
- (gprils!> '("Classifying"))
- (pn0!> w)
- (gprils0!> '(":"))
- (gterpri!>)))
- %----- Petrov classification. 08.01.91, 06.96 --------------------------
- (de petrov!> (lst)
- (prog (w0 w1 w2 w3 w4 wc wr)
- (cond (!*trace
- (prin2 "Petrov classification ...") (terpri)
- (prin2 " Using algorithm by F.W.Letniowski & R.G.McLenaghan") (terpri)
- (prin2 " Gen. Rel. Grav. 20 (1988) 463-483") (terpri)))
- (setq w0 (aeval (nz!> (getel1!> lst 0 ))))
- (setq w1 (aeval (nz!> (getel1!> lst 1 ))))
- (setq w2 (aeval (nz!> (getel1!> lst 2 ))))
- (setq w3 (aeval (nz!> (getel1!> lst 3 ))))
- (setq w4 (aeval (nz!> (getel1!> lst 4 ))))
- (setq wc (plus (times 16 (to1!> w0))
- (times 8 (to1!> w1))
- (times 4 (to1!> w2))
- (times 2 (to1!> w3))
- (times 1 (to1!> w4)) ))
- (cond (!*trace
- (prin2 "Case ") (prin2 wc) (prin2 ": ")
- (foreach!> x in (list w0 w1 w2 w3 w4) do (progn
- (prin2 " ") (cond ((zerop x) (prin2 0)) (t (prin2 "N")))))
- (prin2 " =>")
- (terpri) ))
- (setq wr
- (cond
- ((eqn wc 0) (finis!> "0" ))
- ((eqn wc 1) (finis!> "N" ))
- ((eqn wc 2) (finis!> "III" ))
- ((eqn wc 3) (finis!> "III" ))
- ((eqn wc 4) (finis!> "D" ))
- ((eqn wc 5) (finis!> "II" ))
- ((eqn wc 6) (finis!> "II" ))
- ((eqn wc 7) (alter!> (list 'plus (list 'times 2 w3 w3)
- (list 'times -3 w2 w4))
- "2*W3^2-3*W2*W4" "D" "II"))
- ((eqn wc 8) (finis!> "III" ))
- ((eqn wc 9) (finis!> "I" ))
- ((eqn wc 10) (finis!> "I" ))
- ((eqn wc 11) (alter!> (list 'plus (list 'times 27 w4 w4 w1)
- (list 'times 64 w3 w3 w3))
- "27*W4^2*W1+64*W3^3" "II" "I"))
- ((eqn wc 12) (finis!> "II" ))
- ((eqn wc 13) (alter!> (list 'plus (list 'times w1 w1 w4)
- (list 'times 2 w2 w2 w2))
- "W1^2*W4+2*W2^3" "II" "I"))
- ((eqn wc 14) (alter!> (list 'plus (list 'times 9 w2 w2)
- (list 'times -16 w1 w3))
- "9*W2^2-16*W1*W3" "II" "I"))
- ((eqn wc 15) (scase15!> w0 w1 w2 w3 w4))
- ((eqn wc 16) (finis!> "N" ))
- ((eqn wc 17) (finis!> "I" ))
- ((eqn wc 18) (finis!> "I" ))
- ((eqn wc 19) (alter!> (list 'plus (list 'times w0 w4 w4 w4)
- (list 'times -27 w3 w3 w3 w3))
- "W0*W4^3-27*W3^4" "II" "I"))
- ((eqn wc 20) (finis!> "II" ))
- ((eqn wc 21) (alter!> (list 'plus (list 'times 9 w2 w2)
- (list 'times -1 w0 w4))
- "9*W2^2-W0*W4" "D" "I"))
- ((eqn wc 22) (alter!> (list 'plus (list 'times w3 w3 w0)
- (list 'times 2 w2 w2 w2))
- "W3^2*W0+2*W2^3" "II" "I"))
- ((eqn wc 23) (scase23!> w0 w1 w2 w3 w4))
- ((eqn wc 24) (finis!> "III" ))
- ((eqn wc 25) (alter!> (list 'plus (list 'times w4 w0 w0 w0)
- (list 'times -27 w1 w1 w1 w1))
- "W4*W0^3-27*W1^4" "II" "I"))
- ((eqn wc 26) (alter!> (list 'plus (list 'times 27 w0 w0 w3)
- (list 'times 64 w1 w1 w1))
- "27*W0^2*W3+64*W1^3" "II" "I"))
- ((eqn wc 27) (scase27!> w0 w1 w2 w3 w4))
- ((eqn wc 28) (alter!> (list 'plus (list 'times 2 w1 w1)
- (list 'times -3 w2 w0))
- "2*W1^2-3*W2*W0" "D" "II"))
- ((eqn wc 29) (scase29!> w0 w1 w2 w3 w4))
- ((eqn wc 30) (scase30!> w0 w1 w2 w3 w4))
- ((eqn wc 31) (scase31!> w0 w1 w2 w3 w4))
- ))
- (return wr)))
- (de to1!> (w)
- (cond ((zerop w) 0)
- (t 1)))
- (de finis!> (w)
- (progn
- (prin2 "Petrov type is ")
- (prin2 w)
- (prin2 ".")
- (terpri)
- w))
- (de alter!> (w wp w0 w1)
- (prog2
- (setq w (aeval w))
- (cond ((zerop w) (iszero!> wp 2) (finis!> w0))
- (t (isnonzero!> wp 2 w) (finis!> w1)))))
- (de iszero!> (wp wl)
- (cond (!*trace
- (spaces wl)
- (prin2 wp)
- (prin2 " = 0 =>")
- (terpri))))
- (de isnonzero!> (wp wl w)
- (cond (!*trace
- (spaces wl)
- (prin2 wp)
- (cond (!*showexpr
- (prin2 " = ") (terpri)
- (algpri!> " ") (algpri!> w) (algterpri!>)
- (spaces (sub1 wl))))
- (prin2 " is nonzero =>")
- (terpri))))
- (de zt!> (we wp wl)
- (cond ((zerop we) (prog2 (iszero!> wp wl) t))
- (t (prog2 (isnonzero!> wp wl we) nil))))
- (de scase15!> (w0 w1 w2 w3 w4)
- (prog (wi wf1 wf2 wdh)
- (setq wi (aeval (list 'plus (list 'times 3 w2 w2)
- (list 'times -4 w1 w3))))
- (setq wf1 (aeval (list 'plus (list 'times 2 w2 w3)
- (list 'times -3 w1 w4))))
- (cond
- ((zt!> wi "I=3*W2^2-4*W1*W3" 2)
- (cond
- ((zt!> wf1 "F1=2*W2*W3-3*W1*W4" 4) (return(finis!> "III")))
- (t (return(finis!> "I")))))
- (t (cond
- ((zt!> wf1 "F1=2*W2*W3-3*W1*W4" 4) (return(finis!> "I")))
- (t (setq wf2 (aeval (list 'plus (list 'times 9 w2 w4)
- (list 'times -8 w3 w3))))
- (cond
- ((zt!> wf2 "F2=9*W2*W4-8*W3^2" 6) (return(finis!> "I")))
- (t (setq wdh (aeval (list 'plus (list 'times 3 wf1 wf1)
- (list 'times 2 wi wf2))))
- (cond
- ((zt!> wdh "D^=3*F1^2+2*I*F2" 8)
- (return(finis!> "II")))
- (t (return(finis!> "I"))))))))))))
- (de scase30!> (w0 w1 w2 w3 w4)
- (prog (wi wf1 wf2 wdh)
- (setq wi (aeval (list 'plus (list 'times 3 w2 w2)
- (list 'times -4 w1 w3))))
- (setq wf1 (aeval (list 'plus (list 'times 2 w2 w1)
- (list 'times -3 w3 w0))))
- (cond
- ((zt!> wi "I=3*W2^2-4*W1*W3" 2)
- (cond
- ((zt!> wf1 "F1=2*W2*W1-3*W3*W0" 4) (return(finis!> "III")))
- (t (return(finis!> "I")))))
- (t (cond
- ((zt!> wf1 "F1=2*W2*W1-3*W3*W0" 4) (return(finis!> "I")))
- (t (setq wf2 (aeval (list 'plus (list 'times 9 w2 w0)
- (list 'times -8 w1 w1))))
- (cond
- ((zt!> wf2 "F2=9*W2*W0-8*W1^2" 6) (return(finis!> "I")))
- (t (setq wdh (aeval (list 'plus (list 'times 3 wf1 wf1)
- (list 'times 2 wi wf2))))
- (cond
- ((zt!> wdh "D^=3*F1^2+2*I*F2" 8)
- (return(finis!> "II")))
- (t (return(finis!> "I"))))))))))))
- (de scase23!> (w0 w1 w2 w3 w4)
- (prog (wi wjh wf3 wdt)
- (setq wi (aeval (list 'plus (list 'times w0 w4)
- (list 'times 3 w2 w2))))
- (setq wjh (aeval (list 'plus (list 'times 4 w2 w4)
- (list 'times -3 w3 w3))))
- (cond
- ((zt!> wi "I=W0*W4+3*W2^2" 2)
- (cond
- ((zt!> wjh "J^=4*W2*W4-3*W3^2" 4) (return(finis!> "III")))
- (t (return(finis!> "I")))))
- (t (cond
- ((zt!> wjh "J^=4*W2*W4-3*W3^2" 4) (return(finis!> "I")))
- (t (setq wf3 (aeval (list 'plus (list 'times w0 wjh)
- (list 'times -2 w2 wi ))))
- (cond
- ((zt!> wf3 "F3=W0*J^-2*W2*I" 6) (return(finis!> "I")))
- (t (setq wdt (aeval (list 'plus (list 'times w4 wi wi)
- (list 'times -3 wjh wf3))))
- (cond
- ((zt!> wdt "D~=W4*I^2-3*J^*F3" 8)
- (return(finis!> "II")))
- (t (return(finis!> "I"))))))))))))
- (de scase29!> (w0 w1 w2 w3 w4)
- (prog (wi wjh wf3 wdt)
- (setq wi (aeval (list 'plus (list 'times w0 w4)
- (list 'times 3 w2 w2))))
- (setq wjh (aeval (list 'plus (list 'times 4 w2 w0)
- (list 'times -3 w1 w1))))
- (cond
- ((zt!> wi "I=W0*W4+3*W2^2" 2)
- (cond
- ((zt!> wjh "J^=4*W2*W0-3*W1^2" 4) (return(finis!> "III")))
- (t (return(finis!> "I")))))
- (t (cond
- ((zt!> wjh "J^=4*W2*W0-3*W1^2" 4) (return(finis!> "I")))
- (t (setq wf3 (aeval (list 'plus (list 'times w4 wjh)
- (list 'times -2 w2 wi ))))
- (cond
- ((zt!> wf3 "F3=W4*J^-2*W2*I" 6) (return(finis!> "I")))
- (t (setq wdt (aeval (list 'plus (list 'times w0 wi wi)
- (list 'times -3 wjh wf3))))
- (cond
- ((zt!> wdt "D~=W0*I^2-3*J^*F3" 8)
- (return(finis!> "II")))
- (t (return(finis!> "I"))))))))))))
- (de scase27!> (w0 w1 w2 w3 w4)
- (prog (wv wu ww wi wj wd)
- (setq wv (aeval (list 'plus (list 'times w0 w3 w3)
- (list 'times -1 w1 w1 w4))))
- (cond
- ((zt!> wv "V=W0*W3^3-W1^2*W4" 2)
- (setq wu (aeval (list 'plus (list 'times w0 w4)
- (list 'times 2 w1 w3))))
- (cond
- ((zt!> wu "U=W0*W4+2*W1*W3" 4) (return(finis!> "D")))
- (t
- (setq ww (aeval (list 'plus (list 'times w0 w4)
- (list 'times -16 w1 w3))))
- (cond
- ((zt!> ww "W=W0*W4-16*W1*W3" 6) (return(finis!> "II")))
- (t (return(finis!> "I")))))))
- (t
- (setq wi (aeval (list 'plus (list 'times w0 w4)
- (list 'times -4 w1 w3))))
- (setq wj (aeval (list 'plus (list 'times -1 w0 w3 w3)
- (list 'times -1 w1 w1 w4))))
- (cond
- ((ZT!> WI "I=W0*W4-4*W1*W3" 4)
- (cond
- ((zt!> wj "J=-W0*W3^2-W1^2*W4" 6) (return(finis!> "III")))
- (t (return(finis!> "I")))))
- ((zt!> wj "J=-W0*W3^2-W1^2*W4" 6) (return(finis!> "I")))
- (t
- (setq wd (aeval (list 'plus (list 'times wi wi wi)
- (list 'times -27 wj wj ))))
- (cond
- ((zt!> wd "D=I^3-27*J^2" 8) (return(finis!> "II")))
- (t (return(finis!> "I"))))))))))
- (de scase31!> (w0 w1 w2 w3 w4)
- (prog (wh wf we wa wi wq wj wg wz wss wd)
- (setq wh (aeval (list 'plus (list 'times w0 w2 )
- (list 'times -1 w1 w1 ))))
- (cond
- ((zt!> wh "H=W0*W2-W1^2" 2)
- (setq wf (aeval (list 'plus (list 'times w0 w3 )
- (list 'times -1 w1 w2 ))))
- (setq we (aeval (list 'plus (list 'times w0 w4 )
- (list 'times -1 w2 w2 ))))
- (cond
- ((zt!> wf "F=W0*W3-W1*W2" 4)
- (cond
- ((zt!> we "E=W0*W4-W2^2" 6) (return(finis!> "N")))
- (t (return(finis!> "I")))))
- ((zt!> we "E=W0*W4-W2^2" 6)
- (setq wq (aeval (list 'plus (list 'times 37 w2 w2 )
- (list 'times 27 w1 w3 ))))
- (cond
- ((zt!> wq "Q=37*W2^2+27*W1*W3" 8) (return(finis!> "II")))
- (t (return(finis!> "I")))))
- (t
- (setq wa (aeval (list 'plus (list 'times w1 w3 )
- (list 'times -1 w2 w2 ))))
- (setq wi (aeval (list 'plus we (list 'times -4 wa ))))
- (cond
- ((zt!> wi "A=W1*W3-W2^2; I=E-4*A" 8) (return(finis!> "I")))
- (t
- (setq wj (aeval (list 'plus (list 'times w4 wh )
- (list 'times -1 w3 wf )
- (list 'times w2 wa ))))
- (setq wd (aeval (list 'plus (list 'times wi wi wi )
- (list 'times -27 wj wj ))))
- (cond
- ((zt!> wd "J=W4*H-W3*F+W2*A; D=I^3-27*J^2" 10)
- (return(finis!> "II")))
- (t (return(finis!> "I")))))))))
- (t
- (setq wf (aeval (list 'plus (list 'times w0 w3 )
- (list 'times -1 w1 w2 ))))
- (setq we (aeval (list 'plus (list 'times w0 w4 )
- (list 'times -1 w2 w2 ))))
- (setq wa (aeval (list 'plus (list 'times w1 w3 )
- (list 'times -1 w2 w2 ))))
- (setq wi (aeval (list 'plus we (list 'times -4 wa ))))
- (cond
- ((zt!> wi "E=W0*W4-W2^2; A=W1*W3-W2^2; I=E-4*A" 4)
- (setq wf (aeval (list 'plus (list 'times w0 w3 )
- (list 'times -1 w1 w2 ))))
- (setq wj (aeval (list 'plus (list 'times w4 wh )
- (list 'times -1 w3 wf )
- (list 'times w2 wa ))))
- (cond
- ((zt!> wj "F=W0*W3-W1*W2; J=W4*H-W3*F+W2*A" 6)
- (return(finis!> "III")))
- (t (return(finis!> "I")))))
- (t
- (setq wf (aeval (list 'plus (list 'times w0 w3 )
- (list 'times -1 w1 w2 ))))
- (setq wg (aeval (list 'plus (list 'times w0 wf )
- (list 'times -2 w1 wh ))))
- (cond
- ((zt!> wg "G=W0*F-2*W1*H" 6)
- (setq wz (aeval (list 'plus (list 'times w0 w0 wi )
- (list 'times -12 wh wh ))))
- (cond
- ((zt!> WZ "Z=W0^2*I-12*H^2" 8) (return(finis!> "D")))
- (t
- (setq wss (aeval (list 'plus (list 'times w0 w0 wi )
- (list 'times -3 wh wh ))))
- (cond
- ((zt!> wss "S=W0^2*I-3*H^2" 10)
- (return(finis!> "II")))
- (t (return(finis!> "I")))))))
- (t
- (setq wj (aeval (list 'plus (list 'times w4 wh )
- (list 'times -1 w3 wf )
- (list 'times w2 wa ))))
- (cond
- ((zt!> wj "J=W4*H-W3*F+W2*A" 8) (return(finis!> "I")))
- (t
- (setq wd (aeval (list 'plus (list 'times wi wi wi )
- (list 'times -27 wj wj ))))
- (cond
- ((zt!> wd "D=I^3-27*J^3" 10)
- (return(finis!> "II")))
- (t (return(finis!> "I"))))))))))))))
- %------- EM Type 06.96 ----------------------------------------------------
- (de emtype!> (lst)
- (prog (w0 w1 w2 wc wr wd)
- (cond (!*trace
- (prin2 "EM strength classification ...") (terpri)))
- (setq w0 (aeval (nz!> (getel1!> lst 0 ))))
- (setq w1 (aeval (nz!> (getel1!> lst 1 ))))
- (setq w2 (aeval (nz!> (getel1!> lst 2 ))))
- (setq wc (plus (times 4 (to1!> w0))
- (times 2 (to1!> w1))
- (times 1 (to1!> w2)) ))
- (cond (!*trace
- (prin2 "Case ") (prin2 wc) (prin2 ": ")
- (foreach!> x in (list w0 w1 w2) do (progn
- (prin2 " ") (cond ((zerop x) (prin2 0)) (t (prin2 "N")))))
- (prin2 " =>")
- (terpri) ))
- (setq wr
- (cond
- ((eqn wc 0) (emfinis!> "0"))
- ((eqn wc 1) (emfinis!> "N"))
- ((eqn wc 2) (emfinis!> "I"))
- ((eqn wc 3) (emfinis!> "I"))
- ((eqn wc 4) (emfinis!> "N"))
- ((eqn wc 5) (emfinis!> "I"))
- ((eqn wc 6) (emfinis!> "I"))
- ((eqn wc 7)
- (setq wd (aeval (list 'plus (list 'times w0 w2)
- (list 'times -1 w1 w1))))
- (cond
- ((zt!> wd "D=F0*F2-F1^2" 2) (emfinis!> "N"))
- (t (emfinis!> "I"))))))
- (return wr)))
- (de emfinis!> (w)
- (progn
- (prin2 "EM type is ")
- (prin2 w)
- (prin2 ".")
- (terpri)
- w))
- %------- Ricci spinor classification 06.96 --------------------------------
- (de riccisclass!> (lst)
- (prog (f00 f01 f02 f11 f12 f22 w0 w1 w2 w3 w4 wc wr wpp wi6 ww
- wq ws1 ws2 ws3 ws4 ws5 ws6 ws7 wip wi7)
- (cond (!*trace
- (prin2 "Ricci Spinor classification ...") (terpri)
- (prin2 " Using algorithm by G.C.Joly, M.A.H.McCallum & W.Seixas") (terpri)
- (prin2 " Class. Quantum Grav. 7 (1990) 541-556") (terpri)
- (prin2 " Class. Quantum Grav. 8 (1991) 1577-1585") (terpri)))
- (setq f00 (aeval (nz!> (getel2!> lst 0 0))))
- (setq f01 (aeval (nz!> (getel2!> lst 0 1))))
- (setq f02 (aeval (nz!> (getel2!> lst 0 2))))
- (setq f11 (aeval (nz!> (getel2!> lst 1 1))))
- (setq f12 (aeval (nz!> (getel2!> lst 1 2))))
- (setq f22 (aeval (nz!> (getel2!> lst 2 2))))
- (setq wc (mapcar (list f00 f01 f02 f11 f12 f22) 'to1!>))
- (cond (!*trace
- (prin2 "Case ")
- (foreach!> x in wc do (prin2 x))
- (prin2 " =>")
- (terpri) ))
- % Special cases ...
- (setq wr
- (cond
- ((equal wc '(0 0 0 0 0 0)) (rfin!> "0" "[(1111)]"))
- ((equal wc '(0 0 0 1 0 0)) (rfin!> "D" "[(11)(1,1)]"))
- ((equal wc '(0 0 1 0 0 0)) (rfin!> "D" "[11(1,1)]"))
- ((equal wc '(0 0 0 0 0 1)) (rfin!> "0" "[(112)]"))
- ((equal wc '(1 0 0 0 0 0)) (rfin!> "0" "[(112)]"))
- ((equal wc '(0 0 0 1 0 1)) (rfin!> "D" "[(11)2]"))
- ((equal wc '(1 0 0 1 0 0)) (rfin!> "D" "[(11)2]"))
- ((equal wc '(0 0 1 0 0 1)) (rfin!> "II" "[112]"))
- ((equal wc '(1 0 1 0 0 0)) (rfin!> "II" "[112]"))
- ((equal wc '(0 0 0 0 1 0)) (rfin!> "N" "[(13)]"))
- ((equal wc '(0 1 0 0 0 0)) (rfin!> "N" "[(13)]"))
- ((equal wc '(0 0 0 1 1 0)) (rfin!> "D" "[(11)2]"))
- ((equal wc '(0 1 0 1 0 0)) (rfin!> "D" "[(11)2]"))
- ((equal wc '(0 0 0 0 1 1)) (rfin!> "N" "[(13)]"))
- ((equal wc '(1 1 0 0 0 0)) (rfin!> "N" "[(13)]"))
- ((equal wc '(0 1 0 0 0 1)) (rfin!> "I" "[11ZZ~]"))
- ((equal wc '(1 0 0 0 1 0)) (rfin!> "I" "[11ZZ~]"))
- ))
- (cond (wr (return wr)))
- % General case ...
- % PP type first ...
- (setq w0 (aeval(wff!> 0 lst)))
- (setq w1 (aeval(wff!> 1 lst)))
- (setq w2 (aeval(wff!> 2 lst)))
- (setq w3 (aeval(wff!> 3 lst)))
- (setq w4 (aeval(wff!> 4 lst)))
- (cond (!*trace
- (prin2 "Making Petrov-Plebanski (PP) classification ...")
- (terpri)))
- (setq wpp (petrov!> (list w0 w1 w2 w3 w4)))
- % Segre type ...
- (setq wr
- (cond
- ((equal wpp "0" )
- (setq ww (aeval (list 'plus
- (list 'times f11 f11)
- (list 'times -1 f12 (gfab!> 1 0 lst)))))
- (cond
- ((zt!> ww "W=F11'^2-F10'*F12'" 2) (rfin!> wpp "[(112)]"))
- ((zt!> f00 "F00" 4) (rfin!> wpp "[1(11,1)]"))
- ((zt!> f22 "F22" 4) (rfin!> wpp "[1(11,1)]"))
- (t (rfincond!> wpp "[(111),1]"
- " if W>0 and "
- "[1(11,1)]"
- " if W<0"))))
- ((equal wpp "I" ) (rfincond!> wpp "[111,1]"
- " if D>0 and "
- "[11ZZ~]"
- " if D<0"))
- ((equal wpp "II" ) (rfin!> wpp "[112]"))
- ((equal wpp "III") (rfin!> wpp "[13]"))
- ((equal wpp "N" )
- (setq wi6 (aeval (list 'plus
- (list 'times (gfab!> 0 0 lst) (gfab!> 2 2 lst))
- (list 'times 2 (gfab!> 1 1 lst) (gfab!> 1 1 lst))
- (list 'times -2 (gfab!> 0 1 lst) (gfab!> 2 1 lst))
- (list 'times -2 (gfab!> 1 0 lst) (gfab!> 1 2 lst))
- (list 'times (gfab!> 0 2 lst) (gfab!> 2 0 lst)))))
- (cond
- ((zt!> wi6 "I6" 2) (rfin!> wpp "[(13)]"))
- (t (rfin!> wpp "[1(12)]"))))
- ((equal wpp "D" )
- (setq wi6 (aeval (list 'plus
- (list 'times (gfab!> 0 0 lst) (gfab!> 2 2 lst))
- (list 'times 2 (gfab!> 1 1 lst) (gfab!> 1 1 lst))
- (list 'times -2 (gfab!> 0 1 lst) (gfab!> 2 1 lst))
- (list 'times -2 (gfab!> 1 0 lst) (gfab!> 1 2 lst))
- (list 'times (gfab!> 0 2 lst) (gfab!> 2 0 lst)))))
- (cond
- ((zt!> wi6 "I6" 2) (rfin!> wpp "[(11)ZZ~]"))
- (t
- (setq wip (aeval (list 'plus
- (list 'times w0 w4)
- (list 'times -4 w1 w3)
- (list 'times 3 w2 w2))))
- (setq ww (aeval (list 'plus
- (list 'times f11 f11)
- (list 'times -1 f12 (gfab!> 1 0 lst)))))
- (setq wq (aeval
- (list 'plus wip
- (list 'times -3 (list 'expt (list 'plus w2 ww) 2)))))
- (cond
- ((zt!> wq "Q" 4)
- (setq ws1 (aeval (list 'plus
- (list 'times (gfab!> 2 0 lst) (gfab!> 1 2 lst))
- (list 'times -1 (gfab!> 1 0 lst) (gfab!> 2 2 lst)))))
- (setq ws2 (aeval (list 'plus
- (list 'times (gfab!> 0 0 lst) (gfab!> 2 2 lst))
- (list 'times -1 (gfab!> 2 0 lst) (gfab!> 0 2 lst)))))
- (setq ws3 (aeval (list 'plus
- (list 'times (gfab!> 1 0 lst) (gfab!> 0 2 lst))
- (list 'times -1 (gfab!> 0 0 lst) (gfab!> 1 2 lst)))))
- (setq ws4 (aeval (list 'plus
- (list 'times (gfab!> 0 0 lst) (gfab!> 1 1 lst))
- (list 'times -1 (gfab!> 1 0 lst) (gfab!> 0 1 lst)))))
- (setq ws5 (aeval (list 'plus
- (list 'times (gfab!> 0 1 lst) (gfab!> 1 2 lst))
- (list 'times -1 (gfab!> 0 2 lst) (gfab!> 1 1 lst)))))
- (setq ws6 (aeval (list 'plus
- (list 'times (gfab!> 1 1 lst) (gfab!> 2 2 lst))
- (list 'times -1 (gfab!> 1 2 lst) (gfab!> 2 1 lst)))))
- (setq wi7 (aeval (list 'plus
- (list 'times f01 ws1)
- (list 'times f11 ws2)
- (list 'times (gfab!> 2 1 lst) ws3))))
- (cond
- ((and (zt!> ws1 "S1" 6)
- (zt!> ws2 "S2" 6)
- (zt!> ws3 "S3" 6))
- (cond
- ((and (zt!> ws4 "S4" 6)
- (zt!> ws5 "S5" 6)
- (zt!> ws6 "S6" 6))
- (rfin!> wpp "[(11)(1,1)]"))
- (t (rfin!> wpp "[(11)2]"))))
- ((zt!> wi7 "I7" 6) (rfin!> wpp "[(11)2]"))
- (t (rfin!> wpp "[11ZZ~]"))))
- (t (rfincond!> wpp "[(11)ZZ~]"
- " if S7<0 and "
- "[(11)1,1] or [11(1,1)]"
- " if S7>0"))))
- ))))
- (return wr)))
- (de rfin!> (wpp wss)
- (progn
- (prin2 "Petrov-Plebanski type is ")
- (prin2 wpp)
- (prin2 ".") (terpri)
- (prin2 "Segre type is ")
- (prin2 wss)
- (prin2 ".")
- (terpri)
- (cons wpp wss)))
- (de rfincond!> (wpp wss1 wcc1 wss2 wcc2)
- (progn
- (prin2 "PP type is ")
- (prin2 wpp)
- (prin2 ".") (terpri)
- (prin2 "Segre type is ")
- (prin2 wss1)
- (prin2 wcc1)
- (prin2 wss2)
- (prin2 wcc2)
- (prin2 ".")
- (terpri)
- (cons wpp (cons wss1 wss2))))
- (de gfab!> (wa wb lst)
- (cond ((lessp wb wa) (nz!>(coalg!>(getel2!> lst wb wa))))
- (t (nz!> (getel2!> lst wa wb)))))
- (de ffabsum!> (wa wb lst)
- (list 'quotient
- (list 'plus
- (list 'times (gfab!> wa 0 lst) (gfab!> wb 2 lst))
- (list 'times (gfab!> wa 2 lst) (gfab!> wb 0 lst))
- (list 'times -2 (gfab!> wa 1 lst) (gfab!> wb 1 lst)) )
- 4))
- (de wff!> (wa lst)
- (cond
- ((eqn wa 0) (ffabsum!> 0 0 lst))
- ((eqn wa 1) (list 'quotient
- (list 'plus (ffabsum!> 0 1 lst) (ffabsum!> 1 0 lst))
- 2))
- ((eqn wa 2) (list 'quotient
- (list 'plus (ffabsum!> 0 2 lst) (ffabsum!> 2 0 lst)
- (list 'times 4 (ffabsum!> 1 1 lst)))
- 6))
- ((eqn wa 3) (list 'quotient
- (list 'plus (ffabsum!> 1 2 lst) (ffabsum!> 2 1 lst))
- 2))
- ((eqn wa 4) (ffabsum!> 2 2 lst))
- ))
- %--------- Vector and Scalar classification 06.96 -------------------------
- (de scaltype!> (lst)
- (prog (w)
- (setq w (aeval(nz!>(car lst))))
- (cond ((zerop w) (prin2 "Scalar is 0.") (terpri))
- (t (prin2 "Scalar is nonzero.") (terpri)))
- (return (to1!> w))))
- (de vectype!> (lst)
- (prog (v01 v10 v00 v11 w)
- (setq v00 (aeval (gfab!> 0 0 lst)))
- (setq v01 (aeval (gfab!> 0 1 lst)))
- (setq v10 (aeval (gfab!> 1 0 lst)))
- (setq v11 (aeval (gfab!> 1 1 lst)))
- (setq w (aeval (list 'plus (list 'times 2 v01 v10)
- (list 'times -2 v00 v11))))
- (cond
- ((zt!> w "2*V01'*V10'-2*V00'*V11'" 2)
- (prin2 "Vector is Null.") (terpri))
- (t (prin2 "Vector is Time or Space-like.") (terpri)))
- (return (to1!> w))))
- %=========== End of GRGclass.sl =========================================%
|