;;;  K-PI-1  K-PI-1  K-PI-1  K-PI-1  K-PI-1  K-PI-1  K-PI-1
;;;  K-PI-1  K-PI-1  K-PI-1  K-PI-1  K-PI-1  K-PI-1  K-PI-1
;;;  K-PI-1  K-PI-1  K-PI-1  K-PI-1  K-PI-1  K-PI-1  K-PI-1

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

(PROVIDE "k-pi-1")

(DEFUN K-Z-1-CMPR (gnrt1 gnrt2)
   (declare (list gnrt1 gnrt2))
   (the cmpr
   (do ((mark1 gnrt1 (cdr mark1))
	(mark2 gnrt2 (cdr mark2)))
       ((endp mark1) :equal)
       (case (f-cmpr (car mark1) (car mark2))
	  (:equal)
	  (:less (return-from k-z-1-cmpr :less))
	  (:greater (return-from k-z-1-cmpr :greater))))))

#|
  (k-z-1-cmpr '(1 1 2) '(1 2 2))
  (k-z-1-cmpr '(1 1 2) '(1 1 2))
  (k-z-1-cmpr '(1 1 2) '(1 1 -1))
|#

(DEFUN K-Z-1-FACE (indx dmns gmsm)
   (declare
      (fixnum indx dmns)
      (list gmsm))
   (the absm
   (cond ((zerop indx) (absm 0 (rest gmsm)))
	 ((= indx dmns) (absm 0 (butlast gmsm)))
	 (t
	  (do ((rslt +empty-list+ (cons (car mark) rslt))
	       (mark gmsm (cdr mark))
	       (i 1 (1+ i)))
	      ((= i indx) (let ((new-k (+ (car mark) (cadr mark))))
			    (declare (fixnum new-k))
			    (if (zerop new-k)
			       (absm (2-exp (1- indx)) (nreconc rslt (cddr mark)))
			       (absm 0 (nreconc rslt (cons new-k (cddr mark)))))))
	     (declare
	        (list rslt mark)
		(fixnum i)))))))

