mmarco/kenzo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Same remedy as #40 #41 #43 #45.

Browse Source
This commit is contained in:
Gerd Heber 2015-11-18 20:04:43 -06:00
parent d061360c93
commit 6e7234e191
2 changed files with 413 additions and 438 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

448
src/lp-space-efhm.lisp
View File

@ -7,9 +7,9 @@
(PROVIDE "lp-space-efhm") (PROVIDE "lp-space-efhm")
(DEFUN LS-HAT-U-U (space (DEFUN LS-HAT-U-U (space
&aux (cobar (cobar space)) &aux (cobar (cobar space))
(loop-space (loop-space space)) (loop-space (loop-space space))
(spac-tnsr-lpsp (tnsr-prdc space loop-space))) (spac-tnsr-lpsp (tnsr-prdc space loop-space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type chain-complex cobar spac-tnsr-lpsp) (type chain-complex cobar spac-tnsr-lpsp)
@ -22,38 +22,38 @@
(declare (type simplicial-set space)) (declare (type simplicial-set space))
(let ((cprd (dgnl space))) (let ((cprd (dgnl space)))
(flet ((rslt (degr tnpr) (flet ((rslt (degr tnpr)
(declare (declare
(fixnum degr) (fixnum degr)
(type tnpr tnpr)) (type tnpr tnpr))
(with-tnpr (with-tnpr
(degr1 allp1 nil tnpr2) tnpr (degr1 allp1 nil tnpr2) tnpr
(with-tnpr (with-tnpr
(degr21 gmsm21 degr22 loop22) tnpr2 (degr21 gmsm21 degr22 loop22) tnpr2
(let ((cprd (cmbn-list (gnrt-? cprd degr21 gmsm21)))) (let ((cprd (cmbn-list (gnrt-? cprd degr21 gmsm21))))
(declare (list cprd)) (declare (list cprd))
(setf cprd (rest cprd)) ;;; because \bar{A} (setf cprd (rest cprd)) ;;; because \bar{A}
(make-cmbn (make-cmbn
:degr (1- degr) :degr (1- degr)
:list :list
(mapcar (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc tnpr21) term (cffc tnpr21) term
(with-tnpr (with-tnpr
(degr211 gmsm211 degr212 gmsm212) tnpr21 (degr211 gmsm211 degr212 gmsm212) tnpr21
(decf degr211) (decf degr211)
(term cffc (tnpr (+ degr1 degr211) (term cffc (tnpr (+ degr1 degr211)
(make-allp (make-allp
:list :list
(append (append
(allp-list allp1) (allp-list allp1)
(list (cbgn degr211 (list (cbgn degr211
gmsm211)))) gmsm211))))
(+ degr212 degr22) (+ degr212 degr22)
(tnpr degr212 gmsm212 (tnpr degr212 gmsm212
degr22 loop22)))))) degr22 loop22))))))
cprd))))))) cprd)))))))
(the intr-mrph #'rslt)))) (the intr-mrph #'rslt))))
@ -62,17 +62,17 @@
(the morphism (the morphism
(let ((ls-hat-u-u (ls-hat-u-u space))) (let ((ls-hat-u-u (ls-hat-u-u space)))
(build-mrph (build-mrph
:sorc ls-hat-u-u :sorc ls-hat-u-u
:trgt ls-hat-u-u :trgt ls-hat-u-u
:degr -1 :degr -1
:intr (ls-hat-left-perturbation-intr space) :intr (ls-hat-left-perturbation-intr space)
:strt :gnrt :strt :gnrt
:orgn `(ls-hat-left-perturbation ,space))))) :orgn `(ls-hat-left-perturbation ,space)))))
(DEFUN LS-HAT-T-U (space (DEFUN LS-HAT-T-U (space
&aux (ls-hat-u-u (ls-hat-u-u space)) &aux (ls-hat-u-u (ls-hat-u-u space))
(ls-hat-left-perturbation (ls-hat-left-perturbation
(ls-hat-left-perturbation space))) (ls-hat-left-perturbation space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type chain-complex ls-hat-u-u) (type chain-complex ls-hat-u-u)
@ -87,27 +87,27 @@
(DEFUN LS-HAT-RIGHT-PERTURBATION (space (DEFUN LS-HAT-RIGHT-PERTURBATION (space
&aux (cobar (cobar space)) &aux (cobar (cobar space))
(ls-hat-t-u (ls-hat-t-u space))) (ls-hat-t-u (ls-hat-t-u space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type chain-complex cobar ls-hat-t-u)) (type chain-complex cobar ls-hat-t-u))
(the morphism (the morphism
(multiple-value-bind (szczarba bottom-perturbation) (multiple-value-bind (szczarba bottom-perturbation)
(szczarba space) (szczarba space)
(declare (declare
(ignore szczarba) (ignore szczarba)
(type morphism bottom-perturbation)) (type morphism bottom-perturbation))
(let ((rslt (tnsr-prdc (idnt-mrph cobar) bottom-perturbation))) (let ((rslt (tnsr-prdc (idnt-mrph cobar) bottom-perturbation)))
(declare (type morphism rslt)) (declare (type morphism rslt))
(setf (slot-value rslt 'sorc) ls-hat-t-u (setf (slot-value rslt 'sorc) ls-hat-t-u
(slot-value rslt 'trgt) ls-hat-t-u) (slot-value rslt 'trgt) ls-hat-t-u)
rslt)))) rslt))))
(DEFUN LS-HAT-U-T (space (DEFUN LS-HAT-U-T (space
&aux (cobar (cobar space)) &aux (cobar (cobar space))
(twisted-tnsr-prdc (twisted-tnsr-prdc space)) (twisted-tnsr-prdc (twisted-tnsr-prdc space))
(ls-hat-u-u (ls-hat-u-u space))) (ls-hat-u-u (ls-hat-u-u space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type chain-complex cobar twisted-tnsr-prdc ls-hat-u-u)) (type chain-complex cobar twisted-tnsr-prdc ls-hat-u-u))
@ -119,10 +119,10 @@
(DEFUN LS-LEFT-HMEQ-HAT (space (DEFUN LS-LEFT-HMEQ-HAT (space
&aux &aux
(ls-hat-u-t (ls-hat-u-t space)) (ls-hat-u-t (ls-hat-u-t space))
(ls-hat-left-perturbation (ls-hat-left-perturbation
(ls-hat-left-perturbation space))) (ls-hat-left-perturbation space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type chain-complex ls-hat-u-t) (type chain-complex ls-hat-u-t)
@ -137,75 +137,75 @@
(let ((rslt +empty-list+)) (let ((rslt +empty-list+))
(declare (list rslt)) (declare (list rslt))
(dolist (term (cmbn-list cmbn)) (dolist (term (cmbn-list cmbn))
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc tnpr) term (cffc tnpr) term
(with-tnpr (degr1 nil nil tnpr2) tnpr (with-tnpr (degr1 nil nil tnpr2) tnpr
(if (zerop degr1) (if (zerop degr1)
(with-tnpr (with-tnpr
(degr21 nil nil loop22) tnpr2 (degr21 nil nil loop22) tnpr2
(if (zerop degr21) (if (zerop degr21)
(push (term cffc loop22) rslt) (push (term cffc loop22) rslt)
(return))) (return)))
(return))))) (return)))))
(make-cmbn :degr (cmbn-degr cmbn) (make-cmbn :degr (cmbn-degr cmbn)
:list (nreverse rslt))))) :list (nreverse rslt)))))
(DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-F (space (DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-F (space
&aux (ls-hat-t-u (ls-hat-t-u space)) &aux (ls-hat-t-u (ls-hat-t-u space))
(loop-space (loop-space space))) (loop-space (loop-space space)))
(declare (declare
(type simplicial-set space loop-space) (type simplicial-set space loop-space)
(type chain-complex ls-hat-t-u)) (type chain-complex ls-hat-t-u))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc ls-hat-t-u :sorc ls-hat-t-u
:trgt loop-space :trgt loop-space
:degr 0 :degr 0
:intr #'ls-pre-left-hmeq-left-reduction-intr-f :intr #'ls-pre-left-hmeq-left-reduction-intr-f
:strt :cmbn :strt :cmbn
:orgn `(ls-pre-left-hmeq-left-reduction-f ,space)))) :orgn `(ls-pre-left-hmeq-left-reduction-f ,space))))
(DEFUN LS-LEFT-HMEQ-LEFT-REDUCTION-G-INTR (bspn) (DEFUN LS-LEFT-HMEQ-LEFT-REDUCTION-G-INTR (bspn)
(declare (type gmsm bspn)) (declare (type gmsm bspn))
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(with-cmbn (with-cmbn
(degr list) cmbn (degr list) cmbn
(make-cmbn :degr degr (make-cmbn :degr degr
:list (mapcar :list (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc loop) term (cffc loop) term
(term cffc (term cffc
(tnpr (tnpr
0 +null-allp+ 0 +null-allp+
degr degr
(tnpr 0 bspn degr (tnpr 0 bspn degr
loop))))) loop)))))
list)))))) list))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
(DEFUN LS-LEFT-HMEQ-LEFT-REDUCTION-G (space (DEFUN LS-LEFT-HMEQ-LEFT-REDUCTION-G (space
&aux (bspn (bspn space)) &aux (bspn (bspn space))
(ls-hat-t-u (ls-hat-t-u space)) (ls-hat-t-u (ls-hat-t-u space))
(loop-space (loop-space space))) (loop-space (loop-space space)))
(declare (declare
(type simplicial-set space loop-space) (type simplicial-set space loop-space)
(type gmsm bspn) (type gmsm bspn)
(type chain-complex ls-hat-t-u)) (type chain-complex ls-hat-t-u))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc loop-space :sorc loop-space
:trgt ls-hat-t-u :trgt ls-hat-t-u
:degr 0 :degr 0
:intr (ls-left-hmeq-left-reduction-g-intr bspn) :intr (ls-left-hmeq-left-reduction-g-intr bspn)
:strt :cmbn :strt :cmbn
:orgn `(ls-left-hmeq-left-reduction-g ,space)))) :orgn `(ls-left-hmeq-left-reduction-g ,space))))
(DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-H-INTR (DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-H-INTR
@ -219,88 +219,88 @@
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(with-cmbn (with-cmbn
(degr list) cmbn (degr list) cmbn
(let ((rslt (zero-cmbn (1+ degr)))) (let ((rslt (zero-cmbn (1+ degr))))
(declare (type cmbn rslt)) (declare (type cmbn rslt))
(dolist (term list) (dolist (term list)
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc tnpr) term (cffc tnpr) term
(with-tnpr (with-tnpr
(degr1 allp1 degr2 tnpr2) tnpr (degr1 allp1 degr2 tnpr2) tnpr
(unless (zerop degr1) (unless (zerop degr1)
(with-tnpr (with-tnpr
(degr21 nil degr22 loop22) tnpr2 (degr21 nil degr22 loop22) tnpr2
(when (zerop degr21) (when (zerop degr21)
(setf allp1 (allp-list allp1)) ;;;+++ (setf allp1 (allp-list allp1)) ;;;+++
(let ((last-cbgn (car (last allp1)))) (let ((last-cbgn (car (last allp1))))
(declare (type cbgn last-cbgn)) (declare (type cbgn last-cbgn))
(with-cbgn (with-cbgn
(degrl gmsml) last-cbgn (degrl gmsml) last-cbgn
(dstr-add-term-to-cmbn (dstr-add-term-to-cmbn
cmpr cffc cmpr cffc
(tnpr (- degr1 degrl) (tnpr (- degr1 degrl)
(make-allp (make-allp
:list (butlast allp1)) :list (butlast allp1))
(+ degr2 degrl 1) (+ degr2 degrl 1)
(tnpr (1+ degrl) gmsml (tnpr (1+ degrl) gmsml
degr22 loop22)) degr22 loop22))
rslt))))))))) rslt)))))))))
rslt))))) rslt)))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
(DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-H (space (DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-H (space
&aux (ls-hat-t-u (ls-hat-t-u space))) &aux (ls-hat-t-u (ls-hat-t-u space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type chain-complex ls-hat-t-u)) (type chain-complex ls-hat-t-u))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc ls-hat-t-u :sorc ls-hat-t-u
:trgt ls-hat-t-u :trgt ls-hat-t-u
:degr +1 :degr +1
:intr (ls-pre-left-hmeq-left-reduction-h-intr space) :intr (ls-pre-left-hmeq-left-reduction-h-intr space)
:strt :cmbn :strt :cmbn
:orgn `(ls-pre-left-hmeq-left-reduction-h ,space)))) :orgn `(ls-pre-left-hmeq-left-reduction-h ,space))))
(DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION (space) (DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION (space)
(declare (type simplicial-set space)) (declare (type simplicial-set space))
(the reduction (the reduction
(build-rdct (build-rdct
:f (ls-pre-left-hmeq-left-reduction-f space) :f (ls-pre-left-hmeq-left-reduction-f space)
:g (ls-left-hmeq-left-reduction-g space) :g (ls-left-hmeq-left-reduction-g space)
:h (ls-pre-left-hmeq-left-reduction-h space) :h (ls-pre-left-hmeq-left-reduction-h space)
:orgn `(ls-pre-left-hmeq-left-reduction ,space)))) :orgn `(ls-pre-left-hmeq-left-reduction ,space))))
(DEFUN LS-LEFT-HMEQ-LEFT-REDUCTION (space (DEFUN LS-LEFT-HMEQ-LEFT-REDUCTION (space
&aux (ls-pre-left-hmeq-left-reduction &aux (ls-pre-left-hmeq-left-reduction
(ls-pre-left-hmeq-left-reduction (ls-pre-left-hmeq-left-reduction
space)) space))
(ls-hat-right-perturbation (ls-hat-right-perturbation
(ls-hat-right-perturbation space))) (ls-hat-right-perturbation space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type reduction ls-pre-left-hmeq-left-reduction) (type reduction ls-pre-left-hmeq-left-reduction)
(type morphism ls-hat-right-perturbation)) (type morphism ls-hat-right-perturbation))
(the reduction (the reduction
(progn (progn
(dstr-change-sorc-trgt ls-hat-right-perturbation (dstr-change-sorc-trgt ls-hat-right-perturbation
:new-sorc (tcc ls-pre-left-hmeq-left-reduction) :new-sorc (tcc ls-pre-left-hmeq-left-reduction)
:new-trgt (tcc ls-pre-left-hmeq-left-reduction)) :new-trgt (tcc ls-pre-left-hmeq-left-reduction))
(let ((rslt (special-bpl ls-pre-left-hmeq-left-reduction (let ((rslt (special-bpl ls-pre-left-hmeq-left-reduction
ls-hat-right-perturbation))) ls-hat-right-perturbation)))
(declare (type reduction rslt)) (declare (type reduction rslt))
(with-slots (tcc f g h) rslt (with-slots (tcc f g h) rslt
(setf tcc (ls-left-hmeq-hat space) (setf tcc (ls-left-hmeq-hat space)
(slot-value f 'sorc) tcc (slot-value f 'sorc) tcc
(slot-value g 'trgt) tcc (slot-value g 'trgt) tcc
(slot-value h 'sorc) tcc (slot-value h 'sorc) tcc
(slot-value h 'trgt) tcc) (slot-value h 'trgt) tcc)
rslt))))) rslt)))))
;;; -[CLISP ;;; -[CLISP
@ -309,14 +309,14 @@
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(with-cmbn (degr list) cmbn (with-cmbn (degr list) cmbn
(let ((tail (member 0 list :test #'= :key #'cadddr))) (let ((tail (member 0 list :test #'= :key #'cadddr)))
(make-cmbn :degr degr (make-cmbn :degr degr
:list (mapcar :list (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (cffc tnpr) term (with-term (cffc tnpr) term
(term cffc (gnrt1 tnpr)))) (term cffc (gnrt1 tnpr))))
tail)))))) tail))))))
|# |#
;;; LISP]- ;;; LISP]-
;;; +[CLISP ;;; +[CLISP
@ -324,74 +324,74 @@
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(with-cmbn (degr list) cmbn (with-cmbn (degr list) cmbn
(let ((tail (member 0 list (let ((tail (member 0 list
:key #'(lambda (term) :key #'(lambda (term)
(declare (type term term)) (declare (type term term))
(degr2 (gnrt term)))))) (degr2 (gnrt term))))))
(make-cmbn :degr degr (make-cmbn :degr degr
:list (mapcar :list (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (cffc tnpr) term (with-term (cffc tnpr) term
(term cffc (gnrt1 tnpr)))) (term cffc (gnrt1 tnpr))))
tail)))))) tail))))))
;;; CLISP]+ ;;; CLISP]+
(DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-F (space (DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-F (space
&aux (ls-hat-u-t (ls-hat-u-t space)) &aux (ls-hat-u-t (ls-hat-u-t space))
(cobar (cobar space))) (cobar (cobar space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type chain-complex ls-hat-u-t cobar)) (type chain-complex ls-hat-u-t cobar))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc ls-hat-u-t :trgt cobar :degr 0 :sorc ls-hat-u-t :trgt cobar :degr 0
:intr #'ls-pre-left-hmeq-right-reduction-intr-f :intr #'ls-pre-left-hmeq-right-reduction-intr-f
:strt :cmbn :strt :cmbn
:orgn `(ls-pre-left-hmeq-right-reduction-f ,space)))) :orgn `(ls-pre-left-hmeq-right-reduction-f ,space))))
(DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-G (bspn) (DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-G (bspn)
(declare (type gmsm bspn)) (declare (type gmsm bspn))
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(with-cmbn (with-cmbn
(degr list) cmbn (degr list) cmbn
(let ((bsgn (tnpr 0 bspn 0 +null-loop+))) (let ((bsgn (tnpr 0 bspn 0 +null-loop+)))
(declare (type tnpr bsgn)) (declare (type tnpr bsgn))
(make-cmbn :degr degr (make-cmbn :degr degr
:list (mapcar :list (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc gnrt) term (cffc gnrt) term
(term cffc (tnpr degr gnrt 0 (term cffc (tnpr degr gnrt 0
bsgn)))) bsgn))))
list))))))) list)))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
(DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-G (space (DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-G (space
&aux (ls-hat-u-t (ls-hat-u-t space)) &aux (ls-hat-u-t (ls-hat-u-t space))
(cobar (cobar space)) (cobar (cobar space))
(bspn (bspn space))) (bspn (bspn space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type chain-complex ls-hat-u-t cobar) (type chain-complex ls-hat-u-t cobar)
(type gmsm bspn)) (type gmsm bspn))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc cobar :trgt ls-hat-u-t :degr 0 :sorc cobar :trgt ls-hat-u-t :degr 0
:intr (ls-pre-left-hmeq-right-reduction-intr-g bspn) :intr (ls-pre-left-hmeq-right-reduction-intr-g bspn)
:strt :cmbn :strt :cmbn
:orgn `(ls-pre-left-hmeq-right-reduction-g ,space)))) :orgn `(ls-pre-left-hmeq-right-reduction-g ,space))))
(DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-H (space (DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-H (space
&aux (cobar (cobar space)) &aux (cobar (cobar space))
(tnpr-contraction (tnpr-contraction
(tnpr-contraction space))) (tnpr-contraction space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type chain-complex cobar) (type chain-complex cobar)
@ -404,18 +404,18 @@
(declare (type simplicial-set space)) (declare (type simplicial-set space))
(the reduction (the reduction
(build-rdct (build-rdct
:f (ls-pre-left-hmeq-right-reduction-f space) :f (ls-pre-left-hmeq-right-reduction-f space)
:g (ls-pre-left-hmeq-right-reduction-g space) :g (ls-pre-left-hmeq-right-reduction-g space)
:h (ls-pre-left-hmeq-right-reduction-h space) :h (ls-pre-left-hmeq-right-reduction-h space)
:orgn `(ls-pre-left-hmeq-right-reduction ,space)))) :orgn `(ls-pre-left-hmeq-right-reduction ,space))))
(DEFUN LS-LEFT-HMEQ-RIGHT-REDUCTION (space (DEFUN LS-LEFT-HMEQ-RIGHT-REDUCTION (space
&aux (pre-reduction &aux (pre-reduction
(ls-pre-left-hmeq-right-reduction (ls-pre-left-hmeq-right-reduction
space)) space))
(perturbation (perturbation
(ls-hat-left-perturbation space))) (ls-hat-left-perturbation space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type reduction pre-reduction) (type reduction pre-reduction)
@ -431,15 +431,15 @@
(declare (type simplicial-set space)) (declare (type simplicial-set space))
(the homotopy-equivalence (the homotopy-equivalence
(build-hmeq (build-hmeq
:lrdct (ls-left-hmeq-left-reduction space) :lrdct (ls-left-hmeq-left-reduction space)
:rrdct (ls-left-hmeq-right-reduction space) :rrdct (ls-left-hmeq-right-reduction space)
:orgn `(ls-left-hmeq ,space)))) :orgn `(ls-left-hmeq ,space))))
(DEFUN LOOP-SPACE-EFHM (space) (DEFUN LOOP-SPACE-EFHM (space)
(declare (type simplicial-set space)) (declare (type simplicial-set space))
(let ((ls-left-hmeq (ls-left-hmeq space)) (let ((ls-left-hmeq (ls-left-hmeq space))
(right-hmeq (cobar (efhm space)))) (right-hmeq (cobar (efhm space))))
(declare (type homotopy-equivalence ls-left-hmeq right-hmeq)) (declare (type homotopy-equivalence ls-left-hmeq right-hmeq))
(cmps ls-left-hmeq right-hmeq))) (cmps ls-left-hmeq right-hmeq)))

403
test/lp-space-efhm-test.lisp
View File

@ -1,198 +1,173 @@
(in-package :kenzo-test) (in-package :kenzo-test)
(in-suite :kenzo) (in-suite :kenzo)
#|
(test ls-hat-t-u (test ls-hat-t-u
(cat:cat-init) (cat:cat-init)
(let ((c (cat:ls-hat-t-u (cat:deltab))) (let ((c (cat:ls-hat-t-u (cat:deltab)))
allp allp-degr gnrt) allp allp-degr gnrt)
(dotimes (i 10) (print (random-allp 5))) (dotimes (i 10)
(setf allp (random-allp 4)) ;; the degree could be too big (let ((allp (random-allp 3)))
;; then redo (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (setf gnrt (cat:tnpr allp-degr allp 4
(setf gnrt (cat:tnpr allp-degr allp 4 (cat:tnpr 2 7 2 (cat:loop3 0 15 2))))
(cat:tnpr 2 7 2 (cat:loop3 0 15 2)))) (unless (>= allp-degr 11)
(cat:? c (+ 4 allp-degr) gnrt) (print (cat:? c (+ 4 allp-degr) gnrt))
(cat:? c *) (print (cat:? c (cat:? c (+ 4 allp-degr) gnrt))))))
(dotimes (i 10) (dotimes (i 20)
(let ((allp (random-allp 3))) (let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(setf gnrt (cat:tnpr allp-degr allp 4 (setf gnrt (cat:tnpr allp-degr allp 5
(cat:tnpr 2 7 2 (cat:loop3 0 15 2)))) (cat:tnpr 3 15 2 (cat:loop3 0 15 2))))
(unless (>= allp-degr 11) (unless (>= allp-degr 10)
(print (cat:? c (+ 4 allp-degr) gnrt)) (print (cat:? c (+ 5 allp-degr) gnrt))
(print (cat:? c (cat:? c (+ 4 allp-degr) gnrt)))))) (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt))))))
(dotimes (i 20) (dotimes (i 20)
(let ((allp (random-allp 3))) (let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(setf gnrt (cat:tnpr allp-degr allp 5 (setf gnrt (cat:tnpr allp-degr allp 5
(cat:tnpr 3 15 2 (cat:loop3 0 15 2)))) (cat:tnpr 2 7 3 (cat:loop3 0 31 2))))
(unless (>= allp-degr 10) (unless (>= allp-degr 10)
(print (cat:? c (+ 5 allp-degr) gnrt)) (print (cat:? c (+ 5 allp-degr) gnrt))
(print (cat:? c (cat:? c (+ 5 allp-degr) gnrt)))))) (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt))))))))
(dotimes (i 20)
(let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(setf gnrt (cat:tnpr allp-degr allp 5
(cat:tnpr 2 7 3 (cat:loop3 0 31 2))))
(unless (>= allp-degr 10)
(print (cat:? c (+ 5 allp-degr) gnrt))
(print (cat:? c (cat:? c (+ 5 allp-degr) gnrt))))))))
|#
#|
(test ls-hat-u-t (test ls-hat-u-t
(cat:cat-init) (cat:cat-init)
(let ((c (cat:ls-hat-u-t (cat:deltab))) (let ((c (cat:ls-hat-u-t (cat:deltab)))
allp allp-degr gnrt) allp allp-degr gnrt)
(dotimes (i 10) (print (random-allp 5))) (dotimes (i 10)
(setf allp (random-allp 3)) (let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(setf gnrt (cat:tnpr allp-degr allp 4 (setf gnrt (cat:tnpr allp-degr allp 4
(cat:tnpr 2 7 2 (cat:loop3 0 15 2)))) (cat:tnpr 2 7 2 (cat:loop3 0 15 2))))
(cat:? c (+ 4 allp-degr) gnrt) (unless (>= allp-degr 11)
(cat:? c *) (print (cat:? c (+ 4 allp-degr) gnrt))
(dotimes (i 10) (print (cat:? c (cat:? c (+ 4 allp-degr) gnrt))))))
(let ((allp (random-allp 3))) (dotimes (i 20)
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (let ((allp (random-allp 3)))
(setf gnrt (cat:tnpr allp-degr allp 4 (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(cat:tnpr 2 7 2 (cat:loop3 0 15 2)))) (setf gnrt (cat:tnpr allp-degr allp 5
(unless (>= allp-degr 11) (cat:tnpr 3 15 2 (cat:loop3 0 15 2))))
(print (cat:? c (+ 4 allp-degr) gnrt)) (unless (>= allp-degr 10)
(print (cat:? c (cat:? c (+ 4 allp-degr) gnrt)))))) (print (cat:? c (+ 5 allp-degr) gnrt))
(dotimes (i 20) (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt))))))
(let ((allp (random-allp 3))) (dotimes (i 20)
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (let ((allp (random-allp 3)))
(setf gnrt (cat:tnpr allp-degr allp 5 (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(cat:tnpr 3 15 2 (cat:loop3 0 15 2)))) (setf gnrt (cat:tnpr allp-degr allp 5
(unless (>= allp-degr 10) (cat:tnpr 2 7 3 (cat:loop3 0 31 2))))
(print (cat:? c (+ 5 allp-degr) gnrt)) (unless (>= allp-degr 10)
(print (cat:? c (cat:? c (+ 5 allp-degr) gnrt)))))) (print (cat:? c (+ 5 allp-degr) gnrt))
(dotimes (i 20) (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt))))))))
(let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(setf gnrt (cat:tnpr allp-degr allp 5
(cat:tnpr 2 7 3 (cat:loop3 0 31 2))))
(unless (>= allp-degr 10)
(print (cat:? c (+ 5 allp-degr) gnrt))
(print (cat:? c (cat:? c (+ 5 allp-degr) gnrt))))))))
|#
#|
(test ls-left-hmeq-hat (test ls-left-hmeq-hat
(cat:cat-init) (cat:cat-init)
(let ((c (cat:ls-left-hmeq-hat (cat:deltab))) (let ((c (cat:ls-left-hmeq-hat (cat:deltab)))
allp allp-degr gnrt) allp allp-degr gnrt)
(dotimes (i 10) (print (random-allp 5))) (dotimes (i 10)
(setf allp (random-allp 3)) (let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(setf gnrt (cat:tnpr allp-degr allp 4 (cat:tnpr 2 7 2 (setf gnrt (cat:tnpr allp-degr allp 4
(cat:loop3 0 15 2)))) (cat:tnpr 2 7 2 (cat:loop3 0 15 2))))
(cat:? c (+ 4 allp-degr) gnrt) (unless (>= allp-degr 11)
(cat:? c (cat:? c (+ 4 allp-degr) gnrt)) (print (cat:? c (+ 4 allp-degr) gnrt))
(dotimes (i 10) (print (cat:? c (cat:? c (+ 4 allp-degr) gnrt))))))
(let ((allp (random-allp 3))) (dotimes (i 20)
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (let ((allp (random-allp 3)))
(setf gnrt (cat:tnpr allp-degr allp 4 (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(cat:tnpr 2 7 2 (cat:loop3 0 15 2)))) (setf gnrt (cat:tnpr allp-degr allp 5
(unless (>= allp-degr 11) (cat:tnpr 3 15 2 (cat:loop3 0 15 2))))
(print (cat:? c (+ 4 allp-degr) gnrt)) (unless (>= allp-degr 10)
(print (cat:? c (cat:? c (+ 4 allp-degr) gnrt)))))) (print (cat:? c (+ 5 allp-degr) gnrt))
(dotimes (i 20) (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt))))))
(let ((allp (random-allp 3))) (dotimes (i 20)
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (let ((allp (random-allp 3)))
(setf gnrt (cat:tnpr allp-degr allp 5 (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(cat:tnpr 3 15 2 (cat:loop3 0 15 2)))) (setf gnrt (cat:tnpr allp-degr allp 5
(unless (>= allp-degr 10) (cat:tnpr 2 7 3 (cat:loop3 0 31 2))))
(print (cat:? c (+ 5 allp-degr) gnrt)) (unless (>= allp-degr 10)
(print (cat:? c (cat:? c (+ 5 allp-degr) gnrt)))))) (print (cat:? c (+ 5 allp-degr) gnrt))
(dotimes (i 20) (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt))))))))
(let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(setf gnrt (cat:tnpr allp-degr allp 5
(cat:tnpr 2 7 3 (cat:loop3 0 31 2))))
(unless (>= allp-degr 10)
(print (cat:? c (+ 5 allp-degr) gnrt))
(print (cat:? c (cat:? c (+ 5 allp-degr) gnrt))))))))
|#
(test ls-pre-left-hmeq-left-reduction-intr-f (test ls-pre-left-hmeq-left-reduction-intr-f
(cat:ls-pre-left-hmeq-left-reduction-intr-f (cat:ls-pre-left-hmeq-left-reduction-intr-f
(cat:cmbn 6 100 (cat:tnpr 0 'a 6 (cat:tnpr 0 'b 6 'c)) (cat:cmbn 6 100 (cat:tnpr 0 'a 6 (cat:tnpr 0 'b 6 'c))
50 (cat:tnpr 0 'a 6 (cat:tnpr 0 'b 6 'cc)) 50 (cat:tnpr 0 'a 6 (cat:tnpr 0 'b 6 'cc))
10 (cat:tnpr 0 'a 6 (cat:tnpr 2 'b 4 'c)) 10 (cat:tnpr 0 'a 6 (cat:tnpr 2 'b 4 'c))
1 (cat:tnpr 2 'a 4 (cat:tnpr 2 'b 2 'cc))))) 1 (cat:tnpr 2 'a 4 (cat:tnpr 2 'b 2 'cc)))))
(test ls-left-hmeq-left-reduction-g-intr (test ls-left-hmeq-left-reduction-g-intr
(let ((r (cat:ls-left-hmeq-left-reduction-g-intr '*))) (let ((r (cat:ls-left-hmeq-left-reduction-g-intr '*)))
(funcall r (cat:cmbn 3 4 'loop)))) (funcall r (cat:cmbn 3 4 'loop))))
(test ls-pre-left-hmeq-left-reduction-h-intr (test ls-pre-left-hmeq-left-reduction-h-intr
(cat:cat-init) (cat:cat-init)
(let ((r (cat:ls-pre-left-hmeq-left-reduction-h-intr (cat:deltab)))) (let ((r (cat:ls-pre-left-hmeq-left-reduction-h-intr (cat:deltab))))
(setf cat:*tnpr-with-degrees* t) (setf cat:*tnpr-with-degrees* t)
(funcall r (cat:cmbn 10 1 (cat:tnpr 3 (cat:allp 2 'a 1 'b) (funcall r (cat:cmbn 10 1 (cat:tnpr 3 (cat:allp 2 'a 1 'b)
7 (cat:tnpr 5 'c 2 'd)) 7 (cat:tnpr 5 'c 2 'd))
1 (cat:tnpr 7 (cat:allp 2 'a 5 'b) 1 (cat:tnpr 7 (cat:allp 2 'a 5 'b)
3 (cat:tnpr 0 '* 3 'c)) 3 (cat:tnpr 0 '* 3 'c))
10 (cat:tnpr 8 (cat:allp 4 'aa 4 'bb) 10 (cat:tnpr 8 (cat:allp 4 'aa 4 'bb)
2 (cat:tnpr 0 '* 2 'cc)))) 2 (cat:tnpr 0 '* 2 'cc))))
(funcall r (cat:cmbn 10 1 (cat:tnpr 3 (cat:allp 2 'a 1 'b) (funcall r (cat:cmbn 10 1 (cat:tnpr 3 (cat:allp 2 'a 1 'b)
7 (cat:tnpr 5 'c 2 'd)) 7 (cat:tnpr 5 'c 2 'd))
1 (cat:tnpr 7 (cat:allp 4 'a 3 'b) 1 (cat:tnpr 7 (cat:allp 4 'a 3 'b)
3 (cat:tnpr 0 '* 3 'c)) 3 (cat:tnpr 0 '* 3 'c))
10 (cat:tnpr 8 (cat:allp 3 'aa 5 'bb) 10 (cat:tnpr 8 (cat:allp 3 'aa 5 'bb)
2 (cat:tnpr 0 '* 2 'cc)))) 2 (cat:tnpr 0 '* 2 'cc))))
(setf cat:*tnpr-with-degrees* nil))) (setf cat:*tnpr-with-degrees* nil)))
#| #|
(test ls-pre-left-hmeq-left-reduction (test ls-pre-left-hmeq-left-reduction
(cat:cat-init) (cat:cat-init)
(let* ((rdct (cat:ls-pre-left-hmeq-left-reduction (cat:deltab))) (let* ((rdct (cat:ls-pre-left-hmeq-left-reduction (cat:deltab)))
(allp (random-allp 3)) (allp (random-allp 3))
(allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(gnrt (cat:tnpr allp-degr allp 4 (cat:tnpr 2 7 2 (gnrt (cat:tnpr allp-degr allp 4 (cat:tnpr 2 7 2
(cat:loop3 0 15 2))))) (cat:loop3 0 15 2)))))
(cat:pre-check-rdct rdct) (cat:pre-check-rdct rdct)
(setf cat:*tc* (cat:cmbn (+ 4 allp-degr) 1 gnrt)) (setf cat:*tc* (cat:cmbn (+ 4 allp-degr) 1 gnrt))
(setf cat:*bc* (cat:cmbn 2 1 (cat:loop3 0 15 2))) (setf cat:*bc* (cat:cmbn 2 1 (cat:loop3 0 15 2)))
(check-rdct) (check-rdct)
(setf gnrt (cat:tnpr allp-degr allp 4 (setf gnrt (cat:tnpr allp-degr allp 4
(cat:tnpr 0 1 4 (cat:loop3 0 (cat:mask 6) 2)))) (cat:tnpr 0 1 4 (cat:loop3 0 (cat:mask 6) 2))))
(setf cat:*tc* (cat:cmbn (+ 4 allp-degr) 1 gnrt)) (setf cat:*tc* (cat:cmbn (+ 4 allp-degr) 1 gnrt))
(check-rdct) (check-rdct)
(setf cat:*bc* (cat:cmbn 0 1 (cat:bspn (cat:bcc rdct)))) (setf cat:*bc* (cat:cmbn 0 1 (cat:bspn (cat:bcc rdct))))
(setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn (cat:tcc rdct)))) (setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn (cat:tcc rdct))))
(check-rdct))) (check-rdct)))
|# |#
(defun a (d1 d2 d3) (defun a (d1 d2 d3)
(setf cat:*tc* (cat:cmbn (+ d1 d2 d3) (setf cat:*tc* (cat:cmbn (+ d1 d2 d3)
1 (cat:tnpr 1 (cat:tnpr
d1 (cat:allp d1 (cat:mask (+ d1 2))) d1 (cat:allp d1 (cat:mask (+ d1 2)))
(+ d2 d3) (+ d2 d3)
(cat:tnpr d2 (cat:mask (1+ d2)) (cat:tnpr d2 (cat:mask (1+ d2))
d3 (cat:loop3 d3 (cat:loop3
0 (cat:mask (+ d3 2)) 1)))) 0 (cat:mask (+ d3 2)) 1))))
cat:*bc* (cat:cmbn d3 1 (cat:loop3 0 (cat:mask (+ d3 2)) -1))) cat:*bc* (cat:cmbn d3 1 (cat:loop3 0 (cat:mask (+ d3 2)) -1)))
(check-rdct)) (check-rdct))
(test ls-left-hmeq-left-reduction (test ls-left-hmeq-left-reduction
(cat:cat-init) (cat:cat-init)
(let ((rdct (cat:ls-left-hmeq-left-reduction (cat:deltab2)))) (let ((rdct (cat:ls-left-hmeq-left-reduction (cat:deltab2))))
(cat:pre-check-rdct rdct) (cat:pre-check-rdct rdct)
#| #|
(a 1 0 1) (a 1 0 1)
(a 1 1 1) ;; error because 3 does not exist in deltab2 (a 1 1 1) ;; error because 3 does not exist in deltab2
(a 1 2 1) (a 1 2 1)
(a 2 2 1) (a 2 2 1)
|# |#
) )
) )
@ -203,86 +178,86 @@
(test ls-pre-left-hmeq-right-reduction-intr-g (test ls-pre-left-hmeq-right-reduction-intr-g
(let ((r (cat:ls-pre-left-hmeq-right-reduction-intr-g '*))) (let ((r (cat:ls-pre-left-hmeq-right-reduction-intr-g '*)))
(funcall r (cat:cmbn 3 4 'a)))) (funcall r (cat:cmbn 3 4 'a))))
(test ls-pre-left-hmeq-right-reduction (test ls-pre-left-hmeq-right-reduction
(cat:cat-init) (cat:cat-init)
(let ((r (cat:ls-pre-left-hmeq-right-reduction (cat:deltab2)))) (let ((r (cat:ls-pre-left-hmeq-right-reduction (cat:deltab2))))
(cat:pre-check-rdct r) (cat:pre-check-rdct r)
(setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn (cat:tcc r)))) (setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn (cat:tcc r))))
(setf cat:*bc* (cat:cmbn 0 1 (cat:bsgn (cat:bcc r)))) (setf cat:*bc* (cat:cmbn 0 1 (cat:bsgn (cat:bcc r))))
(check-rdct) (check-rdct)
#| #|
(setf cat:*tc* (cat:cmbn (setf cat:*tc* (cat:cmbn
3 1 (cat:tnpr 3 (cat:allp 3 (cat:mask 5)) 3 1 (cat:tnpr 3 (cat:allp 3 (cat:mask 5))
0 (cat:tnpr 0 1 0 cat:+null-loop+)))) 0 (cat:tnpr 0 1 0 cat:+null-loop+))))
(setf cat:*bc* (cat:cmbn 3 1 (cat:allp 1 7 2 15))) (setf cat:*bc* (cat:cmbn 3 1 (cat:allp 1 7 2 15)))
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn (setf cat:*tc* (cat:cmbn
6 1 (cat:tnpr 3 (cat:allp 1 7 2 15) 6 1 (cat:tnpr 3 (cat:allp 1 7 2 15)
3 (cat:tnpr 2 7 1 (cat:loop3 0 7 2))))) 3 (cat:tnpr 2 7 1 (cat:loop3 0 7 2)))))
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn (setf cat:*tc* (cat:cmbn
6 1 (cat:tnpr 6 1 (cat:tnpr
3 (cat:allp 1 7 2 15) 3 (cat:allp 1 7 2 15)
3 (cat:tnpr 0 1 3 3 (cat:tnpr 0 1 3
(cat:loop3 0 (cat:mask 5) 2))))) (cat:loop3 0 (cat:mask 5) 2)))))
(check-rdct) (check-rdct)
|# |#
)) ))
(test ls-left-hmeq-right-reduction (test ls-left-hmeq-right-reduction
(cat:cat-init) (cat:cat-init)
(let ((r (cat:ls-left-hmeq-right-reduction (cat:deltab2)))) (let ((r (cat:ls-left-hmeq-right-reduction (cat:deltab2))))
(cat:pre-check-rdct r) (cat:pre-check-rdct r)
(setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn (cat:tcc r)))) (setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn (cat:tcc r))))
(setf cat:*bc* (cat:cmbn 0 1 (cat:bsgn (cat:bcc r)))) (setf cat:*bc* (cat:cmbn 0 1 (cat:bsgn (cat:bcc r))))
(check-rdct) (check-rdct)
#| #|
(setf cat:*tc* (cat:cmbn 3 1 (cat:tnpr 3 (cat:allp 3 (cat:mask 5)) (setf cat:*tc* (cat:cmbn 3 1 (cat:tnpr 3 (cat:allp 3 (cat:mask 5))
0 (cat:tnpr 0 1 0 0 (cat:tnpr 0 1 0
cat:+null-loop+)))) cat:+null-loop+))))
(setf cat:*bc* (cat:cmbn 3 1 (cat:allp 1 7 2 15))) (setf cat:*bc* (cat:cmbn 3 1 (cat:allp 1 7 2 15)))
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn (setf cat:*tc* (cat:cmbn
6 1 (cat:tnpr 3 (cat:allp 1 7 2 15) 6 1 (cat:tnpr 3 (cat:allp 1 7 2 15)
3 (cat:tnpr 2 7 1 (cat:loop3 0 7 2))))) 3 (cat:tnpr 2 7 1 (cat:loop3 0 7 2)))))
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn (setf cat:*tc* (cat:cmbn
6 1 (cat:tnpr 3 (cat:allp 1 7 2 15) 6 1 (cat:tnpr 3 (cat:allp 1 7 2 15)
3 (cat:tnpr 0 1 3 3 (cat:tnpr 0 1 3
(cat:loop3 0 (mask 5) 2))))) (cat:loop3 0 (mask 5) 2)))))
(check-rdct) (check-rdct)
|# |#
)) ))
#| #|
(test ls-left-hmeq (test ls-left-hmeq
(cat:cat-init) (cat:cat-init)
(let* ((h (cat:ls-left-hmeq (cat:deltab2))) (let* ((h (cat:ls-left-hmeq (cat:deltab2)))
(loop (cat:loop3 0 (cat:mask 5) 2)) (loop (cat:loop3 0 (cat:mask 5) 2))
(allp (cat:allp 2 (cat:mask 4) 3 (cat:mask 5))) (allp (cat:allp 2 (cat:mask 4) 3 (cat:mask 5)))
x) x)
(setf x (cat:lg h 3 loop)) (setf x (cat:lg h 3 loop))
(setf x (cat:rf h x)) (setf x (cat:rf h x))
(setf x (cat:rg h x)) (setf x (cat:rg h x))
(setf x (cat:lf h x)) (setf x (cat:lf h x))
(setf x (cat:rg h 5 allp)) (setf x (cat:rg h 5 allp))
(setf x (cat:lf h x)) (setf x (cat:lf h x))
(setf x (cat:lg h x)) (setf x (cat:lg h x))
(setf x (cat:rf h x)) ;; = allp, but why ? (setf x (cat:rf h x)) ;; = allp, but why ?
)) ))
|# |#
(test loop-space (test loop-space
(cat:cat-init) (cat:cat-init)
(let ((l (cat:loop-space (cat:sphere 2))) (let ((l (cat:loop-space (cat:sphere 2)))
(oos3 (cat:loop-space (cat:loop-space (cat:sphere 3)))) (oos3 (cat:loop-space (cat:loop-space (cat:sphere 3))))
(ooos4 (cat:loop-space (cat:loop-space (cat:loop-space (ooos4 (cat:loop-space (cat:loop-space (cat:loop-space
(cat:sphere 4)))))) (cat:sphere 4))))))
(cat:homology l 6) (cat:homology l 6)
(cat:homology oos3 3) (cat:homology oos3 3)
(cat:homology ooos4 2))) (cat:homology ooos4 2)))