Extracted tests from lp-space-efhm.lisp.
This commit is contained in:
Gerd Heber
parent
5dceced785
commit
0b929824ab
@ -33,6 +33,7 @@
|
|||||||
(:file "k-pi-n-test")
|
(:file "k-pi-n-test")
|
||||||
(:file "kan-test")
|
(:file "kan-test")
|
||||||
(:file "loop-spaces-test")
|
(:file "loop-spaces-test")
|
||||||
|
(:file "lp-space-efhm-test")
|
||||||
(:file "ls-twisted-products-test")
|
(:file "ls-twisted-products-test")
|
||||||
(:file "searching-homology-test")
|
(:file "searching-homology-test")
|
||||||
(:file "serre-test")
|
(:file "serre-test")
|
||||||
|
|||||||
17
package.lisp
17
package.lisp
@ -240,6 +240,7 @@
|
|||||||
DELTA-INFINITY
|
DELTA-INFINITY
|
||||||
DELTA-N-BASIS
|
DELTA-N-BASIS
|
||||||
DELTAB
|
DELTAB
|
||||||
|
DELTAB2
|
||||||
DELTAB2-BNDR
|
DELTAB2-BNDR
|
||||||
DELTAB2-DGNL
|
DELTAB2-DGNL
|
||||||
SOFT-DELTA
|
SOFT-DELTA
|
||||||
@ -345,6 +346,22 @@
|
|||||||
NORMALIZE-LOOP
|
NORMALIZE-LOOP
|
||||||
UNNORMALIZE-LOOP
|
UNNORMALIZE-LOOP
|
||||||
|
|
||||||
|
;; lp-space-efhm.lisp
|
||||||
|
|
||||||
|
LS-HAT-T-U
|
||||||
|
LS-HAT-U-T
|
||||||
|
LS-LEFT-HMEQ
|
||||||
|
LS-LEFT-HMEQ-HAT
|
||||||
|
LS-LEFT-HMEQ-LEFT-REDUCTION
|
||||||
|
LS-LEFT-HMEQ-LEFT-REDUCTION-G-INTR
|
||||||
|
LS-LEFT-HMEQ-RIGHT-REDUCTION
|
||||||
|
LS-PRE-LEFT-HMEQ-LEFT-REDUCTION
|
||||||
|
LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-H-INTR
|
||||||
|
LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-INTR-F
|
||||||
|
LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION
|
||||||
|
LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-F
|
||||||
|
LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-G
|
||||||
|
|
||||||
;; ls-twisted-products.lisp
|
;; ls-twisted-products.lisp
|
||||||
|
|
||||||
ABSM-LOOPABSM
|
ABSM-LOOPABSM
|
||||||
|
|||||||
@ -7,325 +7,211 @@
|
|||||||
(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)
|
||||||
(type simplicial-group loop-space))
|
(type simplicial-group loop-space))
|
||||||
(the chain-complex
|
(the chain-complex
|
||||||
(tnsr-prdc cobar spac-tnsr-lpsp)))
|
(tnsr-prdc cobar spac-tnsr-lpsp)))
|
||||||
|
|
||||||
|
|
||||||
(DEFUN LS-HAT-LEFT-PERTURBATION-INTR (space)
|
(DEFUN LS-HAT-LEFT-PERTURBATION-INTR (space)
|
||||||
(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 (degr1 allp1 nil tnpr2) tnpr
|
(with-tnpr
|
||||||
(with-tnpr (degr21 gmsm21 degr22 loop22) tnpr2
|
(degr1 allp1 nil tnpr2) tnpr
|
||||||
(let ((cprd (cmbn-list (gnrt-? cprd degr21 gmsm21))))
|
(with-tnpr
|
||||||
(declare (list cprd))
|
(degr21 gmsm21 degr22 loop22) tnpr2
|
||||||
(setf cprd (rest cprd)) ;;; because \bar{A}
|
(let ((cprd (cmbn-list (gnrt-? cprd degr21 gmsm21))))
|
||||||
(make-cmbn :degr (1- degr)
|
(declare (list cprd))
|
||||||
:list
|
(setf cprd (rest cprd)) ;;; because \bar{A}
|
||||||
(mapcar
|
(make-cmbn
|
||||||
#'(lambda (term)
|
:degr (1- degr)
|
||||||
(declare (type term term))
|
:list
|
||||||
(with-term (cffc tnpr21) term
|
(mapcar
|
||||||
(with-tnpr (degr211 gmsm211 degr212 gmsm212) tnpr21
|
#'(lambda (term)
|
||||||
(decf degr211)
|
(declare (type term term))
|
||||||
(term cffc
|
(with-term
|
||||||
(tnpr
|
(cffc tnpr21) term
|
||||||
(+ degr1 degr211)
|
(with-tnpr
|
||||||
(make-allp
|
(degr211 gmsm211 degr212 gmsm212) tnpr21
|
||||||
:list (append
|
(decf degr211)
|
||||||
(allp-list allp1)
|
(term cffc (tnpr (+ degr1 degr211)
|
||||||
(list (cbgn degr211 gmsm211))))
|
(make-allp
|
||||||
(+ degr212 degr22)
|
:list
|
||||||
(tnpr degr212 gmsm212 degr22 loop22))))))
|
(append
|
||||||
cprd)))))))
|
(allp-list allp1)
|
||||||
(the intr-mrph #'rslt))))
|
(list (cbgn degr211
|
||||||
|
gmsm211))))
|
||||||
|
(+ degr212 degr22)
|
||||||
|
(tnpr degr212 gmsm212
|
||||||
|
degr22 loop22))))))
|
||||||
|
cprd)))))))
|
||||||
|
(the intr-mrph #'rslt))))
|
||||||
|
|
||||||
|
|
||||||
(DEFUN LS-HAT-LEFT-PERTURBATION (space)
|
(DEFUN LS-HAT-LEFT-PERTURBATION (space)
|
||||||
(declare (type simplicial-set space))
|
(declare (type simplicial-set space))
|
||||||
(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)
|
||||||
(type morphism ls-hat-left-perturbation))
|
(type morphism ls-hat-left-perturbation))
|
||||||
(the chain-complex
|
(the chain-complex
|
||||||
(progn
|
(progn
|
||||||
(setf (slot-value ls-hat-left-perturbation 'sorc) ls-hat-u-u
|
(setf (slot-value ls-hat-left-perturbation 'sorc) ls-hat-u-u
|
||||||
(slot-value ls-hat-left-perturbation 'trgt) ls-hat-u-u)
|
(slot-value ls-hat-left-perturbation 'trgt) ls-hat-u-u)
|
||||||
;; because maybe these slots have been modified when constructing
|
;; because maybe these slots have been modified when constructing
|
||||||
;; the ls-left-hmeq-right-reduction
|
;; the ls-left-hmeq-right-reduction
|
||||||
(add ls-hat-u-u ls-hat-left-perturbation))))
|
(add ls-hat-u-u ls-hat-left-perturbation))))
|
||||||
|
|
||||||
#|
|
|
||||||
(cat-init)
|
|
||||||
(setf c (ls-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 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))
|
||||||
(the chain-complex
|
(the chain-complex
|
||||||
(let ((rslt (tnsr-prdc cobar twisted-tnsr-prdc)))
|
(let ((rslt (tnsr-prdc cobar twisted-tnsr-prdc)))
|
||||||
(declare (type chain-complex rslt))
|
(declare (type chain-complex rslt))
|
||||||
(setf (slot-value rslt 'grmd) ls-hat-u-u)
|
(setf (slot-value rslt 'grmd) ls-hat-u-u)
|
||||||
rslt)))
|
rslt)))
|
||||||
|
|
||||||
#|
|
|
||||||
(cat-init)
|
|
||||||
(setf c (ls-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 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)
|
||||||
(type morphism ls-hat-left-perturbation))
|
(type morphism ls-hat-left-perturbation))
|
||||||
(the chain-complex
|
(the chain-complex
|
||||||
(add ls-hat-u-t ls-hat-left-perturbation)))
|
(add ls-hat-u-t ls-hat-left-perturbation)))
|
||||||
|
|
||||||
#|
|
|
||||||
(cat-init)
|
|
||||||
(setf c (ls-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 LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-INTR-F (cmbn)
|
(DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-INTR-F (cmbn)
|
||||||
(declare (type cmbn cmbn))
|
(declare (type cmbn cmbn))
|
||||||
(the cmbn
|
(the cmbn
|
||||||
(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 (cffc tnpr) term
|
(with-term
|
||||||
(with-tnpr (degr1 nil nil tnpr2) tnpr
|
(cffc tnpr) term
|
||||||
(if (zerop degr1)
|
(with-tnpr (degr1 nil nil tnpr2) tnpr
|
||||||
(with-tnpr (degr21 nil nil loop22) tnpr2
|
(if (zerop degr1)
|
||||||
(if (zerop degr21)
|
(with-tnpr
|
||||||
(push (term cffc loop22) rslt)
|
(degr21 nil nil loop22) tnpr2
|
||||||
(return)))
|
(if (zerop degr21)
|
||||||
(return)))))
|
(push (term cffc loop22) rslt)
|
||||||
|
(return)))
|
||||||
|
(return)))))
|
||||||
(make-cmbn :degr (cmbn-degr cmbn)
|
(make-cmbn :degr (cmbn-degr cmbn)
|
||||||
:list (nreverse rslt)))))
|
:list (nreverse rslt)))))
|
||||||
|
|
||||||
#|
|
|
||||||
(ls-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 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 (degr list) cmbn
|
(with-cmbn
|
||||||
(make-cmbn :degr degr
|
(degr list) cmbn
|
||||||
:list (mapcar
|
(make-cmbn :degr degr
|
||||||
#'(lambda (term)
|
:list (mapcar
|
||||||
(declare (type term term))
|
#'(lambda (term)
|
||||||
(with-term (cffc loop) term
|
(declare (type term term))
|
||||||
(term cffc
|
(with-term
|
||||||
(tnpr
|
(cffc loop) term
|
||||||
0 +null-allp+
|
(term cffc
|
||||||
degr (tnpr 0 bspn degr loop)))))
|
(tnpr
|
||||||
list))))))
|
0 +null-allp+
|
||||||
(the intr-mrph #'rslt)))
|
degr
|
||||||
|
(tnpr 0 bspn degr
|
||||||
|
loop)))))
|
||||||
|
list))))))
|
||||||
|
(the intr-mrph #'rslt)))
|
||||||
|
|
||||||
#|
|
|
||||||
(setf r (ls-left-hmeq-left-reduction-g-intr '*))
|
|
||||||
(funcall r (cmbn 3 4 'loop))
|
|
||||||
|#
|
|
||||||
|
|
||||||
(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
|
||||||
(space
|
(space
|
||||||
&aux (ls-hat-t-u (ls-hat-t-u space))
|
&aux (ls-hat-t-u (ls-hat-t-u space))
|
||||||
(cmpr (cmpr ls-hat-t-u)))
|
(cmpr (cmpr ls-hat-t-u)))
|
||||||
(declare
|
(declare
|
||||||
(type simplicial-set space)
|
(type simplicial-set space)
|
||||||
(type chain-complex ls-hat-t-u)
|
(type chain-complex ls-hat-t-u)
|
||||||
@ -333,314 +219,222 @@
|
|||||||
(flet ((rslt (cmbn)
|
(flet ((rslt (cmbn)
|
||||||
(declare (type cmbn cmbn))
|
(declare (type cmbn cmbn))
|
||||||
(the cmbn
|
(the cmbn
|
||||||
(with-cmbn (degr list) cmbn
|
(with-cmbn
|
||||||
(let ((rslt (zero-cmbn (1+ degr))))
|
(degr list) cmbn
|
||||||
(declare (type cmbn rslt))
|
(let ((rslt (zero-cmbn (1+ degr))))
|
||||||
(dolist (term list)
|
(declare (type cmbn rslt))
|
||||||
(declare (type term term))
|
(dolist (term list)
|
||||||
(with-term (cffc tnpr) term
|
(declare (type term term))
|
||||||
(with-tnpr (degr1 allp1 degr2 tnpr2) tnpr
|
(with-term
|
||||||
(unless (zerop degr1)
|
(cffc tnpr) term
|
||||||
(with-tnpr (degr21 nil degr22 loop22) tnpr2
|
(with-tnpr
|
||||||
(when (zerop degr21)
|
(degr1 allp1 degr2 tnpr2) tnpr
|
||||||
(setf allp1 (allp-list allp1)) ;;;+++
|
(unless (zerop degr1)
|
||||||
(let ((last-cbgn (car (last allp1))))
|
(with-tnpr
|
||||||
(declare (type cbgn last-cbgn))
|
(degr21 nil degr22 loop22) tnpr2
|
||||||
(with-cbgn (degrl gmsml) last-cbgn
|
(when (zerop degr21)
|
||||||
(dstr-add-term-to-cmbn cmpr
|
(setf allp1 (allp-list allp1)) ;;;+++
|
||||||
cffc (tnpr (- degr1 degrl)
|
(let ((last-cbgn (car (last allp1))))
|
||||||
(make-allp :list (butlast allp1))
|
(declare (type cbgn last-cbgn))
|
||||||
(+ degr2 degrl 1)
|
(with-cbgn
|
||||||
(tnpr (1+ degrl) gmsml
|
(degrl gmsml) last-cbgn
|
||||||
degr22 loop22))
|
(dstr-add-term-to-cmbn
|
||||||
rslt)))))))))
|
cmpr cffc
|
||||||
rslt)))))
|
(tnpr (- degr1 degrl)
|
||||||
(the intr-mrph #'rslt)))
|
(make-allp
|
||||||
|
:list (butlast allp1))
|
||||||
|
(+ degr2 degrl 1)
|
||||||
|
(tnpr (1+ degrl) gmsml
|
||||||
|
degr22 loop22))
|
||||||
|
rslt)))))))))
|
||||||
|
rslt)))))
|
||||||
|
(the intr-mrph #'rslt)))
|
||||||
|
|
||||||
#|
|
|
||||||
(setf r (ls-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 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))))
|
||||||
|
|
||||||
#|
|
|
||||||
(cat-init)
|
|
||||||
(setf rdct (ls-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 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 space))
|
(ls-pre-left-hmeq-left-reduction
|
||||||
(ls-hat-right-perturbation
|
space))
|
||||||
(ls-hat-right-perturbation space)))
|
(ls-hat-right-perturbation
|
||||||
(declare
|
(ls-hat-right-perturbation space)))
|
||||||
(type simplicial-set space)
|
(declare
|
||||||
(type reduction ls-pre-left-hmeq-left-reduction)
|
(type simplicial-set space)
|
||||||
(type morphism ls-hat-right-perturbation))
|
(type reduction ls-pre-left-hmeq-left-reduction)
|
||||||
(the reduction
|
(type morphism ls-hat-right-perturbation))
|
||||||
(progn
|
(the reduction
|
||||||
|
(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)))))
|
||||||
|
|
||||||
#|
|
|
||||||
(cat-init)
|
|
||||||
(setf rdct (ls-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)
|
|
||||||
|#
|
|
||||||
|
|
||||||
|
|
||||||
;;; -[CLISP
|
;;; -[CLISP
|
||||||
#|
|
#|
|
||||||
(DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-F (cmbn)
|
(DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-F (cmbn)
|
||||||
(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
|
||||||
(DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-F (cmbn)
|
(DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-F (cmbn)
|
||||||
(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]+
|
||||||
|
|
||||||
#|
|
|
||||||
()
|
|
||||||
(ls-pre-left-hmeq-right-reduction-intr-f
|
|
||||||
(cmbn 3 12 (tnpr 2 'a 1 'b) 14 (tnpr 3 'aa 0 '*))))
|
|
||||||
|#
|
|
||||||
|
|
||||||
(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 (degr list) cmbn
|
(with-cmbn
|
||||||
(let ((bsgn (tnpr 0 bspn 0 +null-loop+)))
|
(degr list) cmbn
|
||||||
(declare (type tnpr bsgn))
|
(let ((bsgn (tnpr 0 bspn 0 +null-loop+)))
|
||||||
(make-cmbn :degr degr
|
(declare (type tnpr bsgn))
|
||||||
:list (mapcar
|
(make-cmbn :degr degr
|
||||||
#'(lambda (term)
|
:list (mapcar
|
||||||
(declare (type term term))
|
#'(lambda (term)
|
||||||
(with-term (cffc gnrt) term
|
(declare (type term term))
|
||||||
(term cffc (tnpr degr gnrt 0 bsgn))))
|
(with-term
|
||||||
list)))))))
|
(cffc gnrt) term
|
||||||
(the intr-mrph #'rslt)))
|
(term cffc (tnpr degr gnrt 0
|
||||||
|
bsgn))))
|
||||||
|
list)))))))
|
||||||
|
(the intr-mrph #'rslt)))
|
||||||
|
|
||||||
#|
|
|
||||||
(setf r (ls-pre-left-hmeq-right-reduction-intr-g '*))
|
|
||||||
(funcall r (cmbn 3 4 'a))
|
|
||||||
|#
|
|
||||||
|
|
||||||
(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 space)))
|
(tnpr-contraction
|
||||||
(declare
|
(tnpr-contraction space)))
|
||||||
(type simplicial-set space)
|
(declare
|
||||||
(type chain-complex cobar)
|
(type simplicial-set space)
|
||||||
(type morphism tnpr-contraction))
|
(type chain-complex cobar)
|
||||||
(the morphism
|
(type morphism tnpr-contraction))
|
||||||
(tnsr-prdc (idnt-mrph cobar) tnpr-contraction)))
|
(the morphism
|
||||||
|
(tnsr-prdc (idnt-mrph cobar) tnpr-contraction)))
|
||||||
|
|
||||||
|
|
||||||
(DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION (space)
|
(DEFUN LS-PRE-LEFT-HMEQ-RIGHT-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-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))))
|
||||||
|
|
||||||
#|
|
|
||||||
(cat-init)
|
|
||||||
(setf r (ls-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 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 space))
|
(ls-pre-left-hmeq-right-reduction
|
||||||
(perturbation
|
space))
|
||||||
(ls-hat-left-perturbation space)))
|
(perturbation
|
||||||
(declare
|
(ls-hat-left-perturbation space)))
|
||||||
(type simplicial-set space)
|
(declare
|
||||||
(type reduction pre-reduction)
|
(type simplicial-set space)
|
||||||
(type morphism perturbation))
|
(type reduction pre-reduction)
|
||||||
(the reduction
|
(type morphism perturbation))
|
||||||
(progn
|
(the reduction
|
||||||
|
(progn
|
||||||
(setf (slot-value perturbation 'sorc) (tcc pre-reduction)
|
(setf (slot-value perturbation 'sorc) (tcc pre-reduction)
|
||||||
(slot-value perturbation 'trgt) (tcc pre-reduction))
|
(slot-value perturbation 'trgt) (tcc pre-reduction))
|
||||||
(special-bpl pre-reduction perturbation))))
|
(special-bpl pre-reduction perturbation))))
|
||||||
|
|
||||||
#|
|
|
||||||
(cat-init)
|
|
||||||
(setf r (ls-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 LS-LEFT-HMEQ (space)
|
(DEFUN LS-LEFT-HMEQ (space)
|
||||||
(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))))
|
||||||
|
|
||||||
#|
|
|
||||||
(cat-init)
|
|
||||||
(setf h (ls-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)
|
(DEFUN LOOP-SPACE-EFHM (space)
|
||||||
(declare (type simplicial-set space))
|
(declare (type simplicial-set space))
|
||||||
@ -649,16 +443,7 @@
|
|||||||
(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)))
|
||||||
|
|
||||||
|
|
||||||
(DEFMETHOD SEARCH-EFHM (loop-space (orgn (eql 'loop-space)))
|
(DEFMETHOD SEARCH-EFHM (loop-space (orgn (eql 'loop-space)))
|
||||||
(declare (type simplicial-set loop-space))
|
(declare (type simplicial-set loop-space))
|
||||||
(loop-space-efhm (second (orgn 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)
|
|
||||||
|#
|
|
||||||
|
|||||||
@ -212,6 +212,16 @@
|
|||||||
rslt)))
|
rslt)))
|
||||||
|
|
||||||
|
|
||||||
|
(defun random-allp (length)
|
||||||
|
(let ((rslt nil))
|
||||||
|
(dotimes (i length)
|
||||||
|
(let* ((gmsm (random (cat:mask 9)))
|
||||||
|
(dmns (1- (logcount gmsm))))
|
||||||
|
(when (plusp dmns)
|
||||||
|
(push (cat:cbgn (1- dmns) gmsm) rslt))))
|
||||||
|
(cat:make-allp :list rslt)))
|
||||||
|
|
||||||
|
|
||||||
(defun random-apowr (dmns max-expn)
|
(defun random-apowr (dmns max-expn)
|
||||||
(loop
|
(loop
|
||||||
(let* ((dgop (random (cat:2-exp (1- dmns))))
|
(let* ((dgop (random (cat:2-exp (1- dmns))))
|
||||||
|
|||||||
287
test/lp-space-efhm-test.lisp
Normal file
287
test/lp-space-efhm-test.lisp
Normal file
@ -0,0 +1,287 @@
|
|||||||
|
|
||||||
|
(in-package :kenzo-test)
|
||||||
|
|
||||||
|
(in-suite :kenzo)
|
||||||
|
|
||||||
|
#|
|
||||||
|
(test ls-hat-t-u
|
||||||
|
(cat:cat-init)
|
||||||
|
(let ((c (cat:ls-hat-t-u (cat:deltab)))
|
||||||
|
allp allp-degr gnrt)
|
||||||
|
(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 (cat:allp-list allp))))
|
||||||
|
(setf gnrt (cat:tnpr allp-degr allp 4
|
||||||
|
(cat:tnpr 2 7 2 (cat:loop3 0 15 2))))
|
||||||
|
(cat:? c (+ 4 allp-degr) gnrt)
|
||||||
|
(cat:? c *)
|
||||||
|
(dotimes (i 10)
|
||||||
|
(let ((allp (random-allp 3)))
|
||||||
|
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
|
||||||
|
(setf gnrt (cat:tnpr allp-degr allp 4
|
||||||
|
(cat:tnpr 2 7 2 (cat:loop3 0 15 2))))
|
||||||
|
(unless (>= allp-degr 11)
|
||||||
|
(print (cat:? c (+ 4 allp-degr) gnrt))
|
||||||
|
(print (cat:? c (cat:? c (+ 4 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 3 15 2 (cat:loop3 0 15 2))))
|
||||||
|
(unless (>= allp-degr 10)
|
||||||
|
(print (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
|
||||||
|
(cat:cat-init)
|
||||||
|
(let ((c (cat:ls-hat-u-t (cat:deltab)))
|
||||||
|
allp allp-degr gnrt)
|
||||||
|
(dotimes (i 10) (print (random-allp 5)))
|
||||||
|
(setf allp (random-allp 3))
|
||||||
|
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
|
||||||
|
(setf gnrt (cat:tnpr allp-degr allp 4
|
||||||
|
(cat:tnpr 2 7 2 (cat:loop3 0 15 2))))
|
||||||
|
(cat:? c (+ 4 allp-degr) gnrt)
|
||||||
|
(cat:? c *)
|
||||||
|
(dotimes (i 10)
|
||||||
|
(let ((allp (random-allp 3)))
|
||||||
|
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
|
||||||
|
(setf gnrt (cat:tnpr allp-degr allp 4
|
||||||
|
(cat:tnpr 2 7 2 (cat:loop3 0 15 2))))
|
||||||
|
(unless (>= allp-degr 11)
|
||||||
|
(print (cat:? c (+ 4 allp-degr) gnrt))
|
||||||
|
(print (cat:? c (cat:? c (+ 4 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 3 15 2 (cat:loop3 0 15 2))))
|
||||||
|
(unless (>= allp-degr 10)
|
||||||
|
(print (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-left-hmeq-hat
|
||||||
|
(cat:cat-init)
|
||||||
|
(let ((c (cat:ls-left-hmeq-hat (cat:deltab)))
|
||||||
|
allp allp-degr gnrt)
|
||||||
|
(dotimes (i 10) (print (random-allp 5)))
|
||||||
|
(setf allp (random-allp 3))
|
||||||
|
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
|
||||||
|
(setf gnrt (cat:tnpr allp-degr allp 4 (cat:tnpr 2 7 2
|
||||||
|
(cat:loop3 0 15 2))))
|
||||||
|
(cat:? c (+ 4 allp-degr) gnrt)
|
||||||
|
(cat:? c (cat:? c (+ 4 allp-degr) gnrt))
|
||||||
|
(dotimes (i 10)
|
||||||
|
(let ((allp (random-allp 3)))
|
||||||
|
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
|
||||||
|
(setf gnrt (cat:tnpr allp-degr allp 4
|
||||||
|
(cat:tnpr 2 7 2 (cat:loop3 0 15 2))))
|
||||||
|
(unless (>= allp-degr 11)
|
||||||
|
(print (cat:? c (+ 4 allp-degr) gnrt))
|
||||||
|
(print (cat:? c (cat:? c (+ 4 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 3 15 2 (cat:loop3 0 15 2))))
|
||||||
|
(unless (>= allp-degr 10)
|
||||||
|
(print (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-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))
|
||||||
|
50 (cat:tnpr 0 'a 6 (cat:tnpr 0 'b 6 'cc))
|
||||||
|
10 (cat:tnpr 0 'a 6 (cat:tnpr 2 'b 4 'c))
|
||||||
|
1 (cat:tnpr 2 'a 4 (cat:tnpr 2 'b 2 'cc)))))
|
||||||
|
|
||||||
|
|
||||||
|
(test ls-left-hmeq-left-reduction-g-intr
|
||||||
|
(let ((r (cat:ls-left-hmeq-left-reduction-g-intr '*)))
|
||||||
|
(funcall r (cat:cmbn 3 4 'loop))))
|
||||||
|
|
||||||
|
|
||||||
|
(test ls-pre-left-hmeq-left-reduction-h-intr
|
||||||
|
(cat:cat-init)
|
||||||
|
(let ((r (cat:ls-pre-left-hmeq-left-reduction-h-intr (cat:deltab))))
|
||||||
|
(setf cat:*tnpr-with-degrees* t)
|
||||||
|
(funcall r (cat:cmbn 10 1 (cat:tnpr 3 (cat:allp 2 'a 1 'b)
|
||||||
|
7 (cat:tnpr 5 'c 2 'd))
|
||||||
|
1 (cat:tnpr 7 (cat:allp 2 'a 5 'b)
|
||||||
|
3 (cat:tnpr 0 '* 3 'c))
|
||||||
|
10 (cat:tnpr 8 (cat:allp 4 'aa 4 'bb)
|
||||||
|
2 (cat:tnpr 0 '* 2 'cc))))
|
||||||
|
(funcall r (cat:cmbn 10 1 (cat:tnpr 3 (cat:allp 2 'a 1 'b)
|
||||||
|
7 (cat:tnpr 5 'c 2 'd))
|
||||||
|
1 (cat:tnpr 7 (cat:allp 4 'a 3 'b)
|
||||||
|
3 (cat:tnpr 0 '* 3 'c))
|
||||||
|
10 (cat:tnpr 8 (cat:allp 3 'aa 5 'bb)
|
||||||
|
2 (cat:tnpr 0 '* 2 'cc))))
|
||||||
|
(setf cat:*tnpr-with-degrees* nil)))
|
||||||
|
|
||||||
|
|
||||||
|
(test ls-pre-left-hmeq-left-reduction
|
||||||
|
(cat:cat-init)
|
||||||
|
(let* ((rdct (cat:ls-pre-left-hmeq-left-reduction (cat:deltab)))
|
||||||
|
(allp (random-allp 3))
|
||||||
|
(allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
|
||||||
|
(gnrt (cat:tnpr allp-degr allp 4 (cat:tnpr 2 7 2
|
||||||
|
(cat:loop3 0 15 2)))))
|
||||||
|
(cat:pre-check-rdct rdct)
|
||||||
|
(setf cat:*tc* (cat:cmbn (+ 4 allp-degr) 1 gnrt))
|
||||||
|
(setf cat:*bc* (cat:cmbn 2 1 (cat:loop3 0 15 2)))
|
||||||
|
(check-rdct)
|
||||||
|
(setf gnrt (cat:tnpr allp-degr allp 4
|
||||||
|
(cat:tnpr 0 1 4 (cat:loop3 0 (cat:mask 6) 2))))
|
||||||
|
(setf cat:*tc* (cat:cmbn (+ 4 allp-degr) 1 gnrt))
|
||||||
|
(check-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))))
|
||||||
|
(check-rdct)))
|
||||||
|
|
||||||
|
|
||||||
|
(defun a (d1 d2 d3)
|
||||||
|
(setf cat:*tc* (cat:cmbn (+ d1 d2 d3)
|
||||||
|
1 (cat:tnpr
|
||||||
|
d1 (cat:allp d1 (cat:mask (+ d1 2)))
|
||||||
|
(+ d2 d3)
|
||||||
|
(cat:tnpr d2 (cat:mask (1+ d2))
|
||||||
|
d3 (cat:loop3
|
||||||
|
0 (cat:mask (+ d3 2)) 1))))
|
||||||
|
cat:*bc* (cat:cmbn d3 1 (cat:loop3 0 (cat:mask (+ d3 2)) -1)))
|
||||||
|
(check-rdct))
|
||||||
|
|
||||||
|
|
||||||
|
(test ls-left-hmeq-left-reduction
|
||||||
|
(cat:cat-init)
|
||||||
|
(let ((rdct (cat:ls-left-hmeq-left-reduction (cat:deltab2))))
|
||||||
|
(cat:pre-check-rdct 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)
|
||||||
|
|#
|
||||||
|
)
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
(test ls-pre-left-hmeq-left-reduction-intr-f
|
||||||
|
(cat:ls-pre-left-hmeq-right-reduction-intr-f
|
||||||
|
(cat:cmbn 3 12 (cat:tnpr 2 'a 1 'b) 14 (cat:tnpr 3 'aa 0 '*))))
|
||||||
|
|
||||||
|
|
||||||
|
(test 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))))
|
||||||
|
|
||||||
|
|
||||||
|
(test ls-pre-left-hmeq-right-reduction
|
||||||
|
(cat:cat-init)
|
||||||
|
(let ((r (cat:ls-pre-left-hmeq-right-reduction (cat:deltab2))))
|
||||||
|
(cat:pre-check-rdct 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))))
|
||||||
|
(check-rdct)
|
||||||
|
#|
|
||||||
|
(setf cat:*tc* (cat:cmbn
|
||||||
|
3 1 (cat:tnpr 3 (cat:allp 3 (cat:mask 5))
|
||||||
|
0 (cat:tnpr 0 1 0 cat:+null-loop+))))
|
||||||
|
(setf cat:*bc* (cat:cmbn 3 1 (cat:allp 1 7 2 15)))
|
||||||
|
(check-rdct)
|
||||||
|
(setf cat:*tc* (cat:cmbn
|
||||||
|
6 1 (cat:tnpr 3 (cat:allp 1 7 2 15)
|
||||||
|
3 (cat:tnpr 2 7 1 (cat:loop3 0 7 2)))))
|
||||||
|
(check-rdct)
|
||||||
|
(setf cat:*tc* (cat:cmbn
|
||||||
|
6 1 (cat:tnpr
|
||||||
|
3 (cat:allp 1 7 2 15)
|
||||||
|
3 (cat:tnpr 0 1 3
|
||||||
|
(cat:loop3 0 (cat:mask 5) 2)))))
|
||||||
|
(check-rdct)
|
||||||
|
|#
|
||||||
|
))
|
||||||
|
|
||||||
|
|
||||||
|
(test ls-left-hmeq-right-reduction
|
||||||
|
(cat:cat-init)
|
||||||
|
(let ((r (cat:ls-left-hmeq-right-reduction (cat:deltab2))))
|
||||||
|
(cat:pre-check-rdct 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))))
|
||||||
|
(check-rdct)
|
||||||
|
#|
|
||||||
|
(setf cat:*tc* (cat:cmbn 3 1 (cat:tnpr 3 (cat:allp 3 (cat:mask 5))
|
||||||
|
0 (cat:tnpr 0 1 0
|
||||||
|
cat:+null-loop+))))
|
||||||
|
(setf cat:*bc* (cat:cmbn 3 1 (cat:allp 1 7 2 15)))
|
||||||
|
(check-rdct)
|
||||||
|
(setf cat:*tc* (cat:cmbn
|
||||||
|
6 1 (cat:tnpr 3 (cat:allp 1 7 2 15)
|
||||||
|
3 (cat:tnpr 2 7 1 (cat:loop3 0 7 2)))))
|
||||||
|
(check-rdct)
|
||||||
|
(setf cat:*tc* (cat:cmbn
|
||||||
|
6 1 (cat:tnpr 3 (cat:allp 1 7 2 15)
|
||||||
|
3 (cat:tnpr 0 1 3
|
||||||
|
(cat:loop3 0 (mask 5) 2)))))
|
||||||
|
(check-rdct)
|
||||||
|
|#
|
||||||
|
))
|
||||||
|
|
||||||
|
|
||||||
|
#|
|
||||||
|
(test ls-left-hmeq
|
||||||
|
(cat:cat-init)
|
||||||
|
(let* ((h (cat:ls-left-hmeq (cat:deltab2)))
|
||||||
|
(loop (cat:loop3 0 (cat:mask 5) 2))
|
||||||
|
(allp (cat:allp 2 (cat:mask 4) 3 (cat:mask 5)))
|
||||||
|
x)
|
||||||
|
(setf x (cat:lg h 3 loop))
|
||||||
|
(setf x (cat:rf h x))
|
||||||
|
(setf x (cat:rg h x))
|
||||||
|
(setf x (cat:lf h x))
|
||||||
|
(setf x (cat:rg h 5 allp))
|
||||||
|
(setf x (cat:lf h x))
|
||||||
|
(setf x (cat:lg h x))
|
||||||
|
(setf x (cat:rf h x)) ;; = allp, but why ?
|
||||||
|
))
|
||||||
|
|#
|
||||||
|
|
||||||
|
(test loop-space
|
||||||
|
(cat:cat-init)
|
||||||
|
(let ((l (cat:loop-space (cat:sphere 2)))
|
||||||
|
(oos3 (cat:loop-space (cat:loop-space (cat:sphere 3))))
|
||||||
|
(ooos4 (cat:loop-space (cat:loop-space (cat:loop-space
|
||||||
|
(cat:sphere 4))))))
|
||||||
|
(cat:homology l 6)
|
||||||
|
(cat:homology oos3 3)
|
||||||
|
(cat:homology ooos4 2)))
|
||||||
Loading…
Reference in New Issue
Block a user