#|
  (k-z-1-face 0 1 '(3))
  (k-z-1-face 1 1 '(3))
  (k-z-1-face 0 3 '(1 2 3))
  (k-z-1-face 1 3 '(1 2 3))
  (k-z-1-face 2 3 '(1 2 3))
  (k-z-1-face 2 3 '(1 2 -2))
  (k-z-1-face 3 3 '(1 2 3))
|#

(DEFUN Z-ABSM-BAR (absm)
  (declare (type absm absm))
  (the list
    (with-absm (dgop bar1) absm
      (do ((dgop dgop (ash dgop -1))
	   (rslt +empty-list+))
	  ((and (zerop dgop) (endp bar1)) (nreverse rslt))
	  (declare
	     (fixnum dgop)
	     (list rslt))
	  (push (if (oddp dgop)
		    0
		  (pop bar1))
		rslt)))))

#|
  (z-absm-bar (absm 0 '()))
  (z-absm-bar (absm 1 '()))
  (z-absm-bar (absm 0 '(2)))
  (dotimes (i 8)
    (print (z-absm-bar (absm i '(3 6)))))
|#

(DEFUN Z-BAR-ABSM (bar)
  (declare (list bar))
  (the absm
     (do ((rslt-dgop 0)
	  (rslt-bar +empty-list+)
	  (mark bar (cdr mark))
	  (bark 1 (+ bark bark)))
	 ((endp mark) (absm rslt-dgop (nreverse rslt-bar)))
	(declare
	   (fixnum rslt-dgop bark)
	   (list rslt-bar mark))
	(let ((k-i (car mark)))
	  (declare (fixnum k-i))
	  (if (zerop k-i)
	     (incf rslt-dgop bark)
	     (push k-i rslt-bar))))))

#|
  (z-bar-absm (z-absm-bar (absm 0 '())))
  (z-bar-absm (z-absm-bar (absm 1 '())))
  (z-bar-absm (z-absm-bar (absm 0 '(2))))
  (dotimes (i 8)
    (print (z-bar-absm (z-absm-bar (absm i '(3 6))))))
|#

(DEFUN K-Z-1-GRML (dmns crpr)
   (declare
      (fixnum dmns)
      (type crpr crpr))
   (the absm
      (with-crpr (dgop1 bar1 dgop2 bar2) crpr
	 (do ((indx 1 (1+ indx))
	      (dgop1 dgop1 (ash dgop1 -1))
	      (dgop2 dgop2 (ash dgop2 -1))
	      (bark 1 (ash bark +1))
	      (rslt-dgop 0)
	      (rslt-bar +empty-list+))
	     ((> indx dmns) (absm rslt-dgop (nreverse rslt-bar)))
	     (declare
	        (fixnum indx dgop1 dgop2 bark rslt-dgop)
		(list rslt-bar))
	     (let ((item (if (evenp dgop1)
			     (if (evenp dgop2)
				 (+ (pop bar1) (pop bar2))
			       (pop bar1))
			   (if (evenp dgop2)
			       (pop bar2)
			     0))))
	       (declare (fixnum item))
	       (if (zerop item)
		   (incf rslt-dgop bark)
		 (push item rslt-bar)))))))

#|
  (k-z-1-grml 0 (crpr 0 nil 0 nil))
  (k-z-1-grml 1 (crpr 0 '(3) 0 '(4)))
  (k-z-1-grml 1 (crpr 0 '(3) 0 '(-3)))
  (k-z-1-grml 1 (crpr 0 '(3) 1 '()))
  (k-z-1-grml 1 (crpr 1 '() 0 '(3)))
  (k-z-1-grml 1 (crpr 1 '() 1 '()))
  (k-z-1-grml 5 (crpr 24 '(2 2 3) 20 '(-2 2 4)))
|#

(DEFUN K-Z-1-GRIN (dmns bar)
  (declare
     (ignore dmns)
     (list bar))
  (the absm
     (absm 0 (mapcar #'- bar))))

#|
  (k-z-1-grin 3 '(2 3 -4))
  (setf gmsm '(2 3 -4))
  (k-z-1-grml 3 (crpr 0 gmsm 0 (gmsm (k-z-1-grin 3 gmsm))))
|#

#|
(DEFUN K-Z-1-KFLL (indx dmns hat)
  (declare
     (fixnum indx dmns)
     (list hat))
  (the absm
     (cond ((= 1 dmns)
	    (absm 1 +empty-list+))
	   ((zerop indx)
	    (let ((del-1 (first hat))
		  (del-2 (second hat)))
	      (declare (type absm del-1 del-2))
	      (with-absm (dgop1 bar1) del-1
	      (with-absm (dgop2 bar2) del-2
		 (let ((bar01 (if (oddp dgop2)
				 0
				 (first bar2)))
		       (bar02 (if (oddp dgop1)
				 0
				 (first bar1))))
		   (declare (fixnum bar01 bar02))
		   (let ((bar12 (- bar02 bar01)))
		     (declare (fixnum bar02))
		     (if (zerop bar01)
			(1dgnr 0 del-1)
		        (if (zerop bar12)
			   (1gnr 1 del-1)
			   (let (del-01 (k-z-1-face 0 (1- dmns)
						    del-1))
			     (declare (type absm del-01))
			     (with-absm (dgop01 gmsm01) del-01
				(absm (* 4 dgop01)
				      (cons bar01
					    (cons bar02 gmsm01)))))))))))))
	   ((= 1 indx)
	    (let ((del-0 (first hat))
		  (del-2 (second hat)))
	      (declare (type absm del-0 del-2))
	      (with-absm (dgop0 gmsm0) del-0
	      (with-absm (dgop2 gmsm2) del-2
		 (if (oddp dgop2 )))))))))

|#

(DEFUN K-Z-1 ()
  (the ab-simplicial-group
     (build-ab-smgr
        :cmpr #'k-z-1-cmpr
	:basis :locally-effective
	:bspn +empty-list+
	:face #'k-z-1-face
	:sintr-grml #'k-z-1-grml
	:sintr-grin #'k-z-1-grin
	:orgn '(k-z-1))))

#|
  (setf k (k-z-1))
  (defun aleat-list (max length)
     (let ((rslt nil)
           (2max (+ max max)))
        (dotimes (i length)
           (push (let ((k (- (random 2max) max)))
                    (if (zerop k)
                       max
                       k))
              rslt))
        rslt))
  (? k (? k 14 (aleat-list 200 14)))
  (setf zero? (add (idnt-mrph k) (grin k)))
  (? zero? 14 (aleat-list 200 14))
|#

(DEFUN K-Z (n)
   (declare (fixnum n))
   (the ab-simplicial-group
      (if (= n 1)
         (k-z-1)
         (classifying-space (k-z (1- n))))))

(DEFUN CIRCLE-CMPR (gnrt1 gnrt2)
   (declare (ignore gnrt1 gnrt2))
   (the cmpr :equal))

(DEFUN CIRCLE-BASIS (dmns)
   (declare (fixnum dmns))
   (the list
      (case dmns
	 (0 '(*))
	 (1 '(s1))
	 (otherwise +empty-list+))))

(DEFUN CIRCLE ()
   (the chain-complex
      (build-chcm
         :cmpr #'circle-cmpr
	 :basis #'circle-basis
	 :bsgn '*
	 :intr-dffr #'zero-intr-dffr
	 :strt :cmbn
	 :orgn '(circle))))

#|
  (setf c (circle))
  (cmpr c '* '*)
  (basis c 1)
  (? c 1 's1)
|#

(DEFUN KZ1-RDCT-F-INTR (cmbn)
  (declare (type cmbn cmbn))
  (the cmbn
     (with-cmbn (degr list) cmbn
	(case degr
	   (0 (if list
		 (term-cmbn 0 (-cffc list) '*)
		 (zero-cmbn 0)))
	   (1 (let ((rslt
		     (apply #'+
			(mapcar
			 #'(lambda (term)
			     (declare (type term term))
			     (with-term (cffc gnrt) term
					(the fixnum (* cffc
						       (first gnrt)))))
			 list))))
		(if (zerop rslt)
		    (zero-cmbn 1)
		  (term-cmbn 1 rslt 's1))))
	   (otherwise (zero-cmbn degr))))))

#|
  (kz1-rdct-f-intr (cmbn 0))
  (kz1-rdct-f-intr (cmbn 0 4 '()))
  (kz1-rdct-f-intr (cmbn 1))
  (kz1-rdct-f-intr (cmbn 1 4 '(3)))
  (kz1-rdct-f-intr (cmbn 1 4 '(3) 5 '(2)))
  (kz1-rdct-f-intr (cmbn 1 4 '(3) -3 '(4)))
  (kz1-rdct-f-intr (cmbn -3))
|#

(DEFUN KZ1-RDCT-F ()
  (the morphism
     (build-mrph
        :sorc (k-z-1)
	:trgt (circle)
	:degr 0
	:intr #'kz1-rdct-f-intr
	:strt :cmbn
	:orgn '(kz1-rdct-f))))

(DEFUN KZ1-RDCT-G-INTR (cmbn)
  (declare (type cmbn cmbn))
  (the cmbn
     (with-cmbn (degr list) cmbn
	(if list
	    (ecase degr
	       (0 (term-cmbn 0 (-cffc list) +empty-list+))
	       (1 (term-cmbn 1 (-cffc list) (list 1))))
	  (zero-cmbn degr)))))

(DEFUN KZ1-RDCT-G ()
  (the morphism
     (build-mrph
        :sorc (circle)
	:trgt (k-z-1)
	:degr 0
	:intr #'kz1-rdct-g-intr
	:strt :cmbn
	:orgn '(kz1-rdct-g))))

(DEFUN KZ1-RDCT-H-INTR (dmns bar)
  (declare
     (fixnum dmns)
     (list bar))
  (the cmbn
     (progn
       (when (zerop dmns)
	  (return-from kz1-rdct-h-intr (zero-cmbn +1)))
       (let ((k1 (first bar))
	     (tail (rest bar)))
	 (declare
	    (fixnum k1)
	    (list tail))
	 (if (plusp k1)
	    (do ((rslt +empty-list+
		       (cons (term -1
				   (cons 1 (cons i tail)))
			     rslt))
		 (i (1- k1) (1- i)))
		((zerop i) (make-cmbn :degr (1+ dmns)
				      :list rslt))
	       (declare
		  (list rslt)
		  (fixnum i)))
	    (do ((rslt +empty-list+
		       (cons (term +1
				   (cons 1 (cons i tail)))
			     rslt))
		 (i -1 (1- i)))
		((< i k1) (make-cmbn :degr (1+ dmns)
				     :list rslt))))))))

#|
  (kz1-rdct-h-intr 0 nil)
  (kz1-rdct-h-intr 1 '(-4))
  (kz1-rdct-h-intr 1 '(-1))
  (kz1-rdct-h-intr 1 '(1))
  (kz1-rdct-h-intr 1 '(4))
  (kz1-rdct-h-intr 3 '(-4 3 5))
  (kz1-rdct-h-intr 3 '(-1 3 -1))
  (kz1-rdct-h-intr 3 '(1 2 2))
  (kz1-rdct-h-intr 3 '(4 3 5))
|#

(DEFUN KZ1-RDCT-H ()
  (the morphism
     (build-mrph
        :sorc (k-z-1)
	:trgt (k-z-1)
	:degr +1
	:intr #'kz1-rdct-h-intr
	:strt :gnrt
	:orgn '(kz1-rdct-h))))

(DEFUN KZ1-RDCT ()
  (the reduction
     (build-rdct
        :f (kz1-rdct-f)
	:g (kz1-rdct-g)
	:h (kz1-rdct-h)
	:orgn '(kz1-rdct))))

#|
  (pre-check-rdct (kz1-rdct))
  (setf *tc* (cmbn 0 1 '()))
  (setf *bc* (cmbn 0 1 '*))
  (check-rdct)
  (setf *tc* (cmbn 1 1 '(-4) 10 '(-1) 100 '(1) 1000 '(5)))
  (setf *bc* (cmbn 1 1 's1))
  (check-rdct)
  (setf *tc* (cmbn 2 1 '(-4 2) 10 '(-1 3) 100 '(1 -4) 1000 '(5 5)))
  (check-rdct)
  (setf *tc* (cmbn 3 1 '(-4 -4 5) 10 '(-1 2 1)
                     100 '(1 4 2) 1000 '(5 1 -1)))
  (check-rdct)
|#

(DEFUN KZ1-EFHM ()
  (the homotopy-equivalence
     (build-hmeq
        :lrdct (trivial-rdct (k-z-1))
	:rrdct (kz1-rdct)
	:orgn '(kz1-efhm))))

(DEFMETHOD SEARCH-EFHM (k-z-1 (orgn (eql 'k-z-1)))
  (declare (ignore k-z-1))
  (kz1-efhm))

#|
  (cat-init)
  (homology (k-z-1) 1)
|#

(DEFUN K-Z2-1-GRML-INTR (dmns crpr)
  (declare
     (fixnum dmns)
     (type crpr crpr))
  (the absm
     (with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr
	(declare (ignore gmsm1 gmsm2))
	(let ((dgop (- (mask dmns) (logxor dgop1 dgop2))))
	  (declare (fixnum dgop))
	  (absm dgop (- dmns (logcount dgop)))))))

(DEFUN K-Z2-1-GRML ()
  (the simplicial-mrph
     (build-smmr
        :sorc (crts-prdc (r-proj-space) (r-proj-space))
	:trgt (r-proj-space)
	:degr 0
	:sintr #'k-z2-1-grml-intr
	:orgn '(k-z2-1-grml))))

(DEFUN K-Z2-1-GRIN-INTR (dmns gmsm)
  (declare
     (ignore dmns)
     (fixnum gmsm))
  (the absm
     (absm 0 gmsm)))

(DEFUN K-Z2-1-GRIN ()
  (the simplicial-mrph
     (build-smmr
        :sorc (r-proj-space)
	:trgt (r-proj-space)
	:degr 0
	:sintr #'k-z2-1-grin-intr
	:intr #'identity
	:strt :cmbn
	:orgn '(k-z2-1-grin))))

(DEFUN K-Z2-1 ()
  (the ab-simplicial-group
     (let ((rslt (r-proj-space)))
       (declare (type simplicial-set rslt))
       (change-class rslt 'ab-simplicial-group)
       (setf (slot-value rslt 'grml)
	     (k-z2-1-grml)
	     (slot-value rslt 'grin)
	     (k-z2-1-grin))
       (pushnew rslt *smgr-list*)
       rslt)))

#|
  (setf k (k-z2-1))
  (homology k 0 4)
|#

(DEFUN K-Z2 (n)
   (declare (fixnum n))
   (the ab-simplicial-group
      (if (= n 1)
         (k-z2-1)
         (classifying-space (k-z2 (1- n))))))

#|
  (setf k3 (k-z2 3))
  (homology k3 7)
|#

(DEFUN Z2-ABSM-BAR (absm)
  (declare (type absm absm))
  (the list
     (with-absm (dgop gmsm) absm
       (do ((bmark (1- (+ (logcount dgop) gmsm)) (1- bmark))
	    (rslt +empty-list+
		  (cons (if (logbitp bmark dgop)
			    0 1)
			rslt)))
	   ((minusp bmark) rslt)
	  (declare
	     (fixnum bmark)
	     (list rslt))))))

(DEFUN Z2-BAR-ABSM (bar)
  (declare (list bar))
  (the absm
     (do ((dgop 0)
	  (2-pwr 1 (+ 2-pwr 2-pwr))
	  (gmsm 0)
	  (mark bar (cdr mark)))
	 ((endp mark) (absm dgop gmsm))
	(declare
	   (fixnum dgop 2-pwr gmsm)
	   (list mark))
	(if (zerop (car mark))
	   (incf dgop 2-pwr)
	   (incf gmsm)))))

#|
  (dotimes (i 8)    ;;; not really legal
  (dotimes (j 8)
    (print (z2-bar-absm (z2-absm-bar (absm i j))))))
|#


(DEFUN HOPF-FIBRATION-SINTR (n)
  (declare (fixnum n))
  (flet ((rslt (dmns gmsm)
	   (declare (ignore dmns gmsm))
	   (if (zerop n)
	      (absm 1 +empty-list+)
	      (absm 0 (list n)))))
     (the sintr #'rslt)))

(DEFUN HOPF-FIBRATION (n)
  (declare (fixnum n))
  (the simplicial-mrph
     (build-smmr
        :sorc (sphere 2)
	:trgt (k-z-1)
	:degr -1
	:sintr (hopf-fibration-sintr n)
	:orgn `(hopf-fibration ,n))))

(DEFUN Z-FUNDAMENTAL-GMSM (dmns pi-elm)   ;;; pi-elm not equal to 0
   (declare (fixnum dmns pi-elm))
   (the gmsm
      (if (= 1 dmns)
         (list pi-elm)
         (let ((bspn (if (= 2 dmns) +empty-list+ +null-gbar+)))
            (declare (type gmsm bspn))
            (make-gbar :dmns dmns
               :list (cons (absm 0 (z-fundamental-gmsm (1- dmns) pi-elm))
                        (mapcar
                           #'(lambda (k)
                                (declare (fixnum k))
                                (absm (mask k) bspn))
                           (nreverse (<a-b> 0 (- dmns 2))))))))))

#|
  (z-fundamental-gmsm 1 33)
  (z-fundamental-gmsm 2 33)
  (z-fundamental-gmsm 3 33)
  (z-fundamental-gmsm 4 33)
|#

(DEFUN INTERESTING-FACES (face small-dmns high-dmns gmsm)
  (declare
    (type face face)
    (fixnum small-dmns high-dmns)
    (type gmsm gmsm))
  (the list
    (let ((max (mask high-dmns)))
      (declare (fixnum max))
      (if (= small-dmns high-dmns)
	 (list (cons max (absm 0 gmsm)))
	 (do ((prev-list (interesting-faces face (1+ small-dmns) high-dmns gmsm))
	      (k (1- max) (1- k))
	      (rslt +empty-list+)
	      (count (binomial-n-p high-dmns small-dmns)))
	     ((zerop count) rslt)
	     (declare
	       (list prev-list rslt)
	       (fixnum k count))
	    (when (= small-dmns (logcount k))
	      (decf count)
	      (do ((i 0 (1+ i)))
	          ((not (logbitp i k))
		   (push (cons k
			       (a-face4 face
					(- small-dmns -1
					   (if (= i (integer-length k)) (1+ i) i))
					(1+ small-dmns)
					(cdr (assoc (+ k (2-exp i)) prev-list))))
			 rslt)))))))))

#|
  (setf d (delta 14))
  (setf f (face d))
  (do ((i 5 (1- i)))
      ((minusp i))
    (print (interesting-faces f i 5 (mask 6))))
|#     

(DEFUN GMSM-COCYCLE (face small-dmns high-dmns gmsm chml-clss)
  (declare
    (type face face)
    (fixnum small-dmns high-dmns)
    (type gmsm gmsm)
    (type morphism chml-clss))
  (the list
    (let ((int-faces (interesting-faces face small-dmns high-dmns gmsm)))
      (declare (list int-faces))
      (mapc
        #'(lambda (cons)
	    (declare (cons cons))
	    (setf (cdr cons)
		  (let ((absm (cdr cons)))
		    (declare (type absm absm))
		    (with-absm (dgop gmsm2) absm
		      (if (plusp dgop)
			 0
			(let ((cmbn-list (cmbn-list (gnrt-? chml-clss
						 small-dmns gmsm2))))
			  (declare (list cmbn-list))
			  (if cmbn-list
			      (-cffc cmbn-list)
			    0)))))))
        int-faces)
      int-faces)))

#|
  (cat-init)
  (setf d (delta 10))
  (setf chml-clss
    (build-mrph :sorc d :trgt (z-chcm) :degr -2
                :intr #'(lambda (dmns gmsm)
                          (term-cmbn 0 gmsm :gnrt-z))
                :strt :gnrt
                :orgn '(essai-1)))
  (gmsm-cocycle (face d) 2 4 31 chml-clss)
  (setf chml-clss
    (build-mrph :sorc d :trgt (z-chcm) :degr -1
                :intr #'(lambda (dmns gmsm)
                          (term-cmbn 0 gmsm :gnrt-z))
                :strt :gnrt
                :orgn '(essai-2)))
  (gmsm-cocycle (face d) 1 4 31 chml-clss)
|#

(DEFUN Z-COCYCLE-GBAR (n dmns cocycle)
  ;; cocycle \in Z^n(\Delta^{dmns}, \pi) with \pi = Z
  (declare
    (fixnum n dmns)
    (list cocycle))
  (the absm
    (cond ((= n 1)
	   (z-bar-absm (nreverse (mapcar #'cdr cocycle))))
	  ((= n dmns)
	   (let ((value (cdr (first cocycle))))
	     (declare (fixnum value))
	     (if (zerop value)
		(absm (mask dmns) +null-gbar+)
	        (absm 0 (z-fundamental-gmsm dmns value)))))
	  (t
	   (let ((cocycle1 +empty-list+)
		 (cocycle2 +empty-list+))
	     (declare (list cocycle1 cocycle2))
	     (dolist (cons cocycle)
	       (declare (cons cons))
	       (if (evenp (car cons))
		  (push (cons (ash (car cons) -1) (cdr cons))
			cocycle1)
		  (push (cons (ash (car cons) -1) (cdr cons))
			cocycle2)))
	     (setf cocycle1 (nreverse cocycle1)
		   cocycle2 (nreverse cocycle2))
	     (mapc
	       #'(lambda (cons)
		   (declare (cons cons))
		   (when (evenp (car cons))
		     (decf (cdr cons)
			   (cdr (assoc (1+ (car cons)) cocycle1)))))
	       cocycle2)
	     (let ((head-absm (z-cocycle-gbar (1- n) (1- dmns) cocycle2))
		   (tail-absm (z-cocycle-gbar n (1- dmns) cocycle1)))
	       (declare (type absm head-absm tail-absm))
	       (normalize-gbar
		 (cons dmns
		       (cons head-absm
			     (rest (unnormalize-gbar tail-absm
				     (if (= n 2) () +null-gbar+))))))))))))

#|
  (cat-init)
  (setf d (delta 10))
  (setf chml-clss
    (build-mrph :sorc d :trgt (z-chcm) :degr -1
                :intr #'(lambda (dmns gmsm)
                          (term-cmbn 0 gmsm :gnrt-z))
                :strt :gnrt
                :orgn '(essai-1)))
  (gmsm-cocycle (face d) 1 4 31 chml-clss)
  (z-cocycle-gbar 1 4 *)
  (setf chml-clss
    (build-mrph :sorc d :trgt (z-chcm) :degr -2
                :intr #'(lambda (dmns gmsm)
                          (term-cmbn 0 gmsm :gnrt-z))
                :strt :gnrt
                :orgn '(essai-2)))
  (gmsm-cocycle (face d) 2 2 7 chml-clss)
  (z-cocycle-gbar 2 2 *)
  (gmsm-cocycle (face d) 2 2 0 chml-clss) ;; normally illegal
  (z-cocycle-gbar 2 2 *)
  (gmsm-cocycle (face d) 2 3 15 chml-clss)
  (z-cocycle-gbar 2 3 *)
  (gmsm-cocycle (face d) 2 4 31 chml-clss)
  (z-cocycle-gbar 2 4 *)
  (setf chml-clss
    (build-mrph :sorc d :trgt (z-chcm) :degr -3
                :intr #'(lambda (dmns gmsm)
                          (term-cmbn 0 gmsm :gnrt-z))
                :strt :gnrt
                :orgn '(essai-3)))
  (gmsm-cocycle (face d) 3 4 31 chml-clss)
  (z-cocycle-gbar 3 4 *)
  (setf chml-clss
    (build-mrph :sorc d :trgt (z-chcm) :degr -3
                :intr #'(lambda (dmns gmsm)
                          (zero-cmbn 0))
                :strt :gnrt
                :orgn '(essai-33)))
  (gmsm-cocycle (face d) 3 4 31 chml-clss)
  (z-cocycle-gbar 3 4 *)
|#

(DEFUN Z-COCYCLE-GBAR-HEAD (n dmns cocycle)
  ;; cocycle \in Z^n(\Delta^{dmns}, \pi) with \pi = Z
  (declare
    (fixnum n dmns)
    (list cocycle))
  (the absm
    (cond ((= n 1)
	   (error "In Z-COCYCLE-GBAR-HEAD, this point should not have been reached."))
	   ; (z-bar-absm (nreverse (mapcar #'cdr cocycle))))
	  ((= n dmns)
	   (let ((value (cdr (first cocycle))))
	     (declare (fixnum value))
	     (if (zerop value)
		(if (= n 2)
		   (absm 1 +empty-list+)
		   (absm (mask (1- dmns)) +null-gbar+))
	       (absm 0 (z-fundamental-gmsm (1- dmns) value)))))
	  (t
	   (let ((cocycle1 +empty-list+)
		 (cocycle2 +empty-list+))
	     (declare (list cocycle1 cocycle2))
	     (dolist (cons cocycle)
	       (declare (cons cons))
	       (if (evenp (car cons))
		  (push (cons (ash (car cons) -1) (cdr cons))
			cocycle1)
		  (push (cons (ash (car cons) -1) (cdr cons))
			cocycle2)))
	     (setf cocycle1 (nreverse cocycle1)
		   cocycle2 (nreverse cocycle2))
	     (mapc
	       #'(lambda (cons)
		   (declare (cons cons))
		   (when (evenp (car cons))
		     (decf (cdr cons)
			   (cdr (assoc (1+ (car cons)) cocycle1)))))
	       cocycle2)
	     (z-cocycle-gbar (1- n) (1- dmns) cocycle2))))))

#|
  (cat-init)
  (setf d (delta 10))
  (setf chml-clss
    (build-mrph :sorc d :trgt (z-chcm) :degr -1
                :intr #'(lambda (dmns gmsm)
                          (term-cmbn 0 gmsm :gnrt-z))
                :strt :gnrt
                :orgn '(essai-1)))
  (gmsm-cocycle (face d) 1 4 31 chml-clss)
  (z-cocycle-gbar 1 4 *)
  (z-cocycle-gbar-head 1 4 **)
  (setf chml-clss
    (build-mrph :sorc d :trgt (z-chcm) :degr -2
                :intr #'(lambda (dmns gmsm)
                          (term-cmbn 0 gmsm :gnrt-z))
                :strt :gnrt
                :orgn '(essai-2)))
  (gmsm-cocycle (face d) 2 2 7 chml-clss)
  (z-cocycle-gbar 2 2 *)
  (z-cocycle-gbar-head 2 2 **)
  (gmsm-cocycle (face d) 2 2 0 chml-clss) ;; normally illegal
  (z-cocycle-gbar 2 2 *)
  (z-cocycle-gbar-head 2 2 **)
  (gmsm-cocycle (face d) 2 3 15 chml-clss)
  (z-cocycle-gbar 2 3 *)
  (z-cocycle-gbar-head 2 3 **)
  (gmsm-cocycle (face d) 2 4 31 chml-clss)
  (z-cocycle-gbar 2 4 *)
  (z-cocycle-gbar-head 2 4 **)
  (setf chml-clss
    (build-mrph :sorc d :trgt (z-chcm) :degr -3
                :intr #'(lambda (dmns gmsm)
                          (term-cmbn 0 gmsm :gnrt-z))
                :strt :gnrt
                :orgn '(essai-3)))
  (gmsm-cocycle (face d) 3 4 31 chml-clss)
  (z-cocycle-gbar 3 4 *)
  (z-cocycle-gbar-head 3 4 **)
  (setf chml-clss
    (build-mrph :sorc d :trgt (z-chcm) :degr -3
                :intr #'(lambda (dmns gmsm)
                          (zero-cmbn 0))
                :strt :gnrt
                :orgn '(essai-33)))
  (gmsm-cocycle (face d) 3 4 31 chml-clss)
  (z-cocycle-gbar 3 4 *)
  (z-cocycle-gbar-head 3 4 **)
|#

(DEFUN Z2-FUNDAMENTAL-GMSM (dmns pi-elm)  ;; pi-elm not "equal" to 0, therefore 1.
   (declare (fixnum dmns pi-elm))
   (the gmsm
      (if (= 1 dmns)
         1
         (let ((bspn (if (= 2 dmns) 0 +null-gbar+)))
            (declare (type gmsm bspn))
            (make-gbar :dmns dmns
               :list (cons (absm 0 (Z2-fundamental-gmsm (1- dmns) pi-elm))
                        (mapcar
                           #'(lambda (k)
                                (declare (fixnum k))
                                (absm (mask k) bspn))
                           (nreverse (<a-b> 0 (- dmns 2))))))))))

#|
  (Z2-fundamental-gmsm 1 1)
  (Z2-fundamental-gmsm 2 1)
  (Z2-fundamental-gmsm 3 1)
  (Z2-fundamental-gmsm 4 1)
|#    

(DEFUN Z2-COCYCLE-GBAR (n dmns cocycle)
  ;; cocycle \in Z^n(\Delta^{dmns}, \pi) with \pi = Z/2Z
  (declare
    (fixnum n dmns)
    (list cocycle))
  (the absm
    (progn
      (mapc
        #'(lambda (cons)
	    (declare (cons cons))
	    (setf (cdr cons)
		  (if (evenp (cdr cons)) 0 1)))
        cocycle)
      (cond ((= n 1)
	     (z2-bar-absm (nreverse (mapcar #'cdr cocycle))))
	    ((= n dmns)
	     (let ((value (cdr (first cocycle))))
	       (declare (fixnum value))
	       (if (zerop value)
		   (absm (mask dmns) +null-gbar+)
		 (absm 0 (z2-fundamental-gmsm dmns value)))))
	    (t
	     (let ((cocycle1 +empty-list+)
		   (cocycle2 +empty-list+))
	       (declare (list cocycle1 cocycle2))
	       (dolist (cons cocycle)
		 (declare (cons cons))
		 (if (evenp (car cons))
		     (push (cons (ash (car cons) -1) (cdr cons))
			   cocycle1)
		   (push (cons (ash (car cons) -1) (cdr cons))
			 cocycle2)))
	       (setf cocycle1 (nreverse cocycle1)
		     cocycle2 (nreverse cocycle2))
	       (mapc
		#'(lambda (cons)
		    (declare (cons cons))
		    (when (evenp (car cons))
			  (setf (cdr cons)
				(mod (- (cdr cons)
					(cdr (assoc (1+ (car cons)) cocycle1)))
				     2))))
		cocycle2)
	       (let ((head-absm (z2-cocycle-gbar (1- n) (1- dmns) cocycle2))
		     (tail-absm (z2-cocycle-gbar n (1- dmns) cocycle1)))
		 (declare (type absm head-absm tail-absm))
		 (normalize-gbar
		  (cons dmns
			(cons head-absm
			      (rest (unnormalize-gbar tail-absm
						      (if (= n 2) 0 +null-gbar+)))))))))))))

#|
  (cat-init)
  (setf d (delta 10))
  (setf chml-clss
    (build-mrph :sorc d :trgt (z-chcm) :degr -1
                :intr #'(lambda (dmns gmsm)
                          (term-cmbn 0 (mod gmsm 2) :gnrt-z))
                :strt :gnrt
                :orgn '(essai-1)))
  (gmsm-cocycle (face d) 1 4 31 chml-clss)
  (z2-cocycle-gbar 1 4 *)
  (setf chml-clss
    (build-mrph :sorc d :trgt (z-chcm) :degr -2
                :intr #'(lambda (dmns gmsm)
                          (term-cmbn 0 (mod gmsm 2) :gnrt-z))
                :strt :gnrt
                :orgn '(essai-2)))
  (gmsm-cocycle (face d) 2 2 7 chml-clss)
  (z2-cocycle-gbar 2 2 *)
  (gmsm-cocycle (face d) 2 2 0 chml-clss) ;; normally illegal
  (z2-cocycle-gbar 2 2 *)
  (gmsm-cocycle (face d) 2 3 15 chml-clss)
  (z2-cocycle-gbar 2 3 *)
  (gmsm-cocycle (face d) 2 4 31 chml-clss)
  (z2-cocycle-gbar 2 4 *)
  (setf chml-clss
    (build-mrph :sorc d :trgt (z-chcm) :degr -3
                :intr #'(lambda (dmns gmsm)
                          (term-cmbn 0 (mod gmsm 2) :gnrt-z))
                :strt :gnrt
                :orgn '(essai-3)))
  (gmsm-cocycle (face d) 3 4 31 chml-clss)
  (z2-cocycle-gbar 3 4 *)
|#

(DEFUN Z2-COCYCLE-GBAR-HEAD (n dmns cocycle)
  ;; cocycle \in Z^n(\Delta^{dmns}, \pi) with \pi = Z/2Z
  (declare
    (fixnum n dmns)
    (list cocycle))
  (the absm
    (progn
      (mapc
        #'(lambda (cons)
	    (setf (cdr cons)
		  (if (evenp (cdr cons)) 0 1)))
        cocycle)
      (cond ((= n 1)
	     (error "In Z2-COCYCLE-GBAR-HEAD, this point should not have been reached."))
		 ; (z2-bar-absm (nreverse (mapcar #'cdr cocycle))))
	    ((= n dmns)
	     (let ((value (cdr (first cocycle))))
	       (declare (fixnum value))
	       (if (zerop value)
		   (if (= n 2)
		       (absm 1 0)
		     (absm (mask (1- dmns)) +null-gbar+))
		 (absm 0 (z2-fundamental-gmsm (1- dmns) value)))))
	    (t
	     (let ((cocycle1 +empty-list+)
		   (cocycle2 +empty-list+))
	       (declare (list cocycle1 cocycle2))
	       (dolist (cons cocycle)
		 (declare (cons cons))
		 (if (evenp (car cons))
		     (push (cons (ash (car cons) -1) (cdr cons))
			   cocycle1)
		   (push (cons (ash (car cons) -1) (cdr cons))
			 cocycle2)))
	       (setf cocycle1 (nreverse cocycle1)
		     cocycle2 (nreverse cocycle2))
	       (mapc
		#'(lambda (cons)
		    (declare (cons cons))
		    (when (evenp (car cons))
			  (setf (cdr cons)
				(mod (- (cdr cons)
					(cdr (assoc (1+ (car cons)) cocycle1)))
				     2))))
		cocycle2)
	       (z2-cocycle-gbar (1- n) (1- dmns) cocycle2)))))))

#|
  (cat-init)
  (setf d (delta 10))
  (setf chml-clss
    (build-mrph :sorc d :trgt (z-chcm) :degr -1
                :intr #'(lambda (dmns gmsm)
                          (term-cmbn 0 (mod gmsm 2) :gnrt-z))
                :strt :gnrt
                :orgn '(essai-1)))
  (gmsm-cocycle (face d) 1 4 31 chml-clss)
  (z2-cocycle-gbar 1 4 *)
  (z2-cocycle-gbar-head 1 4 **)
  (setf chml-clss
    (build-mrph :sorc d :trgt (z-chcm) :degr -2
                :intr #'(lambda (dmns gmsm)
                          (term-cmbn 0 (mod gmsm 2) :gnrt-z))
                :strt :gnrt
                :orgn '(essai-2)))
  (gmsm-cocycle (face d) 2 2 7 chml-clss)
  (z2-cocycle-gbar 2 2 *)
  (z2-cocycle-gbar-head 2 2 **)
  (gmsm-cocycle (face d) 2 2 0 chml-clss) ;; normally illegal
  (z2-cocycle-gbar 2 2 *)
  (z2-cocycle-gbar-head 2 2 **)
  (gmsm-cocycle (face d) 2 3 15 chml-clss)
  (z2-cocycle-gbar 2 3 *)
  (z2-cocycle-gbar-head 2 3 **)
  (gmsm-cocycle (face d) 2 4 31 chml-clss)
  (z2-cocycle-gbar 2 4 *)
  (z2-cocycle-gbar-head 2 4 **)
  (setf chml-clss
    (build-mrph :sorc d :trgt (z-chcm) :degr -3
                :intr #'(lambda (dmns gmsm)
                          (term-cmbn 0 (mod gmsm 2) :gnrt-z))
                :strt :gnrt
                :orgn '(essai-3)))
  (gmsm-cocycle (face d) 3 4 31 chml-clss)
  (z2-cocycle-gbar 3 4 *)
  (z2-cocycle-gbar-head 3 4 **)
|#

(DEFUN K-Z-FUNDAMENTAL-CLASS (n)
  (declare (fixnum n))
  (the morphism
    (build-mrph
      :sorc (k-z n) :trgt (z-chcm) :degr (- n)
      :intr #'(lambda (dmns gmsm)
		(declare
		  (fixnum dmns)
		  (type gmsm gmsm))
		(if (= dmns n)
		   (do ((gmsm gmsm (gmsm (first (gbar-list gmsm))))
			(dmns dmns (1- dmns)))
		       ((= 1 dmns)
			(term-cmbn 0 (first gmsm) :z-gnrt))
		       (declare
			 (type gmsm gmsm)
			 (fixnum dmns)))
		  (zero-cmbn (- dmns n))))
      :strt :gnrt
      :orgn `(k-z-fundamental-class ,n))))

#|
  (cat-init)
  (setf c1 (k-z-fundamental-class 1))
  (? c1 1 '(34))
  (? c1 2 '(34 45))
  (setf c3 (k-z-fundamental-class 3))
  (? c3 3 (z-fundamental-gmsm 3 45))
|#

(DEFUN K-Z2-FUNDAMENTAL-CLASS (n)
  (declare (fixnum n))
  (the morphism
    (build-mrph
      :sorc (k-z2 n) :trgt (z-chcm) :degr (- n)
      :intr #'(lambda (dmns gmsm)
		(declare
		  (fixnum dmns)
		  (ignore gmsm))
		(if (= dmns n)
		   (term-cmbn 0 1 :z-gnrt)
		  (zero-cmbn (- dmns n))))
      :strt :gnrt
      :orgn `(k-z2-fundamental-class ,n))))

#|
  (cat-init)
  (setf c1 (k-z2-fundamental-class 1))
  (? c1 1 1)
  (? c1 2 2)
  (setf c3 (k-z2-fundamental-class 3))
  (? c3 3 (z2-fundamental-gmsm 3 1))
|#