grg/grggeom.sl

%==========================================================================%
%   GRGgeom.sl                                                   Geometry  %
%==========================================================================%
%   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. %
%==========================================================================%


%------ Coordinate --------------------------------------------------------

% Macro 2 for Coordinates ...
(de x!> (wm)  (getel1!> ![cord!] wm))

%------ Dimension ---------------------------------------------------------

% Macro 3 for dim ...
(de dim!> nil  ![dim!])

%------ Delta symbols -----------------------------------------------------

(de delta!> (wa wb) (cond ((equal wa wb) 1) (t nil)))

%------ Epsilon tensors  05.96 --------------------------------------------

(de epsilon!> (u)
  (cond
    ((issame!> u) nil)
    (t(proc (wt wp w ww wc)
	(setq w u)
        (loop!>
	  (setq wp nil)
	  (setq ww (ncons (car w)))
	  (setq w (cdr w))
	  (while!> w
	    (setq wc (car w))
	    (cond ((lessp wc (car ww))
		     (setq ww (cons (car ww)
				    (cons wc
					  (cdr ww))))
		     (setq wt (not wt))
		     (setq wp t))
		  (t (setq ww (cons wc ww))))
	    (setq w (cdr w)))
	  (cond ((null wp) (return (cond (wt -1) (t 1)))))
	  (setq w (reversip ww)))))))

(de issame!> (w)
  (cond ((null w) nil)
	((memq (car w) (cdr w)) t)
	(t (issame!> (cdr w)))))

