From fe52c14fcc527b2f792155cc19fe14191daa7ff8 Mon Sep 17 00:00:00 2001 From: Gerd Heber Date: Tue, 27 Oct 2015 20:18:36 -0500 Subject: [PATCH 01/15] Updated comments. --- package.lisp | 1148 +++++++++++++++++++++++----------------------- src/classes.lisp | 132 ++++-- 2 files changed, 671 insertions(+), 609 deletions(-) diff --git a/package.lisp b/package.lisp index 9cb2ed6..ba2c2c9 100644 --- a/package.lisp +++ b/package.lisp @@ -1,581 +1,581 @@ -;;;; package.lisp +:;;;; package.lisp (defpackage #:cat (:use #:cl) (:export KENZO-VERSION - ;; kenzo.lisp + ;; kenzo.lisp - *BC* - *BDD* - *CMBN-CONTROL* - *DF-FD* - *DG-GD* - *FH* - *HG* - *HH* - *HOMOLOGY-VERBOSE* - *ID-FG* - *ID-GF-DH-HD* + *BC* + *BDD* + *CMBN-CONTROL* + *DF-FD* + *DG-GD* + *FH* + *HG* + *HH* + *HOMOLOGY-VERBOSE* + *ID-FG* + *ID-GF-DH-HD* *LIST-LIST* - *RESULTS-VERBOSE* - *TC* - *TDD* - *TNPR-WITH-DEGREES* - - ;; abbreviations.lisp - - +ABBREVIATIONS+ - WHAT-IS - - ;; algebras.lisp - - HOPF - - ;; bar.lisp - - +NULL-ABAR+ - ABAR - BAR - BAR-BASIS-LENGTH - BAR-BASIS - BAR-CMPR - BAR-HRZN-DFFR - BAR-INTR-HRZN-DFFR - BAR-INTR-VRTC-DFFR - HMTP-VRTC-BAR-INTR - MRPH-VRTC-BAR-INTR - NCMBN-BAR - VRTC-BAR - - ;; bicones.lisp - - BICN-CMBN-CMBNB - BICN-CMBN-CMBNC - BICN-CMBN-CMBND - BICONE - BICONE-BASIS - BICONE-CMPR - DISPATCH-BICN-CMBN - MAKE-BICN-CMBN - - ;; cartesian-products.lisp - - 2ABSM-ACRPR - CRTS-PRDC - CRTS-PRDC-BASIS - CRTS-PRDC-CMPR - CRTS-PRDC-FACE - CRTS-PRDC-FACE* - EXTRACT-COMMON-DGOP - - ;; chain-complexes.lisp - - ?2 - ?3 - +TOO-MUCH-TIME+ - ALL-OBJECTS - BUILD-CHCM - BUILD-MRPH - CAT-INIT - CHCM - CMBN-? - DO-CONTROL - GNRT-? - HOW-MANY-OBJECTS - K - KD - KD2 - MRPH - - ;; chcm-elementary-op.lisp - - ADD - CMPS - IDNT-MRPH - N-MRPH - OPPS - SBTR - Z-CHCM - ZERO-MRPH - - ;; cl-space-efhm.lisp - - CS-HAT-T-U - CS-HAT-U-T - CS-LEFT-HMEQ - CS-LEFT-HMEQ-HAT - CS-LEFT-HMEQ-LEFT-REDUCTION - CS-LEFT-HMEQ-RIGHT-REDUCTION - CS-PRE-LEFT-HMEQ-LEFT-REDUCTION - CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-INTR-F - CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-INTR-G - CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION - CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-F - CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-G - - ;; classes.lisp - - ABSM - ABSM1 - ABSM2 - AB-SIMPLICIAL-GROUP - ALLP-LIST - APOWR - BCC - BRGN - BSGN - BSPN - CBGN - CHAIN-COMPLEX - CMBN-CMBN - CMBN-DEGR - CMBN-LIST - DEGR - DGOP - DGOP1 - DGOP2 - DFFR1 - EFHM - F - FACE - G - GBAR - GMSM - GMSM2 - H - HOMOTOPY-EQUIVALENCE - IABSM - IDNM - KAN - LOOP-LIST - LRDCT - MAKE-ABAR - MAKE-ALLP - MAKE-CMBN - MAKE-LOOP - MAKE-RESULT - MORPHISM - ORGN - REDUCTION - RRDCT - SIMPLICIAL-GROUP - SINTR - SORC - TCC - - ;; classifying-space.lisp - - +NULL-GBAR+ - CLASSIFYING-SPACE - CLASSIFYING-SPACE-BASIS - CLASSIFYING-SPACE-CMPR - CLASSIFYING-SPACE-FACE - CLASSIFYING-SPACE-GRIN-SINTR - CLASSIFYING-SPACE-GRML-SINTR - GBAR - NORMALIZE-GBAR - UNNORMALIZE-GBAR - - ;; cobar.lisp - - ALLP - COBAR - COBAR-BASIS - COBAR-BASIS-LENGTH - COBAR-CMPR - COBAR-HRZN-DFFR - COBAR-INTR-HRZN-DFFR - COBAR-INTR-VRTC-DFFR - HMTP-VRTC-COBAR-INTR - MRPH-VRTC-COBAR-INTR - NCMBN-COBAR - VRTC-COBAR - - ;; combinations.lisp - - 2CMBN-ADD - 2CMBN-SBTR - 2N-2CMBN - CHECK-CMBN - CMBN - CMBN-CMBN - CMBN-OPPS - DSTR-ADD-TERM-TO-CMBN - F-CMPR - L-CMPR - MAPLEXICO - N-CMBN - NCMBN-ADD - NTERM-ADD - S-CMPR - ZERO-CMBN - ZERO-INTR-DFFR - - ;; cones.lisp - - CMBN-CON0 - CMBN-CON1 - CONE - CONE-2CMBN-APPEND - CONE-2MRPH-DIAG - CONE-2MRPH-DIAG-IMPL - CONE-3MRPH-TRIANGLE - CONE-3MRPH-TRIANGLE-IMPL - CONE-BASIS - CONE-CMBN-SPLIT - CONE-CMPR - TERM-CON0 - TERM-CON1 - TERM-UNCON - - ;; cs-twisted-products.lisp - - SMGR-CRTS-CONTRACTION - SMGR-FIBRATION - SMGR-TNPR-CONTRACTION - - ;; delta.lisp - - DELTA - DELTA-BNDR - DELTA-DGNL - DELTA-FACE - DELTA-INFINITY - DELTA-N-BASIS - DELTAB - DELTAB2 - DELTAB2-BNDR - DELTAB2-DGNL - SOFT-DELTA - SOFT-DELTA-BNDR - SOFT-DELTA-CMPR - SOFT-DELTA-DGNL - SOFT-DELTA-FACE - SOFT-DELTA-INFINITY - SOFT-DELTA-N-BASIS - - ;; disk-pasting.lisp - - CHCM-DISK-PASTING - DISK-PASTING - DISK-PASTING-BASIS - DISK-PASTING-CMPR - DISK-PASTING-FACE - DISK-PASTING-INTR-DFFR - HMEQ-DISK-PASTING - MRPH-DISK-PASTING - MRPH-DISK-PASTING-INTR - - ;; effective-homology.lisp - - BUILD-HMEQ - BUILD-RDCT - CHECK-RDCT - CHECK-RDCT-NO-WAIT - CMPS - HMEQ - PRE-CHECK-RDCT - RDCT - TRIVIAL-HMEQ - TRIVIAL-RDCT - - ;; eilenberg-zilber.lisp - - AW - EML - EZ - INTR-AW - INTR-EML - INTR-PHI - PHI - SHUFFLE-SIGN - - ;; fibrations.lisp - - FIBRATION-TOTAL - - ;; homology-groups - - CHCM-HOMOLOGY - CHCM-HOMOLOGY-GEN - CHCM-MAT - HOMOLOGIE - - ;; k-pi-n.lisp - - CIRCLE - INTERESTING-FACES - GMSM-COCYCLE - K-Z - K-Z-1 - K-Z-1-CMPR - K-Z-1-FACE - K-Z-1-GRIN - K-Z-1-GRML - K-Z2 - K-Z2-1 - KZ1-RDCT - KZ1-RDCT-F-INTR - KZ1-RDCT-H-INTR - K-Z-FUNDAMENTAL-CLASS - K-Z2-FUNDAMENTAL-CLASS - Z-ABSM-BAR - Z-BAR-ABSM - Z-FUNDAMENTAL-GMSM - Z2-ABSM-BAR - Z2-BAR-ABSM - Z2-FUNDAMENTAL-GMSM - Z-COCYCLE-GBAR - Z-COCYCLE-GBAR-HEAD - Z2-COCYCLE-GBAR - Z2-COCYCLE-GBAR-HEAD - - ;; kan.lisp - - CHECK-HAT - CHECK-KAN - SMST-KAN - - ;; loop-spaces.lisp - - +NULL-LOOP+ - APOWR-FACE4 - APOWR-LASTFACE4 - APOWR-NILOOP - GDELTAB - LOOP3 - LOOP-PRINT - LOOP-SPACE - LOOP-SPACE-CMPR - LOOP-SPACE-FACE - LOOP-SPACE-GRIN-SINTR - LOOP-SPACE-GRML-SINTR - NORMALIZE-LOOP - UNNORMALIZE-LOOP - - ;; lp-space-efhm.lisp - - LS-HAT-T-U - LS-HAT-U-T - LS-LEFT-HMEQ - LS-LEFT-HMEQ-HAT - LS-LEFT-HMEQ-LEFT-REDUCTION - LS-LEFT-HMEQ-LEFT-REDUCTION-G-INTR - LS-LEFT-HMEQ-RIGHT-REDUCTION - LS-PRE-LEFT-HMEQ-LEFT-REDUCTION - LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-H-INTR - LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-INTR-F - LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION - LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-F - LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-G - - ;; ls-twisted-products.lisp - - ABSM-LOOPABSM - CRTS-CONTRACTION - CRTS-CONTRACTION-INTR - DTAU-D-INTR - POP-FIRST-ABSM - SZCZARBA - TNPR-CONTRACTION - TWISTED-CRTS-PRDC - - ;; macros.lisp - - -1-EXPT-N - -1-EXPT-N+1 - -1-EXPT-N-1 - ? - 2-EXP - ABAR-LIST - APRD - BASIS - BCC - BCNB - BCNC - BCND - BINOMIAL-P-Q - BNDR - CFFC - CMBN-NON-ZERO-P - CMBN-ZERO-P - CMPR - COLUMN-MINUS-5 - COLUMN-OP-5 - COLUMN-SWAP-5 - CON0 - CON1 - CPRD - CRPR - D - DEF - F - DFFR - DGNL - G - GMSM1 - GNRT - GNRT-NAME - GRIN - GRML - H - I-ADD - I-CMPS - I-SBTR - KFLL - LEXICO - LF - LG - LINE-MINUS-5 - LINE-OP-5 - LINE-SWAP-5 - MASK - MAKE-GBAR - RBCC - RF - RG - TERM - TERM-CMBN - TCC - TNPR - WITH--TERM - WITH-ABSM - WITH-CMBN - WITh-CRPR - WITH-TERM - WITh-TNPR - - ;; searching-homology.lisp - - ECHCM - HOMOLOGY - - ;; serre.lisp - - BROWN-REDUCTION - FIBRATION-DTAU-D - FIBRATION-DTAU-D-INTR - RIGHT-SERRE-EFHM - - ;; simplicial-groups.lisp - - SMGR - - ;; simplicial-mrphs.lisp - - BUILD-SMMR - TW-A-SINTR3 - - ;; simplicial-sets.lisp - - 1DGNR - 1DGOP*DGOP - 1DLOP-DGOP - A-CMPR3 - A-FACE4 - BSPN-P - CHECK-FACES - CHECK-SMST - DGOP*DGOP - DGOP/DGOP - DGOP-EXT-INT - DGOP-INT-EXT - DLOP-EXT-INT - DLOP-INT-EXT - FACE-BNDR - FACE*-BNDR - HYPHENIZE-LIST - INTR-DIAGONAL - NDGNR - NFACE - REMOVE-BIT - SHOW-STRUCTURE - SMST - - ;; smith.lisp - - CHCM-MTRX - CHML-CLSS - CHML-CLSS-INTR - COLUMN-MINUS - COLUMN-OP - COLUMN-SWAP - COPY-MTRX - ECHCM-KILL-EPI - ECHCM-KILL-EPI-F-INTR - ECHCM-KILL-EPI-G-INTR - ECHCM-KILL-EPI-H-INTR - GNRT-NAME-BASIS - IDNT-MTRX - KILL-EPI - KILL-EPIS - LEFT-SUBMATRIX - LINE-MINUS - LINE-OP - LINE-SWAP - LIST-SMITH - MINIMAL-REST-1 - MINIMAL-REST-2 - MINIMAL-TERM - MINIMAL-TERM-TOP-LEFT - MTRX-PRDC - PIVOTT - RANDOM-MATRIX - - ;; special-smsts.lisp - - BUILD-FINITE-SS - FINITE-SS-PRE-TABLE - FINITE-SS-PRE-TABLE-TABLE - FINITE-SS-TABLE - GMSMS-SUBSMST - MOORE - R-PROJ-SPACE - R-PROJ-SPACE-BASIS - SPHERE - SPHERE-FACE - SPHERE-WEDGE - - ;; suspensions.lisp - - SUSPENSION - SUSPENSION-BASIS - SUSPENSION-CMPR - SUSPENSION-FACE - SUSPENSION-INTR - SUSPENSION-INTR-CPRD - SUSPENSION-INTR-DFFR - - ;; tensor-products.lisp - - 2CMBN-TNPR - TNSR-PRDC - TNSR-PRDC-BASIS - TNSR-PRDC-CMPR - TNSR-PRDC-INTR - TNSR-PRDC-INTR-DFFR - TNPR-PRINT - - ;; various.lisp - - +EMPTY-LIST+ - - >A-B< - >A-B> - BINOMIAL-N-P - CLOCK - DONE - SRANDOM - V - - ;; whitehead.lisp - - Z-WHITEHEAD - Z-WHITEHEAD-SINTR - Z2-WHITEHEAD - Z2-WHITEHEAD-SINTR - - )) - + *RESULTS-VERBOSE* + *TC* + *TDD* + *TNPR-WITH-DEGREES* + + ;; abbreviations.lisp + + +ABBREVIATIONS+ + WHAT-IS + + ;; algebras.lisp + + HOPF + + ;; bar.lisp + + +NULL-ABAR+ + ABAR + BAR + BAR-BASIS-LENGTH + BAR-BASIS + BAR-CMPR + BAR-HRZN-DFFR + BAR-INTR-HRZN-DFFR + BAR-INTR-VRTC-DFFR + HMTP-VRTC-BAR-INTR + MRPH-VRTC-BAR-INTR + NCMBN-BAR + VRTC-BAR + + ;; bicones.lisp + + BICN-CMBN-CMBNB + BICN-CMBN-CMBNC + BICN-CMBN-CMBND + BICONE + BICONE-BASIS + BICONE-CMPR + DISPATCH-BICN-CMBN + MAKE-BICN-CMBN + + ;; cartesian-products.lisp + + 2ABSM-ACRPR + CRTS-PRDC + CRTS-PRDC-BASIS + CRTS-PRDC-CMPR + CRTS-PRDC-FACE + CRTS-PRDC-FACE* + EXTRACT-COMMON-DGOP + + ;; chain-complexes.lisp + + ?2 + ?3 + +TOO-MUCH-TIME+ + ALL-OBJECTS + BUILD-CHCM + BUILD-MRPH + CAT-INIT + CHCM + CMBN-? + DO-CONTROL + GNRT-? + HOW-MANY-OBJECTS + K + KD + KD2 + MRPH + + ;; chcm-elementary-op.lisp + + ADD + CMPS + IDNT-MRPH + N-MRPH + OPPS + SBTR + Z-CHCM + ZERO-MRPH + + ;; cl-space-efhm.lisp + + CS-HAT-T-U + CS-HAT-U-T + CS-LEFT-HMEQ + CS-LEFT-HMEQ-HAT + CS-LEFT-HMEQ-LEFT-REDUCTION + CS-LEFT-HMEQ-RIGHT-REDUCTION + CS-PRE-LEFT-HMEQ-LEFT-REDUCTION + CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-INTR-F + CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-INTR-G + CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION + CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-F + CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-G + + ;; classes.lisp + + ABSM + ABSM1 + ABSM2 + AB-SIMPLICIAL-GROUP + ALLP-LIST + APOWR + BCC + BRGN + BSGN + BSPN + CBGN + CHAIN-COMPLEX + CMBN-CMBN + CMBN-DEGR + CMBN-LIST + DEGR + DGOP + DGOP1 + DGOP2 + DFFR1 + EFHM + F + FACE + G + GBAR + GMSM + GMSM2 + H + HOMOTOPY-EQUIVALENCE + IABSM + IDNM + KAN + LOOP-LIST + LRDCT + MAKE-ABAR + MAKE-ALLP + MAKE-CMBN + MAKE-LOOP + MAKE-RESULT + MORPHISM + ORGN + REDUCTION + RRDCT + SIMPLICIAL-GROUP + SINTR + SORC + TCC + + ;; classifying-space.lisp + + +NULL-GBAR+ + CLASSIFYING-SPACE + CLASSIFYING-SPACE-BASIS + CLASSIFYING-SPACE-CMPR + CLASSIFYING-SPACE-FACE + CLASSIFYING-SPACE-GRIN-SINTR + CLASSIFYING-SPACE-GRML-SINTR + GBAR + NORMALIZE-GBAR + UNNORMALIZE-GBAR + + ;; cobar.lisp + + ALLP + COBAR + COBAR-BASIS + COBAR-BASIS-LENGTH + COBAR-CMPR + COBAR-HRZN-DFFR + COBAR-INTR-HRZN-DFFR + COBAR-INTR-VRTC-DFFR + HMTP-VRTC-COBAR-INTR + MRPH-VRTC-COBAR-INTR + NCMBN-COBAR + VRTC-COBAR + + ;; combinations.lisp + + 2CMBN-ADD + 2CMBN-SBTR + 2N-2CMBN + CHECK-CMBN + CMBN + CMBN-CMBN + CMBN-OPPS + DSTR-ADD-TERM-TO-CMBN + F-CMPR + L-CMPR + MAPLEXICO + N-CMBN + NCMBN-ADD + NTERM-ADD + S-CMPR + ZERO-CMBN + ZERO-INTR-DFFR + + ;; cones.lisp + + CMBN-CON0 + CMBN-CON1 + CONE + CONE-2CMBN-APPEND + CONE-2MRPH-DIAG + CONE-2MRPH-DIAG-IMPL + CONE-3MRPH-TRIANGLE + CONE-3MRPH-TRIANGLE-IMPL + CONE-BASIS + CONE-CMBN-SPLIT + CONE-CMPR + TERM-CON0 + TERM-CON1 + TERM-UNCON + + ;; cs-twisted-products.lisp + + SMGR-CRTS-CONTRACTION + SMGR-FIBRATION + SMGR-TNPR-CONTRACTION + + ;; delta.lisp + + DELTA + DELTA-BNDR + DELTA-DGNL + DELTA-FACE + DELTA-INFINITY + DELTA-N-BASIS + DELTAB + DELTAB2 + DELTAB2-BNDR + DELTAB2-DGNL + SOFT-DELTA + SOFT-DELTA-BNDR + SOFT-DELTA-CMPR + SOFT-DELTA-DGNL + SOFT-DELTA-FACE + SOFT-DELTA-INFINITY + SOFT-DELTA-N-BASIS + + ;; disk-pasting.lisp + + CHCM-DISK-PASTING + DISK-PASTING + DISK-PASTING-BASIS + DISK-PASTING-CMPR + DISK-PASTING-FACE + DISK-PASTING-INTR-DFFR + HMEQ-DISK-PASTING + MRPH-DISK-PASTING + MRPH-DISK-PASTING-INTR + + ;; effective-homology.lisp + + BUILD-HMEQ + BUILD-RDCT + CHECK-RDCT + CHECK-RDCT-NO-WAIT + CMPS + HMEQ + PRE-CHECK-RDCT + RDCT + TRIVIAL-HMEQ + TRIVIAL-RDCT + + ;; eilenberg-zilber.lisp + + AW + EML + EZ + INTR-AW + INTR-EML + INTR-PHI + PHI + SHUFFLE-SIGN + + ;; fibrations.lisp + + FIBRATION-TOTAL + + ;; homology-groups + + CHCM-HOMOLOGY + CHCM-HOMOLOGY-GEN + CHCM-MAT + HOMOLOGIE + MAT-ALEAT + + ;; k-pi-n.lisp + + CIRCLE + INTERESTING-FACES + GMSM-COCYCLE + K-Z + K-Z-1 + K-Z-1-CMPR + K-Z-1-FACE + K-Z-1-GRIN + K-Z-1-GRML + K-Z2 + K-Z2-1 + KZ1-RDCT + KZ1-RDCT-F-INTR + KZ1-RDCT-H-INTR + K-Z-FUNDAMENTAL-CLASS + K-Z2-FUNDAMENTAL-CLASS + Z-ABSM-BAR + Z-BAR-ABSM + Z-FUNDAMENTAL-GMSM + Z2-ABSM-BAR + Z2-BAR-ABSM + Z2-FUNDAMENTAL-GMSM + Z-COCYCLE-GBAR + Z-COCYCLE-GBAR-HEAD + Z2-COCYCLE-GBAR + Z2-COCYCLE-GBAR-HEAD + + ;; kan.lisp + + CHECK-HAT + CHECK-KAN + SMST-KAN + + ;; loop-spaces.lisp + + +NULL-LOOP+ + APOWR-FACE4 + APOWR-LASTFACE4 + APOWR-NILOOP + GDELTAB + LOOP3 + LOOP-PRINT + LOOP-SPACE + LOOP-SPACE-CMPR + LOOP-SPACE-FACE + LOOP-SPACE-GRIN-SINTR + LOOP-SPACE-GRML-SINTR + NORMALIZE-LOOP + UNNORMALIZE-LOOP + + ;; lp-space-efhm.lisp + + LS-HAT-T-U + LS-HAT-U-T + LS-LEFT-HMEQ + LS-LEFT-HMEQ-HAT + LS-LEFT-HMEQ-LEFT-REDUCTION + LS-LEFT-HMEQ-LEFT-REDUCTION-G-INTR + LS-LEFT-HMEQ-RIGHT-REDUCTION + LS-PRE-LEFT-HMEQ-LEFT-REDUCTION + LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-H-INTR + LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-INTR-F + LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION + LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-F + LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-G + + ;; ls-twisted-products.lisp + + ABSM-LOOPABSM + CRTS-CONTRACTION + CRTS-CONTRACTION-INTR + DTAU-D-INTR + POP-FIRST-ABSM + SZCZARBA + TNPR-CONTRACTION + TWISTED-CRTS-PRDC + + ;; macros.lisp + + -1-EXPT-N + -1-EXPT-N+1 + -1-EXPT-N-1 + ? + 2-EXP + ABAR-LIST + APRD + BASIS + BCC + BCNB + BCNC + BCND + BINOMIAL-P-Q + BNDR + CFFC + CMBN-NON-ZERO-P + CMBN-ZERO-P + CMPR + COLUMN-MINUS-5 + COLUMN-OP-5 + COLUMN-SWAP-5 + CON0 + CON1 + CPRD + CRPR + D + DEF + F + DFFR + DGNL + G + GMSM1 + GNRT + GNRT-NAME + GRIN + GRML + H + I-ADD + I-CMPS + I-SBTR + KFLL + LEXICO + LF + LG + LINE-MINUS-5 + LINE-OP-5 + LINE-SWAP-5 + MASK + MAKE-GBAR + RBCC + RF + RG + TERM + TERM-CMBN + TCC + TNPR + WITH--TERM + WITH-ABSM + WITH-CMBN + WITh-CRPR + WITH-TERM + WITh-TNPR + + ;; searching-homology.lisp + + ECHCM + HOMOLOGY + + ;; serre.lisp + + BROWN-REDUCTION + FIBRATION-DTAU-D + FIBRATION-DTAU-D-INTR + RIGHT-SERRE-EFHM + + ;; simplicial-groups.lisp + + SMGR + + ;; simplicial-mrphs.lisp + + BUILD-SMMR + TW-A-SINTR3 + + ;; simplicial-sets.lisp + + 1DGNR + 1DGOP*DGOP + 1DLOP-DGOP + A-CMPR3 + A-FACE4 + BSPN-P + CHECK-FACES + CHECK-SMST + DGOP*DGOP + DGOP/DGOP + DGOP-EXT-INT + DGOP-INT-EXT + DLOP-EXT-INT + DLOP-INT-EXT + FACE-BNDR + FACE*-BNDR + HYPHENIZE-LIST + INTR-DIAGONAL + NDGNR + NFACE + REMOVE-BIT + SHOW-STRUCTURE + SMST + + ;; smith.lisp + + CHCM-MTRX + CHML-CLSS + CHML-CLSS-INTR + COLUMN-MINUS + COLUMN-OP + COLUMN-SWAP + COPY-MTRX + ECHCM-KILL-EPI + ECHCM-KILL-EPI-F-INTR + ECHCM-KILL-EPI-G-INTR + ECHCM-KILL-EPI-H-INTR + GNRT-NAME-BASIS + IDNT-MTRX + KILL-EPI + KILL-EPIS + LEFT-SUBMATRIX + LINE-MINUS + LINE-OP + LINE-SWAP + LIST-SMITH + MINIMAL-REST-1 + MINIMAL-REST-2 + MINIMAL-TERM + MINIMAL-TERM-TOP-LEFT + MTRX-PRDC + PIVOTT + RANDOM-MATRIX + + ;; special-smsts.lisp + + BUILD-FINITE-SS + FINITE-SS-PRE-TABLE + FINITE-SS-PRE-TABLE-TABLE + FINITE-SS-TABLE + GMSMS-SUBSMST + MOORE + R-PROJ-SPACE + R-PROJ-SPACE-BASIS + SPHERE + SPHERE-FACE + SPHERE-WEDGE + + ;; suspensions.lisp + + SUSPENSION + SUSPENSION-BASIS + SUSPENSION-CMPR + SUSPENSION-FACE + SUSPENSION-INTR + SUSPENSION-INTR-CPRD + SUSPENSION-INTR-DFFR + + ;; tensor-products.lisp + + 2CMBN-TNPR + TNSR-PRDC + TNSR-PRDC-BASIS + TNSR-PRDC-CMPR + TNSR-PRDC-INTR + TNSR-PRDC-INTR-DFFR + TNPR-PRINT + + ;; various.lisp + + +EMPTY-LIST+ + + >A-B< + >A-B> + BINOMIAL-N-P + CLOCK + DONE + SRANDOM + V + + ;; whitehead.lisp + + Z-WHITEHEAD + Z-WHITEHEAD-SINTR + Z2-WHITEHEAD + Z2-WHITEHEAD-SINTR + + )) diff --git a/src/classes.lisp b/src/classes.lisp index 2a07199..8ca3a37 100644 --- a/src/classes.lisp +++ b/src/classes.lisp @@ -45,7 +45,7 @@ internal representation of combinations. (declare (type any object)) (the boolean (and (typep object 'fixnum) - (/= 0 object)))) + (/= 0 object)))) (DEFTYPE CFFC () "------------------------------------------------------------------[type-doc] @@ -90,8 +90,8 @@ A derived type to represent comparison functions. (declare (type any object)) (the boolean (and (consp object) - (typep (car object) 'cffc) - (typep (cdr object) 'gnrt)))) + (typep (car object) 'cffc) + (typep (cdr object) 'gnrt)))) (DEFTYPE TERM () "------------------------------------------------------------------[type-doc] @@ -110,7 +110,7 @@ and whose CDR is of type GNRT. (declare (type any object)) (the boolean (and (listp object) - (every #'term-p object)))) + (every #'term-p object)))) (DEFTYPE ICMBN () '(satisfies icmbn-p)) @@ -141,8 +141,8 @@ the symbol :LOCALLY-EFFECTIVE. #+allegro (eval-when (:compile-toplevel :load-toplevel :execute) (setf redefinition-warnings-saved - excl::*redefinition-warnings* - *redefinition-warnings* nil)) + excl::*redefinition-warnings* + *redefinition-warnings* nil)) (DEFCLASS CHAIN-COMPLEX () ((cmpr :type cmprf :initarg :cmpr :reader cmpr1) @@ -178,9 +178,16 @@ Intances of this class represent chain complexes. The class has 8 slots: 4. DFFR, the differential morphism, an instance of the class MORPHISM. Its reader function is DFFR1. -5. GRMD, ??? Its reader function is GRMD. +5. GRMD, refers to some chain-complex considered as a reference for the + underlying graded module structure. Sometimes, it is better to check two + chain-complexes have the same underlying graded module. Typically if C1 is + a chain-complex and C2 is obtained from C1 by perturbing the differential, + then (eq (grmd C1) (grmd C2)) should return T. Its reader function is GRMD. -6. EFHM, ??? Its reader function is EFHM. +6. EFHM, if the effective homology of the chain complex has already been + computed, then this slot points to the HOMOTOPY-EQUIVALENCE which IS the + effective homology of this object. Otherwise the slot is unbound. Its + reader function is EFHM. 7. IDNM, an integer, a system generated identifier for this object. Its reader function is IDNM. @@ -218,8 +225,8 @@ A derived type, which represents the mapping strategy of morphisms. (?-clnm :type fixnum :initform 0 :accessor ?-clnm) ;; ReSuLTS (rslts :type simple-vector - ;; (vector (vector result)) - :reader rslts) + ;; (vector (vector result)) + :reader rslts) ;; IDentification NuMber (idnm :type fixnum :initform (incf *idnm-counter*) :reader idnm) ;; ORiGiN @@ -240,11 +247,22 @@ degree -1. The class has 10 slots: 3. DEGR, an integer, the degree of the morphism. Its reader function is DEGR. -4. INTR, a Lisp function implementing the morphism, taking account of the - strategy STRT. Its reader function is INTR. +4. INTR, a Lisp INTeRnal function implementing the morphism, taking account + of the strategy STRT. Its reader function is INTR. 5. STRT, a symbol, one of :GNRT or :CMBN. Its reader function is STRT. + If this slot is :GNRT, the implementation of INTR is a function: + (function (degr gnrt) cmbn) + and for any call of this function, the result is stored in the slot + RSLTS to avoid later a possibly long recalculation for the same + argument. + + If this slot is :CMBN, the implementation of INTR is a function: + (function (cmbn) cmbn) + and the RSLTS slot is not used. Think for example to an identity or + null function, where storing a result is wasted time. + 6. ???-CLNM, an integer updated by the system for internal statistics. Its reader function is ???-CLNM. @@ -352,12 +370,19 @@ The class has 7 slots: ;; IDentification NuMber (idnm :type fixnum :initform (incf *idnm-counter*) :reader idnm) ;; ORiGiN - (orgn :type list :initarg :orgn :reader orgn))) + (orgn :type list :initarg :orgn :reader orgn)) + (:documentation + "----------------------------------------------------------------[class-doc] +HOMOTOPY-EQUIVALENCE +A homotopy-equivalence is essentially a pair of respective reductions from an +intermediate chain complex TCC to the LBCC (left bottom) and RBCC (rigth +bottom) chain complexes. It is an equivalence between LBCC and RBCC. +-----------------------------------------------------------------------------")) #+allegro (eval-when (:compile-toplevel :load-toplevel :execute) (setf excl::*redefinition-warnings* - redefinition-warnings-saved)) + redefinition-warnings-saved)) ;;; ;;; HOMOLOGY-GROUPS @@ -365,9 +390,31 @@ The class has 7 slots: (DEFSTRUCT (matrice (:conc-name nil)) + "------------------------------------------------------------------[type-doc] +MATRICE +Slots: (leftcol uplig) +A MATRICE is made of two vectors LEFTCOL and UPLIG. LEFTCOL is a +vector of size m+1 if m is the number of rows of the matrix, UPLIG is +a vector of size n+1 if n is the number of columns. +Every element of LEFTCOL and UPLIG is a T-MAT with the value NIL +indicating it is a fake term. +------------------------------------------------------------------------------" leftcol uplig) (DEFSTRUCT (t-mat (:conc-name nil)) + "------------------------------------------------------------------[type-doc] +T-MAT +Slots: (val ilig icol left up) +A T-MAT (= Terme de Matrice) has five components: + + VAL = A value, an integer, in principle a non-null integer. + ILIG = the line (row is better) index of this term + ICOL = the column index of this term + LEFT = a pointer to the next term on the left on the same line, + or to a fake term, an element of LEFTCOL of the matrice. + UP = a pointer to the next term above on the same column, + or to a fake term, an element of UPLIG of the matrice. +------------------------------------------------------------------------------" val ilig icol left up) @@ -379,11 +426,26 @@ The class has 7 slots: (conx (:type '(member 0 1))) (icon (:type 'gnrt))) +;; Given a morphism f : C1 -> C0 between two chain complexes, +;; the cone of f is a chain complex made of C0 as such, +;; C1 suspended. +;; The differential of the C0 component is unchanged. +;; If x is an element of C1, then d_cone(x) = -dx + fx +;; with dx computed as in the original C1. +;; A CONE generator is an conx 0 (resp. 1) and +;; and an icon (= internal cone generator) being a +;; generator of C0 (resp. C1). (DEFSTRUCT (BICN (:conc-name nil) (:print-function bicn-print)) (bcnx (:type '(member :bcnb :bcnc :bcnd))) (ibicn (:type 'gnrt))) +;; Analogous with two morphisms f: B -> C and g: D -> C. + +;; Intended to become the central part of a zigzag : +;; A <- B -> C <- D -> E +;; The key structure to compose two equivalences: +;; A <- B -> C and C <- D -> E ;;; ;;; TENSOR-PRODUCTS @@ -412,8 +474,8 @@ The class has 7 slots: (declare (type any object)) (the boolean (and (consp object) - (typep (car object) 'fixnum) ;; degree *in* the cobar - (typep (cdr object) 'gnrt)))) + (typep (car object) 'fixnum) ;; degree *in* the cobar + (typep (cdr object) 'gnrt)))) (DEFTYPE CBGN () '(satisfies cbgn-p)) @@ -422,7 +484,7 @@ The class has 7 slots: (declare (type any object)) (the boolean (and (listp object) - (every #'cbgn-p object)))) + (every #'cbgn-p object)))) (DEFTYPE IALLP () '(satisfies iallp-p)) @@ -454,8 +516,8 @@ The class has 7 slots: (declare (type any object)) (the boolean (and (consp object) - (typep (car object) 'fixnum) ;; degree *in* the bar - (typep (cdr object) 'gnrt)))) + (typep (car object) 'fixnum) ;; degree *in* the bar + (typep (cdr object) 'gnrt)))) (DEFTYPE BRGN () '(satisfies brgn-p)) @@ -464,7 +526,7 @@ The class has 7 slots: (declare (type any object)) (the boolean (and (listp object) - (every #'brgn-p object)))) + (every #'brgn-p object)))) (DEFTYPE IABAR () '(satisfies iabar-p)) @@ -476,8 +538,8 @@ The class has 7 slots: (declare (type any object)) (the boolean (and (consp object) - (eq :abar (car object)) - (typep (cdr object) 'iabar)))) + (eq :abar (car object)) + (typep (cdr object) 'iabar)))) (DEFTYPE ABAR () '(satisfies abar-p)) |# @@ -508,8 +570,8 @@ The class has 7 slots: (declare (type any object)) (the boolean (and (consp object) - (typep (car object) 'dgop) - (typep (cdr object) 'gmsm)))) + (typep (car object) 'dgop) + (typep (cdr object) 'gmsm)))) (DEFTYPE IABSM () '(satisfies iabsm-p)) @@ -555,8 +617,8 @@ The class has 7 slots: (declare (type any object)) (the boolean (and (consp object) - (eq :delt (car object)) - (typep (cdr object) 'dgop)))) + (eq :delt (car object)) + (typep (cdr object) 'dgop)))) (DEFTYPE SOFT-DLOP () '(satisfies soft-dlop-p)) @@ -589,7 +651,7 @@ The class has 7 slots: (declare (type any object)) (the boolean (and (typep object 'simplicial-mrph) - (= -1 (degr object))))) + (= -1 (degr object))))) (DEFTYPE FIBRATION () '(satisfies fibration-p)) @@ -610,7 +672,7 @@ The class has 7 slots: (declare (type any object)) (the boolean (typep object '(and fixnum - (not (eql 0)))))) + (not (eql 0)))))) (DEFTYPE EXPN () '(satisfies expn-p)) @@ -619,8 +681,8 @@ The class has 7 slots: (declare (type any object)) (the boolean (and (consp object) - (typep (car object) 'gmsm) - (typep (cdr object) 'expn)))) + (typep (car object) 'gmsm) + (typep (cdr object) 'expn)))) (DEFTYPE POWR () '(satisfies powr-p)) @@ -629,8 +691,8 @@ The class has 7 slots: (declare (type any object)) (the boolean (and (consp object) - (typep (car object) 'dgop) - (typep (cdr object) 'powr)))) + (typep (car object) 'dgop) + (typep (cdr object) 'powr)))) (DEFTYPE APOWR () '(satisfies apowr-p)) @@ -639,7 +701,7 @@ The class has 7 slots: (declare (type any object)) (the boolean (and (listp object) - (every #'apowr-p object)))) + (every #'apowr-p object)))) (DEFTYPE ILOOP () '(satisfies iloop-p)) @@ -650,7 +712,7 @@ The class has 7 slots: #+clisp(eval-when (:compile-toplevel :load-toplevel :execute) (setf (ext:package-lock :common-lisp) nil)) #+sbcl(eval-when (:compile-toplevel :load-toplevel :execute) - (sb-ext:unlock-package :common-lisp)) + (sb-ext:unlock-package :common-lisp)) (DEFSTRUCT (LOOP (:print-function loop-print)) (list (:type 'iloop))) @@ -661,7 +723,7 @@ The class has 7 slots: #+clisp(eval-when (:compile-toplevel :load-toplevel :execute) (setf (ext:package-lock :common-lisp) t)) #+sbcl(eval-when (:compile-toplevel :load-toplevel :execute) - (sb-ext:lock-package :common-lisp)) + (sb-ext:lock-package :common-lisp)) #+ccl (DEFMETHOD make-load-form ((l loop) &optional env) From a13c03e3e35f1b0b24586e4a05c64a8f421ac2b6 Mon Sep 17 00:00:00 2001 From: Gerd Heber Date: Sun, 8 Nov 2015 19:11:15 -0600 Subject: [PATCH 02/15] Fixed invalid first character. --- package.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/package.lisp b/package.lisp index ba2c2c9..5627299 100644 --- a/package.lisp +++ b/package.lisp @@ -1,4 +1,4 @@ -:;;;; package.lisp +;;;; package.lisp (defpackage #:cat (:use #:cl) From 092164e7863c1131bb327a36eb62537e02f322ae Mon Sep 17 00:00:00 2001 From: Gerd Heber Date: Sun, 8 Nov 2015 19:17:23 -0600 Subject: [PATCH 03/15] Fixed issue #66. --- examples/Chapter1.ipynb | 171 +++++++++++++++++++++++----------------- src/combinations.lisp | 4 +- 2 files changed, 100 insertions(+), 75 deletions(-) diff --git a/examples/Chapter1.ipynb b/examples/Chapter1.ipynb index 5241dfe..f0aba9f 100644 --- a/examples/Chapter1.ipynb +++ b/examples/Chapter1.ipynb @@ -14,6 +14,17 @@ "collapsed": false }, "outputs": [ + { + "name": "stdout", + "output_type": "stream", + "text": [ + "To load \"kenzo\":\n", + " Load 1 ASDF system:\n", + " kenzo\n", + "; Loading \"kenzo\"\n", + ".\n" + ] + }, { "data": { "text/plain": [ @@ -236,8 +247,8 @@ "Args: (degr &rest rest)\n", "Returns a combination of degree DEGR from a sum of terms provided as a sequence\n", "CF1 GNRT1 CF2 GNRT2 ... CFn GNRTn of coefficient / generator pairs in REST.\n", - "REST can be of arbitrary even length and can be empty, in which case the\n", - "combination is an instance of the null combination of degree DEGR.\n", + "REST can be of arbitrary length including NIL, in which case the combination\n", + "is an instance of the null combination of degree DEGR.\n", "------------------------------------------------------------------------------\"" ] }, @@ -689,7 +700,7 @@ { "data": { "text/plain": [ - "#" + "#" ] }, "execution_count": 26, @@ -711,7 +722,7 @@ { "data": { "text/plain": [ - "#" + "#" ] }, "execution_count": 27, @@ -760,7 +771,7 @@ { "data": { "text/plain": [ - "#" + "#" ] }, "execution_count": 29, @@ -1264,39 +1275,53 @@ { "data": { "text/plain": [ - "\"-----------------------------------------------------------------[class-doc]\n", + "\"----------------------------------------------------------------[class-doc]\n", "MORPHISM\n", "Slots: (sorc trgt degr intr strt ???-clnm ?-clnm rslts idnm orgn)\n", "Intances of this class represent morphisms between chain complexes, and the\n", "differential homomorphism of a chain complex is treated as a morphism of\n", "degree -1. The class has 10 slots:\n", "\n", - "1. SORC, an object of class CHAIN-COMPLEX, the source chain complex of this\n", - " morphism.\n", + "1. SORC, an object of type CHAIN-COMPLEX, the source chain complex of this\n", + " morphism. Its reader function is SORC.\n", "\n", - "2. TRGT, an object of class CHAIN-COMPLEX, the target chain complex of this\n", - " morphism.\n", + "2. TRGT, an object of type CHAIN-COMPLEX, the target chain complex of this\n", + " morphism. Its reader function is TRGT.\n", "\n", - "3. DEGR, an integer, the degree of the morphism.\n", + "3. DEGR, an integer, the degree of the morphism. Its reader function is DEGR.\n", "\n", - "4. INTR, a Lisp function implementing the morphism, taking account of the\n", - " strategy STRT.\n", + "4. INTR, a Lisp INTeRnal function implementing the morphism, taking account\n", + " of the strategy STRT. Its reader function is INTR.\n", "\n", - "5. STRT, a symbol, one of :GNRT or :CMBN.\n", + "5. STRT, a symbol, one of :GNRT or :CMBN. Its reader function is STRT.\n", "\n", - "6. ???-CLNM, an integer updated by the system for internal statistics.\n", + " If this slot is :GNRT, the implementation of INTR is a function:\n", + " (function (degr gnrt) cmbn)\n", + " and for any call of this function, the result is stored in the slot\n", + " RSLTS to avoid later a possibly long recalculation for the same\n", + " argument.\n", "\n", - "7. ?-CLNM, another integer maintained by the system for internal pusposes.\n", + " If this slot is :CMBN, the implementation of INTR is a function:\n", + " (function (cmbn) cmbn)\n", + " and the RSLTS slot is not used. Think for example to an identity or\n", + " null function, where storing a result is wasted time.\n", + "\n", + "6. ???-CLNM, an integer updated by the system for internal statistics. Its\n", + " reader function is ???-CLNM.\n", + "\n", + "7. ?-CLNM, another integer maintained by the system for internal pusposes. Its\n", + " reader function is ?-CLNM.\n", "\n", "8. RSLTS, an array of length +MAXIMAL-DIMENSION+ reserved by the system for\n", - " caching intermediate results.\n", + " caching intermediate results. Its reader function is RSLTS.\n", "\n", - "9. IDNM, an integer, a system-generated identifier for this object.\n", + "9. IDNM, an integer, a system-generated identifier for this object. Its reader\n", + " function is IDNM.\n", "\n", "10. ORGN, a list containg a comment indicating the origin of the object. The\n", " should be unique (per session), since it is used in the implementation for\n", - " caching purposes.\n", - "------------------------------------------------------------------------------\"" + " caching purposes. Its reader function is ORGN.\n", + "-----------------------------------------------------------------------------\"" ] }, "execution_count": 47, @@ -1493,7 +1518,7 @@ { "data": { "text/plain": [ - "#" + "#" ] }, "execution_count": 53, @@ -1788,7 +1813,7 @@ }, { "cell_type": "code", - "execution_count": 64, + "execution_count": 65, "metadata": { "collapsed": false }, @@ -1805,7 +1830,7 @@ "------------------------------------------------------------------------------\n" ] }, - "execution_count": 64, + "execution_count": 65, "metadata": {}, "output_type": "execute_result" } @@ -1816,7 +1841,7 @@ }, { "cell_type": "code", - "execution_count": 64, + "execution_count": 66, "metadata": { "collapsed": false }, @@ -1827,7 +1852,7 @@ "[K9 Morphism (degree 0): K5 -> K5]" ] }, - "execution_count": 64, + "execution_count": 66, "metadata": {}, "output_type": "execute_result" } @@ -1838,7 +1863,7 @@ }, { "cell_type": "code", - "execution_count": 64, + "execution_count": 67, "metadata": { "collapsed": false }, @@ -1849,7 +1874,7 @@ "0" ] }, - "execution_count": 64, + "execution_count": 67, "metadata": {}, "output_type": "execute_result" } @@ -1860,7 +1885,7 @@ }, { "cell_type": "code", - "execution_count": 64, + "execution_count": 68, "metadata": { "collapsed": false }, @@ -1877,7 +1902,7 @@ "------------------------------------------------------------------------------\n" ] }, - "execution_count": 64, + "execution_count": 68, "metadata": {}, "output_type": "execute_result" } @@ -1888,7 +1913,7 @@ }, { "cell_type": "code", - "execution_count": 64, + "execution_count": 69, "metadata": { "collapsed": false }, @@ -1901,7 +1926,7 @@ "------------------------------------------------------------------------------\n" ] }, - "execution_count": 64, + "execution_count": 69, "metadata": {}, "output_type": "execute_result" } @@ -1912,7 +1937,7 @@ }, { "cell_type": "code", - "execution_count": 64, + "execution_count": 70, "metadata": { "collapsed": false }, @@ -1923,7 +1948,7 @@ "[K10 Morphism (degree 2): K5 -> K5]" ] }, - "execution_count": 64, + "execution_count": 70, "metadata": {}, "output_type": "execute_result" } @@ -1934,7 +1959,7 @@ }, { "cell_type": "code", - "execution_count": 64, + "execution_count": 71, "metadata": { "collapsed": false }, @@ -1945,7 +1970,7 @@ "2" ] }, - "execution_count": 64, + "execution_count": 71, "metadata": {}, "output_type": "execute_result" } @@ -1956,7 +1981,7 @@ }, { "cell_type": "code", - "execution_count": 64, + "execution_count": 72, "metadata": { "collapsed": false }, @@ -1973,7 +1998,7 @@ "------------------------------------------------------------------------------\n" ] }, - "execution_count": 64, + "execution_count": 72, "metadata": {}, "output_type": "execute_result" } @@ -1984,7 +2009,7 @@ }, { "cell_type": "code", - "execution_count": 64, + "execution_count": 73, "metadata": { "collapsed": false }, @@ -1995,7 +2020,7 @@ "[K11 Morphism (degree 1): K5 -> K5]" ] }, - "execution_count": 64, + "execution_count": 73, "metadata": {}, "output_type": "execute_result" } @@ -2006,7 +2031,7 @@ }, { "cell_type": "code", - "execution_count": 64, + "execution_count": 74, "metadata": { "collapsed": false }, @@ -2017,7 +2042,7 @@ "1" ] }, - "execution_count": 64, + "execution_count": 74, "metadata": {}, "output_type": "execute_result" } @@ -2028,7 +2053,7 @@ }, { "cell_type": "code", - "execution_count": 64, + "execution_count": 75, "metadata": { "collapsed": false }, @@ -2045,7 +2070,7 @@ "------------------------------------------------------------------------------\n" ] }, - "execution_count": 64, + "execution_count": 75, "metadata": {}, "output_type": "execute_result" } @@ -2056,7 +2081,7 @@ }, { "cell_type": "code", - "execution_count": 64, + "execution_count": 76, "metadata": { "collapsed": false }, @@ -2067,7 +2092,7 @@ "[K12 Morphism (degree 0): K5 -> K5]" ] }, - "execution_count": 64, + "execution_count": 76, "metadata": {}, "output_type": "execute_result" } @@ -2078,7 +2103,7 @@ }, { "cell_type": "code", - "execution_count": 64, + "execution_count": 77, "metadata": { "collapsed": false }, @@ -2089,7 +2114,7 @@ "[K13 Morphism (degree 0): K5 -> K5]" ] }, - "execution_count": 64, + "execution_count": 77, "metadata": {}, "output_type": "execute_result" } @@ -2100,7 +2125,7 @@ }, { "cell_type": "code", - "execution_count": 64, + "execution_count": 78, "metadata": { "collapsed": false }, @@ -2114,7 +2139,7 @@ "------------------------------------------------------------------------------\n" ] }, - "execution_count": 64, + "execution_count": 78, "metadata": {}, "output_type": "execute_result" } @@ -2125,7 +2150,7 @@ }, { "cell_type": "code", - "execution_count": 64, + "execution_count": 79, "metadata": { "collapsed": false }, @@ -2138,7 +2163,7 @@ "------------------------------------------------------------------------------\n" ] }, - "execution_count": 64, + "execution_count": 79, "metadata": {}, "output_type": "execute_result" } @@ -2149,7 +2174,7 @@ }, { "cell_type": "code", - "execution_count": 64, + "execution_count": 80, "metadata": { "collapsed": false }, @@ -2168,7 +2193,7 @@ "------------------------------------------------------------------------------\n" ] }, - "execution_count": 64, + "execution_count": 80, "metadata": {}, "output_type": "execute_result" } @@ -2179,7 +2204,7 @@ }, { "cell_type": "code", - "execution_count": 64, + "execution_count": 81, "metadata": { "collapsed": false }, @@ -2195,7 +2220,7 @@ "------------------------------------------------------------------------------\n" ] }, - "execution_count": 64, + "execution_count": 81, "metadata": {}, "output_type": "execute_result" } @@ -2206,7 +2231,7 @@ }, { "cell_type": "code", - "execution_count": 64, + "execution_count": 82, "metadata": { "collapsed": false }, @@ -2222,7 +2247,7 @@ "------------------------------------------------------------------------------\n" ] }, - "execution_count": 64, + "execution_count": 82, "metadata": {}, "output_type": "execute_result" } @@ -2240,7 +2265,7 @@ }, { "cell_type": "code", - "execution_count": 64, + "execution_count": 83, "metadata": { "collapsed": false }, @@ -2251,7 +2276,7 @@ "[K1 Chain-Complex]" ] }, - "execution_count": 64, + "execution_count": 83, "metadata": {}, "output_type": "execute_result" } @@ -2262,7 +2287,7 @@ }, { "cell_type": "code", - "execution_count": 64, + "execution_count": 84, "metadata": { "collapsed": false }, @@ -2283,7 +2308,7 @@ "NIL" ] }, - "execution_count": 64, + "execution_count": 84, "metadata": {}, "output_type": "execute_result" } @@ -2294,7 +2319,7 @@ }, { "cell_type": "code", - "execution_count": 64, + "execution_count": 85, "metadata": { "collapsed": false }, @@ -2305,7 +2330,7 @@ "[K3 Cohomology-Class on K1 of degree 1]" ] }, - "execution_count": 64, + "execution_count": 85, "metadata": {}, "output_type": "execute_result" } @@ -2316,7 +2341,7 @@ }, { "cell_type": "code", - "execution_count": 64, + "execution_count": 86, "metadata": { "collapsed": false }, @@ -2337,7 +2362,7 @@ "NIL" ] }, - "execution_count": 64, + "execution_count": 86, "metadata": {}, "output_type": "execute_result" } @@ -2348,7 +2373,7 @@ }, { "cell_type": "code", - "execution_count": 64, + "execution_count": 87, "metadata": { "collapsed": false }, @@ -2369,7 +2394,7 @@ "NIL" ] }, - "execution_count": 64, + "execution_count": 87, "metadata": {}, "output_type": "execute_result" } @@ -2380,7 +2405,7 @@ }, { "cell_type": "code", - "execution_count": 64, + "execution_count": 88, "metadata": { "collapsed": false }, @@ -2401,7 +2426,7 @@ "NIL" ] }, - "execution_count": 64, + "execution_count": 88, "metadata": {}, "output_type": "execute_result" } @@ -2412,7 +2437,7 @@ }, { "cell_type": "code", - "execution_count": 64, + "execution_count": 89, "metadata": { "collapsed": false }, @@ -2433,7 +2458,7 @@ "NIL" ] }, - "execution_count": 64, + "execution_count": 89, "metadata": {}, "output_type": "execute_result" } @@ -2444,7 +2469,7 @@ }, { "cell_type": "code", - "execution_count": 64, + "execution_count": 90, "metadata": { "collapsed": false }, @@ -2473,7 +2498,7 @@ "(9 8 7)" ] }, - "execution_count": 64, + "execution_count": 90, "metadata": {}, "output_type": "execute_result" } diff --git a/src/combinations.lisp b/src/combinations.lisp index db15957..5665d20 100644 --- a/src/combinations.lisp +++ b/src/combinations.lisp @@ -137,8 +137,8 @@ CMBN Args: (degr &rest rest) Returns a combination of degree DEGR from a sum of terms provided as a sequence CF1 GNRT1 CF2 GNRT2 ... CFn GNRTn of coefficient / generator pairs in REST. -REST can be of arbitrary even length and can be empty, in which case the -combination is an instance of the null combination of degree DEGR. +REST can be of arbitrary length including NIL, in which case the combination +is an instance of the null combination of degree DEGR. ------------------------------------------------------------------------------" (the cmbn (make-cmbn :degr degr From acbfa1ba2cf19a7cc3f9d55a407440be30c27fac Mon Sep 17 00:00:00 2001 From: Gerd Heber Date: Sun, 8 Nov 2015 19:48:31 -0600 Subject: [PATCH 04/15] Resolved issue #67. --- examples/Chapter1.ipynb | 705 ++++++++++++++++++++++------------------ src/macros.lisp | 10 + 2 files changed, 392 insertions(+), 323 deletions(-) diff --git a/examples/Chapter1.ipynb b/examples/Chapter1.ipynb index f0aba9f..36bdacf 100644 --- a/examples/Chapter1.ipynb +++ b/examples/Chapter1.ipynb @@ -22,7 +22,7 @@ " Load 1 ASDF system:\n", " kenzo\n", "; Loading \"kenzo\"\n", - ".\n" + "\n" ] }, { @@ -337,6 +337,13 @@ "(cat:cmbn-non-zero-p comb1)" ] }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "The reader function $\\texttt{cat:cmbn-list}$ gets the list of terms of the combination $\\texttt{cmbn}$. Beware: a term is not a Kenzo object." + ] + }, { "cell_type": "code", "execution_count": 13, @@ -391,7 +398,11 @@ { "data": { "text/plain": [ - "3" + "\"-----------------------------------------------------------------[macro-doc]\n", + "CFFC\n", + "Args: (term)\n", + "Returns the the coefficient (integer) of a term.\n", + "------------------------------------------------------------------------------\"" ] }, "execution_count": 15, @@ -400,7 +411,7 @@ } ], "source": [ - "(cat:cffc term3)" + "(documentation 'cat:cffc 'function)" ] }, { @@ -413,7 +424,7 @@ { "data": { "text/plain": [ - "W" + "3" ] }, "execution_count": 16, @@ -421,13 +432,61 @@ "output_type": "execute_result" } ], + "source": [ + "(cat:cffc term3)" + ] + }, + { + "cell_type": "code", + "execution_count": 17, + "metadata": { + "collapsed": false + }, + "outputs": [ + { + "data": { + "text/plain": [ + "\"-----------------------------------------------------------------[macro-doc]\n", + "GNRT\n", + "Args: (term)\n", + "Returns the the generator of a term.\n", + "------------------------------------------------------------------------------\"" + ] + }, + "execution_count": 17, + "metadata": {}, + "output_type": "execute_result" + } + ], + "source": [ + "(documentation 'cat:gnrt 'function)" + ] + }, + { + "cell_type": "code", + "execution_count": 18, + "metadata": { + "collapsed": false + }, + "outputs": [ + { + "data": { + "text/plain": [ + "W" + ] + }, + "execution_count": 18, + "metadata": {}, + "output_type": "execute_result" + } + ], "source": [ "(cat:gnrt term3)" ] }, { "cell_type": "code", - "execution_count": 17, + "execution_count": 19, "metadata": { "collapsed": false }, @@ -442,7 +501,7 @@ "------------------------------------------------------------------------------\"" ] }, - "execution_count": 17, + "execution_count": 19, "metadata": {}, "output_type": "execute_result" } @@ -453,7 +512,7 @@ }, { "cell_type": "code", - "execution_count": 18, + "execution_count": 20, "metadata": { "collapsed": false }, @@ -470,7 +529,7 @@ "------------------------------------------------------------------------------\n" ] }, - "execution_count": 18, + "execution_count": 20, "metadata": {}, "output_type": "execute_result" } @@ -481,7 +540,7 @@ }, { "cell_type": "code", - "execution_count": 19, + "execution_count": 21, "metadata": { "collapsed": false }, @@ -496,7 +555,7 @@ "------------------------------------------------------------------------------\"" ] }, - "execution_count": 19, + "execution_count": 21, "metadata": {}, "output_type": "execute_result" } @@ -507,7 +566,7 @@ }, { "cell_type": "code", - "execution_count": 20, + "execution_count": 22, "metadata": { "collapsed": false }, @@ -524,7 +583,7 @@ "------------------------------------------------------------------------------\n" ] }, - "execution_count": 20, + "execution_count": 22, "metadata": {}, "output_type": "execute_result" } @@ -535,7 +594,7 @@ }, { "cell_type": "code", - "execution_count": 21, + "execution_count": 23, "metadata": { "collapsed": false }, @@ -553,7 +612,7 @@ "------------------------------------------------------------------------------\"" ] }, - "execution_count": 21, + "execution_count": 23, "metadata": {}, "output_type": "execute_result" } @@ -564,7 +623,7 @@ }, { "cell_type": "code", - "execution_count": 22, + "execution_count": 24, "metadata": { "collapsed": false }, @@ -581,7 +640,7 @@ "------------------------------------------------------------------------------\n" ] }, - "execution_count": 22, + "execution_count": 24, "metadata": {}, "output_type": "execute_result" } @@ -592,7 +651,7 @@ }, { "cell_type": "code", - "execution_count": 23, + "execution_count": 25, "metadata": { "collapsed": false }, @@ -610,7 +669,7 @@ "------------------------------------------------------------------------------\"" ] }, - "execution_count": 23, + "execution_count": 25, "metadata": {}, "output_type": "execute_result" } @@ -621,7 +680,7 @@ }, { "cell_type": "code", - "execution_count": 24, + "execution_count": 26, "metadata": { "collapsed": false }, @@ -638,7 +697,7 @@ "------------------------------------------------------------------------------\"" ] }, - "execution_count": 24, + "execution_count": 26, "metadata": {}, "output_type": "execute_result" } @@ -649,7 +708,7 @@ }, { "cell_type": "code", - "execution_count": 25, + "execution_count": 27, "metadata": { "collapsed": false }, @@ -666,7 +725,7 @@ "------------------------------------------------------------------------------\n" ] }, - "execution_count": 25, + "execution_count": 27, "metadata": {}, "output_type": "execute_result" } @@ -692,7 +751,7 @@ }, { "cell_type": "code", - "execution_count": 26, + "execution_count": 28, "metadata": { "collapsed": false }, @@ -700,10 +759,10 @@ { "data": { "text/plain": [ - "#" + "#" ] }, - "execution_count": 26, + "execution_count": 28, "metadata": {}, "output_type": "execute_result" } @@ -714,7 +773,7 @@ }, { "cell_type": "code", - "execution_count": 27, + "execution_count": 29, "metadata": { "collapsed": false }, @@ -722,10 +781,10 @@ { "data": { "text/plain": [ - "#" + "#" ] }, - "execution_count": 27, + "execution_count": 29, "metadata": {}, "output_type": "execute_result" } @@ -741,7 +800,7 @@ }, { "cell_type": "code", - "execution_count": 28, + "execution_count": 30, "metadata": { "collapsed": false }, @@ -752,7 +811,7 @@ "S0" ] }, - "execution_count": 28, + "execution_count": 30, "metadata": {}, "output_type": "execute_result" } @@ -763,7 +822,7 @@ }, { "cell_type": "code", - "execution_count": 29, + "execution_count": 31, "metadata": { "collapsed": false }, @@ -771,10 +830,10 @@ { "data": { "text/plain": [ - "#" + "#" ] }, - "execution_count": 29, + "execution_count": 31, "metadata": {}, "output_type": "execute_result" } @@ -801,7 +860,7 @@ }, { "cell_type": "code", - "execution_count": 30, + "execution_count": 32, "metadata": { "collapsed": false }, @@ -812,7 +871,7 @@ ":GNRT" ] }, - "execution_count": 30, + "execution_count": 32, "metadata": {}, "output_type": "execute_result" } @@ -823,7 +882,7 @@ }, { "cell_type": "code", - "execution_count": 31, + "execution_count": 33, "metadata": { "collapsed": false }, @@ -834,7 +893,7 @@ "(DIABOLO-FOR-EXAMPLE)" ] }, - "execution_count": 31, + "execution_count": 33, "metadata": {}, "output_type": "execute_result" } @@ -845,7 +904,7 @@ }, { "cell_type": "code", - "execution_count": 32, + "execution_count": 34, "metadata": { "collapsed": false }, @@ -883,64 +942,13 @@ "------------------------------------------------------------------------------\"" ] }, - "execution_count": 32, - "metadata": {}, - "output_type": "execute_result" - } - ], - "source": [ - "(documentation 'cat:build-chcm 'function)" - ] - }, - { - "cell_type": "code", - "execution_count": 33, - "metadata": { - "collapsed": false - }, - "outputs": [ - { - "data": { - "text/plain": [ - "[K1 Chain-Complex]" - ] - }, - "execution_count": 33, - "metadata": {}, - "output_type": "execute_result" - } - ], - "source": [ - "(cat:def diabolo (cat:build-chcm :cmpr diabolo-cmpr :basis diabolo-basis\n", - " :bsgn diabolo-bspn :intr-dffr diabolo-pure-dffr\n", - " :strt diabolo-strt :orgn diabolo-orgn))" - ] - }, - { - "cell_type": "code", - "execution_count": 34, - "metadata": { - "collapsed": false - }, - "outputs": [ - { - "data": { - "text/plain": [ - "\"--------------------------------------------------------------[function-doc]\n", - "CHCM\n", - "Args: (idnm)\n", - "Return from the list *CHCM-LIST* the chain complex instance with Kenzo\n", - "identifier IDNUM or NIL, if it doesn't exist.\n", - "------------------------------------------------------------------------------\"" - ] - }, "execution_count": 34, "metadata": {}, "output_type": "execute_result" } ], "source": [ - "(documentation 'cat:chcm 'function)" + "(documentation 'cat:build-chcm 'function)" ] }, { @@ -962,7 +970,9 @@ } ], "source": [ - "(cat:chcm 1)" + "(cat:def diabolo (cat:build-chcm :cmpr diabolo-cmpr :basis diabolo-basis\n", + " :bsgn diabolo-bspn :intr-dffr diabolo-pure-dffr\n", + " :strt diabolo-strt :orgn diabolo-orgn))" ] }, { @@ -975,7 +985,12 @@ { "data": { "text/plain": [ - "(DIABOLO-FOR-EXAMPLE)" + "\"--------------------------------------------------------------[function-doc]\n", + "CHCM\n", + "Args: (idnm)\n", + "Return from the list *CHCM-LIST* the chain complex instance with Kenzo\n", + "identifier IDNUM or NIL, if it doesn't exist.\n", + "------------------------------------------------------------------------------\"" ] }, "execution_count": 36, @@ -984,7 +999,7 @@ } ], "source": [ - "(cat:orgn diabolo)" + "(documentation 'cat:chcm 'function)" ] }, { @@ -997,7 +1012,7 @@ { "data": { "text/plain": [ - "1" + "[K1 Chain-Complex]" ] }, "execution_count": 37, @@ -1006,7 +1021,7 @@ } ], "source": [ - "(cat:idnm diabolo)" + "(cat:chcm 1)" ] }, { @@ -1019,7 +1034,7 @@ { "data": { "text/plain": [ - "(S0 S1 S2 S3 S4 S5)" + "(DIABOLO-FOR-EXAMPLE)" ] }, "execution_count": 38, @@ -1028,7 +1043,7 @@ } ], "source": [ - "(cat:basis diabolo 0)" + "(cat:orgn diabolo)" ] }, { @@ -1041,7 +1056,7 @@ { "data": { "text/plain": [ - "(S01 S02 S12 S23 S34 S35 S45)" + "1" ] }, "execution_count": 39, @@ -1050,7 +1065,7 @@ } ], "source": [ - "(cat:basis diabolo 1)" + "(cat:idnm diabolo)" ] }, { @@ -1063,7 +1078,7 @@ { "data": { "text/plain": [ - "(S345)" + "(S0 S1 S2 S3 S4 S5)" ] }, "execution_count": 40, @@ -1072,7 +1087,7 @@ } ], "source": [ - "(cat:basis diabolo 2)" + "(cat:basis diabolo 0)" ] }, { @@ -1085,7 +1100,7 @@ { "data": { "text/plain": [ - "NIL" + "(S01 S02 S12 S23 S34 S35 S45)" ] }, "execution_count": 41, @@ -1093,13 +1108,57 @@ "output_type": "execute_result" } ], + "source": [ + "(cat:basis diabolo 1)" + ] + }, + { + "cell_type": "code", + "execution_count": 42, + "metadata": { + "collapsed": false + }, + "outputs": [ + { + "data": { + "text/plain": [ + "(S345)" + ] + }, + "execution_count": 42, + "metadata": {}, + "output_type": "execute_result" + } + ], + "source": [ + "(cat:basis diabolo 2)" + ] + }, + { + "cell_type": "code", + "execution_count": 43, + "metadata": { + "collapsed": false + }, + "outputs": [ + { + "data": { + "text/plain": [ + "NIL" + ] + }, + "execution_count": 43, + "metadata": {}, + "output_type": "execute_result" + } + ], "source": [ "(cat:basis diabolo 10)" ] }, { "cell_type": "code", - "execution_count": 42, + "execution_count": 44, "metadata": { "collapsed": false }, @@ -1115,7 +1174,7 @@ "------------------------------------------------------------------------------\n" ] }, - "execution_count": 42, + "execution_count": 44, "metadata": {}, "output_type": "execute_result" } @@ -1126,7 +1185,7 @@ }, { "cell_type": "code", - "execution_count": 43, + "execution_count": 45, "metadata": { "collapsed": false }, @@ -1139,7 +1198,7 @@ "------------------------------------------------------------------------------\n" ] }, - "execution_count": 43, + "execution_count": 45, "metadata": {}, "output_type": "execute_result" } @@ -1157,7 +1216,7 @@ }, { "cell_type": "code", - "execution_count": 44, + "execution_count": 46, "metadata": { "collapsed": false }, @@ -1168,7 +1227,7 @@ "[K3 Chain-Complex]" ] }, - "execution_count": 44, + "execution_count": 46, "metadata": {}, "output_type": "execute_result" } @@ -1192,7 +1251,7 @@ }, { "cell_type": "code", - "execution_count": 45, + "execution_count": 47, "metadata": { "collapsed": false }, @@ -1207,7 +1266,7 @@ "------------------------------------------------------------------------------\"" ] }, - "execution_count": 45, + "execution_count": 47, "metadata": {}, "output_type": "execute_result" } @@ -1225,7 +1284,7 @@ }, { "cell_type": "code", - "execution_count": 46, + "execution_count": 48, "metadata": { "collapsed": false }, @@ -1236,7 +1295,7 @@ "CIRCLE" ] }, - "execution_count": 46, + "execution_count": 48, "metadata": {}, "output_type": "execute_result" } @@ -1267,7 +1326,7 @@ }, { "cell_type": "code", - "execution_count": 47, + "execution_count": 49, "metadata": { "collapsed": false }, @@ -1324,7 +1383,7 @@ "-----------------------------------------------------------------------------\"" ] }, - "execution_count": 47, + "execution_count": 49, "metadata": {}, "output_type": "execute_result" } @@ -1342,7 +1401,7 @@ }, { "cell_type": "code", - "execution_count": 48, + "execution_count": 50, "metadata": { "collapsed": false }, @@ -1378,7 +1437,7 @@ "------------------------------------------------------------------------------\"" ] }, - "execution_count": 48, + "execution_count": 50, "metadata": {}, "output_type": "execute_result" } @@ -1396,7 +1455,7 @@ }, { "cell_type": "code", - "execution_count": 49, + "execution_count": 51, "metadata": { "collapsed": false }, @@ -1415,7 +1474,7 @@ "NIL" ] }, - "execution_count": 49, + "execution_count": 51, "metadata": {}, "output_type": "execute_result" } @@ -1426,7 +1485,7 @@ }, { "cell_type": "code", - "execution_count": 50, + "execution_count": 52, "metadata": { "collapsed": false }, @@ -1437,7 +1496,7 @@ "[K1 Chain-Complex]" ] }, - "execution_count": 50, + "execution_count": 52, "metadata": {}, "output_type": "execute_result" } @@ -1448,7 +1507,7 @@ }, { "cell_type": "code", - "execution_count": 51, + "execution_count": 53, "metadata": { "collapsed": false }, @@ -1459,7 +1518,7 @@ "[K3 Cohomology-Class on K1 of degree 1]" ] }, - "execution_count": 51, + "execution_count": 53, "metadata": {}, "output_type": "execute_result" } @@ -1476,7 +1535,7 @@ }, { "cell_type": "code", - "execution_count": 52, + "execution_count": 54, "metadata": { "collapsed": false }, @@ -1487,7 +1546,7 @@ "[K4 Cohomology-Class on K1 of degree 0]" ] }, - "execution_count": 52, + "execution_count": 54, "metadata": {}, "output_type": "execute_result" } @@ -1510,7 +1569,7 @@ }, { "cell_type": "code", - "execution_count": 53, + "execution_count": 55, "metadata": { "collapsed": false }, @@ -1518,10 +1577,10 @@ { "data": { "text/plain": [ - "#" + "#" ] }, - "execution_count": 53, + "execution_count": 55, "metadata": {}, "output_type": "execute_result" } @@ -1535,7 +1594,7 @@ }, { "cell_type": "code", - "execution_count": 54, + "execution_count": 56, "metadata": { "collapsed": false }, @@ -1546,7 +1605,7 @@ "[K5 Chain-Complex]" ] }, - "execution_count": 54, + "execution_count": 56, "metadata": {}, "output_type": "execute_result" } @@ -1562,7 +1621,7 @@ }, { "cell_type": "code", - "execution_count": 55, + "execution_count": 57, "metadata": { "collapsed": false }, @@ -1573,7 +1632,7 @@ "[K7 Morphism (degree 1): K5 -> K5]" ] }, - "execution_count": 55, + "execution_count": 57, "metadata": {}, "output_type": "execute_result" } @@ -1587,7 +1646,7 @@ }, { "cell_type": "code", - "execution_count": 56, + "execution_count": 58, "metadata": { "collapsed": false }, @@ -1598,7 +1657,7 @@ "[K8 Morphism (degree -1): K5 -> K5]" ] }, - "execution_count": 56, + "execution_count": 58, "metadata": {}, "output_type": "execute_result" } @@ -1612,7 +1671,7 @@ }, { "cell_type": "code", - "execution_count": 57, + "execution_count": 59, "metadata": { "collapsed": false }, @@ -1626,7 +1685,7 @@ "------------------------------------------------------------------------------\n" ] }, - "execution_count": 57, + "execution_count": 59, "metadata": {}, "output_type": "execute_result" } @@ -1637,7 +1696,7 @@ }, { "cell_type": "code", - "execution_count": 58, + "execution_count": 60, "metadata": { "collapsed": false }, @@ -1650,7 +1709,7 @@ "------------------------------------------------------------------------------\n" ] }, - "execution_count": 58, + "execution_count": 60, "metadata": {}, "output_type": "execute_result" } @@ -1661,7 +1720,7 @@ }, { "cell_type": "code", - "execution_count": 59, + "execution_count": 61, "metadata": { "collapsed": false }, @@ -1677,7 +1736,7 @@ "------------------------------------------------------------------------------\n" ] }, - "execution_count": 59, + "execution_count": 61, "metadata": {}, "output_type": "execute_result" } @@ -1688,7 +1747,7 @@ }, { "cell_type": "code", - "execution_count": 60, + "execution_count": 62, "metadata": { "collapsed": false }, @@ -1703,62 +1762,13 @@ "------------------------------------------------------------------------------\n" ] }, - "execution_count": 60, - "metadata": {}, - "output_type": "execute_result" - } - ], - "source": [ - "(cat:? ccn combn)" - ] - }, - { - "cell_type": "code", - "execution_count": 61, - "metadata": { - "collapsed": false - }, - "outputs": [ - { - "data": { - "text/plain": [ - "\n", - "----------------------------------------------------------------------{CMBN 3}\n", - "------------------------------------------------------------------------------\n" - ] - }, - "execution_count": 61, - "metadata": {}, - "output_type": "execute_result" - } - ], - "source": [ - "(cat:? ccn (cat:? ccn combn))" - ] - }, - { - "cell_type": "code", - "execution_count": 62, - "metadata": { - "collapsed": false - }, - "outputs": [ - { - "data": { - "text/plain": [ - "\n", - "----------------------------------------------------------------------{CMBN 1}\n", - "<1 * 16>\n", - "------------------------------------------------------------------------------\n" - ] - }, "execution_count": 62, "metadata": {}, "output_type": "execute_result" } ], "source": [ - "(cat:? upper-shift 0 6)" + "(cat:? ccn combn)" ] }, { @@ -1772,8 +1782,7 @@ "data": { "text/plain": [ "\n", - "----------------------------------------------------------------------{CMBN 4}\n", - "<1 * 41>\n", + "----------------------------------------------------------------------{CMBN 3}\n", "------------------------------------------------------------------------------\n" ] }, @@ -1783,7 +1792,7 @@ } ], "source": [ - "(cat:? lower-shift 5 51)" + "(cat:? ccn (cat:? ccn combn))" ] }, { @@ -1797,8 +1806,8 @@ "data": { "text/plain": [ "\n", - "----------------------------------------------------------------------{CMBN 3}\n", - "<1 * 31>\n", + "----------------------------------------------------------------------{CMBN 1}\n", + "<1 * 16>\n", "------------------------------------------------------------------------------\n" ] }, @@ -1808,7 +1817,7 @@ } ], "source": [ - "(cat:? lower-shift (cat:? lower-shift 5 51))" + "(cat:? upper-shift 0 6)" ] }, { @@ -1822,11 +1831,8 @@ "data": { "text/plain": [ "\n", - "----------------------------------------------------------------------{CMBN 1}\n", - "<1 * 10>\n", - "<2 * 11>\n", - "<3 * 12>\n", - "<4 * 13>\n", + "----------------------------------------------------------------------{CMBN 4}\n", + "<1 * 41>\n", "------------------------------------------------------------------------------\n" ] }, @@ -1836,7 +1842,7 @@ } ], "source": [ - "(cat:def comb1 (cat:cmbn 1 1 10 2 11 3 12 4 13))" + "(cat:? lower-shift 5 51)" ] }, { @@ -1849,7 +1855,10 @@ { "data": { "text/plain": [ - "[K9 Morphism (degree 0): K5 -> K5]" + "\n", + "----------------------------------------------------------------------{CMBN 3}\n", + "<1 * 31>\n", + "------------------------------------------------------------------------------\n" ] }, "execution_count": 66, @@ -1858,7 +1867,7 @@ } ], "source": [ - "(cat:def identity? (cat:cmps upper-shift lower-shift))" + "(cat:? lower-shift (cat:? lower-shift 5 51))" ] }, { @@ -1867,28 +1876,6 @@ "metadata": { "collapsed": false }, - "outputs": [ - { - "data": { - "text/plain": [ - "0" - ] - }, - "execution_count": 67, - "metadata": {}, - "output_type": "execute_result" - } - ], - "source": [ - "(cat:degr identity?)" - ] - }, - { - "cell_type": "code", - "execution_count": 68, - "metadata": { - "collapsed": false - }, "outputs": [ { "data": { @@ -1902,13 +1889,35 @@ "------------------------------------------------------------------------------\n" ] }, + "execution_count": 67, + "metadata": {}, + "output_type": "execute_result" + } + ], + "source": [ + "(cat:def comb1 (cat:cmbn 1 1 10 2 11 3 12 4 13))" + ] + }, + { + "cell_type": "code", + "execution_count": 68, + "metadata": { + "collapsed": false + }, + "outputs": [ + { + "data": { + "text/plain": [ + "[K9 Morphism (degree 0): K5 -> K5]" + ] + }, "execution_count": 68, "metadata": {}, "output_type": "execute_result" } ], "source": [ - "(cat:? identity? comb1)" + "(cat:def identity? (cat:cmps upper-shift lower-shift))" ] }, { @@ -1921,9 +1930,7 @@ { "data": { "text/plain": [ - "\n", - "----------------------------------------------------------------------{CMBN 1}\n", - "------------------------------------------------------------------------------\n" + "0" ] }, "execution_count": 69, @@ -1932,7 +1939,7 @@ } ], "source": [ - "(cat:2cmbn-sbtr (cat:cmpr ccn) comb1 (cat:? identity? comb1))" + "(cat:degr identity?)" ] }, { @@ -1945,7 +1952,13 @@ { "data": { "text/plain": [ - "[K10 Morphism (degree 2): K5 -> K5]" + "\n", + "----------------------------------------------------------------------{CMBN 1}\n", + "<1 * 10>\n", + "<2 * 11>\n", + "<3 * 12>\n", + "<4 * 13>\n", + "------------------------------------------------------------------------------\n" ] }, "execution_count": 70, @@ -1954,7 +1967,7 @@ } ], "source": [ - "(cat:def upper-shift2 (cat:cmps upper-shift upper-shift))" + "(cat:? identity? comb1)" ] }, { @@ -1967,7 +1980,9 @@ { "data": { "text/plain": [ - "2" + "\n", + "----------------------------------------------------------------------{CMBN 1}\n", + "------------------------------------------------------------------------------\n" ] }, "execution_count": 71, @@ -1975,13 +1990,57 @@ "output_type": "execute_result" } ], + "source": [ + "(cat:2cmbn-sbtr (cat:cmpr ccn) comb1 (cat:? identity? comb1))" + ] + }, + { + "cell_type": "code", + "execution_count": 72, + "metadata": { + "collapsed": false + }, + "outputs": [ + { + "data": { + "text/plain": [ + "[K10 Morphism (degree 2): K5 -> K5]" + ] + }, + "execution_count": 72, + "metadata": {}, + "output_type": "execute_result" + } + ], + "source": [ + "(cat:def upper-shift2 (cat:cmps upper-shift upper-shift))" + ] + }, + { + "cell_type": "code", + "execution_count": 73, + "metadata": { + "collapsed": false + }, + "outputs": [ + { + "data": { + "text/plain": [ + "2" + ] + }, + "execution_count": 73, + "metadata": {}, + "output_type": "execute_result" + } + ], "source": [ "(cat:degr upper-shift2)" ] }, { "cell_type": "code", - "execution_count": 72, + "execution_count": 74, "metadata": { "collapsed": false }, @@ -1998,7 +2057,7 @@ "------------------------------------------------------------------------------\n" ] }, - "execution_count": 72, + "execution_count": 74, "metadata": {}, "output_type": "execute_result" } @@ -2009,7 +2068,7 @@ }, { "cell_type": "code", - "execution_count": 73, + "execution_count": 75, "metadata": { "collapsed": false }, @@ -2020,7 +2079,7 @@ "[K11 Morphism (degree 1): K5 -> K5]" ] }, - "execution_count": 73, + "execution_count": 75, "metadata": {}, "output_type": "execute_result" } @@ -2031,7 +2090,7 @@ }, { "cell_type": "code", - "execution_count": 74, + "execution_count": 76, "metadata": { "collapsed": false }, @@ -2042,7 +2101,7 @@ "1" ] }, - "execution_count": 74, + "execution_count": 76, "metadata": {}, "output_type": "execute_result" } @@ -2053,7 +2112,7 @@ }, { "cell_type": "code", - "execution_count": 75, + "execution_count": 77, "metadata": { "collapsed": false }, @@ -2070,57 +2129,13 @@ "------------------------------------------------------------------------------\n" ] }, - "execution_count": 75, - "metadata": {}, - "output_type": "execute_result" - } - ], - "source": [ - "(cat:? twice-up-shift comb1)" - ] - }, - { - "cell_type": "code", - "execution_count": 76, - "metadata": { - "collapsed": false - }, - "outputs": [ - { - "data": { - "text/plain": [ - "[K12 Morphism (degree 0): K5 -> K5]" - ] - }, - "execution_count": 76, - "metadata": {}, - "output_type": "execute_result" - } - ], - "source": [ - "(cat:def up-d (cat:cmps upper-shift (cat:dffr1 ccn)))" - ] - }, - { - "cell_type": "code", - "execution_count": 77, - "metadata": { - "collapsed": false - }, - "outputs": [ - { - "data": { - "text/plain": [ - "[K13 Morphism (degree 0): K5 -> K5]" - ] - }, "execution_count": 77, "metadata": {}, "output_type": "execute_result" } ], "source": [ - "(cat:def d-up (cat:cmps (cat:dffr1 ccn) upper-shift))" + "(cat:? twice-up-shift comb1)" ] }, { @@ -2133,10 +2148,7 @@ { "data": { "text/plain": [ - "\n", - "----------------------------------------------------------------------{CMBN 1}\n", - "<1 * 11>\n", - "------------------------------------------------------------------------------\n" + "[K12 Morphism (degree 0): K5 -> K5]" ] }, "execution_count": 78, @@ -2145,7 +2157,7 @@ } ], "source": [ - "(cat:? up-d 1 11)" + "(cat:def up-d (cat:cmps upper-shift (cat:dffr1 ccn)))" ] }, { @@ -2158,9 +2170,7 @@ { "data": { "text/plain": [ - "\n", - "----------------------------------------------------------------------{CMBN 1}\n", - "------------------------------------------------------------------------------\n" + "[K13 Morphism (degree 0): K5 -> K5]" ] }, "execution_count": 79, @@ -2169,7 +2179,7 @@ } ], "source": [ - "(cat:? d-up 1 11)" + "(cat:def d-up (cat:cmps (cat:dffr1 ccn) upper-shift))" ] }, { @@ -2184,12 +2194,7 @@ "text/plain": [ "\n", "----------------------------------------------------------------------{CMBN 1}\n", - "<1 * 10>\n", - "<2 * 11>\n", - "<3 * 12>\n", - "<4 * 13>\n", - "<5 * 14>\n", - "<6 * 15>\n", + "<1 * 11>\n", "------------------------------------------------------------------------------\n" ] }, @@ -2199,7 +2204,7 @@ } ], "source": [ - "(cat:def comb3 (cat:cmbn 1 1 10 2 11 3 12 4 13 5 14 6 15))" + "(cat:? up-d 1 11)" ] }, { @@ -2214,9 +2219,6 @@ "text/plain": [ "\n", "----------------------------------------------------------------------{CMBN 1}\n", - "<2 * 11>\n", - "<4 * 13>\n", - "<6 * 15>\n", "------------------------------------------------------------------------------\n" ] }, @@ -2226,7 +2228,7 @@ } ], "source": [ - "(cat:? up-d comb3)" + "(cat:? d-up 1 11)" ] }, { @@ -2235,6 +2237,63 @@ "metadata": { "collapsed": false }, + "outputs": [ + { + "data": { + "text/plain": [ + "\n", + "----------------------------------------------------------------------{CMBN 1}\n", + "<1 * 10>\n", + "<2 * 11>\n", + "<3 * 12>\n", + "<4 * 13>\n", + "<5 * 14>\n", + "<6 * 15>\n", + "------------------------------------------------------------------------------\n" + ] + }, + "execution_count": 82, + "metadata": {}, + "output_type": "execute_result" + } + ], + "source": [ + "(cat:def comb3 (cat:cmbn 1 1 10 2 11 3 12 4 13 5 14 6 15))" + ] + }, + { + "cell_type": "code", + "execution_count": 83, + "metadata": { + "collapsed": false + }, + "outputs": [ + { + "data": { + "text/plain": [ + "\n", + "----------------------------------------------------------------------{CMBN 1}\n", + "<2 * 11>\n", + "<4 * 13>\n", + "<6 * 15>\n", + "------------------------------------------------------------------------------\n" + ] + }, + "execution_count": 83, + "metadata": {}, + "output_type": "execute_result" + } + ], + "source": [ + "(cat:? up-d comb3)" + ] + }, + { + "cell_type": "code", + "execution_count": 84, + "metadata": { + "collapsed": false + }, "outputs": [ { "data": { @@ -2247,7 +2306,7 @@ "------------------------------------------------------------------------------\n" ] }, - "execution_count": 82, + "execution_count": 84, "metadata": {}, "output_type": "execute_result" } @@ -2265,7 +2324,7 @@ }, { "cell_type": "code", - "execution_count": 83, + "execution_count": 85, "metadata": { "collapsed": false }, @@ -2276,7 +2335,7 @@ "[K1 Chain-Complex]" ] }, - "execution_count": 83, + "execution_count": 85, "metadata": {}, "output_type": "execute_result" } @@ -2287,7 +2346,7 @@ }, { "cell_type": "code", - "execution_count": 84, + "execution_count": 86, "metadata": { "collapsed": false }, @@ -2308,7 +2367,7 @@ "NIL" ] }, - "execution_count": 84, + "execution_count": 86, "metadata": {}, "output_type": "execute_result" } @@ -2319,7 +2378,7 @@ }, { "cell_type": "code", - "execution_count": 85, + "execution_count": 87, "metadata": { "collapsed": false }, @@ -2330,7 +2389,7 @@ "[K3 Cohomology-Class on K1 of degree 1]" ] }, - "execution_count": 85, + "execution_count": 87, "metadata": {}, "output_type": "execute_result" } @@ -2341,7 +2400,7 @@ }, { "cell_type": "code", - "execution_count": 86, + "execution_count": 88, "metadata": { "collapsed": false }, @@ -2362,7 +2421,7 @@ "NIL" ] }, - "execution_count": 86, + "execution_count": 88, "metadata": {}, "output_type": "execute_result" } @@ -2373,7 +2432,7 @@ }, { "cell_type": "code", - "execution_count": 87, + "execution_count": 89, "metadata": { "collapsed": false }, @@ -2394,7 +2453,7 @@ "NIL" ] }, - "execution_count": 87, + "execution_count": 89, "metadata": {}, "output_type": "execute_result" } @@ -2405,7 +2464,7 @@ }, { "cell_type": "code", - "execution_count": 88, + "execution_count": 90, "metadata": { "collapsed": false }, @@ -2426,7 +2485,7 @@ "NIL" ] }, - "execution_count": 88, + "execution_count": 90, "metadata": {}, "output_type": "execute_result" } @@ -2437,7 +2496,7 @@ }, { "cell_type": "code", - "execution_count": 89, + "execution_count": 91, "metadata": { "collapsed": false }, @@ -2458,7 +2517,7 @@ "NIL" ] }, - "execution_count": 89, + "execution_count": 91, "metadata": {}, "output_type": "execute_result" } @@ -2469,7 +2528,7 @@ }, { "cell_type": "code", - "execution_count": 90, + "execution_count": 92, "metadata": { "collapsed": false }, @@ -2498,7 +2557,7 @@ "(9 8 7)" ] }, - "execution_count": 90, + "execution_count": 92, "metadata": {}, "output_type": "execute_result" } diff --git a/src/macros.lisp b/src/macros.lisp index 5980920..0fefbb2 100644 --- a/src/macros.lisp +++ b/src/macros.lisp @@ -76,6 +76,11 @@ and returns VALUE. (DEFMACRO CFFC (term) + "-----------------------------------------------------------------[macro-doc] +CFFC +Args: (term) +Returns the the coefficient (integer) of a term. +------------------------------------------------------------------------------" `(car ,term)) @@ -84,6 +89,11 @@ and returns VALUE. (DEFMACRO GNRT (term) + "-----------------------------------------------------------------[macro-doc] +GNRT +Args: (term) +Returns the the generator of a term. +------------------------------------------------------------------------------" `(cdr ,term)) From 1e09c2e8ccaf0bc7158dfcf4523a99eadcae0cbb Mon Sep 17 00:00:00 2001 From: Gerd Heber Date: Sun, 8 Nov 2015 20:22:08 -0600 Subject: [PATCH 05/15] Resolved issue #72. --- examples/Chapter2.ipynb | 32 ++++++++++++++++++-------------- src/classes.lisp | 15 ++++++++------- src/effective-homology.lisp | 9 ++++++--- 3 files changed, 32 insertions(+), 24 deletions(-) diff --git a/examples/Chapter2.ipynb b/examples/Chapter2.ipynb index 0b576ba..51e1a1b 100644 --- a/examples/Chapter2.ipynb +++ b/examples/Chapter2.ipynb @@ -15,7 +15,7 @@ " Load 1 ASDF system:\n", " kenzo\n", "; Loading \"kenzo\"\n", - "\n" + "..\n" ] }, { @@ -102,21 +102,22 @@ "2. BCC, an object of type CHAIN-COMPLEX, the bottom chain complex C. Its reader\n", " function is BCC1.\n", "\n", - "3. F, an object of type MORPHISM representing the morphism f. Its reader\n", + "3. F, an object of type MORPHISM representing the chain morphism f. Its reader\n", " function is F1.\n", "\n", - "4. G, an object of type MORPHISM representing the morphism g. Its reader\n", + "4. G, an object of type MORPHISM representing the chain morphism g. Its reader\n", " function is G1.\n", "\n", - "5. H, an object of type MORPHISM representing the morphism h. Its reader\n", - " function is H1.\n", + "5. H, an object of type MORPHISM representing the morphism of graded modules h.\n", + " Its reader function is H1.\n", "\n", "9. IDNM, an integer, a system-generated identifier for this object. Its reader\n", " function is IDNM.\n", "\n", - "10. ORGN, a list containg a comment indicating the origin of the object. The\n", - " should be unique (per session), since it is used in the implementation for\n", - " caching purposes. Its reader function is ORGN.\n", + "10. ORGN, a list containg a comment indicating the origin of the object.\n", + " This comment should be unique for a Kenzo session (between calls of\n", + " CAT-INIT), as it is used for caching purposes. Its reader function\n", + " is ORGN.\n", "-----------------------------------------------------------------------------\"" ] }, @@ -152,11 +153,14 @@ "Returns an instance of the class REDUCTION. The keyword arguments are as\n", "follows:\n", "\n", - ":F F, an object of type morphism representing the morphism f of a reduction\n", + ":F F, an object of type MORPHISM representing the chain morphism f of a\n", + " reduction\n", "\n", - ":G G, an object of type morphism representing the morphism g of a reduction\n", + ":G G, an object of type MORPHISM representing the chain morphism g of a\n", + " reduction\n", "\n", - ":H H, an object of type morphism representing the morphism h of a reduction\n", + ":H H, an object of type MORPHISM representing the morphism of graded modules h\n", + " of a reduction\n", "\n", ":ORGN ORGN, a list containing a relevant and carefully chosen comment about\n", " the origin of the chain complex. This comment should be unique\n", @@ -1214,7 +1218,7 @@ "cell_type": "markdown", "metadata": {}, "source": [ - "## 2.6 Construction of abicone from 2 reductions\n", + "## 2.6 Construction of a bicone from 2 reductions\n", "#### Example" ] }, @@ -2173,7 +2177,7 @@ }, { "cell_type": "code", - "execution_count": 64, + "execution_count": 65, "metadata": { "collapsed": false }, @@ -2253,7 +2257,7 @@ "NIL" ] }, - "execution_count": 64, + "execution_count": 65, "metadata": {}, "output_type": "execute_result" } diff --git a/src/classes.lisp b/src/classes.lisp index 8ca3a37..acba52e 100644 --- a/src/classes.lisp +++ b/src/classes.lisp @@ -326,21 +326,22 @@ The class has 7 slots: 2. BCC, an object of type CHAIN-COMPLEX, the bottom chain complex C. Its reader function is BCC1. -3. F, an object of type MORPHISM representing the morphism f. Its reader +3. F, an object of type MORPHISM representing the chain morphism f. Its reader function is F1. -4. G, an object of type MORPHISM representing the morphism g. Its reader +4. G, an object of type MORPHISM representing the chain morphism g. Its reader function is G1. -5. H, an object of type MORPHISM representing the morphism h. Its reader - function is H1. +5. H, an object of type MORPHISM representing the morphism of graded modules h. + Its reader function is H1. 9. IDNM, an integer, a system-generated identifier for this object. Its reader function is IDNM. -10. ORGN, a list containg a comment indicating the origin of the object. The - should be unique (per session), since it is used in the implementation for - caching purposes. Its reader function is ORGN. +10. ORGN, a list containg a comment indicating the origin of the object. + This comment should be unique for a Kenzo session (between calls of + CAT-INIT), as it is used for caching purposes. Its reader function + is ORGN. -----------------------------------------------------------------------------")) diff --git a/src/effective-homology.lisp b/src/effective-homology.lisp index 188dc1c..a99c24d 100644 --- a/src/effective-homology.lisp +++ b/src/effective-homology.lisp @@ -45,11 +45,14 @@ Args: (&key f g h orgn) Returns an instance of the class REDUCTION. The keyword arguments are as follows: -:F F, an object of type morphism representing the morphism f of a reduction +:F F, an object of type MORPHISM representing the chain morphism f of a + reduction -:G G, an object of type morphism representing the morphism g of a reduction +:G G, an object of type MORPHISM representing the chain morphism g of a + reduction -:H H, an object of type morphism representing the morphism h of a reduction +:H H, an object of type MORPHISM representing the morphism of graded modules h + of a reduction :ORGN ORGN, a list containing a relevant and carefully chosen comment about the origin of the chain complex. This comment should be unique From bcb4a8539d1d8f06a8bfe51397ce22b084999322 Mon Sep 17 00:00:00 2001 From: Gerd Heber Date: Wed, 11 Nov 2015 19:12:25 -0600 Subject: [PATCH 06/15] Addressed issue #73. --- src/chain-complexes.lisp | 488 ++++++++++++++++++------------------ src/classes.lisp | 27 +- src/effective-homology.lisp | 396 ++++++++++++++--------------- 3 files changed, 461 insertions(+), 450 deletions(-) diff --git a/src/chain-complexes.lisp b/src/chain-complexes.lisp index 1d2f8b2..c6efb70 100644 --- a/src/chain-complexes.lisp +++ b/src/chain-complexes.lisp @@ -31,13 +31,13 @@ Args: () Return the number of user created objects by object type. ------------------------------------------------------------------------------" (mapc #'(lambda (symbol) - (declare (type (or string symbol) symbol)) - (let ((length (length (eval symbol)))) - (declare (fixnum length)) - (setf symbol (symbol-name symbol)) - (setf symbol (subseq symbol 1 (- (length symbol) 6))) - (format t "~%~6D ~As" length symbol))) - *list-list*) + (declare (type (or string symbol) symbol)) + (let ((length (length (eval symbol)))) + (declare (fixnum length)) + (setf symbol (symbol-name symbol)) + (setf symbol (subseq symbol 1 (- (length symbol) 6))) + (format t "~%~6D ~As" length symbol))) + *list-list*) (done)) @@ -48,12 +48,12 @@ Args: () Return a string representation of a user created objects. ------------------------------------------------------------------------------" (let ((object-list - (sort (delete-duplicates - (mapcan #'(lambda (symbol) - (copy-list (eval symbol))) - *list-list*) - :test #'eq) - #'< :key #'idnm))) + (sort (delete-duplicates + (mapcan #'(lambda (symbol) + (copy-list (eval symbol))) + *list-list*) + :test #'eq) + #'< :key #'idnm))) (declare (list object-list)) (dolist (item object-list) (format t "~%~A = ~A" item (orgn item)))) @@ -71,9 +71,9 @@ Return the type of Kenzo object number IDNM and print the comment list (dolist (list *list-list*) (let ((found (find idnm (eval list) :key #'idnm))) (when found - (format t "~%Object: ~A + (format t "~%Object: ~A ~3TOrigin: ~A~2%" found (orgn found)) - (return-from kd (values)))))) + (return-from kd (values)))))) (DEFUN K (idnm) @@ -86,7 +86,7 @@ Returns the IDNM-th Kenzo object. (dolist (list *list-list*) (let ((found (find idnm (eval list) :key #'idnm))) (when found - (return-from k found))))) + (return-from k found))))) (DEFUN KD2 (idnm) @@ -104,16 +104,16 @@ the list of object numbers. (return-from kd2 nil)) (setf k-list (list k-list)) (do ((idnm (1- idnm) (1- idnm))) - ((zerop idnm)) + ((zerop idnm)) (declare (fixnum idnm)) (let ((found (find-if - #'(lambda (item) - (declare (type (or chain-complex morphism) item)) - (member (k idnm) (orgn item))) - k-list))) - (declare (type (or null chain-complex morphism) found)) - (when found - (push (k idnm) k-list)))) + #'(lambda (item) + (declare (type (or chain-complex morphism) item)) + (member (k idnm) (orgn item))) + k-list))) + (declare (type (or null chain-complex morphism) found)) + (when found + (push (k idnm) k-list)))) (mapc #'kd (nreverse (mapcar #'idnm k-list))))) @@ -122,8 +122,8 @@ the list of object numbers. (DEFMETHOD PRINT-OBJECT ((chcm chain-complex) stream) (the chain-complex (progn - (format stream "[K~D Chain-Complex]" (idnm chcm)) - chcm))) + (format stream "[K~D Chain-Complex]" (idnm chcm)) + chcm))) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute) (setf (ext:package-lock :clos) t)) @@ -149,8 +149,8 @@ identifier IDNUM or NIL, if it doesn't exist. ~3TVALUE-> ~A ~4TCLNM-> ~6D ~4TRNTM-> ~11,3F" - (result-gnrt result) (result-value result) - (result-clnm result) (result-rntm result)) + (result-gnrt result) (result-value result) + (result-clnm result) (result-rntm result)) result) @@ -193,12 +193,12 @@ identifier IDNUM or NIL, if it doesn't exist. (DEFMETHOD PRINT-OBJECT ((mrph morphism) stream) (the morphism (progn - (if (eq (first (orgn (trgt mrph))) 'z-chcm) - (format stream "[K~D Cohomology-Class on K~D of degree ~D]" - (idnm mrph) (idnm (sorc mrph)) (- (degr mrph))) - (format stream "[K~D Morphism (degree ~D): K~D -> K~D]" - (idnm mrph) (degr mrph) - (idnm (sorc mrph)) (idnm (trgt mrph)))) + (if (eq (first (orgn (trgt mrph))) 'z-chcm) + (format stream "[K~D Cohomology-Class on K~D of degree ~D]" + (idnm mrph) (idnm (sorc mrph)) (- (degr mrph))) + (format stream "[K~D Morphism (degree ~D): K~D -> K~D]" + (idnm mrph) (degr mrph) + (idnm (sorc mrph)) (idnm (trgt mrph)))) mrph))) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute) (setf (ext:package-lock :clos) t)) @@ -239,10 +239,12 @@ follows: of the differential homomorphism, either by generator or by combination. The default is :GNRT -:ORGN ORGN, a list containing a relevant and carefully chosen comment about - the origin of the chain complex. This comment should be unique - for a Kenzo session (between calls of CAT-INIT), as it is used - for caching purposes. +:ORGN ORGN, a list which is the copy of a Lisp statement, in principle the + statement which was at the origin of the creation of this Kenzo + object. A caching process, using this slot, prevents the creation + of multiple copies of the same mathematical object, which is + important for efficiency. It is used also for debugging and + analyzing the program. Use this function instead of creating instances via the standard constructor MAKE-INSTANCE. @@ -250,25 +252,25 @@ MAKE-INSTANCE. (the chain-complex (progn (let ((already (find orgn *chcm-list* :test #'equal :key #'orgn))) - (declare (type (or chain-complex null) already)) - (when already - (return-from build-chcm already))) + (declare (type (or chain-complex null) already)) + (when already + (return-from build-chcm already))) (unless basis - (setf basis :locally-effective)) + (setf basis :locally-effective)) (let ((chcm (make-instance 'chain-complex - :cmpr cmpr - :basis basis - :bsgn bsgn - :orgn orgn))) - (declare (type chain-complex chcm)) - (setf (slot-value chcm 'dffr) - (build-mrph - :sorc chcm :trgt chcm :degr -1 - :intr intr-dffr :strt strt - :orgn `(dffr ,chcm))) - (setf (slot-value chcm 'grmd) chcm) - (push chcm *chcm-list*) - chcm)))) + :cmpr cmpr + :basis basis + :bsgn bsgn + :orgn orgn))) + (declare (type chain-complex chcm)) + (setf (slot-value chcm 'dffr) + (build-mrph + :sorc chcm :trgt chcm :degr -1 + :intr intr-dffr :strt strt + :orgn `(dffr ,chcm))) + (setf (slot-value chcm 'grmd) chcm) + (push chcm *chcm-list*) + chcm)))) (DEFUN BASIS2 (object n) ;;; @@ -279,7 +281,7 @@ MAKE-INSTANCE. (with-slots (basis) object (declare (type basis basis)) (when (eq :locally-effective basis) - (error "The object ~A is locally-effective." object)) + (error "The object ~A is locally-effective." object)) (funcall basis n)))) @@ -308,10 +310,12 @@ follows: of the differential homomorphism, either by generator or by combination. The default is :GNRT -:ORGN ORGN, a list containing a relevant and carefully chosen comment about - the origin of the chain complex. This comment should be unique - for a Kenzo session (between calls of CAT-INIT), as it is used - for caching purposes. +:ORGN ORGN, a list which is the copy of a Lisp statement, in principle the + statement which was at the origin of the creation of this Kenzo + object. A caching process, using this slot, prevents the creation + of multiple copies of the same mathematical object, which is + important for efficiency. It is used also for debugging and + analyzing the program. Use this function instead of creating instances via the standard constructor MAKE-INSTANCE. @@ -319,63 +323,63 @@ MAKE-INSTANCE. (the morphism (progn (let ((already (find orgn *mrph-list* :test #'equal :key #'orgn))) - (declare (type (or morphism null) already)) - (when already - (return-from build-mrph already))) + (declare (type (or morphism null) already)) + (when already + (return-from build-mrph already))) (let ((mrph (make-instance 'morphism - :sorc sorc :trgt trgt :degr degr - :intr intr :strt strt - :orgn orgn))) - (declare (type morphism mrph)) - (setf (slot-value mrph 'rslts) - (ecase strt - (:gnrt (map 'simple-vector + :sorc sorc :trgt trgt :degr degr + :intr intr :strt strt + :orgn orgn))) + (declare (type morphism mrph)) + (setf (slot-value mrph 'rslts) + (ecase strt + (:gnrt (map 'simple-vector ;; (vector (vector result)) #'(lambda (dummy) - (declare (ignore dummy)) - (make-array 0 - :adjustable t - :fill-pointer 0)) + (declare (ignore dummy)) + (make-array 0 + :adjustable t + :fill-pointer 0)) (make-list +maximal-dimension+))) - (:cmbn (make-array 0)))) - (push mrph *mrph-list*) - mrph)))) + (:cmbn (make-array 0)))) + (push mrph *mrph-list*) + mrph)))) ;;; FUNCTIONS (DEFUN NRESULTS () (the fixnum (let ((nrslts 0)) - (declare (fixnum nrslts)) - (dolist (item *mrph-list*) - (declare (type morphism item)) - (when (eq :gnrt (strt item)) - (map nil - #'(lambda (drslt) - (declare (vector drslt)) - (incf nrslts (length drslt))) - (rslts item)))) - nrslts))) + (declare (fixnum nrslts)) + (dolist (item *mrph-list*) + (declare (type morphism item)) + (when (eq :gnrt (strt item)) + (map nil + #'(lambda (drslt) + (declare (vector drslt)) + (incf nrslts (length drslt))) + (rslts item)))) + nrslts))) (DEFUN TIME-LIST () (the list (let ((time-list +empty-list+)) - (declare (list time-list)) - (dolist (item *mrph-list*) - (declare (type morphism item)) - (when (eq :gnrt (strt item)) - (map nil #'(lambda (drslt) - (declare (vector drslt)) - (map nil #'(lambda (rslt) - (declare (type result rslt)) - (let ((rntm (result-rntm rslt))) - (declare (single-float rntm)) - (when (plusp rntm) - (push rntm time-list)))) - drslt)) - (rslts item)))) - (sort time-list #'>)))) + (declare (list time-list)) + (dolist (item *mrph-list*) + (declare (type morphism item)) + (when (eq :gnrt (strt item)) + (map nil #'(lambda (drslt) + (declare (vector drslt)) + (map nil #'(lambda (rslt) + (declare (type result rslt)) + (let ((rntm (result-rntm rslt))) + (declare (single-float rntm)) + (when (plusp rntm) + (push rntm time-list)))) + drslt)) + (rslts item)))) + (sort time-list #'>)))) (DEFUN CLEAN-RESULTS (&optional (results-coef *results-coef*)) @@ -384,35 +388,35 @@ MAKE-INSTANCE. (special *results-coef* *results-cmlt-tm* *results-n* *results-verbose*)) (the (values ) (let ((cut (* results-coef (/ *results-cmlt-tm* *results-n*)))) - (declare (single-float cut)) - (setf *results-n* 0 *results-cmlt-tm* 0.0) - (dolist (item *mrph-list*) - (declare (type morphism item)) - (when (eq :gnrt (strt item)) - (let ((rslts (rslts item))) - (declare (vector rslts)) - (dotimes (i +maximal-dimension+) - (declare (fixnum i)) - (let ((rslts-i (aref rslts i)) - (output (make-array 0 :adjustable t :fill-pointer 0))) - (declare (vector rslts-i output)) - (map nil - #'(lambda (rslt) - (declare (type result rslt)) - (let ((rntm (result-rntm rslt))) - (declare (single-float rntm)) - (when (> rntm cut) - (incf *results-n*) - (incf *results-cmlt-tm* rntm) - (vector-push-extend rslt output)))) - rslts-i) - (setf (aref rslts i) output)))))) - (when *results-verbose* - (format t "~%*CR* -- Cut = ~A -- N = ~A" cut *results-n*))))) + (declare (single-float cut)) + (setf *results-n* 0 *results-cmlt-tm* 0.0) + (dolist (item *mrph-list*) + (declare (type morphism item)) + (when (eq :gnrt (strt item)) + (let ((rslts (rslts item))) + (declare (vector rslts)) + (dotimes (i +maximal-dimension+) + (declare (fixnum i)) + (let ((rslts-i (aref rslts i)) + (output (make-array 0 :adjustable t :fill-pointer 0))) + (declare (vector rslts-i output)) + (map nil + #'(lambda (rslt) + (declare (type result rslt)) + (let ((rntm (result-rntm rslt))) + (declare (single-float rntm)) + (when (> rntm cut) + (incf *results-n*) + (incf *results-cmlt-tm* rntm) + (vector-push-extend rslt output)))) + rslts-i) + (setf (aref rslts i) output)))))) + (when *results-verbose* + (format t "~%*CR* -- Cut = ~A -- N = ~A" cut *results-n*))))) (DEFUN MRPH-GNRT (cmpr2 intr degr gnrt memory - &optional (left -1) (right (fill-pointer memory))) + &optional (left -1) (right (fill-pointer memory))) (declare (type intr-mrph intr) ;; (function (fixnum gnrt) cmbn) @@ -427,47 +431,47 @@ MAKE-INSTANCE. ;; cmbn = image of the generator ;; fixnum = index "exact" or just "lower" of the maybe stored result (loop - (when (= right (1+ left)) ; the result for gnrt is not available - (push (get-internal-run-time) *start-stack*) - (let ((value (funcall intr degr gnrt)) - (runtime (- (get-internal-run-time) (pop *start-stack*)))) - (declare - (type cmbn value) - (integer runtime)) - (if (> runtime +too-much-time+) - ;; the condition deciding whether - ;; storing must happen - (let ((old-length (vector-push-extend nil memory))) - (declare (fixnum old-length)) - (replace memory memory - :start1 (1+ right) :end1 (1+ old-length) - :start2 right :end2 old-length) - (setf (aref memory right) - (make-result - :gnrt gnrt :value value :clnm 1 - :rntm (let ((rntm - (float - (/ runtime - internal-time-units-per-second)))) - (declare (single-float rntm)) - (incf *results-cmlt-tm* rntm) - rntm))) - (mapl #'(lambda (mark) - (declare (cons mark)) - (incf (car mark) runtime)) - *start-stack*) - (when (> (incf *results-n*) *results-max*) - (clean-results)) - (return (values value right))) - (return (values value left))))) - (let ((middle (truncate (+ right left) 2))) + (when (= right (1+ left)) ; the result for gnrt is not available + (push (get-internal-run-time) *start-stack*) + (let ((value (funcall intr degr gnrt)) + (runtime (- (get-internal-run-time) (pop *start-stack*)))) + (declare + (type cmbn value) + (integer runtime)) + (if (> runtime +too-much-time+) + ;; the condition deciding whether + ;; storing must happen + (let ((old-length (vector-push-extend nil memory))) + (declare (fixnum old-length)) + (replace memory memory + :start1 (1+ right) :end1 (1+ old-length) + :start2 right :end2 old-length) + (setf (aref memory right) + (make-result + :gnrt gnrt :value value :clnm 1 + :rntm (let ((rntm + (float + (/ runtime + internal-time-units-per-second)))) + (declare (single-float rntm)) + (incf *results-cmlt-tm* rntm) + rntm))) + (mapl #'(lambda (mark) + (declare (cons mark)) + (incf (car mark) runtime)) + *start-stack*) + (when (> (incf *results-n*) *results-max*) + (clean-results)) + (return (values value right))) + (return (values value left))))) + (let ((middle (truncate (+ right left) 2))) (declare (fixnum middle)) (ecase (funcall cmpr2 gnrt (result-gnrt (aref memory middle))) - (:equal (let ((rslt (aref memory middle))) - (declare (type result rslt)) - (incf (result-clnm rslt)) - (return (values (result-value rslt) middle)))) - (:less (setf right middle)) + (:equal (let ((rslt (aref memory middle))) + (declare (type result rslt)) + (incf (result-clnm rslt)) + (return (values (result-value rslt) middle)))) + (:less (setf right middle)) (:greater (setf left middle))))))) @@ -481,17 +485,17 @@ MAKE-INSTANCE. ;; (vector result) (the cmbn (with-cmbn (degr list) cmbn - (let ((n-cmbn-list +empty-list+)) - (declare (list n-cmbn-list)) - (do ((mark list (cdr mark)) - (left -1)) - ((endp mark)) - (declare (list mark)) - (multiple-value-bind (rslt new-left) - (mrph-gnrt scmpr2 intr degr (-gnrt mark) memory left) - (setf left new-left) - (push (cons (-cffc mark) rslt) n-cmbn-list))) - (cmbn-cmbn tcmpr2 n-cmbn-list))))) + (let ((n-cmbn-list +empty-list+)) + (declare (list n-cmbn-list)) + (do ((mark list (cdr mark)) + (left -1)) + ((endp mark)) + (declare (list mark)) + (multiple-value-bind (rslt new-left) + (mrph-gnrt scmpr2 intr degr (-gnrt mark) memory left) + (setf left new-left) + (push (cons (-cffc mark) rslt) n-cmbn-list))) + (cmbn-cmbn tcmpr2 n-cmbn-list))))) (DEFUN DO-CONTROL (cmpr cmbn) (declare @@ -501,14 +505,14 @@ MAKE-INSTANCE. (let ((list (cmbn-list cmbn))) (declare (list list)) (do ((mark1 (rest list) (cdr mark1)) - (mark2 list mark1)) - ((endp mark1)) - (declare (list mark1 mark2)) - (unless (eq :less (funcall cmpr (-gnrt mark2) (-gnrt mark1))) - (setf *wrong-cmbn* cmbn) - (error "In the combination located by *WRONG-CMBN*, the generators:~@ + (mark2 list mark1)) + ((endp mark1)) + (declare (list mark1 mark2)) + (unless (eq :less (funcall cmpr (-gnrt mark2) (-gnrt mark1))) + (setf *wrong-cmbn* cmbn) + (error "In the combination located by *WRONG-CMBN*, the generators:~@ ~A and ~A are in a wrong order." (cdar mark2) - (cdar mark1)))))) + (cdar mark1)))))) cmbn) #| @@ -517,9 +521,9 @@ MAKE-INSTANCE. (DEFUN PROFILER-INIT () (mapc #'(lambda (mrph) - (declare (type morphism mrph)) - (setf (wrtm mrph) 0)) - *mrph-list*)) + (declare (type morphism mrph)) + (setf (wrtm mrph) 0)) + *mrph-list*)) (DEFUN PROFILER-ON () (push (get-internal-run-time) *profiler-stack*)) @@ -527,12 +531,12 @@ MAKE-INSTANCE. (DEFUN PROFILER-OFF (mrph) (declare (type morphism mrph)) (let ((time-spent - (- (get-internal-run-time) (pop *profiler-stack*)))) + (- (get-internal-run-time) (pop *profiler-stack*)))) (declare (integer time-spent)) (mapl #'(lambda (mark) - (declare (cons mark)) - (incf (car mark) time-spent)) - *profiler-stack*) + (declare (cons mark)) + (incf (car mark) time-spent)) + *profiler-stack*) (incf (wrtm mrph) time-spent))) |# @@ -544,35 +548,35 @@ MAKE-INSTANCE. (type gnrt gnrt)) (the cmbn (progn - ;; (profiler-on) + ;; (profiler-on) (when (and *future-display* (> (get-internal-run-time) *future-display*)) - (format t "~%GNRT-? + (format t "~%GNRT-? ~3T~A ORGN = ~A ~3TDEGR = ~D ~3TGNRT = ~A" - mrph (orgn mrph) degr gnrt) - (setf *future-display* (+ (get-internal-run-time) *time-interval*))) + mrph (orgn mrph) degr gnrt) + (setf *future-display* (+ (get-internal-run-time) *time-interval*))) (with-slots (sorc (mdegr degr) intr strt ?-clnm) mrph - (declare - (type chain-complex sorc) - (fixnum mdegr ?-clnm) - (type intr-mrph intr) - (type strt strt)) - (with-slots ((scmpr cmpr)) sorc - (declare (type cmprf scmpr)) - (control (slot-value (slot-value mrph 'trgt) 'cmpr) - (progn - (incf ?-clnm) - (prog1 - (ecase strt - (:gnrt - (mrph-gnrt scmpr intr - degr gnrt (svref (rslts mrph) degr))) - (:cmbn - (funcall intr (term-cmbn degr 1 gnrt)))) - ;; (profiler-off mrph) - )))))))) + (declare + (type chain-complex sorc) + (fixnum mdegr ?-clnm) + (type intr-mrph intr) + (type strt strt)) + (with-slots ((scmpr cmpr)) sorc + (declare (type cmprf scmpr)) + (control (slot-value (slot-value mrph 'trgt) 'cmpr) + (progn + (incf ?-clnm) + (prog1 + (ecase strt + (:gnrt + (mrph-gnrt scmpr intr + degr gnrt (svref (rslts mrph) degr))) + (:cmbn + (funcall intr (term-cmbn degr 1 gnrt)))) + ;; (profiler-off mrph) + )))))))) (DEFUN CMBN-? (mrph cmbn) @@ -581,35 +585,35 @@ MAKE-INSTANCE. (type cmbn cmbn)) (the cmbn (progn - ;; (profiler-on) + ;; (profiler-on) (when (and *future-display* (> (get-internal-run-time) *future-display*)) - (format t "~%CMBN-? + (format t "~%CMBN-? ~3T~A ORGN = ~A ~3TCMBN = ~A" - mrph (orgn mrph) cmbn) - (setf *future-display* (+ (get-internal-run-time) *time-interval*))) + mrph (orgn mrph) cmbn) + (setf *future-display* (+ (get-internal-run-time) *time-interval*))) (with-slots (sorc trgt degr intr strt ???-clnm) mrph - (declare - (type chain-complex sorc trgt) - (fixnum degr ???-clnm) - (type intr-mrph intr) - (type strt strt)) - (with-slots ((scmpr cmpr)) sorc - (declare (type cmprf scmpr)) - (with-slots ((tcmpr cmpr)) trgt - (declare (type cmprf tcmpr)) - (control tcmpr - (progn - (controln scmpr cmbn) - (incf ???-clnm) - (when (eq strt :cmbn) - (return-from cmbn-? (funcall intr cmbn))) - (prog1 - (if (cmbn-zero-p cmbn) - (zero-cmbn (+ (cmbn-degr cmbn) degr)) - (mrph-cmbn scmpr tcmpr intr - cmbn (svref (rslts mrph) - (cmbn-degr cmbn)))) - ;; (profiler-off mrph) - ))))))))) + (declare + (type chain-complex sorc trgt) + (fixnum degr ???-clnm) + (type intr-mrph intr) + (type strt strt)) + (with-slots ((scmpr cmpr)) sorc + (declare (type cmprf scmpr)) + (with-slots ((tcmpr cmpr)) trgt + (declare (type cmprf tcmpr)) + (control tcmpr + (progn + (controln scmpr cmbn) + (incf ???-clnm) + (when (eq strt :cmbn) + (return-from cmbn-? (funcall intr cmbn))) + (prog1 + (if (cmbn-zero-p cmbn) + (zero-cmbn (+ (cmbn-degr cmbn) degr)) + (mrph-cmbn scmpr tcmpr intr + cmbn (svref (rslts mrph) + (cmbn-degr cmbn)))) + ;; (profiler-off mrph) + ))))))))) diff --git a/src/classes.lisp b/src/classes.lisp index acba52e..41b2cbe 100644 --- a/src/classes.lisp +++ b/src/classes.lisp @@ -192,9 +192,11 @@ Intances of this class represent chain complexes. The class has 8 slots: 7. IDNM, an integer, a system generated identifier for this object. Its reader function is IDNM. -8. ORGN, a list containg a comment indicating the origin of the object. The - should be unique (per session), since it is used in the implementation for - caching purposes. Its reader function is ORGN. +8. ORGN, a list which is the copy of a Lisp statement, in principle the + statement which was at the origin of the creation of this Kenzo object. + A caching process, using this slot, prevents the creation of multiple + copies of the same mathematical object, which is important for efficiency. + It is used also for debugging and analyzing the program. -----------------------------------------------------------------------------")) @@ -275,9 +277,11 @@ degree -1. The class has 10 slots: 9. IDNM, an integer, a system-generated identifier for this object. Its reader function is IDNM. -10. ORGN, a list containg a comment indicating the origin of the object. The - should be unique (per session), since it is used in the implementation for - caching purposes. Its reader function is ORGN. +10. ORGN, a list which is the copy of a Lisp statement, in principle the + statement which was at the origin of the creation of this Kenzo object. + A caching process, using this slot, prevents the creation of multiple + copies of the same mathematical object, which is important for efficiency. + It is used also for debugging and analyzing the program. -----------------------------------------------------------------------------")) @@ -335,13 +339,14 @@ The class has 7 slots: 5. H, an object of type MORPHISM representing the morphism of graded modules h. Its reader function is H1. -9. IDNM, an integer, a system-generated identifier for this object. Its reader +6. IDNM, an integer, a system-generated identifier for this object. Its reader function is IDNM. -10. ORGN, a list containg a comment indicating the origin of the object. - This comment should be unique for a Kenzo session (between calls of - CAT-INIT), as it is used for caching purposes. Its reader function - is ORGN. +7. ORGN, a list which is the copy of a Lisp statement, in principle the + statement which was at the origin of the creation of this Kenzo object. + A caching process, using this slot, prevents the creation of multiple + copies of the same mathematical object, which is important for efficiency. + It is used also for debugging and analyzing the program. -----------------------------------------------------------------------------")) diff --git a/src/effective-homology.lisp b/src/effective-homology.lisp index a99c24d..d98f79b 100644 --- a/src/effective-homology.lisp +++ b/src/effective-homology.lisp @@ -16,9 +16,9 @@ (DEFMETHOD PRINT-OBJECT ((rdct reduction) stream) (the reduction (progn - (format stream "[K~D Reduction K~D => K~D]" - (idnm rdct) (idnm (tcc rdct)) (idnm (bcc rdct))) - rdct))) + (format stream "[K~D Reduction K~D => K~D]" + (idnm rdct) (idnm (tcc rdct)) (idnm (bcc rdct))) + rdct))) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute) (setf (ext:package-lock :clos) t)) @@ -54,10 +54,12 @@ follows: :H H, an object of type MORPHISM representing the morphism of graded modules h of a reduction -:ORGN ORGN, a list containing a relevant and carefully chosen comment about - the origin of the chain complex. This comment should be unique - for a Kenzo session (between calls of CAT-INIT), as it is used - for caching purposes. +:ORGN ORGN, a list which is the copy of a Lisp statement, in principle the + statement which was at the origin of the creation of this Kenzo + object. A caching process, using this slot, prevents the creation + of multiple copies of the same mathematical object, which is + important for efficiency. It is used also for debugging and + analyzing the program. Use this function instead of creating instances via the standard constructor MAKE-INSTANCE. @@ -65,38 +67,38 @@ MAKE-INSTANCE. (the reduction (progn (unless orgn - (setf orgn `(build-rdct ,f ,g ,h))) + (setf orgn `(build-rdct ,f ,g ,h))) (let ((already (find orgn *rdct-list* :test #'equal :key #'orgn))) - (declare (type (or reduction null) already)) - (when already - (return-from build-rdct already))) + (declare (type (or reduction null) already)) + (when already + (return-from build-rdct already))) (with-slots ((fsorc sorc) (ftrgt trgt) (fdegr degr)) f - (declare - (type chain-complex fsorc ftrgt) - (fixnum fdegr)) - (with-slots ((gsorc sorc) (gtrgt trgt) (gdegr degr)) g - (declare - (type chain-complex gsorc gtrgt) - (fixnum gdegr)) - (with-slots ((hsorc sorc) (htrgt trgt) (hdegr degr)) h - (declare - (type chain-complex hsorc htrgt) - (fixnum hdegr)) - (unless (and (eq gsorc ftrgt) - (eq fsorc gtrgt) - (eq hsorc fsorc) - (eq htrgt fsorc) - (zerop fdegr) - (zerop gdegr) - (= +1 hdegr)) - (error "In BUILD-RDCT, the data are non coherent.")) - (let ((rdct (make-instance 'reduction - :tcc fsorc :bcc ftrgt - :f f :g g :h h - :orgn orgn))) - (declare (type reduction rdct)) - (push rdct *rdct-list*) - rdct))))))) + (declare + (type chain-complex fsorc ftrgt) + (fixnum fdegr)) + (with-slots ((gsorc sorc) (gtrgt trgt) (gdegr degr)) g + (declare + (type chain-complex gsorc gtrgt) + (fixnum gdegr)) + (with-slots ((hsorc sorc) (htrgt trgt) (hdegr degr)) h + (declare + (type chain-complex hsorc htrgt) + (fixnum hdegr)) + (unless (and (eq gsorc ftrgt) + (eq fsorc gtrgt) + (eq hsorc fsorc) + (eq htrgt fsorc) + (zerop fdegr) + (zerop gdegr) + (= +1 hdegr)) + (error "In BUILD-RDCT, the data are non coherent.")) + (let ((rdct (make-instance 'reduction + :tcc fsorc :bcc ftrgt + :f f :g g :h h + :orgn orgn))) + (declare (type reduction rdct)) + (push rdct *rdct-list*) + rdct))))))) (DEFUN TRIVIAL-RDCT (chcm) @@ -142,27 +144,27 @@ See also: ZERO-MRPH, IDNT-MRPH. (the homotopy-equivalence (progn (with-slots ((lf f) (lg g) (lh h) (ltcc tcc) (lbcc bcc)) lrdct - (declare - (type morphism lf lg lh) - (type chain-complex ltcc lbcc)) - (with-slots ((rf f) (rg g) (rh h) (rtcc tcc) (rbcc bcc)) rrdct - (declare - (type morphism rf rg rh) - (type chain-complex rtcc rbcc)) - (unless (eq ltcc rtcc) + (declare + (type morphism lf lg lh) + (type chain-complex ltcc lbcc)) + (with-slots ((rf f) (rg g) (rh h) (rtcc tcc) (rbcc bcc)) rrdct + (declare + (type morphism rf rg rh) + (type chain-complex rtcc rbcc)) + (unless (eq ltcc rtcc) (error "In BUILD-HMEQ (version from rdct), the tcc's are not the same.")) - (unless orgn + (unless orgn (setf orgn `(build-hmeq ,lrdct ,rrdct))) - (let ((already (find orgn *hmeq-list* :test #'equal :key #'orgn))) + (let ((already (find orgn *hmeq-list* :test #'equal :key #'orgn))) (declare (type (or homotopy-equivalence null) already)) (when already - (return-from build-hmeq already))) - (let ((hmeq (make-instance 'homotopy-equivalence - :lbcc lbcc :tcc ltcc :rbcc rbcc - :lf lf :lg lg :lh lh - :rf rf :rg rg :rh rh - :lrdct lrdct :rrdct rrdct - :orgn orgn))) + (return-from build-hmeq already))) + (let ((hmeq (make-instance 'homotopy-equivalence + :lbcc lbcc :tcc ltcc :rbcc rbcc + :lf lf :lg lg :lh lh + :rf rf :rg rg :rh rh + :lrdct lrdct :rrdct rrdct + :orgn orgn))) (declare (type homotopy-equivalence hmeq)) (push hmeq *hmeq-list*) hmeq)))))) @@ -173,10 +175,10 @@ See also: ZERO-MRPH, IDNT-MRPH. (DEFMETHOD PRINT-OBJECT ((hmeq homotopy-equivalence) stream) (the homotopy-equivalence (progn - (format stream "[K~D Homotopy-Equivalence K~D <= K~D => K~D]" - (idnm hmeq) - (idnm (lbcc hmeq)) (idnm (tcc hmeq)) (idnm (rbcc hmeq))) - hmeq))) + (format stream "[K~D Homotopy-Equivalence K~D <= K~D => K~D]" + (idnm hmeq) + (idnm (lbcc hmeq)) (idnm (tcc hmeq)) (idnm (rbcc hmeq))) + hmeq))) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute) (setf (ext:package-lock :clos) t)) @@ -194,16 +196,16 @@ See also: ZERO-MRPH, IDNT-MRPH. (the homotopy-equivalence (progn (unless orgn - (setf orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh))) + (setf orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh))) (let ((already (find orgn *hmeq-list* :test #'equal :key #'orgn))) - (declare (type (or null homotopy-equivalence) already)) - (when already - (return-from build-hmeq already))) + (declare (type (or null homotopy-equivalence) already)) + (when already + (return-from build-hmeq already))) (build-hmeq :lrdct (build-rdct :f lf :g lg :h lh - :orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh lrdct)) + :orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh lrdct)) :rrdct (build-rdct :f rf :g rg :h rh - :orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh rrdct)) + :orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh rrdct)) :orgn orgn)))) (DEFUN TRIVIAL-HMEQ (chcm) @@ -256,21 +258,21 @@ according to these formulas: (type chain-complex bcc tcc) (type morphism f g h)) (setf *tdd* (cmps tcc tcc) - *bdd* (cmps bcc bcc) - *df-fd* (sbtr - (cmps bcc f) - (cmps f tcc)) - *dg-gd* (sbtr - (cmps tcc g) - (cmps g bcc)) - *id-fg* (sbtr (idnt-mrph bcc) (cmps f g)) - *id-gf-dh-hd* (i-sbtr (idnt-mrph tcc) - (cmps g f) - (cmps tcc h) - (cmps h tcc)) - *hh* (cmps h h) - *fh* (cmps f h) - *hg* (cmps h g))) + *bdd* (cmps bcc bcc) + *df-fd* (sbtr + (cmps bcc f) + (cmps f tcc)) + *dg-gd* (sbtr + (cmps tcc g) + (cmps g bcc)) + *id-fg* (sbtr (idnt-mrph bcc) (cmps f g)) + *id-gf-dh-hd* (i-sbtr (idnt-mrph tcc) + (cmps g f) + (cmps tcc h) + (cmps h tcc)) + *hh* (cmps h h) + *fh* (cmps f h) + *hg* (cmps h g))) (done)) @@ -292,13 +294,13 @@ the key. (declare (type symbol cmbn)) (format t "~%~A => ~A" cmbn (eval cmbn))) (dolist (phi '(*tdd* *bdd* *df-fd* *dg-gd* *id-fg* *id-gf-dh-hd* - *hh* *fh* *hg*)) + *hh* *fh* *hg*)) (declare (type symbol phi)) (format t "~%Checking ~A = 0" phi) (format t "~%Result: ") (princ (cmbn-? (eval phi) - (if (member phi '(*bdd* *dg-gd* *id-fg* *dg-gd* *hg*)) - *bc* *tc*))) + (if (member phi '(*bdd* *dg-gd* *id-fg* *dg-gd* *hg*)) + *bc* *tc*))) (read-line)) (done)) @@ -317,13 +319,13 @@ coherent, the result of each mapping is a null combination. (declare (type symbol cmbn)) (format t "~%~A => ~A" cmbn (eval cmbn))) (dolist (phi '(*tdd* *bdd* *df-fd* *dg-gd* *id-fg* *id-gf-dh-hd* - *hh* *fh* *hg*)) + *hh* *fh* *hg*)) (declare (type symbol phi)) (format t "~%Checking ~A = 0" phi) (format t "~%Result: ") (princ (cmbn-? (eval phi) - (if (member phi '(*bdd* *dg-gd* *id-fg* *dg-gd* *hg*)) - *bc* *tc*)))) + (if (member phi '(*bdd* *dg-gd* *id-fg* *dg-gd* *hg*)) + *bc* *tc*)))) (done)) @@ -366,47 +368,47 @@ coherent, the result of each mapping is a null combination. (type morphism top-perturbation)) (the (values reduction morphism) (with-slots ((old-tcc tcc) (old-bcc bcc) - (old-f f) (old-g g) (old-h h)) reduction + (old-f f) (old-g g) (old-h h)) reduction (declare - (type chain-complex old-tcc old-bcc) - (type morphism old-f old-g old-h)) + (type chain-complex old-tcc old-bcc) + (type morphism old-f old-g old-h)) (when (eq (first (orgn top-perturbation)) 'zero-mrph) - (return-from basic-perturbation-lemma - (values reduction (zero-mrph old-bcc)))) + (return-from basic-perturbation-lemma + (values reduction (zero-mrph old-bcc)))) (when (eq (first (orgn (h reduction))) 'zero-mrph) - (return-from basic-perturbation-lemma - (values - (trivial-rdct (add old-tcc top-perturbation)) - (i-cmps old-f top-perturbation old-g)))) + (return-from basic-perturbation-lemma + (values + (trivial-rdct (add old-tcc top-perturbation)) + (i-cmps old-f top-perturbation old-g)))) (let* ((sigma (bpl-*-sigma old-h top-perturbation)) (new-f (cmps old-f - (sbtr (idnt-mrph old-tcc) - (i-cmps - top-perturbation - sigma - old-h)))) + (sbtr (idnt-mrph old-tcc) + (i-cmps + top-perturbation + sigma + old-h)))) (new-g (cmps sigma old-g)) (new-h (cmps sigma old-h)) (bottom-perturbation (i-cmps - old-f - top-perturbation - new-g)) + old-f + top-perturbation + new-g)) (new-tcc (add old-tcc top-perturbation)) (new-bcc (add old-bcc bottom-perturbation))) - (declare - (type chain-complex new-tcc new-bcc) - (type morphism sigma new-f new-g new-h bottom-perturbation)) - (setf new-f (dstr-change-sorc-trgt new-f :new-sorc new-tcc - :new-trgt new-bcc) - new-g (dstr-change-sorc-trgt new-g :new-sorc new-bcc - :new-trgt new-tcc) - new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc - :new-trgt new-tcc)) - (values - (build-rdct :f new-f :g new-g :h new-h - :orgn `(basic-perturbation-lemma ,reduction - ,top-perturbation)) - bottom-perturbation))))) + (declare + (type chain-complex new-tcc new-bcc) + (type morphism sigma new-f new-g new-h bottom-perturbation)) + (setf new-f (dstr-change-sorc-trgt new-f :new-sorc new-tcc + :new-trgt new-bcc) + new-g (dstr-change-sorc-trgt new-g :new-sorc new-bcc + :new-trgt new-tcc) + new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc + :new-trgt new-tcc)) + (values + (build-rdct :f new-f :g new-g :h new-h + :orgn `(basic-perturbation-lemma ,reduction + ,top-perturbation)) + bottom-perturbation))))) (DEFUN EASY-PERTURBATION-LEMMA (reduction bottom-perturbation) (declare @@ -414,32 +416,32 @@ coherent, the result of each mapping is a null combination. (type morphism bottom-perturbation)) (the (values reduction morphism) (with-slots ((old-tcc tcc) (old-bcc bcc) - (old-f f) (old-g g) (old-h h)) reduction + (old-f f) (old-g g) (old-h h)) reduction (declare - (type chain-complex old-tcc old-bcc) - (type morphism old-f old-g old-h)) + (type chain-complex old-tcc old-bcc) + (type morphism old-f old-g old-h)) (when (eq 'zero-mrph (first (orgn bottom-perturbation))) - (return-from easy-perturbation-lemma - (values reduction (zero-mrph old-tcc)))) - (when (eq 'trivial-rdct (first (orgn reduction))) - (return-from easy-perturbation-lemma - (trivial-rdct (add (bcc reduction) bottom-perturbation)))) + (return-from easy-perturbation-lemma + (values reduction (zero-mrph old-tcc)))) + (when (eq 'trivial-rdct (first (orgn reduction))) + (return-from easy-perturbation-lemma + (trivial-rdct (add (bcc reduction) bottom-perturbation)))) (let ((top-perturbation (i-cmps old-g bottom-perturbation old-f))) - (declare (type morphism top-perturbation)) - (let ((new-bcc (add old-bcc bottom-perturbation)) - (new-tcc (add old-tcc top-perturbation))) - (declare (type chain-complex new-bcc new-tcc)) - (values - (build-rdct - :f (dstr-change-sorc-trgt old-f :new-sorc new-tcc - :new-trgt new-bcc) - :g (dstr-change-sorc-trgt old-g :new-sorc new-bcc - :new-trgt new-tcc) - :h (dstr-change-sorc-trgt old-h :new-sorc new-tcc - :new-trgt new-tcc) - :orgn `(easy-perturbation-lemma ,reduction - ,bottom-perturbation)) - top-perturbation)))))) + (declare (type morphism top-perturbation)) + (let ((new-bcc (add old-bcc bottom-perturbation)) + (new-tcc (add old-tcc top-perturbation))) + (declare (type chain-complex new-bcc new-tcc)) + (values + (build-rdct + :f (dstr-change-sorc-trgt old-f :new-sorc new-tcc + :new-trgt new-bcc) + :g (dstr-change-sorc-trgt old-g :new-sorc new-bcc + :new-trgt new-tcc) + :h (dstr-change-sorc-trgt old-h :new-sorc new-tcc + :new-trgt new-tcc) + :orgn `(easy-perturbation-lemma ,reduction + ,bottom-perturbation)) + top-perturbation)))))) (DEFUN SPECIAL-BPL (reduction top-perturbation) (declare @@ -449,28 +451,28 @@ coherent, the result of each mapping is a null combination. (return-from special-bpl reduction)) (the reduction (with-slots ((old-tcc tcc) (old-bcc bcc) - (old-f f) (old-g g) (old-h h)) reduction + (old-f f) (old-g g) (old-h h)) reduction (declare - (type chain-complex old-tcc old-bcc) - (type morphism old-f old-g old-h)) + (type chain-complex old-tcc old-bcc) + (type morphism old-f old-g old-h)) (let* ((sigma (bpl-*-sigma old-h top-perturbation)) (new-f (cmps old-f - (sbtr (idnt-mrph old-tcc) - (i-cmps - top-perturbation - sigma - old-h)))) + (sbtr (idnt-mrph old-tcc) + (i-cmps + top-perturbation + sigma + old-h)))) (new-h (cmps sigma old-h)) (new-tcc (add old-tcc top-perturbation))) - (declare - (type chain-complex new-tcc) - (type morphism sigma new-f new-h)) - (setf new-f (dstr-change-sorc-trgt new-f :new-sorc new-tcc) - old-g (dstr-change-sorc-trgt old-g :new-trgt new-tcc) - new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc - :new-trgt new-tcc)) - (build-rdct :f new-f :g old-g :h new-h - :orgn `(special-bpl ,reduction ,top-perturbation)))))) + (declare + (type chain-complex new-tcc) + (type morphism sigma new-f new-h)) + (setf new-f (dstr-change-sorc-trgt new-f :new-sorc new-tcc) + old-g (dstr-change-sorc-trgt old-g :new-trgt new-tcc) + new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc + :new-trgt new-tcc)) + (build-rdct :f new-f :g old-g :h new-h + :orgn `(special-bpl ,reduction ,top-perturbation)))))) (DEFUN SPECIAL-BPL-2 (reduction top-perturbation) (declare @@ -478,69 +480,69 @@ coherent, the result of each mapping is a null combination. (type morphism top-perturbation)) (the reduction (with-slots ((old-tcc tcc) (old-bcc bcc) - (old-f f) (old-g g) (old-h h)) reduction + (old-f f) (old-g g) (old-h h)) reduction (declare - (type chain-complex old-tcc old-bcc) - (type morphism old-f old-g old-h)) + (type chain-complex old-tcc old-bcc) + (type morphism old-f old-g old-h)) (when (eq (first (orgn top-perturbation)) 'zero-mrph) - (return-from special-bpl-2 - (values reduction (zero-mrph old-bcc)))) + (return-from special-bpl-2 + (values reduction (zero-mrph old-bcc)))) (when (eq (first (orgn (h reduction))) 'zero-mrph) - (return-from special-bpl-2 - (values - (trivial-rdct (add old-tcc top-perturbation)) - (i-cmps old-f top-perturbation old-g)))) + (return-from special-bpl-2 + (values + (trivial-rdct (add old-tcc top-perturbation)) + (i-cmps old-f top-perturbation old-g)))) (let* ((sigma (bpl-*-sigma old-h top-perturbation)) (new-g (cmps sigma old-g)) (new-h (cmps sigma old-h)) (new-tcc (add old-tcc top-perturbation))) - (declare - (type chain-complex new-tcc) - (type morphism sigma new-g new-h)) - (setf old-f (dstr-change-sorc-trgt old-f :new-sorc new-tcc) - new-g (dstr-change-sorc-trgt new-g :new-trgt new-tcc) - new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc - :new-trgt new-tcc)) - (values - (build-rdct :f old-f :g new-g :h new-h - :orgn `(special-bpl-2 ,reduction ,top-perturbation))))))) + (declare + (type chain-complex new-tcc) + (type morphism sigma new-g new-h)) + (setf old-f (dstr-change-sorc-trgt old-f :new-sorc new-tcc) + new-g (dstr-change-sorc-trgt new-g :new-trgt new-tcc) + new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc + :new-trgt new-tcc)) + (values + (build-rdct :f old-f :g new-g :h new-h + :orgn `(special-bpl-2 ,reduction ,top-perturbation))))))) (DEFUN BPL-*-sigma (homotopy perturbation) (declare (type morphism homotopy perturbation)) (the morphism (let ((cmpr (cmpr (sorc perturbation))) - (h-delta (cmps homotopy perturbation))) + (h-delta (cmps homotopy perturbation))) (declare - (type cmprf cmpr) - (type morphism h-delta)) + (type cmprf cmpr) + (type morphism h-delta)) (flet - ((sigma-* (degr gnrt) + ((sigma-* (degr gnrt) (declare - (fixnum degr) - (type gnrt gnrt)) + (fixnum degr) + (type gnrt gnrt)) (do ((rslt (zero-cmbn degr) (2cmbn-add cmpr rslt iterated)) (iterated (term-cmbn degr 1 gnrt) - (cmbn-opps (cmbn-? h-delta iterated)))) + (cmbn-opps (cmbn-? h-delta iterated)))) ((cmbn-zero-p iterated) rslt) - (declare (type cmbn rslt iterated))))) - (build-mrph - :sorc (sorc homotopy) :trgt (sorc homotopy) :degr 0 - :intr #'sigma-* - :strt :gnrt - :orgn `(bpl-*-sigma ,homotopy ,perturbation)))))) + (declare (type cmbn rslt iterated))))) + (build-mrph + :sorc (sorc homotopy) :trgt (sorc homotopy) :degr 0 + :intr #'sigma-* + :strt :gnrt + :orgn `(bpl-*-sigma ,homotopy ,perturbation)))))) (DEFMETHOD ADD ((hmeq homotopy-equivalence) (lb-perturbation morphism) - &optional dummy) + &optional dummy) (declare (ignore dummy)) (the homotopy-equivalence (with-slots (lrdct rrdct) hmeq (declare (type reduction lrdct rrdct)) (multiple-value-bind (new-lrdct top-perturbation) - (add lrdct lb-perturbation) - (declare - (type reduction new-lrdct) - (type morphism lb-perturbation)) - (build-hmeq - :lrdct new-lrdct - :rrdct (add rrdct top-perturbation) - :orgn `(add ,hmeq ,lb-perturbation)))))) + (add lrdct lb-perturbation) + (declare + (type reduction new-lrdct) + (type morphism lb-perturbation)) + (build-hmeq + :lrdct new-lrdct + :rrdct (add rrdct top-perturbation) + :orgn `(add ,hmeq ,lb-perturbation)))))) From 86306c9c42605ce7ee891946ae0288bee339a524 Mon Sep 17 00:00:00 2001 From: Gerd Heber Date: Mon, 16 Nov 2015 08:54:42 -0600 Subject: [PATCH 07/15] Muffle SBCL style warnings and compiler notes. --- src/cat-init.lisp | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/cat-init.lisp b/src/cat-init.lisp index 0b29c93..7bd42d9 100644 --- a/src/cat-init.lisp +++ b/src/cat-init.lisp @@ -79,6 +79,8 @@ (DEFVAR *CMBN-CONTROL*) (SETF *CMBN-CONTROL* T) +#+SBCL (DECLAIM (SB-EXT:MUFFLE-CONDITIONS style-warning compiler-note)) + (DEFUN COMPILE-FILES () (format t "~%*CMBN-CONTROL* = ~A~2%" *cmbn-control*) (mapc #'(lambda (file-name) From d061360c935e74db7119935187e794592bcb84d8 Mon Sep 17 00:00:00 2001 From: Gerd Heber Date: Wed, 18 Nov 2015 19:49:09 -0600 Subject: [PATCH 08/15] Resolved #40 #41 #43 #45 as per Francis' comment. The (unless (>= abar-degr *)) check prevents "degree overflow." --- src/cl-space-efhm.lisp | 510 ++++++++++++------------ test/bar-test.lisp | 330 ++++++++-------- test/cl-space-efhm-test.lisp | 738 ++++++++++++++++------------------- 3 files changed, 752 insertions(+), 826 deletions(-) diff --git a/src/cl-space-efhm.lisp b/src/cl-space-efhm.lisp index 27164ef..87db3c5 100644 --- a/src/cl-space-efhm.lisp +++ b/src/cl-space-efhm.lisp @@ -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))) diff --git a/test/bar-test.lisp b/test/bar-test.lisp index 0cbf850..7eab3db 100644 --- a/test/bar-test.lisp +++ b/test/bar-test.lisp @@ -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)))) diff --git a/test/cl-space-efhm-test.lisp b/test/cl-space-efhm-test.lisp index 9bb906e..4272156 100644 --- a/test/cl-space-efhm-test.lisp +++ b/test/cl-space-efhm-test.lisp @@ -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))) From 6e7234e191ebda57d382ad738c6de8e90cebccda Mon Sep 17 00:00:00 2001 From: Gerd Heber Date: Wed, 18 Nov 2015 20:04:43 -0600 Subject: [PATCH 09/15] Same remedy as #40 #41 #43 #45. --- src/lp-space-efhm.lisp | 448 +++++++++++++++++------------------ test/lp-space-efhm-test.lisp | 403 +++++++++++++++---------------- 2 files changed, 413 insertions(+), 438 deletions(-) diff --git a/src/lp-space-efhm.lisp b/src/lp-space-efhm.lisp index 8bca303..525b6e2 100644 --- a/src/lp-space-efhm.lisp +++ b/src/lp-space-efhm.lisp @@ -7,9 +7,9 @@ (PROVIDE "lp-space-efhm") (DEFUN LS-HAT-U-U (space - &aux (cobar (cobar space)) - (loop-space (loop-space space)) - (spac-tnsr-lpsp (tnsr-prdc space loop-space))) + &aux (cobar (cobar space)) + (loop-space (loop-space space)) + (spac-tnsr-lpsp (tnsr-prdc space loop-space))) (declare (type simplicial-set space) (type chain-complex cobar spac-tnsr-lpsp) @@ -22,38 +22,38 @@ (declare (type simplicial-set space)) (let ((cprd (dgnl space))) (flet ((rslt (degr tnpr) - (declare - (fixnum degr) - (type tnpr tnpr)) - (with-tnpr - (degr1 allp1 nil tnpr2) tnpr - (with-tnpr - (degr21 gmsm21 degr22 loop22) tnpr2 - (let ((cprd (cmbn-list (gnrt-? cprd degr21 gmsm21)))) - (declare (list cprd)) - (setf cprd (rest cprd)) ;;; because \bar{A} - (make-cmbn - :degr (1- degr) - :list - (mapcar - #'(lambda (term) - (declare (type term term)) - (with-term - (cffc tnpr21) term - (with-tnpr - (degr211 gmsm211 degr212 gmsm212) tnpr21 - (decf degr211) - (term cffc (tnpr (+ degr1 degr211) - (make-allp - :list - (append - (allp-list allp1) - (list (cbgn degr211 - gmsm211)))) - (+ degr212 degr22) - (tnpr degr212 gmsm212 - degr22 loop22)))))) - cprd))))))) + (declare + (fixnum degr) + (type tnpr tnpr)) + (with-tnpr + (degr1 allp1 nil tnpr2) tnpr + (with-tnpr + (degr21 gmsm21 degr22 loop22) tnpr2 + (let ((cprd (cmbn-list (gnrt-? cprd degr21 gmsm21)))) + (declare (list cprd)) + (setf cprd (rest cprd)) ;;; because \bar{A} + (make-cmbn + :degr (1- degr) + :list + (mapcar + #'(lambda (term) + (declare (type term term)) + (with-term + (cffc tnpr21) term + (with-tnpr + (degr211 gmsm211 degr212 gmsm212) tnpr21 + (decf degr211) + (term cffc (tnpr (+ degr1 degr211) + (make-allp + :list + (append + (allp-list allp1) + (list (cbgn degr211 + gmsm211)))) + (+ degr212 degr22) + (tnpr degr212 gmsm212 + degr22 loop22)))))) + cprd))))))) (the intr-mrph #'rslt)))) @@ -62,17 +62,17 @@ (the morphism (let ((ls-hat-u-u (ls-hat-u-u space))) (build-mrph - :sorc ls-hat-u-u - :trgt ls-hat-u-u - :degr -1 - :intr (ls-hat-left-perturbation-intr space) - :strt :gnrt - :orgn `(ls-hat-left-perturbation ,space))))) + :sorc ls-hat-u-u + :trgt ls-hat-u-u + :degr -1 + :intr (ls-hat-left-perturbation-intr space) + :strt :gnrt + :orgn `(ls-hat-left-perturbation ,space))))) (DEFUN LS-HAT-T-U (space - &aux (ls-hat-u-u (ls-hat-u-u space)) - (ls-hat-left-perturbation - (ls-hat-left-perturbation space))) + &aux (ls-hat-u-u (ls-hat-u-u space)) + (ls-hat-left-perturbation + (ls-hat-left-perturbation space))) (declare (type simplicial-set space) (type chain-complex ls-hat-u-u) @@ -87,27 +87,27 @@ (DEFUN LS-HAT-RIGHT-PERTURBATION (space - &aux (cobar (cobar space)) - (ls-hat-t-u (ls-hat-t-u space))) + &aux (cobar (cobar space)) + (ls-hat-t-u (ls-hat-t-u space))) (declare (type simplicial-set space) (type chain-complex cobar ls-hat-t-u)) (the morphism (multiple-value-bind (szczarba bottom-perturbation) - (szczarba space) + (szczarba space) (declare - (ignore szczarba) - (type morphism bottom-perturbation)) + (ignore szczarba) + (type morphism bottom-perturbation)) (let ((rslt (tnsr-prdc (idnt-mrph cobar) bottom-perturbation))) - (declare (type morphism rslt)) - (setf (slot-value rslt 'sorc) ls-hat-t-u - (slot-value rslt 'trgt) ls-hat-t-u) - rslt)))) + (declare (type morphism rslt)) + (setf (slot-value rslt 'sorc) ls-hat-t-u + (slot-value rslt 'trgt) ls-hat-t-u) + rslt)))) (DEFUN LS-HAT-U-T (space - &aux (cobar (cobar space)) - (twisted-tnsr-prdc (twisted-tnsr-prdc space)) - (ls-hat-u-u (ls-hat-u-u space))) + &aux (cobar (cobar space)) + (twisted-tnsr-prdc (twisted-tnsr-prdc space)) + (ls-hat-u-u (ls-hat-u-u space))) (declare (type simplicial-set space) (type chain-complex cobar twisted-tnsr-prdc ls-hat-u-u)) @@ -119,10 +119,10 @@ (DEFUN LS-LEFT-HMEQ-HAT (space - &aux - (ls-hat-u-t (ls-hat-u-t space)) - (ls-hat-left-perturbation - (ls-hat-left-perturbation space))) + &aux + (ls-hat-u-t (ls-hat-u-t space)) + (ls-hat-left-perturbation + (ls-hat-left-perturbation space))) (declare (type simplicial-set space) (type chain-complex ls-hat-u-t) @@ -137,75 +137,75 @@ (let ((rslt +empty-list+)) (declare (list rslt)) (dolist (term (cmbn-list cmbn)) - (declare (type term term)) - (with-term - (cffc tnpr) term - (with-tnpr (degr1 nil nil tnpr2) tnpr - (if (zerop degr1) - (with-tnpr - (degr21 nil nil loop22) tnpr2 - (if (zerop degr21) - (push (term cffc loop22) rslt) - (return))) - (return))))) + (declare (type term term)) + (with-term + (cffc tnpr) term + (with-tnpr (degr1 nil nil tnpr2) tnpr + (if (zerop degr1) + (with-tnpr + (degr21 nil nil loop22) tnpr2 + (if (zerop degr21) + (push (term cffc loop22) rslt) + (return))) + (return))))) (make-cmbn :degr (cmbn-degr cmbn) - :list (nreverse rslt))))) + :list (nreverse rslt))))) (DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-F (space - &aux (ls-hat-t-u (ls-hat-t-u space)) - (loop-space (loop-space space))) + &aux (ls-hat-t-u (ls-hat-t-u space)) + (loop-space (loop-space space))) (declare (type simplicial-set space loop-space) (type chain-complex ls-hat-t-u)) (the morphism (build-mrph - :sorc ls-hat-t-u - :trgt loop-space - :degr 0 - :intr #'ls-pre-left-hmeq-left-reduction-intr-f - :strt :cmbn - :orgn `(ls-pre-left-hmeq-left-reduction-f ,space)))) + :sorc ls-hat-t-u + :trgt loop-space + :degr 0 + :intr #'ls-pre-left-hmeq-left-reduction-intr-f + :strt :cmbn + :orgn `(ls-pre-left-hmeq-left-reduction-f ,space)))) (DEFUN LS-LEFT-HMEQ-LEFT-REDUCTION-G-INTR (bspn) (declare (type gmsm bspn)) (flet ((rslt (cmbn) - (declare (type cmbn cmbn)) - (the cmbn + (declare (type cmbn cmbn)) + (the cmbn (with-cmbn - (degr list) cmbn - (make-cmbn :degr degr - :list (mapcar - #'(lambda (term) - (declare (type term term)) - (with-term - (cffc loop) term - (term cffc - (tnpr - 0 +null-allp+ - degr - (tnpr 0 bspn degr - loop))))) - list)))))) + (degr list) cmbn + (make-cmbn :degr degr + :list (mapcar + #'(lambda (term) + (declare (type term term)) + (with-term + (cffc loop) term + (term cffc + (tnpr + 0 +null-allp+ + degr + (tnpr 0 bspn degr + loop))))) + list)))))) (the intr-mrph #'rslt))) (DEFUN LS-LEFT-HMEQ-LEFT-REDUCTION-G (space - &aux (bspn (bspn space)) - (ls-hat-t-u (ls-hat-t-u space)) - (loop-space (loop-space space))) + &aux (bspn (bspn space)) + (ls-hat-t-u (ls-hat-t-u space)) + (loop-space (loop-space space))) (declare (type simplicial-set space loop-space) (type gmsm bspn) (type chain-complex ls-hat-t-u)) (the morphism (build-mrph - :sorc loop-space - :trgt ls-hat-t-u - :degr 0 - :intr (ls-left-hmeq-left-reduction-g-intr bspn) - :strt :cmbn - :orgn `(ls-left-hmeq-left-reduction-g ,space)))) + :sorc loop-space + :trgt ls-hat-t-u + :degr 0 + :intr (ls-left-hmeq-left-reduction-g-intr bspn) + :strt :cmbn + :orgn `(ls-left-hmeq-left-reduction-g ,space)))) (DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-H-INTR @@ -219,88 +219,88 @@ (flet ((rslt (cmbn) (declare (type cmbn cmbn)) (the cmbn - (with-cmbn - (degr list) cmbn - (let ((rslt (zero-cmbn (1+ degr)))) - (declare (type cmbn rslt)) - (dolist (term list) - (declare (type term term)) - (with-term - (cffc tnpr) term - (with-tnpr - (degr1 allp1 degr2 tnpr2) tnpr - (unless (zerop degr1) - (with-tnpr - (degr21 nil degr22 loop22) tnpr2 - (when (zerop degr21) - (setf allp1 (allp-list allp1)) ;;;+++ - (let ((last-cbgn (car (last allp1)))) - (declare (type cbgn last-cbgn)) - (with-cbgn - (degrl gmsml) last-cbgn - (dstr-add-term-to-cmbn - cmpr cffc - (tnpr (- degr1 degrl) - (make-allp - :list (butlast allp1)) - (+ degr2 degrl 1) - (tnpr (1+ degrl) gmsml - degr22 loop22)) - rslt))))))))) - rslt))))) + (with-cmbn + (degr list) cmbn + (let ((rslt (zero-cmbn (1+ degr)))) + (declare (type cmbn rslt)) + (dolist (term list) + (declare (type term term)) + (with-term + (cffc tnpr) term + (with-tnpr + (degr1 allp1 degr2 tnpr2) tnpr + (unless (zerop degr1) + (with-tnpr + (degr21 nil degr22 loop22) tnpr2 + (when (zerop degr21) + (setf allp1 (allp-list allp1)) ;;;+++ + (let ((last-cbgn (car (last allp1)))) + (declare (type cbgn last-cbgn)) + (with-cbgn + (degrl gmsml) last-cbgn + (dstr-add-term-to-cmbn + cmpr cffc + (tnpr (- degr1 degrl) + (make-allp + :list (butlast allp1)) + (+ degr2 degrl 1) + (tnpr (1+ degrl) gmsml + degr22 loop22)) + rslt))))))))) + rslt))))) (the intr-mrph #'rslt))) (DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-H (space - &aux (ls-hat-t-u (ls-hat-t-u space))) + &aux (ls-hat-t-u (ls-hat-t-u space))) (declare (type simplicial-set space) (type chain-complex ls-hat-t-u)) (the morphism (build-mrph - :sorc ls-hat-t-u - :trgt ls-hat-t-u - :degr +1 - :intr (ls-pre-left-hmeq-left-reduction-h-intr space) - :strt :cmbn - :orgn `(ls-pre-left-hmeq-left-reduction-h ,space)))) + :sorc ls-hat-t-u + :trgt ls-hat-t-u + :degr +1 + :intr (ls-pre-left-hmeq-left-reduction-h-intr space) + :strt :cmbn + :orgn `(ls-pre-left-hmeq-left-reduction-h ,space)))) (DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION (space) (declare (type simplicial-set space)) (the reduction (build-rdct - :f (ls-pre-left-hmeq-left-reduction-f space) - :g (ls-left-hmeq-left-reduction-g space) - :h (ls-pre-left-hmeq-left-reduction-h space) - :orgn `(ls-pre-left-hmeq-left-reduction ,space)))) + :f (ls-pre-left-hmeq-left-reduction-f space) + :g (ls-left-hmeq-left-reduction-g space) + :h (ls-pre-left-hmeq-left-reduction-h space) + :orgn `(ls-pre-left-hmeq-left-reduction ,space)))) (DEFUN LS-LEFT-HMEQ-LEFT-REDUCTION (space - &aux (ls-pre-left-hmeq-left-reduction - (ls-pre-left-hmeq-left-reduction - space)) - (ls-hat-right-perturbation - (ls-hat-right-perturbation space))) + &aux (ls-pre-left-hmeq-left-reduction + (ls-pre-left-hmeq-left-reduction + space)) + (ls-hat-right-perturbation + (ls-hat-right-perturbation space))) (declare (type simplicial-set space) (type reduction ls-pre-left-hmeq-left-reduction) (type morphism ls-hat-right-perturbation)) (the reduction (progn - (dstr-change-sorc-trgt ls-hat-right-perturbation - :new-sorc (tcc ls-pre-left-hmeq-left-reduction) - :new-trgt (tcc ls-pre-left-hmeq-left-reduction)) + (dstr-change-sorc-trgt ls-hat-right-perturbation + :new-sorc (tcc ls-pre-left-hmeq-left-reduction) + :new-trgt (tcc ls-pre-left-hmeq-left-reduction)) (let ((rslt (special-bpl ls-pre-left-hmeq-left-reduction - ls-hat-right-perturbation))) - (declare (type reduction rslt)) - (with-slots (tcc f g h) rslt - (setf tcc (ls-left-hmeq-hat space) - (slot-value f 'sorc) tcc - (slot-value g 'trgt) tcc - (slot-value h 'sorc) tcc - (slot-value h 'trgt) tcc) - rslt))))) + ls-hat-right-perturbation))) + (declare (type reduction rslt)) + (with-slots (tcc f g h) rslt + (setf tcc (ls-left-hmeq-hat space) + (slot-value f 'sorc) tcc + (slot-value g 'trgt) tcc + (slot-value h 'sorc) tcc + (slot-value h 'trgt) tcc) + rslt))))) ;;; -[CLISP @@ -309,14 +309,14 @@ (declare (type cmbn cmbn)) (the cmbn (with-cmbn (degr list) cmbn - (let ((tail (member 0 list :test #'= :key #'cadddr))) - (make-cmbn :degr degr - :list (mapcar - #'(lambda (term) - (declare (type term term)) - (with-term (cffc tnpr) term - (term cffc (gnrt1 tnpr)))) - tail)))))) + (let ((tail (member 0 list :test #'= :key #'cadddr))) + (make-cmbn :degr degr + :list (mapcar + #'(lambda (term) + (declare (type term term)) + (with-term (cffc tnpr) term + (term cffc (gnrt1 tnpr)))) + tail)))))) |# ;;; LISP]- ;;; +[CLISP @@ -324,74 +324,74 @@ (declare (type cmbn cmbn)) (the cmbn (with-cmbn (degr list) cmbn - (let ((tail (member 0 list - :key #'(lambda (term) - (declare (type term term)) - (degr2 (gnrt term)))))) - (make-cmbn :degr degr - :list (mapcar - #'(lambda (term) - (declare (type term term)) - (with-term (cffc tnpr) term - (term cffc (gnrt1 tnpr)))) - tail)))))) + (let ((tail (member 0 list + :key #'(lambda (term) + (declare (type term term)) + (degr2 (gnrt term)))))) + (make-cmbn :degr degr + :list (mapcar + #'(lambda (term) + (declare (type term term)) + (with-term (cffc tnpr) term + (term cffc (gnrt1 tnpr)))) + tail)))))) ;;; CLISP]+ (DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-F (space - &aux (ls-hat-u-t (ls-hat-u-t space)) - (cobar (cobar space))) + &aux (ls-hat-u-t (ls-hat-u-t space)) + (cobar (cobar space))) (declare (type simplicial-set space) (type chain-complex ls-hat-u-t cobar)) (the morphism (build-mrph - :sorc ls-hat-u-t :trgt cobar :degr 0 - :intr #'ls-pre-left-hmeq-right-reduction-intr-f - :strt :cmbn - :orgn `(ls-pre-left-hmeq-right-reduction-f ,space)))) + :sorc ls-hat-u-t :trgt cobar :degr 0 + :intr #'ls-pre-left-hmeq-right-reduction-intr-f + :strt :cmbn + :orgn `(ls-pre-left-hmeq-right-reduction-f ,space)))) (DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-G (bspn) (declare (type gmsm bspn)) (flet ((rslt (cmbn) - (declare (type cmbn cmbn)) - (the cmbn + (declare (type cmbn cmbn)) + (the cmbn (with-cmbn - (degr list) cmbn - (let ((bsgn (tnpr 0 bspn 0 +null-loop+))) - (declare (type tnpr bsgn)) - (make-cmbn :degr degr - :list (mapcar - #'(lambda (term) - (declare (type term term)) - (with-term - (cffc gnrt) term - (term cffc (tnpr degr gnrt 0 - bsgn)))) - list))))))) + (degr list) cmbn + (let ((bsgn (tnpr 0 bspn 0 +null-loop+))) + (declare (type tnpr bsgn)) + (make-cmbn :degr degr + :list (mapcar + #'(lambda (term) + (declare (type term term)) + (with-term + (cffc gnrt) term + (term cffc (tnpr degr gnrt 0 + bsgn)))) + list))))))) (the intr-mrph #'rslt))) (DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-G (space - &aux (ls-hat-u-t (ls-hat-u-t space)) - (cobar (cobar space)) - (bspn (bspn space))) + &aux (ls-hat-u-t (ls-hat-u-t space)) + (cobar (cobar space)) + (bspn (bspn space))) (declare (type simplicial-set space) (type chain-complex ls-hat-u-t cobar) (type gmsm bspn)) (the morphism (build-mrph - :sorc cobar :trgt ls-hat-u-t :degr 0 - :intr (ls-pre-left-hmeq-right-reduction-intr-g bspn) - :strt :cmbn - :orgn `(ls-pre-left-hmeq-right-reduction-g ,space)))) + :sorc cobar :trgt ls-hat-u-t :degr 0 + :intr (ls-pre-left-hmeq-right-reduction-intr-g bspn) + :strt :cmbn + :orgn `(ls-pre-left-hmeq-right-reduction-g ,space)))) (DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-H (space - &aux (cobar (cobar space)) - (tnpr-contraction - (tnpr-contraction space))) + &aux (cobar (cobar space)) + (tnpr-contraction + (tnpr-contraction space))) (declare (type simplicial-set space) (type chain-complex cobar) @@ -404,18 +404,18 @@ (declare (type simplicial-set space)) (the reduction (build-rdct - :f (ls-pre-left-hmeq-right-reduction-f space) - :g (ls-pre-left-hmeq-right-reduction-g space) - :h (ls-pre-left-hmeq-right-reduction-h space) - :orgn `(ls-pre-left-hmeq-right-reduction ,space)))) + :f (ls-pre-left-hmeq-right-reduction-f space) + :g (ls-pre-left-hmeq-right-reduction-g space) + :h (ls-pre-left-hmeq-right-reduction-h space) + :orgn `(ls-pre-left-hmeq-right-reduction ,space)))) (DEFUN LS-LEFT-HMEQ-RIGHT-REDUCTION (space - &aux (pre-reduction - (ls-pre-left-hmeq-right-reduction - space)) - (perturbation - (ls-hat-left-perturbation space))) + &aux (pre-reduction + (ls-pre-left-hmeq-right-reduction + space)) + (perturbation + (ls-hat-left-perturbation space))) (declare (type simplicial-set space) (type reduction pre-reduction) @@ -431,15 +431,15 @@ (declare (type simplicial-set space)) (the homotopy-equivalence (build-hmeq - :lrdct (ls-left-hmeq-left-reduction space) - :rrdct (ls-left-hmeq-right-reduction space) - :orgn `(ls-left-hmeq ,space)))) + :lrdct (ls-left-hmeq-left-reduction space) + :rrdct (ls-left-hmeq-right-reduction space) + :orgn `(ls-left-hmeq ,space)))) (DEFUN LOOP-SPACE-EFHM (space) (declare (type simplicial-set space)) (let ((ls-left-hmeq (ls-left-hmeq space)) - (right-hmeq (cobar (efhm space)))) + (right-hmeq (cobar (efhm space)))) (declare (type homotopy-equivalence ls-left-hmeq right-hmeq)) (cmps ls-left-hmeq right-hmeq))) diff --git a/test/lp-space-efhm-test.lisp b/test/lp-space-efhm-test.lisp index fccc588..c8c0990 100644 --- a/test/lp-space-efhm-test.lisp +++ b/test/lp-space-efhm-test.lisp @@ -1,198 +1,173 @@ - (in-package :kenzo-test) (in-suite :kenzo) -#| + (test ls-hat-t-u (cat:cat-init) (let ((c (cat:ls-hat-t-u (cat:deltab))) - allp allp-degr gnrt) - (dotimes (i 10) (print (random-allp 5))) - (setf allp (random-allp 4)) ;; the degree could be too big - ;; then redo - (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) - (setf gnrt (cat:tnpr allp-degr allp 4 - (cat:tnpr 2 7 2 (cat:loop3 0 15 2)))) - (cat:? c (+ 4 allp-degr) gnrt) - (cat:? c *) - (dotimes (i 10) - (let ((allp (random-allp 3))) - (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) - (setf gnrt (cat:tnpr allp-degr allp 4 - (cat:tnpr 2 7 2 (cat:loop3 0 15 2)))) - (unless (>= allp-degr 11) - (print (cat:? c (+ 4 allp-degr) gnrt)) - (print (cat:? c (cat:? c (+ 4 allp-degr) gnrt)))))) - (dotimes (i 20) - (let ((allp (random-allp 3))) - (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) - (setf gnrt (cat:tnpr allp-degr allp 5 - (cat:tnpr 3 15 2 (cat:loop3 0 15 2)))) - (unless (>= allp-degr 10) - (print (cat:? c (+ 5 allp-degr) gnrt)) - (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt)))))) - (dotimes (i 20) - (let ((allp (random-allp 3))) - (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) - (setf gnrt (cat:tnpr allp-degr allp 5 - (cat:tnpr 2 7 3 (cat:loop3 0 31 2)))) - (unless (>= allp-degr 10) - (print (cat:? c (+ 5 allp-degr) gnrt)) - (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt)))))))) -|# + allp allp-degr gnrt) + (dotimes (i 10) + (let ((allp (random-allp 3))) + (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) + (setf gnrt (cat:tnpr allp-degr allp 4 + (cat:tnpr 2 7 2 (cat:loop3 0 15 2)))) + (unless (>= allp-degr 11) + (print (cat:? c (+ 4 allp-degr) gnrt)) + (print (cat:? c (cat:? c (+ 4 allp-degr) gnrt)))))) + (dotimes (i 20) + (let ((allp (random-allp 3))) + (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) + (setf gnrt (cat:tnpr allp-degr allp 5 + (cat:tnpr 3 15 2 (cat:loop3 0 15 2)))) + (unless (>= allp-degr 10) + (print (cat:? c (+ 5 allp-degr) gnrt)) + (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt)))))) + (dotimes (i 20) + (let ((allp (random-allp 3))) + (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) + (setf gnrt (cat:tnpr allp-degr allp 5 + (cat:tnpr 2 7 3 (cat:loop3 0 31 2)))) + (unless (>= allp-degr 10) + (print (cat:? c (+ 5 allp-degr) gnrt)) + (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt)))))))) + -#| (test ls-hat-u-t (cat:cat-init) (let ((c (cat:ls-hat-u-t (cat:deltab))) - allp allp-degr gnrt) - (dotimes (i 10) (print (random-allp 5))) - (setf allp (random-allp 3)) - (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) - (setf gnrt (cat:tnpr allp-degr allp 4 - (cat:tnpr 2 7 2 (cat:loop3 0 15 2)))) - (cat:? c (+ 4 allp-degr) gnrt) - (cat:? c *) - (dotimes (i 10) - (let ((allp (random-allp 3))) - (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) - (setf gnrt (cat:tnpr allp-degr allp 4 - (cat:tnpr 2 7 2 (cat:loop3 0 15 2)))) - (unless (>= allp-degr 11) - (print (cat:? c (+ 4 allp-degr) gnrt)) - (print (cat:? c (cat:? c (+ 4 allp-degr) gnrt)))))) - (dotimes (i 20) - (let ((allp (random-allp 3))) - (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) - (setf gnrt (cat:tnpr allp-degr allp 5 - (cat:tnpr 3 15 2 (cat:loop3 0 15 2)))) - (unless (>= allp-degr 10) - (print (cat:? c (+ 5 allp-degr) gnrt)) - (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt)))))) - (dotimes (i 20) - (let ((allp (random-allp 3))) - (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) - (setf gnrt (cat:tnpr allp-degr allp 5 - (cat:tnpr 2 7 3 (cat:loop3 0 31 2)))) - (unless (>= allp-degr 10) - (print (cat:? c (+ 5 allp-degr) gnrt)) - (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt)))))))) -|# + allp allp-degr gnrt) + (dotimes (i 10) + (let ((allp (random-allp 3))) + (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) + (setf gnrt (cat:tnpr allp-degr allp 4 + (cat:tnpr 2 7 2 (cat:loop3 0 15 2)))) + (unless (>= allp-degr 11) + (print (cat:? c (+ 4 allp-degr) gnrt)) + (print (cat:? c (cat:? c (+ 4 allp-degr) gnrt)))))) + (dotimes (i 20) + (let ((allp (random-allp 3))) + (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) + (setf gnrt (cat:tnpr allp-degr allp 5 + (cat:tnpr 3 15 2 (cat:loop3 0 15 2)))) + (unless (>= allp-degr 10) + (print (cat:? c (+ 5 allp-degr) gnrt)) + (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt)))))) + (dotimes (i 20) + (let ((allp (random-allp 3))) + (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) + (setf gnrt (cat:tnpr allp-degr allp 5 + (cat:tnpr 2 7 3 (cat:loop3 0 31 2)))) + (unless (>= allp-degr 10) + (print (cat:? c (+ 5 allp-degr) gnrt)) + (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt)))))))) + -#| (test ls-left-hmeq-hat (cat:cat-init) (let ((c (cat:ls-left-hmeq-hat (cat:deltab))) - allp allp-degr gnrt) - (dotimes (i 10) (print (random-allp 5))) - (setf allp (random-allp 3)) - (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) - (setf gnrt (cat:tnpr allp-degr allp 4 (cat:tnpr 2 7 2 - (cat:loop3 0 15 2)))) - (cat:? c (+ 4 allp-degr) gnrt) - (cat:? c (cat:? c (+ 4 allp-degr) gnrt)) - (dotimes (i 10) - (let ((allp (random-allp 3))) - (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) - (setf gnrt (cat:tnpr allp-degr allp 4 - (cat:tnpr 2 7 2 (cat:loop3 0 15 2)))) - (unless (>= allp-degr 11) - (print (cat:? c (+ 4 allp-degr) gnrt)) - (print (cat:? c (cat:? c (+ 4 allp-degr) gnrt)))))) - (dotimes (i 20) - (let ((allp (random-allp 3))) - (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) - (setf gnrt (cat:tnpr allp-degr allp 5 - (cat:tnpr 3 15 2 (cat:loop3 0 15 2)))) - (unless (>= allp-degr 10) - (print (cat:? c (+ 5 allp-degr) gnrt)) - (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt)))))) - (dotimes (i 20) - (let ((allp (random-allp 3))) - (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) - (setf gnrt (cat:tnpr allp-degr allp 5 - (cat:tnpr 2 7 3 (cat:loop3 0 31 2)))) - (unless (>= allp-degr 10) - (print (cat:? c (+ 5 allp-degr) gnrt)) - (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt)))))))) -|# + allp allp-degr gnrt) + (dotimes (i 10) + (let ((allp (random-allp 3))) + (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) + (setf gnrt (cat:tnpr allp-degr allp 4 + (cat:tnpr 2 7 2 (cat:loop3 0 15 2)))) + (unless (>= allp-degr 11) + (print (cat:? c (+ 4 allp-degr) gnrt)) + (print (cat:? c (cat:? c (+ 4 allp-degr) gnrt)))))) + (dotimes (i 20) + (let ((allp (random-allp 3))) + (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) + (setf gnrt (cat:tnpr allp-degr allp 5 + (cat:tnpr 3 15 2 (cat:loop3 0 15 2)))) + (unless (>= allp-degr 10) + (print (cat:? c (+ 5 allp-degr) gnrt)) + (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt)))))) + (dotimes (i 20) + (let ((allp (random-allp 3))) + (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) + (setf gnrt (cat:tnpr allp-degr allp 5 + (cat:tnpr 2 7 3 (cat:loop3 0 31 2)))) + (unless (>= allp-degr 10) + (print (cat:? c (+ 5 allp-degr) gnrt)) + (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt)))))))) + (test ls-pre-left-hmeq-left-reduction-intr-f (cat:ls-pre-left-hmeq-left-reduction-intr-f (cat:cmbn 6 100 (cat:tnpr 0 'a 6 (cat:tnpr 0 'b 6 'c)) - 50 (cat:tnpr 0 'a 6 (cat:tnpr 0 'b 6 'cc)) - 10 (cat:tnpr 0 'a 6 (cat:tnpr 2 'b 4 'c)) - 1 (cat:tnpr 2 'a 4 (cat:tnpr 2 'b 2 'cc))))) + 50 (cat:tnpr 0 'a 6 (cat:tnpr 0 'b 6 'cc)) + 10 (cat:tnpr 0 'a 6 (cat:tnpr 2 'b 4 'c)) + 1 (cat:tnpr 2 'a 4 (cat:tnpr 2 'b 2 'cc))))) (test ls-left-hmeq-left-reduction-g-intr (let ((r (cat:ls-left-hmeq-left-reduction-g-intr '*))) - (funcall r (cat:cmbn 3 4 'loop)))) + (funcall r (cat:cmbn 3 4 'loop)))) (test ls-pre-left-hmeq-left-reduction-h-intr (cat:cat-init) (let ((r (cat:ls-pre-left-hmeq-left-reduction-h-intr (cat:deltab)))) - (setf cat:*tnpr-with-degrees* t) - (funcall r (cat:cmbn 10 1 (cat:tnpr 3 (cat:allp 2 'a 1 'b) - 7 (cat:tnpr 5 'c 2 'd)) - 1 (cat:tnpr 7 (cat:allp 2 'a 5 'b) - 3 (cat:tnpr 0 '* 3 'c)) - 10 (cat:tnpr 8 (cat:allp 4 'aa 4 'bb) - 2 (cat:tnpr 0 '* 2 'cc)))) - (funcall r (cat:cmbn 10 1 (cat:tnpr 3 (cat:allp 2 'a 1 'b) - 7 (cat:tnpr 5 'c 2 'd)) - 1 (cat:tnpr 7 (cat:allp 4 'a 3 'b) - 3 (cat:tnpr 0 '* 3 'c)) - 10 (cat:tnpr 8 (cat:allp 3 'aa 5 'bb) - 2 (cat:tnpr 0 '* 2 'cc)))) - (setf cat:*tnpr-with-degrees* nil))) + (setf cat:*tnpr-with-degrees* t) + (funcall r (cat:cmbn 10 1 (cat:tnpr 3 (cat:allp 2 'a 1 'b) + 7 (cat:tnpr 5 'c 2 'd)) + 1 (cat:tnpr 7 (cat:allp 2 'a 5 'b) + 3 (cat:tnpr 0 '* 3 'c)) + 10 (cat:tnpr 8 (cat:allp 4 'aa 4 'bb) + 2 (cat:tnpr 0 '* 2 'cc)))) + (funcall r (cat:cmbn 10 1 (cat:tnpr 3 (cat:allp 2 'a 1 'b) + 7 (cat:tnpr 5 'c 2 'd)) + 1 (cat:tnpr 7 (cat:allp 4 'a 3 'b) + 3 (cat:tnpr 0 '* 3 'c)) + 10 (cat:tnpr 8 (cat:allp 3 'aa 5 'bb) + 2 (cat:tnpr 0 '* 2 'cc)))) + (setf cat:*tnpr-with-degrees* nil))) #| (test ls-pre-left-hmeq-left-reduction (cat:cat-init) (let* ((rdct (cat:ls-pre-left-hmeq-left-reduction (cat:deltab))) - (allp (random-allp 3)) - (allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) - (gnrt (cat:tnpr allp-degr allp 4 (cat:tnpr 2 7 2 - (cat:loop3 0 15 2))))) - (cat:pre-check-rdct rdct) - (setf cat:*tc* (cat:cmbn (+ 4 allp-degr) 1 gnrt)) - (setf cat:*bc* (cat:cmbn 2 1 (cat:loop3 0 15 2))) - (check-rdct) - (setf gnrt (cat:tnpr allp-degr allp 4 - (cat:tnpr 0 1 4 (cat:loop3 0 (cat:mask 6) 2)))) - (setf cat:*tc* (cat:cmbn (+ 4 allp-degr) 1 gnrt)) - (check-rdct) - (setf cat:*bc* (cat:cmbn 0 1 (cat:bspn (cat:bcc rdct)))) - (setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn (cat:tcc rdct)))) - (check-rdct))) + (allp (random-allp 3)) + (allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) + (gnrt (cat:tnpr allp-degr allp 4 (cat:tnpr 2 7 2 + (cat:loop3 0 15 2))))) + (cat:pre-check-rdct rdct) + (setf cat:*tc* (cat:cmbn (+ 4 allp-degr) 1 gnrt)) + (setf cat:*bc* (cat:cmbn 2 1 (cat:loop3 0 15 2))) + (check-rdct) + (setf gnrt (cat:tnpr allp-degr allp 4 + (cat:tnpr 0 1 4 (cat:loop3 0 (cat:mask 6) 2)))) + (setf cat:*tc* (cat:cmbn (+ 4 allp-degr) 1 gnrt)) + (check-rdct) + (setf cat:*bc* (cat:cmbn 0 1 (cat:bspn (cat:bcc rdct)))) + (setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn (cat:tcc rdct)))) + (check-rdct))) |# (defun a (d1 d2 d3) (setf cat:*tc* (cat:cmbn (+ d1 d2 d3) - 1 (cat:tnpr - d1 (cat:allp d1 (cat:mask (+ d1 2))) - (+ d2 d3) - (cat:tnpr d2 (cat:mask (1+ d2)) - d3 (cat:loop3 - 0 (cat:mask (+ d3 2)) 1)))) - cat:*bc* (cat:cmbn d3 1 (cat:loop3 0 (cat:mask (+ d3 2)) -1))) + 1 (cat:tnpr + d1 (cat:allp d1 (cat:mask (+ d1 2))) + (+ d2 d3) + (cat:tnpr d2 (cat:mask (1+ d2)) + d3 (cat:loop3 + 0 (cat:mask (+ d3 2)) 1)))) + cat:*bc* (cat:cmbn d3 1 (cat:loop3 0 (cat:mask (+ d3 2)) -1))) (check-rdct)) (test ls-left-hmeq-left-reduction (cat:cat-init) (let ((rdct (cat:ls-left-hmeq-left-reduction (cat:deltab2)))) - (cat:pre-check-rdct rdct) - #| - (a 1 0 1) - (a 1 1 1) ;; error because 3 does not exist in deltab2 - (a 1 2 1) - (a 2 2 1) - |# - ) + (cat:pre-check-rdct rdct) + #| + (a 1 0 1) + (a 1 1 1) ;; error because 3 does not exist in deltab2 + (a 1 2 1) + (a 2 2 1) + |# + ) ) @@ -203,86 +178,86 @@ (test ls-pre-left-hmeq-right-reduction-intr-g (let ((r (cat:ls-pre-left-hmeq-right-reduction-intr-g '*))) - (funcall r (cat:cmbn 3 4 'a)))) + (funcall r (cat:cmbn 3 4 'a)))) (test ls-pre-left-hmeq-right-reduction (cat:cat-init) (let ((r (cat:ls-pre-left-hmeq-right-reduction (cat:deltab2)))) - (cat:pre-check-rdct r) - (setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn (cat:tcc r)))) - (setf cat:*bc* (cat:cmbn 0 1 (cat:bsgn (cat:bcc r)))) - (check-rdct) - #| - (setf cat:*tc* (cat:cmbn - 3 1 (cat:tnpr 3 (cat:allp 3 (cat:mask 5)) - 0 (cat:tnpr 0 1 0 cat:+null-loop+)))) - (setf cat:*bc* (cat:cmbn 3 1 (cat:allp 1 7 2 15))) - (check-rdct) - (setf cat:*tc* (cat:cmbn - 6 1 (cat:tnpr 3 (cat:allp 1 7 2 15) - 3 (cat:tnpr 2 7 1 (cat:loop3 0 7 2))))) - (check-rdct) - (setf cat:*tc* (cat:cmbn - 6 1 (cat:tnpr - 3 (cat:allp 1 7 2 15) - 3 (cat:tnpr 0 1 3 - (cat:loop3 0 (cat:mask 5) 2))))) - (check-rdct) - |# - )) + (cat:pre-check-rdct r) + (setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn (cat:tcc r)))) + (setf cat:*bc* (cat:cmbn 0 1 (cat:bsgn (cat:bcc r)))) + (check-rdct) + #| + (setf cat:*tc* (cat:cmbn + 3 1 (cat:tnpr 3 (cat:allp 3 (cat:mask 5)) + 0 (cat:tnpr 0 1 0 cat:+null-loop+)))) + (setf cat:*bc* (cat:cmbn 3 1 (cat:allp 1 7 2 15))) + (check-rdct) + (setf cat:*tc* (cat:cmbn + 6 1 (cat:tnpr 3 (cat:allp 1 7 2 15) + 3 (cat:tnpr 2 7 1 (cat:loop3 0 7 2))))) + (check-rdct) + (setf cat:*tc* (cat:cmbn + 6 1 (cat:tnpr + 3 (cat:allp 1 7 2 15) + 3 (cat:tnpr 0 1 3 + (cat:loop3 0 (cat:mask 5) 2))))) + (check-rdct) + |# + )) (test ls-left-hmeq-right-reduction (cat:cat-init) (let ((r (cat:ls-left-hmeq-right-reduction (cat:deltab2)))) - (cat:pre-check-rdct r) - (setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn (cat:tcc r)))) - (setf cat:*bc* (cat:cmbn 0 1 (cat:bsgn (cat:bcc r)))) - (check-rdct) - #| - (setf cat:*tc* (cat:cmbn 3 1 (cat:tnpr 3 (cat:allp 3 (cat:mask 5)) - 0 (cat:tnpr 0 1 0 - cat:+null-loop+)))) - (setf cat:*bc* (cat:cmbn 3 1 (cat:allp 1 7 2 15))) - (check-rdct) - (setf cat:*tc* (cat:cmbn - 6 1 (cat:tnpr 3 (cat:allp 1 7 2 15) - 3 (cat:tnpr 2 7 1 (cat:loop3 0 7 2))))) - (check-rdct) - (setf cat:*tc* (cat:cmbn - 6 1 (cat:tnpr 3 (cat:allp 1 7 2 15) - 3 (cat:tnpr 0 1 3 - (cat:loop3 0 (mask 5) 2))))) - (check-rdct) - |# - )) + (cat:pre-check-rdct r) + (setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn (cat:tcc r)))) + (setf cat:*bc* (cat:cmbn 0 1 (cat:bsgn (cat:bcc r)))) + (check-rdct) + #| + (setf cat:*tc* (cat:cmbn 3 1 (cat:tnpr 3 (cat:allp 3 (cat:mask 5)) + 0 (cat:tnpr 0 1 0 + cat:+null-loop+)))) + (setf cat:*bc* (cat:cmbn 3 1 (cat:allp 1 7 2 15))) + (check-rdct) + (setf cat:*tc* (cat:cmbn + 6 1 (cat:tnpr 3 (cat:allp 1 7 2 15) + 3 (cat:tnpr 2 7 1 (cat:loop3 0 7 2))))) + (check-rdct) + (setf cat:*tc* (cat:cmbn + 6 1 (cat:tnpr 3 (cat:allp 1 7 2 15) + 3 (cat:tnpr 0 1 3 + (cat:loop3 0 (mask 5) 2))))) + (check-rdct) + |# + )) #| (test ls-left-hmeq (cat:cat-init) (let* ((h (cat:ls-left-hmeq (cat:deltab2))) - (loop (cat:loop3 0 (cat:mask 5) 2)) - (allp (cat:allp 2 (cat:mask 4) 3 (cat:mask 5))) - x) - (setf x (cat:lg h 3 loop)) - (setf x (cat:rf h x)) - (setf x (cat:rg h x)) - (setf x (cat:lf h x)) - (setf x (cat:rg h 5 allp)) - (setf x (cat:lf h x)) - (setf x (cat:lg h x)) - (setf x (cat:rf h x)) ;; = allp, but why ? - )) + (loop (cat:loop3 0 (cat:mask 5) 2)) + (allp (cat:allp 2 (cat:mask 4) 3 (cat:mask 5))) + x) + (setf x (cat:lg h 3 loop)) + (setf x (cat:rf h x)) + (setf x (cat:rg h x)) + (setf x (cat:lf h x)) + (setf x (cat:rg h 5 allp)) + (setf x (cat:lf h x)) + (setf x (cat:lg h x)) + (setf x (cat:rf h x)) ;; = allp, but why ? + )) |# (test loop-space (cat:cat-init) (let ((l (cat:loop-space (cat:sphere 2))) - (oos3 (cat:loop-space (cat:loop-space (cat:sphere 3)))) - (ooos4 (cat:loop-space (cat:loop-space (cat:loop-space - (cat:sphere 4)))))) - (cat:homology l 6) - (cat:homology oos3 3) - (cat:homology ooos4 2))) + (oos3 (cat:loop-space (cat:loop-space (cat:sphere 3)))) + (ooos4 (cat:loop-space (cat:loop-space (cat:loop-space + (cat:sphere 4)))))) + (cat:homology l 6) + (cat:homology oos3 3) + (cat:homology ooos4 2))) From 90467b1895f557642ea3e9dac8ddfbeef19fb778 Mon Sep 17 00:00:00 2001 From: Gerd Heber Date: Wed, 18 Nov 2015 20:15:18 -0600 Subject: [PATCH 10/15] M-x untabify --- kenzo-test.asd | 80 +++++++++++++++++++++++++------------------------- 1 file changed, 40 insertions(+), 40 deletions(-) diff --git a/kenzo-test.asd b/kenzo-test.asd index 66bd9cb..1060796 100644 --- a/kenzo-test.asd +++ b/kenzo-test.asd @@ -8,43 +8,43 @@ :depends-on (:kenzo :fiveam) :pathname #P"test/" :components ((:file "package") - (:file "common") - ;; === test files === - (:file "bar-test") - (:file "bicones-test") - (:file "cartesian-products-test") - (:file "ccn") - (:file "chain-complexes-test") - (:file "chcm-elementary-op-test") - (:file "circle") - (:file "cl-space-efhm-test") - (:file "classifying-spaces-test") - (:file "cobar-test") - (:file "combinations-test") - (:file "cones-test") - (:file "cs-twisted-products-test") - (:file "delta-test") - (:file "diabolo") - (:file "disk-pasting-test") - (:file "eilenberg-zilber-test") - (:file "effective-homology-test") - (:file "fibrations-test") - (:file "homology-groups-test") - (:file "k-pi-n-test") - (:file "kan-test") - (:file "loop-spaces-test") - (:file "lp-space-efhm-test") - (:file "ls-twisted-products-test") - (:file "macros-test") - (:file "searching-homology-test") - (:file "serre-test") - (:file "simplicial-groups-test") - (:file "simplicial-mrphs-test") - (:file "simplicial-sets-test") - (:file "smith-test") - (:file "special-smsts-test") - (:file "suspensions-test") - (:file "tensor-products-test") - (:file "various-test") - (:file "whitehead-test") - )) + (:file "common") + ;; === test files === + (:file "bar-test") + (:file "bicones-test") + (:file "cartesian-products-test") + (:file "ccn") + (:file "chain-complexes-test") + (:file "chcm-elementary-op-test") + (:file "circle") + (:file "cl-space-efhm-test") + (:file "classifying-spaces-test") + (:file "cobar-test") + (:file "combinations-test") + (:file "cones-test") + (:file "cs-twisted-products-test") + (:file "delta-test") + (:file "diabolo") + (:file "disk-pasting-test") + (:file "eilenberg-zilber-test") + (:file "effective-homology-test") + (:file "fibrations-test") + (:file "homology-groups-test") + (:file "k-pi-n-test") + (:file "kan-test") + (:file "loop-spaces-test") + (:file "lp-space-efhm-test") + (:file "ls-twisted-products-test") + (:file "macros-test") + (:file "searching-homology-test") + (:file "serre-test") + (:file "simplicial-groups-test") + (:file "simplicial-mrphs-test") + (:file "simplicial-sets-test") + (:file "smith-test") + (:file "special-smsts-test") + (:file "suspensions-test") + (:file "tensor-products-test") + (:file "various-test") + (:file "whitehead-test") + )) From ffdcb9cd7fd1eff67b0ce192796ba33cfc8af85a Mon Sep 17 00:00:00 2001 From: Gerd Heber Date: Tue, 24 Nov 2015 20:14:03 -0600 Subject: [PATCH 11/15] Applied Francis' changes to remedy issue #44. It's still failing. --- src/cat-init.lisp | 4 +- test/bar-test.lisp | 139 ++++++++++++++--------------- test/common.lisp | 218 ++++++++++++++++++++++----------------------- 3 files changed, 180 insertions(+), 181 deletions(-) diff --git a/src/cat-init.lisp b/src/cat-init.lisp index 7bd42d9..5df62b8 100644 --- a/src/cat-init.lisp +++ b/src/cat-init.lisp @@ -60,8 +60,8 @@ (format t "~% FILE ~2D: ~A" i (car mark))) (DEFCONSTANT +SOURCE-EXTENSION+ - #+(or allegro clisp lispworks) "cl" - #+(or ccl ecl sbcl) "lisp" + #+(or allegro lispworks) "cl" + #+(or clisp ccl ecl sbcl) "lisp" #-(or allegro ccl clisp ecl lispworks sbcl) (error "Not an Allegro or CCL or CLisp or LispWorks or SBCL environment.")) diff --git a/test/bar-test.lisp b/test/bar-test.lisp index 7eab3db..256c5f5 100644 --- a/test/bar-test.lisp +++ b/test/bar-test.lisp @@ -1,4 +1,4 @@ - + (in-package :kenzo-test) (in-suite :kenzo) @@ -59,7 +59,7 @@ (defun random-abar1 (length) (let ((rslt nil)) (dotimes (i length) - (let* ((gmsm (random (cat:mask 7))) + (let* ((gmsm (random (cat:mask 6))) (dmns (1- (logcount gmsm)))) (when (plusp dmns) (push (cat:brgn (1+ dmns) (cat:d gmsm)) rslt)))) @@ -68,18 +68,18 @@ (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: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 @@ -177,65 +177,64 @@ 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)))) diff --git a/test/common.lisp b/test/common.lisp index 9d5e5e6..3196403 100644 --- a/test/common.lisp +++ b/test/common.lisp @@ -22,36 +22,36 @@ (defun cdelta (dmns) (the cat:chain-complex (cat:build-chcm - :cmpr #'cat:l-cmpr - :basis :locally-effective - :bsgn '(0) - :intr-dffr #'(lambda (degr gmsm) - (cat:make-cmbn - :degr (1- degr) - :list (do ((rslt cat:+empty-list+ - (cons (cons sign - (append - (subseq gmsm 0 nark) - (subseq gmsm (1+ nark)))) - rslt)) - (sign 1 (- sign)) - (nark 0 (1+ nark))) - ((> nark degr) rslt)))) - :strt :gnrt - :orgn `(locally effective version of C_* delta ,dmns)))) + :cmpr #'cat:l-cmpr + :basis :locally-effective + :bsgn '(0) + :intr-dffr #'(lambda (degr gmsm) + (cat:make-cmbn + :degr (1- degr) + :list (do ((rslt cat:+empty-list+ + (cons (cons sign + (append + (subseq gmsm 0 nark) + (subseq gmsm (1+ nark)))) + rslt)) + (sign 1 (- sign)) + (nark 0 (1+ nark))) + ((> nark degr) rslt)))) + :strt :gnrt + :orgn `(locally effective version of C_* delta ,dmns)))) (defun make-f (tdmns bdmns) (cat:build-mrph :sorc (cdelta tdmns) :trgt (cdelta bdmns) :degr 0 :intr #'(lambda (degr gmsm) - (let ((pos (position-if #'(lambda (vertex) - (>= vertex bdmns)) gmsm))) - (if pos - (if (< pos degr) - (cat:zero-cmbn degr) - (cat:cmbn degr 1 (nconc (butlast gmsm) (list bdmns)))) - (cat:cmbn degr 1 gmsm)))) + (let ((pos (position-if #'(lambda (vertex) + (>= vertex bdmns)) gmsm))) + (if pos + (if (< pos degr) + (cat:zero-cmbn degr) + (cat:cmbn degr 1 (nconc (butlast gmsm) (list bdmns)))) + (cat:cmbn degr 1 gmsm)))) :strt :gnrt :orgn `(projection delta ,tdmns => delta ,bdmns))) @@ -68,44 +68,44 @@ (cat:build-mrph :sorc (cdelta tdmns) :trgt (cdelta tdmns) :degr +1 :intr #'(lambda (degr gmsm) - (let ((pos (position-if #'(lambda (vertex) - (>= vertex bdmns)) gmsm))) - (if pos - (if (member bdmns gmsm) - (cat:zero-cmbn (1+ degr)) - (cat:cmbn (1+ degr) (cat:-1-expt-n pos) - (append (subseq gmsm 0 pos) (list bdmns) - (subseq gmsm pos)))) - (cat:zero-cmbn (1+ degr))))) + (let ((pos (position-if #'(lambda (vertex) + (>= vertex bdmns)) gmsm))) + (if pos + (if (member bdmns gmsm) + (cat:zero-cmbn (1+ degr)) + (cat:cmbn (1+ degr) (cat:-1-expt-n pos) + (append (subseq gmsm 0 pos) (list bdmns) + (subseq gmsm pos)))) + (cat:zero-cmbn (1+ degr))))) :strt :gnrt :orgn `(homotopy for delta ,tdmns => ,bdmns))) (defun make-rdct (tdmns bdmns) (let ((rdct (cat:build-rdct - :f (make-f tdmns bdmns) - :g (make-g tdmns bdmns) - :h (make-h tdmns bdmns) - :orgn `(reduction delta ,tdmns ,bdmns)))) + :f (make-f tdmns bdmns) + :g (make-g tdmns bdmns) + :h (make-h tdmns bdmns) + :orgn `(reduction delta ,tdmns ,bdmns)))) rdct)) (defun cdelta1 (dmns) (cat:build-chcm :cmpr #'cat:l-cmpr :basis #'(lambda (n) - (mapcar #'cat:dlop-int-ext (funcall (cat:delta-n-basis dmns) n))) + (mapcar #'cat:dlop-int-ext (funcall (cat:delta-n-basis dmns) n))) :bsgn '(0) :intr-dffr #'(lambda (degr gmsm) - (cat:make-cmbn - :degr (1- degr) - :list (do ((rslt cat:+empty-list+ - (cons (cons sign (append - (subseq gmsm 0 nark) - (subseq gmsm (1+ nark)))) - rslt)) - (sign 1 (- sign)) - (nark 0 (1+ nark))) - ((> nark degr) rslt)))) + (cat:make-cmbn + :degr (1- degr) + :list (do ((rslt cat:+empty-list+ + (cons (cons sign (append + (subseq gmsm 0 nark) + (subseq gmsm (1+ nark)))) + rslt)) + (sign 1 (- sign)) + (nark 0 (1+ nark))) + ((> nark degr) rslt)))) :strt :gnrt :orgn `(locally effective version of C_* delta ,dmns))) @@ -113,13 +113,13 @@ (cat:build-mrph :sorc (cdelta1 tdmns) :trgt (cdelta1 bdmns) :degr 0 :intr #'(lambda (degr gmsm) - (let ((pos (position-if #'(lambda (vertex) - (>= vertex bdmns)) gmsm))) - (if pos - (if (< pos degr) - (cat:zero-cmbn degr) - (cat:cmbn degr 1 (nconc (butlast gmsm) (list bdmns)))) - (cat:cmbn degr 1 gmsm)))) + (let ((pos (position-if #'(lambda (vertex) + (>= vertex bdmns)) gmsm))) + (if pos + (if (< pos degr) + (cat:zero-cmbn degr) + (cat:cmbn degr 1 (nconc (butlast gmsm) (list bdmns)))) + (cat:cmbn degr 1 gmsm)))) :strt :gnrt :orgn `(projection delta ,tdmns => delta ,bdmns))) @@ -136,58 +136,58 @@ (cat:build-mrph :sorc (cdelta1 tdmns) :trgt (cdelta1 tdmns) :degr +1 :intr #'(lambda (degr gmsm) - (let ((pos (position-if #'(lambda (vertex) - (>= vertex bdmns)) gmsm))) - (if pos - (if (member bdmns gmsm) - (cat:zero-cmbn (1+ degr)) - (cat:cmbn (1+ degr) (cat:-1-expt-n pos) - (append (subseq gmsm 0 pos) (list bdmns) - (subseq gmsm pos)))) - (cat:zero-cmbn (1+ degr))))) + (let ((pos (position-if #'(lambda (vertex) + (>= vertex bdmns)) gmsm))) + (if pos + (if (member bdmns gmsm) + (cat:zero-cmbn (1+ degr)) + (cat:cmbn (1+ degr) (cat:-1-expt-n pos) + (append (subseq gmsm 0 pos) (list bdmns) + (subseq gmsm pos)))) + (cat:zero-cmbn (1+ degr))))) :strt :gnrt :orgn `(homotopy for delta ,tdmns => ,bdmns))) (defun make-rdct1 (tdmns bdmns) (let ((rdct (cat:build-rdct - :f (make-f1 tdmns bdmns) - :g (make-g1 tdmns bdmns) - :h (make-h1 tdmns bdmns) - :orgn `(reduction delta ,tdmns ,bdmns)))) + :f (make-f1 tdmns bdmns) + :g (make-g1 tdmns bdmns) + :h (make-h1 tdmns bdmns) + :orgn `(reduction delta ,tdmns ,bdmns)))) rdct)) (defun check-rdct () (dolist (phi '(cat:*tdd* cat:*bdd* cat:*df-fd* cat:*dg-gd* cat:*id-fg* - cat:*id-gf-dh-hd* cat:*hh* cat:*fh* cat:*hg*)) + cat:*id-gf-dh-hd* cat:*hh* cat:*fh* cat:*hg*)) (declare (type symbol phi)) (is (cat:cmbn-zero-p - (cat:cmbn-? (eval phi) - (if (member phi '(cat:*bdd* cat:*dg-gd* cat:*id-fg* - cat:*dg-gd* cat:*hg*)) - cat:*bc* - cat:*tc*)))))) + (cat:cmbn-? (eval phi) + (if (member phi '(cat:*bdd* cat:*dg-gd* cat:*id-fg* + cat:*dg-gd* cat:*hg*)) + cat:*bc* + cat:*tc*)))))) (defun aleat-tc () (do ((tdegr 0 (+ tdegr degr)) (degr (+ 2 (random 3)) (+ 2 (random 3))) (gnrt (intern (coerce (vector (code-char (+ 65 (random 4)))) 'string)) - (intern (coerce (vector (code-char (+ 65 (random 4)))) 'string))) + (intern (coerce (vector (code-char (+ 65 (random 4)))) 'string))) (rslt nil (cons (cat:brgn degr gnrt) rslt))) - ((> tdegr 10) (setf cat:*tc* (cat:cmbn tdegr 1 (cat:make-abar - :list rslt)))))) + ((> tdegr 8) (setf cat:*tc* (cat:cmbn tdegr 1 (cat:make-abar + :list rslt)))))) (defun aleat-bc () (do ((tdegr 0 (+ tdegr degr)) (degr (1+ (random 4)) (1+ (random 4))) (gnrt (intern (coerce (vector (code-char (+ 67 (random 2)))) 'string)) - (intern (coerce (vector (code-char (+ 67 (random 2)))) 'string))) + (intern (coerce (vector (code-char (+ 67 (random 2)))) 'string))) (rslt nil (cons (cat:brgn degr gnrt) rslt))) - ((> tdegr 10) (setf cat:*bc* (cat:cmbn tdegr 1 (cat:make-abar - :list rslt)))))) + ((> tdegr 8) (setf cat:*bc* (cat:cmbn tdegr 1 (cat:make-abar + :list rslt)))))) (defun c () @@ -203,53 +203,53 @@ ((>= cum-degr tot-degr~) (cat:make-abar :list rslt)) (setf degr (1+ (random max-degr))) (push (cat:brgn (1+ degr) - (let ((list (make-list degr))) - (mapl - #'(lambda (sublist) - (setf (car sublist) (- (random 21) 10))) - list) - list)) - rslt))) + (let ((list (make-list degr))) + (mapl + #'(lambda (sublist) + (setf (car sublist) (- (random 21) 10))) + list) + list)) + rslt))) (defun random-allp (length) (let ((rslt nil)) (dotimes (i length) (let* ((gmsm (random (cat:mask 9))) - (dmns (1- (logcount gmsm)))) - (when (plusp dmns) - (push (cat:cbgn (1- dmns) gmsm) rslt)))) + (dmns (1- (logcount gmsm)))) + (when (plusp dmns) + (push (cat:cbgn (1- dmns) gmsm) rslt)))) (cat:make-allp :list rslt))) (defun random-apowr (dmns max-expn) (loop (let* ((dgop (random (cat:2-exp (1- dmns)))) - (gmsm (- dmns (logcount dgop)))) + (gmsm (- dmns (logcount dgop)))) (unless (< 0 gmsm 3) - (return-from random-apowr - (cat:apowr dgop gmsm (cat:srandom max-expn))))))) + (return-from random-apowr + (cat:apowr dgop gmsm (cat:srandom max-expn))))))) (defun random-cmbn (cmpr degr max-cffc max-expn loop-length cmbn-length) (apply #'cat:nterm-add cmpr degr - (mapcar #'(lambda (dummy) - (declare (ignore dummy)) + (mapcar #'(lambda (dummy) + (declare (ignore dummy)) (cat:term (cat:srandom max-cffc) - (random-crpr degr max-expn loop-length))) - (make-list cmbn-length)))) + (random-crpr degr max-expn loop-length))) + (make-list cmbn-length)))) (defun random-crpr (dmns max-expn length) (loop (let ((loop (cat:normalize-loop dmns - (random-niloop dmns max-expn length))) - (dgop (random (cat:2-exp dmns)))) + (random-niloop dmns max-expn length))) + (dgop (random (cat:2-exp dmns)))) (let ((absm (cat:2absm-acrpr (cat:absm dgop (- dmns (logcount dgop))) - loop))) - (when (and (zerop (cat:dgop absm)) - (not (< (cat:gmsm1 (cat:gmsm absm)) 3))) - (return (cat:gmsm absm))))))) + loop))) + (when (and (zerop (cat:dgop absm)) + (not (< (cat:gmsm1 (cat:gmsm absm)) 3))) + (return (cat:gmsm absm))))))) (defun random-loop-cmbn (cmpr degr max-cffc max-expn loop-length cmbn-length) @@ -259,13 +259,13 @@ ((zerop i) (apply #'cat:nterm-add cmpr degr rslt)) (setf term - (cat:term (cat:srandom max-cffc) - (cat:make-loop :list (random-niloop degr max-expn - loop-length)))))) + (cat:term (cat:srandom max-cffc) + (cat:make-loop :list (random-niloop degr max-expn + loop-length)))))) (defun random-niloop (dmns max-expn length) (mapcar #'(lambda (dummy) - (declare (ignore dummy)) - (random-apowr (1+ dmns) max-expn)) - (make-list length))) + (declare (ignore dummy)) + (random-apowr (1+ dmns) max-expn)) + (make-list length))) From c5c67b83fe0ad5d4fc8bb5a868b3e03f6a9301ed Mon Sep 17 00:00:00 2001 From: Gerd Heber Date: Thu, 26 Nov 2015 21:10:33 -0600 Subject: [PATCH 12/15] Formatting updates. --- kenzo-test.asd | 96 +++++++++++----------- test/bar-test.lisp | 200 ++++++++++++++++++++++----------------------- 2 files changed, 147 insertions(+), 149 deletions(-) diff --git a/kenzo-test.asd b/kenzo-test.asd index 1060796..92acd50 100644 --- a/kenzo-test.asd +++ b/kenzo-test.asd @@ -1,50 +1,50 @@ (defsystem :kenzo-test - :description "A simple regression test suite for Kenzo" - :serial t - :version "0.1.0" - :author "Francis Sergeraert " - :license "GPLv3" - :depends-on (:kenzo :fiveam) - :pathname #P"test/" - :components ((:file "package") - (:file "common") - ;; === test files === - (:file "bar-test") - (:file "bicones-test") - (:file "cartesian-products-test") - (:file "ccn") - (:file "chain-complexes-test") - (:file "chcm-elementary-op-test") - (:file "circle") - (:file "cl-space-efhm-test") - (:file "classifying-spaces-test") - (:file "cobar-test") - (:file "combinations-test") - (:file "cones-test") - (:file "cs-twisted-products-test") - (:file "delta-test") - (:file "diabolo") - (:file "disk-pasting-test") - (:file "eilenberg-zilber-test") - (:file "effective-homology-test") - (:file "fibrations-test") - (:file "homology-groups-test") - (:file "k-pi-n-test") - (:file "kan-test") - (:file "loop-spaces-test") - (:file "lp-space-efhm-test") - (:file "ls-twisted-products-test") - (:file "macros-test") - (:file "searching-homology-test") - (:file "serre-test") - (:file "simplicial-groups-test") - (:file "simplicial-mrphs-test") - (:file "simplicial-sets-test") - (:file "smith-test") - (:file "special-smsts-test") - (:file "suspensions-test") - (:file "tensor-products-test") - (:file "various-test") - (:file "whitehead-test") - )) + :description "A simple regression test suite for Kenzo" + :serial t + :version "0.1.0" + :author "Francis Sergeraert " + :license "GPLv3" + :depends-on (:kenzo :fiveam) + :pathname #P"test/" + :components ((:file "package") + (:file "common") + ;; === test files === + (:file "bar-test") + (:file "bicones-test") + (:file "cartesian-products-test") + (:file "ccn") + (:file "chain-complexes-test") + (:file "chcm-elementary-op-test") + (:file "circle") + (:file "cl-space-efhm-test") + (:file "classifying-spaces-test") + (:file "cobar-test") + (:file "combinations-test") + (:file "cones-test") + (:file "cs-twisted-products-test") + (:file "delta-test") + (:file "diabolo") + (:file "disk-pasting-test") + (:file "eilenberg-zilber-test") + (:file "effective-homology-test") + (:file "fibrations-test") + (:file "homology-groups-test") + (:file "k-pi-n-test") + (:file "kan-test") + (:file "loop-spaces-test") + (:file "lp-space-efhm-test") + (:file "ls-twisted-products-test") + (:file "macros-test") + (:file "searching-homology-test") + (:file "serre-test") + (:file "simplicial-groups-test") + (:file "simplicial-mrphs-test") + (:file "simplicial-sets-test") + (:file "smith-test") + (:file "special-smsts-test") + (:file "suspensions-test") + (:file "tensor-products-test") + (:file "various-test") + (:file "whitehead-test") + )) diff --git a/test/bar-test.lisp b/test/bar-test.lisp index 256c5f5..4bdc453 100644 --- a/test/bar-test.lisp +++ b/test/bar-test.lisp @@ -1,4 +1,3 @@ - (in-package :kenzo-test) (in-suite :kenzo) @@ -11,58 +10,58 @@ (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 6))) - (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) gmsm) rslt)))) (cat:make-abar :list rslt))) @@ -84,54 +83,53 @@ (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,42 +137,42 @@ (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 From c42b17899f8c4c0699508cd13362641b3d099656 Mon Sep 17 00:00:00 2001 From: Gerd Heber Date: Thu, 26 Nov 2015 21:27:08 -0600 Subject: [PATCH 13/15] Removed last loop as per Francis' comment. --- test/cl-space-efhm-test.lisp | 14 ++------------ 1 file changed, 2 insertions(+), 12 deletions(-) diff --git a/test/cl-space-efhm-test.lisp b/test/cl-space-efhm-test.lisp index 4272156..015f6e1 100644 --- a/test/cl-space-efhm-test.lisp +++ b/test/cl-space-efhm-test.lisp @@ -313,7 +313,7 @@ (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))) @@ -349,18 +349,8 @@ (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) From eb8146c42e27f74ca82ff3e97cd3ea21f33a2448 Mon Sep 17 00:00:00 2001 From: gheber Date: Sun, 29 Nov 2015 19:15:22 -0600 Subject: [PATCH 14/15] Added diabolo figure. --- examples/diabolo.graphml | 245 +++++++++++++++++++++++++++++++++++++++ examples/diabolo.svg | 113 ++++++++++++++++++ 2 files changed, 358 insertions(+) create mode 100644 examples/diabolo.graphml create mode 100644 examples/diabolo.svg diff --git a/examples/diabolo.graphml b/examples/diabolo.graphml new file mode 100644 index 0000000..2dab461 --- /dev/null +++ b/examples/diabolo.graphml @@ -0,0 +1,245 @@ + + + + + + + + + + + + + + + + + + + + + + + + S1 + + + + + + + + + + + + S0 + + + + + + + + + + + + S2 + + + + + + + + + + + + S345 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + S4 + + + + + + + + + + + + S3 + + + + + + + + + + + + + + + + + + S5 + + + + + + + + + + + + Diabolo + + + + + + + + + + + + + + + + + + S02 + + + + + + + + + + + + + S01 + + + + + + + + + + + + + S12 + + + + + + + + + + + + + S23 + + + + + + + + + + + + + S34 + + + + + + + + + + + + + S35 + + + + + + + + + + + + + S45 + + + + + + + + + + diff --git a/examples/diabolo.svg b/examples/diabolo.svg new file mode 100644 index 0000000..0f7feb7 --- /dev/null +++ b/examples/diabolo.svg @@ -0,0 +1,113 @@ + + + + + + + + + + + + + + + + + S1 + + + + + + + S0 + + + + + + + S2 + + + + + + + S345 + + + + + + + S4 + + + + + + + S3 + + + + + + + S5 + + Diabolo + + + + + + + S01 + + + + + + + S02 + + + + + + + S12 + + + + + + + S23 + + + + + + + S34 + + + + + + + S45 + + + + + + + S35 + + + From 578d7196836d7fdca05b2f68627eeb15e3579271 Mon Sep 17 00:00:00 2001 From: gheber Date: Sun, 29 Nov 2015 19:22:09 -0600 Subject: [PATCH 15/15] Updated figure. --- examples/diabolo.graphml | 68 +++++++++++++++++++------------------ examples/diabolo.svg | 72 +++++++++++++++++++++------------------- 2 files changed, 73 insertions(+), 67 deletions(-) diff --git a/examples/diabolo.graphml b/examples/diabolo.graphml index 2dab461..a6037ec 100644 --- a/examples/diabolo.graphml +++ b/examples/diabolo.graphml @@ -15,7 +15,24 @@ - + + + + + + + + + + + + + + + + + + @@ -26,8 +43,7 @@ - - + @@ -38,8 +54,7 @@ - - + @@ -50,8 +65,7 @@ - - + @@ -68,8 +82,7 @@ - - + @@ -87,8 +100,7 @@ - - + @@ -99,8 +111,7 @@ - - + @@ -117,8 +128,7 @@ - - + @@ -129,14 +139,13 @@ - - + - Diabolo + Diabolo @@ -147,8 +156,7 @@ - - + @@ -160,8 +168,7 @@ - - + @@ -173,21 +180,19 @@ - - + - S12 + S12 - - + @@ -199,8 +204,7 @@ - - + @@ -212,8 +216,7 @@ - - + @@ -225,8 +228,7 @@ - - + diff --git a/examples/diabolo.svg b/examples/diabolo.svg index 0f7feb7..d26bb15 100644 --- a/examples/diabolo.svg +++ b/examples/diabolo.svg @@ -1,112 +1,116 @@ - + - + - + - - + + - + + + + + S1 - + - + S0 - + - + S2 - - + + - + S345 - + - + S4 - + - + S3 - + - + S5 Diabolo - + - + S01 - + - + S02 - + - - S12 + + S12 - + - + S23 - + - + S34 - + - + S45 - + - + S35