;;;  LP-SPACE-EFHM  LP-SPACE-EFHM  LP-SPACE-EFHM  LP-SPACE-EFHM
;;;  LP-SPACE-EFHM  LP-SPACE-EFHM  LP-SPACE-EFHM  LP-SPACE-EFHM
;;;  LP-SPACE-EFHM  LP-SPACE-EFHM  LP-SPACE-EFHM  LP-SPACE-EFHM

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

(PROVIDE "lp-space-efhm")

(DEFUN HAT-U-U (space
                  &aux (cobar (cobar space))
                       (loop-space (loop-space space))
                       (spac-tnsr-lpsp (tnsr-prdc space loop-space)))
   (declare
      (type simplicial-set space)
      (type chain-complex cobar spac-tnsr-lpsp)
      (type simplicial-group loop-space))
   (the chain-complex
      (tnsr-prdc cobar spac-tnsr-lpsp)))

(DEFUN HAT-LEFT-PERTURBATION-INTR (space)
   (declare (type simplicial-set space))
   (let ((cprd (dgnl space)))
      (flet ((rslt (degr tnpr)
                (declare
                   (fixnum degr)
                   (type tnpr tnpr))
                (with-tnpr (degr1 allp1 nil tnpr2) tnpr
                (with-tnpr (degr21 gmsm21 degr22 loop22) tnpr2
                   (let ((cprd (cmbn-list (gnrt-? cprd degr21 gmsm21))))
                      (declare (list cprd))
                      (setf cprd (rest cprd))    ;;; because \bar{A}
                      (make-cmbn :degr (1- degr)
                         :list
                         (mapcar
                            #'(lambda (term)
                                 (declare (type term term))
                                 (with-term (cffc tnpr21) term
                                 (with-tnpr (degr211 gmsm211 degr212 gmsm212) tnpr21
                                    (decf degr211)
                                    (term cffc
                                       (tnpr
                                          (+ degr1 degr211)
                                          (make-allp
                                             :list (append
                                                      (allp-list allp1)
                                                      (list (cbgn degr211 gmsm211))))
                                          (+ degr212 degr22)
                                          (tnpr degr212 gmsm212 degr22 loop22))))))
                            cprd)))))))
         (the intr-mrph #'rslt))))

(DEFUN HAT-LEFT-PERTURBATION (space)
   (declare (type simplicial-set space))
   (the morphism
      (let ((hat-u-u (hat-u-u space)))
         (build-mrph
            :sorc hat-u-u
            :trgt hat-u-u
            :degr -1
            :intr (hat-left-perturbation-intr space)
            :strt :gnrt
            :orgn `(hat-left-perturbation ,space)))))

(DEFUN HAT-T-U (space
                  &aux (hat-u-u (hat-u-u space))
                       (hat-left-perturbation
                          (hat-left-perturbation space)))
   (declare
      (type simplicial-set space)
      (type chain-complex hat-u-u)
      (type morphism hat-left-perturbation))
   (the chain-complex
      (progn
         (setf (slot-value hat-left-perturbation 'sorc) hat-u-u
               (slot-value hat-left-perturbation 'trgt) hat-u-u)
         ;; because maybe these slots have been modified when constructing
         ;;   the left-hmeq-right-reduction
         (add hat-u-u hat-left-perturbation))))

#|
  (cat-init)
  (setf c (hat-t-u (deltab)))
  (defun random-allp (length)
     (let ((rslt nil))
        (dotimes (i length)
           (let* ((gmsm (random (mask 9)))
                  (dmns (1- (logcount gmsm))))
              (when (plusp dmns)
                 (push (cbgn (1- dmns) gmsm) rslt))))
        (make-allp :list rslt)))
  (dotimes (i 10) (print (random-allp 5)))
  (setf allp (random-allp 4))  ;; the degree could be too big
                               ;; then redo
  (setf allp-degr (apply #'+ (mapcar #'car (allp-list allp))))
  (setf gnrt (tnpr allp-degr allp 4 (tnpr 2 7 2 (loop3 0 15 2))))
  (? c (+ 4 allp-degr) gnrt)
  (? c *)
  (dotimes (i 10)
     (let ((allp (random-allp 3)))
        (setf allp-degr (apply #'+ (mapcar #'car (allp-list allp))))
        (setf gnrt (tnpr allp-degr allp 4 (tnpr 2 7 2 (loop3 0 15 2))))
        (unless (>= allp-degr 11)
           (print (? c (+ 4 allp-degr) gnrt))
           (print (? c (? c (+ 4 allp-degr) gnrt))))))
  (dotimes (i 20)
     (let ((allp (random-allp 3)))
        (setf allp-degr (apply #'+ (mapcar #'car (allp-list allp))))
        (setf gnrt (tnpr allp-degr allp 5 (tnpr 3 15 2 (loop3 0 15 2))))
        (unless (>= allp-degr 10)
           (print (? c (+ 5 allp-degr) gnrt))
           (print (? c (? c (+ 5 allp-degr) gnrt))))))
  (dotimes (i 20)
     (let ((allp (random-allp 3)))
        (setf allp-degr (apply #'+ (mapcar #'car (allp-list allp))))
        (setf gnrt (tnpr allp-degr allp 5 (tnpr 2 7 3 (loop3 0 31 2))))
        (unless (>= allp-degr 10)
           (print (? c (+ 5 allp-degr) gnrt))
           (print (? c (? c (+ 5 allp-degr) gnrt))))))
|#

(DEFUN HAT-RIGHT-PERTURBATION (space
                                 &aux (cobar (cobar space))
                                      (hat-t-u (hat-t-u space)))
   (declare
      (type simplicial-set space)
      (type chain-complex cobar hat-t-u))
   (the morphism
      (multiple-value-bind (szczarba bottom-perturbation)
                           (szczarba space)
         (declare
            (ignore szczarba)
            (type morphism bottom-perturbation))
         (let ((rslt (tnsr-prdc (idnt-mrph cobar) bottom-perturbation)))
        (declare (type morphism rslt))
            (setf (slot-value rslt 'sorc) hat-t-u
                  (slot-value rslt 'trgt) hat-t-u)
            rslt))))

(DEFUN HAT-U-T (space
                  &aux (cobar (cobar space))
                       (twisted-tnsr-prdc (twisted-tnsr-prdc space))
                       (hat-u-u (hat-u-u space)))
   (declare
      (type simplicial-set space)
      (type chain-complex cobar twisted-tnsr-prdc hat-u-u))
   (the chain-complex
      (let ((rslt (tnsr-prdc cobar twisted-tnsr-prdc)))
         (declare (type chain-complex rslt))
         (setf (slot-value rslt 'grmd) hat-u-u)
         rslt)))

#|
  (cat-init)
  (setf c (hat-u-t (deltab)))
  (defun random-allp (length)
     (let ((rslt nil))
        (dotimes (i length)
           (let* ((gmsm (random (mask 9)))
                  (dmns (1- (logcount gmsm))))
              (when (plusp dmns)
                 (push (cbgn (1- dmns) gmsm) rslt))))
        (make-allp :list rslt)))
  (dotimes (i 10) (print (random-allp 5)))
  (setf allp (random-allp 3))
  (setf allp-degr (apply #'+ (mapcar #'car (allp-list allp))))
  (setf gnrt (tnpr allp-degr allp 4 (tnpr 2 7 2 (loop3 0 15 2))))
  (? c (+ 4 allp-degr) gnrt)
  (? c *)
  (dotimes (i 10)
     (let ((allp (random-allp 3)))
        (setf allp-degr (apply #'+ (mapcar #'car (allp-list allp))))
        (setf gnrt (tnpr allp-degr allp 4 (tnpr 2 7 2 (loop3 0 15 2))))
        (unless (>= allp-degr 11)
           (print (? c (+ 4 allp-degr) gnrt))
           (print (? c (? c (+ 4 allp-degr) gnrt))))))
  (dotimes (i 20)
     (let ((allp (random-allp 3)))
        (setf allp-degr (apply #'+ (mapcar #'car (allp-list allp))))
        (setf gnrt (tnpr allp-degr allp 5 (tnpr 3 15 2 (loop3 0 15 2))))
        (unless (>= allp-degr 10)
           (print (? c (+ 5 allp-degr) gnrt))
           (print (? c (? c (+ 5 allp-degr) gnrt))))))
  (dotimes (i 20)
     (let ((allp (random-allp 3)))
        (setf allp-degr (apply #'+ (mapcar #'car (allp-list allp))))
        (setf gnrt (tnpr allp-degr allp 5 (tnpr 2 7 3 (loop3 0 31 2))))
        (unless (>= allp-degr 10)
           (print (? c (+ 5 allp-degr) gnrt))
           (print (? c (? c (+ 5 allp-degr) gnrt))))))
|#

(DEFUN LEFT-HMEQ-HAT (space
                    &aux
                    (hat-u-t (hat-u-t space))
                    (hat-left-perturbation
                       (hat-left-perturbation space)))
   (declare
      (type simplicial-set space)
      (type chain-complex hat-u-t)
      (type morphism hat-left-perturbation))
   (the chain-complex
      (add hat-u-t hat-left-perturbation)))

#|
  (cat-init)
  (setf c (left-hmeq-hat (deltab)))
  (defun random-allp (length)
     (let ((rslt nil))
        (dotimes (i length)
           (let* ((gmsm (random (mask 9)))
                  (dmns (1- (logcount gmsm))))
              (when (plusp dmns)
                 (push (cbgn (1- dmns) gmsm) rslt))))
        (make-allp :list rslt)))
  (dotimes (i 10) (print (random-allp 5)))
  (setf allp (random-allp 3))
  (setf allp-degr (apply #'+ (mapcar #'car (allp-list allp))))
  (setf gnrt (tnpr allp-degr allp 4 (tnpr 2 7 2 (loop3 0 15 2))))
  (? c (+ 4 allp-degr) gnrt)
  (? c *)
  (dotimes (i 10)
     (let ((allp (random-allp 3)))
        (setf allp-degr (apply #'+ (mapcar #'car (allp-list allp))))
        (setf gnrt (tnpr allp-degr allp 4 (tnpr 2 7 2 (loop3 0 15 2))))
        (unless (>= allp-degr 11)
           (print (? c (+ 4 allp-degr) gnrt))
           (print (? c (? c (+ 4 allp-degr) gnrt))))))
  (dotimes (i 20)
     (let ((allp (random-allp 3)))
        (setf allp-degr (apply #'+ (mapcar #'car (allp-list allp))))
        (setf gnrt (tnpr allp-degr allp 5 (tnpr 3 15 2 (loop3 0 15 2))))
        (unless (>= allp-degr 10)
           (print (? c (+ 5 allp-degr) gnrt))
           (print (? c (? c (+ 5 allp-degr) gnrt))))))
  (dotimes (i 20)
     (let ((allp (random-allp 3)))
        (setf allp-degr (apply #'+ (mapcar #'car (allp-list allp))))
        (setf gnrt (tnpr allp-degr allp 5 (tnpr 2 7 3 (loop3 0 31 2))))
        (unless (>= allp-degr 10)
           (print (? c (+ 5 allp-degr) gnrt))
           (print (? c (? c (+ 5 allp-degr) gnrt))))))
|#

(DEFUN PRE-LEFT-HMEQ-LEFT-REDUCTION-INTR-F (cmbn)
   (declare (type cmbn cmbn))
   (the cmbn
      (let ((rslt +empty-list+))
         (declare (list rslt))
         (dolist (term (cmbn-list cmbn))
            (declare (type term term))
            (with-term (cffc tnpr) term
            (with-tnpr (degr1 nil nil tnpr2) tnpr
               (if (zerop degr1)
                  (with-tnpr (degr21 nil nil loop22) tnpr2
                     (if (zerop degr21)
                        (push (term cffc loop22) rslt)
                        (return)))
                  (return)))))
         (make-cmbn :degr (cmbn-degr cmbn)
            :list (nreverse rslt)))))

#|
  (pre-left-hmeq-left-reduction-intr-f
    (cmbn 6 100 (tnpr 0 'a 6 (tnpr 0 'b 6 'c))
            50 (tnpr 0 'a 6 (tnpr 0 'b 6 'cc))
            10 (tnpr 0 'a 6 (tnpr 2 'b 4 'c))
            1 (tnpr 2 'a 4 (tnpr 2 'b 2 'cc))))
|#

(DEFUN PRE-LEFT-HMEQ-LEFT-REDUCTION-F (space
                                         &aux (hat-t-u (hat-t-u space))
                                              (loop-space (loop-space space)))
   (declare
      (type simplicial-set space loop-space)
      (type chain-complex hat-t-u))
   (the morphism
      (build-mrph
         :sorc hat-t-u
         :trgt loop-space
         :degr 0
         :intr #'pre-left-hmeq-left-reduction-intr-f
         :strt :cmbn
         :orgn `(pre-left-hmeq-left-reduction-f ,space))))

(DEFUN LEFT-HMEQ-LEFT-REDUCTION-G-INTR (bspn)
   (declare (type gmsm bspn))
   (flet ((rslt (cmbn)
             (declare (type cmbn cmbn))
             (the cmbn
                (with-cmbn (degr list) cmbn
                   (make-cmbn :degr degr
                      :list (mapcar
                               #'(lambda (term)
                                    (declare (type term term))
                                    (with-term (cffc loop) term
                                       (term cffc
                                          (tnpr
                                             0 +null-allp+
                                             degr (tnpr 0 bspn degr loop)))))
                               list))))))
      (the intr-mrph #'rslt)))

#|
  (setf r (left-hmeq-left-reduction-g-intr '*))
  (funcall r (cmbn 3 4 'loop))
|#

(DEFUN LEFT-HMEQ-LEFT-REDUCTION-G (space
                                     &aux (bspn (bspn space))
                                          (hat-t-u (hat-t-u space))
                                          (loop-space (loop-space space)))
   (declare
      (type simplicial-set space loop-space)
      (type gmsm bspn)
      (type chain-complex hat-t-u))
   (the morphism
      (build-mrph
         :sorc loop-space
         :trgt hat-t-u
         :degr 0
         :intr (left-hmeq-left-reduction-g-intr bspn)
         :strt :cmbn
         :orgn `(left-hmeq-left-reduction-g ,space))))

(DEFUN PRE-LEFT-HMEQ-LEFT-REDUCTION-H-INTR (space
                                          &aux (hat-t-u (hat-t-u space))
                                               (cmpr (cmpr hat-t-u)))
   (declare
      (type simplicial-set space)
      (type chain-complex hat-t-u)
      (type cmprf cmpr))
   (flet ((rslt (cmbn)
             (declare (type cmbn cmbn))
             (the cmbn
                (with-cmbn (degr list) cmbn
                   (let ((rslt (zero-cmbn (1+ degr))))
                      (declare (type cmbn rslt))
                      (dolist (term list)
                         (declare (type term term))
                         (with-term (cffc tnpr) term
                            (with-tnpr (degr1 allp1 degr2 tnpr2) tnpr
                               (unless (zerop degr1)
                                  (with-tnpr (degr21 nil degr22 loop22) tnpr2
                                     (when (zerop degr21)
                                        (let ((last-cbgn (car (last allp1))))
                                           (declare (type cbgn last-cbgn))
                                           (with-cbgn (degrl gmsml) last-cbgn
                                              (dstr-add-term-to-cmbn cmpr
                                                 cffc
                                                 (tnpr
                                                    (- degr1 degrl)
                                                    (butlast allp1)
                                                    (+ degr2 degrl 1)
                                                    (tnpr
                                                       (1+ degrl)
                                                       gmsml
                                                       degr22
                                                       loop22))
                                                 rslt)))))))))
                      rslt)))))
      (the intr-mrph #'rslt)))

#|
  (setf r (pre-left-hmeq-left-reduction-h-intr (deltab)))
  (setf *tnpr-with-degrees* t)
  (funcall r (cmbn 10 1 (tnpr 3 (allp 2 'a 1 'b) 7 (tnpr 5 'c 2 'd))
                      1 (tnpr 7 (allp 2 'a 5 'b) 3 (tnpr 0 '* 3 'c))
                      10 (tnpr 8 (allp 4 'aa 4 'bb) 2 (tnpr 0 '* 2 'cc))))
  (funcall r (cmbn 10 1 (tnpr 3 (allp 2 'a 1 'b) 7 (tnpr 5 'c 2 'd))
                      1 (tnpr 7 (allp 4 'a 3 'b) 3 (tnpr 0 '* 3 'c))
                      10 (tnpr 8 (allp 3 'aa 5 'bb) 2 (tnpr 0 '* 2 'cc))))
  (setf *tnpr-with-degrees* nil)
|#

(DEFUN PRE-LEFT-HMEQ-LEFT-REDUCTION-H (space
                                     &aux (hat-t-u (hat-t-u space)))
   (declare
      (type simplicial-set space)
      (type chain-complex hat-t-u))
   (the morphism
      (build-mrph
         :sorc hat-t-u
         :trgt hat-t-u
         :degr +1
         :intr (pre-left-hmeq-left-reduction-h-intr space)
         :strt :cmbn
         :orgn `(pre-left-hmeq-left-reduction-h ,space))))

(DEFUN PRE-LEFT-HMEQ-LEFT-REDUCTION (space)
   (declare (type simplicial-set space))
   (the reduction
      (build-rdct
         :f (pre-left-hmeq-left-reduction-f space)
         :g (left-hmeq-left-reduction-g space)
         :h (pre-left-hmeq-left-reduction-h space)
         :orgn `(pre-left-hmeq-left-reduction ,space))))

#|
  (cat-init)
  (setf rdct (pre-left-hmeq-left-reduction (deltab)))
  (pre-check-rdct rdct)
  (defun random-allp (length)
     (let ((rslt nil))
        (dotimes (i length)
           (let* ((gmsm (random (mask 9)))
                  (dmns (1- (logcount gmsm))))
              (when (plusp dmns)
                 (push (cbgn (1- dmns) gmsm) rslt))))
        (make-allp :list rslt)))
  (setf allp (random-allp 3))
  (setf allp-degr (apply #'+ (mapcar #'car (allp-list allp))))
  (setf gnrt (tnpr allp-degr allp 4 (tnpr 2 7 2 (loop3 0 15 2))))
  (setf *tc* (cmbn (+ 4 allp-degr) 1 gnrt))
  (setf *bc* (cmbn 2 1 (loop3 0 15 2)))
  (check-rdct)
  (setf gnrt (tnpr allp-degr allp 4 (tnpr 0 1 4 (loop3 0 (mask 6) 2))))
  (setf *tc* (cmbn (+ 4 allp-degr) 1 gnrt))
  (check-rdct)
  (setf *bc* (cmbn 0 1 (bspn (bcc rdct)))
  (setf *tc* (cmbn 0 1 (bsgn (tcc rdct)))
  (check-rdct)
|#

(DEFUN LEFT-HMEQ-LEFT-REDUCTION (space
                                   &aux (pre-left-hmeq-left-reduction
                                           (pre-left-hmeq-left-reduction space))
                                        (hat-right-perturbation
                                           (hat-right-perturbation space)))
   (declare
      (type simplicial-set space)
      (type reduction pre-left-hmeq-left-reduction)
      (type morphism hat-right-perturbation))
   (the reduction
      (progn
     (dstr-change-sorc-trgt hat-right-perturbation
        :new-sorc (tcc pre-left-hmeq-left-reduction)
        :new-trgt (tcc pre-left-hmeq-left-reduction))
         (let ((rslt (special-bpl pre-left-hmeq-left-reduction
                        hat-right-perturbation)))
            (declare (type reduction rslt))
            (with-slots (tcc f g h) rslt
               (setf tcc (left-hmeq-hat space)
                     (slot-value f 'sorc) tcc
                     (slot-value g 'trgt) tcc
                     (slot-value h 'sorc) tcc
                     (slot-value h 'trgt) tcc)
               rslt)))))

#|
  (cat-init)
  (setf rdct (left-hmeq-left-reduction (deltab2)))
  (pre-check-rdct rdct)
  (defun a (d1 d2 d3)
     (setf *tc* (cmbn (+ d1 d2 d3)
                 1 (tnpr d1 (allp d1 (mask (+ d1 2)))
                         (+ d2 d3)
                      (tnpr d2 (mask (1+ d2))
                            d3 (loop3 0 (mask (+ d3 2)) 1))))
           *bc* (cmbn d3 1
                  (loop3 0 (mask (+ d3 2)) -1)))
      (check-rdct))
  (a 1 0 1)
  (a 1 1 1)  ;; error because 3 does not exist in deltab2
  (a 1 2 1)
  (a 2 2 1)
|#

(DEFUN PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-F (cmbn)
   (declare (type cmbn cmbn))
   (the cmbn
      (with-cmbn (degr list) cmbn
         (let ((tail (member 0 list :test #'= :key #'cadddr)))
            (make-cmbn :degr degr
               :list (mapcar
                        #'(lambda (term)
                             (declare (type term term))
                             (with-term (cffc tnpr) term
                                (term cffc (gnrt1 tnpr))))
                        tail))))))

#|
  (pre-left-hmeq-right-reduction-intr-f
     (cmbn 3 12 (tnpr 2 'a 1 'b) 14 (tnpr 3 'aa 0 '*))))
|#

(DEFUN PRE-LEFT-HMEQ-RIGHT-REDUCTION-F (space
                                          &aux (hat-u-t (hat-u-t space))
                                               (cobar (cobar space)))
   (declare
      (type simplicial-set space)
      (type chain-complex hat-u-t cobar))
   (the morphism
      (build-mrph
         :sorc hat-u-t :trgt cobar :degr 0
         :intr #'pre-left-hmeq-right-reduction-intr-f
         :strt :cmbn
         :orgn `(pre-left-hmeq-right-reduction-f ,space))))

(DEFUN PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-G (bspn)
   (declare (type gmsm bspn))
   (flet ((rslt (cmbn)
             (declare (type cmbn cmbn))
             (the cmbn
                (with-cmbn (degr list) cmbn
                   (let ((bsgn (tnpr 0 bspn 0 +null-loop+)))
                      (declare (type tnpr bsgn))
                      (make-cmbn :degr degr
                         :list (mapcar
                                  #'(lambda (term)
                                       (declare (type term term))
                                       (with-term (cffc gnrt) term
                                          (term cffc (tnpr degr gnrt 0 bsgn))))
                                  list)))))))
      (the intr-mrph #'rslt)))

#|
  (setf r (pre-left-hmeq-right-reduction-intr-g '*))
  (funcall r (cmbn 3 4 'a))
|#

(DEFUN PRE-LEFT-HMEQ-RIGHT-REDUCTION-G (space
                                          &aux (hat-u-t (hat-u-t space))
                                               (cobar (cobar space))
                                               (bspn (bspn space)))
   (declare
      (type simplicial-set space)
      (type chain-complex hat-u-t cobar)
      (type gmsm bspn))
   (the morphism
      (build-mrph
         :sorc cobar :trgt hat-u-t :degr 0
         :intr (pre-left-hmeq-right-reduction-intr-g bspn)
         :strt :cmbn
         :orgn `(pre-left-hmeq-right-reduction-g ,space))))

(DEFUN PRE-LEFT-HMEQ-RIGHT-REDUCTION-H (space
                                          &aux (cobar (cobar space))
                                               (tnpr-contraction (tnpr-contraction space)))
   (declare
      (type simplicial-set space)
      (type chain-complex cobar)
      (type morphism tnpr-contraction))
   (the morphism
      (tnsr-prdc (idnt-mrph cobar) tnpr-contraction)))

(DEFUN PRE-LEFT-HMEQ-RIGHT-REDUCTION (space)
   (declare (type simplicial-set space))
   (the reduction
      (build-rdct
         :f (pre-left-hmeq-right-reduction-f space)
         :g (pre-left-hmeq-right-reduction-g space)
         :h (pre-left-hmeq-right-reduction-h space)
         :orgn `(pre-left-hmeq-right-reduction ,space))))

#|
  (cat-init)
  (setf r (pre-left-hmeq-right-reduction (deltab2)))
  (pre-check-rdct r)
  (setf *tc* (cmbn 0 1 (bsgn (tcc r))))
  (setf *bc* (cmbn 0 1 (bsgn (bcc r))))
  (check-rdct)
  (setf *tc* (cmbn 3 1 (tnpr 3 (allp 3 (mask 5)) 0 (tnpr 0 1 0 +null-loop+))))
  (setf *bc* (cmbn 3 1 (allp 1 7 2 15)))
  (check-rdct)
  (setf *tc* (cmbn 6 1 (tnpr 3 (allp 1 7 2 15) 3 (tnpr 2 7 1 (loop3 0 7 2)))))
  (check-rdct)
  (setf *tc* (cmbn 6 1 (tnpr 3 (allp 1 7 2 15) 3 (tnpr 0 1 3 (loop3 0 (mask 5) 2)))))
  (check-rdct)
|#

(DEFUN LEFT-HMEQ-RIGHT-REDUCTION (space
                                    &aux (pre-reduction
                                            (pre-left-hmeq-right-reduction space))
                                         (perturbation
                                            (hat-left-perturbation space)))
   (declare
     (type simplicial-set space)
     (type reduction pre-reduction)
     (type morphism perturbation))
   (the reduction
      (progn
         (setf (slot-value perturbation 'sorc) (tcc pre-reduction)
               (slot-value perturbation 'trgt) (tcc pre-reduction))
         (special-bpl pre-reduction perturbation))))

#|
  (cat-init)
  (setf r (left-hmeq-right-reduction (deltab2)))
  (pre-check-rdct r)
  (setf *tc* (cmbn 0 1 (bsgn (tcc r))))
  (setf *bc* (cmbn 0 1 (bsgn (bcc r))))
  (check-rdct)
  (setf *tc* (cmbn 3 1 (tnpr 3 (allp 3 (mask 5)) 0 (tnpr 0 1 0 +null-loop+))))
  (setf *bc* (cmbn 3 1 (allp 1 7 2 15)))
  (check-rdct)
  (setf *tc* (cmbn 6 1 (tnpr 3 (allp 1 7 2 15) 3 (tnpr 2 7 1 (loop3 0 7 2)))))
  (check-rdct)
  (setf *tc* (cmbn 6 1 (tnpr 3 (allp 1 7 2 15) 3 (tnpr 0 1 3 (loop3 0 (mask 5) 2)))))
  (check-rdct)
|#

(DEFUN LEFT-HMEQ (space)
   (declare (type simplicial-set space))
   (the homotopy-equivalence
      (build-hmeq
         :lrdct (left-hmeq-left-reduction space)
         :rrdct (left-hmeq-right-reduction space)
         :orgn `(left-hmeq ,space))))

#|
  (cat-init)
  (setf h (left-hmeq (deltab2)))
  (setf loop (loop3 0 (mask 5) 2))
  (lg h 3 loop)
  (rf h *)
  (rg h *)
  (lf h *)
  (setf allp (allp 2 (mask 4) 3 (mask 5)))
  (rg h 5 allp)
  (lf h *)
  (lg h *)
  (rf h *)  ;; = allp, but why ?
|#

(DEFUN LOOP-SPACE-EFHM (space)
  (declare (type simplicial-set space))
  (let ((left-hmeq (left-hmeq space))
    (right-hmeq (cobar (efhm space))))
    (declare (type homotopy-equivalence left-hmeq right-hmeq))
    (cmps left-hmeq right-hmeq)))

(DEFMETHOD SEARCH-EFHM (loop-space (orgn (eql 'loop-space)))
  (declare (type simplicial-set loop-space))
  (loop-space-efhm (second (orgn loop-space))))

#|
  (cat-init)
  (setf l (loop-space (sphere 2)))
  (homology l 6)
  (setf oos3 (loop-space (loop-space (sphere 3))))
  (homology oos3 3)
  (setf ooos4 (loop-space (loop-space (loop-space (sphere 4)))))
  (homology ooos4 2)
|#




Home page.