;; GAMMA GAMMA GAMMA GAMMA GAMMA GAMMA GAMMA
;; GAMMA GAMMA GAMMA GAMMA GAMMA GAMMA GAMMA
;; GAMMA GAMMA GAMMA GAMMA GAMMA GAMMA GAMMA

(IN-PACKAGE "COMMON-LISP-USER")

(provide "gamma")


;; TYPES

(DEFUN SGM-P (object)
   ;; SGM = SiGMa   
   (declare (type any object))
   (the boolean
     (and (consp object)
          (typep (car object) 'fixnum)
          (typep (cdr object) 'cmbn))))

(DEFTYPE SGM () '(satisfies sgm-p))

(DEFUN IGAMMA-P (object)
   ;; IGAMMA = Internal GAMMA,
   ;;   without the keyword and the degree
   (declare (type any object))
   (the boolean
     (and (listp object)
          (every #'sgm-p object)))) 

(DEFTYPE IGAMMA () '(satisfies igamma-p))

(DEFUN GAMMA-P (object)
   (declare (type any object))
   (the boolean
     (and (consp object)
          (eql (car object) :gamma)
          (consp (cdr object))
          (typep (second object) 'fixnum)
          (typep (cddr object) 'igamma))))

(DEFTYPE GAMMA () '(satisfies gamma-p))



;; MACROS

(DEFMACRO SGM (sgop cmbn)
   `(cons ,sgop ,cmbn))

(DEFMACRO -SGM (mark)
   `(car ,mark))

(DEFMACRO SGOP (sgm)
   `(car ,sgm))

(DEFMACRO -SGOP (mark)
   `(caar ,mark))

(DEFMACRO SGCM (sgm)
   `(cdr ,sgm))

(DEFMACRO -SGCM (mark)
   `(cdar ,mark))

(DEFMACRO WITH-SGM ((sgop-var sgcm-var) sgm . body)
   `(let ((,sgop-var (sgop ,sgm))
          (,sgcm-var (sgcm ,sgm)))
       (declare
          (fixnum ,sgop-var)
          (type cmbn ,sgcm-var))
       ,@body))

(DEFMACRO WITH--SGM ((sgop-var sgcm-var) mark . body)
   `(let ((,sgop-var (-sgop ,mark))
          (,sgcm-var (-sgcm ,mark)))
       (declare
          (fixnum ,sgop-var)
          (type cmbn ,sgcm-var))
       ,@body))

(DEFMACRO SGM-NON-ZERO-P (sgm)
   `(cmbn-non-zero-p (sgcm ,sgm)))

(DEFMACRO SGM-ZERO-P (sgm)
  `(cmbn-zero-p (sgcm ,sgm)))

(DEFMACRO MAKE-GAMMA (&key degr list)
   `(cons :gamma
       (cons ,degr ,list)))

(DEFMACRO GAMMA-DEGR (gmm)
   `(cadr ,gmm))

(DEFMACRO GAMMA-LIST (gmm)
   `(cddr ,gmm))

(DEFMACRO WITH-GAMMA ((degr list) gmm . body)
   `(let ((,degr (gamma-degr ,gmm))
          (,list (gamma-list ,gmm)))
       (declare
          (fixnum ,degr)
          (list ,list))
       ,@body))

(DEFMACRO SGM-GAMMA (degr sgop sgcm)
   `(cons :gamma (cons ,degr (cons (cons ,sgop ,sgcm) nil))))

(DEFMACRO GAMMA-NON-ZERO-P (gmm)
   `(gamma-list ,gmm)) 

(DEFMACRO GAMMA-ZERO-P (gmm)
  `(null (gamma-list ,gmm)))


#|(DEFMETHOD PRINT-KEYCONS ((key (eql :sgm)) cdr stream)
   (setf cdr (cons :sgm cdr))
   (format stream
      "<Sgm ~A ~A>"
      (hyphenize-list (dgop-int-ext (sgop cdr)))
      (sgcm cdr))
   cdr)
|#


;; METHODS

(DEFMETHOD PRINT-KEYCONS ((key (eql :gamma)) cdr stream)
   (declare
    (list cdr)
    (stream stream))
   (the (eql t)
     (let ((degr (first cdr))
           (list (rest cdr)))
        (declare
         (fixnum degr)
         (list list))
        (format stream "<GAMMA ~D" degr)
        (do ((mark list (cdr mark))
             (nth 0 (1+ nth)))
            ((endp mark))
           (declare
            (list mark)
            (fixnum nth))
           (when (and *print-length* (= nth *print-length*))
              (format stream "~%... ...")
              (return))
           (format stream "~%  <~D  ~A  >" (hyphenize-list (dgop-int-ext (sgop (car mark)))) (sgcm (car mark))))
        (format stream "~%>" )
        t)))


;; ELEMENTARY OPERATIONS WITH GAMMA ELEMENTS
 
(DEFUN GAMMA-ELT (degr &rest rest)
   (declare (fixnum degr))
   (the gamma
     (let ((rslt (list degr :gamma)))
        (do ((mark rest (cddr mark)))
            ((endp mark) (nreverse rslt))
           (declare (list mark))
           (push (sgm (car mark) (cadr mark)) rslt)))))

(DEFUN CHECK-GAMMA (gmm)
  (declare
   (type gamma gmm))
  (the boolean
    (with-gamma (degr glist) gmm
      (declare
       (fixnum degr)
       (list glist))
      (do ((mark2 glist mark1)
           (mark1 (rest glist) (cdr mark1)))
          ((endp mark1) t)
         (declare
          (list mark1 mark2))
         (unless (= degr (+ (length (dgop-int-ext (-sgop mark2))) (cmbn-degr (-sgcm mark2))))
            (error "In CHECK-GAMMA, bad degre; the element:~@
                ~A~@
                has a degree different to:~@
                ~A."
	       (-sgm mark2) degr))
         (unless (< (-sgop mark2) (-sgop mark1))
            (error "In CHECK-GAMMA, bad order; the degeneracy operator:~@
                ~A~@
                is not less than the degeneracy operator:~@
                ~A."
              (dgop-int-ext (-sgop mark2)) (dgop-int-ext (-sgop mark1))))))))

#|
(setf g1 (gamma-elt 5 3 (cmbn 3 8 'a) 1 (cmbn 4 3 'b)))
(check-gamma g1)
(setf g2 (gamma-elt 5 3 (cmbn 4 3 'b) 1 (cmbn 3 8 'a)))
(check-gamma g2)
(setf g3 (gamma-elt 5 1 (cmbn 4 3 'b) 3 (cmbn 3 8 'a)))
(check-gamma g3)
(setf g4 (gamma-elt 5))
(check-gamma g4)
|#

(DEFUN ZERO-GAMMA (degr)
   (declare (fixnum degr))
   (the gamma
     (make-gamma
      :degr degr
      :list +empty-list+)))

#|
(setf g0 (zero-gamma 3))
(check-gamma g0) 
|#

(DEFUN GAMMA-OPPS (gmm)
   (declare (type gamma gmm))
   (the gamma
      (with-gamma (degr glist) gmm
         (make-gamma
            :degr degr
            :list (mapcar #'(lambda (sgm)
                               (declare (type sgm sgm))
                               (with-sgm (sgop cmbn) sgm
                                  (sgm sgop (cmbn-opps cmbn))))
                     glist)))))

#|
(setf g (gamma-elt 5 1 (cmbn 4 3 'b 8 'c) 3 (cmbn 3 8 'a -9 'b)))
(gamma-opps g)
|# 

(DEFUN 2GAMMA-ADD (cmpr gmm1 gmm2)
   (declare
    (type cmprf cmpr)
    (type gamma gmm1 gmm2))
   (the gamma
     (with-gamma (degr1 list1) gmm1
       (with-gamma (degr2 list2) gmm2
         (declare
          (fixnum degr1 degr2)
          (list list1 list2))
         (unless (= degr1 degr2)
            (error "In 2GAMMA-ADD, the gamma elements have different degrees ~D and ~D."
              degr1 degr2))
         (unless list1
            (return-from 2gamma-add gmm2))
         (unless list2
            (return-from 2gamma-add gmm1))
         (let ((pre-rslt +empty-list+))
            (declare (list pre-rslt))
            (do ((mark1 list1)
                 (mark2 list2))
                ((or (endp mark1) (endp mark2))
                 (if mark1
                    (setf pre-rslt (nreconc pre-rslt mark1))
                    (if mark2
                       (setf pre-rslt (nreconc pre-rslt mark2))
                       (setf pre-rslt (nreverse pre-rslt)))))
               (declare (list mark1 mark2))
               (with--sgm (sgop1 cmbn1) mark1
                 (with--sgm (sgop2 cmbn2) mark2
                   (declare 
                     (fixnum sgop1 sgop2)
                     (type cmbn cmbn1 cmbn2))
                   (if (= sgop1 sgop2)
                      (let ((cmbn (2cmbn-add cmpr cmbn1 cmbn2)))
                         (declare (type cmbn cmbn))
                         (unless (cmbn-zero-p cmbn)
                            (push (sgm sgop1 cmbn) pre-rslt))
                         (setf mark1 (cdr mark1)
                               mark2 (cdr mark2)))
                      (if (< sgop1 sgop2)
                         (progn
                          (push (-sgm mark1) pre-rslt)
                          (setf mark1 (cdr mark1)))
                         (progn
                          (push (-sgm mark2) pre-rslt)
                          (setf mark2 (cdr mark2))))))))
            (make-gamma :degr degr1 :list pre-rslt))))))

#|
(setf g1 (gamma-elt 5 1 (cmbn 4 3 'b -5 'd) 3 (cmbn 3 8 'a -7 'c)))
(setf g2 (gamma-elt 5 0 (cmbn 5 3 'a 8 'c) 1 (cmbn 4 2 'b 9 'c) 
           2 (cmbn 4 -5 'a) 3 (cmbn 3 -4 'a 8 'b)))
(setf g3 (2GAMMA-ADD #'s-cmpr g1 g2))
(setf g4 (gamma-elt 5 0 (cmbn 5 -3 'a -8 'c) 1 (cmbn 4 -2 'b 8 'c)
           3 (cmbn 3 5 'a -8 'b 7 'c)))
(setf g5 (2GAMMA-ADD #'s-cmpr g3 g4))
(setf g6 (gamma-elt 5 1 (cmbn 4 -3 'b -17 'c 5 'd) 2 (cmbn 4 5 'a) 3 (cmbn 3 -9 'a)))
(2GAMMA-ADD #'s-cmpr g5 g6)
|#  

(defun ADD-SGM-TO-GAMMA (cmpr sgm gmm)
   (declare
    (type cmprf cmpr)
    (type sgm sgm)
    (type gamma gmm))
   (the gamma
     (with-sgm (sgop sgcm) sgm
       (declare 
         (fixnum sgop)
         (type cmbn sgcm))
       (with-gamma (degr glist) gmm
         (declare 
           (fixnum degr)
           (list glist))
         (let ((pre-rslt +empty-list+))
            (declare (list pre-rslt))
            (do ((mark glist (cdr mark)))
                ((or (endp mark) (equal nil sgop))
                 (if sgop
                  (progn
                   (push sgm pre-rslt)
                   (setf pre-rslt (nreverse pre-rslt)))
                    (setf pre-rslt (nreconc pre-rslt mark))))
               (declare (list mark))
               (with--sgm (sgop2 sgcm2) mark
                 (declare 
                   (fixnum sgop2)
                   (type cmbn sgcm2))
                 (if (= sgop sgop2)
                    (let ((cmbn (2cmbn-add cmpr sgcm sgcm2)))
                       (declare (type cmbn cmbn))
                       (unless (cmbn-zero-p cmbn)
                          (push (sgm sgop cmbn) pre-rslt))
                       (setf sgop nil))
                    (if (< sgop sgop2)
                       (progn 
                         (push sgm pre-rslt)
                         (setf sgop nil)
                         (push (-sgm mark) pre-rslt))
                       (push (-sgm mark) pre-rslt)))))
            (make-gamma :degr degr :list pre-rslt))))))

 #|
(setf g1 (gamma-elt 5 1 (cmbn 4 3 'b -5 'd) 3 (cmbn 3 8 'a -7 'c)))
(setf g2 (add-sgm-to-gamma cmpr (sgm 7 (cmbn 2 -8 'd)) g1))
(setf g3 (add-sgm-to-gamma cmpr (sgm 7 (cmbn 2 8 'd)) g2))
(setf g4 (add-sgm-to-gamma cmpr (sgm 3 (cmbn 3 -8 'a 7 'c 8 'd)) g2))
(setf g5 (add-sgm-to-gamma cmpr (sgm 11 (cmbn 2 9 'a )) g4))
(setf g6 (add-sgm-to-gamma cmpr (sgm 9 (cmbn 3 8 'b)) g5))
(setf g7 (add-sgm-to-gamma cmpr (sgm 9 (cmbn 3 -8 'b 8 'c)) g6))
(setf g8 (add-sgm-to-gamma cmpr (sgm 9 (cmbn 3 -8 'b )) g6))
|# 

(DEFUN NSGM-ADD (cmpr degr &rest rest)
   (declare
      (type cmprf cmpr)
      (fixnum degr)
      (list rest))
   (unless rest
      (return-from nsgm-add (zero-gamma degr)))
   (the gamma
      (let ((rslt (list (first rest))))
         (declare (list rslt))
         (dolist (sgm (rest rest))
            (declare (type sgm sgm))
            (with-sgm  (sgop sgcm) sgm
               (do ((mark1 rslt (cdr mark1))
                    (mark2 nil mark1))
                   ((endp mark1) 
                    (setf (cdr mark2) (list sgm)))
                  (ecase (funcall #'f-cmpr sgop (-sgop mark1))
                     (:less
                      (if mark2
                         (push sgm (cdr mark2))
                         (push sgm rslt))
                      (return))                     
                     (:equal
                      (let ((cmbn2 (2cmbn-add cmpr (-sgcm mark1) sgcm)))
                         (setf (-sgcm mark1) cmbn2))
                      (return))                     
                     (:greater )))))
         (make-gamma
          :degr degr
          :list (flet ((sgm-zero-p (sgm)
                        (let ((sgcm (sgcm sgm)))
                           (cmbn-zero-p sgcm))))
                  (remove-if #'sgm-zero-p rslt))))))

 #|
(setf cmpr #'s-cmpr)
(setf degr 5)
(progn 
  (setf sgm1 (sgm 7 (cmbn 2 3 'a 5 'b)))
  (setf sgm2 (sgm 4 (cmbn 4 7 'a 8 'c)))
  (setf sgm3 (sgm 12 (cmbn 3 -5 'a 8 'b)))
  (setf sgm4 (sgm 4 (cmbn 4 -7 'a 9 'c 12 'd)))
  (setf sgm5 (sgm 6 (cmbn 3 8 'a)))
  (setf sgm6 (sgm 12 (cmbn 3 6 'a)))
  (nsgm-add cmpr degr sgm1 sgm2 sgm3 sgm4 sgm5 sgm6))

(progn 
  (setf sgm1 (sgm 7 (cmbn 2 3 'a 5 'b)))
  (setf sgm2 (sgm 4 (cmbn 4 7 'a 8 'c)))
  (setf sgm3 (sgm 12 (cmbn 3 -5 'a 8 'b)))
  (setf sgm4 (sgm 4 (cmbn 4 -7 'a 9 'c 12 'd)))
  (setf sgm5 (sgm 6 (cmbn 3 8 'a)))
  (setf sgm6 (sgm 12 (cmbn 3 6 'a)))
  (setf sgm7 (sgm 12 (cmbn 3 -6 'a)))
  (nsgm-add cmpr degr sgm1 sgm2 sgm3 sgm4 sgm5 sgm6 sgm7))

(progn 
  (setf sgm1 (sgm 7 (cmbn 2 3 'a 5 'b)))
  (setf sgm2 (sgm 4 (cmbn 4 7 'a 8 'c)))
  (setf sgm3 (sgm 12 (cmbn 3 -5 'a 8 'b)))
  (setf sgm4 (sgm 4 (cmbn 4 -7 'a 9 'c 12 'd)))
  (setf sgm5 (sgm 6 (cmbn 3 8 'a)))
  (setf sgm6 (sgm 12 (cmbn 3 6 'a)))
  (setf sgm7 (sgm 7 (cmbn 2 -3 'a -5 'b)))
  (nsgm-add cmpr degr sgm1 sgm2 sgm3 sgm4 sgm5 sgm6 sgm7))

(progn 
  (setf sgm1 (sgm 7 (cmbn 2 3 'a 5 'b)))
  (setf sgm2 (sgm 7 (cmbn 2 -3 'a -5 'b)))
  (nsgm-add cmpr degr sgm1 sgm2))

|#  


(DEFUN SGM-NDGNR (dgop sgm)
   (declare
      (fixnum dgop)
      (type sgm sgm))
   (the sgm
      (with-sgm (sgop sgcm) sgm
         (sgm (dgop*dgop dgop sgop) sgcm)))) 

#|
(setf sgm (sgm 5 (cmbn 2 5 'a)))
(sgm-ndgnr 2 sgm)
(sgm-ndgnr 1 sgm)
(sgm-ndgnr 5 sgm)
|# 

(DEFUN GAMMA-NDGNR (dgop gmm)
   (declare
      (fixnum dgop)
      (type gamma gmm))
   (the gamma
      (with-gamma (degr glist) gmm
        (let ((pre-rslt (mapcar #'(lambda (sgm)
                          (sgm-ndgnr dgop sgm))
                          glist))
              (degr2 (+ degr (length (dgop-int-ext dgop)))))
           (make-gamma :degr degr2 :list pre-rslt)))))

#|
(setf g (gamma-elt 5 3 (cmbn 3 7 'a) 11 (cmbn 2 -4 'b)))
(gamma-ndgnr 2 g)
(gamma-ndgnr 8 g)
(gamma-ndgnr 3 g)

|# 
        


 
;; FUNCTIONS FOR THE CONSTRUCTION OF THE SIMPLICIAL ABELIAN GROUP
;; \GAMMA(C) 
 
(DEFUN GAMMA-TO-ABSM (gmm)
   (declare (type gamma gmm))
   (the absm
     (with-gamma (degr glist) gmm
       (declare (fixnum degr)
         (list glist))
       (if (endp glist)
          (let ((dgop (dgop-ext-int (reverse (<a-b< 0 degr)))))
             (declare (fixnum dgop))
             (absm dgop (gamma-elt 0)))
          (let* ((sgop-list (mapcar #'(lambda (sgm)
                                        (sgop sgm))
                              glist))
                 (dgop (first sgop-list)))
             (declare
              (type list sgop-list)
              (fixnum dgop))
             (progn
              (do ((mark1 (cdr sgop-list) (cdr mark1)))
                  ((endp mark1))
                 (declare (list mark1))
                 (setf dgop (logand dgop (car mark1))))
              (let* ((degr2 (- degr (length (dgop-int-ext dgop))))
                     (pre-rslt +empty-list+))
                 (declare (fixnum degr2)
                   (type list pre-rslt))
                 (do ((mark2 glist (cdr mark2)))
                     ((endp mark2))
                    (declare (list mark2))
                    (with--sgm (sgop sgcm) mark2
                      (declare (fixnum sgop)
                        (type cmbn sgcm))
                      (let ((sgop2 sgop))
                          (declare (fixnum sgop2))
                         (progn
                          (do ((indx (1- (integer-length dgop)) (1- indx)))
                              ((minusp indx))
                             (declare (fixnum indx))
                              (when (logbitp indx dgop)
                                 (setf sgop2 (remove-bit sgop2 indx))))
                          (push (sgm sgop2 sgcm) pre-rslt)))))
                 (absm dgop (make-gamma :degr degr2
                              :list (nreverse pre-rslt))))))))))



#|
 (setf gmm (gamma-elt 5 3 (cmbn 3 6 'a) 7 (cmbn 2 -8 'c)))
(gamma-to-absm gmm)

(setf gmm2 (gamma-elt 5 3 (cmbn 3 6 'a) 7 (cmbn 2 -8 'c) 11 (cmbn 2 6 'a)))
(gamma-to-absm gmm2)
|#
     

(DEFUN CMBN-CMPR (cmpr)
   (declare (type cmprf cmpr))
   (flet ((rslt (cmbn1 cmbn2)
            (declare (type cmbn cmbn1 cmbn2))
            (let ((degr1 (cmbn-degr cmbn1))
                  (degr2 (cmbn-degr cmbn2)))
               (declare (fixnum degr1 degr2))
               (unless (= degr1 degr2)
                  (error "In CMBN-CMPR, the two combinations have different degrees ~D and ~D."
                    degr1 degr2))
               (flet ((term-cmpr (term1 term2)
                        (with-term (cffc1 gnrt1) term1
                          (with-term (cffc2 gnrt2) term2
                            (declare (fixnum cffc1 cffc2)
                              (type gnrt gnrt1 gnrt2))
                            (lexico
                             (f-cmpr cffc1 cffc2)
                             (funcall cmpr gnrt1 gnrt2))))))
                 (maplexico #'term-cmpr (cmbn-list cmbn1) (cmbn-list cmbn2))))))
     (the cmprf #'rslt)))
 
(DEFUN GAMMA-CMPR (cmpr)
   (declare (type cmprf cmpr))
   (let ((c-cmpr (cmbn-cmpr cmpr)))
      (declare (type cmprf c-cmpr))
      (flet ((rslt (gmm1 gmm2)
               (declare (type gamma gmm1 gmm2))
               (flet ((sgm-cmpr (sgm1 sgm2)
                       (declare (type sgm sgm1 sgm2))
                       (with-sgm (sgop1 cmbn1) sgm1
                         (with-sgm (sgop2 cmbn2) sgm2
                           (declare
                            (fixnum sgop1 sgop2)
                            (type cmbn cmbn1 cmbn2))
                           (lexico
                            (f-cmpr sgop1 sgop2)
                            (funcall c-cmpr cmbn1 cmbn2))))))
                 (maplexico #'sgm-cmpr (gamma-list gmm1) (gamma-list gmm2)))))
     (the cmprf #'rslt))))   

#|
(setf g-cmpr (gamma-cmpr #'s-cmpr))
(setf g1 (gamma-elt 3 1 (cmbn 2 3 'a) 3 (cmbn 1 5 'b)))
(setf g2 (gamma-elt 3 1 (cmbn 2 3 'a) 3 (cmbn 1 8 'b)))
(funcall g-cmpr g1 g2)
(funcall g-cmpr g2 g1)
(setf g3 (gamma-elt 3 2 (cmbn 2 3 'a) 3 (cmbn 1 5 'b)))
(funcall g-cmpr g1 g3)
(funcall g-cmpr g2 g3)
(funcall g-cmpr g2 g2)
(setf g4 (gamma-elt 3 2 (cmbn 2 3 'b) 3 (cmbn 1 5 'b)))
(funcall g-cmpr g4 g3)
(setf g5 (gamma-elt 3 2 (cmbn 2 3 'b)))
(funcall g-cmpr g5 g3)
(funcall g-cmpr g5 g4)
|# 



(defun sgm-face (dffr)
   (declare (type morphism dffr))
   (flet ((rslt (indx dmns sgm)
            (declare 
              (fixnum indx dmns)
              (type sgm sgm))
            (the sgm 
              (with-sgm (sgop sgcm) sgm
                (declare 
                  (fixnum sgop)
                  (type cmbn sgcm))
                (let* ((ext-sgop (dgop-int-ext sgop))
                       (k (length ext-sgop))
                       (r (- dmns k))
                       (c-degr (cmbn-degr sgcm)))
                   (declare
                    (type list ext-sgop)
                    (fixnum k r c-degr))
                   (unless (= r c-degr)
                      (error "In SGM-FACE, the degree of the Sigma element ~D is different to the degree introduced ~D."
                        (+ c-degr k) dmns))
                   (multiple-value-bind (dgop 1dlop) (1dlop-dgop indx sgop)
                      (declare (fixnum dgop 1dlop))                     
                      (if (not 1dlop)
                         (SGM dgop sgcm)
                         (if (= r 1dlop)
                          (let ((cmbn (? dffr sgcm)))
                             (declare (type cmbn cmbn))
                             (SGM dgop cmbn))
                            (sgm dgop (cmbn (1- r)))
                            ))))))))
     (the face #'rslt)))


 
(DEFUN GAMMA-FACE (cmpr dffr)
   (declare 
     (type cmprf cmpr)
     (type morphism dffr))
   (let ((sgm-f (sgm-face dffr)))
      (flet ((rslt (indx dmns gmsm)
               (declare
                (fixnum indx dmns)
                (type gamma gmsm))
               (the absm
                 (let ((pre-rslt nil))
                    (do ((mark (gamma-list gmsm) (cdr mark)))
                        ((endp mark) (setf pre-rslt (nreverse pre-rslt)))
                       (declare 
                         (type list mark))
                       (let ((sgm (-sgm mark)))
                          (let ((sface (funcall sgm-f indx dmns sgm)))
                             (if (sgm-non-zero-p sface)
                                (push sface pre-rslt)))))
                    (gamma-to-absm (apply #'nsgm-add cmpr (1- dmns) pre-rslt))))))
        (the face #'rslt))))


#|
(setf d3 (delta 3))
(setf cmpr (cmpr d3))
(setf dffr (dffr d3))

(setf sface (sgm-face dffr))
(setf s1 (sgm 3 (cmbn 2 5 7 -8 13)))
(dotimes (i 5)
   (print (funcall sface i 4 s1)))

(setf s2 (sgm 23 (cmbn 3 -7 15)))
(dotimes (i 8)
   (print (funcall sface i 7 s2)))

(setf gface (gamma-face cmpr dffr))
(setf g1 (sgm-gamma 4 3 (cmbn 2 5 7 -8 13)))
(dotimes (i 5)
   (print i)
   (print (funcall gface i 4 g1)))

(setf g2 (sgm-gamma 7 23 (cmbn 3 -7 15)))
(dotimes (i 8)
   (print i)
   (print (funcall gface i 7 g2)))

(setf g3 (sgm-gamma 7 59 (cmbn 2 1 7 -5 13 6 14)))
(setf g4 (2gamma-add cmpr g2 g3))

(dotimes (i 8)
   (print i)
   (print (funcall gface i 7 g3)))

(setf g5 (sgm-gamma 7 27 (cmbn 3 1 15)))
(setf g6 (2gamma-add cmpr g2 g5))
(dotimes (i 8)
   (print i)
   (print (funcall gface i 7 g6)))
|# 

(defun gamma-grml (cmpr)
   (flet ((rslt (dmns crpr)
            (the absm
              (with-crpr (dgop1 gmm1 dgop2 gmm2) crpr
                (let ((sgm-list1 +empty-list+)
                      (sgm-list2 +empty-list+)
                      (k1 (length (dgop-int-ext dgop1)))
                      (k2 (length (dgop-int-ext dgop2)))
                      (g1 (gamma-elt 0))
                      (g2 (gamma-elt 0)))
                   (with-gamma (degr1 glist1) gmm1
                     (do ((mark1 glist1 (cdr mark1)))
                         ((endp mark1))
                        (with--sgm (sgop1 sgcm1) mark1 
                          (push (sgm (dgop*dgop dgop1 sgop1) sgcm1) sgm-list1)))
                     (setf g1 (make-gamma :degr (+ degr1 k1)
                                :list (nreverse sgm-list1))))
                   (with-gamma (degr2 glist2) gmm2
                     (do ((mark2 glist2 (cdr mark2)))
                         ((endp mark2))
                        (with--sgm (sgop2 sgcm2) mark2 
                          (push (sgm (dgop*dgop dgop2 sgop2) sgcm2) sgm-list2)))
                     (setf g2 (make-gamma :degr (+ degr2 k2)
                                :list (nreverse sgm-list2))))
                   (gamma-to-absm (2gamma-add cmpr g1 g2)))))))
     #'rslt))

#|
(setf ggrml (gamma-grml cmpr))
(funcall ggrml 9 (crpr 136 g3 9 g4))

(funcall ggrml 7 (crpr 0 g3 0 g4))
(funcall ggrml 7 (crpr 0 g3 0 (gamma-opps g4)))
|# 

(defun gamma-grin (dmns gmm)
   (the absm
     (absm 0 (gamma-opps gmm))))


#|
(gamma-grin 7 g3)
(gamma-grin 7 g4)
|# 
 
  
(defun gamma-chcm (x)
   (declare (type simplicial-set x))
   (the ab-simplicial-group
     (let* ((x-cmpr (cmpr x))
            (x-dffr (dffr x))
            (x-orgn (orgn x))
            (cmpr (gamma-cmpr x-cmpr))
            (bspn (gamma-elt 0))
            (face (gamma-face x-cmpr x-dffr))
            (sintr-grml (gamma-grml x-cmpr)))
        (build-ab-smgr
         :cmpr cmpr
         :basis :locally-effective
         :bspn bspn
         :face face
         :bndr-strt :gnrt
         :dgnl-strt :gnrt
         :sintr-grml sintr-grml
         :sintr-grin #'gamma-grin
         :orgn `(GAMMA ,x)
         ))))


#|
(setf d2 (delta 2)) 
(setf gamma-d2 (gamma-chcm d2))
(basis gamma-d2 2)
(orgn gamma-d2)
(setf g1 (gamma-elt 5 7 (cmbn 2 3 7) 11 (cmbn 2 -9 13)))
(setf g2 (gamma-elt 5 7 (cmbn 2 -3 7) 9 (cmbn 3 -5 15)))
(cmpr gamma-d2 g1 g2)
(cmpr gamma-d2 g2 g1)
(setf g3 (2gamma-add (cmpr d2) g1 g2))
(cmpr gamma-d2 g1 g3)
(cmpr gamma-d2 g2 g3)
(bspn gamma-d2)
(dotimes (i 6)
   (print i)
   (print (face gamma-d2 i 5 g3)))
(grml gamma-d2 5 (crpr 0 g2 0 (gamma-opps g3)))
(grin gamma-d2 5 g1)

|# 



;; GAMMA APPLIED TO A MORPHISM

(defun gamma-sintr (f)
   (declare (type morphism f))
   (flet ((rslt (dmns gmm)
            (declare 
              (fixnum dmns)
              (type gamma gmm))
            (the absm
              (with-gamma (degr glist) gmm
                (declare 
                  (fixnum degr)
                  (list glist))
                (let ((pre-rslt +empty-list+))
                   (declare (list pre-rslt))
                   (do ((mark glist (cdr mark)))
                       ((endp mark))
                      (declare (list mark))
                      (with--sgm (sgop sgcm) mark
                        (declare
                         (fixnum sgop)
                         (type cmbn sgcm))
                        (let ((sgm2 (sgm sgop (? f sgcm))))
                           (declare (type sgm sgm2))
                           (if (sgm-non-zero-p sgm2)
                              (push sgm2 pre-rslt)))))
                   (gamma-to-absm (make-gamma :degr degr :list (nreverse pre-rslt))))))))
     #'rslt))
                    
#|
(setf d3 (delta 3))
(setf f (idnt-mrph d3))
(setf gamma-f (gamma-sintr f))
(setf gmm1 (gamma-elt 5 5 (cmbn 3 7 15) 26 (cmbn 2 -3 11)))
(funcall gamma-f 5 gmm1)

(setf g (opps f))
(setf gamma-g (gamma-sintr g))
(funcall gamma-g 5 g1)

(setf f+g (add f g))
(setf gamma-fg (gamma-sintr f+g))
(funcall gamma-fg 5 g1)

|#  

(defun gamma-mrph (f)
   (declare (type morphism f))
   (the simplicial-mrph
     (let ((sorc (sorc f))
           (trgt (trgt f))
           (degr (degr f)))
        (unless (= degr 0)
           (error "In GAMMA-MRPH, the morphism has degree ~D different to zero."
             degr))
        (build-smmr
         :sorc (gamma-chcm sorc)
         :trgt (gamma-chcm trgt)
         :degr degr
         :sintr (gamma-sintr f)
         :orgn `(GAMMA ,f)))))

#|
(setf gamma-f (gamma-mrph f))
(? gamma-f 5 g1)
(setf g2 (gamma-elt 5 5 (cmbn 3 -7 15) 10 (cmbn 3 7 15)))
(? gamma-f 5 g2)
(? gamma-f 5 (2gamma-add (cmpr d3) g1 g2))
(? gamma-f (cmbn 5 1 g2 1 g1))
|#


(defun sgm-hintr (cmpr h d)
   (declare 
     (type cmprf cmpr)
     (type morphism h d))
   (labels ((rslt (indx dmns sgm)
            (declare 
              (fixnum indx dmns)
              (type sgm sgm))
            (the gamma
              (with-sgm (sgop sgcm) sgm
                (declare 
                  (fixnum sgop)
                  (type cmbn sgcm))
                (if (= 0 sgop)
                   (let ((degr (cmbn-degr sgcm)))
                      (declare (fixnum degr))
                      (if (= degr indx)
                         (let* ((sgm1 (sgm 0 (cmbn-opps (? h sgcm))))
                                (sgm2 (sgm (dgop-ext-int (list indx)) (2cmbn-add cmpr sgcm (cmbn-opps (? h (? d sgcm))))))
                                (glist +empty-list+))
                            (declare 
                              (type sgm sgm1 sgm2)
                              (list glist))
                            (if (sgm-non-zero-p sgm2)
                               (push sgm2 glist))
                            (if (sgm-non-zero-p sgm1)
                               (push sgm1 glist))
                            (make-gamma :degr (1+ dmns)
                              :list glist))
                         (if (= (1- degr) indx)
                            (let* ((sgm1 (sgm (dgop-ext-int (list indx)) sgcm))
                                   (sgm2 (sgm (dgop-ext-int (list degr)) (cmbn-opps (? h (? d sgcm)))))
                                   (glist +empty-list+))
                               (declare 
                                 (type sgm sgm1 sgm2)
                                 (list glist))
                               (if (sgm-non-zero-p sgm2)
                                  (push sgm2 glist))
                               (if (sgm-non-zero-p sgm1)
                                  (push sgm1 glist))
                               (make-gamma :degr (1+ dmns)
                                 :list glist))
                            (sgm-gamma (1+ dmns) (dgop-ext-int (list indx)) sgcm))))
                   (let* ((dgop1-ext (first (dgop-int-ext sgop)))
                          (dgop2 (remove-bit sgop dgop1-ext))
                          (sgm2 (sgm dgop2 sgcm)))
                      (declare
                       (fixnum dgop1-ext dgop2)
                       (type sgm sgm2))
                      (if (>= dgop1-ext indx)
                         (let ((smhmt-i (rslt indx (1- dmns)  (sgm dgop2 sgcm))))
                            (declare (type gamma smhmt-i))
                            (gamma-ndgnr (dgop-ext-int (list (1+ dgop1-ext))) smhmt-i))
                         (let ((smhmt-i-1 (rslt (1- indx) (1- dmns)  sgm2)))
                            (declare (type gamma smhmt-i-1))
                            (gamma-ndgnr (dgop-ext-int (list dgop1-ext)) smhmt-i-1)))))))))
     (the hintr #'rslt)))
     
#|
(setf d3 (delta 3))
(setf d (dffr d3))
(setf h (lh (efhm d3)))
(setf cmpr #'f-cmpr)

(setf sgm-smhmt (sgm-hintr cmpr h d))
(setf sgm (sgm 5 (cmbn 3 -7 15)))
(dotimes (indx 6)
   (print (funcall sgm-smhmt indx 5 sgm)))

(setf sgm2 (sgm 11 (cmbn 2 7 7)))
(dotimes (indx 6)
   (print (funcall sgm-smhmt indx 5 sgm2)))


|# 


(defun gamma-hintr (cmpr h d)
   (declare 
     (type morphism h d)
     (type cmprf cmpr))
   (let ((s-hintr (sgm-hintr cmpr h d)))
      (flet ((rslt (indx dmns gmsm)
               (declare 
                 (type fixnum indx dmns)
                 (type gamma gmsm))
               (let ((rslt (gamma-elt (1+ dmns))))
                  (do ((mark (gamma-list gmsm) (cdr mark)))
                      ((endp mark) (gamma-to-absm rslt))
                     (setf rslt (2gamma-add cmpr rslt (funcall s-hintr indx dmns (-sgm mark))))))))
      (the hintr #'rslt))))
             

#|
(setf d3 (delta 3))
(setf d (dffr d3))
(setf h (lh (efhm d3)))

(setf gmm (gamma-elt 5 5 (cmbn 3 -7 15) 11 (cmbn 2 7 7)))
(setf cmpr #'f-cmpr)

(setf g-hintr (gamma-hintr cmpr h d))
(dotimes (indx 6)
   (print (funcall g-hintr indx 5 gmm)))

|# 
           

(defun gamma-hmtp (h)
   (declare (type morphism h))
   (the simplicial-hmtp
     (let* ((cc (sorc h))
            (gamma-cc (gamma-chcm cc))
            (degr (degr h))
            (cmpr (cmpr cc))
            (dffr (dffr cc))
            (orgn (orgn cc)))
        (declare
         (type chain-complex cc)
         (type ab-simplicial-group gamma-cc)
         (fixnum degr)
         (type cmprf cmpr)
         (type morphism dffr))
        (unless (= degr 1)
           (error "In GAMMA-HMTP, the morphism has degree ~D different to +1."
             degr))
        (build-smhmt
         :sorc gamma-cc
         :trgt gamma-cc
         :degr 1
         :hintr (gamma-hintr cmpr h dffr)
         :orgn `(GAMMA ,orgn)))))

#|
(setf d3 (delta 3))
(setf h (lh (efhm d3)))
(setf gamma-h (gamma-hmtp h))
(setf gmm (gamma-elt 5 5 (cmbn 3 -7 15) 11 (cmbn 2 7 7)))
(dotimes (i 6)
  (print (? gamma-h i 5 gmm)) )

(setf i 0)
(? gamma-h i 5 gmm)

(? gamma-h 5 gmm)

|# 
 
#|
(defun deltan-h (n)
   (the morphism
     (let ((delta-n (delta n)))
        (build-mrph
         :sorc delta-n
         :trgt delta-n
         :degr +1
         :intr #'(lambda (degr gmsm)
                   (if (oddp gmsm)
                      (zero-cmbn (1+ degr))
                      (term-cmbn (1+ degr) 1 (1+ gmsm))))
                   :strt :gnrt
                   :orgn `(homotopy for delta ,n)))))

(setf h5 (deltan-h 5))
(? h5 3 15)
(? h5 3 30)
(? h5 3 39)

(setf gmm-d5-h (gamma-hmtp h5))

(setf g1 (gamma-elt 3 0 (cmbn 3 1 15)))
(dotimes (indx 4)
   (print (? gmm-d5-h indx 3 g1)))

(setf g2 (gamma-elt 3 0 (cmbn 3 1 46)))
(dotimes (indx 4)
   (print (? gmm-d5-h indx 3 g2)))

(setf g3 (gamma-elt 5 5 (cmbn 3 -7 15)))
(dotimes (indx 6)
   (print (? gmm-d5-h indx 5 g3)))

(dotimes (i 6)
   (dotimes (j 7)
      (format t "i= ~D, j= ~D" i j)
      (print (? gmm-d5-h j 6 (? gmm-d3-h i 5 g3)))))

(setf g4 (gamma-elt 5 11 (cmbn 2 1 14)))
(dotimes (indx 6)
   (print (? gmm-d5-h indx 5 g4)))

(setf g5 (2gamma-add #'f-cmpr g3 g4))
(dotimes (indx 6)
   (print (? gmm-d5-h indx 5 g5)))

(setf g6 (2gamma-add #'f-cmpr g5 (gamma-elt 5 0 (cmbn 5 2 63))))
(dotimes (indx 6)
   (print (? gmm-d5-h indx 5 g6)))
|#


(defun gamma-rdct (rdct)
   (declare (type reduction rdct))
   (the reduction
     (let ((f (f rdct))
           (g (g rdct))
           (h (h rdct))
           (orgn (orgn rdct)))
        (declare
         (type morphism f g h)
         (list orgn))
        (build-rdct
         :f (gamma-mrph f)
         :g (gamma-mrph g)
         :h (gamma-hmtp h)
         :orgn `(gamma ,orgn)))))

#|
(setf d3 (delta 3))
(setf rdct (lrdct (efhm d3)))
(setf grdct (gamma-rdct rdct))

(setf d5 (delta 5))
(setf z (z-chcm))
(setf f (build-mrph
         :sorc d5
         :trgt z
         :degr 0
         :intr #'(lambda (dmns gnrt)
                   (if (and (= dmns 0) (= gnrt 1))
                      (cmbn 0 1 :zgnrt)
                      (cmbn dmns)))
         :strt :gnrt
         :orgn `(trivial-morphism from ,d5 to ,z)))
      
(setf g (build-mrph
         :sorc z
         :trgt d5
         :degr 0
         :intr #'(lambda (dmns gnrt)
                   (if (equal gnrt :z-gnrt)
                      (cmbn 0 1 1)
                      (cmbn dmns)))
         :strt :gnrt
         :orgn `(trivial-morphism from ,z to ,d5)))

(setf h (deltan-h 5))
(setf rdct5 (build-rdct :f f :g g :h h :orgn `(contraction-homotopy ,d5)))
(setf grdct5 (gamma-rdct rdct5))

(pre-check-rdct grdct5)
(setf *tc* (cmbn 5 1 (gamma-elt 5 0 (cmbn 5 2 63) 5 (cmbn 3 -7 15) 11 (cmbn 2 1 14)))) 
(setf *bc* (cmbn 0 1 (gamma-elt 0 0 (cmbn 0 1 :z-gnrt))))
(check-rdct)

(setf *tc* (cmbn 3 1 (gamma-elt 3 0 (cmbn 3 -6 27 2 43) 5 (cmbn 1 8 9) 7 (cmbn 0 7 8 1 32)) 6 
             (gamma-elt 3 0 (cmbn 3 1 15) 5 (cmbn 1 -7 5 6 18) 6 (cmbn 1 6 12 -3 18 4 20) 7 (cmbn 0 8 16 -3 32))
))

(check-rdct)




|# 
   

(DEFMETHOD GAMMA ((chcm chain-complex))
   (gamma-chcm chcm))

(DEFMETHOD GAMMA ((rdct reduction))
   (gamma-rdct rdct))