diff --git a/kenzo-test.asd b/kenzo-test.asd index 92acd50..b2564e7 100644 --- a/kenzo-test.asd +++ b/kenzo-test.asd @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (defsystem :kenzo-test :description "A simple regression test suite for Kenzo" diff --git a/kenzo.asd b/kenzo.asd index c7a9c58..3971e95 100644 --- a/kenzo.asd +++ b/kenzo.asd @@ -1,4 +1,4 @@ -;;;; kenzo.asd +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :cl-user) @@ -16,52 +16,51 @@ :components ((:file "package") (:module "src" - :components - ((:file "kenzo") - (:file "abbreviations") - (:file "macros") - (:file "various") - (:file "classes") - (:file "combinations") - (:file "chain-complexes") - (:file "chcm-elementary-op") - (:file "effective-homology") - (:file "homology-groups") - (:file "searching-homology") - (:file "cones") - (:file "bicones") - (:file "tensor-products") - (:file "coalgebras") - (:file "cobar") - (:file "algebras") - (:file "bar") - (:file "simplicial-sets") - (:file "simplicial-mrphs") - (:file "delta") - (:file "special-smsts") - (:file "suspensions") - (:file "disk-pasting") - (:file "cartesian-products") - (:file "eilenberg-zilber") - (:file "kan") - (:file "simplicial-groups") - (:file "fibrations") - (:file "loop-spaces") - (:file "ls-twisted-products") - (:file "lp-space-efhm") - (:file "classifying-spaces") - (:file "k-pi-n") - (:file "serre") - (:file "cs-twisted-products") - (:file "cl-space-efhm") - (:file "whitehead") - (:file "smith") - #| - (:module "anromero" - :components - ((:file "bicomplexes") - (:file "filtered-complexes") - (:file "spectral-sequences"))) - |# - )))) - + :components + ((:file "kenzo") + (:file "abbreviations") + (:file "macros") + (:file "various") + (:file "classes") + (:file "combinations") + (:file "chain-complexes") + (:file "chcm-elementary-op") + (:file "effective-homology") + (:file "homology-groups") + (:file "searching-homology") + (:file "cones") + (:file "bicones") + (:file "tensor-products") + (:file "coalgebras") + (:file "cobar") + (:file "algebras") + (:file "bar") + (:file "simplicial-sets") + (:file "simplicial-mrphs") + (:file "delta") + (:file "special-smsts") + (:file "suspensions") + (:file "disk-pasting") + (:file "cartesian-products") + (:file "eilenberg-zilber") + (:file "kan") + (:file "simplicial-groups") + (:file "fibrations") + (:file "loop-spaces") + (:file "ls-twisted-products") + (:file "lp-space-efhm") + (:file "classifying-spaces") + (:file "k-pi-n") + (:file "serre") + (:file "cs-twisted-products") + (:file "cl-space-efhm") + (:file "whitehead") + (:file "smith") + #| + (:module "anromero" + :components + ((:file "bicomplexes") + (:file "filtered-complexes") + (:file "spectral-sequences"))) + |# + )))) diff --git a/package.lisp b/package.lisp index 708668a..e472234 100644 --- a/package.lisp +++ b/package.lisp @@ -1,6 +1,4 @@ -;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- -;;;; -;;;; package.lisp +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (defpackage #:cat (:use #:cl) diff --git a/run-kenzo-test.lisp b/run-kenzo-test.lisp index 7c086da..bceff46 100644 --- a/run-kenzo-test.lisp +++ b/run-kenzo-test.lisp @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (DECLAIM (OPTIMIZE (speed 3) (space 0) (debug 3))) diff --git a/src/Demo.lisp b/src/Demo.lisp index 9cada96..49d240a 100644 --- a/src/Demo.lisp +++ b/src/Demo.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; DEMO DEMO DEMO DEMO DEMO DEMO DEMO DEMO DEMO DEMO DEMO ;;; DEMO DEMO DEMO DEMO DEMO DEMO DEMO DEMO DEMO DEMO DEMO ;;; DEMO DEMO DEMO DEMO DEMO DEMO DEMO DEMO DEMO DEMO DEMO @@ -11,10 +13,10 @@ (terpri) (dotimes (i 50) (princ "-")) (princ "") -; (dotimes (i 31) (princ "-")) -; (terpri) + ; (dotimes (i 31) (princ "-")) + ; (terpri) (princ string) -; (terpri) + ; (terpri) (dotimes (i 50) (princ "-")) (values)) @@ -26,8 +28,8 @@ (terpri) (dotimes (i 50) (princ "-")) (princ "") -; (dotimes (i 29) (princ "-")) -; (terpri) + ; (dotimes (i 29) (princ "-")) + ; (terpri) (pprint ',statement) (terpri) ; (terpri) (dotimes (i 50) (princ "-")) @@ -51,14 +53,14 @@ (setf *statement* (read-from-string dstatement)) `(progn (terpri) - (dotimes (i 50) (princ "-")) - (princ "") - ; (dotimes (i 31) (princ "-")) - ; (terpri) - (princ (strip-initial-spaces *dstatement*)) - ; (terpri) - (dotimes (i 50) (princ "-")) - (values))) + (dotimes (i 50) (princ "-")) + (princ "") + ; (dotimes (i 31) (princ "-")) + ; (terpri) + (princ (strip-initial-spaces *dstatement*)) + ; (terpri) + (dotimes (i 50) (princ "-")) + (values))) ;; E = EXECUTE (DEFUN E () @@ -66,7 +68,7 @@ (terpri) (dotimes (i 50) (princ "-")) (princ "") -; (dotimes (i 32) (princ "-")) + ; (dotimes (i 32) (princ "-")) (terpri) ; (terpri) (prin1 (eval *statement*)) (terpri) ; (terpri) @@ -82,14 +84,14 @@ (terpri) (terpri) (restart-case (handler-bind ((error - #'(lambda (condition) - (format t "Type-error: ~S~&" - (class-name (class-of condition))) - (apply #'format t - (simple-condition-format-control condition) - (simple-condition-format-arguments condition)) - (invoke-restart 'my-restart)))) - (eval *statement*)) + #'(lambda (condition) + (format t "Type-error: ~S~&" + (class-name (class-of condition))) + (apply #'format t + (simple-condition-format-control condition) + (simple-condition-format-arguments condition)) + (invoke-restart 'my-restart)))) + (eval *statement*)) (my-restart () (values))) (terpri) (terpri) (dotimes (i 50) (princ "-")) @@ -97,4 +99,4 @@ (DEFMACRO M (statement) (eval statement) - '(values )) \ No newline at end of file + '(values )) diff --git a/src/abbreviations.lisp b/src/abbreviations.lisp index 2ac6dce..5059bf9 100644 --- a/src/abbreviations.lisp +++ b/src/abbreviations.lisp @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (IN-PACKAGE #:cat) @@ -119,7 +120,7 @@ "WHAT-IS returns the full word or term for an abbreviation provided as a keyword, string, or symbol. It returns NIL for unknown abbreviations." (unless (null kwd) - (getf +ABBREVIATIONS+ - (cond ((keywordp kwd) kwd) - ((stringp kwd) (intern (string-upcase kwd) 'keyword)) - ((symbolp kwd) (intern (symbol-name kwd) 'keyword)))))) + (getf +ABBREVIATIONS+ + (cond ((keywordp kwd) kwd) + ((stringp kwd) (intern (string-upcase kwd) 'keyword)) + ((symbolp kwd) (intern (symbol-name kwd) 'keyword)))))) diff --git a/src/algebras.lisp b/src/algebras.lisp index d3e9eef..fa5b9b3 100644 --- a/src/algebras.lisp +++ b/src/algebras.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; ALGEBRAS ALGEBRAS ALGEBRAS ALGEBRAS ALGEBRAS ALGEBRAS ;;; ALGEBRAS ALGEBRAS ALGEBRAS ALGEBRAS ALGEBRAS ALGEBRAS ;;; ALGEBRAS ALGEBRAS ALGEBRAS ALGEBRAS ALGEBRAS ALGEBRAS @@ -9,82 +11,81 @@ #+clisp(eval-when (:compile-toplevel :load-toplevel :execute) (setf (ext:package-lock :clos) nil)) (DEFMETHOD PRINT-OBJECT ((algb algebra) stream) - (the algebra - (progn - (format stream "[K~D Algebra]" (idnm algb)) - algb))) + (the algebra + (progn + (format stream "[K~D Algebra]" (idnm algb)) + algb))) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute) (setf (ext:package-lock :clos) t)) (DEFUN ALGB (idnm) - (declare (fixnum idnm)) - (the (or algebra null) - (find idnm *algb-list* :key #'idnm))) + (declare (fixnum idnm)) + (the (or algebra null) + (find idnm *algb-list* :key #'idnm))) (DEFUN BUILD-ALGB (&key cmpr basis bsgn intr-dffr dffr-strt intr-aprd aprd-strt orgn) - (declare - (type cmprf cmpr) - (type intr-mrph intr-dffr intr-aprd) - (type basis basis) - (type gnrt bsgn) - (type strt dffr-strt aprd-strt) - (list orgn)) - (the algebra - (progn + (declare + (type cmprf cmpr) + (type intr-mrph intr-dffr intr-aprd) + (type basis basis) + (type gnrt bsgn) + (type strt dffr-strt aprd-strt) + (list orgn)) + (the algebra + (progn (let ((already (find orgn *algb-list* :key #'orgn :test #'equal))) - (declare (type (or null algebra) already)) - (when already - (return-from build-algb already))) + (declare (type (or null algebra) already)) + (when already + (return-from build-algb already))) (let* ((rslt (build-chcm :cmpr cmpr :basis basis :bsgn bsgn - :intr-dffr intr-dffr :strt dffr-strt - :orgn orgn)) - ;; to be done before change-class - (rslt-rslt (tnsr-prdc rslt rslt))) - (declare (type chain-complex rslt rslt-rslt)) - (change-class rslt 'algebra) - (setf (slot-value rslt 'aprd) - (build-mrph :sorc rslt-rslt :trgt rslt :degr 0 - :intr intr-aprd :strt aprd-strt - :orgn `(algebra-product ,rslt))) - (push rslt *algb-list*) - rslt)))) + :intr-dffr intr-dffr :strt dffr-strt + :orgn orgn)) + ;; to be done before change-class + (rslt-rslt (tnsr-prdc rslt rslt))) + (declare (type chain-complex rslt rslt-rslt)) + (change-class rslt 'algebra) + (setf (slot-value rslt 'aprd) + (build-mrph :sorc rslt-rslt :trgt rslt :degr 0 + :intr intr-aprd :strt aprd-strt + :orgn `(algebra-product ,rslt))) + (push rslt *algb-list*) + rslt)))) (DEFUN CHANGE-CHCM-TO-ALGB (chcm &key intr-aprd aprd-strt orgn) - (declare - (type chain-complex chcm) - (type intr-mrph intr-aprd) - (type strt aprd-strt) - (list orgn)) - (the algebra - (let ((chcm-chcm (tnsr-prdc chcm chcm))) - (declare (type chain-complex chcm-chcm)) - (change-class chcm 'algebra) - (setf orgn (list (orgn chcm) 'then orgn)) - (let ((already (find orgn *algb-list* :key #'orgn :test #'equal))) - (declare (type (or null algebra) already)) - (when already - (return-from change-chcm-to-algb already))) - (setf (slot-value chcm 'aprd) (build-mrph - :sorc chcm-chcm :trgt chcm - :degr 0 - :intr intr-aprd :strt aprd-strt - :orgn orgn)) - (push chcm *algb-list*) - chcm))) + (declare + (type chain-complex chcm) + (type intr-mrph intr-aprd) + (type strt aprd-strt) + (list orgn)) + (the algebra + (let ((chcm-chcm (tnsr-prdc chcm chcm))) + (declare (type chain-complex chcm-chcm)) + (change-class chcm 'algebra) + (setf orgn (list (orgn chcm) 'then orgn)) + (let ((already (find orgn *algb-list* :key #'orgn :test #'equal))) + (declare (type (or null algebra) already)) + (when already + (return-from change-chcm-to-algb already))) + (setf (slot-value chcm 'aprd) (build-mrph + :sorc chcm-chcm :trgt chcm + :degr 0 + :intr intr-aprd :strt aprd-strt + :orgn orgn)) + (push chcm *algb-list*) + chcm))) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute) (setf (ext:package-lock :clos) nil)) (DEFMETHOD PRINT-OBJECT ((hopf hopf-algebra) stream) - (the hopf-algebra - (progn - (format stream "[K~D Hopf-Algebra]" (idnm hopf)) - hopf))) + (the hopf-algebra + (progn + (format stream "[K~D Hopf-Algebra]" (idnm hopf)) + hopf))) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute) (setf (ext:package-lock :clos) t)) (DEFUN HOPF (idnm) - (declare (fixnum idnm)) - (the (or hopf-algebra null) - (find idnm *hopf-list* :key #'idnm))) - + (declare (fixnum idnm)) + (the (or hopf-algebra null) + (find idnm *hopf-list* :key #'idnm))) diff --git a/src/bar.lisp b/src/bar.lisp index 1530da7..d06efef 100644 --- a/src/bar.lisp +++ b/src/bar.lisp @@ -1,5 +1,5 @@ -;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- -;;; +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; BAR BAR BAR BAR BAR BAR BAR BAR BAR ;;; BAR BAR BAR BAR BAR BAR BAR BAR BAR ;;; BAR BAR BAR BAR BAR BAR BAR BAR BAR diff --git a/src/bicones.lisp b/src/bicones.lisp index c8609e9..17c9971 100644 --- a/src/bicones.lisp +++ b/src/bicones.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; BICONES BICONES BICONES BICONES BICONES BICONES BICONES BICONES ;;; BICONES BICONES BICONES BICONES BICONES BICONES BICONES BICONES ;;; BICONES BICONES BICONES BICONES BICONES BICONES BICONES BICONES @@ -12,25 +14,25 @@ combinations and returns 3 values." (declare (type cmbn cmbn)) (the (values cmbn cmbn cmbn) (with-cmbn (degr list) cmbn - (let ((listb +empty-list+) - (listc +empty-list+) - (listd +empty-list+)) - (declare (list listb listc listd)) - (dolist (term list) - (declare (type term term)) - (with-term (cffc bicn) term - (with-bicn (bcnx ibicn) bicn - (ecase bcnx - (:bcnb (push (term cffc ibicn) - listb)) - (:bcnc (push (term cffc ibicn) - listc)) - (:bcnd (push (term cffc ibicn) - listd)))))) - (values - (make-cmbn :degr degr :list (nreverse listb)) - (make-cmbn :degr (1+ degr) :list (nreverse listc)) - (make-cmbn :degr degr :list (nreverse listd))))))) + (let ((listb +empty-list+) + (listc +empty-list+) + (listd +empty-list+)) + (declare (list listb listc listd)) + (dolist (term list) + (declare (type term term)) + (with-term (cffc bicn) term + (with-bicn (bcnx ibicn) bicn + (ecase bcnx + (:bcnb (push (term cffc ibicn) + listb)) + (:bcnc (push (term cffc ibicn) + listc)) + (:bcnd (push (term cffc ibicn) + listd)))))) + (values + (make-cmbn :degr degr :list (nreverse listb)) + (make-cmbn :degr (1+ degr) :list (nreverse listc)) + (make-cmbn :degr degr :list (nreverse listd))))))) (DEFUN BICN-CMBN-CMBNB (cmbn) @@ -40,19 +42,19 @@ n the B-component as a legal combination of degree n in B. If the B-component is empty, the null combination of degree n in B is returned." (the cmbn (with-cmbn (degr list) cmbn - (make-cmbn - :degr degr - :list (do ((rslt +empty-list+) - (mark list (cdr mark))) - ((endp mark) (nreverse rslt)) - (declare (list rslt mark)) - (with--term (cffc bicn) mark - (with-bicn (bcnx gnrtB) bicn - (if (eq bcnx :bcnB) - (push (term cffc gnrtB) - rslt) - (return - (nreverse rslt)))))))))) + (make-cmbn + :degr degr + :list (do ((rslt +empty-list+) + (mark list (cdr mark))) + ((endp mark) (nreverse rslt)) + (declare (list rslt mark)) + (with--term (cffc bicn) mark + (with-bicn (bcnx gnrtB) bicn + (if (eq bcnx :bcnB) + (push (term cffc gnrtB) + rslt) + (return + (nreverse rslt)))))))))) (DEFUN BICN-CMBN-CMBNC (cmbn) (declare (type cmbn cmbn)) @@ -61,24 +63,24 @@ n the C-component as a legal combination of degree n+1 in C. If the C-component is empty, the null combination of degree n+1 in C is returned." (the cmbn (with-cmbn (degr list) cmbn - (make-cmbn - :degr (1+ degr) - :list (do ((rslt +empty-list+) - (mark (member :bcnc list - ;; Correction 1-1-2 - :key #'(lambda (term) - (declare (type term term)) - (bcnx (gnrt term)))) - (cdr mark))) - ((endp mark) (nreverse rslt)) - (declare (list rslt mark)) - (with--term (cffc bicn) mark - (with-bicn (bcnx gnrtC) bicn - (if (eq bcnx :bcnC) - (push (term cffc gnrtC) - rslt) - (return - (nreverse rslt)))))))))) + (make-cmbn + :degr (1+ degr) + :list (do ((rslt +empty-list+) + (mark (member :bcnc list + ;; Correction 1-1-2 + :key #'(lambda (term) + (declare (type term term)) + (bcnx (gnrt term)))) + (cdr mark))) + ((endp mark) (nreverse rslt)) + (declare (list rslt mark)) + (with--term (cffc bicn) mark + (with-bicn (bcnx gnrtC) bicn + (if (eq bcnx :bcnC) + (push (term cffc gnrtC) + rslt) + (return + (nreverse rslt)))))))))) (DEFUN BICN-CMBN-CMBND (cmbn) @@ -88,18 +90,18 @@ n the D-component as a legal combination of degree n in D. If the D-component is empty, the null combination of degree n in D is returned." (the cmbn (with-cmbn (degr list) cmbn - (make-cmbn - :degr degr - :list (mapcar - #'(lambda (term) - (declare (type term term)) - (with-term (cffc bicn) term - (term cffc (ibicn bicn)))) - (member - :bcnd list - :key #'(lambda (term) - (declare (type term term)) - (the keyword (bcnx (gnrt term)))))))))) + (make-cmbn + :degr degr + :list (mapcar + #'(lambda (term) + (declare (type term term)) + (with-term (cffc bicn) term + (term cffc (ibicn bicn)))) + (member + :bcnd list + :key #'(lambda (term) + (declare (type term term)) + (the keyword (bcnx (gnrt term)))))))))) (DEFUN MAKE-BICN-CMBN (cmbnb cmbnc cmbnd) @@ -110,31 +112,31 @@ Combinations CMBNB and CMBND must be of the same degree n and combination CMBNC must be of degree n+1, yiedling a bicone combination of degree n." (the cmbn (with-cmbn - (degrb listb) cmbnb - (with-cmbn - (degrc listc) cmbnc - (with-cmbn - (degrd listd) cmbnd - (unless (= degrb (1- degrc) degrd) - (error "In MAKE-BICN-CMBN, the degrees are not coherent.")) - (make-cmbn - :degr degrb - :list (nconc - (mapcar #'(lambda (termb) - (declare (type term termb)) - (with-term (cffc gnrtb) termb - (term cffc (bcnb gnrtb)))) - listb) - (mapcar #'(lambda (termc) - (declare (type term termc)) - (with-term (cffc gnrtc) termc - (term cffc (bcnc gnrtc)))) - listc) - (mapcar #'(lambda (termd) - (declare (type term termd)) - (with-term (cffc gnrtd) termd - (term cffc (bcnd gnrtd)))) - listd)))))))) + (degrb listb) cmbnb + (with-cmbn + (degrc listc) cmbnc + (with-cmbn + (degrd listd) cmbnd + (unless (= degrb (1- degrc) degrd) + (error "In MAKE-BICN-CMBN, the degrees are not coherent.")) + (make-cmbn + :degr degrb + :list (nconc + (mapcar #'(lambda (termb) + (declare (type term termb)) + (with-term (cffc gnrtb) termb + (term cffc (bcnb gnrtb)))) + listb) + (mapcar #'(lambda (termc) + (declare (type term termc)) + (with-term (cffc gnrtc) termc + (term cffc (bcnc gnrtc)))) + listc) + (mapcar #'(lambda (termd) + (declare (type term termd)) + (with-term (cffc gnrtd) termd + (term cffc (bcnd gnrtd)))) + listd)))))))) (DEFUN BICN-PRINT (bicn stream depth) @@ -143,12 +145,12 @@ CMBNC must be of degree n+1, yiedling a bicone combination of degree n." (ignore depth)) (the bicn (with-bicn (bcnx ibicn) bicn - ;; Correction 1-1-2 - (format stream "" - ;; Correction 1-1-3 - (ecase bcnx (:bcnb #\B) (:bcnc #\C) (:bcnd #\D)) - ibicn) - bicn))) + ;; Correction 1-1-2 + (format stream "" + ;; Correction 1-1-3 + (ecase bcnx (:bcnb #\B) (:bcnc #\C) (:bcnd #\D)) + ibicn) + bicn))) (DEFUN BICONE-CMPR (cmprb cmprc cmprd) @@ -157,15 +159,15 @@ CMBNC must be of degree n+1, yiedling a bicone combination of degree n." generators, which is contructed from the comparison functions CMPRB, CMPRC and CMPRD." (flet ((rslt (bicn1 bicn2) - (declare (type bicn bicn1 bicn2)) - (let ((bcnx1 (bcnx bicn1))) - (declare (type (member :bcnb :bcnc :bcnd) bcnx1)) - (lexico - (s-cmpr bcnx1 (bcnx bicn2)) - (case bcnx1 - (:bcnb (funcall cmprb (ibicn bicn1) (ibicn bicn2))) - (:bcnc (funcall cmprc (ibicn bicn1) (ibicn bicn2))) - (:bcnd (funcall cmprd (ibicn bicn1) (ibicn bicn2)))))))) + (declare (type bicn bicn1 bicn2)) + (let ((bcnx1 (bcnx bicn1))) + (declare (type (member :bcnb :bcnc :bcnd) bcnx1)) + (lexico + (s-cmpr bcnx1 (bcnx bicn2)) + (case bcnx1 + (:bcnb (funcall cmprb (ibicn bicn1) (ibicn bicn2))) + (:bcnc (funcall cmprc (ibicn bicn1) (ibicn bicn2))) + (:bcnd (funcall cmprd (ibicn bicn1) (ibicn bicn2)))))))) (the cmprf #'rslt))) @@ -176,25 +178,25 @@ from the basis functions BASISB, BASISC and BASISD. If at least one is locally effective, the function returns the symbol :locally-effective." (the basis (if (or (eq :locally-effective basisb) - (eq :locally-effective basisc) - (eq :locally-effective basisd)) - :locally-effective - (flet ((rslt (degr) - (declare (fixnum degr)) - (append - (mapcar #'(lambda (item) - (declare (type gnrt item)) - (bcnb item)) - (funcall basisb degr)) - (mapcar #'(lambda (item) - (declare (type gnrt item)) - (bcnc item)) - (funcall basisc (1+ degr))) - (mapcar #'(lambda (item) - (declare (type gnrt item)) - (bcnd item)) - (funcall basisd degr))))) - (the basis #'rslt))))) + (eq :locally-effective basisc) + (eq :locally-effective basisd)) + :locally-effective + (flet ((rslt (degr) + (declare (fixnum degr)) + (append + (mapcar #'(lambda (item) + (declare (type gnrt item)) + (bcnb item)) + (funcall basisb degr)) + (mapcar #'(lambda (item) + (declare (type gnrt item)) + (bcnc item)) + (funcall basisc (1+ degr))) + (mapcar #'(lambda (item) + (declare (type gnrt item)) + (bcnd item)) + (funcall basisd degr))))) + (the basis #'rslt))))) (DEFUN BICONE-INTR-DFFR (cmprc dffrb dffrc dffrd f1 f2) @@ -203,22 +205,22 @@ locally effective, the function returns the symbol :locally-effective." (type morphism dffrb dffrc dffrd f1 f2)) "(BICONE-INTR-DFFR CMPRC DFFRB DFFRC DFFRD F1 F2) " (flet ((rslt (cmbn) - (declare (type cmbn cmbn)) - (the cmbn + (declare (type cmbn cmbn)) + (the cmbn (multiple-value-bind (cmbnb cmbnc cmbnd) - (dispatch-bicn-cmbn cmbn) - (declare (type cmbn cmbnb cmbnc cmbnd)) - (let ((dffrb (cmbn-? dffrb cmbnb)) - (dffrc (cmbn-? dffrc cmbnc)) - (dffrd (cmbn-? dffrd cmbnd)) - (f1 (cmbn-? f1 cmbnb)) - (f2 (cmbn-? f2 cmbnd))) - (declare (type cmbn dffrb dffrc dffrd f1 f2)) - (let ((cmbnc (2cmbn-sbtr cmprc - (2cmbn-add cmprc f1 f2) - dffrc))) - (declare (type cmbn cmbnc)) - (make-bicn-cmbn dffrb cmbnc dffrd))))))) + (dispatch-bicn-cmbn cmbn) + (declare (type cmbn cmbnb cmbnc cmbnd)) + (let ((dffrb (cmbn-? dffrb cmbnb)) + (dffrc (cmbn-? dffrc cmbnc)) + (dffrd (cmbn-? dffrd cmbnd)) + (f1 (cmbn-? f1 cmbnb)) + (f2 (cmbn-? f2 cmbnd))) + (declare (type cmbn dffrb dffrc dffrd f1 f2)) + (let ((cmbnc (2cmbn-sbtr cmprc + (2cmbn-add cmprc f1 f2) + dffrc))) + (declare (type cmbn cmbnc)) + (make-bicn-cmbn dffrb cmbnc dffrd))))))) (the intr-mrph #'rslt))) @@ -232,149 +234,149 @@ same, and C is that chain complex." (the chain-complex (with-slots ((tcc1 tcc) (bcc1 bcc) (f1 f)) rdct1 (declare - (type chain-complex tcc1 bcc1) - (type morphism f1)) - (with-slots ((tcc2 tcc) (bcc2 bcc) (f2 f)) rdct2 - (declare + (type chain-complex tcc1 bcc1) + (type morphism f1)) + (with-slots ((tcc2 tcc) (bcc2 bcc) (f2 f)) rdct2 + (declare (type chain-complex tcc2 bcc2) (type morphism f2)) - (unless (eq bcc1 bcc2) - (error "In BICONE, both reductions have different BCC's.")) - (let ((rslt (build-chcm + (unless (eq bcc1 bcc2) + (error "In BICONE, both reductions have different BCC's.")) + (let ((rslt (build-chcm :cmpr (bicone-cmpr (cmpr tcc1) (cmpr bcc1) (cmpr tcc2)) :basis (bicone-basis (basis tcc1) (basis bcc1) - (basis tcc2)) + (basis tcc2)) :bsgn :undefined :intr-dffr (bicone-intr-dffr (cmpr bcc1) - (dffr tcc1) (dffr bcc1) - (dffr tcc2) - f1 f2) + (dffr tcc1) (dffr bcc1) + (dffr tcc2) + f1 f2) :strt :cmbn :orgn `(bicone ,rdct1 ,rdct2)))) - (declare (type chain-complex rslt)) - ; (slot-makunbound rslt 'bsgn) - rslt))))) + (declare (type chain-complex rslt)) + ; (slot-makunbound rslt 'bsgn) + rslt))))) (DEFMETHOD CMPS ((hmeq1 homotopy-equivalence) (hmeq2 homotopy-equivalence) - &optional dummy) + &optional dummy) (declare (ignore dummy)) "(CMPS HMEQ1 HMEQ2 &OPTIONAL DUMMY) constructs a homotopy equivalence by composition of the homotopy equivalences HMEQ1 and HMEQ2." (the homotopy-equivalence (progn (when (eq 'trivial-hmeq (orgn hmeq2)) - (return-from cmps hmeq1)) + (return-from cmps hmeq1)) (with-slots ((cc-A lbcc) (cc-B tcc) (cc-C rbcc) (f1 lf) (g1 lg) (h1 lh) (f2 rf) (g2 rg) (h2 rh)) hmeq1 - (declare - (type chain-complex cc-A cc-B cc-C) - (type morphism f1 g1 h1 f2 g2 h2)) - (with-slots ((cc-C2 lbcc) (cc-D tcc) (cc-E rbcc) - (f3 lf) (g3 lg) (h3 lh) (f4 rf) (g4 rg) (h4 rh)) hmeq2 - (declare - (type chain-complex cc-C2 cc-D cc-E) - (type morphism f3 g3 h3 f4 g4 h4)) - (unless (eq (grmd cc-C) (grmd cc-C2)) + (declare + (type chain-complex cc-A cc-B cc-C) + (type morphism f1 g1 h1 f2 g2 h2)) + (with-slots ((cc-C2 lbcc) (cc-D tcc) (cc-E rbcc) + (f3 lf) (g3 lg) (h3 lh) (f4 rf) (g4 rg) (h4 rh)) hmeq2 + (declare + (type chain-complex cc-C2 cc-D cc-E) + (type morphism f3 g3 h3 f4 g4 h4)) + (unless (eq (grmd cc-C) (grmd cc-C2)) (error "In (CMPS HMEQ HMEQ), both hmeq's may not be composed.")) - (let ((bicone (bicone (rrdct hmeq1) (lrdct hmeq2))) - (cmpr-B (cmpr cc-B)) - (cmpr-D (cmpr cc-D))) + (let ((bicone (bicone (rrdct hmeq1) (lrdct hmeq2))) + (cmpr-B (cmpr cc-B)) + (cmpr-D (cmpr cc-D))) (declare (type chain-complex bicone)) (let ((lf (build-mrph - :sorc bicone :trgt cc-A :degr 0 - :intr #'(lambda (cmbn) - (declare (type cmbn cmbn)) - (cmbn-? f1 (bicn-cmbn-cmbnB cmbn))) - :strt :cmbn - :orgn `(cmps ,hmeq1 ,hmeq2 lf))) + :sorc bicone :trgt cc-A :degr 0 + :intr #'(lambda (cmbn) + (declare (type cmbn cmbn)) + (cmbn-? f1 (bicn-cmbn-cmbnB cmbn))) + :strt :cmbn + :orgn `(cmps ,hmeq1 ,hmeq2 lf))) (lg (build-mrph - :sorc cc-A :trgt bicone :degr 0 - :intr #'(lambda (cmbn) - (declare (type cmbn cmbn)) - (let* ((cmbnB (cmbn-? g1 cmbn)) - (cmbnC (zero-cmbn - (1+ (cmbn-degr cmbn)))) - (cmbnD (cmbn-? g3 - (cmbn-? f2 - (cmbn-opps - cmbnB))))) - (declare (type cmbn cmbnB cmbnC cmbnD)) - (make-bicn-cmbn cmbnB cmbnC cmbnD))) - :strt :cmbn - :orgn `(cmps ,hmeq1 ,hmeq2 lg))) + :sorc cc-A :trgt bicone :degr 0 + :intr #'(lambda (cmbn) + (declare (type cmbn cmbn)) + (let* ((cmbnB (cmbn-? g1 cmbn)) + (cmbnC (zero-cmbn + (1+ (cmbn-degr cmbn)))) + (cmbnD (cmbn-? g3 + (cmbn-? f2 + (cmbn-opps + cmbnB))))) + (declare (type cmbn cmbnB cmbnC cmbnD)) + (make-bicn-cmbn cmbnB cmbnC cmbnD))) + :strt :cmbn + :orgn `(cmps ,hmeq1 ,hmeq2 lg))) (lh (build-mrph - :sorc bicone :trgt bicone :degr +1 - :intr #'(lambda (cmbn) - (declare (type cmbn cmbn)) - (multiple-value-bind (cmbnB cmbnC cmbnD) - (dispatch-bicn-cmbn cmbn) - (declare (type cmbn cmbnB cmbnC cmbnD)) - (setf cmbnB (cmbn-? h1 cmbnB)) - (let ((cmbnC (zero-cmbn - (1+ (cmbn-degr cmbnC)))) - (cmbnD1 (cmbn-? g3 - (cmbn-? f2 cmbnB))) - (cmbnD2 (cmbn-? g3 cmbnC)) ;; let, not let* - (cmbnD3 (cmbn-? h3 cmbnD))) - (declare (type cmbn cmbnC cmbnD1 cmbnD2 - cmbnD3)) - (make-bicn-cmbn - cmbnB - cmbnC - (2cmbn-sbtr cmpr-D - (2cmbn-add cmpr-D cmbnD2 - cmbnD3) - cmbnD1))))) - :strt :cmbn - :orgn `(cmps ,hmeq1 ,hmeq2 lh))) + :sorc bicone :trgt bicone :degr +1 + :intr #'(lambda (cmbn) + (declare (type cmbn cmbn)) + (multiple-value-bind (cmbnB cmbnC cmbnD) + (dispatch-bicn-cmbn cmbn) + (declare (type cmbn cmbnB cmbnC cmbnD)) + (setf cmbnB (cmbn-? h1 cmbnB)) + (let ((cmbnC (zero-cmbn + (1+ (cmbn-degr cmbnC)))) + (cmbnD1 (cmbn-? g3 + (cmbn-? f2 cmbnB))) + (cmbnD2 (cmbn-? g3 cmbnC)) ;; let, not let* + (cmbnD3 (cmbn-? h3 cmbnD))) + (declare (type cmbn cmbnC cmbnD1 cmbnD2 + cmbnD3)) + (make-bicn-cmbn + cmbnB + cmbnC + (2cmbn-sbtr cmpr-D + (2cmbn-add cmpr-D cmbnD2 + cmbnD3) + cmbnD1))))) + :strt :cmbn + :orgn `(cmps ,hmeq1 ,hmeq2 lh))) (rf (build-mrph - :sorc bicone :trgt cc-E :degr 0 - :intr #'(lambda (cmbn) - (declare (type cmbn cmbn)) - (cmbn-? f4 (bicn-cmbn-cmbnD cmbn))) - :strt :cmbn - :orgn `(cmps ,hmeq1 ,hmeq2 rf))) + :sorc bicone :trgt cc-E :degr 0 + :intr #'(lambda (cmbn) + (declare (type cmbn cmbn)) + (cmbn-? f4 (bicn-cmbn-cmbnD cmbn))) + :strt :cmbn + :orgn `(cmps ,hmeq1 ,hmeq2 rf))) (rg (build-mrph - :sorc cc-E :trgt bicone :degr 0 - :intr #'(lambda (cmbn) - (declare (type cmbn cmbn)) - (let* ((cmbnD (cmbn-? g4 cmbn)) - (cmbnC (zero-cmbn - (1+ (cmbn-degr cmbn)))) - (cmbnB - (cmbn-? - g2 (cmbn-? f3 (cmbn-opps cmbnD))))) - (declare (type cmbn cmbnD cmbnC cmbnB)) - (make-bicn-cmbn cmbnB cmbnC cmbnD))) - :strt :cmbn - :orgn `(cmps ,hmeq1 ,hmeq2 rg))) + :sorc cc-E :trgt bicone :degr 0 + :intr #'(lambda (cmbn) + (declare (type cmbn cmbn)) + (let* ((cmbnD (cmbn-? g4 cmbn)) + (cmbnC (zero-cmbn + (1+ (cmbn-degr cmbn)))) + (cmbnB + (cmbn-? + g2 (cmbn-? f3 (cmbn-opps cmbnD))))) + (declare (type cmbn cmbnD cmbnC cmbnB)) + (make-bicn-cmbn cmbnB cmbnC cmbnD))) + :strt :cmbn + :orgn `(cmps ,hmeq1 ,hmeq2 rg))) (rh (build-mrph - :sorc bicone :trgt bicone :degr +1 - :intr #'(lambda (cmbn) - (declare (type cmbn cmbn)) - (multiple-value-bind (cmbnB cmbnC cmbnD) - (dispatch-bicn-cmbn cmbn) - (declare (type cmbn cmbnB cmbnC cmbnD)) - (setf cmbnD (cmbn-? h4 cmbnD)) - (let ((cmbnC (zero-cmbn - (1+ (cmbn-degr cmbnC)))) - (cmbnB1 (cmbn-? g2 - (cmbn-? f3 cmbnD))) - (cmbnB2 (cmbn-? g2 cmbnC)) ;; let, not let* - (cmbnB3 (cmbn-? h2 cmbnB))) - (declare (type cmbn cmbnC cmbnB1 cmbnB2 - cmbnB3)) - (make-bicn-cmbn - (2cmbn-sbtr cmpr-B - (2cmbn-add cmpr-B cmbnB2 - cmbnB3) - cmbnB1) - cmbnC - cmbnD)))) - :strt :cmbn - :orgn `(cmps ,hmeq1 ,hmeq2 rh)))) - (declare - (type morphism lf lg lh rf rg rh)) - (build-hmeq :lf lf :lg lg :lh lh :rf rf :rg rg :rh rh - :orgn `(cmps ,hmeq1 ,hmeq2))))))))) + :sorc bicone :trgt bicone :degr +1 + :intr #'(lambda (cmbn) + (declare (type cmbn cmbn)) + (multiple-value-bind (cmbnB cmbnC cmbnD) + (dispatch-bicn-cmbn cmbn) + (declare (type cmbn cmbnB cmbnC cmbnD)) + (setf cmbnD (cmbn-? h4 cmbnD)) + (let ((cmbnC (zero-cmbn + (1+ (cmbn-degr cmbnC)))) + (cmbnB1 (cmbn-? g2 + (cmbn-? f3 cmbnD))) + (cmbnB2 (cmbn-? g2 cmbnC)) ;; let, not let* + (cmbnB3 (cmbn-? h2 cmbnB))) + (declare (type cmbn cmbnC cmbnB1 cmbnB2 + cmbnB3)) + (make-bicn-cmbn + (2cmbn-sbtr cmpr-B + (2cmbn-add cmpr-B cmbnB2 + cmbnB3) + cmbnB1) + cmbnC + cmbnD)))) + :strt :cmbn + :orgn `(cmps ,hmeq1 ,hmeq2 rh)))) + (declare + (type morphism lf lg lh rf rg rh)) + (build-hmeq :lf lf :lg lg :lh lh :rf rf :rg rg :rh rh + :orgn `(cmps ,hmeq1 ,hmeq2))))))))) diff --git a/src/cartesian-products.lisp b/src/cartesian-products.lisp index 58f0610..d60fb9c 100644 --- a/src/cartesian-products.lisp +++ b/src/cartesian-products.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS ;;; CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS ;;; CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS @@ -14,8 +16,8 @@ (ignore depth)) (with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr (format stream "" - (hyphenize-list (dgop-int-ext dgop1)) gmsm1 - (hyphenize-list (dgop-int-ext dgop2)) gmsm2) + (hyphenize-list (dgop-int-ext dgop1)) gmsm1 + (hyphenize-list (dgop-int-ext dgop2)) gmsm2) crpr)) @@ -24,11 +26,11 @@ (let ((dgop (logand dgop1 dgop2))) (declare (fixnum dgop)) (do ((indx (1- (integer-length dgop)) (1- indx))) - ((minusp indx)) + ((minusp indx)) (declare (fixnum indx)) (when (logbitp indx dgop) - (setf dgop1 (remove-bit dgop1 indx) - dgop2 (remove-bit dgop2 indx)))) + (setf dgop1 (remove-bit dgop1 indx) + dgop2 (remove-bit dgop2 indx)))) (values dgop dgop1 dgop2))) @@ -36,128 +38,128 @@ (declare (type absm absm1 absm2)) (the absm (with-absm (dgop1 gmsm1) absm1 - (with-absm (dgop2 gmsm2) absm2 - (multiple-value-bind (dgop dgop11 dgop22) - (extract-common-dgop dgop1 dgop2) - (declare (fixnum dgop dgop11 dgop22)) - (absm dgop - (crpr dgop11 gmsm1 dgop22 gmsm2))))))) + (with-absm (dgop2 gmsm2) absm2 + (multiple-value-bind (dgop dgop11 dgop22) + (extract-common-dgop dgop1 dgop2) + (declare (fixnum dgop dgop11 dgop22)) + (absm dgop + (crpr dgop11 gmsm1 dgop22 gmsm2))))))) #| (DEFUN CRTS-PRDC-CMPR (cmpr1 cmpr2) (declare (type cmprf cmpr1 cmpr2)) (flet ((rslt (crpr1 crpr2) - (declare (type crpr crpr1 crpr2)) - (the cmpr + (declare (type crpr crpr1 crpr2)) + (the cmpr (let ((left-cons-1 (cadr crpr1)) (left-cons-2 (cadr crpr2))) - (declare (cons left-cons-1 left-cons-2)) - (lexico - (f-cmpr (car left-cons-1) (car left-cons-2)) - (let ((right-cons-1 (cddr crpr1)) - (right-cons-2 (cddr crpr2))) - (declare (cons right-cons-1 right-cons-2)) - (lexico - (f-cmpr (car right-cons-1) (car right-cons-2)) - (funcall cmpr1 (cdr left-cons-1) (cdr left-cons-2)) - (funcall cmpr2 (cdr right-cons-1) (cdr right-cons-2))))))))) + (declare (cons left-cons-1 left-cons-2)) + (lexico + (f-cmpr (car left-cons-1) (car left-cons-2)) + (let ((right-cons-1 (cddr crpr1)) + (right-cons-2 (cddr crpr2))) + (declare (cons right-cons-1 right-cons-2)) + (lexico + (f-cmpr (car right-cons-1) (car right-cons-2)) + (funcall cmpr1 (cdr left-cons-1) (cdr left-cons-2)) + (funcall cmpr2 (cdr right-cons-1) (cdr right-cons-2))))))))) (the cmprf #'rslt))) |# (DEFUN CRTS-PRDC-CMPR (cmpr1 cmpr2) (declare (type cmprf cmpr1 cmpr2)) (flet ((rslt (crpr1 crpr2) - (declare (type crpr crpr1 crpr2)) - (the cmpr - (lexico - (f-cmpr (dgop1 crpr1) (dgop1 crpr2)) - (f-cmpr (dgop2 crpr1) (dgop2 crpr2)) - (funcall cmpr1 (gmsm1 crpr1) (gmsm1 crpr2)) - (funcall cmpr2 (gmsm2 crpr1) (gmsm2 crpr2)))))) + (declare (type crpr crpr1 crpr2)) + (the cmpr + (lexico + (f-cmpr (dgop1 crpr1) (dgop1 crpr2)) + (f-cmpr (dgop2 crpr1) (dgop2 crpr2)) + (funcall cmpr1 (gmsm1 crpr1) (gmsm1 crpr2)) + (funcall cmpr2 (gmsm2 crpr1) (gmsm2 crpr2)))))) (the cmprf #'rslt))) (DEFUN CRTS-PRDC-BASIS (basis1 basis2) (declare (type basis basis1 basis2)) (when (or (eq basis1 :locally-effective) - (eq basis2 :locally-effective)) + (eq basis2 :locally-effective)) (return-from crts-prdc-basis :locally-effective)) (flet ((rslt (dmns) - (declare (fixnum dmns)) - (the list + (declare (fixnum dmns)) + (the list (progn - (when (minusp dmns) - (return-from rslt +empty-list+)) - (let ((array1 (make-array (1+ dmns))) - (array2 (make-array (1+ dmns))) - (rslt +empty-list+) - (mask (mask dmns))) - (declare - (simple-vector array1 array2) - (list rslt) - (fixnum mask)) - (dotimes (i (1+ dmns)) - (setf (svref array1 i) (funcall basis1 i) - (svref array2 i) (funcall basis2 i))) - (do ((dgop1 mask (1- dgop1))) - ((minusp dgop1)) - (declare (fixnum dgop1)) - (let ((dmns1 (- dmns (logcount dgop1)))) - (declare (fixnum dmns1)) - (do ((dgop2 mask (1- dgop2))) - ((minusp dgop2)) - (declare (fixnum dgop2)) - (unless (plusp (logand dgop1 dgop2)) - (setf rslt - (nconc - (mapcan - #'(lambda (item1) - (declare (type gmsm item1)) - (mapcar - #'(lambda (item2) - (declare (type gmsm item2)) - (crpr dgop1 item1 dgop2 item2)) - (svref array2 (- dmns - (logcount dgop2))))) - (svref array1 dmns1)) - rslt)))))) - rslt))))) + (when (minusp dmns) + (return-from rslt +empty-list+)) + (let ((array1 (make-array (1+ dmns))) + (array2 (make-array (1+ dmns))) + (rslt +empty-list+) + (mask (mask dmns))) + (declare + (simple-vector array1 array2) + (list rslt) + (fixnum mask)) + (dotimes (i (1+ dmns)) + (setf (svref array1 i) (funcall basis1 i) + (svref array2 i) (funcall basis2 i))) + (do ((dgop1 mask (1- dgop1))) + ((minusp dgop1)) + (declare (fixnum dgop1)) + (let ((dmns1 (- dmns (logcount dgop1)))) + (declare (fixnum dmns1)) + (do ((dgop2 mask (1- dgop2))) + ((minusp dgop2)) + (declare (fixnum dgop2)) + (unless (plusp (logand dgop1 dgop2)) + (setf rslt + (nconc + (mapcan + #'(lambda (item1) + (declare (type gmsm item1)) + (mapcar + #'(lambda (item2) + (declare (type gmsm item2)) + (crpr dgop1 item1 dgop2 item2)) + (svref array2 (- dmns + (logcount dgop2))))) + (svref array1 dmns1)) + rslt)))))) + rslt))))) (the basis #'rslt))) (DEFUN CRTS-PRDC-FACE (face1 face2) (declare (type face face1 face2)) (flet ((rslt (indx dmns crpr) - (declare - (fixnum indx dmns) - (type crpr crpr)) - (with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr - (multiple-value-bind (dgop1 del1) (1dlop-dgop indx dgop1) - (declare - (fixnum dgop1) - (type (or null fixnum) del1)) - (multiple-value-bind (dgop2 del2) (1dlop-dgop indx - dgop2) - (declare - (fixnum dgop2) - (type (or null fixnum) del2)) - (when del1 - (let ((absm1 (funcall face1 del1 (- dmns (logcount - dgop1)) - gmsm1))) - (declare (type absm absm1)) - (setf dgop1 (dgop*dgop dgop1 (dgop absm1)) - gmsm1 (gmsm absm1)))) - (when del2 - (let ((absm2 (funcall face2 del2 (- dmns (logcount - dgop2)) - gmsm2))) - (declare (type absm absm2)) - (setf dgop2 (dgop*dgop dgop2 (dgop absm2)) - gmsm2 (gmsm absm2)))) - (multiple-value-bind (dgop dgop1 dgop2) - (extract-common-dgop dgop1 dgop2) + (declare + (fixnum indx dmns) + (type crpr crpr)) + (with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr + (multiple-value-bind (dgop1 del1) (1dlop-dgop indx dgop1) + (declare + (fixnum dgop1) + (type (or null fixnum) del1)) + (multiple-value-bind (dgop2 del2) (1dlop-dgop indx + dgop2) + (declare + (fixnum dgop2) + (type (or null fixnum) del2)) + (when del1 + (let ((absm1 (funcall face1 del1 (- dmns (logcount + dgop1)) + gmsm1))) + (declare (type absm absm1)) + (setf dgop1 (dgop*dgop dgop1 (dgop absm1)) + gmsm1 (gmsm absm1)))) + (when del2 + (let ((absm2 (funcall face2 del2 (- dmns (logcount + dgop2)) + gmsm2))) + (declare (type absm absm2)) + (setf dgop2 (dgop*dgop dgop2 (dgop absm2)) + gmsm2 (gmsm absm2)))) + (multiple-value-bind (dgop dgop1 dgop2) + (extract-common-dgop dgop1 dgop2) (declare (fixnum dgop dgop1 dgop2)) (absm dgop (crpr dgop1 gmsm1 dgop2 gmsm2)))))))) (the face #'rslt))) @@ -166,36 +168,36 @@ (DEFUN CRTS-PRDC-FACE* (face1 face2) (declare (type face face1 face2)) (flet ((rslt (indx dmns crpr) - (declare - (fixnum indx dmns) - (type crpr crpr)) - (with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr - (multiple-value-bind (dgop1 del1) (1dlop-dgop indx dgop1) - (declare - (fixnum dgop1) - (type (or null fixnum) del1)) - (multiple-value-bind (dgop2 del2) (1dlop-dgop indx - dgop2) - (declare - (fixnum dgop2) - (type (or null fixnum) del2)) - (when del1 - (let ((absm1 (funcall face1 del1 (- dmns (logcount - dgop1)) - gmsm1))) - (declare (type absm absm1)) - (setf dgop1 (dgop*dgop dgop1 (dgop absm1)) - gmsm1 (gmsm absm1)))) - (when del2 - (let ((absm2 (funcall face2 del2 (- dmns (logcount - dgop2)) - gmsm2))) - (declare (type absm absm2)) - (setf dgop2 (dgop*dgop dgop2 (dgop absm2)) - gmsm2 (gmsm absm2)))) - (if (plusp (logand dgop1 dgop2)) - :degenerate - (crpr dgop1 gmsm1 dgop2 gmsm2))))))) + (declare + (fixnum indx dmns) + (type crpr crpr)) + (with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr + (multiple-value-bind (dgop1 del1) (1dlop-dgop indx dgop1) + (declare + (fixnum dgop1) + (type (or null fixnum) del1)) + (multiple-value-bind (dgop2 del2) (1dlop-dgop indx + dgop2) + (declare + (fixnum dgop2) + (type (or null fixnum) del2)) + (when del1 + (let ((absm1 (funcall face1 del1 (- dmns (logcount + dgop1)) + gmsm1))) + (declare (type absm absm1)) + (setf dgop1 (dgop*dgop dgop1 (dgop absm1)) + gmsm1 (gmsm absm1)))) + (when del2 + (let ((absm2 (funcall face2 del2 (- dmns (logcount + dgop2)) + gmsm2))) + (declare (type absm absm2)) + (setf dgop2 (dgop*dgop dgop2 (dgop absm2)) + gmsm2 (gmsm absm2)))) + (if (plusp (logand dgop1 dgop2)) + :degenerate + (crpr dgop1 gmsm1 dgop2 gmsm2))))))) (the intr-mrph #'rslt))) @@ -212,7 +214,7 @@ (type basis basis2) (type face face2)) (the simplicial-set - (build-smst + (build-smst :cmpr (crts-prdc-cmpr cmpr1 cmpr2) :basis (crts-prdc-basis basis1 basis2) :bspn (crpr 0 bspn1 0 bspn2) diff --git a/src/cat-init.lisp b/src/cat-init.lisp index 5df62b8..15da0f3 100644 --- a/src/cat-init.lisp +++ b/src/cat-init.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; FILES FILES FILES FILES FILES FILES FILES FILES FILES FILES ;;; FILES FILES FILES FILES FILES FILES FILES FILES FILES FILES ;;; FILES FILES FILES FILES FILES FILES FILES FILES FILES FILES @@ -14,67 +16,66 @@ (PROCLAIM '(OPTIMIZE (speed 3) (safety 1) (space 0) (debug 0))) (DEFCONSTANT +FILE-LIST+ - '("kenzo" - "macros" - "various" - "classes" - "combinations" - "chain-complexes" - "chcm-elementary-op" - "effective-homology" - "homology-groups" - "searching-homology" - "cones" - "bicones" - "tensor-products" - "coalgebras" - "cobar" - "algebras" - "bar" - "simplicial-sets" - "simplicial-mrphs" - "delta" - "special-smsts" - "suspensions" - "disk-pasting" - "cartesian-products" - "eilenberg-zilber" - "kan" - "simplicial-groups" - "fibrations" - "loop-spaces" - "ls-twisted-products" - "lp-space-efhm" - "classifying-spaces" - "k-pi-n" - "serre" - "cs-twisted-products" - "cl-space-efhm" - "whitehead" - "smith" - )) + '("kenzo" + "macros" + "various" + "classes" + "combinations" + "chain-complexes" + "chcm-elementary-op" + "effective-homology" + "homology-groups" + "searching-homology" + "cones" + "bicones" + "tensor-products" + "coalgebras" + "cobar" + "algebras" + "bar" + "simplicial-sets" + "simplicial-mrphs" + "delta" + "special-smsts" + "suspensions" + "disk-pasting" + "cartesian-products" + "eilenberg-zilber" + "kan" + "simplicial-groups" + "fibrations" + "loop-spaces" + "ls-twisted-products" + "lp-space-efhm" + "classifying-spaces" + "k-pi-n" + "serre" + "cs-twisted-products" + "cl-space-efhm" + "whitehead" + "smith")) (DO ((i 1 (1+ i)) (mark +file-list+ (cdr mark))) ((endp mark) (terpri)) - (format t "~% FILE ~2D: ~A" i (car mark))) + (format t "~% FILE ~2D: ~A" i (car mark))) (DEFCONSTANT +SOURCE-EXTENSION+ #+(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.")) + (error "Not an Allegro or CCL or CLisp or LispWorks or SBCL environment.")) -(DEFCONSTANT +COMPILED-EXTENSION+ - #+(or allegro sbcl) "fasl" - #+ccl "lafsl" - #+ (or clisp ecl) "fas" - #+lispworks "ofasl") +(DEFCONSTANT +COMPILED-EXTENSION+ + #+(or allegro sbcl) "fasl" + #+ccl "lafsl" + #+ (or clisp ecl) "fas" + #+lispworks "ofasl") (DEFUN LOAD-SFILES () - (mapc #'(lambda (file-name) - (load (concatenate 'string file-name "." +source-extension+))) - +file-list+)) + (mapc #'(lambda (file-name) + (load (concatenate 'string file-name "." +source-extension+))) + +file-list+)) (DEFVAR *CMBN-CONTROL*) (SETF *CMBN-CONTROL* T) @@ -86,9 +87,9 @@ (mapc #'(lambda (file-name) (compile-file (concatenate 'string file-name "." +source-extension+)) (load (concatenate 'string file-name "." +compiled-extension+))) - +file-list+)) + +file-list+)) (DEFUN LOAD-CFILES () - (mapc #'(lambda (file-name) - (load (concatenate 'string file-name "." +compiled-extension+))) - +file-list+)) + (mapc #'(lambda (file-name) + (load (concatenate 'string file-name "." +compiled-extension+))) + +file-list+)) diff --git a/src/chain-complexes.lisp b/src/chain-complexes.lisp index cbb4317..e0845a8 100644 --- a/src/chain-complexes.lisp +++ b/src/chain-complexes.lisp @@ -1,4 +1,4 @@ -;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* ;;; CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES ;;; CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES diff --git a/src/chcm-elementary-op.lisp b/src/chcm-elementary-op.lisp index 83bb8d1..0e14f97 100644 --- a/src/chcm-elementary-op.lisp +++ b/src/chcm-elementary-op.lisp @@ -1,4 +1,4 @@ -;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* ;;; CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP ;;; CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP diff --git a/src/cl-space-efhm.lisp b/src/cl-space-efhm.lisp index 87db3c5..482afb7 100644 --- a/src/cl-space-efhm.lisp +++ b/src/cl-space-efhm.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; CL-SPACE-EFHM CL-SPACE-EFHM CL-SPACE-EFHM CL-SPACE-EFHM ;;; CL-SPACE-EFHM CL-SPACE-EFHM CL-SPACE-EFHM CL-SPACE-EFHM ;;; CL-SPACE-EFHM CL-SPACE-EFHM CL-SPACE-EFHM CL-SPACE-EFHM @@ -7,9 +9,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 +24,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 +133,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 +154,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 +407,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/src/classes.lisp b/src/classes.lisp index 45d7390..da39ff3 100644 --- a/src/classes.lisp +++ b/src/classes.lisp @@ -1,4 +1,4 @@ -;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* ;;; CLASSES CLASSES CLASSES CLASSES CLASSES CLASSES CLASSES ;;; CLASSES CLASSES CLASSES CLASSES CLASSES CLASSES CLASSES diff --git a/src/classifying-spaces.lisp b/src/classifying-spaces.lisp index 85db693..e3d3c49 100644 --- a/src/classifying-spaces.lisp +++ b/src/classifying-spaces.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; CLASSIFYING-SPACES CLASSIFYING-SPACES CLASSIFYING-SPACES ;;; CLASSIFYING-SPACES CLASSIFYING-SPACES CLASSIFYING-SPACES ;;; CLASSIFYING-SPACES CLASSIFYING-SPACES CLASSIFYING-SPACES @@ -15,15 +17,15 @@ (ignore depth)) (the gbar (progn - (princ "<" - (hyphenize-list (dgop-int-ext dgop)) - gmsm))) - (princ ">>" stream) - gbar))) + (princ "<" + (hyphenize-list (dgop-int-ext dgop)) + gmsm))) + (princ ">>" stream) + gbar))) ;;; NIGBAR = non-normalized igbar (with dimension) @@ -31,57 +33,57 @@ (declare (list nigbar)) (the absm (let ((dmns (first nigbar)) - (igbar (rest nigbar))) - (declare - (fixnum dmns) - (list igbar)) - (when (zerop dmns) - (return-from normalize-gbar (absm 0 +null-gbar+))) - (do ((mark igbar (cdr mark)) - (indx (1- dmns) (1- indx)) - (2-indx (2-exp (1- dmns)) (ash 2-indx -1)) - (mask (mask (1- dmns)) (ash mask -1)) - (and-dgops -1 (logand and-dgops (dgop (car mark)))) - ;; r = result - (r-dgop 0) - (r-absm-list +empty-list+)) - ((endp mark) - (absm r-dgop - (make-gbar - :dmns (- dmns (logcount r-dgop)) - :list (nreverse r-absm-list)))) - (declare - (list mark r-absm-list) - (fixnum indx 2-indx mask and-dgops r-dgop)) - (when (zerop and-dgops) - (return-from normalize-gbar - (absm r-dgop - (make-gbar - :dmns (- dmns (logcount r-dgop)) - :list (nreconc r-absm-list mark))))) - (let ((absm (car mark))) - (with-absm - (dgop gmsm) absm - (declare (ignore gmsm)) - (if (and (= dgop mask) - (logbitp indx and-dgops)) - (progn - (incf r-dgop 2-indx) - (mapl - #'(lambda (sublist) - (declare (list sublist)) - (setf (car sublist) - (let ((absm (car sublist))) - (declare (type absm absm)) - (with-absm - (dgop gmsm) absm - (absm (multiple-value-bind (q r) - (floor dgop 2-indx) - (declare (fixnum q r)) - (+ (ash (1- q) (1- indx)) r)) - gmsm))))) - r-absm-list)) - (push absm r-absm-list)))))))) + (igbar (rest nigbar))) + (declare + (fixnum dmns) + (list igbar)) + (when (zerop dmns) + (return-from normalize-gbar (absm 0 +null-gbar+))) + (do ((mark igbar (cdr mark)) + (indx (1- dmns) (1- indx)) + (2-indx (2-exp (1- dmns)) (ash 2-indx -1)) + (mask (mask (1- dmns)) (ash mask -1)) + (and-dgops -1 (logand and-dgops (dgop (car mark)))) + ;; r = result + (r-dgop 0) + (r-absm-list +empty-list+)) + ((endp mark) + (absm r-dgop + (make-gbar + :dmns (- dmns (logcount r-dgop)) + :list (nreverse r-absm-list)))) + (declare + (list mark r-absm-list) + (fixnum indx 2-indx mask and-dgops r-dgop)) + (when (zerop and-dgops) + (return-from normalize-gbar + (absm r-dgop + (make-gbar + :dmns (- dmns (logcount r-dgop)) + :list (nreconc r-absm-list mark))))) + (let ((absm (car mark))) + (with-absm + (dgop gmsm) absm + (declare (ignore gmsm)) + (if (and (= dgop mask) + (logbitp indx and-dgops)) + (progn + (incf r-dgop 2-indx) + (mapl + #'(lambda (sublist) + (declare (list sublist)) + (setf (car sublist) + (let ((absm (car sublist))) + (declare (type absm absm)) + (with-absm + (dgop gmsm) absm + (absm (multiple-value-bind (q r) + (floor dgop 2-indx) + (declare (fixnum q r)) + (+ (ash (1- q) (1- indx)) r)) + gmsm))))) + r-absm-list)) + (push absm r-absm-list)))))))) (DEFUN UNNORMALIZE-GBAR (absm idnt) @@ -90,55 +92,55 @@ (type gmsm idnt)) (the list ;; igbar (with-absm (dgop gbar) absm - (with-gbar (dmns list) gbar - (setf list (reverse list)) - (do ((dgop2 dgop (ash dgop2 -1)) - (indx 0 (1+ indx)) - (2-indx 1 (ash 2-indx 1)) - (dgop3 0) - (rslt +empty-list+)) - ((zerop dgop2) - (cons (+ dmns (logcount dgop)) - (nreconc - (mapcar - #'(lambda (absm) - (declare (type absm absm)) - (ndgnr dgop3 absm)) - list) - rslt))) - (declare - (list rslt) - (fixnum dgop2 2-indx dgop3)) - (if (oddp dgop2) - (progn - (push (absm (mask indx) idnt) rslt) - (incf dgop3 2-indx)) - (push (ndgnr dgop3 (pop list)) rslt))))))) + (with-gbar (dmns list) gbar + (setf list (reverse list)) + (do ((dgop2 dgop (ash dgop2 -1)) + (indx 0 (1+ indx)) + (2-indx 1 (ash 2-indx 1)) + (dgop3 0) + (rslt +empty-list+)) + ((zerop dgop2) + (cons (+ dmns (logcount dgop)) + (nreconc + (mapcar + #'(lambda (absm) + (declare (type absm absm)) + (ndgnr dgop3 absm)) + list) + rslt))) + (declare + (list rslt) + (fixnum dgop2 2-indx dgop3)) + (if (oddp dgop2) + (progn + (push (absm (mask indx) idnt) rslt) + (incf dgop3 2-indx)) + (push (ndgnr dgop3 (pop list)) rslt))))))) (DEFUN GBAR (dmns &rest rest) (the gbar (progn - (unless (= (+ dmns dmns) (length rest)) - (error "In GBAR, the argument list has a wrong length.")) - (make-gbar :dmns dmns - :list (do ((mark rest (cddr mark)) - (rslt +empty-list+ - (cons (absm (car mark) (cadr mark)) - rslt))) - ((endp mark) (nreverse rslt)) - (declare (list mark rslt))))))) + (unless (= (+ dmns dmns) (length rest)) + (error "In GBAR, the argument list has a wrong length.")) + (make-gbar :dmns dmns + :list (do ((mark rest (cddr mark)) + (rslt +empty-list+ + (cons (absm (car mark) (cadr mark)) + rslt))) + ((endp mark) (nreverse rslt)) + (declare (list mark rslt))))))) (DEFUN CLASSIFYING-SPACE-CMPR (cmpr) (declare (type cmprf cmpr)) (flet ((rslt (gbar1 gbar2) - (declare (type gbar gbar1 gbar2)) - (maplexico - #'(lambda (absm1 absm2) - (declare (type absm absm1 absm2)) - (a-cmpr3 cmpr absm1 absm2)) - (gbar-list gbar1) (gbar-list gbar2)))) + (declare (type gbar gbar1 gbar2)) + (maplexico + #'(lambda (absm1 absm2) + (declare (type absm absm1 absm2)) + (a-cmpr3 cmpr absm1 absm2)) + (gbar-list gbar1) (gbar-list gbar2)))) (the cmprf #'rslt))) @@ -153,29 +155,29 @@ (type gmsm idnt)) (labels ((rslt (dmns) - (declare (fixnum dmns)) - (when (minusp dmns) - (return-from rslt +empty-list+)) - (when (zerop dmns) - (return-from rslt (list +null-gbar+))) - (let ((basis-1 (funcall crts-basis (1- dmns)))) - (declare (list basis-1)) - (nreverse - (mapcar ;; xxx bug - #'(lambda (crpr) - (declare (type crpr crpr)) - (with-crpr - (absm1 absm2) crpr - (make-gbar - :dmns dmns - :list (cons absm1 - (rest (unnormalize-gbar absm2 idnt)))))) - (member-if ;; xxx bug - #'(lambda (dgop) - (declare (fixnum dgop)) - (< dgop (mask (1- dmns)))) - (reverse basis-1) - :key #'dgop1)))))) + (declare (fixnum dmns)) + (when (minusp dmns) + (return-from rslt +empty-list+)) + (when (zerop dmns) + (return-from rslt (list +null-gbar+))) + (let ((basis-1 (funcall crts-basis (1- dmns)))) + (declare (list basis-1)) + (nreverse + (mapcar ;; xxx bug + #'(lambda (crpr) + (declare (type crpr crpr)) + (with-crpr + (absm1 absm2) crpr + (make-gbar + :dmns dmns + :list (cons absm1 + (rest (unnormalize-gbar absm2 idnt)))))) + (member-if ;; xxx bug + #'(lambda (dgop) + (declare (fixnum dgop)) + (< dgop (mask (1- dmns)))) + (reverse basis-1) + :key #'dgop1)))))) ;;; :key #'caadr)))))) (setf crts-basis (crts-prdc-basis basis #'rslt)) (the basis #'rslt)))) @@ -186,29 +188,29 @@ (type face face) (type sintr sintr-grml)) (flet ((rslt (indx dmns gbar) - (declare - (fixnum indx dmns) - (type gbar gbar)) - (when (= indx dmns) - (return-from rslt - (normalize-gbar (cons (1- dmns) (rest (gbar-list gbar)))))) - (do ((mark (gbar-list gbar) (cdr mark)) - (dmns2 (1- dmns) (1- dmns2)) - (rslt +empty-list+ - (cons (a-face4 face indx dmns2 (car mark)) - rslt))) - ((= dmns2 indx) - (if (zerop indx) - (normalize-gbar (cons (1- dmns) (nreverse rslt))) - (normalize-gbar - (cons (1- dmns) - (nreconc - rslt - (cons (a-grml4 sintr-grml (1- indx) - (second mark) - (a-face4 face indx indx - (first mark))) - (nthcdr 2 mark)))))))))) + (declare + (fixnum indx dmns) + (type gbar gbar)) + (when (= indx dmns) + (return-from rslt + (normalize-gbar (cons (1- dmns) (rest (gbar-list gbar)))))) + (do ((mark (gbar-list gbar) (cdr mark)) + (dmns2 (1- dmns) (1- dmns2)) + (rslt +empty-list+ + (cons (a-face4 face indx dmns2 (car mark)) + rslt))) + ((= dmns2 indx) + (if (zerop indx) + (normalize-gbar (cons (1- dmns) (nreverse rslt))) + (normalize-gbar + (cons (1- dmns) + (nreconc + rslt + (cons (a-grml4 sintr-grml (1- indx) + (second mark) + (a-face4 face indx indx + (first mark))) + (nthcdr 2 mark)))))))))) (the face #'rslt))) @@ -217,10 +219,10 @@ (DEFMETHOD CLASSIFYING-SPACE ((smgr simplicial-group)) (the simplicial-set (build-smst :cmpr (classifying-space-cmpr (cmpr smgr)) - :basis (classifying-space-basis (basis smgr)) - :bspn +null-gbar+ - :face (classifying-space-face (face smgr) (sintr (grml smgr))) - :orgn `(classifying-space ,smgr)))) + :basis (classifying-space-basis (basis smgr)) + :bspn +null-gbar+ + :face (classifying-space-face (face smgr) (sintr (grml smgr))) + :orgn `(classifying-space ,smgr)))) (DEFUN CLASSIFYING-SPACE-GRML-SINTR (idnt sintr-grml) @@ -228,53 +230,53 @@ (type gmsm idnt) (type sintr sintr-grml)) (flet ((rslt (dmns crpr) - (declare - (fixnum dmns) - (type crpr crpr)) - (with-crpr (absm1 absm2) crpr - (let ((absm-list-1 (rest (unnormalize-gbar absm1 idnt))) - (absm-list-2 (rest (unnormalize-gbar absm2 idnt)))) - (declare (list absm-list-1 absm-list-2)) - (normalize-gbar - (cons dmns - (mapcar - #'(lambda (absm1 absm2) - (declare (type absm absm1 absm2)) - (decf dmns) ;; !! - (a-grml4 sintr-grml dmns absm1 absm2)) - absm-list-1 absm-list-2))))))) + (declare + (fixnum dmns) + (type crpr crpr)) + (with-crpr (absm1 absm2) crpr + (let ((absm-list-1 (rest (unnormalize-gbar absm1 idnt))) + (absm-list-2 (rest (unnormalize-gbar absm2 idnt)))) + (declare (list absm-list-1 absm-list-2)) + (normalize-gbar + (cons dmns + (mapcar + #'(lambda (absm1 absm2) + (declare (type absm absm1 absm2)) + (decf dmns) ;; !! + (a-grml4 sintr-grml dmns absm1 absm2)) + absm-list-1 absm-list-2))))))) (the sintr #'rslt))) (DEFUN CLASSIFYING-SPACE-GRIN-SINTR (sintr-grin) (declare (type sintr sintr-grin)) (flet ((rslt (dmns gbar) - (declare - (fixnum dmns) - (type gbar gbar)) - (absm 0 - (make-gbar - :dmns dmns - :list (mapcar - #'(lambda (absm) - (declare (type absm absm)) - (a-grin4 sintr-grin dmns absm)) - (gbar-list gbar)))))) + (declare + (fixnum dmns) + (type gbar gbar)) + (absm 0 + (make-gbar + :dmns dmns + :list (mapcar + #'(lambda (absm) + (declare (type absm absm)) + (a-grin4 sintr-grin dmns absm)) + (gbar-list gbar)))))) (the sintr #'rslt))) (DEFMETHOD CLASSIFYING-SPACE ((smgr ab-simplicial-group)) (the ab-simplicial-group (change-class - (build-smgr :cmpr (classifying-space-cmpr (cmpr smgr)) - :basis (classifying-space-basis (basis smgr)) - :bspn +null-gbar+ - :face (classifying-space-face (face smgr) - (sintr (grml smgr))) - :sintr-grml (classifying-space-grml-sintr - (bspn smgr) - (sintr (grml smgr))) - :sintr-grin (classifying-space-grin-sintr - (sintr (grin smgr))) - :orgn `(classifying-space ,smgr)) - 'ab-simplicial-group))) + (build-smgr :cmpr (classifying-space-cmpr (cmpr smgr)) + :basis (classifying-space-basis (basis smgr)) + :bspn +null-gbar+ + :face (classifying-space-face (face smgr) + (sintr (grml smgr))) + :sintr-grml (classifying-space-grml-sintr + (bspn smgr) + (sintr (grml smgr))) + :sintr-grin (classifying-space-grin-sintr + (sintr (grin smgr))) + :orgn `(classifying-space ,smgr)) + 'ab-simplicial-group))) diff --git a/src/coalgebras.lisp b/src/coalgebras.lisp index 3b18a15..e0fd1e4 100644 --- a/src/coalgebras.lisp +++ b/src/coalgebras.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; COALGEBRAS COALGEBRAS COALGEBRAS COALGEBRAS COALGEBRAS COALGEBRAS ;;; COALGEBRAS COALGEBRAS COALGEBRAS COALGEBRAS COALGEBRAS COALGEBRAS ;;; COALGEBRAS COALGEBRAS COALGEBRAS COALGEBRAS COALGEBRAS COALGEBRAS @@ -9,64 +11,63 @@ #+clisp(eval-when (:compile-toplevel :load-toplevel :execute) (setf (ext:package-lock :clos) nil)) (DEFMETHOD PRINT-OBJECT ((clgb coalgebra) stream) - (the coalgebra - (progn - (format stream "[K~D Coalgebra]" (idnm clgb)) - clgb))) + (the coalgebra + (progn + (format stream "[K~D Coalgebra]" (idnm clgb)) + clgb))) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute) (setf (ext:package-lock :clos) t)) (DEFUN CLGB (idnm) - (declare (fixnum idnm)) - (the (or coalgebra null) - (find idnm *clgb-list* :key #'idnm))) + (declare (fixnum idnm)) + (the (or coalgebra null) + (find idnm *clgb-list* :key #'idnm))) (DEFUN BUILD-CLGB (&key cmpr basis bsgn intr-dffr dffr-strt intr-cprd cprd-strt orgn) - (declare - (type cmprf cmpr) - (type intr-mrph intr-dffr intr-cprd) - (type basis basis) - (type gnrt bsgn) - (type strt dffr-strt cprd-strt) - (list orgn)) - (the coalgebra - (progn + (declare + (type cmprf cmpr) + (type intr-mrph intr-dffr intr-cprd) + (type basis basis) + (type gnrt bsgn) + (type strt dffr-strt cprd-strt) + (list orgn)) + (the coalgebra + (progn (let ((already (find orgn *clgb-list* :key #'orgn :test #'equal))) - (declare (type (or null coalgebra) already)) - (when already - (return-from build-clgb already))) + (declare (type (or null coalgebra) already)) + (when already + (return-from build-clgb already))) (let ((rslt (build-chcm :cmpr cmpr :basis basis :bsgn bsgn - :intr-dffr intr-dffr :strt dffr-strt - :orgn orgn))) - (declare (type chain-complex rslt)) - (change-class rslt 'coalgebra) - (setf (slot-value rslt 'cprd) - (build-mrph :sorc rslt :trgt (tnsr-prdc rslt rslt) :degr 0 - :intr intr-cprd :strt cprd-strt - :orgn `(coalgebra-coproduct ,rslt))) - (push rslt *clgb-list*) - rslt)))) + :intr-dffr intr-dffr :strt dffr-strt + :orgn orgn))) + (declare (type chain-complex rslt)) + (change-class rslt 'coalgebra) + (setf (slot-value rslt 'cprd) + (build-mrph :sorc rslt :trgt (tnsr-prdc rslt rslt) :degr 0 + :intr intr-cprd :strt cprd-strt + :orgn `(coalgebra-coproduct ,rslt))) + (push rslt *clgb-list*) + rslt)))) (DEFUN CHANGE-CHCM-TO-CLGB (chcm &key intr-cprd cprd-strt orgn) - (declare - (type chain-complex chcm) - (type intr-mrph intr-cprd) - (type strt cprd-strt) - (list orgn)) - (the coalgebra - (progn + (declare + (type chain-complex chcm) + (type intr-mrph intr-cprd) + (type strt cprd-strt) + (list orgn)) + (the coalgebra + (progn (change-class chcm 'coalgebra) (setf orgn (list (orgn chcm) 'then orgn)) (let ((already (find orgn *clgb-list* :key #'orgn :test #'equal))) - (declare (type (or null coalgebra) already)) - (when already - (return-from change-chcm-to-clgb already))) + (declare (type (or null coalgebra) already)) + (when already + (return-from change-chcm-to-clgb already))) (setf (slot-value chcm 'cprd) (build-mrph - :sorc chcm :trgt (tnsr-prdc chcm chcm) - :degr 0 - :intr intr-cprd :strt cprd-strt - :orgn orgn)) + :sorc chcm :trgt (tnsr-prdc chcm chcm) + :degr 0 + :intr intr-cprd :strt cprd-strt + :orgn orgn)) (push chcm *clgb-list*) chcm))) - diff --git a/src/cobar.lisp b/src/cobar.lisp index 96066e4..1a57146 100644 --- a/src/cobar.lisp +++ b/src/cobar.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; COBAR COBAR COBAR COBAR COBAR COBAR COBAR COBAR COBAR ;;; COBAR COBAR COBAR COBAR COBAR COBAR COBAR COBAR COBAR ;;; COBAR COBAR COBAR COBAR COBAR COBAR COBAR COBAR COBAR @@ -13,12 +15,12 @@ (error "In ALLP, the length list should be even.")) (the allp (let ((rslt +empty-list+)) - (declare (list rslt)) - (do ((mark list (cddr mark))) - ((endp mark)) - (declare (list mark)) - (push (cbgn (car mark) (cadr mark)) rslt)) - (make-allp :list (nreverse rslt))))) + (declare (list rslt)) + (do ((mark list (cddr mark))) + ((endp mark)) + (declare (list mark)) + (push (cbgn (car mark) (cadr mark)) rslt)) + (make-allp :list (nreverse rslt))))) #-sbcl (DEFINE-CONSTANT +NULL-ALLP+ (make-allp :list +empty-list+)) @@ -31,31 +33,31 @@ (ignore depth)) (the allp (progn - (format stream "<>") - allp))) + (format stream "<>") + allp))) (DEFUN COBAR-CMPR (cmpr) (declare (type cmprf cmpr)) (flet ((rslt (allp1 allp2) - (declare (type allp allp1 allp2)) - (the cmpr - (let ((list1 (allp-list allp1)) - (list2 (allp-list allp2))) - (declare (type iallp list1 list2)) - (lexico - (f-cmpr (length list1) (length list2)) - (maplexico - #'(lambda (cbgn1 cbgn2) - (lexico - (f-cmpr (cdegr cbgn1) (cdegr cbgn2)) - (funcall cmpr (cgnrt cbgn1) (cgnrt cbgn2)))) - list1 list2)))))) + (declare (type allp allp1 allp2)) + (the cmpr + (let ((list1 (allp-list allp1)) + (list2 (allp-list allp2))) + (declare (type iallp list1 list2)) + (lexico + (f-cmpr (length list1) (length list2)) + (maplexico + #'(lambda (cbgn1 cbgn2) + (lexico + (f-cmpr (cdegr cbgn1) (cdegr cbgn2)) + (funcall cmpr (cgnrt cbgn1) (cgnrt cbgn2)))) + list1 list2)))))) (the cmprf #'rslt))) @@ -65,53 +67,53 @@ (fixnum degr length)) (the list (progn - (when (= 1 length) - (return-from cobar-basis-length - (mapcar - #'(lambda (item) - (declare (type gnrt item)) - (list (cbgn degr item))) - (funcall basis (1+ degr))))) - (mapcan - #'(lambda (degr1) - (declare (fixnum degr1)) - (let ((list1 (funcall basis (1+ degr1))) - (list2 (cobar-basis-length - basis (- degr degr1) (1- length)))) - (declare (list list1 list2)) - (mapcan - #'(lambda (item1) - (declare (type gnrt item1)) - (mapcar - #'(lambda (item2) - (declare (type iallp item2)) - (cons (cbgn degr1 item1) item2)) - list2)) - list1))) - (>a-b< 0 degr))))) + (when (= 1 length) + (return-from cobar-basis-length + (mapcar + #'(lambda (item) + (declare (type gnrt item)) + (list (cbgn degr item))) + (funcall basis (1+ degr))))) + (mapcan + #'(lambda (degr1) + (declare (fixnum degr1)) + (let ((list1 (funcall basis (1+ degr1))) + (list2 (cobar-basis-length + basis (- degr degr1) (1- length)))) + (declare (list list1 list2)) + (mapcan + #'(lambda (item1) + (declare (type gnrt item1)) + (mapcar + #'(lambda (item2) + (declare (type iallp item2)) + (cons (cbgn degr1 item1) item2)) + list2)) + list1))) + (>a-b< 0 degr))))) (DEFUN COBAR-BASIS (basis) (declare (type basis basis)) (the basis (progn - (when (eq :locally-effective basis) - (return-from cobar-basis :locally-effective)) - (flet ((rslt (degr) - (declare (fixnum degr)) - (cond ((minusp degr) +empty-list+) - ((zerop degr) (list +null-allp+)) - (t - (mapcan - #'(lambda (length) - (declare (fixnum length)) - (mapcar - #'(lambda (iallp) - (declare (type iallp iallp)) - (make-allp :list iallp)) - (cobar-basis-length basis degr length))) - (>a-b> 0 degr)))))) - #'rslt)))) + (when (eq :locally-effective basis) + (return-from cobar-basis :locally-effective)) + (flet ((rslt (degr) + (declare (fixnum degr)) + (cond ((minusp degr) +empty-list+) + ((zerop degr) (list +null-allp+)) + (t + (mapcan + #'(lambda (length) + (declare (fixnum length)) + (mapcar + #'(lambda (iallp) + (declare (type iallp iallp)) + (make-allp :list iallp)) + (cobar-basis-length basis degr length))) + (>a-b> 0 degr)))))) + #'rslt)))) #| The following version of the COBAR-BASIS function is not correctly compiled with ACL-Unix, probably @@ -126,102 +128,102 @@ structure of closures. This version works on ACL-PC. (the basis (progn (when (eq :locally-effective basis) - (return-from cobar-basis :locally-effecive)) + (return-from cobar-basis :locally-effecive)) (labels ((rslt (degr length) - (declare (fixnum degr length)) - (when (= 1 length) - (return-from rslt - (mapcar - #'(lambda (item) - (declare (type gnrt item)) - (list (cbgn degr item))) - (funcall basis (1+ degr))))) - (mapcan - #'(lambda (degr1) - (declare (fixnum degr1)) - (let ((list1 (funcall basis (1+ degr1))) - (list2 (rslt (- degr degr1) (1- length)))) - (declare (list list1 lis2)) - (mapcan - #'(lambda (item1) - (declare (type gnrt item1)) - (mapcar - #'(lambda (item2) - (declare (type iallp item2)) - (cons (cbgn degr1 item1) item2)) - list2)) - list1))) - (>a-b< 0 degr)))) - #'(lambda (degr) - (declare (fixnum degr)) - (if (zerop degr) - (list (make-allp :list +empty-list+)) - (mapcan - #'(lambda (length) - (declare (fixnum length)) - (mapcar - #'(lambda (iallp) - (declare (type iallp iallp)) - (make-allp :list iallp)) - (rslt degr length))) - (>a-b> 0 degr)))))))) + (declare (fixnum degr length)) + (when (= 1 length) + (return-from rslt + (mapcar + #'(lambda (item) + (declare (type gnrt item)) + (list (cbgn degr item))) + (funcall basis (1+ degr))))) + (mapcan + #'(lambda (degr1) + (declare (fixnum degr1)) + (let ((list1 (funcall basis (1+ degr1))) + (list2 (rslt (- degr degr1) (1- length)))) + (declare (list list1 lis2)) + (mapcan + #'(lambda (item1) + (declare (type gnrt item1)) + (mapcar + #'(lambda (item2) + (declare (type iallp item2)) + (cons (cbgn degr1 item1) item2)) + list2)) + list1))) + (>a-b< 0 degr)))) + #'(lambda (degr) + (declare (fixnum degr)) + (if (zerop degr) + (list (make-allp :list +empty-list+)) + (mapcan + #'(lambda (length) + (declare (fixnum length)) + (mapcar + #'(lambda (iallp) + (declare (type iallp iallp)) + (make-allp :list iallp)) + (rslt degr length))) + (>a-b> 0 degr)))))))) |# (DEFUN COBAR-INTR-VRTC-DFFR (dffr) (declare (type morphism dffr)) (labels ((rslt (degr iallp) - ;; the argument iallp is an internal algebraic loop, - ;; without the keyword :allp - ;; rslt returns an internal combination - ;; without the keyword :cmbn, without degree - (declare - (fixnum degr) - (type iallp iallp)) - (the icmbn + ;; the argument iallp is an internal algebraic loop, + ;; without the keyword :allp + ;; rslt returns an internal combination + ;; without the keyword :cmbn, without degree + (declare + (fixnum degr) + (type iallp iallp)) + (the icmbn (progn - (unless iallp - (return-from rslt +empty-list+)) - (let ((cbgn1 (first iallp)) - (rest (rest iallp))) - (declare - (type cbgn cbgn1) - (type iallp rest)) - (with-cbgn - (degr1 gnrt1) cbgn1 - (let ((d-gnrt1 (cmbn-list (gnrt-? dffr (1+ degr1) - gnrt1))) - (d-rest (rslt (- degr degr1) rest)) - (degr1-1 (1- degr1)) - (first-sign (-1-expt-n-1 (length rest))) - (rest-sign (-1-expt-n degr1))) - (declare - (type icmbn d-gnrt1 d-rest) - (fixnum degr1-1 rest-sign)) - (nconc - (mapcar - #'(lambda (term) - (with-term - (cffc gnrt) term - (term (* first-sign cffc) - (cons (cbgn degr1-1 gnrt) rest)))) - d-gnrt1) - (mapcar - #'(lambda (term) - (with-term - (cffc gnrt) term - (term (* rest-sign cffc) - (cons cbgn1 gnrt)))) - d-rest))))))))) + (unless iallp + (return-from rslt +empty-list+)) + (let ((cbgn1 (first iallp)) + (rest (rest iallp))) + (declare + (type cbgn cbgn1) + (type iallp rest)) + (with-cbgn + (degr1 gnrt1) cbgn1 + (let ((d-gnrt1 (cmbn-list (gnrt-? dffr (1+ degr1) + gnrt1))) + (d-rest (rslt (- degr degr1) rest)) + (degr1-1 (1- degr1)) + (first-sign (-1-expt-n-1 (length rest))) + (rest-sign (-1-expt-n degr1))) + (declare + (type icmbn d-gnrt1 d-rest) + (fixnum degr1-1 rest-sign)) + (nconc + (mapcar + #'(lambda (term) + (with-term + (cffc gnrt) term + (term (* first-sign cffc) + (cons (cbgn degr1-1 gnrt) rest)))) + d-gnrt1) + (mapcar + #'(lambda (term) + (with-term + (cffc gnrt) term + (term (* rest-sign cffc) + (cons cbgn1 gnrt)))) + d-rest))))))))) (the intr-mrph #'(lambda (degr allp) - (make-cmbn - :degr (1- degr) - :list (mapcar - #'(lambda (term) - (with-term (cffc iallp) term - (term cffc (make-allp :list iallp)))) - (rslt degr (allp-list allp)))))))) + (make-cmbn + :degr (1- degr) + :list (mapcar + #'(lambda (term) + (with-term (cffc iallp) term + (term cffc (make-allp :list iallp)))) + (rslt degr (allp-list allp)))))))) (DEFGENERIC VRTC-COBAR (chcm-or-hmeq-or-rdct)) @@ -231,77 +233,77 @@ structure of closures. This version works on ACL-PC. (the chain-complex (with-slots (cmpr basis dffr) chcm (declare - (type cmprf cmpr) - (type basis basis) - (type morphism dffr)) + (type cmprf cmpr) + (type basis basis) + (type morphism dffr)) (build-chcm - :cmpr (cobar-cmpr cmpr) - :basis (cobar-basis basis) - :bsgn +null-allp+ - :intr-dffr (cobar-intr-vrtc-dffr dffr) - :strt :gnrt - :orgn `(vrtc-cobar ,chcm))))) + :cmpr (cobar-cmpr cmpr) + :basis (cobar-basis basis) + :bsgn +null-allp+ + :intr-dffr (cobar-intr-vrtc-dffr dffr) + :strt :gnrt + :orgn `(vrtc-cobar ,chcm))))) (DEFUN COBAR-INTR-HRZN-DFFR (cprd) (declare (type morphism cprd)) (labels ((rslt (degr iallp) - (declare - (fixnum degr) - (type iallp iallp)) - (the icmbn + (declare + (fixnum degr) + (type iallp iallp)) + (the icmbn (progn - (unless iallp - (return-from rslt +empty-list+)) - (let ((cbgn1 (first iallp)) - (rest (rest iallp))) - (declare - (type cbgn cbgn1) - (type iallp rest)) - (with-cbgn - (degr1 gnrt1) cbgn1 - (let ((cprd-gnrt1 (cmbn-list (gnrt-? cprd (1+ degr1) gnrt1))) - (cprd-rest (rslt (- degr degr1) rest)) - (sign (-1-expt-n-1 (length rest)))) - (declare - (type icmbn cprd-gnrt1 cprd-rest) - (fixnum sign)) + (unless iallp + (return-from rslt +empty-list+)) + (let ((cbgn1 (first iallp)) + (rest (rest iallp))) + (declare + (type cbgn cbgn1) + (type iallp rest)) + (with-cbgn + (degr1 gnrt1) cbgn1 + (let ((cprd-gnrt1 (cmbn-list (gnrt-? cprd (1+ degr1) gnrt1))) + (cprd-rest (rslt (- degr degr1) rest)) + (sign (-1-expt-n-1 (length rest)))) + (declare + (type icmbn cprd-gnrt1 cprd-rest) + (fixnum sign)) ;;; because \bar{A} - (setf cprd-gnrt1 (rest (butlast cprd-gnrt1))) - (nconc - (mapcar - #'(lambda (term1) - (declare (type term term1)) - (with-term - (nil tnpr) term1 ;;; cffc is in fact 1 - (with-tnpr - (degr1 gnrt1 degr2 gnrt2) tnpr - (term sign ;;; (* cffc sign) - (cons (cbgn (1- degr1) gnrt1) - (cons (cbgn (1- degr2) gnrt2) - rest)))))) - cprd-gnrt1) - (mapcar - #'(lambda (term2) - (declare (type term term2)) - (with-term (cffc allp2) term2 - (term cffc - (cons cbgn1 allp2)))) - cprd-rest))))))))) + (setf cprd-gnrt1 (rest (butlast cprd-gnrt1))) + (nconc + (mapcar + #'(lambda (term1) + (declare (type term term1)) + (with-term + (nil tnpr) term1 ;;; cffc is in fact 1 + (with-tnpr + (degr1 gnrt1 degr2 gnrt2) tnpr + (term sign ;;; (* cffc sign) + (cons (cbgn (1- degr1) gnrt1) + (cons (cbgn (1- degr2) gnrt2) + rest)))))) + cprd-gnrt1) + (mapcar + #'(lambda (term2) + (declare (type term term2)) + (with-term (cffc allp2) term2 + (term cffc + (cons cbgn1 allp2)))) + cprd-rest))))))))) (the intr-mrph #'(lambda (degr allp) - (declare - (fixnum degr) - (type allp allp)) - (the cmbn - (make-cmbn :degr (1- degr) - :list (mapcar #'(lambda (term) - (declare (type term term)) - (with-term - (cffc iallp) term - (term cffc (make-allp - :list iallp)))) - (rslt degr (allp-list allp))))))))) + (declare + (fixnum degr) + (type allp allp)) + (the cmbn + (make-cmbn :degr (1- degr) + :list (mapcar #'(lambda (term) + (declare (type term term)) + (with-term + (cffc iallp) term + (term cffc (make-allp + :list iallp)))) + (rslt degr (allp-list allp))))))))) (DEFUN COBAR-HRZN-DFFR (clgb) @@ -310,23 +312,23 @@ structure of closures. This version works on ACL-PC. (with-slots (cprd) clgb (declare (type morphism cprd)) (build-mrph - :sorc (vrtc-cobar clgb) :trgt (vrtc-cobar clgb) :degr -1 - :intr (cobar-intr-hrzn-dffr cprd) :strt :gnrt - :orgn `(cobar-hrzn-dffr ,clgb))))) + :sorc (vrtc-cobar clgb) :trgt (vrtc-cobar clgb) :degr -1 + :intr (cobar-intr-hrzn-dffr cprd) :strt :gnrt + :orgn `(cobar-hrzn-dffr ,clgb))))) (DEFUN COBAR-INTR-DFFR (vrtc-dffr hrzn-dffr) (declare (type morphism vrtc-dffr hrzn-dffr)) (flet ((rslt (degr allp) - (declare - (fixnum degr) - (type allp allp)) - (make-cmbn :degr (1- degr) - :list (append ;;; and not nconc, otherwise a terrible + (declare + (fixnum degr) + (type allp allp)) + (make-cmbn :degr (1- degr) + :list (append ;;; and not nconc, otherwise a terrible ;;; bug, when the ;;; first result is stored in memory... - (cmbn-list (gnrt-? vrtc-dffr degr allp)) - (cmbn-list (gnrt-? hrzn-dffr degr allp)))))) + (cmbn-list (gnrt-? vrtc-dffr degr allp)) + (cmbn-list (gnrt-? hrzn-dffr degr allp)))))) (the intr-mrph #'rslt))) @@ -335,52 +337,52 @@ structure of closures. This version works on ACL-PC. (DEFMETHOD COBAR ((coalgebra coalgebra)) (let ((vrtc-cobar (vrtc-cobar coalgebra)) - (cobar-hrzn-dffr (cobar-hrzn-dffr coalgebra))) + (cobar-hrzn-dffr (cobar-hrzn-dffr coalgebra))) (declare (type chain-complex vrtc-cobar) - (type morphism cobar-hrzn-dffr)) + (type morphism cobar-hrzn-dffr)) (the chain-complex - (let ((rslt (build-chcm - :cmpr (cmpr vrtc-cobar) - :basis (basis vrtc-cobar) - :bsgn +null-allp+ - :intr-dffr (cobar-intr-dffr (dffr vrtc-cobar) - cobar-hrzn-dffr) - :strt :gnrt - :orgn `(add ,vrtc-cobar ,cobar-hrzn-dffr)))) - (declare (type chain-complex rslt)) - (setf (slot-value rslt 'grmd) (grmd vrtc-cobar)) - rslt)))) + (let ((rslt (build-chcm + :cmpr (cmpr vrtc-cobar) + :basis (basis vrtc-cobar) + :bsgn +null-allp+ + :intr-dffr (cobar-intr-dffr (dffr vrtc-cobar) + cobar-hrzn-dffr) + :strt :gnrt + :orgn `(add ,vrtc-cobar ,cobar-hrzn-dffr)))) + (declare (type chain-complex rslt)) + (setf (slot-value rslt 'grmd) (grmd vrtc-cobar)) + rslt)))) (DEFUN CMBN-ALLP-CMBN-TNPR (cmbn allp-cmbn) (declare (type cmbn cmbn allp-cmbn)) (the cmbn (with-cmbn - (degr1 list1) cmbn - (decf degr1) ;; because allp organization - (with-cmbn - (degrr listr) allp-cmbn - (make-cmbn - :degr (+ degr1 degrr) - :list - (mapcan - #'(lambda (term1) - (declare (type term term1)) - (with-term - (cffc1 gnrt1) term1 - (let ((cbgn1 (cbgn degr1 gnrt1))) - (declare (type cbgn cbgn1)) - (mapcar - #'(lambda (termr) - (declare (type term termr)) - (with-term - (cffcr allpr) termr - (term (* cffc1 cffcr) - (make-allp - :list (cons cbgn1 - (allp-list allpr)))))) - listr)))) - list1)))))) + (degr1 list1) cmbn + (decf degr1) ;; because allp organization + (with-cmbn + (degrr listr) allp-cmbn + (make-cmbn + :degr (+ degr1 degrr) + :list + (mapcan + #'(lambda (term1) + (declare (type term term1)) + (with-term + (cffc1 gnrt1) term1 + (let ((cbgn1 (cbgn degr1 gnrt1))) + (declare (type cbgn cbgn1)) + (mapcar + #'(lambda (termr) + (declare (type term termr)) + (with-term + (cffcr allpr) termr + (term (* cffc1 cffcr) + (make-allp + :list (cons cbgn1 + (allp-list allpr)))))) + listr)))) + list1)))))) (DEFUN NCMBN-COBAR (cmbn-list) @@ -388,33 +390,33 @@ structure of closures. This version works on ACL-PC. (the cmbn (progn (unless cmbn-list - (return-from ncmbn-cobar (cmbn 0 1 +null-allp+))) + (return-from ncmbn-cobar (cmbn 0 1 +null-allp+))) (cmbn-allp-cmbn-tnpr - (first cmbn-list) - (ncmbn-cobar (rest cmbn-list)))))) + (first cmbn-list) + (ncmbn-cobar (rest cmbn-list)))))) (DEFUN MRPH-VRTC-COBAR-INTR (mrph) (declare (type morphism mrph)) (flet ((rslt (degr allp) - (declare - (ignore degr) - (type allp allp)) - (the cmbn - (ncmbn-cobar - (mapcar #'(lambda (cbgn) - (declare (type cbgn cbgn)) - (with-cbgn (degr gnrt) cbgn - (gnrt-? mrph (1+ degr) gnrt))) - (allp-list allp)))))) + (declare + (ignore degr) + (type allp allp)) + (the cmbn + (ncmbn-cobar + (mapcar #'(lambda (cbgn) + (declare (type cbgn cbgn)) + (with-cbgn (degr gnrt) cbgn + (gnrt-? mrph (1+ degr) gnrt))) + (allp-list allp)))))) (the intr-mrph #'rslt))) (DEFMETHOD VRTC-COBAR ((mrph morphism)) (the morphism (if (eq (first (orgn mrph)) 'idnt-mrph) - (idnt-mrph (vrtc-cobar (sorc mrph))) - (build-mrph + (idnt-mrph (vrtc-cobar (sorc mrph))) + (build-mrph :sorc (vrtc-cobar (sorc mrph)) :trgt (vrtc-cobar (trgt mrph)) :degr 0 @@ -426,70 +428,70 @@ structure of closures. This version works on ACL-PC. (DEFUN HMTP-VRTC-COBAR-INTR (h gf) (declare (type morphism h gf)) (flet ((rslt (degr allp) - (declare - (fixnum degr) - (type allp allp)) - (let* ((cbgn-list (reverse (allp-list allp))) - (rslt (list nil)) - (sign (oddp (apply #'+ (mapcar #'car cbgn-list)))) - ;; nil = -1 ;; t = +1 - (gfgf-tail (term-cmbn 0 1 +null-allp+))) - (declare - (list cbgn-list rslt) - (boolean sign) - (type cmbn gfgf-tail)) - (unless cbgn-list - (return-from rslt (zero-cmbn 1))) - (loop - (let ((cbgn (car cbgn-list))) - (declare (type cbgn cbgn)) - (with-cbgn - (degr gnrt) cbgn - (when (evenp degr) - (setf sign (not sign))) - (incf degr) - (let ((h-gnrt (gnrt-? h degr gnrt))) - (declare (type cmbn h-gnrt)) - (let ((hgfgf (cmbn-list (cmbn-allp-cmbn-tnpr - h-gnrt - gfgf-tail)))) - (declare (type list hgfgf)) - (when sign - (mapc #'(lambda (term) - (declare (type term term)) - (setf (cffc term) (- (cffc term)))) - hgfgf)) - (setf cbgn-list (rest cbgn-list)) - (let ((head (reverse cbgn-list))) - (declare (list head)) - (mapc #'(lambda (term) - (setf (allp-list (gnrt term)) - (append head (allp-list (gnrt term))))) - hgfgf)) - (nconc rslt hgfgf))) - (unless cbgn-list (return)) - (setf gfgf-tail - (cmbn-allp-cmbn-tnpr - (gnrt-? gf degr gnrt) gfgf-tail))))) - (make-cmbn - :degr (1+ degr) - :list (rest rslt))))) + (declare + (fixnum degr) + (type allp allp)) + (let* ((cbgn-list (reverse (allp-list allp))) + (rslt (list nil)) + (sign (oddp (apply #'+ (mapcar #'car cbgn-list)))) + ;; nil = -1 ;; t = +1 + (gfgf-tail (term-cmbn 0 1 +null-allp+))) + (declare + (list cbgn-list rslt) + (boolean sign) + (type cmbn gfgf-tail)) + (unless cbgn-list + (return-from rslt (zero-cmbn 1))) + (loop + (let ((cbgn (car cbgn-list))) + (declare (type cbgn cbgn)) + (with-cbgn + (degr gnrt) cbgn + (when (evenp degr) + (setf sign (not sign))) + (incf degr) + (let ((h-gnrt (gnrt-? h degr gnrt))) + (declare (type cmbn h-gnrt)) + (let ((hgfgf (cmbn-list (cmbn-allp-cmbn-tnpr + h-gnrt + gfgf-tail)))) + (declare (type list hgfgf)) + (when sign + (mapc #'(lambda (term) + (declare (type term term)) + (setf (cffc term) (- (cffc term)))) + hgfgf)) + (setf cbgn-list (rest cbgn-list)) + (let ((head (reverse cbgn-list))) + (declare (list head)) + (mapc #'(lambda (term) + (setf (allp-list (gnrt term)) + (append head (allp-list (gnrt term))))) + hgfgf)) + (nconc rslt hgfgf))) + (unless cbgn-list (return)) + (setf gfgf-tail + (cmbn-allp-cmbn-tnpr + (gnrt-? gf degr gnrt) gfgf-tail))))) + (make-cmbn + :degr (1+ degr) + :list (rest rslt))))) (the intr-mrph #'rslt))) (DEFUN HMTP-VRTC-COBAR (h gf) (declare (type morphism h gf)) (unless (and (= +1 (degr h)) - (= +0 (degr gf))) + (= +0 (degr gf))) (error "In HMTP-VRTC-COBAR, the morphism degrees are not the right ones.")) (unless (and (eq (sorc h) (trgt h)) - (eq (trgt h) (sorc gf)) - (eq (sorc gf) (trgt gf))) + (eq (trgt h) (sorc gf)) + (eq (sorc gf) (trgt gf))) (error "In HMTP-VRTC-COBAR, fg-h sources and targets are not the same.")) (the morphism (if (eq (first (orgn h)) 'zero-mrph) - (zero-mrph (vrtc-cobar (sorc h))) - (build-mrph + (zero-mrph (vrtc-cobar (sorc h))) + (build-mrph :sorc (vrtc-cobar (sorc h)) :trgt (vrtc-cobar (sorc h)) :degr +1 :intr (hmtp-vrtc-cobar-intr h gf) :strt :gnrt @@ -499,24 +501,24 @@ structure of closures. This version works on ACL-PC. (DEFMETHOD VRTC-COBAR ((rdct reduction)) (the reduction (if (eq (first (orgn rdct)) 'trivial-rdct) - (trivial-rdct (vrtc-cobar (bcc rdct))) - (with-slots (f g h) rdct - (build-rdct - :f (vrtc-cobar f) - :g (vrtc-cobar g) - :h (hmtp-vrtc-cobar h (cmps g f)) - :orgn `(vrtc-cobar ,rdct)))))) + (trivial-rdct (vrtc-cobar (bcc rdct))) + (with-slots (f g h) rdct + (build-rdct + :f (vrtc-cobar f) + :g (vrtc-cobar g) + :h (hmtp-vrtc-cobar h (cmps g f)) + :orgn `(vrtc-cobar ,rdct)))))) (DEFMETHOD VRTC-COBAR ((hmeq homotopy-equivalence)) (the homotopy-equivalence (if (eq (first (orgn hmeq)) 'trivial-hmeq) - (trivial-hmeq (vrtc-cobar (lbcc hmeq))) - (with-slots (lrdct rrdct) hmeq - (build-hmeq - :lrdct (vrtc-cobar lrdct) - :rrdct (vrtc-cobar rrdct) - :orgn `(vrtc-cobar ,hmeq)))))) + (trivial-hmeq (vrtc-cobar (lbcc hmeq))) + (with-slots (lrdct rrdct) hmeq + (build-hmeq + :lrdct (vrtc-cobar lrdct) + :rrdct (vrtc-cobar rrdct) + :orgn `(vrtc-cobar ,hmeq)))))) (DEFMETHOD COBAR ((hmeq homotopy-equivalence)) @@ -524,5 +526,5 @@ structure of closures. This version works on ACL-PC. (error "In (COBAR HMEQ), the LBCC should be a coalgebra.")) (the homotopy-equivalence (if (eq (first (orgn hmeq)) 'trivial-hmeq) - (trivial-hmeq (cobar (lbcc hmeq))) - (add (vrtc-cobar hmeq) (cobar-hrzn-dffr (lbcc hmeq)))))) + (trivial-hmeq (cobar (lbcc hmeq))) + (add (vrtc-cobar hmeq) (cobar-hrzn-dffr (lbcc hmeq)))))) diff --git a/src/combinations.lisp b/src/combinations.lisp index d3b09f2..e5d20e2 100644 --- a/src/combinations.lisp +++ b/src/combinations.lisp @@ -1,4 +1,4 @@ -;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* ;;; COMBINATIONS COMBINATIONS COMBINATIONS COMBINATIONS COMBINATIONS ;;; COMBINATIONS COMBINATIONS COMBINATIONS COMBINATIONS COMBINATIONS diff --git a/src/cones.lisp b/src/cones.lisp index e36a334..6d53ecf 100644 --- a/src/cones.lisp +++ b/src/cones.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; CONES CONES CONES CONES CONES CONES CONES CONES CONES CONES ;;; CONES CONES CONES CONES CONES CONES CONES CONES CONES CONES ;;; CONES CONES CONES CONES CONES CONES CONES CONES CONES CONES @@ -13,72 +15,72 @@ (ignore depth)) (the cone (with-cone (conx icon) cone - (format stream "" mark)) - (declare (type gnrt icon)) - (with-cone (conx icon) mark - (format stream "-~D" conx) - (setf mark icon))) - cone))) + (format stream "" mark)) + (declare (type gnrt icon)) + (with-cone (conx icon) mark + (format stream "-~D" conx) + (setf mark icon))) + cone))) (DEFUN CONE-CMPR (cmpr0 cmpr1) (declare (type cmprf cmpr0 cmpr1)) (the cmprf (flet ((rslt (gnrt1 gnrt2) - (declare (type cone gnrt1 gnrt2)) - (the cmpr - (let ((ind1 (conx gnrt1)) - (ind2 (conx gnrt2)) - (gnrt11 (icon gnrt1)) - (gnrt22 (icon gnrt2))) - (declare - (fixnum ind1 ind2) - (type gnrt gnrt11 gnrt22)) - (ecase ind1 - (0 (ecase ind2 - (0 (funcall cmpr0 gnrt11 gnrt22)) - (1 :less))) - (1 (ecase ind2 - (0 :greater) - (1 (funcall cmpr1 gnrt11 gnrt22))))))))) - (declare (ftype (function (cone cone) cmpr) rslt)) - #'rslt))) + (declare (type cone gnrt1 gnrt2)) + (the cmpr + (let ((ind1 (conx gnrt1)) + (ind2 (conx gnrt2)) + (gnrt11 (icon gnrt1)) + (gnrt22 (icon gnrt2))) + (declare + (fixnum ind1 ind2) + (type gnrt gnrt11 gnrt22)) + (ecase ind1 + (0 (ecase ind2 + (0 (funcall cmpr0 gnrt11 gnrt22)) + (1 :less))) + (1 (ecase ind2 + (0 :greater) + (1 (funcall cmpr1 gnrt11 gnrt22))))))))) + (declare (ftype (function (cone cone) cmpr) rslt)) + #'rslt))) (DEFUN CONE-BASIS (basis0 basis1) (declare (type basis basis0 basis1)) (the basis (progn - (when (or (eq basis0 :locally-effective) - (eq basis1 :locally-effective)) - (return-from cone-basis :locally-effective)) - (flet ((rslt (degr) - (declare (type fixnum degr)) - (the list - (append - (mapcar #'(lambda (item) (con0 item)) - (funcall basis0 degr)) - (mapcar #'(lambda (item) (con1 item)) - (funcall basis1 (1- degr))))))) - (declare (ftype (function (fixnum) list) rslt)) - #'rslt)))) + (when (or (eq basis0 :locally-effective) + (eq basis1 :locally-effective)) + (return-from cone-basis :locally-effective)) + (flet ((rslt (degr) + (declare (type fixnum degr)) + (the list + (append + (mapcar #'(lambda (item) (con0 item)) + (funcall basis0 degr)) + (mapcar #'(lambda (item) (con1 item)) + (funcall basis1 (1- degr))))))) + (declare (ftype (function (fixnum) list) rslt)) + #'rslt)))) (DEFUN TERM-CON0 (term) (declare (type term term)) (the term (term (cffc term) - (con0 (gnrt term))))) + (con0 (gnrt term))))) (DEFUN TERM-CON1 (term) (declare (type term term)) (the term (term (cffc term) - (con1 (gnrt term))))) + (con1 (gnrt term))))) (DEFUN TERM-UNCON (term) @@ -91,95 +93,95 @@ (declare (type cmbn cmbn)) (the cmbn (make-cmbn - :degr (cmbn-degr cmbn) - :list (mapcar #'term-con0 (cmbn-list cmbn))))) + :degr (cmbn-degr cmbn) + :list (mapcar #'term-con0 (cmbn-list cmbn))))) (DEFUN CMBN-CON1 (cmbn) (declare (type cmbn cmbn)) (the cmbn (make-cmbn - :degr (cmbn-degr cmbn) - :list (mapcar #'term-con1 (cmbn-list cmbn))))) + :degr (cmbn-degr cmbn) + :list (mapcar #'term-con1 (cmbn-list cmbn))))) (DEFUN CONE-CMBN-SPLIT (cmbn) (declare (type cmbn cmbn)) (the (values cmbn cmbn) (with-cmbn (degr list) cmbn - (let ((list0 +empty-list+) - (list1 +empty-list+)) - (declare (type list list0 list1)) - (do ((mark list (cdr mark))) - ((endp mark) - (setf list0 (nreverse list0) - list1 +empty-list+)) - (declare (type list mark)) - (when (eql 1 (conx (cdar mark))) - (setf list0 (nreverse list0) - list1 (mapcar #'term-uncon mark)) - (return)) - (push (term-uncon (car mark)) list0)) - (values (make-cmbn :degr degr :list list0) - (make-cmbn :degr (1- degr) :list list1)))))) + (let ((list0 +empty-list+) + (list1 +empty-list+)) + (declare (type list list0 list1)) + (do ((mark list (cdr mark))) + ((endp mark) + (setf list0 (nreverse list0) + list1 +empty-list+)) + (declare (type list mark)) + (when (eql 1 (conx (cdar mark))) + (setf list0 (nreverse list0) + list1 (mapcar #'term-uncon mark)) + (return)) + (push (term-uncon (car mark)) list0)) + (values (make-cmbn :degr degr :list list0) + (make-cmbn :degr (1- degr) :list list1)))))) (DEFUN CONE-2CMBN-APPEND (cmbn0 cmbn1) (declare (type cmbn cmbn0 cmbn1)) (the cmbn (make-cmbn - :degr (cmbn-degr cmbn0) - :list (append (mapcar #'term-con0 (cmbn-list cmbn0)) - (mapcar #'term-con1 (cmbn-list cmbn1)))))) + :degr (cmbn-degr cmbn0) + :list (append (mapcar #'term-con0 (cmbn-list cmbn0)) + (mapcar #'term-con1 (cmbn-list cmbn1)))))) (DEFUN CONE-2MRPH-DIAG-IMPL (mrph0 mrph1) (declare (type morphism mrph0 mrph1)) (the intr-mrph (flet ((rslt (cmbn) - (declare (type cmbn cmbn)) - (the cmbn - (multiple-value-bind (cmbn0 cmbn1) - (cone-cmbn-split cmbn) - (declare (type cmbn cmbn0 cmbn1)) - (cone-2cmbn-append (? mrph0 cmbn0) - (? mrph1 cmbn1)))))) - #'rslt))) + (declare (type cmbn cmbn)) + (the cmbn + (multiple-value-bind (cmbn0 cmbn1) + (cone-cmbn-split cmbn) + (declare (type cmbn cmbn0 cmbn1)) + (cone-2cmbn-append (? mrph0 cmbn0) + (? mrph1 cmbn1)))))) + #'rslt))) (DEFUN CONE-3MRPH-TRIANGLE-IMPL (cmpr0 mrph0 mrph1 phi) (declare (ignore cmpr0) (type morphism mrph0 mrph1 phi)) (the intr-mrph (flet ((rslt (degr gnrt) - (declare (type fixnum degr) (type gnrt gnrt)) - (the cmbn - (ecase (conx gnrt) - (0 (cmbn-con0 (? mrph0 degr (icon gnrt)))) - (1 - (let ((gnrt (icon gnrt))) - (declare (type gnrt gnrt)) - (cone-2cmbn-append - (? phi (1- degr) gnrt) - (? mrph1 (1- degr) gnrt)))))))) - #'rslt))) + (declare (type fixnum degr) (type gnrt gnrt)) + (the cmbn + (ecase (conx gnrt) + (0 (cmbn-con0 (? mrph0 degr (icon gnrt)))) + (1 + (let ((gnrt (icon gnrt))) + (declare (type gnrt gnrt)) + (cone-2cmbn-append + (? phi (1- degr) gnrt) + (? mrph1 (1- degr) gnrt)))))))) + #'rslt))) (DEFUN CONE (mrph) (declare (type morphism mrph)) (the chain-complex (let ((chcm0 (trgt mrph)) - (chcm1 (sorc mrph))) - (declare (type chain-complex chcm0 chcm1)) - (build-chcm - :cmpr (cone-cmpr (cmpr chcm0) (cmpr chcm1)) - :basis (cone-basis (basis chcm0) (basis chcm1)) - :bsgn (con0 (bsgn chcm0)) - :intr-dffr (cone-3mrph-triangle-impl (cmpr chcm0) - (dffr chcm0) - (n-mrph -1 (dffr chcm1)) - mrph) - :strt :gnrt - :orgn `(cone ,mrph))))) + (chcm1 (sorc mrph))) + (declare (type chain-complex chcm0 chcm1)) + (build-chcm + :cmpr (cone-cmpr (cmpr chcm0) (cmpr chcm1)) + :basis (cone-basis (basis chcm0) (basis chcm1)) + :bsgn (con0 (bsgn chcm0)) + :intr-dffr (cone-3mrph-triangle-impl (cmpr chcm0) + (dffr chcm0) + (n-mrph -1 (dffr chcm1)) + mrph) + :strt :gnrt + :orgn `(cone ,mrph))))) (DEFUN CONE-2MRPH-DIAG (sorc-cone trgt-cone mrph0 mrph1) @@ -188,15 +190,15 @@ (type morphism mrph0 mrph1)) (the morphism (progn - (unless (= (degr mrph0) (degr mrph1)) - (error "Non-coherent degrees in CONE-2MRPH-DIAG.")) - (build-mrph - :sorc sorc-cone - :trgt trgt-cone - :degr (degr mrph0) - :intr (cone-2mrph-diag-impl mrph0 mrph1) - :strt :cmbn - :orgn `(cone-2mrph-diag ,sorc-cone ,trgt-cone ,mrph0 ,mrph1))))) + (unless (= (degr mrph0) (degr mrph1)) + (error "Non-coherent degrees in CONE-2MRPH-DIAG.")) + (build-mrph + :sorc sorc-cone + :trgt trgt-cone + :degr (degr mrph0) + :intr (cone-2mrph-diag-impl mrph0 mrph1) + :strt :cmbn + :orgn `(cone-2mrph-diag ,sorc-cone ,trgt-cone ,mrph0 ,mrph1))))) (DEFUN CONE-3MRPH-TRIANGLE (sorc-cone trgt-cone mrph0 mrph1 phi) @@ -205,55 +207,55 @@ (type morphism mrph0 mrph1 phi)) (the morphism (progn - (unless (= (degr mrph0) (degr mrph1)) - (error "Non-coherent degrees in CONE-3MRPH-TRIANGLE.")) - (unless (= (1+ (degr mrph0)) (degr phi)) - (error "Non-coherent-degrees in CONE-3MRPH-TRIANGLE.")) - (build-mrph - :sorc sorc-cone - :trgt trgt-cone - :degr (degr mrph0) - :intr (cone-3mrph-triangle-impl - (cmpr (trgt phi)) - mrph0 mrph1 phi) - :strt :gnrt - :orgn `(cone-3mrph-triangle ,sorc-cone ,trgt-cone - ,mrph0 ,mrph1 ,phi))))) + (unless (= (degr mrph0) (degr mrph1)) + (error "Non-coherent degrees in CONE-3MRPH-TRIANGLE.")) + (unless (= (1+ (degr mrph0)) (degr phi)) + (error "Non-coherent-degrees in CONE-3MRPH-TRIANGLE.")) + (build-mrph + :sorc sorc-cone + :trgt trgt-cone + :degr (degr mrph0) + :intr (cone-3mrph-triangle-impl + (cmpr (trgt phi)) + mrph0 mrph1 phi) + :strt :gnrt + :orgn `(cone-3mrph-triangle ,sorc-cone ,trgt-cone + ,mrph0 ,mrph1 ,phi))))) (DEFUN CONE-EFHM (cone) (declare (type chain-complex cone)) (the homotopy-equivalence (let* ((phi (second (orgn cone))) - (chcm0 (trgt phi)) (chcm1 (sorc phi)) - (efhm0 (efhm chcm0)) (efhm1 (efhm chcm1)) - (lf0 (lf efhm0)) (lg0 (lg efhm0)) (lh0 (lh efhm0)) - (rf0 (rf efhm0)) (rg0 (rg efhm0)) (rh0 (rh efhm0)) - (lf1 (lf efhm1)) (lg1 (lg efhm1)) (lh1 (lh efhm1)) - (rf1 (rf efhm1)) (rg1 (rg efhm1)) (rh1 (rh efhm1)) - (hphi (cmps lg0 (cmps phi lf1))) - (ephi (cmps rf0 (cmps hphi rg1))) - (hcone (cone hphi)) - (econe (cone ephi)) - (LF (cone-2mrph-diag hcone cone lf0 lf1)) - (LG (cone-2mrph-diag cone hcone lg0 lg1)) - (LH (cone-2mrph-diag hcone hcone lh0 (n-mrph -1 lh1))) - (RF (cone-3mrph-triangle hcone econe rf0 rf1 - (cmps rf0 (cmps hphi rh1)))) - (RG (cone-3mrph-triangle econe hcone rg0 rg1 - (n-mrph -1 (cmps rh0 (cmps hphi rg1))))) - (RH (cone-3mrph-triangle hcone hcone rh0 (n-mrph -1 rh1) - (cmps rh0 (cmps hphi rh1))))) - (declare - (type chain-complex chcm0 chcm1 hcone econe) - (type morphism phi lf0 lg0 lh0 rf0 rg0 rh0 lf1 lg1 lh1 rf1 rg1 rh1 - hphi ephi LF LG LH RF RG RH)) - (build-hmeq - :lrdct (build-rdct :f LF :g LG :h LH - :orgn `(cone-efhm ,cone lrdct)) - :rrdct (build-rdct :f RF :g RG :h RH - :orgn `(cone-efhm ,cone rrdct)) - :orgn `(cone-efhm ,cone))))) + (chcm0 (trgt phi)) (chcm1 (sorc phi)) + (efhm0 (efhm chcm0)) (efhm1 (efhm chcm1)) + (lf0 (lf efhm0)) (lg0 (lg efhm0)) (lh0 (lh efhm0)) + (rf0 (rf efhm0)) (rg0 (rg efhm0)) (rh0 (rh efhm0)) + (lf1 (lf efhm1)) (lg1 (lg efhm1)) (lh1 (lh efhm1)) + (rf1 (rf efhm1)) (rg1 (rg efhm1)) (rh1 (rh efhm1)) + (hphi (cmps lg0 (cmps phi lf1))) + (ephi (cmps rf0 (cmps hphi rg1))) + (hcone (cone hphi)) + (econe (cone ephi)) + (LF (cone-2mrph-diag hcone cone lf0 lf1)) + (LG (cone-2mrph-diag cone hcone lg0 lg1)) + (LH (cone-2mrph-diag hcone hcone lh0 (n-mrph -1 lh1))) + (RF (cone-3mrph-triangle hcone econe rf0 rf1 + (cmps rf0 (cmps hphi rh1)))) + (RG (cone-3mrph-triangle econe hcone rg0 rg1 + (n-mrph -1 (cmps rh0 (cmps hphi rg1))))) + (RH (cone-3mrph-triangle hcone hcone rh0 (n-mrph -1 rh1) + (cmps rh0 (cmps hphi rh1))))) + (declare + (type chain-complex chcm0 chcm1 hcone econe) + (type morphism phi lf0 lg0 lh0 rf0 rg0 rh0 lf1 lg1 lh1 rf1 rg1 rh1 + hphi ephi LF LG LH RF RG RH)) + (build-hmeq + :lrdct (build-rdct :f LF :g LG :h LH + :orgn `(cone-efhm ,cone lrdct)) + :rrdct (build-rdct :f RF :g RG :h RH + :orgn `(cone-efhm ,cone rrdct)) + :orgn `(cone-efhm ,cone))))) (DEFMETHOD SEARCH-EFHM (chcm (orgn (eql 'cone))) (declare (type chain-complex chcm)) diff --git a/src/cs-twisted-products.lisp b/src/cs-twisted-products.lisp index ac2393c..1e130b1 100644 --- a/src/cs-twisted-products.lisp +++ b/src/cs-twisted-products.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; CS-TWISTED-PRODUCTS CS-TWISTED-PRODUCTS CS-TWISTED-PRODUCTS ;;; CS-TWISTED-PRODUCTS CS-TWISTED-PRODUCTS CS-TWISTED-PRODUCTS ;;; CS-TWISTED-PRODUCTS CS-TWISTED-PRODUCTS CS-TWISTED-PRODUCTS @@ -17,35 +19,35 @@ (declare (type simplicial-group smgr)) (the fibration (build-smmr - :sorc (classifying-space smgr) - :trgt smgr - :degr -1 - :sintr #'smgr-fibration-sintr - :orgn `(simplicial-group-fibration ,smgr)))) + :sorc (classifying-space smgr) + :trgt smgr + :degr -1 + :sintr #'smgr-fibration-sintr + :orgn `(simplicial-group-fibration ,smgr)))) (DEFUN SMGR-CRTS-CONTRACTION-INTR (idnt) (declare (type gmsm idnt)) (flet ((rslt (degr crpr - &aux (degr+1 (1+ degr))) - (declare - (fixnum degr degr+1) - (type crpr crpr)) - (the cmbn - (with-crpr - (absm1 absm2) crpr - (if (= (dgop absm2) (mask degr)) - (zero-cmbn degr+1) - (term-cmbn degr+1 - (-1-expt-n+1 degr) - (crpr 0 (make-gbar - :dmns degr+1 - :list (cons absm2 - (rest - (unnormalize-gbar - absm1 idnt)))) - (mask degr+1) idnt))))))) + &aux (degr+1 (1+ degr))) + (declare + (fixnum degr degr+1) + (type crpr crpr)) + (the cmbn + (with-crpr + (absm1 absm2) crpr + (if (= (dgop absm2) (mask degr)) + (zero-cmbn degr+1) + (term-cmbn degr+1 + (-1-expt-n+1 degr) + (crpr 0 (make-gbar + :dmns degr+1 + :list (cons absm2 + (rest + (unnormalize-gbar + absm1 idnt)))) + (mask degr+1) idnt))))))) (the intr-mrph #'rslt))) @@ -53,20 +55,20 @@ (declare (type simplicial-group smgr)) (the morphism (build-mrph - :sorc (fibration-total (smgr-fibration smgr)) - :trgt (fibration-total (smgr-fibration smgr)) - :degr +1 - :intr (smgr-crts-contraction-intr (bspn smgr)) - :strt :gnrt - :orgn `(smgr-crts-contraction ,smgr)))) + :sorc (fibration-total (smgr-fibration smgr)) + :trgt (fibration-total (smgr-fibration smgr)) + :degr +1 + :intr (smgr-crts-contraction-intr (bspn smgr)) + :strt :gnrt + :orgn `(smgr-crts-contraction ,smgr)))) (DEFUN SMGR-TNPR-CONTRACTION (smgr - &aux (fibration (smgr-fibration smgr)) - (brown (brown-reduction fibration)) - (f (f brown)) - (g (g brown)) - (chi (smgr-crts-contraction smgr))) + &aux (fibration (smgr-fibration smgr)) + (brown (brown-reduction fibration)) + (f (f brown)) + (g (g brown)) + (chi (smgr-crts-contraction smgr))) (declare (type simplicial-group smgr) (type fibration fibration) diff --git a/src/delta.lisp b/src/delta.lisp index 122d73d..e83417d 100644 --- a/src/delta.lisp +++ b/src/delta.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; DELTA DELTA DELTA DELTA DELTA DELTA DELTA DELTA DELTA ;;; DELTA DELTA DELTA DELTA DELTA DELTA DELTA DELTA DELTA ;;; DELTA DELTA DELTA DELTA DELTA DELTA DELTA DELTA DELTA @@ -25,13 +27,13 @@ (ignore dmns)) (the absm (do ((pmark 1 (ash pmark 1)) - (bmark indx) - (gmsm2 gmsm (ash gmsm2 -1))) - (nil) + (bmark indx) + (gmsm2 gmsm (ash gmsm2 -1))) + (nil) (declare (fixnum pmark bmark gmsm2)) (when (oddp gmsm2) - (when (minusp (decf bmark)) - (return-from delta-face (absm 0 (logxor gmsm pmark)))))))) + (when (minusp (decf bmark)) + (return-from delta-face (absm 0 (logxor gmsm pmark)))))))) (DEFUN SOFT-DELTA-FACE (indx dmns gmsm) @@ -45,20 +47,20 @@ (declare (fixnum dmns gmsm)) (the cmbn (if (zerop dmns) - +zero-negative-cmbn+ - (make-cmbn + +zero-negative-cmbn+ + (make-cmbn :degr (1- dmns) :list (do ((rslt +empty-list+) - (gmsm2 gmsm (ash gmsm2 -1)) - (pmark 1 (ash pmark +1)) - (sign 1)) - ((zerop gmsm2) rslt) + (gmsm2 gmsm (ash gmsm2 -1)) + (pmark 1 (ash pmark +1)) + (sign 1)) + ((zerop gmsm2) rslt) (declare - (list rslt) - (fixnum gmsm2 pmark sign)) + (list rslt) + (fixnum gmsm2 pmark sign)) (when (oddp gmsm2) - (push (term sign (logxor gmsm pmark)) rslt) - (setf sign (- sign)))))))) + (push (term sign (logxor gmsm pmark)) rslt) + (setf sign (- sign)))))))) (DEFUN SOFT-DELTA-BNDR (dmns gmsm) @@ -68,30 +70,30 @@ (make-cmbn :degr (1- dmns) :list (mapcar #'(lambda (term) - (with-term (cffc gmsm) term - (term cffc (d gmsm)))) - (cmbn-list (delta-bndr dmns (cdr gmsm)))))) + (with-term (cffc gmsm) term + (term cffc (d gmsm)))) + (cmbn-list (delta-bndr dmns (cdr gmsm)))))) (DEFUN DELTA-DGNL (dmns gmsm) (declare (fixnum dmns gmsm)) (the cmbn (make-cmbn - :degr dmns - :list (do ((rslt +empty-list+) - (ldegr dmns) - (indx (1- (integer-length gmsm)) (1- indx))) - ((minusp indx)) - (declare - (list rslt) - (fixnum indx)) - (when (logbitp indx gmsm) - (push (term 1 (tnpr - ldegr (logand gmsm (mask (1+ indx))) - (- dmns ldegr) (logandc2 gmsm (mask indx)))) + :degr dmns + :list (do ((rslt +empty-list+) + (ldegr dmns) + (indx (1- (integer-length gmsm)) (1- indx))) + ((minusp indx)) + (declare + (list rslt) + (fixnum indx)) + (when (logbitp indx gmsm) + (push (term 1 (tnpr + ldegr (logand gmsm (mask (1+ indx))) + (- dmns ldegr) (logandc2 gmsm (mask indx)))) rslt) - (when (minusp (decf ldegr)) - (return rslt))))))) + (when (minusp (decf ldegr)) + (return rslt))))))) (DEFUN SOFT-DELTA-DGNL (dmns gmsm) @@ -99,72 +101,72 @@ (fixnum dmns) (type soft-dlop gmsm)) (make-cmbn :degr dmns - :list (mapcar - #'(lambda (term) - (with-term (cffc tnpr) term - (with-tnpr (degr1 gmsm1 degr2 gmsm2) tnpr - (term cffc - (tnpr degr1 (d gmsm1) - degr2 (d gmsm2)))))) - (cmbn-list (delta-dgnl dmns (cdr gmsm)))))) + :list (mapcar + #'(lambda (term) + (with-term (cffc tnpr) term + (with-tnpr (degr1 gmsm1 degr2 gmsm2) tnpr + (term cffc + (tnpr degr1 (d gmsm1) + degr2 (d gmsm2)))))) + (cmbn-list (delta-dgnl dmns (cdr gmsm)))))) (DEFUN DELTA-INFINITY () (the simplicial-set (build-smst - :cmpr #'f-cmpr - :basis :locally-effective - :bspn 1 - :face #'delta-face - :intr-dgnl #'delta-dgnl - :dgnl-strt :gnrt - :intr-bndr #'delta-bndr - :bndr-strt :gnrt - :orgn '(delta-infinity)))) + :cmpr #'f-cmpr + :basis :locally-effective + :bspn 1 + :face #'delta-face + :intr-dgnl #'delta-dgnl + :dgnl-strt :gnrt + :intr-bndr #'delta-bndr + :bndr-strt :gnrt + :orgn '(delta-infinity)))) (DEFUN SOFT-DELTA-INFINITY () (the simplicial-set (build-smst - :cmpr #'soft-delta-cmpr - :basis :locally-effective - :bspn (d 1) - :face #'soft-delta-face - :intr-dgnl #'soft-delta-dgnl :dgnl-strt :gnrt - :intr-bndr #'soft-delta-bndr :bndr-strt :gnrt - :orgn '(soft-delta-infinity)))) + :cmpr #'soft-delta-cmpr + :basis :locally-effective + :bspn (d 1) + :face #'soft-delta-face + :intr-dgnl #'soft-delta-dgnl :dgnl-strt :gnrt + :intr-bndr #'soft-delta-bndr :bndr-strt :gnrt + :orgn '(soft-delta-infinity)))) (DEFUN DELTA-N-BASIS (n) (declare (fixnum n)) (flet ((rslt (dmns) - (declare (fixnum dmns)) - (when (> dmns n) - (return-from rslt +empty-list+)) - (setf dmns (1+ dmns)) - (do ((rslt +empty-list+) - (count (binomial-n-p (1+ n) dmns)) - (gmsm (mask (1+ n)) (1- gmsm))) - ((zerop count) rslt) - (when (= (logcount gmsm) dmns) - (push gmsm rslt) - (decf count))))) + (declare (fixnum dmns)) + (when (> dmns n) + (return-from rslt +empty-list+)) + (setf dmns (1+ dmns)) + (do ((rslt +empty-list+) + (count (binomial-n-p (1+ n) dmns)) + (gmsm (mask (1+ n)) (1- gmsm))) + ((zerop count) rslt) + (when (= (logcount gmsm) dmns) + (push gmsm rslt) + (decf count))))) (the basis #'rslt))) (DEFUN SOFT-DELTA-N-BASIS (n) (declare (fixnum n)) (flet ((rslt (dmns) - (when (> dmns n) - (return-from rslt +empty-list+)) - (setf dmns (1+ dmns)) - (do ((rslt +empty-list+) - (count (binomial-n-p (1+ n) dmns)) - (gmsm (mask (1+ n)) (1- gmsm))) - ((zerop count) rslt) - (when (= (logcount gmsm) dmns) - (push (d gmsm) rslt) - (decf count))))) + (when (> dmns n) + (return-from rslt +empty-list+)) + (setf dmns (1+ dmns)) + (do ((rslt +empty-list+) + (count (binomial-n-p (1+ n) dmns)) + (gmsm (mask (1+ n)) (1- gmsm))) + ((zerop count) rslt) + (when (= (logcount gmsm) dmns) + (push (d gmsm) rslt) + (decf count))))) (the basis #'rslt))) @@ -172,28 +174,28 @@ (declare (fixnum dmns)) (the simplicial-set (build-smst - :cmpr #'f-cmpr - :basis (delta-n-basis dmns) - :bspn 1 - :face #'delta-face - :intr-dgnl #'delta-dgnl - :dgnl-strt :gnrt - :intr-bndr #'delta-bndr - :bndr-strt :gnrt - :orgn `(delta ,dmns)))) + :cmpr #'f-cmpr + :basis (delta-n-basis dmns) + :bspn 1 + :face #'delta-face + :intr-dgnl #'delta-dgnl + :dgnl-strt :gnrt + :intr-bndr #'delta-bndr + :bndr-strt :gnrt + :orgn `(delta ,dmns)))) (DEFUN SOFT-DELTA (dmns) (declare (fixnum dmns)) (the simplicial-set (build-smst - :cmpr #'soft-delta-cmpr - :basis (soft-delta-n-basis dmns) - :bspn (d 1) - :face #'soft-delta-face - :intr-dgnl #'soft-delta-dgnl :dgnl-strt :gnrt - :intr-bndr #'soft-delta-bndr :bndr-strt :gnrt - :orgn `(soft-delta ,dmns)))) + :cmpr #'soft-delta-cmpr + :basis (soft-delta-n-basis dmns) + :bspn (d 1) + :face #'soft-delta-face + :intr-dgnl #'soft-delta-dgnl :dgnl-strt :gnrt + :intr-bndr #'soft-delta-bndr :bndr-strt :gnrt + :orgn `(soft-delta ,dmns)))) (DEFUN DELTAB-CMPR (gmsm1 gmsm2) @@ -207,20 +209,20 @@ (declare (fixnum dmns gmsm)) (the cmbn (if (< dmns 2) - (zero-cmbn (1- dmns)) - (make-cmbn + (zero-cmbn (1- dmns)) + (make-cmbn :degr (1- dmns) :list (do ((rslt +empty-list+) - (gmsm2 gmsm (ash gmsm2 -1)) - (pmark 1 (ash pmark +1)) - (sign 1)) - ((zerop gmsm2) rslt) + (gmsm2 gmsm (ash gmsm2 -1)) + (pmark 1 (ash pmark +1)) + (sign 1)) + ((zerop gmsm2) rslt) (declare - (list rslt) - (fixnum gmsm2 pmark sign)) + (list rslt) + (fixnum gmsm2 pmark sign)) (when (oddp gmsm2) - (push (term sign (logxor gmsm pmark)) rslt) - (setf sign (- sign)))))))) + (push (term sign (logxor gmsm pmark)) rslt) + (setf sign (- sign)))))))) (DEFUN DELTAB2-FACE (indx dmns gmsm) @@ -228,87 +230,87 @@ (fixnum indx dmns gmsm)) (the absm (progn - (when (= 2 dmns) - (return-from deltab2-face (absm 1 1))) - (do ((pmark 1 (ash pmark 1)) - (bmark indx) - (gmsm2 gmsm (ash gmsm2 -1))) - (nil) - (declare (fixnum pmark bmark gmsm2)) - (when (oddp gmsm2) - (when (minusp (decf bmark)) - (return-from deltab2-face (absm 0 (logxor gmsm pmark))))))))) + (when (= 2 dmns) + (return-from deltab2-face (absm 1 1))) + (do ((pmark 1 (ash pmark 1)) + (bmark indx) + (gmsm2 gmsm (ash gmsm2 -1))) + (nil) + (declare (fixnum pmark bmark gmsm2)) + (when (oddp gmsm2) + (when (minusp (decf bmark)) + (return-from deltab2-face (absm 0 (logxor gmsm pmark))))))))) (DEFUN DELTAB2-DGNL (dmns gmsm) (declare (fixnum dmns gmsm)) (the cmbn (make-cmbn - :degr dmns - :list (if (zerop dmns) - (list (term 1 (tnpr 0 gmsm 0 gmsm))) - (do ((rslt +empty-list+) - (ldegr dmns) - (indx (1- (integer-length gmsm)) (1- indx))) - ((minusp indx)) - (declare (list rslt) (fixnum indx)) - (when (logbitp indx gmsm) - (push (term 1 (tnpr - ldegr (logand gmsm (mask (1+ indx))) - (- dmns ldegr) - (logandc2 gmsm (mask indx)))) - rslt) - (when (minusp (decf ldegr)) - (setf rslt (delete 1 rslt - :key #'(lambda (x) - (degr1 (cdr x))))) - (setf (gnrt1 (gnrt (first rslt))) - (setf (gnrt2 (gnrt (car (last rslt)))) - 1)) - (return (delete 1 rslt - :key #'(lambda (x) - (gnrt1 (cdr x)))))))))))) + :degr dmns + :list (if (zerop dmns) + (list (term 1 (tnpr 0 gmsm 0 gmsm))) + (do ((rslt +empty-list+) + (ldegr dmns) + (indx (1- (integer-length gmsm)) (1- indx))) + ((minusp indx)) + (declare (list rslt) (fixnum indx)) + (when (logbitp indx gmsm) + (push (term 1 (tnpr + ldegr (logand gmsm (mask (1+ indx))) + (- dmns ldegr) + (logandc2 gmsm (mask indx)))) + rslt) + (when (minusp (decf ldegr)) + (setf rslt (delete 1 rslt + :key #'(lambda (x) + (degr1 (cdr x))))) + (setf (gnrt1 (gnrt (first rslt))) + (setf (gnrt2 (gnrt (car (last rslt)))) + 1)) + (return (delete 1 rslt + :key #'(lambda (x) + (gnrt1 (cdr x)))))))))))) (DEFUN DELTAB2-BNDR (dmns gmsm) (declare (fixnum dmns gmsm)) (the cmbn (if (< dmns 3) - (zero-cmbn (1- dmns)) - (make-cmbn + (zero-cmbn (1- dmns)) + (make-cmbn :degr (1- dmns) :list (do ((rslt +empty-list+) - (gmsm2 gmsm (ash gmsm2 -1)) - (pmark 1 (ash pmark +1)) - (sign 1)) - ((zerop gmsm2) rslt) + (gmsm2 gmsm (ash gmsm2 -1)) + (pmark 1 (ash pmark +1)) + (sign 1)) + ((zerop gmsm2) rslt) (declare - (list rslt) - (fixnum gmsm2 pmark sign)) + (list rslt) + (fixnum gmsm2 pmark sign)) (when (oddp gmsm2) - (push (term sign (logxor gmsm pmark)) rslt) - (setf sign (- sign)))))))) + (push (term sign (logxor gmsm pmark)) rslt) + (setf sign (- sign)))))))) (DEFUN DELTAB () (the simplicial-set (build-smst - :cmpr #'deltab-cmpr - :basis :locally-effective - :bspn 1 - :face #'delta-face - :intr-dgnl #'delta-dgnl - :dgnl-strt :gnrt - :orgn '(deltab)))) + :cmpr #'deltab-cmpr + :basis :locally-effective + :bspn 1 + :face #'delta-face + :intr-dgnl #'delta-dgnl + :dgnl-strt :gnrt + :orgn '(deltab)))) (DEFUN DELTAB2 () (the simplicial-set (build-smst - :cmpr #'f-cmpr - :basis :locally-effective - :bspn 1 - :face #'deltab2-face - :intr-dgnl #'deltab2-dgnl - :dgnl-strt :gnrt - :orgn '(deltab2)))) + :cmpr #'f-cmpr + :basis :locally-effective + :bspn 1 + :face #'deltab2-face + :intr-dgnl #'deltab2-dgnl + :dgnl-strt :gnrt + :orgn '(deltab2)))) diff --git a/src/disk-pasting.lisp b/src/disk-pasting.lisp index aa936ec..2b73958 100644 --- a/src/disk-pasting.lisp +++ b/src/disk-pasting.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; DISK-PASTING DISK-PASTING DISK-PASTING DISK-PASTING ;;; DISK-PASTING DISK-PASTING DISK-PASTING DISK-PASTING ;;; DISK-PASTING DISK-PASTING DISK-PASTING DISK-PASTING @@ -11,14 +13,14 @@ (type cmprf cmpr) (symbol new)) (flet ((rslt (gnrt1 gnrt2) - (declare (type gnrt gnrt1 gnrt2)) - (if (eq gnrt1 new) - (if (eq gnrt2 new) - :equal - :less) - (if (eq gnrt2 new) - :greater - (funcall cmpr gnrt1 gnrt2))))) + (declare (type gnrt gnrt1 gnrt2)) + (if (eq gnrt1 new) + (if (eq gnrt2 new) + :equal + :less) + (if (eq gnrt2 new) + :greater + (funcall cmpr gnrt1 gnrt2))))) (the cmprf #'rslt))) @@ -28,10 +30,10 @@ (fixnum dmns) (symbol new)) (flet ((rslt (degr) - (declare (fixnum degr)) - (if (= degr dmns) - (cons new (funcall basis dmns)) - (funcall basis degr)))) + (declare (fixnum degr)) + (if (= degr dmns) + (cons new (funcall basis dmns)) + (funcall basis degr)))) (the basis #'rslt))) @@ -46,22 +48,22 @@ (let ((cmpr (cmpr (trgt old-dffr)))) (declare (type cmprf cmpr)) (flet ((rslt (cmbn) - (declare (type cmbn cmbn)) - (with-cmbn (degr2 list) cmbn - (unless (= degr degr2) - (return-from rslt - (cmbn-? old-dffr cmbn))) - (unless list - (return-from rslt - (zero-cmbn (1- degr)))) - (unless (eq (-gnrt list) new) - (return-from rslt - (cmbn-? old-dffr cmbn))) - (2cmbn-add cmpr - (n-cmbn (-cffc list) bndr) - (cmbn-? old-dffr - (make-cmbn :degr degr - :list (rest list))))))) + (declare (type cmbn cmbn)) + (with-cmbn (degr2 list) cmbn + (unless (= degr degr2) + (return-from rslt + (cmbn-? old-dffr cmbn))) + (unless list + (return-from rslt + (zero-cmbn (1- degr)))) + (unless (eq (-gnrt list) new) + (return-from rslt + (cmbn-? old-dffr cmbn))) + (2cmbn-add cmpr + (n-cmbn (-cffc list) bndr) + (cmbn-? old-dffr + (make-cmbn :degr degr + :list (rest list))))))) (the intr-mrph #'rslt)))) @@ -73,20 +75,20 @@ (type cmbn bndr)) (the chain-complex (with-slots (cmpr basis dffr) chcm - (declare - (type cmprf cmpr) - (type basis basis) - (type morphism dffr)) - (let ((rslt (build-chcm - :cmpr (disk-pasting-cmpr cmpr new) - :basis (disk-pasting-basis basis dmns new) - :intr-dffr (disk-pasting-intr-dffr dffr dmns new bndr) - :strt :cmbn - :orgn `(chcm-disk-pasting ,chcm ,dmns ,new ,bndr)))) - (declare (type chain-complex rslt)) - (when (slot-boundp chcm 'bsgn) - (setf (slot-value rslt 'bsgn) (slot-value chcm 'bsgn))) - rslt)))) + (declare + (type cmprf cmpr) + (type basis basis) + (type morphism dffr)) + (let ((rslt (build-chcm + :cmpr (disk-pasting-cmpr cmpr new) + :basis (disk-pasting-basis basis dmns new) + :intr-dffr (disk-pasting-intr-dffr dffr dmns new bndr) + :strt :cmbn + :orgn `(chcm-disk-pasting ,chcm ,dmns ,new ,bndr)))) + (declare (type chain-complex rslt)) + (when (slot-boundp chcm 'bsgn) + (setf (slot-value rslt 'bsgn) (slot-value chcm 'bsgn))) + rslt)))) (DEFUN DISK-PASTING-FACE (cmpr face dmns new faces) @@ -99,20 +101,20 @@ (unless (= (1+ dmns) (length faces)) (error "In DISK-PASTING, non-coherent arguments.")) (mapl #'(lambda (mark) - (declare (list mark)) - (unless (typep (car mark) 'absm) - (setf (car mark) (absm 0 (car mark))))) - faces) + (declare (list mark)) + (unless (typep (car mark) 'absm) + (setf (car mark) (absm 0 (car mark))))) + faces) (flet ((rslt (indx dmns2 gmsm) - (declare - (fixnum indx dmns2) - (type gmsm gmsm)) - (unless (= dmns dmns2) - (return-from rslt - (funcall face indx dmns2 gmsm))) - (if (eq gmsm new) - (nth indx faces) - (funcall face indx dmns gmsm)))) + (declare + (fixnum indx dmns2) + (type gmsm gmsm)) + (unless (= dmns dmns2) + (return-from rslt + (funcall face indx dmns2 gmsm))) + (if (eq gmsm new) + (nth indx faces) + (funcall face indx dmns gmsm)))) (unless (check-faces cmpr #'rslt dmns new) (error "The new simplicial-set is not constructed.")) (the face #'rslt))) @@ -126,37 +128,37 @@ (list faces)) (the simplicial-set (with-slots (cmpr basis bsgn face dffr) smst - (declare - (type cmprf cmpr) - (type basis basis) - (type gmsm bsgn) - (type face face) - (type morphism dffr)) - (let ((new-face (disk-pasting-face (cmpr smst) face - dmns new faces)) - (new-bndr (zero-cmbn (1- dmns)))) - (declare - (type face new-face) - (type cmbn new-bndr)) - (do ((mark faces (cdr mark)) - (sign 1 (- sign))) - ((endp mark)) - (declare - (list mark) - (fixnum sign)) - (let ((absm (car mark))) - (declare (type absm absm)) - (with-absm (dgop gmsm) absm - (unless (plusp dgop) - (dstr-add-term-to-cmbn cmpr sign gmsm new-bndr))))) - (build-smst - :cmpr (disk-pasting-cmpr cmpr new) - :basis (disk-pasting-basis basis dmns new) - :bspn bsgn - :face new-face - :intr-bndr (disk-pasting-intr-dffr dffr dmns new new-bndr) - :bndr-strt :cmbn - :orgn `(disk-pasting ,smst ,dmns ,new ,faces)))))) + (declare + (type cmprf cmpr) + (type basis basis) + (type gmsm bsgn) + (type face face) + (type morphism dffr)) + (let ((new-face (disk-pasting-face (cmpr smst) face + dmns new faces)) + (new-bndr (zero-cmbn (1- dmns)))) + (declare + (type face new-face) + (type cmbn new-bndr)) + (do ((mark faces (cdr mark)) + (sign 1 (- sign))) + ((endp mark)) + (declare + (list mark) + (fixnum sign)) + (let ((absm (car mark))) + (declare (type absm absm)) + (with-absm (dgop gmsm) absm + (unless (plusp dgop) + (dstr-add-term-to-cmbn cmpr sign gmsm new-bndr))))) + (build-smst + :cmpr (disk-pasting-cmpr cmpr new) + :basis (disk-pasting-basis basis dmns new) + :bspn bsgn + :face new-face + :intr-bndr (disk-pasting-intr-dffr dffr dmns new new-bndr) + :bndr-strt :cmbn + :orgn `(disk-pasting ,smst ,dmns ,new ,faces)))))) (DEFUN MRPH-DISK-PASTING-INTR (mrph trgt-cmpr dmns new new-im) @@ -169,22 +171,22 @@ (let ((mrph-degr (degr mrph))) (declare (fixnum mrph-degr)) (flet ((rslt (cmbn) - (declare (type cmbn cmbn)) - (with-cmbn (degr list) cmbn - (unless (= degr dmns) - (return-from rslt - (cmbn-? mrph cmbn))) - (unless list - (return-from rslt - (zero-cmbn (+ degr mrph-degr)))) - (unless (eq new (-gnrt list)) - (return-from rslt - (cmbn-? mrph cmbn))) - (2cmbn-add trgt-cmpr - (n-cmbn (-cffc list) new-im) - (cmbn-? mrph - (make-cmbn :degr degr - :list (rest list))))))) + (declare (type cmbn cmbn)) + (with-cmbn (degr list) cmbn + (unless (= degr dmns) + (return-from rslt + (cmbn-? mrph cmbn))) + (unless list + (return-from rslt + (zero-cmbn (+ degr mrph-degr)))) + (unless (eq new (-gnrt list)) + (return-from rslt + (cmbn-? mrph cmbn))) + (2cmbn-add trgt-cmpr + (n-cmbn (-cffc list) new-im) + (cmbn-? mrph + (make-cmbn :degr degr + :list (rest list))))))) (the intr-mrph #'rslt)))) @@ -197,12 +199,12 @@ (type cmbn new-im)) (the morphism (build-mrph - :sorc new-sorc :trgt new-trgt :degr (degr mrph) - :intr (mrph-disk-pasting-intr mrph (cmpr new-trgt) - dmns new new-im) - :strt :cmbn - :orgn `(mrph-disk-pasting ,mrph ,new-sorc ,new-trgt - ,dmns ,new ,new-im)))) + :sorc new-sorc :trgt new-trgt :degr (degr mrph) + :intr (mrph-disk-pasting-intr mrph (cmpr new-trgt) + dmns new new-im) + :strt :cmbn + :orgn `(mrph-disk-pasting ,mrph ,new-sorc ,new-trgt + ,dmns ,new ,new-im)))) (DEFUN HMEQ-DISK-PASTING (hmeq dmns new bndr &key new-lbcc) @@ -213,18 +215,18 @@ (type cmbn bndr) (type (or null chain-complex) new-lbcc)) (let* ((lg (lg hmeq)) - (rf (rf hmeq)) - (rh (rh hmeq)) - (t-bndr (cmbn-? lg bndr)) - (rb-bndr (cmbn-? rf t-bndr)) - (new-lbcc (or new-lbcc - (chcm-disk-pasting (lbcc hmeq) - dmns new bndr))) - (new-tcc (chcm-disk-pasting (tcc hmeq) - dmns new t-bndr)) - (new-rbcc (chcm-disk-pasting (rbcc hmeq) - dmns new rb-bndr)) - (1+dmns (1+ dmns))) + (rf (rf hmeq)) + (rh (rh hmeq)) + (t-bndr (cmbn-? lg bndr)) + (rb-bndr (cmbn-? rf t-bndr)) + (new-lbcc (or new-lbcc + (chcm-disk-pasting (lbcc hmeq) + dmns new bndr))) + (new-tcc (chcm-disk-pasting (tcc hmeq) + dmns new t-bndr)) + (new-rbcc (chcm-disk-pasting (rbcc hmeq) + dmns new rb-bndr)) + (1+dmns (1+ dmns))) (declare (type morphism lg rf rh) (type cmbn t-bndr rb-bndr) @@ -232,25 +234,25 @@ (fixnum 1+dmns)) (build-hmeq :lrdct (build-rdct - :f (mrph-disk-pasting (lf hmeq) new-tcc new-lbcc - dmns new (cmbn dmns 1 new)) - :g (mrph-disk-pasting lg new-lbcc new-tcc - dmns new (cmbn dmns 1 new)) - :h (mrph-disk-pasting (lh hmeq) new-tcc new-tcc - dmns new (zero-cmbn 1+dmns))) + :f (mrph-disk-pasting (lf hmeq) new-tcc new-lbcc + dmns new (cmbn dmns 1 new)) + :g (mrph-disk-pasting lg new-lbcc new-tcc + dmns new (cmbn dmns 1 new)) + :h (mrph-disk-pasting (lh hmeq) new-tcc new-tcc + dmns new (zero-cmbn 1+dmns))) :rrdct (build-rdct - :f (mrph-disk-pasting rf new-tcc new-rbcc - dmns new (cmbn dmns 1 new)) - :g (mrph-disk-pasting (rg hmeq) new-rbcc new-tcc - dmns new - (make-cmbn - :degr dmns - :list (cons (term 1 new) - (cmbn-list - (cmbn-opps - (cmbn-? rh t-bndr)))))) - :h (mrph-disk-pasting rh new-tcc new-tcc - dmns new (zero-cmbn 1+dmns))) + :f (mrph-disk-pasting rf new-tcc new-rbcc + dmns new (cmbn dmns 1 new)) + :g (mrph-disk-pasting (rg hmeq) new-rbcc new-tcc + dmns new + (make-cmbn + :degr dmns + :list (cons (term 1 new) + (cmbn-list + (cmbn-opps + (cmbn-? rh t-bndr)))))) + :h (mrph-disk-pasting rh new-tcc new-tcc + dmns new (zero-cmbn 1+dmns))) :orgn `(hmeq-disk-pasting ,hmeq ,dmns ,new ,bndr)))) @@ -258,11 +260,11 @@ (declare (type simplicial-set smst)) (the homotopy-equivalence (destructuring-bind (old-smst dmns new faces) (rest (orgn smst)) - (declare - (type simplicial-set old-smst) - (fixnum dmns) - (symbol new) - (ignore faces)) - (hmeq-disk-pasting (efhm old-smst) - dmns new (? smst dmns new) - :new-lbcc smst)))) + (declare + (type simplicial-set old-smst) + (fixnum dmns) + (symbol new) + (ignore faces)) + (hmeq-disk-pasting (efhm old-smst) + dmns new (? smst dmns new) + :new-lbcc smst)))) diff --git a/src/effective-homology.lisp b/src/effective-homology.lisp index d98f79b..65ce9ac 100644 --- a/src/effective-homology.lisp +++ b/src/effective-homology.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; EFFECTIVE-HOMOLOGY EFFECTIVE-HOMOLOGY EFFECTIVE-HOMOLOGY ;;; EFFECTIVE-HOMOLOGY EFFECTIVE-HOMOLOGY EFFECTIVE-HOMOLOGY ;;; EFFECTIVE-HOMOLOGY EFFECTIVE-HOMOLOGY EFFECTIVE-HOMOLOGY diff --git a/src/eilenberg-zilber.lisp b/src/eilenberg-zilber.lisp index ca8cb7a..fe8f0c3 100644 --- a/src/eilenberg-zilber.lisp +++ b/src/eilenberg-zilber.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; EILENBERG-ZILBER EILENBERG-ZILBER EILENBERG-ZILBER ;;; EILENBERG-ZILBER EILENBERG-ZILBER EILENBERG-ZILBER ;;; EILENBERG-ZILBER EILENBERG-ZILBER EILENBERG-ZILBER @@ -10,13 +12,13 @@ (declare (fixnum dgop)) (the fixnum (do ((rslt +1) - (bit-position (- (integer-length dgop) 2) (1- bit-position)) - (factor -1)) - ((minusp bit-position) rslt) + (bit-position (- (integer-length dgop) 2) (1- bit-position)) + (factor -1)) + ((minusp bit-position) rslt) (declare (fixnum rslt bit-position factor)) (if (logbitp bit-position dgop) - (setf factor (- factor)) - (setf rslt (* rslt factor)))))) + (setf factor (- factor)) + (setf rslt (* rslt factor)))))) (DEFUN INTR-EML (cmbn) @@ -25,48 +27,48 @@ (return-from intr-eml cmbn)) (the cmbn (with-cmbn - (degr list) cmbn - (let* ((limits (make-array (+ degr 2))) - (rslt (list nil)) - (rslt-mark rslt) - (mask (mask degr))) - (declare - (simple-vector limits) - (list rslt rslt-mark) - (fixnum mask)) - (do ((mark list (member i mark - :test #'< - :key #'(lambda (term) - (declare (type term term)) - (degr1 (gnrt term))))) - (i 0 (1+ i))) - ((> i degr) (setf (svref limits i) nil)) - (declare - (list mark) - (fixnum i)) - (setf (svref limits i) mark)) - (dotimes (dgop1 (1+ mask)) - (declare (fixnum dgop1)) - (let* ((i (- degr (logcount dgop1))) - (dgop2 (- mask dgop1)) - (sign (shuffle-sign dgop2))) - (declare (fixnum i dgop2 sign)) - (do ((mark (svref limits i) (cdr mark)) - (stop (svref limits (1+ i)))) - ((eq mark stop)) - (declare (list mark stop)) - (with--term - (cffc tnpr) mark - (setf rslt-mark - (setf (cdr rslt-mark) - (list (term - (* sign cffc) - (crpr - dgop1 (gnrt1 tnpr) - dgop2 (gnrt2 tnpr)))))))))) - (make-cmbn - :degr degr - :list (rest rslt)))))) + (degr list) cmbn + (let* ((limits (make-array (+ degr 2))) + (rslt (list nil)) + (rslt-mark rslt) + (mask (mask degr))) + (declare + (simple-vector limits) + (list rslt rslt-mark) + (fixnum mask)) + (do ((mark list (member i mark + :test #'< + :key #'(lambda (term) + (declare (type term term)) + (degr1 (gnrt term))))) + (i 0 (1+ i))) + ((> i degr) (setf (svref limits i) nil)) + (declare + (list mark) + (fixnum i)) + (setf (svref limits i) mark)) + (dotimes (dgop1 (1+ mask)) + (declare (fixnum dgop1)) + (let* ((i (- degr (logcount dgop1))) + (dgop2 (- mask dgop1)) + (sign (shuffle-sign dgop2))) + (declare (fixnum i dgop2 sign)) + (do ((mark (svref limits i) (cdr mark)) + (stop (svref limits (1+ i)))) + ((eq mark stop)) + (declare (list mark stop)) + (with--term + (cffc tnpr) mark + (setf rslt-mark + (setf (cdr rslt-mark) + (list (term + (* sign cffc) + (crpr + dgop1 (gnrt1 tnpr) + dgop2 (gnrt2 tnpr)))))))))) + (make-cmbn + :degr degr + :list (rest rslt)))))) (DEFUN EML (smst1 smst2) @@ -80,76 +82,76 @@ (DEFUN INTR-PHI (smst1 smst2 - &aux (crts-prdc (crts-prdc smst1 smst2)) - (cmpr (cmpr crts-prdc)) - (face1 (face smst1)) - (face2 (face smst2))) + &aux (crts-prdc (crts-prdc smst1 smst2)) + (cmpr (cmpr crts-prdc)) + (face1 (face smst1)) + (face2 (face smst2))) (declare (type simplicial-set smst1 smst2 crts-prdc) (type cmprf cmpr) (type face face1 face2)) (flet ((rslt (cmbn) - (declare (type cmbn cmbn)) - (when (cmbn-zero-p cmbn) - (return-from rslt (zero-cmbn (1+ (cmbn-degr cmbn))))) - (the cmbn + (declare (type cmbn cmbn)) + (when (cmbn-zero-p cmbn) + (return-from rslt (zero-cmbn (1+ (cmbn-degr cmbn))))) + (the cmbn (let* ((n (cmbn-degr cmbn)) (n+1 (1+ n)) (array-pq (make-array (list (1+ n+1) (1+ n+1))))) - (declare - (fixnum n n+1) - (simple-array array-pq)) - (do ((i 1 (1+ i))) - ((> i n+1)) - (declare (fixnum i)) - (do ((p i (1+ p)) - (q n+1 (1- q))) - ((> p n+1)) - (declare (fixnum p q)) - (setf (aref array-pq p q) (zero-cmbn i)))) - (dolist (term (cmbn-list cmbn)) - (declare (type term term)) - (with-term - (cffc crpr) term - (let ((absm1 (absm1 crpr)) - (absm2 (absm2 crpr))) - (declare (type absm absm1 absm2)) - (do ((n-alpha n (1- n-alpha)) - (left-d absm1 (a-face4 face1 n-alpha n-alpha - left-d))) - ((zerop n-alpha)) - (declare - (fixnum n-alpha) - (type absm left-d)) - (do ((beta 0 (1+ beta)) - (i n-alpha (1- i)) ;; pseudo-degree - (sign (-1-expt-n n-alpha) (- sign)) - (right-d absm2 - (a-face4 face2 (1- i) dim-right-d - right-d)) - (dim-right-d n (1- dim-right-d))) - ((= beta n-alpha)) - (declare - (fixnum beta i sign dim-right-d) - (type absm right-d)) - (let ((absm1 (1dgnr (1- i) left-d))) - (declare (type absm absm1)) - (with-absm - (dgop1 gmsm1) absm1 - (with-absm - (dgop2 gmsm2) right-d - (or (> (integer-length dgop1) i) - (> (integer-length dgop2) i) - (plusp (logand dgop1 dgop2)) - (dstr-add-term-to-cmbn - cmpr - (* sign cffc) - (crpr dgop1 gmsm1 dgop2 gmsm2) - (aref array-pq (1+ n-alpha) - (- n beta)))))))))))) + (declare + (fixnum n n+1) + (simple-array array-pq)) + (do ((i 1 (1+ i))) + ((> i n+1)) + (declare (fixnum i)) + (do ((p i (1+ p)) + (q n+1 (1- q))) + ((> p n+1)) + (declare (fixnum p q)) + (setf (aref array-pq p q) (zero-cmbn i)))) + (dolist (term (cmbn-list cmbn)) + (declare (type term term)) + (with-term + (cffc crpr) term + (let ((absm1 (absm1 crpr)) + (absm2 (absm2 crpr))) + (declare (type absm absm1 absm2)) + (do ((n-alpha n (1- n-alpha)) + (left-d absm1 (a-face4 face1 n-alpha n-alpha + left-d))) + ((zerop n-alpha)) + (declare + (fixnum n-alpha) + (type absm left-d)) + (do ((beta 0 (1+ beta)) + (i n-alpha (1- i)) ;; pseudo-degree + (sign (-1-expt-n n-alpha) (- sign)) + (right-d absm2 + (a-face4 face2 (1- i) dim-right-d + right-d)) + (dim-right-d n (1- dim-right-d))) + ((= beta n-alpha)) + (declare + (fixnum beta i sign dim-right-d) + (type absm right-d)) + (let ((absm1 (1dgnr (1- i) left-d))) + (declare (type absm absm1)) + (with-absm + (dgop1 gmsm1) absm1 + (with-absm + (dgop2 gmsm2) right-d + (or (> (integer-length dgop1) i) + (> (integer-length dgop2) i) + (plusp (logand dgop1 dgop2)) + (dstr-add-term-to-cmbn + cmpr + (* sign cffc) + (crpr dgop1 gmsm1 dgop2 gmsm2) + (aref array-pq (1+ n-alpha) + (- n beta)))))))))))) ;; array-pq))) ;; in case of debugging (intr-phi-2 array-pq cmpr) - )))) + )))) (the intr-mrph #'rslt))) #| @@ -158,210 +160,210 @@ (declare (type (simple-array cmbn (* *)) array-pq) (type cmprf cmpr)) -; (format t " -22- ") ; +; (format t " -22- ") ; ; (the cmbn (let* ((n+1 (1- (array-dimension array-pq 0))) - (n (1- n+1))) + (n (1- n+1))) (declare (fixnum n n+1)) (flet ((step-i (i) - (declare (fixnum i)) - (do ((p (1+ i) (1+ p)) - (p-1 i p) - (q n+1 q-1) - (q-1 n (1- q-1)) - (sign t (not sign)) - (ibit (2-exp i))) - ((> p n+1)) + (declare (fixnum i)) + (do ((p (1+ i) (1+ p)) + (p-1 i p) + (q n+1 q-1) + (q-1 n (1- q-1)) + (sign t (not sign)) + (ibit (2-exp i))) + ((> p n+1)) (declare - (fixnum p p-1 q q-1 ibit) - (type boolean sign)) + (fixnum p p-1 q q-1 ibit) + (type boolean sign)) (setf (aref array-pq p q) (2cmbn-add cmpr - (aref array-pq p q) - (make-cmbn - :degr (1+ i) - :list (nconc - (mapcar - #'(lambda (term) - (declare (type term term)) - (with-term (cffc crpr) term - (with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr - (term cffc (crpr - dgop1 gmsm1 - (+ ibit dgop2) gmsm2))))) - (cmbn-list (aref array-pq p q-1))) - (let ((list (cmbn-list (aref array-pq p-1 q)))) - (declare (list lst)) - (unless sign - (dolist (term list) - (declare (type term term)) - (setf (cffc term) (- (cffc term))))) - (dolist (term list) - (declare (type term term)) - (incf (dgop1 (gnrt term)) ibit)) - list)))))))) - (do ((i 1 (1+ i))) - ((= i n+1)) - (declare (type fixnum i)) - (step-i i)) - (aref array-pq n+1 n+1))))) + (aref array-pq p q) + (make-cmbn + :degr (1+ i) + :list (nconc + (mapcar + #'(lambda (term) + (declare (type term term)) + (with-term (cffc crpr) term + (with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr + (term cffc (crpr + dgop1 gmsm1 + (+ ibit dgop2) gmsm2))))) + (cmbn-list (aref array-pq p q-1))) + (let ((list (cmbn-list (aref array-pq p-1 q)))) + (declare (list lst)) + (unless sign + (dolist (term list) + (declare (type term term)) + (setf (cffc term) (- (cffc term))))) + (dolist (term list) + (declare (type term term)) + (incf (dgop1 (gnrt term)) ibit)) + list)))))))) + (do ((i 1 (1+ i))) + ((= i n+1)) + (declare (type fixnum i)) + (step-i i)) + (aref array-pq n+1 n+1))))) |# (DEFUN INTR-PHI-2 (array-pq cmpr) (declare (type (simple-array cmbn (* *)) array-pq) (type cmprf cmpr)) - ; (format t " -2- ") + ; (format t " -2- ") (the cmbn (let* ((n+1 (1- (array-dimension array-pq 0))) - (n (1- n+1)) - (cmbn-list +empty-list+)) + (n (1- n+1)) + (cmbn-list +empty-list+)) (declare - (fixnum n n+1) - (list cmbn-list)) + (fixnum n n+1) + (list cmbn-list)) (do ((i 1 (1+ i)) (cmbn-i (list nil) (list nil)) (mask (mask n) (ash mask -1))) ((= i n+1)) - (declare - (fixnum i mask) - (list cmbn-i)) - (let ((cmbn-i-tail cmbn-i)) - (declare (list cmbn-i-tail)) - (do ((dgop1 0 (1+ dgop1))) - ((> dgop1 mask) - (push (make-cmbn - :degr n+1 - :list (rest cmbn-i)) - cmbn-list)) - (declare (fixnum dgop1)) - (let ((p (- n+1 (logcount dgop1))) - (dgop2 (- mask dgop1))) - (declare (fixnum p dgop2)) - (unless (= p i) - (let ((q (- (+ n+1 i) p)) - (sign (shuffle-sign dgop2)) - (dgop1-ashed (ash dgop1 i)) - (dgop2-ashed (ash dgop2 i))) - (declare (fixnum q sign dgop1-ashed dgop2-ashed)) - (dolist (term (cmbn-list (aref array-pq p q))) - (declare (type term term)) - (with-term - (cffc crpr) term - (with-crpr - (dgop1 gmsm1 dgop2 gmsm2) crpr - (setf cmbn-i-tail - (setf (cdr cmbn-i-tail) - (list (term (* sign cffc) - (crpr - (+ dgop1 dgop1-ashed) - gmsm1 - (+ dgop2 dgop2-ashed) - gmsm2)))))))))))))) + (declare + (fixnum i mask) + (list cmbn-i)) + (let ((cmbn-i-tail cmbn-i)) + (declare (list cmbn-i-tail)) + (do ((dgop1 0 (1+ dgop1))) + ((> dgop1 mask) + (push (make-cmbn + :degr n+1 + :list (rest cmbn-i)) + cmbn-list)) + (declare (fixnum dgop1)) + (let ((p (- n+1 (logcount dgop1))) + (dgop2 (- mask dgop1))) + (declare (fixnum p dgop2)) + (unless (= p i) + (let ((q (- (+ n+1 i) p)) + (sign (shuffle-sign dgop2)) + (dgop1-ashed (ash dgop1 i)) + (dgop2-ashed (ash dgop2 i))) + (declare (fixnum q sign dgop1-ashed dgop2-ashed)) + (dolist (term (cmbn-list (aref array-pq p q))) + (declare (type term term)) + (with-term + (cffc crpr) term + (with-crpr + (dgop1 gmsm1 dgop2 gmsm2) crpr + (setf cmbn-i-tail + (setf (cdr cmbn-i-tail) + (list (term (* sign cffc) + (crpr + (+ dgop1 dgop1-ashed) + gmsm1 + (+ dgop2 dgop2-ashed) + gmsm2)))))))))))))) (if cmbn-list - (apply #'ncmbn-add cmpr cmbn-list) - (zero-cmbn n+1))))) + (apply #'ncmbn-add cmpr cmbn-list) + (zero-cmbn n+1))))) (DEFUN PHI (smst1 smst2) (declare (type simplicial-set smst1 smst2)) (the morphism (build-mrph - :sorc (crts-prdc smst1 smst2) - :trgt (crts-prdc smst1 smst2) - :degr +1 - :intr (intr-phi smst1 smst2) - :strt :cmbn - :orgn `(phi ,smst1 ,smst2)))) + :sorc (crts-prdc smst1 smst2) + :trgt (crts-prdc smst1 smst2) + :degr +1 + :intr (intr-phi smst1 smst2) + :strt :cmbn + :orgn `(phi ,smst1 ,smst2)))) (DEFUN INTR-AW (face1 face2) (declare (type face face1 face2)) (flet ((rslt (dmns crpr) (declare - (fixnum dmns) - (type crpr crpr)) + (fixnum dmns) + (type crpr crpr)) (the cmbn - (let ((absm1 (absm1 crpr)) - (absm2 (absm2 crpr)) - (rslt +empty-list+) - (del-0-s +empty-list+)) - (declare - (type absm absm1 absm2) - (list rslt del-0-s)) - (do ((face absm2 (a-face4 face2 0 dmns2 face)) - (dmns2 dmns (1- dmns2))) - ((zerop dmns2) (push face del-0-s)) + (let ((absm1 (absm1 crpr)) + (absm2 (absm2 crpr)) + (rslt +empty-list+) + (del-0-s +empty-list+)) + (declare + (type absm absm1 absm2) + (list rslt del-0-s)) + (do ((face absm2 (a-face4 face2 0 dmns2 face)) + (dmns2 dmns (1- dmns2))) + ((zerop dmns2) (push face del-0-s)) (declare - (type absm face) - (fixnum dmns)) + (type absm face) + (fixnum dmns)) (push face del-0-s)) - (do ((face absm1 (a-face4 face1 dmns1 dmns1 face)) - (dmns1 dmns (1- dmns1)) - (dmns2 0 (1+ dmns2)) - (mark del-0-s (cdr mark))) - ((zerop dmns1) - (unless (degenerate-p absm2) + (do ((face absm1 (a-face4 face1 dmns1 dmns1 face)) + (dmns1 dmns (1- dmns1)) + (dmns2 0 (1+ dmns2)) + (mark del-0-s (cdr mark))) + ((zerop dmns1) + (unless (degenerate-p absm2) (push - (term 1 - (tnpr 0 (gmsm face) dmns (gmsm absm2))) - rslt))) + (term 1 + (tnpr 0 (gmsm face) dmns (gmsm absm2))) + rslt))) (declare - (type absm face) - (fixnum dmns1 dmns2) - (list mark)) + (type absm face) + (fixnum dmns1 dmns2) + (list mark)) (unless (or (degenerate-p face) (degenerate-p (car mark))) - (push - (term 1 + (push + (term 1 (tnpr dmns1 (gmsm face) dmns2 (gmsm (car mark)))) - rslt))) - (make-cmbn - :degr dmns - :list rslt))))) + rslt))) + (make-cmbn + :degr dmns + :list rslt))))) (the intr-mrph #'rslt))) (DEFUN AW (smst1 smst2 - &aux (crts-prdc (crts-prdc smst1 smst2)) - (tnsr-prdc (tnsr-prdc smst1 smst2)) - (face1 (face smst1)) - (face2 (face smst2))) + &aux (crts-prdc (crts-prdc smst1 smst2)) + (tnsr-prdc (tnsr-prdc smst1 smst2)) + (face1 (face smst1)) + (face2 (face smst2))) (declare (type simplicial-set smst1 smst2) (type face face1 face2)) (the morphism (build-mrph - :sorc crts-prdc - :trgt tnsr-prdc - :degr 0 - :intr (intr-aw face1 face2) - :strt :gnrt - :orgn `(aw ,smst1 ,smst2)))) + :sorc crts-prdc + :trgt tnsr-prdc + :degr 0 + :intr (intr-aw face1 face2) + :strt :gnrt + :orgn `(aw ,smst1 ,smst2)))) (DEFUN EZ (smst1 smst2) (declare (type simplicial-set smst1 smst2)) (the reduction (build-rdct - :f (aw smst1 smst2) - :g (eml smst1 smst2) - :h (phi smst1 smst2) - :orgn `(eilenberg-zilber ,smst1 ,smst2)))) + :f (aw smst1 smst2) + :g (eml smst1 smst2) + :h (phi smst1 smst2) + :orgn `(eilenberg-zilber ,smst1 ,smst2)))) (DEFUN LEFT-CRTS-PRDC-EFHM (smst1 smst2) (declare (type simplicial-set smst1 smst2)) (the homotopy-equivalence (build-hmeq - :lrdct (trivial-rdct (crts-prdc smst1 smst2)) - :rrdct (ez smst1 smst2)))) + :lrdct (trivial-rdct (crts-prdc smst1 smst2)) + :rrdct (ez smst1 smst2)))) (DEFMETHOD SEARCH-EFHM (smst (orgn (eql 'crts-prdc))) (declare (type simplicial-set smst)) (the homotopy-equivalence (cmps - (left-crts-prdc-efhm (second (orgn smst)) (third (orgn smst))) - (tnsr-prdc (efhm (second (orgn smst))) - (efhm (third (orgn smst))))))) + (left-crts-prdc-efhm (second (orgn smst)) (third (orgn smst))) + (tnsr-prdc (efhm (second (orgn smst))) + (efhm (third (orgn smst))))))) diff --git a/src/fibrations.lisp b/src/fibrations.lisp index e4303bd..9f86ee5 100644 --- a/src/fibrations.lisp +++ b/src/fibrations.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; FIBRATIONS FIBRATIONS FIBRATIONS FIBRATIONS FIBRATIONS ;;; FIBRATIONS FIBRATIONS FIBRATIONS FIBRATIONS FIBRATIONS ;;; FIBRATIONS FIBRATIONS FIBRATIONS FIBRATIONS FIBRATIONS @@ -7,16 +9,16 @@ (PROVIDE "fibrations") (DEFUN FIBRATION-TOTAL-FACE (fibration - &aux (base (sorc fibration)) - (bface (face base)) - (fibr (trgt fibration)) - (fbspn (bspn fibr)) - (fface (face fibr)) - (grml (grml fibr)) - (sintr-grml (sintr grml)) - (totl (crts-prdc base fibr)) - (uface (face totl)) - (sintr-twist (sintr fibration))) + &aux (base (sorc fibration)) + (bface (face base)) + (fibr (trgt fibration)) + (fbspn (bspn fibr)) + (fface (face fibr)) + (grml (grml fibr)) + (sintr-grml (sintr grml)) + (totl (crts-prdc base fibr)) + (uface (face totl)) + (sintr-twist (sintr fibration))) (declare (type fibration fibration) (type simplicial-mrph grml) @@ -26,65 +28,65 @@ (type face bface fface uface) (type sintr sintr-grml sintr-twist)) (flet ((rslt (indx dmns crpr) - (declare - (fixnum indx dmns) - (type crpr crpr)) - (the absm - (progn - (when (< indx dmns) - (return-from rslt - (funcall uface indx dmns crpr))) - (with-crpr (b-absm f-absm) crpr - (let ((deln-b - (a-face4 bface dmns dmns - b-absm)) - (deln-f - (a-face4 fface dmns dmns - f-absm)) - (tau-b - (tw-a-sintr3 sintr-twist dmns - b-absm fbspn))) - (declare - ( type absm deln-b deln-f tau-b)) - (2absm-acrpr - deln-b - (a-grml4 sintr-grml (1- dmns) - tau-b deln-f)))))))) + (declare + (fixnum indx dmns) + (type crpr crpr)) + (the absm + (progn + (when (< indx dmns) + (return-from rslt + (funcall uface indx dmns crpr))) + (with-crpr (b-absm f-absm) crpr + (let ((deln-b + (a-face4 bface dmns dmns + b-absm)) + (deln-f + (a-face4 fface dmns dmns + f-absm)) + (tau-b + (tw-a-sintr3 sintr-twist dmns + b-absm fbspn))) + (declare + ( type absm deln-b deln-f tau-b)) + (2absm-acrpr + deln-b + (a-grml4 sintr-grml (1- dmns) + tau-b deln-f)))))))) (the face #'rslt))) (DEFUN FIBRATION-TOTAL (fibration - &aux (base (sorc fibration)) - (fibre (trgt fibration)) - (untwisted-prdc - (crts-prdc base fibre))) + &aux (base (sorc fibration)) + (fibre (trgt fibration)) + (untwisted-prdc + (crts-prdc base fibre))) (declare (type fibration fibration)) (the simplicial-set (let ((rslt (build-smst :cmpr (cmpr untwisted-prdc) - :basis (basis untwisted-prdc) - :bspn (bspn untwisted-prdc) - :face (fibration-total-face fibration) - :orgn `(fibration-total ,fibration)))) - (declare (type simplicial-set rslt)) - (setf (slot-value rslt 'grmd) untwisted-prdc) - (when (and (typep base 'kan) - (typep fibre 'kan)) - (change-class rslt 'kan) - (setf (slot-value rslt 'kfll) - (fibration-kfll fibration))) - rslt))) + :basis (basis untwisted-prdc) + :bspn (bspn untwisted-prdc) + :face (fibration-total-face fibration) + :orgn `(fibration-total ,fibration)))) + (declare (type simplicial-set rslt)) + (setf (slot-value rslt 'grmd) untwisted-prdc) + (when (and (typep base 'kan) + (typep fibre 'kan)) + (change-class rslt 'kan) + (setf (slot-value rslt 'kfll) + (fibration-kfll fibration))) + rslt))) (DEFUN FIBRATION-KFLL (twist - &aux (sintr-twist (sintr twist)) - (base (sorc twist)) - (fibre (trgt twist)) - (fbspn (bspn fibre)) - (bkfll (kfll base)) - (fkfll (kfll fibre)) - (sintr-grml (sintr (grml fibre))) - (sintr-grin (sintr (grin fibre)))) + &aux (sintr-twist (sintr twist)) + (base (sorc twist)) + (fibre (trgt twist)) + (fbspn (bspn fibre)) + (bkfll (kfll base)) + (fkfll (kfll fibre)) + (sintr-grml (sintr (grml fibre))) + (sintr-grin (sintr (grin fibre)))) (declare (type fibration twist) (type kan base fibre) @@ -92,34 +94,34 @@ (type kfll bkfll fkfll) (type sintr sintr-grml sintr-grin)) (flet ((rslt (indx dmns hat) - (declare - (fixnum indx dmns) - (list hat)) - (let (bhat fhat) - (declare (type list bhat fhat)) - (do ((mark hat (cdr mark))) - ((endp mark)) - (declare (list mark)) - (let ((absm (car mark))) - (declare (type absm absm)) - (with-absm - (dgop crpr) absm - (with-crpr - (dgop1 gmsm1 dgop2 gmsm2) crpr - (push (absm (dgop*dgop dgop dgop1) gmsm1) bhat) - (push (absm (dgop*dgop dgop dgop2) gmsm2) fhat))))) - (setf bhat (nreverse bhat)) - (let ((bkfll (funcall bkfll indx dmns bhat))) - (declare (type absm bkfll)) - (when (< indx dmns) - (setf (first fhat) - (a-grml4 sintr-grml (1- dmns) - (a-grin4 sintr-grin (1- dmns) - (tw-a-sintr3 sintr-twist dmns bkfll - fbspn)) - (first fhat)))) - (setf fhat (nreverse fhat)) - (let ((fkfll (funcall fkfll indx dmns fhat))) - (declare (type absm fkfll)) - (2absm-acrpr bkfll fkfll)))))) + (declare + (fixnum indx dmns) + (list hat)) + (let (bhat fhat) + (declare (type list bhat fhat)) + (do ((mark hat (cdr mark))) + ((endp mark)) + (declare (list mark)) + (let ((absm (car mark))) + (declare (type absm absm)) + (with-absm + (dgop crpr) absm + (with-crpr + (dgop1 gmsm1 dgop2 gmsm2) crpr + (push (absm (dgop*dgop dgop dgop1) gmsm1) bhat) + (push (absm (dgop*dgop dgop dgop2) gmsm2) fhat))))) + (setf bhat (nreverse bhat)) + (let ((bkfll (funcall bkfll indx dmns bhat))) + (declare (type absm bkfll)) + (when (< indx dmns) + (setf (first fhat) + (a-grml4 sintr-grml (1- dmns) + (a-grin4 sintr-grin (1- dmns) + (tw-a-sintr3 sintr-twist dmns bkfll + fbspn)) + (first fhat)))) + (setf fhat (nreverse fhat)) + (let ((fkfll (funcall fkfll indx dmns fhat))) + (declare (type absm fkfll)) + (2absm-acrpr bkfll fkfll)))))) (the kfll #'rslt))) diff --git a/src/homology-groups.lisp b/src/homology-groups.lisp index e286ec9..efc1e4b 100644 --- a/src/homology-groups.lisp +++ b/src/homology-groups.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;; HOMOLOGY-GROUPS HOMOLOGY-GROUPS HOMOLOGY-GROUPS HOMOLOGY-GROUPS ;; HOMOLOGY-GROUPS HOMOLOGY-GROUPS HOMOLOGY-GROUPS HOMOLOGY-GROUPS ;; HOMOLOGY-GROUPS HOMOLOGY-GROUPS HOMOLOGY-GROUPS HOMOLOGY-GROUPS @@ -15,17 +17,17 @@ (defun creer-matrice (n1 n2) (let ((mat (make-matrice - :leftcol (make-array (1+ n1)) - :uplig (make-array (1+ n2))))) + :leftcol (make-array (1+ n1)) + :uplig (make-array (1+ n2))))) (setf (baselig mat 0) (make-t-mat :ilig 0 :icol 0)) (setf (basecol mat 0) (baselig mat 0)) (do ((i 1 (1+ i))) - ((> i n1)) + ((> i n1)) (setf (baselig mat i) (make-t-mat :ilig i :icol 0 :up (baselig mat (1- i)))) (setf (left (baselig mat i)) (baselig mat i))) (do ((j 1 (1+ j))) - ((> j n2)) + ((> j n2)) (setf (basecol mat j) (make-t-mat :ilig 0 :icol j :left (basecol mat (1- j)))) (setf (up (basecol mat j)) (basecol mat j))) @@ -45,15 +47,15 @@ (defun inserer-terme (pl pc val) (setf (left pl) (make-t-mat :val val - :ilig (ilig pl) - :icol (icol pc) - :left (left pl) - :up (up pc)) - (up pc) (left pl))) + :ilig (ilig pl) + :icol (icol pc) + :left (left pl) + :up (up pc)) + (up pc) (left pl))) (defun supprimer-terme (pl pc) (setf (left pl) (left (left pl)) - (up pc) (up (up pc)))) + (up pc) (up (up pc)))) (defun maj-terme (pl pc val) (if (= val 0) @@ -66,9 +68,9 @@ (let ((ptl (baselig mat il))) (mapcar #'(lambda (elem) - (maj-terme (chercher-hor ptl (first elem)) - (chercher-ver (basecol mat (first elem)) il) - (second elem))) + (maj-terme (chercher-hor ptl (first elem)) + (chercher-ver (basecol mat (first elem)) il) + (second elem))) liste) ptl)) @@ -76,9 +78,9 @@ (let ((ptc (basecol mat ic))) (mapcar #'(lambda (elem) - (maj-terme (chercher-hor (baselig mat (first elem)) ic) - (chercher-ver ptc (first elem)) - (second elem))) + (maj-terme (chercher-hor (baselig mat (first elem)) ic) + (chercher-ver ptc (first elem)) + (second elem))) liste) ptc)) @@ -106,9 +108,9 @@ (princ (second elem)) (princ ")")) (let ((ptl (baselig mat il)) - (res '())) + (res '())) (do ((pl (left ptl) (left pl))) - ((eq pl ptl)) + ((eq pl ptl)) (push (list (icol pl) (val pl)) res)) res)) (values )) @@ -126,9 +128,9 @@ (princ (second elem)) (princ ")")) (let ((ptc (basecol mat ic)) - (res '())) + (res '())) (do ((pc (up ptc) (up pc))) - ((eq pc ptc)) + ((eq pc ptc)) (push (list (ilig pc) (val pc)) res)) res)) (values )) @@ -139,7 +141,7 @@ (defun disp-matrice (mat) (let ((nlig (nlig mat))) (do ((i 1 (1+ i))) - ((> i nlig)) + ((> i nlig)) (disp-ligne mat i))) (done)) @@ -148,26 +150,26 @@ (DEFMETHOD PRINT-OBJECT ((mtrx matrice) stream) (declare (stream stream)) (the matrice (progn - (let ((nlig (nlig mtrx)) - (ncol (ncol mtrx))) - (declare (fixnum nlig ncol)) - (format stream "~%========== MATRIX ~D lines + ~D columns =====" - nlig ncol) - (do ((ilig 1 (1+ ilig))) - ((> ilig nlig)) - (declare (fixnum ilig)) - (format stream "~%L~D=" ilig) - (dolist (item (let ((baselig (baselig mtrx ilig))) - (declare (type t-mat baselig)) - (do ((rslt +empty-list+ (cons t-mat rslt)) - (t-mat (left baselig) (left t-mat))) - ((eq t-mat baselig) rslt) - (declare - (list rslt) - (type t-mat t-mat))))) - (declare (type t-mat item)) - (format stream "[C~D=~D]" (icol item) (val item)))) - (format stream "~%========== END-MATRIX")) + (let ((nlig (nlig mtrx)) + (ncol (ncol mtrx))) + (declare (fixnum nlig ncol)) + (format stream "~%========== MATRIX ~D lines + ~D columns =====" + nlig ncol) + (do ((ilig 1 (1+ ilig))) + ((> ilig nlig)) + (declare (fixnum ilig)) + (format stream "~%L~D=" ilig) + (dolist (item (let ((baselig (baselig mtrx ilig))) + (declare (type t-mat baselig)) + (do ((rslt +empty-list+ (cons t-mat rslt)) + (t-mat (left baselig) (left t-mat))) + ((eq t-mat baselig) rslt) + (declare + (list rslt) + (type t-mat t-mat))))) + (declare (type t-mat item)) + (format stream "[C~D=~D]" (icol item) (val item)))) + (format stream "~%========== END-MATRIX")) mtrx))) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute) (setf (ext:package-lock :clos) t)) @@ -176,63 +178,63 @@ (defun disp-matrice-colonnes (mat) (let ((ncol (ncol mat))) (do ((i 1 (1+ i))) - ((> i ncol)) + ((> i ncol)) (disp-colonne mat i))) (done)) (defun terme (mat i j) (let ((p (left (chercher-hor (baselig mat i) j)))) (if (= j (icol p)) - (val (left p)) - nil))) + (val (left p)) + nil))) (defun mat-aleat (n1 n2 dens x) (let ((mat (creer-matrice n1 n2)) - (n (truncate (* dens n1 n2))) - (2x (* 2 x)) - (res nil)) + (n (truncate (* dens n1 n2))) + (2x (* 2 x)) + (res nil)) (dotimes (i n) (let* ((il (1+ (random n1))) - (ic (1+ (random n2))) - (val (let ((pval (- (random 2x) x))) - (if (minusp pval) - pval - (1+ pval)))) - (elem (member il res - :test #'(lambda (x y) (eql x (first y)))))) - (if elem - (push (list ic val) (cadar elem)) - (push (list il (list (list ic val))) res)))) + (ic (1+ (random n2))) + (val (let ((pval (- (random 2x) x))) + (if (minusp pval) + pval + (1+ pval)))) + (elem (member il res + :test #'(lambda (x y) (eql x (first y)))))) + (if elem + (push (list ic val) (cadar elem)) + (push (list il (list (list ic val))) res)))) (maj-matrice mat res))) (defun op-elem (pl pc alpha) (if (eq (left pl) (up pc)) (if (= alpha (val (left pl))) - (supprimer-terme pl pc) - (decf (val (left pl)) alpha)) + (supprimer-terme pl pc) + (decf (val (left pl)) alpha)) (inserer-terme pl pc (- alpha)))) (defun peigne-ver (mat ptl il) (if (< il (ilig ptl)) (do ((res nil (cons (chercher-ver pl il) - res)) - (pl (left ptl) (left pl))) - ((eq pl ptl) (nreverse res))) + res)) + (pl (left ptl) (left pl))) + ((eq pl ptl) (nreverse res))) (do ((res nil (cons (chercher-ver (basecol mat (icol pl)) il) - res)) - (pl (left ptl) (left pl))) - ((eq pl ptl) (nreverse res))))) + res)) + (pl (left ptl) (left pl))) + ((eq pl ptl) (nreverse res))))) (defun peigne-hor (mat ptc ic) (if (< ic (icol ptc)) (do ((res nil (cons (chercher-hor pc ic) - res)) - (pc (up ptc) (up pc))) - ((eq pc ptc) (nreverse res))) + res)) + (pc (up ptc) (up pc))) + ((eq pc ptc) (nreverse res))) (do ((res nil (cons (chercher-hor (baselig mat (ilig pc)) ic) - res)) - (pc (up ptc) (up pc))) - ((eq pc ptc) (nreverse res))))) + res)) + (pc (up ptc) (up pc))) + ((eq pc ptc) (nreverse res))))) (defun op-lig (ptl1 ptl2 peigne lambda) (do ((pl1 (left ptl1) (left pl1)) @@ -477,14 +479,14 @@ (if (null p1) (go depart2) (if (= 1 (abs (val p1))) - (go pivot1) - (progn (setf p2 (reste-minimal-colonne M p1)) - (if (null p2) - (progn (setf p2 (reste-minimal-ligne M p1)) - (if (null p2) - (go pivot1) - (go op-col1))) - (go op-lig1))))) + (go pivot1) + (progn (setf p2 (reste-minimal-colonne M p1)) + (if (null p2) + (progn (setf p2 (reste-minimal-ligne M p1)) + (if (null p2) + (go pivot1) + (go op-col1))) + (go op-lig1))))) op-lig1 (op-lig-n M (ilig p1) (ilig p2) (diviseur (val p2) (val p1))) (setf p1 p2) @@ -508,14 +510,14 @@ (if (null p1) (go depart3) (if (= 1 (abs (val p1))) - (go pivot2) - (progn (setf p2 (reste-minimal-ligne N p1)) - (if (null p2) - (progn (setf p2 (reste-minimal-colonne N p1)) - (if (null p2) - (go pivot2-torsion) - (go op-lig2))) - (go op-col2))))) + (go pivot2) + (progn (setf p2 (reste-minimal-ligne N p1)) + (if (null p2) + (progn (setf p2 (reste-minimal-colonne N p1)) + (if (null p2) + (go pivot2-torsion) + (go op-lig2))) + (go op-col2))))) op-lig2 (setf div (diviseur (val p2) (val p1))) (op-col-n B (ilig p2) (ilig p1) (- div)) @@ -551,7 +553,7 @@ (type cmprf cmpr)) (format t "~%Computing boundary-matrix in dimension ~D. Rank of the source-module : ~D.~2%" - n (length sorc)) + n (length sorc)) (let ((sorcl (length sorc)) (mat (creer-matrice (length trgt) (length sorc))) (test #'(lambda (gnrt1 gnrt2) @@ -569,15 +571,15 @@ Rank of the source-module : ~D.~2%" (when *homology-verbose* (clock) (format t "Computing the boundary of the generator ~D/~D (dimension ~D) :" - i sorcl n) + i sorcl n) (print (car mark))) - (maj-colonne mat i - (mapcar #'(lambda (term) - (declare (type term term)) - (list - (1+ (position (gnrt term) trgt :test test)) - (cffc term))) - (cmbn-list (? chcm n (car mark))))) + (maj-colonne mat i + (mapcar #'(lambda (term) + (declare (type term term)) + (list + (1+ (position (gnrt term) trgt :test test)) + (cffc term))) + (cmbn-list (? chcm n (car mark))))) (when *homology-verbose* (format t "~%End of computing.~2%"))) mat))) @@ -592,7 +594,7 @@ Rank of the source-module : ~D.~2%" (declare (type list item)) (format t "~2%Component Z") (unless (zerop (first item)) - (format t "/~DZ" (first item))))) + (format t "/~DZ" (first item))))) (terpri) (terpri) (done)) @@ -615,12 +617,12 @@ Rank of the source-module : ~D.~2%" (mapcar #'(lambda (term) (declare (type term term)) (term (car term) (nth (cdr term) src))) - item)) - rsl)) + item)) + rsl)) (setf rsl (mapcar #'(lambda (item) (declare (type list item)) (make-cmbn :degr n :list item)) - rsl)) + rsl)) rsl)) @@ -634,9 +636,9 @@ Rank of the source-module : ~D.~2%" (declare (type list item)) (format t "~2%Component Z") (unless (zerop (first item)) - (format t "/~DZ" (first item))) + (format t "/~DZ" (first item))) (format t "~2%Generator :") (dolist (item2 (rest item)) - (declare (type cons item2)) - (format t "~%~D~6T* ~S" (car item2) (nth (cdr item2) src))))) + (declare (type cons item2)) + (format t "~%~D~6T* ~S" (car item2) (nth (cdr item2) src))))) (done)) diff --git a/src/k-pi-n.lisp b/src/k-pi-n.lisp index 945f1a4..df8db31 100644 --- a/src/k-pi-n.lisp +++ b/src/k-pi-n.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; K-PI-1 K-PI-1 K-PI-1 K-PI-1 K-PI-1 K-PI-1 K-PI-1 ;;; K-PI-1 K-PI-1 K-PI-1 K-PI-1 K-PI-1 K-PI-1 K-PI-1 ;;; K-PI-1 K-PI-1 K-PI-1 K-PI-1 K-PI-1 K-PI-1 K-PI-1 @@ -10,12 +12,12 @@ (declare (list gnrt1 gnrt2)) (the cmpr (do ((mark1 gnrt1 (cdr mark1)) - (mark2 gnrt2 (cdr mark2))) - ((endp mark1) :equal) - (case (f-cmpr (car mark1) (car mark2)) - (:equal) - (:less (return-from k-z-1-cmpr :less)) - (:greater (return-from k-z-1-cmpr :greater)))))) + (mark2 gnrt2 (cdr mark2))) + ((endp mark1) :equal) + (case (f-cmpr (car mark1) (car mark2)) + (:equal) + (:less (return-from k-z-1-cmpr :less)) + (:greater (return-from k-z-1-cmpr :greater)))))) (DEFUN K-Z-1-FACE (indx dmns gmsm) @@ -24,57 +26,57 @@ (list gmsm)) (the absm (cond ((zerop indx) (absm 0 (rest gmsm))) - ((= indx dmns) (absm 0 (butlast gmsm))) - (t - (do ((rslt +empty-list+ (cons (car mark) rslt)) - (mark gmsm (cdr mark)) - (i 1 (1+ i))) - ((= i indx) (let ((new-k (+ (car mark) (cadr mark)))) - (declare (fixnum new-k)) - (if (zerop new-k) - (absm (2-exp (1- indx)) - (nreconc rslt (cddr mark))) - (absm 0 - (nreconc rslt - (cons new-k - (cddr mark))))))) - (declare - (list rslt mark) - (fixnum i))))))) + ((= indx dmns) (absm 0 (butlast gmsm))) + (t + (do ((rslt +empty-list+ (cons (car mark) rslt)) + (mark gmsm (cdr mark)) + (i 1 (1+ i))) + ((= i indx) (let ((new-k (+ (car mark) (cadr mark)))) + (declare (fixnum new-k)) + (if (zerop new-k) + (absm (2-exp (1- indx)) + (nreconc rslt (cddr mark))) + (absm 0 + (nreconc rslt + (cons new-k + (cddr mark))))))) + (declare + (list rslt mark) + (fixnum i))))))) (DEFUN Z-ABSM-BAR (absm) (declare (type absm absm)) (the list (with-absm (dgop bar1) absm - (do ((dgop dgop (ash dgop -1)) - (rslt +empty-list+)) - ((and (zerop dgop) (endp bar1)) (nreverse rslt)) - (declare - (fixnum dgop) - (list rslt)) - (push (if (oddp dgop) - 0 - (pop bar1)) - rslt))))) + (do ((dgop dgop (ash dgop -1)) + (rslt +empty-list+)) + ((and (zerop dgop) (endp bar1)) (nreverse rslt)) + (declare + (fixnum dgop) + (list rslt)) + (push (if (oddp dgop) + 0 + (pop bar1)) + rslt))))) (DEFUN Z-BAR-ABSM (bar) (declare (list bar)) (the absm (do ((rslt-dgop 0) - (rslt-bar +empty-list+) - (mark bar (cdr mark)) - (bark 1 (+ bark bark))) - ((endp mark) (absm rslt-dgop (nreverse rslt-bar))) - (declare - (fixnum rslt-dgop bark) - (list rslt-bar mark)) - (let ((k-i (car mark))) - (declare (fixnum k-i)) - (if (zerop k-i) - (incf rslt-dgop bark) - (push k-i rslt-bar)))))) + (rslt-bar +empty-list+) + (mark bar (cdr mark)) + (bark 1 (+ bark bark))) + ((endp mark) (absm rslt-dgop (nreverse rslt-bar))) + (declare + (fixnum rslt-dgop bark) + (list rslt-bar mark)) + (let ((k-i (car mark))) + (declare (fixnum k-i)) + (if (zerop k-i) + (incf rslt-dgop bark) + (push k-i rslt-bar)))))) (DEFUN K-Z-1-GRML (dmns crpr) @@ -83,27 +85,27 @@ (type crpr crpr)) (the absm (with-crpr (dgop1 bar1 dgop2 bar2) crpr - (do ((indx 1 (1+ indx)) - (dgop1 dgop1 (ash dgop1 -1)) - (dgop2 dgop2 (ash dgop2 -1)) - (bark 1 (ash bark +1)) - (rslt-dgop 0) - (rslt-bar +empty-list+)) - ((> indx dmns) (absm rslt-dgop (nreverse rslt-bar))) - (declare - (fixnum indx dgop1 dgop2 bark rslt-dgop) - (list rslt-bar)) - (let ((item (if (evenp dgop1) - (if (evenp dgop2) - (+ (pop bar1) (pop bar2)) - (pop bar1)) - (if (evenp dgop2) - (pop bar2) - 0)))) - (declare (fixnum item)) - (if (zerop item) - (incf rslt-dgop bark) - (push item rslt-bar))))))) + (do ((indx 1 (1+ indx)) + (dgop1 dgop1 (ash dgop1 -1)) + (dgop2 dgop2 (ash dgop2 -1)) + (bark 1 (ash bark +1)) + (rslt-dgop 0) + (rslt-bar +empty-list+)) + ((> indx dmns) (absm rslt-dgop (nreverse rslt-bar))) + (declare + (fixnum indx dgop1 dgop2 bark rslt-dgop) + (list rslt-bar)) + (let ((item (if (evenp dgop1) + (if (evenp dgop2) + (+ (pop bar1) (pop bar2)) + (pop bar1)) + (if (evenp dgop2) + (pop bar2) + 0)))) + (declare (fixnum item)) + (if (zerop item) + (incf rslt-dgop bark) + (push item rslt-bar))))))) (DEFUN K-Z-1-GRIN (dmns bar) @@ -121,40 +123,40 @@ (list hat)) (the absm (cond ((= 1 dmns) - (absm 1 +empty-list+)) - ((zerop indx) - (let ((del-1 (first hat)) - (del-2 (second hat))) - (declare (type absm del-1 del-2)) - (with-absm (dgop1 bar1) del-1 - (with-absm (dgop2 bar2) del-2 - (let ((bar01 (if (oddp dgop2) - 0 - (first bar2))) - (bar02 (if (oddp dgop1) - 0 - (first bar1)))) - (declare (fixnum bar01 bar02)) - (let ((bar12 (- bar02 bar01))) - (declare (fixnum bar02)) - (if (zerop bar01) - (1dgnr 0 del-1) - (if (zerop bar12) - (1gnr 1 del-1) - (let (del-01 (k-z-1-face 0 (1- dmns) - del-1)) - (declare (type absm del-01)) - (with-absm (dgop01 gmsm01) del-01 - (absm (* 4 dgop01) - (cons bar01 - (cons bar02 gmsm01))))))))))))) - ((= 1 indx) - (let ((del-0 (first hat)) - (del-2 (second hat))) - (declare (type absm del-0 del-2)) - (with-absm (dgop0 gmsm0) del-0 - (with-absm (dgop2 gmsm2) del-2 - (if (oddp dgop2 ))))))))) + (absm 1 +empty-list+)) + ((zerop indx) + (let ((del-1 (first hat)) + (del-2 (second hat))) + (declare (type absm del-1 del-2)) + (with-absm (dgop1 bar1) del-1 + (with-absm (dgop2 bar2) del-2 + (let ((bar01 (if (oddp dgop2) + 0 + (first bar2))) + (bar02 (if (oddp dgop1) + 0 + (first bar1)))) + (declare (fixnum bar01 bar02)) + (let ((bar12 (- bar02 bar01))) + (declare (fixnum bar02)) + (if (zerop bar01) + (1dgnr 0 del-1) + (if (zerop bar12) + (1gnr 1 del-1) + (let (del-01 (k-z-1-face 0 (1- dmns) + del-1)) + (declare (type absm del-01)) + (with-absm (dgop01 gmsm01) del-01 + (absm (* 4 dgop01) + (cons bar01 + (cons bar02 gmsm01))))))))))))) + ((= 1 indx) + (let ((del-0 (first hat)) + (del-2 (second hat))) + (declare (type absm del-0 del-2)) + (with-absm (dgop0 gmsm0) del-0 + (with-absm (dgop2 gmsm2) del-2 + (if (oddp dgop2 ))))))))) |# @@ -162,20 +164,20 @@ (the ab-simplicial-group (build-ab-smgr :cmpr #'k-z-1-cmpr - :basis :locally-effective - :bspn +empty-list+ - :face #'k-z-1-face - :sintr-grml #'k-z-1-grml - :sintr-grin #'k-z-1-grin - :orgn '(k-z-1)))) + :basis :locally-effective + :bspn +empty-list+ + :face #'k-z-1-face + :sintr-grml #'k-z-1-grml + :sintr-grin #'k-z-1-grin + :orgn '(k-z-1)))) (DEFUN K-Z (n) (declare (fixnum n)) (the ab-simplicial-group (if (= n 1) - (k-z-1) - (classifying-space (k-z (1- n)))))) + (k-z-1) + (classifying-space (k-z (1- n)))))) (DEFUN CIRCLE-CMPR (gnrt1 gnrt2) (declare (ignore gnrt1 gnrt2)) @@ -185,75 +187,75 @@ (declare (fixnum dmns)) (the list (case dmns - (0 '(*)) - (1 '(s1)) - (otherwise +empty-list+)))) + (0 '(*)) + (1 '(s1)) + (otherwise +empty-list+)))) (DEFUN CIRCLE () (the chain-complex (build-chcm - :cmpr #'circle-cmpr - :basis #'circle-basis - :bsgn '* - :intr-dffr #'zero-intr-dffr - :strt :cmbn - :orgn '(circle)))) + :cmpr #'circle-cmpr + :basis #'circle-basis + :bsgn '* + :intr-dffr #'zero-intr-dffr + :strt :cmbn + :orgn '(circle)))) (DEFUN KZ1-RDCT-F-INTR (cmbn) (declare (type cmbn cmbn)) (the cmbn (with-cmbn - (degr list) cmbn - (case degr - (0 (if list - (term-cmbn 0 (-cffc list) '*) - (zero-cmbn 0))) - (1 (let ((rslt - (apply #'+ - (mapcar - #'(lambda (term) - (declare (type term term)) - (with-term - (cffc gnrt) term - (the fixnum (* cffc (first gnrt))))) - list)))) - (if (zerop rslt) - (zero-cmbn 1) - (term-cmbn 1 rslt 's1)))) - (otherwise (zero-cmbn degr)))))) + (degr list) cmbn + (case degr + (0 (if list + (term-cmbn 0 (-cffc list) '*) + (zero-cmbn 0))) + (1 (let ((rslt + (apply #'+ + (mapcar + #'(lambda (term) + (declare (type term term)) + (with-term + (cffc gnrt) term + (the fixnum (* cffc (first gnrt))))) + list)))) + (if (zerop rslt) + (zero-cmbn 1) + (term-cmbn 1 rslt 's1)))) + (otherwise (zero-cmbn degr)))))) (DEFUN KZ1-RDCT-F () (the morphism (build-mrph :sorc (k-z-1) - :trgt (circle) - :degr 0 - :intr #'kz1-rdct-f-intr - :strt :cmbn - :orgn '(kz1-rdct-f)))) + :trgt (circle) + :degr 0 + :intr #'kz1-rdct-f-intr + :strt :cmbn + :orgn '(kz1-rdct-f)))) (DEFUN KZ1-RDCT-G-INTR (cmbn) (declare (type cmbn cmbn)) (the cmbn (with-cmbn (degr list) cmbn - (if list - (ecase degr - (0 (term-cmbn 0 (-cffc list) +empty-list+)) - (1 (term-cmbn 1 (-cffc list) (list 1)))) - (zero-cmbn degr))))) + (if list + (ecase degr + (0 (term-cmbn 0 (-cffc list) +empty-list+)) + (1 (term-cmbn 1 (-cffc list) (list 1)))) + (zero-cmbn degr))))) (DEFUN KZ1-RDCT-G () (the morphism (build-mrph :sorc (circle) - :trgt (k-z-1) - :degr 0 - :intr #'kz1-rdct-g-intr - :strt :cmbn - :orgn '(kz1-rdct-g)))) + :trgt (k-z-1) + :degr 0 + :intr #'kz1-rdct-g-intr + :strt :cmbn + :orgn '(kz1-rdct-g)))) (DEFUN KZ1-RDCT-H-INTR (dmns bar) @@ -262,59 +264,59 @@ (list bar)) (the cmbn (progn - (when (zerop dmns) - (return-from kz1-rdct-h-intr (zero-cmbn +1))) - (let ((k1 (first bar)) - (tail (rest bar))) - (declare - (fixnum k1) - (list tail)) - (if (plusp k1) - (do ((rslt +empty-list+ - (cons (term -1 - (cons 1 (cons i tail))) - rslt)) - (i (1- k1) (1- i))) - ((zerop i) (make-cmbn :degr (1+ dmns) - :list rslt)) - (declare - (list rslt) - (fixnum i))) - (do ((rslt +empty-list+ - (cons (term +1 - (cons 1 (cons i tail))) - rslt)) - (i -1 (1- i))) - ((< i k1) (make-cmbn :degr (1+ dmns) - :list rslt)))))))) + (when (zerop dmns) + (return-from kz1-rdct-h-intr (zero-cmbn +1))) + (let ((k1 (first bar)) + (tail (rest bar))) + (declare + (fixnum k1) + (list tail)) + (if (plusp k1) + (do ((rslt +empty-list+ + (cons (term -1 + (cons 1 (cons i tail))) + rslt)) + (i (1- k1) (1- i))) + ((zerop i) (make-cmbn :degr (1+ dmns) + :list rslt)) + (declare + (list rslt) + (fixnum i))) + (do ((rslt +empty-list+ + (cons (term +1 + (cons 1 (cons i tail))) + rslt)) + (i -1 (1- i))) + ((< i k1) (make-cmbn :degr (1+ dmns) + :list rslt)))))))) (DEFUN KZ1-RDCT-H () (the morphism (build-mrph :sorc (k-z-1) - :trgt (k-z-1) - :degr +1 - :intr #'kz1-rdct-h-intr - :strt :gnrt - :orgn '(kz1-rdct-h)))) + :trgt (k-z-1) + :degr +1 + :intr #'kz1-rdct-h-intr + :strt :gnrt + :orgn '(kz1-rdct-h)))) (DEFUN KZ1-RDCT () (the reduction (build-rdct :f (kz1-rdct-f) - :g (kz1-rdct-g) - :h (kz1-rdct-h) - :orgn '(kz1-rdct)))) + :g (kz1-rdct-g) + :h (kz1-rdct-h) + :orgn '(kz1-rdct)))) (DEFUN KZ1-EFHM () (the homotopy-equivalence (build-hmeq :lrdct (trivial-rdct (k-z-1)) - :rrdct (kz1-rdct) - :orgn '(kz1-efhm)))) + :rrdct (kz1-rdct) + :orgn '(kz1-efhm)))) (DEFMETHOD SEARCH-EFHM (k-z-1 (orgn (eql 'k-z-1))) (declare (ignore k-z-1)) @@ -327,20 +329,20 @@ (type crpr crpr)) (the absm (with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr - (declare (ignore gmsm1 gmsm2)) - (let ((dgop (- (mask dmns) (logxor dgop1 dgop2)))) - (declare (fixnum dgop)) - (absm dgop (- dmns (logcount dgop))))))) + (declare (ignore gmsm1 gmsm2)) + (let ((dgop (- (mask dmns) (logxor dgop1 dgop2)))) + (declare (fixnum dgop)) + (absm dgop (- dmns (logcount dgop))))))) (DEFUN K-Z2-1-GRML () (the simplicial-mrph (build-smmr :sorc (crts-prdc (r-proj-space) (r-proj-space)) - :trgt (r-proj-space) - :degr 0 - :sintr #'k-z2-1-grml-intr - :orgn '(k-z2-1-grml)))) + :trgt (r-proj-space) + :degr 0 + :sintr #'k-z2-1-grml-intr + :orgn '(k-z2-1-grml)))) (DEFUN K-Z2-1-GRIN-INTR (dmns gmsm) @@ -355,73 +357,73 @@ (the simplicial-mrph (build-smmr :sorc (r-proj-space) - :trgt (r-proj-space) - :degr 0 - :sintr #'k-z2-1-grin-intr - :intr #'identity - :strt :cmbn - :orgn '(k-z2-1-grin)))) + :trgt (r-proj-space) + :degr 0 + :sintr #'k-z2-1-grin-intr + :intr #'identity + :strt :cmbn + :orgn '(k-z2-1-grin)))) (DEFUN K-Z2-1 () (the ab-simplicial-group (let ((rslt (r-proj-space))) - (declare (type simplicial-set rslt)) - (change-class rslt 'ab-simplicial-group) - (setf (slot-value rslt 'grml) - (k-z2-1-grml) - (slot-value rslt 'grin) - (k-z2-1-grin)) - (pushnew rslt *smgr-list*) - rslt))) + (declare (type simplicial-set rslt)) + (change-class rslt 'ab-simplicial-group) + (setf (slot-value rslt 'grml) + (k-z2-1-grml) + (slot-value rslt 'grin) + (k-z2-1-grin)) + (pushnew rslt *smgr-list*) + rslt))) (DEFUN K-Z2 (n) (declare (fixnum n)) (the ab-simplicial-group (if (= n 1) - (k-z2-1) - (classifying-space (k-z2 (1- n)))))) + (k-z2-1) + (classifying-space (k-z2 (1- n)))))) (DEFUN Z2-ABSM-BAR (absm) (declare (type absm absm)) (the list (with-absm (dgop gmsm) absm - (do ((bmark (1- (+ (logcount dgop) gmsm)) (1- bmark)) - (rslt +empty-list+ - (cons (if (logbitp bmark dgop) - 0 1) - rslt))) - ((minusp bmark) rslt) - (declare - (fixnum bmark) - (list rslt)))))) + (do ((bmark (1- (+ (logcount dgop) gmsm)) (1- bmark)) + (rslt +empty-list+ + (cons (if (logbitp bmark dgop) + 0 1) + rslt))) + ((minusp bmark) rslt) + (declare + (fixnum bmark) + (list rslt)))))) (DEFUN Z2-BAR-ABSM (bar) (declare (list bar)) (the absm (do ((dgop 0) - (2-pwr 1 (+ 2-pwr 2-pwr)) - (gmsm 0) - (mark bar (cdr mark))) - ((endp mark) (absm dgop gmsm)) - (declare - (fixnum dgop 2-pwr gmsm) - (list mark)) - (if (zerop (car mark)) - (incf dgop 2-pwr) - (incf gmsm))))) + (2-pwr 1 (+ 2-pwr 2-pwr)) + (gmsm 0) + (mark bar (cdr mark))) + ((endp mark) (absm dgop gmsm)) + (declare + (fixnum dgop 2-pwr gmsm) + (list mark)) + (if (zerop (car mark)) + (incf dgop 2-pwr) + (incf gmsm))))) (DEFUN HOPF-FIBRATION-SINTR (n) (declare (fixnum n)) (flet ((rslt (dmns gmsm) - (declare (ignore dmns gmsm)) - (if (zerop n) - (absm 1 +empty-list+) - (absm 0 (list n))))) + (declare (ignore dmns gmsm)) + (if (zerop n) + (absm 1 +empty-list+) + (absm 0 (list n))))) (the sintr #'rslt))) @@ -430,27 +432,27 @@ (the simplicial-mrph (build-smmr :sorc (sphere 2) - :trgt (k-z-1) - :degr -1 - :sintr (hopf-fibration-sintr n) - :orgn `(hopf-fibration ,n)))) + :trgt (k-z-1) + :degr -1 + :sintr (hopf-fibration-sintr n) + :orgn `(hopf-fibration ,n)))) (DEFUN Z-FUNDAMENTAL-GMSM (dmns pi-elm) ;;; pi-elm not equal to 0 (declare (fixnum dmns pi-elm)) (the gmsm (if (= 1 dmns) - (list pi-elm) - (let ((bspn (if (= 2 dmns) +empty-list+ +null-gbar+))) - (declare (type gmsm bspn)) - (make-gbar :dmns dmns - :list (cons (absm 0 (z-fundamental-gmsm (1- dmns) - pi-elm)) - (mapcar - #'(lambda (k) - (declare (fixnum k)) - (absm (mask k) bspn)) - (nreverse ( 0 (- dmns 2)))))))))) + (list pi-elm) + (let ((bspn (if (= 2 dmns) +empty-list+ +null-gbar+))) + (declare (type gmsm bspn)) + (make-gbar :dmns dmns + :list (cons (absm 0 (z-fundamental-gmsm (1- dmns) + pi-elm)) + (mapcar + #'(lambda (k) + (declare (fixnum k)) + (absm (mask k) bspn)) + (nreverse ( 0 (- dmns 2)))))))))) (DEFUN INTERESTING-FACES (face small-dmns high-dmns gmsm) @@ -460,32 +462,32 @@ (type gmsm gmsm)) (the list (let ((max (mask high-dmns))) - (declare (fixnum max)) - (if (= small-dmns high-dmns) - (list (cons max (absm 0 gmsm))) - (do ((prev-list (interesting-faces face (1+ small-dmns) high-dmns - gmsm)) - (k (1- max) (1- k)) - (rslt +empty-list+) - (count (binomial-n-p high-dmns small-dmns))) - ((zerop count) rslt) - (declare - (list prev-list rslt) - (fixnum k count)) - (when (= small-dmns (logcount k)) - (decf count) - (do ((i 0 (1+ i))) - ((not (logbitp i k)) - (push (cons k - (a-face4 face - (- small-dmns -1 - (if (= i (integer-length k)) - (1+ i) - i)) - (1+ small-dmns) - (cdr (assoc (+ k (2-exp i)) - prev-list)))) - rslt))))))))) + (declare (fixnum max)) + (if (= small-dmns high-dmns) + (list (cons max (absm 0 gmsm))) + (do ((prev-list (interesting-faces face (1+ small-dmns) high-dmns + gmsm)) + (k (1- max) (1- k)) + (rslt +empty-list+) + (count (binomial-n-p high-dmns small-dmns))) + ((zerop count) rslt) + (declare + (list prev-list rslt) + (fixnum k count)) + (when (= small-dmns (logcount k)) + (decf count) + (do ((i 0 (1+ i))) + ((not (logbitp i k)) + (push (cons k + (a-face4 face + (- small-dmns -1 + (if (= i (integer-length k)) + (1+ i) + i)) + (1+ small-dmns) + (cdr (assoc (+ k (2-exp i)) + prev-list)))) + rslt))))))))) (DEFUN GMSM-COCYCLE (face small-dmns high-dmns gmsm chml-clss) @@ -496,26 +498,26 @@ (type morphism chml-clss)) (the list (let ((int-faces (interesting-faces face small-dmns high-dmns gmsm))) - (declare (list int-faces)) - (mapc - #'(lambda (cons) - (declare (cons cons)) - (setf (cdr cons) - (let ((absm (cdr cons))) - (declare (type absm absm)) - (with-absm (dgop gmsm2) absm - (if (plusp dgop) - 0 - (let ((cmbn-list - (cmbn-list (gnrt-? chml-clss - small-dmns - gmsm2)))) - (declare (list cmbn-list)) - (if cmbn-list - (-cffc cmbn-list) - 0))))))) - int-faces) - int-faces))) + (declare (list int-faces)) + (mapc + #'(lambda (cons) + (declare (cons cons)) + (setf (cdr cons) + (let ((absm (cdr cons))) + (declare (type absm absm)) + (with-absm (dgop gmsm2) absm + (if (plusp dgop) + 0 + (let ((cmbn-list + (cmbn-list (gnrt-? chml-clss + small-dmns + gmsm2)))) + (declare (list cmbn-list)) + (if cmbn-list + (-cffc cmbn-list) + 0))))))) + int-faces) + int-faces))) (DEFUN Z-COCYCLE-GBAR (n dmns cocycle) @@ -525,42 +527,42 @@ (list cocycle)) (the absm (cond ((= n 1) - (z-bar-absm (nreverse (mapcar #'cdr cocycle)))) - ((= n dmns) - (let ((value (cdr (first cocycle)))) - (declare (fixnum value)) - (if (zerop value) - (absm (mask dmns) +null-gbar+) - (absm 0 (z-fundamental-gmsm dmns value))))) - (t - (let ((cocycle1 +empty-list+) - (cocycle2 +empty-list+)) - (declare (list cocycle1 cocycle2)) - (dolist (cons cocycle) - (declare (cons cons)) - (if (evenp (car cons)) - (push (cons (ash (car cons) -1) (cdr cons)) - cocycle1) - (push (cons (ash (car cons) -1) (cdr cons)) - cocycle2))) - (setf cocycle1 (nreverse cocycle1) - cocycle2 (nreverse cocycle2)) - (mapc - #'(lambda (cons) - (declare (cons cons)) - (when (evenp (car cons)) - (decf (cdr cons) - (cdr (assoc (1+ (car cons)) cocycle1))))) - cocycle2) - (let ((head-absm (z-cocycle-gbar (1- n) (1- dmns) cocycle2)) - (tail-absm (z-cocycle-gbar n (1- dmns) cocycle1))) - (declare (type absm head-absm tail-absm)) - (normalize-gbar - (cons dmns - (cons head-absm - (rest (unnormalize-gbar - tail-absm - (if (= n 2) () +null-gbar+)))))))))))) + (z-bar-absm (nreverse (mapcar #'cdr cocycle)))) + ((= n dmns) + (let ((value (cdr (first cocycle)))) + (declare (fixnum value)) + (if (zerop value) + (absm (mask dmns) +null-gbar+) + (absm 0 (z-fundamental-gmsm dmns value))))) + (t + (let ((cocycle1 +empty-list+) + (cocycle2 +empty-list+)) + (declare (list cocycle1 cocycle2)) + (dolist (cons cocycle) + (declare (cons cons)) + (if (evenp (car cons)) + (push (cons (ash (car cons) -1) (cdr cons)) + cocycle1) + (push (cons (ash (car cons) -1) (cdr cons)) + cocycle2))) + (setf cocycle1 (nreverse cocycle1) + cocycle2 (nreverse cocycle2)) + (mapc + #'(lambda (cons) + (declare (cons cons)) + (when (evenp (car cons)) + (decf (cdr cons) + (cdr (assoc (1+ (car cons)) cocycle1))))) + cocycle2) + (let ((head-absm (z-cocycle-gbar (1- n) (1- dmns) cocycle2)) + (tail-absm (z-cocycle-gbar n (1- dmns) cocycle1))) + (declare (type absm head-absm tail-absm)) + (normalize-gbar + (cons dmns + (cons head-absm + (rest (unnormalize-gbar + tail-absm + (if (= n 2) () +null-gbar+)))))))))))) (DEFUN Z-COCYCLE-GBAR-HEAD (n dmns cocycle) @@ -570,54 +572,54 @@ (list cocycle)) (the absm (cond ((= n 1) - (error "In Z-COCYCLE-GBAR-HEAD, this point should not have been reached.")) - ;; (z-bar-absm (nreverse (mapcar #'cdr cocycle)))) - ((= n dmns) - (let ((value (cdr (first cocycle)))) - (declare (fixnum value)) - (if (zerop value) - (if (= n 2) - (absm 1 +empty-list+) - (absm (mask (1- dmns)) +null-gbar+)) - (absm 0 (z-fundamental-gmsm (1- dmns) value))))) - (t - (let ((cocycle1 +empty-list+) - (cocycle2 +empty-list+)) - (declare (list cocycle1 cocycle2)) - (dolist (cons cocycle) - (declare (cons cons)) - (if (evenp (car cons)) - (push (cons (ash (car cons) -1) (cdr cons)) - cocycle1) - (push (cons (ash (car cons) -1) (cdr cons)) - cocycle2))) - (setf cocycle1 (nreverse cocycle1) - cocycle2 (nreverse cocycle2)) - (mapc - #'(lambda (cons) - (declare (cons cons)) - (when (evenp (car cons)) - (decf (cdr cons) - (cdr (assoc (1+ (car cons)) cocycle1))))) - cocycle2) - (z-cocycle-gbar (1- n) (1- dmns) cocycle2)))))) + (error "In Z-COCYCLE-GBAR-HEAD, this point should not have been reached.")) + ;; (z-bar-absm (nreverse (mapcar #'cdr cocycle)))) + ((= n dmns) + (let ((value (cdr (first cocycle)))) + (declare (fixnum value)) + (if (zerop value) + (if (= n 2) + (absm 1 +empty-list+) + (absm (mask (1- dmns)) +null-gbar+)) + (absm 0 (z-fundamental-gmsm (1- dmns) value))))) + (t + (let ((cocycle1 +empty-list+) + (cocycle2 +empty-list+)) + (declare (list cocycle1 cocycle2)) + (dolist (cons cocycle) + (declare (cons cons)) + (if (evenp (car cons)) + (push (cons (ash (car cons) -1) (cdr cons)) + cocycle1) + (push (cons (ash (car cons) -1) (cdr cons)) + cocycle2))) + (setf cocycle1 (nreverse cocycle1) + cocycle2 (nreverse cocycle2)) + (mapc + #'(lambda (cons) + (declare (cons cons)) + (when (evenp (car cons)) + (decf (cdr cons) + (cdr (assoc (1+ (car cons)) cocycle1))))) + cocycle2) + (z-cocycle-gbar (1- n) (1- dmns) cocycle2)))))) (DEFUN Z2-FUNDAMENTAL-GMSM (dmns pi-elm) ;; pi-elm not "equal" to 0, therefore 1. (declare (fixnum dmns pi-elm)) (the gmsm (if (= 1 dmns) - 1 - (let ((bspn (if (= 2 dmns) 0 +null-gbar+))) - (declare (type gmsm bspn)) - (make-gbar :dmns dmns - :list (cons (absm 0 (Z2-fundamental-gmsm (1- dmns) - pi-elm)) - (mapcar - #'(lambda (k) - (declare (fixnum k)) - (absm (mask k) bspn)) - (nreverse ( 0 (- dmns 2)))))))))) + 1 + (let ((bspn (if (= 2 dmns) 0 +null-gbar+))) + (declare (type gmsm bspn)) + (make-gbar :dmns dmns + :list (cons (absm 0 (Z2-fundamental-gmsm (1- dmns) + pi-elm)) + (mapcar + #'(lambda (k) + (declare (fixnum k)) + (absm (mask k) bspn)) + (nreverse ( 0 (- dmns 2)))))))))) (DEFUN Z2-COCYCLE-GBAR (n dmns cocycle) @@ -627,51 +629,51 @@ (list cocycle)) (the absm (progn - (mapc - #'(lambda (cons) - (declare (cons cons)) - (setf (cdr cons) - (if (evenp (cdr cons)) 0 1))) - cocycle) - (cond ((= n 1) - (z2-bar-absm (nreverse (mapcar #'cdr cocycle)))) - ((= n dmns) - (let ((value (cdr (first cocycle)))) - (declare (fixnum value)) - (if (zerop value) - (absm (mask dmns) +null-gbar+) - (absm 0 (z2-fundamental-gmsm dmns value))))) - (t - (let ((cocycle1 +empty-list+) - (cocycle2 +empty-list+)) - (declare (list cocycle1 cocycle2)) - (dolist (cons cocycle) - (declare (cons cons)) - (if (evenp (car cons)) - (push (cons (ash (car cons) -1) (cdr cons)) - cocycle1) - (push (cons (ash (car cons) -1) (cdr cons)) - cocycle2))) - (setf cocycle1 (nreverse cocycle1) - cocycle2 (nreverse cocycle2)) - (mapc - #'(lambda (cons) - (declare (cons cons)) - (when (evenp (car cons)) - (setf (cdr cons) - (mod (- (cdr cons) - (cdr (assoc (1+ (car cons)) cocycle1))) - 2)))) - cocycle2) - (let ((head-absm (z2-cocycle-gbar (1- n) (1- dmns) cocycle2)) - (tail-absm (z2-cocycle-gbar n (1- dmns) cocycle1))) - (declare (type absm head-absm tail-absm)) - (normalize-gbar - (cons dmns - (cons head-absm - (rest (unnormalize-gbar - tail-absm - (if (= n 2) 0 +null-gbar+))))))))))))) + (mapc + #'(lambda (cons) + (declare (cons cons)) + (setf (cdr cons) + (if (evenp (cdr cons)) 0 1))) + cocycle) + (cond ((= n 1) + (z2-bar-absm (nreverse (mapcar #'cdr cocycle)))) + ((= n dmns) + (let ((value (cdr (first cocycle)))) + (declare (fixnum value)) + (if (zerop value) + (absm (mask dmns) +null-gbar+) + (absm 0 (z2-fundamental-gmsm dmns value))))) + (t + (let ((cocycle1 +empty-list+) + (cocycle2 +empty-list+)) + (declare (list cocycle1 cocycle2)) + (dolist (cons cocycle) + (declare (cons cons)) + (if (evenp (car cons)) + (push (cons (ash (car cons) -1) (cdr cons)) + cocycle1) + (push (cons (ash (car cons) -1) (cdr cons)) + cocycle2))) + (setf cocycle1 (nreverse cocycle1) + cocycle2 (nreverse cocycle2)) + (mapc + #'(lambda (cons) + (declare (cons cons)) + (when (evenp (car cons)) + (setf (cdr cons) + (mod (- (cdr cons) + (cdr (assoc (1+ (car cons)) cocycle1))) + 2)))) + cocycle2) + (let ((head-absm (z2-cocycle-gbar (1- n) (1- dmns) cocycle2)) + (tail-absm (z2-cocycle-gbar n (1- dmns) cocycle1))) + (declare (type absm head-absm tail-absm)) + (normalize-gbar + (cons dmns + (cons head-absm + (rest (unnormalize-gbar + tail-absm + (if (= n 2) 0 +null-gbar+))))))))))))) (DEFUN Z2-COCYCLE-GBAR-HEAD (n dmns cocycle) @@ -681,80 +683,80 @@ (list cocycle)) (the absm (progn - (mapc - #'(lambda (cons) - (setf (cdr cons) - (if (evenp (cdr cons)) 0 1))) - cocycle) - (cond ((= n 1) - (error "In Z2-COCYCLE-GBAR-HEAD, this point should not have been reached.")) - ;; (z2-bar-absm (nreverse (mapcar #'cdr cocycle)))) - ((= n dmns) - (let ((value (cdr (first cocycle)))) - (declare (fixnum value)) - (if (zerop value) - (if (= n 2) - (absm 1 0) - (absm (mask (1- dmns)) +null-gbar+)) - (absm 0 (z2-fundamental-gmsm (1- dmns) value))))) - (t - (let ((cocycle1 +empty-list+) - (cocycle2 +empty-list+)) - (declare (list cocycle1 cocycle2)) - (dolist (cons cocycle) - (declare (cons cons)) - (if (evenp (car cons)) - (push (cons (ash (car cons) -1) (cdr cons)) - cocycle1) - (push (cons (ash (car cons) -1) (cdr cons)) - cocycle2))) - (setf cocycle1 (nreverse cocycle1) - cocycle2 (nreverse cocycle2)) - (mapc - #'(lambda (cons) - (declare (cons cons)) - (when (evenp (car cons)) - (setf (cdr cons) - (mod (- (cdr cons) - (cdr (assoc (1+ (car cons)) cocycle1))) - 2)))) - cocycle2) - (z2-cocycle-gbar (1- n) (1- dmns) cocycle2))))))) + (mapc + #'(lambda (cons) + (setf (cdr cons) + (if (evenp (cdr cons)) 0 1))) + cocycle) + (cond ((= n 1) + (error "In Z2-COCYCLE-GBAR-HEAD, this point should not have been reached.")) + ;; (z2-bar-absm (nreverse (mapcar #'cdr cocycle)))) + ((= n dmns) + (let ((value (cdr (first cocycle)))) + (declare (fixnum value)) + (if (zerop value) + (if (= n 2) + (absm 1 0) + (absm (mask (1- dmns)) +null-gbar+)) + (absm 0 (z2-fundamental-gmsm (1- dmns) value))))) + (t + (let ((cocycle1 +empty-list+) + (cocycle2 +empty-list+)) + (declare (list cocycle1 cocycle2)) + (dolist (cons cocycle) + (declare (cons cons)) + (if (evenp (car cons)) + (push (cons (ash (car cons) -1) (cdr cons)) + cocycle1) + (push (cons (ash (car cons) -1) (cdr cons)) + cocycle2))) + (setf cocycle1 (nreverse cocycle1) + cocycle2 (nreverse cocycle2)) + (mapc + #'(lambda (cons) + (declare (cons cons)) + (when (evenp (car cons)) + (setf (cdr cons) + (mod (- (cdr cons) + (cdr (assoc (1+ (car cons)) cocycle1))) + 2)))) + cocycle2) + (z2-cocycle-gbar (1- n) (1- dmns) cocycle2))))))) (DEFUN K-Z-FUNDAMENTAL-CLASS (n) (declare (fixnum n)) (the morphism (build-mrph - :sorc (k-z n) :trgt (z-chcm) :degr (- n) - :intr #'(lambda (dmns gmsm) - (declare - (fixnum dmns) - (type gmsm gmsm)) - (if (= dmns n) - (do ((gmsm gmsm (gmsm (first (gbar-list gmsm)))) - (dmns dmns (1- dmns))) - ((= 1 dmns) - (term-cmbn 0 (first gmsm) :z-gnrt)) - (declare - (type gmsm gmsm) - (fixnum dmns))) - (zero-cmbn (- dmns n)))) - :strt :gnrt - :orgn `(k-z-fundamental-class ,n)))) + :sorc (k-z n) :trgt (z-chcm) :degr (- n) + :intr #'(lambda (dmns gmsm) + (declare + (fixnum dmns) + (type gmsm gmsm)) + (if (= dmns n) + (do ((gmsm gmsm (gmsm (first (gbar-list gmsm)))) + (dmns dmns (1- dmns))) + ((= 1 dmns) + (term-cmbn 0 (first gmsm) :z-gnrt)) + (declare + (type gmsm gmsm) + (fixnum dmns))) + (zero-cmbn (- dmns n)))) + :strt :gnrt + :orgn `(k-z-fundamental-class ,n)))) (DEFUN K-Z2-FUNDAMENTAL-CLASS (n) (declare (fixnum n)) (the morphism (build-mrph - :sorc (k-z2 n) :trgt (z-chcm) :degr (- n) - :intr #'(lambda (dmns gmsm) - (declare - (fixnum dmns) - (ignore gmsm)) - (if (= dmns n) - (term-cmbn 0 1 :z-gnrt) - (zero-cmbn (- dmns n)))) - :strt :gnrt - :orgn `(k-z2-fundamental-class ,n)))) + :sorc (k-z2 n) :trgt (z-chcm) :degr (- n) + :intr #'(lambda (dmns gmsm) + (declare + (fixnum dmns) + (ignore gmsm)) + (if (= dmns n) + (term-cmbn 0 1 :z-gnrt) + (zero-cmbn (- dmns n)))) + :strt :gnrt + :orgn `(k-z2-fundamental-class ,n)))) diff --git a/src/kan.lisp b/src/kan.lisp index 4dc6eeb..3fa1d33 100644 --- a/src/kan.lisp +++ b/src/kan.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; KAN KAN KAN KAN KAN KAN KAN KAN KAN KAN KAN KAN ;;; KAN KAN KAN KAN KAN KAN KAN KAN KAN KAN KAN KAN ;;; KAN KAN KAN KAN KAN KAN KAN KAN KAN KAN KAN KAN @@ -17,8 +19,8 @@ (DEFMETHOD PRINT-OBJECT ((kan kan) stream) (the kan (progn - (format stream "[K~D Kan-Simplicial-Set]" (idnm kan)) - kan))) + (format stream "[K~D Kan-Simplicial-Set]" (idnm kan)) + kan))) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute) (setf (ext:package-lock :clos) t)) @@ -29,10 +31,10 @@ (type kfll kfll)) (the kan (progn - (change-class smst 'kan) - (setf (slot-value smst 'kfll) kfll) - (pushnew smst *kan-list*) - smst))) + (change-class smst 'kan) + (setf (slot-value smst 'kfll) kfll) + (pushnew smst *kan-list*) + smst))) (DEFUN CHECK-HAT (kan indx dmns hat) @@ -42,9 +44,9 @@ (list hat)) (assert (= dmns (length hat))) (setf hat - (append (subseq hat 0 indx) - (list :hole) - (nthcdr indx hat))) + (append (subseq hat 0 indx) + (list :hole) + (nthcdr indx hat))) (do ((cmpr (cmpr kan)) (j 0 (1+ j))) ((> j dmns) t) @@ -53,17 +55,17 @@ (fixnum j)) (unless (= j indx) (let ((del-j (nth j hat))) - (declare (type absm del-j)) - (do ((i j (1+ i))) - ((= i dmns)) - (declare (fixnum i)) - (unless (= i (1- indx)) - (let ((del-i-del-j (face kan i (1- dmns) del-j)) - (del-j-del-i+1 (face kan j (1- dmns) - (nth (1+ i) hat)))) - (declare (type absm del-i-del-j del-j-del-i+1)) - (assert (eq :equal - (a-cmpr3 cmpr del-i-del-j del-j-del-i+1)))))))))) + (declare (type absm del-j)) + (do ((i j (1+ i))) + ((= i dmns)) + (declare (fixnum i)) + (unless (= i (1- indx)) + (let ((del-i-del-j (face kan i (1- dmns) del-j)) + (del-j-del-i+1 (face kan j (1- dmns) + (nth (1+ i) hat)))) + (declare (type absm del-i-del-j del-j-del-i+1)) + (assert (eq :equal + (a-cmpr3 cmpr del-i-del-j del-j-del-i+1)))))))))) (DEFUN CHECK-KAN (kan indx dmns hat) @@ -73,29 +75,29 @@ (list hat)) (the (values) (let ((rslt (kfll kan indx dmns hat)) - (cmpr (cmpr kan)) - (face (face kan))) - (declare - (type absm rslt) - (type cmprf cmpr) - (type face face)) - (check-hat kan indx dmns hat) - (do ((i 0 (1+ i))) - ((> i dmns)) - (declare (fixnum i)) - (unless (= i indx) - (let ((x-i (pop hat)) - (del-i-rslt (a-face4 face i dmns rslt))) - (declare (type absm x-i del-i-rslt)) - (with-absm (dgop1 gmsm1) x-i - (with-absm - (dgop2 gmsm2) del-i-rslt - (unless (and (= dgop1 dgop2) - (eq (funcall cmpr gmsm1 gmsm2) - :equal)) - (error "Wrong result:~@ + (cmpr (cmpr kan)) + (face (face kan))) + (declare + (type absm rslt) + (type cmprf cmpr) + (type face face)) + (check-hat kan indx dmns hat) + (do ((i 0 (1+ i))) + ((> i dmns)) + (declare (fixnum i)) + (unless (= i indx) + (let ((x-i (pop hat)) + (del-i-rslt (a-face4 face i dmns rslt))) + (declare (type absm x-i del-i-rslt)) + (with-absm (dgop1 gmsm1) x-i + (with-absm + (dgop2 gmsm2) del-i-rslt + (unless (and (= dgop1 dgop2) + (eq (funcall cmpr gmsm1 gmsm2) + :equal)) + (error "Wrong result:~@ Fill = ~A~@ Del-~D(Fill) = ~A~@ Hat-~D = ~A" - rslt i del-i-rslt i x-i))))))) - (done)))) + rslt i del-i-rslt i x-i))))))) + (done)))) diff --git a/src/kenzo.lisp b/src/kenzo.lisp index e9ad30a..a76fb41 100644 --- a/src/kenzo.lisp +++ b/src/kenzo.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;;; kenzo.lisp (IN-PACKAGE #:cat) @@ -12,7 +14,7 @@ (DEFMACRO DEFINE-CONSTANT (name value &optional doc) `(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value) - ,@(when doc (list doc)))) + ,@(when doc (list doc)))) ;; globals from cat-init.lisp @@ -26,7 +28,7 @@ validation of combinations.") (DEFINE-CONSTANT +EMPTY-LIST+ '()) (DEFINE-CONSTANT +F-EMPTY-VECTOR+ - (make-array 0 :element-type 'fixnum)) + (make-array 0 :element-type 'fixnum)) (DEFINE-CONSTANT +S-EMPTY-VECTOR+ #()) @@ -36,17 +38,17 @@ validation of combinations.") (DEFINE-CONSTANT +2-EXP+ (let ((rslt (make-array (integer-length most-positive-fixnum) - :element-type 'fixnum))) + :element-type 'fixnum))) (declare (type (array fixnum 1) rslt)) (dotimes (i (integer-length most-positive-fixnum) rslt) - (setf (aref rslt i) (the fixnum (expt 2 i)))))) + (setf (aref rslt i) (the fixnum (expt 2 i)))))) (DEFINE-CONSTANT +MASK+ (let ((rslt (make-array (integer-length most-positive-fixnum) - :element-type 'fixnum))) + :element-type 'fixnum))) (declare (type (array fixnum 1) rslt)) (dotimes (i (integer-length most-positive-fixnum) rslt) - (setf (aref rslt i) (the fixnum (1- (expt 2 i))))))) + (setf (aref rslt i) (the fixnum (1- (expt 2 i))))))) ;; globals from combinations.lisp diff --git a/src/loop-spaces.lisp b/src/loop-spaces.lisp index 9b2312a..a38f41f 100644 --- a/src/loop-spaces.lisp +++ b/src/loop-spaces.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; LOOP-SPACES LOOP-SPACES LOOP-SPACES LOOP-SPACES LOOP-SPACES LOOP-SPACES ;;; LOOP-SPACES LOOP-SPACES LOOP-SPACES LOOP-SPACES LOOP-SPACES LOOP-SPACES ;;; LOOP-SPACES LOOP-SPACES LOOP-SPACES LOOP-SPACES LOOP-SPACES LOOP-SPACES @@ -16,30 +18,30 @@ (the absm (progn (unless niloop - (return-from normalize-loop - (absm (mask dmns) +null-loop+))) + (return-from normalize-loop + (absm (mask dmns) +null-loop+))) (let ((dgop (apply #'logand (mapcar #'car niloop)))) - (declare (fixnum dgop)) - (if (zerop dgop) + (declare (fixnum dgop)) + (if (zerop dgop) (absm 0 (make-loop :list niloop)) (absm dgop - (make-loop - :list (mapcar #'(lambda (apowr) + (make-loop + :list (mapcar #'(lambda (apowr) (cons - (dgop/dgop (apdgop apowr) dgop) - (cdr apowr))) - niloop)))))))) + (dgop/dgop (apdgop apowr) dgop) + (cdr apowr))) + niloop)))))))) (DEFUN UNNORMALIZE-LOOP (absm) (declare (type absm absm)) (the iloop (with-absm (dgop loop) absm - (mapcar #'(lambda (apowr) - (declare (type apowr apowr)) - (cons (dgop*dgop dgop (car apowr)) - (cdr apowr))) - (loop-list loop))))) + (mapcar #'(lambda (apowr) + (declare (type apowr apowr)) + (cons (dgop*dgop dgop (car apowr)) + (cdr apowr))) + (loop-list loop))))) (DEFUN LOOP3 (&rest list) @@ -49,9 +51,9 @@ (unless (zerop (mod (length list) 3)) (error "In LOOP3, 3 should divide the list length.")) (flet ((fixnumpp (object) - (unless (typep object 'fixnum) - (error "In LOOP3, ~A should be a fixnum." object)) - object)) + (unless (typep object 'fixnum) + (error "In LOOP3, ~A should be a fixnum." object)) + object)) (do ((rslt +empty-list+ (cons (apowr (fixnumpp (car mark)) (cadr mark) @@ -68,19 +70,19 @@ (ignore depth)) (the loop (progn - (format stream "<>") - loop))) + (format stream "<>") + loop))) (DEFUN APOWR-NILOOP (cmpr apowr niloop) @@ -91,20 +93,20 @@ (the iloop (progn (unless niloop - (return-from apowr-niloop - (list apowr))) + (return-from apowr-niloop + (list apowr))) (let ((apowr2 (first niloop))) - (declare (type apowr apowr2)) - (with-apowr (dgop2 gmsm2 expn2) apowr2 - (unless (and (= (apdgop apowr) dgop2) - (eq :equal (funcall cmpr (apgmsm apowr) - gmsm2))) - (return-from apowr-niloop - (cons apowr niloop))) - (incf expn2 (apexpn apowr)) - (if (zerop expn2) - (rest niloop) - (cons (apowr dgop2 gmsm2 expn2) (rest niloop)))))))) + (declare (type apowr apowr2)) + (with-apowr (dgop2 gmsm2 expn2) apowr2 + (unless (and (= (apdgop apowr) dgop2) + (eq :equal (funcall cmpr (apgmsm apowr) + gmsm2))) + (return-from apowr-niloop + (cons apowr niloop))) + (incf expn2 (apexpn apowr)) + (if (zerop expn2) + (rest niloop) + (cons (apowr dgop2 gmsm2 expn2) (rest niloop)))))))) (DEFUN LOOP-SPACE-CMPR (cmpr) @@ -112,12 +114,12 @@ (flet ((2apowr-cmpr (apowr1 apowr2) (declare (type apowr apowr1 apowr2)) (lexico - (f-cmpr (apdgop apowr1) (apdgop apowr2)) - (funcall cmpr (apgmsm apowr1) (apgmsm apowr2)) - (f-cmpr (apexpn apowr1) (apexpn apowr2))))) + (f-cmpr (apdgop apowr1) (apdgop apowr2)) + (funcall cmpr (apgmsm apowr1) (apgmsm apowr2)) + (f-cmpr (apexpn apowr1) (apexpn apowr2))))) (flet ((rslt (loop1 loop2) - (declare (type loop loop1 loop2)) - (maplexico #'2apowr-cmpr (loop-list loop1) (loop-list loop2)))) + (declare (type loop loop1 loop2)) + (maplexico #'2apowr-cmpr (loop-list loop1) (loop-list loop2)))) (the cmprf #'rslt)))) @@ -127,12 +129,12 @@ (type face face) (type apowr apowr)) (with-apowr (dgop gmsm expn) apowr - (let ((face (a-face4 face indx (1+ dmns) (absm dgop gmsm)))) - (declare (type absm face)) - (with-absm (dgop gmsm) face - (if (logbitp (1- dmns) dgop) - nil - (apowr dgop gmsm expn)))))) + (let ((face (a-face4 face indx (1+ dmns) (absm dgop gmsm)))) + (declare (type absm face)) + (with-absm (dgop gmsm) face + (if (logbitp (1- dmns) dgop) + nil + (apowr dgop gmsm expn)))))) (DEFUN APOWR-LASTFACE4 (cmpr face dmns apowr) @@ -144,54 +146,54 @@ (type apowr apowr)) (the list (with-apowr - (dgop gmsm expn) apowr - (let ((absm (absm dgop gmsm))) - (declare (type absm absm)) - (let ((face-n (a-face4 face dmns (1+ dmns) absm)) - (face-n+1 (a-face4 face (1+ dmns) (1+ dmns) absm))) - (declare (type absm face-n face-n+1)) - (with-absm - (dgop1 gmsm1) face-n - (with-absm - (dgop2 gmsm2) face-n+1 - (if (logbitp (1- dmns) dgop1) - (if (logbitp (1- dmns) dgop2) - (return-from apowr-lastface4 +empty-list+) - (return-from apowr-lastface4 - (list (apowr dgop2 gmsm2 (- expn))))) - (when (logbitp (1- dmns) dgop2) - (return-from apowr-lastface4 - (list (apowr dgop1 gmsm1 expn))))) - (when (and (= dgop1 dgop2) - (eq :equal (funcall cmpr gmsm1 gmsm2))) - (return-from apowr-lastface4 +empty-list+)) - (case expn - (+1 (list (apowr dgop2 gmsm2 -1) (apowr dgop1 gmsm1 - +1))) - (-1 (list (apowr dgop1 gmsm1 -1) (apowr dgop2 gmsm2 - +1))) - (otherwise - (if (plusp expn) - (do ((rslt +empty-list+ (cons apowr2 - (cons apowr1 - rslt))) - (apowr1 (apowr dgop1 gmsm1 +1)) - (apowr2 (apowr dgop2 gmsm2 -1)) - (nark expn (1- nark))) - ((zerop nark) rslt) - (declare - (list rslt) - (type apowr apowr1 apowr2))) - (do ((rslt +empty-list+ (cons apowr1 - (cons apowr2 - rslt))) - (apowr1 (apowr dgop1 gmsm1 -1)) - (apowr2 (apowr dgop2 gmsm2 +1)) - (nark expn (1+ nark))) - ((zerop nark) rslt) - (declare - (list rslt) - (type apowr apowr1 apowr2))))))))))))) + (dgop gmsm expn) apowr + (let ((absm (absm dgop gmsm))) + (declare (type absm absm)) + (let ((face-n (a-face4 face dmns (1+ dmns) absm)) + (face-n+1 (a-face4 face (1+ dmns) (1+ dmns) absm))) + (declare (type absm face-n face-n+1)) + (with-absm + (dgop1 gmsm1) face-n + (with-absm + (dgop2 gmsm2) face-n+1 + (if (logbitp (1- dmns) dgop1) + (if (logbitp (1- dmns) dgop2) + (return-from apowr-lastface4 +empty-list+) + (return-from apowr-lastface4 + (list (apowr dgop2 gmsm2 (- expn))))) + (when (logbitp (1- dmns) dgop2) + (return-from apowr-lastface4 + (list (apowr dgop1 gmsm1 expn))))) + (when (and (= dgop1 dgop2) + (eq :equal (funcall cmpr gmsm1 gmsm2))) + (return-from apowr-lastface4 +empty-list+)) + (case expn + (+1 (list (apowr dgop2 gmsm2 -1) (apowr dgop1 gmsm1 + +1))) + (-1 (list (apowr dgop1 gmsm1 -1) (apowr dgop2 gmsm2 + +1))) + (otherwise + (if (plusp expn) + (do ((rslt +empty-list+ (cons apowr2 + (cons apowr1 + rslt))) + (apowr1 (apowr dgop1 gmsm1 +1)) + (apowr2 (apowr dgop2 gmsm2 -1)) + (nark expn (1- nark))) + ((zerop nark) rslt) + (declare + (list rslt) + (type apowr apowr1 apowr2))) + (do ((rslt +empty-list+ (cons apowr1 + (cons apowr2 + rslt))) + (apowr1 (apowr dgop1 gmsm1 -1)) + (apowr2 (apowr dgop2 gmsm2 +1)) + (nark expn (1+ nark))) + ((zerop nark) rslt) + (declare + (list rslt) + (type apowr apowr1 apowr2))))))))))))) (DEFUN LOOP-SPACE-FACE (cmpr face) @@ -199,27 +201,27 @@ (type cmprf cmpr) (type face face)) (flet ((rslt (indx dmns loop) - (declare - (fixnum indx dmns) - (type loop loop)) - (the absm + (declare + (fixnum indx dmns) + (type loop loop)) + (the absm (let ((rslt +empty-list+)) - (declare (type iloop rslt)) - (if (< indx dmns) + (declare (type iloop rslt)) + (if (< indx dmns) (dolist (apowr (loop-list loop)) - (declare (type apowr apowr)) - (let ((lface (apowr-face4 face indx dmns apowr))) - (declare (type (or null apowr) lface)) - (when lface (setf rslt (apowr-niloop cmpr lface - rslt))))) + (declare (type apowr apowr)) + (let ((lface (apowr-face4 face indx dmns apowr))) + (declare (type (or null apowr) lface)) + (when lface (setf rslt (apowr-niloop cmpr lface + rslt))))) (dolist (apowr (loop-list loop)) - (declare (type apowr apowr)) - (let ((lface (apowr-lastface4 cmpr face dmns apowr))) - (declare (list lface)) - (dolist (apowr lface) - (declare (type apowr apowr)) - (setf rslt (apowr-niloop cmpr apowr rslt)))))) - (normalize-loop (1- dmns) (nreverse rslt)))))) + (declare (type apowr apowr)) + (let ((lface (apowr-lastface4 cmpr face dmns apowr))) + (declare (list lface)) + (dolist (apowr lface) + (declare (type apowr apowr)) + (setf rslt (apowr-niloop cmpr apowr rslt)))))) + (normalize-loop (1- dmns) (nreverse rslt)))))) (the face #'rslt))) @@ -228,27 +230,27 @@ (type cmprf cmpr) (type face face)) (flet ((rslt (indx dmns loop) - (declare - (fixnum indx dmns) - (type loop loop)) - (the (or loop (eql :degenerate)) + (declare + (fixnum indx dmns) + (type loop loop)) + (the (or loop (eql :degenerate)) (let ((rslt +empty-list+)) - (declare (type iloop rslt)) - (if (< indx dmns) + (declare (type iloop rslt)) + (if (< indx dmns) (dolist (apowr (loop-list loop)) - (declare (type apowr apowr)) - (let ((lface (apowr-face4 face indx dmns apowr))) - (declare (type (or null apowr) lface)) - (when lface (setf rslt (apowr-niloop cmpr lface - rslt))))) + (declare (type apowr apowr)) + (let ((lface (apowr-face4 face indx dmns apowr))) + (declare (type (or null apowr) lface)) + (when lface (setf rslt (apowr-niloop cmpr lface + rslt))))) (dolist (apowr (loop-list loop)) - (declare (type apowr apowr)) - (let ((lface (apowr-lastface4 cmpr face dmns apowr))) - (declare (list lface)) - (dolist (apowr lface) - (declare (type apowr apowr)) - (setf rslt (apowr-niloop cmpr apowr rslt)))))) - (if (zerop (apply #'logand (mapcar #'car rslt))) + (declare (type apowr apowr)) + (let ((lface (apowr-lastface4 cmpr face dmns apowr))) + (declare (list lface)) + (dolist (apowr lface) + (declare (type apowr apowr)) + (setf rslt (apowr-niloop cmpr apowr rslt)))))) + (if (zerop (apply #'logand (mapcar #'car rslt))) (make-loop :list (nreverse rslt)) :degenerate))))) (the face* #'rslt))) @@ -260,52 +262,52 @@ (type loop loop)) (the absm (absm 0 (make-loop - :list (mapcar #'(lambda (apowr) - (declare (type apowr apowr)) - (with-apowr (dgop gmsm expn) apowr - (apowr dgop gmsm (- expn)))) - (reverse (loop-list loop))))))) + :list (mapcar #'(lambda (apowr) + (declare (type apowr apowr)) + (with-apowr (dgop gmsm expn) apowr + (apowr dgop gmsm (- expn)))) + (reverse (loop-list loop))))))) (DEFUN LOOP-SPACE-GRML-SINTR (cmpr) (declare (type cmprf cmpr)) (flet ((rslt (dmns crpr) - (declare - (fixnum dmns) - (type crpr crpr)) - (the absm - (with-crpr - (absm1 absm2) crpr - (let ((niloop1 (nreverse (unnormalize-loop absm1))) - (niloop2 (unnormalize-loop absm2))) - (declare (type iloop niloop1 niloop2)) - (loop - (unless niloop1 (return)) - (unless niloop2 (return)) - (let ((apowr1 (first niloop1)) - (apowr2 (first niloop2))) - (declare (type apowr apowr1 apowr2)) - (with-apowr - (dgop1 gmsm1 expn1) apowr1 - (with-apowr - (dgop2 gmsm2 expn2) apowr2 - (unless (and (= dgop1 dgop2) - (eq :equal (funcall cmpr - gmsm1 - gmsm2))) - (return)) - (incf expn1 expn2) - (cond ((zerop expn1) - (pop niloop1) - (pop niloop2)) - (t - (pop niloop1) - (setf niloop2 - (cons (apowr dgop2 gmsm2 expn1) - (rest niloop2))) - (return))))))) - (normalize-loop dmns - (nreconc niloop1 niloop2))))))) + (declare + (fixnum dmns) + (type crpr crpr)) + (the absm + (with-crpr + (absm1 absm2) crpr + (let ((niloop1 (nreverse (unnormalize-loop absm1))) + (niloop2 (unnormalize-loop absm2))) + (declare (type iloop niloop1 niloop2)) + (loop + (unless niloop1 (return)) + (unless niloop2 (return)) + (let ((apowr1 (first niloop1)) + (apowr2 (first niloop2))) + (declare (type apowr apowr1 apowr2)) + (with-apowr + (dgop1 gmsm1 expn1) apowr1 + (with-apowr + (dgop2 gmsm2 expn2) apowr2 + (unless (and (= dgop1 dgop2) + (eq :equal (funcall cmpr + gmsm1 + gmsm2))) + (return)) + (incf expn1 expn2) + (cond ((zerop expn1) + (pop niloop1) + (pop niloop2)) + (t + (pop niloop1) + (setf niloop2 + (cons (apowr dgop2 gmsm2 expn1) + (rest niloop2))) + (return))))))) + (normalize-loop dmns + (nreconc niloop1 niloop2))))))) (the sintr #'rslt))) @@ -315,20 +317,20 @@ (fixnum n)) (the simplicial-group (if (= n 1) - (with-slots (cmpr face) smst - (declare - (type cmprf cmpr) - (type face face)) - (build-smgr - :cmpr (loop-space-cmpr cmpr) - :basis :locally-effective - :bspn +null-loop+ - :face (loop-space-face cmpr face) - :face* (loop-space-face* cmpr face) - :sintr-grml (loop-space-grml-sintr cmpr) - :sintr-grin #'loop-space-grin-sintr - :orgn `(loop-space ,smst))) - (loop-space (loop-space smst) (1- n))))) + (with-slots (cmpr face) smst + (declare + (type cmprf cmpr) + (type face face)) + (build-smgr + :cmpr (loop-space-cmpr cmpr) + :basis :locally-effective + :bspn +null-loop+ + :face (loop-space-face cmpr face) + :face* (loop-space-face* cmpr face) + :sintr-grml (loop-space-grml-sintr cmpr) + :sintr-grin #'loop-space-grin-sintr + :orgn `(loop-space ,smst))) + (loop-space (loop-space smst) (1- n))))) (DEFUN GDELTAB () diff --git a/src/lp-space-efhm.lisp b/src/lp-space-efhm.lisp index 525b6e2..a1f4787 100644 --- a/src/lp-space-efhm.lisp +++ b/src/lp-space-efhm.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; LP-SPACE-EFHM LP-SPACE-EFHM LP-SPACE-EFHM LP-SPACE-EFHM ;;; LP-SPACE-EFHM LP-SPACE-EFHM LP-SPACE-EFHM LP-SPACE-EFHM ;;; LP-SPACE-EFHM LP-SPACE-EFHM LP-SPACE-EFHM LP-SPACE-EFHM @@ -7,9 +9,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 +24,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 + (declare + (fixnum degr) + (type tnpr tnpr)) + (with-tnpr + (degr1 allp1 nil tnpr2) tnpr (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))))))) + (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 +64,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 +89,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 +121,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 +139,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 +221,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 +311,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 +326,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 +406,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 +433,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/src/ls-twisted-products.lisp b/src/ls-twisted-products.lisp index 89c6d47..8c86022 100644 --- a/src/ls-twisted-products.lisp +++ b/src/ls-twisted-products.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; LS-TWISTED-PRODUCTS LS-TWISTED-PRODUCTS LS-TWISTED-PRODUCTS ;;; LS-TWISTED-PRODUCTS LS-TWISTED-PRODUCTS LS-TWISTED-PRODUCTS ;;; LS-TWISTED-PRODUCTS LS-TWISTED-PRODUCTS LS-TWISTED-PRODUCTS @@ -18,57 +20,57 @@ (type absm absm loop-absm)) (the absm (with-absm - (dgop1 gmsm1) absm - (when (logbitp (1- dmns) dgop1) - (return-from absm-loopabsm loop-absm)) - (with-absm - (dgop2 loop2) loop-absm - (let ((iloop2 (loop-list loop2))) - (declare (list iloop2)) - (unless iloop2 - (return-from absm-loopabsm - (absm dgop1 (make-loop :list (list (apowr 0 gmsm1 +1)))))) - (let ((apowr (first iloop2))) - (declare (type apowr apowr)) - (with-apowr - (dgop22 gmsm2 expn2) apowr - (if (and (= dgop1 (dgop*dgop dgop2 dgop22)) - (eq :equal (funcall cmpr gmsm1 gmsm2))) - ;; the absm is eaten by the first component of the loop - (if (= -1 expn2) - ;; the first item of the loop disappears. - (let ((iloop2-rest (rest iloop2))) - (if iloop2-rest - (let ((loop-rest (normalize-loop - (1- dmns) iloop2-rest))) - (declare (type absm loop-rest)) - (absm (dgop*dgop dgop2 (dgop loop-rest)) - (gmsm loop-rest))) - (absm (mask (1- dmns)) +null-loop+))) - ;; the exponent of the first item is increased by 1 - (absm dgop2 (make-loop :list - (cons (apowr dgop22 - gmsm2 - (1+ expn2)) - (rest iloop2))))) - ;; a concatenation must be done - (multiple-value-bind (dgop dgop1 dgop2) - (extract-common-dgop dgop1 dgop2) - (declare (fixnum dgop dgop1 dgop2)) - (absm dgop - (make-loop - :list (cons (apowr dgop1 gmsm1 +1) - (if (zerop dgop2) - iloop2 - (mapcar - #'(lambda (apowr) - (declare - (type apowr apowr)) - (cons (dgop*dgop - dgop2 (apdgop - apowr)) - (cdr apowr))) - iloop2)))))))))))))) + (dgop1 gmsm1) absm + (when (logbitp (1- dmns) dgop1) + (return-from absm-loopabsm loop-absm)) + (with-absm + (dgop2 loop2) loop-absm + (let ((iloop2 (loop-list loop2))) + (declare (list iloop2)) + (unless iloop2 + (return-from absm-loopabsm + (absm dgop1 (make-loop :list (list (apowr 0 gmsm1 +1)))))) + (let ((apowr (first iloop2))) + (declare (type apowr apowr)) + (with-apowr + (dgop22 gmsm2 expn2) apowr + (if (and (= dgop1 (dgop*dgop dgop2 dgop22)) + (eq :equal (funcall cmpr gmsm1 gmsm2))) + ;; the absm is eaten by the first component of the loop + (if (= -1 expn2) + ;; the first item of the loop disappears. + (let ((iloop2-rest (rest iloop2))) + (if iloop2-rest + (let ((loop-rest (normalize-loop + (1- dmns) iloop2-rest))) + (declare (type absm loop-rest)) + (absm (dgop*dgop dgop2 (dgop loop-rest)) + (gmsm loop-rest))) + (absm (mask (1- dmns)) +null-loop+))) + ;; the exponent of the first item is increased by 1 + (absm dgop2 (make-loop :list + (cons (apowr dgop22 + gmsm2 + (1+ expn2)) + (rest iloop2))))) + ;; a concatenation must be done + (multiple-value-bind (dgop dgop1 dgop2) + (extract-common-dgop dgop1 dgop2) + (declare (fixnum dgop dgop1 dgop2)) + (absm dgop + (make-loop + :list (cons (apowr dgop1 gmsm1 +1) + (if (zerop dgop2) + iloop2 + (mapcar + #'(lambda (apowr) + (declare + (type apowr apowr)) + (cons (dgop*dgop + dgop2 (apdgop + apowr)) + (cdr apowr))) + iloop2)))))))))))))) (DEFUN TWISTED-CRTS-PRDC-FACE (cmpr space-face loop-space-face non-twisted-face) @@ -76,52 +78,52 @@ (type cmprf cmpr) (type face space-face loop-space-face non-twisted-face)) (flet ((rslt (indx dmns crpr) - (declare - (fixnum indx dmns) - (type crpr crpr)) - (the absm - (progn - (unless (= indx dmns) - (return-from rslt - (funcall non-twisted-face indx dmns crpr))) - (with-crpr (absm1 absm2) crpr - (let ((face1 (a-face4 space-face dmns dmns absm1)) - (face2 (a-face4 loop-space-face dmns dmns - absm2))) - (declare (type absm face1 face2)) - (setf face2 (absm-loopabsm cmpr dmns absm1 - face2)) - (2absm-acrpr face1 face2))))))) + (declare + (fixnum indx dmns) + (type crpr crpr)) + (the absm + (progn + (unless (= indx dmns) + (return-from rslt + (funcall non-twisted-face indx dmns crpr))) + (with-crpr (absm1 absm2) crpr + (let ((face1 (a-face4 space-face dmns dmns absm1)) + (face2 (a-face4 loop-space-face dmns dmns + absm2))) + (declare (type absm face1 face2)) + (setf face2 (absm-loopabsm cmpr dmns absm1 + face2)) + (2absm-acrpr face1 face2))))))) (the face #'rslt))) (DEFUN TWISTED-CRTS-PRDC (space - &aux (loop-space (loop-space space)) - (crts-prdc (crts-prdc space loop-space))) + &aux (loop-space (loop-space space)) + (crts-prdc (crts-prdc space loop-space))) (declare (type simplicial-set space loop-space crts-prdc)) (the simplicial-set (with-slots ((space-cmpr cmpr) (space-face face)) space (declare - (type cmprf space-cmpr) - (type face space-face)) - (with-slots ((loop-space-face face)) loop-space - (declare (type face loop-space-face)) - (with-slots ((crts-prdc-cmpr cmpr) basis bsgn (crts-prdc-face face)) - crts-prdc - (declare - (type cmprf crts-prdc-cmpr) - (type basis basis) - (type face crts-prdc-face) - (type gmsm bsgn)) - (let ((rslt (build-smst - :cmpr crts-prdc-cmpr - :basis basis - :bspn bsgn - :face (twisted-crts-prdc-face + (type cmprf space-cmpr) + (type face space-face)) + (with-slots ((loop-space-face face)) loop-space + (declare (type face loop-space-face)) + (with-slots ((crts-prdc-cmpr cmpr) basis bsgn (crts-prdc-face face)) + crts-prdc + (declare + (type cmprf crts-prdc-cmpr) + (type basis basis) + (type face crts-prdc-face) + (type gmsm bsgn)) + (let ((rslt (build-smst + :cmpr crts-prdc-cmpr + :basis basis + :bspn bsgn + :face (twisted-crts-prdc-face space-cmpr space-face loop-space-face - crts-prdc-face) - :orgn `(twisted-crts-prdc ,space)))) - (setf (slot-value rslt 'grmd) crts-prdc) - rslt)))))) + crts-prdc-face) + :orgn `(twisted-crts-prdc ,space)))) + (setf (slot-value rslt 'grmd) crts-prdc) + rslt)))))) (DEFUN DTAU-D-INTR (crts-prdc-cmpr crts-prdc-face twisted-crts-prdc-face) @@ -129,93 +131,93 @@ (type cmprf crts-prdc-cmpr) (type face crts-prdc-face twisted-crts-prdc-face)) (flet ((rslt (dmns crpr) - (declare - (fixnum dmns) - (type crpr crpr)) - (when (zerop dmns) - (return-from rslt +zero-negative-cmbn+)) - (the cmbn + (declare + (fixnum dmns) + (type crpr crpr)) + (when (zerop dmns) + (return-from rslt +zero-negative-cmbn+)) + (the cmbn (let ((dmns-1 (1- dmns))) - (declare (fixnum dmns-1)) - (when (logbitp dmns-1 (dgop1 crpr)) - (return-from rslt (zero-cmbn dmns-1))) - (let ((face-tau (funcall twisted-crts-prdc-face dmns dmns - crpr)) - (face (funcall crts-prdc-face dmns dmns crpr)) - (sign (-1-expt-n dmns))) - (declare - (type absm face-tau face) - (fixnum sign)) - (with-absm - (dgop-tau gmsm-tau) face-tau - (with-absm - (dgop gmsm) face - (if (plusp dgop-tau) - (if (plusp dgop) - (zero-cmbn dmns-1) - (term-cmbn dmns-1 (- sign) gmsm)) - (if (plusp dgop) - (term-cmbn dmns-1 sign gmsm-tau) - (ecase (funcall crts-prdc-cmpr gmsm-tau - gmsm) - (:less - (cmbn dmns-1 sign gmsm-tau (- sign) - gmsm)) - (:greater - (cmbn dmns-1 (- sign) gmsm sign - gmsm-tau)) - (:equal - (error "Surprise in DTAU-D-INTR.~@ + (declare (fixnum dmns-1)) + (when (logbitp dmns-1 (dgop1 crpr)) + (return-from rslt (zero-cmbn dmns-1))) + (let ((face-tau (funcall twisted-crts-prdc-face dmns dmns + crpr)) + (face (funcall crts-prdc-face dmns dmns crpr)) + (sign (-1-expt-n dmns))) + (declare + (type absm face-tau face) + (fixnum sign)) + (with-absm + (dgop-tau gmsm-tau) face-tau + (with-absm + (dgop gmsm) face + (if (plusp dgop-tau) + (if (plusp dgop) + (zero-cmbn dmns-1) + (term-cmbn dmns-1 (- sign) gmsm)) + (if (plusp dgop) + (term-cmbn dmns-1 sign gmsm-tau) + (ecase (funcall crts-prdc-cmpr gmsm-tau + gmsm) + (:less + (cmbn dmns-1 sign gmsm-tau (- sign) + gmsm)) + (:greater + (cmbn dmns-1 (- sign) gmsm sign + gmsm-tau)) + (:equal + (error "Surprise in DTAU-D-INTR.~@ Crpr = ~A~@ D-tau = ~A~@ D = ~A" - crpr gmsm-tau gmsm)))))))))))) + crpr gmsm-tau gmsm)))))))))))) (the intr-mrph #'rslt))) (DEFUN DTAU-D (space - &aux (loop-space (loop-space space)) - (crts-prdc (crts-prdc space loop-space)) - (crts-prdc-cmpr (cmpr crts-prdc)) - (crts-prdc-face (face crts-prdc)) - (twisted-crts-prdc (twisted-crts-prdc space)) - (twisted-crts-prdc-face (face twisted-crts-prdc))) + &aux (loop-space (loop-space space)) + (crts-prdc (crts-prdc space loop-space)) + (crts-prdc-cmpr (cmpr crts-prdc)) + (crts-prdc-face (face crts-prdc)) + (twisted-crts-prdc (twisted-crts-prdc space)) + (twisted-crts-prdc-face (face twisted-crts-prdc))) (declare (type simplicial-set space loop-space crts-prdc twisted-crts-prdc) (type cmprf crts-prdc-cmpr) (type face crts-prdc-face twisted-crts-prdc-face)) (the morphism (build-mrph - :sorc crts-prdc :trgt crts-prdc :degr -1 - :intr (dtau-d-intr crts-prdc-cmpr crts-prdc-face - twisted-crts-prdc-face) - :strt :gnrt - :orgn `(dtau-d ,space)))) + :sorc crts-prdc :trgt crts-prdc :degr -1 + :intr (dtau-d-intr crts-prdc-cmpr crts-prdc-face + twisted-crts-prdc-face) + :strt :gnrt + :orgn `(dtau-d ,space)))) (DEFUN SZCZARBA (space - &aux (loop-space (loop-space space)) - (twisted-crts-prdc (twisted-crts-prdc space)) - (ez (ez space loop-space)) - (dtau-d (dtau-d space))) + &aux (loop-space (loop-space space)) + (twisted-crts-prdc (twisted-crts-prdc space)) + (ez (ez space loop-space)) + (dtau-d (dtau-d space))) (declare (type simplicial-set space loop-space twisted-crts-prdc) (type reduction ez) (type morphism dtau-d)) (the (values reduction morphism) (multiple-value-bind (szczarba bottom-perturbation) - (add ez dtau-d) - (with-slots (tcc f g h) szczarba - (setf tcc twisted-crts-prdc - (slot-value f 'sorc) twisted-crts-prdc - (slot-value g 'trgt) twisted-crts-prdc - (slot-value h 'sorc) twisted-crts-prdc - (slot-value h 'trgt) twisted-crts-prdc)) + (add ez dtau-d) + (with-slots (tcc f g h) szczarba + (setf tcc twisted-crts-prdc + (slot-value f 'sorc) twisted-crts-prdc + (slot-value g 'trgt) twisted-crts-prdc + (slot-value h 'sorc) twisted-crts-prdc + (slot-value h 'trgt) twisted-crts-prdc)) (values szczarba bottom-perturbation)))) (DEFUN TWISTED-TNSR-PRDC (space - &aux (szczarba (szczarba space))) + &aux (szczarba (szczarba space))) (declare (type simplicial-set space) (type reduction szczarba)) @@ -231,32 +233,32 @@ (the (values (member -1 0 1) (or nil absm) absm) (progn (unless iloop - (return-from pop-first-absm - (values 0 nil iloop))) + (return-from pop-first-absm + (values 0 nil iloop))) (let ((apowr (first iloop)) (niloop-rest (rest iloop))) - (declare - (type apowr apowr) - (type iloop niloop-rest)) - (with-apowr - (dgop gmsm expn) apowr - (let ((popped-absm (absm dgop gmsm))) - (declare (type absm popped-absm)) - (cond ((< expn -1) - (values -1 popped-absm - (absm 0 - (make-loop - :list (cons (apowr dgop gmsm (1+ expn)) - niloop-rest))))) - ((> expn +1) - (values +1 popped-absm - (absm 0 - (make-loop - :list (cons (apowr dgop gmsm (1- expn)) - niloop-rest))))) - (t - (values expn popped-absm - (normalize-loop dmns niloop-rest)))))))))) + (declare + (type apowr apowr) + (type iloop niloop-rest)) + (with-apowr + (dgop gmsm expn) apowr + (let ((popped-absm (absm dgop gmsm))) + (declare (type absm popped-absm)) + (cond ((< expn -1) + (values -1 popped-absm + (absm 0 + (make-loop + :list (cons (apowr dgop gmsm (1+ expn)) + niloop-rest))))) + ((> expn +1) + (values +1 popped-absm + (absm 0 + (make-loop + :list (cons (apowr dgop gmsm (1- expn)) + niloop-rest))))) + (t + (values expn popped-absm + (normalize-loop dmns niloop-rest)))))))))) @@ -267,109 +269,109 @@ (type face base-face)) (flet ((rslt (n crpr) - (declare - (fixnum n) - (type crpr crpr)) - (the cmbn + (declare + (fixnum n) + (type crpr crpr)) + (the cmbn (let ((n+1 (1+ n))) - (declare (fixnum n+1)) - (labels ( - (hh (x-n g-n) - (declare (type absm x-n g-n)) - (if (bspn-p base-cmpr base-bspn n x-n) - (if (degenerate-p g-n) - (zero-cmbn n+1) - (h-hat (loop-list (gmsm g-n)))) - (if (degenerate-p g-n) - (h-tilde (1dgnr n x-n) g-n) - (2cmbn-add crts-cmpr - (h-hat (loop-list (gmsm g-n))) - (h-tilde (1dgnr n x-n) g-n))))) - (h-tilde (x-n+1 g-n) - (declare (type absm x-n+1 g-n)) - (when (bspn-p base-cmpr base-bspn n+1 x-n+1) - (return-from h-tilde - (zero-cmbn n+1))) - (do ((i n (1- i)) - (dgop 0 (+ dgop (2-exp i))) - (sign (-1-expt-n+1 n) (- sign)) - (del-i x-n+1 (a-face4 base-face i (1+ i) - del-i)) - (rslt (zero-cmbn n+1))) - ((minusp i) rslt) - (declare - (fixnum i dgop sign) - (type absm del-i) - (type cmbn rslt)) - (let ((absm1 (ndgnr dgop del-i)) - (loop-absm2 (1dgnr i g-n))) - (declare (type absm absm1 loop-absm2)) - (unless (plusp (logand (dgop absm1) - (dgop loop-absm2))) - (dstr-add-term-to-cmbn - crts-cmpr - sign (crpr absm1 loop-absm2) - rslt))))) - (h-hat (g-n) - (declare (type iloop g-n)) ;;; *** - (multiple-value-bind (expn y-n+1 gp-n) - (pop-first-absm n g-n) - (declare - (fixnum expn) - (type (or absm null) y-n+1 gp-n)) - (ecase expn - (0 (zero-cmbn (1+ n))) - (+1 - (let ((h-tildes - (2cmbn-sbtr - crts-cmpr (h-tilde y-n+1 gp-n) - (h-tilde (1dgnr n (a-face4 base-face - (1+ n) - (1+ n) - y-n+1)) - (absm 0 (make-loop :list - g-n)))))) - (declare (type cmbn h-tildes)) - (if (degenerate-p gp-n) - h-tildes - (2cmbn-add crts-cmpr - (h-hat (loop-list - (gmsm gp-n))) - h-tildes)))) - (-1 - (let ((next-x-n (a-face4 base-face (1+ n) - (1+ n) y-n+1)) - (h-tilde - (h-tilde y-n+1 - (absm 0 (make-loop - :list g-n))))) - (declare - (type absm next-x-n) - (type cmbn h-tilde)) - (if (zerop (logand (dgop next-x-n) - (dgop gp-n))) - (2cmbn-sbtr crts-cmpr - (hh next-x-n gp-n) h-tilde) - (cmbn-opps h-tilde)))))))) - (with-crpr (absm1 loop-absm2) crpr - (hh absm1 loop-absm2))))))) + (declare (fixnum n+1)) + (labels ( + (hh (x-n g-n) + (declare (type absm x-n g-n)) + (if (bspn-p base-cmpr base-bspn n x-n) + (if (degenerate-p g-n) + (zero-cmbn n+1) + (h-hat (loop-list (gmsm g-n)))) + (if (degenerate-p g-n) + (h-tilde (1dgnr n x-n) g-n) + (2cmbn-add crts-cmpr + (h-hat (loop-list (gmsm g-n))) + (h-tilde (1dgnr n x-n) g-n))))) + (h-tilde (x-n+1 g-n) + (declare (type absm x-n+1 g-n)) + (when (bspn-p base-cmpr base-bspn n+1 x-n+1) + (return-from h-tilde + (zero-cmbn n+1))) + (do ((i n (1- i)) + (dgop 0 (+ dgop (2-exp i))) + (sign (-1-expt-n+1 n) (- sign)) + (del-i x-n+1 (a-face4 base-face i (1+ i) + del-i)) + (rslt (zero-cmbn n+1))) + ((minusp i) rslt) + (declare + (fixnum i dgop sign) + (type absm del-i) + (type cmbn rslt)) + (let ((absm1 (ndgnr dgop del-i)) + (loop-absm2 (1dgnr i g-n))) + (declare (type absm absm1 loop-absm2)) + (unless (plusp (logand (dgop absm1) + (dgop loop-absm2))) + (dstr-add-term-to-cmbn + crts-cmpr + sign (crpr absm1 loop-absm2) + rslt))))) + (h-hat (g-n) + (declare (type iloop g-n)) ;;; *** + (multiple-value-bind (expn y-n+1 gp-n) + (pop-first-absm n g-n) + (declare + (fixnum expn) + (type (or absm null) y-n+1 gp-n)) + (ecase expn + (0 (zero-cmbn (1+ n))) + (+1 + (let ((h-tildes + (2cmbn-sbtr + crts-cmpr (h-tilde y-n+1 gp-n) + (h-tilde (1dgnr n (a-face4 base-face + (1+ n) + (1+ n) + y-n+1)) + (absm 0 (make-loop :list + g-n)))))) + (declare (type cmbn h-tildes)) + (if (degenerate-p gp-n) + h-tildes + (2cmbn-add crts-cmpr + (h-hat (loop-list + (gmsm gp-n))) + h-tildes)))) + (-1 + (let ((next-x-n (a-face4 base-face (1+ n) + (1+ n) y-n+1)) + (h-tilde + (h-tilde y-n+1 + (absm 0 (make-loop + :list g-n))))) + (declare + (type absm next-x-n) + (type cmbn h-tilde)) + (if (zerop (logand (dgop next-x-n) + (dgop gp-n))) + (2cmbn-sbtr crts-cmpr + (hh next-x-n gp-n) h-tilde) + (cmbn-opps h-tilde)))))))) + (with-crpr (absm1 loop-absm2) crpr + (hh absm1 loop-absm2))))))) (the intr-mrph #'rslt))) (DEFUN CRTS-CONTRACTION (space - &aux (twisted-crts-prdc (twisted-crts-prdc space))) + &aux (twisted-crts-prdc (twisted-crts-prdc space))) (declare (type simplicial-set space twisted-crts-prdc)) (the morphism (build-mrph - :sorc twisted-crts-prdc :trgt twisted-crts-prdc :degr +1 - :intr (crts-contraction-intr (cmpr space) (bspn space) (face space) - (cmpr twisted-crts-prdc)) - :strt :gnrt - :orgn `(crts-contraction ,space)))) + :sorc twisted-crts-prdc :trgt twisted-crts-prdc :degr +1 + :intr (crts-contraction-intr (cmpr space) (bspn space) (face space) + (cmpr twisted-crts-prdc)) + :strt :gnrt + :orgn `(crts-contraction ,space)))) (DEFUN TNPR-CONTRACTION (space - &aux + &aux (szczarba (szczarba space)) (f (f szczarba)) (g (g szczarba)) diff --git a/src/macros.lisp b/src/macros.lisp index c9af69a..8bcf0f0 100644 --- a/src/macros.lisp +++ b/src/macros.lisp @@ -1,4 +1,4 @@ -;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* ;;; MACROS MACROS MACROS MACROS MACROS MACROS MACROS ;;; MACROS MACROS MACROS MACROS MACROS MACROS MACROS diff --git a/src/searching-homology.lisp b/src/searching-homology.lisp index 52566e4..95333fd 100644 --- a/src/searching-homology.lisp +++ b/src/searching-homology.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; SEARCHING-HOMOLOGY SEARCHING-HOMOLOGY SEARCHING-HOMOLOGY ;;; SEARCHING-HOMOLOGY SEARCHING-HOMOLOGY SEARCHING-HOMOLOGY ;;; SEARCHING-HOMOLOGY SEARCHING-HOMOLOGY SEARCHING-HOMOLOGY @@ -34,10 +36,10 @@ (declare (ignore class)) (the homotopy-equivalence (let ((efhm (search-efhm chcm (first (orgn chcm))))) - (setf (efhm chcm) - (or efhm - (when (functionp (basis chcm)) - (trivial-hmeq chcm)) - (error "I don't know how to determine ~ + (setf (efhm chcm) + (or efhm + (when (functionp (basis chcm)) + (trivial-hmeq chcm)) + (error "I don't know how to determine ~ the effective homology of:~@ ~A (Origin: ~A)." chcm (orgn chcm))))))) diff --git a/src/serre.lisp b/src/serre.lisp index 4cebacb..9b4ace7 100644 --- a/src/serre.lisp +++ b/src/serre.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; SERRE SERRE SERRE SERRE SERRE SERRE SERRE SERRE SERRE ;;; SERRE SERRE SERRE SERRE SERRE SERRE SERRE SERRE SERRE ;;; SERRE SERRE SERRE SERRE SERRE SERRE SERRE SERRE SERRE @@ -8,14 +10,14 @@ (DEFUN FIBRATION-DTAU-D-INTR (fibration &aux (base (sorc fibration)) - (bface (face base)) - (fibre (trgt fibration)) - (fface (face fibre)) - (sintr-grml (sintr (grml fibre))) - (fbspn (bspn fibre)) - (sintr-twist (sintr fibration)) - (total (fibration-total fibration)) - (total-cmpr (cmpr total))) + (bface (face base)) + (fibre (trgt fibration)) + (fface (face fibre)) + (sintr-grml (sintr (grml fibre))) + (fbspn (bspn fibre)) + (sintr-twist (sintr fibration)) + (total (fibration-total fibration)) + (total-cmpr (cmpr total))) (declare (type fibration fibration) (type simplicial-set base total) @@ -26,80 +28,80 @@ (type cmprf total-cmpr)) (flet ((rslt (dmns crpr &aux (dmns-1 (1- dmns))) - (declare - (fixnum dmns dmns-1) - (type crpr crpr)) - (unless (plusp dmns) - (return-from rslt - (zero-cmbn dmns-1))) - (with-crpr - (b-absm f-absm) crpr - (let ((tau-b - (tw-a-sintr3 sintr-twist dmns - b-absm fbspn))) - (declare (type absm tau-b)) - (when (= (dgop tau-b) (mask dmns-1)) - (return-from rslt - (zero-cmbn dmns-1))) - (let ((deln-b - (a-face4 bface dmns dmns - b-absm)) - (deln-f - (a-face4 fface dmns dmns - f-absm))) - (declare - (type absm deln-b deln-f tau-b)) - (let ((acrpr1 (2absm-acrpr deln-b deln-f)) - (acrpr2 - (2absm-acrpr - deln-b - (a-grml4 sintr-grml (1- dmns) - tau-b deln-f)))) - (declare (type absm acrpr1 acrpr2)) - (with-absm - (dgop1 crpr1) acrpr1 - (with-absm - (dgop2 crpr2) acrpr2 - (if (zerop dgop1) - (if (zerop dgop2) - (dstr-add-term-to-cmbn - total-cmpr - (-1-expt-n+1 dmns) crpr1 - (term-cmbn dmns-1 - (-1-expt-n dmns) - crpr2)) - (term-cmbn dmns-1 - (-1-expt-n+1 dmns) - crpr1)) - (if (zerop dgop2) - (term-cmbn dmns-1 - (-1-expt-n dmns) - crpr2) - (zero-cmbn dmns-1))))))))))) + (declare + (fixnum dmns dmns-1) + (type crpr crpr)) + (unless (plusp dmns) + (return-from rslt + (zero-cmbn dmns-1))) + (with-crpr + (b-absm f-absm) crpr + (let ((tau-b + (tw-a-sintr3 sintr-twist dmns + b-absm fbspn))) + (declare (type absm tau-b)) + (when (= (dgop tau-b) (mask dmns-1)) + (return-from rslt + (zero-cmbn dmns-1))) + (let ((deln-b + (a-face4 bface dmns dmns + b-absm)) + (deln-f + (a-face4 fface dmns dmns + f-absm))) + (declare + (type absm deln-b deln-f tau-b)) + (let ((acrpr1 (2absm-acrpr deln-b deln-f)) + (acrpr2 + (2absm-acrpr + deln-b + (a-grml4 sintr-grml (1- dmns) + tau-b deln-f)))) + (declare (type absm acrpr1 acrpr2)) + (with-absm + (dgop1 crpr1) acrpr1 + (with-absm + (dgop2 crpr2) acrpr2 + (if (zerop dgop1) + (if (zerop dgop2) + (dstr-add-term-to-cmbn + total-cmpr + (-1-expt-n+1 dmns) crpr1 + (term-cmbn dmns-1 + (-1-expt-n dmns) + crpr2)) + (term-cmbn dmns-1 + (-1-expt-n+1 dmns) + crpr1)) + (if (zerop dgop2) + (term-cmbn dmns-1 + (-1-expt-n dmns) + crpr2) + (zero-cmbn dmns-1))))))))))) (the intr-mrph #'rslt))) (DEFUN FIBRATION-DTAU-D (fibration - &aux (base (sorc fibration)) - (fibre (trgt fibration)) - (utotal (crts-prdc base fibre))) + &aux (base (sorc fibration)) + (fibre (trgt fibration)) + (utotal (crts-prdc base fibre))) (declare (type fibration fibration)) (the morphism (build-mrph :sorc utotal - :trgt utotal - :degr -1 - :intr (fibration-dtau-d-intr fibration) - :strt :gnrt - :orgn `(fibration-dtau-d ,fibration)))) + :trgt utotal + :degr -1 + :intr (fibration-dtau-d-intr fibration) + :strt :gnrt + :orgn `(fibration-dtau-d ,fibration)))) (DEFUN BROWN-REDUCTION (fibration - &aux (base (sorc fibration)) - (fibre (trgt fibration)) - (total (fibration-total fibration)) - (ez (eilenberg-zilber base fibre)) - (t-perturbation (fibration-dtau-d fibration))) + &aux (base (sorc fibration)) + (fibre (trgt fibration)) + (total (fibration-total fibration)) + (ez (eilenberg-zilber base fibre)) + (t-perturbation (fibration-dtau-d fibration))) (declare (type fibration fibration) (type simplicial-set base fibre total) @@ -107,15 +109,15 @@ (type morphism t-perturbation)) (the (values reduction morphism) (multiple-value-bind (rslt b-perturbation) (add ez t-perturbation) - (declare - (type reduction rslt) - (type morphism b-perturbation)) - (with-slots (f g h tcc) rslt - (setf tcc total) - (dstr-change-sorc-trgt f :new-sorc total) - (dstr-change-sorc-trgt g :new-trgt total) - (dstr-change-sorc-trgt h :new-sorc total :new-trgt total) - (values rslt b-perturbation))))) + (declare + (type reduction rslt) + (type morphism b-perturbation)) + (with-slots (f g h tcc) rslt + (setf tcc total) + (dstr-change-sorc-trgt f :new-sorc total) + (dstr-change-sorc-trgt g :new-trgt total) + (dstr-change-sorc-trgt h :new-sorc total :new-trgt total) + (values rslt b-perturbation))))) (DEFUN LEFT-SERRE-EFHM (fibration) @@ -123,49 +125,49 @@ (the homotopy-equivalence (build-hmeq :lrdct (trivial-rdct (fibration-total fibration)) - :rrdct (brown-reduction fibration)))) + :rrdct (brown-reduction fibration)))) (DEFUN RIGHT-SERRE-EFHM (fibration - &aux (base (sorc fibration)) - (fibre (trgt fibration)) - (base-efhm (efhm base)) - (fibre-efhm (efhm fibre)) - (uprdc-efhm (tnsr-prdc base-efhm fibre-efhm))) + &aux (base (sorc fibration)) + (fibre (trgt fibration)) + (base-efhm (efhm base)) + (fibre-efhm (efhm fibre)) + (uprdc-efhm (tnsr-prdc base-efhm fibre-efhm))) (declare (type fibration fibration) (type simplicial-set base fibre) (type homotopy-equivalence base-efhm fibre-efhm uprdc-efhm)) (the homotopy-equivalence (multiple-value-bind (brown b-perturbation) (brown-reduction fibration) - (declare - (type reduction brown) - (type morphism b-perturbation)) - (let ((rslt (add uprdc-efhm b-perturbation))) - (declare (type homotopy-equivalence rslt)) - (with-slots (lbcc lf lg lrdct) rslt - (declare - (type chain-complex lbcc) - (type morphism lf lg) - (type reduction lrdct)) - (setf lbcc (bcc brown)) - (dstr-change-sorc-trgt lf :new-trgt lbcc) - (dstr-change-sorc-trgt lg :new-sorc lbcc) - (with-slots (bcc f g) lrdct - (declare - (type chain-complex bcc) - (type morphism f g)) - (setf bcc lbcc) - (dstr-change-sorc-trgt f :new-trgt lbcc) - (dstr-change-sorc-trgt g :new-sorc lbcc))) - rslt)))) + (declare + (type reduction brown) + (type morphism b-perturbation)) + (let ((rslt (add uprdc-efhm b-perturbation))) + (declare (type homotopy-equivalence rslt)) + (with-slots (lbcc lf lg lrdct) rslt + (declare + (type chain-complex lbcc) + (type morphism lf lg) + (type reduction lrdct)) + (setf lbcc (bcc brown)) + (dstr-change-sorc-trgt lf :new-trgt lbcc) + (dstr-change-sorc-trgt lg :new-sorc lbcc) + (with-slots (bcc f g) lrdct + (declare + (type chain-complex bcc) + (type morphism f g)) + (setf bcc lbcc) + (dstr-change-sorc-trgt f :new-trgt lbcc) + (dstr-change-sorc-trgt g :new-sorc lbcc))) + rslt)))) (DEFUN FIBRATION-TOTAL-EFHM (fibration) (declare (type fibration fibration)) (the homotopy-equivalence (cmps (left-serre-efhm fibration) - (right-serre-efhm fibration)))) + (right-serre-efhm fibration)))) (DEFMETHOD SEARCH-EFHM (smst (orgn (eql 'fibration-total))) diff --git a/src/simplicial-groups.lisp b/src/simplicial-groups.lisp index 421ddc6..3cb6438 100644 --- a/src/simplicial-groups.lisp +++ b/src/simplicial-groups.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; SIMPLICIAL-GROUPS SIMPLICIAL-GROUPS SIMPLICIAL-GROUPS ;;; SIMPLICIAL-GROUPS SIMPLICIAL-GROUPS SIMPLICIAL-GROUPS ;;; SIMPLICIAL-GROUPS SIMPLICIAL-GROUPS SIMPLICIAL-GROUPS @@ -18,8 +20,8 @@ (DEFMETHOD PRINT-OBJECT ((smgr simplicial-group) stream) (the simplicial-group (progn - (format stream "[K~D Simplicial-Group]" (idnm smgr)) - smgr))) + (format stream "[K~D Simplicial-Group]" (idnm smgr)) + smgr))) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute) (setf (ext:package-lock :clos) t)) @@ -28,8 +30,8 @@ (DEFMETHOD PRINT-OBJECT ((smgr ab-simplicial-group) stream) (the simplicial-group (progn - (format stream "[K~D Abelian-Simplicial-Group]" (idnm smgr)) - smgr))) + (format stream "[K~D Abelian-Simplicial-Group]" (idnm smgr)) + smgr))) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute) (setf (ext:package-lock :clos) t)) @@ -55,20 +57,20 @@ (when already (return-from build-smgr already))) (let ((rslt (build-smst - :cmpr cmpr :basis basis :bspn bspn - :face face :face* face* :intr-bndr intr-bndr - :bndr-strt bndr-strt :intr-dgnl intr-dgnl - :dgnl-strt dgnl-strt :orgn orgn))) + :cmpr cmpr :basis basis :bspn bspn + :face face :face* face* :intr-bndr intr-bndr + :bndr-strt bndr-strt :intr-dgnl intr-dgnl + :dgnl-strt dgnl-strt :orgn orgn))) (declare (type simplicial-set rslt)) (change-class rslt 'simplicial-group) (setf (slot-value rslt 'grml) - (build-smmr - :sorc (crts-prdc rslt rslt) :trgt rslt :degr 0 - :sintr sintr-grml :orgn `(group-multiplication ,rslt)) - (slot-value rslt 'grin) - (build-smmr - :sorc rslt :trgt rslt :degr 0 - :sintr sintr-grin :orgn `(group-inversion ,rslt))) + (build-smmr + :sorc (crts-prdc rslt rslt) :trgt rslt :degr 0 + :sintr sintr-grml :orgn `(group-multiplication ,rslt)) + (slot-value rslt 'grin) + (build-smmr + :sorc rslt :trgt rslt :degr 0 + :sintr sintr-grin :orgn `(group-inversion ,rslt))) (push rslt *smgr-list*) rslt)) @@ -79,12 +81,12 @@ (type absm absm1 absm2)) (the absm (let ((acrpr (2absm-acrpr absm1 absm2))) - (declare (type absm acrpr)) - (with-absm (dgop crpr) acrpr - (ndgnr dgop - (funcall sintr-grml - (- dmns (logcount dgop)) - crpr)))))) + (declare (type absm acrpr)) + (with-absm (dgop crpr) acrpr + (ndgnr dgop + (funcall sintr-grml + (- dmns (logcount dgop)) + crpr)))))) (DEFUN A-GRIN4 (sintr-grin dmns absm) @@ -94,73 +96,73 @@ (type absm absm)) (the absm (with-absm (dgop gmsm) absm - (absm dgop - (gmsm - (funcall sintr-grin (- dmns (logcount dgop)) - gmsm)))))) + (absm dgop + (gmsm + (funcall sintr-grin (- dmns (logcount dgop)) + gmsm)))))) (DEFMETHOD SLOT-UNBOUND (class (smgr simplicial-group) - (name (eql 'kfll))) + (name (eql 'kfll))) (declare (ignore class)) (the kfll (progn - (push smgr *kan-list*) - (setf (slot-value smgr 'kfll) (smgr-kfll smgr))))) + (push smgr *kan-list*) + (setf (slot-value smgr 'kfll) (smgr-kfll smgr))))) (DEFUN SMGR-KFLL-INTR (face sintr-grml sintr-grin) (flet ((rslt (indx dmns hat - &aux (dmns-1 (1- dmns))) - (declare - (fixnum indx dmns dmns-1) - (list hat)) - (the absm - (let ((rslt (absm 0 nil))) - (declare (type absm rslt)) - (when (plusp indx) - (setf rslt (1dgnr 0 (pop hat))) - (do ((i 1 (1+ i))) - ((= i indx)) - (declare (fixnum i)) - (setf rslt - (a-grml4 - sintr-grml dmns - rslt - (1dgnr i - (a-grml4 - sintr-grml dmns-1 - (a-grin4 - sintr-grin dmns-1 - (a-face4 face - i dmns rslt)) - (pop hat))))))) - (when (< indx dmns) - (setf hat (reverse hat)) - (when (zerop indx) - (setf rslt (1dgnr dmns-1 (pop hat)))) - (do ((i (if (zerop indx) - dmns-1 - dmns) - (1- i))) - ((endp hat) rslt) - (declare - (type absm rslt) - (fixnum i)) - (setf rslt - (a-grml4 - sintr-grml dmns - rslt - (1dgnr (1- i) - (a-grml4 - sintr-grml dmns-1 - (a-grin4 - sintr-grin dmns-1 - (a-face4 - face - i dmns rslt)) - (pop hat))))))) - rslt)))) + &aux (dmns-1 (1- dmns))) + (declare + (fixnum indx dmns dmns-1) + (list hat)) + (the absm + (let ((rslt (absm 0 nil))) + (declare (type absm rslt)) + (when (plusp indx) + (setf rslt (1dgnr 0 (pop hat))) + (do ((i 1 (1+ i))) + ((= i indx)) + (declare (fixnum i)) + (setf rslt + (a-grml4 + sintr-grml dmns + rslt + (1dgnr i + (a-grml4 + sintr-grml dmns-1 + (a-grin4 + sintr-grin dmns-1 + (a-face4 face + i dmns rslt)) + (pop hat))))))) + (when (< indx dmns) + (setf hat (reverse hat)) + (when (zerop indx) + (setf rslt (1dgnr dmns-1 (pop hat)))) + (do ((i (if (zerop indx) + dmns-1 + dmns) + (1- i))) + ((endp hat) rslt) + (declare + (type absm rslt) + (fixnum i)) + (setf rslt + (a-grml4 + sintr-grml dmns + rslt + (1dgnr (1- i) + (a-grml4 + sintr-grml dmns-1 + (a-grin4 + sintr-grin dmns-1 + (a-face4 + face + i dmns rslt)) + (pop hat))))))) + rslt)))) (the kfll #'rslt))) @@ -174,20 +176,20 @@ (DEFMETHOD SLOT-UNBOUND (class (smgr simplicial-group) - (name (eql 'aprd))) + (name (eql 'aprd))) (declare (ignore class)) (the morphism (progn - (push smgr *hopf-list*) - (setf (slot-value smgr 'aprd) (smgr-aprd smgr))))) + (push smgr *hopf-list*) + (setf (slot-value smgr 'aprd) (smgr-aprd smgr))))) (DEFUN SMGR-APRD (smgr) (declare (type simplicial-group smgr)) (the morphism (let ((eml (eml smgr smgr)) - (grml (grml smgr))) - (declare - (type morphism eml) - (type simplicial-mrph grml)) - (cmps grml eml)))) + (grml (grml smgr))) + (declare + (type morphism eml) + (type simplicial-mrph grml)) + (cmps grml eml)))) diff --git a/src/simplicial-mrphs.lisp b/src/simplicial-mrphs.lisp index a548a26..ea2c073 100644 --- a/src/simplicial-mrphs.lisp +++ b/src/simplicial-mrphs.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; SIMPLICIAL-MRPHS SIMPLICIAL-MRPHS SIMPLICIAL-MRPHS ;;; SIMPLICIAL-MRPHS SIMPLICIAL-MRPHS SIMPLICIAL-MRPHS ;;; SIMPLICIAL-MRPHS SIMPLICIAL-MRPHS SIMPLICIAL-MRPHS @@ -13,10 +15,10 @@ (typecase absm-or-gmsm (absm (with-absm (dgop gmsm) absm-or-gmsm - (let ((gmsm-smmr (funcall (sintr smmr) - (- dmns (logcount dgop)) gmsm))) - (declare (type absm gmsm-smmr)) - (ndgnr dgop gmsm-smmr)))) + (let ((gmsm-smmr (funcall (sintr smmr) + (- dmns (logcount dgop)) gmsm))) + (declare (type absm gmsm-smmr)) + (ndgnr dgop gmsm-smmr)))) (otherwise (funcall (sintr smmr) dmns absm-or-gmsm)))) @@ -26,12 +28,12 @@ (DEFMETHOD PRINT-OBJECT ((smmr simplicial-mrph) stream) (the simplicial-mrph (progn - (if (= -1 (degr smmr)) - (format stream "[K~D Fibration K~D -> K~D]" - (idnm smmr) (idnm (sorc smmr)) (idnm (trgt smmr))) - (format stream "[K~D Simplicial-Morphism K~D -> K~D]" - (idnm smmr) (idnm (sorc smmr)) (idnm (trgt smmr)))) - smmr))) + (if (= -1 (degr smmr)) + (format stream "[K~D Fibration K~D -> K~D]" + (idnm smmr) (idnm (sorc smmr)) (idnm (trgt smmr))) + (format stream "[K~D Simplicial-Morphism K~D -> K~D]" + (idnm smmr) (idnm (sorc smmr)) (idnm (trgt smmr)))) + smmr))) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute) (setf (ext:package-lock :clos) t)) @@ -45,16 +47,16 @@ (DEFUN SINTR-INTR (sintr) (declare (type sintr sintr)) (flet ((rslt (dmns gmsm) - (declare - (fixnum dmns) - (type gmsm gmsm)) - (when (minusp dmns) - (return-from rslt (zero-cmbn dmns))) - (let ((rslt (funcall sintr dmns gmsm))) - (declare (type absm rslt)) - (if (degenerate-p rslt) - (zero-cmbn dmns) - (term-cmbn dmns 1 (gmsm rslt)))))) + (declare + (fixnum dmns) + (type gmsm gmsm)) + (when (minusp dmns) + (return-from rslt (zero-cmbn dmns))) + (let ((rslt (funcall sintr dmns gmsm))) + (declare (type absm rslt)) + (if (degenerate-p rslt) + (zero-cmbn dmns) + (term-cmbn dmns 1 (gmsm rslt)))))) (the intr-mrph #'rslt))) @@ -68,26 +70,26 @@ (list orgn)) (the simplicial-mrph (progn - (let ((already (find orgn *smmr-list* :test #'equal :key #'orgn))) - (declare (type (or simplicial-mrph null) already)) - (when already - (return-from build-smmr already))) - (if (zerop degr) - (if intr - (unless strt - (error "In BUILD-SMMR, an intr is given but not its strt")) - (setf strt :gnrt - intr (sintr-intr sintr))) - (setf intr nil strt :gnrt)) - (let ((rslt (build-mrph - :sorc sorc :trgt trgt :degr degr - :intr intr :strt strt - :orgn orgn))) - (declare (type morphism rslt)) - (change-class rslt 'simplicial-mrph) - (setf (slot-value rslt 'sintr) sintr) - (push rslt *smmr-list*) - rslt)))) + (let ((already (find orgn *smmr-list* :test #'equal :key #'orgn))) + (declare (type (or simplicial-mrph null) already)) + (when already + (return-from build-smmr already))) + (if (zerop degr) + (if intr + (unless strt + (error "In BUILD-SMMR, an intr is given but not its strt")) + (setf strt :gnrt + intr (sintr-intr sintr))) + (setf intr nil strt :gnrt)) + (let ((rslt (build-mrph + :sorc sorc :trgt trgt :degr degr + :intr intr :strt strt + :orgn orgn))) + (declare (type morphism rslt)) + (change-class rslt 'simplicial-mrph) + (setf (slot-value rslt 'sintr) sintr) + (push rslt *smmr-list*) + rslt)))) #| ???? @@ -98,7 +100,7 @@ (type iabsm iabsm)) (the absm (with-iabsm (dgop gmsm) iabsm - (ndgnr dgop (funcall sintr (- dmns (logcount dgop)) gmsm))))) + (ndgnr dgop (funcall sintr (- dmns (logcount dgop)) gmsm))))) (DEFUN A-SINTR3 (sintr dmns absm) (declare @@ -107,7 +109,7 @@ (type absm absm)) (the absm (with-absm (dgop gmsm) absm - (ndgnr dgop (funcall sintr (- dmns (logcount dgop)) gmsm))))) + (ndgnr dgop (funcall sintr (- dmns (logcount dgop)) gmsm))))) |# ;;; ???? @@ -119,13 +121,13 @@ (type gmsm bspn)) (the absm (with-absm (dgop gmsm) absm - (let ((dmns-1 (1- dmns))) - (declare (fixnum dmns-1)) - (if (logbitp dmns-1 dgop) - (absm (mask dmns-1) bspn) - (ndgnr dgop (funcall sintr - (- dmns (logcount dgop)) - gmsm))))))) + (let ((dmns-1 (1- dmns))) + (declare (fixnum dmns-1)) + (if (logbitp dmns-1 dgop) + (absm (mask dmns-1) bspn) + (ndgnr dgop (funcall sintr + (- dmns (logcount dgop)) + gmsm))))))) #| (DEFUN TW-IA-SINTR3 (sintr dmns iabsm bspn) @@ -136,11 +138,11 @@ (type gmsm bspn)) (the absm (with-iabsm (dgop gmsm) iabsm - (let ((dmns-1 (1- dmns))) - (declare (fixnum dmns-1)) - (if (logbitp dmns-1 dgop) - (absm (mask dmns-1) bspn) - (ndgnr dgop (funcall sintr - (- dmns (logcount dgop)) - gmsm))))))) + (let ((dmns-1 (1- dmns))) + (declare (fixnum dmns-1)) + (if (logbitp dmns-1 dgop) + (absm (mask dmns-1) bspn) + (ndgnr dgop (funcall sintr + (- dmns (logcount dgop)) + gmsm))))))) |# diff --git a/src/simplicial-sets.lisp b/src/simplicial-sets.lisp index a1b2cd3..270c12e 100644 --- a/src/simplicial-sets.lisp +++ b/src/simplicial-sets.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; SIMPLICIAL-SETS SIMPLICIAL-SETS SIMPLICIAL-SETS ;;; SIMPLICIAL-SETS SIMPLICIAL-SETS SIMPLICIAL-SETS ;;; SIMPLICIAL-SETS SIMPLICIAL-SETS SIMPLICIAL-SETS @@ -15,10 +17,10 @@ (error "In DGOP-EXT-INT, the external dgop ~A is not decreasing." ext-dgop))) (the fixnum (apply #'logxor (mapcar - #'(lambda (item) - (declare (fixnum item)) - (the fixnum (2-exp item))) - ext-dgop)))) + #'(lambda (item) + (declare (fixnum item)) + (the fixnum (2-exp item))) + ext-dgop)))) (DEFUN DGOP-INT-EXT (dgop) @@ -27,14 +29,14 @@ (error "In DXOP-INT-EXT, ~A is not a dxop." dgop)) (the list (do ((dgop dgop (ash dgop -1)) - (rslt +empty-list+) - (bmark 0 (1+ bmark))) - ((zerop dgop) rslt) + (rslt +empty-list+) + (bmark 0 (1+ bmark))) + ((zerop dgop) rslt) (declare - (fixnum dgop bmark) - (list rslt)) + (fixnum dgop bmark) + (list rslt)) (when (oddp dgop) - (push bmark rslt))))) + (push bmark rslt))))) (DEFUN HYPHENIZE-LIST (list) @@ -50,9 +52,9 @@ (type stream stream) (ignore depth)) (format stream - "" - (hyphenize-list (dgop-int-ext (dgop absm))) - (gmsm absm)) + "" + (hyphenize-list (dgop-int-ext (dgop absm))) + (gmsm absm)) absm) @@ -68,7 +70,7 @@ (the simplicial-set (progn (format stream "[K~D Simplicial-Set]" (idnm smst)) - smst))) + smst))) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute) (setf (ext:package-lock :clos) t)) @@ -97,24 +99,24 @@ (return-from build-smst already))) (if intr-bndr (unless bndr-strt - (error "In BUILD-SMST, an intr-bndr is given but not its strategy.")) + (error "In BUILD-SMST, an intr-bndr is given but not its strategy.")) (cond (face* - (setf bndr-strt :gnrt - intr-bndr (face*-bndr cmpr face*))) + (setf bndr-strt :gnrt + intr-bndr (face*-bndr cmpr face*))) (face - (setf bndr-strt :gnrt - intr-bndr (face-bndr cmpr face))))) + (setf bndr-strt :gnrt + intr-bndr (face-bndr cmpr face))))) (if intr-dgnl (unless dgnl-strt - (error "In BUILD-SMST, an intr-dgnl is given but not its strategy.")) + (error "In BUILD-SMST, an intr-dgnl is given but not its strategy.")) (setf dgnl-strt :gnrt intr-dgnl (intr-diagonal face))) (the simplicial-set (let ((rslt (build-chcm :cmpr cmpr :basis basis :bsgn bspn - :intr-dffr intr-bndr - :strt bndr-strt :orgn orgn))) + :intr-dffr intr-bndr + :strt bndr-strt :orgn orgn))) (change-chcm-to-clgb rslt - :intr-cprd intr-dgnl :cprd-strt dgnl-strt) + :intr-cprd intr-dgnl :cprd-strt dgnl-strt) (setf (slot-value (dgnl rslt) 'orgn) `(diagonal ,rslt)) (change-class rslt 'simplicial-set) @@ -129,53 +131,53 @@ (fixnum dmns)) (the list (let ((basis-array (make-array (1+ dmns) :element-type 'list))) - (declare (type (vector list) basis-array)) - (dotimes (i (1+ dmns)) - (declare (fixnum i)) - (setf (aref basis-array i) (funcall basis i))) - (do ((dgop (mask dmns) (1- dgop)) - (rslt +empty-list+ - (nconc (mapcar - #'(lambda (gmsm) - (declare (type gmsm gmsm)) - (absm dgop gmsm)) - (aref basis-array (- dmns (logcount dgop)))) - rslt))) - ((minusp dgop) rslt))))) + (declare (type (vector list) basis-array)) + (dotimes (i (1+ dmns)) + (declare (fixnum i)) + (setf (aref basis-array i) (funcall basis i))) + (do ((dgop (mask dmns) (1- dgop)) + (rslt +empty-list+ + (nconc (mapcar + #'(lambda (gmsm) + (declare (type gmsm gmsm)) + (absm dgop gmsm)) + (aref basis-array (- dmns (logcount dgop)))) + rslt))) + ((minusp dgop) rslt))))) (DEFUN INTR-DIAGONAL (face) (declare (type face face)) (flet ((rslt (dmns gmsm) - (declare - (fixnum dmns) - (type gmsm gmsm)) - (the cmbn - (let ((del-0-s +empty-list+) - (rslt +empty-list+)) - (declare (list del-0-s rslt)) - (do ((dmns dmns (1- dmns)) - (absm (absm 0 gmsm) (a-face4 face 0 dmns absm))) - ((zerop dmns) (push absm del-0-s)) - (declare (fixnum dmns) (type absm absm)) - (push absm del-0-s)) - (do ((ldmns dmns (1- ldmns)) - (rdmns 0 (1+ rdmns)) - (absm (absm 0 gmsm) (a-face4 face ldmns ldmns absm)) - (mark-del-0 del-0-s (cdr mark-del-0))) - ((zerop ldmns) - (push (term 1 (tnpr 0 (gmsm absm) dmns gmsm)) - rslt)) - (declare - (fixnum ldmns rdmns) - (type gmsm gmsm) - (list mark-del-0)) - (unless (or (plusp (dgop absm)) - (plusp (dgop (car mark-del-0)))) - (push (term 1 (tnpr ldmns (gmsm absm) - rdmns (gmsm (car mark-del-0)))) - rslt))) - (make-cmbn :degr dmns :list rslt))))) + (declare + (fixnum dmns) + (type gmsm gmsm)) + (the cmbn + (let ((del-0-s +empty-list+) + (rslt +empty-list+)) + (declare (list del-0-s rslt)) + (do ((dmns dmns (1- dmns)) + (absm (absm 0 gmsm) (a-face4 face 0 dmns absm))) + ((zerop dmns) (push absm del-0-s)) + (declare (fixnum dmns) (type absm absm)) + (push absm del-0-s)) + (do ((ldmns dmns (1- ldmns)) + (rdmns 0 (1+ rdmns)) + (absm (absm 0 gmsm) (a-face4 face ldmns ldmns absm)) + (mark-del-0 del-0-s (cdr mark-del-0))) + ((zerop ldmns) + (push (term 1 (tnpr 0 (gmsm absm) dmns gmsm)) + rslt)) + (declare + (fixnum ldmns rdmns) + (type gmsm gmsm) + (list mark-del-0)) + (unless (or (plusp (dgop absm)) + (plusp (dgop (car mark-del-0)))) + (push (term 1 (tnpr ldmns (gmsm absm) + rdmns (gmsm (car mark-del-0)))) + rslt))) + (make-cmbn :degr dmns :list rslt))))) (the intr-mrph #'rslt))) @@ -184,24 +186,24 @@ (type cmprf cmpr) (type face face)) (flet ((rslt (dmns gmsm) - (declare - (fixnum dmns) - (type gmsm gmsm)) - (the cmbn + (declare + (fixnum dmns) + (type gmsm gmsm)) + (the cmbn (progn - (when (zerop dmns) - (return-from rslt +zero-negative-cmbn+)) - (let ((pre-rslt +empty-list+)) - (declare (list pre-rslt)) - ;; (list (cons cffc face)) - (dotimes (indx (1+ dmns)) - (declare (fixnum indx)) - (let ((face (funcall face indx dmns gmsm))) - (declare (type absm face)) - (unless (degenerate-p face) - (push (term (-1-expt-n indx) (gmsm face)) - pre-rslt)))) - (apply #'nterm-add cmpr (1- dmns) pre-rslt)))))) + (when (zerop dmns) + (return-from rslt +zero-negative-cmbn+)) + (let ((pre-rslt +empty-list+)) + (declare (list pre-rslt)) + ;; (list (cons cffc face)) + (dotimes (indx (1+ dmns)) + (declare (fixnum indx)) + (let ((face (funcall face indx dmns gmsm))) + (declare (type absm face)) + (unless (degenerate-p face) + (push (term (-1-expt-n indx) (gmsm face)) + pre-rslt)))) + (apply #'nterm-add cmpr (1- dmns) pre-rslt)))))) (the intr-mrph #'rslt))) @@ -210,23 +212,23 @@ (type cmprf cmpr) (type face* face*)) (flet ((rslt (dmns gmsm) - (declare - (fixnum dmns) - (type gmsm gmsm)) - (the cmbn + (declare + (fixnum dmns) + (type gmsm gmsm)) + (the cmbn (progn - (when (zerop dmns) - (return-from rslt +zero-negative-cmbn+)) - (let ((pre-rslt +empty-list+)) - (declare (list pre-rslt)) - ;; (list (list gmsm fixnum)) - (dotimes (indx (1+ dmns)) - (declare (fixnum indx)) - (let ((face (funcall face* indx dmns gmsm))) - (declare (type (or gmsm (eql :degenerate)) face)) - (unless (eq face :degenerate) - (push (term (-1-expt-n indx) face) pre-rslt)))) - (apply #'nterm-add cmpr (1- dmns) pre-rslt)))))) + (when (zerop dmns) + (return-from rslt +zero-negative-cmbn+)) + (let ((pre-rslt +empty-list+)) + (declare (list pre-rslt)) + ;; (list (list gmsm fixnum)) + (dotimes (indx (1+ dmns)) + (declare (fixnum indx)) + (let ((face (funcall face* indx dmns gmsm))) + (declare (type (or gmsm (eql :degenerate)) face)) + (unless (eq face :degenerate) + (push (term (-1-expt-n indx) face) pre-rslt)))) + (apply #'nterm-add cmpr (1- dmns) pre-rslt)))))) (the intr-mrph #'rslt))) @@ -236,10 +238,10 @@ (type absm absm1 absm2)) (the cmpr (with-absm (dgop1 gmsm1) absm1 - (with-absm (dgop2 gmsm2) absm2 - (lexico - (f-cmpr dgop1 dgop2) - (funcall cmpr gmsm1 gmsm2)))))) + (with-absm (dgop2 gmsm2) absm2 + (lexico + (f-cmpr dgop1 dgop2) + (funcall cmpr gmsm1 gmsm2)))))) (DEFUN BSPN-P (cmpr bspn dmns absm) @@ -251,8 +253,8 @@ (type absm absm)) (the boolean (with-absm (dgop gmsm) absm - (and (= dgop (mask dmns)) - (eq :equal (funcall cmpr bspn gmsm)))))) + (and (= dgop (mask dmns)) + (eq :equal (funcall cmpr bspn gmsm)))))) (DEFUN DLOP-EXT-INT (ext-dlop) @@ -263,10 +265,10 @@ (error "In DLOP-EXT-INT, the external dlop ~A is not increasing." ext-dlop))) (the fixnum (apply #'logxor - (mapcar #'(lambda (item) - (declare (fixnum item)) - (the fixnum (2-exp item))) - ext-dlop)))) + (mapcar #'(lambda (item) + (declare (fixnum item)) + (the fixnum (2-exp item))) + ext-dlop)))) (DEFUN DLOP-INT-EXT (dlop) @@ -283,29 +285,29 @@ (let ((share (ash -1 1dgop))) (declare (fixnum share)) (logxor - (ash (logand share dgop) 1) - (2-exp 1dgop) - (logandc1 share dgop))))) + (ash (logand share dgop) 1) + (2-exp 1dgop) + (logandc1 share dgop))))) (DEFUN DGOP*DGOP (dgop1 dgop2) (declare (type fixnum dgop1 dgop2)) (let ((dgop 0) - (bmark 0)) + (bmark 0)) (declare (fixnum dgop bmark)) (loop (when (zerop dgop1) - (return-from dgop*dgop - (logxor dgop (ash dgop2 bmark)))) + (return-from dgop*dgop + (logxor dgop (ash dgop2 bmark)))) (when (zerop dgop2) - (return-from dgop*dgop - (logxor dgop (ash dgop1 bmark)))) + (return-from dgop*dgop + (logxor dgop (ash dgop1 bmark)))) (cond ((evenp dgop1) - (when (oddp dgop2) - (incf dgop (2-exp bmark))) - (setf dgop2 (ash dgop2 -1))) - (t - (incf dgop (2-exp bmark)))) + (when (oddp dgop2) + (incf dgop (2-exp bmark))) + (setf dgop2 (ash dgop2 -1))) + (t + (incf dgop (2-exp bmark)))) (setf dgop1 (ash dgop1 -1)) (incf bmark)))) @@ -315,18 +317,18 @@ (the fixnum (let ((cut (2-exp indx))) (multiple-value-bind (quotient remainder) (truncate n cut) - (declare (fixnum quotient remainder)) - (+ (ash (ash quotient -1) indx) remainder))))) + (declare (fixnum quotient remainder)) + (+ (ash (ash quotient -1) indx) remainder))))) (DEFUN DGOP/DGOP (dgop1 dgop2) (declare (fixnum dgop1 dgop2)) (the fixnum (do ((indx (1- (integer-length dgop2)) (1- indx))) - ((minusp indx) dgop1) + ((minusp indx) dgop1) (declare (fixnum indx)) (when (logbitp indx dgop2) - (setf dgop1 (remove-bit dgop1 indx)))))) + (setf dgop1 (remove-bit dgop1 indx)))))) (DEFUN 1DLOP-DGOP (1dlop dgop) @@ -336,32 +338,32 @@ (the (values fixnum (or fixnum null)) (progn (when (logbitp 1dlop dgop) - (let ((share (ash -1 1dlop))) - (declare (fixnum share)) - (return-from 1dlop-dgop - (values - (logxor - (logand share (ash dgop -1)) - (logandc1 share dgop)) - nil)))) + (let ((share (ash -1 1dlop))) + (declare (fixnum share)) + (return-from 1dlop-dgop + (values + (logxor + (logand share (ash dgop -1)) + (logandc1 share dgop)) + nil)))) (when (and (plusp 1dlop) (logbitp (1- 1dlop) dgop)) - (let ((share (ash -1 1dlop))) ;;; - (declare (fixnum share)) - (setf share (ash share -1)) ;;; because of the compiler bug - (return-from 1dlop-dgop - (values - (logxor - (logand share (ash dgop -1)) - (logandc1 share dgop)) - nil)))) + (let ((share (ash -1 1dlop))) ;;; + (declare (fixnum share)) + (setf share (ash share -1)) ;;; because of the compiler bug + (return-from 1dlop-dgop + (values + (logxor + (logand share (ash dgop -1)) + (logandc1 share dgop)) + nil)))) (let ((share (ash -1 1dlop))) - (declare (fixnum share)) - (let ((right (logandc1 share dgop))) - (declare (fixnum right)) - (values - (logxor right (logand share (ash dgop -1))) - (- 1dlop (logcount right)))))))) + (declare (fixnum share)) + (let ((right (logandc1 share dgop))) + (declare (fixnum right)) + (values + (logxor right (logand share (ash dgop -1))) + (- 1dlop (logcount right)))))))) (DEFUN A-FACE4 (face indx dmns absm) @@ -371,20 +373,20 @@ (type absm absm)) (the absm (with-absm - (dgop gmsm) absm - (multiple-value-bind (dgop2 1dlop) (1dlop-dgop indx dgop) - (declare (fixnum dgop2) - #-(or ccl ecl lispworks sbcl) - (type (or fixnum nil) 1dlop)) - ;; Bug LispWorks if this or-type defined - (unless 1dlop - (return-from a-face4 (absm dgop2 gmsm))) - (locally (declare (fixnum 1dlop)) - (let ((gmsm-face (funcall face 1dlop (- dmns (logcount dgop)) - gmsm))) - (declare (type absm gmsm-face)) - (with-absm (dgop3 gmsm3) gmsm-face - (absm (dgop*dgop dgop2 dgop3) gmsm3)))))))) + (dgop gmsm) absm + (multiple-value-bind (dgop2 1dlop) (1dlop-dgop indx dgop) + (declare (fixnum dgop2) + #-(or ccl ecl lispworks sbcl) + (type (or fixnum nil) 1dlop)) + ;; Bug LispWorks if this or-type defined + (unless 1dlop + (return-from a-face4 (absm dgop2 gmsm))) + (locally (declare (fixnum 1dlop)) + (let ((gmsm-face (funcall face 1dlop (- dmns (logcount dgop)) + gmsm))) + (declare (type absm gmsm-face)) + (with-absm (dgop3 gmsm3) gmsm-face + (absm (dgop*dgop dgop2 dgop3) gmsm3)))))))) (DEFUN 1DGNR (indx absm) @@ -393,7 +395,7 @@ (type absm absm)) (the absm (with-absm (dgop gmsm) absm - (absm (1dgop*dgop indx dgop) gmsm)))) + (absm (1dgop*dgop indx dgop) gmsm)))) (DEFUN NDGNR (dgop absm) @@ -402,7 +404,7 @@ (type absm absm)) (the absm (with-absm (dgop2 gmsm) absm - (absm (dgop*dgop dgop dgop2) gmsm)))) + (absm (dgop*dgop dgop dgop2) gmsm)))) (DEFUN NFACE (face dlop dmns gmsm) @@ -412,11 +414,11 @@ (fixnum dmns) (type gmsm gmsm)) (do* ((gmsm gmsm) - (dmns dmns) - (dgop 0) - (dlop dlop (- dlop (2-exp bark))) - (bark (1- (integer-length dlop)) - (1- (integer-length dlop)))) + (dmns dmns) + (dgop 0) + (dlop dlop (- dlop (2-exp bark))) + (bark (1- (integer-length dlop)) + (1- (integer-length dlop)))) ((zerop dlop) (absm dgop gmsm)) (declare (type gmsm gmsm) @@ -426,15 +428,15 @@ (fixnum dgop2) (type (or null fixnum) indx)) (if indx - (locally (declare (fixnum indx)) - (let ((new-absm (funcall face indx dmns gmsm))) - (declare (type absm new-absm)) - (with-absm (dgop3 gmsm2) new-absm - (setf gmsm gmsm2 - dmns (- dmns 1 - (logcount dgop3)) - dgop (dgop*dgop dgop2 dgop3))))) - (setf dgop dgop2))))) + (locally (declare (fixnum indx)) + (let ((new-absm (funcall face indx dmns gmsm))) + (declare (type absm new-absm)) + (with-absm (dgop3 gmsm2) new-absm + (setf gmsm gmsm2 + dmns (- dmns 1 + (logcount dgop3)) + dgop (dgop*dgop dgop2 dgop3))))) + (setf dgop dgop2))))) (DEFUN CHECK-FACES (cmpr face dmns gmsm) @@ -446,25 +448,25 @@ (the boolean (progn (when (> dmns 1) - (let ((dmns-1 (1- dmns))) - (declare (fixnum dmns-1)) - (dotimes (i dmns) - (declare (fixnum i)) - (dotimes (j (1+ i)) - (declare (fixnum j)) - (let ((rslt1 (a-face4 face i dmns-1 - (funcall face j dmns gmsm))) - (rslt2 (a-face4 face j dmns-1 - (funcall face (1+ i) dmns gmsm)))) - (declare (type absm rslt1 rslt2)) - (unless (eq (a-cmpr3 cmpr rslt1 rslt2) :equal) - (cerror "CHECK-FACES will return NIL." - "Noncoherent boundary operators detected by CHECK-FACES :~@ + (let ((dmns-1 (1- dmns))) + (declare (fixnum dmns-1)) + (dotimes (i dmns) + (declare (fixnum i)) + (dotimes (j (1+ i)) + (declare (fixnum j)) + (let ((rslt1 (a-face4 face i dmns-1 + (funcall face j dmns gmsm))) + (rslt2 (a-face4 face j dmns-1 + (funcall face (1+ i) dmns gmsm)))) + (declare (type absm rslt1 rslt2)) + (unless (eq (a-cmpr3 cmpr rslt1 rslt2) :equal) + (cerror "CHECK-FACES will return NIL." + "Noncoherent boundary operators detected by CHECK-FACES :~@ Simplex => ~A~@ del_~D o del_~D => ~A~@ del_~D o del_~D => ~A" - gmsm i j rslt1 j (1+ i) rslt2) - (return-from check-faces nil))))))) + gmsm i j rslt1 j (1+ i) rslt2) + (return-from check-faces nil))))))) t))) @@ -480,16 +482,16 @@ (error "In CHECK-SMST, the locally-effective simplicial-set ~A~@ cannot be checked." smst)) (do ((rslt t) - (dmns dmns1 (1+ dmns))) - ((>= dmns dmns2) rslt) + (dmns dmns1 (1+ dmns))) + ((>= dmns dmns2) rslt) (declare (type boolean rslt) (fixnum dmns)) (format t "~%Checking the ~D-simplices..." dmns) (dolist (gmsm (funcall basis dmns)) - (declare (type gmsm gmsm)) - (unless (check-faces cmpr face dmns gmsm) - (setf rslt nil)))))) + (declare (type gmsm gmsm)) + (unless (check-faces cmpr face dmns gmsm) + (setf rslt nil)))))) (DEFUN SHOW-STRUCTURE (smst dmns) @@ -506,9 +508,9 @@ from dimension 0 up to and including dimension DMNS. (dotimes (i (1+ dmns)) (format t "~2%Dimension = ~D:" i) (case i - (0 (format t "~2%~8TVertices : ~8T~A" (basis smst 0))) - (otherwise - (dolist (s (basis smst i)) - (format t "~2%~8TSimplex : ~A~2%~16TFaces : ~A" - s (mapcar #'(lambda (j) (face smst j i s)) - ( 0 i))))))))) + (0 (format t "~2%~8TVertices : ~8T~A" (basis smst 0))) + (otherwise + (dolist (s (basis smst i)) + (format t "~2%~8TSimplex : ~A~2%~16TFaces : ~A" + s (mapcar #'(lambda (j) (face smst j i s)) + ( 0 i))))))))) diff --git a/src/smith.lisp b/src/smith.lisp index af0bc4d..60fba3f 100644 --- a/src/smith.lisp +++ b/src/smith.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; SMITH SMITH SMITH SMITH SMITH SMITH SMITH SMITH ;;; SMITH SMITH SMITH SMITH SMITH SMITH SMITH SMITH ;;; SMITH SMITH SMITH SMITH SMITH SMITH SMITH SMITH @@ -13,94 +15,94 @@ (declare (fixnum line-n column-n max)) (the matrix (let ((rslt (make-array (list line-n column-n) - :element-type 'fixnum)) - (2max+1 (+ max max 1))) - (declare - (type matrix rslt) - (fixnum 2max+1)) - (dotimes (i line-n) - (declare (fixnum i)) - (dotimes (j column-n) - (declare (fixnum j)) - (setf (aref rslt i j) - (- (random 2max+1) max)))) - rslt))) + :element-type 'fixnum)) + (2max+1 (+ max max 1))) + (declare + (type matrix rslt) + (fixnum 2max+1)) + (dotimes (i line-n) + (declare (fixnum i)) + (dotimes (j column-n) + (declare (fixnum j)) + (setf (aref rslt i j) + (- (random 2max+1) max)))) + rslt))) (DEFUN IDNT-MTRX (n) (declare (fixnum n)) (the matrix (let ((rslt (if (zerop n) - (make-array '(0 0) - :element-type 'fixnum) - (make-array (list n n) - :element-type 'fixnum - :initial-element 0)))) - (declare (type matrix rslt)) - (dotimes (i n) - (declare (fixnum i)) - (setf (aref rslt i i) 1)) - rslt))) + (make-array '(0 0) + :element-type 'fixnum) + (make-array (list n n) + :element-type 'fixnum + :initial-element 0)))) + (declare (type matrix rslt)) + (dotimes (i n) + (declare (fixnum i)) + (setf (aref rslt i i) 1)) + rslt))) (DEFUN COPY-MTRX (mtrx) (declare (type matrix mtrx)) (the matrix (let ((line-n (line-number mtrx)) - (column-n (column-number mtrx))) - (declare (fixnum line-n column-n)) - (let ((rslt (make-array (list line-n column-n) - :element-type 'fixnum))) - (declare (type matrix rslt)) - (dotimes (il line-n) - (declare (fixnum il)) - (dotimes (ic column-n) - (declare (fixnum ic)) - (setf (aref rslt il ic) (aref mtrx il ic)))) - rslt)))) + (column-n (column-number mtrx))) + (declare (fixnum line-n column-n)) + (let ((rslt (make-array (list line-n column-n) + :element-type 'fixnum))) + (declare (type matrix rslt)) + (dotimes (il line-n) + (declare (fixnum il)) + (dotimes (ic column-n) + (declare (fixnum ic)) + (setf (aref rslt il ic) (aref mtrx il ic)))) + rslt)))) (DEFUN LEFT-SUBMATRIX (mtrx k) (declare (type matrix mtrx)) (the matrix (let ((line-n (line-number mtrx)) - (column-n (column-number mtrx))) - (declare (fixnum line-n column-n)) - (assert (<= k column-n)) - (let ((rslt (make-array (list line-n k) - :element-type 'fixnum))) - (declare (type matrix rslt)) - (dotimes (il line-n) - (declare (fixnum il)) - (dotimes (ic k) - (declare (fixnum ic)) - (setf (aref rslt il ic) (aref mtrx il ic)))) - rslt)))) + (column-n (column-number mtrx))) + (declare (fixnum line-n column-n)) + (assert (<= k column-n)) + (let ((rslt (make-array (list line-n k) + :element-type 'fixnum))) + (declare (type matrix rslt)) + (dotimes (il line-n) + (declare (fixnum il)) + (dotimes (ic k) + (declare (fixnum ic)) + (setf (aref rslt il ic) (aref mtrx il ic)))) + rslt)))) (DEFUN MTRX-PRDC (mtrx1 mtrx2) (declare (type matrix mtrx1 mtrx2)) (the matrix (let ((rslt-line-n (line-number mtrx1)) - (mtrx1-column-n (column-number mtrx1)) - (mtrx2-line-n (line-number mtrx2)) - (rslt-column-n (column-number mtrx2))) - (declare (fixnum rslt-line-n mtrx1-column-n - mtrx2-line-n rslt-column-n)) - (unless (= mtrx1-column-n mtrx2-line-n) - (error "In MTRX-PRDC, bad line or column number.")) - (let ((rslt (make-array (list rslt-line-n rslt-column-n) - :element-type 'fixnum))) - (declare (type matrix rslt)) - (dotimes (il rslt-line-n) - (declare (fixnum il)) - (dotimes (ic rslt-column-n) - (declare (fixnum ic)) - (do ((k 0 (1+ k)) - (sum 0 (+ sum - (* (aref mtrx1 il k) (aref mtrx2 k ic))))) - ((= k mtrx1-column-n) (setf (aref rslt il ic) sum))))) - rslt)))) + (mtrx1-column-n (column-number mtrx1)) + (mtrx2-line-n (line-number mtrx2)) + (rslt-column-n (column-number mtrx2))) + (declare (fixnum rslt-line-n mtrx1-column-n + mtrx2-line-n rslt-column-n)) + (unless (= mtrx1-column-n mtrx2-line-n) + (error "In MTRX-PRDC, bad line or column number.")) + (let ((rslt (make-array (list rslt-line-n rslt-column-n) + :element-type 'fixnum))) + (declare (type matrix rslt)) + (dotimes (il rslt-line-n) + (declare (fixnum il)) + (dotimes (ic rslt-column-n) + (declare (fixnum ic)) + (do ((k 0 (1+ k)) + (sum 0 (+ sum + (* (aref mtrx1 il k) (aref mtrx2 k ic))))) + ((= k mtrx1-column-n) (setf (aref rslt il ic) sum))))) + rslt)))) (DEFUN CHCM-MTRX (chcm degr) @@ -109,46 +111,46 @@ (fixnum degr)) (the matrix (let ((cmpr (cmpr1 chcm)) - (dffr (dffr chcm)) - (sbasis (basis chcm degr)) - (tbasis (basis chcm (1- degr)))) - (declare - (type cmprf cmpr) - (type morphism dffr) - (list sbasis tbasis)) - (let ((srank (length sbasis)) - (trank (length tbasis))) - (declare (fixnum srank trank)) - (let ((rslt (make-array (list trank srank) - :element-type 'fixnum - :initial-element 0))) - (declare (type matrix rslt)) - (do ((j 0 (1+ j)) - (mark sbasis (cdr mark))) - ((endp mark)) - (declare - (fixnum j) - (list mark)) - (let ((cmbn (gnrt-? dffr degr (car mark)))) - (declare (type cmbn cmbn)) - (do ((mark1 (cmbn-list cmbn) (cdr mark1)) - (mark2 tbasis) - (i 0)) - ((endp mark1)) - (declare - (list mark1 mark2) - (fixnum i)) - (with--term - (cffc gnrt) mark1 - (loop - (cond ((eq :equal (funcall cmpr gnrt (car mark2))) - (setf (aref rslt i j) cffc) - (incf i) - (pop mark2) - (return)) - (t (incf i) - (pop mark2)))))))) - rslt))))) + (dffr (dffr chcm)) + (sbasis (basis chcm degr)) + (tbasis (basis chcm (1- degr)))) + (declare + (type cmprf cmpr) + (type morphism dffr) + (list sbasis tbasis)) + (let ((srank (length sbasis)) + (trank (length tbasis))) + (declare (fixnum srank trank)) + (let ((rslt (make-array (list trank srank) + :element-type 'fixnum + :initial-element 0))) + (declare (type matrix rslt)) + (do ((j 0 (1+ j)) + (mark sbasis (cdr mark))) + ((endp mark)) + (declare + (fixnum j) + (list mark)) + (let ((cmbn (gnrt-? dffr degr (car mark)))) + (declare (type cmbn cmbn)) + (do ((mark1 (cmbn-list cmbn) (cdr mark1)) + (mark2 tbasis) + (i 0)) + ((endp mark1)) + (declare + (list mark1 mark2) + (fixnum i)) + (with--term + (cffc gnrt) mark1 + (loop + (cond ((eq :equal (funcall cmpr gnrt (car mark2))) + (setf (aref rslt i j) cffc) + (incf i) + (pop mark2) + (return)) + (t (incf i) + (pop mark2)))))))) + rslt))))) (DEFUN LINE-OP (mtrx begin lambda line1 line2) @@ -158,13 +160,13 @@ (fixnum begin lambda line1 line2)) (the matrix (progn - (do ((column-number (column-number mtrx)) - (j begin (1+ j))) - ((= j column-number)) - (declare (fixnum column-number j)) - (incf (aref mtrx line2 j) - (* lambda (aref mtrx line1 j)))) - mtrx))) + (do ((column-number (column-number mtrx)) + (j begin (1+ j))) + ((= j column-number)) + (declare (fixnum column-number j)) + (incf (aref mtrx line2 j) + (* lambda (aref mtrx line1 j)))) + mtrx))) (DEFUN COLUMN-OP (mtrx begin lambda column1 column2) @@ -173,13 +175,13 @@ (fixnum begin lambda column1 column2)) (the matrix (progn - (do ((line-number (line-number mtrx)) - (i begin (1+ i))) - ((= i line-number)) - (declare (fixnum line-number i)) - (incf (aref mtrx i column2) - (* lambda (aref mtrx i column1)))) - mtrx))) + (do ((line-number (line-number mtrx)) + (i begin (1+ i))) + ((= i line-number)) + (declare (fixnum line-number i)) + (incf (aref mtrx i column2) + (* lambda (aref mtrx i column1)))) + mtrx))) (DEFUN LINE-SWAP (mtrx begin line1 line2) @@ -188,12 +190,12 @@ (fixnum begin line1 line2)) (the matrix (progn - (do ((column-number (column-number mtrx)) - (j begin (1+ j))) - ((= j column-number)) - (declare (fixnum column-number j)) - (rotatef (aref mtrx line1 j) (aref mtrx line2 j))) - mtrx))) + (do ((column-number (column-number mtrx)) + (j begin (1+ j))) + ((= j column-number)) + (declare (fixnum column-number j)) + (rotatef (aref mtrx line1 j) (aref mtrx line2 j))) + mtrx))) (DEFUN COLUMN-SWAP (mtrx begin column1 column2) @@ -201,12 +203,12 @@ (type matrix mtrx) (fixnum begin column1 column2)) (the matrix (progn - (do ((line-number (line-number mtrx)) - (i begin (1+ i))) - ((= i line-number)) - (declare (fixnum line-number i)) - (rotatef (aref mtrx i column1) (aref mtrx i column2))) - mtrx))) + (do ((line-number (line-number mtrx)) + (i begin (1+ i))) + ((= i line-number)) + (declare (fixnum line-number i)) + (rotatef (aref mtrx i column1) (aref mtrx i column2))) + mtrx))) (DEFUN LINE-MINUS (mtrx begin line) @@ -214,24 +216,24 @@ (type matrix mtrx) (fixnum begin line)) (the matrix (progn - (do ((column-number (column-number mtrx)) - (j begin (1+ j))) - ((= j column-number)) - (declare (fixnum column-number j)) - (setf (aref mtrx line j) (- (aref mtrx line j)))) - mtrx))) + (do ((column-number (column-number mtrx)) + (j begin (1+ j))) + ((= j column-number)) + (declare (fixnum column-number j)) + (setf (aref mtrx line j) (- (aref mtrx line j)))) + mtrx))) (DEFUN COLUMN-MINUS (mtrx begin column) (declare (type matrix mtrx) (fixnum begin column)) (the matrix (progn - (do ((line-number (line-number mtrx)) - (i begin (1+ i))) - ((= i line-number)) - (declare (fixnum line-number i)) - (setf (aref mtrx i column) (- (aref mtrx i column)))) - mtrx))) + (do ((line-number (line-number mtrx)) + (i begin (1+ i))) + ((= i line-number)) + (declare (fixnum line-number i)) + (setf (aref mtrx i column) (- (aref mtrx i column)))) + mtrx))) (DEFUN MINIMAL-TERM (matrix begin) @@ -240,27 +242,27 @@ (fixnum begin)) (the (values fixnum fixnum fixnum) (do ((line-number (line-number matrix)) - (column-number (column-number matrix)) - (min 0) - (min-il -1) - (min-ic -1) - (il begin (1+ il))) - ((= il line-number) (values min min-il min-ic)) - (declare (fixnum line-number column-number - min min-il min-ic il)) - (do ((ic begin (1+ ic))) - ((= ic column-number)) - (declare (fixnum ic)) - (let ((term (abs (aref matrix il ic)))) - (declare (fixnum term)) - (when (= term 1) + (column-number (column-number matrix)) + (min 0) + (min-il -1) + (min-ic -1) + (il begin (1+ il))) + ((= il line-number) (values min min-il min-ic)) + (declare (fixnum line-number column-number + min min-il min-ic il)) + (do ((ic begin (1+ ic))) + ((= ic column-number)) + (declare (fixnum ic)) + (let ((term (abs (aref matrix il ic)))) + (declare (fixnum term)) + (when (= term 1) (return-from minimal-term (values 1 il ic))) - (when (plusp term) + (when (plusp term) (when (or (< term min) (zerop min)) - (setf min term - min-il il - min-ic ic)))))))) + (setf min term + min-il il + min-ic ic)))))))) (DEFUN MINIMAL-REST-1 (matrix begin) @@ -269,43 +271,43 @@ (fixnum begin)) (the (values fixnum fixnum fixnum) (let ((line-number (line-number matrix)) - (column-number (column-number matrix)) - (corner (aref matrix begin begin)) - (min 0) - (min-il -1) - (min-ic -1)) - (declare (fixnum corner min min-il min-ic)) - (do ((ic (1+ begin) (1+ ic))) - ((= ic column-number)) - (declare (fixnum ic)) - (let ((term (abs (second (multiple-value-list - (round (aref matrix begin ic) - corner)))))) - (declare (fixnum term)) - (when (= term 1) + (column-number (column-number matrix)) + (corner (aref matrix begin begin)) + (min 0) + (min-il -1) + (min-ic -1)) + (declare (fixnum corner min min-il min-ic)) + (do ((ic (1+ begin) (1+ ic))) + ((= ic column-number)) + (declare (fixnum ic)) + (let ((term (abs (second (multiple-value-list + (round (aref matrix begin ic) + corner)))))) + (declare (fixnum term)) + (when (= term 1) (return-from minimal-rest-1 (values 1 begin ic))) - (when (plusp term) + (when (plusp term) (when (or (< term min) (zerop min)) - (setf min term - min-il begin - min-ic ic))))) - (do ((il (1+ begin) (1+ il))) - ((= il line-number)) - (declare (fixnum il)) - (let ((term (abs (second (multiple-value-list - (round (aref matrix il begin) - corner)))))) - (declare (fixnum term)) - (when (= term 1) + (setf min term + min-il begin + min-ic ic))))) + (do ((il (1+ begin) (1+ il))) + ((= il line-number)) + (declare (fixnum il)) + (let ((term (abs (second (multiple-value-list + (round (aref matrix il begin) + corner)))))) + (declare (fixnum term)) + (when (= term 1) (return-from minimal-rest-1 (values 1 il begin))) - (when (plusp term) + (when (plusp term) (when (or (< term min) (zerop min)) - (setf min term - min-il il - min-ic begin))))) - (values min min-il min-ic)))) + (setf min term + min-il il + min-ic begin))))) + (values min min-il min-ic)))) (DEFUN MINIMAL-REST-2 (matrix begin) @@ -314,31 +316,31 @@ (fixnum begin)) (the (values fixnum fixnum fixnum) (let ((line-number (line-number matrix)) - (column-number (column-number matrix)) - (corner (aref matrix begin begin)) - (min 0) - (min-il -1) - (min-ic -1)) - (declare (fixnum corner min min-il min-ic)) - (do ((il (1+ begin) (1+ il))) - ((= il line-number)) - (declare (fixnum il)) - (do ((ic (1+ begin) (1+ ic))) - ((= ic column-number)) - (declare (fixnum il)) - (let ((term (abs (second (multiple-value-list - (round (aref matrix il ic) - corner)))))) + (column-number (column-number matrix)) + (corner (aref matrix begin begin)) + (min 0) + (min-il -1) + (min-ic -1)) + (declare (fixnum corner min min-il min-ic)) + (do ((il (1+ begin) (1+ il))) + ((= il line-number)) + (declare (fixnum il)) + (do ((ic (1+ begin) (1+ ic))) + ((= ic column-number)) + (declare (fixnum il)) + (let ((term (abs (second (multiple-value-list + (round (aref matrix il ic) + corner)))))) (declare (fixnum term)) (when (= 1 term) - (return-from minimal-rest-2 (values 1 il ic))) + (return-from minimal-rest-2 (values 1 il ic))) (when (plusp term) - (when (or (< term min) - (zerop min)) - (setf min term - min-il il - min-ic ic)))))) - (values min min-il min-ic)))) + (when (or (< term min) + (zerop min)) + (setf min term + min-il il + min-ic ic)))))) + (values min min-il min-ic)))) (DEFUN MINIMAL-TERM-TOP-LEFT (mtrx-list begin il ic) @@ -346,13 +348,13 @@ (list mtrx-list) (fixnum begin il ic)) (the list (progn - (when (< begin il) - (line-swap-5 mtrx-list begin begin il)) - (when (< begin ic) - (column-swap-5 mtrx-list begin begin ic)) - (when (minusp (aref (third mtrx-list) begin begin)) - (line-minus-5 mtrx-list begin begin)) - mtrx-list))) + (when (< begin il) + (line-swap-5 mtrx-list begin begin il)) + (when (< begin ic) + (column-swap-5 mtrx-list begin begin ic)) + (when (minusp (aref (third mtrx-list) begin begin)) + (line-minus-5 mtrx-list begin begin)) + mtrx-list))) (DEFUN PIVOTT (mtrx-list begin) @@ -360,89 +362,89 @@ (list mtrx-list) (fixnum begin)) (the list (progn - (let ((line-number (line-number (third mtrx-list))) - (column-number (column-number (third mtrx-list))) - (corner (aref (third mtrx-list) begin begin))) - (declare (fixnum line-number column-number corner)) - (do ((il (1+ begin) (1+ il))) - ((= il line-number)) - (declare (fixnum il)) - (line-op-5 mtrx-list begin - (- (round (aref (third mtrx-list) il begin) - corner)) - begin il)) - (do ((ic (1+ begin) (1+ ic))) - ((= ic column-number)) - (declare (fixnum ic)) - (column-op-5 mtrx-list begin - (- (round (aref (third mtrx-list) begin ic) - corner)) - begin ic))) - mtrx-list))) + (let ((line-number (line-number (third mtrx-list))) + (column-number (column-number (third mtrx-list))) + (corner (aref (third mtrx-list) begin begin))) + (declare (fixnum line-number column-number corner)) + (do ((il (1+ begin) (1+ il))) + ((= il line-number)) + (declare (fixnum il)) + (line-op-5 mtrx-list begin + (- (round (aref (third mtrx-list) il begin) + corner)) + begin il)) + (do ((ic (1+ begin) (1+ ic))) + ((= ic column-number)) + (declare (fixnum ic)) + (column-op-5 mtrx-list begin + (- (round (aref (third mtrx-list) begin ic) + corner)) + begin ic))) + mtrx-list))) (DEFUN LIST-SMITH (mtrx-list) (declare (list mtrx-list)) (the list (progn - (let ((matrix (third mtrx-list)) - (begin 0)) - (declare - (type matrix matrix) - (fixnum begin)) - (loop - (multiple-value-bind (term il ic) - (minimal-term matrix begin) - (declare (fixnum term il ic)) - ;; (format t "~%*BEGIN* = ~D ; MIN = ~D." begin term) - (when (zerop term) - (return-from list-smith mtrx-list)) - (minimal-term-top-left mtrx-list begin il ic)) - (loop - (multiple-value-bind (term il ic) - (minimal-rest-1 matrix begin) - (declare (fixnum term il ic)) - (cond ((zerop term) - (pivott mtrx-list begin) - (multiple-value-bind (term il ic) - (minimal-rest-2 matrix begin) - (declare - (fixnum term il) - (ignore ic)) - (if (zerop term) - (return) - (line-op-5 mtrx-list begin 1 il begin)))) - ((= il begin) - (column-op-5 mtrx-list begin - (- (round (aref matrix begin ic) - (aref matrix begin - begin))) - begin ic) - (column-swap-5 mtrx-list begin begin ic) - (when (minusp (aref matrix begin begin)) - (column-minus-5 mtrx-list begin begin))) - (t - (line-op-5 mtrx-list begin - (- (round (aref matrix il begin) - (aref matrix begin begin))) - begin il) - (line-swap-5 mtrx-list begin begin il) - (when (minusp (aref matrix begin begin)) - (column-minus-5 mtrx-list begin begin)))))) - ;; (Format t "~% Finally the diagonal term is ~D." (aref matrix begin begin)) - (incf begin))) - mtrx-list))) + (let ((matrix (third mtrx-list)) + (begin 0)) + (declare + (type matrix matrix) + (fixnum begin)) + (loop + (multiple-value-bind (term il ic) + (minimal-term matrix begin) + (declare (fixnum term il ic)) + ;; (format t "~%*BEGIN* = ~D ; MIN = ~D." begin term) + (when (zerop term) + (return-from list-smith mtrx-list)) + (minimal-term-top-left mtrx-list begin il ic)) + (loop + (multiple-value-bind (term il ic) + (minimal-rest-1 matrix begin) + (declare (fixnum term il ic)) + (cond ((zerop term) + (pivott mtrx-list begin) + (multiple-value-bind (term il ic) + (minimal-rest-2 matrix begin) + (declare + (fixnum term il) + (ignore ic)) + (if (zerop term) + (return) + (line-op-5 mtrx-list begin 1 il begin)))) + ((= il begin) + (column-op-5 mtrx-list begin + (- (round (aref matrix begin ic) + (aref matrix begin + begin))) + begin ic) + (column-swap-5 mtrx-list begin begin ic) + (when (minusp (aref matrix begin begin)) + (column-minus-5 mtrx-list begin begin))) + (t + (line-op-5 mtrx-list begin + (- (round (aref matrix il begin) + (aref matrix begin begin))) + begin il) + (line-swap-5 mtrx-list begin begin il) + (when (minusp (aref matrix begin begin)) + (column-minus-5 mtrx-list begin begin)))))) + ;; (Format t "~% Finally the diagonal term is ~D." (aref matrix begin begin)) + (incf begin))) + mtrx-list))) (DEFUN SMITH (matrix) (declare (type matrix matrix)) (the list (let ((line-n (line-number matrix)) - (column-n (column-number matrix))) - (declare (fixnum line-n column-n)) - (list-smith - (list (idnt-mtrx line-n) (idnt-mtrx line-n) - matrix - (idnt-mtrx column-n) (idnt-mtrx column-n)))))) + (column-n (column-number matrix))) + (declare (fixnum line-n column-n)) + (list-smith + (list (idnt-mtrx line-n) (idnt-mtrx line-n) + matrix + (idnt-mtrx column-n) (idnt-mtrx column-n)))))) ;;; ECHCM -> The same without the first epimorphism @@ -462,11 +464,11 @@ (declare (fixnum n)) (the list (do ((i (1- n) (1- i)) - (rslt +empty-list+ (cons (gnrt-name i) rslt))) - ((minusp i) rslt) - (declare - (fixnum i) - (list rslt))))) + (rslt +empty-list+ (cons (gnrt-name i) rslt))) + ((minusp i) rslt) + (declare + (fixnum i) + (list rslt))))) (DEFUN ECHCM-KILL-EPI-F-INTR (cmpr first n m f+1-basis mtrx-list) @@ -475,52 +477,52 @@ (fixnum first n m) (list f+1-basis mtrx-list)) (let ((f+1 (1+ first)) - (m-n (- m n)) - (q-1 (fifth mtrx-list))) + (m-n (- m n)) + (q-1 (fifth mtrx-list))) (declare (fixnum f+1 m-n) (type matrix q-1)) (flet ((rslt (cmbn) - (declare (type cmbn cmbn)) - (with-cmbn - (degr list) cmbn - (when (= degr first) - (return-from rslt (zero-cmbn degr))) - (unless (= degr f+1) - (return-from rslt cmbn)) - (let ((rslt-cffcs (make-array m-n :element-type 'fixnum - :initial-element 0))) - (declare (type (array fixnum *) rslt-cffcs)) - (do ((cmbn-mark list (cdr cmbn-mark)) - (basis-mark f+1-basis) - (ic 0)) - ((endp cmbn-mark)) - (declare - (list cmbn-mark basis-mark) - (fixnum ic)) - (with--term - (cffc gnrt) cmbn-mark - (loop (when (eq :equal (funcall cmpr gnrt - (car basis-mark))) - (return)) - (pop basis-mark) - (incf ic)) - (dotimes (il m-n) - (incf (aref rslt-cffcs il) - (* cffc (aref q-1 (+ n il) ic)))) - (pop basis-mark) - (incf ic))) - (do ((term-list +empty-list+) - (il (1- m-n) (1- il))) - ((minusp il) (make-cmbn :degr degr - :list term-list)) - (declare - (list term-list) - (fixnum il)) - (let ((cffc (aref rslt-cffcs il))) - (declare (fixnum cffc)) - (unless (zerop cffc) - (push (term cffc (gnrt-name il)) term-list)))))))) + (declare (type cmbn cmbn)) + (with-cmbn + (degr list) cmbn + (when (= degr first) + (return-from rslt (zero-cmbn degr))) + (unless (= degr f+1) + (return-from rslt cmbn)) + (let ((rslt-cffcs (make-array m-n :element-type 'fixnum + :initial-element 0))) + (declare (type (array fixnum *) rslt-cffcs)) + (do ((cmbn-mark list (cdr cmbn-mark)) + (basis-mark f+1-basis) + (ic 0)) + ((endp cmbn-mark)) + (declare + (list cmbn-mark basis-mark) + (fixnum ic)) + (with--term + (cffc gnrt) cmbn-mark + (loop (when (eq :equal (funcall cmpr gnrt + (car basis-mark))) + (return)) + (pop basis-mark) + (incf ic)) + (dotimes (il m-n) + (incf (aref rslt-cffcs il) + (* cffc (aref q-1 (+ n il) ic)))) + (pop basis-mark) + (incf ic))) + (do ((term-list +empty-list+) + (il (1- m-n) (1- il))) + ((minusp il) (make-cmbn :degr degr + :list term-list)) + (declare + (list term-list) + (fixnum il)) + (let ((cffc (aref rslt-cffcs il))) + (declare (fixnum cffc)) + (unless (zerop cffc) + (push (term cffc (gnrt-name il)) term-list)))))))) (the intr-mrph #'rslt)))) @@ -535,43 +537,43 @@ (fixnum f+1 m-n) (type matrix q)) (flet ((rslt (cmbn) - (declare (type cmbn cmbn)) - (with-cmbn - (degr list) cmbn - (unless (= degr f+1) - (return-from rslt cmbn)) - (let ((rslt-cffcs (make-array m :element-type 'fixnum - :initial-element 0))) - (declare (type (array fixnum *) rslt-cffcs)) - (do ((cmbn-mark list (cdr cmbn-mark)) - (basis-mark (gnrt-name-basis m-n)) - (ic 0)) - ((endp cmbn-mark)) - (declare - (list cmbn-mark basis-mark) - (fixnum ic)) - (with--term - (cffc gnrt) cmbn-mark - (loop (when (eq :equal (s-cmpr gnrt (car basis-mark))) - (return)) - (pop basis-mark) - (incf ic)) - (dotimes (il m) - (incf (aref rslt-cffcs il) - (* cffc (aref q il (+ n ic))))) - (pop basis-mark) - (incf ic))) - (do ((term-list +empty-list+) - (il (1- m) (1- il))) - ((minusp il) (make-cmbn :degr degr - :list term-list)) - (declare - (list term-list) - (fixnum il)) - (let ((cffc (aref rslt-cffcs il))) - (declare (fixnum cffc)) - (unless (zerop cffc) - (push (term cffc (nth il f+1-basis)) term-list)))))))) + (declare (type cmbn cmbn)) + (with-cmbn + (degr list) cmbn + (unless (= degr f+1) + (return-from rslt cmbn)) + (let ((rslt-cffcs (make-array m :element-type 'fixnum + :initial-element 0))) + (declare (type (array fixnum *) rslt-cffcs)) + (do ((cmbn-mark list (cdr cmbn-mark)) + (basis-mark (gnrt-name-basis m-n)) + (ic 0)) + ((endp cmbn-mark)) + (declare + (list cmbn-mark basis-mark) + (fixnum ic)) + (with--term + (cffc gnrt) cmbn-mark + (loop (when (eq :equal (s-cmpr gnrt (car basis-mark))) + (return)) + (pop basis-mark) + (incf ic)) + (dotimes (il m) + (incf (aref rslt-cffcs il) + (* cffc (aref q il (+ n ic))))) + (pop basis-mark) + (incf ic))) + (do ((term-list +empty-list+) + (il (1- m) (1- il))) + ((minusp il) (make-cmbn :degr degr + :list term-list)) + (declare + (list term-list) + (fixnum il)) + (let ((cffc (aref rslt-cffcs il))) + (declare (fixnum cffc)) + (unless (zerop cffc) + (push (term cffc (nth il f+1-basis)) term-list)))))))) (the intr-mrph #'rslt)))) @@ -584,44 +586,44 @@ (second mtrx-list)))) (declare (type matrix lqxp-1)) (flet ((rslt (cmbn) - (declare (type cmbn cmbn)) - (with-cmbn - (degr list) cmbn - (unless (= degr first) - (return-from rslt (zero-cmbn (1+ degr)))) - (let ((rslt-cffcs (make-array m :element-type 'fixnum - :initial-element 0))) - (declare (type (array fixnum *) rslt-cffcs)) - (do ((cmbn-mark list (cdr cmbn-mark)) - (basis-mark f-basis) - (ic 0)) - ((endp cmbn-mark)) - (declare - (list cmbn-mark basis-mark) - (fixnum ic)) - (with--term - (cffc gnrt) cmbn-mark - (loop (when (eq :equal (funcall cmpr gnrt - (car basis-mark))) - (return)) - (pop basis-mark) - (incf ic)) - (dotimes (il m) - (incf (aref rslt-cffcs il) - (* cffc (aref lqxp-1 il ic)))) - (pop basis-mark) - (incf ic))) - (do ((term-list +empty-list+) - (il (1- m) (1- il))) - ((minusp il) (make-cmbn :degr (1+ degr) - :list term-list)) - (declare - (list term-list) - (fixnum il)) - (let ((cffc (aref rslt-cffcs il))) - (declare (fixnum cffc)) - (unless (zerop cffc) - (push (term cffc (nth il f+1-basis)) term-list)))))))) + (declare (type cmbn cmbn)) + (with-cmbn + (degr list) cmbn + (unless (= degr first) + (return-from rslt (zero-cmbn (1+ degr)))) + (let ((rslt-cffcs (make-array m :element-type 'fixnum + :initial-element 0))) + (declare (type (array fixnum *) rslt-cffcs)) + (do ((cmbn-mark list (cdr cmbn-mark)) + (basis-mark f-basis) + (ic 0)) + ((endp cmbn-mark)) + (declare + (list cmbn-mark basis-mark) + (fixnum ic)) + (with--term + (cffc gnrt) cmbn-mark + (loop (when (eq :equal (funcall cmpr gnrt + (car basis-mark))) + (return)) + (pop basis-mark) + (incf ic)) + (dotimes (il m) + (incf (aref rslt-cffcs il) + (* cffc (aref lqxp-1 il ic)))) + (pop basis-mark) + (incf ic))) + (do ((term-list +empty-list+) + (il (1- m) (1- il))) + ((minusp il) (make-cmbn :degr (1+ degr) + :list term-list)) + (declare + (list term-list) + (fixnum il)) + (let ((cffc (aref rslt-cffcs il))) + (declare (fixnum cffc)) + (unless (zerop cffc) + (push (term cffc (nth il f+1-basis)) term-list)))))))) (the intr-mrph #'rslt)))) @@ -632,36 +634,36 @@ (type intr-mrph intr-f)) (the chain-complex (with-slots (cmpr basis dffr orgn) echcm - (declare - (type cmprf cmpr) - (type basis basis) - (type morphism dffr) - (list orgn)) - (build-chcm - :cmpr #'(lambda (gnrt1 gnrt2) - (if (and (symbolp gnrt1) - (eq (symbol-package gnrt1) - +gnrts-pckg+)) - (s-cmpr gnrt1 gnrt2) - (funcall cmpr gnrt1 gnrt2))) - :basis #'(lambda (degr) - (declare (fixnum degr)) - (cond ((= degr first) - +empty-list+) - ((= degr (1+ first)) - (gnrt-name-basis (- m n))) - (t - (funcall basis degr)))) - :intr-dffr #'(lambda (cmbn) - (declare (type cmbn cmbn)) - (case (- (cmbn-degr cmbn) first) - (1 (zero-cmbn first)) - (2 (funcall intr-f - (cmbn-? dffr cmbn))) - (otherwise - (cmbn-? dffr cmbn)))) - :strt :cmbn - :orgn `(echcm-without-epi ,echcm))))) + (declare + (type cmprf cmpr) + (type basis basis) + (type morphism dffr) + (list orgn)) + (build-chcm + :cmpr #'(lambda (gnrt1 gnrt2) + (if (and (symbolp gnrt1) + (eq (symbol-package gnrt1) + +gnrts-pckg+)) + (s-cmpr gnrt1 gnrt2) + (funcall cmpr gnrt1 gnrt2))) + :basis #'(lambda (degr) + (declare (fixnum degr)) + (cond ((= degr first) + +empty-list+) + ((= degr (1+ first)) + (gnrt-name-basis (- m n))) + (t + (funcall basis degr)))) + :intr-dffr #'(lambda (cmbn) + (declare (type cmbn cmbn)) + (case (- (cmbn-degr cmbn) first) + (1 (zero-cmbn first)) + (2 (funcall intr-f + (cmbn-? dffr cmbn))) + (otherwise + (cmbn-? dffr cmbn)))) + :strt :cmbn + :orgn `(echcm-without-epi ,echcm))))) (DEFUN ECHCM-KILL-EPI (echcm first) @@ -670,47 +672,47 @@ (fixnum first)) (the reduction (with-slots (cmpr basis) echcm - (declare - (type cmprf cmpr) - (type basis basis)) - (assert (not (eq basis :locally-effective))) - (let* ((f-basis (funcall basis first)) - (f+1-basis (funcall basis (1+ first))) - (mtrx-list (smith (chcm-mtrx echcm (1+ first)))) - (smith (third mtrx-list)) - (m (column-number smith)) - (n (line-number smith)) - (intr-f (echcm-kill-epi-f-intr cmpr first n m - f+1-basis - mtrx-list)) - (intr-g (echcm-kill-epi-g-intr first n m f+1-basis mtrx-list)) - (intr-h (echcm-kill-epi-h-intr cmpr first n m - f-basis f+1-basis - mtrx-list)) - (echcm2 (echcm-without-epi echcm first n m intr-f))) - (declare - (list mtrx-list) - (type matrix smith) - (fixnum m n) - (type intr-mrph intr-f intr-g intr-h) - (type chain-complex echcm2)) - (assert (dotimes (i n +true+) - (unless (= 1 (aref smith i i)) - (return +false+)))) - (build-rdct - :f (build-mrph - :sorc echcm :trgt echcm2 :degr 0 - :intr intr-f :strt :cmbn - :orgn `(echcm-kill-epi-f ,echcm)) - :g (build-mrph - :sorc echcm2 :trgt echcm :degr 0 - :intr intr-g :strt :cmbn - :orgn `(echcm-kill-epi-g ,echcm)) - :h (build-mrph - :sorc echcm :trgt echcm :degr +1 - :intr intr-h :strt :cmbn - :orgn `(echcm-kill-epi-h ,echcm)) - :orgn `(echcm-kill-epi ,echcm)))))) + (declare + (type cmprf cmpr) + (type basis basis)) + (assert (not (eq basis :locally-effective))) + (let* ((f-basis (funcall basis first)) + (f+1-basis (funcall basis (1+ first))) + (mtrx-list (smith (chcm-mtrx echcm (1+ first)))) + (smith (third mtrx-list)) + (m (column-number smith)) + (n (line-number smith)) + (intr-f (echcm-kill-epi-f-intr cmpr first n m + f+1-basis + mtrx-list)) + (intr-g (echcm-kill-epi-g-intr first n m f+1-basis mtrx-list)) + (intr-h (echcm-kill-epi-h-intr cmpr first n m + f-basis f+1-basis + mtrx-list)) + (echcm2 (echcm-without-epi echcm first n m intr-f))) + (declare + (list mtrx-list) + (type matrix smith) + (fixnum m n) + (type intr-mrph intr-f intr-g intr-h) + (type chain-complex echcm2)) + (assert (dotimes (i n +true+) + (unless (= 1 (aref smith i i)) + (return +false+)))) + (build-rdct + :f (build-mrph + :sorc echcm :trgt echcm2 :degr 0 + :intr intr-f :strt :cmbn + :orgn `(echcm-kill-epi-f ,echcm)) + :g (build-mrph + :sorc echcm2 :trgt echcm :degr 0 + :intr intr-g :strt :cmbn + :orgn `(echcm-kill-epi-g ,echcm)) + :h (build-mrph + :sorc echcm :trgt echcm :degr +1 + :intr intr-h :strt :cmbn + :orgn `(echcm-kill-epi-h ,echcm)) + :orgn `(echcm-kill-epi ,echcm)))))) (DEFUN KILL-EPI (chcm first) @@ -719,17 +721,17 @@ (fixnum first)) (the homotopy-equivalence (let ((efhm (efhm chcm)) - (echcm (echcm chcm))) - (declare - (type homotopy-equivalence efhm) - (type chain-complex echcm)) - (let ((last-rdct (echcm-kill-epi echcm first))) - (declare (type reduction last-rdct)) - (setf (slot-value chcm 'efhm) - (build-hmeq - :lrdct (lrdct efhm) - :rrdct (cmps last-rdct (rrdct efhm)) - :orgn `(kill-epi ,chcm ,first))))))) + (echcm (echcm chcm))) + (declare + (type homotopy-equivalence efhm) + (type chain-complex echcm)) + (let ((last-rdct (echcm-kill-epi echcm first))) + (declare (type reduction last-rdct)) + (setf (slot-value chcm 'efhm) + (build-hmeq + :lrdct (lrdct efhm) + :rrdct (cmps last-rdct (rrdct efhm)) + :orgn `(kill-epi ,chcm ,first))))))) (DEFUN KILL-EPIS (chcm first end) @@ -737,11 +739,11 @@ (type chain-complex chcm) (fixnum first end)) (the homotopy-equivalence (progn - (do ((indx first (1+ indx))) - ((= indx end)) - (declare (fixnum indx)) - (kill-epi chcm indx)) - (efhm chcm)))) + (do ((indx first (1+ indx))) + ((= indx end)) + (declare (fixnum indx)) + (kill-epi chcm indx)) + (efhm chcm)))) (DEFUN CHML-CLSS-INTR (chcm first) @@ -749,22 +751,22 @@ (type chain-complex chcm) (fixnum first)) (let* ((echcm (echcm chcm)) - (cmpr (cmpr echcm)) - (basis (basis echcm)) - (f-basis (funcall basis first)) - (mtrx-list (smith (chcm-mtrx echcm (1+ first)))) - (p-1 (second mtrx-list)) - (smith (third mtrx-list)) - (n (line-number smith)) - (m (column-number smith)) + (cmpr (cmpr echcm)) + (basis (basis echcm)) + (f-basis (funcall basis first)) + (mtrx-list (smith (chcm-mtrx echcm (1+ first)))) + (p-1 (second mtrx-list)) + (smith (third mtrx-list)) + (n (line-number smith)) + (m (column-number smith)) (diag-indx (dotimes (indx (min n m) - (if (> n m) - m - (error "In CHML-CLSS, the cohomology-ring ~@ + (if (> n m) + m + (error "In CHML-CLSS, the cohomology-ring ~@ is null."))) - (declare (fixnum indx)) - (unless (= 1 (aref smith indx indx)) - (return indx))))) + (declare (fixnum indx)) + (unless (= 1 (aref smith indx indx)) + (return indx))))) (declare (type chain-complex echcm) (type cmprf cmpr) @@ -773,32 +775,32 @@ (list f-basis mtrx-list) (type matrix p-1 smith)) (flet ((rslt (cmbn) - (declare (type cmbn cmbn)) - (with-cmbn - (degr list) cmbn - (unless (= degr first) - (return-from rslt (zero-cmbn (- degr first)))) - (do ((rslt 0) - (bmark f-basis) - (ic 0) - (cmark list (cdr cmark))) - ((endp cmark) - (if (zerop rslt) - (zero-cmbn 0) - (term-cmbn 0 rslt :z-gnrt))) - (declare - (fixnum rslt) - (list bmark cmark)) - (with--term - (cffc gnrt) cmark - (loop - (when (eq :equal (funcall cmpr gnrt (car bmark))) - (return)) - (pop bmark) - (incf ic)) - (incf rslt (* cffc (aref p-1 diag-indx ic))) - (pop bmark) - (incf ic)))))) + (declare (type cmbn cmbn)) + (with-cmbn + (degr list) cmbn + (unless (= degr first) + (return-from rslt (zero-cmbn (- degr first)))) + (do ((rslt 0) + (bmark f-basis) + (ic 0) + (cmark list (cdr cmark))) + ((endp cmark) + (if (zerop rslt) + (zero-cmbn 0) + (term-cmbn 0 rslt :z-gnrt))) + (declare + (fixnum rslt) + (list bmark cmark)) + (with--term + (cffc gnrt) cmark + (loop + (when (eq :equal (funcall cmpr gnrt (car bmark))) + (return)) + (pop bmark) + (incf ic)) + (incf rslt (* cffc (aref p-1 diag-indx ic))) + (pop bmark) + (incf ic)))))) (the intr-mrph #'rslt)))) @@ -808,7 +810,7 @@ (fixnum first)) (the morphism (build-mrph - :sorc (echcm chcm) :trgt (z-chcm) :degr (- first) - :intr (chml-clss-intr chcm first) - :strt :cmbn - :orgn `(chml-clss ,chcm ,first)))) + :sorc (echcm chcm) :trgt (z-chcm) :degr (- first) + :intr (chml-clss-intr chcm first) + :strt :cmbn + :orgn `(chml-clss ,chcm ,first)))) diff --git a/src/special-smsts.lisp b/src/special-smsts.lisp index 702685a..af86c98 100644 --- a/src/special-smsts.lisp +++ b/src/special-smsts.lisp @@ -1,4 +1,5 @@ ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS ;;; SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS ;;; SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS diff --git a/src/suspensions.lisp b/src/suspensions.lisp index 31f1b7c..b186c69 100644 --- a/src/suspensions.lisp +++ b/src/suspensions.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; SUSPENSIONS SUSPENSIONS SUSPENSIONS SUSPENSIONS ;;; SUSPENSIONS SUSPENSIONS SUSPENSIONS SUSPENSIONS ;;; SUSPENSIONS SUSPENSIONS SUSPENSIONS SUSPENSIONS @@ -9,10 +11,10 @@ (DEFUN SUSPENSION-CMPR (cmpr) (declare (type cmprf cmpr)) (flet ((rslt (gnrt1 gnrt2) - (declare (type gnrt gnrt1 gnrt2)) - (if (eq gnrt1 :s-bsgn) - :equal - (funcall cmpr gnrt1 gnrt2)))) + (declare (type gnrt gnrt1 gnrt2)) + (if (eq gnrt1 :s-bsgn) + :equal + (funcall cmpr gnrt1 gnrt2)))) (the cmprf #'rslt))) @@ -21,35 +23,35 @@ (when (eq basis :locally-effective) (return-from suspension-basis :locally-effective)) (flet ((rslt (degr) - (declare (fixnum degr)) - (case degr - (0 (list :s-bsgn)) - (1 +empty-list+) - (otherwise (funcall basis (1- degr)))))) + (declare (fixnum degr)) + (case degr + (0 (list :s-bsgn)) + (1 +empty-list+) + (otherwise (funcall basis (1- degr)))))) (the basis #'rslt))) (DEFUN SUSPENSION-INTR-DFFR (dffr) (declare (type morphism dffr)) (flet ((rslt (cmbn) - (declare (type cmbn cmbn)) - (with-cmbn - (degr list) cmbn - (decf degr) - (if (<= degr 0) - (zero-cmbn degr) - (make-cmbn :degr degr - :list (cmbn-list - (cmbn-? dffr - (make-cmbn :degr degr - :list list)))))))) + (declare (type cmbn cmbn)) + (with-cmbn + (degr list) cmbn + (decf degr) + (if (<= degr 0) + (zero-cmbn degr) + (make-cmbn :degr degr + :list (cmbn-list + (cmbn-? dffr + (make-cmbn :degr degr + :list list)))))))) (the intr-mrph #'rslt))) (DEFUN SUSPENSION (obj &optional (n 1)) (declare (type (or chain-complex morphism reduction - homotopy-equivalence) obj) - (fixnum n)) + homotopy-equivalence) obj) + (fixnum n)) (if (= n 0) obj (suspension-1 (suspension obj (1- n))))) @@ -61,91 +63,91 @@ (DEFMETHOD SUSPENSION-1 ((chcm chain-complex)) (the chain-complex (with-slots (cmpr basis dffr) chcm - (build-chcm - :cmpr (suspension-cmpr cmpr) - :basis (suspension-basis basis) - :bsgn :s-bsgn - :intr-dffr (suspension-intr-dffr dffr) - :strt :cmbn - :orgn `(suspension ,chcm))))) + (build-chcm + :cmpr (suspension-cmpr cmpr) + :basis (suspension-basis basis) + :bsgn :s-bsgn + :intr-dffr (suspension-intr-dffr dffr) + :strt :cmbn + :orgn `(suspension ,chcm))))) (DEFUN SUSPENSION-INTR-CPRD (cmbn) (declare (type cmbn cmbn)) (the cmbn (with-cmbn - (degr list) cmbn - (if (zerop degr) - (make-cmbn :degr 0 - :list (if list - (list (term (-cffc list) - (tnpr 0 :s-bsgn - 0 :s-bsgn))) - +empty-list+)) - (make-cmbn :degr degr - :list (let ((list1 +empty-list+) - (list2 +empty-list+)) - (declare (list list1 list2)) - (mapc - #'(lambda (term) - (declare (type term term)) - (with-term - (cffc gnrt) term - (push (term cffc - (tnpr 0 :s-bsgn - degr gnrt)) - list1) - (push (term cffc - (tnpr degr gnrt - 0 :s-bsgn)) - list2))) - list) - (nreconc list1 (nreverse list2)))))))) + (degr list) cmbn + (if (zerop degr) + (make-cmbn :degr 0 + :list (if list + (list (term (-cffc list) + (tnpr 0 :s-bsgn + 0 :s-bsgn))) + +empty-list+)) + (make-cmbn :degr degr + :list (let ((list1 +empty-list+) + (list2 +empty-list+)) + (declare (list list1 list2)) + (mapc + #'(lambda (term) + (declare (type term term)) + (with-term + (cffc gnrt) term + (push (term cffc + (tnpr 0 :s-bsgn + degr gnrt)) + list1) + (push (term cffc + (tnpr degr gnrt + 0 :s-bsgn)) + list2))) + list) + (nreconc list1 (nreverse list2)))))))) (DEFMETHOD SUSPENSION-1 ((clgb coalgebra)) (the coalgebra (let ((irslt (call-next-method))) - (declare (type (or chain-complex coalgebra) irslt)) - (when (typep irslt 'coalgebra) - (return-from suspension-1 irslt)) - (change-chcm-to-clgb irslt :intr-cprd #'suspension-intr-cprd - :cprd-strt :cmbn) - (setf (slot-value irslt 'orgn) `(suspension ,clgb)) - (setf (slot-value (slot-value irslt 'cprd) 'orgn) - `(coproduct ,irslt)) - irslt))) + (declare (type (or chain-complex coalgebra) irslt)) + (when (typep irslt 'coalgebra) + (return-from suspension-1 irslt)) + (change-chcm-to-clgb irslt :intr-cprd #'suspension-intr-cprd + :cprd-strt :cmbn) + (setf (slot-value irslt 'orgn) `(suspension ,clgb)) + (setf (slot-value (slot-value irslt 'cprd) 'orgn) + `(coproduct ,irslt)) + irslt))) (DEFUN SUSPENSION-FACE (face) (declare (type face face)) (flet ((rslt (indx dmns gmsm) - (declare - (fixnum indx dmns) - (type gmsm gmsm)) - (assert (> dmns 1)) - (if (= indx dmns) - (absm (mask (1- dmns)) :s-bsgn) - (let ((irslt (funcall face indx (1- dmns) gmsm))) - (declare (type absm irslt)) - (if (= (dgop irslt) (mask (- dmns 2))) - (absm (mask (1- dmns)) :s-bsgn) - irslt))))) + (declare + (fixnum indx dmns) + (type gmsm gmsm)) + (assert (> dmns 1)) + (if (= indx dmns) + (absm (mask (1- dmns)) :s-bsgn) + (let ((irslt (funcall face indx (1- dmns) gmsm))) + (declare (type absm irslt)) + (if (= (dgop irslt) (mask (- dmns 2))) + (absm (mask (1- dmns)) :s-bsgn) + irslt))))) (the face #'rslt))) (DEFMETHOD SUSPENSION-1 ((smst simplicial-set)) (the simplicial-set (let ((irslt (call-next-method))) - (declare (type coalgebra irslt)) - (when (typep irslt 'simplicial-set) - (return-from suspension-1 irslt)) - (change-class irslt 'simplicial-set) - (setf (slot-value irslt 'face) - (suspension-face (face smst))) - (setf (slot-value (slot-value irslt 'cprd) 'orgn) - `(diagonal ,irslt)) - irslt))) + (declare (type coalgebra irslt)) + (when (typep irslt 'simplicial-set) + (return-from suspension-1 irslt)) + (change-class irslt 'simplicial-set) + (setf (slot-value irslt 'face) + (suspension-face (face smst))) + (setf (slot-value (slot-value irslt 'cprd) 'orgn) + `(diagonal ,irslt)) + irslt))) (DEFUN SUSPENSION-INTR (mrph) @@ -153,64 +155,64 @@ (let ((mdegr (degr mrph))) (declare (fixnum mdegr)) (flet ((rslt (cmbn) - (declare (type cmbn cmbn)) - (with-cmbn - (cdegr list) cmbn - (when (zerop cdegr) - (return-from rslt - (if (zerop mdegr) - cmbn - (zero-cmbn (+ mdegr cdegr))))) - (make-cmbn :degr (+ mdegr cdegr) - :list (cmbn-list - (cmbn-? mrph (make-cmbn :degr (1- cdegr) - :list list))))))) + (declare (type cmbn cmbn)) + (with-cmbn + (cdegr list) cmbn + (when (zerop cdegr) + (return-from rslt + (if (zerop mdegr) + cmbn + (zero-cmbn (+ mdegr cdegr))))) + (make-cmbn :degr (+ mdegr cdegr) + :list (cmbn-list + (cmbn-? mrph (make-cmbn :degr (1- cdegr) + :list list))))))) (the intr-mrph #'rslt)))) (DEFMETHOD SUSPENSION-1 ((mrph morphism)) (the morphism (let ((orgn (orgn mrph))) - (declare (list orgn)) - (when (eq (first orgn) 'zero-mrph) - (return-from suspension-1 - (zero-mrph (suspension (sorc mrph)) - (suspension (trgt mrph)) - (degr mrph)))) - (when (eq (first orgn) 'idnt-mrph) - (return-from suspension-1 - (idnt-mrph (suspension (sorc mrph))))) - (build-mrph - :sorc (suspension (sorc mrph)) - :trgt (suspension (trgt mrph)) - :degr (degr mrph) - :intr (suspension-intr mrph) - :strt :cmbn - :orgn `(suspension ,mrph))))) + (declare (list orgn)) + (when (eq (first orgn) 'zero-mrph) + (return-from suspension-1 + (zero-mrph (suspension (sorc mrph)) + (suspension (trgt mrph)) + (degr mrph)))) + (when (eq (first orgn) 'idnt-mrph) + (return-from suspension-1 + (idnt-mrph (suspension (sorc mrph))))) + (build-mrph + :sorc (suspension (sorc mrph)) + :trgt (suspension (trgt mrph)) + :degr (degr mrph) + :intr (suspension-intr mrph) + :strt :cmbn + :orgn `(suspension ,mrph))))) (DEFMETHOD SUSPENSION-1 ((rdct reduction)) (the reduction (progn - (when (eq (first (orgn rdct)) 'trivial-rdct) - (return-from suspension-1 - (trivial-rdct (suspension (second (orgn rdct)))))) - (build-rdct - :f (suspension (f rdct)) - :g (suspension (g rdct)) - :h (suspension (h rdct)) - :orgn `(suspension ,rdct))))) + (when (eq (first (orgn rdct)) 'trivial-rdct) + (return-from suspension-1 + (trivial-rdct (suspension (second (orgn rdct)))))) + (build-rdct + :f (suspension (f rdct)) + :g (suspension (g rdct)) + :h (suspension (h rdct)) + :orgn `(suspension ,rdct))))) (DEFMETHOD SUSPENSION-1 ((hmeq homotopy-equivalence)) (the homotopy-equivalence (progn - (when (eq (first (orgn hmeq)) 'trivial-hmeq) - (return-from suspension-1 - (trivial-hmeq (suspension - (second (orgn hmeq)))))) - (build-hmeq - :lrdct (suspension (lrdct hmeq)) - :rrdct (suspension (rrdct hmeq)) - :orgn `(suspension ,hmeq))))) + (when (eq (first (orgn hmeq)) 'trivial-hmeq) + (return-from suspension-1 + (trivial-hmeq (suspension + (second (orgn hmeq)))))) + (build-hmeq + :lrdct (suspension (lrdct hmeq)) + :rrdct (suspension (rrdct hmeq)) + :orgn `(suspension ,hmeq))))) (DEFMETHOD SEARCH-EFHM (suspension (orgn (eql 'suspension))) diff --git a/src/tensor-products.lisp b/src/tensor-products.lisp index 17dcba8..7c6a432 100644 --- a/src/tensor-products.lisp +++ b/src/tensor-products.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; TENSOR-PRODUCTS TENSOR-PRODUCTS TENSOR-PRODUCTS TENSOR-PRODUCTS TENSOR-PRODUCTS ;;; TENSOR-PRODUCTS TENSOR-PRODUCTS TENSOR-PRODUCTS TENSOR-PRODUCTS TENSOR-PRODUCTS ;;; TENSOR-PRODUCTS TENSOR-PRODUCTS TENSOR-PRODUCTS TENSOR-PRODUCTS TENSOR-PRODUCTS @@ -13,52 +15,52 @@ (ignore depth)) (the tnpr (progn - (with-tnpr (degr1 gnrt1 degr2 gnrt2) tnpr - (format stream - "" - *tnpr-with-degrees* degr1 gnrt1 - *tnpr-with-degrees* degr2 gnrt2)) - tnpr))) + (with-tnpr (degr1 gnrt1 degr2 gnrt2) tnpr + (format stream + "" + *tnpr-with-degrees* degr1 gnrt1 + *tnpr-with-degrees* degr2 gnrt2)) + tnpr))) (DEFUN 2CMBN-TNPR (cmbn1 cmbn2) (declare (type cmbn cmbn1 cmbn2)) (the cmbn (with-cmbn - (degr1 list1) cmbn1 - (with-cmbn - (degr2 list2) cmbn2 - (make-cmbn - :degr (+ degr1 degr2) - :list (mapcan - #'(lambda (term1) - (declare (type term term1)) - (the list - (with-term - (cffc1 gnrt1) term1 - (mapcar - #'(lambda (term2) - (declare (type term term2)) - (the term - (term - (* cffc1 (cffc term2)) - (tnpr degr1 gnrt1 degr2 - (gnrt term2))))) - list2)))) - list1)))))) + (degr1 list1) cmbn1 + (with-cmbn + (degr2 list2) cmbn2 + (make-cmbn + :degr (+ degr1 degr2) + :list (mapcan + #'(lambda (term1) + (declare (type term term1)) + (the list + (with-term + (cffc1 gnrt1) term1 + (mapcar + #'(lambda (term2) + (declare (type term term2)) + (the term + (term + (* cffc1 (cffc term2)) + (tnpr degr1 gnrt1 degr2 + (gnrt term2))))) + list2)))) + list1)))))) #| (DEFUN TNSR-PRDC-CMPR (cmpr1 cmpr2) (declare (type cmprf cmpr1 cmpr2)) (flet ((rslt (tnpr1 tnpr2) - (declare (type tnpr tnpr1 tnpr2)) - (let ((left-cons-1 (cadr tnpr1)) - (left-cons-2 (cadr tnpr2))) - (declare (cons left-cons-1 left-cons-2)) - (lexico - (f-cmpr (car left-cons-1) (car left-cons-2)) - (funcall cmpr1 (cdr left-cons-1) (cdr left-cons-2)) - (funcall cmpr2 (gnrt2 tnpr1) (gnrt2 tnpr2)))))) + (declare (type tnpr tnpr1 tnpr2)) + (let ((left-cons-1 (cadr tnpr1)) + (left-cons-2 (cadr tnpr2))) + (declare (cons left-cons-1 left-cons-2)) + (lexico + (f-cmpr (car left-cons-1) (car left-cons-2)) + (funcall cmpr1 (cdr left-cons-1) (cdr left-cons-2)) + (funcall cmpr2 (gnrt2 tnpr1) (gnrt2 tnpr2)))))) (the cmprf #'rslt))) |# (DEFUN TNSR-PRDC-CMPR (cmpr1 cmpr2) @@ -66,87 +68,87 @@ (flet ((rslt (tnpr1 tnpr2) (declare (type tnpr tnpr1 tnpr2)) (the cmpr - (lexico - (f-cmpr (degr1 tnpr1) (degr1 tnpr2)) - (funcall cmpr1 (gnrt1 tnpr1) (gnrt1 tnpr2)) - (funcall cmpr2 (gnrt2 tnpr1) (gnrt2 tnpr2)))))) + (lexico + (f-cmpr (degr1 tnpr1) (degr1 tnpr2)) + (funcall cmpr1 (gnrt1 tnpr1) (gnrt1 tnpr2)) + (funcall cmpr2 (gnrt2 tnpr1) (gnrt2 tnpr2)))))) (the cmprf #'rslt))) (DEFUN TNSR-PRDC-BASIS (basis1 basis2) (declare (type basis basis1 basis2)) (when (or (eq basis1 :locally-effective) - (eq basis2 :locally-effective)) + (eq basis2 :locally-effective)) (return-from tnsr-prdc-basis :locally-effective)) (flet ((rslt (degr) - (declare (fixnum degr)) - (the list + (declare (fixnum degr)) + (the list (progn - (when (minusp degr) - (return-from rslt +empty-list+)) - (mapcan - #'(lambda (degr1) - (declare (fixnum degr1)) - (let* ((basis1 (funcall basis1 degr1)) - (degr2 (- degr degr1)) - (basis2 (funcall basis2 degr2))) - (declare - (fixnum degr2) - (list basis1 basis2)) - (the list - (mapcan - #'(lambda (gnrt1) - (declare (type gnrt gnrt1)) - (the list - (mapcar - #'(lambda (gnrt2) - (declare (type gnrt gnrt2)) - (the tnpr - (tnpr degr1 gnrt1 degr2 - gnrt2))) - basis2))) - basis1)))) - ( 0 degr)))))) + (when (minusp degr) + (return-from rslt +empty-list+)) + (mapcan + #'(lambda (degr1) + (declare (fixnum degr1)) + (let* ((basis1 (funcall basis1 degr1)) + (degr2 (- degr degr1)) + (basis2 (funcall basis2 degr2))) + (declare + (fixnum degr2) + (list basis1 basis2)) + (the list + (mapcan + #'(lambda (gnrt1) + (declare (type gnrt gnrt1)) + (the list + (mapcar + #'(lambda (gnrt2) + (declare (type gnrt gnrt2)) + (the tnpr + (tnpr degr1 gnrt1 degr2 + gnrt2))) + basis2))) + basis1)))) + ( 0 degr)))))) (the basis #'rslt))) (DEFUN TNSR-PRDC-INTR-DFFR (dffr1 dffr2) (declare (type morphism dffr1 dffr2)) (flet ((rslt (degr tnpr) - (declare - (fixnum degr) - (type tnpr tnpr)) - (the cmbn + (declare + (fixnum degr) + (type tnpr tnpr)) + (the cmbn (with-tnpr - (degr1 gnrt1 degr2 gnrt2) tnpr - (let ((degr1-1 (1- degr1)) - (degr2-1 (1- degr2)) - (sign (oddp degr1)) - (list1 (cmbn-list (gnrt-? dffr1 degr1 gnrt1))) - (list2 (cmbn-list (gnrt-? dffr2 degr2 gnrt2)))) - (declare - (fixnum degr1-1 degr2-1) - (boolean sign) - (list list1 list2)) - (make-cmbn - :degr (1- degr) - :list (nconc - (mapcar - #'(lambda (term1) - (declare (type term term1)) - (with-term - (cffc1 gnrt1) term1 - (term cffc1 (tnpr degr1-1 gnrt1 - degr2 gnrt2)))) - list1) - (mapcar - #'(lambda (term2) - (declare (type term term2)) - (with-term (cffc2 gnrt2) term2 - (term (if sign (- cffc2) cffc2) - (tnpr degr1 gnrt1 - degr2-1 gnrt2)))) - list2)))))))) + (degr1 gnrt1 degr2 gnrt2) tnpr + (let ((degr1-1 (1- degr1)) + (degr2-1 (1- degr2)) + (sign (oddp degr1)) + (list1 (cmbn-list (gnrt-? dffr1 degr1 gnrt1))) + (list2 (cmbn-list (gnrt-? dffr2 degr2 gnrt2)))) + (declare + (fixnum degr1-1 degr2-1) + (boolean sign) + (list list1 list2)) + (make-cmbn + :degr (1- degr) + :list (nconc + (mapcar + #'(lambda (term1) + (declare (type term term1)) + (with-term + (cffc1 gnrt1) term1 + (term cffc1 (tnpr degr1-1 gnrt1 + degr2 gnrt2)))) + list1) + (mapcar + #'(lambda (term2) + (declare (type term term2)) + (with-term (cffc2 gnrt2) term2 + (term (if sign (- cffc2) cffc2) + (tnpr degr1 gnrt1 + degr2-1 gnrt2)))) + list2)))))))) (the intr-mrph #'rslt))) @@ -156,28 +158,28 @@ (the chain-complex (with-slots ((cmpr1 cmpr) (basis1 basis) (dffr1 dffr)) chcm1 (declare - (type cmprf cmpr1) - (type basis basis1) - (type morphism dffr1)) - (with-slots ((cmpr2 cmpr) (basis2 basis) (dffr2 dffr)) chcm2 - (declare + (type cmprf cmpr1) + (type basis basis1) + (type morphism dffr1)) + (with-slots ((cmpr2 cmpr) (basis2 basis) (dffr2 dffr)) chcm2 + (declare (type cmprf cmpr2) (type basis basis2) - (type morphism dffr2)) - (let ((rslt - (build-chcm - :cmpr (tnsr-prdc-cmpr cmpr1 cmpr2) - :basis (tnsr-prdc-basis basis1 basis2) - :intr-dffr (tnsr-prdc-intr-dffr dffr1 dffr2) - :strt :gnrt - :orgn `(tnsr-prdc ,chcm1 ,chcm2)))) - (declare (type chain-complex rslt)) - (if (and (slot-boundp chcm1 'bsgn) - (slot-boundp chcm2 'bsgn)) - (setf (slot-value rslt 'bsgn) - (tnpr 0 (bsgn chcm1) 0 (bsgn chcm2))) - (slot-makunbound rslt 'bsgn)) - rslt))))) + (type morphism dffr2)) + (let ((rslt + (build-chcm + :cmpr (tnsr-prdc-cmpr cmpr1 cmpr2) + :basis (tnsr-prdc-basis basis1 basis2) + :intr-dffr (tnsr-prdc-intr-dffr dffr1 dffr2) + :strt :gnrt + :orgn `(tnsr-prdc ,chcm1 ,chcm2)))) + (declare (type chain-complex rslt)) + (if (and (slot-boundp chcm1 'bsgn) + (slot-boundp chcm2 'bsgn)) + (setf (slot-value rslt 'bsgn) + (tnpr 0 (bsgn chcm1) 0 (bsgn chcm2))) + (slot-makunbound rslt 'bsgn)) + rslt))))) (DEFUN TNSR-PRDC-INTR (mrph1 mrph2) @@ -186,84 +188,84 @@ (let ((mrph2-sign (oddp (degr mrph2)))) (declare (type boolean mrph2-sign)) (flet ((rslt (degr tnpr) - (declare - (ignore degr) - (type tnpr tnpr)) - (with-tnpr (degr1 gnrt1 degr2 gnrt2) tnpr - (let ((rslt (2cmbn-tnpr - (gnrt-? mrph1 degr1 gnrt1) - (gnrt-? mrph2 degr2 gnrt2)))) - (declare (type cmbn rslt)) - (when (and mrph2-sign - (oddp degr1)) - (mapc #'(lambda (term) - (declare (type term term)) - (setf (the fixnum (cffc term)) - (the fixnum (- (cffc term))))) - (cmbn-list rslt))) - rslt)))) + (declare + (ignore degr) + (type tnpr tnpr)) + (with-tnpr (degr1 gnrt1 degr2 gnrt2) tnpr + (let ((rslt (2cmbn-tnpr + (gnrt-? mrph1 degr1 gnrt1) + (gnrt-? mrph2 degr2 gnrt2)))) + (declare (type cmbn rslt)) + (when (and mrph2-sign + (oddp degr1)) + (mapc #'(lambda (term) + (declare (type term term)) + (setf (the fixnum (cffc term)) + (the fixnum (- (cffc term))))) + (cmbn-list rslt))) + rslt)))) (the intr-mrph #'rslt)))) (DEFMETHOD TNSR-PRDC ((mrph1 morphism) (mrph2 morphism)) (the morphism (with-slots ((sorc1 sorc) (trgt1 trgt) (degr1 degr)) mrph1 - (with-slots ((sorc2 sorc) (trgt2 trgt) (degr2 degr)) mrph2 - (the morphism - (progn - (when (and (eq 'idnt-mrph (first (orgn mrph1))) - (eq 'idnt-mrph (first (orgn mrph2)))) - (return-from tnsr-prdc - (idnt-mrph (tnsr-prdc sorc1 sorc2)))) - (when (or (eq 'zero-mrph (first (orgn mrph1))) - (eq 'zero-mrph (first (orgn mrph2)))) - (return-from tnsr-prdc - (zero-mrph (tnsr-prdc sorc1 sorc2) - (tnsr-prdc trgt1 trgt2) - (+ degr1 degr2)))) - (build-mrph - :sorc (tnsr-prdc sorc1 sorc2) - :trgt (tnsr-prdc trgt1 trgt2) - :degr (+ degr1 degr2) - :intr (tnsr-prdc-intr mrph1 mrph2) - :strt :gnrt - :orgn `(tnsr-prdc ,mrph1 ,mrph2)))))))) + (with-slots ((sorc2 sorc) (trgt2 trgt) (degr2 degr)) mrph2 + (the morphism + (progn + (when (and (eq 'idnt-mrph (first (orgn mrph1))) + (eq 'idnt-mrph (first (orgn mrph2)))) + (return-from tnsr-prdc + (idnt-mrph (tnsr-prdc sorc1 sorc2)))) + (when (or (eq 'zero-mrph (first (orgn mrph1))) + (eq 'zero-mrph (first (orgn mrph2)))) + (return-from tnsr-prdc + (zero-mrph (tnsr-prdc sorc1 sorc2) + (tnsr-prdc trgt1 trgt2) + (+ degr1 degr2)))) + (build-mrph + :sorc (tnsr-prdc sorc1 sorc2) + :trgt (tnsr-prdc trgt1 trgt2) + :degr (+ degr1 degr2) + :intr (tnsr-prdc-intr mrph1 mrph2) + :strt :gnrt + :orgn `(tnsr-prdc ,mrph1 ,mrph2)))))))) (DEFMETHOD TNSR-PRDC ((rdct1 reduction) (rdct2 reduction)) (the reduction (progn - (when (and (eq 'trivial-rdct (first (orgn rdct1))) - (eq 'trivial-rdct (first (orgn rdct2)))) - (return-from tnsr-prdc - (trivial-rdct (tnsr-prdc (bcc rdct1) (bcc rdct2))))) - (with-slots ((tcc1 tcc) (bcc1 bcc) (f1 f) (g1 g) (h1 h)) rdct1 - (declare - (type chain-complex tcc1 bcc1) - (type morphism f1 g1 h1)) - (with-slots ((tcc2 tcc) (bcc2 bcc) (f2 f) (g2 g) (h2 h)) rdct2 - (declare - (type chain-complex tcc2 bcc2) - (type morphism f2 g2 h2)) - (build-rdct - :f (tnsr-prdc f1 f2) - :g (tnsr-prdc g1 g2) - :h (add - (tnsr-prdc h1 (cmps g2 f2)) - (tnsr-prdc (idnt-mrph tcc1) h2)) - :orgn `(tnsr-prdc ,rdct1 ,rdct2))))))) + (when (and (eq 'trivial-rdct (first (orgn rdct1))) + (eq 'trivial-rdct (first (orgn rdct2)))) + (return-from tnsr-prdc + (trivial-rdct (tnsr-prdc (bcc rdct1) (bcc rdct2))))) + (with-slots ((tcc1 tcc) (bcc1 bcc) (f1 f) (g1 g) (h1 h)) rdct1 + (declare + (type chain-complex tcc1 bcc1) + (type morphism f1 g1 h1)) + (with-slots ((tcc2 tcc) (bcc2 bcc) (f2 f) (g2 g) (h2 h)) rdct2 + (declare + (type chain-complex tcc2 bcc2) + (type morphism f2 g2 h2)) + (build-rdct + :f (tnsr-prdc f1 f2) + :g (tnsr-prdc g1 g2) + :h (add + (tnsr-prdc h1 (cmps g2 f2)) + (tnsr-prdc (idnt-mrph tcc1) h2)) + :orgn `(tnsr-prdc ,rdct1 ,rdct2))))))) (DEFMETHOD TNSR-PRDC ((hmeq1 homotopy-equivalence) - (hmeq2 homotopy-equivalence)) + (hmeq2 homotopy-equivalence)) (the homotopy-equivalence (build-hmeq :lrdct (tnsr-prdc (lrdct hmeq1) (lrdct hmeq2)) - :rrdct (tnsr-prdc (rrdct hmeq1) (rrdct hmeq2)) - :orgn `(tnsr-prdc ,hmeq1 ,hmeq2)))) + :rrdct (tnsr-prdc (rrdct hmeq1) (rrdct hmeq2)) + :orgn `(tnsr-prdc ,hmeq1 ,hmeq2)))) (DEFMETHOD SEARCH-EFHM (chcm (orgn (eql 'tnsr-prdc))) (declare (type chain-complex chcm)) (the homotopy-equivalence (tnsr-prdc (efhm (second (orgn chcm))) - (efhm (third (orgn chcm)))))) + (efhm (third (orgn chcm)))))) diff --git a/src/various.lisp b/src/various.lisp index 81a67b8..04174e7 100644 --- a/src/various.lisp +++ b/src/various.lisp @@ -1,4 +1,4 @@ -;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* ;;; VARIOUS VARIOUS VARIOUS VARIOUS VARIOUS VARIOUS ;;; VARIOUS VARIOUS VARIOUS VARIOUS VARIOUS VARIOUS diff --git a/src/whitehead.lisp b/src/whitehead.lisp index f3a062a..6e79aab 100644 --- a/src/whitehead.lisp +++ b/src/whitehead.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD ;;; WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD ;;; WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD @@ -11,10 +13,10 @@ ;;; (DEFUN Z-WWHITEHEAD-SINTR (smst n chml-clss - &aux (face (face smst)) - (k-z-n (k-z n)) - (idnt (bspn k-z-n)) - (efhm (efhm smst))) + &aux (face (face smst)) + (k-z-n (k-z n)) + (idnt (bspn k-z-n)) + (efhm (efhm smst))) (declare (type simplicial-set smst) (fixnum n) @@ -24,23 +26,23 @@ (type gmsm idnt) (type homotopy-equivalence efhm)) (setf chml-clss - (i-cmps chml-clss (rf efhm) (lg efhm))) + (i-cmps chml-clss (rf efhm) (lg efhm))) (flet ((rslt (dmns gmsm) - (declare - (fixnum dmns) - (type gmsm gmsm)) - (if (< dmns n) - (absm (mask dmns) idnt) - (z-cocycle-gbar n dmns - (gmsm-cocycle face n dmns gmsm chml-clss))))) + (declare + (fixnum dmns) + (type gmsm gmsm)) + (if (< dmns n) + (absm (mask dmns) idnt) + (z-cocycle-gbar n dmns + (gmsm-cocycle face n dmns gmsm chml-clss))))) (the sintr #'rslt))) (DEFUN Z-WHITEHEAD-SINTR (smst n chml-clss - &aux (face (face smst)) - (k-z-n-1 (k-z (1- n))) - (idnt (bspn k-z-n-1)) - (efhm (efhm smst))) + &aux (face (face smst)) + (k-z-n-1 (k-z (1- n))) + (idnt (bspn k-z-n-1)) + (efhm (efhm smst))) (declare (type simplicial-set smst) (fixnum n) @@ -50,15 +52,15 @@ (type gmsm idnt) (type homotopy-equivalence efhm)) (setf chml-clss - (i-cmps chml-clss (rf efhm) (lg efhm))) + (i-cmps chml-clss (rf efhm) (lg efhm))) (flet ((rslt (dmns gmsm) - (declare - (fixnum dmns) - (type gmsm gmsm)) - (if (< dmns n) - (absm (mask (1- dmns)) idnt) - (z-cocycle-gbar-head n dmns - (gmsm-cocycle face n dmns gmsm chml-clss))))) + (declare + (fixnum dmns) + (type gmsm gmsm)) + (if (< dmns n) + (absm (mask (1- dmns)) idnt) + (z-cocycle-gbar-head n dmns + (gmsm-cocycle face n dmns gmsm chml-clss))))) (the sintr #'rslt))) @@ -69,19 +71,19 @@ (type morphism chml-clss)) (the fibration (build-smmr - :sorc smst :trgt (k-z (1- n)) :degr -1 - :sintr (z-whitehead-sintr smst n chml-clss) - :orgn `(z-whitehead ,smst)))) + :sorc smst :trgt (k-z (1- n)) :degr -1 + :sintr (z-whitehead-sintr smst n chml-clss) + :orgn `(z-whitehead ,smst)))) ;;; ;;; Z/2Z ;;; (DEFUN Z2-WWHITEHEAD-SINTR (smst n chml-clss - &aux (face (face smst)) - (k-z2-n (k-z2 n)) - (idnt (bspn k-z2-n)) - (efhm (efhm smst))) + &aux (face (face smst)) + (k-z2-n (k-z2 n)) + (idnt (bspn k-z2-n)) + (efhm (efhm smst))) (declare (type simplicial-set smst) (fixnum n) @@ -91,23 +93,23 @@ (type gmsm idnt) (type homotopy-equivalence efhm)) (setf chml-clss - (i-cmps chml-clss (rf efhm) (lg efhm))) + (i-cmps chml-clss (rf efhm) (lg efhm))) (flet ((rslt (dmns gmsm) - (declare - (fixnum dmns) - (type gmsm gmsm)) - (if (< dmns n) - (absm (mask dmns) idnt) - (z2-cocycle-gbar n dmns - (gmsm-cocycle face n dmns gmsm chml-clss))))) + (declare + (fixnum dmns) + (type gmsm gmsm)) + (if (< dmns n) + (absm (mask dmns) idnt) + (z2-cocycle-gbar n dmns + (gmsm-cocycle face n dmns gmsm chml-clss))))) (the sintr #'rslt))) (DEFUN Z2-WHITEHEAD-SINTR (smst n chml-clss - &aux (face (face smst)) - (k-z2-n-1 (k-z2 (1- n))) - (idnt (bspn k-z2-n-1)) - (efhm (efhm smst))) + &aux (face (face smst)) + (k-z2-n-1 (k-z2 (1- n))) + (idnt (bspn k-z2-n-1)) + (efhm (efhm smst))) (declare (type simplicial-set smst) (fixnum n) @@ -117,16 +119,16 @@ (type gmsm idnt) (type homotopy-equivalence efhm)) (setf chml-clss - (i-cmps chml-clss (rf efhm) (lg efhm))) + (i-cmps chml-clss (rf efhm) (lg efhm))) (flet ((rslt (dmns gmsm) - (declare - (fixnum dmns) - (type gmsm gmsm)) - (if (< dmns n) - (absm (mask (1- dmns)) idnt) - (z2-cocycle-gbar-head n dmns - (gmsm-cocycle face n dmns gmsm - chml-clss))))) + (declare + (fixnum dmns) + (type gmsm gmsm)) + (if (< dmns n) + (absm (mask (1- dmns)) idnt) + (z2-cocycle-gbar-head n dmns + (gmsm-cocycle face n dmns gmsm + chml-clss))))) (the sintr #'rslt))) @@ -137,6 +139,6 @@ (type morphism chml-clss)) (the fibration (build-smmr - :sorc smst :trgt (k-z2 (1- n)) :degr -1 - :sintr (Z2-whitehead-sintr smst n chml-clss) - :orgn `(Z2-whitehead ,smst)))) + :sorc smst :trgt (k-z2 (1- n)) :degr -1 + :sintr (Z2-whitehead-sintr smst n chml-clss) + :orgn `(Z2-whitehead ,smst)))) diff --git a/test/Test.lisp b/test/Test.lisp index b7959e2..7a77fc0 100644 --- a/test/Test.lisp +++ b/test/Test.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;; TEST TEST TEST TEST TEST TEST TEST TEST TEST TEST TEST TEST ;;; TEST TEST TEST TEST TEST TEST TEST TEST TEST TEST TEST TEST ;;; TEST TEST TEST TEST TEST TEST TEST TEST TEST TEST TEST TEST @@ -16,9 +18,9 @@ (homology (loop-space (moore 2 4) 2) 7) (homology (k-z2 2) 3 8) - + (homology (k-z2 3) 3 8) - + (setf s3 (sphere 3)) (homology s3 3) (setf ch3 (chml-clss s3 3)) @@ -33,7 +35,7 @@ (setf f5 (z-whitehead x5 ch5)) (setf x6 (fibration-total f5)) -)) + )) (time (homology o2s3 7)) -(time (homology x6 6)) \ No newline at end of file +(time (homology x6 6)) diff --git a/test/bar-test.lisp b/test/bar-test.lisp index f7da188..7b740b3 100644 --- a/test/bar-test.lisp +++ b/test/bar-test.lisp @@ -1,4 +1,4 @@ -;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :kenzo-test) diff --git a/test/bicones-test.lisp b/test/bicones-test.lisp index 2158ad5..e0a0396 100644 --- a/test/bicones-test.lisp +++ b/test/bicones-test.lisp @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :kenzo-test) @@ -5,114 +6,114 @@ (test bicn-cmbn (let* ((comb-bic (cat:cmbn 3 2 (cat:bcnb 'b1) 4 (cat:bcnb 'b2) - 6 (cat:bcnb 'b3) 3 (cat:bcnc 'c1) - 5 (cat:bcnc 'c2) 7 (cat:bcnd 'd1)))) - (cat:cmbn-list comb-bic) - (cat:dispatch-bicn-cmbn (cat:cmbn 3 3 (cat:bcnb 'b1) - 4 (cat:bcnb 'b2) - 33 (cat:bcnc 'c) - 333 (cat:bcnd 'd))))) + 6 (cat:bcnb 'b3) 3 (cat:bcnc 'c1) + 5 (cat:bcnc 'c2) 7 (cat:bcnd 'd1)))) + (cat:cmbn-list comb-bic) + (cat:dispatch-bicn-cmbn (cat:cmbn 3 3 (cat:bcnb 'b1) + 4 (cat:bcnb 'b2) + 33 (cat:bcnc 'c) + 333 (cat:bcnd 'd))))) (test bicn-cmbn-cmbn* (is (cat:cmbn-non-zero-p - (cat:bicn-cmbn-cmbnb (cat:cmbn 3 1 (cat:bcnb 'a) 2 (cat:bcnc 'b))))) + (cat:bicn-cmbn-cmbnb (cat:cmbn 3 1 (cat:bcnb 'a) 2 (cat:bcnc 'b))))) (is (cat:cmbn-zero-p - (cat:bicn-cmbn-cmbnb (cat:cmbn 3 2 (cat:bcnc 'b))))) + (cat:bicn-cmbn-cmbnb (cat:cmbn 3 2 (cat:bcnc 'b))))) (is (cat:cmbn-non-zero-p - (cat:bicn-cmbn-cmbnc (cat:cmbn 3 1 (cat:bcnb 'a) 2 (cat:bcnc 'b) - 3 (cat:bcnd 'c))))) + (cat:bicn-cmbn-cmbnc (cat:cmbn 3 1 (cat:bcnb 'a) 2 (cat:bcnc 'b) + 3 (cat:bcnd 'c))))) (is (cat:cmbn-zero-p - (cat:bicn-cmbn-cmbnc (cat:cmbn 3 1 (cat:bcnb 'a) 3 (cat:bcnd 'c))))) + (cat:bicn-cmbn-cmbnc (cat:cmbn 3 1 (cat:bcnb 'a) 3 (cat:bcnd 'c))))) (is (cat:cmbn-non-zero-p - (cat:bicn-cmbn-cmbnd (cat:cmbn 3 1 (cat:bcnb 'a) 2 (cat:bcnc 'b) - 3 (cat:bcnd 'c))))) + (cat:bicn-cmbn-cmbnd (cat:cmbn 3 1 (cat:bcnb 'a) 2 (cat:bcnc 'b) + 3 (cat:bcnd 'c))))) (is (cat:cmbn-zero-p - (cat:bicn-cmbn-cmbnd (cat:cmbn 3 2 (cat:bcnb 'b)))))) + (cat:bicn-cmbn-cmbnd (cat:cmbn 3 2 (cat:bcnb 'b)))))) (test make-bicn-cmbn (multiple-value-call #'cat:make-bicn-cmbn - (cat:dispatch-bicn-cmbn - (cat:cmbn 3 3 (cat:bcnb 'b1) 4 (cat:bcnb 'b2) 33 (cat:bcnc 'c) - 333 (cat:bcnd 'd))))) + (cat:dispatch-bicn-cmbn + (cat:cmbn 3 3 (cat:bcnb 'b1) 4 (cat:bcnb 'b2) 33 (cat:bcnc 'c) + 333 (cat:bcnd 'd))))) (test bicn-print (let ((a (format nil "~A" (cat:bcnb 'a))) - (b (format nil "~A" (cat:bcnc 'b))) - (c (format nil "~A" (cat:bcnd 'c)))) - (is (string= a "")) - (is (string= b "")) - (is (string= c "")))) + (b (format nil "~A" (cat:bcnc 'b))) + (c (format nil "~A" (cat:bcnd 'c)))) + (is (string= a "")) + (is (string= b "")) + (is (string= c "")))) (test bicone-cmpr (let ((r (cat:bicone-cmpr #'cat:f-cmpr #'cat:f-cmpr #'cat:f-cmpr))) - (is (equal :less (funcall r (cat:bcnb 1) (cat:bcnc 0)))) - (is (equal :less (funcall r (cat:bcnb 1) (cat:bcnb 2)))))) + (is (equal :less (funcall r (cat:bcnb 1) (cat:bcnc 0)))) + (is (equal :less (funcall r (cat:bcnb 1) (cat:bcnb 2)))))) (test bicone-basis (is (equal :locally-effective - (cat:bicone-basis :locally-effective - :locally-effective - :locally-effective))) + (cat:bicone-basis :locally-effective + :locally-effective + :locally-effective))) (let* ((b #'(lambda (degr) - (mapcar #'(lambda (item) - (cons degr item)) (cat: 0 degr)))) - (r (cat:bicone-basis b b b))) - (is (not (null (funcall r 3)))))) + (mapcar #'(lambda (item) + (cons degr item)) (cat: 0 degr)))) + (r (cat:bicone-basis b b b))) + (is (not (null (funcall r 3)))))) (test bicone (progn - (cat:cat-init) - (let ((delta3 (cdelta1 3)) - (bic (cat:bicone (make-rdct1 3 2) (make-rdct1 4 2)))) - #| - (princ (cat:basis delta3 0)) - (princ (cat:basis delta3 1)) - (princ (cat:basis delta3 2)) - (princ (cat:basis delta3 3)) - (princ (cat:basis delta3 4)) - |# - (princ (cat:basis bic 0)) - (princ (cat:basis bic 1)) - (princ (cat:basis bic 4)) - (princ (cat:? bic (cat:cmbn 2 3 (cat:bcnb '(0 1 3)) - 4 (cat:bcnc '(0 1 2 3)) - 5 (cat:bcnd '(0 1 4))))) - (is (cat:cmbn-zero-p - (cat:? bic - (cat:? bic (cat:cmbn 2 3 (cat:bcnb '(0 1 3)) - 4 (cat:bcnc '(0 1 2 3)) - 5 (cat:bcnd '(0 1 4)))))))))) + (cat:cat-init) + (let ((delta3 (cdelta1 3)) + (bic (cat:bicone (make-rdct1 3 2) (make-rdct1 4 2)))) + #| + (princ (cat:basis delta3 0)) + (princ (cat:basis delta3 1)) + (princ (cat:basis delta3 2)) + (princ (cat:basis delta3 3)) + (princ (cat:basis delta3 4)) + |# + (princ (cat:basis bic 0)) + (princ (cat:basis bic 1)) + (princ (cat:basis bic 4)) + (princ (cat:? bic (cat:cmbn 2 3 (cat:bcnb '(0 1 3)) + 4 (cat:bcnc '(0 1 2 3)) + 5 (cat:bcnd '(0 1 4))))) + (is (cat:cmbn-zero-p + (cat:? bic + (cat:? bic (cat:cmbn 2 3 (cat:bcnb '(0 1 3)) + 4 (cat:bcnc '(0 1 2 3)) + 5 (cat:bcnd '(0 1 4)))))))))) (test cmps (progn - (cat:cat-init) - (let* ((c (cat:build-chcm - :cmpr #'cat:s-cmpr - :basis #'(lambda (dmns) '(a)) - :bsgn 'a - :intr-dffr #'cat:zero-intr-dffr - :strt :cmbn - :orgn '(c))) - (h1 (cat:trivial-hmeq c)) - (h2 (cat:cmps h1 h1)) - (h3 (cat:cmps h2 h2))) - (cat:pre-check-rdct (cat:lrdct h2)) - (setf cat:*tc* (cat:cmbn 3 1 (cat:bcnB 'a) 10 (cat:bcnC 'a) - 100 (cat:bcnD 'a))) - (setf cat:*bc* (cat:cmbn 3 1 'a)) - (check-rdct) - (cat:pre-check-rdct (cat:rrdct h2)) - (check-rdct) - (setf cat:*tc* (cat:cmbn 3 1 (cat:bcnB (cat:bcnB 'a)) - 10 (cat:bcnB (cat:bcnC 'a)) - 100 (cat:bcnB (cat:bcnD 'a)) - 1000 (cat:bcnC 'a) - 10000 (cat:bcnD (cat:bcnB 'a)) - 5234 (cat:bcnD (cat:bcnC 'a)) - 223 (cat:bcnD (cat:bcnD 'a)))) - (cat:pre-check-rdct (cat:lrdct h3)) - (check-rdct) - (cat:pre-check-rdct (cat:rrdct h3)) - (check-rdct)))) + (cat:cat-init) + (let* ((c (cat:build-chcm + :cmpr #'cat:s-cmpr + :basis #'(lambda (dmns) '(a)) + :bsgn 'a + :intr-dffr #'cat:zero-intr-dffr + :strt :cmbn + :orgn '(c))) + (h1 (cat:trivial-hmeq c)) + (h2 (cat:cmps h1 h1)) + (h3 (cat:cmps h2 h2))) + (cat:pre-check-rdct (cat:lrdct h2)) + (setf cat:*tc* (cat:cmbn 3 1 (cat:bcnB 'a) 10 (cat:bcnC 'a) + 100 (cat:bcnD 'a))) + (setf cat:*bc* (cat:cmbn 3 1 'a)) + (check-rdct) + (cat:pre-check-rdct (cat:rrdct h2)) + (check-rdct) + (setf cat:*tc* (cat:cmbn 3 1 (cat:bcnB (cat:bcnB 'a)) + 10 (cat:bcnB (cat:bcnC 'a)) + 100 (cat:bcnB (cat:bcnD 'a)) + 1000 (cat:bcnC 'a) + 10000 (cat:bcnD (cat:bcnB 'a)) + 5234 (cat:bcnD (cat:bcnC 'a)) + 223 (cat:bcnD (cat:bcnD 'a)))) + (cat:pre-check-rdct (cat:lrdct h3)) + (check-rdct) + (cat:pre-check-rdct (cat:rrdct h3)) + (check-rdct)))) diff --git a/test/cartesian-products-test.lisp b/test/cartesian-products-test.lisp index 2222753..3fbb087 100644 --- a/test/cartesian-products-test.lisp +++ b/test/cartesian-products-test.lisp @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :kenzo-test) @@ -5,12 +6,12 @@ (test extract-common-dgop (dotimes (i 100) - (dotimes (j 100) - (multiple-value-bind (dgop dgop1 dgop2) (cat:extract-common-dgop i j) - (unless (and (= i (cat:dgop*dgop dgop dgop1)) - (= j (cat:dgop*dgop dgop dgop2))) - (error "i = ~D, j = ~D, dgop = ~D, dgop1 = ~D, dgop2 = ~D" - i j dgop dgop1 dgop2)))))) + (dotimes (j 100) + (multiple-value-bind (dgop dgop1 dgop2) (cat:extract-common-dgop i j) + (unless (and (= i (cat:dgop*dgop dgop dgop1)) + (= j (cat:dgop*dgop dgop dgop2))) + (error "i = ~D, j = ~D, dgop = ~D, dgop1 = ~D, dgop2 = ~D" + i j dgop dgop1 dgop2)))))) (test 2absm-acrpr @@ -19,96 +20,96 @@ (test crts-prdc-cmpr (let* ((c (cat:cmpr (cat:delta-infinity))) - (rslt (cat:crts-prdc-cmpr c c))) - (is (equal :less (funcall rslt (cat:crpr 0 3 0 3) (cat:crpr 1 1 0 3)))) - (is (equal :greater - (funcall rslt (cat:crpr 4 3 0 7) (cat:crpr 3 1 0 7)))) - (is (equal :less (funcall rslt (cat:crpr 0 3 0 3) (cat:crpr 0 3 1 1)))) - (is (equal :less (funcall rslt (cat:crpr 0 3 0 3) (cat:crpr 0 5 0 3)))) - (is (equal :less (funcall rslt (cat:crpr 0 3 0 3) (cat:crpr 0 3 0 5)))) - (is (equal :equal - (funcall rslt (cat:crpr 0 3 0 3) (cat:crpr 0 3 0 3)))))) + (rslt (cat:crts-prdc-cmpr c c))) + (is (equal :less (funcall rslt (cat:crpr 0 3 0 3) (cat:crpr 1 1 0 3)))) + (is (equal :greater + (funcall rslt (cat:crpr 4 3 0 7) (cat:crpr 3 1 0 7)))) + (is (equal :less (funcall rslt (cat:crpr 0 3 0 3) (cat:crpr 0 3 1 1)))) + (is (equal :less (funcall rslt (cat:crpr 0 3 0 3) (cat:crpr 0 5 0 3)))) + (is (equal :less (funcall rslt (cat:crpr 0 3 0 3) (cat:crpr 0 3 0 5)))) + (is (equal :equal + (funcall rslt (cat:crpr 0 3 0 3) (cat:crpr 0 3 0 3)))))) (test crts-prdc-basis (let* ((b (cat:basis (cat:delta 1))) - (r (cat:crts-prdc-basis b b)) - (d3 (cat:basis (cat:delta 3)))) - (funcall r 0) - (funcall r 1) - (funcall r 2) - (funcall r 3) - (setf r (cat:crts-prdc-basis d3 d3)) - (time (dotimes (i 7) - (print (length (funcall r i))))) - (setf s3 (cat:basis (cat:sphere 3))) - (setf p (cat:crts-prdc-basis s3 s3)) - (dotimes (i 8) - (print (funcall p i))))) + (r (cat:crts-prdc-basis b b)) + (d3 (cat:basis (cat:delta 3)))) + (funcall r 0) + (funcall r 1) + (funcall r 2) + (funcall r 3) + (setf r (cat:crts-prdc-basis d3 d3)) + (time (dotimes (i 7) + (print (length (funcall r i))))) + (setf s3 (cat:basis (cat:sphere 3))) + (setf p (cat:crts-prdc-basis s3 s3)) + (dotimes (i 8) + (print (funcall p i))))) (test crts-prdc-face (let* ((d2 (cat:delta 2)) - (b2 (cat:basis d2)) - (f2 (cat:face d2)) - (b (cat:crts-prdc-basis b2 b2)) - (r (cat:crts-prdc-face f2 f2))) - (dotimes (i 5) - (unless (zerop i) - (dolist (item (funcall b i)) - (dotimes (j (1+ i)) - (format t "~%del-~D ~A = ~A" - j item (funcall r j i item)))))))) + (b2 (cat:basis d2)) + (f2 (cat:face d2)) + (b (cat:crts-prdc-basis b2 b2)) + (r (cat:crts-prdc-face f2 f2))) + (dotimes (i 5) + (unless (zerop i) + (dolist (item (funcall b i)) + (dotimes (j (1+ i)) + (format t "~%del-~D ~A = ~A" + j item (funcall r j i item)))))))) (test crts-prdc-face* (let* ((d2 (cat:delta 2)) - (b2 (cat:basis d2)) - (f2 (cat:face d2)) - (b (cat:crts-prdc-basis b2 b2)) - (r (cat:crts-prdc-face* f2 f2))) - (dotimes (i 5) - (unless (zerop i) - (dolist (item (coerce (funcall b i) 'list)) - (dotimes (j (1+ i)) - (format t "~%del-~D ~A = ~A" - j item (funcall r j i item))))))) + (b2 (cat:basis d2)) + (f2 (cat:face d2)) + (b (cat:crts-prdc-basis b2 b2)) + (r (cat:crts-prdc-face* f2 f2))) + (dotimes (i 5) + (unless (zerop i) + (dolist (item (coerce (funcall b i) 'list)) + (dotimes (j (1+ i)) + (format t "~%del-~D ~A = ~A" + j item (funcall r j i item))))))) (let* ((s3 (cat:sphere 3)) - (b3 (cat:basis s3)) - (f3 (cat:face s3)) - (b (cat:crts-prdc-basis b3 b3)) - (r (cat:crts-prdc-face* f3 f3))) - (dotimes (i 7) - (unless (zerop i) - (dolist (item (coerce (funcall b i) 'list)) - (dotimes (j (1+ i)) - (format t "~%del-~D ~A = ~A" - j item (funcall r j i item)))))))) + (b3 (cat:basis s3)) + (f3 (cat:face s3)) + (b (cat:crts-prdc-basis b3 b3)) + (r (cat:crts-prdc-face* f3 f3))) + (dotimes (i 7) + (unless (zerop i) + (dolist (item (coerce (funcall b i) 'list)) + (dotimes (j (1+ i)) + (format t "~%del-~D ~A = ~A" + j item (funcall r j i item)))))))) (test crts-prdc (let ((p (cat:crts-prdc (cat:delta 3) (cat:delta 3)))) - (cat:? p 0 (cat:crpr 0 1 0 2)) - (cat:? p 1 (cat:crpr 0 3 0 3)) - (cat:? p 2 (cat:crpr 0 7 0 7)) - (cat:? p 3 (cat:crpr 0 15 0 15)) - (cat:? p 4 (cat:crpr 1 15 2 15)))) + (cat:? p 0 (cat:crpr 0 1 0 2)) + (cat:? p 1 (cat:crpr 0 3 0 3)) + (cat:? p 2 (cat:crpr 0 7 0 7)) + (cat:? p 3 (cat:crpr 0 15 0 15)) + (cat:? p 4 (cat:crpr 1 15 2 15)))) (test eat (let* ((s5 (cat:sphere 5)) - (p (cat:crts-prdc s5 s5)) - (b (cat:basis p)) - (d (cat:bndr p)) - (basis (funcall b 10)) - (c (cat:make-cmbn :degr 10 - :list (mapcar #'(lambda (item) - (cat:term (1+ (random 5)) - item)) - basis)))) - (length basis) - (setf cat:+too-much-time+ -1) - (cat:cmbn-? d (cat:cmbn-? d c)) - (time - (dotimes (i 5) - (cat:cmbn-? d (cat:cmbn-? d c)))))) + (p (cat:crts-prdc s5 s5)) + (b (cat:basis p)) + (d (cat:bndr p)) + (basis (funcall b 10)) + (c (cat:make-cmbn :degr 10 + :list (mapcar #'(lambda (item) + (cat:term (1+ (random 5)) + item)) + basis)))) + (length basis) + (setf cat:+too-much-time+ -1) + (cat:cmbn-? d (cat:cmbn-? d c)) + (time + (dotimes (i 5) + (cat:cmbn-? d (cat:cmbn-? d c)))))) diff --git a/test/ccn.lisp b/test/ccn.lisp index 1045f81..77a02c0 100644 --- a/test/ccn.lisp +++ b/test/ccn.lisp @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :kenzo-test) @@ -6,87 +7,87 @@ (defun ccn () (the cat:chain-complex (cat:build-chcm - :cmpr #'cat:f-cmpr - :basis #'(lambda (n) - (cat:= 15 is possible => error. - )) + :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))) + cobar) + (cat:tcc rdct 3 'a) + (cat:g rdct (cat:f rdct 3 'a)) + (cat:h rdct 3 'a) + (setf cobar (cat:vrtc-cobar rdct)) + (cat:pre-check-rdct cobar) + (aleat-tc) + ;;(aleat-bc) + ;;(loop (c)) + ;; degrees >= 15 is possible => error. + )) |# #| (cat-init) (setf tcc (build-chcm - :cmpr #'s-cmpr - :basis #'(lambda (degr) '(a b c d)) - :bsgn 'd - :intr-dffr #'(lambda (degr gnrt) - (ecase gnrt - (a (cmbn (1- degr) 1 'b 1 'd)) - ((b d) (cmbn (1- degr))) - (c (cmbn (1- degr) 1 'd)))) - :strt :gnrt - :orgn '(tcc))) + :cmpr #'s-cmpr + :basis #'(lambda (degr) '(a b c d)) + :bsgn 'd + :intr-dffr #'(lambda (degr gnrt) + (ecase gnrt + (a (cmbn (1- degr) 1 'b 1 'd)) + ((b d) (cmbn (1- degr))) + (c (cmbn (1- degr) 1 'd)))) + :strt :gnrt + :orgn '(tcc))) (setf bcc (build-chcm - :cmpr #'s-cmpr - :basis #'(lambda (degr) '(c d)) - :bsgn 'd - :intr-dffr #'(lambda (degr gnrt) - (ecase gnrt - (d (cmbn (1- degr))) - (c (cmbn (1- degr) 1 'd)))) - :strt :gnrt - :orgn '(bcc))) + :cmpr #'s-cmpr + :basis #'(lambda (degr) '(c d)) + :bsgn 'd + :intr-dffr #'(lambda (degr gnrt) + (ecase gnrt + (d (cmbn (1- degr))) + (c (cmbn (1- degr) 1 'd)))) + :strt :gnrt + :orgn '(bcc))) (setf f (build-mrph :sorc tcc :trgt bcc :degr 0 - :intr #'(lambda (degr gnrt) - (ecase gnrt - (a (cmbn degr 1 'c 1 'd)) - (b (cmbn degr)) - ((c d) (cmbn degr 1 gnrt)))) - :strt :gnrt :orgn '(f))) + :intr #'(lambda (degr gnrt) + (ecase gnrt + (a (cmbn degr 1 'c 1 'd)) + (b (cmbn degr)) + ((c d) (cmbn degr 1 gnrt)))) + :strt :gnrt :orgn '(f))) (setf g (build-mrph :sorc bcc :trgt tcc :degr 0 - :intr #'identity :strt :cmbn :orgn '(g))) + :intr #'identity :strt :cmbn :orgn '(g))) (setf h (build-mrph :sorc tcc :trgt tcc :degr +1 - :intr #'(lambda (degr gnrt) - (ecase gnrt - ((a b) (cmbn (1+ degr) 1 'a -1 'b -1 'c -1 'd)) - ((c d) (cmbn (1+ degr))))) - :strt :gnrt :orgn '(h))) + :intr #'(lambda (degr gnrt) + (ecase gnrt + ((a b) (cmbn (1+ degr) 1 'a -1 'b -1 'c -1 'd)) + ((c d) (cmbn (1+ degr))))) + :strt :gnrt :orgn '(h))) (setf rdct (build-rdct :f f :g g :h h :orgn '(rdct))) (tcc rdct 3 'a) (g rdct (f rdct 3 'a)) @@ -262,7 +263,7 @@ (do ((tdegr 0 (+ tdegr degr)) (degr (1+ (random 4)) (1+ (random 4))) (gnrt (intern (coerce (vector (+ 65 (random 4))) 'string)) - (intern (coerce (vector (+ 65 (random 4))) 'string))) + (intern (coerce (vector (+ 65 (random 4))) 'string))) (rslt nil (cons (cbgn degr gnrt) rslt))) ((> tdegr 10) (setf *tc* (cmbn tdegr 1 (make-allp :list rslt)))))) (aleat-tc) @@ -270,7 +271,7 @@ (do ((tdegr 0 (+ tdegr degr)) (degr (1+ (random 4)) (1+ (random 4))) (gnrt (intern (coerce (vector (+ 67 (random 2))) 'string)) - (intern (coerce (vector (+ 67 (random 2))) 'string))) + (intern (coerce (vector (+ 67 (random 2))) 'string))) (rslt nil (cons (cbgn degr gnrt) rslt))) ((> tdegr 10) (setf *bc* (cmbn tdegr 1 (make-allp :list rslt)))))) (aleat-bc) @@ -286,6 +287,6 @@ (test left-hmeq (cat:cat-init) (let* ((h (cat:left-hmeq (cat:sphere 3))) - (c (cat:cobar h))) - (inspect c))) + (c (cat:cobar h))) + (inspect c))) |# diff --git a/test/combinations-test.lisp b/test/combinations-test.lisp index c281e14..2587b23 100644 --- a/test/combinations-test.lisp +++ b/test/combinations-test.lisp @@ -1,324 +1,325 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :kenzo-test) (in-suite :kenzo) (test f-cmpr - (is (equal (cat:f-cmpr 1 2) :less)) - (is (equal (cat:f-cmpr 2 2) :equal)) - (is (equal (cat:f-cmpr 3 2) :greater)) - (is (equal (cat:f-cmpr 123 789) :less)) - (is (equal (cat:maplexico #'cat:f-cmpr '(1 2 3) '(1 3)) :less)) - (is (equal (cat:maplexico #'cat:f-cmpr '(1 2 3) '(1 1)) :greater)) - (is (equal (cat:maplexico #'cat:f-cmpr '(1 1) '(1 1 0)) :less)) - (is (equal (cat:maplexico #'cat:f-cmpr '(1 1 0) '(1 1)) :greater)) - (is (equal (cat:maplexico #'cat:f-cmpr '(1 1) '(1 1)) :equal)) - (is (equal (cat:maplexico #'cat:f-cmpr nil nil) :equal))) + (is (equal (cat:f-cmpr 1 2) :less)) + (is (equal (cat:f-cmpr 2 2) :equal)) + (is (equal (cat:f-cmpr 3 2) :greater)) + (is (equal (cat:f-cmpr 123 789) :less)) + (is (equal (cat:maplexico #'cat:f-cmpr '(1 2 3) '(1 3)) :less)) + (is (equal (cat:maplexico #'cat:f-cmpr '(1 2 3) '(1 1)) :greater)) + (is (equal (cat:maplexico #'cat:f-cmpr '(1 1) '(1 1 0)) :less)) + (is (equal (cat:maplexico #'cat:f-cmpr '(1 1 0) '(1 1)) :greater)) + (is (equal (cat:maplexico #'cat:f-cmpr '(1 1) '(1 1)) :equal)) + (is (equal (cat:maplexico #'cat:f-cmpr nil nil) :equal))) (test l-cmpr - (is (equal (cat:l-cmpr nil nil) :equal)) - (is (equal (cat:l-cmpr nil '(1)) :less)) - (is (equal (cat:l-cmpr '(1) nil) :greater)) - (is (equal (cat:l-cmpr '(a) '(a)) :equal)) - (is (equal (cat:l-cmpr '(a) '(1)) :greater)) - (is (equal (cat:l-cmpr '(1) '(a)) :less)) - (is (equal (cat:l-cmpr '(1) '(1)) :equal)) - (is (equal (cat:l-cmpr '(1 a) '(1 1)) :greater)) - (is (equal (cat:l-cmpr '(1 a b) '(1 a)) :greater)) - (is (equal (cat:l-cmpr '(1 a) '(1 a b)) :less))) + (is (equal (cat:l-cmpr nil nil) :equal)) + (is (equal (cat:l-cmpr nil '(1)) :less)) + (is (equal (cat:l-cmpr '(1) nil) :greater)) + (is (equal (cat:l-cmpr '(a) '(a)) :equal)) + (is (equal (cat:l-cmpr '(a) '(1)) :greater)) + (is (equal (cat:l-cmpr '(1) '(a)) :less)) + (is (equal (cat:l-cmpr '(1) '(1)) :equal)) + (is (equal (cat:l-cmpr '(1 a) '(1 1)) :greater)) + (is (equal (cat:l-cmpr '(1 a b) '(1 a)) :greater)) + (is (equal (cat:l-cmpr '(1 a) '(1 a b)) :less))) (test s-cmpr - (is (equal (cat:s-cmpr 'a 'b) :less)) - (is (equal (cat:s-cmpr 'b 'b) :equal)) - (is (equal (cat:s-cmpr 'c 'b) :greater)) - (is (equal (cat:s-cmpr 'circulation 'circular) :greater)) - (is (equal (cat:s-cmpr 'qwerty 'qwerty) :equal))) + (is (equal (cat:s-cmpr 'a 'b) :less)) + (is (equal (cat:s-cmpr 'b 'b) :equal)) + (is (equal (cat:s-cmpr 'c 'b) :greater)) + (is (equal (cat:s-cmpr 'circulation 'circular) :greater)) + (is (equal (cat:s-cmpr 'qwerty 'qwerty) :equal))) (test cmbn - (let ((comb (cat:cmbn 2))) - (is (equal (cat:cmbn-degr comb) 2)) - (is (equal (cat:cmbn-list comb) nil))) + (let ((comb (cat:cmbn 2))) + (is (equal (cat:cmbn-degr comb) 2)) + (is (equal (cat:cmbn-list comb) nil))) - (let ((comb (cat:cmbn 2 2 'a))) - (is (equal (cat:cmbn-degr comb) 2)) - (is (equal (cat:cmbn-list comb) '((2 . a))))) + (let ((comb (cat:cmbn 2 2 'a))) + (is (equal (cat:cmbn-degr comb) 2)) + (is (equal (cat:cmbn-list comb) '((2 . a))))) - (let ((comb (cat:cmbn 2 'a))) - (is (equal (cat:cmbn-degr comb) 2)) - (is (equal (cat:cmbn-list comb) '((a))))) + (let ((comb (cat:cmbn 2 'a))) + (is (equal (cat:cmbn-degr comb) 2)) + (is (equal (cat:cmbn-list comb) '((a))))) - (let ((comb (cat:cmbn 2 2 'a -3 'b))) - (is (equal (cat:cmbn-degr comb) 2)) - (is (equal (cat:cmbn-list comb) '((2 . a) (-3 . b))))) + (let ((comb (cat:cmbn 2 2 'a -3 'b))) + (is (equal (cat:cmbn-degr comb) 2)) + (is (equal (cat:cmbn-list comb) '((2 . a) (-3 . b))))) - (let ((comb (cat:term-cmbn 3 -5 'a))) - (is (equal (cat:cmbn-degr comb) 3)) - (is (equal (cat:cmbn-list comb) '((-5 . a)))))) + (let ((comb (cat:term-cmbn 3 -5 'a))) + (is (equal (cat:cmbn-degr comb) 3)) + (is (equal (cat:cmbn-list comb) '((-5 . a)))))) (test zero-cmbn - (let ((comb (cat:zero-cmbn 3))) - (is (equal (cat:cmbn-degr comb) 3)) - (is (equal (cat:cmbn-list comb) nil))) + (let ((comb (cat:zero-cmbn 3))) + (is (equal (cat:cmbn-degr comb) 3)) + (is (equal (cat:cmbn-list comb) nil))) - (let ((comb (cat:zero-intr-dffr (cat:cmbn 2)))) - (is (equal (cat:cmbn-degr comb) 1)) - (is (equal (cat:cmbn-list comb) nil))) + (let ((comb (cat:zero-intr-dffr (cat:cmbn 2)))) + (is (equal (cat:cmbn-degr comb) 1)) + (is (equal (cat:cmbn-list comb) nil))) - (is (null (cat:cmbn-non-zero-p (cat:cmbn 0)))) - (is (cat:cmbn-non-zero-p (cat:cmbn 0 1 'a))) - (is (cat:cmbn-zero-p (cat:cmbn 0))) - (is (null (cat:cmbn-zero-p (cat:cmbn 0 1 'a))))) + (is (null (cat:cmbn-non-zero-p (cat:cmbn 0)))) + (is (cat:cmbn-non-zero-p (cat:cmbn 0 1 'a))) + (is (cat:cmbn-zero-p (cat:cmbn 0))) + (is (null (cat:cmbn-zero-p (cat:cmbn 0 1 'a))))) (test cmbn-opps - (let* ((comb (cat:cmbn 0 1 'a -2 'b)) - (comb1 (cat:cmbn-opps comb))) - (is (equal (cat:cmbn-degr comb) 0)) - (is (equal (cat:cmbn-list comb) '((1 . a) (-2 . b)))) - (is (equal (cat:cmbn-degr comb1) 0)) - (is (equal (cat:cmbn-list comb1) '((-1 . a) (2 . b)))))) + (let* ((comb (cat:cmbn 0 1 'a -2 'b)) + (comb1 (cat:cmbn-opps comb))) + (is (equal (cat:cmbn-degr comb) 0)) + (is (equal (cat:cmbn-list comb) '((1 . a) (-2 . b)))) + (is (equal (cat:cmbn-degr comb1) 0)) + (is (equal (cat:cmbn-list comb1) '((-1 . a) (2 . b)))))) (test n-cmbn - (let* ((comb (cat:cmbn 2 3 'a)) - (comb1 (cat:n-cmbn 1 comb)) - (comb2 (cat:n-cmbn -1 comb)) - (comb3 (cat:n-cmbn -3 comb))) - (is (eq comb comb1)) - (is (equal (cat:cmbn-degr comb2) 2)) - (is (equal (cat:cmbn-list comb2) '((-3 . a)))) - (is (equal (cat:cmbn-degr comb3) 2)) - (is (equal (cat:cmbn-list comb3) '((-9 . a)))))) + (let* ((comb (cat:cmbn 2 3 'a)) + (comb1 (cat:n-cmbn 1 comb)) + (comb2 (cat:n-cmbn -1 comb)) + (comb3 (cat:n-cmbn -3 comb))) + (is (eq comb comb1)) + (is (equal (cat:cmbn-degr comb2) 2)) + (is (equal (cat:cmbn-list comb2) '((-3 . a)))) + (is (equal (cat:cmbn-degr comb3) 2)) + (is (equal (cat:cmbn-list comb3) '((-9 . a)))))) (test 2cmbn-add - (signals simple-error (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0) (cat:cmbn 1))) + (signals simple-error (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0) (cat:cmbn 1))) - (is (cat:cmbn-zero-p (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0) (cat:cmbn 0)))) + (is (cat:cmbn-zero-p (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0) (cat:cmbn 0)))) - (let ((comb (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0 1 'a) (cat:cmbn 0)))) - (is (equal (cat:cmbn-degr comb) 0)) - (is (equal (cat:cmbn-list comb) '((1 . a))))) + (let ((comb (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0 1 'a) (cat:cmbn 0)))) + (is (equal (cat:cmbn-degr comb) 0)) + (is (equal (cat:cmbn-list comb) '((1 . a))))) - (let ((comb (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0 1 'a) (cat:cmbn 0 2 'a)))) - (is (equal (cat:cmbn-degr comb) 0)) - (is (equal (cat:cmbn-list comb) '((3 . a))))) + (let ((comb (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0 1 'a) (cat:cmbn 0 2 'a)))) + (is (equal (cat:cmbn-degr comb) 0)) + (is (equal (cat:cmbn-list comb) '((3 . a))))) - (let ((comb (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0 1 'a) (cat:cmbn 0 -1 'a)))) - (is (cat:cmbn-zero-p comb))) + (let ((comb (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0 1 'a) (cat:cmbn 0 -1 'a)))) + (is (cat:cmbn-zero-p comb))) - (let ((comb (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0 1 'a) (cat:cmbn 0 2 'b)))) - (is (equal (cat:cmbn-degr comb) 0)) - (is (equal (cat:cmbn-list comb) '((1 . a) (2 . b))))) + (let ((comb (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0 1 'a) (cat:cmbn 0 2 'b)))) + (is (equal (cat:cmbn-degr comb) 0)) + (is (equal (cat:cmbn-list comb) '((1 . a) (2 . b))))) - (let ((comb (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0 1 'a -2 'b) - (cat:cmbn 0 2 'b)))) - (is (equal (cat:cmbn-degr comb) 0)) - (is (equal (cat:cmbn-list comb) '((1 . a))))) + (let ((comb (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0 1 'a -2 'b) + (cat:cmbn 0 2 'b)))) + (is (equal (cat:cmbn-degr comb) 0)) + (is (equal (cat:cmbn-list comb) '((1 . a))))) - (let ((comb (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0 2 'b) - (cat:cmbn 0 1 'a 3 'c)))) - (is (equal (cat:cmbn-degr comb) 0)) - (is (equal (cat:cmbn-list comb) '((1 . a) (2 . b) (3 . c)))))) + (let ((comb (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0 2 'b) + (cat:cmbn 0 1 'a 3 'c)))) + (is (equal (cat:cmbn-degr comb) 0)) + (is (equal (cat:cmbn-list comb) '((1 . a) (2 . b) (3 . c)))))) (test 2cmbn-sbtr - (signals simple-error (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0) (cat:cmbn 1))) + (signals simple-error (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0) (cat:cmbn 1))) - (is (cat:cmbn-zero-p (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0) (cat:cmbn 0)))) + (is (cat:cmbn-zero-p (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0) (cat:cmbn 0)))) - (let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0) (cat:cmbn 0 1 'a)))) - (is (equal (cat:cmbn-degr comb) 0)) - (is (equal (cat:cmbn-list comb) '((-1 . a))))) + (let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0) (cat:cmbn 0 1 'a)))) + (is (equal (cat:cmbn-degr comb) 0)) + (is (equal (cat:cmbn-list comb) '((-1 . a))))) - (let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0 2 'b) (cat:cmbn 0)))) - (is (equal (cat:cmbn-degr comb) 0)) - (is (equal (cat:cmbn-list comb) '((2 . b))))) + (let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0 2 'b) (cat:cmbn 0)))) + (is (equal (cat:cmbn-degr comb) 0)) + (is (equal (cat:cmbn-list comb) '((2 . b))))) - (is (cat:cmbn-zero-p (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0 3 'b) - (cat:cmbn 0 3 'b)))) + (is (cat:cmbn-zero-p (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0 3 'b) + (cat:cmbn 0 3 'b)))) - (let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0 3 'b) (cat:cmbn 0 4 'b)))) - (is (equal (cat:cmbn-degr comb) 0)) - (is (equal (cat:cmbn-list comb) '((-1 . b))))) + (let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0 3 'b) (cat:cmbn 0 4 'b)))) + (is (equal (cat:cmbn-degr comb) 0)) + (is (equal (cat:cmbn-list comb) '((-1 . b))))) - (let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr - (cat:cmbn 0 1 'a 2 'c 2 'd 3 'g) - (cat:cmbn 0 1 'c -2 'd 4 'f -3 'g 4 'h)))) - (is (equal (cat:cmbn-degr comb) 0)) - (is (equal (cat:cmbn-list comb) '((1 . a) (1 . c) (4 . d) (-4 . f) (6 . g) - (-4 . h))))) + (let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr + (cat:cmbn 0 1 'a 2 'c 2 'd 3 'g) + (cat:cmbn 0 1 'c -2 'd 4 'f -3 'g 4 'h)))) + (is (equal (cat:cmbn-degr comb) 0)) + (is (equal (cat:cmbn-list comb) '((1 . a) (1 . c) (4 . d) (-4 . f) (6 . g) + (-4 . h))))) - (let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr - (cat:cmbn 0 1 'c -2 'd 4 'f -3 'g 4 'h) - (cat:cmbn 0 1 'a 2 'c 2 'd 3 'g)))) - (is (equal (cat:cmbn-degr comb) 0)) - (is (equal (cat:cmbn-list comb) '((-1 . a) (-1 . c) (-4 . d) (4 . f) - (-6 . g) (4 . h))))) + (let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr + (cat:cmbn 0 1 'c -2 'd 4 'f -3 'g 4 'h) + (cat:cmbn 0 1 'a 2 'c 2 'd 3 'g)))) + (is (equal (cat:cmbn-degr comb) 0)) + (is (equal (cat:cmbn-list comb) '((-1 . a) (-1 . c) (-4 . d) (4 . f) + (-6 . g) (4 . h))))) - (let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr - (cat:cmbn 0 1 'c -2 'd 4 'f -3 'g) - (cat:cmbn 0 1 'a 2 'c 2 'd 3 'g)))) - (is (equal (cat:cmbn-degr comb) 0)) - (is (equal (cat:cmbn-list comb) '((-1 . a) (-1 . c) (-4 . d) (4 . f) - (-6 . g))))) + (let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr + (cat:cmbn 0 1 'c -2 'd 4 'f -3 'g) + (cat:cmbn 0 1 'a 2 'c 2 'd 3 'g)))) + (is (equal (cat:cmbn-degr comb) 0)) + (is (equal (cat:cmbn-list comb) '((-1 . a) (-1 . c) (-4 . d) (4 . f) + (-6 . g))))) - (let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0 1 'b 2 'a) - (cat:cmbn 0 1 'a 1 'b)))) - (is (equal (cat:cmbn-degr comb) 0)) - (is (equal (cat:cmbn-list comb) '((-1 . a) (2 . a))))) + (let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0 1 'b 2 'a) + (cat:cmbn 0 1 'a 1 'b)))) + (is (equal (cat:cmbn-degr comb) 0)) + (is (equal (cat:cmbn-list comb) '((-1 . a) (2 . a))))) - (let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0 1 'b 2 'c) - (cat:cmbn 0 1 'a 1 'b)))) - (is (equal (cat:cmbn-degr comb) 0)) - (is (equal (cat:cmbn-list comb) '((-1 . a) (2 . c)))))) + (let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0 1 'b 2 'c) + (cat:cmbn 0 1 'a 1 'b)))) + (is (equal (cat:cmbn-degr comb) 0)) + (is (equal (cat:cmbn-list comb) '((-1 . a) (2 . c)))))) (test 2n-2cmbn - (signals simple-error (cat:2n-2cmbn #'cat:s-cmpr 3 (cat:cmbn 0) - 4 (cat:cmbn 1))) + (signals simple-error (cat:2n-2cmbn #'cat:s-cmpr 3 (cat:cmbn 0) + 4 (cat:cmbn 1))) - (is (cat:cmbn-zero-p (cat:2n-2cmbn #'cat:s-cmpr 3 (cat:cmbn 0) - 4 (cat:cmbn 0)))) + (is (cat:cmbn-zero-p (cat:2n-2cmbn #'cat:s-cmpr 3 (cat:cmbn 0) + 4 (cat:cmbn 0)))) - (let ((comb (cat:2n-2cmbn #'cat:s-cmpr 3 (cat:cmbn 0 1 'a) 4 (cat:cmbn 0)))) - (is (equal (cat:cmbn-degr comb) 0)) - (is (equal (cat:cmbn-list comb) '((3 . a))))) + (let ((comb (cat:2n-2cmbn #'cat:s-cmpr 3 (cat:cmbn 0 1 'a) 4 (cat:cmbn 0)))) + (is (equal (cat:cmbn-degr comb) 0)) + (is (equal (cat:cmbn-list comb) '((3 . a))))) - (let ((comb (cat:2n-2cmbn #'cat:s-cmpr - 3 (cat:cmbn 0 1 'a 2 'b 3 'c) - 1 (cat:cmbn 0 -3 'a 2 'b 4 'd)))) - (is (equal (cat:cmbn-degr comb) 0)) - (is (equal (cat:cmbn-list comb) '((8 . b) (9 . c) (4 . d))))) + (let ((comb (cat:2n-2cmbn #'cat:s-cmpr + 3 (cat:cmbn 0 1 'a 2 'b 3 'c) + 1 (cat:cmbn 0 -3 'a 2 'b 4 'd)))) + (is (equal (cat:cmbn-degr comb) 0)) + (is (equal (cat:cmbn-list comb) '((8 . b) (9 . c) (4 . d))))) - (let ((comb (cat:2n-2cmbn #'cat:s-cmpr - 3 (cat:cmbn 0 -3 'a 2 'b 4 'd) - 1 (cat:cmbn 0 1 'a 2 'b 3 'c)))) - (is (equal (cat:cmbn-degr comb) 0)) - (is (equal (cat:cmbn-list comb) '((-8 . a) (8 . b) (3 . c) (12 . d))))) + (let ((comb (cat:2n-2cmbn #'cat:s-cmpr + 3 (cat:cmbn 0 -3 'a 2 'b 4 'd) + 1 (cat:cmbn 0 1 'a 2 'b 3 'c)))) + (is (equal (cat:cmbn-degr comb) 0)) + (is (equal (cat:cmbn-list comb) '((-8 . a) (8 . b) (3 . c) (12 . d))))) - (let ((comb (cat:2n-2cmbn #'cat:s-cmpr - 1 (cat:cmbn 0 1 'a 2 'b 3 'c) - 1 (cat:cmbn 0 -3 'a 2 'b 4 'd)))) - (is (equal (cat:cmbn-degr comb) 0)) - (is (equal (cat:cmbn-list comb) '((-2 . a) (4 . b) (3 . c) (4 . d))))) + (let ((comb (cat:2n-2cmbn #'cat:s-cmpr + 1 (cat:cmbn 0 1 'a 2 'b 3 'c) + 1 (cat:cmbn 0 -3 'a 2 'b 4 'd)))) + (is (equal (cat:cmbn-degr comb) 0)) + (is (equal (cat:cmbn-list comb) '((-2 . a) (4 . b) (3 . c) (4 . d))))) - (let ((comb (cat:2n-2cmbn #'cat:s-cmpr - 1 (cat:cmbn 0 -3 'a 2 'b 4 'd) - 1 (cat:cmbn 0 1 'a 2 'b 3 'c)))) - (is (equal (cat:cmbn-degr comb) 0)) - (is (equal (cat:cmbn-list comb) '((-2 . a) (4 . b) (3 . c) (4 . d))))) + (let ((comb (cat:2n-2cmbn #'cat:s-cmpr + 1 (cat:cmbn 0 -3 'a 2 'b 4 'd) + 1 (cat:cmbn 0 1 'a 2 'b 3 'c)))) + (is (equal (cat:cmbn-degr comb) 0)) + (is (equal (cat:cmbn-list comb) '((-2 . a) (4 . b) (3 . c) (4 . d))))) - (let ((comb (cat:2n-2cmbn #'cat:s-cmpr - 1 (cat:cmbn 0 -3 'a 2 'b 4 'd) - 3 (cat:cmbn 0 1 'a 2 'b 3 'c)))) - (is (equal (cat:cmbn-degr comb) 0)) - (is (equal (cat:cmbn-list comb) '((8 . b) (9 . c) (4 . d)))))) + (let ((comb (cat:2n-2cmbn #'cat:s-cmpr + 1 (cat:cmbn 0 -3 'a 2 'b 4 'd) + 3 (cat:cmbn 0 1 'a 2 'b 3 'c)))) + (is (equal (cat:cmbn-degr comb) 0)) + (is (equal (cat:cmbn-list comb) '((8 . b) (9 . c) (4 . d)))))) (test cmbn-cmbn - (let* ((cons (cons 3 (cat:cmbn 0 4 'a))) - (comb (cat:cmbn-cmbn #'cat:s-cmpr - (make-list 5 :initial-element cons)))) - (is (equal (cat:cmbn-degr comb) 0)) - (is (equal (cat:cmbn-list comb) '((60 . a))))) + (let* ((cons (cons 3 (cat:cmbn 0 4 'a))) + (comb (cat:cmbn-cmbn #'cat:s-cmpr + (make-list 5 :initial-element cons)))) + (is (equal (cat:cmbn-degr comb) 0)) + (is (equal (cat:cmbn-list comb) '((60 . a))))) - (let* ((cffc '(12 24 36 48 60 72 84 96 108 120)) - (cons (cons 3 (cat:cmbn 0 4 'a)))) - (dotimes (i 10) - (is (equal (nth i cffc) - (cat:cffc (first (cat:cmbn-list - (cat:cmbn-cmbn #'cat:s-cmpr - (make-list (1+ i) - :initial-element - cons)))))))))) + (let* ((cffc '(12 24 36 48 60 72 84 96 108 120)) + (cons (cons 3 (cat:cmbn 0 4 'a)))) + (dotimes (i 10) + (is (equal (nth i cffc) + (cat:cffc (first (cat:cmbn-list + (cat:cmbn-cmbn #'cat:s-cmpr + (make-list (1+ i) + :initial-element + cons)))))))))) (test nterm-add - (let ((comb (cat:nterm-add #'cat:s-cmpr 11))) - (is (equal (cat:cmbn-degr comb) 11)) - (is (equal (cat:cmbn-list comb) nil))) + (let ((comb (cat:nterm-add #'cat:s-cmpr 11))) + (is (equal (cat:cmbn-degr comb) 11)) + (is (equal (cat:cmbn-list comb) nil))) - (let ((comb (cat:nterm-add #'cat:s-cmpr 11 (cat:term 1 'a)))) - (is (equal (cat:cmbn-degr comb) 11)) - (is (equal (cat:cmbn-list comb) '((1 . a))))) + (let ((comb (cat:nterm-add #'cat:s-cmpr 11 (cat:term 1 'a)))) + (is (equal (cat:cmbn-degr comb) 11)) + (is (equal (cat:cmbn-list comb) '((1 . a))))) - (let ((comb (cat:nterm-add #'cat:s-cmpr 11 (cat:term 1 'a) - (cat:term 2 'b)))) - (is (equal (cat:cmbn-degr comb) 11)) - (is (equal (cat:cmbn-list comb) '((1 . a) (2 . b))))) + (let ((comb (cat:nterm-add #'cat:s-cmpr 11 (cat:term 1 'a) + (cat:term 2 'b)))) + (is (equal (cat:cmbn-degr comb) 11)) + (is (equal (cat:cmbn-list comb) '((1 . a) (2 . b))))) - (let ((comb (cat:nterm-add #'cat:s-cmpr 11 (cat:term 1 'b) - (cat:term 2 'a) (cat:term 3 'aa) - (cat:term -2 'aa) (cat:term -2 'a) - (cat:term 4 'aa) (cat:term 5 'c)))) - (is (equal (cat:cmbn-degr comb) 11)) - (is (equal (cat:cmbn-list comb) '((5 . aa) (1 . b) (5 . c)))))) + (let ((comb (cat:nterm-add #'cat:s-cmpr 11 (cat:term 1 'b) + (cat:term 2 'a) (cat:term 3 'aa) + (cat:term -2 'aa) (cat:term -2 'a) + (cat:term 4 'aa) (cat:term 5 'c)))) + (is (equal (cat:cmbn-degr comb) 11)) + (is (equal (cat:cmbn-list comb) '((5 . aa) (1 . b) (5 . c)))))) (test ncmbn-add - (let* ((c (cat:cmbn 3 4 'a)) - (comb (cat:ncmbn-add #'cat:s-cmpr c c c c c))) - (is (equal (cat:cmbn-degr comb) 3)) - (is (equal (cat:cmbn-list comb) '((20 . a)))))) + (let* ((c (cat:cmbn 3 4 'a)) + (comb (cat:ncmbn-add #'cat:s-cmpr c c c c c))) + (is (equal (cat:cmbn-degr comb) 3)) + (is (equal (cat:cmbn-list comb) '((20 . a)))))) (test dstr-add-term-to-cmbn - (let* ((c (cat:zero-cmbn 10)) - (comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr 3 'f c))) - (is (eq comb c)) - (is (equal (cat:cmbn-degr comb) 10)) - (is (equal (cat:cmbn-list comb) '((3 . f)))) - (setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr 3 'g c)) - (is (eq comb c)) - (is (equal (cat:cmbn-degr comb) 10)) - (is (equal (cat:cmbn-list comb) '((3 . f) (3 . g)))) - (setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr 3 'a c)) - (is (eq comb c)) - (is (equal (cat:cmbn-degr comb) 10)) - (is (equal (cat:cmbn-list comb) '((3 . a) (3 . f) (3 . g)))) - (setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr 3 'd c)) - (is (eq comb c)) - (is (equal (cat:cmbn-degr comb) 10)) - (is (equal (cat:cmbn-list comb) '((3 . a) (3 . d) (3 . f) (3 . g)))) - (setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr -3 'd c)) - (is (eq comb c)) - (is (equal (cat:cmbn-degr comb) 10)) - (is (equal (cat:cmbn-list comb) '((3 . a) (3 . f) (3 . g)))) - (setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr -2 'a c)) - (is (eq comb c)) - (is (equal (cat:cmbn-degr comb) 10)) - (is (equal (cat:cmbn-list comb) '((1 . a) (3 . f) (3 . g)))) - (setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr -1 'a c)) - (is (eq comb c)) - (is (equal (cat:cmbn-degr comb) 10)) - (is (equal (cat:cmbn-list comb) '((3 . f) (3 . g)))) - (setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr -3 'g c)) - (is (eq comb c)) - (is (equal (cat:cmbn-degr comb) 10)) - (is (equal (cat:cmbn-list comb) '((3 . f)))) - (setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr -3 'f c)) - (is (eq comb c)) - (is (equal (cat:cmbn-degr comb) 10)) - (is (equal (cat:cmbn-list comb) nil)))) + (let* ((c (cat:zero-cmbn 10)) + (comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr 3 'f c))) + (is (eq comb c)) + (is (equal (cat:cmbn-degr comb) 10)) + (is (equal (cat:cmbn-list comb) '((3 . f)))) + (setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr 3 'g c)) + (is (eq comb c)) + (is (equal (cat:cmbn-degr comb) 10)) + (is (equal (cat:cmbn-list comb) '((3 . f) (3 . g)))) + (setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr 3 'a c)) + (is (eq comb c)) + (is (equal (cat:cmbn-degr comb) 10)) + (is (equal (cat:cmbn-list comb) '((3 . a) (3 . f) (3 . g)))) + (setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr 3 'd c)) + (is (eq comb c)) + (is (equal (cat:cmbn-degr comb) 10)) + (is (equal (cat:cmbn-list comb) '((3 . a) (3 . d) (3 . f) (3 . g)))) + (setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr -3 'd c)) + (is (eq comb c)) + (is (equal (cat:cmbn-degr comb) 10)) + (is (equal (cat:cmbn-list comb) '((3 . a) (3 . f) (3 . g)))) + (setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr -2 'a c)) + (is (eq comb c)) + (is (equal (cat:cmbn-degr comb) 10)) + (is (equal (cat:cmbn-list comb) '((1 . a) (3 . f) (3 . g)))) + (setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr -1 'a c)) + (is (eq comb c)) + (is (equal (cat:cmbn-degr comb) 10)) + (is (equal (cat:cmbn-list comb) '((3 . f) (3 . g)))) + (setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr -3 'g c)) + (is (eq comb c)) + (is (equal (cat:cmbn-degr comb) 10)) + (is (equal (cat:cmbn-list comb) '((3 . f)))) + (setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr -3 'f c)) + (is (eq comb c)) + (is (equal (cat:cmbn-degr comb) 10)) + (is (equal (cat:cmbn-list comb) nil)))) (test uvwz (let* ((comb1 (cat:cmbn 1 1 'u 2 'v 3 'w 4 'z)) - (comb1-list (cat:cmbn-list comb1)) - (term3 (third comb1-list)) - (mcomb1 (cat:cmbn-opps comb1)) - (comb2 (cat:n-cmbn 10 comb1)) - (comb12 (cat:2cmbn-add #'cat:s-cmpr comb1 comb2)) - (comb112 (cat:2cmbn-sbtr #'cat:s-cmpr comb1 comb12)) - (comb12n (cat:ncmbn-add #'cat:s-cmpr comb1 comb2 comb1 comb2 - comb1 comb2 comb1 comb2 comb1 comb2))) - (is (cat:cmbn-non-zero-p comb1)) - (is (equal comb1-list '((1 . u) (2 . v) (3 . w) (4 . z)))) - (is (equal (cat:cffc term3) 3)) - (is (equal (cat:gnrt term3) 'w)) - (is (equal (cat:cmbn-degr comb1) (cat:cmbn-degr mcomb1))) - (is (equal (cat:cmbn-list mcomb1) '((-1 . u) (-2 . v) - (-3 . w) (-4 . z)))) - (is (equal (cat:cmbn-degr comb1) (cat:cmbn-degr comb2))) - (is (equal (cat:cmbn-list comb2) '((10 . u) (20 . v) - (30 . w) (40 . z)))) - (is (equal (cat:cmbn-degr comb1) (cat:cmbn-degr comb12))) - (is (equal (cat:cmbn-list comb12) '((11 . u) (22 . v) - (33 . w) (44 . z)))) - (is (equal (cat:cmbn-degr comb1) (cat:cmbn-degr comb112))) - (is (equal (cat:cmbn-list comb112) '((-10 . u) (-20 . v) - (-30 . w) (-40 . z)))) - (is (equal (cat:cmbn-degr comb1) (cat:cmbn-degr comb12n))) - (is (equal (cat:cmbn-list comb12n) '((55 . u) (110 . v) - (165 . w) (220 . z)))))) + (comb1-list (cat:cmbn-list comb1)) + (term3 (third comb1-list)) + (mcomb1 (cat:cmbn-opps comb1)) + (comb2 (cat:n-cmbn 10 comb1)) + (comb12 (cat:2cmbn-add #'cat:s-cmpr comb1 comb2)) + (comb112 (cat:2cmbn-sbtr #'cat:s-cmpr comb1 comb12)) + (comb12n (cat:ncmbn-add #'cat:s-cmpr comb1 comb2 comb1 comb2 + comb1 comb2 comb1 comb2 comb1 comb2))) + (is (cat:cmbn-non-zero-p comb1)) + (is (equal comb1-list '((1 . u) (2 . v) (3 . w) (4 . z)))) + (is (equal (cat:cffc term3) 3)) + (is (equal (cat:gnrt term3) 'w)) + (is (equal (cat:cmbn-degr comb1) (cat:cmbn-degr mcomb1))) + (is (equal (cat:cmbn-list mcomb1) '((-1 . u) (-2 . v) + (-3 . w) (-4 . z)))) + (is (equal (cat:cmbn-degr comb1) (cat:cmbn-degr comb2))) + (is (equal (cat:cmbn-list comb2) '((10 . u) (20 . v) + (30 . w) (40 . z)))) + (is (equal (cat:cmbn-degr comb1) (cat:cmbn-degr comb12))) + (is (equal (cat:cmbn-list comb12) '((11 . u) (22 . v) + (33 . w) (44 . z)))) + (is (equal (cat:cmbn-degr comb1) (cat:cmbn-degr comb112))) + (is (equal (cat:cmbn-list comb112) '((-10 . u) (-20 . v) + (-30 . w) (-40 . z)))) + (is (equal (cat:cmbn-degr comb1) (cat:cmbn-degr comb12n))) + (is (equal (cat:cmbn-list comb12n) '((55 . u) (110 . v) + (165 . w) (220 . z)))))) diff --git a/test/common.lisp b/test/common.lisp index 3196403..0a3d65f 100644 --- a/test/common.lisp +++ b/test/common.lisp @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :kenzo-test) @@ -83,10 +84,10 @@ (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) @@ -151,10 +152,10 @@ (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)) @@ -177,7 +178,7 @@ (intern (coerce (vector (code-char (+ 65 (random 4)))) 'string))) (rslt nil (cons (cat:brgn degr gnrt) rslt))) ((> tdegr 8) (setf cat:*tc* (cat:cmbn tdegr 1 (cat:make-abar - :list rslt)))))) + :list rslt)))))) (defun aleat-bc () @@ -187,7 +188,7 @@ (intern (coerce (vector (code-char (+ 67 (random 2)))) 'string))) (rslt nil (cons (cat:brgn degr gnrt) rslt))) ((> tdegr 8) (setf cat:*bc* (cat:cmbn tdegr 1 (cat:make-abar - :list rslt)))))) + :list rslt)))))) (defun c () @@ -203,12 +204,12 @@ ((>= 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)) + (let ((list (make-list degr))) + (mapl + #'(lambda (sublist) + (setf (car sublist) (- (random 21) 10))) + list) + list)) rslt))) diff --git a/test/cones-test.lisp b/test/cones-test.lisp index bd039eb..b6f46ff 100644 --- a/test/cones-test.lisp +++ b/test/cones-test.lisp @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :kenzo-test) @@ -15,20 +16,20 @@ (test cone-cmpr (let ((cmpr (cat:cone-cmpr #'cat:s-cmpr #'cat:f-cmpr))) - (is (equal :less (funcall cmpr (cat:con0 'a) (cat:con0 'b)))) - (is (equal :equal (funcall cmpr (cat:con0 'b) (cat:con0 'b)))) - (is (equal :greater (funcall cmpr (cat:con0 'b) (cat:con0 'a)))) - (is (equal :less (funcall cmpr (cat:con0 'b) (cat:con1 '2)))) - (is (equal :greater (funcall cmpr (cat:con1 '2) (cat:con0 'b)))) - (is (equal :less (funcall cmpr (cat:con1 '1) (cat:con1 '2)))) - (is (equal :equal (funcall cmpr (cat:con1 '2) (cat:con1 '2)))) - (is (equal :greater (funcall cmpr (cat:con1 '2) (cat:con1 '1)))))) + (is (equal :less (funcall cmpr (cat:con0 'a) (cat:con0 'b)))) + (is (equal :equal (funcall cmpr (cat:con0 'b) (cat:con0 'b)))) + (is (equal :greater (funcall cmpr (cat:con0 'b) (cat:con0 'a)))) + (is (equal :less (funcall cmpr (cat:con0 'b) (cat:con1 '2)))) + (is (equal :greater (funcall cmpr (cat:con1 '2) (cat:con0 'b)))) + (is (equal :less (funcall cmpr (cat:con1 '1) (cat:con1 '2)))) + (is (equal :equal (funcall cmpr (cat:con1 '2) (cat:con1 '2)))) + (is (equal :greater (funcall cmpr (cat:con1 '2) (cat:con1 '1)))))) (test cone-basis (let ((basis (cat:cone-basis #'(lambda (n) (list n)) - #'(lambda (n) (list n))))) - (funcall basis 4))) + #'(lambda (n) (list n))))) + (funcall basis 4))) (test term-con @@ -54,58 +55,58 @@ (test cone-2mrph-diag-impl (let* ((mrph (cat:dffr (cat:delta 4))) - (rslt (cat:cone-2mrph-diag-impl mrph mrph))) - (funcall rslt (cat:cmbn 3 4 (cat:con0 15) 5 (cat:con1 7))))) + (rslt (cat:cone-2mrph-diag-impl mrph mrph))) + (funcall rslt (cat:cmbn 3 4 (cat:con0 15) 5 (cat:con1 7))))) (test cone-3mrph-triangle-impl (let ((rslt (cat:cone-3mrph-triangle-impl #'cat:f-cmpr - (cat:dffr (cat:delta 4)) - (cat:dffr (cat:delta 4)) - (cat:idnt-mrph (cat:delta 4))))) - (funcall rslt 4 (cat:con0 '31)) - (funcall rslt 5 (cat:con1 '31)) - (funcall rslt 4 (cat:con1 '15)))) + (cat:dffr (cat:delta 4)) + (cat:dffr (cat:delta 4)) + (cat:idnt-mrph (cat:delta 4))))) + (funcall rslt 4 (cat:con0 '31)) + (funcall rslt 5 (cat:con1 '31)) + (funcall rslt 4 (cat:con1 '15)))) (test cone (progn - (cat:cat-init) - (let* ((k (cat:k-z 1)) - (u (cat:idnt-mrph k)) - (c (cat:cone u)) - (cone)) - (setf cat:*tc* (cat:cmbn 4 1 (cat:con0 '(1 2 3 4)))) - (cat:? c 4 (cat:con0 '(1 2 3 4))) - (cat:? c cat:*tc*) + (cat:cat-init) + (let* ((k (cat:k-z 1)) + (u (cat:idnt-mrph k)) + (c (cat:cone u)) + (cone)) + (setf cat:*tc* (cat:cmbn 4 1 (cat:con0 '(1 2 3 4)))) + (cat:? c 4 (cat:con0 '(1 2 3 4))) + (cat:? c cat:*tc*) - (setf cone (cat:cone (cat:idnt-mrph (cat:delta 4)))) - (cat:? cone (cat:cmbn 4 1 (cat:con0 '31) -1 (cat:con1 '15))) - (cat:? cone - (cat:? cone (cat:cmbn 4 - 1 (cat:con0 '31) -1 (cat:con1 '15))))))) + (setf cone (cat:cone (cat:idnt-mrph (cat:delta 4)))) + (cat:? cone (cat:cmbn 4 1 (cat:con0 '31) -1 (cat:con1 '15))) + (cat:? cone + (cat:? cone (cat:cmbn 4 + 1 (cat:con0 '31) -1 (cat:con1 '15))))))) (test cone-2mrph-diag (let* ((idnt (cat:idnt-mrph (cat:delta 4))) - (cone (cat:cone idnt)) - (ff (cat:cone-2mrph-diag cone cone idnt idnt))) - (cat:? ff (cat:cmbn 4 1 (cat:con0 '31) 10 (cat:con1 '15))))) + (cone (cat:cone idnt)) + (ff (cat:cone-2mrph-diag cone cone idnt idnt))) + (cat:? ff (cat:cmbn 4 1 (cat:con0 '31) 10 (cat:con1 '15))))) (test cone-3mrph-triangle (progn - (cat:cat-init) - (let* ((d (cat:delta 4)) - (df (cat:dffr (cat:delta 4))) - (n (cat:idnt-mrph d)) - (c (cat:cone n)) - (z (cat:sbtr (cat:dffr c) - (cat:cone-3mrph-triangle c c df - (cat:n-mrph -1 df) n)))) - (cat:? z 0 (cat:con0 '1)) - (cat:? z 1 (cat:con1 '1)) - (cat:? z 1 (cat:con0 '3)) - (cat:? z 2 (cat:con1 '3)) - (cat:? z 4 (cat:con0 '31)) - (cat:? z 5 (cat:con1 '31))))) + (cat:cat-init) + (let* ((d (cat:delta 4)) + (df (cat:dffr (cat:delta 4))) + (n (cat:idnt-mrph d)) + (c (cat:cone n)) + (z (cat:sbtr (cat:dffr c) + (cat:cone-3mrph-triangle c c df + (cat:n-mrph -1 df) n)))) + (cat:? z 0 (cat:con0 '1)) + (cat:? z 1 (cat:con1 '1)) + (cat:? z 1 (cat:con0 '3)) + (cat:? z 2 (cat:con1 '3)) + (cat:? z 4 (cat:con0 '31)) + (cat:? z 5 (cat:con1 '31))))) diff --git a/test/cs-twisted-products-test.lisp b/test/cs-twisted-products-test.lisp index 95ddac8..db4b1b2 100644 --- a/test/cs-twisted-products-test.lisp +++ b/test/cs-twisted-products-test.lisp @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :kenzo-test) @@ -6,92 +7,92 @@ (test smgr-fibration (cat:cat-init) (let* ((k1 (cat:k-z-1)) - (tw (cat:smgr-fibration k1)) - (k2 (cat:sorc tw)) - (tt (cat:fibration-total tw)) - (gmsm (cat:crpr 0 (cat:gbar 4 0 '(10 11 12) 0 '(20 21) - 0 '(30) 0 '()) - 0 '(2 4 6 8))) - (br (cat:brown-reduction tw)) - (tw-pr (cat:bcc br))) - (dotimes (i 5) - (print (cat:face tt i 4 gmsm))) - (cat:? tw-pr 4 (cat:tnpr 4 (cat:gbar 4 0 '(1 10 100) 0 '(1000 10000) - 0 '(100000) 0 '()) - 0 '())))) + (tw (cat:smgr-fibration k1)) + (k2 (cat:sorc tw)) + (tt (cat:fibration-total tw)) + (gmsm (cat:crpr 0 (cat:gbar 4 0 '(10 11 12) 0 '(20 21) + 0 '(30) 0 '()) + 0 '(2 4 6 8))) + (br (cat:brown-reduction tw)) + (tw-pr (cat:bcc br))) + (dotimes (i 5) + (print (cat:face tt i 4 gmsm))) + (cat:? tw-pr 4 (cat:tnpr 4 (cat:gbar 4 0 '(1 10 100) 0 '(1000 10000) + 0 '(100000) 0 '()) + 0 '())))) #| (test smgr-crts-contraction (cat:cat-init) (let* ((chi (cat:smgr-crts-contraction (cat:k-z-1))) - (rdct (cat:build-rdct :f (cat:zero-mrph (cat:sorc chi) - (cat:z-chcm)) - :g (cat:zero-mrph (cat:z-chcm) - (cat:sorc chi)) - :h chi))) - (cat:pre-check-rdct rdct) - (setf cat:*tc* (cat:cmbn 0 1 (cat:crpr 0 cat:+null-gbar+ 0 '()))) - (setf cat:*bc* (cat:cmbn 0 1 :z-gnrt)) - (check-rdct) - (setf cat:*tc* (cat:cmbn 1 1 (cat:crpr 1 cat:+null-gbar+ 0 '(1)))) - (check-rdct) - (setf cat:*tc* (cat:cmbn 4 1 (cat:crpr 0 (cat:gbar 4 0 '(10 11 12) - 0 '(20 21) - 0 '(30) 0 '()) - 0 '(2 4 6 8)))) - (check-rdct) - (setf cat:*tc* (cat:cmbn 3 1 (cat:crpr 0 (cat:gbar 3 0 '(10 11) - 0 '(20) 0 '()) - 0 '(2 4 6)))) - (check-rdct))) + (rdct (cat:build-rdct :f (cat:zero-mrph (cat:sorc chi) + (cat:z-chcm)) + :g (cat:zero-mrph (cat:z-chcm) + (cat:sorc chi)) + :h chi))) + (cat:pre-check-rdct rdct) + (setf cat:*tc* (cat:cmbn 0 1 (cat:crpr 0 cat:+null-gbar+ 0 '()))) + (setf cat:*bc* (cat:cmbn 0 1 :z-gnrt)) + (check-rdct) + (setf cat:*tc* (cat:cmbn 1 1 (cat:crpr 1 cat:+null-gbar+ 0 '(1)))) + (check-rdct) + (setf cat:*tc* (cat:cmbn 4 1 (cat:crpr 0 (cat:gbar 4 0 '(10 11 12) + 0 '(20 21) + 0 '(30) 0 '()) + 0 '(2 4 6 8)))) + (check-rdct) + (setf cat:*tc* (cat:cmbn 3 1 (cat:crpr 0 (cat:gbar 3 0 '(10 11) + 0 '(20) 0 '()) + 0 '(2 4 6)))) + (check-rdct))) |# #| (test smgr-tnpr-contraction (cat:cat-init) (let* ((chi (cat:smgr-tnpr-contraction (cat:k-z-1))) - (rdct (cat:build-rdct :f (cat:zero-mrph (cat:sorc chi) - (cat:z-chcm)) - :g (cat:zero-mrph (cat:z-chcm) - (cat:sorc chi)) - :h chi))) - (cat:pre-check-rdct rdct) - (setf cat:*tc* (cat:cmbn 0 1 (cat:tnpr 0 cat:+null-gbar+ 0 '()))) - (setf cat:*bc* (cat:cmbn 0 1 :z-gnrt)) - (check-rdct) - (setf cat:*tc* (cat:cmbn 1 1 (cat:tnpr 0 cat:+null-gbar+ 1 '(1)))) - (check-rdct) - (setf cat:*tc* (cat:cmbn 3 1 (cat:tnpr 0 cat:+null-gbar+ - 3 '(1 10 100)))) - (cat:? chi cat:*tc*) - (check-rdct) - (setf cat:*tc* (cat:cmbn 3 1 (cat:tnpr 2 (cat:gbar 2 0 '(1) 0 '()) - 1 '(10)))) - (cat:? chi cat:*tc*) - (check-rdct) - (setf cat:*tc* (cat:cmbn 3 1 (cat:tnpr 3 (cat:gbar 3 0 '(1 10) - 0 '(100) 0 '()) - 0 '()))) - (cat:? chi cat:*tc*) - (check-rdct) - (setf cat:*tc* (cat:cmbn 4 1 (cat:tnpr 0 cat:+null-gbar+ - 4 '(1 10 100 1000)))) - (cat:? chi cat:*tc*) - (check-rdct) - (setf cat:*tc* (cat:cmbn 4 1 (cat:tnpr 2 (cat:gbar 2 0 '(1) 0 '()) - 2 '(10 100)))) - (cat:? chi cat:*tc*) - (check-rdct) - (setf cat:*tc* (cat:cmbn 4 1 (cat:tnpr 3 (cat:gbar 3 0 '(1 10) - 0 '(100) 0 '()) - 1 '(1000)))) - (cat:? chi cat:*tc*) - (check-rdct) - (setf cat:*tc* (cat:cmbn 4 1 (cat:tnpr 4 (cat:gbar 4 0 '(1 10 100) - 0 '(1000 10000) - 0 '(100000) - 0 '()) - 0 '()))) - (cat:? chi cat:*tc*) - (check-rdct))) + (rdct (cat:build-rdct :f (cat:zero-mrph (cat:sorc chi) + (cat:z-chcm)) + :g (cat:zero-mrph (cat:z-chcm) + (cat:sorc chi)) + :h chi))) + (cat:pre-check-rdct rdct) + (setf cat:*tc* (cat:cmbn 0 1 (cat:tnpr 0 cat:+null-gbar+ 0 '()))) + (setf cat:*bc* (cat:cmbn 0 1 :z-gnrt)) + (check-rdct) + (setf cat:*tc* (cat:cmbn 1 1 (cat:tnpr 0 cat:+null-gbar+ 1 '(1)))) + (check-rdct) + (setf cat:*tc* (cat:cmbn 3 1 (cat:tnpr 0 cat:+null-gbar+ + 3 '(1 10 100)))) + (cat:? chi cat:*tc*) + (check-rdct) + (setf cat:*tc* (cat:cmbn 3 1 (cat:tnpr 2 (cat:gbar 2 0 '(1) 0 '()) + 1 '(10)))) + (cat:? chi cat:*tc*) + (check-rdct) + (setf cat:*tc* (cat:cmbn 3 1 (cat:tnpr 3 (cat:gbar 3 0 '(1 10) + 0 '(100) 0 '()) + 0 '()))) + (cat:? chi cat:*tc*) + (check-rdct) + (setf cat:*tc* (cat:cmbn 4 1 (cat:tnpr 0 cat:+null-gbar+ + 4 '(1 10 100 1000)))) + (cat:? chi cat:*tc*) + (check-rdct) + (setf cat:*tc* (cat:cmbn 4 1 (cat:tnpr 2 (cat:gbar 2 0 '(1) 0 '()) + 2 '(10 100)))) + (cat:? chi cat:*tc*) + (check-rdct) + (setf cat:*tc* (cat:cmbn 4 1 (cat:tnpr 3 (cat:gbar 3 0 '(1 10) + 0 '(100) 0 '()) + 1 '(1000)))) + (cat:? chi cat:*tc*) + (check-rdct) + (setf cat:*tc* (cat:cmbn 4 1 (cat:tnpr 4 (cat:gbar 4 0 '(1 10 100) + 0 '(1000 10000) + 0 '(100000) + 0 '()) + 0 '()))) + (cat:? chi cat:*tc*) + (check-rdct))) |# diff --git a/test/delta-test.lisp b/test/delta-test.lisp index b5e72ba..b22a8b7 100644 --- a/test/delta-test.lisp +++ b/test/delta-test.lisp @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :kenzo-test) @@ -22,11 +23,11 @@ (is (equal '(0 2 4) (faces 3 '(0 2 4 6)))) (dotimes (i 4) - (print (cat:soft-delta-face i 3 (cat:d (cat:mask 4))))) + (print (cat:soft-delta-face i 3 (cat:d (cat:mask 4))))) (dotimes (i 4) - (print (cat:soft-delta-face i 3 (cat:d - (cat:dlop-ext-int '(0 2 4 6))))))) + (print (cat:soft-delta-face i 3 (cat:d + (cat:dlop-ext-int '(0 2 4 6))))))) (test delta-bndr @@ -41,7 +42,7 @@ (is (cat:cmbn-non-zero-p (cat:delta-dgnl 3 15))) (is (cat:cmbn-non-zero-p (cat:delta-dgnl 3 170))) (is (cat:cmbn-non-zero-p - (cat:soft-delta-dgnl 3 (cat:d (cat:dlop-ext-int '(1 3 5 7)))))) + (cat:soft-delta-dgnl 3 (cat:d (cat:dlop-ext-int '(1 3 5 7)))))) (is (cat:cmbn-non-zero-p (cat:delta-dgnl 0 64)))) @@ -58,64 +59,64 @@ (test soft-delta-infinity (progn - (cat:cat-init) - (cat:cmpr (cat:soft-delta-infinity) (cat:d 2) (cat:d 4)) - (cat:face (cat:soft-delta-infinity) 1 2 - (cat:d (cat:dlop-ext-int '(1 3 5)))) - (cat:cprd (cat:soft-delta-infinity) 3 (cat:d 15)) - (cat:dgnl (cat:soft-delta-infinity) 3 (cat:d 15)) - (cat:? (cat:soft-delta-infinity) 2 - (cat:d (cat:dlop-ext-int '(0 2 4)))))) + (cat:cat-init) + (cat:cmpr (cat:soft-delta-infinity) (cat:d 2) (cat:d 4)) + (cat:face (cat:soft-delta-infinity) 1 2 + (cat:d (cat:dlop-ext-int '(1 3 5)))) + (cat:cprd (cat:soft-delta-infinity) 3 (cat:d 15)) + (cat:dgnl (cat:soft-delta-infinity) 3 (cat:d 15)) + (cat:? (cat:soft-delta-infinity) 2 + (cat:d (cat:dlop-ext-int '(0 2 4)))))) (test basis (let ((basis (cat:delta-n-basis 3)) - (soft-basis (cat:soft-delta-n-basis 3))) - (dotimes (i 5) - (print (funcall basis i))) - (dotimes (i 5) - (print (funcall soft-basis i))))) + (soft-basis (cat:soft-delta-n-basis 3))) + (dotimes (i 5) + (print (funcall basis i))) + (dotimes (i 5) + (print (funcall soft-basis i))))) (test delta (progn - (cat:cat-init) - (let ((d3 (cat:delta 3)) - (d)) - (is (equal :less (cat:cmpr d3 2 4))) - (is (equal :equal (cat:cmpr d3 4 4))) - (is (equal :greater (cat:cmpr d3 8 4))) - (cat:basis d3 1) - (cat:dgnl d3 3 15) - (cat:face d3 1 2 21) - (cat:? d3 2 13) - (setf d (cat:delta-infinity)) - (cat:basis d)))) + (cat:cat-init) + (let ((d3 (cat:delta 3)) + (d)) + (is (equal :less (cat:cmpr d3 2 4))) + (is (equal :equal (cat:cmpr d3 4 4))) + (is (equal :greater (cat:cmpr d3 8 4))) + (cat:basis d3 1) + (cat:dgnl d3 3 15) + (cat:face d3 1 2 21) + (cat:? d3 2 13) + (setf d (cat:delta-infinity)) + (cat:basis d)))) (test soft-delta (progn - (cat:cat-init) - (let ((d3 (cat:soft-delta 3))) - (cat:cmpr d3 (cat:d 2) (cat:d 4)) - (cat:basis d3 1) - (cat:dgnl d3 3 (cat:d 15)) - (cat:face d3 1 2 (cat:d 21)) - (cat:? d3 2 (cat:d 13))))) + (cat:cat-init) + (let ((d3 (cat:soft-delta 3))) + (cat:cmpr d3 (cat:d 2) (cat:d 4)) + (cat:basis d3 1) + (cat:dgnl d3 3 (cat:d 15)) + (cat:face d3 1 2 (cat:d 21)) + (cat:? d3 2 (cat:d 13))))) (test eat (let* ((delta (cat:delta-infinity)) - (d (cat:bndr delta)) - (s14 (cat:mask 15))) - (cat:cmbn-? d (cat:gnrt-? d 14 s14)) - (defun t1 (n) - (time (dotimes (i n) (cat:cmbn-? d (cat:gnrt-? d 14 s14))))) - (compile 't1) - (t1 500) - (setf cat:+too-much-time+ -1) - (t1 500))) + (d (cat:bndr delta)) + (s14 (cat:mask 15))) + (cat:cmbn-? d (cat:gnrt-? d 14 s14)) + (defun t1 (n) + (time (dotimes (i n) (cat:cmbn-? d (cat:gnrt-? d 14 s14))))) + (compile 't1) + (t1 500) + (setf cat:+too-much-time+ -1) + (t1 500))) (test deltab2-dgnl (dotimes (i 7) - (print (cat:deltab2-dgnl i (cat:mask (1+ i)))))) + (print (cat:deltab2-dgnl i (cat:mask (1+ i)))))) (test deltab2-bndr diff --git a/test/diabolo.lisp b/test/diabolo.lisp index a0414c5..a7a377e 100644 --- a/test/diabolo.lisp +++ b/test/diabolo.lisp @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :kenzo-test) @@ -16,34 +17,34 @@ (case dmn (0 (cat:cmbn -1)) (1 (case gnr - (s01 (cat:cmbn 0 -1 's0 1 's1)) - (s02 (cat:cmbn 0 -1 's0 1 's2)) - (s12 (cat:cmbn 0 -1 's1 1 's2)) - (s23 (cat:cmbn 0 -1 's2 1 's3)) - (s34 (cat:cmbn 0 -1 's3 1 's4)) - (s35 (cat:cmbn 0 -1 's3 1 's5)) - (s45 (cat:cmbn 0 -1 's4 1 's5)))) + (s01 (cat:cmbn 0 -1 's0 1 's1)) + (s02 (cat:cmbn 0 -1 's0 1 's2)) + (s12 (cat:cmbn 0 -1 's1 1 's2)) + (s23 (cat:cmbn 0 -1 's2 1 's3)) + (s34 (cat:cmbn 0 -1 's3 1 's4)) + (s35 (cat:cmbn 0 -1 's3 1 's5)) + (s45 (cat:cmbn 0 -1 's4 1 's5)))) (2 (case gnr - (s345 (cat:cmbn 1 1 's34 -1 's35 1 's45)))) + (s345 (cat:cmbn 1 1 's34 -1 's35 1 's45)))) (otherwise (error "Bad generator for complex diabolo.")))) (test diabolo (progn - (cat:cat-init) - (let ((diabolo (cat:build-chcm :cmpr #'cat:s-cmpr - :basis #'diabolo-basis - :bsgn 's0 - :intr-dffr #'diabolo-pure-dffr - :strt :GNRT - :orgn '(diabolo-for-example)))) - (is (equal (cat:basis diabolo 0) '(s0 s1 s2 s3 s4 s5))) - (is (equal (cat:basis diabolo 1) '(s01 s02 s12 s23 s34 s35 s45))) - (is (equal (cat:basis diabolo 2) '(s345))) - (is (null (cat:basis diabolo 10))) + (cat:cat-init) + (let ((diabolo (cat:build-chcm :cmpr #'cat:s-cmpr + :basis #'diabolo-basis + :bsgn 's0 + :intr-dffr #'diabolo-pure-dffr + :strt :GNRT + :orgn '(diabolo-for-example)))) + (is (equal (cat:basis diabolo 0) '(s0 s1 s2 s3 s4 s5))) + (is (equal (cat:basis diabolo 1) '(s01 s02 s12 s23 s34 s35 s45))) + (is (equal (cat:basis diabolo 2) '(s345))) + (is (null (cat:basis diabolo 10))) - (let* ((comb (cat:dffr diabolo 2 's345)) - (comb1 (cat:dffr diabolo comb))) - (is (equal (cat:cmbn-degr comb) 1)) - (is (equal (cat:cmbn-list comb) '((1 . s34) (-1 . s35) (1 . s45)))) - (is (equal (cat:cmbn-degr comb1) 0)) - (is (equal (cat:cmbn-list comb1) nil)))))) + (let* ((comb (cat:dffr diabolo 2 's345)) + (comb1 (cat:dffr diabolo comb))) + (is (equal (cat:cmbn-degr comb) 1)) + (is (equal (cat:cmbn-list comb) '((1 . s34) (-1 . s35) (1 . s45)))) + (is (equal (cat:cmbn-degr comb1) 0)) + (is (equal (cat:cmbn-list comb1) nil)))))) diff --git a/test/disk-pasting-test.lisp b/test/disk-pasting-test.lisp index 9eabdcb..8c1fb4f 100644 --- a/test/disk-pasting-test.lisp +++ b/test/disk-pasting-test.lisp @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :kenzo-test) @@ -5,144 +6,144 @@ (test disk-pasting-cmpr (let* ((c (cat:delta 3)) - (cmpr (cat:disk-pasting-cmpr (cat:cmpr c) 'new))) - (is (equal :equal (funcall cmpr 'new 'new))) - (is (equal :less (funcall cmpr 'new 5))) - (is (equal :greater (funcall cmpr 5 'new))) - (is (equal :equal (funcall cmpr 5 5))) - (is (equal :less (funcall cmpr 5 6))) - (is (equal :greater (funcall cmpr 6 5))))) + (cmpr (cat:disk-pasting-cmpr (cat:cmpr c) 'new))) + (is (equal :equal (funcall cmpr 'new 'new))) + (is (equal :less (funcall cmpr 'new 5))) + (is (equal :greater (funcall cmpr 5 'new))) + (is (equal :equal (funcall cmpr 5 5))) + (is (equal :less (funcall cmpr 5 6))) + (is (equal :greater (funcall cmpr 6 5))))) (test disk-pasting-basis (cat:cat-init) (let* ((c (cat:delta 3)) - (basis (cat:disk-pasting-basis (cat:basis c) 3 'new))) - (funcall basis 3) - (funcall basis 2))) + (basis (cat:disk-pasting-basis (cat:basis c) 3 'new))) + (funcall basis 3) + (funcall basis 2))) (test disk-pasting-intr-dffr (cat:cat-init) (let* ((c (cat:delta 3)) - intr) - (signals simple-error - (setf intr (cat:disk-pasting-intr-dffr - (cat:dffr c) 3 'new (cat:cmbn 2 1 7)))) - (setf intr (cat:disk-pasting-intr-dffr (cat:dffr c) - 3 'new (cat:? c 3 15))) - (funcall intr (cat:cmbn 2 1 7)) - (funcall intr (cat:cmbn 3)) - (funcall intr (cat:cmbn 3 1 15)) - (funcall intr (cat:cmbn 3 1 'new 1 15)) - (funcall intr (cat:cmbn 3 1 'new -1 15)) - (funcall intr (cat:cmbn 3 -1 'new 1 15)) - (funcall intr (cat:cmbn 3 -1 'new -1 15)))) + intr) + (signals simple-error + (setf intr (cat:disk-pasting-intr-dffr + (cat:dffr c) 3 'new (cat:cmbn 2 1 7)))) + (setf intr (cat:disk-pasting-intr-dffr (cat:dffr c) + 3 'new (cat:? c 3 15))) + (funcall intr (cat:cmbn 2 1 7)) + (funcall intr (cat:cmbn 3)) + (funcall intr (cat:cmbn 3 1 15)) + (funcall intr (cat:cmbn 3 1 'new 1 15)) + (funcall intr (cat:cmbn 3 1 'new -1 15)) + (funcall intr (cat:cmbn 3 -1 'new 1 15)) + (funcall intr (cat:cmbn 3 -1 'new -1 15)))) (test chcm-disk-pasting (cat:cat-init) (let* ((c (cat:delta 3)) - (s3 (cat:chcm-disk-pasting c 3 'new (cat:? c 3 15)))) - (cat:homology s3 0 5))) + (s3 (cat:chcm-disk-pasting c 3 'new (cat:? c 3 15)))) + (cat:homology s3 0 5))) (test disk-pasting-face (cat:cat-init) (let* ((c (cat:delta 3)) - (face (cat:disk-pasting-face (cat:cmpr c) (cat:face c) - 3 'new - (list 14 (cat:absm 0 13) 11 7)))) - (funcall face 0 2 7) - (funcall face 0 3 15) - (dotimes (i 4) (print (funcall face i 3 'new))))) + (face (cat:disk-pasting-face (cat:cmpr c) (cat:face c) + 3 'new + (list 14 (cat:absm 0 13) 11 7)))) + (funcall face 0 2 7) + (funcall face 0 3 15) + (dotimes (i 4) (print (funcall face i 3 'new))))) (test disk-pasting (cat:cat-init) (let* ((d2 (cat:delta 2)) - (s2 (cat:disk-pasting d2 2 'new '(6 5 3))) - s2xs2) - (cat:homology s2 0 4) - (setf s2xs2 (cat:crts-prdc s2 s2)) - (cat:homology s2xs2 0 6))) + (s2 (cat:disk-pasting d2 2 'new '(6 5 3))) + s2xs2) + (cat:homology s2 0 4) + (setf s2xs2 (cat:crts-prdc s2 s2)) + (cat:homology s2xs2 0 6))) (test mrph-disk-pasting-intr (cat:cat-init) (let* ((m (cat:idnt-mrph (cat:delta 3))) - (intr (cat:mrph-disk-pasting-intr m (cat:cmpr (cat:delta 3)) - 3 'new (cat:cmbn 3 -1 15)))) - (funcall intr (cat:cmbn 2 3 7)) - (funcall intr (cat:cmbn 3)) - (funcall intr (cat:cmbn 3 4 15)) - (funcall intr (cat:cmbn 3 1 'new 1 15)) - (funcall intr (cat:cmbn 3 -1 'new 1 15)))) + (intr (cat:mrph-disk-pasting-intr m (cat:cmpr (cat:delta 3)) + 3 'new (cat:cmbn 3 -1 15)))) + (funcall intr (cat:cmbn 2 3 7)) + (funcall intr (cat:cmbn 3)) + (funcall intr (cat:cmbn 3 4 15)) + (funcall intr (cat:cmbn 3 1 'new 1 15)) + (funcall intr (cat:cmbn 3 -1 'new 1 15)))) (test mrph-disk-pasting (cat:cat-init) (let* ((d (cat:delta 3)) - (m (cat:idnt-mrph d)) - (sorc (cat:chcm-disk-pasting d 3 'new (cat:? d 3 15))) - (nm (cat:mrph-disk-pasting m sorc sorc 3 'new - (cat:cmbn 3 1 'new)))) - (cat:? nm (cat:cmbn 3 2 'new 3 15)))) + (m (cat:idnt-mrph d)) + (sorc (cat:chcm-disk-pasting d 3 'new (cat:? d 3 15))) + (nm (cat:mrph-disk-pasting m sorc sorc 3 'new + (cat:cmbn 3 1 'new)))) + (cat:? nm (cat:cmbn 3 2 'new 3 15)))) (test disk-pasting1 (cat:cat-init) (let* ((d (cat:delta 2)) - (s2 (cat:disk-pasting d 2 'new '(6 5 3)))) - (cat:homology s2 0 4))) + (s2 (cat:disk-pasting d 2 'new '(6 5 3)))) + (cat:homology s2 0 4))) (test hmeq-disk-pasting (cat:cat-init) (let* ((tcc (cat:build-chcm - :cmpr #'cat:s-cmpr - :basis #'(lambda (degr) - (case degr - (0 (list 'a)) - (1 (list 'b)) - (otherwise nil))) - :intr-dffr #'(lambda (degr gnrt) - (if (= 1 degr) - (cat:cmbn 0 1 'a) - (cat:zero-cmbn (1- degr)))) - :strt :gnrt - :orgn '(z-z))) - (bcc (cat:build-chcm - :cmpr #'cat:s-cmpr - :basis #'(lambda (degr) nil) - :intr-dffr #'(lambda (degr gnrt) (error "Impossible.")) - :strt :gnrt - :orgn '(zero))) - (rh (cat:build-mrph - :sorc tcc :trgt tcc :degr +1 - :intr #'(lambda (degr gnrt) - (if (zerop degr) - (cat:cmbn 1 1 'b) - (cat:zero-cmbn 2))) - :strt :gnrt - :orgn '(rh))) - (hmeq (cat:build-hmeq - :lrdct (cat:trivial-rdct tcc) - :rrdct (cat:build-rdct - :f (cat:zero-mrph tcc bcc 0) - :g (cat:zero-mrph bcc tcc 0) - :h rh - :orgn '(rrdct)))) - (nhmeq (cat:hmeq-disk-pasting hmeq 1 'new (cat:cmbn 0 1 'a)))) - (cat:pre-check-rdct (cat:lrdct nhmeq)) - (setf cat:*tc* (cat:cmbn 0 1 'a)) - (setf cat:*bc* cat:*tc*) - (check-rdct) - (setf cat:*tc* (cat:cmbn 1 1 'new 10 'b)) - (setf cat:*bc* cat:*tc*) - (check-rdct) - (cat:pre-check-rdct (cat:rrdct nhmeq)) - (setf cat:*bc* (cat:zero-cmbn 0)) - (check-rdct) - (setf cat:*tc* (cat:cmbn 0 1 'a)) - (check-rdct))) + :cmpr #'cat:s-cmpr + :basis #'(lambda (degr) + (case degr + (0 (list 'a)) + (1 (list 'b)) + (otherwise nil))) + :intr-dffr #'(lambda (degr gnrt) + (if (= 1 degr) + (cat:cmbn 0 1 'a) + (cat:zero-cmbn (1- degr)))) + :strt :gnrt + :orgn '(z-z))) + (bcc (cat:build-chcm + :cmpr #'cat:s-cmpr + :basis #'(lambda (degr) nil) + :intr-dffr #'(lambda (degr gnrt) (error "Impossible.")) + :strt :gnrt + :orgn '(zero))) + (rh (cat:build-mrph + :sorc tcc :trgt tcc :degr +1 + :intr #'(lambda (degr gnrt) + (if (zerop degr) + (cat:cmbn 1 1 'b) + (cat:zero-cmbn 2))) + :strt :gnrt + :orgn '(rh))) + (hmeq (cat:build-hmeq + :lrdct (cat:trivial-rdct tcc) + :rrdct (cat:build-rdct + :f (cat:zero-mrph tcc bcc 0) + :g (cat:zero-mrph bcc tcc 0) + :h rh + :orgn '(rrdct)))) + (nhmeq (cat:hmeq-disk-pasting hmeq 1 'new (cat:cmbn 0 1 'a)))) + (cat:pre-check-rdct (cat:lrdct nhmeq)) + (setf cat:*tc* (cat:cmbn 0 1 'a)) + (setf cat:*bc* cat:*tc*) + (check-rdct) + (setf cat:*tc* (cat:cmbn 1 1 'new 10 'b)) + (setf cat:*bc* cat:*tc*) + (check-rdct) + (cat:pre-check-rdct (cat:rrdct nhmeq)) + (setf cat:*bc* (cat:zero-cmbn 0)) + (check-rdct) + (setf cat:*tc* (cat:cmbn 0 1 'a)) + (check-rdct))) diff --git a/test/effective-homology-test.lisp b/test/effective-homology-test.lisp index 45ad1d6..e4df7a9 100644 --- a/test/effective-homology-test.lisp +++ b/test/effective-homology-test.lisp @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :kenzo-test) @@ -5,107 +6,107 @@ (test cdelta (progn - (cat:cat-init) - (let* ((cc (cdelta 5)) - (hmeq (cat:trivial-hmeq cc))) - (declare (ignore hmeq)) - (signals simple-error (equal (cat:basis cc 0) cat:+empty-list+)) - (signals simple-error (equal (cat:basis cc 1) cat:+empty-list+)) - (signals simple-error (equal (cat:basis cc 2) cat:+empty-list+)) - (signals simple-error (equal (cat:basis cc 3) cat:+empty-list+)) - (signals simple-error (equal (cat:basis cc 4) cat:+empty-list+)) - (signals simple-error (equal (cat:basis cc 5) cat:+empty-list+))))) + (cat:cat-init) + (let* ((cc (cdelta 5)) + (hmeq (cat:trivial-hmeq cc))) + (declare (ignore hmeq)) + (signals simple-error (equal (cat:basis cc 0) cat:+empty-list+)) + (signals simple-error (equal (cat:basis cc 1) cat:+empty-list+)) + (signals simple-error (equal (cat:basis cc 2) cat:+empty-list+)) + (signals simple-error (equal (cat:basis cc 3) cat:+empty-list+)) + (signals simple-error (equal (cat:basis cc 4) cat:+empty-list+)) + (signals simple-error (equal (cat:basis cc 5) cat:+empty-list+))))) (test make-rdct (progn - (cat:cat-init) - (let ((rdct (make-rdct 6 3))) - (is (equal (cat:orgn rdct) '(REDUCTION DELTA 6 3))) - (cat:pre-check-rdct rdct) - (setf cat:*tc* (cat:cmbn 2 1 '(0 1 2) 10 '(1 2 3) 100 '(1 2 4) - 1000 '(2 3 4))) - (setf cat:*bc* (cat:cmbn 3 4 '(0 1 2 3))) - (check-rdct)))) + (cat:cat-init) + (let ((rdct (make-rdct 6 3))) + (is (equal (cat:orgn rdct) '(REDUCTION DELTA 6 3))) + (cat:pre-check-rdct rdct) + (setf cat:*tc* (cat:cmbn 2 1 '(0 1 2) 10 '(1 2 3) 100 '(1 2 4) + 1000 '(2 3 4))) + (setf cat:*bc* (cat:cmbn 3 4 '(0 1 2 3))) + (check-rdct)))) (test cmps (progn - (cat:cat-init) - (let* ((trdct (make-rdct 6 4)) - (brdct (make-rdct 4 3)) - (rdct (cat:cmps brdct trdct))) - (cat:pre-check-rdct rdct) - (setf cat:*tc* (cat:cmbn 2 1 '(0 1 2) 10 '(1 2 3) 100 '(1 2 4) - 100 '(1 3 5) 10 '(1 4 5) 1 '(3 4 5))) - (setf cat:*bc* (cat:cmbn 2 1 '(0 1 3))) - (check-rdct)))) + (cat:cat-init) + (let* ((trdct (make-rdct 6 4)) + (brdct (make-rdct 4 3)) + (rdct (cat:cmps brdct trdct))) + (cat:pre-check-rdct rdct) + (setf cat:*tc* (cat:cmbn 2 1 '(0 1 2) 10 '(1 2 3) 100 '(1 2 4) + 100 '(1 3 5) 10 '(1 4 5) 1 '(3 4 5))) + (setf cat:*bc* (cat:cmbn 2 1 '(0 1 3))) + (check-rdct)))) (test zero-mrph (progn - (cat:cat-init) - (let* ((rdct (make-rdct 6 3)) - (perturb (cat:zero-mrph (cdelta 6) (cdelta 6) -1)) - (new-rdct (cat:add rdct perturb))) - (cat:pre-check-rdct new-rdct) - (setf cat:*tc* (cat:cmbn 2 3 '(0 1 2))) - (setf cat:*bc* (cat:cmbn 3 4 '(0 1 2 3))) - (check-rdct)))) + (cat:cat-init) + (let* ((rdct (make-rdct 6 3)) + (perturb (cat:zero-mrph (cdelta 6) (cdelta 6) -1)) + (new-rdct (cat:add rdct perturb))) + (cat:pre-check-rdct new-rdct) + (setf cat:*tc* (cat:cmbn 2 3 '(0 1 2))) + (setf cat:*bc* (cat:cmbn 3 4 '(0 1 2 3))) + (check-rdct)))) (test opps (progn - (cat:cat-init) - (let* ((rdct (make-rdct 6 3)) - (perturb (cat:opps (cat:dffr (cat:tcc rdct)))) - (new-rdct (cat:add rdct perturb))) - (cat:pre-check-rdct new-rdct) - (setf cat:*tc* (cat:cmbn 2 3 '(0 1 2))) - (setf cat:*bc* (cat:cmbn 3 4 '(0 1 2 3))) - (check-rdct)))) + (cat:cat-init) + (let* ((rdct (make-rdct 6 3)) + (perturb (cat:opps (cat:dffr (cat:tcc rdct)))) + (new-rdct (cat:add rdct perturb))) + (cat:pre-check-rdct new-rdct) + (setf cat:*tc* (cat:cmbn 2 3 '(0 1 2))) + (setf cat:*bc* (cat:cmbn 3 4 '(0 1 2 3))) + (check-rdct)))) ;; an absurd reduction ; just to test bpl-*-sigma (test bpl-*-sigma (progn - (cat:cat-init) - (let* ((tcc (cat:build-chcm - :cmpr #'cat:l-cmpr - :basis :locally-effective - :bsgn '(0) - :intr-dffr #'(lambda (degr gnrt) - (cat:cmbn (1- degr) 1 gnrt)) - :strt :gnrt - :orgn '(test1))) - (rdct (cat:trivial-rdct tcc)) - (perturb (cat:build-mrph - :sorc tcc :trgt tcc :degr -1 - :intr #'(lambda (degr gnrt) - (if (zerop (first gnrt)) - (cat:zero-cmbn (1- degr)) - (cat:cmbn (1- degr) 1 - (list (1- (first gnrt)) - (1+ (second gnrt)))))) - :strt :gnrt - :orgn '(test3))) - (new-rdct)) - (setf (slot-value rdct 'cat:h) - (cat:build-mrph - :sorc tcc :trgt tcc :degr +1 - :intr #'(lambda (degr gnrt) - (cat:cmbn (1+ degr) 1 gnrt)) - :strt :gnrt - :orgn '(test2))) - (setf new-rdct (cat:add rdct perturb)) - (cat:gnrt-? (cat:dffr (cat:tcc new-rdct)) 3 '(3 5)) - (cat:gnrt-? (cat:dffr (cat:bcc new-rdct)) 3 '(3 5))))) + (cat:cat-init) + (let* ((tcc (cat:build-chcm + :cmpr #'cat:l-cmpr + :basis :locally-effective + :bsgn '(0) + :intr-dffr #'(lambda (degr gnrt) + (cat:cmbn (1- degr) 1 gnrt)) + :strt :gnrt + :orgn '(test1))) + (rdct (cat:trivial-rdct tcc)) + (perturb (cat:build-mrph + :sorc tcc :trgt tcc :degr -1 + :intr #'(lambda (degr gnrt) + (if (zerop (first gnrt)) + (cat:zero-cmbn (1- degr)) + (cat:cmbn (1- degr) 1 + (list (1- (first gnrt)) + (1+ (second gnrt)))))) + :strt :gnrt + :orgn '(test3))) + (new-rdct)) + (setf (slot-value rdct 'cat:h) + (cat:build-mrph + :sorc tcc :trgt tcc :degr +1 + :intr #'(lambda (degr gnrt) + (cat:cmbn (1+ degr) 1 gnrt)) + :strt :gnrt + :orgn '(test2))) + (setf new-rdct (cat:add rdct perturb)) + (cat:gnrt-? (cat:dffr (cat:tcc new-rdct)) 3 '(3 5)) + (cat:gnrt-? (cat:dffr (cat:bcc new-rdct)) 3 '(3 5))))) (test trivial-hmeq (progn - (cat:cat-init) - (let ((hmeq (cat:trivial-hmeq (cdelta 4)))) - (cat:add (cat:lrdct hmeq) (cat:opps (cat:dffr (cdelta 4)))) - (setf hmeq (cat:add hmeq (cat:opps (cat:dffr (cdelta 4))))) - (cat:gnrt-? (cat:dffr (cat:rbcc hmeq)) 3 '(0 1 2 3))))) + (cat:cat-init) + (let ((hmeq (cat:trivial-hmeq (cdelta 4)))) + (cat:add (cat:lrdct hmeq) (cat:opps (cat:dffr (cdelta 4)))) + (setf hmeq (cat:add hmeq (cat:opps (cat:dffr (cdelta 4))))) + (cat:gnrt-? (cat:dffr (cat:rbcc hmeq)) 3 '(0 1 2 3))))) diff --git a/test/eilenberg-zilber-test.lisp b/test/eilenberg-zilber-test.lisp index 813b717..1730c67 100644 --- a/test/eilenberg-zilber-test.lisp +++ b/test/eilenberg-zilber-test.lisp @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :kenzo-test) @@ -6,115 +7,115 @@ (test shuffle-sign (dotimes (i 30) - (format t "~%~A => ~@D" (cat:hyphenize-list (cat:dlop-int-ext i)) - (cat:shuffle-sign i)))) + (format t "~%~A => ~@D" (cat:hyphenize-list (cat:dlop-int-ext i)) + (cat:shuffle-sign i)))) (test intr-eml (cat:intr-eml (cat:cmbn 3 1 (cat:tnpr 0 'a 3 'b) - 2 (cat:tnpr 2 'a 1 'b) - 3 (cat:tnpr 2 'aa 1 'bb) - 4 (cat:tnpr 3 'a 0 'b))) + 2 (cat:tnpr 2 'a 1 'b) + 3 (cat:tnpr 2 'aa 1 'bb) + 4 (cat:tnpr 3 'a 0 'b))) (cat:intr-eml (cat:cmbn 3 1 (cat:tnpr 1 'c 2 'd) - 10 (cat:tnpr 2 'a 1 'b))) + 10 (cat:tnpr 2 'a 1 'b))) (cat:intr-eml (cat:cmbn 3 10 (cat:tnpr 1 'c 2 'd) - 1 (cat:tnpr 2 'a 1 'b) - 100 (cat:tnpr 2 'aa 1 'bb))) + 1 (cat:tnpr 2 'a 1 'b) + 100 (cat:tnpr 2 'aa 1 'bb))) (cat:intr-eml (cat:cmbn 3 10 (cat:tnpr 1 'c 2 'd) - 100 (cat:tnpr 1 'cc 2 'dd) - 1 (cat:tnpr 2 'a 1 'b)))) + 100 (cat:tnpr 1 'cc 2 'dd) + 1 (cat:tnpr 2 'a 1 'b)))) (test eml (cat:cat-init) (let* ((d (cat:delta-infinity)) - (eml (cat:eml d d))) - (cat:? eml (cat:cmbn 3 1 (cat:tnpr 0 1 3 30) - 10 (cat:tnpr 1 3 2 28) - 100 (cat:tnpr 2 7 1 24) - 1000 (cat:tnpr 3 15 0 16))))) + (eml (cat:eml d d))) + (cat:? eml (cat:cmbn 3 1 (cat:tnpr 0 1 3 30) + 10 (cat:tnpr 1 3 2 28) + 100 (cat:tnpr 2 7 1 24) + 1000 (cat:tnpr 3 15 0 16))))) (test intr-phi (cat:cat-init) (let* ((d (cat:delta-infinity)) - (rslt (cat:intr-phi d d))) - (funcall rslt (cat:cmbn 3 1 (cat:crpr 0 15 0 15))) - (funcall rslt (cat:cmbn 2 1 (cat:crpr 0 7 0 7))) - (funcall rslt (cat:cmbn 1 1 (cat:crpr 0 3 0 3))) - (funcall rslt (cat:cmbn 0 1 (cat:crpr 0 1 0 1))))) + (rslt (cat:intr-phi d d))) + (funcall rslt (cat:cmbn 3 1 (cat:crpr 0 15 0 15))) + (funcall rslt (cat:cmbn 2 1 (cat:crpr 0 7 0 7))) + (funcall rslt (cat:cmbn 1 1 (cat:crpr 0 3 0 3))) + (funcall rslt (cat:cmbn 0 1 (cat:crpr 0 1 0 1))))) (test phi (cat:cat-init) (let ((phi (cat:phi (cat:delta-infinity) (cat:delta-infinity)))) - (cat:? phi 3 (cat:crpr 0 15 0 15)))) + (cat:? phi 3 (cat:crpr 0 15 0 15)))) (test eat (cat:cat-init) (let* ((s (cat:sphere 5)) - (p (cat:crts-prdc s s)) - (b (cat:basis p 8)) - (c (cat:make-cmbn :degr 8 - :list (mapcar #'(lambda (item) - (cat:term (1+ (random 5)) - item)) - b))) - (phi (cat:phi s s))) - (time (cat:? phi c)))) + (p (cat:crts-prdc s s)) + (b (cat:basis p 8)) + (c (cat:make-cmbn :degr 8 + :list (mapcar #'(lambda (item) + (cat:term (1+ (random 5)) + item)) + b))) + (phi (cat:phi s s))) + (time (cat:? phi c)))) (test intr-aw (cat:cat-init) (let* ((r (cat:intr-aw #'cat:delta-face #'cat:delta-face)) - (s (cat:sphere 3)) - (f (cat:face s))) - (funcall r 3 (cat:crpr 0 15 0 15)) - (setf r (cat:intr-aw f f)) - (funcall r 3 (cat:crpr 0 's3 0 's3)))) + (s (cat:sphere 3)) + (f (cat:face s))) + (funcall r 3 (cat:crpr 0 15 0 15)) + (setf r (cat:intr-aw f f)) + (funcall r 3 (cat:crpr 0 's3 0 's3)))) (test aw (cat:cat-init) (let ((aw (cat:aw (cat:delta-infinity) (cat:delta-infinity)))) - (cat:? aw (cat:cmbn 3 1 (cat:crpr 0 15 0 30) - -1 (cat:crpr 0 23 0 29))))) + (cat:? aw (cat:cmbn 3 1 (cat:crpr 0 15 0 30) + -1 (cat:crpr 0 23 0 29))))) (test ez (cat:cat-init) (let ((ez (cat:ez (cat:delta-infinity) (cat:delta-infinity)))) - (setf cat:*bc* (cat:cmbn 3 1 (cat:tnpr 0 1 3 30) - 10 (cat:tnpr 1 96 2 896) - 100 (cat:tnpr 2 7168 1 3) - 1000 (cat:tnpr 3 15 0 4096))) - (setf cat:*tc* (cat:cmbn 3 1 (cat:crpr 0 15 0 480) - 100 (cat:crpr 0 15 5 96) - 10 (cat:crpr 6 3 0 480) - 1000 (cat:crpr 6 3 1 224))) - (cat:pre-check-rdct ez) - (check-rdct))) + (setf cat:*bc* (cat:cmbn 3 1 (cat:tnpr 0 1 3 30) + 10 (cat:tnpr 1 96 2 896) + 100 (cat:tnpr 2 7168 1 3) + 1000 (cat:tnpr 3 15 0 4096))) + (setf cat:*tc* (cat:cmbn 3 1 (cat:crpr 0 15 0 480) + 100 (cat:crpr 0 15 5 96) + 10 (cat:crpr 6 3 0 480) + 1000 (cat:crpr 6 3 1 224))) + (cat:pre-check-rdct ez) + (check-rdct))) (test eat1 (cat:cat-init) (let* ((s (cat:sphere 5)) - (ez (cat:ez s s)) - (b (cat:basis (cat:tcc ez) 8)) - (c (cat:make-cmbn :degr 8 - :list (mapcar #'(lambda (item) - (cat:term (1+ (random 5)) - item)) - b)))) - (cat:pre-check-rdct ez) - (setf cat:+too-much-time+ -1) - (time (cat:? cat:*id-gf-dh-hd* c)) - (time (cat:? cat:*id-gf-dh-hd* c)))) + (ez (cat:ez s s)) + (b (cat:basis (cat:tcc ez) 8)) + (c (cat:make-cmbn :degr 8 + :list (mapcar #'(lambda (item) + (cat:term (1+ (random 5)) + item)) + b)))) + (cat:pre-check-rdct ez) + (setf cat:+too-much-time+ -1) + (time (cat:? cat:*id-gf-dh-hd* c)) + (time (cat:? cat:*id-gf-dh-hd* c)))) (test crts-prdc (cat:cat-init) (let* ((k (cat:k-z 2)) - (k2 (cat:crts-prdc k k))) - (cat:homology k2 0 10))) + (k2 (cat:crts-prdc k k))) + (cat:homology k2 0 10))) diff --git a/test/fibrations-test.lisp b/test/fibrations-test.lisp index 085151a..ce82019 100644 --- a/test/fibrations-test.lisp +++ b/test/fibrations-test.lisp @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :kenzo-test) @@ -8,67 +9,67 @@ (test fibration-total-face (cat:cat-init) (let* ((h (cat:hopf 1)) - (sf (cat:serre-face h))) - (funcall sf 0 2 (cat:crpr 0 's2 0 '(2 4))) - (funcall sf 1 2 (cat:crpr 0 's2 0 '(2 4))) - (funcall sf 2 2 (cat:crpr 0 's2 0 '(2 4))) - (funcall sf 3 3 (cat:crpr 1 's2 2 '(2 4))))) + (sf (cat:serre-face h))) + (funcall sf 0 2 (cat:crpr 0 's2 0 '(2 4))) + (funcall sf 1 2 (cat:crpr 0 's2 0 '(2 4))) + (funcall sf 2 2 (cat:crpr 0 's2 0 '(2 4))) + (funcall sf 3 3 (cat:crpr 1 's2 2 '(2 4))))) |# (test fibration-total (cat:cat-init) (let* ((s2 (cat:sphere 2)) - (k (cat:k-z-1)) - (tw (cat:build-smmr - :sorc s2 - :trgt k - :degr -1 - :sintr #'(lambda (dmns gmsm) - (cat:absm 0 (list 1))) - :orgn '(s2-tw-kz1))) - (e (cat:fibration-total tw))) - (cat:homology e 2) - (cat:homology e 0 8))) + (k (cat:k-z-1)) + (tw (cat:build-smmr + :sorc s2 + :trgt k + :degr -1 + :sintr #'(lambda (dmns gmsm) + (cat:absm 0 (list 1))) + :orgn '(s2-tw-kz1))) + (e (cat:fibration-total tw))) + (cat:homology e 2) + (cat:homology e 0 8))) (test fibration-total1 (cat:cat-init) (let* ((s2 (cat:sphere 2)) - (k (cat:k-z2-1)) - (tw (cat:build-smmr - :sorc s2 - :trgt k - :degr -1 - :sintr #'(lambda (dmns gmsm) - (cat:absm 0 1)) - :orgn '(s2-tw-kz2))) - (e (cat:fibration-total tw))) - (cat:homology e 2) - (cat:homology e 0 8))) + (k (cat:k-z2-1)) + (tw (cat:build-smmr + :sorc s2 + :trgt k + :degr -1 + :sintr #'(lambda (dmns gmsm) + (cat:absm 0 1)) + :orgn '(s2-tw-kz2))) + (e (cat:fibration-total tw))) + (cat:homology e 2) + (cat:homology e 0 8))) #| (test fibration-total2 (cat:cat-init) (let* ((tw (cat:kdivide-z2-twist opr opr-chml-clss)) - (pr-4 (cat:fibration-total tw)) - (absm (cat:absm 0 (cat:crpr 0 (cat:loop3 0 5 2) 0 4))) - (hat (mapcar #'(lambda (i) (cat:face pr-4 i 4 absm)) - (cat: 0 4)))) - (dotimes (i 5) - (print (cat:kfll pr-4 i 4 (remove (nth i hat) hat))) - (cat:check-kan pr-4 i 4 (remove (nth i hat) hat))))) + (pr-4 (cat:fibration-total tw)) + (absm (cat:absm 0 (cat:crpr 0 (cat:loop3 0 5 2) 0 4))) + (hat (mapcar #'(lambda (i) (cat:face pr-4 i 4 absm)) + (cat: 0 4)))) + (dotimes (i 5) + (print (cat:kfll pr-4 i 4 (remove (nth i hat) hat))) + (cat:check-kan pr-4 i 4 (remove (nth i hat) hat))))) (test fibration-total3 (cat:cat-init) (let* ((os3-fibration os3-fibration) - (total (cat:fibration-total os3-fibration)) - (absm (cat:absm 1 (cat:crpr 0 (cat:loop3 1 's3 1 2 's3 -2) - 0 '(-2 1 1)))) - (hat (mapcar #'(lambda (i) (cat:face total i 4 absm)) - '(0 1 2 3 4)))) - (dotimes (i 5) - (print (kfll total i 4 (remove (nth i hat) hat))) - (check-kan total i 4 (remove (nth i hat) hat))))) + (total (cat:fibration-total os3-fibration)) + (absm (cat:absm 1 (cat:crpr 0 (cat:loop3 1 's3 1 2 's3 -2) + 0 '(-2 1 1)))) + (hat (mapcar #'(lambda (i) (cat:face total i 4 absm)) + '(0 1 2 3 4)))) + (dotimes (i 5) + (print (kfll total i 4 (remove (nth i hat) hat))) + (check-kan total i 4 (remove (nth i hat) hat))))) |# diff --git a/test/homology-groups-test.lisp b/test/homology-groups-test.lisp index 393ce0a..6191aad 100644 --- a/test/homology-groups-test.lisp +++ b/test/homology-groups-test.lisp @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :kenzo-test) @@ -5,24 +6,24 @@ (test chcm-mat (progn - (let ((d (cat:delta 3))) - (princ (cat:chcm-mat d 2)) - (princ (cat:chcm-mat d 3)) - (princ (cat:chcm-mat d 4))))) + (let ((d (cat:delta 3))) + (princ (cat:chcm-mat d 2)) + (princ (cat:chcm-mat d 3)) + (princ (cat:chcm-mat d 4))))) (test chcm-homology (progn - (let ((d (cat:sphere 3))) - (princ (cat:chcm-homology d 2)) - (princ (cat:chcm-homology d 3)) - (princ (cat:chcm-homology d 4))))) + (let ((d (cat:sphere 3))) + (princ (cat:chcm-homology d 2)) + (princ (cat:chcm-homology d 3)) + (princ (cat:chcm-homology d 4))))) (test chcm-homology-gen (progn - (let ((d (cat:sphere 3))) - (princ (cat:chcm-homology-gen d 2)) - (princ (cat:chcm-homology-gen d 3)) - (princ (cat:chcm-homology-gen d 4))))) + (let ((d (cat:sphere 3))) + (princ (cat:chcm-homology-gen d 2)) + (princ (cat:chcm-homology-gen d 3)) + (princ (cat:chcm-homology-gen d 4))))) #| diff --git a/test/k-pi-n-test.lisp b/test/k-pi-n-test.lisp index 9d1fc50..ec96374 100644 --- a/test/k-pi-n-test.lisp +++ b/test/k-pi-n-test.lisp @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :kenzo-test) @@ -22,7 +23,7 @@ (cat:z-absm-bar (cat:absm 1 '())) (cat:z-absm-bar (cat:absm 0 '(2))) (dotimes (i 8) - (print (cat:z-absm-bar (cat:absm i '(3 6)))))) + (print (cat:z-absm-bar (cat:absm i '(3 6)))))) (test z-bar-absm @@ -30,7 +31,7 @@ (cat:z-bar-absm (cat:z-absm-bar (cat:absm 1 '()))) (cat:z-bar-absm (cat:z-absm-bar (cat:absm 0 '(2)))) (dotimes (i 8) - (print (cat:z-bar-absm (cat:z-absm-bar (cat:absm i '(3 6))))))) + (print (cat:z-bar-absm (cat:z-absm-bar (cat:absm i '(3 6))))))) (test k-z-1-grml @@ -46,35 +47,35 @@ (test k-z-1-grin (cat:k-z-1-grin 3 '(2 3 -4)) (let ((gmsm '(2 3 -4))) - (cat:k-z-1-grml 3 (cat:crpr 0 gmsm 0 - (cat:gmsm (cat:k-z-1-grin 3 gmsm)))))) + (cat:k-z-1-grml 3 (cat:crpr 0 gmsm 0 + (cat:gmsm (cat:k-z-1-grin 3 gmsm)))))) (defun aleat-list (max length) (let ((rslt nil) - (2max (+ max max))) + (2max (+ max max))) (dotimes (i length) (push (let ((k (- (random 2max) max))) - (if (zerop k) - max - k)) - rslt)) + (if (zerop k) + max + k)) + rslt)) rslt)) (test k-z-1 (let ((k (cat:k-z-1)) - zero?) - (cat:? k (cat:? k 14 (aleat-list 200 14))) - (setf zero? (cat:add (cat:idnt-mrph k) (cat:grin k))) - (cat:? zero? 14 (aleat-list 200 14)))) + zero?) + (cat:? k (cat:? k 14 (aleat-list 200 14))) + (setf zero? (cat:add (cat:idnt-mrph k) (cat:grin k))) + (cat:? zero? 14 (aleat-list 200 14)))) (test circle (let ((c (cat:circle))) - (cat:cmpr c '* '*) - (cat:basis c 1) - (cat:? c 1 's1))) + (cat:cmpr c '* '*) + (cat:basis c 1) + (cat:? c 1 's1))) (test kz1-rdct-f-intr @@ -111,7 +112,7 @@ (setf cat:*tc* (cat:cmbn 2 1 '(-4 2) 10 '(-1 3) 100 '(1 -4) 1000 '(5 5))) (check-rdct) (setf cat:*tc* (cat:cmbn 3 1 '(-4 -4 5) 10 '(-1 2 1) - 100 '(1 4 2) 1000 '(5 1 -1))) + 100 '(1 4 2) 1000 '(5 1 -1))) (check-rdct)) @@ -122,18 +123,18 @@ (test k-z2-1-homology (let ((k (cat:k-z2-1))) - (cat:homology k 0 4))) + (cat:homology k 0 4))) (test k-z2-homology (let ((k3 (cat:k-z2 3))) - (cat:homology k3 7))) + (cat:homology k3 7))) (test z2-bar-absm (dotimes (i 8) ;;; not really legal - (dotimes (j 8) - (print (cat:z2-bar-absm (cat:z2-absm-bar (cat:absm i j))))))) + (dotimes (j 8) + (print (cat:z2-bar-absm (cat:z2-absm-bar (cat:absm i j))))))) (test z-fundamental-gmsm @@ -145,129 +146,129 @@ (test interesting-faces (let* ((d (cat:delta 14)) - (f (cat:face d))) - (do ((i 5 (1- i))) - ((minusp i)) - (print (cat:interesting-faces f i 5 (cat:mask 6)))))) + (f (cat:face d))) + (do ((i 5 (1- i))) + ((minusp i)) + (print (cat:interesting-faces f i 5 (cat:mask 6)))))) (test gmsm-cocycle (cat:cat-init) (let* ((d (cat:delta 10)) - (chml-clss (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -2 - :intr #'(lambda (dmns gmsm) - (cat:term-cmbn 0 gmsm - :gnrt-z)) - :strt :gnrt - :orgn '(essai-1)))) - (cat:gmsm-cocycle (cat:face d) 2 4 31 chml-clss) - (setf chml-clss (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -1 - :intr #'(lambda (dmns gmsm) - (cat:term-cmbn 0 gmsm - :gnrt-z)) - :strt :gnrt - :orgn '(essai-2))) - (cat:gmsm-cocycle (cat:face d) 1 4 31 chml-clss))) + (chml-clss (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -2 + :intr #'(lambda (dmns gmsm) + (cat:term-cmbn 0 gmsm + :gnrt-z)) + :strt :gnrt + :orgn '(essai-1)))) + (cat:gmsm-cocycle (cat:face d) 2 4 31 chml-clss) + (setf chml-clss (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -1 + :intr #'(lambda (dmns gmsm) + (cat:term-cmbn 0 gmsm + :gnrt-z)) + :strt :gnrt + :orgn '(essai-2))) + (cat:gmsm-cocycle (cat:face d) 1 4 31 chml-clss))) (test z-cocycle-gbar (cat:cat-init) (let* ((d (cat:delta 10)) - (chml-clss (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -1 - :intr #'(lambda (dmns gmsm) - (cat:term-cmbn 0 gmsm - :gnrt-z)) - :strt :gnrt - :orgn '(essai-1)))) - (cat:gmsm-cocycle (cat:face d) 1 4 31 chml-clss) - (cat:z-cocycle-gbar 1 4 (cat:gmsm-cocycle (cat:face d) - 1 4 31 chml-clss)) - (setf chml-clss - (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -2 - :intr #'(lambda (dmns gmsm) - (cat:term-cmbn 0 gmsm :gnrt-z)) - :strt :gnrt - :orgn '(essai-2))) - (cat:gmsm-cocycle (cat:face d) 2 2 7 chml-clss) - (cat:z-cocycle-gbar 2 2 (cat:gmsm-cocycle (cat:face d) - 2 2 7 chml-clss)) - (cat:gmsm-cocycle (cat:face d) 2 2 0 chml-clss) ;; normally illegal - (cat:z-cocycle-gbar 2 2 (cat:gmsm-cocycle (cat:face d) - 2 2 0 chml-clss)) - (cat:gmsm-cocycle (cat:face d) 2 3 15 chml-clss) - (cat:z-cocycle-gbar 2 3 (cat:gmsm-cocycle (cat:face d) - 2 3 15 chml-clss)) - (cat:gmsm-cocycle (cat:face d) 2 4 31 chml-clss) - (cat:z-cocycle-gbar 2 4 (cat:gmsm-cocycle (cat:face d) - 2 4 31 chml-clss)) - (setf chml-clss - (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -3 - :intr #'(lambda (dmns gmsm) - (cat:term-cmbn 0 gmsm :gnrt-z)) - :strt :gnrt - :orgn '(essai-3))) - (cat:gmsm-cocycle (cat:face d) 3 4 31 chml-clss) - (cat:z-cocycle-gbar 3 4 (cat:gmsm-cocycle (cat:face d) - 3 4 31 chml-clss)) - (setf chml-clss - (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -3 - :intr #'(lambda (dmns gmsm) - (cat:zero-cmbn 0)) - :strt :gnrt - :orgn '(essai-33))) - (cat:gmsm-cocycle (cat:face d) 3 4 31 chml-clss) - (cat:z-cocycle-gbar 3 4 (cat:gmsm-cocycle (cat:face d) - 3 4 31 chml-clss)))) + (chml-clss (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -1 + :intr #'(lambda (dmns gmsm) + (cat:term-cmbn 0 gmsm + :gnrt-z)) + :strt :gnrt + :orgn '(essai-1)))) + (cat:gmsm-cocycle (cat:face d) 1 4 31 chml-clss) + (cat:z-cocycle-gbar 1 4 (cat:gmsm-cocycle (cat:face d) + 1 4 31 chml-clss)) + (setf chml-clss + (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -2 + :intr #'(lambda (dmns gmsm) + (cat:term-cmbn 0 gmsm :gnrt-z)) + :strt :gnrt + :orgn '(essai-2))) + (cat:gmsm-cocycle (cat:face d) 2 2 7 chml-clss) + (cat:z-cocycle-gbar 2 2 (cat:gmsm-cocycle (cat:face d) + 2 2 7 chml-clss)) + (cat:gmsm-cocycle (cat:face d) 2 2 0 chml-clss) ;; normally illegal + (cat:z-cocycle-gbar 2 2 (cat:gmsm-cocycle (cat:face d) + 2 2 0 chml-clss)) + (cat:gmsm-cocycle (cat:face d) 2 3 15 chml-clss) + (cat:z-cocycle-gbar 2 3 (cat:gmsm-cocycle (cat:face d) + 2 3 15 chml-clss)) + (cat:gmsm-cocycle (cat:face d) 2 4 31 chml-clss) + (cat:z-cocycle-gbar 2 4 (cat:gmsm-cocycle (cat:face d) + 2 4 31 chml-clss)) + (setf chml-clss + (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -3 + :intr #'(lambda (dmns gmsm) + (cat:term-cmbn 0 gmsm :gnrt-z)) + :strt :gnrt + :orgn '(essai-3))) + (cat:gmsm-cocycle (cat:face d) 3 4 31 chml-clss) + (cat:z-cocycle-gbar 3 4 (cat:gmsm-cocycle (cat:face d) + 3 4 31 chml-clss)) + (setf chml-clss + (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -3 + :intr #'(lambda (dmns gmsm) + (cat:zero-cmbn 0)) + :strt :gnrt + :orgn '(essai-33))) + (cat:gmsm-cocycle (cat:face d) 3 4 31 chml-clss) + (cat:z-cocycle-gbar 3 4 (cat:gmsm-cocycle (cat:face d) + 3 4 31 chml-clss)))) (test z-cocycle-gbar-head (cat:cat-init) (let* ((d (cat:delta 10)) - (chml-clss - (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -1 - :intr #'(lambda (dmns gmsm) - (cat:term-cmbn 0 gmsm :gnrt-z)) - :strt :gnrt - :orgn '(essai-1))) - (x (cat:gmsm-cocycle (cat:face d) 1 4 31 chml-clss))) - (cat:z-cocycle-gbar 1 4 x) - (signals simple-error (cat:z-cocycle-gbar-head 1 4 x)) - (setf chml-clss - (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -2 - :intr #'(lambda (dmns gmsm) - (cat:term-cmbn 0 gmsm :gnrt-z)) - :strt :gnrt - :orgn '(essai-2))) - (setf x (cat:gmsm-cocycle (cat:face d) 2 2 7 chml-clss)) - (cat:z-cocycle-gbar 2 2 x) - (cat:z-cocycle-gbar-head 2 2 x) - ;; normally illegal - (setf x (cat:gmsm-cocycle (cat:face d) 2 2 0 chml-clss)) - (cat:z-cocycle-gbar 2 2 x) - (cat:z-cocycle-gbar-head 2 2 x) - (setf x (cat:gmsm-cocycle (cat:face d) 2 3 15 chml-clss)) - (cat:z-cocycle-gbar 2 3 x) - (cat:z-cocycle-gbar-head 2 3 x) - (setf x (cat:gmsm-cocycle (cat:face d) 2 4 31 chml-clss)) - (cat:z-cocycle-gbar 2 4 x) - (cat:z-cocycle-gbar-head 2 4 x) - (setf chml-clss - (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -3 - :intr #'(lambda (dmns gmsm) - (cat:term-cmbn 0 gmsm :gnrt-z)) - :strt :gnrt - :orgn '(essai-3))) - (setf x (cat:gmsm-cocycle (cat:face d) 3 4 31 chml-clss)) - (cat:z-cocycle-gbar 3 4 x) - (cat:z-cocycle-gbar-head 3 4 x) - (setf chml-clss - (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -3 - :intr #'(lambda (dmns gmsm) - (cat:zero-cmbn 0)) - :strt :gnrt - :orgn '(essai-33))) - (setf x (cat:gmsm-cocycle (cat:face d) 3 4 31 chml-clss)) - (cat:z-cocycle-gbar 3 4 x) - (cat:z-cocycle-gbar-head 3 4 x))) + (chml-clss + (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -1 + :intr #'(lambda (dmns gmsm) + (cat:term-cmbn 0 gmsm :gnrt-z)) + :strt :gnrt + :orgn '(essai-1))) + (x (cat:gmsm-cocycle (cat:face d) 1 4 31 chml-clss))) + (cat:z-cocycle-gbar 1 4 x) + (signals simple-error (cat:z-cocycle-gbar-head 1 4 x)) + (setf chml-clss + (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -2 + :intr #'(lambda (dmns gmsm) + (cat:term-cmbn 0 gmsm :gnrt-z)) + :strt :gnrt + :orgn '(essai-2))) + (setf x (cat:gmsm-cocycle (cat:face d) 2 2 7 chml-clss)) + (cat:z-cocycle-gbar 2 2 x) + (cat:z-cocycle-gbar-head 2 2 x) + ;; normally illegal + (setf x (cat:gmsm-cocycle (cat:face d) 2 2 0 chml-clss)) + (cat:z-cocycle-gbar 2 2 x) + (cat:z-cocycle-gbar-head 2 2 x) + (setf x (cat:gmsm-cocycle (cat:face d) 2 3 15 chml-clss)) + (cat:z-cocycle-gbar 2 3 x) + (cat:z-cocycle-gbar-head 2 3 x) + (setf x (cat:gmsm-cocycle (cat:face d) 2 4 31 chml-clss)) + (cat:z-cocycle-gbar 2 4 x) + (cat:z-cocycle-gbar-head 2 4 x) + (setf chml-clss + (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -3 + :intr #'(lambda (dmns gmsm) + (cat:term-cmbn 0 gmsm :gnrt-z)) + :strt :gnrt + :orgn '(essai-3))) + (setf x (cat:gmsm-cocycle (cat:face d) 3 4 31 chml-clss)) + (cat:z-cocycle-gbar 3 4 x) + (cat:z-cocycle-gbar-head 3 4 x) + (setf chml-clss + (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -3 + :intr #'(lambda (dmns gmsm) + (cat:zero-cmbn 0)) + :strt :gnrt + :orgn '(essai-33))) + (setf x (cat:gmsm-cocycle (cat:face d) 3 4 31 chml-clss)) + (cat:z-cocycle-gbar 3 4 x) + (cat:z-cocycle-gbar-head 3 4 x))) (test Z2-fundamental-gmsm @@ -280,94 +281,94 @@ (test z2-cocycle-gbar (cat:cat-init) (let* ((d (cat:delta 10)) - (chml-clss - (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -1 - :intr #'(lambda (dmns gmsm) - (cat:term-cmbn 0 (mod gmsm 2) :gnrt-z)) - :strt :gnrt - :orgn '(essai-1))) - (x (cat:gmsm-cocycle (cat:face d) 1 4 31 chml-clss))) - (cat:z2-cocycle-gbar 1 4 x) - (setf chml-clss - (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -2 - :intr #'(lambda (dmns gmsm) - (cat:term-cmbn 0 (mod gmsm 2) :gnrt-z)) - :strt :gnrt - :orgn '(essai-2))) - (setf x (cat:gmsm-cocycle (cat:face d) 2 2 7 chml-clss)) - (cat:z2-cocycle-gbar 2 2 x) - ;; normally illegal - (setf x (cat:gmsm-cocycle (cat:face d) 2 2 0 chml-clss)) - (cat:z2-cocycle-gbar 2 2 x) - (setf x (cat:gmsm-cocycle (cat:face d) 2 3 15 chml-clss)) - (cat:z2-cocycle-gbar 2 3 x) - (setf x (cat:gmsm-cocycle (cat:face d) 2 4 31 chml-clss)) - (cat:z2-cocycle-gbar 2 4 x) - (setf chml-clss - (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -3 - :intr #'(lambda (dmns gmsm) - (cat:term-cmbn 0 (mod gmsm 2) :gnrt-z)) - :strt :gnrt - :orgn '(essai-3))) - (setf x (cat:gmsm-cocycle (cat:face d) 3 4 31 chml-clss)) - (cat:z2-cocycle-gbar 3 4 x))) + (chml-clss + (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -1 + :intr #'(lambda (dmns gmsm) + (cat:term-cmbn 0 (mod gmsm 2) :gnrt-z)) + :strt :gnrt + :orgn '(essai-1))) + (x (cat:gmsm-cocycle (cat:face d) 1 4 31 chml-clss))) + (cat:z2-cocycle-gbar 1 4 x) + (setf chml-clss + (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -2 + :intr #'(lambda (dmns gmsm) + (cat:term-cmbn 0 (mod gmsm 2) :gnrt-z)) + :strt :gnrt + :orgn '(essai-2))) + (setf x (cat:gmsm-cocycle (cat:face d) 2 2 7 chml-clss)) + (cat:z2-cocycle-gbar 2 2 x) + ;; normally illegal + (setf x (cat:gmsm-cocycle (cat:face d) 2 2 0 chml-clss)) + (cat:z2-cocycle-gbar 2 2 x) + (setf x (cat:gmsm-cocycle (cat:face d) 2 3 15 chml-clss)) + (cat:z2-cocycle-gbar 2 3 x) + (setf x (cat:gmsm-cocycle (cat:face d) 2 4 31 chml-clss)) + (cat:z2-cocycle-gbar 2 4 x) + (setf chml-clss + (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -3 + :intr #'(lambda (dmns gmsm) + (cat:term-cmbn 0 (mod gmsm 2) :gnrt-z)) + :strt :gnrt + :orgn '(essai-3))) + (setf x (cat:gmsm-cocycle (cat:face d) 3 4 31 chml-clss)) + (cat:z2-cocycle-gbar 3 4 x))) (test z2-cocycle-gbar-head (cat:cat-init) (let* ((d (cat:delta 10)) - (chml-clss - (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -1 - :intr #'(lambda (dmns gmsm) - (cat:term-cmbn 0 (mod gmsm 2) :gnrt-z)) - :strt :gnrt - :orgn '(essai-1))) - (x (cat:gmsm-cocycle (cat:face d) 1 4 31 chml-clss))) - (cat:z2-cocycle-gbar 1 4 x) - (signals simple-error (cat:z2-cocycle-gbar-head 1 4 x)) - (setf chml-clss - (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -2 - :intr #'(lambda (dmns gmsm) - (cat:term-cmbn 0 (mod gmsm 2) :gnrt-z)) - :strt :gnrt - :orgn '(essai-2))) - (setf x (cat:gmsm-cocycle (cat:face d) 2 2 7 chml-clss)) - (cat:z2-cocycle-gbar 2 2 x) - (cat:z2-cocycle-gbar-head 2 2 x) - ;; normally illegal - (setf x (cat:gmsm-cocycle (cat:face d) 2 2 0 chml-clss)) - (cat:z2-cocycle-gbar 2 2 x) - (cat:z2-cocycle-gbar-head 2 2 x) - (setf x (cat:gmsm-cocycle (cat:face d) 2 3 15 chml-clss)) - (cat:z2-cocycle-gbar 2 3 x) - (cat:z2-cocycle-gbar-head 2 3 x) - (setf x (cat:gmsm-cocycle (cat:face d) 2 4 31 chml-clss)) - (cat:z2-cocycle-gbar 2 4 x) - (cat:z2-cocycle-gbar-head 2 4 x) - (setf chml-clss - (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -3 - :intr #'(lambda (dmns gmsm) - (cat:term-cmbn 0 (mod gmsm 2) :gnrt-z)) - :strt :gnrt - :orgn '(essai-3))) - (setf x (cat:gmsm-cocycle (cat:face d) 3 4 31 chml-clss)) - (cat:z2-cocycle-gbar 3 4 x) - (cat:z2-cocycle-gbar-head 3 4 x))) + (chml-clss + (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -1 + :intr #'(lambda (dmns gmsm) + (cat:term-cmbn 0 (mod gmsm 2) :gnrt-z)) + :strt :gnrt + :orgn '(essai-1))) + (x (cat:gmsm-cocycle (cat:face d) 1 4 31 chml-clss))) + (cat:z2-cocycle-gbar 1 4 x) + (signals simple-error (cat:z2-cocycle-gbar-head 1 4 x)) + (setf chml-clss + (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -2 + :intr #'(lambda (dmns gmsm) + (cat:term-cmbn 0 (mod gmsm 2) :gnrt-z)) + :strt :gnrt + :orgn '(essai-2))) + (setf x (cat:gmsm-cocycle (cat:face d) 2 2 7 chml-clss)) + (cat:z2-cocycle-gbar 2 2 x) + (cat:z2-cocycle-gbar-head 2 2 x) + ;; normally illegal + (setf x (cat:gmsm-cocycle (cat:face d) 2 2 0 chml-clss)) + (cat:z2-cocycle-gbar 2 2 x) + (cat:z2-cocycle-gbar-head 2 2 x) + (setf x (cat:gmsm-cocycle (cat:face d) 2 3 15 chml-clss)) + (cat:z2-cocycle-gbar 2 3 x) + (cat:z2-cocycle-gbar-head 2 3 x) + (setf x (cat:gmsm-cocycle (cat:face d) 2 4 31 chml-clss)) + (cat:z2-cocycle-gbar 2 4 x) + (cat:z2-cocycle-gbar-head 2 4 x) + (setf chml-clss + (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -3 + :intr #'(lambda (dmns gmsm) + (cat:term-cmbn 0 (mod gmsm 2) :gnrt-z)) + :strt :gnrt + :orgn '(essai-3))) + (setf x (cat:gmsm-cocycle (cat:face d) 3 4 31 chml-clss)) + (cat:z2-cocycle-gbar 3 4 x) + (cat:z2-cocycle-gbar-head 3 4 x))) (test k-z-fundamental-class (cat:cat-init) (let ((c1 (cat:k-z-fundamental-class 1)) - (c3 (cat:k-z-fundamental-class 3))) - (cat:? c1 1 '(34)) - (cat:? c1 2 '(34 45)) - (cat:? c3 3 (cat:z-fundamental-gmsm 3 45)))) + (c3 (cat:k-z-fundamental-class 3))) + (cat:? c1 1 '(34)) + (cat:? c1 2 '(34 45)) + (cat:? c3 3 (cat:z-fundamental-gmsm 3 45)))) (test k-z2-fundamental-class (cat:cat-init) (let ((c1 (cat:k-z2-fundamental-class 1)) - (c3 (cat:k-z2-fundamental-class 3))) - (cat:? c1 1 1) - (cat:? c1 2 2) - (cat:? c3 3 (cat:z2-fundamental-gmsm 3 1)))) + (c3 (cat:k-z2-fundamental-class 3))) + (cat:? c1 1 1) + (cat:? c1 2 2) + (cat:? c3 3 (cat:z2-fundamental-gmsm 3 1)))) diff --git a/test/loop-spaces-test.lisp b/test/loop-spaces-test.lisp index e4cc739..965a0aa 100644 --- a/test/loop-spaces-test.lisp +++ b/test/loop-spaces-test.lisp @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :kenzo-test) @@ -43,57 +44,57 @@ (test loop-space-cmpr (let ((cmpr (cat:loop-space-cmpr #'cat:s-cmpr))) - (is (equal :greater (funcall cmpr (cat:loop3 '(1 a 2)) - (cat:loop3 '(1 a -1))))) - (is (equal :greater (funcall cmpr (cat:loop3 '(3 b 4 1 a 2)) - (cat:loop3 '(3 b 4 1 a -1))))))) + (is (equal :greater (funcall cmpr (cat:loop3 '(1 a 2)) + (cat:loop3 '(1 a -1))))) + (is (equal :greater (funcall cmpr (cat:loop3 '(3 b 4 1 a 2)) + (cat:loop3 '(3 b 4 1 a -1))))))) (test apowr-face4 (cat:cat-init) (let ((face (cat:face (cat:delta-infinity)))) - (cat:apowr-face4 face 3 4 (cat:apowr 1 31 5)) - (setf face (cat:face (cat:sphere 5))) - (cat:apowr-face4 face 2 5 (cat:apowr 1 's5 4)) - (cat:apowr-face4 face 2 5 (cat:apowr 2 's5 4)))) + (cat:apowr-face4 face 3 4 (cat:apowr 1 31 5)) + (setf face (cat:face (cat:sphere 5))) + (cat:apowr-face4 face 2 5 (cat:apowr 1 's5 4)) + (cat:apowr-face4 face 2 5 (cat:apowr 2 's5 4)))) (test apowr-lastface4 (cat:cat-init) (let ((cmpr #'cat:f-cmpr) - (face (cat:face (cat:delta-infinity)))) - (cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 63 1)) - (cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 63 -1)) - (cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 63 3)) - (cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 63 -3)) - (cat:apowr-lastface4 cmpr face 4 (cat:apowr 8 31 1)) - (setf face #'(lambda (indx dmns gmsm) ; dmns = 5 - (case indx - (5 (cat:absm 8 'a)) - (4 (cat:absm 8 'a))))) - (setf cmpr #'cat:s-cmpr) - (cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 'a 2)) - (setf face #'(lambda (indx dmns gmsm) ; dmns = 5 - (case indx - (5 (cat:absm 1 'a)) - (4 (cat:absm 8 'a))))) - (cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 'a 2)) - (setf face #'(lambda (indx dmns gmsm) ; dmns = 5 - (case indx - (5 (cat:absm 1 'a)) - (4 (cat:absm 1 'a))))) - (cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 'a 2)))) + (face (cat:face (cat:delta-infinity)))) + (cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 63 1)) + (cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 63 -1)) + (cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 63 3)) + (cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 63 -3)) + (cat:apowr-lastface4 cmpr face 4 (cat:apowr 8 31 1)) + (setf face #'(lambda (indx dmns gmsm) ; dmns = 5 + (case indx + (5 (cat:absm 8 'a)) + (4 (cat:absm 8 'a))))) + (setf cmpr #'cat:s-cmpr) + (cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 'a 2)) + (setf face #'(lambda (indx dmns gmsm) ; dmns = 5 + (case indx + (5 (cat:absm 1 'a)) + (4 (cat:absm 8 'a))))) + (cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 'a 2)) + (setf face #'(lambda (indx dmns gmsm) ; dmns = 5 + (case indx + (5 (cat:absm 1 'a)) + (4 (cat:absm 1 'a))))) + (cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 'a 2)))) (test loop-space-face (cat:cat-init) (let* ((cmpr #'cat:f-cmpr) - (face (cat:face (cat:delta-infinity))) - (rslt (cat:loop-space-face cmpr face))) - (funcall rslt 2 4 (cat:loop3 '(0 63 3 1 31 -3))) - (funcall rslt 2 4 (cat:loop3 '(0 63 3 0 63 -3))) - (funcall rslt 4 4 (cat:loop3 '(0 63 3 0 63 -3))) - (funcall rslt 4 4 (cat:loop3 '(0 63 3))))) + (face (cat:face (cat:delta-infinity))) + (rslt (cat:loop-space-face cmpr face))) + (funcall rslt 2 4 (cat:loop3 '(0 63 3 1 31 -3))) + (funcall rslt 2 4 (cat:loop3 '(0 63 3 0 63 -3))) + (funcall rslt 4 4 (cat:loop3 '(0 63 3 0 63 -3))) + (funcall rslt 4 4 (cat:loop3 '(0 63 3))))) (test loop-space-grin-sintr @@ -102,94 +103,94 @@ (test loop-space-grml-sintr (let* ((cmpr #'cat:s-cmpr) - (ml (cat:loop-space-grml-sintr cmpr))) - (funcall ml 2 (cat:crpr 3 (cat:loop3) 0 (cat:loop3 0 'a 2))) - (funcall ml 2 (cat:crpr 0 (cat:loop3 0 'a 2) 3 (cat:loop3))) - (funcall ml 2 (cat:crpr 0 (cat:loop3 0 'a 2) 0 (cat:loop3 0 'a -2))) - (funcall ml 2 (cat:crpr 0 (cat:loop3 0 'a 2) 0 (cat:loop3 0 'a -3))) - (funcall ml 2 (cat:crpr 0 (cat:loop3 0 'a 2) 0 (cat:loop3 0 'b -3))) - (funcall ml 2 (cat:crpr 0 (cat:loop3 0 'a 2 0 'b -3) - 0 (cat:loop3 0 'b +3 0 'a -2))))) + (ml (cat:loop-space-grml-sintr cmpr))) + (funcall ml 2 (cat:crpr 3 (cat:loop3) 0 (cat:loop3 0 'a 2))) + (funcall ml 2 (cat:crpr 0 (cat:loop3 0 'a 2) 3 (cat:loop3))) + (funcall ml 2 (cat:crpr 0 (cat:loop3 0 'a 2) 0 (cat:loop3 0 'a -2))) + (funcall ml 2 (cat:crpr 0 (cat:loop3 0 'a 2) 0 (cat:loop3 0 'a -3))) + (funcall ml 2 (cat:crpr 0 (cat:loop3 0 'a 2) 0 (cat:loop3 0 'b -3))) + (funcall ml 2 (cat:crpr 0 (cat:loop3 0 'a 2 0 'b -3) + 0 (cat:loop3 0 'b +3 0 'a -2))))) (test loop-space (cat:cat-init) (let ((g (cat:gdeltab)) - basis cmbn cmbn2 dd echcm efhm hat loop-list rslt x) - (is (equal :equal (cat:cmpr g (cat:loop3 0 3 2) (cat:loop3 0 3 2)))) - (is (equal :less (cat:cmpr g (cat:loop3 0 3 2) (cat:loop3 0 3 3)))) - (is (equal :less (cat:cmpr g (cat:loop3 0 3 2) (cat:loop3 0 5 2)))) - (is (equal :greater (cat:cmpr g (cat:loop3 0 5 2) (cat:loop3 0 3 2)))) - (cat:face g 3 3 (cat:loop3 12 7 3)) - (cat:face g 3 3 (cat:loop3 5 7 3)) - (cat:face g 3 3 (cat:loop3 6 7 3 5 7 3 3 7 3)) - (cat:face g 4 4 (cat:absm 4 (cat:loop3 6 7 3 5 7 3 3 7 3))) - (cat:check-faces (cat:cmpr g) (cat:face g) 3 - (cat:loop3 6 7 -3 5 7 -3 3 7 -3)) - (setf dd (cat:cmps g g)) - (cat:? dd 3 (cat:loop3 6 7 3 5 7 3 3 7 3)) - (cat:grml g 2 (cat:crpr 0 (cat:loop3 0 15 3) 0 (cat:loop3 0 15 4))) - (cat:grin g 2 (cat:loop3 0 15 -2)) - (setf rslt (cat:loop3 0 31 1)) - (setf hat (mapcar #'(lambda (i) (cat:face g i 3 rslt)) - (cat: 0 3))) - (dotimes (i 4) - (print (cat:kfll g i 3 (remove (nth i hat) hat :test #'equal))) - (cat:check-kan g i 3 (remove (nth i hat) hat :test #'equal))) + basis cmbn cmbn2 dd echcm efhm hat loop-list rslt x) + (is (equal :equal (cat:cmpr g (cat:loop3 0 3 2) (cat:loop3 0 3 2)))) + (is (equal :less (cat:cmpr g (cat:loop3 0 3 2) (cat:loop3 0 3 3)))) + (is (equal :less (cat:cmpr g (cat:loop3 0 3 2) (cat:loop3 0 5 2)))) + (is (equal :greater (cat:cmpr g (cat:loop3 0 5 2) (cat:loop3 0 3 2)))) + (cat:face g 3 3 (cat:loop3 12 7 3)) + (cat:face g 3 3 (cat:loop3 5 7 3)) + (cat:face g 3 3 (cat:loop3 6 7 3 5 7 3 3 7 3)) + (cat:face g 4 4 (cat:absm 4 (cat:loop3 6 7 3 5 7 3 3 7 3))) + (cat:check-faces (cat:cmpr g) (cat:face g) 3 + (cat:loop3 6 7 -3 5 7 -3 3 7 -3)) + (setf dd (cat:cmps g g)) + (cat:? dd 3 (cat:loop3 6 7 3 5 7 3 3 7 3)) + (cat:grml g 2 (cat:crpr 0 (cat:loop3 0 15 3) 0 (cat:loop3 0 15 4))) + (cat:grin g 2 (cat:loop3 0 15 -2)) + (setf rslt (cat:loop3 0 31 1)) + (setf hat (mapcar #'(lambda (i) (cat:face g i 3 rslt)) + (cat: 0 3))) + (dotimes (i 4) + (print (cat:kfll g i 3 (remove (nth i hat) hat :test #'equal))) + (cat:check-kan g i 3 (remove (nth i hat) hat :test #'equal))) - (setf g (cat:loop-space (cat:sphere 2))) - (setf rslt (cat:loop3 3 's2 2 5 's2 -2 6 's2 2)) - (setf hat (mapcar #'(lambda (i) (cat:face g i 3 rslt)) - (cat: 0 3))) - (dotimes (i 4) - (print (cat:kfll g i 3 (remove (nth i hat) hat :test #'equal))) - (cat:check-kan g i 3 (remove (nth i hat) hat :test #'equal))) + (setf g (cat:loop-space (cat:sphere 2))) + (setf rslt (cat:loop3 3 's2 2 5 's2 -2 6 's2 2)) + (setf hat (mapcar #'(lambda (i) (cat:face g i 3 rslt)) + (cat: 0 3))) + (dotimes (i 4) + (print (cat:kfll g i 3 (remove (nth i hat) hat :test #'equal))) + (cat:check-kan g i 3 (remove (nth i hat) hat :test #'equal))) - (setf g (cat:loop-space (cat:sphere 3) 2)) - (setf x (first (cat:basis (cat:echcm g) 4))) - (setf efhm (cat:efhm g)) - (setf x (cat:lf efhm (cat:rg efhm 4 x))) - (setf rslt (cat:gnrt (first (cat:cmbn-list x)))) - (setf hat (mapcar #'(lambda (i) (cat:face g i 4 rslt)) - (cat: 0 4))) - (dotimes (i 5) - (print (cat:kfll g i 4 (remove (nth i hat) hat :test #'equal))) - (cat:check-kan g i 4 (remove (nth i hat) hat :test #'equal))) + (setf g (cat:loop-space (cat:sphere 3) 2)) + (setf x (first (cat:basis (cat:echcm g) 4))) + (setf efhm (cat:efhm g)) + (setf x (cat:lf efhm (cat:rg efhm 4 x))) + (setf rslt (cat:gnrt (first (cat:cmbn-list x)))) + (setf hat (mapcar #'(lambda (i) (cat:face g i 4 rslt)) + (cat: 0 4))) + (dotimes (i 5) + (print (cat:kfll g i 4 (remove (nth i hat) hat :test #'equal))) + (cat:check-kan g i 4 (remove (nth i hat) hat :test #'equal))) - (setf rslt (cat:gnrt (third (cat:cmbn-list x)))) - (setf hat (mapcar #'(lambda (i) (cat:face g i 4 rslt)) - (cat: 0 4))) - (dotimes (i 5) - (print (cat:kfll g i 4 (remove (nth i hat) hat :test #'equal))) - (cat:check-kan g i 4 (remove (nth i hat) hat :test #'equal))) + (setf rslt (cat:gnrt (third (cat:cmbn-list x)))) + (setf hat (mapcar #'(lambda (i) (cat:face g i 4 rslt)) + (cat: 0 4))) + (dotimes (i 5) + (print (cat:kfll g i 4 (remove (nth i hat) hat :test #'equal))) + (cat:check-kan g i 4 (remove (nth i hat) hat :test #'equal))) - (setf g (cat:loop-space (cat:sphere 3) 2)) - (setf efhm (cat:efhm g)) - (setf echcm (cat:rbcc efhm)) - (setf basis (cat:basis echcm 4)) - (setf cmbn (cat:cmbn 4 1 (first basis) 10 (second basis) - 100 (third basis))) - (setf cmbn2 (cat:lf efhm (cat:rg efhm cmbn))) - (setf loop-list (mapcar #'cdr (cat:cmbn-list cmbn2))) - (dolist (loop loop-list) - (setf hat (mapcar #'(lambda (i) (cat:face g i 4 loop)) - (cat: 0 4))) - (dotimes (i 5) - (print (cat:kfll g i 4 (remove (nth i hat) hat))) - (cat:check-kan g i 4 (remove (nth i hat) hat)))))) + (setf g (cat:loop-space (cat:sphere 3) 2)) + (setf efhm (cat:efhm g)) + (setf echcm (cat:rbcc efhm)) + (setf basis (cat:basis echcm 4)) + (setf cmbn (cat:cmbn 4 1 (first basis) 10 (second basis) + 100 (third basis))) + (setf cmbn2 (cat:lf efhm (cat:rg efhm cmbn))) + (setf loop-list (mapcar #'cdr (cat:cmbn-list cmbn2))) + (dolist (loop loop-list) + (setf hat (mapcar #'(lambda (i) (cat:face g i 4 loop)) + (cat: 0 4))) + (dotimes (i 5) + (print (cat:kfll g i 4 (remove (nth i hat) hat))) + (cat:check-kan g i 4 (remove (nth i hat) hat)))))) (test loop-space2 (cat:cat-init) (let* ((p (cat:r-proj-space 3)) - (op (cat:loop-space p)) - cmpr c) - (dotimes (i 15) (print (random-apowr 8 3))) - (dotimes (i 20) - (print (cat:normalize-loop 7 (random-niloop 7 3 3)))) + (op (cat:loop-space p)) + cmpr c) + (dotimes (i 15) (print (random-apowr 8 3))) + (dotimes (i 20) + (print (cat:normalize-loop 7 (random-niloop 7 3 3)))) - (setf cmpr (cat:cmpr op)) - (setf cat:+too-much-time+ -1) - (setf c (random-loop-cmbn cmpr 8 10 4 4 100)) - (time (cat:? op (cat:? op c))) - (time (cat:? op (cat:? op c))))) + (setf cmpr (cat:cmpr op)) + (setf cat:+too-much-time+ -1) + (setf c (random-loop-cmbn cmpr 8 10 4 4 100)) + (time (cat:? op (cat:? op c))) + (time (cat:? op (cat:? op c))))) diff --git a/test/lp-space-efhm-test.lisp b/test/lp-space-efhm-test.lisp index c8c0990..517b96d 100644 --- a/test/lp-space-efhm-test.lisp +++ b/test/lp-space-efhm-test.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + (in-package :kenzo-test) (in-suite :kenzo) @@ -6,168 +8,168 @@ (test ls-hat-t-u (cat:cat-init) (let ((c (cat:ls-hat-t-u (cat:deltab))) - 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)))))))) + 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) - (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) - (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) + |# + ) ) @@ -178,86 +180,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))) diff --git a/test/ls-twisted-products-test.lisp b/test/ls-twisted-products-test.lisp index 3fddc5e..7347310 100644 --- a/test/ls-twisted-products-test.lisp +++ b/test/ls-twisted-products-test.lisp @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :kenzo-test) @@ -6,75 +7,75 @@ (test absm-loopabsm (let ((cmpr (cat:cmpr (cat:deltab)))) - (cat:absm-loopabsm cmpr 3 (cat:absm 4 7) (cat:absm 7 cat:+null-loop+)) - (cat:absm-loopabsm cmpr 3 (cat:absm 0 15) (cat:absm 7 cat:+null-loop+)) - (cat:absm-loopabsm cmpr 3 (cat:absm 2 7) - (cat:absm 2 (cat:loop3 0 7 4))) - (cat:absm-loopabsm cmpr 3 (cat:absm 2 7) - (cat:absm 2 (cat:loop3 0 7 4 1 12 -1))) - (cat:absm-loopabsm cmpr 3 (cat:absm 2 7) - (cat:absm 2 (cat:loop3 0 7 -1))) - (cat:absm-loopabsm cmpr 3 (cat:absm 2 7) - (cat:absm 2 (cat:loop3 0 7 -1 1 12 -1))) - (cat:absm-loopabsm cmpr 3 (cat:absm 2 7) - (cat:absm 2 (cat:loop3 0 7 4))) - (cat:absm-loopabsm cmpr 3 (cat:absm 2 7) - (cat:absm 0 (cat:loop3 2 7 4 1 14 -1))) - ;; in principle illegal but works - (cat:absm-loopabsm cmpr 3 (cat:absm 2 7) - (cat:absm 0 (cat:loop3 2 7 -1))) - (cat:absm-loopabsm cmpr 3 (cat:absm 2 7) - (cat:absm 0 (cat:loop3 2 7 -1 1 14 -1))) - (cat:absm-loopabsm cmpr 3 (cat:absm 2 7) - (cat:absm 0 (cat:loop3 0 15 -1 1 14 -1))) - (cat:absm-loopabsm cmpr 3 (cat:absm 0 15) - (cat:absm 2 (cat:loop3 0 7 -1 0 14 -1))) - (cat:absm-loopabsm cmpr 3 (cat:absm 2 7) - (cat:absm 2 (cat:loop3 0 28 -1 0 14 -1))))) + (cat:absm-loopabsm cmpr 3 (cat:absm 4 7) (cat:absm 7 cat:+null-loop+)) + (cat:absm-loopabsm cmpr 3 (cat:absm 0 15) (cat:absm 7 cat:+null-loop+)) + (cat:absm-loopabsm cmpr 3 (cat:absm 2 7) + (cat:absm 2 (cat:loop3 0 7 4))) + (cat:absm-loopabsm cmpr 3 (cat:absm 2 7) + (cat:absm 2 (cat:loop3 0 7 4 1 12 -1))) + (cat:absm-loopabsm cmpr 3 (cat:absm 2 7) + (cat:absm 2 (cat:loop3 0 7 -1))) + (cat:absm-loopabsm cmpr 3 (cat:absm 2 7) + (cat:absm 2 (cat:loop3 0 7 -1 1 12 -1))) + (cat:absm-loopabsm cmpr 3 (cat:absm 2 7) + (cat:absm 2 (cat:loop3 0 7 4))) + (cat:absm-loopabsm cmpr 3 (cat:absm 2 7) + (cat:absm 0 (cat:loop3 2 7 4 1 14 -1))) + ;; in principle illegal but works + (cat:absm-loopabsm cmpr 3 (cat:absm 2 7) + (cat:absm 0 (cat:loop3 2 7 -1))) + (cat:absm-loopabsm cmpr 3 (cat:absm 2 7) + (cat:absm 0 (cat:loop3 2 7 -1 1 14 -1))) + (cat:absm-loopabsm cmpr 3 (cat:absm 2 7) + (cat:absm 0 (cat:loop3 0 15 -1 1 14 -1))) + (cat:absm-loopabsm cmpr 3 (cat:absm 0 15) + (cat:absm 2 (cat:loop3 0 7 -1 0 14 -1))) + (cat:absm-loopabsm cmpr 3 (cat:absm 2 7) + (cat:absm 2 (cat:loop3 0 28 -1 0 14 -1))))) (test twisted-crts-prdc (cat:cat-init) (let* ((p (cat:r-proj-space 3)) - (tw (cat:twisted-crts-prdc p)) - (cmpr (cat:cmpr tw)) - (c (random-cmbn cmpr 8 10 4 4 100))) - (time (cat:? tw (cat:? tw c))) - (time (cat:? tw (cat:? tw c))))) + (tw (cat:twisted-crts-prdc p)) + (cmpr (cat:cmpr tw)) + (c (random-cmbn cmpr 8 10 4 4 100))) + (time (cat:? tw (cat:? tw c))) + (time (cat:? tw (cat:? tw c))))) (test dtau-d-intr (cat:cat-init) (let* ((d (cat:deltab)) - (p (cat:crts-prdc d (cat:loop-space d))) - (tw (cat:twisted-crts-prdc d)) - (crts-prdc-cmpr (cat:cmpr p)) - (crts-prdc-face (cat:face p)) - (twisted-crts-prdc-face (cat:face tw)) - (delta (cat:dtau-d-intr crts-prdc-cmpr crts-prdc-face - twisted-crts-prdc-face))) - (funcall delta 3 (cat:crpr 0 15 0 (cat:loop3 0 (- 2048 64) 1))) - (funcall delta 5 (cat:crpr 10 15 5 (cat:loop3 0 (- 2048 64) 1))) - (funcall delta 5 (cat:crpr 5 15 10 (cat:loop3 0 (- 2048 64) 1))))) + (p (cat:crts-prdc d (cat:loop-space d))) + (tw (cat:twisted-crts-prdc d)) + (crts-prdc-cmpr (cat:cmpr p)) + (crts-prdc-face (cat:face p)) + (twisted-crts-prdc-face (cat:face tw)) + (delta (cat:dtau-d-intr crts-prdc-cmpr crts-prdc-face + twisted-crts-prdc-face))) + (funcall delta 3 (cat:crpr 0 15 0 (cat:loop3 0 (- 2048 64) 1))) + (funcall delta 5 (cat:crpr 10 15 5 (cat:loop3 0 (- 2048 64) 1))) + (funcall delta 5 (cat:crpr 5 15 10 (cat:loop3 0 (- 2048 64) 1))))) (test szczarba (cat:cat-init) (let ((rdct (cat:szczarba (cat:deltab))) - bcc) - (cat:pre-check-rdct rdct) - (setf cat:*tc* (cat:cmbn 2 1 (cat:crpr 0 7 0 - (cat:loop3 0 (- 512 32) 1))) - cat:*bc* (cat:cmbn 2 1 (cat:tnpr 0 1 2 - (cat:loop3 0 (- 512 32) 1)) - 10 (cat:tnpr 1 (- 4096 1024) 1 - (cat:loop3 0 7 1)) - 100 (cat:tnpr 2 7 0 - (cat:loop3 0 (- 4096 1024) 1)))) - (check-rdct) - (setf bcc (cat:bcc rdct)) - (time (cat:? bcc 5 (cat:tnpr 5 (cat:mask 6) 0 cat:+null-loop+))) - (time (cat:? bcc 6 (cat:tnpr 6 (cat:mask 7) 0 cat:+null-loop+))))) + bcc) + (cat:pre-check-rdct rdct) + (setf cat:*tc* (cat:cmbn 2 1 (cat:crpr 0 7 0 + (cat:loop3 0 (- 512 32) 1))) + cat:*bc* (cat:cmbn 2 1 (cat:tnpr 0 1 2 + (cat:loop3 0 (- 512 32) 1)) + 10 (cat:tnpr 1 (- 4096 1024) 1 + (cat:loop3 0 7 1)) + 100 (cat:tnpr 2 7 0 + (cat:loop3 0 (- 4096 1024) 1)))) + (check-rdct) + (setf bcc (cat:bcc rdct)) + (time (cat:? bcc 5 (cat:tnpr 5 (cat:mask 6) 0 cat:+null-loop+))) + (time (cat:? bcc 6 (cat:tnpr 6 (cat:mask 7) 0 cat:+null-loop+))))) (test pop-first-absm @@ -94,88 +95,88 @@ (test crts-contraction-intr (cat:cat-init) (let* ((delta (cat:deltab)) - (tw (cat:twisted-crts-prdc delta)) - (d (cat:bndr tw)) - (base-cmpr (cat:cmpr delta)) - (base-bspn (cat:bspn delta)) - (base-face (cat:face delta)) - (crts-cmpr (cat:cmpr tw)) - (r (cat:crts-contraction-intr base-cmpr base-bspn base-face - crts-cmpr)) - (h (cat:build-mrph :sorc tw :trgt tw :degr +1 - :intr r :strt :gnrt - :orgn `(crts-contraction ,delta))) - (z (cat:i-sbtr (cat:idnt-mrph tw) (cat:cmps d h) (cat:cmps h d)))) - (cat:? z 0 (cat:crpr 0 1 0 cat:+null-loop+)) - (funcall r 0 (cat:crpr 0 1 0 (cat:loop3 0 96 1))) - (cat:? z 0 (cat:crpr 0 1 0 (cat:loop3 0 96 1))) - (cat:? z 0 (cat:crpr 0 1 0 (cat:loop3 0 96 1 0 (+ 256 128) 1))) - (cat:? z 0 (cat:crpr 0 1 0 (cat:loop3 0 96 1 0 (+ 256 128) - 1 0 (+ 512 1024) 1))) - (cat:? z 0 (cat:crpr 0 1 0 (cat:loop3 0 96 2))) - (cat:? z 1 (cat:crpr 0 3 0 (cat:loop3 0 (+ 32 64 128) 1))) - (cat:? z 2 (cat:crpr 0 7 0 (cat:loop3 0 (+ 32 64 128 256) 1))) - (cat:? z 3 (cat:crpr 2 7 1 (cat:loop3 2 (+ 32 64 128) - 2 4 (+ 32 64 128) -2))) - (cat:? z 3 (cat:crpr 2 7 4 (cat:loop3 2 (+ 32 64 128) - 2 1 (+ 32 64 128) -2))) - (cat:? z 3 (cat:crpr 2 7 1 (cat:loop3 2 (+ 32 64 128) - -2 4 (+ 32 64 128) 2))) - (cat:? z 3 (cat:crpr 2 7 4 (cat:loop3 2 (+ 32 64 128) - -2 1 (+ 32 64 128) 2))) - (cat:? z 3 (cat:crpr 1 7 2 (cat:loop3 2 (+ 32 64 128) - 2 4 (+ 32 64 128) -2))) - (cat:? z 3 (cat:crpr 4 7 2 (cat:loop3 2 (+ 32 64 128) - 2 1 (+ 32 64 128) -2))) - (cat:? z 3 (cat:crpr 1 7 2 (cat:loop3 2 (+ 32 64 128) - -2 4 (+ 32 64 128) 2))) - (cat:? z 3 (cat:crpr 4 7 2 (cat:loop3 2 (+ 32 64 128) - -2 1 (+ 32 64 128) 2))))) + (tw (cat:twisted-crts-prdc delta)) + (d (cat:bndr tw)) + (base-cmpr (cat:cmpr delta)) + (base-bspn (cat:bspn delta)) + (base-face (cat:face delta)) + (crts-cmpr (cat:cmpr tw)) + (r (cat:crts-contraction-intr base-cmpr base-bspn base-face + crts-cmpr)) + (h (cat:build-mrph :sorc tw :trgt tw :degr +1 + :intr r :strt :gnrt + :orgn `(crts-contraction ,delta))) + (z (cat:i-sbtr (cat:idnt-mrph tw) (cat:cmps d h) (cat:cmps h d)))) + (cat:? z 0 (cat:crpr 0 1 0 cat:+null-loop+)) + (funcall r 0 (cat:crpr 0 1 0 (cat:loop3 0 96 1))) + (cat:? z 0 (cat:crpr 0 1 0 (cat:loop3 0 96 1))) + (cat:? z 0 (cat:crpr 0 1 0 (cat:loop3 0 96 1 0 (+ 256 128) 1))) + (cat:? z 0 (cat:crpr 0 1 0 (cat:loop3 0 96 1 0 (+ 256 128) + 1 0 (+ 512 1024) 1))) + (cat:? z 0 (cat:crpr 0 1 0 (cat:loop3 0 96 2))) + (cat:? z 1 (cat:crpr 0 3 0 (cat:loop3 0 (+ 32 64 128) 1))) + (cat:? z 2 (cat:crpr 0 7 0 (cat:loop3 0 (+ 32 64 128 256) 1))) + (cat:? z 3 (cat:crpr 2 7 1 (cat:loop3 2 (+ 32 64 128) + 2 4 (+ 32 64 128) -2))) + (cat:? z 3 (cat:crpr 2 7 4 (cat:loop3 2 (+ 32 64 128) + 2 1 (+ 32 64 128) -2))) + (cat:? z 3 (cat:crpr 2 7 1 (cat:loop3 2 (+ 32 64 128) + -2 4 (+ 32 64 128) 2))) + (cat:? z 3 (cat:crpr 2 7 4 (cat:loop3 2 (+ 32 64 128) + -2 1 (+ 32 64 128) 2))) + (cat:? z 3 (cat:crpr 1 7 2 (cat:loop3 2 (+ 32 64 128) + 2 4 (+ 32 64 128) -2))) + (cat:? z 3 (cat:crpr 4 7 2 (cat:loop3 2 (+ 32 64 128) + 2 1 (+ 32 64 128) -2))) + (cat:? z 3 (cat:crpr 1 7 2 (cat:loop3 2 (+ 32 64 128) + -2 4 (+ 32 64 128) 2))) + (cat:? z 3 (cat:crpr 4 7 2 (cat:loop3 2 (+ 32 64 128) + -2 1 (+ 32 64 128) 2))))) (test crts-contraction (cat:cat-init) (let* ((p (cat:r-proj-space 3)) - (tw (cat:twisted-crts-prdc p)) - (cmpr (cat:cmpr tw)) - (r (cat:crts-contraction-intr (cat:cmpr p) (cat:bspn p) - (cat:face p) (cat:cmpr tw))) - (h (cat:build-mrph :sorc tw :trgt tw :degr +1 - :intr r :strt :gnrt - :orgn `(cat:crts-contraction ,p))) - (d (cat:bndr tw)) - (z (cat:i-sbtr (cat:idnt-mrph tw) (cat:cmps h d) (cat:cmps d h))) - (c (random-cmbn cmpr 5 10 2 2 1))) - (cat:? z c) - (setf c (random-cmbn cmpr 6 10 3 3 3)) - (cat:? z c) - (setf c (random-cmbn cmpr 7 10 4 4 6)) - (cat:? z c) - (setf c (random-cmbn cmpr 8 10 4 4 20)) - (cat:? z c) - (cat:? h c) - (cat:? d (cat:? h c)) - (print (length (cat:cmbn-list (cat:? d (cat:? h c))))))) + (tw (cat:twisted-crts-prdc p)) + (cmpr (cat:cmpr tw)) + (r (cat:crts-contraction-intr (cat:cmpr p) (cat:bspn p) + (cat:face p) (cat:cmpr tw))) + (h (cat:build-mrph :sorc tw :trgt tw :degr +1 + :intr r :strt :gnrt + :orgn `(cat:crts-contraction ,p))) + (d (cat:bndr tw)) + (z (cat:i-sbtr (cat:idnt-mrph tw) (cat:cmps h d) (cat:cmps d h))) + (c (random-cmbn cmpr 5 10 2 2 1))) + (cat:? z c) + (setf c (random-cmbn cmpr 6 10 3 3 3)) + (cat:? z c) + (setf c (random-cmbn cmpr 7 10 4 4 6)) + (cat:? z c) + (setf c (random-cmbn cmpr 8 10 4 4 20)) + (cat:? z c) + (cat:? h c) + (cat:? d (cat:? h c)) + (print (length (cat:cmbn-list (cat:? d (cat:? h c))))))) (test crts-contraction1 (let* ((h (cat:crts-contraction (cat:deltab))) - (d (cat:bndr (cat:twisted-crts-prdc (cat:deltab)))) - (z (cat:i-sbtr (cat:idnt-mrph (cat:sorc d)) (cat:cmps d h) - (cat:cmps h d)))) - (cat:? z 3 (cat:crpr 4 7 2 (cat:loop3 2 (+ 32 64 128) - -2 1 (+ 32 64 128) 2))))) + (d (cat:bndr (cat:twisted-crts-prdc (cat:deltab)))) + (z (cat:i-sbtr (cat:idnt-mrph (cat:sorc d)) (cat:cmps d h) + (cat:cmps h d)))) + (cat:? z 3 (cat:crpr 4 7 2 (cat:loop3 2 (+ 32 64 128) + -2 1 (+ 32 64 128) 2))))) (test tnpr-contraction (cat:cat-init) (let* ((delta (cat:deltab)) - (sz (cat:szczarba (cat:deltab))) - (tw (cat:bcc sz)) - (h (cat:tnpr-contraction delta)) - (z (cat:i-sbtr (cat:idnt-mrph tw) (cat:cmps tw h) - (cat:cmps h tw)))) - (time (cat:? z 3 (cat:tnpr 0 1 3 (cat:loop3 0 (cat:mask 5) - 2 0 (* 32 (cat:mask 5)) - -1)))) - (cat:? h 4 (cat:tnpr 0 1 0 (cat:loop3 0 (cat:mask 6) 1))))) + (sz (cat:szczarba (cat:deltab))) + (tw (cat:bcc sz)) + (h (cat:tnpr-contraction delta)) + (z (cat:i-sbtr (cat:idnt-mrph tw) (cat:cmps tw h) + (cat:cmps h tw)))) + (time (cat:? z 3 (cat:tnpr 0 1 3 (cat:loop3 0 (cat:mask 5) + 2 0 (* 32 (cat:mask 5)) + -1)))) + (cat:? h 4 (cat:tnpr 0 1 0 (cat:loop3 0 (cat:mask 6) 1))))) diff --git a/test/macros-test.lisp b/test/macros-test.lisp index 2015be0..1013f85 100644 --- a/test/macros-test.lisp +++ b/test/macros-test.lisp @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :kenzo-test) @@ -21,30 +22,30 @@ (test lexico (setf cl:*print-level* nil) (pprint (macroexpand-1 - '(cat:lexico - comparison1 - comparison2 - comparison3 - comparison4)))) + '(cat:lexico + comparison1 + comparison2 + comparison3 + comparison4)))) (test with-term (macroexpand-1 '(cat:with-term (cffc gnrt) term - (statement-1) - (statement-2))) + (statement-1) + (statement-2))) (macroexpand-1 '(cat:with-term (nil gnrt) term - (statement-1) - (statement-2)))) + (statement-1) + (statement-2)))) (test with--term (macroexpand-1 '(cat:with--term (cffc gnrt) mark - (statement-1) - (statement-2)))) + (statement-1) + (statement-2)))) (test with-cmbn (macroexpand-1 '(cat:with-cmbn (degr list) cmbn - (statement-1) - (statement-2)))) + (statement-1) + (statement-2)))) (test cmpr @@ -88,11 +89,11 @@ (test with-tnpr (macroexpand-1 '(cat:with-tnpr (degr1 gnrt1 degr2 gnrt2) tnpr - (statement-1) - (statement-2))) + (statement-1) + (statement-2))) (macroexpand-1 '(cat:with-tnpr (nil gnrt1 degr2 gnrt2) tnpr - (statement-1) - (statement-2)))) + (statement-1) + (statement-2)))) (test crpr @@ -101,23 +102,21 @@ (macroexpand '(cat:crpr absm1 absm2)) (macroexpand '(cat:crpr dgop1 gmsm1 dgop2 gmsm2)) (let ((c (cat:crpr 1 'a 2 'b))) - (cat:dgop1 c) - (cat:gmsm1 c) - (cat:dgop2 c) - (cat:gmsm2 c) - (cat:absm1 c) - (cat:absm2 c))) + (cat:dgop1 c) + (cat:gmsm1 c) + (cat:dgop2 c) + (cat:gmsm2 c) + (cat:absm1 c) + (cat:absm2 c))) (test with-crpr (cat:with-crpr (absm1 absm2) (cat:crpr 3 'a 4 'b) (list absm1 absm2)) (macroexpand-1 (macroexpand-1 '(cat:with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr - (statement-1) - (statement-2)))) + (statement-1) + (statement-2)))) (macroexpand-1 (macroexpand-1 '(cat:with-crpr (absm1 absm2) crpr - (statement-1) - (statement-2))))) - - + (statement-1) + (statement-2))))) diff --git a/test/package.lisp b/test/package.lisp index f812d34..7f421e4 100644 --- a/test/package.lisp +++ b/test/package.lisp @@ -1,3 +1,5 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + ;;;; package.lisp (defpackage :kenzo-test @@ -6,4 +8,3 @@ (in-package :kenzo-test) (def-suite :kenzo) - diff --git a/test/searching-homology-test.lisp b/test/searching-homology-test.lisp index efeb17e..4c5140e 100644 --- a/test/searching-homology-test.lisp +++ b/test/searching-homology-test.lisp @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :kenzo-test) @@ -5,6 +6,6 @@ (test homology (progn - (cat:cat-init) - (let ((d (cat:delta 3))) - (princ (cat:homology d 0))))) + (cat:cat-init) + (let ((d (cat:delta 3))) + (princ (cat:homology d 0))))) diff --git a/test/serre-test.lisp b/test/serre-test.lisp index 5369429..5227bcb 100644 --- a/test/serre-test.lisp +++ b/test/serre-test.lisp @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :kenzo-test) @@ -7,123 +8,123 @@ (test fibration-dtau-d-intr (cat:cat-init) (let* ((s2 (cat:sphere 2)) - (k (cat:k-z2-1)) - (tw (cat:build-smmr - :sorc s2 - :trgt k - :degr -1 - :sintr #'(lambda (dmns gmsm) - (cat:absm 0 1)) - :orgn '(s2-tw-kz2))) - (dt-d (cat:fibration-dtau-d-intr tw))) - (funcall dt-d 0 (cat:crpr 0 '* 0 0)) - (funcall dt-d 3 (cat:crpr 4 's2 0 3)) - (funcall dt-d 3 (cat:crpr 2 's2 0 3)) - (funcall dt-d 3 (cat:crpr 2 's2 5 1)) - (funcall dt-d 2 (cat:crpr 0 's2 0 2)))) + (k (cat:k-z2-1)) + (tw (cat:build-smmr + :sorc s2 + :trgt k + :degr -1 + :sintr #'(lambda (dmns gmsm) + (cat:absm 0 1)) + :orgn '(s2-tw-kz2))) + (dt-d (cat:fibration-dtau-d-intr tw))) + (funcall dt-d 0 (cat:crpr 0 '* 0 0)) + (funcall dt-d 3 (cat:crpr 4 's2 0 3)) + (funcall dt-d 3 (cat:crpr 2 's2 0 3)) + (funcall dt-d 3 (cat:crpr 2 's2 5 1)) + (funcall dt-d 2 (cat:crpr 0 's2 0 2)))) (test fibration-dtau-d-intr1 (cat:cat-init) (let* ((s2 (cat:sphere 2)) - (k (cat:k-z-1)) - (tw (cat:build-smmr - :sorc s2 - :trgt k - :degr -1 - :sintr #'(lambda (dmns gmsm) - (cat:absm 0 (list 1))) - :orgn '(s2-tw-kz))) - (dt-d (cat:fibration-dtau-d-intr tw))) - (funcall dt-d 0 (cat:crpr 0 '* 0 nil)) - (funcall dt-d 3 (cat:crpr 4 's2 0 '(2 3 4))) - (funcall dt-d 3 (cat:crpr 2 's2 0 '(2 3 4))) - (funcall dt-d 3 (cat:crpr 2 's2 5 '(5))) - (funcall dt-d 2 (cat:crpr 0 's2 0 '(3 -2))))) + (k (cat:k-z-1)) + (tw (cat:build-smmr + :sorc s2 + :trgt k + :degr -1 + :sintr #'(lambda (dmns gmsm) + (cat:absm 0 (list 1))) + :orgn '(s2-tw-kz))) + (dt-d (cat:fibration-dtau-d-intr tw))) + (funcall dt-d 0 (cat:crpr 0 '* 0 nil)) + (funcall dt-d 3 (cat:crpr 4 's2 0 '(2 3 4))) + (funcall dt-d 3 (cat:crpr 2 's2 0 '(2 3 4))) + (funcall dt-d 3 (cat:crpr 2 's2 5 '(5))) + (funcall dt-d 2 (cat:crpr 0 's2 0 '(3 -2))))) (test fibration-dtau-d (cat:cat-init) (let* ((s2 (cat:sphere 2)) - (k (cat:k-z-1)) - (tw (cat:build-smmr - :sorc s2 - :trgt k - :degr -1 - :sintr #'(lambda (dmns gmsm) - (cat:absm 0 (list 1))) - :orgn '(s2-tw-kz))) - (dt-d (cat:fibration-dtau-d tw))) - (cat:? dt-d 0 (cat:crpr 0 '* 0 nil)) - (cat:? dt-d 3 (cat:crpr 4 's2 0 '(2 3 4))) - (cat:? dt-d 3 (cat:crpr 2 's2 0 '(2 3 4))) - (cat:? dt-d 3 (cat:crpr 2 's2 5 '(5))) - (cat:? dt-d 2 (cat:crpr 0 's2 0 '(3 -2))))) + (k (cat:k-z-1)) + (tw (cat:build-smmr + :sorc s2 + :trgt k + :degr -1 + :sintr #'(lambda (dmns gmsm) + (cat:absm 0 (list 1))) + :orgn '(s2-tw-kz))) + (dt-d (cat:fibration-dtau-d tw))) + (cat:? dt-d 0 (cat:crpr 0 '* 0 nil)) + (cat:? dt-d 3 (cat:crpr 4 's2 0 '(2 3 4))) + (cat:? dt-d 3 (cat:crpr 2 's2 0 '(2 3 4))) + (cat:? dt-d 3 (cat:crpr 2 's2 5 '(5))) + (cat:? dt-d 2 (cat:crpr 0 's2 0 '(3 -2))))) (test brown-reduction (cat:cat-init) (let* ((s2 (cat:sphere 2)) - (k (cat:k-z2-1)) - (tw (cat:build-smmr - :sorc s2 - :trgt k - :degr -1 - :sintr #'(lambda (dmns gmsm) - (cat:absm 0 1)) - :orgn '(s2-tw-kz2))) - (brown (cat:brown-reduction tw)) - (tcc (cat:tcc brown)) - (bcc (cat:bcc brown))) - (cat:homology bcc 3) - (cat:homology tcc 1 8) - (cat:homology bcc 1 8))) + (k (cat:k-z2-1)) + (tw (cat:build-smmr + :sorc s2 + :trgt k + :degr -1 + :sintr #'(lambda (dmns gmsm) + (cat:absm 0 1)) + :orgn '(s2-tw-kz2))) + (brown (cat:brown-reduction tw)) + (tcc (cat:tcc brown)) + (bcc (cat:bcc brown))) + (cat:homology bcc 3) + (cat:homology tcc 1 8) + (cat:homology bcc 1 8))) #| (test brown-reduction1 (cat:cat-init) (let* ((s2 (cat:sphere 2)) - (k (cat:k-z-1)) - (tw (cat:build-smmr - :sorc s2 - :trgt k - :degr -1 - :sintr #'(lambda (dmns gmsm) - (cat:absm 0 (list 1))) - :orgn '(s2-tw-kz))) - (brown (cat:brown-reduction tw))) - (cat:homology (cat:tcc brown) 1 5) - (cat:homology (cat:bcc brown) 1 5))) + (k (cat:k-z-1)) + (tw (cat:build-smmr + :sorc s2 + :trgt k + :degr -1 + :sintr #'(lambda (dmns gmsm) + (cat:absm 0 (list 1))) + :orgn '(s2-tw-kz))) + (brown (cat:brown-reduction tw))) + (cat:homology (cat:tcc brown) 1 5) + (cat:homology (cat:bcc brown) 1 5))) |# (test right-serre-efhm (cat:cat-init) (let* ((s2 (cat:sphere 2)) - (k (cat:k-z-1)) - (tw (cat:build-smmr - :sorc s2 - :trgt k - :degr -1 - :sintr #'(lambda (dmns gmsm) - (cat:absm 0 (list 1))) - :orgn '(s2-tw-kz1))) - (rh (cat:right-serre-efhm tw)) - (rbcc (cat:rbcc rh))) - (cat:homology rbcc 0 5))) + (k (cat:k-z-1)) + (tw (cat:build-smmr + :sorc s2 + :trgt k + :degr -1 + :sintr #'(lambda (dmns gmsm) + (cat:absm 0 (list 1))) + :orgn '(s2-tw-kz1))) + (rh (cat:right-serre-efhm tw)) + (rbcc (cat:rbcc rh))) + (cat:homology rbcc 0 5))) (test fibration-total (cat:cat-init) (let* ((s2 (cat:sphere 2)) - (k (cat:k-z-1)) - (tw (cat:build-smmr - :sorc s2 - :trgt k - :degr -1 - :sintr #'(lambda (dmns gmsm) - (cat:absm 0 (list 1))) - :orgn '(s2-tw-kz1))) - (p3r (cat:fibration-total tw))) - (cat:homology p3r 1))) + (k (cat:k-z-1)) + (tw (cat:build-smmr + :sorc s2 + :trgt k + :degr -1 + :sintr #'(lambda (dmns gmsm) + (cat:absm 0 (list 1))) + :orgn '(s2-tw-kz1))) + (p3r (cat:fibration-total tw))) + (cat:homology p3r 1))) (test dummy diff --git a/test/simplicial-groups-test.lisp b/test/simplicial-groups-test.lisp index ba6e264..a79238d 100644 --- a/test/simplicial-groups-test.lisp +++ b/test/simplicial-groups-test.lisp @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :kenzo-test) @@ -6,8 +7,8 @@ (test check-kan (cat:cat-init) (let* ((k (cat:k-z-1)) - (rslt '(1 10 100)) - (hat (mapcar #'(lambda (i) (cat:face k i 3 rslt)) - (cat: 0 3)))) - (dotimes (i 4) - (cat:check-kan k i 3 (remove (nth i hat) hat :test #'equal))))) + (rslt '(1 10 100)) + (hat (mapcar #'(lambda (i) (cat:face k i 3 rslt)) + (cat: 0 3)))) + (dotimes (i 4) + (cat:check-kan k i 3 (remove (nth i hat) hat :test #'equal))))) diff --git a/test/simplicial-mrphs-test.lisp b/test/simplicial-mrphs-test.lisp index c89741b..103253f 100644 --- a/test/simplicial-mrphs-test.lisp +++ b/test/simplicial-mrphs-test.lisp @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :kenzo-test) @@ -6,14 +7,14 @@ (test build-smmr (let* ((d (cat:delta 3)) - (m (cat:build-smmr - :sorc d :trgt d :degr 0 - :sintr #'(lambda (dmns gmsm) (cat:absm 0 gmsm)) - :orgn '(identity delta-3))) - (m2 (cat:build-smmr - :sorc d :trgt d :degr 0 - :sintr #'(lambda (dmns gmsm) (cat:absm (cat:mask dmns) 1)) - :orgn '(null delta-3)))) - (cat:? m2 2 7) - ;; (s? m2 2 7) - )) + (m (cat:build-smmr + :sorc d :trgt d :degr 0 + :sintr #'(lambda (dmns gmsm) (cat:absm 0 gmsm)) + :orgn '(identity delta-3))) + (m2 (cat:build-smmr + :sorc d :trgt d :degr 0 + :sintr #'(lambda (dmns gmsm) (cat:absm (cat:mask dmns) 1)) + :orgn '(null delta-3)))) + (cat:? m2 2 7) + ;; (s? m2 2 7) + )) diff --git a/test/simplicial-sets-test.lisp b/test/simplicial-sets-test.lisp index 65b3a4a..444e458 100644 --- a/test/simplicial-sets-test.lisp +++ b/test/simplicial-sets-test.lisp @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :kenzo-test) @@ -14,7 +15,7 @@ (is (equal '(2) (cat:dgop-int-ext 4))) (is (equal '(5 4 3 2 1 0) (cat:dgop-int-ext 63))) (dotimes (i 33) - (is (= i (cat:dgop-ext-int (cat:dgop-int-ext i)))))) + (is (= i (cat:dgop-ext-int (cat:dgop-int-ext i)))))) (test hyphenize-list @@ -25,89 +26,89 @@ (test moore (let ((m (cat:moore 2 2))) - (dotimes (i 4) - (print (cat:basis m i :dgnr))))) + (dotimes (i 4) + (print (cat:basis m i :dgnr))))) #| (test intr-diagonal (let* ((cmpr #'cat:f-cmpr) - (face #'cat:delta-face) - (diag (cat:intr-diagonal face))) - (funcall diag 4 (cat:mask 5)) - (funcall diag 0 4) - (setf cmpr #'cat:s-cmpr face (cat:sphere-face 4)) - (setf diag (cat:intr-diagonal face)) - (funcall diag 4 's4) - (funcall diag 0 '*) - (setf s4 (cat:sphere 4)) - (cat:dgnl s4 4 's4))) + (face #'cat:delta-face) + (diag (cat:intr-diagonal face))) + (funcall diag 4 (cat:mask 5)) + (funcall diag 0 4) + (setf cmpr #'cat:s-cmpr face (cat:sphere-face 4)) + (setf diag (cat:intr-diagonal face)) + (funcall diag 4 's4) + (funcall diag 0 '*) + (setf s4 (cat:sphere 4)) + (cat:dgnl s4 4 's4))) |# (test face-bndr (let* ((face #'(lambda (indx dmns gmsm) - (cat:absm 0 (append - (subseq gmsm 0 indx) - (subseq gmsm (1+ indx)))))) - (bndr (cat:face-bndr #'cat:l-cmpr face))) - (funcall bndr 0 '(a)) - (funcall bndr 1 '(a b)) - (funcall bndr 2 '(a b c)) - (funcall bndr 3 '(a b c d)) - (funcall bndr 3 '(d c b a)) - (funcall bndr 1 '(a a)) - (funcall bndr 2 '(a a a)) - (funcall bndr 3 '(a a a a)) - (setf face #'(lambda (index dmns gmsm) - (cat:absm (cat:dgop-ext-int - (nreverse (cat: 0 3)) - (cat:? s3 3 's3) - (cat:smst (cat:idnm s3)) - (cat:chcm (cat:idnm s3)) - (setf d (cat:bndr s3)) - (cat:add d d))) + d) + (funcall (cat:cmpr s3) 's3 's3) + (dotimes (i 5) + (print (funcall (cat:basis s3) i))) + (mapcar #'(lambda (i) (funcall (cat:face s3) i 3 's3)) (cat: 0 3)) + (cat:? s3 3 's3) + (cat:smst (cat:idnm s3)) + (cat:chcm (cat:idnm s3)) + (setf d (cat:bndr s3)) + (cat:add d d))) (test sphere-wedge (cat:cat-init) (let ((w (cat:sphere-wedge 3 2 3))) - (funcall (cat:cmpr w) 's3-1 's3-2) - (dotimes (i 5) (print (funcall (cat:basis w) i))) - (funcall (cat:face w) 2 3 's3-1) - (cat:gnrt-? (cat:bndr w) 3 's3-2))) + (funcall (cat:cmpr w) 's3-1 's3-2) + (dotimes (i 5) (print (funcall (cat:basis w) i))) + (funcall (cat:face w) 2 3 's3-1) + (cat:gnrt-? (cat:bndr w) 3 's3-2))) (test moore (cat:cat-init) (let ((m4 (cat:moore 2 4))) - (cat:cmpr m4 'n5 'n5) - (dotimes (i 7) - (print (cat:basis m4 i))) - (mapcar #'(lambda (i) (cat:face m4 i 5 'n5)) (cat: 0 5)) - (cat:? m4 4 'm4) - (cat:? m4 5 'n5))) + (cat:cmpr m4 'n5 'n5) + (dotimes (i 7) + (print (cat:basis m4 i))) + (mapcar #'(lambda (i) (cat:face m4 i 5 'n5)) (cat: 0 5)) + (cat:? m4 4 'm4) + (cat:? m4 5 'n5))) (test r-proj-space-basis (let ((b (cat:r-proj-space-basis 1 :infinity))) - (dotimes (i 5) (print (funcall b i))) - (setf b (cat:r-proj-space-basis 1 5)) - (dotimes (i 8) (print (funcall b i))) - (setf b (cat:r-proj-space-basis 3 :infinity)) - (dotimes (i 5) (print (funcall b i))) - (setf b (cat:r-proj-space-basis 3 6)) - (dotimes (i 10) (print (funcall b i))))) + (dotimes (i 5) (print (funcall b i))) + (setf b (cat:r-proj-space-basis 1 5)) + (dotimes (i 8) (print (funcall b i))) + (setf b (cat:r-proj-space-basis 3 :infinity)) + (dotimes (i 5) (print (funcall b i))) + (setf b (cat:r-proj-space-basis 3 6)) + (dotimes (i 10) (print (funcall b i))))) (test R-proj-space (cat:cat-init) (let ((p (cat:R-proj-space))) - (cat:basis p 4) - (dotimes (i 5) - (print (cat:face p i 4 4))) - (dotimes (i 5) - (print (cat:? p i i))) - (setf dd (cat:cmps p p)) - (dotimes (i 6) - (print (cat:? dd i i))) - (setf p (cat:R-proj-space 3)) - (dotimes (i 7) - (print (cat:basis p i))) - (dotimes (i 5) - (print (cat:face p i 4 4))) - (dotimes (i 7) - (print (cat:? p i i))) - (setf dd (cat:cmps p p)) - (dotimes (i 7) - (print (cat:? dd i i))))) + (cat:basis p 4) + (dotimes (i 5) + (print (cat:face p i 4 4))) + (dotimes (i 5) + (print (cat:? p i i))) + (setf dd (cat:cmps p p)) + (dotimes (i 6) + (print (cat:? dd i i))) + (setf p (cat:R-proj-space 3)) + (dotimes (i 7) + (print (cat:basis p i))) + (dotimes (i 5) + (print (cat:face p i 4 4))) + (dotimes (i 7) + (print (cat:? p i i))) + (setf dd (cat:cmps p p)) + (dotimes (i 7) + (print (cat:? dd i i))))) (test gmsms-subsmst (cat:cat-init) (let* ((k (cat:k-z 2)) - (efhm (cat:efhm k)) - g cmbn kf incl cone s2 cl2 f2 s3 + (efhm (cat:efhm k)) + g cmbn kf incl cone s2 cl2 f2 s3 - ) - (setf cat:*homology-verbose* nil) - (setf g (first (cat:chcm-homology-gen (cat:rbcc efhm) 4))) - (setf cmbn (cat:lf efhm (cat:rg efhm g))) - (multiple-value-setq (kf incl) (cat:gmsms-subsmst k cmbn)) - (setf cone (cat:cone incl)) - (cat:efhm cone) - (cat:homology kf 0 5) - (cat:homology (cat:cone incl) 0 6) + ) + (setf cat:*homology-verbose* nil) + (setf g (first (cat:chcm-homology-gen (cat:rbcc efhm) 4))) + (setf cmbn (cat:lf efhm (cat:rg efhm g))) + (multiple-value-setq (kf incl) (cat:gmsms-subsmst k cmbn)) + (setf cone (cat:cone incl)) + (cat:efhm cone) + (cat:homology kf 0 5) + (cat:homology (cat:cone incl) 0 6) - (setf g (first (cat:chcm-homology-gen (cat:rbcc efhm) 8))) - (setf cmbn (cat:lf efhm (cat:rg efhm g))) - (multiple-value-setq (kf incl) (cat:gmsms-subsmst k cmbn)) - (setf cone (cat:cone incl)) - (cat:efhm cone) - (cat:homology kf 0 9) - (cat:homology (cat:cone incl) 0 10) - (dotimes (i 9) (print (length (cat:basis kf i)))) + (setf g (first (cat:chcm-homology-gen (cat:rbcc efhm) 8))) + (setf cmbn (cat:lf efhm (cat:rg efhm g))) + (multiple-value-setq (kf incl) (cat:gmsms-subsmst k cmbn)) + (setf cone (cat:cone incl)) + (cat:efhm cone) + (cat:homology kf 0 9) + (cat:homology (cat:cone incl) 0 10) + (dotimes (i 9) (print (length (cat:basis kf i)))) - (setf s2 (cat:sphere 2)) - (setf cl2 (cat:chml-clss s2 2)) - (setf f2 (cat:z-whitehead s2 cl2)) - (setf s3 (cat:fibration-total f2)) - (setf efhm (cat:efhm s3)) - (cat:basis (cat:rbcc efhm) 3) - (setf cmbn (cat:lf efhm (cat:rg efhm 3 (first (cat:basis - (cat:rbcc efhm) 3))))) - (setf kf (cat:gmsms-subsmst s3 cmbn)) - (cat:homology kf 0 4))) + (setf s2 (cat:sphere 2)) + (setf cl2 (cat:chml-clss s2 2)) + (setf f2 (cat:z-whitehead s2 cl2)) + (setf s3 (cat:fibration-total f2)) + (setf efhm (cat:efhm s3)) + (cat:basis (cat:rbcc efhm) 3) + (setf cmbn (cat:lf efhm (cat:rg efhm 3 (first (cat:basis + (cat:rbcc efhm) 3))))) + (setf kf (cat:gmsms-subsmst s3 cmbn)) + (cat:homology kf 0 4))) diff --git a/test/suspensions-test.lisp b/test/suspensions-test.lisp index 41e57d0..c031c06 100644 --- a/test/suspensions-test.lisp +++ b/test/suspensions-test.lisp @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :kenzo-test) @@ -6,38 +7,38 @@ (test suspension-cmpr (cat:cat-init) (let* ((cc (cat:deltab)) - (cmpr (cat:suspension-cmpr (cat:cmpr cc)))) - (is (equal :equal (funcall cmpr :s-bsgn :s-bsgn))) - (is (equal :greater (funcall cmpr 6 5))))) + (cmpr (cat:suspension-cmpr (cat:cmpr cc)))) + (is (equal :equal (funcall cmpr :s-bsgn :s-bsgn))) + (is (equal :greater (funcall cmpr 6 5))))) (test suspension-basis (cat:cat-init) (let* ((cc (cat:sphere 2)) - (basis (cat:suspension-basis (cat:basis cc)))) - (dotimes (i 6) - (print (funcall basis i))) - (cat:suspension-basis :locally-effective))) + (basis (cat:suspension-basis (cat:basis cc)))) + (dotimes (i 6) + (print (funcall basis i))) + (cat:suspension-basis :locally-effective))) (test suspension-intr-dffr (cat:cat-init) (let* ((cc (cat:deltab)) - (intr (cat:suspension-intr-dffr (cat:dffr cc)))) - (funcall intr (cat:cmbn 0 3 :s-bsgn)) - (funcall intr (cat:cmbn 3 66 7)))) + (intr (cat:suspension-intr-dffr (cat:dffr cc)))) + (funcall intr (cat:cmbn 0 3 :s-bsgn)) + (funcall intr (cat:cmbn 3 66 7)))) (test suspension (cat:cat-init) (let* ((cc (cat:deltab)) - (scc (cat:suspension cc))) - (cat:cmpr scc 7 11) - (signals simple-error (cat:basis scc 3)) - (cat:bsgn scc) - (cat:? scc 3 11) - (setf scc (cat:suspension cc 2)) - (cat:? scc 4 11))) + (scc (cat:suspension cc))) + (cat:cmpr scc 7 11) + (signals simple-error (cat:basis scc 3)) + (cat:bsgn scc) + (cat:? scc 3 11) + (setf scc (cat:suspension cc 2)) + (cat:? scc 4 11))) (test suspension-intr-cprd @@ -49,92 +50,92 @@ (test coal (cat:cat-init) (let* ((coal (cat:deltab)) - (scoal (cat:suspension coal))) - (setf scoal (cat:suspension coal)) - (cat:? scoal 3 7) - (cat:cprd scoal 3 7))) + (scoal (cat:suspension coal))) + (setf scoal (cat:suspension coal)) + (cat:? scoal 3 7) + (cat:cprd scoal 3 7))) (test suspension-face (cat:cat-init) (let* ((ss (cat:deltab)) - (face (cat:suspension-face (cat:face ss))) - (m (cat:moore 2 3))) - (funcall face 4 4 15) - (funcall face 0 4 15) - #+(or ecl sbcl) - (signals type-error (cat:check-faces #'cat:f-cmpr face 4 15)) - #+(or ecl sbcl) - (signals type-error (cat:check-faces #'cat:f-cmpr face 3 7)) - #+(or ecl sbcl) - (signals type-error (cat:check-faces #'cat:f-cmpr face 2 3)) - #-(or ecl sbcl) (cat:check-faces #'cat:f-cmpr face 4 15) - #-(or ecl sbcl) (cat:check-faces #'cat:f-cmpr face 3 7) - #-(or ecl sbcl) (cat:check-faces #'cat:f-cmpr face 2 3) - (setf face (cat:suspension-face (cat:face m))) - (dotimes (i 5) (print (funcall face i 4 'm3))) - (dotimes (i 6) (print (funcall face i 5 'mm4))) - (cat:check-faces #'cat:s-cmpr face 4 'm3) - (cat:check-faces #'cat:s-cmpr face 5 'mm4) - )) + (face (cat:suspension-face (cat:face ss))) + (m (cat:moore 2 3))) + (funcall face 4 4 15) + (funcall face 0 4 15) + #+(or ecl sbcl) + (signals type-error (cat:check-faces #'cat:f-cmpr face 4 15)) + #+(or ecl sbcl) + (signals type-error (cat:check-faces #'cat:f-cmpr face 3 7)) + #+(or ecl sbcl) + (signals type-error (cat:check-faces #'cat:f-cmpr face 2 3)) + #-(or ecl sbcl) (cat:check-faces #'cat:f-cmpr face 4 15) + #-(or ecl sbcl) (cat:check-faces #'cat:f-cmpr face 3 7) + #-(or ecl sbcl) (cat:check-faces #'cat:f-cmpr face 2 3) + (setf face (cat:suspension-face (cat:face m))) + (dotimes (i 5) (print (funcall face i 4 'm3))) + (dotimes (i 6) (print (funcall face i 5 'mm4))) + (cat:check-faces #'cat:s-cmpr face 4 'm3) + (cat:check-faces #'cat:s-cmpr face 5 'mm4) + )) (test suspension1 (cat:cat-init) (let* ((d (cat:deltab)) - (sd (cat:suspension d)) - (m (cat:moore 2 1)) - (sm (cat:suspension m))) - (setf sd (cat:suspension d)) - (cat:? sd 3 7) - (cat:cprd sd 3 7) - (cat:face sd 3 3 7) - (cat:face sd 2 3 7) - (cat:homology sm 0 5) - (setf ssm (cat:suspension sm)) - (cat:homology ssm 0 6))) + (sd (cat:suspension d)) + (m (cat:moore 2 1)) + (sm (cat:suspension m))) + (setf sd (cat:suspension d)) + (cat:? sd 3 7) + (cat:cprd sd 3 7) + (cat:face sd 3 3 7) + (cat:face sd 2 3 7) + (cat:homology sm 0 5) + (setf ssm (cat:suspension sm)) + (cat:homology ssm 0 6))) (test suspension-intr (cat:cat-init) (let* ((f (cat:idnt-mrph (cat:deltab))) - (sf (cat:suspension-intr f)) - (d (cat:dffr (cat:deltab))) - (sd (cat:suspension-intr d))) - (funcall sf (cat:cmbn 0 3 :s-bsgn)) - (funcall sf (cat:cmbn 2 4 3)) - (funcall sd (cat:cmbn 0 3 :s-bsgn)) - (funcall sd (cat:cmbn 2 4 3)) - (funcall sd (cat:cmbn 3 4 7)))) + (sf (cat:suspension-intr f)) + (d (cat:dffr (cat:deltab))) + (sd (cat:suspension-intr d))) + (funcall sf (cat:cmbn 0 3 :s-bsgn)) + (funcall sf (cat:cmbn 2 4 3)) + (funcall sd (cat:cmbn 0 3 :s-bsgn)) + (funcall sd (cat:cmbn 2 4 3)) + (funcall sd (cat:cmbn 3 4 7)))) (test suspension2 (cat:cat-init) (let* ((f (cat:idnt-mrph (cat:deltab))) - (sf (cat:suspension f)) - (d (cat:dffr (cat:deltab))) - (sd (cat:suspension d))) - (cat:? sf (cat:cmbn 0 3 :s-bsgn)) - (cat:? sf (cat:cmbn 2 4 3)) - (cat:? sd (cat:cmbn 0 3 :s-bsgn)) - (cat:? sd (cat:cmbn 2 4 3)) - (cat:? sd (cat:cmbn 3 4 7)))) + (sf (cat:suspension f)) + (d (cat:dffr (cat:deltab))) + (sd (cat:suspension d))) + (cat:? sf (cat:cmbn 0 3 :s-bsgn)) + (cat:? sf (cat:cmbn 2 4 3)) + (cat:? sd (cat:cmbn 0 3 :s-bsgn)) + (cat:? sd (cat:cmbn 2 4 3)) + (cat:? sd (cat:cmbn 3 4 7)))) (test suspension3 (cat:cat-init) (let* ((rdct (cat:ez (cat:deltab) (cat:deltab))) - (srdct (cat:suspension rdct))) - (cat:pre-check-rdct srdct) - (setf cat:*tc* (cat:cmbn 4 1 (cat:crpr 0 15 0 15))) - (setf cat:*bc* (cat:cmbn 4 1 (cat:tnpr 0 1 3 15) - 5 (cat:tnpr 1 3 2 7) - 10 (cat:tnpr 2 7 1 3) - 100 (cat:tnpr 3 15 0 1))) - (check-rdct))) + (srdct (cat:suspension rdct))) + (cat:pre-check-rdct srdct) + (setf cat:*tc* (cat:cmbn 4 1 (cat:crpr 0 15 0 15))) + (setf cat:*bc* (cat:cmbn 4 1 (cat:tnpr 0 1 3 15) + 5 (cat:tnpr 1 3 2 7) + 10 (cat:tnpr 2 7 1 3) + 100 (cat:tnpr 3 15 0 1))) + (check-rdct))) (test suspension4 (cat:cat-init) (let ((sk (cat:suspension (cat:k-z 2)))) - (cat:homology sk 0 10))) + (cat:homology sk 0 10))) diff --git a/test/tensor-products-test.lisp b/test/tensor-products-test.lisp index 3ac2f42..d2687f9 100644 --- a/test/tensor-products-test.lisp +++ b/test/tensor-products-test.lisp @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :kenzo-test) @@ -14,32 +15,32 @@ (test 2cmbn-tnpr (setf cat:*tnpr-with-degrees* t) (cat:2cmbn-tnpr (cat:cmbn 2 3 'a 4 'b -5 'c) - (cat:cmbn 3 4 'x -3 'y 2 'z))) + (cat:cmbn 3 4 'x -3 'y 2 'z))) (test tnsr-prdc-cmpr (let ((cmpr (cat:tnsr-prdc-cmpr #'cat:s-cmpr #'cat:s-cmpr))) - (is (equal :less (funcall cmpr - (cat:tnpr 2 'a 3 'b) - (cat:tnpr 3 'a 2 'b)))) - (is (equal :greater (funcall cmpr - (cat:tnpr 3 'a 2 'b) - (cat:tnpr 2 'a 3 'b)))) - (is (equal :less (funcall cmpr - (cat:tnpr 2 'a 3 'b) - (cat:tnpr 2 'b 3 'b)))) - (is (equal :greater (funcall cmpr - (cat:tnpr 2 'b 3 'b) - (cat:tnpr 2 'a 3 'b)))) - (is (equal :less (funcall cmpr - (cat:tnpr 2 'a 3 'a) - (cat:tnpr 2 'a 3 'b)))) - (is (equal :greater (funcall cmpr - (cat:tnpr 2 'a 3 'c) - (cat:tnpr 2 'a 3 'b)))) - (is (equal :equal (funcall cmpr - (cat:tnpr 2 'a 3 'b) - (cat:tnpr 2 'a 3 'b)))))) + (is (equal :less (funcall cmpr + (cat:tnpr 2 'a 3 'b) + (cat:tnpr 3 'a 2 'b)))) + (is (equal :greater (funcall cmpr + (cat:tnpr 3 'a 2 'b) + (cat:tnpr 2 'a 3 'b)))) + (is (equal :less (funcall cmpr + (cat:tnpr 2 'a 3 'b) + (cat:tnpr 2 'b 3 'b)))) + (is (equal :greater (funcall cmpr + (cat:tnpr 2 'b 3 'b) + (cat:tnpr 2 'a 3 'b)))) + (is (equal :less (funcall cmpr + (cat:tnpr 2 'a 3 'a) + (cat:tnpr 2 'a 3 'b)))) + (is (equal :greater (funcall cmpr + (cat:tnpr 2 'a 3 'c) + (cat:tnpr 2 'a 3 'b)))) + (is (equal :equal (funcall cmpr + (cat:tnpr 2 'a 3 'b) + (cat:tnpr 2 'a 3 'b)))))) (defun bas (degr) @@ -52,99 +53,99 @@ (test tnsr-prdc-basis (let ((bas (cat:tnsr-prdc-basis #'bas #'bas))) - (dotimes (i 8) - (print (funcall bas i))))) + (dotimes (i 8) + (print (funcall bas i))))) (test tnsr-prdc-intr-dffr - (cat:cat-init) - (let* ((chcm (cat:build-chcm :cmpr #'cat:s-cmpr - :basis :locally-effective - :intr-dffr #'cat:zero-mrph - :strt :gnrt :orgn '(test-1))) - (dffr (cat:build-mrph - :sorc chcm :trgt chcm :degr -1 - :intr #'(lambda (degr gnrt) - (ecase gnrt - (a (cat:cmbn (1- degr) 2 'd1a -3 'd2a)) - (b (cat:cmbn (1- degr) 3 'd1b -4 'd2b)))) - :strt :gnrt :orgn '(test-2))) - (rslt (cat:tnsr-prdc-intr-dffr dffr dffr))) - (funcall rslt 4 (cat:tnpr 2 'a 2 'b)) - (funcall rslt 5 (cat:tnpr 3 'a 2 'b)) - (funcall rslt 5 (cat:tnpr 2 'a 3 'b)) - (funcall rslt 6 (cat:tnpr 3 'a 3 'b)))) + (cat:cat-init) + (let* ((chcm (cat:build-chcm :cmpr #'cat:s-cmpr + :basis :locally-effective + :intr-dffr #'cat:zero-mrph + :strt :gnrt :orgn '(test-1))) + (dffr (cat:build-mrph + :sorc chcm :trgt chcm :degr -1 + :intr #'(lambda (degr gnrt) + (ecase gnrt + (a (cat:cmbn (1- degr) 2 'd1a -3 'd2a)) + (b (cat:cmbn (1- degr) 3 'd1b -4 'd2b)))) + :strt :gnrt :orgn '(test-2))) + (rslt (cat:tnsr-prdc-intr-dffr dffr dffr))) + (funcall rslt 4 (cat:tnpr 2 'a 2 'b)) + (funcall rslt 5 (cat:tnpr 3 'a 2 'b)) + (funcall rslt 5 (cat:tnpr 2 'a 3 'b)) + (funcall rslt 6 (cat:tnpr 3 'a 3 'b)))) (test tnsr-prdc (let ((dd (cat:tnsr-prdc (cat:delta 2) (cat:delta 3)))) - (cat:cmpr dd (cat:tnpr 2 7 2 11) (cat:tnpr 2 7 2 14)) - (cat:basis dd 3) - (cat:? dd 4 (cat:tnpr 2 7 2 14)) - (cat:? dd 3 (cat:tnpr 1 6 2 14)) - (cat:? dd (cat:? dd 4 (cat:tnpr 2 7 2 14))) - (cat:? dd (cat:? dd 3 (cat:tnpr 1 6 2 14))))) + (cat:cmpr dd (cat:tnpr 2 7 2 11) (cat:tnpr 2 7 2 14)) + (cat:basis dd 3) + (cat:? dd 4 (cat:tnpr 2 7 2 14)) + (cat:? dd 3 (cat:tnpr 1 6 2 14)) + (cat:? dd (cat:? dd 4 (cat:tnpr 2 7 2 14))) + (cat:? dd (cat:? dd 3 (cat:tnpr 1 6 2 14))))) (test tnsr-prdc-intr (cat:cat-init) (let* ((chcm (cat:build-chcm :cmpr #'cat:s-cmpr - :basis :locally-effective - :intr-dffr #'cat:zero-mrph - :strt :gnrt - :orgn '(test-1))) + :basis :locally-effective + :intr-dffr #'cat:zero-mrph + :strt :gnrt + :orgn '(test-1))) - (mrph (cat:build-mrph - :sorc chcm :trgt chcm :degr 0 - :intr #'(lambda (degr gnrt) - (ecase gnrt - (a (cat:cmbn degr 2 'd1a -3 'd2a)) - (b (cat:cmbn degr 3 'd1b -4 'd2b)))) - :strt :gnrt :orgn '(test-2))) - (rslt (cat:tnsr-prdc-intr mrph mrph))) - (funcall rslt 6 (cat:tnpr 2 'a 4 'b)) - (funcall rslt 5 (cat:tnpr 3 'a 2 'b)) - (setf mrph (cat:build-mrph - :sorc chcm :trgt chcm :degr 1 - :intr #'(lambda (degr gnrt) - (ecase gnrt - (a (cat:cmbn (1+ degr) 2 'd1a -3 'd2a)) - (b (cat:cmbn (1+ degr) 3 'd1b -4 'd2b)))) - :strt :gnrt :orgn '(test-3))) - (setf rslt (cat:tnsr-prdc-intr mrph mrph)) - (funcall rslt 6 (cat:tnpr 2 'a 4 'b)) - (funcall rslt 5 (cat:tnpr 3 'a 2 'b)))) + (mrph (cat:build-mrph + :sorc chcm :trgt chcm :degr 0 + :intr #'(lambda (degr gnrt) + (ecase gnrt + (a (cat:cmbn degr 2 'd1a -3 'd2a)) + (b (cat:cmbn degr 3 'd1b -4 'd2b)))) + :strt :gnrt :orgn '(test-2))) + (rslt (cat:tnsr-prdc-intr mrph mrph))) + (funcall rslt 6 (cat:tnpr 2 'a 4 'b)) + (funcall rslt 5 (cat:tnpr 3 'a 2 'b)) + (setf mrph (cat:build-mrph + :sorc chcm :trgt chcm :degr 1 + :intr #'(lambda (degr gnrt) + (ecase gnrt + (a (cat:cmbn (1+ degr) 2 'd1a -3 'd2a)) + (b (cat:cmbn (1+ degr) 3 'd1b -4 'd2b)))) + :strt :gnrt :orgn '(test-3))) + (setf rslt (cat:tnsr-prdc-intr mrph mrph)) + (funcall rslt 6 (cat:tnpr 2 'a 4 'b)) + (funcall rslt 5 (cat:tnpr 3 'a 2 'b)))) (test tnsr-prdc (cat:cat-init) (let* ((d (cat:dffr (cat:delta-infinity))) - (dd (cat:tnsr-prdc d d)) - (ddd (cat:cmps dd dd))) - (is (eq (cat:sorc dd) (cat:tnsr-prdc (cat:delta-infinity) - (cat:delta-infinity)))) - (cat:? dd 5 (cat:tnpr 2 7 3 15)) - (cat:? dd 5 (cat:tnpr 3 15 2 7)) - (cat:? dd (cat:? dd 5 (cat:tnpr 2 7 3 15))) - (cat:? dd (cat:? dd 5 (cat:tnpr 3 15 2 7))) - (cat:? ddd 5 (cat:tnpr 2 7 3 15)) - (cat:? ddd 5 (cat:tnpr 3 15 2 7)))) + (dd (cat:tnsr-prdc d d)) + (ddd (cat:cmps dd dd))) + (is (eq (cat:sorc dd) (cat:tnsr-prdc (cat:delta-infinity) + (cat:delta-infinity)))) + (cat:? dd 5 (cat:tnpr 2 7 3 15)) + (cat:? dd 5 (cat:tnpr 3 15 2 7)) + (cat:? dd (cat:? dd 5 (cat:tnpr 2 7 3 15))) + (cat:? dd (cat:? dd 5 (cat:tnpr 3 15 2 7))) + (cat:? ddd 5 (cat:tnpr 2 7 3 15)) + (cat:? ddd 5 (cat:tnpr 3 15 2 7)))) (test tnsr-prdc1 (cat:cat-init) (let* ((r (cat:ez (cat:delta-infinity) (cat:delta-infinity))) - (r2 (cat:tnsr-prdc r r))) - (setf cat:*bc* (cat:cmbn 4 1 (cat:tnpr 2 (cat:tnpr 1 3 1 3) 2 - (cat:tnpr 1 3 1 3))) - cat:*tc* (cat:cmbn 2 1 (cat:tnpr 1 (cat:crpr 0 3 0 3) 1 - (cat:crpr 0 3 0 3)))) - (cat:pre-check-rdct r2) - (check-rdct))) + (r2 (cat:tnsr-prdc r r))) + (setf cat:*bc* (cat:cmbn 4 1 (cat:tnpr 2 (cat:tnpr 1 3 1 3) 2 + (cat:tnpr 1 3 1 3))) + cat:*tc* (cat:cmbn 2 1 (cat:tnpr 1 (cat:crpr 0 3 0 3) 1 + (cat:crpr 0 3 0 3)))) + (cat:pre-check-rdct r2) + (check-rdct))) (test tnsr-prdc2 (cat:cat-init) (let* ((k (cat:k-z 2)) - (k2 (cat:tnsr-prdc k k))) - (cat:homology k2 0 10))) + (k2 (cat:tnsr-prdc k k))) + (cat:homology k2 0 10))) diff --git a/test/various-test.lisp b/test/various-test.lisp index cfe8017..e69c985 100644 --- a/test/various-test.lisp +++ b/test/various-test.lisp @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :kenzo-test) @@ -5,15 +6,15 @@ (test binomial-n-p (let ((rslt '(1 5 10 10 5 1))) - (dotimes (i 6) - (is (equal (cat:binomial-n-p 5 i) - (nth i rslt)))))) + (dotimes (i 6) + (is (equal (cat:binomial-n-p 5 i) + (nth i rslt)))))) (test binomial-p-q (let ((rslt '(1 5 10 10 5 1))) - (dotimes (i 6) - (is (equal (cat:binomial-p-q (- 5 i) i) - (nth i rslt)))))) + (dotimes (i 6) + (is (equal (cat:binomial-p-q (- 5 i) i) + (nth i rslt)))))) (test (is (equalp (cat:v -5 5) - (make-array 11 :element-type 'fixnum - :initial-contents '(-5 -4 -3 -2 -1 - 0 1 2 3 4 5))))) + (make-array 11 :element-type 'fixnum + :initial-contents '(-5 -4 -3 -2 -1 + 0 1 2 3 4 5))))) (test srandom (dotimes (i 20) - (let ((rslt (cat:srandom 3))) - (is (and (typep rslt 'fixnum) - (<= -3 rslt 3)))))) + (let ((rslt (cat:srandom 3))) + (is (and (typep rslt 'fixnum) + (<= -3 rslt 3)))))) diff --git a/test/whitehead-test.lisp b/test/whitehead-test.lisp index e592365..0e7f69b 100644 --- a/test/whitehead-test.lisp +++ b/test/whitehead-test.lisp @@ -1,3 +1,4 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* (in-package :kenzo-test) @@ -7,88 +8,88 @@ (test z-whitehead-sintr (cat:cat-init) (let* ((k (cat:k-z 2)) - (ecc (cat:echcm k)) - (chml-clss - (cat:build-mrph - :sorc ecc :trgt (cat:z-chcm) :degr 2 - :intr #'(lambda (degr gnrt) - (if (= degr 2) - (cat:term-cmbn 0 1 :z-gnrt) - (cat:zero-cmbn (- degr 2)))) - :strt :gnrt :orgn '(fundamental-class k-z-2))) - (tw (cat:z-whitehead-sintr k 2 chml-clss))) - (cat:tw-a-sintr3 tw 1 (cat:absm 1 cat:+null-gbar+) '()) - (cat:tw-a-sintr3 tw 2 (cat:absm 3 cat:+null-gbar+) '()) - (funcall tw 2 (cat:gbar 2 0 '(55) 0 '())) - (funcall tw 3 (cat:gbar 3 0 '(12 23) 0 '(34) 0 '())) - (funcall tw 4 (cat:gbar 4 0 '(12 23 34) 2 '(45) 0 '(56) 0 '())) - (setf k (cat:k-z 3)) - (setf ecc (cat:echcm k)) - (setf chml-clss - (cat:build-mrph - :sorc ecc :trgt (cat:z-chcm) :degr 3 - :intr #'(lambda (degr gnrt) - (if (= degr 3) - (cat:term-cmbn 0 -1 :z-gnrt) - (cat:zero-cmbn (- degr 3)))) - :strt :gnrt :orgn '(fundamental-class k-z-3))) - (setf tw (cat:z-whitehead-sintr k 3 chml-clss)) - (cat:tw-a-sintr3 tw 1 (cat:absm 1 cat:+null-gbar+) cat:+null-gbar+) - (cat:tw-a-sintr3 tw 2 (cat:absm 3 cat:+null-gbar+) cat:+null-gbar+) - (cat:tw-a-sintr3 tw 3 (cat:absm 7 cat:+null-gbar+) cat:+null-gbar+) - (funcall tw 3 (cat:z-fundamental-gmsm 3 55)) - (is (equalp (funcall tw 3 (cat:z-fundamental-gmsm 3 55)) - (cat:absm 0 (cat:z-fundamental-gmsm 2 55)))) - (funcall tw 4 (cat:gbar 4 0 (cat:gbar 3 0 '(12 23) 0 '(34) 0 '()) - 0 (cat:gbar 2 0 '(45) 0 '()) - 1 (cat:gbar 0) - 0 (cat:gbar 0))))) + (ecc (cat:echcm k)) + (chml-clss + (cat:build-mrph + :sorc ecc :trgt (cat:z-chcm) :degr 2 + :intr #'(lambda (degr gnrt) + (if (= degr 2) + (cat:term-cmbn 0 1 :z-gnrt) + (cat:zero-cmbn (- degr 2)))) + :strt :gnrt :orgn '(fundamental-class k-z-2))) + (tw (cat:z-whitehead-sintr k 2 chml-clss))) + (cat:tw-a-sintr3 tw 1 (cat:absm 1 cat:+null-gbar+) '()) + (cat:tw-a-sintr3 tw 2 (cat:absm 3 cat:+null-gbar+) '()) + (funcall tw 2 (cat:gbar 2 0 '(55) 0 '())) + (funcall tw 3 (cat:gbar 3 0 '(12 23) 0 '(34) 0 '())) + (funcall tw 4 (cat:gbar 4 0 '(12 23 34) 2 '(45) 0 '(56) 0 '())) + (setf k (cat:k-z 3)) + (setf ecc (cat:echcm k)) + (setf chml-clss + (cat:build-mrph + :sorc ecc :trgt (cat:z-chcm) :degr 3 + :intr #'(lambda (degr gnrt) + (if (= degr 3) + (cat:term-cmbn 0 -1 :z-gnrt) + (cat:zero-cmbn (- degr 3)))) + :strt :gnrt :orgn '(fundamental-class k-z-3))) + (setf tw (cat:z-whitehead-sintr k 3 chml-clss)) + (cat:tw-a-sintr3 tw 1 (cat:absm 1 cat:+null-gbar+) cat:+null-gbar+) + (cat:tw-a-sintr3 tw 2 (cat:absm 3 cat:+null-gbar+) cat:+null-gbar+) + (cat:tw-a-sintr3 tw 3 (cat:absm 7 cat:+null-gbar+) cat:+null-gbar+) + (funcall tw 3 (cat:z-fundamental-gmsm 3 55)) + (is (equalp (funcall tw 3 (cat:z-fundamental-gmsm 3 55)) + (cat:absm 0 (cat:z-fundamental-gmsm 2 55)))) + (funcall tw 4 (cat:gbar 4 0 (cat:gbar 3 0 '(12 23) 0 '(34) 0 '()) + 0 (cat:gbar 2 0 '(45) 0 '()) + 1 (cat:gbar 0) + 0 (cat:gbar 0))))) (test Z2-whitehead-sintr (cat:cat-init) (let* ((k (cat:k-z2 2)) - (ecc (cat:echcm k)) - (chml-clss - (cat:build-mrph - :sorc ecc :trgt (cat:z-chcm) :degr 2 - :intr #'(lambda (degr gnrt) - (if (= degr 2) - (cat:term-cmbn 0 1 :z-gnrt) - (cat:zero-cmbn (- degr 2)))) - :strt :gnrt :orgn '(fundamental-class k-z-2))) - (tw (cat:Z2-whitehead-sintr k 2 chml-clss))) - (cat:tw-a-sintr3 tw 1 (cat:absm 1 cat:+null-gbar+) 0) - (cat:tw-a-sintr3 tw 2 (cat:absm 3 cat:+null-gbar+) 0) - (funcall tw 2 (cat:gbar 2 0 1 0 '())) - (funcall tw 3 (cat:gbar 3 0 2 - 0 1 - 0 0)) - (funcall tw 4 (cat:gbar 4 0 3 - 2 1 - 0 1 - 0 0)) - (setf k (cat:k-z2 3)) - (setf ecc (cat:echcm k)) - (setf chml-clss - (cat:build-mrph - :sorc ecc :trgt (cat:z-chcm) :degr 3 - :intr #'(lambda (degr gnrt) - (if (= degr 3) - (cat:term-cmbn 0 -1 :z-gnrt) - (cat:zero-cmbn (- degr 3)))) - :strt :gnrt :orgn '(fundamental-class k-z-3))) - (setf tw (cat:Z2-whitehead-sintr k 3 chml-clss)) - (cat:tw-a-sintr3 tw 1 (cat:absm 1 cat:+null-gbar+) 0) - (cat:tw-a-sintr3 tw 2 (cat:absm 3 cat:+null-gbar+) 0) - (cat:tw-a-sintr3 tw 3 (cat:absm 7 cat:+null-gbar+) 0) - (funcall tw 3 (cat:Z2-fundamental-gmsm 3 1)) - (is (equalp (funcall tw 3 (cat:Z2-fundamental-gmsm 3 1)) - (cat:absm 0 (cat:Z2-fundamental-gmsm 2 1)))) - (funcall tw 4 (cat:gbar 4 0 (cat:gbar 3 0 2 0 1 0 0) - 0 (cat:gbar 2 0 1 0 0) - 1 (cat:gbar 0) - 0 (cat:gbar 0))))) + (ecc (cat:echcm k)) + (chml-clss + (cat:build-mrph + :sorc ecc :trgt (cat:z-chcm) :degr 2 + :intr #'(lambda (degr gnrt) + (if (= degr 2) + (cat:term-cmbn 0 1 :z-gnrt) + (cat:zero-cmbn (- degr 2)))) + :strt :gnrt :orgn '(fundamental-class k-z-2))) + (tw (cat:Z2-whitehead-sintr k 2 chml-clss))) + (cat:tw-a-sintr3 tw 1 (cat:absm 1 cat:+null-gbar+) 0) + (cat:tw-a-sintr3 tw 2 (cat:absm 3 cat:+null-gbar+) 0) + (funcall tw 2 (cat:gbar 2 0 1 0 '())) + (funcall tw 3 (cat:gbar 3 0 2 + 0 1 + 0 0)) + (funcall tw 4 (cat:gbar 4 0 3 + 2 1 + 0 1 + 0 0)) + (setf k (cat:k-z2 3)) + (setf ecc (cat:echcm k)) + (setf chml-clss + (cat:build-mrph + :sorc ecc :trgt (cat:z-chcm) :degr 3 + :intr #'(lambda (degr gnrt) + (if (= degr 3) + (cat:term-cmbn 0 -1 :z-gnrt) + (cat:zero-cmbn (- degr 3)))) + :strt :gnrt :orgn '(fundamental-class k-z-3))) + (setf tw (cat:Z2-whitehead-sintr k 3 chml-clss)) + (cat:tw-a-sintr3 tw 1 (cat:absm 1 cat:+null-gbar+) 0) + (cat:tw-a-sintr3 tw 2 (cat:absm 3 cat:+null-gbar+) 0) + (cat:tw-a-sintr3 tw 3 (cat:absm 7 cat:+null-gbar+) 0) + (funcall tw 3 (cat:Z2-fundamental-gmsm 3 1)) + (is (equalp (funcall tw 3 (cat:Z2-fundamental-gmsm 3 1)) + (cat:absm 0 (cat:Z2-fundamental-gmsm 2 1)))) + (funcall tw 4 (cat:gbar 4 0 (cat:gbar 3 0 2 0 1 0 0) + 0 (cat:gbar 2 0 1 0 0) + 1 (cat:gbar 0) + 0 (cat:gbar 0))))) #| @@ -98,16 +99,16 @@ (test Z2-whitehead (cat:cat-init) (let* ((m (cat:moore 2 4)) - (chml-clss - (cat:build-mrph - :sorc m :trgt (cat:z-chcm) :degr -4 - :intr #'(lambda (dmns gmsm) - (if (= 4 dmns) - (cat:cmbn 0 1 :z-gnrt) - (cat:zero-cmbn (- dmns 4)))) - :strt :gnrt - :orgn '(chml-clss moore 2 4))) - (mf (cat:z2-whitehead m chml-clss)) - (mt (cat:fibration-total mf))) - (cat:homology mt 0 10))) + (chml-clss + (cat:build-mrph + :sorc m :trgt (cat:z-chcm) :degr -4 + :intr #'(lambda (dmns gmsm) + (if (= 4 dmns) + (cat:cmbn 0 1 :z-gnrt) + (cat:zero-cmbn (- dmns 4)))) + :strt :gnrt + :orgn '(chml-clss moore 2 4))) + (mf (cat:z2-whitehead m chml-clss)) + (mt (cat:fibration-total mf))) + (cat:homology mt 0 10))) |#