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

Resolved #40 #41 #43 #45 as per Francis' comment. The (unless (>= abar-degr *))

Browse Source 
check prevents "degree overflow."
This commit is contained in:
Gerd Heber 2015-11-18 19:49:09 -06:00
parent 86306c9c42
commit d061360c93
3 changed files with 752 additions and 826 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

510
src/cl-space-efhm.lisp
View File

@ -7,9 +7,9 @@
(provide "cl-space-efhm") (provide "cl-space-efhm")
(DEFUN CS-HAT-U-U (smgr (DEFUN CS-HAT-U-U (smgr
&aux (bar (bar smgr)) &aux (bar (bar smgr))
(cl-space (classifying-space smgr)) (cl-space (classifying-space smgr))
(clsp-tnsr-smgr (tnsr-prdc cl-space smgr))) (clsp-tnsr-smgr (tnsr-prdc cl-space smgr)))
(declare (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type chain-complex bar clsp-tnsr-smgr) (type chain-complex bar clsp-tnsr-smgr)
@ -22,108 +22,108 @@
(declare (type simplicial-group smgr)) (declare (type simplicial-group smgr))
(let ((aprd (aprd smgr))) (let ((aprd (aprd smgr)))
(flet ((rslt (degr tnpr) (flet ((rslt (degr tnpr)
(declare (declare
(fixnum degr) (fixnum degr)
(type tnpr tnpr)) (type tnpr tnpr))
(with-tnpr (with-tnpr
(degr1 tnpr1 degr2 abar2) tnpr (degr1 tnpr1 degr2 abar2) tnpr
(when (zerop degr2) (when (zerop degr2)
(return-from rslt (zero-cmbn (1- degr)))) (return-from rslt (zero-cmbn (1- degr))))
(with-tnpr (with-tnpr
(degr11 gbar11 degr12 gmsm12) tnpr1 (degr11 gbar11 degr12 gmsm12) tnpr1
(let ((sign (-1-expt-n degr1)) (let ((sign (-1-expt-n degr1))
(brgn21 (first (abar-list abar2))) (brgn21 (first (abar-list abar2)))
(bar22 (make-abar :list (rest (abar-list abar2))))) (bar22 (make-abar :list (rest (abar-list abar2)))))
(declare (declare
(fixnum sign) (fixnum sign)
(type brgn brgn21) (type brgn brgn21)
(type abar bar22)) (type abar bar22))
(with-brgn (with-brgn
(degr21 gmsm21) brgn21 (degr21 gmsm21) brgn21
(let ((degr22 (- degr2 degr21))) (let ((degr22 (- degr2 degr21)))
(declare (fixnum degr22)) (declare (fixnum degr22))
(decf degr21) ;; = dmns(gmsm21) (decf degr21) ;; = dmns(gmsm21)
(let ((aprd (gnrt-? aprd (+ degr12 degr21) (let ((aprd (gnrt-? aprd (+ degr12 degr21)
(tnpr degr12 gmsm12 (tnpr degr12 gmsm12
degr21 gmsm21)))) degr21 gmsm21))))
(declare (type cmbn aprd)) (declare (type cmbn aprd))
(with-cmbn (with-cmbn
(degr12+21 list) aprd (degr12+21 list) aprd
(make-cmbn (make-cmbn
:degr (1- degr) :degr (1- degr)
:list :list
(mapcar (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc gmsm) term (cffc gmsm) term
(term (* sign cffc) (term (* sign cffc)
(tnpr (+ degr1 degr21) (tnpr (+ degr1 degr21)
(tnpr degr11 gbar11 (tnpr degr11 gbar11
degr12+21 gmsm) degr12+21 gmsm)
degr22 bar22)))) degr22 bar22))))
list))))))))))) list)))))))))))
(the intr-mrph #'rslt)))) (the intr-mrph #'rslt))))
(DEFUN CS-HAT-RIGHT-PERTURBATION (smgr (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 (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type chain-complex hat-u-u)) (type chain-complex hat-u-u))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc hat-u-u :sorc hat-u-u
:trgt hat-u-u :trgt hat-u-u
:degr -1 :degr -1
:intr (cs-hat-right-perturbation-intr smgr) :intr (cs-hat-right-perturbation-intr smgr)
:strt :gnrt :strt :gnrt
:orgn `(cs-hat-right-perturbation ,smgr)))) :orgn `(cs-hat-right-perturbation ,smgr))))
(DEFUN CS-HAT-U-T (smgr (DEFUN CS-HAT-U-T (smgr
&aux (hat-u-u (cs-hat-u-u smgr)) &aux (hat-u-u (cs-hat-u-u smgr))
(hat-right-perturbation (hat-right-perturbation
(cs-hat-right-perturbation smgr))) (cs-hat-right-perturbation smgr)))
(declare (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type chain-complex hat-u-u) (type chain-complex hat-u-u)
(type morphism hat-right-perturbation)) (type morphism hat-right-perturbation))
(the chain-complex (the chain-complex
(progn (progn
(setf (slot-value hat-right-perturbation 'sorc) hat-u-u (setf (slot-value hat-right-perturbation 'sorc) hat-u-u
(slot-value hat-right-perturbation 'trgt) hat-u-u) (slot-value hat-right-perturbation 'trgt) hat-u-u)
;; cf lp-space-efhm.lisp ;; cf lp-space-efhm.lisp
(add hat-u-u hat-right-perturbation)))) (add hat-u-u hat-right-perturbation))))
(DEFUN CS-HAT-LEFT-PERTURBATION (smgr (DEFUN CS-HAT-LEFT-PERTURBATION (smgr
&aux (fibration (smgr-fibration smgr)) &aux (fibration (smgr-fibration smgr))
(bar (bar smgr)) (bar (bar smgr))
(hat-u-t (cs-hat-u-t smgr))) (hat-u-t (cs-hat-u-t smgr)))
(declare (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type fibration fibration) (type fibration fibration)
(type chain-complex bar hat-u-t)) (type chain-complex bar hat-u-t))
(the morphism (the morphism
(multiple-value-bind (brown bottom-perturbation) (multiple-value-bind (brown bottom-perturbation)
(brown-reduction fibration) (brown-reduction fibration)
(declare (declare
(ignore brown) (ignore brown)
(type morphism bottom-perturbation)) (type morphism bottom-perturbation))
(let ((rslt (tnsr-prdc bottom-perturbation (idnt-mrph bar)))) (let ((rslt (tnsr-prdc bottom-perturbation (idnt-mrph bar))))
(declare (type morphism rslt)) (declare (type morphism rslt))
(setf (slot-value rslt 'sorc) hat-u-t (setf (slot-value rslt 'sorc) hat-u-t
(slot-value rslt 'trgt) hat-u-t) (slot-value rslt 'trgt) hat-u-t)
rslt)))) rslt))))
(DEFUN CS-HAT-T-U (smgr (DEFUN CS-HAT-T-U (smgr
&aux (bar (bar smgr)) &aux (bar (bar smgr))
(fibration (smgr-fibration smgr)) (fibration (smgr-fibration smgr))
(brown (brown-reduction fibration)) (brown (brown-reduction fibration))
(twisted-tnsr-prdc (bcc brown)) (twisted-tnsr-prdc (bcc brown))
(hat-u-u (cs-hat-u-u smgr))) (hat-u-u (cs-hat-u-u smgr)))
(declare (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type chain-complex bar twisted-tnsr-prdc hat-u-u) (type chain-complex bar twisted-tnsr-prdc hat-u-u)
@ -131,15 +131,15 @@
(type reduction brown)) (type reduction brown))
(the chain-complex (the chain-complex
(let ((rslt (tnsr-prdc twisted-tnsr-prdc bar))) (let ((rslt (tnsr-prdc twisted-tnsr-prdc bar)))
(declare (type chain-complex rslt)) (declare (type chain-complex rslt))
(setf (slot-value rslt 'grmd) hat-u-u) (setf (slot-value rslt 'grmd) hat-u-u)
rslt))) rslt)))
(DEFUN CS-LEFT-HMEQ-HAT (smgr (DEFUN CS-LEFT-HMEQ-HAT (smgr
&aux (hat-t-u (cs-hat-t-u smgr)) &aux (hat-t-u (cs-hat-t-u smgr))
(hat-right-perturbation (hat-right-perturbation
(cs-hat-right-perturbation smgr))) (cs-hat-right-perturbation smgr)))
(declare (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type chain-complex hat-t-u) (type chain-complex hat-t-u)
@ -152,248 +152,248 @@
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(with-cmbn (with-cmbn
(degr list) cmbn (degr list) cmbn
(make-cmbn (make-cmbn
:degr degr :degr degr
:list (mapcar :list (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc tnpr) term (cffc tnpr) term
(term cffc (gnrt1 (gnrt1 tnpr))))) (term cffc (gnrt1 (gnrt1 tnpr)))))
(member-if (member-if
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc tnpr) term (cffc tnpr) term
(declare (ignore cffc)) (declare (ignore cffc))
(with-tnpr (with-tnpr
(degr1 tnpr1 degr2 abar2) tnpr (degr1 tnpr1 degr2 abar2) tnpr
(declare (ignore degr1 abar2)) (declare (ignore degr1 abar2))
(and (zerop degr2) (zerop (degr2 tnpr1)))))) (and (zerop degr2) (zerop (degr2 tnpr1))))))
list)))))) list))))))
(DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-F (smgr (DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-F (smgr
&aux (hat-u-t (cs-hat-u-t smgr)) &aux (hat-u-t (cs-hat-u-t smgr))
(classifying-space (classifying-space smgr))) (classifying-space (classifying-space smgr)))
(declare (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type chain-complex hat-u-t) (type chain-complex hat-u-t)
(type simplicial-set classifying-space)) (type simplicial-set classifying-space))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc hat-u-t :sorc hat-u-t
:trgt classifying-space :trgt classifying-space
:degr 0 :degr 0
:intr #'cs-pre-left-hmeq-left-reduction-intr-f :intr #'cs-pre-left-hmeq-left-reduction-intr-f
:strt :cmbn :strt :cmbn
:orgn `(cs-pre-left-hmeq-left-reduction-f ,smgr)))) :orgn `(cs-pre-left-hmeq-left-reduction-f ,smgr))))
(DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-INTR-G (idnt) (DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-INTR-G (idnt)
(declare (type gmsm idnt)) (declare (type gmsm idnt))
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(with-cmbn (with-cmbn
(degr list) cmbn (degr list) cmbn
(make-cmbn (make-cmbn
:degr degr :degr degr
:list (mapcar :list (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc gbar) term (cffc gbar) term
(term cffc (term cffc
(tnpr degr (tnpr degr
(tnpr degr gbar 0 idnt) (tnpr degr gbar 0 idnt)
0 +null-abar+)))) 0 +null-abar+))))
list)))))) list))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
(DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-G (smgr (DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-G (smgr
&aux (hat-u-t (cs-hat-u-t smgr)) &aux (hat-u-t (cs-hat-u-t smgr))
(classifying-space (classifying-space
(classifying-space smgr))) (classifying-space smgr)))
(declare (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type chain-complex hat-u-t) (type chain-complex hat-u-t)
(type simplicial-set classifying-space)) (type simplicial-set classifying-space))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc classifying-space :sorc classifying-space
:trgt hat-u-t :trgt hat-u-t
:degr 0 :degr 0
:intr (cs-pre-left-hmeq-left-reduction-intr-g (bspn smgr)) :intr (cs-pre-left-hmeq-left-reduction-intr-g (bspn smgr))
:strt :cmbn :strt :cmbn
:orgn `(cs-pre-left-hmeq-left-reduction-g ,smgr)))) :orgn `(cs-pre-left-hmeq-left-reduction-g ,smgr))))
(DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-INTR-H (cmpr idnt) (DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-INTR-H (cmpr idnt)
(declare (type gmsm idnt)) (declare (type gmsm idnt))
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(with-cmbn (with-cmbn
(degr list) cmbn (degr list) cmbn
(do ((rslt (zero-cmbn (1+ degr))) (do ((rslt (zero-cmbn (1+ degr)))
(mark list (cdr mark))) (mark list (cdr mark)))
((endp mark) rslt) ((endp mark) rslt)
(declare (declare
(type cmbn rslt) (type cmbn rslt)
(list mark)) (list mark))
(let ((term (car mark))) (let ((term (car mark)))
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc tnpr) term (cffc tnpr) term
(with-tnpr (with-tnpr
(degr1 tnpr1 degr2 abar2) tnpr (degr1 tnpr1 degr2 abar2) tnpr
(declare (ignore degr1)) (declare (ignore degr1))
(with-tnpr (with-tnpr
(degr11 gbar11 degr12 gmsm12) tnpr1 (degr11 gbar11 degr12 gmsm12) tnpr1
(unless (zerop degr12) (unless (zerop degr12)
(dstr-add-term-to-cmbn (dstr-add-term-to-cmbn
cmpr cmpr
(if (evenp degr11) cffc (- cffc)) (if (evenp degr11) cffc (- cffc))
(tnpr degr11 (tnpr degr11
(tnpr degr11 gbar11 0 idnt) (tnpr degr11 gbar11 0 idnt)
(+ 1 degr12 degr2) (+ 1 degr12 degr2)
(make-abar (make-abar
:list :list
(cons (brgn (1+ degr12) (cons (brgn (1+ degr12)
gmsm12) gmsm12)
(abar-list abar2)))) (abar-list abar2))))
rslt))))))))))) rslt)))))))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
(DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-H (smgr (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 (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type chain-complex hat-u-t)) (type chain-complex hat-u-t))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc hat-u-t :sorc hat-u-t
:trgt hat-u-t :trgt hat-u-t
:degr +1 :degr +1
:intr (cs-pre-left-hmeq-left-reduction-intr-h (cmpr hat-u-t) :intr (cs-pre-left-hmeq-left-reduction-intr-h (cmpr hat-u-t)
(bspn smgr)) (bspn smgr))
:strt :cmbn :strt :cmbn
:orgn `(cs-pre-left-hmeq-left-reduction-h ,smgr)))) :orgn `(cs-pre-left-hmeq-left-reduction-h ,smgr))))
(DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION (smgr) (DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION (smgr)
(declare (type simplicial-group smgr)) (declare (type simplicial-group smgr))
(the reduction (the reduction
(build-rdct (build-rdct
:f (cs-pre-left-hmeq-left-reduction-f smgr) :f (cs-pre-left-hmeq-left-reduction-f smgr)
:g (cs-pre-left-hmeq-left-reduction-g smgr) :g (cs-pre-left-hmeq-left-reduction-g smgr)
:h (cs-pre-left-hmeq-left-reduction-h smgr) :h (cs-pre-left-hmeq-left-reduction-h smgr)
:orgn `(cs-pre-left-hmeq-left-reduction ,smgr)))) :orgn `(cs-pre-left-hmeq-left-reduction ,smgr))))
(DEFUN CS-LEFT-HMEQ-LEFT-REDUCTION (smgr (DEFUN CS-LEFT-HMEQ-LEFT-REDUCTION (smgr
&aux (pre-left-hmeq-left-reduction &aux (pre-left-hmeq-left-reduction
(cs-pre-left-hmeq-left-reduction (cs-pre-left-hmeq-left-reduction
smgr)) smgr))
(hat-left-perturbation (hat-left-perturbation
(cs-hat-left-perturbation smgr))) (cs-hat-left-perturbation smgr)))
(declare (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type reduction pre-left-hmeq-left-reduction) (type reduction pre-left-hmeq-left-reduction)
(type morphism hat-left-perturbation)) (type morphism hat-left-perturbation))
(the reduction (the reduction
(progn (progn
(dstr-change-sorc-trgt hat-left-perturbation (dstr-change-sorc-trgt hat-left-perturbation
:new-sorc (tcc pre-left-hmeq-left-reduction) :new-sorc (tcc pre-left-hmeq-left-reduction)
:new-trgt (tcc pre-left-hmeq-left-reduction)) :new-trgt (tcc pre-left-hmeq-left-reduction))
(let ((rslt (special-bpl-2 pre-left-hmeq-left-reduction (let ((rslt (special-bpl-2 pre-left-hmeq-left-reduction
hat-left-perturbation))) hat-left-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 (cs-left-hmeq-hat smgr) (setf tcc (cs-left-hmeq-hat smgr)
(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))))
(DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-F (cmbn) (DEFUN CS-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 ((rslt +empty-list+)) (let ((rslt +empty-list+))
(declare (list rslt)) (declare (list rslt))
(do ((mark list (cdr mark))) (do ((mark list (cdr mark)))
((endp mark)) ((endp mark))
(declare (list mark)) (declare (list mark))
(with--term (cffc tnpr) mark (with--term (cffc tnpr) mark
(with-tnpr (degr1 nil nil abar2) tnpr (with-tnpr (degr1 nil nil abar2) tnpr
(if (zerop degr1) (if (zerop degr1)
(push (term cffc abar2) rslt) (push (term cffc abar2) rslt)
(return))))) (return)))))
(make-cmbn :degr degr (make-cmbn :degr degr
:list (nreverse rslt)))))) :list (nreverse rslt))))))
(DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-F (smgr (DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-F (smgr
&aux (hat-t-u (cs-hat-t-u smgr)) &aux (hat-t-u (cs-hat-t-u smgr))
(bar (bar smgr))) (bar (bar smgr)))
(declare (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type chain-complex hat-t-u bar)) (type chain-complex hat-t-u bar))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc hat-t-u :trgt bar :degr 0 :sorc hat-t-u :trgt bar :degr 0
:intr #'cs-pre-left-hmeq-right-reduction-intr-f :intr #'cs-pre-left-hmeq-right-reduction-intr-f
:strt :cmbn :strt :cmbn
:orgn `(cs-pre-left-hmeq-right-reduction-f ,smgr)))) :orgn `(cs-pre-left-hmeq-right-reduction-f ,smgr))))
(DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-G (idnt) (DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-G (idnt)
(declare (type gmsm idnt)) (declare (type gmsm idnt))
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(with-cmbn (with-cmbn
(degr list) cmbn (degr list) cmbn
(let ((bsgn (tnpr 0 +null-gbar+ 0 idnt))) (let ((bsgn (tnpr 0 +null-gbar+ 0 idnt)))
(declare (type tnpr bsgn)) (declare (type tnpr bsgn))
(make-cmbn :degr degr (make-cmbn :degr degr
:list (mapcar :list (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc abar) term (cffc abar) term
(term cffc (term cffc
(tnpr 0 bsgn (tnpr 0 bsgn
degr abar)))) degr abar))))
list))))))) list)))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
(DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-G (smgr (DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-G (smgr
&aux (hat-t-u (cs-hat-t-u smgr)) &aux (hat-t-u (cs-hat-t-u smgr))
(bar (bar smgr)) (bar (bar smgr))
(idnt (bspn smgr))) (idnt (bspn smgr)))
(declare (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type chain-complex hat-t-u bar) (type chain-complex hat-t-u bar)
(type gmsm idnt)) (type gmsm idnt))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc bar :trgt hat-t-u :degr 0 :sorc bar :trgt hat-t-u :degr 0
:intr (cs-pre-left-hmeq-right-reduction-intr-g idnt) :intr (cs-pre-left-hmeq-right-reduction-intr-g idnt)
:strt :cmbn :strt :cmbn
:orgn `(cs-pre-left-hmeq-right-reduction-g ,smgr)))) :orgn `(cs-pre-left-hmeq-right-reduction-g ,smgr))))
(DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-H (smgr (DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-H (smgr
&aux (bar (bar smgr)) &aux (bar (bar smgr))
(tnpr-contraction (tnpr-contraction
(smgr-tnpr-contraction smgr))) (smgr-tnpr-contraction smgr)))
(declare (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type chain-complex bar) (type chain-complex bar)
@ -405,42 +405,42 @@
(declare (type simplicial-group smgr)) (declare (type simplicial-group smgr))
(the reduction (the reduction
(build-rdct (build-rdct
:f (cs-pre-left-hmeq-right-reduction-f smgr) :f (cs-pre-left-hmeq-right-reduction-f smgr)
:g (cs-pre-left-hmeq-right-reduction-g smgr) :g (cs-pre-left-hmeq-right-reduction-g smgr)
:h (cs-pre-left-hmeq-right-reduction-h smgr) :h (cs-pre-left-hmeq-right-reduction-h smgr)
:orgn `(cs-pre-left-hmeq-right-reduction ,smgr)))) :orgn `(cs-pre-left-hmeq-right-reduction ,smgr))))
(DEFUN CS-LEFT-HMEQ-RIGHT-REDUCTION (smgr (DEFUN CS-LEFT-HMEQ-RIGHT-REDUCTION (smgr
&aux (pre-reduction &aux (pre-reduction
(cs-pre-left-hmeq-right-reduction (cs-pre-left-hmeq-right-reduction
smgr)) smgr))
(perturbation (perturbation
(cs-hat-right-perturbation smgr))) (cs-hat-right-perturbation smgr)))
(declare (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type reduction pre-reduction) (type reduction pre-reduction)
(type morphism perturbation)) (type morphism perturbation))
(the reduction (the reduction
(progn (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-2 pre-reduction perturbation)))) (special-bpl-2 pre-reduction perturbation))))
(DEFUN CS-LEFT-HMEQ (smgr) (DEFUN CS-LEFT-HMEQ (smgr)
(declare (type simplicial-group smgr)) (declare (type simplicial-group smgr))
(the homotopy-equivalence (the homotopy-equivalence
(build-hmeq (build-hmeq
:lrdct (cs-left-hmeq-left-reduction smgr) :lrdct (cs-left-hmeq-left-reduction smgr)
:rrdct (cs-left-hmeq-right-reduction smgr) :rrdct (cs-left-hmeq-right-reduction smgr)
:orgn `(cs-left-hmeq ,smgr)))) :orgn `(cs-left-hmeq ,smgr))))
(DEFUN CLASSIFYING-SPACE-EFHM (smgr) (DEFUN CLASSIFYING-SPACE-EFHM (smgr)
(declare (type simplicial-group smgr)) (declare (type simplicial-group smgr))
(let ((left-hmeq (cs-left-hmeq 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)) (declare (type homotopy-equivalence left-hmeq right-hmeq))
(cmps left-hmeq right-hmeq))) (cmps left-hmeq right-hmeq)))

328
test/bar-test.lisp
View File

@ -11,127 +11,127 @@
(test bar-cmpr (test bar-cmpr
(let ((r (cat:bar-cmpr #'cat:s-cmpr))) (let ((r (cat:bar-cmpr #'cat:s-cmpr)))
(is (equal :equal (funcall r (cat:abar) (cat:abar)))) (is (equal :equal (funcall r (cat:abar) (cat:abar))))
(is (equal :greater (funcall r (cat:abar 3 'a) (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 2 'a 1 'b))))
(is (equal :less (funcall r (cat:abar 3 'a) (cat:abar 3 '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 3 'a) (cat:abar 3 'a))))))
(test bar-basis-length (test bar-basis-length
(let ((basis #'(lambda (degr) (list degr)))) (let ((basis #'(lambda (degr) (list degr))))
(cat:bar-basis-length basis 2 1) (cat:bar-basis-length basis 2 1)
(cat:bar-basis-length basis 2 2) (cat:bar-basis-length basis 2 2)
(cat:bar-basis-length basis 3 1) (cat:bar-basis-length basis 3 1)
(cat:bar-basis-length basis 3 2) (cat:bar-basis-length basis 3 2)
(cat:bar-basis-length basis 4 1) (cat:bar-basis-length basis 4 1)
(cat:bar-basis-length basis 4 2) (cat:bar-basis-length basis 4 2)
(cat:bar-basis-length basis 4 3) (cat:bar-basis-length basis 4 3)
(cat:bar-basis-length basis 4 4) (cat:bar-basis-length basis 4 4)
(cat:bar-basis-length basis 8 1) (cat:bar-basis-length basis 8 1)
(cat:bar-basis-length basis 8 2) (cat:bar-basis-length basis 8 2)
(cat:bar-basis-length basis 8 3) (cat:bar-basis-length basis 8 3)
(cat:bar-basis-length basis 8 4) (cat:bar-basis-length basis 8 4)
(cat:bar-basis-length basis 8 5) (cat:bar-basis-length basis 8 5)
(cat:bar-basis-length basis 8 6) (cat:bar-basis-length basis 8 6)
(cat:bar-basis-length basis 8 11))) (cat:bar-basis-length basis 8 11)))
(test bar-basis (test bar-basis
(let* ((basis #'(lambda (degr) (list degr))) (let* ((basis #'(lambda (degr) (list degr)))
(r (cat:bar-basis basis))) (r (cat:bar-basis basis)))
(funcall r 0) (funcall r 0)
(funcall r 1) (funcall r 1)
(funcall r 2) (funcall r 2)
(dotimes (i 7) (dotimes (i 7)
(print (funcall r i))) (print (funcall r i)))
(cat:bar-basis :locally-effective))) (cat:bar-basis :locally-effective)))
(test bar-intr-vrtc-dffr (test bar-intr-vrtc-dffr
(let* ((d (cat:soft-delta-infinity)) (let* ((d (cat:soft-delta-infinity))
(r (cat:bar-intr-vrtc-dffr (cat:dffr d)))) (r (cat:bar-intr-vrtc-dffr (cat:dffr d))))
(funcall r 0 (cat:abar)) (funcall r 0 (cat:abar))
(funcall r 3 (cat:abar 3 (cat:d 7))) (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 3 (cat:d 7) 2 (cat:d 3)))
(funcall r 5 (cat:abar 2 (cat:d 3) 3 (cat:d 7))))) (funcall r 5 (cat:abar 2 (cat:d 3) 3 (cat:d 7)))))
(defun random-abar1 (length) (defun random-abar1 (length)
(let ((rslt nil)) (let ((rslt nil))
(dotimes (i length) (dotimes (i length)
(let* ((gmsm (random (cat:mask 7))) (let* ((gmsm (random (cat:mask 7)))
(dmns (1- (logcount gmsm)))) (dmns (1- (logcount gmsm))))
(when (plusp dmns) (when (plusp dmns)
(push (cat:brgn (1+ dmns) (cat:d gmsm)) rslt)))) (push (cat:brgn (1+ dmns) (cat:d gmsm)) rslt))))
(cat:make-abar :list rslt))) (cat:make-abar :list rslt)))
(test vrtc-bar (test vrtc-bar
(progn (progn
(cat:cat-init) (cat:cat-init)
(let ((v (cat:vrtc-bar (cat:soft-delta-infinity)))) (let ((v (cat:vrtc-bar (cat:soft-delta-infinity))))
(dotimes (i 10) (dotimes (i 10)
(print (random-abar1 5))) (print (random-abar1 5)))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar1 3))) (let ((abar (random-abar1 3)))
(print abar) (print abar)
(print (cat:? v (apply #'+ (mapcar #'car (cat:abar-list abar))) (print (cat:? v (apply #'+ (mapcar #'car (cat:abar-list abar)))
abar)) abar))
(print (cat:? v (cat:? v (apply #'+ (mapcar #'car (print (cat:? v (cat:? v (apply #'+ (mapcar #'car
(cat:abar-list abar))) (cat:abar-list abar)))
abar)))))))) abar))))))))
(test bar-intr-hrzn-dffr (test bar-intr-hrzn-dffr
(let* ((k (cat:k-z-1)) (let* ((k (cat:k-z-1))
(r (cat:bar-intr-hrzn-dffr (cat:aprd k)))) (r (cat:bar-intr-hrzn-dffr (cat:aprd k))))
(funcall r 0 (cat:abar )) (funcall r 0 (cat:abar ))
(funcall r 3 (cat:abar 3 '(2 3))) (funcall r 3 (cat:abar 3 '(2 3)))
(funcall r 6 (cat:abar 3 '(2 3) 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 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))))) (funcall r 11 (cat:abar 3 '(2 3) 3 '(-2 -3) 2 '(-2) 3 '(-2 -3)))))
#| #|
(test bar-hrzn-dffr (test bar-hrzn-dffr
(progn (progn
(cat:cat-init) (cat:cat-init)
(let ((h (cat:bar-hrzn-dffr (cat:k-z-1))) (let ((h (cat:bar-hrzn-dffr (cat:k-z-1)))
(abar)) (abar))
(dotimes (i 10) (dotimes (i 10)
(print (random-abar 10 5))) (print (random-abar 10 5)))
(setf abar (random-abar 10 5)) (setf abar (random-abar 10 5))
(cat:? h (apply #'+ (mapcar #'car (cat:abar-list abar))) abar) (cat:? h (apply #'+ (mapcar #'car (cat:abar-list abar))) abar)
(cat:? h (cat:? h (apply #'+ (mapcar #'car (cat:? h (cat:? h (apply #'+ (mapcar #'car
(cat:abar-list abar))) abar)) (cat:abar-list abar))) abar))
(dotimes (i 10) (dotimes (i 10)
(setf abar (random-abar 10 3)) (setf abar (random-abar 10 3))
(print abar) (print abar)
(print (cat:? h (apply #'+ (mapcar #'car (cat:abar-list abar))) (print (cat:? h (apply #'+ (mapcar #'car (cat:abar-list abar)))
abar)) abar))
(print (cat:? h (cat:? h (apply #'+ (mapcar #'car (print (cat:? h (cat:? h (apply #'+ (mapcar #'car
(cat:abar-list abar))) (cat:abar-list abar)))
abar))))))) abar)))))))
|# |#
(test bar (test bar
(progn (progn
(cat:cat-init) (cat:cat-init)
(let ((b (cat:bar (cat:k-z-1))) (let ((b (cat:bar (cat:k-z-1)))
(abar (random-abar 10 3))) (abar (random-abar 10 3)))
(cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar))) abar) (cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar))) abar)
(cat:? b (cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar))) (cat:? b (cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar)))
abar)) abar))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 10 3))) (let ((abar (random-abar 10 3)))
(print abar) (print abar)
(print (cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar))) (print (cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar)))
abar)) abar))
(print (cat:? b (print (cat:? b
(cat:? b (cat:? b
(apply #'+ (mapcar #'car (apply #'+ (mapcar #'car
(cat:abar-list abar))) (cat:abar-list abar)))
abar)))))))) abar))))))))
(test ncmbn-bar (test ncmbn-bar
@ -139,103 +139,103 @@
(cat:ncmbn-bar (list (cat:cmbn 3 2 'a 3 'b))) (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 2 4 'c 5 'd)))
(cat:ncmbn-bar (list (cat:cmbn 1 2 'a 3 'b) (cat:cmbn 1 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 (test mrph-vrtc-bar-intr
(let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr (let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr
:basis :locally-effective :basis :locally-effective
:intr-dffr #'cat:zero-mrph :intr-dffr #'cat:zero-mrph
:strt :cmbn)) :strt :cmbn))
(m (cat:build-mrph :sorc cc :trgt cc :degr 0 :intr (m (cat:build-mrph :sorc cc :trgt cc :degr 0 :intr
#'(lambda (degr gnrt) #'(lambda (degr gnrt)
(cat:cmbn degr 2 gnrt 3 (1+ gnrt))) (cat:cmbn degr 2 gnrt 3 (1+ gnrt)))
:strt :gnrt :orgn '(test))) :strt :gnrt :orgn '(test)))
(r (cat:mrph-vrtc-bar-intr m))) (r (cat:mrph-vrtc-bar-intr m)))
(funcall r 4 (cat:abar 2 3 2 4)))) (funcall r 4 (cat:abar 2 3 2 4))))
(test vrtc-bar (test vrtc-bar
(progn (progn
(cat:cat-init) (cat:cat-init)
(let* ((f (cat:aw (cat:soft-delta-infinity) (let* ((f (cat:aw (cat:soft-delta-infinity)
(cat:soft-delta-infinity))) (cat:soft-delta-infinity)))
(cf (cat:vrtc-bar f))) (cf (cat:vrtc-bar f)))
(cat:? cf 6 (cat:abar 3 (cat:crpr 0 (cat:d 7) 0 (cat:d 7)) 3 (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:crpr 0 (cat:d 56) 0 (cat:d 56)))))))
(test hmtp-vrtc-bar-intr (test hmtp-vrtc-bar-intr
(progn (progn
(cat:cat-init) (cat:cat-init)
(let* ((ez (cat:ez (cat:delta-infinity) (cat:delta-infinity))) (let* ((ez (cat:ez (cat:delta-infinity) (cat:delta-infinity)))
(h (cat:h ez)) (h (cat:h ez))
(gf (cat:cmps (cat:g ez) (cat:f ez))) (gf (cat:cmps (cat:g ez) (cat:f ez)))
(r (cat:hmtp-vrtc-bar-intr h gf))) (r (cat:hmtp-vrtc-bar-intr h gf)))
(funcall r 3 (cat:abar 3 (cat:crpr 0 7 0 7))) (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) (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)))))) 3 (cat:crpr 0 14 0 14))))))
#| #|
(test vrtc-bar1 (test vrtc-bar1
(progn (progn
(cat:cat-init) (cat:cat-init)
(let* ((tcc (cat:build-chcm (let* ((tcc (cat:build-chcm
:cmpr #'cat:s-cmpr :cmpr #'cat:s-cmpr
:basis #'(lambda (degr) '(a b c d)) :basis #'(lambda (degr) '(a b c d))
:bsgn 'd :bsgn 'd
:intr-dffr #'(lambda (degr gnrt) :intr-dffr #'(lambda (degr gnrt)
(ecase gnrt (ecase gnrt
(a (cat:cmbn (1- degr) 1 'b 1 'd)) (a (cat:cmbn (1- degr) 1 'b 1 'd))
((b d) (cat:cmbn (1- degr))) ((b d) (cat:cmbn (1- degr)))
(c (cat:cmbn (1- degr) 1 'd)))) (c (cat:cmbn (1- degr) 1 'd))))
:strt :gnrt :strt :gnrt
:orgn '(tcc))) :orgn '(tcc)))
(bcc (cat:build-chcm (bcc (cat:build-chcm
:cmpr #'cat:s-cmpr :cmpr #'cat:s-cmpr
:basis #'(lambda (degr) '(c d)) :basis #'(lambda (degr) '(c d))
:bsgn 'd :bsgn 'd
:intr-dffr #'(lambda (degr gnrt) :intr-dffr #'(lambda (degr gnrt)
(ecase gnrt (ecase gnrt
(d (cat:cmbn (1- degr))) (d (cat:cmbn (1- degr)))
(c (cat:cmbn (1- degr) 1 'd)))) (c (cat:cmbn (1- degr) 1 'd))))
:strt :gnrt :strt :gnrt
:orgn '(bcc))) :orgn '(bcc)))
(f (cat:build-mrph :sorc tcc :trgt bcc :degr 0 (f (cat:build-mrph :sorc tcc :trgt bcc :degr 0
:intr #'(lambda (degr gnrt) :intr #'(lambda (degr gnrt)
(ecase gnrt (ecase gnrt
(a (cat:cmbn degr 1 'c 1 'd)) (a (cat:cmbn degr 1 'c 1 'd))
(b (cat:cmbn degr)) (b (cat:cmbn degr))
((c d) (cat:cmbn degr 1 gnrt)))) ((c d) (cat:cmbn degr 1 gnrt))))
:strt :gnrt :orgn '(f))) :strt :gnrt :orgn '(f)))
(g (cat:build-mrph :sorc bcc :trgt tcc :degr 0 (g (cat:build-mrph :sorc bcc :trgt tcc :degr 0
:intr #'identity :strt :cmbn :orgn '(g))) :intr #'identity :strt :cmbn :orgn '(g)))
(h (cat:build-mrph :sorc tcc :trgt tcc :degr +1 (h (cat:build-mrph :sorc tcc :trgt tcc :degr +1
:intr #'(lambda (degr gnrt) :intr #'(lambda (degr gnrt)
(ecase gnrt (ecase gnrt
((a b) (cat:cmbn ((a b) (cat:cmbn
(1+ degr) (1+ degr)
1 'a -1 'b -1 'c -1 'd)) 1 'a -1 'b -1 'c -1 'd))
((c d) (cat:cmbn (1+ degr))))) ((c d) (cat:cmbn (1+ degr)))))
:strt :gnrt :orgn '(h))) :strt :gnrt :orgn '(h)))
(rdct (cat:build-rdct :f f :g g :h h :orgn '(rdct))) (rdct (cat:build-rdct :f f :g g :h h :orgn '(rdct)))
(bar)) (bar))
(cat:tcc rdct 3 'a) (cat:tcc rdct 3 'a)
(cat:g rdct (cat:f rdct 3 'a)) (cat:g rdct (cat:f rdct 3 'a))
(cat:h rdct 3 'a) (cat:h rdct 3 'a)
(setf bar (cat:vrtc-bar rdct)) (setf bar (cat:vrtc-bar rdct))
(cat:pre-check-rdct bar) (cat:pre-check-rdct bar)
(aleat-tc) (aleat-tc)
(aleat-bc) (aleat-bc)
;;(loop (c)) ;;(loop (c))
(dotimes (i 10) (c))))) ;; degrees >= 15 is possible => error. (dotimes (i 10) (c))))) ;; degrees >= 15 is possible => error.
|# |#
(test homology (test homology
(progn (progn
(cat:cat-init) (cat:cat-init)
(let* ((h (cat:efhm (cat:k-z-1))) (let* ((h (cat:efhm (cat:k-z-1)))
(b (cat:bar h))) (b (cat:bar h)))
(cat:homology (cat:rbcc b) 0 11)))) (cat:homology (cat:rbcc b) 0 11))))

738
test/cl-space-efhm-test.lisp
View File

@ -1,456 +1,382 @@
(in-package :kenzo-test) (in-package :kenzo-test)
(in-suite :kenzo) (in-suite :kenzo)
#|
(test cs-hat-u-t (test cs-hat-u-t
(cat:cat-init) (cat:cat-init)
(let* ((c (cat:cs-hat-u-t (cat:k-z-1))) (let ((c (cat:cs-hat-u-t (cat:k-z-1)))
(abar (random-abar 8 4)) abar-degr
(abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) gnrt)
(gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) 0 '()) (dotimes (i 10)
2 '(4 5)) (let ((abar (random-abar 8 4)))
abar-degr abar))) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(cat:? c (+ 5 abar-degr) gnrt) (setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr) gnrt)))) 0 '()) 2 '(4 5))
(dotimes (i 10) abar-degr abar))
(let ((abar (random-abar 8 4))) (unless (>= abar-degr 10)
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (print (cat:? c (+ 5 abar-degr) gnrt))
(setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) (is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
0 '()) 2 '(4 5)) gnrt)))))))
abar-degr abar)) (dotimes (i 10)
(unless (>= abar-degr 10) (let ((abar (random-abar 8 4)))
(print (cat:? c (+ 5 abar-degr) gnrt)) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr) (setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
gnrt))))))) 0 '()) 3 '(4 5 6))
(dotimes (i 10) abar-degr abar))
(let ((abar (random-abar 8 4))) (unless (>= abar-degr 9)
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (print (cat:? c (+ 6 abar-degr) gnrt))
(setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) (is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 6 abar-degr)
0 '()) 3 '(4 5 6)) gnrt)))))))
abar-degr abar)) (dotimes (i 10)
(unless (>= abar-degr 9) (let ((abar (random-abar 8 4)))
(print (cat:? c (+ 6 abar-degr) gnrt)) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 6 abar-degr) (setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
gnrt))))))) 3 '(4 5 6)) abar-degr abar))
(dotimes (i 10) (unless (>= abar-degr 10)
(let ((abar (random-abar 8 4))) (print (cat:? c (+ 5 abar-degr) gnrt))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '()) gnrt)))))))
3 '(4 5 6)) abar-degr abar)) (dotimes (i 10)
(unless (>= abar-degr 10) (let ((abar (random-abar 8 4)))
(print (cat:? c (+ 5 abar-degr) gnrt)) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr) (setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
gnrt))))))) 2 '(4 5))
(dotimes (i 10) abar-degr abar))
(let ((abar (random-abar 8 4))) (unless (>= abar-degr 11)
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (print (cat:? c (+ 4 abar-degr) gnrt))
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '()) (is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 4 abar-degr)
2 '(4 5)) gnrt)))))))))
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 (test cs-hat-t-u
(cat:cat-init) (cat:cat-init)
(dotimes (i 5) (print (random-abar 8 4))) (dotimes (i 5) (print (random-abar 8 4)))
(let* ((c (cat:cs-hat-t-u (cat:k-z-1))) (let ((c (cat:cs-hat-t-u (cat:k-z-1)))
(abar (random-abar 8 4)) abar-degr
(abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) gnrt)
(gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) 0 '()) (dotimes (i 10)
2 '(4 5)) (let ((abar (random-abar 8 4)))
abar-degr abar))) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(cat:? c (+ 5 abar-degr) gnrt) (setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr) gnrt)))) 0 '()) 2 '(4 5))
(dotimes (i 10) abar-degr abar))
(let ((abar (random-abar 8 4))) (unless (>= abar-degr 10)
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (print (cat:? c (+ 5 abar-degr) gnrt))
(setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) (is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
0 '()) 2 '(4 5)) gnrt)))))))
abar-degr abar)) (dotimes (i 10)
(unless (>= abar-degr 10) (let ((abar (random-abar 8 4)))
(print (cat:? c (+ 5 abar-degr) gnrt)) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr) (setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
gnrt))))))) 0 '()) 3 '(4 5 6))
(dotimes (i 10) abar-degr abar))
(let ((abar (random-abar 8 4))) (unless (>= abar-degr 9)
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (print (cat:? c (+ 6 abar-degr) gnrt))
(setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) (is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 6 abar-degr)
0 '()) 3 '(4 5 6)) gnrt)))))))
abar-degr abar)) (dotimes (i 10)
(unless (>= abar-degr 9) (let ((abar (random-abar 8 4)))
(print (cat:? c (+ 6 abar-degr) gnrt)) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 6 abar-degr) (setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
gnrt))))))) 3 '(4 5 6))
(dotimes (i 10) abar-degr abar))
(let ((abar (random-abar 8 4))) (unless (>= abar-degr 10)
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (print (cat:? c (+ 5 abar-degr) gnrt))
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '()) (is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
3 '(4 5 6)) gnrt)))))))
abar-degr abar)) (dotimes (i 10)
(unless (>= abar-degr 10) (let ((abar (random-abar 8 4)))
(print (cat:? c (+ 5 abar-degr) gnrt)) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr) (setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
gnrt))))))) 2 '(4 5))
(dotimes (i 10) abar-degr abar))
(let ((abar (random-abar 8 4))) (unless (>= abar-degr 11)
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (print (cat:? c (+ 4 abar-degr) gnrt))
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '()) (is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 4 abar-degr)
2 '(4 5)) gnrt)))))))))
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 (test cs-left-hmeq-hat
(cat:cat-init) (cat:cat-init)
(let ((c (cat:cs-left-hmeq-hat (cat:k-z-1))) (let ((c (cat:cs-left-hmeq-hat (cat:k-z-1)))
abar-degr abar-degr
gnrt) gnrt)
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 8 4))) (let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (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) (setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
0 '()) 2 '(4 5)) 0 '()) 2 '(4 5))
abar-degr abar)) abar-degr abar))
(unless (>= abar-degr 10) (unless (>= abar-degr 10)
(print (cat:? c (+ 5 abar-degr) gnrt)) (print (cat:? c (+ 5 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr) (is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
gnrt))))))) gnrt)))))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 8 4))) (let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (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) (setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
0 '()) 3 '(4 5 6)) 0 '()) 3 '(4 5 6))
abar-degr abar)) abar-degr abar))
(unless (>= abar-degr 9) (unless (>= abar-degr 9)
(print (cat:? c (+ 6 abar-degr) gnrt)) (print (cat:? c (+ 6 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 6 abar-degr) (is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 6 abar-degr)
gnrt))))))) gnrt)))))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 8 4))) (let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '()) (setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
3 '(4 5 6)) 3 '(4 5 6))
abar-degr abar)) abar-degr abar))
(unless (>= abar-degr 10) (unless (>= abar-degr 10)
(print (cat:? c (+ 5 abar-degr) gnrt)) (print (cat:? c (+ 5 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr) (is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 5 abar-degr)
gnrt))))))) gnrt)))))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 8 4))) (let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '()) (setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
2 '(4 5)) 2 '(4 5))
abar-degr abar)) abar-degr abar))
(unless (>= abar-degr 11) (unless (>= abar-degr 11)
(print (cat:? c (+ 4 abar-degr) gnrt)) (print (cat:? c (+ 4 abar-degr) gnrt))
(is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 4 abar-degr) (is (cat:cmbn-zero-p (cat:? c (cat:? c (+ 4 abar-degr)
gnrt))))))))) 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 (test cs-pre-left-hmeq-left-reduction
(cat:cat-init) (cat:cat-init)
(let ((rdct (cat:cs-pre-left-hmeq-left-reduction (cat:k-z-1))) (let ((rdct (cat:cs-pre-left-hmeq-left-reduction (cat:k-z-1)))
abar-degr abar-degr
gnrt gnrt
gbar) gbar)
(cat:pre-check-rdct rdct) (cat:pre-check-rdct rdct)
(setf cat:*tc* (cat:cmbn 0 1 (dotimes (i 10)
(cat:tnpr 0 (cat:tnpr 0 (let ((abar (random-abar 8 4)))
cat:+null-gbar+ 0 '()) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
0 cat:+null-abar+)) (setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
cat:*bc* (cat:cmbn 0 1 cat:+null-gbar+)) 0 '()) 2 '(4 5))
(check-rdct) abar-degr abar))
(setf cat:*tc* (cat:cmbn 1 1 (setf gbar (cat:gbar 2 0 '(1) 0 '()))
(cat:tnpr 1 (cat:tnpr 0 (unless (>= abar-degr 9)
cat:+null-gbar+ 1 '(13)) (setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt)
0 cat:+null-abar+))) cat:*bc* (cat:cmbn 2 1 gbar))
(check-rdct) (check-rdct))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 8 4))) (let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (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) (setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
0 '()) 2 '(4 5)) 0 '()) 3 '(4 5 6))
abar-degr abar)) abar-degr abar))
(setf gbar (cat:gbar 2 0 '(1) 0 '())) (setf gbar (cat:gbar 3 0 '(1 2) 1 '() 0 '()))
(unless (>= abar-degr 9) (unless (>= abar-degr 8)
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt) (setf cat:*tc* (cat:cmbn (+ 6 abar-degr) 1 gnrt)
cat:*bc* (cat:cmbn 2 1 gbar)) cat:*bc* (cat:cmbn 3 1 gbar))
(check-rdct)))) (check-rdct))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 6 4))) (let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (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) (setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
0 '()) 3 '(4 5 6)) 3 '(4 5 6))
abar-degr abar)) abar-degr abar))
(setf gbar (cat:gbar 3 0 '(1 2) 1 '() 0 '())) (setf gbar (cat:gbar 4 0 '(1 2 3) 0 '(4 5) 0 '(6) 0 '()))
(unless (>= abar-degr 8) (unless (>= abar-degr 9)
(setf cat:*tc* (cat:cmbn (+ 6 abar-degr) 1 gnrt) (setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt))
cat:*bc* (cat:cmbn 3 1 gbar)) (setf cat:*bc* (cat:cmbn 4 1 gbar))
(check-rdct)))) (check-rdct))))
(dotimes (i 10) (dotimes (i 10)
(let ((abar (random-abar 6 4))) (let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '()) (setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
3 '(4 5 6)) 2 '(4 5))
abar-degr abar)) abar-degr abar))
(setf gbar (cat:gbar 4 0 '(1 2 3) 0 '(4 5) 0 '(6) 0 '())) (setf gbar (cat:gbar 5 8 '(1 2 3) 0 '(4 5 6) 0 '(7 8) 0 '(9)
(unless (>= abar-degr 9) 0 '()))
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt)) (unless (>= abar-degr 10)
(setf cat:*bc* (cat:cmbn 4 1 gbar)) (setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt))
(check-rdct)))) (setf cat:*bc* (cat:cmbn 5 1 gbar))
(dotimes (i 10) (check-rdct))))))
(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 (test cs-left-hmeq-left-reduction
(cat:cat-init) (cat:cat-init)
(let ((rdct (cat:cs-left-hmeq-left-reduction (cat:k-z-1))) (let ((rdct (cat:cs-left-hmeq-left-reduction (cat:k-z-1)))
abar-degr gnrt gbar) abar-degr
(cat:pre-check-rdct rdct) gnrt
(setf cat:*tc* (cat:cmbn 0 1 (cat:tnpr 0 gbar)
(cat:tnpr 0 cat:+null-gbar+ (cat:pre-check-rdct rdct)
0 '()) 0 (dotimes (i 10)
cat:+null-abar+)) (let ((abar (random-abar 8 4)))
cat:*bc* (cat:cmbn 0 1 cat:+null-gbar+)) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(check-rdct) (setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
(setf cat:*tc* (cat:cmbn 1 1 (cat:tnpr 1 0 '()) 2 '(4 5))
(cat:tnpr 0 cat:+null-gbar+ abar-degr abar))
1 '(13)) 0 (setf gbar (cat:gbar 2 0 '(1) 0 '()))
cat:+null-abar+))) (unless (>= abar-degr 9)
(check-rdct) (setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt)
(dotimes (i 10) cat:*bc* (cat:cmbn 2 1 gbar))
(let ((abar (random-abar 8 4))) (check-rdct))))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (dotimes (i 10)
(setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) (let ((abar (random-abar 6 4)))
0 '()) 2 '(4 5)) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
abar-degr abar)) (setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
(setf gbar (cat:gbar 2 0 '(1) 0 '())) 0 '()) 3 '(4 5 6))
(unless (>= abar-degr 9) abar-degr abar))
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt) (setf gbar (cat:gbar 3 0 '(1 2) 1 '() 0 '()))
cat:*bc* (cat:cmbn 2 1 gbar)) (unless (>= abar-degr 8)
(check-rdct)))) (setf cat:*tc* (cat:cmbn (+ 6 abar-degr) 1 gnrt)
(dotimes (i 10) cat:*bc* (cat:cmbn 3 1 gbar))
(let ((abar (random-abar 6 4))) (check-rdct))))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (dotimes (i 10)
(setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) (let ((abar (random-abar 6 4)))
0 '()) 3 '(4 5 6)) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
abar-degr abar)) (setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
(setf gbar (cat:gbar 3 0 '(1 2) 1 '() 0 '())) 3 '(4 5 6))
(unless (>= abar-degr 8) abar-degr abar))
(setf cat:*tc* (cat:cmbn (+ 6 abar-degr) 1 gnrt) (setf gbar (cat:gbar 4 0 '(1 2 3) 0 '(4 5) 0 '(6) 0 '()))
cat:*bc* (cat:cmbn 3 1 gbar)) (unless (>= abar-degr 9)
(check-rdct)))) (setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt))
(dotimes (i 10) (setf cat:*bc* (cat:cmbn 4 1 gbar))
(let ((abar (random-abar 6 4))) (check-rdct))))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (dotimes (i 10)
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '()) (let ((abar (random-abar 6 4)))
3 '(4 5 6)) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
abar-degr abar)) (setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
(setf gbar (cat:gbar 4 0 '(1 2 3) 0 '(4 5) 0 '(6) 0 '())) 2 '(4 5))
(unless (>= abar-degr 9) abar-degr abar))
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt)) (setf gbar (cat:gbar 5 8 '(1 2 3) 0 '(4 5 6) 0 '(7 8) 0 '(9)
(setf cat:*bc* (cat:cmbn 4 1 gbar)) 0 '()))
(check-rdct)))) (unless (>= abar-degr 10)
(dotimes (i 10) (setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt))
(let ((abar (random-abar 6 4))) (setf cat:*bc* (cat:cmbn 5 1 gbar))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (check-rdct))))))
(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 (test cs-pre-left-hmeq-right-reduction-intr-f
(cat: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) (cat:cmbn 4 2 (cat:tnpr 0 (cat:tnpr 0 cat:+null-gbar+ 0 'i)
4 (cat:abar 2 'a 2 'b)) 4 (cat:abar 2 'a 2 'b))
3 (cat:tnpr 0 (cat:tnpr 0 cat:+null-gbar+ 0 'i) 3 (cat:tnpr 0 (cat:tnpr 0 cat:+null-gbar+ 0 'i)
4 (cat:abar 2 'a 2 'c)) 4 (cat:abar 2 'a 2 'c))
5 (cat:tnpr 1 (cat:tnpr 0 cat:+null-gbar+ 1 'a) 5 (cat:tnpr 1 (cat:tnpr 0 cat:+null-gbar+ 1 'a)
3 (cat:abar 1 'a 2 'b))))) 3 (cat:abar 1 'a 2 'b)))))
(test cs-pre-left-hmeq-right-reduction-g (test cs-pre-left-hmeq-right-reduction-g
(let ((g (cat:cs-pre-left-hmeq-right-reduction-intr-g 'i))) (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 (test cs-pre-left-hmeq-right-reduction
(cat:cat-init) (cat:cat-init)
(let ((rdct (cat:cs-pre-left-hmeq-right-reduction (cat:k-z-1))) (let ((rdct (cat:cs-pre-left-hmeq-right-reduction (cat:k-z-1)))
abar-degr abar-degr
gnrt) gnrt)
(cat:pre-check-rdct rdct) (cat:pre-check-rdct rdct)
(setf cat:*tc* (cat:cmbn 0 1 (cat:tnpr 0 (dotimes (i 10)
(cat:tnpr 0 cat:+null-gbar+ (let ((abar (random-abar 8 4)))
0 '()) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
0 cat:+null-abar+)) (setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3)
cat:*bc* (cat:cmbn 0 1 cat:+null-abar+)) 0 '()) 2 '(4 5))
(check-rdct) abar-degr abar))
(setf cat:*tc* (cat:cmbn 1 1 (cat:tnpr 1 (unless (>= abar-degr 9)
(cat:tnpr 0 cat:+null-gbar+ (setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt)
1 '(13)) cat:*bc* (cat:cmbn abar-degr 1 abar))
0 cat:+null-abar+))) (check-rdct))))
(check-rdct) (dotimes (i 10)
(dotimes (i 10) (let ((abar (random-abar 6 4)))
(let ((abar (random-abar 8 4))) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(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)
(setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6))
0 '()) 2 '(4 5)) abar-degr abar))
abar-degr abar)) (unless (>= abar-degr 8)
(unless (>= abar-degr 9) (setf cat:*tc* (cat:cmbn (+ 6 abar-degr) 1 gnrt)
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt) cat:*bc* (cat:cmbn abar-degr 1 abar))
cat:*bc* (cat:cmbn abar-degr 1 abar)) (check-rdct))))
(check-rdct)))) (dotimes (i 10)
(dotimes (i 10) (let ((abar (random-abar 6 4)))
(let ((abar (random-abar 6 4))) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
(setf gnrt (cat:tnpr 6 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 0 '(3) 3 '(4 5 6))
0 '()) 3 '(4 5 6)) abar-degr abar))
abar-degr abar)) (unless (>= abar-degr 9)
(unless (>= abar-degr 8) (setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt))
(setf cat:*tc* (cat:cmbn (+ 6 abar-degr) 1 gnrt) (setf cat:*bc* (cat:cmbn abar-degr 1 abar))
cat:*bc* (cat:cmbn abar-degr 1 abar)) (check-rdct))))
(check-rdct)))) (dotimes (i 10)
(dotimes (i 10) (let ((abar (random-abar 6 4)))
(let ((abar (random-abar 6 4))) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
(setf gnrt (cat:tnpr 5 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '()) 2 '(4 5))
3 '(4 5 6)) abar-degr abar))
abar-degr abar)) (unless (>= abar-degr 10)
(unless (>= abar-degr 9) (setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt))
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt)) (setf cat:*bc* (cat:cmbn abar-degr 1 abar))
(setf cat:*bc* (cat:cmbn abar-degr 1 abar)) (check-rdct))))))
(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 (test cs-left-hmeq-right-reduction
(cat:cat-init) (cat:cat-init)
(let ((rdct (cat:cs-left-hmeq-right-reduction (cat:k-z-1))) (let ((rdct (cat:cs-left-hmeq-right-reduction (cat:k-z-1)))
abar-degr abar-degr
gnrt) gnrt)
(cat:pre-check-rdct rdct) (cat:pre-check-rdct rdct)
(setf cat:*tc* (cat:cmbn 0 1 (dotimes (i 10)
(cat:tnpr 0 (cat:tnpr 0 cat:+null-gbar+ (let ((abar (random-abar 4 2)))
0 '()) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
0 cat:+null-abar+)) (setf gnrt (cat:tnpr 3 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
cat:*bc* (cat:cmbn 0 1 cat:+null-abar+)) 1 '(4))
(check-rdct) abar-degr abar))
(setf cat:*tc* (cat:cmbn 1 1 (unless (>= abar-degr 9)
(cat:tnpr 1 (cat:tnpr 0 cat:+null-gbar+ (setf cat:*tc* (cat:cmbn (+ 3 abar-degr) 1 gnrt)
1 '(13)) cat:*bc* (cat:cmbn abar-degr 1 abar))
0 cat:+null-abar+))) (check-rdct))))
(check-rdct) (dotimes (i 10)
(dotimes (i 10) (let ((abar (random-abar 3 1)))
(let ((abar (random-abar 4 2))) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
(setf gnrt (cat:tnpr 3 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '()) 2 '(5 6))
1 '(4)) abar-degr abar))
abar-degr abar)) (unless (>= abar-degr 8)
(unless (>= abar-degr 9) (setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt)
(setf cat:*tc* (cat:cmbn (+ 3 abar-degr) 1 gnrt) cat:*bc* (cat:cmbn abar-degr 1 abar))
cat:*bc* (cat:cmbn abar-degr 1 abar)) (check-rdct))))
(check-rdct)))) (dotimes (i 10)
(dotimes (i 10) (let ((abar (random-abar 3 1)))
(let ((abar (random-abar 3 1))) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(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 '()
(setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '()) 0 '()) 2 '(5 6))
2 '(5 6)) abar-degr abar))
abar-degr abar)) (unless (>= abar-degr 9)
(unless (>= abar-degr 8) (setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt))
(setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt) (setf cat:*bc* (cat:cmbn abar-degr 1 abar))
cat:*bc* (cat:cmbn abar-degr 1 abar)) (check-rdct))))
(check-rdct)))) (dotimes (i 10)
(dotimes (i 10) (let ((abar (random-abar 6 4)))
(let ((abar (random-abar 3 1))) (setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar))))
(setf abar-degr (apply #'+ (mapcar #'car (cat:abar-list abar)))) (setf gnrt (cat:tnpr 4 (cat:tnpr 2 (cat:gbar 2 0 '(3) 0 '())
(setf gnrt (cat:tnpr 5 (cat:tnpr 3 (cat:gbar 3 0 '(1 2) 1 '() 2 '(4 5))
0 '()) 2 '(5 6)) abar-degr abar))
abar-degr abar)) (unless (>= abar-degr 10)
(unless (>= abar-degr 9) (setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt))
(setf cat:*tc* (cat:cmbn (+ 5 abar-degr) 1 gnrt)) (setf cat:*bc* (cat:cmbn abar-degr 1 abar))
(setf cat:*bc* (cat:cmbn abar-degr 1 abar)) (check-rdct))))))
(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 (test cs-left-hmeq
(cat:cat-init) (cat:cat-init)
(let* ((h (cat:cs-left-hmeq (cat:k-z-1))) (let* ((h (cat:cs-left-hmeq (cat:k-z-1)))
(abar (cat:abar 2 '(2) 3 '(3 4)))) (abar (cat:abar 2 '(2) 3 '(3 4))))
(cat:rf h (cat:rf h
(cat:lg h (cat:lg h
(cat:lf h (cat:lf h
(cat:rg h 5 abar)))))) (cat:rg h 5 abar))))))
(test classifying-space (test classifying-space
(cat:cat-init) (cat:cat-init)
(let* ((k (cat:k-z-1)) (let* ((k (cat:k-z-1))
(bk (cat:classifying-space k)) (bk (cat:classifying-space k))
(obk (cat:loop-space bk))) (obk (cat:loop-space bk)))
(cat:homology k 0 10) (cat:homology k 0 10)
(cat:homology bk 0 10) (cat:homology bk 0 10)
(cat:homology obk 0 6))) (cat:homology obk 0 6)))