check prevents "degree overflow."
This commit is contained in:
Gerd Heber
parent
86306c9c42
commit
d061360c93
@ -7,9 +7,9 @@
|
||||
(provide "cl-space-efhm")
|
||||
|
||||
(DEFUN CS-HAT-U-U (smgr
|
||||
&aux (bar (bar smgr))
|
||||
(cl-space (classifying-space smgr))
|
||||
(clsp-tnsr-smgr (tnsr-prdc cl-space smgr)))
|
||||
&aux (bar (bar smgr))
|
||||
(cl-space (classifying-space smgr))
|
||||
(clsp-tnsr-smgr (tnsr-prdc cl-space smgr)))
|
||||
(declare
|
||||
(type simplicial-group smgr)
|
||||
(type chain-complex bar clsp-tnsr-smgr)
|
||||
@ -22,108 +22,108 @@
|
||||
(declare (type simplicial-group smgr))
|
||||
(let ((aprd (aprd smgr)))
|
||||
(flet ((rslt (degr tnpr)
|
||||
(declare
|
||||
(fixnum degr)
|
||||
(type tnpr tnpr))
|
||||
(with-tnpr
|
||||
(degr1 tnpr1 degr2 abar2) tnpr
|
||||
(when (zerop degr2)
|
||||
(return-from rslt (zero-cmbn (1- degr))))
|
||||
(with-tnpr
|
||||
(degr11 gbar11 degr12 gmsm12) tnpr1
|
||||
(let ((sign (-1-expt-n degr1))
|
||||
(brgn21 (first (abar-list abar2)))
|
||||
(bar22 (make-abar :list (rest (abar-list abar2)))))
|
||||
(declare
|
||||
(fixnum sign)
|
||||
(type brgn brgn21)
|
||||
(type abar bar22))
|
||||
(with-brgn
|
||||
(degr21 gmsm21) brgn21
|
||||
(let ((degr22 (- degr2 degr21)))
|
||||
(declare (fixnum degr22))
|
||||
(decf degr21) ;; = dmns(gmsm21)
|
||||
(let ((aprd (gnrt-? aprd (+ degr12 degr21)
|
||||
(tnpr degr12 gmsm12
|
||||
degr21 gmsm21))))
|
||||
(declare (type cmbn aprd))
|
||||
(with-cmbn
|
||||
(degr12+21 list) aprd
|
||||
(make-cmbn
|
||||
:degr (1- degr)
|
||||
:list
|
||||
(mapcar
|
||||
#'(lambda (term)
|
||||
(declare (type term term))
|
||||
(with-term
|
||||
(cffc gmsm) term
|
||||
(term (* sign cffc)
|
||||
(tnpr (+ degr1 degr21)
|
||||
(tnpr degr11 gbar11
|
||||
degr12+21 gmsm)
|
||||
degr22 bar22))))
|
||||
list)))))))))))
|
||||
(declare
|
||||
(fixnum degr)
|
||||
(type tnpr tnpr))
|
||||
(with-tnpr
|
||||
(degr1 tnpr1 degr2 abar2) tnpr
|
||||
(when (zerop degr2)
|
||||
(return-from rslt (zero-cmbn (1- degr))))
|
||||
(with-tnpr
|
||||
(degr11 gbar11 degr12 gmsm12) tnpr1
|
||||
(let ((sign (-1-expt-n degr1))
|
||||
(brgn21 (first (abar-list abar2)))
|
||||
(bar22 (make-abar :list (rest (abar-list abar2)))))
|
||||
(declare
|
||||
(fixnum sign)
|
||||
(type brgn brgn21)
|
||||
(type abar bar22))
|
||||
(with-brgn
|
||||
(degr21 gmsm21) brgn21
|
||||
(let ((degr22 (- degr2 degr21)))
|
||||
(declare (fixnum degr22))
|
||||
(decf degr21) ;; = dmns(gmsm21)
|
||||
(let ((aprd (gnrt-? aprd (+ degr12 degr21)
|
||||
(tnpr degr12 gmsm12
|
||||
degr21 gmsm21))))
|
||||
(declare (type cmbn aprd))
|
||||
(with-cmbn
|
||||
(degr12+21 list) aprd
|
||||
(make-cmbn
|
||||
:degr (1- degr)
|
||||
:list
|
||||
(mapcar
|
||||
#'(lambda (term)
|
||||
(declare (type term term))
|
||||
(with-term
|
||||
(cffc gmsm) term
|
||||
(term (* sign cffc)
|
||||
(tnpr (+ degr1 degr21)
|
||||
(tnpr degr11 gbar11
|
||||
degr12+21 gmsm)
|
||||
degr22 bar22))))
|
||||
list)))))))))))
|
||||
(the intr-mrph #'rslt))))
|
||||
|
||||
|
||||
(DEFUN CS-HAT-RIGHT-PERTURBATION (smgr
|
||||
&aux (hat-u-u (cs-hat-u-u smgr)))
|
||||
&aux (hat-u-u (cs-hat-u-u smgr)))
|
||||
(declare
|
||||
(type simplicial-group smgr)
|
||||
(type chain-complex hat-u-u))
|
||||
(the morphism
|
||||
(build-mrph
|
||||
:sorc hat-u-u
|
||||
:trgt hat-u-u
|
||||
:degr -1
|
||||
:intr (cs-hat-right-perturbation-intr smgr)
|
||||
:strt :gnrt
|
||||
:orgn `(cs-hat-right-perturbation ,smgr))))
|
||||
:trgt hat-u-u
|
||||
:degr -1
|
||||
:intr (cs-hat-right-perturbation-intr smgr)
|
||||
:strt :gnrt
|
||||
:orgn `(cs-hat-right-perturbation ,smgr))))
|
||||
|
||||
|
||||
(DEFUN CS-HAT-U-T (smgr
|
||||
&aux (hat-u-u (cs-hat-u-u smgr))
|
||||
(hat-right-perturbation
|
||||
(cs-hat-right-perturbation smgr)))
|
||||
&aux (hat-u-u (cs-hat-u-u smgr))
|
||||
(hat-right-perturbation
|
||||
(cs-hat-right-perturbation smgr)))
|
||||
(declare
|
||||
(type simplicial-group smgr)
|
||||
(type chain-complex hat-u-u)
|
||||
(type morphism hat-right-perturbation))
|
||||
(the chain-complex
|
||||
(progn
|
||||
(setf (slot-value hat-right-perturbation 'sorc) hat-u-u
|
||||
(slot-value hat-right-perturbation 'trgt) hat-u-u)
|
||||
;; cf lp-space-efhm.lisp
|
||||
(add hat-u-u hat-right-perturbation))))
|
||||
(setf (slot-value hat-right-perturbation 'sorc) hat-u-u
|
||||
(slot-value hat-right-perturbation 'trgt) hat-u-u)
|
||||
;; cf lp-space-efhm.lisp
|
||||
(add hat-u-u hat-right-perturbation))))
|
||||
|
||||
|
||||
(DEFUN CS-HAT-LEFT-PERTURBATION (smgr
|
||||
&aux (fibration (smgr-fibration smgr))
|
||||
(bar (bar smgr))
|
||||
(hat-u-t (cs-hat-u-t smgr)))
|
||||
&aux (fibration (smgr-fibration smgr))
|
||||
(bar (bar smgr))
|
||||
(hat-u-t (cs-hat-u-t smgr)))
|
||||
(declare
|
||||
(type simplicial-group smgr)
|
||||
(type fibration fibration)
|
||||
(type chain-complex bar hat-u-t))
|
||||
(the morphism
|
||||
(multiple-value-bind (brown bottom-perturbation)
|
||||
(brown-reduction fibration)
|
||||
(declare
|
||||
(ignore brown)
|
||||
(type morphism bottom-perturbation))
|
||||
(let ((rslt (tnsr-prdc bottom-perturbation (idnt-mrph bar))))
|
||||
(declare (type morphism rslt))
|
||||
(setf (slot-value rslt 'sorc) hat-u-t
|
||||
(slot-value rslt 'trgt) hat-u-t)
|
||||
rslt))))
|
||||
(brown-reduction fibration)
|
||||
(declare
|
||||
(ignore brown)
|
||||
(type morphism bottom-perturbation))
|
||||
(let ((rslt (tnsr-prdc bottom-perturbation (idnt-mrph bar))))
|
||||
(declare (type morphism rslt))
|
||||
(setf (slot-value rslt 'sorc) hat-u-t
|
||||
(slot-value rslt 'trgt) hat-u-t)
|
||||
rslt))))
|
||||
|
||||
|
||||
(DEFUN CS-HAT-T-U (smgr
|
||||
&aux (bar (bar smgr))
|
||||
(fibration (smgr-fibration smgr))
|
||||
(brown (brown-reduction fibration))
|
||||
(twisted-tnsr-prdc (bcc brown))
|
||||
(hat-u-u (cs-hat-u-u smgr)))
|
||||
&aux (bar (bar smgr))
|
||||
(fibration (smgr-fibration smgr))
|
||||
(brown (brown-reduction fibration))
|
||||
(twisted-tnsr-prdc (bcc brown))
|
||||
(hat-u-u (cs-hat-u-u smgr)))
|
||||
(declare
|
||||
(type simplicial-group smgr)
|
||||
(type chain-complex bar twisted-tnsr-prdc hat-u-u)
|
||||
@ -131,15 +131,15 @@
|
||||
(type reduction brown))
|
||||
(the chain-complex
|
||||
(let ((rslt (tnsr-prdc twisted-tnsr-prdc bar)))
|
||||
(declare (type chain-complex rslt))
|
||||
(setf (slot-value rslt 'grmd) hat-u-u)
|
||||
rslt)))
|
||||
(declare (type chain-complex rslt))
|
||||
(setf (slot-value rslt 'grmd) hat-u-u)
|
||||
rslt)))
|
||||
|
||||
|
||||
(DEFUN CS-LEFT-HMEQ-HAT (smgr
|
||||
&aux (hat-t-u (cs-hat-t-u smgr))
|
||||
(hat-right-perturbation
|
||||
(cs-hat-right-perturbation smgr)))
|
||||
&aux (hat-t-u (cs-hat-t-u smgr))
|
||||
(hat-right-perturbation
|
||||
(cs-hat-right-perturbation smgr)))
|
||||
(declare
|
||||
(type simplicial-group smgr)
|
||||
(type chain-complex hat-t-u)
|
||||
@ -152,248 +152,248 @@
|
||||
(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 tnpr) term
|
||||
(term cffc (gnrt1 (gnrt1 tnpr)))))
|
||||
(member-if
|
||||
#'(lambda (term)
|
||||
(declare (type term term))
|
||||
(with-term
|
||||
(cffc tnpr) term
|
||||
(declare (ignore cffc))
|
||||
(with-tnpr
|
||||
(degr1 tnpr1 degr2 abar2) tnpr
|
||||
(declare (ignore degr1 abar2))
|
||||
(and (zerop degr2) (zerop (degr2 tnpr1))))))
|
||||
list))))))
|
||||
(degr list) cmbn
|
||||
(make-cmbn
|
||||
:degr degr
|
||||
:list (mapcar
|
||||
#'(lambda (term)
|
||||
(declare (type term term))
|
||||
(with-term
|
||||
(cffc tnpr) term
|
||||
(term cffc (gnrt1 (gnrt1 tnpr)))))
|
||||
(member-if
|
||||
#'(lambda (term)
|
||||
(declare (type term term))
|
||||
(with-term
|
||||
(cffc tnpr) term
|
||||
(declare (ignore cffc))
|
||||
(with-tnpr
|
||||
(degr1 tnpr1 degr2 abar2) tnpr
|
||||
(declare (ignore degr1 abar2))
|
||||
(and (zerop degr2) (zerop (degr2 tnpr1))))))
|
||||
list))))))
|
||||
|
||||
|
||||
(DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-F (smgr
|
||||
&aux (hat-u-t (cs-hat-u-t smgr))
|
||||
(classifying-space (classifying-space smgr)))
|
||||
&aux (hat-u-t (cs-hat-u-t smgr))
|
||||
(classifying-space (classifying-space smgr)))
|
||||
(declare
|
||||
(type simplicial-group smgr)
|
||||
(type chain-complex hat-u-t)
|
||||
(type simplicial-set classifying-space))
|
||||
(the morphism
|
||||
(build-mrph
|
||||
:sorc hat-u-t
|
||||
:trgt classifying-space
|
||||
:degr 0
|
||||
:intr #'cs-pre-left-hmeq-left-reduction-intr-f
|
||||
:strt :cmbn
|
||||
:orgn `(cs-pre-left-hmeq-left-reduction-f ,smgr))))
|
||||
:sorc hat-u-t
|
||||
:trgt classifying-space
|
||||
:degr 0
|
||||
:intr #'cs-pre-left-hmeq-left-reduction-intr-f
|
||||
:strt :cmbn
|
||||
:orgn `(cs-pre-left-hmeq-left-reduction-f ,smgr))))
|
||||
|
||||
(DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-INTR-G (idnt)
|
||||
(declare (type gmsm idnt))
|
||||
(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 gbar) term
|
||||
(term cffc
|
||||
(tnpr degr
|
||||
(tnpr degr gbar 0 idnt)
|
||||
0 +null-abar+))))
|
||||
list))))))
|
||||
(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 gbar) term
|
||||
(term cffc
|
||||
(tnpr degr
|
||||
(tnpr degr gbar 0 idnt)
|
||||
0 +null-abar+))))
|
||||
list))))))
|
||||
(the intr-mrph #'rslt)))
|
||||
|
||||
|
||||
(DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-G (smgr
|
||||
&aux (hat-u-t (cs-hat-u-t smgr))
|
||||
(classifying-space
|
||||
(classifying-space smgr)))
|
||||
&aux (hat-u-t (cs-hat-u-t smgr))
|
||||
(classifying-space
|
||||
(classifying-space smgr)))
|
||||
(declare
|
||||
(type simplicial-group smgr)
|
||||
(type chain-complex hat-u-t)
|
||||
(type simplicial-set classifying-space))
|
||||
(the morphism
|
||||
(build-mrph
|
||||
:sorc classifying-space
|
||||
:trgt hat-u-t
|
||||
:degr 0
|
||||
:intr (cs-pre-left-hmeq-left-reduction-intr-g (bspn smgr))
|
||||
:strt :cmbn
|
||||
:orgn `(cs-pre-left-hmeq-left-reduction-g ,smgr))))
|
||||
:sorc classifying-space
|
||||
:trgt hat-u-t
|
||||
:degr 0
|
||||
:intr (cs-pre-left-hmeq-left-reduction-intr-g (bspn smgr))
|
||||
:strt :cmbn
|
||||
:orgn `(cs-pre-left-hmeq-left-reduction-g ,smgr))))
|
||||
|
||||
|
||||
(DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-INTR-H (cmpr idnt)
|
||||
(declare (type gmsm idnt))
|
||||
(flet ((rslt (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(the cmbn
|
||||
(with-cmbn
|
||||
(degr list) cmbn
|
||||
(do ((rslt (zero-cmbn (1+ degr)))
|
||||
(mark list (cdr mark)))
|
||||
((endp mark) rslt)
|
||||
(declare
|
||||
(type cmbn rslt)
|
||||
(list mark))
|
||||
(let ((term (car mark)))
|
||||
(declare (type term term))
|
||||
(with-term
|
||||
(cffc tnpr) term
|
||||
(with-tnpr
|
||||
(degr1 tnpr1 degr2 abar2) tnpr
|
||||
(declare (ignore degr1))
|
||||
(with-tnpr
|
||||
(degr11 gbar11 degr12 gmsm12) tnpr1
|
||||
(unless (zerop degr12)
|
||||
(dstr-add-term-to-cmbn
|
||||
cmpr
|
||||
(if (evenp degr11) cffc (- cffc))
|
||||
(tnpr degr11
|
||||
(tnpr degr11 gbar11 0 idnt)
|
||||
(+ 1 degr12 degr2)
|
||||
(make-abar
|
||||
:list
|
||||
(cons (brgn (1+ degr12)
|
||||
gmsm12)
|
||||
(abar-list abar2))))
|
||||
rslt)))))))))))
|
||||
(declare (type cmbn cmbn))
|
||||
(the cmbn
|
||||
(with-cmbn
|
||||
(degr list) cmbn
|
||||
(do ((rslt (zero-cmbn (1+ degr)))
|
||||
(mark list (cdr mark)))
|
||||
((endp mark) rslt)
|
||||
(declare
|
||||
(type cmbn rslt)
|
||||
(list mark))
|
||||
(let ((term (car mark)))
|
||||
(declare (type term term))
|
||||
(with-term
|
||||
(cffc tnpr) term
|
||||
(with-tnpr
|
||||
(degr1 tnpr1 degr2 abar2) tnpr
|
||||
(declare (ignore degr1))
|
||||
(with-tnpr
|
||||
(degr11 gbar11 degr12 gmsm12) tnpr1
|
||||
(unless (zerop degr12)
|
||||
(dstr-add-term-to-cmbn
|
||||
cmpr
|
||||
(if (evenp degr11) cffc (- cffc))
|
||||
(tnpr degr11
|
||||
(tnpr degr11 gbar11 0 idnt)
|
||||
(+ 1 degr12 degr2)
|
||||
(make-abar
|
||||
:list
|
||||
(cons (brgn (1+ degr12)
|
||||
gmsm12)
|
||||
(abar-list abar2))))
|
||||
rslt)))))))))))
|
||||
(the intr-mrph #'rslt)))
|
||||
|
||||
|
||||
(DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-H (smgr
|
||||
&aux (hat-u-t (cs-hat-u-t smgr)))
|
||||
&aux (hat-u-t (cs-hat-u-t smgr)))
|
||||
(declare
|
||||
(type simplicial-group smgr)
|
||||
(type chain-complex hat-u-t))
|
||||
(the morphism
|
||||
(build-mrph
|
||||
:sorc hat-u-t
|
||||
:trgt hat-u-t
|
||||
:degr +1
|
||||
:intr (cs-pre-left-hmeq-left-reduction-intr-h (cmpr hat-u-t)
|
||||
(bspn smgr))
|
||||
:strt :cmbn
|
||||
:orgn `(cs-pre-left-hmeq-left-reduction-h ,smgr))))
|
||||
:sorc hat-u-t
|
||||
:trgt hat-u-t
|
||||
:degr +1
|
||||
:intr (cs-pre-left-hmeq-left-reduction-intr-h (cmpr hat-u-t)
|
||||
(bspn smgr))
|
||||
:strt :cmbn
|
||||
:orgn `(cs-pre-left-hmeq-left-reduction-h ,smgr))))
|
||||
|
||||
|
||||
(DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION (smgr)
|
||||
(declare (type simplicial-group smgr))
|
||||
(the reduction
|
||||
(build-rdct
|
||||
:f (cs-pre-left-hmeq-left-reduction-f smgr)
|
||||
:g (cs-pre-left-hmeq-left-reduction-g smgr)
|
||||
:h (cs-pre-left-hmeq-left-reduction-h smgr)
|
||||
:orgn `(cs-pre-left-hmeq-left-reduction ,smgr))))
|
||||
:f (cs-pre-left-hmeq-left-reduction-f smgr)
|
||||
:g (cs-pre-left-hmeq-left-reduction-g smgr)
|
||||
:h (cs-pre-left-hmeq-left-reduction-h smgr)
|
||||
:orgn `(cs-pre-left-hmeq-left-reduction ,smgr))))
|
||||
|
||||
|
||||
(DEFUN CS-LEFT-HMEQ-LEFT-REDUCTION (smgr
|
||||
&aux (pre-left-hmeq-left-reduction
|
||||
(cs-pre-left-hmeq-left-reduction
|
||||
smgr))
|
||||
(hat-left-perturbation
|
||||
(cs-hat-left-perturbation smgr)))
|
||||
&aux (pre-left-hmeq-left-reduction
|
||||
(cs-pre-left-hmeq-left-reduction
|
||||
smgr))
|
||||
(hat-left-perturbation
|
||||
(cs-hat-left-perturbation smgr)))
|
||||
(declare
|
||||
(type simplicial-group smgr)
|
||||
(type reduction pre-left-hmeq-left-reduction)
|
||||
(type morphism hat-left-perturbation))
|
||||
(the reduction
|
||||
(progn
|
||||
(dstr-change-sorc-trgt hat-left-perturbation
|
||||
:new-sorc (tcc pre-left-hmeq-left-reduction)
|
||||
:new-trgt (tcc pre-left-hmeq-left-reduction))
|
||||
(let ((rslt (special-bpl-2 pre-left-hmeq-left-reduction
|
||||
hat-left-perturbation)))
|
||||
(declare (type reduction rslt))
|
||||
(with-slots (tcc f g h) rslt
|
||||
(setf tcc (cs-left-hmeq-hat smgr)
|
||||
(slot-value f 'sorc) tcc
|
||||
(slot-value g 'trgt) tcc
|
||||
(slot-value h 'sorc) tcc
|
||||
(slot-value h 'trgt) tcc))
|
||||
rslt))))
|
||||
(dstr-change-sorc-trgt hat-left-perturbation
|
||||
:new-sorc (tcc pre-left-hmeq-left-reduction)
|
||||
:new-trgt (tcc pre-left-hmeq-left-reduction))
|
||||
(let ((rslt (special-bpl-2 pre-left-hmeq-left-reduction
|
||||
hat-left-perturbation)))
|
||||
(declare (type reduction rslt))
|
||||
(with-slots (tcc f g h) rslt
|
||||
(setf tcc (cs-left-hmeq-hat smgr)
|
||||
(slot-value f 'sorc) tcc
|
||||
(slot-value g 'trgt) tcc
|
||||
(slot-value h 'sorc) tcc
|
||||
(slot-value h 'trgt) tcc))
|
||||
rslt))))
|
||||
|
||||
|
||||
(DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-F (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(the cmbn
|
||||
(with-cmbn (degr list) cmbn
|
||||
(let ((rslt +empty-list+))
|
||||
(declare (list rslt))
|
||||
(do ((mark list (cdr mark)))
|
||||
((endp mark))
|
||||
(declare (list mark))
|
||||
(with--term (cffc tnpr) mark
|
||||
(with-tnpr (degr1 nil nil abar2) tnpr
|
||||
(if (zerop degr1)
|
||||
(push (term cffc abar2) rslt)
|
||||
(return)))))
|
||||
(make-cmbn :degr degr
|
||||
:list (nreverse rslt))))))
|
||||
(let ((rslt +empty-list+))
|
||||
(declare (list rslt))
|
||||
(do ((mark list (cdr mark)))
|
||||
((endp mark))
|
||||
(declare (list mark))
|
||||
(with--term (cffc tnpr) mark
|
||||
(with-tnpr (degr1 nil nil abar2) tnpr
|
||||
(if (zerop degr1)
|
||||
(push (term cffc abar2) rslt)
|
||||
(return)))))
|
||||
(make-cmbn :degr degr
|
||||
:list (nreverse rslt))))))
|
||||
|
||||
|
||||
(DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-F (smgr
|
||||
&aux (hat-t-u (cs-hat-t-u smgr))
|
||||
(bar (bar smgr)))
|
||||
&aux (hat-t-u (cs-hat-t-u smgr))
|
||||
(bar (bar smgr)))
|
||||
(declare
|
||||
(type simplicial-group smgr)
|
||||
(type chain-complex hat-t-u bar))
|
||||
(the morphism
|
||||
(build-mrph
|
||||
:sorc hat-t-u :trgt bar :degr 0
|
||||
:intr #'cs-pre-left-hmeq-right-reduction-intr-f
|
||||
:strt :cmbn
|
||||
:orgn `(cs-pre-left-hmeq-right-reduction-f ,smgr))))
|
||||
:sorc hat-t-u :trgt bar :degr 0
|
||||
:intr #'cs-pre-left-hmeq-right-reduction-intr-f
|
||||
:strt :cmbn
|
||||
:orgn `(cs-pre-left-hmeq-right-reduction-f ,smgr))))
|
||||
|
||||
|
||||
(DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-G (idnt)
|
||||
(declare (type gmsm idnt))
|
||||
(flet ((rslt (cmbn)
|
||||
(declare (type cmbn cmbn))
|
||||
(the cmbn
|
||||
(with-cmbn
|
||||
(degr list) cmbn
|
||||
(let ((bsgn (tnpr 0 +null-gbar+ 0 idnt)))
|
||||
(declare (type tnpr bsgn))
|
||||
(make-cmbn :degr degr
|
||||
:list (mapcar
|
||||
#'(lambda (term)
|
||||
(declare (type term term))
|
||||
(with-term
|
||||
(cffc abar) term
|
||||
(term cffc
|
||||
(tnpr 0 bsgn
|
||||
degr abar))))
|
||||
list)))))))
|
||||
(declare (type cmbn cmbn))
|
||||
(the cmbn
|
||||
(with-cmbn
|
||||
(degr list) cmbn
|
||||
(let ((bsgn (tnpr 0 +null-gbar+ 0 idnt)))
|
||||
(declare (type tnpr bsgn))
|
||||
(make-cmbn :degr degr
|
||||
:list (mapcar
|
||||
#'(lambda (term)
|
||||
(declare (type term term))
|
||||
(with-term
|
||||
(cffc abar) term
|
||||
(term cffc
|
||||
(tnpr 0 bsgn
|
||||
degr abar))))
|
||||
list)))))))
|
||||
(the intr-mrph #'rslt)))
|
||||
|
||||
|
||||
(DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-G (smgr
|
||||
&aux (hat-t-u (cs-hat-t-u smgr))
|
||||
(bar (bar smgr))
|
||||
(idnt (bspn smgr)))
|
||||
&aux (hat-t-u (cs-hat-t-u smgr))
|
||||
(bar (bar smgr))
|
||||
(idnt (bspn smgr)))
|
||||
(declare
|
||||
(type simplicial-group smgr)
|
||||
(type chain-complex hat-t-u bar)
|
||||
(type gmsm idnt))
|
||||
(the morphism
|
||||
(build-mrph
|
||||
:sorc bar :trgt hat-t-u :degr 0
|
||||
:intr (cs-pre-left-hmeq-right-reduction-intr-g idnt)
|
||||
:strt :cmbn
|
||||
:orgn `(cs-pre-left-hmeq-right-reduction-g ,smgr))))
|
||||
:sorc bar :trgt hat-t-u :degr 0
|
||||
:intr (cs-pre-left-hmeq-right-reduction-intr-g idnt)
|
||||
:strt :cmbn
|
||||
:orgn `(cs-pre-left-hmeq-right-reduction-g ,smgr))))
|
||||
|
||||
(DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-H (smgr
|
||||
&aux (bar (bar smgr))
|
||||
(tnpr-contraction
|
||||
(smgr-tnpr-contraction smgr)))
|
||||
&aux (bar (bar smgr))
|
||||
(tnpr-contraction
|
||||
(smgr-tnpr-contraction smgr)))
|
||||
(declare
|
||||
(type simplicial-group smgr)
|
||||
(type chain-complex bar)
|
||||
@ -405,42 +405,42 @@
|
||||
(declare (type simplicial-group smgr))
|
||||
(the reduction
|
||||
(build-rdct
|
||||
:f (cs-pre-left-hmeq-right-reduction-f smgr)
|
||||
:g (cs-pre-left-hmeq-right-reduction-g smgr)
|
||||
:h (cs-pre-left-hmeq-right-reduction-h smgr)
|
||||
:orgn `(cs-pre-left-hmeq-right-reduction ,smgr))))
|
||||
:f (cs-pre-left-hmeq-right-reduction-f smgr)
|
||||
:g (cs-pre-left-hmeq-right-reduction-g smgr)
|
||||
:h (cs-pre-left-hmeq-right-reduction-h smgr)
|
||||
:orgn `(cs-pre-left-hmeq-right-reduction ,smgr))))
|
||||
|
||||
|
||||
(DEFUN CS-LEFT-HMEQ-RIGHT-REDUCTION (smgr
|
||||
&aux (pre-reduction
|
||||
(cs-pre-left-hmeq-right-reduction
|
||||
smgr))
|
||||
(perturbation
|
||||
(cs-hat-right-perturbation smgr)))
|
||||
&aux (pre-reduction
|
||||
(cs-pre-left-hmeq-right-reduction
|
||||
smgr))
|
||||
(perturbation
|
||||
(cs-hat-right-perturbation smgr)))
|
||||
(declare
|
||||
(type simplicial-group smgr)
|
||||
(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-2 pre-reduction perturbation))))
|
||||
(setf (slot-value perturbation 'sorc) (tcc pre-reduction)
|
||||
(slot-value perturbation 'trgt) (tcc pre-reduction))
|
||||
(special-bpl-2 pre-reduction perturbation))))
|
||||
|
||||
|
||||
(DEFUN CS-LEFT-HMEQ (smgr)
|
||||
(declare (type simplicial-group smgr))
|
||||
(the homotopy-equivalence
|
||||
(build-hmeq
|
||||
:lrdct (cs-left-hmeq-left-reduction smgr)
|
||||
:rrdct (cs-left-hmeq-right-reduction smgr)
|
||||
:orgn `(cs-left-hmeq ,smgr))))
|
||||
:lrdct (cs-left-hmeq-left-reduction smgr)
|
||||
:rrdct (cs-left-hmeq-right-reduction smgr)
|
||||
:orgn `(cs-left-hmeq ,smgr))))
|
||||
|
||||
|
||||
(DEFUN CLASSIFYING-SPACE-EFHM (smgr)
|
||||
(declare (type simplicial-group smgr))
|
||||
(let ((left-hmeq (cs-left-hmeq smgr))
|
||||
(right-hmeq (bar (efhm smgr))))
|
||||
(right-hmeq (bar (efhm smgr))))
|
||||
(declare (type homotopy-equivalence left-hmeq right-hmeq))
|
||||
(cmps left-hmeq right-hmeq)))
|
||||
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
|
||||
|
||||
(in-package :kenzo-test)
|
||||
|
||||
(in-suite :kenzo)
|
||||
@ -11,127 +11,127 @@
|
||||
|
||||
(test bar-cmpr
|
||||
(let ((r (cat:bar-cmpr #'cat:s-cmpr)))
|
||||
(is (equal :equal (funcall r (cat:abar) (cat:abar))))
|
||||
(is (equal :greater (funcall r (cat:abar 3 'a) (cat:abar))))
|
||||
(is (equal :less (funcall r (cat:abar 3 'a) (cat:abar 2 'a 1 'b))))
|
||||
(is (equal :less (funcall r (cat:abar 3 'a) (cat:abar 3 'b))))
|
||||
(is (equal :equal (funcall r (cat:abar 3 'a) (cat:abar 3 'a))))))
|
||||
(is (equal :equal (funcall r (cat:abar) (cat:abar))))
|
||||
(is (equal :greater (funcall r (cat:abar 3 'a) (cat:abar))))
|
||||
(is (equal :less (funcall r (cat:abar 3 'a) (cat:abar 2 'a 1 'b))))
|
||||
(is (equal :less (funcall r (cat:abar 3 'a) (cat:abar 3 'b))))
|
||||
(is (equal :equal (funcall r (cat:abar 3 'a) (cat:abar 3 'a))))))
|
||||
|
||||
(test bar-basis-length
|
||||
(let ((basis #'(lambda (degr) (list degr))))
|
||||
(cat:bar-basis-length basis 2 1)
|
||||
(cat:bar-basis-length basis 2 2)
|
||||
(cat:bar-basis-length basis 3 1)
|
||||
(cat:bar-basis-length basis 3 2)
|
||||
(cat:bar-basis-length basis 4 1)
|
||||
(cat:bar-basis-length basis 4 2)
|
||||
(cat:bar-basis-length basis 4 3)
|
||||
(cat:bar-basis-length basis 4 4)
|
||||
(cat:bar-basis-length basis 8 1)
|
||||
(cat:bar-basis-length basis 8 2)
|
||||
(cat:bar-basis-length basis 8 3)
|
||||
(cat:bar-basis-length basis 8 4)
|
||||
(cat:bar-basis-length basis 8 5)
|
||||
(cat:bar-basis-length basis 8 6)
|
||||
(cat:bar-basis-length basis 8 11)))
|
||||
(cat:bar-basis-length basis 2 1)
|
||||
(cat:bar-basis-length basis 2 2)
|
||||
(cat:bar-basis-length basis 3 1)
|
||||
(cat:bar-basis-length basis 3 2)
|
||||
(cat:bar-basis-length basis 4 1)
|
||||
(cat:bar-basis-length basis 4 2)
|
||||
(cat:bar-basis-length basis 4 3)
|
||||
(cat:bar-basis-length basis 4 4)
|
||||
(cat:bar-basis-length basis 8 1)
|
||||
(cat:bar-basis-length basis 8 2)
|
||||
(cat:bar-basis-length basis 8 3)
|
||||
(cat:bar-basis-length basis 8 4)
|
||||
(cat:bar-basis-length basis 8 5)
|
||||
(cat:bar-basis-length basis 8 6)
|
||||
(cat:bar-basis-length basis 8 11)))
|
||||
|
||||
|
||||
(test bar-basis
|
||||
(let* ((basis #'(lambda (degr) (list degr)))
|
||||
(r (cat:bar-basis basis)))
|
||||
(funcall r 0)
|
||||
(funcall r 1)
|
||||
(funcall r 2)
|
||||
(dotimes (i 7)
|
||||
(print (funcall r i)))
|
||||
(cat:bar-basis :locally-effective)))
|
||||
(r (cat:bar-basis basis)))
|
||||
(funcall r 0)
|
||||
(funcall r 1)
|
||||
(funcall r 2)
|
||||
(dotimes (i 7)
|
||||
(print (funcall r i)))
|
||||
(cat:bar-basis :locally-effective)))
|
||||
|
||||
|
||||
(test bar-intr-vrtc-dffr
|
||||
(let* ((d (cat:soft-delta-infinity))
|
||||
(r (cat:bar-intr-vrtc-dffr (cat:dffr d))))
|
||||
(funcall r 0 (cat:abar))
|
||||
(funcall r 3 (cat:abar 3 (cat:d 7)))
|
||||
(funcall r 5 (cat:abar 3 (cat:d 7) 2 (cat:d 3)))
|
||||
(funcall r 5 (cat:abar 2 (cat:d 3) 3 (cat:d 7)))))
|
||||
(r (cat:bar-intr-vrtc-dffr (cat:dffr d))))
|
||||
(funcall r 0 (cat:abar))
|
||||
(funcall r 3 (cat:abar 3 (cat:d 7)))
|
||||
(funcall r 5 (cat:abar 3 (cat:d 7) 2 (cat:d 3)))
|
||||
(funcall r 5 (cat:abar 2 (cat:d 3) 3 (cat:d 7)))))
|
||||
|
||||
|
||||
(defun random-abar1 (length)
|
||||
(let ((rslt nil))
|
||||
(dotimes (i length)
|
||||
(let* ((gmsm (random (cat:mask 7)))
|
||||
(dmns (1- (logcount gmsm))))
|
||||
(when (plusp dmns)
|
||||
(push (cat:brgn (1+ dmns) (cat:d gmsm)) rslt))))
|
||||
(dmns (1- (logcount gmsm))))
|
||||
(when (plusp dmns)
|
||||
(push (cat:brgn (1+ dmns) (cat:d gmsm)) rslt))))
|
||||
(cat:make-abar :list rslt)))
|
||||
|
||||
|
||||
(test vrtc-bar
|
||||
(progn
|
||||
(cat:cat-init)
|
||||
(let ((v (cat:vrtc-bar (cat:soft-delta-infinity))))
|
||||
(dotimes (i 10)
|
||||
(print (random-abar1 5)))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar1 3)))
|
||||
(print abar)
|
||||
(print (cat:? v (apply #'+ (mapcar #'car (cat:abar-list abar)))
|
||||
abar))
|
||||
(print (cat:? v (cat:? v (apply #'+ (mapcar #'car
|
||||
(cat:abar-list abar)))
|
||||
abar))))))))
|
||||
(cat:cat-init)
|
||||
(let ((v (cat:vrtc-bar (cat:soft-delta-infinity))))
|
||||
(dotimes (i 10)
|
||||
(print (random-abar1 5)))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar1 3)))
|
||||
(print abar)
|
||||
(print (cat:? v (apply #'+ (mapcar #'car (cat:abar-list abar)))
|
||||
abar))
|
||||
(print (cat:? v (cat:? v (apply #'+ (mapcar #'car
|
||||
(cat:abar-list abar)))
|
||||
abar))))))))
|
||||
|
||||
|
||||
(test bar-intr-hrzn-dffr
|
||||
(let* ((k (cat:k-z-1))
|
||||
(r (cat:bar-intr-hrzn-dffr (cat:aprd k))))
|
||||
(funcall r 0 (cat:abar ))
|
||||
(funcall r 3 (cat:abar 3 '(2 3)))
|
||||
(funcall r 6 (cat:abar 3 '(2 3) 3 '(-2 -3)))
|
||||
(funcall r 9 (cat:abar 3 '(2 3) 3 '(-2 -3) 3 '(2 3)))
|
||||
(funcall r 11 (cat:abar 3 '(2 3) 3 '(-2 -3) 2 '(-2) 3 '(-2 -3)))))
|
||||
(r (cat:bar-intr-hrzn-dffr (cat:aprd k))))
|
||||
(funcall r 0 (cat:abar ))
|
||||
(funcall r 3 (cat:abar 3 '(2 3)))
|
||||
(funcall r 6 (cat:abar 3 '(2 3) 3 '(-2 -3)))
|
||||
(funcall r 9 (cat:abar 3 '(2 3) 3 '(-2 -3) 3 '(2 3)))
|
||||
(funcall r 11 (cat:abar 3 '(2 3) 3 '(-2 -3) 2 '(-2) 3 '(-2 -3)))))
|
||||
|
||||
|
||||
#|
|
||||
(test bar-hrzn-dffr
|
||||
(progn
|
||||
(cat:cat-init)
|
||||
(let ((h (cat:bar-hrzn-dffr (cat:k-z-1)))
|
||||
(abar))
|
||||
(dotimes (i 10)
|
||||
(print (random-abar 10 5)))
|
||||
(setf abar (random-abar 10 5))
|
||||
(cat:? h (apply #'+ (mapcar #'car (cat:abar-list abar))) abar)
|
||||
(cat:? h (cat:? h (apply #'+ (mapcar #'car
|
||||
(cat:abar-list abar))) abar))
|
||||
(dotimes (i 10)
|
||||
(setf abar (random-abar 10 3))
|
||||
(print abar)
|
||||
(print (cat:? h (apply #'+ (mapcar #'car (cat:abar-list abar)))
|
||||
abar))
|
||||
(print (cat:? h (cat:? h (apply #'+ (mapcar #'car
|
||||
(cat:abar-list abar)))
|
||||
abar)))))))
|
||||
(cat:cat-init)
|
||||
(let ((h (cat:bar-hrzn-dffr (cat:k-z-1)))
|
||||
(abar))
|
||||
(dotimes (i 10)
|
||||
(print (random-abar 10 5)))
|
||||
(setf abar (random-abar 10 5))
|
||||
(cat:? h (apply #'+ (mapcar #'car (cat:abar-list abar))) abar)
|
||||
(cat:? h (cat:? h (apply #'+ (mapcar #'car
|
||||
(cat:abar-list abar))) abar))
|
||||
(dotimes (i 10)
|
||||
(setf abar (random-abar 10 3))
|
||||
(print abar)
|
||||
(print (cat:? h (apply #'+ (mapcar #'car (cat:abar-list abar)))
|
||||
abar))
|
||||
(print (cat:? h (cat:? h (apply #'+ (mapcar #'car
|
||||
(cat:abar-list abar)))
|
||||
abar)))))))
|
||||
|#
|
||||
|
||||
(test bar
|
||||
(progn
|
||||
(cat:cat-init)
|
||||
(let ((b (cat:bar (cat:k-z-1)))
|
||||
(abar (random-abar 10 3)))
|
||||
(cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar))) abar)
|
||||
(cat:? b (cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar)))
|
||||
abar))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 10 3)))
|
||||
(print abar)
|
||||
(print (cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar)))
|
||||
abar))
|
||||
(print (cat:? b
|
||||
(cat:? b
|
||||
(apply #'+ (mapcar #'car
|
||||
(cat:abar-list abar)))
|
||||
abar))))))))
|
||||
(cat:cat-init)
|
||||
(let ((b (cat:bar (cat:k-z-1)))
|
||||
(abar (random-abar 10 3)))
|
||||
(cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar))) abar)
|
||||
(cat:? b (cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar)))
|
||||
abar))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 10 3)))
|
||||
(print abar)
|
||||
(print (cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar)))
|
||||
abar))
|
||||
(print (cat:? b
|
||||
(cat:? b
|
||||
(apply #'+ (mapcar #'car
|
||||
(cat:abar-list abar)))
|
||||
abar))))))))
|
||||
|
||||
|
||||
(test ncmbn-bar
|
||||
@ -139,103 +139,103 @@
|
||||
(cat:ncmbn-bar (list (cat:cmbn 3 2 'a 3 'b)))
|
||||
(cat:ncmbn-bar (list (cat:cmbn 1 2 'a 3 'b) (cat:cmbn 2 4 'c 5 'd)))
|
||||
(cat:ncmbn-bar (list (cat:cmbn 1 2 'a 3 'b) (cat:cmbn 1 4 'c 5 'd)
|
||||
(cat:cmbn 1 6 'e 7 'f))))
|
||||
(cat:cmbn 1 6 'e 7 'f))))
|
||||
|
||||
|
||||
(test mrph-vrtc-bar-intr
|
||||
(let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr
|
||||
:basis :locally-effective
|
||||
:intr-dffr #'cat:zero-mrph
|
||||
:strt :cmbn))
|
||||
(m (cat:build-mrph :sorc cc :trgt cc :degr 0 :intr
|
||||
#'(lambda (degr gnrt)
|
||||
(cat:cmbn degr 2 gnrt 3 (1+ gnrt)))
|
||||
:strt :gnrt :orgn '(test)))
|
||||
(r (cat:mrph-vrtc-bar-intr m)))
|
||||
(funcall r 4 (cat:abar 2 3 2 4))))
|
||||
:basis :locally-effective
|
||||
:intr-dffr #'cat:zero-mrph
|
||||
:strt :cmbn))
|
||||
(m (cat:build-mrph :sorc cc :trgt cc :degr 0 :intr
|
||||
#'(lambda (degr gnrt)
|
||||
(cat:cmbn degr 2 gnrt 3 (1+ gnrt)))
|
||||
:strt :gnrt :orgn '(test)))
|
||||
(r (cat:mrph-vrtc-bar-intr m)))
|
||||
(funcall r 4 (cat:abar 2 3 2 4))))
|
||||
|
||||
|
||||
(test vrtc-bar
|
||||
(progn
|
||||
(cat:cat-init)
|
||||
(let* ((f (cat:aw (cat:soft-delta-infinity)
|
||||
(cat:soft-delta-infinity)))
|
||||
(cf (cat:vrtc-bar f)))
|
||||
(cat:? cf 6 (cat:abar 3 (cat:crpr 0 (cat:d 7) 0 (cat:d 7)) 3
|
||||
(cat:crpr 0 (cat:d 56) 0 (cat:d 56)))))))
|
||||
(cat:cat-init)
|
||||
(let* ((f (cat:aw (cat:soft-delta-infinity)
|
||||
(cat:soft-delta-infinity)))
|
||||
(cf (cat:vrtc-bar f)))
|
||||
(cat:? cf 6 (cat:abar 3 (cat:crpr 0 (cat:d 7) 0 (cat:d 7)) 3
|
||||
(cat:crpr 0 (cat:d 56) 0 (cat:d 56)))))))
|
||||
|
||||
|
||||
(test hmtp-vrtc-bar-intr
|
||||
(progn
|
||||
(cat:cat-init)
|
||||
(let* ((ez (cat:ez (cat:delta-infinity) (cat:delta-infinity)))
|
||||
(h (cat:h ez))
|
||||
(gf (cat:cmps (cat:g ez) (cat:f ez)))
|
||||
(r (cat:hmtp-vrtc-bar-intr h gf)))
|
||||
(funcall r 3 (cat:abar 3 (cat:crpr 0 7 0 7)))
|
||||
(funcall r 9 (cat:abar 3 (cat:crpr 0 7 0 7) 3 (cat:crpr 0 14 0 14)
|
||||
3 (cat:crpr 0 14 0 14))))))
|
||||
(cat:cat-init)
|
||||
(let* ((ez (cat:ez (cat:delta-infinity) (cat:delta-infinity)))
|
||||
(h (cat:h ez))
|
||||
(gf (cat:cmps (cat:g ez) (cat:f ez)))
|
||||
(r (cat:hmtp-vrtc-bar-intr h gf)))
|
||||
(funcall r 3 (cat:abar 3 (cat:crpr 0 7 0 7)))
|
||||
(funcall r 9 (cat:abar 3 (cat:crpr 0 7 0 7) 3 (cat:crpr 0 14 0 14)
|
||||
3 (cat:crpr 0 14 0 14))))))
|
||||
|
||||
|
||||
#|
|
||||
(test vrtc-bar1
|
||||
(progn
|
||||
(cat:cat-init)
|
||||
(cat:cat-init)
|
||||
|
||||
(let* ((tcc (cat:build-chcm
|
||||
:cmpr #'cat:s-cmpr
|
||||
:basis #'(lambda (degr) '(a b c d))
|
||||
:bsgn 'd
|
||||
:intr-dffr #'(lambda (degr gnrt)
|
||||
(ecase gnrt
|
||||
(a (cat:cmbn (1- degr) 1 'b 1 'd))
|
||||
((b d) (cat:cmbn (1- degr)))
|
||||
(c (cat:cmbn (1- degr) 1 'd))))
|
||||
:strt :gnrt
|
||||
:orgn '(tcc)))
|
||||
(bcc (cat:build-chcm
|
||||
:cmpr #'cat:s-cmpr
|
||||
:basis #'(lambda (degr) '(c d))
|
||||
:bsgn 'd
|
||||
:intr-dffr #'(lambda (degr gnrt)
|
||||
(ecase gnrt
|
||||
(d (cat:cmbn (1- degr)))
|
||||
(c (cat:cmbn (1- degr) 1 'd))))
|
||||
:strt :gnrt
|
||||
:orgn '(bcc)))
|
||||
(f (cat:build-mrph :sorc tcc :trgt bcc :degr 0
|
||||
:intr #'(lambda (degr gnrt)
|
||||
(ecase gnrt
|
||||
(a (cat:cmbn degr 1 'c 1 'd))
|
||||
(b (cat:cmbn degr))
|
||||
((c d) (cat:cmbn degr 1 gnrt))))
|
||||
:strt :gnrt :orgn '(f)))
|
||||
(g (cat:build-mrph :sorc bcc :trgt tcc :degr 0
|
||||
:intr #'identity :strt :cmbn :orgn '(g)))
|
||||
(h (cat:build-mrph :sorc tcc :trgt tcc :degr +1
|
||||
:intr #'(lambda (degr gnrt)
|
||||
(ecase gnrt
|
||||
((a b) (cat:cmbn
|
||||
(1+ degr)
|
||||
1 'a -1 'b -1 'c -1 'd))
|
||||
((c d) (cat:cmbn (1+ degr)))))
|
||||
:strt :gnrt :orgn '(h)))
|
||||
(rdct (cat:build-rdct :f f :g g :h h :orgn '(rdct)))
|
||||
(bar))
|
||||
(cat:tcc rdct 3 'a)
|
||||
(cat:g rdct (cat:f rdct 3 'a))
|
||||
(cat:h rdct 3 'a)
|
||||
(setf bar (cat:vrtc-bar rdct))
|
||||
(cat:pre-check-rdct bar)
|
||||
(aleat-tc)
|
||||
(aleat-bc)
|
||||
;;(loop (c))
|
||||
(dotimes (i 10) (c))))) ;; degrees >= 15 is possible => error.
|
||||
(let* ((tcc (cat:build-chcm
|
||||
:cmpr #'cat:s-cmpr
|
||||
:basis #'(lambda (degr) '(a b c d))
|
||||
:bsgn 'd
|
||||
:intr-dffr #'(lambda (degr gnrt)
|
||||
(ecase gnrt
|
||||
(a (cat:cmbn (1- degr) 1 'b 1 'd))
|
||||
((b d) (cat:cmbn (1- degr)))
|
||||
(c (cat:cmbn (1- degr) 1 'd))))
|
||||
:strt :gnrt
|
||||
:orgn '(tcc)))
|
||||
(bcc (cat:build-chcm
|
||||
:cmpr #'cat:s-cmpr
|
||||
:basis #'(lambda (degr) '(c d))
|
||||
:bsgn 'd
|
||||
:intr-dffr #'(lambda (degr gnrt)
|
||||
(ecase gnrt
|
||||
(d (cat:cmbn (1- degr)))
|
||||
(c (cat:cmbn (1- degr) 1 'd))))
|
||||
:strt :gnrt
|
||||
:orgn '(bcc)))
|
||||
(f (cat:build-mrph :sorc tcc :trgt bcc :degr 0
|
||||
:intr #'(lambda (degr gnrt)
|
||||
(ecase gnrt
|
||||
(a (cat:cmbn degr 1 'c 1 'd))
|
||||
(b (cat:cmbn degr))
|
||||
((c d) (cat:cmbn degr 1 gnrt))))
|
||||
:strt :gnrt :orgn '(f)))
|
||||
(g (cat:build-mrph :sorc bcc :trgt tcc :degr 0
|
||||
:intr #'identity :strt :cmbn :orgn '(g)))
|
||||
(h (cat:build-mrph :sorc tcc :trgt tcc :degr +1
|
||||
:intr #'(lambda (degr gnrt)
|
||||
(ecase gnrt
|
||||
((a b) (cat:cmbn
|
||||
(1+ degr)
|
||||
1 'a -1 'b -1 'c -1 'd))
|
||||
((c d) (cat:cmbn (1+ degr)))))
|
||||
:strt :gnrt :orgn '(h)))
|
||||
(rdct (cat:build-rdct :f f :g g :h h :orgn '(rdct)))
|
||||
(bar))
|
||||
(cat:tcc rdct 3 'a)
|
||||
(cat:g rdct (cat:f rdct 3 'a))
|
||||
(cat:h rdct 3 'a)
|
||||
(setf bar (cat:vrtc-bar rdct))
|
||||
(cat:pre-check-rdct bar)
|
||||
(aleat-tc)
|
||||
(aleat-bc)
|
||||
;;(loop (c))
|
||||
(dotimes (i 10) (c))))) ;; degrees >= 15 is possible => error.
|
||||
|#
|
||||
|
||||
(test homology
|
||||
(progn
|
||||
(cat:cat-init)
|
||||
(let* ((h (cat:efhm (cat:k-z-1)))
|
||||
(b (cat:bar h)))
|
||||
(cat:homology (cat:rbcc b) 0 11))))
|
||||
(cat:cat-init)
|
||||
(let* ((h (cat:efhm (cat:k-z-1)))
|
||||
(b (cat:bar h)))
|
||||
(cat:homology (cat:rbcc b) 0 11))))
|
||||
|
||||
@ -1,456 +1,382 @@
|
||||
|
||||
(in-package :kenzo-test)
|
||||
|
||||
(in-suite :kenzo)
|
||||
|
||||
#|
|
||||
(test cs-hat-u-t
|
||||
(cat:cat-init)
|
||||
(let* ((c (cat:cs-hat-u-t (cat:k-z-1)))
|
||||
(abar (random-abar 8 4))
|
||||
(abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) 0 '())
|
||||
2 '(4 5))
|
||||
abar-degr abar)))
|
||||
(cat:? c (+ 5 abar-degr) gnrt)
|
||||
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr) gnrt))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
|
||||
0 '()) 2 '(4 5))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 10)
|
||||
(print (cat:? c (+ 5 abar-degr) gnrt))
|
||||
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
|
||||
gnrt)))))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
|
||||
0 '()) 3 '(4 5 6))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 9)
|
||||
(print (cat:? c (+ 6 abar-degr) gnrt))
|
||||
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 6 abar-degr)
|
||||
gnrt)))))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
3 '(4 5 6)) abar-degr abar))
|
||||
(unless (>= abar-degr 10)
|
||||
(print (cat:? c (+ 5 abar-degr) gnrt))
|
||||
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
|
||||
gnrt)))))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
2 '(4 5))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 11)
|
||||
(print (cat:? c (+ 4 abar-degr) gnrt))
|
||||
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 4 abar-degr)
|
||||
gnrt)))))))))
|
||||
|#
|
||||
(let ((c (cat:cs-hat-u-t (cat:k-z-1)))
|
||||
abar-degr
|
||||
gnrt)
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
|
||||
0 '()) 2 '(4 5))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 10)
|
||||
(print (cat:? c (+ 5 abar-degr) gnrt))
|
||||
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
|
||||
gnrt)))))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
|
||||
0 '()) 3 '(4 5 6))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 9)
|
||||
(print (cat:? c (+ 6 abar-degr) gnrt))
|
||||
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 6 abar-degr)
|
||||
gnrt)))))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
3 '(4 5 6)) abar-degr abar))
|
||||
(unless (>= abar-degr 10)
|
||||
(print (cat:? c (+ 5 abar-degr) gnrt))
|
||||
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
|
||||
gnrt)))))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
2 '(4 5))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 11)
|
||||
(print (cat:? c (+ 4 abar-degr) gnrt))
|
||||
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 4 abar-degr)
|
||||
gnrt)))))))))
|
||||
|
||||
|
||||
#|
|
||||
(test cs-hat-t-u
|
||||
(cat:cat-init)
|
||||
(dotimes (i 5) (print (random-abar 8 4)))
|
||||
(let* ((c (cat:cs-hat-t-u (cat:k-z-1)))
|
||||
(abar (random-abar 8 4))
|
||||
(abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) 0 '())
|
||||
2 '(4 5))
|
||||
abar-degr abar)))
|
||||
(cat:? c (+ 5 abar-degr) gnrt)
|
||||
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr) gnrt))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
|
||||
0 '()) 2 '(4 5))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 10)
|
||||
(print (cat:? c (+ 5 abar-degr) gnrt))
|
||||
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
|
||||
gnrt)))))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
|
||||
0 '()) 3 '(4 5 6))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 9)
|
||||
(print (cat:? c (+ 6 abar-degr) gnrt))
|
||||
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 6 abar-degr)
|
||||
gnrt)))))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
3 '(4 5 6))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 10)
|
||||
(print (cat:? c (+ 5 abar-degr) gnrt))
|
||||
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
|
||||
gnrt)))))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
2 '(4 5))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 11)
|
||||
(print (cat:? c (+ 4 abar-degr) gnrt))
|
||||
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 4 abar-degr)
|
||||
gnrt)))))))))
|
||||
|#
|
||||
(let ((c (cat:cs-hat-t-u (cat:k-z-1)))
|
||||
abar-degr
|
||||
gnrt)
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
|
||||
0 '()) 2 '(4 5))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 10)
|
||||
(print (cat:? c (+ 5 abar-degr) gnrt))
|
||||
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
|
||||
gnrt)))))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
|
||||
0 '()) 3 '(4 5 6))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 9)
|
||||
(print (cat:? c (+ 6 abar-degr) gnrt))
|
||||
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 6 abar-degr)
|
||||
gnrt)))))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
3 '(4 5 6))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 10)
|
||||
(print (cat:? c (+ 5 abar-degr) gnrt))
|
||||
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
|
||||
gnrt)))))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
2 '(4 5))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 11)
|
||||
(print (cat:? c (+ 4 abar-degr) gnrt))
|
||||
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 4 abar-degr)
|
||||
gnrt)))))))))
|
||||
|
||||
|
||||
#|
|
||||
(test cs-left-hmeq-hat
|
||||
(cat:cat-init)
|
||||
(let ((c (cat:cs-left-hmeq-hat (cat:k-z-1)))
|
||||
abar-degr
|
||||
gnrt)
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
|
||||
0 '()) 2 '(4 5))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 10)
|
||||
(print (cat:? c (+ 5 abar-degr) gnrt))
|
||||
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
|
||||
gnrt)))))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
|
||||
0 '()) 3 '(4 5 6))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 9)
|
||||
(print (cat:? c (+ 6 abar-degr) gnrt))
|
||||
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 6 abar-degr)
|
||||
gnrt)))))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
3 '(4 5 6))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 10)
|
||||
(print (cat:? c (+ 5 abar-degr) gnrt))
|
||||
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
|
||||
gnrt)))))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
2 '(4 5))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 11)
|
||||
(print (cat:? c (+ 4 abar-degr) gnrt))
|
||||
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 4 abar-degr)
|
||||
gnrt)))))))))
|
||||
|#
|
||||
abar-degr
|
||||
gnrt)
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
|
||||
0 '()) 2 '(4 5))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 10)
|
||||
(print (cat:? c (+ 5 abar-degr) gnrt))
|
||||
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
|
||||
gnrt)))))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
|
||||
0 '()) 3 '(4 5 6))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 9)
|
||||
(print (cat:? c (+ 6 abar-degr) gnrt))
|
||||
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 6 abar-degr)
|
||||
gnrt)))))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
3 '(4 5 6))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 10)
|
||||
(print (cat:? c (+ 5 abar-degr) gnrt))
|
||||
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
|
||||
gnrt)))))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
2 '(4 5))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 11)
|
||||
(print (cat:? c (+ 4 abar-degr) gnrt))
|
||||
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 4 abar-degr)
|
||||
gnrt)))))))))
|
||||
|
||||
|
||||
(test cs-pre-left-hmeq-left-reduction-intr-f
|
||||
(cat:cs-pre-left-hmeq-left-reduction-intr-f
|
||||
(cat:cmbn 6 100 (cat:tnpr 4 (cat:tnpr 2 'a 2 'b) 2 'c)
|
||||
10 (cat:tnpr 6 (cat:tnpr 2 'a 4 'b) 0 'c)
|
||||
50 (cat:tnpr 6 (cat:tnpr 6 'a 0 'b) 0 'c)
|
||||
1 (cat:tnpr 6 (cat:tnpr 6 'aa 0 'b) 0 'c))))
|
||||
|
||||
|
||||
(test cs-pre-left-hmeq-left-reduction-intr-g
|
||||
(let ((g (cat:cs-pre-left-hmeq-left-reduction-intr-g '())))
|
||||
(funcall g (cat:cmbn 3 14 (cat:gbar 3 0 'a 1 'b 0 '())))))
|
||||
|
||||
|
||||
#|
|
||||
(test cs-pre-left-hmeq-left-reduction
|
||||
(cat:cat-init)
|
||||
(let ((rdct (cat:cs-pre-left-hmeq-left-reduction (cat:k-z-1)))
|
||||
abar-degr
|
||||
gnrt
|
||||
gbar)
|
||||
(cat:pre-check-rdct rdct)
|
||||
(setf cat:*tc* (cat:cmbn 0 1
|
||||
(cat:tnpr 0 (cat:tnpr 0
|
||||
cat:+null-gbar+ 0 '())
|
||||
0 cat:+null-abar+))
|
||||
cat:*bc* (cat:cmbn 0 1 cat:+null-gbar+))
|
||||
(check-rdct)
|
||||
(setf cat:*tc* (cat:cmbn 1 1
|
||||
(cat:tnpr 1 (cat:tnpr 0
|
||||
cat:+null-gbar+ 1 '(13))
|
||||
0 cat:+null-abar+)))
|
||||
(check-rdct)
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
|
||||
0 '()) 2 '(4 5))
|
||||
abar-degr abar))
|
||||
(setf gbar (cat:gbar 2 0 '(1) 0 '()))
|
||||
(unless (>= abar-degr 9)
|
||||
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt)
|
||||
cat:*bc* (cat:cmbn 2 1 gbar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
|
||||
0 '()) 3 '(4 5 6))
|
||||
abar-degr abar))
|
||||
(setf gbar (cat:gbar 3 0 '(1 2) 1 '() 0 '()))
|
||||
(unless (>= abar-degr 8)
|
||||
(setf cat:*tc* (cat:cmbn (+ 6 abar-degr) 1 gnrt)
|
||||
cat:*bc* (cat:cmbn 3 1 gbar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
3 '(4 5 6))
|
||||
abar-degr abar))
|
||||
(setf gbar (cat:gbar 4 0 '(1 2 3) 0 '(4 5) 0 '(6) 0 '()))
|
||||
(unless (>= abar-degr 9)
|
||||
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt))
|
||||
(setf cat:*bc* (cat:cmbn 4 1 gbar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
2 '(4 5))
|
||||
abar-degr abar))
|
||||
(setf gbar (cat:gbar 5 8 '(1 2 3) 0 '(4 5 6) 0 '(7 8) 0 '(9)
|
||||
0 '()))
|
||||
(unless (>= abar-degr 10)
|
||||
(setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt))
|
||||
(setf cat:*bc* (cat:cmbn 5 1 gbar))
|
||||
(check-rdct))))))
|
||||
|#
|
||||
abar-degr
|
||||
gnrt
|
||||
gbar)
|
||||
(cat:pre-check-rdct rdct)
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
|
||||
0 '()) 2 '(4 5))
|
||||
abar-degr abar))
|
||||
(setf gbar (cat:gbar 2 0 '(1) 0 '()))
|
||||
(unless (>= abar-degr 9)
|
||||
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt)
|
||||
cat:*bc* (cat:cmbn 2 1 gbar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
|
||||
0 '()) 3 '(4 5 6))
|
||||
abar-degr abar))
|
||||
(setf gbar (cat:gbar 3 0 '(1 2) 1 '() 0 '()))
|
||||
(unless (>= abar-degr 8)
|
||||
(setf cat:*tc* (cat:cmbn (+ 6 abar-degr) 1 gnrt)
|
||||
cat:*bc* (cat:cmbn 3 1 gbar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
3 '(4 5 6))
|
||||
abar-degr abar))
|
||||
(setf gbar (cat:gbar 4 0 '(1 2 3) 0 '(4 5) 0 '(6) 0 '()))
|
||||
(unless (>= abar-degr 9)
|
||||
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt))
|
||||
(setf cat:*bc* (cat:cmbn 4 1 gbar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
2 '(4 5))
|
||||
abar-degr abar))
|
||||
(setf gbar (cat:gbar 5 8 '(1 2 3) 0 '(4 5 6) 0 '(7 8) 0 '(9)
|
||||
0 '()))
|
||||
(unless (>= abar-degr 10)
|
||||
(setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt))
|
||||
(setf cat:*bc* (cat:cmbn 5 1 gbar))
|
||||
(check-rdct))))))
|
||||
|
||||
|
||||
#|
|
||||
(test cs-left-hmeq-left-reduction
|
||||
(cat:cat-init)
|
||||
(let ((rdct (cat:cs-left-hmeq-left-reduction (cat:k-z-1)))
|
||||
abar-degr gnrt gbar)
|
||||
(cat:pre-check-rdct rdct)
|
||||
(setf cat:*tc* (cat:cmbn 0 1 (cat:tnpr 0
|
||||
(cat:tnpr 0 cat:+null-gbar+
|
||||
0 '()) 0
|
||||
cat:+null-abar+))
|
||||
cat:*bc* (cat:cmbn 0 1 cat:+null-gbar+))
|
||||
(check-rdct)
|
||||
(setf cat:*tc* (cat:cmbn 1 1 (cat:tnpr 1
|
||||
(cat:tnpr 0 cat:+null-gbar+
|
||||
1 '(13)) 0
|
||||
cat:+null-abar+)))
|
||||
(check-rdct)
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
|
||||
0 '()) 2 '(4 5))
|
||||
abar-degr abar))
|
||||
(setf gbar (cat:gbar 2 0 '(1) 0 '()))
|
||||
(unless (>= abar-degr 9)
|
||||
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt)
|
||||
cat:*bc* (cat:cmbn 2 1 gbar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
|
||||
0 '()) 3 '(4 5 6))
|
||||
abar-degr abar))
|
||||
(setf gbar (cat:gbar 3 0 '(1 2) 1 '() 0 '()))
|
||||
(unless (>= abar-degr 8)
|
||||
(setf cat:*tc* (cat:cmbn (+ 6 abar-degr) 1 gnrt)
|
||||
cat:*bc* (cat:cmbn 3 1 gbar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
3 '(4 5 6))
|
||||
abar-degr abar))
|
||||
(setf gbar (cat:gbar 4 0 '(1 2 3) 0 '(4 5) 0 '(6) 0 '()))
|
||||
(unless (>= abar-degr 9)
|
||||
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt))
|
||||
(setf cat:*bc* (cat:cmbn 4 1 gbar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
2 '(4 5))
|
||||
abar-degr abar))
|
||||
(setf gbar (cat:gbar 5 8 '(1 2 3) 0 '(4 5 6) 0 '(7 8) 0 '(9)
|
||||
0 '()))
|
||||
(unless (>= abar-degr 10)
|
||||
(setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt))
|
||||
(setf cat:*bc* (cat:cmbn 5 1 gbar))
|
||||
(check-rdct))))))
|
||||
|#
|
||||
abar-degr
|
||||
gnrt
|
||||
gbar)
|
||||
(cat:pre-check-rdct rdct)
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
|
||||
0 '()) 2 '(4 5))
|
||||
abar-degr abar))
|
||||
(setf gbar (cat:gbar 2 0 '(1) 0 '()))
|
||||
(unless (>= abar-degr 9)
|
||||
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt)
|
||||
cat:*bc* (cat:cmbn 2 1 gbar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
|
||||
0 '()) 3 '(4 5 6))
|
||||
abar-degr abar))
|
||||
(setf gbar (cat:gbar 3 0 '(1 2) 1 '() 0 '()))
|
||||
(unless (>= abar-degr 8)
|
||||
(setf cat:*tc* (cat:cmbn (+ 6 abar-degr) 1 gnrt)
|
||||
cat:*bc* (cat:cmbn 3 1 gbar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
3 '(4 5 6))
|
||||
abar-degr abar))
|
||||
(setf gbar (cat:gbar 4 0 '(1 2 3) 0 '(4 5) 0 '(6) 0 '()))
|
||||
(unless (>= abar-degr 9)
|
||||
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt))
|
||||
(setf cat:*bc* (cat:cmbn 4 1 gbar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
2 '(4 5))
|
||||
abar-degr abar))
|
||||
(setf gbar (cat:gbar 5 8 '(1 2 3) 0 '(4 5 6) 0 '(7 8) 0 '(9)
|
||||
0 '()))
|
||||
(unless (>= abar-degr 10)
|
||||
(setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt))
|
||||
(setf cat:*bc* (cat:cmbn 5 1 gbar))
|
||||
(check-rdct))))))
|
||||
|
||||
|
||||
(test cs-pre-left-hmeq-right-reduction-intr-f
|
||||
(cat:cs-pre-left-hmeq-right-reduction-intr-f
|
||||
(cat:cmbn 4 2 (cat:tnpr 0 (cat:tnpr 0 cat:+null-gbar+ 0 'i)
|
||||
4 (cat:abar 2 'a 2 'b))
|
||||
3 (cat:tnpr 0 (cat:tnpr 0 cat:+null-gbar+ 0 'i)
|
||||
4 (cat:abar 2 'a 2 'c))
|
||||
5 (cat:tnpr 1 (cat:tnpr 0 cat:+null-gbar+ 1 'a)
|
||||
3 (cat:abar 1 'a 2 'b)))))
|
||||
4 (cat:abar 2 'a 2 'b))
|
||||
3 (cat:tnpr 0 (cat:tnpr 0 cat:+null-gbar+ 0 'i)
|
||||
4 (cat:abar 2 'a 2 'c))
|
||||
5 (cat:tnpr 1 (cat:tnpr 0 cat:+null-gbar+ 1 'a)
|
||||
3 (cat:abar 1 'a 2 'b)))))
|
||||
|
||||
|
||||
(test cs-pre-left-hmeq-right-reduction-g
|
||||
(let ((g (cat:cs-pre-left-hmeq-right-reduction-intr-g 'i)))
|
||||
(funcall g (cat:cmbn 3 2 (cat:abar 1 'a 2 'b)))))
|
||||
(funcall g (cat:cmbn 3 2 (cat:abar 1 'a 2 'b)))))
|
||||
|
||||
|
||||
#|
|
||||
(test cs-pre-left-hmeq-right-reduction
|
||||
(cat:cat-init)
|
||||
(let ((rdct (cat:cs-pre-left-hmeq-right-reduction (cat:k-z-1)))
|
||||
abar-degr
|
||||
gnrt)
|
||||
(cat:pre-check-rdct rdct)
|
||||
(setf cat:*tc* (cat:cmbn 0 1 (cat:tnpr 0
|
||||
(cat:tnpr 0 cat:+null-gbar+
|
||||
0 '())
|
||||
0 cat:+null-abar+))
|
||||
cat:*bc* (cat:cmbn 0 1 cat:+null-abar+))
|
||||
(check-rdct)
|
||||
(setf cat:*tc* (cat:cmbn 1 1 (cat:tnpr 1
|
||||
(cat:tnpr 0 cat:+null-gbar+
|
||||
1 '(13))
|
||||
0 cat:+null-abar+)))
|
||||
(check-rdct)
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
|
||||
0 '()) 2 '(4 5))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 9)
|
||||
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt)
|
||||
cat:*bc* (cat:cmbn abar-degr 1 abar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
|
||||
0 '()) 3 '(4 5 6))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 8)
|
||||
(setf cat:*tc* (cat:cmbn (+ 6 abar-degr) 1 gnrt)
|
||||
cat:*bc* (cat:cmbn abar-degr 1 abar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
3 '(4 5 6))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 9)
|
||||
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt))
|
||||
(setf cat:*bc* (cat:cmbn abar-degr 1 abar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
2 '(4 5))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 10)
|
||||
(setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt))
|
||||
(setf cat:*bc* (cat:cmbn abar-degr 1 abar))
|
||||
(check-rdct))))))
|
||||
|#
|
||||
abar-degr
|
||||
gnrt)
|
||||
(cat:pre-check-rdct rdct)
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 8 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
|
||||
0 '()) 2 '(4 5))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 9)
|
||||
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt)
|
||||
cat:*bc* (cat:cmbn abar-degr 1 abar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
|
||||
0 '()) 3 '(4 5 6))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 8)
|
||||
(setf cat:*tc* (cat:cmbn (+ 6 abar-degr) 1 gnrt)
|
||||
cat:*bc* (cat:cmbn abar-degr 1 abar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
3 '(4 5 6))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 9)
|
||||
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt))
|
||||
(setf cat:*bc* (cat:cmbn abar-degr 1 abar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
2 '(4 5))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 10)
|
||||
(setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt))
|
||||
(setf cat:*bc* (cat:cmbn abar-degr 1 abar))
|
||||
(check-rdct))))))
|
||||
|
||||
#|
|
||||
(test cs-left-hmeq-right-reduction
|
||||
(cat:cat-init)
|
||||
|
||||
(let ((rdct (cat:cs-left-hmeq-right-reduction (cat:k-z-1)))
|
||||
abar-degr
|
||||
gnrt)
|
||||
(cat:pre-check-rdct rdct)
|
||||
(setf cat:*tc* (cat:cmbn 0 1
|
||||
(cat:tnpr 0 (cat:tnpr 0 cat:+null-gbar+
|
||||
0 '())
|
||||
0 cat:+null-abar+))
|
||||
cat:*bc* (cat:cmbn 0 1 cat:+null-abar+))
|
||||
(check-rdct)
|
||||
(setf cat:*tc* (cat:cmbn 1 1
|
||||
(cat:tnpr 1 (cat:tnpr 0 cat:+null-gbar+
|
||||
1 '(13))
|
||||
0 cat:+null-abar+)))
|
||||
(check-rdct)
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 4 2)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 3 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
1 '(4))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 9)
|
||||
(setf cat:*tc* (cat:cmbn (+ 3 abar-degr) 1 gnrt)
|
||||
cat:*bc* (cat:cmbn abar-degr 1 abar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 3 1)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
2 '(5 6))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 8)
|
||||
(setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt)
|
||||
cat:*bc* (cat:cmbn abar-degr 1 abar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 3 1)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 1 '()
|
||||
0 '()) 2 '(5 6))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 9)
|
||||
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt))
|
||||
(setf cat:*bc* (cat:cmbn abar-degr 1 abar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
2 '(4 5))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 10)
|
||||
(setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt))
|
||||
(setf cat:*bc* (cat:cmbn abar-degr 1 abar))
|
||||
(check-rdct))))))
|
||||
abar-degr
|
||||
gnrt)
|
||||
(cat:pre-check-rdct rdct)
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 4 2)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 3 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
1 '(4))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 9)
|
||||
(setf cat:*tc* (cat:cmbn (+ 3 abar-degr) 1 gnrt)
|
||||
cat:*bc* (cat:cmbn abar-degr 1 abar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 3 1)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
2 '(5 6))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 8)
|
||||
(setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt)
|
||||
cat:*bc* (cat:cmbn abar-degr 1 abar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 3 1)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 1 '()
|
||||
0 '()) 2 '(5 6))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 9)
|
||||
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt))
|
||||
(setf cat:*bc* (cat:cmbn abar-degr 1 abar))
|
||||
(check-rdct))))
|
||||
(dotimes (i 10)
|
||||
(let ((abar (random-abar 6 4)))
|
||||
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
|
||||
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
|
||||
2 '(4 5))
|
||||
abar-degr abar))
|
||||
(unless (>= abar-degr 10)
|
||||
(setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt))
|
||||
(setf cat:*bc* (cat:cmbn abar-degr 1 abar))
|
||||
(check-rdct))))))
|
||||
|#
|
||||
|
||||
(test cs-left-hmeq
|
||||
(cat:cat-init)
|
||||
(let* ((h (cat:cs-left-hmeq (cat:k-z-1)))
|
||||
(abar (cat:abar 2 '(2) 3 '(3 4))))
|
||||
(cat:rf h
|
||||
(cat:lg h
|
||||
(cat:lf h
|
||||
(cat:rg h 5 abar))))))
|
||||
(abar (cat:abar 2 '(2) 3 '(3 4))))
|
||||
(cat:rf h
|
||||
(cat:lg h
|
||||
(cat:lf h
|
||||
(cat:rg h 5 abar))))))
|
||||
|
||||
|
||||
(test classifying-space
|
||||
(cat:cat-init)
|
||||
(let* ((k (cat:k-z-1))
|
||||
(bk (cat:classifying-space k))
|
||||
(obk (cat:loop-space bk)))
|
||||
(cat:homology k 0 10)
|
||||
(cat:homology bk 0 10)
|
||||
(cat:homology obk 0 6)))
|
||||
(bk (cat:classifying-space k))
|
||||
(obk (cat:loop-space bk)))
|
||||
(cat:homology k 0 10)
|
||||
(cat:homology bk 0 10)
|
||||
(cat:homology obk 0 6)))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user