(dm epsilf!> (w) (list 'epsilf0!> (list 'quote (cdr w))))
(de epsilf0!> (w)
  (prog2
    (setq w (epsilon!> w))
    (cond (w (list 'times w (car !#!s!d!e!t!G)))
	  (t nil))))

(dm epsiuf!> (w) (list 'epsiuf0!> (list 'quote (cdr w))))
(de epsiuf0!> (w)
  (prog2
    (setq w (epsilon!> w))
    (cond (w (list 'quotient (list 'times w ![sigprod!]) (car !#!s!d!e!t!G)))
	  (t nil))))

(dm epsilh!> (w) (list 'epsilh0!> (list 'quote (cdr w))))
(de epsilh0!> (w)
  (prog2
    (setq w (epsilon!> w))
    (cond (w (list 'times w (list 'sqrt
                              (list 'times ![sigprod!] (car !#!d!e!t!g)))))
	  (t nil))))

(dm epsiuh!> (w) (list 'epsiuh0!> (list 'quote (cdr w))))
(de epsiuh0!> (w)
  (prog2
    (setq w (epsilon!> w))
    (cond (w (list 'quotient (list 'times w ![sigprod!])
                             (list 'sqrt
                               (list 'times ![sigprod!] (car !#!d!e!t!g)))))
	  (t nil))))

(de epss!> (wa wb)
  (cond ((equal wa wb)  nil)
	((eqn wa 0)       1)
	((eqn wa 1)      -1)
	(t              nil)))


%------ Basis and Inverse Basis  27.02.91, 05.96 --------------------------

% Basis ...
(de base!> nil
  (setq !#!b (copy !#!T)))

(de base1!> nil  % 05.96
  (prog (w) (setq !#!b (mkt!> 1))
    (setq w (aeval (list 'tp (list 'quotient 1 (mkmtetr!> !#!e)))))
    (mktetrm!> (cdr w) !#!b)
    (return t)))

% Inverse Basis ...
(de ibase!> nil
  (prog (w)
    (setq w (evalform!>(dfprod!> !#!b)))
    (cond ((null w) (prog2 (setq ![er!] 8400) (return !!er!!))))
    (setq !#!e (mkt!> 1))
    (setq w (aeval (list 'tp (list 'quotient 1 (mkmtetr!> !#!b)))))
    (mktetrm!> (cdr w) !#!e)
    (return t)))


%------ Sigma Matrix -------------------------------------------------------

(de sigma!> (wm wa wb)
  (prog (w)
    (setq w
      (cond
        ((and (eqn wm 0) (eqn wa 1) (eqn wb 1)) 1)
        ((and (eqn wm 1) (eqn wa 0) (eqn wb 0)) 1)
        ((and (eqn wm 2) (eqn wa 1) (eqn wb 0)) 1)
        ((and (eqn wm 3) (eqn wa 0) (eqn wb 1)) 1)
	(t nil)))
    (cond (w (setq w (car ![sgn!]))))
    (return w)))

(de sigmai!> (wm wa wb)
  (prog (w)
    (setq w
      (cond
        ((and (eqn wm 0) (eqn wa 1) (eqn wb 1)) 1)
        ((and (eqn wm 1) (eqn wa 0) (eqn wb 0)) 1)
        ((and (eqn wm 2) (eqn wa 1) (eqn wb 0)) 1)
        ((and (eqn wm 3) (eqn wa 0) (eqn wb 1)) 1)
	(t nil)))
    (return w)))

%------ Signature ----------------------------------------------------------

% Signum ...
(de signum!> (w)  (cond ((lessp w 0) -1) (t 1)))

% Signum of Product of Signature, i.e. Signum of the Metric ...
(de sigprod!> nil (signum!> (eval (cons 'times ![sgn!]))))

% Macros 2 Signature diagonal ...
(de diagonal!> (w)  (getel1!> ![sgn!] w))

(de pmsgn!> nil (pm!> 1))
(de mpsgn!> nil (mp!> 1))

%------ S - forms ----------------------------------------------------------

(de makesforms!> nil
  (prog nil
    (setq !#!S (mkt!> 2))
    (fordim!> x do (fordim!> y do (cond ((lessp x y)
      (putel!> (evalform!> (dfprod2!> (getframe!> x)
				      (getframe!> y)))
	       !#!S (list2 x y))))))
    (return t)))

%------ Metric -------------------------------------------------------------

(de imetr1!> nil  % 05.96
  (prog (w)
    (cond ((zerop (nz!>(eval!> (list 'det (setq w (mats!> !#!G))))))
      (setq ![er!] 6800) (return !!er!!) ))
    (setq !#!G!I (mkt!> 2))
    (rmats!> !#!G!I (aeval (list 'quotient 1 w)))
    (mitype!>)
    (return t)))

(de metr0!> nil  % 05.96
  (prog nil
    (msg!> 6801)
    (setq !#!G (mkt!> 2))
    (fordim!> i do
	  (putel!> (getel1!> ![sgn!] i) !#!G (list2 i i)))
    (mtype!>)
    (return t)))

(de metr1!> nil  % 05.96
  (prog (w)
    (cond ((zerop (nz!>(eval!> (list 'det (setq w (mats!> !#!G!I))))))
      (setq ![er!] 6800) (return !!er!!) ))
    (setq !#!G (mkt!> 2))
    (rmats!> !#!G (aeval (list 'quotient 1 w)))
    (mtype!>)
    (return t)))

(de nullmetric!> nil % 05.96
  (prog nil
    (cond
      (!#!G (msg!> 6820) (return t))
      ((equal ![sgn!] '(-1 1 1 1))
	 (setq !#!G  (copy ![nullm!]))
	 (setq ![mtype!] 1)
	 (setq ![dtype!] 1)
	 (return t))
      ((equal ![sgn!] '(1 -1 -1 -1))
	 (setq !#!G  (copy ![nullm1!]))
	 (setq ![mtype!] 1)
	 (setq ![dtype!] 1)
	 (return t))
      (t (setq ![er!] 7910) (return !!er!!)))))

(de detg1!> nil  % 05.96
  (prog (w)
    (cond ((zerop (nz!> (setq w (eval!> (list 'det (mats!> !#!G))))))
            (setq ![er!] 6800) (return !!er!!) ))
    (setq !#!d!e!t!G (ncons w))
    (return t)))

(de dethg1!> nil  % 05.96
  (prog (w)
    (cond ((zerop (nz!> (setq w (eval!> (list 'det (matsf!> 'gmetr!>))))))
            (setq ![er!] 6800) (return !!er!!) ))
    (setq !#!d!e!t!g (ncons w))
    (return t)))

(de sdetg1!> nil  % 05.96
  (prog (w)
    (cond ((zerop (nz!> (setq w (eval!> (list 'det (mats!> !#!G))))))
            (setq ![er!] 6800) (return !!er!!) ))
    (setq !#!s!d!e!t!G (ncons (evalalg!>
                    (list 'sqrt (list 'times ![sigprod!] w)))))
    (return t)))


%------ Volume -------------------------------------------------------------

(de vol0!> nil  % 05.96
  (prog (w)
    (fordim!> i do
      (cond ((eqn i 0) (setq w (getframe!> 0)))
            (t         (setq w (dfprod2!> w (getframe!> i))))))
    (setq w (evalform!> (fndfpr!> (car !#!s!d!e!t!G) w)))
    (cond ((null w) (setq ![er!] 4000) (return !!er!!)))
    (setq !#!V!O!L (ncons w))
    (return t)))


%------ Frame --------------------------------------------------------------

(de frame1!> nil  % 05.96
  (prog (w) (setq !#!T (mkt!> 1))
    (setq w (aeval (list 'tp (list 'quotient 1 (mkmtetr!> !#!D)))))
    (mktetrm!> (cdr w) !#!T)
    (ftype!>)
    (return t)))

(de iframe1!> nil  % 05.96
  (prog (w) (setq !#!D (mkt!> 1))
    (setq w (aeval (list 'tp (list 'quotient 1 (mkmtetr!> !#!T)))))
    (mktetrm!> (cdr w) !#!D)
    (fitype!>)
    (return t)))

(de frame0!> nil  % 05.96
  (prog nil
    (msg!> 6803)
    (setq !#!T (mkt1!>))
    (fordim!> i do (putel1!> (mkdx!> i) !#!T i))
    (ftype!>)
    (return t)))


%----- Macros Metric/Frame components -------------------------------------

% Components of Frame/Inverse Frame ... 05.96
(de ham!>  (wa wm)  % h^a_m
  (cond (![umod!] (vform1!> (getel1!> ![xv!] wm) (getel1!> !#!T wa)))
        (t        (getfdx!> (getel1!> !#!T wa) wm))))

(de hiam!> (wa wm)  % h_a^m
  (cond (![umod!] (vform1!> (getel1!> !#!D wa) (getel1!> ![xf!] wm)))
        (t        (getfdx!> (getel1!> !#!D wa) wm))))

(de gmetr!> (wi wk) % g_ik
  (cond((fholop!>)  % holonomic frame
         (getmetr!> wi wk))
       ((motop!>)   % `diagonal' metric
         (cons 'plus
           (foreach!> a in (dimlist!> 0) collect
             (mktimes!> (list (diagm!> a)
                              (ham!> a wi)
                              (ham!> (ai!> a) wk))))))
       (t(prog (w wc) % general case
           (fordim!> a do
             (fordim!> b do
               (cond ((setq wc (getmetr!> a b))
                 (setq w (cons (mktimes!> (list wc
                                                (ham!> a wi)
                                                (ham!> b wk)))
                               w))))))
           (cond (w (return (cons 'plus w))) (t (return nil)))))))

(de gmetr0!> (wi wk) % g_ik
  (cond((fholop!>)  % holonomic frame
         (getmetr!> wi wk))
       ((motop!>)   % `diagonal' metric
         (cons 'plus
           (foreach!> a in (dimlist!> 0) collect
             (mktimes!> (list (diagm!> a)
                              (ham0!> a wi)
                              (ham0!> (ai!> a) wk))))))
       (t(prog (w wc) % general case
           (fordim!> a do
             (fordim!> b do
               (cond ((setq wc (getmetr!> a b))
                 (setq w (cons (mktimes!> (list wc
                                                (ham0!> a wi)
                                                (ham0!> b wk)))
                               w))))))
           (cond (w (return (cons 'plus w))) (t (return nil)))))))

(de gimetr!> (wi wk) % g^ik
  (cond((ifholop!>)  % holonomic frame
         (getimetr!> wi wk))
       ((imotop!>)   % `diagonal' metric
         (cons 'plus
           (foreach!> a in (dimlist!> 0) collect
             (mktimes!> (list (diagmi!> a)
                              (hiam!> a wi)
                              (hiam!> (ai!> a)wk))))))
       (t(prog (w wc)
           (fordim!> a do
             (fordim!> b do
               (cond ((setq wc (getimetr!> a b))
                 (setq w (cons (mktimes!> (list wc
                                                (hiam!> a wi)
                                                (hiam!> b wk)))
                               w))))))
           (cond (w (return(cons 'plus w))) (t (return nil)))))))

(de huam!> (wa wm) % h^a^mu
  (cond ((imotop!>)
          (mktimes!> (list (diagmi!> wa) (hiam!> (ai!> wa) wm))))
        (t(cons 'plus
            (foreach!> b in (dimlist!> 0) collect
              (mktimes!> (list (getimetr!> wa b) (hiam!> b wm))))))))

(de hlam!> (wa wm) % h_a_mu
  (cond ((motop!>)
          (mktimes!> (list (diagm!> wa) (ham!> (ai!> wa) wm))))
        (t(cons 'plus
            (foreach!> b in (dimlist!> 0) collect
              (mktimes!> (list (getmetr!> wa b) (ham!> b wm))))))))

%---------- Spin Coefficients -------------------------------------------

(de spcoef!> (waa wb)
  (vform1!> (getiframe!> wb) (getel1!> !#!o!m!e!g!a!u waa)))

%----------  Line-element. 27.12.90, 05.96 ------------------------------

(de showlinel!> nil
  (proc (w wx wy wf wm)
    (setq wm "Cannot calculate Line-Element.")
    (setq ![chain!] nil)
    (setq w (request!> '!#!G))
    (cond((eq w !!er!!) (return w))
         ((null w) (progn (trsf!> '!#!G)(prin2 wm)(terpri)
                          (setq ![er!] 6046) (return !!er!!))))
    (setq ![chain!] nil)
    (setq w (request!> '!#!T))
    (cond((eq w !!er!!) (return w))
         ((null w) (progn (trsf!> '!#!T)(prin2 wm)(terpri)
                          (setq ![er!] 6046) (return !!er!!))))
    (gprinreset!>)
    (cond((not(and (fancyon!>) (not !*latex))) (terpri)))
    (cond((ifmodo!>) (gprin!> "ds2"))
	 (t(prog2
             (algpri!> " d" )
             (algpri!> '(expt !s 2) ))))
    (wriassign!> nil)
    (cond(!*math (gprin!> "(")))
    (fordim!> x  do (fordim!> y  do
      (cond((or(lessp x y)(eqn x y))(progn
        (setq w(eval!>(cond ((eqn x y) (gmetr0!> x x))
                           (t(list 'times 2 (gmetr0!> x y))))))
        (setq w (nz!> w))
        (cond((and(not(ifmodo!>))(numberp w)(lessp w 0)(not(eqn w -1)))
          (setq w (list 'minus (minus w)))))
        (cond((or (null w) (eqn w 0)) nil)
	     ((ifmodo!>)
	       (progn
		 (cond(wf (gprin!> "+")))
                 (setq wx (list2 '!dx (prepdx2!> x)))
                 (setq wy (list2 '!dx (prepdx2!> y)))
		 (ooprin!> (list 'times w wx wy))
		 (setq wf t)))
             (t(progn
                 (algpri!>(cond((eqn w -1) " - ")(wf " + ")(t " ")) )
                 (cond((not(memq w '(1 -1))) (progn
                    (cond((pairp w)(algpri!> "(" )))
                    (algpri!> (aeval w) )
                    (cond((pairp w)(algpri!> ")" ))) )))
                 (wridd!>)
                 (setq wx (prepdx2!> x))
                 (setq wy (prepdx2!> y))
                 (cond
                   ((eqn x y) (prog2
		     (cond((and ![umod!] (fancyon!>)) (progn
		       (algpri!> "(" )
		       (algpri!> wx )
		       (setq wx ")" ))))
                     (algpri!> (list 'expt wx 2) )))
                   (t(progn
                     (algpri!> wx )
                     (wridd!>)
                     (algpri!> wy ))))
                 (setq wf t)
                 )))  )))))
    (cond ((null wf) (alpri!> nil)))
    (cond (!*math (gprin!> ")")))
    (grgends!>)
    (grgterpri!>)
    (terpri)
))

(de prepdx2!> (wx)
  (cond
    (![umod!]
      (cond ((fancyon!>) (list 'expt '!#!#b wx))
            (t (compress (cons '!b (explode2 wx))))))
    (t (getel1!> ![cord!] wx))))

(de wridd!> nil
  (algpri!>
    (cond (![umod!] (cond ((fancyon!>) "\,")
			  (t           " ")))
	  (t        (cond ((fancyon!>) "\,d\,")
			  (t           " d "))))
    ))

%------ Spinorial S-forms 06.96 ------------------------------------------

(de ssform!> (wn w2 w3)
  (prog (w)
    (set wn (mkbox!> wn))
    (setq wn (eval wn))
    (setq w (evalform!> (chsignf!> (dfprod2!> (getframe!> 0)
					      (getframe!> w2)))))
    (putel1!> w wn 0)
    (setq w (evalform!> (fndfpr!> '(quotient 1 2) (dfsum!> (list2
	       (dfprod2!> (getframe!> 0) (getframe!> 1))
	       (chsignf!> (dfprod2!> (getframe!> w2) (getframe!> w3))))))))
    (putel1!> w wn 1)
    (setq w (evalform!> (dfprod2!> (getframe!> 1)
				   (getframe!> w3))))
    (putel1!> w wn 2)
    (return t)))

%------ Christoffel symbols  06.96 ---------------------------------------

(de chrt!> (wa)
  (list 'times '(quotient 1 2)
    (list 'quotient (list 'df (car !#!d!e!t!g) (getel1!> ![cord!] wa))
		    (car !#!d!e!t!g))))

(de chrf!> (wa wb wc)
  (list 'times '(quotient 1 2)
    (list 'plus
      (list 'df (gmetr!> wa wc) (getel1!> ![cord!] wb))
      (list 'df (gmetr!> wa wb) (getel1!> ![cord!] wc))
      (chsigna!> (list 'df (gmetr!> wb wc) (getel1!> ![cord!] wa))))))

(de chr!> (wa wb wc)
  (evalalg!> (getm!> '!#!C!H!R!F nil (list wa wb wc) '(3 nil nil))))


%------ Tensorial Solver 06.96 -------------------------------------------

% Genral solver for frame connection ...
% W - result, WT = t^a, WN = n_a_b (symmetric)
(de fsolver!> (wr wt wn)
  (prog (w ww wc)
    (setq ww (mkt!> 1))
    (setq w  (mkt!> 2))
    (set wr  (mkt!> 2))
    (setq wr (eval wr))
    % Creating t_a -> WT
    (cond (wt
      (fordim!> a do (putel1!> (getlo!> wt a) ww a))
      (setq wt ww)
      (setq ww nil)))
    % Solving for 2*omega_a_b -> W (antisymmetric iff n_a_b=0)
    (fordim!> a do (fordim!> b do
      (cond ((or (lessp a b) wn)
	(setq wc nil)
	(fordim!> c do (progn
	  % ( D_a _| D_b _| t_c ) T^c
	  (cond (wt
	    (setq wc (cons
	      (fndfpr!> (vform1!> (getiframe!> a)
			  (vform!> (getiframe!> b)
			    (getel1!> wt c)))
			(getframe!> c))
	      wc))))
	  % ( D_b _| n_a_c - D_a _| n_b_c ) T^c
	  (cond (wn
	    (setq wc (cons
	      (fndfpr!> (list 'difference
			  (vform1!> (getiframe!> b) (getel2s!> wn a c))
			  (vform1!> (getiframe!> a) (getel2s!> wn b c)))
			(getframe!> c))
	      wc))))))
	(cond (wt
	  % - D_a _| t_b
	  (setq wc (cons
	    (chsignf!> (vform!> (getiframe!> a) (getel1!> wt b)))
	    wc))
	  % D_b _| t_a
	  (setq wc (cons
	    (vform!> (getiframe!> b) (getel1!> wt a))
	    wc))))
	(cond (wn
	  % n_a_b
	  (setq wc (cons (getel2s!> wn a b) wc))))
	(setq wc (evalform!> (dfsum!> wc)))
	(putel!> wc w (list2 a b))))))
    % Now omega^a_b
    (fordim!> a do (fordim!> b do (progn
      (setq wc (evalform!>
        (cond
          ((imotop!>)
            (fndfpr!> (mktimes2!> '(quotient 1 2) (diagmi!> a))
	      (cond (wn (getel2!>  w (ai!> a) b))
		    (t  (getasy2!> w (ai!> a) b t)))))
          (t (dfsum!> (foreach!> c in (dimlist!> 0) collect
            (fndfpr!> (mktimes2!> '(quotient 1 2) (getimetr!> a c))
	      (cond (wn (getel2!>  w c b))
		    (t  (getasy2!> w c b t))))))))))
      (putel!> wc wr (list2 a b)) ))) ))


%------ Spinorial Solver  06.96 ------------------------------------------

% General spinorial solver ...
% WD = T - dotted, NIL - undotted
% WR - destination, WZ - Z_AA 3-form
(de ssolver!> (wr wz wd)
  (prog (wm00 wm10 wm20 wm01 wm11 wm21 w02 w12 w22 w03 w13 w23
         i0 i1 i2 i3 w)
    (set wr (mkbox!> wr))
    (setq wr (eval wr))
    (setq i0 0) (setq i1 1)
    (cond (wd (setq i2 3) (setq i3 2))  % undotted
          (t  (setq i2 2) (setq i3 3))) % dotted
    % #( Z_AA/\T^b )
    (setq wm00  (dfp2!> (not wd) (getel1!> wz 0) (getframe!> i0)))
    (setq wm10  (dfp2!> (not wd) (getel1!> wz 1) (getframe!> i0)))
    (setq wm20  (dfp2!> (not wd) (getel1!> wz 2) (getframe!> i0)))
    (setq wm01  (dfp2!> (not wd) (getel1!> wz 0) (getframe!> i1)))
    (setq wm11  (dfp2!> (not wd) (getel1!> wz 1) (getframe!> i1)))
    (setq wm21  (dfp2!> (not wd) (getel1!> wz 2) (getframe!> i1)))
    (setq w02  (dfp2!> wd (getel1!> wz 0) (getframe!> i2)))
    (setq w12  (dfp2!> wd (getel1!> wz 1) (getframe!> i2)))
    (setq w22  (dfp2!> wd (getel1!> wz 2) (getframe!> i2)))
    (setq w03  (dfp2!> wd (getel1!> wz 0) (getframe!> i3)))
    (setq w13  (dfp2!> wd (getel1!> wz 1) (getframe!> i3)))
    (setq w23  (dfp2!> wd (getel1!> wz 2) (getframe!> i3)))
    % omega_0
    (setq w (evalform!> (fndfpr!> 'i (dfsum!> (list
	      (fndfpr!>  w12 (getframe!> i0))
	      (fndfpr!> wm00 (getframe!> i1))
	      (fndfpr!> wm10 (getframe!> i2))
	      (fndfpr!>  w02 (getframe!> i3)))))))
    (putel1!> w wr 0)
    % omega_1
    (setq w (evalform!> (fndfpr!> '(quotient i 2) (dfsum!> (list
	      (fndfpr!> (list 'plus w22 wm11) (getframe!> i0))
	      (fndfpr!> (list 'plus w03 wm10) (getframe!> i1))
	      (fndfpr!> (list 'plus w13 wm20) (getframe!> i2))
	      (fndfpr!> (list 'plus w12 wm01) (getframe!> i3)))))))
    (putel1!> w wr 1)
    % omega_2
    (setq w (evalform!> (fndfpr!> 'i (dfsum!> (list
	      (fndfpr!> wm21 (getframe!> i0))
	      (fndfpr!>  w13 (getframe!> i1))
	      (fndfpr!>  w23 (getframe!> i2))
	      (fndfpr!> wm11 (getframe!> i3)))))))
    (putel1!> w wr 2)
    ))

(de dfp2!> (wd w1 w2)
  (eval!> (duald!>
    (cond
      ((and wd (not(pmmm!>)))  (dfprod2!> w1 w2))
      ((and (pmmm!>) (not wd)) (dfprod2!> w1 w2))
      (t                       (dfprod2!> w2 w1)) ))))

%-------------------------------------------------------------------------

% omega from dT with THETA and N ...
(de connec!> nil  % 09.96
  (prog (wt wn)
    % t = dT + TH
    (setq wt (mkt!> 1))
    (fordim!> a do
       (putel1!> (cond (!*torsion (dfsum!> (list
                                      (dex!>(getframe!> a))
				      (getel1!> !#!T!H!E!T!A a))))
		       (t         (dex!>(getframe!> a))))
                 wt a))
    % n = dG + N
    (setq wn (mkt!> 2))
    (fordim!> a do (fordim!> b do
      (cond ((leq a b)
    	(putel!> (cond (!*nonmetr (dfsum!> (list
                                      (dfun!>(getmetr!> a b))
				      (getel2!> !#!N a b))))
                       (t         (dfun!>(getmetr!> a b)) ))
                 wn (list2 a b))))))
    % solving ...
    (fsolver!> '!#!o!m!e!g!a wt wn)))

% Riem connection + wa
(de connecplus!> (wa)  % 09.96
  (prog (wt wn)
    % t = dT
    (setq wt (mkt!> 1))
    (fordim!> a do
       (putel1!> (dex!>(getframe!> a)) wt a))
    % n = dG
    (setq wn (mkt!> 2))
    (fordim!> a do (fordim!> b do
      (cond ((leq a b)
    	(putel!> (dfun!>(getmetr!> a b)) wn (list2 a b))))))
    % solving ...
    (cond (wa (fsolver!> '!#!o!m!e!g!a wt wn))
	  (t  (fsolver!> '!#!r!o!m!e!g!a wt wn)))
    % adding wa ...
    (cond (wa
     (fordim!> a do (fordim!> b do
       (putel!> (evalform!> (dfsum!> (list (getel2!> !#!o!m!e!g!a a b)
					   (getel2!> wa a b))))
		!#!o!m!e!g!a (list2 a b))))  ))
    ))

% K from THETA and N ...
(de conndef!> nil  % 09.96
  (prog (wt wn)
    % t = TH
    (setq wt (mkt!> 1))
    (fordim!> a do
       (putel1!> (getel1!> !#!T!H!E!T!A a) wt a))
    % n = N
    (setq wn (mkt!> 2))
    (fordim!> a do (fordim!> b do
      (cond ((leq a b)
    	(putel!> (getel2!> !#!N a b) wn (list2 a b))))))
    % solving ...
    (fsolver!> '!#!K wt wn)))

% KN from  N ...
(de nondef!> nil  % 09.96
  (prog (wt wn)
    (setq wt (mkt!> 1))
    % n = N
    (setq wn (mkt!> 2))
    (fordim!> a do (fordim!> b do
      (cond ((leq a b)
    	(putel!> (getel2!> !#!N a b) wn (list2 a b))))))
    % solving ...
    (fsolver!> '!#!K!N wt wn)))

% KQ from THETA ...
(de contor!> nil  % 09.96
  (prog (wt wn)
    % t = TH
    (setq wt (mkt!> 1))
    (fordim!> a do
       (putel1!> (getel1!> !#!T!H!E!T!A a) wt a))
    (setq wn (mkt!> 2))
    % solving ...
    (fsolver!> '!#!K!Q wt wn)))

% GAMMA from omega ...
(de gfromo!> nil
  (prog nil
     (setq !#!G!A!M!M!A (mkt!> 2))
     (fordim!> a do (fordim!> b do
       (putel!> (evalform!> (dfsum!> (list
		   (getm!> '!#!o!m!e!g!a nil (list2 a b) '(7 8))
		   (addgamma!> a b))))
		!#!G!A!M!M!A (list2 a b)))) ))

% RGAMMA from romega ...
(de rgfromro!> nil
  (prog nil
     (setq !#!R!G!A!M!M!A (mkt!> 2))
     (fordim!> a do (fordim!> b do
       (putel!> (evalform!> (dfsum!> (list
		   (getm!> '!#!r!o!m!e!g!a nil (list2 a b) '(7 8))
		   (addgamma!> a b))))
		!#!R!G!A!M!M!A (list2 a b)))) ))

(de addgamma!> (wm wn)
  (prog (w)
    (fordim!> ww do
       (setq w (cons (fndfpr!> (hiam!> ww wm) (dfun!>(ham!> ww wn))) w)))
    (return(dfsum!> w))))

% omega from GAMMA ...
(de ofromg!> nil
  (prog nil
     (setq !#!o!m!e!g!a (mkt!> 2))
     (fordim!> a do (fordim!> b do
       (putel!> (evalform!> (dfsum!> (list
		   (getm!> '!#!G!A!M!M!A nil (list2 a b) '(5 6))
		   (addomega!> a b))))
		!#!o!m!e!g!a (list2 a b)))) ))

(de addomega!> (wa wb)
  (prog (w)
    (fordim!> ww do
      (setq w (cons (fndfpr!> (ham!> wa ww) (dfun!>(hiam!> wb ww))) w)))
    (return(dfsum!> w))))

% N from K ...
(de nfromk!> (wk)
  (prog nil
    (setq !#!N (mkt!> 2))
    (fordim!> a do (fordim!> b do (cond ((leq a b)
       (putel!> (evalform!> (dfsum!> (list
		   (getm!> wk nil (list2 a b) '(2 nil))
		   (getm!> wk nil (list2 b a) '(2 nil))
		   )))
		!#!N (list2 a b)))) ))))

% THETA from K ...
(de qfromk!> (wk)
  (prog (w)
    (setq !#!T!H!E!T!A (mkt!> 1))
    (setq wk (eval wk))
    (fordim!> a do (progn
      (setq w nil)
      (fordim!> b do
	(setq w (cons (dfprod2!> (getframe!> b) (getel2!> wk a b)) w)))
      (putel1!> (evalform!> (dfsum!> w)) !#!T!H!E!T!A a)))))

% Torsion trace 1-form 08.01.91
(de qqq!> nil
  (prog (w)
    (fordim!> a  do
      (setq w (cons (vform!> (getiframe!> a)
                             (getel1!> !#!T!H!E!T!A a)) w)))
    (setq !#!Q!Q (ncons(evalform!>(chsign!> t (dfsum!> w)))))
    (return t)))

% Antisymmetric Torsion 3-form 10.96
(de qqqa!> nil
  (prog (w)
    (fordim!> a  do
      (setq w (cons (dfprod2!> (getlo!> !#!T a)
                               (getel1!> !#!T!H!E!T!A a)) w)))
    (setq !#!Q!Q!A (ncons (evalform!> (dfsum!> w))))
    (return t)))

% roumegau ...
(de ruconnec!> nil
  (ssolver!> '!#!r!o!m!e!g!a!u (mapcar !#!S!U 'dex!>) nil))
% romegad ...
(de rdconnec!> nil
  (ssolver!> '!#!r!o!m!e!g!a!d (mapcar !#!S!D 'dex!>) t))

% oumegau ...
(de uconnec!> nil
  (prog nil
    (ssolver!> '!#!o!m!e!g!a!u (mapcar !#!S!U 'dex!>) nil)
    (cond (!*torsion
      (for!> x (0 1 2) do
        (putel1!> (evalform!> (dfsum2!> (getel1!> !#!o!m!e!g!a!u x)
				        (getel1!> !#!K!U x)))
                  !#!o!m!e!g!a!u x))))))
% omegad ...
(de dconnec!> nil
  (prog nil
    (ssolver!> '!#!o!m!e!g!a!d (mapcar !#!S!D 'dex!>) t)
    (cond (!*torsion
      (for!> x (0 1 2) do
        (putel1!> (evalform!> (dfsum2!> (getel1!> !#!o!m!e!g!a!d x)
				        (getel1!> !#!K!D x)))
                  !#!o!m!e!g!a!d x))))))


% omegau from omega ...
(de oufromo!> (wu wo)
  (prog nil
    (set wu (mkbox!> wu))
    (setq wu (eval wu))
    (putel1!> (evalform!> (mpf!> (getel2!> wo 2 1))) wu 0)
    (putel1!> (evalform!> (fndfpr!> (pma!> '(quotient 1 2))
		(dfsum2!> (getel2!> wo 1 1) (getel2!> wo 3 3)))) wu 1)
    (putel1!> (evalform!> (pmf!> (getel2!> wo 3 0))) wu 2)
    ))

% omegad from omega ...
(de odfromo!> (wu wo)
  (prog nil
    (set wu (mkbox!> wu))
    (setq wu (eval wu))
    (putel1!> (evalform!> (mpf!> (getel2!> wo 3 1))) wu 0)
    (putel1!> (evalform!> (fndfpr!> (pma!> '(quotient 1 2))
		(dfsum2!> (getel2!> wo 1 1) (getel2!> wo 2 2)))) wu 1)
    (putel1!> (evalform!> (pmf!> (getel2!> wo 2 0))) wu 2)
    ))

% omega from omegau+omegad ...
(de ofromos!> (wo wu wd)
  (prog (w)
    (set wo (mkbox!> wo))
    (setq wo (eval wo))
    %
    (setq w (dfsum2!> (getel1!> wu 1) (getel1!> wd 1)))
    (putel!> (evalform!>(mpf!> w)) wo (list2 0 0))
    (putel!> (evalform!>(pmf!> w)) wo (list2 1 1))
    %
    (setq w (dfsum2!> (getel1!> wd 1) (chsign!> t (getel1!> wu 1))))
    (putel!> (evalform!>(pmf!> w)) wo (list2 2 2))
    (putel!> (evalform!>(mpf!> w)) wo (list2 3 3))
    %
    (setq w (evalform!>(pmf!>(getel1!> wd 2))))
    (putel!> w wo (list2 2 0))
    (putel!> w wo (list2 1 3))
    %
    (setq w (evalform!>(mpf!>(getel1!> wu 0))))
    (putel!> w wo (list2 2 1))
    (putel!> w wo (list2 0 3))
    %
    (setq w (evalform!>(pmf!>(getel1!> wu 2))))
    (putel!> w wo (list2 3 0))
    (putel!> w wo (list2 1 2))
    %
    (setq w (evalform!>(mpf!>(getel1!> wd 0))))
    (putel!> w wo (list2 3 1))
    (putel!> w wo (list2 0 2))
    ))

% complex conjugation ...
(de conj3!> (wr wss)
  (prog nil
    (set wr (mkbox!> wr))
    (setq wr (eval wr))
    (putel1!> (evalform!>(coform!>(getel1!> wss 0))) wr 0)
    (putel1!> (evalform!>(coform!>(getel1!> wss 1))) wr 1)
    (putel1!> (evalform!>(coform!>(getel1!> wss 2))) wr 2)
    ))

%--------------------------------------------------------------------------

% Curvature ...
(de curvature!> nil
  (prog (w)
    (setq !#!O!M!E!G!A (mkt!> 2))
    (fordim!> a do (fordim!> b do (progn
      (setq w (ncons (dex!> (getel2!> !#!o!m!e!g!a a b))))
      (fordim!> x do
	(setq w (cons (dfprod2!> (getel2!> !#!o!m!e!g!a a x)
				 (getel2!> !#!o!m!e!g!a x b) ) w)))
      (putel!> (evalform!> (dfsum!> w)) !#!O!M!E!G!A (list2 a b)))))))

% Spinor Curvature
(de scurvature!> (wr wo)
  (prog nil
    (set wr (mkbox!> wr))
    (setq wr (eval wr))
    (putel1!> (evalform!>(dfsum2!> (dex!>(getel1!> wo 0))
				   (fndfpr!> (pma!> 2) (dfprod2!>
				      (getel1!> wo 0)
				      (getel1!> wo 1) ))))  wr 0)
    (putel1!> (evalform!>(dfsum2!> (dex!>(getel1!> wo 1))
				   (fndfpr!> (pma!> 1) (dfprod2!>
				      (getel1!> wo 0)
				      (getel1!> wo 2) ))))  wr 1)
    (putel1!> (evalform!>(dfsum2!> (dex!>(getel1!> wo 2))
				   (fndfpr!> (pma!> 2) (dfprod2!>
				      (getel1!> wo 1)
				      (getel1!> wo 2) ))))  wr 2)
    ))

% Riemann Tensor ...
(de riemm!> nil
  (prog (w)
    (setq !#!R!I!M (mkt!> 4))
    (fordim!> wa do (fordim!> wb do
      (fordim!> wc do (fordim!> wd do (cond ((lessp wc wd)
	(setq w (vform1!> (getiframe!> wd)
		  (vform!> (getiframe!> wc)
                    (getel2!> !#!O!M!E!G!A wa wb))))
	(putel!> (evalalg!> w) !#!R!I!M (list wa wb wc wd))))))))))

% Ricci Tensor ...
(de ricci!> nil
  (prog (w)
    (setq !#!R!I!C (mkt!> 2))
    (fordim!> wa do (fordim!> wb do
      (cond
        ((and (null !*torsion) (null !*nonmetr) (greaterp wa wb)) nil)
	(t (progn
	     (setq w nil)
	     (fordim!> wx do
	       (setq w (cons (getrim!> wx wa wx wb) w)))
	     (putel!> (summa!> w) !#!R!I!C (list2 wa wb)))))))))

% Scalar Curvature ...
(de rscalar!> nil
  (prog (w)
    (fordim!> wa do (fordim!> wb do
      (setq w (cons (multa!> (getimetr!> wa wb)
			     (cond ((or !*torsion !*nonmetr)
					(getel2!> !#!R!I!C wa wb))
				   (t   (getel2s!> !#!R!I!C wa wb))) )
		    w))))
      (setq w (summa!> w))
      (setq !#!R!R (ncons w)) ))

% Einstein Tensor ...
(de gtensor!> nil
  (prog (w)
    (setq !#!G!T (mkt!> 2))
    (fordim!> wa do (fordim!> wb do
      (cond
        ((and (null !*torsion) (null !*nonmetr) (greaterp wa wb)) nil)
	(t (progn
	     (setq w (list2 (getel2!> !#!R!I!C wa wb)
			    (multa!> '(quotient -1 2)
			      (multa!> (getmetr!> wa wb)
				       (car !#!R!R)))))
	     (putel!> (summa!> w) !#!G!T (list2 wa wb)))))))))

%------- Curvature spinors -------------------------------------------------

% local aux functions ...
(de ousu!> (wa wb)
  (dualdi!> (dfprod2!> (getel1!> !#!O!M!E!G!A!U wa)
                       (getel1!> !#!S!U wb))))
(de ousd!> (wa wb)
  (dualdi!> (dfprod2!> (getel1!> !#!O!M!E!G!A!U wa)
                       (getel1!> !#!S!D wb))))
(de odsu!> (wa wb)
  (dualdi!> (dfprod2!> (getel1!> !#!O!M!E!G!A!D wa)
                       (getel1!> !#!S!U wb))))
(de odsd!> (wa wb)
  (dualdi!> (dfprod2!> (getel1!> !#!O!M!E!G!A!D wa)
                       (getel1!> !#!S!D wb))))

% Scalar curvature ...
(de rrsp!> nil
  (prog (wr)
    (cond
      (!*torsion
        (setq wr (summa!>  (list (ousu!> 2 0) (ousu!> 0 2)
			         (multa!> -2 (ousu!> 1 1)))))
        (setq wr (evalalg!>
          (cond (!*torsion (multa!> 2 (list 'plus wr (coalg!> wr))))
	        (t         (multa!> 4 wr))))) )
      (t
	(setq wr (evalalg!> (multa!> 8 (list 'difference
					 (ousu!> 0 2) (ousu!> 1 1))))) ))
    (setq !#!R!R (ncons wr))))

% Scalar deviation ...
(de rdsp!> nil
  (prog (wr)
    (setq wr (summa!>  (list (ousu!> 2 0) (ousu!> 0 2)
			     (multa!> -2 (ousu!> 1 1)))))
    (setq wr (evalalg!>
      (multa!> '(times -2 i) (list 'difference wr (coalg!> wr)))))
    (setq !#!R!D (ncons wr))))

% Weyl spinor ...
(de rwsp!> nil
  (progn
    (makebox!> '!#!R!W)
    (cond
      (!*torsion
        (putel1!> (evalalg!> (ousu!> 0 0))  !#!R!W 0)
        (putel1!> (evalalg!> (multa!> '(quotient 1 2)
                    (list 'plus  (ousu!> 0 1) (ousu!> 1 0))))  !#!R!W 1)
        (putel1!> (evalalg!> (list 'plus
                    (multa!> '(quotient 1 6)
                      (list 'plus  (ousu!> 2 0) (ousu!> 0 2)))
                    (multa!> '(quotient 2 3) (ousu!> 1 1))))   !#!R!W 2)
        (putel1!> (evalalg!> (multa!> '(quotient 1 2)
                    (list 'plus  (ousu!> 1 2) (ousu!> 2 1))))  !#!R!W 3)
        (putel1!> (evalalg!> (ousu!> 2 2))  !#!R!W 4)  )
      (t
        (putel1!> (evalalg!> (ousu!> 0 0))  !#!R!W 0)
        (putel1!> (evalalg!> (ousu!> 0 1))  !#!R!W 1)
        (putel1!> (evalalg!> (list 'plus
                    (multa!> '(quotient 1 3) (ousu!> 0 2))
                    (multa!> '(quotient 2 3) (ousu!> 1 1))))  !#!R!W 2)
        (putel1!> (evalalg!> (ousu!> 1 2))  !#!R!W 3)
        (putel1!> (evalalg!> (ousu!> 2 2))  !#!R!W 4)  )  )
    t))

% Ricanti spinor ...
(de rasp!> nil
  (progn
    (makebox!> '!#!R!A)
    (putel1!> (evalalg!> (multa!> (cond ((mppp!>) 1) (t -1))
                (list 'difference
                  (ousu!> 1 0) (ousu!> 0 1))))  !#!R!A 0)
    (putel1!> (evalalg!> (multa!> (cond ((mppp!>) '(quotient 1 2))
					(t        '(quotient -1 2)))
                (list 'difference
                  (ousu!> 2 0) (ousu!> 0 2))))  !#!R!A 1)
    (putel1!> (evalalg!> (multa!> (cond ((mppp!>) 1) (t -1))
                (list 'difference
                  (ousu!> 2 1) (ousu!> 1 2))))  !#!R!A 2)
    t))

% Traceless ricci spinor ...
(de rcsp!> nil
  (progn
    (makebox!> '!#!R!C)
    (for!> x (0 1 2) do (for!> y (0 1 2) do
      (cond ((leq x y)
        (putel!> (cond (!*torsion (evalalg!> (mpa!> (list 'difference
		                     (ousd!> x y) (odsu!> y x)))))
		       (t (evalalg!> (mpa!> (multa!> 2 (ousd!> x y))))))
		 !#!R!C (list2 x y))))))
    t))

% Traceless deviation spinor ...
(de rbsp!> nil
  (progn
    (makebox!> '!#!R!B)
    (for!> x (0 1 2) do (for!> y (0 1 2) do
      (cond ((leq x y)
        (putel!> (evalalg!> (mpa!> (multa!> 'i (list 'plus
		   (ousd!> x y) (odsu!> y x)))))
		 !#!R!B (list2 x y))))))
    t))

%----- NP formalism via macro 10.96 ---------------------------------------

(de psinp!> (w)
  (getel1!> !#!R!W w))

(de phinp!> (wa wb)
  (prog (w)
    (setq w (cond ((leq wa wb) (getel2!> !#!R!C wa wb))
		  (t  (coalg!> (getel2!> !#!R!C wb wa)))))
    (return (cond (w (list 'times (pma!> '(quotient 1 2)) w))
		  (t nil)))))

(de alphanp!>   nil (pma!>(spcoef!> 1 2)))
(de betanp!>    nil (pma!>(spcoef!> 1 3)))
(de gammanp!>   nil (pma!>(spcoef!> 1 0)))
(de epsilonnp!> nil (pma!>(spcoef!> 1 1)))
(de kappanp!>   nil (pma!>(spcoef!> 0 1)))
(de rhonp!>     nil (pma!>(spcoef!> 0 2)))
(de sigmanp!>   nil (pma!>(spcoef!> 0 3)))
(de taunp!>     nil (pma!>(spcoef!> 0 0)))
(de munp!>      nil (pma!>(spcoef!> 2 3)))
(de nunp!>      nil (pma!>(spcoef!> 2 0)))
(de lambdanp!>  nil (pma!>(spcoef!> 2 2)))
(de pinp!>      nil (pma!>(spcoef!> 2 1)))

(de dtop!>  nil (getiframe!> 0))
(de dddop!> nil (getiframe!> 1))
(de duop!>  nil (getiframe!> 3))
(de ddop!>  nil (getiframe!> 2))

%----- Geosedics. 10.96 ---------------------------------------------------

(de geodesics!> nil
  (prog (w)
    (setq !#!G!E!O!q (mkt!> 1))
    (fordim!> x do (progn
      (setq w (ncons (list 'df (getel1!> ![cord!] x) (car ![apar!]) 2)))
      (fordim!> y do (fordim!> z do
        (setq w (cons (list 'times (chr!> x y z)
			(list 'df (getel1!> ![cord!] y) (car ![apar!]))
			(list 'df (getel1!> ![cord!] z) (car ![apar!])))
		       w))))
      (putel1!> (equation!> (evalalg!> (cons 'plus w)) nil) !#!G!E!O!q x)))))

%----- Null Congruence. 10.96 ---------------------------------------------

(de ncnq!> nil
  (prog (w)
    (setq w (evalalg!> (vprod!> (car !#!K!V) (car !#!K!V))))
    (setq !#!N!C!o (ncons(equation!> w nil)))
    (cond (w (msg!> 6700)))))

% vec'w
(de getncv!> (w)
  (vform1!> (car !#!K!V) (getframe!> w)))
% vec.w
(de getncvlo!> (w)
  (vform1!> (car !#!K!V) (getlo!> !#!T w)))

% Riemann omega'a.b
(de rimomega!> (wa wb)
  (cond ((or !*torsion !*nonmetr) (getel2!> !#!r!o!m!e!g!a wa wb))
        (t                        (getel2!> !#!o!m!e!g!a wa wb))))

% Riemann omega'a.b.c
(de rimomegac!> (wa wb wc)
  (vform1!> (getiframe!> wc) (rimomega!> wa wb)))

(de ncgq!> nil
  (prog (w wc)
    (setq !#!G!C!o (mkt!> 1))
    (fordim!> x do (progn
      (setq w (ncons (vfun!> (car !#!K!V) (getncv!> x))))
      (fordim!> y do
	(setq w (cons (list 'times
			(vform1!> (car !#!K!V) (rimomega!> x y))
			(getncv!> y)) w)))
      (setq w (evalalg!> (cons 'plus w)))
      (cond (w (setq wc t)))
      (putel1!> (equation!> w nil) !#!G!C!o x)))
   (cond (wc (msg!> 6701)))))

% D.a ( vec.b ) = D.a | vec.b - omega'm.b.a vec.m
(de dcnc!> (wa wb)
  (prog (w)
    (setq w (ncons (vfun!> (getiframe!> wa) (getncvlo!> wb))))
    (fordim!> m do
      (setq w (cons (list 'times -1 (rimomegac!> m wb wa)
				    (getncvlo!> m))  w)))
    (setq w (evalalg!> (cons 'plus w)))
    (return w)))

% THETA
(de nctheta!> nil
  (prog (w)
    (fordim!> x do (fordim!> y do
      (setq w (cons (list 'times '(quotient 1 2)
				  (dcnc!> x y)
				  (getimetr!> x y)) w))))
   (setq w (evalalg!> (cons 'plus w)))
   (setq !#!t!h!e!t!a!O (ncons w)) ))

% omega^2
(de ncomega!> nil
  (prog (w wa wb)
    (fordim!> x do (fordim!> y do
      (fordim!> p do (fordim!> q do (progn
	(setq wa (getimetr!> x p))
	(setq wb (getimetr!> y q))
	(cond ((and wa wb)
          (setq w (cons (list 'times '(quotient 1 4) wa wb (dcnc!> p q)
			  (list 'difference (dcnc!> x y) (dcnc!> y x)))
                      w)))))))))
   (setq w (evalalg!> (cons 'plus w)))
   (setq !#!o!m!e!g!a!S!Q!O (ncons w)) ))

% sigma*~sigma
(de ncsigma!> nil
  (prog (w wa wb)
    (fordim!> x do (fordim!> y do
      (fordim!> p do (fordim!> q do (progn
	(setq wa (getimetr!> x p))
	(setq wb (getimetr!> y q))
	(cond ((and wa wb)
          (setq w (cons (list 'times '(quotient 1 4) wa wb (dcnc!> p q)
			  (list 'plus (dcnc!> x y) (dcnc!> y x)))
                      w)))))))))
   (setq w (cons 'plus w))
   (setq w (list 'difference w (list 'expt (car !#!t!h!e!t!a!O) 2)))
   (setq w (evalalg!> w))
   (setq !#!s!i!g!m!a!S!Q!O (ncons w)) ))

%----- Kinematics 10.96 ----------------------------------------------------

% UV = UUP'a D.a
(de uvfromuup!> nil
  (prog (w)
    (fordim!> x do
      (setq w (cons (fndfpr!> (getel1!> !#!U!U x) (getiframe!> x)) w)))
    (setq !#!U!V (ncons (evalform!> (dfsum!> w))))))

% UUp'a = UV _| T'a
(de uupfromuv!> nil
  (prog nil
    (setq !#!U!U (mkt!> 1))
    (fordim!> x do
      (putel1!> (evalalg!> (vform1!> (car !#!U!V) (getframe!> x)))
		!#!U!U x))
    ))

(de uudefault!> nil
  (prog nil
    (setq !#!U!U (mkt!> 1))
    (putel1!> 1	!#!U!U 0)
    (msg!> 6805)
    ))

% USQ = UUP'a UUP.a
(de usquare!> nil
  (prog (w)
    (fordim!> x do
      (setq w (cons (list 'times (getel1!> !#!U!U x)
                                 (getloa!> !#!U!U x)) w)))
    (setq w (evalalg!> (cons 'plus w)))
    (cond ((null w) (setq ![er!] 6702) (return !!er!!))
	  ((eqn (exprtype!> w) 2) (msg!> 9001)))
    (setq !#!U!S!Q (ncons w))))

% PRO'a.b
(de projector!> nil
  (prog (w)
    (setq !#!P!R (mkt!> 2))
    (cond ((null (car !#!U!S!Q)) (setq ![er!] 6702) (return !!er!!)))
    (setq w (list 'quotient 1 (car !#!U!S!Q)))
    (fordim!> a do (fordim!> b do
      (putel!> (evalalg!> (list 'difference (delta!> a b)
			    (list 'times w (getel1!> !#!U!U a)
					   (getloa!> !#!U!U b))))
	       !#!P!R (list2 a b))))))

(de dcuup!> (wa wb)
  (prog (w)
    (setq w (ncons (vfun!> (getiframe!> wa) (getel1!> !#!U!U wb))))
    (fordim!> wm do
      (setq w (cons (list 'times (getel1!> !#!U!U wm)
				 (rimomegac!> wb wm wa)) w)))
    (return (cons 'plus w))))

(de dcudown!> (wa wb)
  (prog (w)
    (setq w (ncons (vfun!> (getiframe!> wa) (getloa!> !#!U!U wb))))
    (fordim!> wm do
      (setq w (cons (list 'times -1 (getloa!> !#!U!U wm)
				    (rimomegac!> wm wb wa)) w)))
    (return (cons 'plus w))))

(de accelerat!> nil
  (prog (w)
     (setq !#!a!c!c!U (mkt!> 1))
     (fordim!> a do (progn
       (setq w nil)
       (fordim!> m do
	 (setq w (cons (list 'times (getel1!> !#!U!U m)
				    (dcuup!> m a)) w)))
       (putel1!> (evalalg!> (cons 'plus w)) !#!a!c!c!U a)))))

(de utheta!> nil
  (prog (w)
    (fordim!> m do (setq w (cons (dcuup!> m m) w)))
    (setq !#!t!h!e!t!a!U (ncons (evalalg!> (cons 'plus w))))))

(de uomega!> nil
  (prog (w)
    (setq !#!o!m!e!g!a!U (mkt!> 2))
    (fordim!> a do (fordim!> b do (cond ((lessp a b)
      (setq w nil)
      (fordim!> m do (fordim!> n do
	(setq w (cons (list 'times '(quotient 1 2)
			(getel2!> !#!P!R m a) (getel2!> !#!P!R n b)
			(list 'difference (dcudown!> m n)
					  (dcudown!> n m))) w))))
      (putel!> (evalalg!> (cons 'plus w)) !#!o!m!e!g!a!U (list2 a b))))))))

(de usigma!> nil
  (prog (w)
    (setq !#!s!i!g!m!a!U (mkt!> 2))
    (fordim!> a do (fordim!> b do (cond ((leq a b)
      (setq w (ncons (list 'times (list 'quotient -1 ![dim1!])
			    (car !#!t!h!e!t!a!U)
			    (getm!> '!#!P!R nil (list2 a b) '(2 nil)))))
      (fordim!> m do (fordim!> n do
	(setq w (cons (list 'times '(quotient 1 2)
			(getel2!> !#!P!R m a) (getel2!> !#!P!R n b)
			(list 'plus (dcudown!> m n)
				    (dcudown!> n m))) w))))
      (putel!> (evalalg!> (cons 'plus w)) !#!s!i!g!m!a!U (list2 a b))))))))


%------- Irreducible torsion components. 01.91 ---------------------------

% Local aux functions ...
(de qsu!> (wq wss)
   (dualdi!> (dfprod2!> (getel1!> !#!T!H!E!T!A wq) (getel1!> !#!S!U wss))))
(de qsd!> (wq wss)
   (dualdi!> (dfprod2!> (getel1!> !#!T!H!E!T!A wq) (getel1!> !#!S!D wss))))

% Tracelass torsion spinor ...
(de qcfromth!> nil
   (progn
     (makebox!> '!#!Q!C)
     (putel!> (evalalg!> (list 'times 1 (qsu!> 0 0)))
              !#!Q!C (list  0 0))
     (putel!> (evalalg!> (list 'times 1 '(quotient -1 3)
              (list 'plus (qsu!> 3 0) (list 'times -2 (qsu!> 0 1)))))
              !#!Q!C (list 1 0))
     (putel!> (evalalg!> (list 'times 1 (qsu!> 1 2)))
              !#!Q!C  (list 3 1))
     (putel!> (evalalg!> (list 'times 1 '(quotient 1 3)
              (list 'plus (qsu!> 0 2) (list 'times -2 (qsu!> 3 1)))))
              !#!Q!C (list 2 0))
     (putel!> (evalalg!> (list 'times -1 (qsu!> 3 2)))
              !#!Q!C  (list 3 0))
     (putel!> (evalalg!> (list 'times 1 '(quotient 1 3)
              (list 'plus (qsu!> 1 0) (list 'times -2 (qsu!> 2 1)))))
              !#!Q!C (list 1 1))
     (putel!> (evalalg!> (list 'times -1 (qsu!> 2 0)))
              !#!Q!C  (list 0 1))
     (putel!> (evalalg!> (list 'times 1 '(quotient -1 3)
              (list 'plus (qsu!> 2 2) (list 'times -2 (qsu!> 1 1)))))
              !#!Q!C (list 2 1))
     t))

% Torsion trace vector with spinors ...
(de qtfromthsp!> nil
   (progn
     (setq !#!Q!T (mkt!> 1))
     (putel1!> (evalalg!> (list 'times (car ![sgn!])
       (list 'plus (qsu!> 1 0) (qsu!> 2 1) (qsd!> 2 1) (qsd!> 0 2))))
       !#!Q!T 2)
     (putel1!> (evalalg!> (list 'times (car ![sgn!]) -1
       (list 'plus (qsu!> 3 1)(qsu!> 0 2)(qsd!> 1 0)(qsd!> 3 1))))
       !#!Q!T 3)
     (putel1!> (evalalg!> (list 'times (car ![sgn!]) -1
       (list 'plus
             (list 'times -1 (list 'plus (qsu!> 3 0) (qsu!> 0 1)))
             (qsd!> 2 0) (qsd!> 0 1))))
       !#!Q!T 0)
     (putel1!> (evalalg!> (list 'times (car ![sgn!]) -1
        (list 'plus
              (qsu!> 1 1) (qsu!> 2 2)
              (list 'times -1 (list 'plus (qsd!> 1 1) (qsd!> 3 2))))))
       !#!Q!T 1)
     t))

% Torsion pseudotrace vector with spinors ...
(de qpfromthsp!> nil
   (progn
     (setq !#!Q!P (mkt!> 1))
     (putel1!> (evalalg!> (list 'times (car ![sgn!]) 'i
       (list 'plus (qsu!> 3 0) (qsu!> 0 1) (qsd!> 2 0) (qsd!> 0 1))))
       !#!Q!P 0)
     (putel1!> (evalalg!>(list 'times (car ![sgn!]) '(minus i)
       (list 'plus (qsu!> 1 1) (qsu!> 2 2) (qsd!> 1 1) (qsd!> 3 2))))
       !#!Q!P 1)
     (putel1!> (evalalg!> (list 'times (car ![sgn!]) 'i
       (list 'plus (list 'times -1
                     (list 'plus (qsu!> 3 1) (qsu!> 0 2)))
                   (qsd!> 1 0) (qsd!> 3 1))))
       !#!Q!P 3)
     (putel1!> (evalalg!>(list 'times (car ![sgn!]) 'i
       (list 'plus (qsu!> 1 0) (qsu!> 2 1)
              (list 'times -1
                (list 'plus (qsd!> 2 1) (qsd!> 0 2))))))
       !#!Q!P 2)
     t))


%---- Undotted torsion 2-forms. 12.91 ------------------------------------

% wd - internal variable, fun - get function, wss - s-forms
(de trfr!> (wd fun wss)
  (prog (w wc)
    (set wd (mkt!> 1))
    (setq wd (eval wd))
    (for!> a (0 1 3) do (progn
      (setq w nil)
      (for!> b (0 1 2) do
        (setq w (cons (fndfpr!> (list 'times (cond ((eqn b 1) -2) (t 1))
                                             (apply fun (list a b)))
                                (getel1!> (eval wss) (si!> b))) w)) )
      (cond (w (putel1!> (evalform!> (dfsum!> w)) wd a)))))
    (return t)))

% local aux function ...
(de si!> (w)
  (cond ((eqn w 1) 1)
        ((eqn w 2) 0)
        ((eqn w 0) 2)))

% Get Traceless Torsion spinor ...
(de gcf!> (wa wb)
  (cond
    ((and (eqn wa 0) (eqn wb 0)) (getel2!> !#!Q!C 0 0))
    ((and (eqn wa 0) (eqn wb 1)) (getel2!> !#!Q!C 1 0))
    ((and (eqn wa 0) (eqn wb 2)) (getel2!> !#!Q!C 2 0))
    ((and (eqn wa 1) (eqn wb 0)) (getel2!> !#!Q!C 1 1))
    ((and (eqn wa 1) (eqn wb 1)) (getel2!> !#!Q!C 2 1))
    ((and (eqn wa 1) (eqn wb 2)) (getel2!> !#!Q!C 3 1))
    ((and (eqn wa 2) (eqn wb 0)) (list 'times -1 (getel2!> !#!Q!C 0 1)))
    ((and (eqn wa 2) (eqn wb 1)) (list 'times -1 (getel2!> !#!Q!C 1 1)))
    ((and (eqn wa 2) (eqn wb 2)) (list 'times -1 (getel2!> !#!Q!C 2 1)))
    ((and (eqn wa 3) (eqn wb 0)) (list 'times -1 (getel2!> !#!Q!C 1 0)))
    ((and (eqn wa 3) (eqn wb 1)) (list 'times -1 (getel2!> !#!Q!C 2 0)))
    ((and (eqn wa 3) (eqn wb 2)) (list 'times -1 (getel2!> !#!Q!C 3 0))) ))

% Get Torsion Trace spinor ...
(de gqf!> (wa wb)
  (gqpf!> wa wb (car ![sgn!]) !#!Q!T))

% Get Torsion Pseudotrace spinor ...
(de gpf!> (wa wb)
  (gqpf!> wa wb (cond ((mppp!>) 'i) (t '(minus i))) !#!Q!P))

(de gqpf!> (wa wb w lst)
  (cond
    ((and (eqn wa 0) (eqn wb 1))
      (list 'times (mkq!> w 6 nil) (getel1!> lst 0)))
    ((and (eqn wa 0) (eqn wb 2))
      (list 'times (mkq!> w 3 t) (getel1!> lst 3)))
    ((and (eqn wa 3) (eqn wb 0))
      (list 'times (mkq!> w 3 nil) (getel1!> lst 0)))
    ((and (eqn wa 3) (eqn wb 1))
      (list 'times (mkq!> w 6 t) (getel1!> lst 3)))
    ((and(eqn wa 2) (eqn wb 1))
      (list 'times (mkq!> w 6 nil) (getel1!> lst 2)))
    ((and (eqn wa 2) (eqn wb 2))
      (list 'times (mkq!> w 3 t) (getel1!> lst 1)))
    ((and (eqn wa 1) (eqn wb 0))
      (list 'times (mkq!> w 3 nil) (getel1!> lst 2)))
    ((and (eqn wa 1) (eqn wb 1))
      (list 'times (mkq!> w 6 t) (getel1!> lst 1))) ))

(de mkq!> (wd wn wb)
  (list 'quotient  (cond (wb (list 'minus wd)) (t wd))  wn))

(de qtfromqq!> nil
  (prog nil
    (makebox!> '!#!Q!T)
    (fordim!> a do
      (putel1!> (evalalg!> (vform1!> (getup!> !#!D a) (car !#!Q!Q)))
		!#!Q!T a))))

(de qpfromqqa!> nil
  (prog (w)
    (makebox!> '!#!Q!P)
    (setq w (dual!> (car !#!Q!Q!A)))
    (fordim!> a do
      (putel1!> (evalalg!> (vform1!> (getup!> !#!D a) w))
		!#!Q!P a))))

%------- Undotted Curvature 2-forms. 01.91 --------------------------------

% wd - internal variable, fun - get function, wss - s-forms
(de crfr!> (wd fun wss)
  (prog (w)
    (set wd (mkspace!> '((n . 2))))
    (for!> a (0 1 2) do (progn
      (setq w nil)
      (for!> b (0 1 2) do
        (setq w(cons(fndfpr!>(list 'times
                                     (cond((eqn b 1) '(minus 2))(t 1))
                                     (apply fun (list a b)))
                             (getel1!> (eval wss) (si!> b)))w)) )
      (cond(w(putel1!>(evalform!>(dfsum!> w)) (eval wd)  a)))))
    (return t)))

% Get Wayl spinor ...
(de gwf!> (wa wb)
   (getel1!> !#!R!W (plus wa wb)))

% Get Traceless Ricci spinor ...
(de gtf!> (wa wb)
   (list 'times (cond ((pmmm!>) '(quotient -1 2))
                      (t        '(quotient 1 2)))
                (getel2h!> !#!R!C wa wb)))

% Get Traceless Deviation spinor ...
(de gbf!> (wa wb)
   (list 'times (cond ((pmmm!>) '(quotient i 2))
                      (t        '(quotient (minus i) 2)))
                (getel2h!> !#!R!B wa wb)))

% Get Scalar Curvature spinor ...
(de gsf!> (wa wb)
   (cond((or(and(eqn wa 0)(eqn wb 2))(and(eqn wa 2)(eqn wb 0)))
           (list 'times '(quotient 1 12) (car !#!R!R)))
        ((and(eqn wa 1)(eqn wb 1))
           (list 'times '(quotient (minus 1) 24)(car !#!R!R)))
        (t nil)))

% Get Scalar Deviation spinor ...
(de gdf!> (wa wb)
   (cond((or(and(eqn wa 0)(eqn wb 2))(and(eqn wa 2)(eqn wb 0)))
           (list 'times '(quotient i 12)(car !#!R!D)))
        ((and(eqn wa 1)(eqn wb 1))
           (list 'times '(quotient (minus i) 24)(car !#!R!D)))
        (t nil)))

% Get Antisymmetric Ricci spinor ...
(de gaf!> (wa wb)
   (cond((and(eqn wa 0)(eqn wb 1))
           (list 'times (sgnm!>) '(quotient -1 2) (getel1!> !#!R!A 0)))
        ((and(eqn wa 0)(eqn wb 2))
           (list 'times (sgnm!>) -1 (getel1!> !#!R!A 1)))
        ((and(eqn wa 1)(eqn wb 0))
           (list 'times (sgnm!>) '(quotient 1 2) (getel1!> !#!R!A 0)))
        ((and(eqn wa 1)(eqn wb 2))
           (list 'times (sgnm!>) '(quotient -1 2)(getel1!> !#!R!A 2)))
        ((and(eqn wa 2)(eqn wb 0))
           (list 'times (sgnm!>) (getel1!> !#!R!A 1)))
        ((and(eqn wa 2)(eqn wb 1))
           (list 'times (sgnm!>) '(quotient 1 2) (getel1!> !#!R!A 2)))
        (t nil)))

% Signature ...
(de sgnm!> nil
  (cond ((pmmm!>) -1) (t 1)))

%=========== End of GRGgeom.sl ============================================%