;;; tensor.lisp       ;;;
;;; (C) Kenrou Adachi ;;;
;;;     2007/2/3      ;;; 


; tensortype(f) ;

(mdefprop $tensortype
  ((lambda) ((mlist) $f)
    ((mprog) ((mlist) $ttyp $ttmp) 
      ((msetq) $ttmp (($copylist) $f))
      ((msetq) $ttyp (($cons) (($length) $ttmp) ((mlist))))

      ((mdefine) (($rectyp) $typ $tmp)
        ((mprog) ((msetq) $tmp (($first) $tmp))
          ((mcond)
            (($listp) $tmp)
              ((mprogn)
                ((msetq) $typ (($cons) (($length) $tmp) $typ))
                (($rectyp) $typ $tmp))
            t
              $typ)))

      (($reverse) (($rectyp) $ttyp $ttmp))))
mexpr)

(add2lnc '(($tensortype) $f) $functions)


; tensorrank(f) ;

(mdefprop $tensorrank
  ((lambda) ((mlist) $f)
    (($length) (($tensortype) $f))) mexpr)

(add2lnc '(($tensorrank) $f) $functions)


; zerotensor(ttype) ;

(mdefprop $zerotensor
  ((lambda) ((mlist) $ttype)
    ((mprog) ((mlist) $rr $rk $rst $rtyp $tt1 $tt2)
      ((msetq) $rr (($length) $ttype))
      ((msetq) $tt1 ((mlist)))
      ((msetq) $rtyp (($reverse) $ttype))
      ((msetq) $rk (($first) $rtyp))
      ((msetq) $rst (($rest) $rtyp))

      ((mdo) $i 1 nil nil $rk nil
        ((msetq) $tt1 (($cons) 0 $tt1)))
      ((mcond)
        ((mnot) ((mequal) $rst ((mlist))))
          ((mprogn)
            ((msetq) $rk (($first) $rst))
            ((mdo) $j 2 nil nil $rr NIL
              ((mprogn)
                ((msetq) $tt2 ((mlist)))
                ((mdo) $i 1 nil nil $rk nil
                  ((msetq) $tt2 (($cons) $tt1 $tt2)))
                ((msetq) $tt1 $tt2)
                ((msetq) $rst (($rest) $rst))
                ((mcond)
                  ((mnot)
                    ((mequal) $rst ((mlist))))
                      ((msetq) $rk (($first) $rst))
                    t
                      $false))))
        t
          $false)
      $tt1))
mexpr)

(add2lnc '(($zerotensor) $ttype) $functions)


; rp(a, b) ;

(mdefprop $rp
  ((lambda) ((mlist) $a $b)
    ((mprog)
      ((mcond)
        ((mnot) (($listp) (($first) $a)))
          (($maplist) ((lambda) ((mlist) $x) ((mtimes) $x $b)) $a)
        t
          (($maplist) ((lambda) ((mlist) $x) (($rp) $x $b)) $a))))
mexpr)

(Add2lnc '(($rp) $a $b) $functions)


; infix("ot") ;

(defprop $ot %ot verb)
(defprop $ot &ot op)
(defprop &ot $ot opr)

(add2lnc '&ot $props)


; a ot b := rp(a, b) ;

(define-symbol '&ot)
(defprop $ot dimension-infix dimension)
(defprop $ot (#\Space #\O #\T #\Space) dissym)
(defprop $ot msize-infix grind)
(defprop $ot 180 lbp)
(defprop $ot 180 rbp)
(defprop $ot parse-infix led)
(defprop %ot dimension-infix dimension)
(defprop %ot (#\Space #\O #\T #\Space) dissym)

(mdefprop $ot
  ((lambda) ((mlist) $a $b)
    (($rp) $a $b)) mexpr)

(add2lnc '(($ot) $a $b) $functions)

(defprop %ot $ot noun)

; simplistp(f) ; 

(mdefprop $simplistp
  ((lambda) ((mlist) $f)
    ((mprog)
      ((mcond)
        ((mnot)
          (($listp) (($first) $f)))
            t
          t
            nil)))
mexpr)

(add2lnc '(($simplistp) $f) $functions)


; tvcntrct(a, b) ;

(mdefprop $tvcntrct
  ((lambda) ((mlist) $a $b)
    ((mprog)
      ((mcond)
        (($simplistp) $a)
          (($inprod) $a $b)
        t
          ((mcond)
            (($simplistp) (($first) $a))
              (($maplist) ((lambda) ((mlist) $x) (($inprod) $x $b)) $a)
            t
              (($maplist) ((lambda) ((mlist) $x) (($tvcntrct) $x $b)) $a)))))
mexpr)

(add2lnc '(($tvcntrct) $a $b) $functions)
; infix("tvc") ;

(defprop $tvc %tvc verb)
(defprop $tvc &tvc op)
(defprop &tvc $tvc opr)

(add2lnc '&tvc $props)


; a tvc b := tvcntrct(a, b) ;

(define-symbol '&tvc)
(defprop $tvc dimension-infix dimension)
(defprop $tvc (#\Space #\T #\V #\C #\Space) dissym)
(defprop $tvc msize-infix grind)
(defprop $tvc 180 lbp)
(defprop $tvc 180 rbp)
(defprop $tvc parse-infix led)
(defprop %tvc dimension-infix dimension)
(defprop %tvc (#\Space #\T #\V #\C #\Space) dissym)

(mdefprop $tvc
  ((lambda) ((mlist) $a $b)
    (($tvcntrct) $a $b))
mexpr)

(add2lnc '(($tvc) $a $b) $functions)

(defprop %tvc $tvc noun)


; exchinext(a) ;

(mdefprop $exchinext
  ((lambda) ((mlist) $a)
    ((mprog) ((mlist) $b $c $ni $nip)
      ((msetq) $ni (($length) $a))
      ((msetq) $nip (($length) (($a array) 1)))
      ((msetq) $b ((mlist)))
      ((mdo) $j 1 nil nil $nip nil
        ((mprogn)
          ((msetq) $c ((mlist)))
          ((mdo) $k 1 nil nil $ni nil
            ((msetq) $c (($endcons) ((mqapply array) (($a array) $k) $j) $c)))
          ((msetq) $b (($endcons) $c $b))))
      $b))
mexpr)

(add2lnc '(($exchinext) $a) $functions)


; exchnext(a, i) ;

(mdefprop $exchnext
  ((lambda) ((mlist) $a $i)
    ((mprog) ((mlist) $n)
      ((msetq) $n (($tensorrank) $a))
      ((mcond)
        ((mor) ((mgreaterp) $i ((mplus) $n ((mminus) 1))) ((mlessp) $i 1))
          ((mprogn)
            (($print) |&Index is out of range|) nil)
        t
          ((mcond)
            ((mequal) $i 1)
              (($exchinext) $a)
            t
              (($maplist)
                ((lambda) ((mlist) $x)
                  (($exchnext) $x ((mplus) $i ((mminus) 1)))) $a)))))
mexpr)

(add2lnc '(($exchnext) $a $i) $functions)


; exchttype(a, i, j) ;

(mdefprop $exchttype
  ((lambda) ((mlist) $a $i $j)
    ((mprog) ((mlist) $b)
      ((mcond)
        ((mequal) $i $j)
          ((mprogn)
            (($print) |&Invalid indices|) nil)
        t
          ((mcond)
            ((mgreaterp) $i $j)
              (($exchttype) $a $j $i)
            t
              ((mcond)
                ((mequal) $j ((mplus) $i 1))
                  (($exchnext) $a $i)
                t
                  ((mprogn)
                    ((msetq) $b (($copylist) $a))
                    ((mdo) $k $i nil nil ((mplus) $j ((mminus) 1)) nil
                      ((msetq) $b (($exchnext) $b $k)))
                    ((mdo) $k ((mplus) $j ((mminus) 2)) ((mminus) 1) nil $i nil
                      ((msetq) $b (($exchnext) $b $k)))
                    $b))))))
mexpr)

(add2lnc '(($exchttype) $a $i $j) $functions)


; simpsqmatp(a) ;

(mdefprop $simpsqmatp
  ((lambda) ((mlist) $a)
    ((mprog)
      ((mcond)
        (($listp) ((mqapply array) (($a array) 1) 1))
          nil
        t
          ((mcond)
            ((mnot) ((mequal) (($length) $a) (($length) (($a array) 1))))
              nil
            t
              t))))
mexpr)

(add2lnc '(($simpsqmatp) $a) $functions)


; cntrmat(a) ;

(mdefprop $cntrmat
  ((lambda) ((mlist) $a)
    ((mprog) ((mlist) $n $tra)
      ((mcond)
        ((mnot) (($simpsqmatp) $a))
          ((mprogn)
            (($print) |&The indices are not square-matrix-like|) nil)
        t
          ((mprogn)
            ((msetq) $n (($length) $a))
            ((msetq)
              $tra (($sum) ((mqapply array) (($a array) $i) $i) $i 1 $n))
            $tra))))
mexpr)

(add2lnc '(($cntrmat) $a) $functions)


; cntrlst2(a) ;

(mdefprop $cntrlst2
  ((lambda) ((mlist) $a)
    ((mprog)
      ((mcond)
        (($simpsqmatp) $a)
          (($cntrmat) $a)
        t
         (($maplist) ((lambda) ((mlist) $x) (($cntrlst2) $x)) $a))))
mexpr)

(add2lnc '(($cntrlst2) $a) $functions)


(mdefprop $cntrct
  ((lambda) ((mlist) $a $i $j)
    ((mprog) ((mlist) $n $b $c)
      ((msetq) $n (($tensorrank) $a))
      ((mcond)
       ((mor) ((mequal) $i $j) ((mlessp) $i 1) ((mgreaterp) $i $n)
                               ((mlessp) $j 1) ((mgreaterp) $j $n))
         ((mprogn)
           (($print) |&Invalid indices|) nil)
         t
           ((mcond)
             ((mgreaterp) $i $j)
               (($cntrct) $a $j $i)
             t
               ((mcond)
                 ((mequal) $i ((mplus) $n ((mminus) 1)))
                   (($cntrlst2) $a)
                 t
                   ((mprogn)
                     ((msetq) $b (($copylist) $a))
                     ((mcond)
                       ((mnot) ((mequal) $j $n))
                         ((mdo) $p $j NIL NIL ((mplus) $n ((mminus) 1)) nil
                           ((msetq) $b (($exchnext) $b $p)))
                       t
                         $false)
                     ((mcond)
                       ((mnot) ((mequal) $i ((mplus) $n ((mminus) 1))))
                         ((mdo) $p $i nil nil ((mplus) $n ((mminus) 2)) nil
                           ((msetq) $B (($exchnext) $b $p)))
                       t
                         $false)
                     ((msetq) $c (($cntrlst2) $b)) $c))))))
mexpr)

(add2lnc '(($cntrct) $a $i $j) $functions)

;;; end of tensor.lisp ;;;