;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*

;;;  SMITH  SMITH  SMITH  SMITH  SMITH  SMITH  SMITH  SMITH
;;;  SMITH  SMITH  SMITH  SMITH  SMITH  SMITH  SMITH  SMITH
;;;  SMITH  SMITH  SMITH  SMITH  SMITH  SMITH  SMITH  SMITH

(IN-PACKAGE #:cat)

(PROVIDE "smith")

(DEFTYPE MATRIX () '(array fixnum (* *)))


(DEFUN RANDOM-MATRIX (line-n column-n max)
  (declare (fixnum line-n column-n max))
  (the matrix
       (let ((rslt (make-array (list line-n column-n)
                               :element-type 'fixnum))
             (2max+1 (+ max max 1)))
         (declare
          (type matrix rslt)
          (fixnum 2max+1))
         (dotimes (i line-n)
           (declare (fixnum i))
           (dotimes (j column-n)
             (declare (fixnum j))
             (setf (aref rslt i j)
                   (- (random 2max+1) max))))
         rslt)))


(DEFUN IDNT-MTRX (n)
  (declare (fixnum n))
  (the matrix
       (let ((rslt (if (zerop n)
                       (make-array '(0 0)
                                   :element-type 'fixnum)
                       (make-array (list n n)
                                   :element-type 'fixnum
                                   :initial-element 0))))
         (declare (type matrix rslt))
         (dotimes (i n)
           (declare (fixnum i))
           (setf (aref rslt i i) 1))
         rslt)))


(DEFUN COPY-MTRX (mtrx)
  (declare (type matrix mtrx))
  (the matrix
       (let ((line-n (line-number mtrx))
             (column-n (column-number mtrx)))
         (declare (fixnum line-n column-n))
         (let ((rslt (make-array (list line-n column-n)
                                 :element-type 'fixnum)))
           (declare (type matrix rslt))
           (dotimes (il line-n)
             (declare (fixnum il))
             (dotimes (ic column-n)
               (declare (fixnum ic))
               (setf (aref rslt il ic) (aref mtrx il ic))))
           rslt))))


(DEFUN LEFT-SUBMATRIX (mtrx k)
  (declare (type matrix mtrx))
  (the matrix
       (let ((line-n (line-number mtrx))
             (column-n (column-number mtrx)))
         (declare (fixnum line-n column-n))
         (assert (<= k column-n))
         (let ((rslt (make-array (list line-n k)
                                 :element-type 'fixnum)))
           (declare (type matrix rslt))
           (dotimes (il line-n)
             (declare (fixnum il))
             (dotimes (ic k)
               (declare (fixnum ic))
               (setf (aref rslt il ic) (aref mtrx il ic))))
           rslt))))


(DEFUN MTRX-PRDC (mtrx1 mtrx2)
  (declare (type matrix mtrx1 mtrx2))
  (the matrix
       (let ((rslt-line-n (line-number mtrx1))
             (mtrx1-column-n (column-number mtrx1))
             (mtrx2-line-n (line-number mtrx2))
             (rslt-column-n (column-number mtrx2)))
         (declare (fixnum rslt-line-n mtrx1-column-n
                          mtrx2-line-n rslt-column-n))
         (unless (= mtrx1-column-n mtrx2-line-n)
           (error "In MTRX-PRDC, bad line or column number."))
         (let ((rslt (make-array (list rslt-line-n rslt-column-n)
                                 :element-type 'fixnum)))
           (declare (type matrix rslt))
           (dotimes (il rslt-line-n)
             (declare (fixnum il))
             (dotimes (ic rslt-column-n)
               (declare (fixnum ic))
               (do ((k 0 (1+ k))
                    (sum 0 (+ sum
                              (* (aref mtrx1 il k) (aref mtrx2 k ic)))))
                   ((= k mtrx1-column-n) (setf (aref rslt il ic) sum)))))
           rslt))))


(DEFUN CHCM-MTRX (chcm degr)
  (declare
   (type chain-complex chcm)
   (fixnum degr))
  (the matrix
       (let ((cmpr (cmpr1 chcm))
             (dffr (dffr chcm))
             (sbasis (basis chcm degr))
             (tbasis (basis chcm (1- degr))))
         (declare
          (type cmprf cmpr)
          (type morphism dffr)
          (list sbasis tbasis))
         (let ((srank (length sbasis))
               (trank (length tbasis)))
           (declare (fixnum srank trank))
           (let ((rslt (make-array (list trank srank)
                                   :element-type 'fixnum
                                   :initial-element 0)))
             (declare (type matrix rslt))
             (do ((j 0 (1+ j))
                  (mark sbasis (cdr mark)))
                 ((endp mark))
               (declare
                (fixnum j)
                (list mark))
               (let ((cmbn (gnrt-? dffr degr (car mark))))
                 (declare (type cmbn cmbn))
                 (do ((mark1 (cmbn-list cmbn) (cdr mark1))
                      (mark2 tbasis)
                      (i 0))
                     ((endp mark1))
                   (declare
                    (list mark1 mark2)
                    (fixnum i))
                   (with--term
                       (cffc gnrt) mark1
                       (loop
                          (cond ((eq :equal (funcall cmpr gnrt (car mark2)))
                                 (setf (aref rslt i j) cffc)
                                 (incf i)
                                 (pop mark2)
                                 (return))
                                (t (incf i)
                                   (pop mark2))))))))
             rslt)))))


(DEFUN LINE-OP (mtrx begin lambda line1 line2)
  ;; line2 := line2 + lambda * line1
  (declare
   (type matrix mtrx)
   (fixnum begin lambda line1 line2))
  (the matrix
       (progn
         (do ((column-number (column-number mtrx))
              (j begin (1+ j)))
             ((= j column-number))
           (declare (fixnum column-number j))
           (incf (aref mtrx line2 j)
                 (* lambda (aref mtrx line1 j))))
         mtrx)))


(DEFUN COLUMN-OP (mtrx begin lambda column1 column2)
  (declare
   (type matrix mtrx)
   (fixnum begin lambda column1 column2))
  (the matrix
       (progn
         (do ((line-number (line-number mtrx))
              (i begin (1+ i)))
             ((= i line-number))
           (declare (fixnum line-number i))
           (incf (aref mtrx i column2)
                 (* lambda (aref mtrx i column1))))
         mtrx)))


(DEFUN LINE-SWAP (mtrx begin line1 line2)
  (declare
   (type matrix mtrx)
   (fixnum begin line1 line2))
  (the matrix
       (progn
         (do ((column-number (column-number mtrx))
              (j begin (1+ j)))
             ((= j column-number))
           (declare (fixnum column-number j))
           (rotatef (aref mtrx line1 j) (aref mtrx line2 j)))
         mtrx)))


(DEFUN COLUMN-SWAP (mtrx begin column1 column2)
  (declare
   (type matrix mtrx)
   (fixnum begin column1 column2))
  (the matrix (progn
                (do ((line-number (line-number mtrx))
                     (i begin (1+ i)))
                    ((= i line-number))
                  (declare (fixnum line-number i))
                  (rotatef (aref mtrx i column1) (aref mtrx i column2)))
                mtrx)))


(DEFUN LINE-MINUS (mtrx begin line)
  (declare
   (type matrix mtrx)
   (fixnum begin line))
  (the matrix (progn
                (do ((column-number (column-number mtrx))
                     (j begin (1+ j)))
                    ((= j column-number))
                  (declare (fixnum column-number j))
                  (setf (aref mtrx line j) (- (aref mtrx line j))))
                mtrx)))

(DEFUN COLUMN-MINUS (mtrx begin column)
  (declare
   (type matrix mtrx)
   (fixnum begin column))
  (the matrix (progn
                (do ((line-number (line-number mtrx))
                     (i begin (1+ i)))
                    ((= i line-number))
                  (declare (fixnum line-number i))
                  (setf (aref mtrx i column) (- (aref mtrx i column))))
                mtrx)))


(DEFUN MINIMAL-TERM (matrix begin)
  (declare
   (type matrix matrix)
   (fixnum begin))
  (the (values fixnum fixnum fixnum)
       (do ((line-number (line-number matrix))
            (column-number (column-number matrix))
            (min 0)
            (min-il -1)
            (min-ic -1)
            (il begin (1+ il)))
           ((= il line-number) (values min min-il min-ic))
         (declare (fixnum line-number column-number
                          min min-il min-ic il))
         (do ((ic begin (1+ ic)))
             ((= ic column-number))
           (declare (fixnum ic))
           (let ((term (abs (aref matrix il ic))))
             (declare (fixnum term))
             (when (= term 1)
               (return-from minimal-term (values 1 il ic)))
             (when (plusp term)
               (when (or (< term min)
                         (zerop min))
                 (setf min term
                       min-il il
                       min-ic ic))))))))


(DEFUN MINIMAL-REST-1 (matrix begin)
  (declare
   (type matrix matrix)
   (fixnum begin))
  (the (values fixnum fixnum fixnum)
       (let ((line-number (line-number matrix))
             (column-number (column-number matrix))
             (corner (aref matrix begin begin))
             (min 0)
             (min-il -1)
             (min-ic -1))
         (declare (fixnum corner min min-il min-ic))
         (do ((ic (1+ begin) (1+ ic)))
             ((= ic column-number))
           (declare (fixnum ic))
           (let ((term (abs (second (multiple-value-list
                                     (round (aref matrix begin ic)
                                            corner))))))
             (declare (fixnum term))
             (when (= term 1)
               (return-from minimal-rest-1 (values 1 begin ic)))
             (when (plusp term)
               (when (or (< term min)
                         (zerop min))
                 (setf min term
                       min-il begin
                       min-ic ic)))))
         (do ((il (1+ begin) (1+ il)))
             ((= il line-number))
           (declare (fixnum il))
           (let ((term (abs (second (multiple-value-list
                                     (round (aref matrix il begin)
                                            corner))))))
             (declare (fixnum term))
             (when (= term 1)
               (return-from minimal-rest-1 (values 1 il begin)))
             (when (plusp term)
               (when (or (< term min)
                         (zerop min))
                 (setf min term
                       min-il il
                       min-ic begin)))))
         (values min min-il min-ic))))


(DEFUN MINIMAL-REST-2 (matrix begin)
  (declare
   (type matrix matrix)
   (fixnum begin))
  (the (values fixnum fixnum fixnum)
       (let ((line-number (line-number matrix))
             (column-number (column-number matrix))
             (corner (aref matrix begin begin))
             (min 0)
             (min-il  -1)
             (min-ic -1))
         (declare (fixnum corner min min-il min-ic))
         (do ((il (1+ begin) (1+ il)))
             ((= il line-number))
           (declare (fixnum il))
           (do ((ic (1+ begin) (1+ ic)))
               ((= ic column-number))
             (declare (fixnum il))
             (let ((term (abs (second (multiple-value-list
                                       (round (aref matrix il ic)
                                              corner))))))
               (declare (fixnum term))
               (when (= 1 term)
                 (return-from minimal-rest-2 (values 1 il ic)))
               (when (plusp term)
                 (when (or (< term min)
                           (zerop min))
                   (setf min term
                         min-il il
                         min-ic ic))))))
         (values min min-il min-ic))))


(DEFUN MINIMAL-TERM-TOP-LEFT (mtrx-list begin il ic)
  (declare
   (list mtrx-list)
   (fixnum begin il ic))
  (the list (progn
              (when (< begin il)
                (line-swap-5 mtrx-list begin begin il))
              (when (< begin ic)
                (column-swap-5 mtrx-list begin begin ic))
              (when (minusp (aref (third mtrx-list) begin begin))
                (line-minus-5 mtrx-list begin begin))
              mtrx-list)))


(DEFUN PIVOTT (mtrx-list begin)
  (declare
   (list mtrx-list)
   (fixnum begin))
  (the list (progn
              (let ((line-number (line-number (third mtrx-list)))
                    (column-number (column-number (third mtrx-list)))
                    (corner (aref (third mtrx-list) begin begin)))
                (declare (fixnum line-number column-number corner))
                (do ((il (1+ begin) (1+ il)))
                    ((= il line-number))
                  (declare (fixnum il))
                  (line-op-5 mtrx-list begin
                             (- (round (aref (third mtrx-list) il begin)
                                       corner))
                             begin il))
                (do ((ic (1+ begin) (1+ ic)))
                    ((= ic column-number))
                  (declare (fixnum ic))
                  (column-op-5 mtrx-list begin
                               (- (round (aref (third mtrx-list) begin ic)
                                         corner))
                               begin ic)))
              mtrx-list)))


(DEFUN LIST-SMITH (mtrx-list)
  (declare (list mtrx-list))
  (the list (progn
              (let ((matrix (third mtrx-list))
                    (begin 0))
                (declare
                 (type matrix matrix)
                 (fixnum begin))
                (loop
                   (multiple-value-bind (term il ic)
                       (minimal-term matrix begin)
                     (declare (fixnum term il ic))
                     ;; (format t "~%*BEGIN* = ~D ; MIN = ~D." begin term)
                     (when (zerop term)
                       (return-from list-smith mtrx-list))
                     (minimal-term-top-left mtrx-list begin il ic))
                   (loop
                      (multiple-value-bind (term il ic)
                          (minimal-rest-1 matrix begin)
                        (declare (fixnum term il ic))
                        (cond ((zerop term)
                               (pivott mtrx-list begin)
                               (multiple-value-bind (term il ic)
                                   (minimal-rest-2 matrix begin)
                                 (declare
                                  (fixnum term il)
                                  (ignore ic))
                                 (if (zerop term)
                                     (return)
                                     (line-op-5 mtrx-list begin 1 il begin))))
                              ((= il begin)
                               (column-op-5 mtrx-list begin
                                            (- (round (aref matrix begin ic)
                                                      (aref matrix begin
                                                            begin)))
                                            begin ic)
                               (column-swap-5 mtrx-list begin begin ic)
                               (when (minusp (aref matrix begin begin))
                                 (column-minus-5 mtrx-list begin begin)))
                              (t
                               (line-op-5 mtrx-list begin
                                          (- (round (aref matrix il begin)
                                                    (aref matrix begin begin)))
                                          begin il)
                               (line-swap-5 mtrx-list begin begin il)
                               (when (minusp (aref matrix begin begin))
                                 (column-minus-5 mtrx-list begin begin))))))
                   ;; (Format t "~%  Finally the diagonal term is ~D." (aref matrix begin begin))
                   (incf begin)))
              mtrx-list)))


(DEFUN SMITH (matrix)
  (declare (type matrix matrix))
  (the list
       (let ((line-n (line-number matrix))
             (column-n (column-number matrix)))
         (declare (fixnum line-n column-n))
         (list-smith
          (list (idnt-mtrx line-n) (idnt-mtrx line-n)
                matrix
                (idnt-mtrx column-n) (idnt-mtrx column-n))))))


;;; ECHCM -> The same without the first epimorphism
;;;
;;; epi: C_f <- C_{f+1}
;;  rank(C_f) = n
;;  rank(C_{f+1}) = m
;;  f = first

(eval-when (:compile-toplevel :load-toplevel :execute)
  (UNLESS (FIND-PACKAGE "GNRTS")
    (make-package "GNRTS"))
  (DEFCONSTANT +GNRTS-PCKG+
    (find-package "GNRTS")))

(DEFUN GNRT-NAME-BASIS (n)
  (declare (fixnum n))
  (the list
       (do ((i (1- n) (1- i))
            (rslt +empty-list+ (cons (gnrt-name i) rslt)))
           ((minusp i) rslt)
         (declare
          (fixnum i)
          (list rslt)))))


(DEFUN ECHCM-KILL-EPI-F-INTR (cmpr first n m f+1-basis mtrx-list)
  (declare
   (type cmprf cmpr)
   (fixnum first n m)
   (list f+1-basis mtrx-list))
  (let ((f+1 (1+ first))
        (m-n (- m n))
        (q-1 (fifth mtrx-list)))
    (declare
     (fixnum f+1 m-n)
     (type matrix q-1))
    (flet ((rslt (cmbn)
             (declare (type cmbn cmbn))
             (with-cmbn
                 (degr list) cmbn
                 (when (= degr first)
                   (return-from rslt (zero-cmbn degr)))
                 (unless (= degr f+1)
                   (return-from rslt cmbn))
                 (let ((rslt-cffcs (make-array m-n :element-type 'fixnum
                                               :initial-element 0)))
                   (declare (type (array fixnum *) rslt-cffcs))
                   (do ((cmbn-mark list (cdr cmbn-mark))
                        (basis-mark f+1-basis)
                        (ic 0))
                       ((endp cmbn-mark))
                     (declare
                      (list cmbn-mark basis-mark)
                      (fixnum ic))
                     (with--term
                         (cffc gnrt) cmbn-mark
                         (loop (when (eq :equal (funcall cmpr gnrt
                                                         (car basis-mark)))
                                 (return))
                            (pop basis-mark)
                            (incf ic))
                         (dotimes (il m-n)
                           (incf (aref rslt-cffcs il)
                                 (* cffc (aref q-1 (+ n il) ic))))
                         (pop basis-mark)
                         (incf ic)))
                   (do ((term-list +empty-list+)
                        (il (1- m-n) (1- il)))
                       ((minusp il) (make-cmbn :degr degr
                                               :list term-list))
                     (declare
                      (list term-list)
                      (fixnum il))
                     (let ((cffc (aref rslt-cffcs il)))
                       (declare (fixnum cffc))
                       (unless (zerop cffc)
                         (push (term cffc (gnrt-name il)) term-list))))))))
      (the intr-mrph #'rslt))))


(DEFUN ECHCM-KILL-EPI-G-INTR (first n m f+1-basis mtrx-list)
  (declare
   (fixnum first n m)
   (list f+1-basis mtrx-list))
  (let ((f+1 (1+ first))
        (m-n (- m n))
        (q (fourth mtrx-list)))
    (declare
     (fixnum f+1 m-n)
     (type matrix q))
    (flet ((rslt (cmbn)
             (declare (type cmbn cmbn))
             (with-cmbn
                 (degr list) cmbn
                 (unless (= degr f+1)
                   (return-from rslt cmbn))
                 (let ((rslt-cffcs (make-array m :element-type 'fixnum
                                               :initial-element 0)))
                   (declare (type (array fixnum *) rslt-cffcs))
                   (do ((cmbn-mark list (cdr cmbn-mark))
                        (basis-mark (gnrt-name-basis m-n))
                        (ic 0))
                       ((endp cmbn-mark))
                     (declare
                      (list cmbn-mark basis-mark)
                      (fixnum ic))
                     (with--term
                         (cffc gnrt) cmbn-mark
                         (loop (when (eq :equal (s-cmpr gnrt (car basis-mark)))
                                 (return))
                            (pop basis-mark)
                            (incf ic))
                         (dotimes (il m)
                           (incf (aref rslt-cffcs il)
                                 (* cffc (aref q il (+ n ic)))))
                         (pop basis-mark)
                         (incf ic)))
                   (do ((term-list +empty-list+)
                        (il (1- m) (1- il)))
                       ((minusp il) (make-cmbn :degr degr
                                               :list term-list))
                     (declare
                      (list term-list)
                      (fixnum il))
                     (let ((cffc (aref rslt-cffcs il)))
                       (declare (fixnum cffc))
                       (unless (zerop cffc)
                         (push (term cffc (nth il f+1-basis)) term-list))))))))
      (the intr-mrph #'rslt))))


(DEFUN ECHCM-KILL-EPI-H-INTR (cmpr first n m f-basis f+1-basis mtrx-list)
  (declare
   (type cmprf cmpr)
   (fixnum first n m)
   (list f-basis f+1-basis mtrx-list))
  (let ((lqxp-1 (mtrx-prdc (left-submatrix (fourth mtrx-list) n)
                           (second mtrx-list))))
    (declare (type matrix lqxp-1))
    (flet ((rslt (cmbn)
             (declare (type cmbn cmbn))
             (with-cmbn
                 (degr list) cmbn
                 (unless (= degr first)
                   (return-from rslt (zero-cmbn (1+ degr))))
                 (let ((rslt-cffcs (make-array m :element-type 'fixnum
                                               :initial-element 0)))
                   (declare (type (array fixnum *) rslt-cffcs))
                   (do ((cmbn-mark list (cdr cmbn-mark))
                        (basis-mark f-basis)
                        (ic 0))
                       ((endp cmbn-mark))
                     (declare
                      (list cmbn-mark basis-mark)
                      (fixnum ic))
                     (with--term
                         (cffc gnrt) cmbn-mark
                         (loop (when (eq :equal (funcall cmpr gnrt
                                                         (car basis-mark)))
                                 (return))
                            (pop basis-mark)
                            (incf ic))
                         (dotimes (il m)
                           (incf (aref rslt-cffcs il)
                                 (* cffc (aref lqxp-1 il ic))))
                         (pop basis-mark)
                         (incf ic)))
                   (do ((term-list +empty-list+)
                        (il (1- m) (1- il)))
                       ((minusp il) (make-cmbn :degr (1+ degr)
                                               :list term-list))
                     (declare
                      (list term-list)
                      (fixnum il))
                     (let ((cffc (aref rslt-cffcs il)))
                       (declare (fixnum cffc))
                       (unless (zerop cffc)
                         (push (term cffc (nth il f+1-basis)) term-list))))))))
      (the intr-mrph #'rslt))))


(DEFUN ECHCM-WITHOUT-EPI (echcm first n m intr-f)
  (declare
   (type chain-complex echcm)
   (fixnum first n m)
   (type intr-mrph intr-f))
  (the chain-complex
       (with-slots (cmpr basis dffr orgn) echcm
         (declare
          (type cmprf cmpr)
          (type basis basis)
          (type morphism dffr)
          (list orgn))
         (build-chcm
          :cmpr #'(lambda (gnrt1 gnrt2)
                    (if (and (symbolp gnrt1)
                             (eq (symbol-package gnrt1)
                                 +gnrts-pckg+))
                        (s-cmpr gnrt1 gnrt2)
                        (funcall cmpr gnrt1 gnrt2)))
          :basis #'(lambda (degr)
                     (declare (fixnum degr))
                     (cond ((= degr first)
                            +empty-list+)
                           ((= degr (1+ first))
                            (gnrt-name-basis (- m n)))
                           (t
                            (funcall basis degr))))
          :intr-dffr #'(lambda (cmbn)
                         (declare (type cmbn cmbn))
                         (case (- (cmbn-degr cmbn) first)
                           (1 (zero-cmbn first))
                           (2 (funcall intr-f
                                       (cmbn-? dffr cmbn)))
                           (otherwise
                            (cmbn-? dffr cmbn))))
          :strt :cmbn
          :orgn `(echcm-without-epi ,echcm)))))


(DEFUN ECHCM-KILL-EPI (echcm first)
  (declare
   (type chain-complex echcm)
   (fixnum first))
  (the reduction
       (with-slots (cmpr basis) echcm
         (declare
          (type cmprf cmpr)
          (type basis basis))
         (assert (not (eq basis :locally-effective)))
         (let* ((f-basis (funcall basis first))
                (f+1-basis (funcall basis (1+ first)))
                (mtrx-list (smith (chcm-mtrx echcm (1+ first))))
                (smith (third mtrx-list))
                (m (column-number smith))
                (n (line-number smith))
                (intr-f (echcm-kill-epi-f-intr cmpr first n m
                                               f+1-basis
                                               mtrx-list))
                (intr-g (echcm-kill-epi-g-intr first n m f+1-basis mtrx-list))
                (intr-h (echcm-kill-epi-h-intr cmpr first n m
                                               f-basis f+1-basis
                                               mtrx-list))
                (echcm2 (echcm-without-epi echcm first n m intr-f)))
           (declare
            (list mtrx-list)
            (type matrix smith)
            (fixnum m n)
            (type intr-mrph intr-f intr-g intr-h)
            (type chain-complex echcm2))
           (assert (dotimes (i n +true+)
                     (unless (= 1 (aref smith i i))
                       (return +false+))))
           (build-rdct
            :f (build-mrph
                :sorc echcm :trgt echcm2 :degr 0
                :intr intr-f :strt :cmbn
                :orgn `(echcm-kill-epi-f ,echcm))
            :g (build-mrph
                :sorc echcm2 :trgt echcm :degr 0
                :intr intr-g :strt :cmbn
                :orgn `(echcm-kill-epi-g ,echcm))
            :h (build-mrph
                :sorc echcm :trgt echcm :degr +1
                :intr intr-h :strt :cmbn
                :orgn `(echcm-kill-epi-h ,echcm))
            :orgn `(echcm-kill-epi ,echcm))))))


(DEFUN KILL-EPI (chcm first)
  (declare
   (type chain-complex chcm)
   (fixnum first))
  (the homotopy-equivalence
       (let ((efhm (efhm chcm))
             (echcm (echcm chcm)))
         (declare
          (type homotopy-equivalence efhm)
          (type chain-complex echcm))
         (let ((last-rdct (echcm-kill-epi echcm first)))
           (declare (type reduction last-rdct))
           (setf (slot-value chcm 'efhm)
                 (build-hmeq
                  :lrdct (lrdct efhm)
                  :rrdct (cmps last-rdct (rrdct efhm))
                  :orgn `(kill-epi ,chcm ,first)))))))


(DEFUN KILL-EPIS (chcm first end)
  (declare
   (type chain-complex chcm)
   (fixnum first end))
  (the homotopy-equivalence (progn
                              (do ((indx first (1+ indx)))
                                  ((= indx end))
                                (declare (fixnum indx))
                                (kill-epi chcm indx))
                              (efhm chcm))))


(DEFUN CHML-CLSS-INTR (chcm first)
  (declare
   (type chain-complex chcm)
   (fixnum first))
  (let* ((echcm (echcm chcm))
         (cmpr (cmpr echcm))
         (basis (basis echcm))
         (f-basis (funcall basis first))
         (mtrx-list (smith (chcm-mtrx echcm (1+ first))))
         (p-1 (second mtrx-list))
         (smith (third mtrx-list))
         (n (line-number smith))
         (m (column-number smith))
         (diag-indx (dotimes (indx (min n m)
                              (if (> n m)
                                  m
                                  (error "In CHML-CLSS, the cohomology-ring ~@
                                      is null.")))
                      (declare (fixnum indx))
                      (unless (= 1 (aref smith indx indx))
                        (return indx)))))
    (declare
     (type chain-complex echcm)
     (type cmprf cmpr)
     (type basis basis)
     (fixnum n m diag-indx)
     (list f-basis mtrx-list)
     (type matrix p-1 smith))
    (flet ((rslt (cmbn)
             (declare (type cmbn cmbn))
             (with-cmbn
                 (degr list) cmbn
                 (unless (= degr first)
                   (return-from rslt (zero-cmbn (- degr first))))
                 (do ((rslt 0)
                      (bmark f-basis)
                      (ic 0)
                      (cmark list (cdr cmark)))
                     ((endp cmark)
                      (if (zerop rslt)
                          (zero-cmbn 0)
                          (term-cmbn 0 rslt :z-gnrt)))
                   (declare
                    (fixnum rslt)
                    (list bmark cmark))
                   (with--term
                       (cffc gnrt) cmark
                       (loop
                          (when (eq :equal (funcall cmpr gnrt (car bmark)))
                            (return))
                          (pop bmark)
                          (incf ic))
                       (incf rslt (* cffc (aref p-1 diag-indx ic)))
                       (pop bmark)
                       (incf ic))))))
      (the intr-mrph #'rslt))))


(DEFUN CHML-CLSS (chcm first)
  (declare
   (type chain-complex chcm)
   (fixnum first))
  (the morphism
       (build-mrph
        :sorc (echcm chcm) :trgt (z-chcm) :degr (- first)
        :intr (chml-clss-intr chcm first)
        :strt :cmbn
        :orgn `(chml-clss ,chcm ,first))))