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

Added Emacs mode line and introduced consistent formatting.

Browse Source
This commit is contained in:
Gerd Heber 2016-03-08 20:00:42 -05:00
parent 54893a7b0b
commit 16757dc1df
84 changed files with 7901 additions and 7800 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
kenzo-test.asd
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(defsystem :kenzo-test (defsystem :kenzo-test
:description "A simple regression test suite for Kenzo" :description "A simple regression test suite for Kenzo"

99
kenzo.asd
View File

@ -1,4 +1,4 @@
;;;; kenzo.asd ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :cl-user) (in-package :cl-user)
@ -16,52 +16,51 @@
:components :components
((:file "package") ((:file "package")
(:module "src" (:module "src"
:components :components
((:file "kenzo") ((:file "kenzo")
(:file "abbreviations") (:file "abbreviations")
(:file "macros") (:file "macros")
(:file "various") (:file "various")
(:file "classes") (:file "classes")
(:file "combinations") (:file "combinations")
(:file "chain-complexes") (:file "chain-complexes")
(:file "chcm-elementary-op") (:file "chcm-elementary-op")
(:file "effective-homology") (:file "effective-homology")
(:file "homology-groups") (:file "homology-groups")
(:file "searching-homology") (:file "searching-homology")
(:file "cones") (:file "cones")
(:file "bicones") (:file "bicones")
(:file "tensor-products") (:file "tensor-products")
(:file "coalgebras") (:file "coalgebras")
(:file "cobar") (:file "cobar")
(:file "algebras") (:file "algebras")
(:file "bar") (:file "bar")
(:file "simplicial-sets") (:file "simplicial-sets")
(:file "simplicial-mrphs") (:file "simplicial-mrphs")
(:file "delta") (:file "delta")
(:file "special-smsts") (:file "special-smsts")
(:file "suspensions") (:file "suspensions")
(:file "disk-pasting") (:file "disk-pasting")
(:file "cartesian-products") (:file "cartesian-products")
(:file "eilenberg-zilber") (:file "eilenberg-zilber")
(:file "kan") (:file "kan")
(:file "simplicial-groups") (:file "simplicial-groups")
(:file "fibrations") (:file "fibrations")
(:file "loop-spaces") (:file "loop-spaces")
(:file "ls-twisted-products") (:file "ls-twisted-products")
(:file "lp-space-efhm") (:file "lp-space-efhm")
(:file "classifying-spaces") (:file "classifying-spaces")
(:file "k-pi-n") (:file "k-pi-n")
(:file "serre") (:file "serre")
(:file "cs-twisted-products") (:file "cs-twisted-products")
(:file "cl-space-efhm") (:file "cl-space-efhm")
(:file "whitehead") (:file "whitehead")
(:file "smith") (:file "smith")
#| #|
(:module "anromero" (:module "anromero"
:components :components
((:file "bicomplexes") ((:file "bicomplexes")
(:file "filtered-complexes") (:file "filtered-complexes")
(:file "spectral-sequences"))) (:file "spectral-sequences")))
|# |#
)))) ))))

4
package.lisp
View File

@ -1,6 +1,4 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
;;;;
;;;; package.lisp
(defpackage #:cat (defpackage #:cat
(:use #:cl) (:use #:cl)

1
run-kenzo-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(DECLAIM (OPTIMIZE (speed 3) (space 0) (debug 3))) (DECLAIM (OPTIMIZE (speed 3) (space 0) (debug 3)))

46
src/Demo.lisp
View File

@ -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 ;;; 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) (terpri)
(dotimes (i 50) (princ "-")) (dotimes (i 50) (princ "-"))
(princ "<Comment>") (princ "<Comment>")
; (dotimes (i 31) (princ "-")) ; (dotimes (i 31) (princ "-"))
; (terpri) ; (terpri)
(princ string) (princ string)
; (terpri) ; (terpri)
(dotimes (i 50) (princ "-")) (dotimes (i 50) (princ "-"))
(values)) (values))
@ -26,8 +28,8 @@
(terpri) (terpri)
(dotimes (i 50) (princ "-")) (dotimes (i 50) (princ "-"))
(princ "<Lisp Statement>") (princ "<Lisp Statement>")
; (dotimes (i 29) (princ "-")) ; (dotimes (i 29) (princ "-"))
; (terpri) ; (terpri)
(pprint ',statement) (pprint ',statement)
(terpri) ; (terpri) (terpri) ; (terpri)
(dotimes (i 50) (princ "-")) (dotimes (i 50) (princ "-"))
@ -51,14 +53,14 @@
(setf *statement* (read-from-string dstatement)) (setf *statement* (read-from-string dstatement))
`(progn `(progn
(terpri) (terpri)
(dotimes (i 50) (princ "-")) (dotimes (i 50) (princ "-"))
(princ "<Lisp Statement>") (princ "<Lisp Statement>")
; (dotimes (i 31) (princ "-")) ; (dotimes (i 31) (princ "-"))
; (terpri) ; (terpri)
(princ (strip-initial-spaces *dstatement*)) (princ (strip-initial-spaces *dstatement*))
; (terpri) ; (terpri)
(dotimes (i 50) (princ "-")) (dotimes (i 50) (princ "-"))
(values))) (values)))
;; E = EXECUTE ;; E = EXECUTE
(DEFUN E () (DEFUN E ()
@ -66,7 +68,7 @@
(terpri) (terpri)
(dotimes (i 50) (princ "-")) (dotimes (i 50) (princ "-"))
(princ "<Result>") (princ "<Result>")
; (dotimes (i 32) (princ "-")) ; (dotimes (i 32) (princ "-"))
(terpri) ; (terpri) (terpri) ; (terpri)
(prin1 (eval *statement*)) (prin1 (eval *statement*))
(terpri) ; (terpri) (terpri) ; (terpri)
@ -82,14 +84,14 @@
(terpri) (terpri) (terpri) (terpri)
(restart-case (restart-case
(handler-bind ((error (handler-bind ((error
#'(lambda (condition) #'(lambda (condition)
(format t "Type-error: ~S~&" (format t "Type-error: ~S~&"
(class-name (class-of condition))) (class-name (class-of condition)))
(apply #'format t (apply #'format t
(simple-condition-format-control condition) (simple-condition-format-control condition)
(simple-condition-format-arguments condition)) (simple-condition-format-arguments condition))
(invoke-restart 'my-restart)))) (invoke-restart 'my-restart))))
(eval *statement*)) (eval *statement*))
(my-restart () (values))) (my-restart () (values)))
(terpri) (terpri) (terpri) (terpri)
(dotimes (i 50) (princ "-")) (dotimes (i 50) (princ "-"))

9
src/abbreviations.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(IN-PACKAGE #:cat) (IN-PACKAGE #:cat)
@ -119,7 +120,7 @@
"WHAT-IS returns the full word or term for an abbreviation provided as a "WHAT-IS returns the full word or term for an abbreviation provided as a
keyword, string, or symbol. It returns NIL for unknown abbreviations." keyword, string, or symbol. It returns NIL for unknown abbreviations."
(unless (null kwd) (unless (null kwd)
(getf +ABBREVIATIONS+ (getf +ABBREVIATIONS+
(cond ((keywordp kwd) kwd) (cond ((keywordp kwd) kwd)
((stringp kwd) (intern (string-upcase kwd) 'keyword)) ((stringp kwd) (intern (string-upcase kwd) 'keyword))
((symbolp kwd) (intern (symbol-name kwd) 'keyword)))))) ((symbolp kwd) (intern (symbol-name kwd) 'keyword))))))

121
src/algebras.lisp
View File

@ -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 ;;; 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) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) nil)) (setf (ext:package-lock :clos) nil))
(DEFMETHOD PRINT-OBJECT ((algb algebra) stream) (DEFMETHOD PRINT-OBJECT ((algb algebra) stream)
(the algebra (the algebra
(progn (progn
(format stream "[K~D Algebra]" (idnm algb)) (format stream "[K~D Algebra]" (idnm algb))
algb))) algb)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t)) (setf (ext:package-lock :clos) t))
(DEFUN ALGB (idnm) (DEFUN ALGB (idnm)
(declare (fixnum idnm)) (declare (fixnum idnm))
(the (or algebra null) (the (or algebra null)
(find idnm *algb-list* :key #'idnm))) (find idnm *algb-list* :key #'idnm)))
(DEFUN BUILD-ALGB (DEFUN BUILD-ALGB
(&key cmpr basis bsgn intr-dffr dffr-strt intr-aprd aprd-strt orgn) (&key cmpr basis bsgn intr-dffr dffr-strt intr-aprd aprd-strt orgn)
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(type intr-mrph intr-dffr intr-aprd) (type intr-mrph intr-dffr intr-aprd)
(type basis basis) (type basis basis)
(type gnrt bsgn) (type gnrt bsgn)
(type strt dffr-strt aprd-strt) (type strt dffr-strt aprd-strt)
(list orgn)) (list orgn))
(the algebra (the algebra
(progn (progn
(let ((already (find orgn *algb-list* :key #'orgn :test #'equal))) (let ((already (find orgn *algb-list* :key #'orgn :test #'equal)))
(declare (type (or null algebra) already)) (declare (type (or null algebra) already))
(when already (when already
(return-from build-algb already))) (return-from build-algb already)))
(let* ((rslt (build-chcm :cmpr cmpr :basis basis :bsgn bsgn (let* ((rslt (build-chcm :cmpr cmpr :basis basis :bsgn bsgn
:intr-dffr intr-dffr :strt dffr-strt :intr-dffr intr-dffr :strt dffr-strt
:orgn orgn)) :orgn orgn))
;; to be done before change-class ;; to be done before change-class
(rslt-rslt (tnsr-prdc rslt rslt))) (rslt-rslt (tnsr-prdc rslt rslt)))
(declare (type chain-complex rslt rslt-rslt)) (declare (type chain-complex rslt rslt-rslt))
(change-class rslt 'algebra) (change-class rslt 'algebra)
(setf (slot-value rslt 'aprd) (setf (slot-value rslt 'aprd)
(build-mrph :sorc rslt-rslt :trgt rslt :degr 0 (build-mrph :sorc rslt-rslt :trgt rslt :degr 0
:intr intr-aprd :strt aprd-strt :intr intr-aprd :strt aprd-strt
:orgn `(algebra-product ,rslt))) :orgn `(algebra-product ,rslt)))
(push rslt *algb-list*) (push rslt *algb-list*)
rslt)))) rslt))))
(DEFUN CHANGE-CHCM-TO-ALGB (chcm &key intr-aprd aprd-strt orgn) (DEFUN CHANGE-CHCM-TO-ALGB (chcm &key intr-aprd aprd-strt orgn)
(declare (declare
(type chain-complex chcm) (type chain-complex chcm)
(type intr-mrph intr-aprd) (type intr-mrph intr-aprd)
(type strt aprd-strt) (type strt aprd-strt)
(list orgn)) (list orgn))
(the algebra (the algebra
(let ((chcm-chcm (tnsr-prdc chcm chcm))) (let ((chcm-chcm (tnsr-prdc chcm chcm)))
(declare (type chain-complex chcm-chcm)) (declare (type chain-complex chcm-chcm))
(change-class chcm 'algebra) (change-class chcm 'algebra)
(setf orgn (list (orgn chcm) 'then orgn)) (setf orgn (list (orgn chcm) 'then orgn))
(let ((already (find orgn *algb-list* :key #'orgn :test #'equal))) (let ((already (find orgn *algb-list* :key #'orgn :test #'equal)))
(declare (type (or null algebra) already)) (declare (type (or null algebra) already))
(when already (when already
(return-from change-chcm-to-algb already))) (return-from change-chcm-to-algb already)))
(setf (slot-value chcm 'aprd) (build-mrph (setf (slot-value chcm 'aprd) (build-mrph
:sorc chcm-chcm :trgt chcm :sorc chcm-chcm :trgt chcm
:degr 0 :degr 0
:intr intr-aprd :strt aprd-strt :intr intr-aprd :strt aprd-strt
:orgn orgn)) :orgn orgn))
(push chcm *algb-list*) (push chcm *algb-list*)
chcm))) chcm)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) nil)) (setf (ext:package-lock :clos) nil))
(DEFMETHOD PRINT-OBJECT ((hopf hopf-algebra) stream) (DEFMETHOD PRINT-OBJECT ((hopf hopf-algebra) stream)
(the hopf-algebra (the hopf-algebra
(progn (progn
(format stream "[K~D Hopf-Algebra]" (idnm hopf)) (format stream "[K~D Hopf-Algebra]" (idnm hopf))
hopf))) hopf)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t)) (setf (ext:package-lock :clos) t))
(DEFUN HOPF (idnm) (DEFUN HOPF (idnm)
(declare (fixnum idnm)) (declare (fixnum idnm))
(the (or hopf-algebra null) (the (or hopf-algebra null)
(find idnm *hopf-list* :key #'idnm))) (find idnm *hopf-list* :key #'idnm)))

4
src/bar.lisp
View File

@ -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 ;;; 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

512
src/bicones.lisp
View File

@ -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 ;;; 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)) (declare (type cmbn cmbn))
(the (values cmbn cmbn cmbn) (the (values cmbn cmbn cmbn)
(with-cmbn (degr list) cmbn (with-cmbn (degr list) cmbn
(let ((listb +empty-list+) (let ((listb +empty-list+)
(listc +empty-list+) (listc +empty-list+)
(listd +empty-list+)) (listd +empty-list+))
(declare (list listb listc listd)) (declare (list listb listc listd))
(dolist (term list) (dolist (term list)
(declare (type term term)) (declare (type term term))
(with-term (cffc bicn) term (with-term (cffc bicn) term
(with-bicn (bcnx ibicn) bicn (with-bicn (bcnx ibicn) bicn
(ecase bcnx (ecase bcnx
(:bcnb (push (term cffc ibicn) (:bcnb (push (term cffc ibicn)
listb)) listb))
(:bcnc (push (term cffc ibicn) (:bcnc (push (term cffc ibicn)
listc)) listc))
(:bcnd (push (term cffc ibicn) (:bcnd (push (term cffc ibicn)
listd)))))) listd))))))
(values (values
(make-cmbn :degr degr :list (nreverse listb)) (make-cmbn :degr degr :list (nreverse listb))
(make-cmbn :degr (1+ degr) :list (nreverse listc)) (make-cmbn :degr (1+ degr) :list (nreverse listc))
(make-cmbn :degr degr :list (nreverse listd))))))) (make-cmbn :degr degr :list (nreverse listd)))))))
(DEFUN BICN-CMBN-CMBNB (cmbn) (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." is empty, the null combination of degree n in B is returned."
(the cmbn (the cmbn
(with-cmbn (degr list) cmbn (with-cmbn (degr list) cmbn
(make-cmbn (make-cmbn
:degr degr :degr degr
:list (do ((rslt +empty-list+) :list (do ((rslt +empty-list+)
(mark list (cdr mark))) (mark list (cdr mark)))
((endp mark) (nreverse rslt)) ((endp mark) (nreverse rslt))
(declare (list rslt mark)) (declare (list rslt mark))
(with--term (cffc bicn) mark (with--term (cffc bicn) mark
(with-bicn (bcnx gnrtB) bicn (with-bicn (bcnx gnrtB) bicn
(if (eq bcnx :bcnB) (if (eq bcnx :bcnB)
(push (term cffc gnrtB) (push (term cffc gnrtB)
rslt) rslt)
(return (return
(nreverse rslt)))))))))) (nreverse rslt))))))))))
(DEFUN BICN-CMBN-CMBNC (cmbn) (DEFUN BICN-CMBN-CMBNC (cmbn)
(declare (type cmbn 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." is empty, the null combination of degree n+1 in C is returned."
(the cmbn (the cmbn
(with-cmbn (degr list) cmbn (with-cmbn (degr list) cmbn
(make-cmbn (make-cmbn
:degr (1+ degr) :degr (1+ degr)
:list (do ((rslt +empty-list+) :list (do ((rslt +empty-list+)
(mark (member :bcnc list (mark (member :bcnc list
;; Correction 1-1-2 ;; Correction 1-1-2
:key #'(lambda (term) :key #'(lambda (term)
(declare (type term term)) (declare (type term term))
(bcnx (gnrt term)))) (bcnx (gnrt term))))
(cdr mark))) (cdr mark)))
((endp mark) (nreverse rslt)) ((endp mark) (nreverse rslt))
(declare (list rslt mark)) (declare (list rslt mark))
(with--term (cffc bicn) mark (with--term (cffc bicn) mark
(with-bicn (bcnx gnrtC) bicn (with-bicn (bcnx gnrtC) bicn
(if (eq bcnx :bcnC) (if (eq bcnx :bcnC)
(push (term cffc gnrtC) (push (term cffc gnrtC)
rslt) rslt)
(return (return
(nreverse rslt)))))))))) (nreverse rslt))))))))))
(DEFUN BICN-CMBN-CMBND (cmbn) (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." is empty, the null combination of degree n in D is returned."
(the cmbn (the cmbn
(with-cmbn (degr list) cmbn (with-cmbn (degr list) cmbn
(make-cmbn (make-cmbn
:degr degr :degr degr
:list (mapcar :list (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (cffc bicn) term (with-term (cffc bicn) term
(term cffc (ibicn bicn)))) (term cffc (ibicn bicn))))
(member (member
:bcnd list :bcnd list
:key #'(lambda (term) :key #'(lambda (term)
(declare (type term term)) (declare (type term term))
(the keyword (bcnx (gnrt term)))))))))) (the keyword (bcnx (gnrt term))))))))))
(DEFUN MAKE-BICN-CMBN (cmbnb cmbnc cmbnd) (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." CMBNC must be of degree n+1, yiedling a bicone combination of degree n."
(the cmbn (the cmbn
(with-cmbn (with-cmbn
(degrb listb) cmbnb (degrb listb) cmbnb
(with-cmbn (with-cmbn
(degrc listc) cmbnc (degrc listc) cmbnc
(with-cmbn (with-cmbn
(degrd listd) cmbnd (degrd listd) cmbnd
(unless (= degrb (1- degrc) degrd) (unless (= degrb (1- degrc) degrd)
(error "In MAKE-BICN-CMBN, the degrees are not coherent.")) (error "In MAKE-BICN-CMBN, the degrees are not coherent."))
(make-cmbn (make-cmbn
:degr degrb :degr degrb
:list (nconc :list (nconc
(mapcar #'(lambda (termb) (mapcar #'(lambda (termb)
(declare (type term termb)) (declare (type term termb))
(with-term (cffc gnrtb) termb (with-term (cffc gnrtb) termb
(term cffc (bcnb gnrtb)))) (term cffc (bcnb gnrtb))))
listb) listb)
(mapcar #'(lambda (termc) (mapcar #'(lambda (termc)
(declare (type term termc)) (declare (type term termc))
(with-term (cffc gnrtc) termc (with-term (cffc gnrtc) termc
(term cffc (bcnc gnrtc)))) (term cffc (bcnc gnrtc))))
listc) listc)
(mapcar #'(lambda (termd) (mapcar #'(lambda (termd)
(declare (type term termd)) (declare (type term termd))
(with-term (cffc gnrtd) termd (with-term (cffc gnrtd) termd
(term cffc (bcnd gnrtd)))) (term cffc (bcnd gnrtd))))
listd)))))))) listd))))))))
(DEFUN BICN-PRINT (bicn stream depth) (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)) (ignore depth))
(the bicn (the bicn
(with-bicn (bcnx ibicn) bicn (with-bicn (bcnx ibicn) bicn
;; Correction 1-1-2 ;; Correction 1-1-2
(format stream "<Bcn~A ~A>" (format stream "<Bcn~A ~A>"
;; Correction 1-1-3 ;; Correction 1-1-3
(ecase bcnx (:bcnb #\B) (:bcnc #\C) (:bcnd #\D)) (ecase bcnx (:bcnb #\B) (:bcnc #\C) (:bcnd #\D))
ibicn) ibicn)
bicn))) bicn)))
(DEFUN BICONE-CMPR (cmprb cmprc cmprd) (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 generators, which is contructed from the comparison functions CMPRB, CMPRC
and CMPRD." and CMPRD."
(flet ((rslt (bicn1 bicn2) (flet ((rslt (bicn1 bicn2)
(declare (type bicn bicn1 bicn2)) (declare (type bicn bicn1 bicn2))
(let ((bcnx1 (bcnx bicn1))) (let ((bcnx1 (bcnx bicn1)))
(declare (type (member :bcnb :bcnc :bcnd) bcnx1)) (declare (type (member :bcnb :bcnc :bcnd) bcnx1))
(lexico (lexico
(s-cmpr bcnx1 (bcnx bicn2)) (s-cmpr bcnx1 (bcnx bicn2))
(case bcnx1 (case bcnx1
(:bcnb (funcall cmprb (ibicn bicn1) (ibicn bicn2))) (:bcnb (funcall cmprb (ibicn bicn1) (ibicn bicn2)))
(:bcnc (funcall cmprc (ibicn bicn1) (ibicn bicn2))) (:bcnc (funcall cmprc (ibicn bicn1) (ibicn bicn2)))
(:bcnd (funcall cmprd (ibicn bicn1) (ibicn bicn2)))))))) (:bcnd (funcall cmprd (ibicn bicn1) (ibicn bicn2))))))))
(the cmprf #'rslt))) (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." locally effective, the function returns the symbol :locally-effective."
(the basis (the basis
(if (or (eq :locally-effective basisb) (if (or (eq :locally-effective basisb)
(eq :locally-effective basisc) (eq :locally-effective basisc)
(eq :locally-effective basisd)) (eq :locally-effective basisd))
:locally-effective :locally-effective
(flet ((rslt (degr) (flet ((rslt (degr)
(declare (fixnum degr)) (declare (fixnum degr))
(append (append
(mapcar #'(lambda (item) (mapcar #'(lambda (item)
(declare (type gnrt item)) (declare (type gnrt item))
(bcnb item)) (bcnb item))
(funcall basisb degr)) (funcall basisb degr))
(mapcar #'(lambda (item) (mapcar #'(lambda (item)
(declare (type gnrt item)) (declare (type gnrt item))
(bcnc item)) (bcnc item))
(funcall basisc (1+ degr))) (funcall basisc (1+ degr)))
(mapcar #'(lambda (item) (mapcar #'(lambda (item)
(declare (type gnrt item)) (declare (type gnrt item))
(bcnd item)) (bcnd item))
(funcall basisd degr))))) (funcall basisd degr)))))
(the basis #'rslt))))) (the basis #'rslt)))))
(DEFUN BICONE-INTR-DFFR (cmprc dffrb dffrc dffrd f1 f2) (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)) (type morphism dffrb dffrc dffrd f1 f2))
"(BICONE-INTR-DFFR CMPRC DFFRB DFFRC DFFRD F1 F2) " "(BICONE-INTR-DFFR CMPRC DFFRB DFFRC DFFRD F1 F2) "
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(multiple-value-bind (cmbnb cmbnc cmbnd) (multiple-value-bind (cmbnb cmbnc cmbnd)
(dispatch-bicn-cmbn cmbn) (dispatch-bicn-cmbn cmbn)
(declare (type cmbn cmbnb cmbnc cmbnd)) (declare (type cmbn cmbnb cmbnc cmbnd))
(let ((dffrb (cmbn-? dffrb cmbnb)) (let ((dffrb (cmbn-? dffrb cmbnb))
(dffrc (cmbn-? dffrc cmbnc)) (dffrc (cmbn-? dffrc cmbnc))
(dffrd (cmbn-? dffrd cmbnd)) (dffrd (cmbn-? dffrd cmbnd))
(f1 (cmbn-? f1 cmbnb)) (f1 (cmbn-? f1 cmbnb))
(f2 (cmbn-? f2 cmbnd))) (f2 (cmbn-? f2 cmbnd)))
(declare (type cmbn dffrb dffrc dffrd f1 f2)) (declare (type cmbn dffrb dffrc dffrd f1 f2))
(let ((cmbnc (2cmbn-sbtr cmprc (let ((cmbnc (2cmbn-sbtr cmprc
(2cmbn-add cmprc f1 f2) (2cmbn-add cmprc f1 f2)
dffrc))) dffrc)))
(declare (type cmbn cmbnc)) (declare (type cmbn cmbnc))
(make-bicn-cmbn dffrb cmbnc dffrd))))))) (make-bicn-cmbn dffrb cmbnc dffrd)))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
@ -232,149 +234,149 @@ same, and C is that chain complex."
(the chain-complex (the chain-complex
(with-slots ((tcc1 tcc) (bcc1 bcc) (f1 f)) rdct1 (with-slots ((tcc1 tcc) (bcc1 bcc) (f1 f)) rdct1
(declare (declare
(type chain-complex tcc1 bcc1) (type chain-complex tcc1 bcc1)
(type morphism f1)) (type morphism f1))
(with-slots ((tcc2 tcc) (bcc2 bcc) (f2 f)) rdct2 (with-slots ((tcc2 tcc) (bcc2 bcc) (f2 f)) rdct2
(declare (declare
(type chain-complex tcc2 bcc2) (type chain-complex tcc2 bcc2)
(type morphism f2)) (type morphism f2))
(unless (eq bcc1 bcc2) (unless (eq bcc1 bcc2)
(error "In BICONE, both reductions have different BCC's.")) (error "In BICONE, both reductions have different BCC's."))
(let ((rslt (build-chcm (let ((rslt (build-chcm
:cmpr (bicone-cmpr (cmpr tcc1) (cmpr bcc1) (cmpr tcc2)) :cmpr (bicone-cmpr (cmpr tcc1) (cmpr bcc1) (cmpr tcc2))
:basis (bicone-basis (basis tcc1) (basis bcc1) :basis (bicone-basis (basis tcc1) (basis bcc1)
(basis tcc2)) (basis tcc2))
:bsgn :undefined :bsgn :undefined
:intr-dffr (bicone-intr-dffr (cmpr bcc1) :intr-dffr (bicone-intr-dffr (cmpr bcc1)
(dffr tcc1) (dffr bcc1) (dffr tcc1) (dffr bcc1)
(dffr tcc2) (dffr tcc2)
f1 f2) f1 f2)
:strt :cmbn :strt :cmbn
:orgn `(bicone ,rdct1 ,rdct2)))) :orgn `(bicone ,rdct1 ,rdct2))))
(declare (type chain-complex rslt)) (declare (type chain-complex rslt))
; (slot-makunbound rslt 'bsgn) ; (slot-makunbound rslt 'bsgn)
rslt))))) rslt)))))
(DEFMETHOD CMPS ((hmeq1 homotopy-equivalence) (hmeq2 homotopy-equivalence) (DEFMETHOD CMPS ((hmeq1 homotopy-equivalence) (hmeq2 homotopy-equivalence)
&optional dummy) &optional dummy)
(declare (ignore dummy)) (declare (ignore dummy))
"(CMPS HMEQ1 HMEQ2 &OPTIONAL DUMMY) constructs a homotopy equivalence "(CMPS HMEQ1 HMEQ2 &OPTIONAL DUMMY) constructs a homotopy equivalence
by composition of the homotopy equivalences HMEQ1 and HMEQ2." by composition of the homotopy equivalences HMEQ1 and HMEQ2."
(the homotopy-equivalence (the homotopy-equivalence
(progn (progn
(when (eq 'trivial-hmeq (orgn hmeq2)) (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) (with-slots ((cc-A lbcc) (cc-B tcc) (cc-C rbcc)
(f1 lf) (g1 lg) (h1 lh) (f2 rf) (g2 rg) (h2 rh)) hmeq1 (f1 lf) (g1 lg) (h1 lh) (f2 rf) (g2 rg) (h2 rh)) hmeq1
(declare (declare
(type chain-complex cc-A cc-B cc-C) (type chain-complex cc-A cc-B cc-C)
(type morphism f1 g1 h1 f2 g2 h2)) (type morphism f1 g1 h1 f2 g2 h2))
(with-slots ((cc-C2 lbcc) (cc-D tcc) (cc-E rbcc) (with-slots ((cc-C2 lbcc) (cc-D tcc) (cc-E rbcc)
(f3 lf) (g3 lg) (h3 lh) (f4 rf) (g4 rg) (h4 rh)) hmeq2 (f3 lf) (g3 lg) (h3 lh) (f4 rf) (g4 rg) (h4 rh)) hmeq2
(declare (declare
(type chain-complex cc-C2 cc-D cc-E) (type chain-complex cc-C2 cc-D cc-E)
(type morphism f3 g3 h3 f4 g4 h4)) (type morphism f3 g3 h3 f4 g4 h4))
(unless (eq (grmd cc-C) (grmd cc-C2)) (unless (eq (grmd cc-C) (grmd cc-C2))
(error "In (CMPS HMEQ HMEQ), both hmeq's may not be composed.")) (error "In (CMPS HMEQ HMEQ), both hmeq's may not be composed."))
(let ((bicone (bicone (rrdct hmeq1) (lrdct hmeq2))) (let ((bicone (bicone (rrdct hmeq1) (lrdct hmeq2)))
(cmpr-B (cmpr cc-B)) (cmpr-B (cmpr cc-B))
(cmpr-D (cmpr cc-D))) (cmpr-D (cmpr cc-D)))
(declare (type chain-complex bicone)) (declare (type chain-complex bicone))
(let ((lf (build-mrph (let ((lf (build-mrph
:sorc bicone :trgt cc-A :degr 0 :sorc bicone :trgt cc-A :degr 0
:intr #'(lambda (cmbn) :intr #'(lambda (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(cmbn-? f1 (bicn-cmbn-cmbnB cmbn))) (cmbn-? f1 (bicn-cmbn-cmbnB cmbn)))
:strt :cmbn :strt :cmbn
:orgn `(cmps ,hmeq1 ,hmeq2 lf))) :orgn `(cmps ,hmeq1 ,hmeq2 lf)))
(lg (build-mrph (lg (build-mrph
:sorc cc-A :trgt bicone :degr 0 :sorc cc-A :trgt bicone :degr 0
:intr #'(lambda (cmbn) :intr #'(lambda (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(let* ((cmbnB (cmbn-? g1 cmbn)) (let* ((cmbnB (cmbn-? g1 cmbn))
(cmbnC (zero-cmbn (cmbnC (zero-cmbn
(1+ (cmbn-degr cmbn)))) (1+ (cmbn-degr cmbn))))
(cmbnD (cmbn-? g3 (cmbnD (cmbn-? g3
(cmbn-? f2 (cmbn-? f2
(cmbn-opps (cmbn-opps
cmbnB))))) cmbnB)))))
(declare (type cmbn cmbnB cmbnC cmbnD)) (declare (type cmbn cmbnB cmbnC cmbnD))
(make-bicn-cmbn cmbnB cmbnC cmbnD))) (make-bicn-cmbn cmbnB cmbnC cmbnD)))
:strt :cmbn :strt :cmbn
:orgn `(cmps ,hmeq1 ,hmeq2 lg))) :orgn `(cmps ,hmeq1 ,hmeq2 lg)))
(lh (build-mrph (lh (build-mrph
:sorc bicone :trgt bicone :degr +1 :sorc bicone :trgt bicone :degr +1
:intr #'(lambda (cmbn) :intr #'(lambda (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(multiple-value-bind (cmbnB cmbnC cmbnD) (multiple-value-bind (cmbnB cmbnC cmbnD)
(dispatch-bicn-cmbn cmbn) (dispatch-bicn-cmbn cmbn)
(declare (type cmbn cmbnB cmbnC cmbnD)) (declare (type cmbn cmbnB cmbnC cmbnD))
(setf cmbnB (cmbn-? h1 cmbnB)) (setf cmbnB (cmbn-? h1 cmbnB))
(let ((cmbnC (zero-cmbn (let ((cmbnC (zero-cmbn
(1+ (cmbn-degr cmbnC)))) (1+ (cmbn-degr cmbnC))))
(cmbnD1 (cmbn-? g3 (cmbnD1 (cmbn-? g3
(cmbn-? f2 cmbnB))) (cmbn-? f2 cmbnB)))
(cmbnD2 (cmbn-? g3 cmbnC)) ;; let, not let* (cmbnD2 (cmbn-? g3 cmbnC)) ;; let, not let*
(cmbnD3 (cmbn-? h3 cmbnD))) (cmbnD3 (cmbn-? h3 cmbnD)))
(declare (type cmbn cmbnC cmbnD1 cmbnD2 (declare (type cmbn cmbnC cmbnD1 cmbnD2
cmbnD3)) cmbnD3))
(make-bicn-cmbn (make-bicn-cmbn
cmbnB cmbnB
cmbnC cmbnC
(2cmbn-sbtr cmpr-D (2cmbn-sbtr cmpr-D
(2cmbn-add cmpr-D cmbnD2 (2cmbn-add cmpr-D cmbnD2
cmbnD3) cmbnD3)
cmbnD1))))) cmbnD1)))))
:strt :cmbn :strt :cmbn
:orgn `(cmps ,hmeq1 ,hmeq2 lh))) :orgn `(cmps ,hmeq1 ,hmeq2 lh)))
(rf (build-mrph (rf (build-mrph
:sorc bicone :trgt cc-E :degr 0 :sorc bicone :trgt cc-E :degr 0
:intr #'(lambda (cmbn) :intr #'(lambda (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(cmbn-? f4 (bicn-cmbn-cmbnD cmbn))) (cmbn-? f4 (bicn-cmbn-cmbnD cmbn)))
:strt :cmbn :strt :cmbn
:orgn `(cmps ,hmeq1 ,hmeq2 rf))) :orgn `(cmps ,hmeq1 ,hmeq2 rf)))
(rg (build-mrph (rg (build-mrph
:sorc cc-E :trgt bicone :degr 0 :sorc cc-E :trgt bicone :degr 0
:intr #'(lambda (cmbn) :intr #'(lambda (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(let* ((cmbnD (cmbn-? g4 cmbn)) (let* ((cmbnD (cmbn-? g4 cmbn))
(cmbnC (zero-cmbn (cmbnC (zero-cmbn
(1+ (cmbn-degr cmbn)))) (1+ (cmbn-degr cmbn))))
(cmbnB (cmbnB
(cmbn-? (cmbn-?
g2 (cmbn-? f3 (cmbn-opps cmbnD))))) g2 (cmbn-? f3 (cmbn-opps cmbnD)))))
(declare (type cmbn cmbnD cmbnC cmbnB)) (declare (type cmbn cmbnD cmbnC cmbnB))
(make-bicn-cmbn cmbnB cmbnC cmbnD))) (make-bicn-cmbn cmbnB cmbnC cmbnD)))
:strt :cmbn :strt :cmbn
:orgn `(cmps ,hmeq1 ,hmeq2 rg))) :orgn `(cmps ,hmeq1 ,hmeq2 rg)))
(rh (build-mrph (rh (build-mrph
:sorc bicone :trgt bicone :degr +1 :sorc bicone :trgt bicone :degr +1
:intr #'(lambda (cmbn) :intr #'(lambda (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(multiple-value-bind (cmbnB cmbnC cmbnD) (multiple-value-bind (cmbnB cmbnC cmbnD)
(dispatch-bicn-cmbn cmbn) (dispatch-bicn-cmbn cmbn)
(declare (type cmbn cmbnB cmbnC cmbnD)) (declare (type cmbn cmbnB cmbnC cmbnD))
(setf cmbnD (cmbn-? h4 cmbnD)) (setf cmbnD (cmbn-? h4 cmbnD))
(let ((cmbnC (zero-cmbn (let ((cmbnC (zero-cmbn
(1+ (cmbn-degr cmbnC)))) (1+ (cmbn-degr cmbnC))))
(cmbnB1 (cmbn-? g2 (cmbnB1 (cmbn-? g2
(cmbn-? f3 cmbnD))) (cmbn-? f3 cmbnD)))
(cmbnB2 (cmbn-? g2 cmbnC)) ;; let, not let* (cmbnB2 (cmbn-? g2 cmbnC)) ;; let, not let*
(cmbnB3 (cmbn-? h2 cmbnB))) (cmbnB3 (cmbn-? h2 cmbnB)))
(declare (type cmbn cmbnC cmbnB1 cmbnB2 (declare (type cmbn cmbnC cmbnB1 cmbnB2
cmbnB3)) cmbnB3))
(make-bicn-cmbn (make-bicn-cmbn
(2cmbn-sbtr cmpr-B (2cmbn-sbtr cmpr-B
(2cmbn-add cmpr-B cmbnB2 (2cmbn-add cmpr-B cmbnB2
cmbnB3) cmbnB3)
cmbnB1) cmbnB1)
cmbnC cmbnC
cmbnD)))) cmbnD))))
:strt :cmbn :strt :cmbn
:orgn `(cmps ,hmeq1 ,hmeq2 rh)))) :orgn `(cmps ,hmeq1 ,hmeq2 rh))))
(declare (declare
(type morphism lf lg lh rf rg rh)) (type morphism lf lg lh rf rg rh))
(build-hmeq :lf lf :lg lg :lh lh :rf rf :rg rg :rh rh (build-hmeq :lf lf :lg lg :lh lh :rf rf :rg rg :rh rh
:orgn `(cmps ,hmeq1 ,hmeq2))))))))) :orgn `(cmps ,hmeq1 ,hmeq2)))))))))

260
src/cartesian-products.lisp
View File

@ -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 ;;; 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)) (ignore depth))
(with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr (with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr
(format stream "<CrPr ~A ~A ~A ~A>" (format stream "<CrPr ~A ~A ~A ~A>"
(hyphenize-list (dgop-int-ext dgop1)) gmsm1 (hyphenize-list (dgop-int-ext dgop1)) gmsm1
(hyphenize-list (dgop-int-ext dgop2)) gmsm2) (hyphenize-list (dgop-int-ext dgop2)) gmsm2)
crpr)) crpr))
@ -24,11 +26,11 @@
(let ((dgop (logand dgop1 dgop2))) (let ((dgop (logand dgop1 dgop2)))
(declare (fixnum dgop)) (declare (fixnum dgop))
(do ((indx (1- (integer-length dgop)) (1- indx))) (do ((indx (1- (integer-length dgop)) (1- indx)))
((minusp indx)) ((minusp indx))
(declare (fixnum indx)) (declare (fixnum indx))
(when (logbitp indx dgop) (when (logbitp indx dgop)
(setf dgop1 (remove-bit dgop1 indx) (setf dgop1 (remove-bit dgop1 indx)
dgop2 (remove-bit dgop2 indx)))) dgop2 (remove-bit dgop2 indx))))
(values dgop dgop1 dgop2))) (values dgop dgop1 dgop2)))
@ -36,128 +38,128 @@
(declare (type absm absm1 absm2)) (declare (type absm absm1 absm2))
(the absm (the absm
(with-absm (dgop1 gmsm1) absm1 (with-absm (dgop1 gmsm1) absm1
(with-absm (dgop2 gmsm2) absm2 (with-absm (dgop2 gmsm2) absm2
(multiple-value-bind (dgop dgop11 dgop22) (multiple-value-bind (dgop dgop11 dgop22)
(extract-common-dgop dgop1 dgop2) (extract-common-dgop dgop1 dgop2)
(declare (fixnum dgop dgop11 dgop22)) (declare (fixnum dgop dgop11 dgop22))
(absm dgop (absm dgop
(crpr dgop11 gmsm1 dgop22 gmsm2))))))) (crpr dgop11 gmsm1 dgop22 gmsm2)))))))
#| #|
(DEFUN CRTS-PRDC-CMPR (cmpr1 cmpr2) (DEFUN CRTS-PRDC-CMPR (cmpr1 cmpr2)
(declare (type cmprf cmpr1 cmpr2)) (declare (type cmprf cmpr1 cmpr2))
(flet ((rslt (crpr1 crpr2) (flet ((rslt (crpr1 crpr2)
(declare (type crpr crpr1 crpr2)) (declare (type crpr crpr1 crpr2))
(the cmpr (the cmpr
(let ((left-cons-1 (cadr crpr1)) (let ((left-cons-1 (cadr crpr1))
(left-cons-2 (cadr crpr2))) (left-cons-2 (cadr crpr2)))
(declare (cons left-cons-1 left-cons-2)) (declare (cons left-cons-1 left-cons-2))
(lexico (lexico
(f-cmpr (car left-cons-1) (car left-cons-2)) (f-cmpr (car left-cons-1) (car left-cons-2))
(let ((right-cons-1 (cddr crpr1)) (let ((right-cons-1 (cddr crpr1))
(right-cons-2 (cddr crpr2))) (right-cons-2 (cddr crpr2)))
(declare (cons right-cons-1 right-cons-2)) (declare (cons right-cons-1 right-cons-2))
(lexico (lexico
(f-cmpr (car right-cons-1) (car right-cons-2)) (f-cmpr (car right-cons-1) (car right-cons-2))
(funcall cmpr1 (cdr left-cons-1) (cdr left-cons-2)) (funcall cmpr1 (cdr left-cons-1) (cdr left-cons-2))
(funcall cmpr2 (cdr right-cons-1) (cdr right-cons-2))))))))) (funcall cmpr2 (cdr right-cons-1) (cdr right-cons-2)))))))))
(the cmprf #'rslt))) (the cmprf #'rslt)))
|# |#
(DEFUN CRTS-PRDC-CMPR (cmpr1 cmpr2) (DEFUN CRTS-PRDC-CMPR (cmpr1 cmpr2)
(declare (type cmprf cmpr1 cmpr2)) (declare (type cmprf cmpr1 cmpr2))
(flet ((rslt (crpr1 crpr2) (flet ((rslt (crpr1 crpr2)
(declare (type crpr crpr1 crpr2)) (declare (type crpr crpr1 crpr2))
(the cmpr (the cmpr
(lexico (lexico
(f-cmpr (dgop1 crpr1) (dgop1 crpr2)) (f-cmpr (dgop1 crpr1) (dgop1 crpr2))
(f-cmpr (dgop2 crpr1) (dgop2 crpr2)) (f-cmpr (dgop2 crpr1) (dgop2 crpr2))
(funcall cmpr1 (gmsm1 crpr1) (gmsm1 crpr2)) (funcall cmpr1 (gmsm1 crpr1) (gmsm1 crpr2))
(funcall cmpr2 (gmsm2 crpr1) (gmsm2 crpr2)))))) (funcall cmpr2 (gmsm2 crpr1) (gmsm2 crpr2))))))
(the cmprf #'rslt))) (the cmprf #'rslt)))
(DEFUN CRTS-PRDC-BASIS (basis1 basis2) (DEFUN CRTS-PRDC-BASIS (basis1 basis2)
(declare (type basis basis1 basis2)) (declare (type basis basis1 basis2))
(when (or (eq basis1 :locally-effective) (when (or (eq basis1 :locally-effective)
(eq basis2 :locally-effective)) (eq basis2 :locally-effective))
(return-from crts-prdc-basis :locally-effective)) (return-from crts-prdc-basis :locally-effective))
(flet ((rslt (dmns) (flet ((rslt (dmns)
(declare (fixnum dmns)) (declare (fixnum dmns))
(the list (the list
(progn (progn
(when (minusp dmns) (when (minusp dmns)
(return-from rslt +empty-list+)) (return-from rslt +empty-list+))
(let ((array1 (make-array (1+ dmns))) (let ((array1 (make-array (1+ dmns)))
(array2 (make-array (1+ dmns))) (array2 (make-array (1+ dmns)))
(rslt +empty-list+) (rslt +empty-list+)
(mask (mask dmns))) (mask (mask dmns)))
(declare (declare
(simple-vector array1 array2) (simple-vector array1 array2)
(list rslt) (list rslt)
(fixnum mask)) (fixnum mask))
(dotimes (i (1+ dmns)) (dotimes (i (1+ dmns))
(setf (svref array1 i) (funcall basis1 i) (setf (svref array1 i) (funcall basis1 i)
(svref array2 i) (funcall basis2 i))) (svref array2 i) (funcall basis2 i)))
(do ((dgop1 mask (1- dgop1))) (do ((dgop1 mask (1- dgop1)))
((minusp dgop1)) ((minusp dgop1))
(declare (fixnum dgop1)) (declare (fixnum dgop1))
(let ((dmns1 (- dmns (logcount dgop1)))) (let ((dmns1 (- dmns (logcount dgop1))))
(declare (fixnum dmns1)) (declare (fixnum dmns1))
(do ((dgop2 mask (1- dgop2))) (do ((dgop2 mask (1- dgop2)))
((minusp dgop2)) ((minusp dgop2))
(declare (fixnum dgop2)) (declare (fixnum dgop2))
(unless (plusp (logand dgop1 dgop2)) (unless (plusp (logand dgop1 dgop2))
(setf rslt (setf rslt
(nconc (nconc
(mapcan (mapcan
#'(lambda (item1) #'(lambda (item1)
(declare (type gmsm item1)) (declare (type gmsm item1))
(mapcar (mapcar
#'(lambda (item2) #'(lambda (item2)
(declare (type gmsm item2)) (declare (type gmsm item2))
(crpr dgop1 item1 dgop2 item2)) (crpr dgop1 item1 dgop2 item2))
(svref array2 (- dmns (svref array2 (- dmns
(logcount dgop2))))) (logcount dgop2)))))
(svref array1 dmns1)) (svref array1 dmns1))
rslt)))))) rslt))))))
rslt))))) rslt)))))
(the basis #'rslt))) (the basis #'rslt)))
(DEFUN CRTS-PRDC-FACE (face1 face2) (DEFUN CRTS-PRDC-FACE (face1 face2)
(declare (type face face1 face2)) (declare (type face face1 face2))
(flet ((rslt (indx dmns crpr) (flet ((rslt (indx dmns crpr)
(declare (declare
(fixnum indx dmns) (fixnum indx dmns)
(type crpr crpr)) (type crpr crpr))
(with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr (with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr
(multiple-value-bind (dgop1 del1) (1dlop-dgop indx dgop1) (multiple-value-bind (dgop1 del1) (1dlop-dgop indx dgop1)
(declare (declare
(fixnum dgop1) (fixnum dgop1)
(type (or null fixnum) del1)) (type (or null fixnum) del1))
(multiple-value-bind (dgop2 del2) (1dlop-dgop indx (multiple-value-bind (dgop2 del2) (1dlop-dgop indx
dgop2) dgop2)
(declare (declare
(fixnum dgop2) (fixnum dgop2)
(type (or null fixnum) del2)) (type (or null fixnum) del2))
(when del1 (when del1
(let ((absm1 (funcall face1 del1 (- dmns (logcount (let ((absm1 (funcall face1 del1 (- dmns (logcount
dgop1)) dgop1))
gmsm1))) gmsm1)))
(declare (type absm absm1)) (declare (type absm absm1))
(setf dgop1 (dgop*dgop dgop1 (dgop absm1)) (setf dgop1 (dgop*dgop dgop1 (dgop absm1))
gmsm1 (gmsm absm1)))) gmsm1 (gmsm absm1))))
(when del2 (when del2
(let ((absm2 (funcall face2 del2 (- dmns (logcount (let ((absm2 (funcall face2 del2 (- dmns (logcount
dgop2)) dgop2))
gmsm2))) gmsm2)))
(declare (type absm absm2)) (declare (type absm absm2))
(setf dgop2 (dgop*dgop dgop2 (dgop absm2)) (setf dgop2 (dgop*dgop dgop2 (dgop absm2))
gmsm2 (gmsm absm2)))) gmsm2 (gmsm absm2))))
(multiple-value-bind (dgop dgop1 dgop2) (multiple-value-bind (dgop dgop1 dgop2)
(extract-common-dgop dgop1 dgop2) (extract-common-dgop dgop1 dgop2)
(declare (fixnum dgop dgop1 dgop2)) (declare (fixnum dgop dgop1 dgop2))
(absm dgop (crpr dgop1 gmsm1 dgop2 gmsm2)))))))) (absm dgop (crpr dgop1 gmsm1 dgop2 gmsm2))))))))
(the face #'rslt))) (the face #'rslt)))
@ -166,36 +168,36 @@
(DEFUN CRTS-PRDC-FACE* (face1 face2) (DEFUN CRTS-PRDC-FACE* (face1 face2)
(declare (type face face1 face2)) (declare (type face face1 face2))
(flet ((rslt (indx dmns crpr) (flet ((rslt (indx dmns crpr)
(declare (declare
(fixnum indx dmns) (fixnum indx dmns)
(type crpr crpr)) (type crpr crpr))
(with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr (with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr
(multiple-value-bind (dgop1 del1) (1dlop-dgop indx dgop1) (multiple-value-bind (dgop1 del1) (1dlop-dgop indx dgop1)
(declare (declare
(fixnum dgop1) (fixnum dgop1)
(type (or null fixnum) del1)) (type (or null fixnum) del1))
(multiple-value-bind (dgop2 del2) (1dlop-dgop indx (multiple-value-bind (dgop2 del2) (1dlop-dgop indx
dgop2) dgop2)
(declare (declare
(fixnum dgop2) (fixnum dgop2)
(type (or null fixnum) del2)) (type (or null fixnum) del2))
(when del1 (when del1
(let ((absm1 (funcall face1 del1 (- dmns (logcount (let ((absm1 (funcall face1 del1 (- dmns (logcount
dgop1)) dgop1))
gmsm1))) gmsm1)))
(declare (type absm absm1)) (declare (type absm absm1))
(setf dgop1 (dgop*dgop dgop1 (dgop absm1)) (setf dgop1 (dgop*dgop dgop1 (dgop absm1))
gmsm1 (gmsm absm1)))) gmsm1 (gmsm absm1))))
(when del2 (when del2
(let ((absm2 (funcall face2 del2 (- dmns (logcount (let ((absm2 (funcall face2 del2 (- dmns (logcount
dgop2)) dgop2))
gmsm2))) gmsm2)))
(declare (type absm absm2)) (declare (type absm absm2))
(setf dgop2 (dgop*dgop dgop2 (dgop absm2)) (setf dgop2 (dgop*dgop dgop2 (dgop absm2))
gmsm2 (gmsm absm2)))) gmsm2 (gmsm absm2))))
(if (plusp (logand dgop1 dgop2)) (if (plusp (logand dgop1 dgop2))
:degenerate :degenerate
(crpr dgop1 gmsm1 dgop2 gmsm2))))))) (crpr dgop1 gmsm1 dgop2 gmsm2)))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
@ -212,7 +214,7 @@
(type basis basis2) (type basis basis2)
(type face face2)) (type face face2))
(the simplicial-set (the simplicial-set
(build-smst (build-smst
:cmpr (crts-prdc-cmpr cmpr1 cmpr2) :cmpr (crts-prdc-cmpr cmpr1 cmpr2)
:basis (crts-prdc-basis basis1 basis2) :basis (crts-prdc-basis basis1 basis2)
:bspn (crpr 0 bspn1 0 bspn2) :bspn (crpr 0 bspn1 0 bspn2)

105
src/cat-init.lisp
View File

@ -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 ;;; 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))) (PROCLAIM '(OPTIMIZE (speed 3) (safety 1) (space 0) (debug 0)))
(DEFCONSTANT +FILE-LIST+ (DEFCONSTANT +FILE-LIST+
'("kenzo" '("kenzo"
"macros" "macros"
"various" "various"
"classes" "classes"
"combinations" "combinations"
"chain-complexes" "chain-complexes"
"chcm-elementary-op" "chcm-elementary-op"
"effective-homology" "effective-homology"
"homology-groups" "homology-groups"
"searching-homology" "searching-homology"
"cones" "cones"
"bicones" "bicones"
"tensor-products" "tensor-products"
"coalgebras" "coalgebras"
"cobar" "cobar"
"algebras" "algebras"
"bar" "bar"
"simplicial-sets" "simplicial-sets"
"simplicial-mrphs" "simplicial-mrphs"
"delta" "delta"
"special-smsts" "special-smsts"
"suspensions" "suspensions"
"disk-pasting" "disk-pasting"
"cartesian-products" "cartesian-products"
"eilenberg-zilber" "eilenberg-zilber"
"kan" "kan"
"simplicial-groups" "simplicial-groups"
"fibrations" "fibrations"
"loop-spaces" "loop-spaces"
"ls-twisted-products" "ls-twisted-products"
"lp-space-efhm" "lp-space-efhm"
"classifying-spaces" "classifying-spaces"
"k-pi-n" "k-pi-n"
"serre" "serre"
"cs-twisted-products" "cs-twisted-products"
"cl-space-efhm" "cl-space-efhm"
"whitehead" "whitehead"
"smith" "smith"))
))
(DO ((i 1 (1+ i)) (DO ((i 1 (1+ i))
(mark +file-list+ (cdr mark))) (mark +file-list+ (cdr mark)))
((endp mark) (terpri)) ((endp mark) (terpri))
(format t "~% FILE ~2D: ~A" i (car mark))) (format t "~% FILE ~2D: ~A" i (car mark)))
(DEFCONSTANT +SOURCE-EXTENSION+ (DEFCONSTANT +SOURCE-EXTENSION+
#+(or allegro lispworks) "cl" #+(or allegro lispworks) "cl"
#+(or clisp ccl ecl sbcl) "lisp" #+(or clisp ccl ecl sbcl) "lisp"
#-(or allegro ccl clisp ecl lispworks sbcl) #-(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+ (DEFCONSTANT +COMPILED-EXTENSION+
#+(or allegro sbcl) "fasl" #+(or allegro sbcl) "fasl"
#+ccl "lafsl" #+ccl "lafsl"
#+ (or clisp ecl) "fas" #+ (or clisp ecl) "fas"
#+lispworks "ofasl") #+lispworks "ofasl")
(DEFUN LOAD-SFILES () (DEFUN LOAD-SFILES ()
(mapc #'(lambda (file-name) (mapc #'(lambda (file-name)
(load (concatenate 'string file-name "." +source-extension+))) (load (concatenate 'string file-name "." +source-extension+)))
+file-list+)) +file-list+))
(DEFVAR *CMBN-CONTROL*) (DEFVAR *CMBN-CONTROL*)
(SETF *CMBN-CONTROL* T) (SETF *CMBN-CONTROL* T)
@ -86,9 +87,9 @@
(mapc #'(lambda (file-name) (mapc #'(lambda (file-name)
(compile-file (concatenate 'string file-name "." +source-extension+)) (compile-file (concatenate 'string file-name "." +source-extension+))
(load (concatenate 'string file-name "." +compiled-extension+))) (load (concatenate 'string file-name "." +compiled-extension+)))
+file-list+)) +file-list+))
(DEFUN LOAD-CFILES () (DEFUN LOAD-CFILES ()
(mapc #'(lambda (file-name) (mapc #'(lambda (file-name)
(load (concatenate 'string file-name "." +compiled-extension+))) (load (concatenate 'string file-name "." +compiled-extension+)))
+file-list+)) +file-list+))

2
src/chain-complexes.lisp
View File

@ -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
;;; CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES ;;; CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES

2
src/chcm-elementary-op.lisp
View File

@ -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
;;; CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP ;;; CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP

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

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

2
src/classes.lisp
View File

@ -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
;;; CLASSES CLASSES CLASSES CLASSES CLASSES CLASSES CLASSES ;;; CLASSES CLASSES CLASSES CLASSES CLASSES CLASSES CLASSES

376
src/classifying-spaces.lisp
View File

@ -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 ;;; CLASSIFYING-SPACES CLASSIFYING-SPACES CLASSIFYING-SPACES
;;; CLASSIFYING-SPACES CLASSIFYING-SPACES CLASSIFYING-SPACES ;;; CLASSIFYING-SPACES CLASSIFYING-SPACES CLASSIFYING-SPACES
@ -15,15 +17,15 @@
(ignore depth)) (ignore depth))
(the gbar (the gbar
(progn (progn
(princ "<<GBar" stream) (princ "<<GBar" stream)
(dolist (absm (gbar-list gbar)) (dolist (absm (gbar-list gbar))
(declare (type absm absm)) (declare (type absm absm))
(with-absm (dgop gmsm) absm (with-absm (dgop gmsm) absm
(format stream "<~A ~A>" (format stream "<~A ~A>"
(hyphenize-list (dgop-int-ext dgop)) (hyphenize-list (dgop-int-ext dgop))
gmsm))) gmsm)))
(princ ">>" stream) (princ ">>" stream)
gbar))) gbar)))
;;; NIGBAR = non-normalized igbar (with dimension) ;;; NIGBAR = non-normalized igbar (with dimension)
@ -31,57 +33,57 @@
(declare (list nigbar)) (declare (list nigbar))
(the absm (the absm
(let ((dmns (first nigbar)) (let ((dmns (first nigbar))
(igbar (rest nigbar))) (igbar (rest nigbar)))
(declare (declare
(fixnum dmns) (fixnum dmns)
(list igbar)) (list igbar))
(when (zerop dmns) (when (zerop dmns)
(return-from normalize-gbar (absm 0 +null-gbar+))) (return-from normalize-gbar (absm 0 +null-gbar+)))
(do ((mark igbar (cdr mark)) (do ((mark igbar (cdr mark))
(indx (1- dmns) (1- indx)) (indx (1- dmns) (1- indx))
(2-indx (2-exp (1- dmns)) (ash 2-indx -1)) (2-indx (2-exp (1- dmns)) (ash 2-indx -1))
(mask (mask (1- dmns)) (ash mask -1)) (mask (mask (1- dmns)) (ash mask -1))
(and-dgops -1 (logand and-dgops (dgop (car mark)))) (and-dgops -1 (logand and-dgops (dgop (car mark))))
;; r = result ;; r = result
(r-dgop 0) (r-dgop 0)
(r-absm-list +empty-list+)) (r-absm-list +empty-list+))
((endp mark) ((endp mark)
(absm r-dgop (absm r-dgop
(make-gbar (make-gbar
:dmns (- dmns (logcount r-dgop)) :dmns (- dmns (logcount r-dgop))
:list (nreverse r-absm-list)))) :list (nreverse r-absm-list))))
(declare (declare
(list mark r-absm-list) (list mark r-absm-list)
(fixnum indx 2-indx mask and-dgops r-dgop)) (fixnum indx 2-indx mask and-dgops r-dgop))
(when (zerop and-dgops) (when (zerop and-dgops)
(return-from normalize-gbar (return-from normalize-gbar
(absm r-dgop (absm r-dgop
(make-gbar (make-gbar
:dmns (- dmns (logcount r-dgop)) :dmns (- dmns (logcount r-dgop))
:list (nreconc r-absm-list mark))))) :list (nreconc r-absm-list mark)))))
(let ((absm (car mark))) (let ((absm (car mark)))
(with-absm (with-absm
(dgop gmsm) absm (dgop gmsm) absm
(declare (ignore gmsm)) (declare (ignore gmsm))
(if (and (= dgop mask) (if (and (= dgop mask)
(logbitp indx and-dgops)) (logbitp indx and-dgops))
(progn (progn
(incf r-dgop 2-indx) (incf r-dgop 2-indx)
(mapl (mapl
#'(lambda (sublist) #'(lambda (sublist)
(declare (list sublist)) (declare (list sublist))
(setf (car sublist) (setf (car sublist)
(let ((absm (car sublist))) (let ((absm (car sublist)))
(declare (type absm absm)) (declare (type absm absm))
(with-absm (with-absm
(dgop gmsm) absm (dgop gmsm) absm
(absm (multiple-value-bind (q r) (absm (multiple-value-bind (q r)
(floor dgop 2-indx) (floor dgop 2-indx)
(declare (fixnum q r)) (declare (fixnum q r))
(+ (ash (1- q) (1- indx)) r)) (+ (ash (1- q) (1- indx)) r))
gmsm))))) gmsm)))))
r-absm-list)) r-absm-list))
(push absm r-absm-list)))))))) (push absm r-absm-list))))))))
(DEFUN UNNORMALIZE-GBAR (absm idnt) (DEFUN UNNORMALIZE-GBAR (absm idnt)
@ -90,55 +92,55 @@
(type gmsm idnt)) (type gmsm idnt))
(the list ;; igbar (the list ;; igbar
(with-absm (dgop gbar) absm (with-absm (dgop gbar) absm
(with-gbar (dmns list) gbar (with-gbar (dmns list) gbar
(setf list (reverse list)) (setf list (reverse list))
(do ((dgop2 dgop (ash dgop2 -1)) (do ((dgop2 dgop (ash dgop2 -1))
(indx 0 (1+ indx)) (indx 0 (1+ indx))
(2-indx 1 (ash 2-indx 1)) (2-indx 1 (ash 2-indx 1))
(dgop3 0) (dgop3 0)
(rslt +empty-list+)) (rslt +empty-list+))
((zerop dgop2) ((zerop dgop2)
(cons (+ dmns (logcount dgop)) (cons (+ dmns (logcount dgop))
(nreconc (nreconc
(mapcar (mapcar
#'(lambda (absm) #'(lambda (absm)
(declare (type absm absm)) (declare (type absm absm))
(ndgnr dgop3 absm)) (ndgnr dgop3 absm))
list) list)
rslt))) rslt)))
(declare (declare
(list rslt) (list rslt)
(fixnum dgop2 2-indx dgop3)) (fixnum dgop2 2-indx dgop3))
(if (oddp dgop2) (if (oddp dgop2)
(progn (progn
(push (absm (mask indx) idnt) rslt) (push (absm (mask indx) idnt) rslt)
(incf dgop3 2-indx)) (incf dgop3 2-indx))
(push (ndgnr dgop3 (pop list)) rslt))))))) (push (ndgnr dgop3 (pop list)) rslt)))))))
(DEFUN GBAR (dmns &rest rest) (DEFUN GBAR (dmns &rest rest)
(the gbar (the gbar
(progn (progn
(unless (= (+ dmns dmns) (length rest)) (unless (= (+ dmns dmns) (length rest))
(error "In GBAR, the argument list has a wrong length.")) (error "In GBAR, the argument list has a wrong length."))
(make-gbar :dmns dmns (make-gbar :dmns dmns
:list (do ((mark rest (cddr mark)) :list (do ((mark rest (cddr mark))
(rslt +empty-list+ (rslt +empty-list+
(cons (absm (car mark) (cadr mark)) (cons (absm (car mark) (cadr mark))
rslt))) rslt)))
((endp mark) (nreverse rslt)) ((endp mark) (nreverse rslt))
(declare (list mark rslt))))))) (declare (list mark rslt)))))))
(DEFUN CLASSIFYING-SPACE-CMPR (cmpr) (DEFUN CLASSIFYING-SPACE-CMPR (cmpr)
(declare (type cmprf cmpr)) (declare (type cmprf cmpr))
(flet ((rslt (gbar1 gbar2) (flet ((rslt (gbar1 gbar2)
(declare (type gbar gbar1 gbar2)) (declare (type gbar gbar1 gbar2))
(maplexico (maplexico
#'(lambda (absm1 absm2) #'(lambda (absm1 absm2)
(declare (type absm absm1 absm2)) (declare (type absm absm1 absm2))
(a-cmpr3 cmpr absm1 absm2)) (a-cmpr3 cmpr absm1 absm2))
(gbar-list gbar1) (gbar-list gbar2)))) (gbar-list gbar1) (gbar-list gbar2))))
(the cmprf #'rslt))) (the cmprf #'rslt)))
@ -153,29 +155,29 @@
(type gmsm idnt)) (type gmsm idnt))
(labels (labels
((rslt (dmns) ((rslt (dmns)
(declare (fixnum dmns)) (declare (fixnum dmns))
(when (minusp dmns) (when (minusp dmns)
(return-from rslt +empty-list+)) (return-from rslt +empty-list+))
(when (zerop dmns) (when (zerop dmns)
(return-from rslt (list +null-gbar+))) (return-from rslt (list +null-gbar+)))
(let ((basis-1 (funcall crts-basis (1- dmns)))) (let ((basis-1 (funcall crts-basis (1- dmns))))
(declare (list basis-1)) (declare (list basis-1))
(nreverse (nreverse
(mapcar ;; xxx bug (mapcar ;; xxx bug
#'(lambda (crpr) #'(lambda (crpr)
(declare (type crpr crpr)) (declare (type crpr crpr))
(with-crpr (with-crpr
(absm1 absm2) crpr (absm1 absm2) crpr
(make-gbar (make-gbar
:dmns dmns :dmns dmns
:list (cons absm1 :list (cons absm1
(rest (unnormalize-gbar absm2 idnt)))))) (rest (unnormalize-gbar absm2 idnt))))))
(member-if ;; xxx bug (member-if ;; xxx bug
#'(lambda (dgop) #'(lambda (dgop)
(declare (fixnum dgop)) (declare (fixnum dgop))
(< dgop (mask (1- dmns)))) (< dgop (mask (1- dmns))))
(reverse basis-1) (reverse basis-1)
:key #'dgop1)))))) :key #'dgop1))))))
;;; :key #'caadr)))))) ;;; :key #'caadr))))))
(setf crts-basis (crts-prdc-basis basis #'rslt)) (setf crts-basis (crts-prdc-basis basis #'rslt))
(the basis #'rslt)))) (the basis #'rslt))))
@ -186,29 +188,29 @@
(type face face) (type face face)
(type sintr sintr-grml)) (type sintr sintr-grml))
(flet ((rslt (indx dmns gbar) (flet ((rslt (indx dmns gbar)
(declare (declare
(fixnum indx dmns) (fixnum indx dmns)
(type gbar gbar)) (type gbar gbar))
(when (= indx dmns) (when (= indx dmns)
(return-from rslt (return-from rslt
(normalize-gbar (cons (1- dmns) (rest (gbar-list gbar)))))) (normalize-gbar (cons (1- dmns) (rest (gbar-list gbar))))))
(do ((mark (gbar-list gbar) (cdr mark)) (do ((mark (gbar-list gbar) (cdr mark))
(dmns2 (1- dmns) (1- dmns2)) (dmns2 (1- dmns) (1- dmns2))
(rslt +empty-list+ (rslt +empty-list+
(cons (a-face4 face indx dmns2 (car mark)) (cons (a-face4 face indx dmns2 (car mark))
rslt))) rslt)))
((= dmns2 indx) ((= dmns2 indx)
(if (zerop indx) (if (zerop indx)
(normalize-gbar (cons (1- dmns) (nreverse rslt))) (normalize-gbar (cons (1- dmns) (nreverse rslt)))
(normalize-gbar (normalize-gbar
(cons (1- dmns) (cons (1- dmns)
(nreconc (nreconc
rslt rslt
(cons (a-grml4 sintr-grml (1- indx) (cons (a-grml4 sintr-grml (1- indx)
(second mark) (second mark)
(a-face4 face indx indx (a-face4 face indx indx
(first mark))) (first mark)))
(nthcdr 2 mark)))))))))) (nthcdr 2 mark))))))))))
(the face #'rslt))) (the face #'rslt)))
@ -217,10 +219,10 @@
(DEFMETHOD CLASSIFYING-SPACE ((smgr simplicial-group)) (DEFMETHOD CLASSIFYING-SPACE ((smgr simplicial-group))
(the simplicial-set (the simplicial-set
(build-smst :cmpr (classifying-space-cmpr (cmpr smgr)) (build-smst :cmpr (classifying-space-cmpr (cmpr smgr))
:basis (classifying-space-basis (basis smgr)) :basis (classifying-space-basis (basis smgr))
:bspn +null-gbar+ :bspn +null-gbar+
:face (classifying-space-face (face smgr) (sintr (grml smgr))) :face (classifying-space-face (face smgr) (sintr (grml smgr)))
:orgn `(classifying-space ,smgr)))) :orgn `(classifying-space ,smgr))))
(DEFUN CLASSIFYING-SPACE-GRML-SINTR (idnt sintr-grml) (DEFUN CLASSIFYING-SPACE-GRML-SINTR (idnt sintr-grml)
@ -228,53 +230,53 @@
(type gmsm idnt) (type gmsm idnt)
(type sintr sintr-grml)) (type sintr sintr-grml))
(flet ((rslt (dmns crpr) (flet ((rslt (dmns crpr)
(declare (declare
(fixnum dmns) (fixnum dmns)
(type crpr crpr)) (type crpr crpr))
(with-crpr (absm1 absm2) crpr (with-crpr (absm1 absm2) crpr
(let ((absm-list-1 (rest (unnormalize-gbar absm1 idnt))) (let ((absm-list-1 (rest (unnormalize-gbar absm1 idnt)))
(absm-list-2 (rest (unnormalize-gbar absm2 idnt)))) (absm-list-2 (rest (unnormalize-gbar absm2 idnt))))
(declare (list absm-list-1 absm-list-2)) (declare (list absm-list-1 absm-list-2))
(normalize-gbar (normalize-gbar
(cons dmns (cons dmns
(mapcar (mapcar
#'(lambda (absm1 absm2) #'(lambda (absm1 absm2)
(declare (type absm absm1 absm2)) (declare (type absm absm1 absm2))
(decf dmns) ;; !! (decf dmns) ;; !!
(a-grml4 sintr-grml dmns absm1 absm2)) (a-grml4 sintr-grml dmns absm1 absm2))
absm-list-1 absm-list-2))))))) absm-list-1 absm-list-2)))))))
(the sintr #'rslt))) (the sintr #'rslt)))
(DEFUN CLASSIFYING-SPACE-GRIN-SINTR (sintr-grin) (DEFUN CLASSIFYING-SPACE-GRIN-SINTR (sintr-grin)
(declare (type sintr sintr-grin)) (declare (type sintr sintr-grin))
(flet ((rslt (dmns gbar) (flet ((rslt (dmns gbar)
(declare (declare
(fixnum dmns) (fixnum dmns)
(type gbar gbar)) (type gbar gbar))
(absm 0 (absm 0
(make-gbar (make-gbar
:dmns dmns :dmns dmns
:list (mapcar :list (mapcar
#'(lambda (absm) #'(lambda (absm)
(declare (type absm absm)) (declare (type absm absm))
(a-grin4 sintr-grin dmns absm)) (a-grin4 sintr-grin dmns absm))
(gbar-list gbar)))))) (gbar-list gbar))))))
(the sintr #'rslt))) (the sintr #'rslt)))
(DEFMETHOD CLASSIFYING-SPACE ((smgr ab-simplicial-group)) (DEFMETHOD CLASSIFYING-SPACE ((smgr ab-simplicial-group))
(the ab-simplicial-group (the ab-simplicial-group
(change-class (change-class
(build-smgr :cmpr (classifying-space-cmpr (cmpr smgr)) (build-smgr :cmpr (classifying-space-cmpr (cmpr smgr))
:basis (classifying-space-basis (basis smgr)) :basis (classifying-space-basis (basis smgr))
:bspn +null-gbar+ :bspn +null-gbar+
:face (classifying-space-face (face smgr) :face (classifying-space-face (face smgr)
(sintr (grml smgr))) (sintr (grml smgr)))
:sintr-grml (classifying-space-grml-sintr :sintr-grml (classifying-space-grml-sintr
(bspn smgr) (bspn smgr)
(sintr (grml smgr))) (sintr (grml smgr)))
:sintr-grin (classifying-space-grin-sintr :sintr-grin (classifying-space-grin-sintr
(sintr (grin smgr))) (sintr (grin smgr)))
:orgn `(classifying-space ,smgr)) :orgn `(classifying-space ,smgr))
'ab-simplicial-group))) 'ab-simplicial-group)))

89
src/coalgebras.lisp
View File

@ -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 ;;; 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) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) nil)) (setf (ext:package-lock :clos) nil))
(DEFMETHOD PRINT-OBJECT ((clgb coalgebra) stream) (DEFMETHOD PRINT-OBJECT ((clgb coalgebra) stream)
(the coalgebra (the coalgebra
(progn (progn
(format stream "[K~D Coalgebra]" (idnm clgb)) (format stream "[K~D Coalgebra]" (idnm clgb))
clgb))) clgb)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t)) (setf (ext:package-lock :clos) t))
(DEFUN CLGB (idnm) (DEFUN CLGB (idnm)
(declare (fixnum idnm)) (declare (fixnum idnm))
(the (or coalgebra null) (the (or coalgebra null)
(find idnm *clgb-list* :key #'idnm))) (find idnm *clgb-list* :key #'idnm)))
(DEFUN BUILD-CLGB (DEFUN BUILD-CLGB
(&key cmpr basis bsgn intr-dffr dffr-strt intr-cprd cprd-strt orgn) (&key cmpr basis bsgn intr-dffr dffr-strt intr-cprd cprd-strt orgn)
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(type intr-mrph intr-dffr intr-cprd) (type intr-mrph intr-dffr intr-cprd)
(type basis basis) (type basis basis)
(type gnrt bsgn) (type gnrt bsgn)
(type strt dffr-strt cprd-strt) (type strt dffr-strt cprd-strt)
(list orgn)) (list orgn))
(the coalgebra (the coalgebra
(progn (progn
(let ((already (find orgn *clgb-list* :key #'orgn :test #'equal))) (let ((already (find orgn *clgb-list* :key #'orgn :test #'equal)))
(declare (type (or null coalgebra) already)) (declare (type (or null coalgebra) already))
(when already (when already
(return-from build-clgb already))) (return-from build-clgb already)))
(let ((rslt (build-chcm :cmpr cmpr :basis basis :bsgn bsgn (let ((rslt (build-chcm :cmpr cmpr :basis basis :bsgn bsgn
:intr-dffr intr-dffr :strt dffr-strt :intr-dffr intr-dffr :strt dffr-strt
:orgn orgn))) :orgn orgn)))
(declare (type chain-complex rslt)) (declare (type chain-complex rslt))
(change-class rslt 'coalgebra) (change-class rslt 'coalgebra)
(setf (slot-value rslt 'cprd) (setf (slot-value rslt 'cprd)
(build-mrph :sorc rslt :trgt (tnsr-prdc rslt rslt) :degr 0 (build-mrph :sorc rslt :trgt (tnsr-prdc rslt rslt) :degr 0
:intr intr-cprd :strt cprd-strt :intr intr-cprd :strt cprd-strt
:orgn `(coalgebra-coproduct ,rslt))) :orgn `(coalgebra-coproduct ,rslt)))
(push rslt *clgb-list*) (push rslt *clgb-list*)
rslt)))) rslt))))
(DEFUN CHANGE-CHCM-TO-CLGB (chcm &key intr-cprd cprd-strt orgn) (DEFUN CHANGE-CHCM-TO-CLGB (chcm &key intr-cprd cprd-strt orgn)
(declare (declare
(type chain-complex chcm) (type chain-complex chcm)
(type intr-mrph intr-cprd) (type intr-mrph intr-cprd)
(type strt cprd-strt) (type strt cprd-strt)
(list orgn)) (list orgn))
(the coalgebra (the coalgebra
(progn (progn
(change-class chcm 'coalgebra) (change-class chcm 'coalgebra)
(setf orgn (list (orgn chcm) 'then orgn)) (setf orgn (list (orgn chcm) 'then orgn))
(let ((already (find orgn *clgb-list* :key #'orgn :test #'equal))) (let ((already (find orgn *clgb-list* :key #'orgn :test #'equal)))
(declare (type (or null coalgebra) already)) (declare (type (or null coalgebra) already))
(when already (when already
(return-from change-chcm-to-clgb already))) (return-from change-chcm-to-clgb already)))
(setf (slot-value chcm 'cprd) (build-mrph (setf (slot-value chcm 'cprd) (build-mrph
:sorc chcm :trgt (tnsr-prdc chcm chcm) :sorc chcm :trgt (tnsr-prdc chcm chcm)
:degr 0 :degr 0
:intr intr-cprd :strt cprd-strt :intr intr-cprd :strt cprd-strt
:orgn orgn)) :orgn orgn))
(push chcm *clgb-list*) (push chcm *clgb-list*)
chcm))) chcm)))

692
src/cobar.lisp
View File

@ -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 ;;; 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.")) (error "In ALLP, the length list should be even."))
(the allp (the allp
(let ((rslt +empty-list+)) (let ((rslt +empty-list+))
(declare (list rslt)) (declare (list rslt))
(do ((mark list (cddr mark))) (do ((mark list (cddr mark)))
((endp mark)) ((endp mark))
(declare (list mark)) (declare (list mark))
(push (cbgn (car mark) (cadr mark)) rslt)) (push (cbgn (car mark) (cadr mark)) rslt))
(make-allp :list (nreverse rslt))))) (make-allp :list (nreverse rslt)))))
#-sbcl (DEFINE-CONSTANT +NULL-ALLP+ (make-allp :list +empty-list+)) #-sbcl (DEFINE-CONSTANT +NULL-ALLP+ (make-allp :list +empty-list+))
@ -31,31 +33,31 @@
(ignore depth)) (ignore depth))
(the allp (the allp
(progn (progn
(format stream "<<AlLp") (format stream "<<AlLp")
(dolist (cbgn (allp-list allp)) (dolist (cbgn (allp-list allp))
(declare (type cbgn cbgn)) (declare (type cbgn cbgn))
(with-cbgn (degr gnrt) cbgn (with-cbgn (degr gnrt) cbgn
(format stream "[~D ~A]" degr gnrt))) (format stream "[~D ~A]" degr gnrt)))
(format stream ">>") (format stream ">>")
allp))) allp)))
(DEFUN COBAR-CMPR (cmpr) (DEFUN COBAR-CMPR (cmpr)
(declare (type cmprf cmpr)) (declare (type cmprf cmpr))
(flet ((rslt (allp1 allp2) (flet ((rslt (allp1 allp2)
(declare (type allp allp1 allp2)) (declare (type allp allp1 allp2))
(the cmpr (the cmpr
(let ((list1 (allp-list allp1)) (let ((list1 (allp-list allp1))
(list2 (allp-list allp2))) (list2 (allp-list allp2)))
(declare (type iallp list1 list2)) (declare (type iallp list1 list2))
(lexico (lexico
(f-cmpr (length list1) (length list2)) (f-cmpr (length list1) (length list2))
(maplexico (maplexico
#'(lambda (cbgn1 cbgn2) #'(lambda (cbgn1 cbgn2)
(lexico (lexico
(f-cmpr (cdegr cbgn1) (cdegr cbgn2)) (f-cmpr (cdegr cbgn1) (cdegr cbgn2))
(funcall cmpr (cgnrt cbgn1) (cgnrt cbgn2)))) (funcall cmpr (cgnrt cbgn1) (cgnrt cbgn2))))
list1 list2)))))) list1 list2))))))
(the cmprf #'rslt))) (the cmprf #'rslt)))
@ -65,53 +67,53 @@
(fixnum degr length)) (fixnum degr length))
(the list (the list
(progn (progn
(when (= 1 length) (when (= 1 length)
(return-from cobar-basis-length (return-from cobar-basis-length
(mapcar (mapcar
#'(lambda (item) #'(lambda (item)
(declare (type gnrt item)) (declare (type gnrt item))
(list (cbgn degr item))) (list (cbgn degr item)))
(funcall basis (1+ degr))))) (funcall basis (1+ degr)))))
(mapcan (mapcan
#'(lambda (degr1) #'(lambda (degr1)
(declare (fixnum degr1)) (declare (fixnum degr1))
(let ((list1 (funcall basis (1+ degr1))) (let ((list1 (funcall basis (1+ degr1)))
(list2 (cobar-basis-length (list2 (cobar-basis-length
basis (- degr degr1) (1- length)))) basis (- degr degr1) (1- length))))
(declare (list list1 list2)) (declare (list list1 list2))
(mapcan (mapcan
#'(lambda (item1) #'(lambda (item1)
(declare (type gnrt item1)) (declare (type gnrt item1))
(mapcar (mapcar
#'(lambda (item2) #'(lambda (item2)
(declare (type iallp item2)) (declare (type iallp item2))
(cons (cbgn degr1 item1) item2)) (cons (cbgn degr1 item1) item2))
list2)) list2))
list1))) list1)))
(>a-b< 0 degr))))) (>a-b< 0 degr)))))
(DEFUN COBAR-BASIS (basis) (DEFUN COBAR-BASIS (basis)
(declare (type basis basis)) (declare (type basis basis))
(the basis (the basis
(progn (progn
(when (eq :locally-effective basis) (when (eq :locally-effective basis)
(return-from cobar-basis :locally-effective)) (return-from cobar-basis :locally-effective))
(flet ((rslt (degr) (flet ((rslt (degr)
(declare (fixnum degr)) (declare (fixnum degr))
(cond ((minusp degr) +empty-list+) (cond ((minusp degr) +empty-list+)
((zerop degr) (list +null-allp+)) ((zerop degr) (list +null-allp+))
(t (t
(mapcan (mapcan
#'(lambda (length) #'(lambda (length)
(declare (fixnum length)) (declare (fixnum length))
(mapcar (mapcar
#'(lambda (iallp) #'(lambda (iallp)
(declare (type iallp iallp)) (declare (type iallp iallp))
(make-allp :list iallp)) (make-allp :list iallp))
(cobar-basis-length basis degr length))) (cobar-basis-length basis degr length)))
(>a-b> 0 degr)))))) (>a-b> 0 degr))))))
#'rslt)))) #'rslt))))
#| The following version of the COBAR-BASIS function is #| The following version of the COBAR-BASIS function is
not correctly compiled with ACL-Unix, probably not correctly compiled with ACL-Unix, probably
@ -126,102 +128,102 @@ structure of closures. This version works on ACL-PC.
(the basis (the basis
(progn (progn
(when (eq :locally-effective basis) (when (eq :locally-effective basis)
(return-from cobar-basis :locally-effecive)) (return-from cobar-basis :locally-effecive))
(labels ((rslt (degr length) (labels ((rslt (degr length)
(declare (fixnum degr length)) (declare (fixnum degr length))
(when (= 1 length) (when (= 1 length)
(return-from rslt (return-from rslt
(mapcar (mapcar
#'(lambda (item) #'(lambda (item)
(declare (type gnrt item)) (declare (type gnrt item))
(list (cbgn degr item))) (list (cbgn degr item)))
(funcall basis (1+ degr))))) (funcall basis (1+ degr)))))
(mapcan (mapcan
#'(lambda (degr1) #'(lambda (degr1)
(declare (fixnum degr1)) (declare (fixnum degr1))
(let ((list1 (funcall basis (1+ degr1))) (let ((list1 (funcall basis (1+ degr1)))
(list2 (rslt (- degr degr1) (1- length)))) (list2 (rslt (- degr degr1) (1- length))))
(declare (list list1 lis2)) (declare (list list1 lis2))
(mapcan (mapcan
#'(lambda (item1) #'(lambda (item1)
(declare (type gnrt item1)) (declare (type gnrt item1))
(mapcar (mapcar
#'(lambda (item2) #'(lambda (item2)
(declare (type iallp item2)) (declare (type iallp item2))
(cons (cbgn degr1 item1) item2)) (cons (cbgn degr1 item1) item2))
list2)) list2))
list1))) list1)))
(>a-b< 0 degr)))) (>a-b< 0 degr))))
#'(lambda (degr) #'(lambda (degr)
(declare (fixnum degr)) (declare (fixnum degr))
(if (zerop degr) (if (zerop degr)
(list (make-allp :list +empty-list+)) (list (make-allp :list +empty-list+))
(mapcan (mapcan
#'(lambda (length) #'(lambda (length)
(declare (fixnum length)) (declare (fixnum length))
(mapcar (mapcar
#'(lambda (iallp) #'(lambda (iallp)
(declare (type iallp iallp)) (declare (type iallp iallp))
(make-allp :list iallp)) (make-allp :list iallp))
(rslt degr length))) (rslt degr length)))
(>a-b> 0 degr)))))))) (>a-b> 0 degr))))))))
|# |#
(DEFUN COBAR-INTR-VRTC-DFFR (dffr) (DEFUN COBAR-INTR-VRTC-DFFR (dffr)
(declare (type morphism dffr)) (declare (type morphism dffr))
(labels ((rslt (degr iallp) (labels ((rslt (degr iallp)
;; the argument iallp is an internal algebraic loop, ;; the argument iallp is an internal algebraic loop,
;; without the keyword :allp ;; without the keyword :allp
;; rslt returns an internal combination ;; rslt returns an internal combination
;; without the keyword :cmbn, without degree ;; without the keyword :cmbn, without degree
(declare (declare
(fixnum degr) (fixnum degr)
(type iallp iallp)) (type iallp iallp))
(the icmbn (the icmbn
(progn (progn
(unless iallp (unless iallp
(return-from rslt +empty-list+)) (return-from rslt +empty-list+))
(let ((cbgn1 (first iallp)) (let ((cbgn1 (first iallp))
(rest (rest iallp))) (rest (rest iallp)))
(declare (declare
(type cbgn cbgn1) (type cbgn cbgn1)
(type iallp rest)) (type iallp rest))
(with-cbgn (with-cbgn
(degr1 gnrt1) cbgn1 (degr1 gnrt1) cbgn1
(let ((d-gnrt1 (cmbn-list (gnrt-? dffr (1+ degr1) (let ((d-gnrt1 (cmbn-list (gnrt-? dffr (1+ degr1)
gnrt1))) gnrt1)))
(d-rest (rslt (- degr degr1) rest)) (d-rest (rslt (- degr degr1) rest))
(degr1-1 (1- degr1)) (degr1-1 (1- degr1))
(first-sign (-1-expt-n-1 (length rest))) (first-sign (-1-expt-n-1 (length rest)))
(rest-sign (-1-expt-n degr1))) (rest-sign (-1-expt-n degr1)))
(declare (declare
(type icmbn d-gnrt1 d-rest) (type icmbn d-gnrt1 d-rest)
(fixnum degr1-1 rest-sign)) (fixnum degr1-1 rest-sign))
(nconc (nconc
(mapcar (mapcar
#'(lambda (term) #'(lambda (term)
(with-term (with-term
(cffc gnrt) term (cffc gnrt) term
(term (* first-sign cffc) (term (* first-sign cffc)
(cons (cbgn degr1-1 gnrt) rest)))) (cons (cbgn degr1-1 gnrt) rest))))
d-gnrt1) d-gnrt1)
(mapcar (mapcar
#'(lambda (term) #'(lambda (term)
(with-term (with-term
(cffc gnrt) term (cffc gnrt) term
(term (* rest-sign cffc) (term (* rest-sign cffc)
(cons cbgn1 gnrt)))) (cons cbgn1 gnrt))))
d-rest))))))))) d-rest)))))))))
(the intr-mrph (the intr-mrph
#'(lambda (degr allp) #'(lambda (degr allp)
(make-cmbn (make-cmbn
:degr (1- degr) :degr (1- degr)
:list (mapcar :list (mapcar
#'(lambda (term) #'(lambda (term)
(with-term (cffc iallp) term (with-term (cffc iallp) term
(term cffc (make-allp :list iallp)))) (term cffc (make-allp :list iallp))))
(rslt degr (allp-list allp)))))))) (rslt degr (allp-list allp))))))))
(DEFGENERIC VRTC-COBAR (chcm-or-hmeq-or-rdct)) (DEFGENERIC VRTC-COBAR (chcm-or-hmeq-or-rdct))
@ -231,77 +233,77 @@ structure of closures. This version works on ACL-PC.
(the chain-complex (the chain-complex
(with-slots (cmpr basis dffr) chcm (with-slots (cmpr basis dffr) chcm
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(type basis basis) (type basis basis)
(type morphism dffr)) (type morphism dffr))
(build-chcm (build-chcm
:cmpr (cobar-cmpr cmpr) :cmpr (cobar-cmpr cmpr)
:basis (cobar-basis basis) :basis (cobar-basis basis)
:bsgn +null-allp+ :bsgn +null-allp+
:intr-dffr (cobar-intr-vrtc-dffr dffr) :intr-dffr (cobar-intr-vrtc-dffr dffr)
:strt :gnrt :strt :gnrt
:orgn `(vrtc-cobar ,chcm))))) :orgn `(vrtc-cobar ,chcm)))))
(DEFUN COBAR-INTR-HRZN-DFFR (cprd) (DEFUN COBAR-INTR-HRZN-DFFR (cprd)
(declare (type morphism cprd)) (declare (type morphism cprd))
(labels ((rslt (degr iallp) (labels ((rslt (degr iallp)
(declare (declare
(fixnum degr) (fixnum degr)
(type iallp iallp)) (type iallp iallp))
(the icmbn (the icmbn
(progn (progn
(unless iallp (unless iallp
(return-from rslt +empty-list+)) (return-from rslt +empty-list+))
(let ((cbgn1 (first iallp)) (let ((cbgn1 (first iallp))
(rest (rest iallp))) (rest (rest iallp)))
(declare (declare
(type cbgn cbgn1) (type cbgn cbgn1)
(type iallp rest)) (type iallp rest))
(with-cbgn (with-cbgn
(degr1 gnrt1) cbgn1 (degr1 gnrt1) cbgn1
(let ((cprd-gnrt1 (cmbn-list (gnrt-? cprd (1+ degr1) gnrt1))) (let ((cprd-gnrt1 (cmbn-list (gnrt-? cprd (1+ degr1) gnrt1)))
(cprd-rest (rslt (- degr degr1) rest)) (cprd-rest (rslt (- degr degr1) rest))
(sign (-1-expt-n-1 (length rest)))) (sign (-1-expt-n-1 (length rest))))
(declare (declare
(type icmbn cprd-gnrt1 cprd-rest) (type icmbn cprd-gnrt1 cprd-rest)
(fixnum sign)) (fixnum sign))
;;; because \bar{A} ;;; because \bar{A}
(setf cprd-gnrt1 (rest (butlast cprd-gnrt1))) (setf cprd-gnrt1 (rest (butlast cprd-gnrt1)))
(nconc (nconc
(mapcar (mapcar
#'(lambda (term1) #'(lambda (term1)
(declare (type term term1)) (declare (type term term1))
(with-term (with-term
(nil tnpr) term1 ;;; cffc is in fact 1 (nil tnpr) term1 ;;; cffc is in fact 1
(with-tnpr (with-tnpr
(degr1 gnrt1 degr2 gnrt2) tnpr (degr1 gnrt1 degr2 gnrt2) tnpr
(term sign ;;; (* cffc sign) (term sign ;;; (* cffc sign)
(cons (cbgn (1- degr1) gnrt1) (cons (cbgn (1- degr1) gnrt1)
(cons (cbgn (1- degr2) gnrt2) (cons (cbgn (1- degr2) gnrt2)
rest)))))) rest))))))
cprd-gnrt1) cprd-gnrt1)
(mapcar (mapcar
#'(lambda (term2) #'(lambda (term2)
(declare (type term term2)) (declare (type term term2))
(with-term (cffc allp2) term2 (with-term (cffc allp2) term2
(term cffc (term cffc
(cons cbgn1 allp2)))) (cons cbgn1 allp2))))
cprd-rest))))))))) cprd-rest)))))))))
(the intr-mrph (the intr-mrph
#'(lambda (degr allp) #'(lambda (degr allp)
(declare (declare
(fixnum degr) (fixnum degr)
(type allp allp)) (type allp allp))
(the cmbn (the cmbn
(make-cmbn :degr (1- degr) (make-cmbn :degr (1- degr)
:list (mapcar #'(lambda (term) :list (mapcar #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc iallp) term (cffc iallp) term
(term cffc (make-allp (term cffc (make-allp
:list iallp)))) :list iallp))))
(rslt degr (allp-list allp))))))))) (rslt degr (allp-list allp)))))))))
(DEFUN COBAR-HRZN-DFFR (clgb) (DEFUN COBAR-HRZN-DFFR (clgb)
@ -310,23 +312,23 @@ structure of closures. This version works on ACL-PC.
(with-slots (cprd) clgb (with-slots (cprd) clgb
(declare (type morphism cprd)) (declare (type morphism cprd))
(build-mrph (build-mrph
:sorc (vrtc-cobar clgb) :trgt (vrtc-cobar clgb) :degr -1 :sorc (vrtc-cobar clgb) :trgt (vrtc-cobar clgb) :degr -1
:intr (cobar-intr-hrzn-dffr cprd) :strt :gnrt :intr (cobar-intr-hrzn-dffr cprd) :strt :gnrt
:orgn `(cobar-hrzn-dffr ,clgb))))) :orgn `(cobar-hrzn-dffr ,clgb)))))
(DEFUN COBAR-INTR-DFFR (vrtc-dffr hrzn-dffr) (DEFUN COBAR-INTR-DFFR (vrtc-dffr hrzn-dffr)
(declare (type morphism vrtc-dffr hrzn-dffr)) (declare (type morphism vrtc-dffr hrzn-dffr))
(flet ((rslt (degr allp) (flet ((rslt (degr allp)
(declare (declare
(fixnum degr) (fixnum degr)
(type allp allp)) (type allp allp))
(make-cmbn :degr (1- degr) (make-cmbn :degr (1- degr)
:list (append ;;; and not nconc, otherwise a terrible :list (append ;;; and not nconc, otherwise a terrible
;;; bug, when the ;;; bug, when the
;;; first result is stored in memory... ;;; first result is stored in memory...
(cmbn-list (gnrt-? vrtc-dffr degr allp)) (cmbn-list (gnrt-? vrtc-dffr degr allp))
(cmbn-list (gnrt-? hrzn-dffr degr allp)))))) (cmbn-list (gnrt-? hrzn-dffr degr allp))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
@ -335,52 +337,52 @@ structure of closures. This version works on ACL-PC.
(DEFMETHOD COBAR ((coalgebra coalgebra)) (DEFMETHOD COBAR ((coalgebra coalgebra))
(let ((vrtc-cobar (vrtc-cobar 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) (declare (type chain-complex vrtc-cobar)
(type morphism cobar-hrzn-dffr)) (type morphism cobar-hrzn-dffr))
(the chain-complex (the chain-complex
(let ((rslt (build-chcm (let ((rslt (build-chcm
:cmpr (cmpr vrtc-cobar) :cmpr (cmpr vrtc-cobar)
:basis (basis vrtc-cobar) :basis (basis vrtc-cobar)
:bsgn +null-allp+ :bsgn +null-allp+
:intr-dffr (cobar-intr-dffr (dffr vrtc-cobar) :intr-dffr (cobar-intr-dffr (dffr vrtc-cobar)
cobar-hrzn-dffr) cobar-hrzn-dffr)
:strt :gnrt :strt :gnrt
:orgn `(add ,vrtc-cobar ,cobar-hrzn-dffr)))) :orgn `(add ,vrtc-cobar ,cobar-hrzn-dffr))))
(declare (type chain-complex rslt)) (declare (type chain-complex rslt))
(setf (slot-value rslt 'grmd) (grmd vrtc-cobar)) (setf (slot-value rslt 'grmd) (grmd vrtc-cobar))
rslt)))) rslt))))
(DEFUN CMBN-ALLP-CMBN-TNPR (cmbn allp-cmbn) (DEFUN CMBN-ALLP-CMBN-TNPR (cmbn allp-cmbn)
(declare (type cmbn cmbn allp-cmbn)) (declare (type cmbn cmbn allp-cmbn))
(the cmbn (the cmbn
(with-cmbn (with-cmbn
(degr1 list1) cmbn (degr1 list1) cmbn
(decf degr1) ;; because allp organization (decf degr1) ;; because allp organization
(with-cmbn (with-cmbn
(degrr listr) allp-cmbn (degrr listr) allp-cmbn
(make-cmbn (make-cmbn
:degr (+ degr1 degrr) :degr (+ degr1 degrr)
:list :list
(mapcan (mapcan
#'(lambda (term1) #'(lambda (term1)
(declare (type term term1)) (declare (type term term1))
(with-term (with-term
(cffc1 gnrt1) term1 (cffc1 gnrt1) term1
(let ((cbgn1 (cbgn degr1 gnrt1))) (let ((cbgn1 (cbgn degr1 gnrt1)))
(declare (type cbgn cbgn1)) (declare (type cbgn cbgn1))
(mapcar (mapcar
#'(lambda (termr) #'(lambda (termr)
(declare (type term termr)) (declare (type term termr))
(with-term (with-term
(cffcr allpr) termr (cffcr allpr) termr
(term (* cffc1 cffcr) (term (* cffc1 cffcr)
(make-allp (make-allp
:list (cons cbgn1 :list (cons cbgn1
(allp-list allpr)))))) (allp-list allpr))))))
listr)))) listr))))
list1)))))) list1))))))
(DEFUN NCMBN-COBAR (cmbn-list) (DEFUN NCMBN-COBAR (cmbn-list)
@ -388,33 +390,33 @@ structure of closures. This version works on ACL-PC.
(the cmbn (the cmbn
(progn (progn
(unless cmbn-list (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 (cmbn-allp-cmbn-tnpr
(first cmbn-list) (first cmbn-list)
(ncmbn-cobar (rest cmbn-list)))))) (ncmbn-cobar (rest cmbn-list))))))
(DEFUN MRPH-VRTC-COBAR-INTR (mrph) (DEFUN MRPH-VRTC-COBAR-INTR (mrph)
(declare (type morphism mrph)) (declare (type morphism mrph))
(flet ((rslt (degr allp) (flet ((rslt (degr allp)
(declare (declare
(ignore degr) (ignore degr)
(type allp allp)) (type allp allp))
(the cmbn (the cmbn
(ncmbn-cobar (ncmbn-cobar
(mapcar #'(lambda (cbgn) (mapcar #'(lambda (cbgn)
(declare (type cbgn cbgn)) (declare (type cbgn cbgn))
(with-cbgn (degr gnrt) cbgn (with-cbgn (degr gnrt) cbgn
(gnrt-? mrph (1+ degr) gnrt))) (gnrt-? mrph (1+ degr) gnrt)))
(allp-list allp)))))) (allp-list allp))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
(DEFMETHOD VRTC-COBAR ((mrph morphism)) (DEFMETHOD VRTC-COBAR ((mrph morphism))
(the morphism (the morphism
(if (eq (first (orgn mrph)) 'idnt-mrph) (if (eq (first (orgn mrph)) 'idnt-mrph)
(idnt-mrph (vrtc-cobar (sorc mrph))) (idnt-mrph (vrtc-cobar (sorc mrph)))
(build-mrph (build-mrph
:sorc (vrtc-cobar (sorc mrph)) :sorc (vrtc-cobar (sorc mrph))
:trgt (vrtc-cobar (trgt mrph)) :trgt (vrtc-cobar (trgt mrph))
:degr 0 :degr 0
@ -426,70 +428,70 @@ structure of closures. This version works on ACL-PC.
(DEFUN HMTP-VRTC-COBAR-INTR (h gf) (DEFUN HMTP-VRTC-COBAR-INTR (h gf)
(declare (type morphism h gf)) (declare (type morphism h gf))
(flet ((rslt (degr allp) (flet ((rslt (degr allp)
(declare (declare
(fixnum degr) (fixnum degr)
(type allp allp)) (type allp allp))
(let* ((cbgn-list (reverse (allp-list allp))) (let* ((cbgn-list (reverse (allp-list allp)))
(rslt (list nil)) (rslt (list nil))
(sign (oddp (apply #'+ (mapcar #'car cbgn-list)))) (sign (oddp (apply #'+ (mapcar #'car cbgn-list))))
;; nil = -1 ;; t = +1 ;; nil = -1 ;; t = +1
(gfgf-tail (term-cmbn 0 1 +null-allp+))) (gfgf-tail (term-cmbn 0 1 +null-allp+)))
(declare (declare
(list cbgn-list rslt) (list cbgn-list rslt)
(boolean sign) (boolean sign)
(type cmbn gfgf-tail)) (type cmbn gfgf-tail))
(unless cbgn-list (unless cbgn-list
(return-from rslt (zero-cmbn 1))) (return-from rslt (zero-cmbn 1)))
(loop (loop
(let ((cbgn (car cbgn-list))) (let ((cbgn (car cbgn-list)))
(declare (type cbgn cbgn)) (declare (type cbgn cbgn))
(with-cbgn (with-cbgn
(degr gnrt) cbgn (degr gnrt) cbgn
(when (evenp degr) (when (evenp degr)
(setf sign (not sign))) (setf sign (not sign)))
(incf degr) (incf degr)
(let ((h-gnrt (gnrt-? h degr gnrt))) (let ((h-gnrt (gnrt-? h degr gnrt)))
(declare (type cmbn h-gnrt)) (declare (type cmbn h-gnrt))
(let ((hgfgf (cmbn-list (cmbn-allp-cmbn-tnpr (let ((hgfgf (cmbn-list (cmbn-allp-cmbn-tnpr
h-gnrt h-gnrt
gfgf-tail)))) gfgf-tail))))
(declare (type list hgfgf)) (declare (type list hgfgf))
(when sign (when sign
(mapc #'(lambda (term) (mapc #'(lambda (term)
(declare (type term term)) (declare (type term term))
(setf (cffc term) (- (cffc term)))) (setf (cffc term) (- (cffc term))))
hgfgf)) hgfgf))
(setf cbgn-list (rest cbgn-list)) (setf cbgn-list (rest cbgn-list))
(let ((head (reverse cbgn-list))) (let ((head (reverse cbgn-list)))
(declare (list head)) (declare (list head))
(mapc #'(lambda (term) (mapc #'(lambda (term)
(setf (allp-list (gnrt term)) (setf (allp-list (gnrt term))
(append head (allp-list (gnrt term))))) (append head (allp-list (gnrt term)))))
hgfgf)) hgfgf))
(nconc rslt hgfgf))) (nconc rslt hgfgf)))
(unless cbgn-list (return)) (unless cbgn-list (return))
(setf gfgf-tail (setf gfgf-tail
(cmbn-allp-cmbn-tnpr (cmbn-allp-cmbn-tnpr
(gnrt-? gf degr gnrt) gfgf-tail))))) (gnrt-? gf degr gnrt) gfgf-tail)))))
(make-cmbn (make-cmbn
:degr (1+ degr) :degr (1+ degr)
:list (rest rslt))))) :list (rest rslt)))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
(DEFUN HMTP-VRTC-COBAR (h gf) (DEFUN HMTP-VRTC-COBAR (h gf)
(declare (type morphism h gf)) (declare (type morphism h gf))
(unless (and (= +1 (degr h)) (unless (and (= +1 (degr h))
(= +0 (degr gf))) (= +0 (degr gf)))
(error "In HMTP-VRTC-COBAR, the morphism degrees are not the right ones.")) (error "In HMTP-VRTC-COBAR, the morphism degrees are not the right ones."))
(unless (and (eq (sorc h) (trgt h)) (unless (and (eq (sorc h) (trgt h))
(eq (trgt h) (sorc gf)) (eq (trgt h) (sorc gf))
(eq (sorc gf) (trgt gf))) (eq (sorc gf) (trgt gf)))
(error "In HMTP-VRTC-COBAR, fg-h sources and targets are not the same.")) (error "In HMTP-VRTC-COBAR, fg-h sources and targets are not the same."))
(the morphism (the morphism
(if (eq (first (orgn h)) 'zero-mrph) (if (eq (first (orgn h)) 'zero-mrph)
(zero-mrph (vrtc-cobar (sorc h))) (zero-mrph (vrtc-cobar (sorc h)))
(build-mrph (build-mrph
:sorc (vrtc-cobar (sorc h)) :trgt (vrtc-cobar (sorc h)) :degr +1 :sorc (vrtc-cobar (sorc h)) :trgt (vrtc-cobar (sorc h)) :degr +1
:intr (hmtp-vrtc-cobar-intr h gf) :intr (hmtp-vrtc-cobar-intr h gf)
:strt :gnrt :strt :gnrt
@ -499,24 +501,24 @@ structure of closures. This version works on ACL-PC.
(DEFMETHOD VRTC-COBAR ((rdct reduction)) (DEFMETHOD VRTC-COBAR ((rdct reduction))
(the reduction (the reduction
(if (eq (first (orgn rdct)) 'trivial-rdct) (if (eq (first (orgn rdct)) 'trivial-rdct)
(trivial-rdct (vrtc-cobar (bcc rdct))) (trivial-rdct (vrtc-cobar (bcc rdct)))
(with-slots (f g h) rdct (with-slots (f g h) rdct
(build-rdct (build-rdct
:f (vrtc-cobar f) :f (vrtc-cobar f)
:g (vrtc-cobar g) :g (vrtc-cobar g)
:h (hmtp-vrtc-cobar h (cmps g f)) :h (hmtp-vrtc-cobar h (cmps g f))
:orgn `(vrtc-cobar ,rdct)))))) :orgn `(vrtc-cobar ,rdct))))))
(DEFMETHOD VRTC-COBAR ((hmeq homotopy-equivalence)) (DEFMETHOD VRTC-COBAR ((hmeq homotopy-equivalence))
(the homotopy-equivalence (the homotopy-equivalence
(if (eq (first (orgn hmeq)) 'trivial-hmeq) (if (eq (first (orgn hmeq)) 'trivial-hmeq)
(trivial-hmeq (vrtc-cobar (lbcc hmeq))) (trivial-hmeq (vrtc-cobar (lbcc hmeq)))
(with-slots (lrdct rrdct) hmeq (with-slots (lrdct rrdct) hmeq
(build-hmeq (build-hmeq
:lrdct (vrtc-cobar lrdct) :lrdct (vrtc-cobar lrdct)
:rrdct (vrtc-cobar rrdct) :rrdct (vrtc-cobar rrdct)
:orgn `(vrtc-cobar ,hmeq)))))) :orgn `(vrtc-cobar ,hmeq))))))
(DEFMETHOD COBAR ((hmeq homotopy-equivalence)) (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.")) (error "In (COBAR HMEQ), the LBCC should be a coalgebra."))
(the homotopy-equivalence (the homotopy-equivalence
(if (eq (first (orgn hmeq)) 'trivial-hmeq) (if (eq (first (orgn hmeq)) 'trivial-hmeq)
(trivial-hmeq (cobar (lbcc hmeq))) (trivial-hmeq (cobar (lbcc hmeq)))
(add (vrtc-cobar hmeq) (cobar-hrzn-dffr (lbcc hmeq)))))) (add (vrtc-cobar hmeq) (cobar-hrzn-dffr (lbcc hmeq))))))

2
src/combinations.lisp
View File

@ -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
;;; COMBINATIONS COMBINATIONS COMBINATIONS COMBINATIONS COMBINATIONS ;;; COMBINATIONS COMBINATIONS COMBINATIONS COMBINATIONS COMBINATIONS

296
src/cones.lisp
View File

@ -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 ;;; 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)) (ignore depth))
(the cone (the cone
(with-cone (conx icon) cone (with-cone (conx icon) cone
(format stream "<CONE ~D" conx) (format stream "<CONE ~D" conx)
(do ((mark icon)) (do ((mark icon))
((not (typep mark 'cone)) ((not (typep mark 'cone))
(format stream " ~A>" mark)) (format stream " ~A>" mark))
(declare (type gnrt icon)) (declare (type gnrt icon))
(with-cone (conx icon) mark (with-cone (conx icon) mark
(format stream "-~D" conx) (format stream "-~D" conx)
(setf mark icon))) (setf mark icon)))
cone))) cone)))
(DEFUN CONE-CMPR (cmpr0 cmpr1) (DEFUN CONE-CMPR (cmpr0 cmpr1)
(declare (type cmprf cmpr0 cmpr1)) (declare (type cmprf cmpr0 cmpr1))
(the cmprf (the cmprf
(flet ((rslt (gnrt1 gnrt2) (flet ((rslt (gnrt1 gnrt2)
(declare (type cone gnrt1 gnrt2)) (declare (type cone gnrt1 gnrt2))
(the cmpr (the cmpr
(let ((ind1 (conx gnrt1)) (let ((ind1 (conx gnrt1))
(ind2 (conx gnrt2)) (ind2 (conx gnrt2))
(gnrt11 (icon gnrt1)) (gnrt11 (icon gnrt1))
(gnrt22 (icon gnrt2))) (gnrt22 (icon gnrt2)))
(declare (declare
(fixnum ind1 ind2) (fixnum ind1 ind2)
(type gnrt gnrt11 gnrt22)) (type gnrt gnrt11 gnrt22))
(ecase ind1 (ecase ind1
(0 (ecase ind2 (0 (ecase ind2
(0 (funcall cmpr0 gnrt11 gnrt22)) (0 (funcall cmpr0 gnrt11 gnrt22))
(1 :less))) (1 :less)))
(1 (ecase ind2 (1 (ecase ind2
(0 :greater) (0 :greater)
(1 (funcall cmpr1 gnrt11 gnrt22))))))))) (1 (funcall cmpr1 gnrt11 gnrt22)))))))))
(declare (ftype (function (cone cone) cmpr) rslt)) (declare (ftype (function (cone cone) cmpr) rslt))
#'rslt))) #'rslt)))
(DEFUN CONE-BASIS (basis0 basis1) (DEFUN CONE-BASIS (basis0 basis1)
(declare (type basis basis0 basis1)) (declare (type basis basis0 basis1))
(the basis (the basis
(progn (progn
(when (or (eq basis0 :locally-effective) (when (or (eq basis0 :locally-effective)
(eq basis1 :locally-effective)) (eq basis1 :locally-effective))
(return-from cone-basis :locally-effective)) (return-from cone-basis :locally-effective))
(flet ((rslt (degr) (flet ((rslt (degr)
(declare (type fixnum degr)) (declare (type fixnum degr))
(the list (the list
(append (append
(mapcar #'(lambda (item) (con0 item)) (mapcar #'(lambda (item) (con0 item))
(funcall basis0 degr)) (funcall basis0 degr))
(mapcar #'(lambda (item) (con1 item)) (mapcar #'(lambda (item) (con1 item))
(funcall basis1 (1- degr))))))) (funcall basis1 (1- degr)))))))
(declare (ftype (function (fixnum) list) rslt)) (declare (ftype (function (fixnum) list) rslt))
#'rslt)))) #'rslt))))
(DEFUN TERM-CON0 (term) (DEFUN TERM-CON0 (term)
(declare (type term term)) (declare (type term term))
(the term (the term
(term (cffc term) (term (cffc term)
(con0 (gnrt term))))) (con0 (gnrt term)))))
(DEFUN TERM-CON1 (term) (DEFUN TERM-CON1 (term)
(declare (type term term)) (declare (type term term))
(the term (the term
(term (cffc term) (term (cffc term)
(con1 (gnrt term))))) (con1 (gnrt term)))))
(DEFUN TERM-UNCON (term) (DEFUN TERM-UNCON (term)
@ -91,95 +93,95 @@
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(make-cmbn (make-cmbn
:degr (cmbn-degr cmbn) :degr (cmbn-degr cmbn)
:list (mapcar #'term-con0 (cmbn-list cmbn))))) :list (mapcar #'term-con0 (cmbn-list cmbn)))))
(DEFUN CMBN-CON1 (cmbn) (DEFUN CMBN-CON1 (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(make-cmbn (make-cmbn
:degr (cmbn-degr cmbn) :degr (cmbn-degr cmbn)
:list (mapcar #'term-con1 (cmbn-list cmbn))))) :list (mapcar #'term-con1 (cmbn-list cmbn)))))
(DEFUN CONE-CMBN-SPLIT (cmbn) (DEFUN CONE-CMBN-SPLIT (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the (values cmbn cmbn) (the (values cmbn cmbn)
(with-cmbn (degr list) cmbn (with-cmbn (degr list) cmbn
(let ((list0 +empty-list+) (let ((list0 +empty-list+)
(list1 +empty-list+)) (list1 +empty-list+))
(declare (type list list0 list1)) (declare (type list list0 list1))
(do ((mark list (cdr mark))) (do ((mark list (cdr mark)))
((endp mark) ((endp mark)
(setf list0 (nreverse list0) (setf list0 (nreverse list0)
list1 +empty-list+)) list1 +empty-list+))
(declare (type list mark)) (declare (type list mark))
(when (eql 1 (conx (cdar mark))) (when (eql 1 (conx (cdar mark)))
(setf list0 (nreverse list0) (setf list0 (nreverse list0)
list1 (mapcar #'term-uncon mark)) list1 (mapcar #'term-uncon mark))
(return)) (return))
(push (term-uncon (car mark)) list0)) (push (term-uncon (car mark)) list0))
(values (make-cmbn :degr degr :list list0) (values (make-cmbn :degr degr :list list0)
(make-cmbn :degr (1- degr) :list list1)))))) (make-cmbn :degr (1- degr) :list list1))))))
(DEFUN CONE-2CMBN-APPEND (cmbn0 cmbn1) (DEFUN CONE-2CMBN-APPEND (cmbn0 cmbn1)
(declare (type cmbn cmbn0 cmbn1)) (declare (type cmbn cmbn0 cmbn1))
(the cmbn (the cmbn
(make-cmbn (make-cmbn
:degr (cmbn-degr cmbn0) :degr (cmbn-degr cmbn0)
:list (append (mapcar #'term-con0 (cmbn-list cmbn0)) :list (append (mapcar #'term-con0 (cmbn-list cmbn0))
(mapcar #'term-con1 (cmbn-list cmbn1)))))) (mapcar #'term-con1 (cmbn-list cmbn1))))))
(DEFUN CONE-2MRPH-DIAG-IMPL (mrph0 mrph1) (DEFUN CONE-2MRPH-DIAG-IMPL (mrph0 mrph1)
(declare (type morphism mrph0 mrph1)) (declare (type morphism mrph0 mrph1))
(the intr-mrph (the intr-mrph
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(multiple-value-bind (cmbn0 cmbn1) (multiple-value-bind (cmbn0 cmbn1)
(cone-cmbn-split cmbn) (cone-cmbn-split cmbn)
(declare (type cmbn cmbn0 cmbn1)) (declare (type cmbn cmbn0 cmbn1))
(cone-2cmbn-append (? mrph0 cmbn0) (cone-2cmbn-append (? mrph0 cmbn0)
(? mrph1 cmbn1)))))) (? mrph1 cmbn1))))))
#'rslt))) #'rslt)))
(DEFUN CONE-3MRPH-TRIANGLE-IMPL (cmpr0 mrph0 mrph1 phi) (DEFUN CONE-3MRPH-TRIANGLE-IMPL (cmpr0 mrph0 mrph1 phi)
(declare (ignore cmpr0) (type morphism mrph0 mrph1 phi)) (declare (ignore cmpr0) (type morphism mrph0 mrph1 phi))
(the intr-mrph (the intr-mrph
(flet ((rslt (degr gnrt) (flet ((rslt (degr gnrt)
(declare (type fixnum degr) (type gnrt gnrt)) (declare (type fixnum degr) (type gnrt gnrt))
(the cmbn (the cmbn
(ecase (conx gnrt) (ecase (conx gnrt)
(0 (cmbn-con0 (? mrph0 degr (icon gnrt)))) (0 (cmbn-con0 (? mrph0 degr (icon gnrt))))
(1 (1
(let ((gnrt (icon gnrt))) (let ((gnrt (icon gnrt)))
(declare (type gnrt gnrt)) (declare (type gnrt gnrt))
(cone-2cmbn-append (cone-2cmbn-append
(? phi (1- degr) gnrt) (? phi (1- degr) gnrt)
(? mrph1 (1- degr) gnrt)))))))) (? mrph1 (1- degr) gnrt))))))))
#'rslt))) #'rslt)))
(DEFUN CONE (mrph) (DEFUN CONE (mrph)
(declare (type morphism mrph)) (declare (type morphism mrph))
(the chain-complex (the chain-complex
(let ((chcm0 (trgt mrph)) (let ((chcm0 (trgt mrph))
(chcm1 (sorc mrph))) (chcm1 (sorc mrph)))
(declare (type chain-complex chcm0 chcm1)) (declare (type chain-complex chcm0 chcm1))
(build-chcm (build-chcm
:cmpr (cone-cmpr (cmpr chcm0) (cmpr chcm1)) :cmpr (cone-cmpr (cmpr chcm0) (cmpr chcm1))
:basis (cone-basis (basis chcm0) (basis chcm1)) :basis (cone-basis (basis chcm0) (basis chcm1))
:bsgn (con0 (bsgn chcm0)) :bsgn (con0 (bsgn chcm0))
:intr-dffr (cone-3mrph-triangle-impl (cmpr chcm0) :intr-dffr (cone-3mrph-triangle-impl (cmpr chcm0)
(dffr chcm0) (dffr chcm0)
(n-mrph -1 (dffr chcm1)) (n-mrph -1 (dffr chcm1))
mrph) mrph)
:strt :gnrt :strt :gnrt
:orgn `(cone ,mrph))))) :orgn `(cone ,mrph)))))
(DEFUN CONE-2MRPH-DIAG (sorc-cone trgt-cone mrph0 mrph1) (DEFUN CONE-2MRPH-DIAG (sorc-cone trgt-cone mrph0 mrph1)
@ -188,15 +190,15 @@
(type morphism mrph0 mrph1)) (type morphism mrph0 mrph1))
(the morphism (the morphism
(progn (progn
(unless (= (degr mrph0) (degr mrph1)) (unless (= (degr mrph0) (degr mrph1))
(error "Non-coherent degrees in CONE-2MRPH-DIAG.")) (error "Non-coherent degrees in CONE-2MRPH-DIAG."))
(build-mrph (build-mrph
:sorc sorc-cone :sorc sorc-cone
:trgt trgt-cone :trgt trgt-cone
:degr (degr mrph0) :degr (degr mrph0)
:intr (cone-2mrph-diag-impl mrph0 mrph1) :intr (cone-2mrph-diag-impl mrph0 mrph1)
:strt :cmbn :strt :cmbn
:orgn `(cone-2mrph-diag ,sorc-cone ,trgt-cone ,mrph0 ,mrph1))))) :orgn `(cone-2mrph-diag ,sorc-cone ,trgt-cone ,mrph0 ,mrph1)))))
(DEFUN CONE-3MRPH-TRIANGLE (sorc-cone trgt-cone mrph0 mrph1 phi) (DEFUN CONE-3MRPH-TRIANGLE (sorc-cone trgt-cone mrph0 mrph1 phi)
@ -205,55 +207,55 @@
(type morphism mrph0 mrph1 phi)) (type morphism mrph0 mrph1 phi))
(the morphism (the morphism
(progn (progn
(unless (= (degr mrph0) (degr mrph1)) (unless (= (degr mrph0) (degr mrph1))
(error "Non-coherent degrees in CONE-3MRPH-TRIANGLE.")) (error "Non-coherent degrees in CONE-3MRPH-TRIANGLE."))
(unless (= (1+ (degr mrph0)) (degr phi)) (unless (= (1+ (degr mrph0)) (degr phi))
(error "Non-coherent-degrees in CONE-3MRPH-TRIANGLE.")) (error "Non-coherent-degrees in CONE-3MRPH-TRIANGLE."))
(build-mrph (build-mrph
:sorc sorc-cone :sorc sorc-cone
:trgt trgt-cone :trgt trgt-cone
:degr (degr mrph0) :degr (degr mrph0)
:intr (cone-3mrph-triangle-impl :intr (cone-3mrph-triangle-impl
(cmpr (trgt phi)) (cmpr (trgt phi))
mrph0 mrph1 phi) mrph0 mrph1 phi)
:strt :gnrt :strt :gnrt
:orgn `(cone-3mrph-triangle ,sorc-cone ,trgt-cone :orgn `(cone-3mrph-triangle ,sorc-cone ,trgt-cone
,mrph0 ,mrph1 ,phi))))) ,mrph0 ,mrph1 ,phi)))))
(DEFUN CONE-EFHM (cone) (DEFUN CONE-EFHM (cone)
(declare (type chain-complex cone)) (declare (type chain-complex cone))
(the homotopy-equivalence (the homotopy-equivalence
(let* ((phi (second (orgn cone))) (let* ((phi (second (orgn cone)))
(chcm0 (trgt phi)) (chcm1 (sorc phi)) (chcm0 (trgt phi)) (chcm1 (sorc phi))
(efhm0 (efhm chcm0)) (efhm1 (efhm chcm1)) (efhm0 (efhm chcm0)) (efhm1 (efhm chcm1))
(lf0 (lf efhm0)) (lg0 (lg efhm0)) (lh0 (lh efhm0)) (lf0 (lf efhm0)) (lg0 (lg efhm0)) (lh0 (lh efhm0))
(rf0 (rf efhm0)) (rg0 (rg efhm0)) (rh0 (rh efhm0)) (rf0 (rf efhm0)) (rg0 (rg efhm0)) (rh0 (rh efhm0))
(lf1 (lf efhm1)) (lg1 (lg efhm1)) (lh1 (lh efhm1)) (lf1 (lf efhm1)) (lg1 (lg efhm1)) (lh1 (lh efhm1))
(rf1 (rf efhm1)) (rg1 (rg efhm1)) (rh1 (rh efhm1)) (rf1 (rf efhm1)) (rg1 (rg efhm1)) (rh1 (rh efhm1))
(hphi (cmps lg0 (cmps phi lf1))) (hphi (cmps lg0 (cmps phi lf1)))
(ephi (cmps rf0 (cmps hphi rg1))) (ephi (cmps rf0 (cmps hphi rg1)))
(hcone (cone hphi)) (hcone (cone hphi))
(econe (cone ephi)) (econe (cone ephi))
(LF (cone-2mrph-diag hcone cone lf0 lf1)) (LF (cone-2mrph-diag hcone cone lf0 lf1))
(LG (cone-2mrph-diag cone hcone lg0 lg1)) (LG (cone-2mrph-diag cone hcone lg0 lg1))
(LH (cone-2mrph-diag hcone hcone lh0 (n-mrph -1 lh1))) (LH (cone-2mrph-diag hcone hcone lh0 (n-mrph -1 lh1)))
(RF (cone-3mrph-triangle hcone econe rf0 rf1 (RF (cone-3mrph-triangle hcone econe rf0 rf1
(cmps rf0 (cmps hphi rh1)))) (cmps rf0 (cmps hphi rh1))))
(RG (cone-3mrph-triangle econe hcone rg0 rg1 (RG (cone-3mrph-triangle econe hcone rg0 rg1
(n-mrph -1 (cmps rh0 (cmps hphi rg1))))) (n-mrph -1 (cmps rh0 (cmps hphi rg1)))))
(RH (cone-3mrph-triangle hcone hcone rh0 (n-mrph -1 rh1) (RH (cone-3mrph-triangle hcone hcone rh0 (n-mrph -1 rh1)
(cmps rh0 (cmps hphi rh1))))) (cmps rh0 (cmps hphi rh1)))))
(declare (declare
(type chain-complex chcm0 chcm1 hcone econe) (type chain-complex chcm0 chcm1 hcone econe)
(type morphism phi lf0 lg0 lh0 rf0 rg0 rh0 lf1 lg1 lh1 rf1 rg1 rh1 (type morphism phi lf0 lg0 lh0 rf0 rg0 rh0 lf1 lg1 lh1 rf1 rg1 rh1
hphi ephi LF LG LH RF RG RH)) hphi ephi LF LG LH RF RG RH))
(build-hmeq (build-hmeq
:lrdct (build-rdct :f LF :g LG :h LH :lrdct (build-rdct :f LF :g LG :h LH
:orgn `(cone-efhm ,cone lrdct)) :orgn `(cone-efhm ,cone lrdct))
:rrdct (build-rdct :f RF :g RG :h RH :rrdct (build-rdct :f RF :g RG :h RH
:orgn `(cone-efhm ,cone rrdct)) :orgn `(cone-efhm ,cone rrdct))
:orgn `(cone-efhm ,cone))))) :orgn `(cone-efhm ,cone)))))
(DEFMETHOD SEARCH-EFHM (chcm (orgn (eql 'cone))) (DEFMETHOD SEARCH-EFHM (chcm (orgn (eql 'cone)))
(declare (type chain-complex chcm)) (declare (type chain-complex chcm))

70
src/cs-twisted-products.lisp
View File

@ -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 ;;; 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)) (declare (type simplicial-group smgr))
(the fibration (the fibration
(build-smmr (build-smmr
:sorc (classifying-space smgr) :sorc (classifying-space smgr)
:trgt smgr :trgt smgr
:degr -1 :degr -1
:sintr #'smgr-fibration-sintr :sintr #'smgr-fibration-sintr
:orgn `(simplicial-group-fibration ,smgr)))) :orgn `(simplicial-group-fibration ,smgr))))
(DEFUN SMGR-CRTS-CONTRACTION-INTR (idnt) (DEFUN SMGR-CRTS-CONTRACTION-INTR (idnt)
(declare (declare
(type gmsm idnt)) (type gmsm idnt))
(flet ((rslt (degr crpr (flet ((rslt (degr crpr
&aux (degr+1 (1+ degr))) &aux (degr+1 (1+ degr)))
(declare (declare
(fixnum degr degr+1) (fixnum degr degr+1)
(type crpr crpr)) (type crpr crpr))
(the cmbn (the cmbn
(with-crpr (with-crpr
(absm1 absm2) crpr (absm1 absm2) crpr
(if (= (dgop absm2) (mask degr)) (if (= (dgop absm2) (mask degr))
(zero-cmbn degr+1) (zero-cmbn degr+1)
(term-cmbn degr+1 (term-cmbn degr+1
(-1-expt-n+1 degr) (-1-expt-n+1 degr)
(crpr 0 (make-gbar (crpr 0 (make-gbar
:dmns degr+1 :dmns degr+1
:list (cons absm2 :list (cons absm2
(rest (rest
(unnormalize-gbar (unnormalize-gbar
absm1 idnt)))) absm1 idnt))))
(mask degr+1) idnt))))))) (mask degr+1) idnt)))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
@ -53,20 +55,20 @@
(declare (type simplicial-group smgr)) (declare (type simplicial-group smgr))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc (fibration-total (smgr-fibration smgr)) :sorc (fibration-total (smgr-fibration smgr))
:trgt (fibration-total (smgr-fibration smgr)) :trgt (fibration-total (smgr-fibration smgr))
:degr +1 :degr +1
:intr (smgr-crts-contraction-intr (bspn smgr)) :intr (smgr-crts-contraction-intr (bspn smgr))
:strt :gnrt :strt :gnrt
:orgn `(smgr-crts-contraction ,smgr)))) :orgn `(smgr-crts-contraction ,smgr))))
(DEFUN SMGR-TNPR-CONTRACTION (smgr (DEFUN SMGR-TNPR-CONTRACTION (smgr
&aux (fibration (smgr-fibration smgr)) &aux (fibration (smgr-fibration smgr))
(brown (brown-reduction fibration)) (brown (brown-reduction fibration))
(f (f brown)) (f (f brown))
(g (g brown)) (g (g brown))
(chi (smgr-crts-contraction smgr))) (chi (smgr-crts-contraction smgr)))
(declare (declare
(type simplicial-group smgr) (type simplicial-group smgr)
(type fibration fibration) (type fibration fibration)

324
src/delta.lisp
View File

@ -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 ;;; 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)) (ignore dmns))
(the absm (the absm
(do ((pmark 1 (ash pmark 1)) (do ((pmark 1 (ash pmark 1))
(bmark indx) (bmark indx)
(gmsm2 gmsm (ash gmsm2 -1))) (gmsm2 gmsm (ash gmsm2 -1)))
(nil) (nil)
(declare (fixnum pmark bmark gmsm2)) (declare (fixnum pmark bmark gmsm2))
(when (oddp gmsm2) (when (oddp gmsm2)
(when (minusp (decf bmark)) (when (minusp (decf bmark))
(return-from delta-face (absm 0 (logxor gmsm pmark)))))))) (return-from delta-face (absm 0 (logxor gmsm pmark))))))))
(DEFUN SOFT-DELTA-FACE (indx dmns gmsm) (DEFUN SOFT-DELTA-FACE (indx dmns gmsm)
@ -45,20 +47,20 @@
(declare (fixnum dmns gmsm)) (declare (fixnum dmns gmsm))
(the cmbn (the cmbn
(if (zerop dmns) (if (zerop dmns)
+zero-negative-cmbn+ +zero-negative-cmbn+
(make-cmbn (make-cmbn
:degr (1- dmns) :degr (1- dmns)
:list (do ((rslt +empty-list+) :list (do ((rslt +empty-list+)
(gmsm2 gmsm (ash gmsm2 -1)) (gmsm2 gmsm (ash gmsm2 -1))
(pmark 1 (ash pmark +1)) (pmark 1 (ash pmark +1))
(sign 1)) (sign 1))
((zerop gmsm2) rslt) ((zerop gmsm2) rslt)
(declare (declare
(list rslt) (list rslt)
(fixnum gmsm2 pmark sign)) (fixnum gmsm2 pmark sign))
(when (oddp gmsm2) (when (oddp gmsm2)
(push (term sign (logxor gmsm pmark)) rslt) (push (term sign (logxor gmsm pmark)) rslt)
(setf sign (- sign)))))))) (setf sign (- sign))))))))
(DEFUN SOFT-DELTA-BNDR (dmns gmsm) (DEFUN SOFT-DELTA-BNDR (dmns gmsm)
@ -68,30 +70,30 @@
(make-cmbn (make-cmbn
:degr (1- dmns) :degr (1- dmns)
:list (mapcar #'(lambda (term) :list (mapcar #'(lambda (term)
(with-term (cffc gmsm) term (with-term (cffc gmsm) term
(term cffc (d gmsm)))) (term cffc (d gmsm))))
(cmbn-list (delta-bndr dmns (cdr gmsm)))))) (cmbn-list (delta-bndr dmns (cdr gmsm))))))
(DEFUN DELTA-DGNL (dmns gmsm) (DEFUN DELTA-DGNL (dmns gmsm)
(declare (fixnum dmns gmsm)) (declare (fixnum dmns gmsm))
(the cmbn (the cmbn
(make-cmbn (make-cmbn
:degr dmns :degr dmns
:list (do ((rslt +empty-list+) :list (do ((rslt +empty-list+)
(ldegr dmns) (ldegr dmns)
(indx (1- (integer-length gmsm)) (1- indx))) (indx (1- (integer-length gmsm)) (1- indx)))
((minusp indx)) ((minusp indx))
(declare (declare
(list rslt) (list rslt)
(fixnum indx)) (fixnum indx))
(when (logbitp indx gmsm) (when (logbitp indx gmsm)
(push (term 1 (tnpr (push (term 1 (tnpr
ldegr (logand gmsm (mask (1+ indx))) ldegr (logand gmsm (mask (1+ indx)))
(- dmns ldegr) (logandc2 gmsm (mask indx)))) (- dmns ldegr) (logandc2 gmsm (mask indx))))
rslt) rslt)
(when (minusp (decf ldegr)) (when (minusp (decf ldegr))
(return rslt))))))) (return rslt)))))))
(DEFUN SOFT-DELTA-DGNL (dmns gmsm) (DEFUN SOFT-DELTA-DGNL (dmns gmsm)
@ -99,72 +101,72 @@
(fixnum dmns) (fixnum dmns)
(type soft-dlop gmsm)) (type soft-dlop gmsm))
(make-cmbn :degr dmns (make-cmbn :degr dmns
:list (mapcar :list (mapcar
#'(lambda (term) #'(lambda (term)
(with-term (cffc tnpr) term (with-term (cffc tnpr) term
(with-tnpr (degr1 gmsm1 degr2 gmsm2) tnpr (with-tnpr (degr1 gmsm1 degr2 gmsm2) tnpr
(term cffc (term cffc
(tnpr degr1 (d gmsm1) (tnpr degr1 (d gmsm1)
degr2 (d gmsm2)))))) degr2 (d gmsm2))))))
(cmbn-list (delta-dgnl dmns (cdr gmsm)))))) (cmbn-list (delta-dgnl dmns (cdr gmsm))))))
(DEFUN DELTA-INFINITY () (DEFUN DELTA-INFINITY ()
(the simplicial-set (the simplicial-set
(build-smst (build-smst
:cmpr #'f-cmpr :cmpr #'f-cmpr
:basis :locally-effective :basis :locally-effective
:bspn 1 :bspn 1
:face #'delta-face :face #'delta-face
:intr-dgnl #'delta-dgnl :intr-dgnl #'delta-dgnl
:dgnl-strt :gnrt :dgnl-strt :gnrt
:intr-bndr #'delta-bndr :intr-bndr #'delta-bndr
:bndr-strt :gnrt :bndr-strt :gnrt
:orgn '(delta-infinity)))) :orgn '(delta-infinity))))
(DEFUN SOFT-DELTA-INFINITY () (DEFUN SOFT-DELTA-INFINITY ()
(the simplicial-set (the simplicial-set
(build-smst (build-smst
:cmpr #'soft-delta-cmpr :cmpr #'soft-delta-cmpr
:basis :locally-effective :basis :locally-effective
:bspn (d 1) :bspn (d 1)
:face #'soft-delta-face :face #'soft-delta-face
:intr-dgnl #'soft-delta-dgnl :dgnl-strt :gnrt :intr-dgnl #'soft-delta-dgnl :dgnl-strt :gnrt
:intr-bndr #'soft-delta-bndr :bndr-strt :gnrt :intr-bndr #'soft-delta-bndr :bndr-strt :gnrt
:orgn '(soft-delta-infinity)))) :orgn '(soft-delta-infinity))))
(DEFUN DELTA-N-BASIS (n) (DEFUN DELTA-N-BASIS (n)
(declare (fixnum n)) (declare (fixnum n))
(flet ((rslt (dmns) (flet ((rslt (dmns)
(declare (fixnum dmns)) (declare (fixnum dmns))
(when (> dmns n) (when (> dmns n)
(return-from rslt +empty-list+)) (return-from rslt +empty-list+))
(setf dmns (1+ dmns)) (setf dmns (1+ dmns))
(do ((rslt +empty-list+) (do ((rslt +empty-list+)
(count (binomial-n-p (1+ n) dmns)) (count (binomial-n-p (1+ n) dmns))
(gmsm (mask (1+ n)) (1- gmsm))) (gmsm (mask (1+ n)) (1- gmsm)))
((zerop count) rslt) ((zerop count) rslt)
(when (= (logcount gmsm) dmns) (when (= (logcount gmsm) dmns)
(push gmsm rslt) (push gmsm rslt)
(decf count))))) (decf count)))))
(the basis #'rslt))) (the basis #'rslt)))
(DEFUN SOFT-DELTA-N-BASIS (n) (DEFUN SOFT-DELTA-N-BASIS (n)
(declare (fixnum n)) (declare (fixnum n))
(flet ((rslt (dmns) (flet ((rslt (dmns)
(when (> dmns n) (when (> dmns n)
(return-from rslt +empty-list+)) (return-from rslt +empty-list+))
(setf dmns (1+ dmns)) (setf dmns (1+ dmns))
(do ((rslt +empty-list+) (do ((rslt +empty-list+)
(count (binomial-n-p (1+ n) dmns)) (count (binomial-n-p (1+ n) dmns))
(gmsm (mask (1+ n)) (1- gmsm))) (gmsm (mask (1+ n)) (1- gmsm)))
((zerop count) rslt) ((zerop count) rslt)
(when (= (logcount gmsm) dmns) (when (= (logcount gmsm) dmns)
(push (d gmsm) rslt) (push (d gmsm) rslt)
(decf count))))) (decf count)))))
(the basis #'rslt))) (the basis #'rslt)))
@ -172,28 +174,28 @@
(declare (fixnum dmns)) (declare (fixnum dmns))
(the simplicial-set (the simplicial-set
(build-smst (build-smst
:cmpr #'f-cmpr :cmpr #'f-cmpr
:basis (delta-n-basis dmns) :basis (delta-n-basis dmns)
:bspn 1 :bspn 1
:face #'delta-face :face #'delta-face
:intr-dgnl #'delta-dgnl :intr-dgnl #'delta-dgnl
:dgnl-strt :gnrt :dgnl-strt :gnrt
:intr-bndr #'delta-bndr :intr-bndr #'delta-bndr
:bndr-strt :gnrt :bndr-strt :gnrt
:orgn `(delta ,dmns)))) :orgn `(delta ,dmns))))
(DEFUN SOFT-DELTA (dmns) (DEFUN SOFT-DELTA (dmns)
(declare (fixnum dmns)) (declare (fixnum dmns))
(the simplicial-set (the simplicial-set
(build-smst (build-smst
:cmpr #'soft-delta-cmpr :cmpr #'soft-delta-cmpr
:basis (soft-delta-n-basis dmns) :basis (soft-delta-n-basis dmns)
:bspn (d 1) :bspn (d 1)
:face #'soft-delta-face :face #'soft-delta-face
:intr-dgnl #'soft-delta-dgnl :dgnl-strt :gnrt :intr-dgnl #'soft-delta-dgnl :dgnl-strt :gnrt
:intr-bndr #'soft-delta-bndr :bndr-strt :gnrt :intr-bndr #'soft-delta-bndr :bndr-strt :gnrt
:orgn `(soft-delta ,dmns)))) :orgn `(soft-delta ,dmns))))
(DEFUN DELTAB-CMPR (gmsm1 gmsm2) (DEFUN DELTAB-CMPR (gmsm1 gmsm2)
@ -207,20 +209,20 @@
(declare (fixnum dmns gmsm)) (declare (fixnum dmns gmsm))
(the cmbn (the cmbn
(if (< dmns 2) (if (< dmns 2)
(zero-cmbn (1- dmns)) (zero-cmbn (1- dmns))
(make-cmbn (make-cmbn
:degr (1- dmns) :degr (1- dmns)
:list (do ((rslt +empty-list+) :list (do ((rslt +empty-list+)
(gmsm2 gmsm (ash gmsm2 -1)) (gmsm2 gmsm (ash gmsm2 -1))
(pmark 1 (ash pmark +1)) (pmark 1 (ash pmark +1))
(sign 1)) (sign 1))
((zerop gmsm2) rslt) ((zerop gmsm2) rslt)
(declare (declare
(list rslt) (list rslt)
(fixnum gmsm2 pmark sign)) (fixnum gmsm2 pmark sign))
(when (oddp gmsm2) (when (oddp gmsm2)
(push (term sign (logxor gmsm pmark)) rslt) (push (term sign (logxor gmsm pmark)) rslt)
(setf sign (- sign)))))))) (setf sign (- sign))))))))
(DEFUN DELTAB2-FACE (indx dmns gmsm) (DEFUN DELTAB2-FACE (indx dmns gmsm)
@ -228,87 +230,87 @@
(fixnum indx dmns gmsm)) (fixnum indx dmns gmsm))
(the absm (the absm
(progn (progn
(when (= 2 dmns) (when (= 2 dmns)
(return-from deltab2-face (absm 1 1))) (return-from deltab2-face (absm 1 1)))
(do ((pmark 1 (ash pmark 1)) (do ((pmark 1 (ash pmark 1))
(bmark indx) (bmark indx)
(gmsm2 gmsm (ash gmsm2 -1))) (gmsm2 gmsm (ash gmsm2 -1)))
(nil) (nil)
(declare (fixnum pmark bmark gmsm2)) (declare (fixnum pmark bmark gmsm2))
(when (oddp gmsm2) (when (oddp gmsm2)
(when (minusp (decf bmark)) (when (minusp (decf bmark))
(return-from deltab2-face (absm 0 (logxor gmsm pmark))))))))) (return-from deltab2-face (absm 0 (logxor gmsm pmark)))))))))
(DEFUN DELTAB2-DGNL (dmns gmsm) (DEFUN DELTAB2-DGNL (dmns gmsm)
(declare (fixnum dmns gmsm)) (declare (fixnum dmns gmsm))
(the cmbn (the cmbn
(make-cmbn (make-cmbn
:degr dmns :degr dmns
:list (if (zerop dmns) :list (if (zerop dmns)
(list (term 1 (tnpr 0 gmsm 0 gmsm))) (list (term 1 (tnpr 0 gmsm 0 gmsm)))
(do ((rslt +empty-list+) (do ((rslt +empty-list+)
(ldegr dmns) (ldegr dmns)
(indx (1- (integer-length gmsm)) (1- indx))) (indx (1- (integer-length gmsm)) (1- indx)))
((minusp indx)) ((minusp indx))
(declare (list rslt) (fixnum indx)) (declare (list rslt) (fixnum indx))
(when (logbitp indx gmsm) (when (logbitp indx gmsm)
(push (term 1 (tnpr (push (term 1 (tnpr
ldegr (logand gmsm (mask (1+ indx))) ldegr (logand gmsm (mask (1+ indx)))
(- dmns ldegr) (- dmns ldegr)
(logandc2 gmsm (mask indx)))) (logandc2 gmsm (mask indx))))
rslt) rslt)
(when (minusp (decf ldegr)) (when (minusp (decf ldegr))
(setf rslt (delete 1 rslt (setf rslt (delete 1 rslt
:key #'(lambda (x) :key #'(lambda (x)
(degr1 (cdr x))))) (degr1 (cdr x)))))
(setf (gnrt1 (gnrt (first rslt))) (setf (gnrt1 (gnrt (first rslt)))
(setf (gnrt2 (gnrt (car (last rslt)))) (setf (gnrt2 (gnrt (car (last rslt))))
1)) 1))
(return (delete 1 rslt (return (delete 1 rslt
:key #'(lambda (x) :key #'(lambda (x)
(gnrt1 (cdr x)))))))))))) (gnrt1 (cdr x))))))))))))
(DEFUN DELTAB2-BNDR (dmns gmsm) (DEFUN DELTAB2-BNDR (dmns gmsm)
(declare (fixnum dmns gmsm)) (declare (fixnum dmns gmsm))
(the cmbn (the cmbn
(if (< dmns 3) (if (< dmns 3)
(zero-cmbn (1- dmns)) (zero-cmbn (1- dmns))
(make-cmbn (make-cmbn
:degr (1- dmns) :degr (1- dmns)
:list (do ((rslt +empty-list+) :list (do ((rslt +empty-list+)
(gmsm2 gmsm (ash gmsm2 -1)) (gmsm2 gmsm (ash gmsm2 -1))
(pmark 1 (ash pmark +1)) (pmark 1 (ash pmark +1))
(sign 1)) (sign 1))
((zerop gmsm2) rslt) ((zerop gmsm2) rslt)
(declare (declare
(list rslt) (list rslt)
(fixnum gmsm2 pmark sign)) (fixnum gmsm2 pmark sign))
(when (oddp gmsm2) (when (oddp gmsm2)
(push (term sign (logxor gmsm pmark)) rslt) (push (term sign (logxor gmsm pmark)) rslt)
(setf sign (- sign)))))))) (setf sign (- sign))))))))
(DEFUN DELTAB () (DEFUN DELTAB ()
(the simplicial-set (the simplicial-set
(build-smst (build-smst
:cmpr #'deltab-cmpr :cmpr #'deltab-cmpr
:basis :locally-effective :basis :locally-effective
:bspn 1 :bspn 1
:face #'delta-face :face #'delta-face
:intr-dgnl #'delta-dgnl :intr-dgnl #'delta-dgnl
:dgnl-strt :gnrt :dgnl-strt :gnrt
:orgn '(deltab)))) :orgn '(deltab))))
(DEFUN DELTAB2 () (DEFUN DELTAB2 ()
(the simplicial-set (the simplicial-set
(build-smst (build-smst
:cmpr #'f-cmpr :cmpr #'f-cmpr
:basis :locally-effective :basis :locally-effective
:bspn 1 :bspn 1
:face #'deltab2-face :face #'deltab2-face
:intr-dgnl #'deltab2-dgnl :intr-dgnl #'deltab2-dgnl
:dgnl-strt :gnrt :dgnl-strt :gnrt
:orgn '(deltab2)))) :orgn '(deltab2))))

294
src/disk-pasting.lisp
View File

@ -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 ;;; 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) (type cmprf cmpr)
(symbol new)) (symbol new))
(flet ((rslt (gnrt1 gnrt2) (flet ((rslt (gnrt1 gnrt2)
(declare (type gnrt gnrt1 gnrt2)) (declare (type gnrt gnrt1 gnrt2))
(if (eq gnrt1 new) (if (eq gnrt1 new)
(if (eq gnrt2 new) (if (eq gnrt2 new)
:equal :equal
:less) :less)
(if (eq gnrt2 new) (if (eq gnrt2 new)
:greater :greater
(funcall cmpr gnrt1 gnrt2))))) (funcall cmpr gnrt1 gnrt2)))))
(the cmprf #'rslt))) (the cmprf #'rslt)))
@ -28,10 +30,10 @@
(fixnum dmns) (fixnum dmns)
(symbol new)) (symbol new))
(flet ((rslt (degr) (flet ((rslt (degr)
(declare (fixnum degr)) (declare (fixnum degr))
(if (= degr dmns) (if (= degr dmns)
(cons new (funcall basis dmns)) (cons new (funcall basis dmns))
(funcall basis degr)))) (funcall basis degr))))
(the basis #'rslt))) (the basis #'rslt)))
@ -46,22 +48,22 @@
(let ((cmpr (cmpr (trgt old-dffr)))) (let ((cmpr (cmpr (trgt old-dffr))))
(declare (type cmprf cmpr)) (declare (type cmprf cmpr))
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(with-cmbn (degr2 list) cmbn (with-cmbn (degr2 list) cmbn
(unless (= degr degr2) (unless (= degr degr2)
(return-from rslt (return-from rslt
(cmbn-? old-dffr cmbn))) (cmbn-? old-dffr cmbn)))
(unless list (unless list
(return-from rslt (return-from rslt
(zero-cmbn (1- degr)))) (zero-cmbn (1- degr))))
(unless (eq (-gnrt list) new) (unless (eq (-gnrt list) new)
(return-from rslt (return-from rslt
(cmbn-? old-dffr cmbn))) (cmbn-? old-dffr cmbn)))
(2cmbn-add cmpr (2cmbn-add cmpr
(n-cmbn (-cffc list) bndr) (n-cmbn (-cffc list) bndr)
(cmbn-? old-dffr (cmbn-? old-dffr
(make-cmbn :degr degr (make-cmbn :degr degr
:list (rest list))))))) :list (rest list)))))))
(the intr-mrph #'rslt)))) (the intr-mrph #'rslt))))
@ -73,20 +75,20 @@
(type cmbn bndr)) (type cmbn bndr))
(the chain-complex (the chain-complex
(with-slots (cmpr basis dffr) chcm (with-slots (cmpr basis dffr) chcm
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(type basis basis) (type basis basis)
(type morphism dffr)) (type morphism dffr))
(let ((rslt (build-chcm (let ((rslt (build-chcm
:cmpr (disk-pasting-cmpr cmpr new) :cmpr (disk-pasting-cmpr cmpr new)
:basis (disk-pasting-basis basis dmns new) :basis (disk-pasting-basis basis dmns new)
:intr-dffr (disk-pasting-intr-dffr dffr dmns new bndr) :intr-dffr (disk-pasting-intr-dffr dffr dmns new bndr)
:strt :cmbn :strt :cmbn
:orgn `(chcm-disk-pasting ,chcm ,dmns ,new ,bndr)))) :orgn `(chcm-disk-pasting ,chcm ,dmns ,new ,bndr))))
(declare (type chain-complex rslt)) (declare (type chain-complex rslt))
(when (slot-boundp chcm 'bsgn) (when (slot-boundp chcm 'bsgn)
(setf (slot-value rslt 'bsgn) (slot-value chcm 'bsgn))) (setf (slot-value rslt 'bsgn) (slot-value chcm 'bsgn)))
rslt)))) rslt))))
(DEFUN DISK-PASTING-FACE (cmpr face dmns new faces) (DEFUN DISK-PASTING-FACE (cmpr face dmns new faces)
@ -99,20 +101,20 @@
(unless (= (1+ dmns) (length faces)) (unless (= (1+ dmns) (length faces))
(error "In DISK-PASTING, non-coherent arguments.")) (error "In DISK-PASTING, non-coherent arguments."))
(mapl #'(lambda (mark) (mapl #'(lambda (mark)
(declare (list mark)) (declare (list mark))
(unless (typep (car mark) 'absm) (unless (typep (car mark) 'absm)
(setf (car mark) (absm 0 (car mark))))) (setf (car mark) (absm 0 (car mark)))))
faces) faces)
(flet ((rslt (indx dmns2 gmsm) (flet ((rslt (indx dmns2 gmsm)
(declare (declare
(fixnum indx dmns2) (fixnum indx dmns2)
(type gmsm gmsm)) (type gmsm gmsm))
(unless (= dmns dmns2) (unless (= dmns dmns2)
(return-from rslt (return-from rslt
(funcall face indx dmns2 gmsm))) (funcall face indx dmns2 gmsm)))
(if (eq gmsm new) (if (eq gmsm new)
(nth indx faces) (nth indx faces)
(funcall face indx dmns gmsm)))) (funcall face indx dmns gmsm))))
(unless (check-faces cmpr #'rslt dmns new) (unless (check-faces cmpr #'rslt dmns new)
(error "The new simplicial-set is not constructed.")) (error "The new simplicial-set is not constructed."))
(the face #'rslt))) (the face #'rslt)))
@ -126,37 +128,37 @@
(list faces)) (list faces))
(the simplicial-set (the simplicial-set
(with-slots (cmpr basis bsgn face dffr) smst (with-slots (cmpr basis bsgn face dffr) smst
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(type basis basis) (type basis basis)
(type gmsm bsgn) (type gmsm bsgn)
(type face face) (type face face)
(type morphism dffr)) (type morphism dffr))
(let ((new-face (disk-pasting-face (cmpr smst) face (let ((new-face (disk-pasting-face (cmpr smst) face
dmns new faces)) dmns new faces))
(new-bndr (zero-cmbn (1- dmns)))) (new-bndr (zero-cmbn (1- dmns))))
(declare (declare
(type face new-face) (type face new-face)
(type cmbn new-bndr)) (type cmbn new-bndr))
(do ((mark faces (cdr mark)) (do ((mark faces (cdr mark))
(sign 1 (- sign))) (sign 1 (- sign)))
((endp mark)) ((endp mark))
(declare (declare
(list mark) (list mark)
(fixnum sign)) (fixnum sign))
(let ((absm (car mark))) (let ((absm (car mark)))
(declare (type absm absm)) (declare (type absm absm))
(with-absm (dgop gmsm) absm (with-absm (dgop gmsm) absm
(unless (plusp dgop) (unless (plusp dgop)
(dstr-add-term-to-cmbn cmpr sign gmsm new-bndr))))) (dstr-add-term-to-cmbn cmpr sign gmsm new-bndr)))))
(build-smst (build-smst
:cmpr (disk-pasting-cmpr cmpr new) :cmpr (disk-pasting-cmpr cmpr new)
:basis (disk-pasting-basis basis dmns new) :basis (disk-pasting-basis basis dmns new)
:bspn bsgn :bspn bsgn
:face new-face :face new-face
:intr-bndr (disk-pasting-intr-dffr dffr dmns new new-bndr) :intr-bndr (disk-pasting-intr-dffr dffr dmns new new-bndr)
:bndr-strt :cmbn :bndr-strt :cmbn
:orgn `(disk-pasting ,smst ,dmns ,new ,faces)))))) :orgn `(disk-pasting ,smst ,dmns ,new ,faces))))))
(DEFUN MRPH-DISK-PASTING-INTR (mrph trgt-cmpr dmns new new-im) (DEFUN MRPH-DISK-PASTING-INTR (mrph trgt-cmpr dmns new new-im)
@ -169,22 +171,22 @@
(let ((mrph-degr (degr mrph))) (let ((mrph-degr (degr mrph)))
(declare (fixnum mrph-degr)) (declare (fixnum mrph-degr))
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(with-cmbn (degr list) cmbn (with-cmbn (degr list) cmbn
(unless (= degr dmns) (unless (= degr dmns)
(return-from rslt (return-from rslt
(cmbn-? mrph cmbn))) (cmbn-? mrph cmbn)))
(unless list (unless list
(return-from rslt (return-from rslt
(zero-cmbn (+ degr mrph-degr)))) (zero-cmbn (+ degr mrph-degr))))
(unless (eq new (-gnrt list)) (unless (eq new (-gnrt list))
(return-from rslt (return-from rslt
(cmbn-? mrph cmbn))) (cmbn-? mrph cmbn)))
(2cmbn-add trgt-cmpr (2cmbn-add trgt-cmpr
(n-cmbn (-cffc list) new-im) (n-cmbn (-cffc list) new-im)
(cmbn-? mrph (cmbn-? mrph
(make-cmbn :degr degr (make-cmbn :degr degr
:list (rest list))))))) :list (rest list)))))))
(the intr-mrph #'rslt)))) (the intr-mrph #'rslt))))
@ -197,12 +199,12 @@
(type cmbn new-im)) (type cmbn new-im))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc new-sorc :trgt new-trgt :degr (degr mrph) :sorc new-sorc :trgt new-trgt :degr (degr mrph)
:intr (mrph-disk-pasting-intr mrph (cmpr new-trgt) :intr (mrph-disk-pasting-intr mrph (cmpr new-trgt)
dmns new new-im) dmns new new-im)
:strt :cmbn :strt :cmbn
:orgn `(mrph-disk-pasting ,mrph ,new-sorc ,new-trgt :orgn `(mrph-disk-pasting ,mrph ,new-sorc ,new-trgt
,dmns ,new ,new-im)))) ,dmns ,new ,new-im))))
(DEFUN HMEQ-DISK-PASTING (hmeq dmns new bndr &key new-lbcc) (DEFUN HMEQ-DISK-PASTING (hmeq dmns new bndr &key new-lbcc)
@ -213,18 +215,18 @@
(type cmbn bndr) (type cmbn bndr)
(type (or null chain-complex) new-lbcc)) (type (or null chain-complex) new-lbcc))
(let* ((lg (lg hmeq)) (let* ((lg (lg hmeq))
(rf (rf hmeq)) (rf (rf hmeq))
(rh (rh hmeq)) (rh (rh hmeq))
(t-bndr (cmbn-? lg bndr)) (t-bndr (cmbn-? lg bndr))
(rb-bndr (cmbn-? rf t-bndr)) (rb-bndr (cmbn-? rf t-bndr))
(new-lbcc (or new-lbcc (new-lbcc (or new-lbcc
(chcm-disk-pasting (lbcc hmeq) (chcm-disk-pasting (lbcc hmeq)
dmns new bndr))) dmns new bndr)))
(new-tcc (chcm-disk-pasting (tcc hmeq) (new-tcc (chcm-disk-pasting (tcc hmeq)
dmns new t-bndr)) dmns new t-bndr))
(new-rbcc (chcm-disk-pasting (rbcc hmeq) (new-rbcc (chcm-disk-pasting (rbcc hmeq)
dmns new rb-bndr)) dmns new rb-bndr))
(1+dmns (1+ dmns))) (1+dmns (1+ dmns)))
(declare (declare
(type morphism lg rf rh) (type morphism lg rf rh)
(type cmbn t-bndr rb-bndr) (type cmbn t-bndr rb-bndr)
@ -232,25 +234,25 @@
(fixnum 1+dmns)) (fixnum 1+dmns))
(build-hmeq (build-hmeq
:lrdct (build-rdct :lrdct (build-rdct
:f (mrph-disk-pasting (lf hmeq) new-tcc new-lbcc :f (mrph-disk-pasting (lf hmeq) new-tcc new-lbcc
dmns new (cmbn dmns 1 new)) dmns new (cmbn dmns 1 new))
:g (mrph-disk-pasting lg new-lbcc new-tcc :g (mrph-disk-pasting lg new-lbcc new-tcc
dmns new (cmbn dmns 1 new)) dmns new (cmbn dmns 1 new))
:h (mrph-disk-pasting (lh hmeq) new-tcc new-tcc :h (mrph-disk-pasting (lh hmeq) new-tcc new-tcc
dmns new (zero-cmbn 1+dmns))) dmns new (zero-cmbn 1+dmns)))
:rrdct (build-rdct :rrdct (build-rdct
:f (mrph-disk-pasting rf new-tcc new-rbcc :f (mrph-disk-pasting rf new-tcc new-rbcc
dmns new (cmbn dmns 1 new)) dmns new (cmbn dmns 1 new))
:g (mrph-disk-pasting (rg hmeq) new-rbcc new-tcc :g (mrph-disk-pasting (rg hmeq) new-rbcc new-tcc
dmns new dmns new
(make-cmbn (make-cmbn
:degr dmns :degr dmns
:list (cons (term 1 new) :list (cons (term 1 new)
(cmbn-list (cmbn-list
(cmbn-opps (cmbn-opps
(cmbn-? rh t-bndr)))))) (cmbn-? rh t-bndr))))))
:h (mrph-disk-pasting rh new-tcc new-tcc :h (mrph-disk-pasting rh new-tcc new-tcc
dmns new (zero-cmbn 1+dmns))) dmns new (zero-cmbn 1+dmns)))
:orgn `(hmeq-disk-pasting ,hmeq ,dmns ,new ,bndr)))) :orgn `(hmeq-disk-pasting ,hmeq ,dmns ,new ,bndr))))
@ -258,11 +260,11 @@
(declare (type simplicial-set smst)) (declare (type simplicial-set smst))
(the homotopy-equivalence (the homotopy-equivalence
(destructuring-bind (old-smst dmns new faces) (rest (orgn smst)) (destructuring-bind (old-smst dmns new faces) (rest (orgn smst))
(declare (declare
(type simplicial-set old-smst) (type simplicial-set old-smst)
(fixnum dmns) (fixnum dmns)
(symbol new) (symbol new)
(ignore faces)) (ignore faces))
(hmeq-disk-pasting (efhm old-smst) (hmeq-disk-pasting (efhm old-smst)
dmns new (? smst dmns new) dmns new (? smst dmns new)
:new-lbcc smst)))) :new-lbcc smst))))

2
src/effective-homology.lisp
View File

@ -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 ;;; EFFECTIVE-HOMOLOGY EFFECTIVE-HOMOLOGY EFFECTIVE-HOMOLOGY
;;; EFFECTIVE-HOMOLOGY EFFECTIVE-HOMOLOGY EFFECTIVE-HOMOLOGY ;;; EFFECTIVE-HOMOLOGY EFFECTIVE-HOMOLOGY EFFECTIVE-HOMOLOGY

494
src/eilenberg-zilber.lisp
View File

@ -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 ;;; 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)) (declare (fixnum dgop))
(the fixnum (the fixnum
(do ((rslt +1) (do ((rslt +1)
(bit-position (- (integer-length dgop) 2) (1- bit-position)) (bit-position (- (integer-length dgop) 2) (1- bit-position))
(factor -1)) (factor -1))
((minusp bit-position) rslt) ((minusp bit-position) rslt)
(declare (fixnum rslt bit-position factor)) (declare (fixnum rslt bit-position factor))
(if (logbitp bit-position dgop) (if (logbitp bit-position dgop)
(setf factor (- factor)) (setf factor (- factor))
(setf rslt (* rslt factor)))))) (setf rslt (* rslt factor))))))
(DEFUN INTR-EML (cmbn) (DEFUN INTR-EML (cmbn)
@ -25,48 +27,48 @@
(return-from intr-eml cmbn)) (return-from intr-eml cmbn))
(the cmbn (the cmbn
(with-cmbn (with-cmbn
(degr list) cmbn (degr list) cmbn
(let* ((limits (make-array (+ degr 2))) (let* ((limits (make-array (+ degr 2)))
(rslt (list nil)) (rslt (list nil))
(rslt-mark rslt) (rslt-mark rslt)
(mask (mask degr))) (mask (mask degr)))
(declare (declare
(simple-vector limits) (simple-vector limits)
(list rslt rslt-mark) (list rslt rslt-mark)
(fixnum mask)) (fixnum mask))
(do ((mark list (member i mark (do ((mark list (member i mark
:test #'< :test #'<
:key #'(lambda (term) :key #'(lambda (term)
(declare (type term term)) (declare (type term term))
(degr1 (gnrt term))))) (degr1 (gnrt term)))))
(i 0 (1+ i))) (i 0 (1+ i)))
((> i degr) (setf (svref limits i) nil)) ((> i degr) (setf (svref limits i) nil))
(declare (declare
(list mark) (list mark)
(fixnum i)) (fixnum i))
(setf (svref limits i) mark)) (setf (svref limits i) mark))
(dotimes (dgop1 (1+ mask)) (dotimes (dgop1 (1+ mask))
(declare (fixnum dgop1)) (declare (fixnum dgop1))
(let* ((i (- degr (logcount dgop1))) (let* ((i (- degr (logcount dgop1)))
(dgop2 (- mask dgop1)) (dgop2 (- mask dgop1))
(sign (shuffle-sign dgop2))) (sign (shuffle-sign dgop2)))
(declare (fixnum i dgop2 sign)) (declare (fixnum i dgop2 sign))
(do ((mark (svref limits i) (cdr mark)) (do ((mark (svref limits i) (cdr mark))
(stop (svref limits (1+ i)))) (stop (svref limits (1+ i))))
((eq mark stop)) ((eq mark stop))
(declare (list mark stop)) (declare (list mark stop))
(with--term (with--term
(cffc tnpr) mark (cffc tnpr) mark
(setf rslt-mark (setf rslt-mark
(setf (cdr rslt-mark) (setf (cdr rslt-mark)
(list (term (list (term
(* sign cffc) (* sign cffc)
(crpr (crpr
dgop1 (gnrt1 tnpr) dgop1 (gnrt1 tnpr)
dgop2 (gnrt2 tnpr)))))))))) dgop2 (gnrt2 tnpr))))))))))
(make-cmbn (make-cmbn
:degr degr :degr degr
:list (rest rslt)))))) :list (rest rslt))))))
(DEFUN EML (smst1 smst2) (DEFUN EML (smst1 smst2)
@ -80,76 +82,76 @@
(DEFUN INTR-PHI (smst1 smst2 (DEFUN INTR-PHI (smst1 smst2
&aux (crts-prdc (crts-prdc smst1 smst2)) &aux (crts-prdc (crts-prdc smst1 smst2))
(cmpr (cmpr crts-prdc)) (cmpr (cmpr crts-prdc))
(face1 (face smst1)) (face1 (face smst1))
(face2 (face smst2))) (face2 (face smst2)))
(declare (declare
(type simplicial-set smst1 smst2 crts-prdc) (type simplicial-set smst1 smst2 crts-prdc)
(type cmprf cmpr) (type cmprf cmpr)
(type face face1 face2)) (type face face1 face2))
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(when (cmbn-zero-p cmbn) (when (cmbn-zero-p cmbn)
(return-from rslt (zero-cmbn (1+ (cmbn-degr cmbn))))) (return-from rslt (zero-cmbn (1+ (cmbn-degr cmbn)))))
(the cmbn (the cmbn
(let* ((n (cmbn-degr cmbn)) (let* ((n (cmbn-degr cmbn))
(n+1 (1+ n)) (n+1 (1+ n))
(array-pq (make-array (list (1+ n+1) (1+ n+1))))) (array-pq (make-array (list (1+ n+1) (1+ n+1)))))
(declare (declare
(fixnum n n+1) (fixnum n n+1)
(simple-array array-pq)) (simple-array array-pq))
(do ((i 1 (1+ i))) (do ((i 1 (1+ i)))
((> i n+1)) ((> i n+1))
(declare (fixnum i)) (declare (fixnum i))
(do ((p i (1+ p)) (do ((p i (1+ p))
(q n+1 (1- q))) (q n+1 (1- q)))
((> p n+1)) ((> p n+1))
(declare (fixnum p q)) (declare (fixnum p q))
(setf (aref array-pq p q) (zero-cmbn i)))) (setf (aref array-pq p q) (zero-cmbn i))))
(dolist (term (cmbn-list cmbn)) (dolist (term (cmbn-list cmbn))
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc crpr) term (cffc crpr) term
(let ((absm1 (absm1 crpr)) (let ((absm1 (absm1 crpr))
(absm2 (absm2 crpr))) (absm2 (absm2 crpr)))
(declare (type absm absm1 absm2)) (declare (type absm absm1 absm2))
(do ((n-alpha n (1- n-alpha)) (do ((n-alpha n (1- n-alpha))
(left-d absm1 (a-face4 face1 n-alpha n-alpha (left-d absm1 (a-face4 face1 n-alpha n-alpha
left-d))) left-d)))
((zerop n-alpha)) ((zerop n-alpha))
(declare (declare
(fixnum n-alpha) (fixnum n-alpha)
(type absm left-d)) (type absm left-d))
(do ((beta 0 (1+ beta)) (do ((beta 0 (1+ beta))
(i n-alpha (1- i)) ;; pseudo-degree (i n-alpha (1- i)) ;; pseudo-degree
(sign (-1-expt-n n-alpha) (- sign)) (sign (-1-expt-n n-alpha) (- sign))
(right-d absm2 (right-d absm2
(a-face4 face2 (1- i) dim-right-d (a-face4 face2 (1- i) dim-right-d
right-d)) right-d))
(dim-right-d n (1- dim-right-d))) (dim-right-d n (1- dim-right-d)))
((= beta n-alpha)) ((= beta n-alpha))
(declare (declare
(fixnum beta i sign dim-right-d) (fixnum beta i sign dim-right-d)
(type absm right-d)) (type absm right-d))
(let ((absm1 (1dgnr (1- i) left-d))) (let ((absm1 (1dgnr (1- i) left-d)))
(declare (type absm absm1)) (declare (type absm absm1))
(with-absm (with-absm
(dgop1 gmsm1) absm1 (dgop1 gmsm1) absm1
(with-absm (with-absm
(dgop2 gmsm2) right-d (dgop2 gmsm2) right-d
(or (> (integer-length dgop1) i) (or (> (integer-length dgop1) i)
(> (integer-length dgop2) i) (> (integer-length dgop2) i)
(plusp (logand dgop1 dgop2)) (plusp (logand dgop1 dgop2))
(dstr-add-term-to-cmbn (dstr-add-term-to-cmbn
cmpr cmpr
(* sign cffc) (* sign cffc)
(crpr dgop1 gmsm1 dgop2 gmsm2) (crpr dgop1 gmsm1 dgop2 gmsm2)
(aref array-pq (1+ n-alpha) (aref array-pq (1+ n-alpha)
(- n beta)))))))))))) (- n beta))))))))))))
;; array-pq))) ;; in case of debugging ;; array-pq))) ;; in case of debugging
(intr-phi-2 array-pq cmpr) (intr-phi-2 array-pq cmpr)
)))) ))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
#| #|
@ -158,210 +160,210 @@
(declare (declare
(type (simple-array cmbn (* *)) array-pq) (type (simple-array cmbn (* *)) array-pq)
(type cmprf cmpr)) (type cmprf cmpr))
; (format t " -22- ") ; ; (format t " -22- ") ; ;
(the cmbn (the cmbn
(let* ((n+1 (1- (array-dimension array-pq 0))) (let* ((n+1 (1- (array-dimension array-pq 0)))
(n (1- n+1))) (n (1- n+1)))
(declare (fixnum n n+1)) (declare (fixnum n n+1))
(flet ((step-i (i) (flet ((step-i (i)
(declare (fixnum i)) (declare (fixnum i))
(do ((p (1+ i) (1+ p)) (do ((p (1+ i) (1+ p))
(p-1 i p) (p-1 i p)
(q n+1 q-1) (q n+1 q-1)
(q-1 n (1- q-1)) (q-1 n (1- q-1))
(sign t (not sign)) (sign t (not sign))
(ibit (2-exp i))) (ibit (2-exp i)))
((> p n+1)) ((> p n+1))
(declare (declare
(fixnum p p-1 q q-1 ibit) (fixnum p p-1 q q-1 ibit)
(type boolean sign)) (type boolean sign))
(setf (aref array-pq p q) (setf (aref array-pq p q)
(2cmbn-add cmpr (2cmbn-add cmpr
(aref array-pq p q) (aref array-pq p q)
(make-cmbn (make-cmbn
:degr (1+ i) :degr (1+ i)
:list (nconc :list (nconc
(mapcar (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (cffc crpr) term (with-term (cffc crpr) term
(with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr (with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr
(term cffc (crpr (term cffc (crpr
dgop1 gmsm1 dgop1 gmsm1
(+ ibit dgop2) gmsm2))))) (+ ibit dgop2) gmsm2)))))
(cmbn-list (aref array-pq p q-1))) (cmbn-list (aref array-pq p q-1)))
(let ((list (cmbn-list (aref array-pq p-1 q)))) (let ((list (cmbn-list (aref array-pq p-1 q))))
(declare (list lst)) (declare (list lst))
(unless sign (unless sign
(dolist (term list) (dolist (term list)
(declare (type term term)) (declare (type term term))
(setf (cffc term) (- (cffc term))))) (setf (cffc term) (- (cffc term)))))
(dolist (term list) (dolist (term list)
(declare (type term term)) (declare (type term term))
(incf (dgop1 (gnrt term)) ibit)) (incf (dgop1 (gnrt term)) ibit))
list)))))))) list))))))))
(do ((i 1 (1+ i))) (do ((i 1 (1+ i)))
((= i n+1)) ((= i n+1))
(declare (type fixnum i)) (declare (type fixnum i))
(step-i i)) (step-i i))
(aref array-pq n+1 n+1))))) (aref array-pq n+1 n+1)))))
|# |#
(DEFUN INTR-PHI-2 (array-pq cmpr) (DEFUN INTR-PHI-2 (array-pq cmpr)
(declare (declare
(type (simple-array cmbn (* *)) array-pq) (type (simple-array cmbn (* *)) array-pq)
(type cmprf cmpr)) (type cmprf cmpr))
; (format t " -2- ") ; (format t " -2- ")
(the cmbn (the cmbn
(let* ((n+1 (1- (array-dimension array-pq 0))) (let* ((n+1 (1- (array-dimension array-pq 0)))
(n (1- n+1)) (n (1- n+1))
(cmbn-list +empty-list+)) (cmbn-list +empty-list+))
(declare (declare
(fixnum n n+1) (fixnum n n+1)
(list cmbn-list)) (list cmbn-list))
(do ((i 1 (1+ i)) (do ((i 1 (1+ i))
(cmbn-i (list nil) (list nil)) (cmbn-i (list nil) (list nil))
(mask (mask n) (ash mask -1))) (mask (mask n) (ash mask -1)))
((= i n+1)) ((= i n+1))
(declare (declare
(fixnum i mask) (fixnum i mask)
(list cmbn-i)) (list cmbn-i))
(let ((cmbn-i-tail cmbn-i)) (let ((cmbn-i-tail cmbn-i))
(declare (list cmbn-i-tail)) (declare (list cmbn-i-tail))
(do ((dgop1 0 (1+ dgop1))) (do ((dgop1 0 (1+ dgop1)))
((> dgop1 mask) ((> dgop1 mask)
(push (make-cmbn (push (make-cmbn
:degr n+1 :degr n+1
:list (rest cmbn-i)) :list (rest cmbn-i))
cmbn-list)) cmbn-list))
(declare (fixnum dgop1)) (declare (fixnum dgop1))
(let ((p (- n+1 (logcount dgop1))) (let ((p (- n+1 (logcount dgop1)))
(dgop2 (- mask dgop1))) (dgop2 (- mask dgop1)))
(declare (fixnum p dgop2)) (declare (fixnum p dgop2))
(unless (= p i) (unless (= p i)
(let ((q (- (+ n+1 i) p)) (let ((q (- (+ n+1 i) p))
(sign (shuffle-sign dgop2)) (sign (shuffle-sign dgop2))
(dgop1-ashed (ash dgop1 i)) (dgop1-ashed (ash dgop1 i))
(dgop2-ashed (ash dgop2 i))) (dgop2-ashed (ash dgop2 i)))
(declare (fixnum q sign dgop1-ashed dgop2-ashed)) (declare (fixnum q sign dgop1-ashed dgop2-ashed))
(dolist (term (cmbn-list (aref array-pq p q))) (dolist (term (cmbn-list (aref array-pq p q)))
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc crpr) term (cffc crpr) term
(with-crpr (with-crpr
(dgop1 gmsm1 dgop2 gmsm2) crpr (dgop1 gmsm1 dgop2 gmsm2) crpr
(setf cmbn-i-tail (setf cmbn-i-tail
(setf (cdr cmbn-i-tail) (setf (cdr cmbn-i-tail)
(list (term (* sign cffc) (list (term (* sign cffc)
(crpr (crpr
(+ dgop1 dgop1-ashed) (+ dgop1 dgop1-ashed)
gmsm1 gmsm1
(+ dgop2 dgop2-ashed) (+ dgop2 dgop2-ashed)
gmsm2)))))))))))))) gmsm2))))))))))))))
(if cmbn-list (if cmbn-list
(apply #'ncmbn-add cmpr cmbn-list) (apply #'ncmbn-add cmpr cmbn-list)
(zero-cmbn n+1))))) (zero-cmbn n+1)))))
(DEFUN PHI (smst1 smst2) (DEFUN PHI (smst1 smst2)
(declare (type simplicial-set smst1 smst2)) (declare (type simplicial-set smst1 smst2))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc (crts-prdc smst1 smst2) :sorc (crts-prdc smst1 smst2)
:trgt (crts-prdc smst1 smst2) :trgt (crts-prdc smst1 smst2)
:degr +1 :degr +1
:intr (intr-phi smst1 smst2) :intr (intr-phi smst1 smst2)
:strt :cmbn :strt :cmbn
:orgn `(phi ,smst1 ,smst2)))) :orgn `(phi ,smst1 ,smst2))))
(DEFUN INTR-AW (face1 face2) (DEFUN INTR-AW (face1 face2)
(declare (type face face1 face2)) (declare (type face face1 face2))
(flet ((rslt (dmns crpr) (flet ((rslt (dmns crpr)
(declare (declare
(fixnum dmns) (fixnum dmns)
(type crpr crpr)) (type crpr crpr))
(the cmbn (the cmbn
(let ((absm1 (absm1 crpr)) (let ((absm1 (absm1 crpr))
(absm2 (absm2 crpr)) (absm2 (absm2 crpr))
(rslt +empty-list+) (rslt +empty-list+)
(del-0-s +empty-list+)) (del-0-s +empty-list+))
(declare (declare
(type absm absm1 absm2) (type absm absm1 absm2)
(list rslt del-0-s)) (list rslt del-0-s))
(do ((face absm2 (a-face4 face2 0 dmns2 face)) (do ((face absm2 (a-face4 face2 0 dmns2 face))
(dmns2 dmns (1- dmns2))) (dmns2 dmns (1- dmns2)))
((zerop dmns2) (push face del-0-s)) ((zerop dmns2) (push face del-0-s))
(declare (declare
(type absm face) (type absm face)
(fixnum dmns)) (fixnum dmns))
(push face del-0-s)) (push face del-0-s))
(do ((face absm1 (a-face4 face1 dmns1 dmns1 face)) (do ((face absm1 (a-face4 face1 dmns1 dmns1 face))
(dmns1 dmns (1- dmns1)) (dmns1 dmns (1- dmns1))
(dmns2 0 (1+ dmns2)) (dmns2 0 (1+ dmns2))
(mark del-0-s (cdr mark))) (mark del-0-s (cdr mark)))
((zerop dmns1) ((zerop dmns1)
(unless (degenerate-p absm2) (unless (degenerate-p absm2)
(push (push
(term 1 (term 1
(tnpr 0 (gmsm face) dmns (gmsm absm2))) (tnpr 0 (gmsm face) dmns (gmsm absm2)))
rslt))) rslt)))
(declare (declare
(type absm face) (type absm face)
(fixnum dmns1 dmns2) (fixnum dmns1 dmns2)
(list mark)) (list mark))
(unless (or (degenerate-p face) (unless (or (degenerate-p face)
(degenerate-p (car mark))) (degenerate-p (car mark)))
(push (push
(term 1 (term 1
(tnpr dmns1 (gmsm face) dmns2 (gmsm (car mark)))) (tnpr dmns1 (gmsm face) dmns2 (gmsm (car mark))))
rslt))) rslt)))
(make-cmbn (make-cmbn
:degr dmns :degr dmns
:list rslt))))) :list rslt)))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
(DEFUN AW (smst1 smst2 (DEFUN AW (smst1 smst2
&aux (crts-prdc (crts-prdc smst1 smst2)) &aux (crts-prdc (crts-prdc smst1 smst2))
(tnsr-prdc (tnsr-prdc smst1 smst2)) (tnsr-prdc (tnsr-prdc smst1 smst2))
(face1 (face smst1)) (face1 (face smst1))
(face2 (face smst2))) (face2 (face smst2)))
(declare (declare
(type simplicial-set smst1 smst2) (type simplicial-set smst1 smst2)
(type face face1 face2)) (type face face1 face2))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc crts-prdc :sorc crts-prdc
:trgt tnsr-prdc :trgt tnsr-prdc
:degr 0 :degr 0
:intr (intr-aw face1 face2) :intr (intr-aw face1 face2)
:strt :gnrt :strt :gnrt
:orgn `(aw ,smst1 ,smst2)))) :orgn `(aw ,smst1 ,smst2))))
(DEFUN EZ (smst1 smst2) (DEFUN EZ (smst1 smst2)
(declare (type simplicial-set smst1 smst2)) (declare (type simplicial-set smst1 smst2))
(the reduction (the reduction
(build-rdct (build-rdct
:f (aw smst1 smst2) :f (aw smst1 smst2)
:g (eml smst1 smst2) :g (eml smst1 smst2)
:h (phi smst1 smst2) :h (phi smst1 smst2)
:orgn `(eilenberg-zilber ,smst1 ,smst2)))) :orgn `(eilenberg-zilber ,smst1 ,smst2))))
(DEFUN LEFT-CRTS-PRDC-EFHM (smst1 smst2) (DEFUN LEFT-CRTS-PRDC-EFHM (smst1 smst2)
(declare (type simplicial-set smst1 smst2)) (declare (type simplicial-set smst1 smst2))
(the homotopy-equivalence (the homotopy-equivalence
(build-hmeq (build-hmeq
:lrdct (trivial-rdct (crts-prdc smst1 smst2)) :lrdct (trivial-rdct (crts-prdc smst1 smst2))
:rrdct (ez smst1 smst2)))) :rrdct (ez smst1 smst2))))
(DEFMETHOD SEARCH-EFHM (smst (orgn (eql 'crts-prdc))) (DEFMETHOD SEARCH-EFHM (smst (orgn (eql 'crts-prdc)))
(declare (type simplicial-set smst)) (declare (type simplicial-set smst))
(the homotopy-equivalence (the homotopy-equivalence
(cmps (cmps
(left-crts-prdc-efhm (second (orgn smst)) (third (orgn smst))) (left-crts-prdc-efhm (second (orgn smst)) (third (orgn smst)))
(tnsr-prdc (efhm (second (orgn smst))) (tnsr-prdc (efhm (second (orgn smst)))
(efhm (third (orgn smst))))))) (efhm (third (orgn smst)))))))

178
src/fibrations.lisp
View File

@ -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 ;;; FIBRATIONS FIBRATIONS FIBRATIONS FIBRATIONS FIBRATIONS
;;; FIBRATIONS FIBRATIONS FIBRATIONS FIBRATIONS FIBRATIONS ;;; FIBRATIONS FIBRATIONS FIBRATIONS FIBRATIONS FIBRATIONS
@ -7,16 +9,16 @@
(PROVIDE "fibrations") (PROVIDE "fibrations")
(DEFUN FIBRATION-TOTAL-FACE (fibration (DEFUN FIBRATION-TOTAL-FACE (fibration
&aux (base (sorc fibration)) &aux (base (sorc fibration))
(bface (face base)) (bface (face base))
(fibr (trgt fibration)) (fibr (trgt fibration))
(fbspn (bspn fibr)) (fbspn (bspn fibr))
(fface (face fibr)) (fface (face fibr))
(grml (grml fibr)) (grml (grml fibr))
(sintr-grml (sintr grml)) (sintr-grml (sintr grml))
(totl (crts-prdc base fibr)) (totl (crts-prdc base fibr))
(uface (face totl)) (uface (face totl))
(sintr-twist (sintr fibration))) (sintr-twist (sintr fibration)))
(declare (declare
(type fibration fibration) (type fibration fibration)
(type simplicial-mrph grml) (type simplicial-mrph grml)
@ -26,65 +28,65 @@
(type face bface fface uface) (type face bface fface uface)
(type sintr sintr-grml sintr-twist)) (type sintr sintr-grml sintr-twist))
(flet ((rslt (indx dmns crpr) (flet ((rslt (indx dmns crpr)
(declare (declare
(fixnum indx dmns) (fixnum indx dmns)
(type crpr crpr)) (type crpr crpr))
(the absm (the absm
(progn (progn
(when (< indx dmns) (when (< indx dmns)
(return-from rslt (return-from rslt
(funcall uface indx dmns crpr))) (funcall uface indx dmns crpr)))
(with-crpr (b-absm f-absm) crpr (with-crpr (b-absm f-absm) crpr
(let ((deln-b (let ((deln-b
(a-face4 bface dmns dmns (a-face4 bface dmns dmns
b-absm)) b-absm))
(deln-f (deln-f
(a-face4 fface dmns dmns (a-face4 fface dmns dmns
f-absm)) f-absm))
(tau-b (tau-b
(tw-a-sintr3 sintr-twist dmns (tw-a-sintr3 sintr-twist dmns
b-absm fbspn))) b-absm fbspn)))
(declare (declare
( type absm deln-b deln-f tau-b)) ( type absm deln-b deln-f tau-b))
(2absm-acrpr (2absm-acrpr
deln-b deln-b
(a-grml4 sintr-grml (1- dmns) (a-grml4 sintr-grml (1- dmns)
tau-b deln-f)))))))) tau-b deln-f))))))))
(the face #'rslt))) (the face #'rslt)))
(DEFUN FIBRATION-TOTAL (fibration (DEFUN FIBRATION-TOTAL (fibration
&aux (base (sorc fibration)) &aux (base (sorc fibration))
(fibre (trgt fibration)) (fibre (trgt fibration))
(untwisted-prdc (untwisted-prdc
(crts-prdc base fibre))) (crts-prdc base fibre)))
(declare (type fibration fibration)) (declare (type fibration fibration))
(the simplicial-set (the simplicial-set
(let ((rslt (build-smst (let ((rslt (build-smst
:cmpr (cmpr untwisted-prdc) :cmpr (cmpr untwisted-prdc)
:basis (basis untwisted-prdc) :basis (basis untwisted-prdc)
:bspn (bspn untwisted-prdc) :bspn (bspn untwisted-prdc)
:face (fibration-total-face fibration) :face (fibration-total-face fibration)
:orgn `(fibration-total ,fibration)))) :orgn `(fibration-total ,fibration))))
(declare (type simplicial-set rslt)) (declare (type simplicial-set rslt))
(setf (slot-value rslt 'grmd) untwisted-prdc) (setf (slot-value rslt 'grmd) untwisted-prdc)
(when (and (typep base 'kan) (when (and (typep base 'kan)
(typep fibre 'kan)) (typep fibre 'kan))
(change-class rslt 'kan) (change-class rslt 'kan)
(setf (slot-value rslt 'kfll) (setf (slot-value rslt 'kfll)
(fibration-kfll fibration))) (fibration-kfll fibration)))
rslt))) rslt)))
(DEFUN FIBRATION-KFLL (twist (DEFUN FIBRATION-KFLL (twist
&aux (sintr-twist (sintr twist)) &aux (sintr-twist (sintr twist))
(base (sorc twist)) (base (sorc twist))
(fibre (trgt twist)) (fibre (trgt twist))
(fbspn (bspn fibre)) (fbspn (bspn fibre))
(bkfll (kfll base)) (bkfll (kfll base))
(fkfll (kfll fibre)) (fkfll (kfll fibre))
(sintr-grml (sintr (grml fibre))) (sintr-grml (sintr (grml fibre)))
(sintr-grin (sintr (grin fibre)))) (sintr-grin (sintr (grin fibre))))
(declare (declare
(type fibration twist) (type fibration twist)
(type kan base fibre) (type kan base fibre)
@ -92,34 +94,34 @@
(type kfll bkfll fkfll) (type kfll bkfll fkfll)
(type sintr sintr-grml sintr-grin)) (type sintr sintr-grml sintr-grin))
(flet ((rslt (indx dmns hat) (flet ((rslt (indx dmns hat)
(declare (declare
(fixnum indx dmns) (fixnum indx dmns)
(list hat)) (list hat))
(let (bhat fhat) (let (bhat fhat)
(declare (type list bhat fhat)) (declare (type list bhat fhat))
(do ((mark hat (cdr mark))) (do ((mark hat (cdr mark)))
((endp mark)) ((endp mark))
(declare (list mark)) (declare (list mark))
(let ((absm (car mark))) (let ((absm (car mark)))
(declare (type absm absm)) (declare (type absm absm))
(with-absm (with-absm
(dgop crpr) absm (dgop crpr) absm
(with-crpr (with-crpr
(dgop1 gmsm1 dgop2 gmsm2) crpr (dgop1 gmsm1 dgop2 gmsm2) crpr
(push (absm (dgop*dgop dgop dgop1) gmsm1) bhat) (push (absm (dgop*dgop dgop dgop1) gmsm1) bhat)
(push (absm (dgop*dgop dgop dgop2) gmsm2) fhat))))) (push (absm (dgop*dgop dgop dgop2) gmsm2) fhat)))))
(setf bhat (nreverse bhat)) (setf bhat (nreverse bhat))
(let ((bkfll (funcall bkfll indx dmns bhat))) (let ((bkfll (funcall bkfll indx dmns bhat)))
(declare (type absm bkfll)) (declare (type absm bkfll))
(when (< indx dmns) (when (< indx dmns)
(setf (first fhat) (setf (first fhat)
(a-grml4 sintr-grml (1- dmns) (a-grml4 sintr-grml (1- dmns)
(a-grin4 sintr-grin (1- dmns) (a-grin4 sintr-grin (1- dmns)
(tw-a-sintr3 sintr-twist dmns bkfll (tw-a-sintr3 sintr-twist dmns bkfll
fbspn)) fbspn))
(first fhat)))) (first fhat))))
(setf fhat (nreverse fhat)) (setf fhat (nreverse fhat))
(let ((fkfll (funcall fkfll indx dmns fhat))) (let ((fkfll (funcall fkfll indx dmns fhat)))
(declare (type absm fkfll)) (declare (type absm fkfll))
(2absm-acrpr bkfll fkfll)))))) (2absm-acrpr bkfll fkfll))))))
(the kfll #'rslt))) (the kfll #'rslt)))

208
src/homology-groups.lisp
View File

@ -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 ;; 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) (defun creer-matrice (n1 n2)
(let ((mat (make-matrice (let ((mat (make-matrice
:leftcol (make-array (1+ n1)) :leftcol (make-array (1+ n1))
:uplig (make-array (1+ n2))))) :uplig (make-array (1+ n2)))))
(setf (baselig mat 0) (make-t-mat :ilig 0 :icol 0)) (setf (baselig mat 0) (make-t-mat :ilig 0 :icol 0))
(setf (basecol mat 0) (baselig mat 0)) (setf (basecol mat 0) (baselig mat 0))
(do ((i 1 (1+ i))) (do ((i 1 (1+ i)))
((> i n1)) ((> i n1))
(setf (baselig mat i) (setf (baselig mat i)
(make-t-mat :ilig i :icol 0 :up (baselig mat (1- i)))) (make-t-mat :ilig i :icol 0 :up (baselig mat (1- i))))
(setf (left (baselig mat i)) (baselig mat i))) (setf (left (baselig mat i)) (baselig mat i)))
(do ((j 1 (1+ j))) (do ((j 1 (1+ j)))
((> j n2)) ((> j n2))
(setf (basecol mat j) (setf (basecol mat j)
(make-t-mat :ilig 0 :icol j :left (basecol mat (1- j)))) (make-t-mat :ilig 0 :icol j :left (basecol mat (1- j))))
(setf (up (basecol mat j)) (basecol mat j))) (setf (up (basecol mat j)) (basecol mat j)))
@ -45,15 +47,15 @@
(defun inserer-terme (pl pc val) (defun inserer-terme (pl pc val)
(setf (left pl) (make-t-mat :val val (setf (left pl) (make-t-mat :val val
:ilig (ilig pl) :ilig (ilig pl)
:icol (icol pc) :icol (icol pc)
:left (left pl) :left (left pl)
:up (up pc)) :up (up pc))
(up pc) (left pl))) (up pc) (left pl)))
(defun supprimer-terme (pl pc) (defun supprimer-terme (pl pc)
(setf (left pl) (left (left pl)) (setf (left pl) (left (left pl))
(up pc) (up (up pc)))) (up pc) (up (up pc))))
(defun maj-terme (pl pc val) (defun maj-terme (pl pc val)
(if (= val 0) (if (= val 0)
@ -66,9 +68,9 @@
(let ((ptl (baselig mat il))) (let ((ptl (baselig mat il)))
(mapcar (mapcar
#'(lambda (elem) #'(lambda (elem)
(maj-terme (chercher-hor ptl (first elem)) (maj-terme (chercher-hor ptl (first elem))
(chercher-ver (basecol mat (first elem)) il) (chercher-ver (basecol mat (first elem)) il)
(second elem))) (second elem)))
liste) liste)
ptl)) ptl))
@ -76,9 +78,9 @@
(let ((ptc (basecol mat ic))) (let ((ptc (basecol mat ic)))
(mapcar (mapcar
#'(lambda (elem) #'(lambda (elem)
(maj-terme (chercher-hor (baselig mat (first elem)) ic) (maj-terme (chercher-hor (baselig mat (first elem)) ic)
(chercher-ver ptc (first elem)) (chercher-ver ptc (first elem))
(second elem))) (second elem)))
liste) liste)
ptc)) ptc))
@ -106,9 +108,9 @@
(princ (second elem)) (princ (second elem))
(princ ")")) (princ ")"))
(let ((ptl (baselig mat il)) (let ((ptl (baselig mat il))
(res '())) (res '()))
(do ((pl (left ptl) (left pl))) (do ((pl (left ptl) (left pl)))
((eq pl ptl)) ((eq pl ptl))
(push (list (icol pl) (val pl)) res)) (push (list (icol pl) (val pl)) res))
res)) res))
(values )) (values ))
@ -126,9 +128,9 @@
(princ (second elem)) (princ (second elem))
(princ ")")) (princ ")"))
(let ((ptc (basecol mat ic)) (let ((ptc (basecol mat ic))
(res '())) (res '()))
(do ((pc (up ptc) (up pc))) (do ((pc (up ptc) (up pc)))
((eq pc ptc)) ((eq pc ptc))
(push (list (ilig pc) (val pc)) res)) (push (list (ilig pc) (val pc)) res))
res)) res))
(values )) (values ))
@ -139,7 +141,7 @@
(defun disp-matrice (mat) (defun disp-matrice (mat)
(let ((nlig (nlig mat))) (let ((nlig (nlig mat)))
(do ((i 1 (1+ i))) (do ((i 1 (1+ i)))
((> i nlig)) ((> i nlig))
(disp-ligne mat i))) (disp-ligne mat i)))
(done)) (done))
@ -148,26 +150,26 @@
(DEFMETHOD PRINT-OBJECT ((mtrx matrice) stream) (DEFMETHOD PRINT-OBJECT ((mtrx matrice) stream)
(declare (stream stream)) (declare (stream stream))
(the matrice (progn (the matrice (progn
(let ((nlig (nlig mtrx)) (let ((nlig (nlig mtrx))
(ncol (ncol mtrx))) (ncol (ncol mtrx)))
(declare (fixnum nlig ncol)) (declare (fixnum nlig ncol))
(format stream "~%========== MATRIX ~D lines + ~D columns =====" (format stream "~%========== MATRIX ~D lines + ~D columns ====="
nlig ncol) nlig ncol)
(do ((ilig 1 (1+ ilig))) (do ((ilig 1 (1+ ilig)))
((> ilig nlig)) ((> ilig nlig))
(declare (fixnum ilig)) (declare (fixnum ilig))
(format stream "~%L~D=" ilig) (format stream "~%L~D=" ilig)
(dolist (item (let ((baselig (baselig mtrx ilig))) (dolist (item (let ((baselig (baselig mtrx ilig)))
(declare (type t-mat baselig)) (declare (type t-mat baselig))
(do ((rslt +empty-list+ (cons t-mat rslt)) (do ((rslt +empty-list+ (cons t-mat rslt))
(t-mat (left baselig) (left t-mat))) (t-mat (left baselig) (left t-mat)))
((eq t-mat baselig) rslt) ((eq t-mat baselig) rslt)
(declare (declare
(list rslt) (list rslt)
(type t-mat t-mat))))) (type t-mat t-mat)))))
(declare (type t-mat item)) (declare (type t-mat item))
(format stream "[C~D=~D]" (icol item) (val item)))) (format stream "[C~D=~D]" (icol item) (val item))))
(format stream "~%========== END-MATRIX")) (format stream "~%========== END-MATRIX"))
mtrx))) mtrx)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t)) (setf (ext:package-lock :clos) t))
@ -176,63 +178,63 @@
(defun disp-matrice-colonnes (mat) (defun disp-matrice-colonnes (mat)
(let ((ncol (ncol mat))) (let ((ncol (ncol mat)))
(do ((i 1 (1+ i))) (do ((i 1 (1+ i)))
((> i ncol)) ((> i ncol))
(disp-colonne mat i))) (disp-colonne mat i)))
(done)) (done))
(defun terme (mat i j) (defun terme (mat i j)
(let ((p (left (chercher-hor (baselig mat i) j)))) (let ((p (left (chercher-hor (baselig mat i) j))))
(if (= j (icol p)) (if (= j (icol p))
(val (left p)) (val (left p))
nil))) nil)))
(defun mat-aleat (n1 n2 dens x) (defun mat-aleat (n1 n2 dens x)
(let ((mat (creer-matrice n1 n2)) (let ((mat (creer-matrice n1 n2))
(n (truncate (* dens n1 n2))) (n (truncate (* dens n1 n2)))
(2x (* 2 x)) (2x (* 2 x))
(res nil)) (res nil))
(dotimes (i n) (dotimes (i n)
(let* ((il (1+ (random n1))) (let* ((il (1+ (random n1)))
(ic (1+ (random n2))) (ic (1+ (random n2)))
(val (let ((pval (- (random 2x) x))) (val (let ((pval (- (random 2x) x)))
(if (minusp pval) (if (minusp pval)
pval pval
(1+ pval)))) (1+ pval))))
(elem (member il res (elem (member il res
:test #'(lambda (x y) (eql x (first y)))))) :test #'(lambda (x y) (eql x (first y))))))
(if elem (if elem
(push (list ic val) (cadar elem)) (push (list ic val) (cadar elem))
(push (list il (list (list ic val))) res)))) (push (list il (list (list ic val))) res))))
(maj-matrice mat res))) (maj-matrice mat res)))
(defun op-elem (pl pc alpha) (defun op-elem (pl pc alpha)
(if (eq (left pl) (up pc)) (if (eq (left pl) (up pc))
(if (= alpha (val (left pl))) (if (= alpha (val (left pl)))
(supprimer-terme pl pc) (supprimer-terme pl pc)
(decf (val (left pl)) alpha)) (decf (val (left pl)) alpha))
(inserer-terme pl pc (- alpha)))) (inserer-terme pl pc (- alpha))))
(defun peigne-ver (mat ptl il) (defun peigne-ver (mat ptl il)
(if (< il (ilig ptl)) (if (< il (ilig ptl))
(do ((res nil (cons (chercher-ver pl il) (do ((res nil (cons (chercher-ver pl il)
res)) res))
(pl (left ptl) (left pl))) (pl (left ptl) (left pl)))
((eq pl ptl) (nreverse res))) ((eq pl ptl) (nreverse res)))
(do ((res nil (cons (chercher-ver (basecol mat (icol pl)) il) (do ((res nil (cons (chercher-ver (basecol mat (icol pl)) il)
res)) res))
(pl (left ptl) (left pl))) (pl (left ptl) (left pl)))
((eq pl ptl) (nreverse res))))) ((eq pl ptl) (nreverse res)))))
(defun peigne-hor (mat ptc ic) (defun peigne-hor (mat ptc ic)
(if (< ic (icol ptc)) (if (< ic (icol ptc))
(do ((res nil (cons (chercher-hor pc ic) (do ((res nil (cons (chercher-hor pc ic)
res)) res))
(pc (up ptc) (up pc))) (pc (up ptc) (up pc)))
((eq pc ptc) (nreverse res))) ((eq pc ptc) (nreverse res)))
(do ((res nil (cons (chercher-hor (baselig mat (ilig pc)) ic) (do ((res nil (cons (chercher-hor (baselig mat (ilig pc)) ic)
res)) res))
(pc (up ptc) (up pc))) (pc (up ptc) (up pc)))
((eq pc ptc) (nreverse res))))) ((eq pc ptc) (nreverse res)))))
(defun op-lig (ptl1 ptl2 peigne lambda) (defun op-lig (ptl1 ptl2 peigne lambda)
(do ((pl1 (left ptl1) (left pl1)) (do ((pl1 (left ptl1) (left pl1))
@ -477,14 +479,14 @@
(if (null p1) (if (null p1)
(go depart2) (go depart2)
(if (= 1 (abs (val p1))) (if (= 1 (abs (val p1)))
(go pivot1) (go pivot1)
(progn (setf p2 (reste-minimal-colonne M p1)) (progn (setf p2 (reste-minimal-colonne M p1))
(if (null p2) (if (null p2)
(progn (setf p2 (reste-minimal-ligne M p1)) (progn (setf p2 (reste-minimal-ligne M p1))
(if (null p2) (if (null p2)
(go pivot1) (go pivot1)
(go op-col1))) (go op-col1)))
(go op-lig1))))) (go op-lig1)))))
op-lig1 op-lig1
(op-lig-n M (ilig p1) (ilig p2) (diviseur (val p2) (val p1))) (op-lig-n M (ilig p1) (ilig p2) (diviseur (val p2) (val p1)))
(setf p1 p2) (setf p1 p2)
@ -508,14 +510,14 @@
(if (null p1) (if (null p1)
(go depart3) (go depart3)
(if (= 1 (abs (val p1))) (if (= 1 (abs (val p1)))
(go pivot2) (go pivot2)
(progn (setf p2 (reste-minimal-ligne N p1)) (progn (setf p2 (reste-minimal-ligne N p1))
(if (null p2) (if (null p2)
(progn (setf p2 (reste-minimal-colonne N p1)) (progn (setf p2 (reste-minimal-colonne N p1))
(if (null p2) (if (null p2)
(go pivot2-torsion) (go pivot2-torsion)
(go op-lig2))) (go op-lig2)))
(go op-col2))))) (go op-col2)))))
op-lig2 op-lig2
(setf div (diviseur (val p2) (val p1))) (setf div (diviseur (val p2) (val p1)))
(op-col-n B (ilig p2) (ilig p1) (- div)) (op-col-n B (ilig p2) (ilig p1) (- div))
@ -551,7 +553,7 @@
(type cmprf cmpr)) (type cmprf cmpr))
(format t "~%Computing boundary-matrix in dimension ~D. (format t "~%Computing boundary-matrix in dimension ~D.
Rank of the source-module : ~D.~2%" Rank of the source-module : ~D.~2%"
n (length sorc)) n (length sorc))
(let ((sorcl (length sorc)) (let ((sorcl (length sorc))
(mat (creer-matrice (length trgt) (length sorc))) (mat (creer-matrice (length trgt) (length sorc)))
(test #'(lambda (gnrt1 gnrt2) (test #'(lambda (gnrt1 gnrt2)
@ -569,15 +571,15 @@ Rank of the source-module : ~D.~2%"
(when *homology-verbose* (when *homology-verbose*
(clock) (clock)
(format t "Computing the boundary of the generator ~D/~D (dimension ~D) :" (format t "Computing the boundary of the generator ~D/~D (dimension ~D) :"
i sorcl n) i sorcl n)
(print (car mark))) (print (car mark)))
(maj-colonne mat i (maj-colonne mat i
(mapcar #'(lambda (term) (mapcar #'(lambda (term)
(declare (type term term)) (declare (type term term))
(list (list
(1+ (position (gnrt term) trgt :test test)) (1+ (position (gnrt term) trgt :test test))
(cffc term))) (cffc term)))
(cmbn-list (? chcm n (car mark))))) (cmbn-list (? chcm n (car mark)))))
(when *homology-verbose* (when *homology-verbose*
(format t "~%End of computing.~2%"))) (format t "~%End of computing.~2%")))
mat))) mat)))
@ -592,7 +594,7 @@ Rank of the source-module : ~D.~2%"
(declare (type list item)) (declare (type list item))
(format t "~2%Component Z") (format t "~2%Component Z")
(unless (zerop (first item)) (unless (zerop (first item))
(format t "/~DZ" (first item))))) (format t "/~DZ" (first item)))))
(terpri) (terpri) (terpri) (terpri)
(done)) (done))
@ -615,12 +617,12 @@ Rank of the source-module : ~D.~2%"
(mapcar #'(lambda (term) (mapcar #'(lambda (term)
(declare (type term term)) (declare (type term term))
(term (car term) (nth (cdr term) src))) (term (car term) (nth (cdr term) src)))
item)) item))
rsl)) rsl))
(setf rsl (mapcar #'(lambda (item) (setf rsl (mapcar #'(lambda (item)
(declare (type list item)) (declare (type list item))
(make-cmbn :degr n :list item)) (make-cmbn :degr n :list item))
rsl)) rsl))
rsl)) rsl))
@ -634,9 +636,9 @@ Rank of the source-module : ~D.~2%"
(declare (type list item)) (declare (type list item))
(format t "~2%Component Z") (format t "~2%Component Z")
(unless (zerop (first item)) (unless (zerop (first item))
(format t "/~DZ" (first item))) (format t "/~DZ" (first item)))
(format t "~2%Generator :") (format t "~2%Generator :")
(dolist (item2 (rest item)) (dolist (item2 (rest item))
(declare (type cons item2)) (declare (type cons item2))
(format t "~%~D~6T* ~S" (car item2) (nth (cdr item2) src))))) (format t "~%~D~6T* ~S" (car item2) (nth (cdr item2) src)))))
(done)) (done))

964
src/k-pi-n.lisp
View File

File diff suppressed because it is too large Load Diff

88
src/kan.lisp
View File

@ -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 ;;; 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) (DEFMETHOD PRINT-OBJECT ((kan kan) stream)
(the kan (the kan
(progn (progn
(format stream "[K~D Kan-Simplicial-Set]" (idnm kan)) (format stream "[K~D Kan-Simplicial-Set]" (idnm kan))
kan))) kan)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t)) (setf (ext:package-lock :clos) t))
@ -29,10 +31,10 @@
(type kfll kfll)) (type kfll kfll))
(the kan (the kan
(progn (progn
(change-class smst 'kan) (change-class smst 'kan)
(setf (slot-value smst 'kfll) kfll) (setf (slot-value smst 'kfll) kfll)
(pushnew smst *kan-list*) (pushnew smst *kan-list*)
smst))) smst)))
(DEFUN CHECK-HAT (kan indx dmns hat) (DEFUN CHECK-HAT (kan indx dmns hat)
@ -42,9 +44,9 @@
(list hat)) (list hat))
(assert (= dmns (length hat))) (assert (= dmns (length hat)))
(setf hat (setf hat
(append (subseq hat 0 indx) (append (subseq hat 0 indx)
(list :hole) (list :hole)
(nthcdr indx hat))) (nthcdr indx hat)))
(do ((cmpr (cmpr kan)) (do ((cmpr (cmpr kan))
(j 0 (1+ j))) (j 0 (1+ j)))
((> j dmns) t) ((> j dmns) t)
@ -53,17 +55,17 @@
(fixnum j)) (fixnum j))
(unless (= j indx) (unless (= j indx)
(let ((del-j (nth j hat))) (let ((del-j (nth j hat)))
(declare (type absm del-j)) (declare (type absm del-j))
(do ((i j (1+ i))) (do ((i j (1+ i)))
((= i dmns)) ((= i dmns))
(declare (fixnum i)) (declare (fixnum i))
(unless (= i (1- indx)) (unless (= i (1- indx))
(let ((del-i-del-j (face kan i (1- dmns) del-j)) (let ((del-i-del-j (face kan i (1- dmns) del-j))
(del-j-del-i+1 (face kan j (1- dmns) (del-j-del-i+1 (face kan j (1- dmns)
(nth (1+ i) hat)))) (nth (1+ i) hat))))
(declare (type absm del-i-del-j del-j-del-i+1)) (declare (type absm del-i-del-j del-j-del-i+1))
(assert (eq :equal (assert (eq :equal
(a-cmpr3 cmpr del-i-del-j del-j-del-i+1)))))))))) (a-cmpr3 cmpr del-i-del-j del-j-del-i+1))))))))))
(DEFUN CHECK-KAN (kan indx dmns hat) (DEFUN CHECK-KAN (kan indx dmns hat)
@ -73,29 +75,29 @@
(list hat)) (list hat))
(the (values) (the (values)
(let ((rslt (kfll kan indx dmns hat)) (let ((rslt (kfll kan indx dmns hat))
(cmpr (cmpr kan)) (cmpr (cmpr kan))
(face (face kan))) (face (face kan)))
(declare (declare
(type absm rslt) (type absm rslt)
(type cmprf cmpr) (type cmprf cmpr)
(type face face)) (type face face))
(check-hat kan indx dmns hat) (check-hat kan indx dmns hat)
(do ((i 0 (1+ i))) (do ((i 0 (1+ i)))
((> i dmns)) ((> i dmns))
(declare (fixnum i)) (declare (fixnum i))
(unless (= i indx) (unless (= i indx)
(let ((x-i (pop hat)) (let ((x-i (pop hat))
(del-i-rslt (a-face4 face i dmns rslt))) (del-i-rslt (a-face4 face i dmns rslt)))
(declare (type absm x-i del-i-rslt)) (declare (type absm x-i del-i-rslt))
(with-absm (dgop1 gmsm1) x-i (with-absm (dgop1 gmsm1) x-i
(with-absm (with-absm
(dgop2 gmsm2) del-i-rslt (dgop2 gmsm2) del-i-rslt
(unless (and (= dgop1 dgop2) (unless (and (= dgop1 dgop2)
(eq (funcall cmpr gmsm1 gmsm2) (eq (funcall cmpr gmsm1 gmsm2)
:equal)) :equal))
(error "Wrong result:~@ (error "Wrong result:~@
Fill = ~A~@ Fill = ~A~@
Del-~D(Fill) = ~A~@ Del-~D(Fill) = ~A~@
Hat-~D = ~A" Hat-~D = ~A"
rslt i del-i-rslt i x-i))))))) rslt i del-i-rslt i x-i)))))))
(done)))) (done))))

14
src/kenzo.lisp
View File

@ -1,3 +1,5 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
;;;; kenzo.lisp ;;;; kenzo.lisp
(IN-PACKAGE #:cat) (IN-PACKAGE #:cat)
@ -12,7 +14,7 @@
(DEFMACRO DEFINE-CONSTANT (name value &optional doc) (DEFMACRO DEFINE-CONSTANT (name value &optional doc)
`(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value) `(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value)
,@(when doc (list doc)))) ,@(when doc (list doc))))
;; globals from cat-init.lisp ;; globals from cat-init.lisp
@ -26,7 +28,7 @@ validation of combinations.")
(DEFINE-CONSTANT +EMPTY-LIST+ '()) (DEFINE-CONSTANT +EMPTY-LIST+ '())
(DEFINE-CONSTANT +F-EMPTY-VECTOR+ (DEFINE-CONSTANT +F-EMPTY-VECTOR+
(make-array 0 :element-type 'fixnum)) (make-array 0 :element-type 'fixnum))
(DEFINE-CONSTANT +S-EMPTY-VECTOR+ #()) (DEFINE-CONSTANT +S-EMPTY-VECTOR+ #())
@ -36,17 +38,17 @@ validation of combinations.")
(DEFINE-CONSTANT +2-EXP+ (DEFINE-CONSTANT +2-EXP+
(let ((rslt (make-array (integer-length most-positive-fixnum) (let ((rslt (make-array (integer-length most-positive-fixnum)
:element-type 'fixnum))) :element-type 'fixnum)))
(declare (type (array fixnum 1) rslt)) (declare (type (array fixnum 1) rslt))
(dotimes (i (integer-length most-positive-fixnum) 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+ (DEFINE-CONSTANT +MASK+
(let ((rslt (make-array (integer-length most-positive-fixnum) (let ((rslt (make-array (integer-length most-positive-fixnum)
:element-type 'fixnum))) :element-type 'fixnum)))
(declare (type (array fixnum 1) rslt)) (declare (type (array fixnum 1) rslt))
(dotimes (i (integer-length most-positive-fixnum) 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 ;; globals from combinations.lisp

388
src/loop-spaces.lisp
View File

@ -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 ;;; 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 (the absm
(progn (progn
(unless niloop (unless niloop
(return-from normalize-loop (return-from normalize-loop
(absm (mask dmns) +null-loop+))) (absm (mask dmns) +null-loop+)))
(let ((dgop (apply #'logand (mapcar #'car niloop)))) (let ((dgop (apply #'logand (mapcar #'car niloop))))
(declare (fixnum dgop)) (declare (fixnum dgop))
(if (zerop dgop) (if (zerop dgop)
(absm 0 (make-loop :list niloop)) (absm 0 (make-loop :list niloop))
(absm dgop (absm dgop
(make-loop (make-loop
:list (mapcar #'(lambda (apowr) :list (mapcar #'(lambda (apowr)
(cons (cons
(dgop/dgop (apdgop apowr) dgop) (dgop/dgop (apdgop apowr) dgop)
(cdr apowr))) (cdr apowr)))
niloop)))))))) niloop))))))))
(DEFUN UNNORMALIZE-LOOP (absm) (DEFUN UNNORMALIZE-LOOP (absm)
(declare (type absm absm)) (declare (type absm absm))
(the iloop (the iloop
(with-absm (dgop loop) absm (with-absm (dgop loop) absm
(mapcar #'(lambda (apowr) (mapcar #'(lambda (apowr)
(declare (type apowr apowr)) (declare (type apowr apowr))
(cons (dgop*dgop dgop (car apowr)) (cons (dgop*dgop dgop (car apowr))
(cdr apowr))) (cdr apowr)))
(loop-list loop))))) (loop-list loop)))))
(DEFUN LOOP3 (&rest list) (DEFUN LOOP3 (&rest list)
@ -49,9 +51,9 @@
(unless (zerop (mod (length list) 3)) (unless (zerop (mod (length list) 3))
(error "In LOOP3, 3 should divide the list length.")) (error "In LOOP3, 3 should divide the list length."))
(flet ((fixnumpp (object) (flet ((fixnumpp (object)
(unless (typep object 'fixnum) (unless (typep object 'fixnum)
(error "In LOOP3, ~A should be a fixnum." object)) (error "In LOOP3, ~A should be a fixnum." object))
object)) object))
(do ((rslt +empty-list+ (cons (apowr (do ((rslt +empty-list+ (cons (apowr
(fixnumpp (car mark)) (fixnumpp (car mark))
(cadr mark) (cadr mark)
@ -68,19 +70,19 @@
(ignore depth)) (ignore depth))
(the loop (the loop
(progn (progn
(format stream "<<Loop") (format stream "<<Loop")
(dolist (apowr (loop-list loop)) (dolist (apowr (loop-list loop))
(declare (type apowr apowr)) (declare (type apowr apowr))
(with-apowr (dgop gmsm expn) apowr (with-apowr (dgop gmsm expn) apowr
(format stream "[") (format stream "[")
(unless (zerop dgop) (unless (zerop dgop)
(format stream "~A " (hyphenize-list (dgop-int-ext dgop)))) (format stream "~A " (hyphenize-list (dgop-int-ext dgop))))
(format stream "~A" gmsm) (format stream "~A" gmsm)
(unless (= 1 expn) (unless (= 1 expn)
(format stream "\\~D" expn)) (format stream "\\~D" expn))
(format stream "]"))) (format stream "]")))
(format stream ">>") (format stream ">>")
loop))) loop)))
(DEFUN APOWR-NILOOP (cmpr apowr niloop) (DEFUN APOWR-NILOOP (cmpr apowr niloop)
@ -91,20 +93,20 @@
(the iloop (the iloop
(progn (progn
(unless niloop (unless niloop
(return-from apowr-niloop (return-from apowr-niloop
(list apowr))) (list apowr)))
(let ((apowr2 (first niloop))) (let ((apowr2 (first niloop)))
(declare (type apowr apowr2)) (declare (type apowr apowr2))
(with-apowr (dgop2 gmsm2 expn2) apowr2 (with-apowr (dgop2 gmsm2 expn2) apowr2
(unless (and (= (apdgop apowr) dgop2) (unless (and (= (apdgop apowr) dgop2)
(eq :equal (funcall cmpr (apgmsm apowr) (eq :equal (funcall cmpr (apgmsm apowr)
gmsm2))) gmsm2)))
(return-from apowr-niloop (return-from apowr-niloop
(cons apowr niloop))) (cons apowr niloop)))
(incf expn2 (apexpn apowr)) (incf expn2 (apexpn apowr))
(if (zerop expn2) (if (zerop expn2)
(rest niloop) (rest niloop)
(cons (apowr dgop2 gmsm2 expn2) (rest niloop)))))))) (cons (apowr dgop2 gmsm2 expn2) (rest niloop))))))))
(DEFUN LOOP-SPACE-CMPR (cmpr) (DEFUN LOOP-SPACE-CMPR (cmpr)
@ -112,12 +114,12 @@
(flet ((2apowr-cmpr (apowr1 apowr2) (flet ((2apowr-cmpr (apowr1 apowr2)
(declare (type apowr apowr1 apowr2)) (declare (type apowr apowr1 apowr2))
(lexico (lexico
(f-cmpr (apdgop apowr1) (apdgop apowr2)) (f-cmpr (apdgop apowr1) (apdgop apowr2))
(funcall cmpr (apgmsm apowr1) (apgmsm apowr2)) (funcall cmpr (apgmsm apowr1) (apgmsm apowr2))
(f-cmpr (apexpn apowr1) (apexpn apowr2))))) (f-cmpr (apexpn apowr1) (apexpn apowr2)))))
(flet ((rslt (loop1 loop2) (flet ((rslt (loop1 loop2)
(declare (type loop loop1 loop2)) (declare (type loop loop1 loop2))
(maplexico #'2apowr-cmpr (loop-list loop1) (loop-list loop2)))) (maplexico #'2apowr-cmpr (loop-list loop1) (loop-list loop2))))
(the cmprf #'rslt)))) (the cmprf #'rslt))))
@ -127,12 +129,12 @@
(type face face) (type face face)
(type apowr apowr)) (type apowr apowr))
(with-apowr (dgop gmsm expn) apowr (with-apowr (dgop gmsm expn) apowr
(let ((face (a-face4 face indx (1+ dmns) (absm dgop gmsm)))) (let ((face (a-face4 face indx (1+ dmns) (absm dgop gmsm))))
(declare (type absm face)) (declare (type absm face))
(with-absm (dgop gmsm) face (with-absm (dgop gmsm) face
(if (logbitp (1- dmns) dgop) (if (logbitp (1- dmns) dgop)
nil nil
(apowr dgop gmsm expn)))))) (apowr dgop gmsm expn))))))
(DEFUN APOWR-LASTFACE4 (cmpr face dmns apowr) (DEFUN APOWR-LASTFACE4 (cmpr face dmns apowr)
@ -144,54 +146,54 @@
(type apowr apowr)) (type apowr apowr))
(the list (the list
(with-apowr (with-apowr
(dgop gmsm expn) apowr (dgop gmsm expn) apowr
(let ((absm (absm dgop gmsm))) (let ((absm (absm dgop gmsm)))
(declare (type absm absm)) (declare (type absm absm))
(let ((face-n (a-face4 face dmns (1+ dmns) absm)) (let ((face-n (a-face4 face dmns (1+ dmns) absm))
(face-n+1 (a-face4 face (1+ dmns) (1+ dmns) absm))) (face-n+1 (a-face4 face (1+ dmns) (1+ dmns) absm)))
(declare (type absm face-n face-n+1)) (declare (type absm face-n face-n+1))
(with-absm (with-absm
(dgop1 gmsm1) face-n (dgop1 gmsm1) face-n
(with-absm (with-absm
(dgop2 gmsm2) face-n+1 (dgop2 gmsm2) face-n+1
(if (logbitp (1- dmns) dgop1) (if (logbitp (1- dmns) dgop1)
(if (logbitp (1- dmns) dgop2) (if (logbitp (1- dmns) dgop2)
(return-from apowr-lastface4 +empty-list+) (return-from apowr-lastface4 +empty-list+)
(return-from apowr-lastface4 (return-from apowr-lastface4
(list (apowr dgop2 gmsm2 (- expn))))) (list (apowr dgop2 gmsm2 (- expn)))))
(when (logbitp (1- dmns) dgop2) (when (logbitp (1- dmns) dgop2)
(return-from apowr-lastface4 (return-from apowr-lastface4
(list (apowr dgop1 gmsm1 expn))))) (list (apowr dgop1 gmsm1 expn)))))
(when (and (= dgop1 dgop2) (when (and (= dgop1 dgop2)
(eq :equal (funcall cmpr gmsm1 gmsm2))) (eq :equal (funcall cmpr gmsm1 gmsm2)))
(return-from apowr-lastface4 +empty-list+)) (return-from apowr-lastface4 +empty-list+))
(case expn (case expn
(+1 (list (apowr dgop2 gmsm2 -1) (apowr dgop1 gmsm1 (+1 (list (apowr dgop2 gmsm2 -1) (apowr dgop1 gmsm1
+1))) +1)))
(-1 (list (apowr dgop1 gmsm1 -1) (apowr dgop2 gmsm2 (-1 (list (apowr dgop1 gmsm1 -1) (apowr dgop2 gmsm2
+1))) +1)))
(otherwise (otherwise
(if (plusp expn) (if (plusp expn)
(do ((rslt +empty-list+ (cons apowr2 (do ((rslt +empty-list+ (cons apowr2
(cons apowr1 (cons apowr1
rslt))) rslt)))
(apowr1 (apowr dgop1 gmsm1 +1)) (apowr1 (apowr dgop1 gmsm1 +1))
(apowr2 (apowr dgop2 gmsm2 -1)) (apowr2 (apowr dgop2 gmsm2 -1))
(nark expn (1- nark))) (nark expn (1- nark)))
((zerop nark) rslt) ((zerop nark) rslt)
(declare (declare
(list rslt) (list rslt)
(type apowr apowr1 apowr2))) (type apowr apowr1 apowr2)))
(do ((rslt +empty-list+ (cons apowr1 (do ((rslt +empty-list+ (cons apowr1
(cons apowr2 (cons apowr2
rslt))) rslt)))
(apowr1 (apowr dgop1 gmsm1 -1)) (apowr1 (apowr dgop1 gmsm1 -1))
(apowr2 (apowr dgop2 gmsm2 +1)) (apowr2 (apowr dgop2 gmsm2 +1))
(nark expn (1+ nark))) (nark expn (1+ nark)))
((zerop nark) rslt) ((zerop nark) rslt)
(declare (declare
(list rslt) (list rslt)
(type apowr apowr1 apowr2))))))))))))) (type apowr apowr1 apowr2)))))))))))))
(DEFUN LOOP-SPACE-FACE (cmpr face) (DEFUN LOOP-SPACE-FACE (cmpr face)
@ -199,27 +201,27 @@
(type cmprf cmpr) (type cmprf cmpr)
(type face face)) (type face face))
(flet ((rslt (indx dmns loop) (flet ((rslt (indx dmns loop)
(declare (declare
(fixnum indx dmns) (fixnum indx dmns)
(type loop loop)) (type loop loop))
(the absm (the absm
(let ((rslt +empty-list+)) (let ((rslt +empty-list+))
(declare (type iloop rslt)) (declare (type iloop rslt))
(if (< indx dmns) (if (< indx dmns)
(dolist (apowr (loop-list loop)) (dolist (apowr (loop-list loop))
(declare (type apowr apowr)) (declare (type apowr apowr))
(let ((lface (apowr-face4 face indx dmns apowr))) (let ((lface (apowr-face4 face indx dmns apowr)))
(declare (type (or null apowr) lface)) (declare (type (or null apowr) lface))
(when lface (setf rslt (apowr-niloop cmpr lface (when lface (setf rslt (apowr-niloop cmpr lface
rslt))))) rslt)))))
(dolist (apowr (loop-list loop)) (dolist (apowr (loop-list loop))
(declare (type apowr apowr)) (declare (type apowr apowr))
(let ((lface (apowr-lastface4 cmpr face dmns apowr))) (let ((lface (apowr-lastface4 cmpr face dmns apowr)))
(declare (list lface)) (declare (list lface))
(dolist (apowr lface) (dolist (apowr lface)
(declare (type apowr apowr)) (declare (type apowr apowr))
(setf rslt (apowr-niloop cmpr apowr rslt)))))) (setf rslt (apowr-niloop cmpr apowr rslt))))))
(normalize-loop (1- dmns) (nreverse rslt)))))) (normalize-loop (1- dmns) (nreverse rslt))))))
(the face #'rslt))) (the face #'rslt)))
@ -228,27 +230,27 @@
(type cmprf cmpr) (type cmprf cmpr)
(type face face)) (type face face))
(flet ((rslt (indx dmns loop) (flet ((rslt (indx dmns loop)
(declare (declare
(fixnum indx dmns) (fixnum indx dmns)
(type loop loop)) (type loop loop))
(the (or loop (eql :degenerate)) (the (or loop (eql :degenerate))
(let ((rslt +empty-list+)) (let ((rslt +empty-list+))
(declare (type iloop rslt)) (declare (type iloop rslt))
(if (< indx dmns) (if (< indx dmns)
(dolist (apowr (loop-list loop)) (dolist (apowr (loop-list loop))
(declare (type apowr apowr)) (declare (type apowr apowr))
(let ((lface (apowr-face4 face indx dmns apowr))) (let ((lface (apowr-face4 face indx dmns apowr)))
(declare (type (or null apowr) lface)) (declare (type (or null apowr) lface))
(when lface (setf rslt (apowr-niloop cmpr lface (when lface (setf rslt (apowr-niloop cmpr lface
rslt))))) rslt)))))
(dolist (apowr (loop-list loop)) (dolist (apowr (loop-list loop))
(declare (type apowr apowr)) (declare (type apowr apowr))
(let ((lface (apowr-lastface4 cmpr face dmns apowr))) (let ((lface (apowr-lastface4 cmpr face dmns apowr)))
(declare (list lface)) (declare (list lface))
(dolist (apowr lface) (dolist (apowr lface)
(declare (type apowr apowr)) (declare (type apowr apowr))
(setf rslt (apowr-niloop cmpr apowr rslt)))))) (setf rslt (apowr-niloop cmpr apowr rslt))))))
(if (zerop (apply #'logand (mapcar #'car rslt))) (if (zerop (apply #'logand (mapcar #'car rslt)))
(make-loop :list (nreverse rslt)) (make-loop :list (nreverse rslt))
:degenerate))))) :degenerate)))))
(the face* #'rslt))) (the face* #'rslt)))
@ -260,52 +262,52 @@
(type loop loop)) (type loop loop))
(the absm (the absm
(absm 0 (make-loop (absm 0 (make-loop
:list (mapcar #'(lambda (apowr) :list (mapcar #'(lambda (apowr)
(declare (type apowr apowr)) (declare (type apowr apowr))
(with-apowr (dgop gmsm expn) apowr (with-apowr (dgop gmsm expn) apowr
(apowr dgop gmsm (- expn)))) (apowr dgop gmsm (- expn))))
(reverse (loop-list loop))))))) (reverse (loop-list loop)))))))
(DEFUN LOOP-SPACE-GRML-SINTR (cmpr) (DEFUN LOOP-SPACE-GRML-SINTR (cmpr)
(declare (type cmprf cmpr)) (declare (type cmprf cmpr))
(flet ((rslt (dmns crpr) (flet ((rslt (dmns crpr)
(declare (declare
(fixnum dmns) (fixnum dmns)
(type crpr crpr)) (type crpr crpr))
(the absm (the absm
(with-crpr (with-crpr
(absm1 absm2) crpr (absm1 absm2) crpr
(let ((niloop1 (nreverse (unnormalize-loop absm1))) (let ((niloop1 (nreverse (unnormalize-loop absm1)))
(niloop2 (unnormalize-loop absm2))) (niloop2 (unnormalize-loop absm2)))
(declare (type iloop niloop1 niloop2)) (declare (type iloop niloop1 niloop2))
(loop (loop
(unless niloop1 (return)) (unless niloop1 (return))
(unless niloop2 (return)) (unless niloop2 (return))
(let ((apowr1 (first niloop1)) (let ((apowr1 (first niloop1))
(apowr2 (first niloop2))) (apowr2 (first niloop2)))
(declare (type apowr apowr1 apowr2)) (declare (type apowr apowr1 apowr2))
(with-apowr (with-apowr
(dgop1 gmsm1 expn1) apowr1 (dgop1 gmsm1 expn1) apowr1
(with-apowr (with-apowr
(dgop2 gmsm2 expn2) apowr2 (dgop2 gmsm2 expn2) apowr2
(unless (and (= dgop1 dgop2) (unless (and (= dgop1 dgop2)
(eq :equal (funcall cmpr (eq :equal (funcall cmpr
gmsm1 gmsm1
gmsm2))) gmsm2)))
(return)) (return))
(incf expn1 expn2) (incf expn1 expn2)
(cond ((zerop expn1) (cond ((zerop expn1)
(pop niloop1) (pop niloop1)
(pop niloop2)) (pop niloop2))
(t (t
(pop niloop1) (pop niloop1)
(setf niloop2 (setf niloop2
(cons (apowr dgop2 gmsm2 expn1) (cons (apowr dgop2 gmsm2 expn1)
(rest niloop2))) (rest niloop2)))
(return))))))) (return)))))))
(normalize-loop dmns (normalize-loop dmns
(nreconc niloop1 niloop2))))))) (nreconc niloop1 niloop2)))))))
(the sintr #'rslt))) (the sintr #'rslt)))
@ -315,20 +317,20 @@
(fixnum n)) (fixnum n))
(the simplicial-group (the simplicial-group
(if (= n 1) (if (= n 1)
(with-slots (cmpr face) smst (with-slots (cmpr face) smst
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(type face face)) (type face face))
(build-smgr (build-smgr
:cmpr (loop-space-cmpr cmpr) :cmpr (loop-space-cmpr cmpr)
:basis :locally-effective :basis :locally-effective
:bspn +null-loop+ :bspn +null-loop+
:face (loop-space-face cmpr face) :face (loop-space-face cmpr face)
:face* (loop-space-face* cmpr face) :face* (loop-space-face* cmpr face)
:sintr-grml (loop-space-grml-sintr cmpr) :sintr-grml (loop-space-grml-sintr cmpr)
:sintr-grin #'loop-space-grin-sintr :sintr-grin #'loop-space-grin-sintr
:orgn `(loop-space ,smst))) :orgn `(loop-space ,smst)))
(loop-space (loop-space smst) (1- n))))) (loop-space (loop-space smst) (1- n)))))
(DEFUN GDELTAB () (DEFUN GDELTAB ()

448
src/lp-space-efhm.lisp
View File

@ -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 ;;; 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") (PROVIDE "lp-space-efhm")
(DEFUN LS-HAT-U-U (space (DEFUN LS-HAT-U-U (space
&aux (cobar (cobar space)) &aux (cobar (cobar space))
(loop-space (loop-space space)) (loop-space (loop-space space))
(spac-tnsr-lpsp (tnsr-prdc space loop-space))) (spac-tnsr-lpsp (tnsr-prdc space loop-space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type chain-complex cobar spac-tnsr-lpsp) (type chain-complex cobar spac-tnsr-lpsp)
@ -22,38 +24,38 @@
(declare (type simplicial-set space)) (declare (type simplicial-set space))
(let ((cprd (dgnl space))) (let ((cprd (dgnl space)))
(flet ((rslt (degr tnpr) (flet ((rslt (degr tnpr)
(declare (declare
(fixnum degr) (fixnum degr)
(type tnpr tnpr)) (type tnpr tnpr))
(with-tnpr (with-tnpr
(degr1 allp1 nil tnpr2) tnpr (degr1 allp1 nil tnpr2) tnpr
(with-tnpr
(degr21 gmsm21 degr22 loop22) tnpr2
(let ((cprd (cmbn-list (gnrt-? cprd degr21 gmsm21))))
(declare (list cprd))
(setf cprd (rest cprd)) ;;; because \bar{A}
(make-cmbn
:degr (1- degr)
:list
(mapcar
#'(lambda (term)
(declare (type term term))
(with-term
(cffc tnpr21) term
(with-tnpr (with-tnpr
(degr211 gmsm211 degr212 gmsm212) tnpr21 (degr21 gmsm21 degr22 loop22) tnpr2
(decf degr211) (let ((cprd (cmbn-list (gnrt-? cprd degr21 gmsm21))))
(term cffc (tnpr (+ degr1 degr211) (declare (list cprd))
(make-allp (setf cprd (rest cprd)) ;;; because \bar{A}
:list (make-cmbn
(append :degr (1- degr)
(allp-list allp1) :list
(list (cbgn degr211 (mapcar
gmsm211)))) #'(lambda (term)
(+ degr212 degr22) (declare (type term term))
(tnpr degr212 gmsm212 (with-term
degr22 loop22)))))) (cffc tnpr21) term
cprd))))))) (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)))) (the intr-mrph #'rslt))))
@ -62,17 +64,17 @@
(the morphism (the morphism
(let ((ls-hat-u-u (ls-hat-u-u space))) (let ((ls-hat-u-u (ls-hat-u-u space)))
(build-mrph (build-mrph
:sorc ls-hat-u-u :sorc ls-hat-u-u
:trgt ls-hat-u-u :trgt ls-hat-u-u
:degr -1 :degr -1
:intr (ls-hat-left-perturbation-intr space) :intr (ls-hat-left-perturbation-intr space)
:strt :gnrt :strt :gnrt
:orgn `(ls-hat-left-perturbation ,space))))) :orgn `(ls-hat-left-perturbation ,space)))))
(DEFUN LS-HAT-T-U (space (DEFUN LS-HAT-T-U (space
&aux (ls-hat-u-u (ls-hat-u-u space)) &aux (ls-hat-u-u (ls-hat-u-u space))
(ls-hat-left-perturbation (ls-hat-left-perturbation
(ls-hat-left-perturbation space))) (ls-hat-left-perturbation space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type chain-complex ls-hat-u-u) (type chain-complex ls-hat-u-u)
@ -87,27 +89,27 @@
(DEFUN LS-HAT-RIGHT-PERTURBATION (space (DEFUN LS-HAT-RIGHT-PERTURBATION (space
&aux (cobar (cobar space)) &aux (cobar (cobar space))
(ls-hat-t-u (ls-hat-t-u space))) (ls-hat-t-u (ls-hat-t-u space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type chain-complex cobar ls-hat-t-u)) (type chain-complex cobar ls-hat-t-u))
(the morphism (the morphism
(multiple-value-bind (szczarba bottom-perturbation) (multiple-value-bind (szczarba bottom-perturbation)
(szczarba space) (szczarba space)
(declare (declare
(ignore szczarba) (ignore szczarba)
(type morphism bottom-perturbation)) (type morphism bottom-perturbation))
(let ((rslt (tnsr-prdc (idnt-mrph cobar) bottom-perturbation))) (let ((rslt (tnsr-prdc (idnt-mrph cobar) bottom-perturbation)))
(declare (type morphism rslt)) (declare (type morphism rslt))
(setf (slot-value rslt 'sorc) ls-hat-t-u (setf (slot-value rslt 'sorc) ls-hat-t-u
(slot-value rslt 'trgt) ls-hat-t-u) (slot-value rslt 'trgt) ls-hat-t-u)
rslt)))) rslt))))
(DEFUN LS-HAT-U-T (space (DEFUN LS-HAT-U-T (space
&aux (cobar (cobar space)) &aux (cobar (cobar space))
(twisted-tnsr-prdc (twisted-tnsr-prdc space)) (twisted-tnsr-prdc (twisted-tnsr-prdc space))
(ls-hat-u-u (ls-hat-u-u space))) (ls-hat-u-u (ls-hat-u-u space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type chain-complex cobar twisted-tnsr-prdc ls-hat-u-u)) (type chain-complex cobar twisted-tnsr-prdc ls-hat-u-u))
@ -119,10 +121,10 @@
(DEFUN LS-LEFT-HMEQ-HAT (space (DEFUN LS-LEFT-HMEQ-HAT (space
&aux &aux
(ls-hat-u-t (ls-hat-u-t space)) (ls-hat-u-t (ls-hat-u-t space))
(ls-hat-left-perturbation (ls-hat-left-perturbation
(ls-hat-left-perturbation space))) (ls-hat-left-perturbation space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type chain-complex ls-hat-u-t) (type chain-complex ls-hat-u-t)
@ -137,75 +139,75 @@
(let ((rslt +empty-list+)) (let ((rslt +empty-list+))
(declare (list rslt)) (declare (list rslt))
(dolist (term (cmbn-list cmbn)) (dolist (term (cmbn-list cmbn))
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc tnpr) term (cffc tnpr) term
(with-tnpr (degr1 nil nil tnpr2) tnpr (with-tnpr (degr1 nil nil tnpr2) tnpr
(if (zerop degr1) (if (zerop degr1)
(with-tnpr (with-tnpr
(degr21 nil nil loop22) tnpr2 (degr21 nil nil loop22) tnpr2
(if (zerop degr21) (if (zerop degr21)
(push (term cffc loop22) rslt) (push (term cffc loop22) rslt)
(return))) (return)))
(return))))) (return)))))
(make-cmbn :degr (cmbn-degr cmbn) (make-cmbn :degr (cmbn-degr cmbn)
:list (nreverse rslt))))) :list (nreverse rslt)))))
(DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-F (space (DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-F (space
&aux (ls-hat-t-u (ls-hat-t-u space)) &aux (ls-hat-t-u (ls-hat-t-u space))
(loop-space (loop-space space))) (loop-space (loop-space space)))
(declare (declare
(type simplicial-set space loop-space) (type simplicial-set space loop-space)
(type chain-complex ls-hat-t-u)) (type chain-complex ls-hat-t-u))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc ls-hat-t-u :sorc ls-hat-t-u
:trgt loop-space :trgt loop-space
:degr 0 :degr 0
:intr #'ls-pre-left-hmeq-left-reduction-intr-f :intr #'ls-pre-left-hmeq-left-reduction-intr-f
:strt :cmbn :strt :cmbn
:orgn `(ls-pre-left-hmeq-left-reduction-f ,space)))) :orgn `(ls-pre-left-hmeq-left-reduction-f ,space))))
(DEFUN LS-LEFT-HMEQ-LEFT-REDUCTION-G-INTR (bspn) (DEFUN LS-LEFT-HMEQ-LEFT-REDUCTION-G-INTR (bspn)
(declare (type gmsm bspn)) (declare (type gmsm bspn))
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(with-cmbn (with-cmbn
(degr list) cmbn (degr list) cmbn
(make-cmbn :degr degr (make-cmbn :degr degr
:list (mapcar :list (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc loop) term (cffc loop) term
(term cffc (term cffc
(tnpr (tnpr
0 +null-allp+ 0 +null-allp+
degr degr
(tnpr 0 bspn degr (tnpr 0 bspn degr
loop))))) loop)))))
list)))))) list))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
(DEFUN LS-LEFT-HMEQ-LEFT-REDUCTION-G (space (DEFUN LS-LEFT-HMEQ-LEFT-REDUCTION-G (space
&aux (bspn (bspn space)) &aux (bspn (bspn space))
(ls-hat-t-u (ls-hat-t-u space)) (ls-hat-t-u (ls-hat-t-u space))
(loop-space (loop-space space))) (loop-space (loop-space space)))
(declare (declare
(type simplicial-set space loop-space) (type simplicial-set space loop-space)
(type gmsm bspn) (type gmsm bspn)
(type chain-complex ls-hat-t-u)) (type chain-complex ls-hat-t-u))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc loop-space :sorc loop-space
:trgt ls-hat-t-u :trgt ls-hat-t-u
:degr 0 :degr 0
:intr (ls-left-hmeq-left-reduction-g-intr bspn) :intr (ls-left-hmeq-left-reduction-g-intr bspn)
:strt :cmbn :strt :cmbn
:orgn `(ls-left-hmeq-left-reduction-g ,space)))) :orgn `(ls-left-hmeq-left-reduction-g ,space))))
(DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-H-INTR (DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-H-INTR
@ -219,88 +221,88 @@
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(with-cmbn (with-cmbn
(degr list) cmbn (degr list) cmbn
(let ((rslt (zero-cmbn (1+ degr)))) (let ((rslt (zero-cmbn (1+ degr))))
(declare (type cmbn rslt)) (declare (type cmbn rslt))
(dolist (term list) (dolist (term list)
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc tnpr) term (cffc tnpr) term
(with-tnpr (with-tnpr
(degr1 allp1 degr2 tnpr2) tnpr (degr1 allp1 degr2 tnpr2) tnpr
(unless (zerop degr1) (unless (zerop degr1)
(with-tnpr (with-tnpr
(degr21 nil degr22 loop22) tnpr2 (degr21 nil degr22 loop22) tnpr2
(when (zerop degr21) (when (zerop degr21)
(setf allp1 (allp-list allp1)) ;;;+++ (setf allp1 (allp-list allp1)) ;;;+++
(let ((last-cbgn (car (last allp1)))) (let ((last-cbgn (car (last allp1))))
(declare (type cbgn last-cbgn)) (declare (type cbgn last-cbgn))
(with-cbgn (with-cbgn
(degrl gmsml) last-cbgn (degrl gmsml) last-cbgn
(dstr-add-term-to-cmbn (dstr-add-term-to-cmbn
cmpr cffc cmpr cffc
(tnpr (- degr1 degrl) (tnpr (- degr1 degrl)
(make-allp (make-allp
:list (butlast allp1)) :list (butlast allp1))
(+ degr2 degrl 1) (+ degr2 degrl 1)
(tnpr (1+ degrl) gmsml (tnpr (1+ degrl) gmsml
degr22 loop22)) degr22 loop22))
rslt))))))))) rslt)))))))))
rslt))))) rslt)))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
(DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-H (space (DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-H (space
&aux (ls-hat-t-u (ls-hat-t-u space))) &aux (ls-hat-t-u (ls-hat-t-u space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type chain-complex ls-hat-t-u)) (type chain-complex ls-hat-t-u))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc ls-hat-t-u :sorc ls-hat-t-u
:trgt ls-hat-t-u :trgt ls-hat-t-u
:degr +1 :degr +1
:intr (ls-pre-left-hmeq-left-reduction-h-intr space) :intr (ls-pre-left-hmeq-left-reduction-h-intr space)
:strt :cmbn :strt :cmbn
:orgn `(ls-pre-left-hmeq-left-reduction-h ,space)))) :orgn `(ls-pre-left-hmeq-left-reduction-h ,space))))
(DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION (space) (DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION (space)
(declare (type simplicial-set space)) (declare (type simplicial-set space))
(the reduction (the reduction
(build-rdct (build-rdct
:f (ls-pre-left-hmeq-left-reduction-f space) :f (ls-pre-left-hmeq-left-reduction-f space)
:g (ls-left-hmeq-left-reduction-g space) :g (ls-left-hmeq-left-reduction-g space)
:h (ls-pre-left-hmeq-left-reduction-h space) :h (ls-pre-left-hmeq-left-reduction-h space)
:orgn `(ls-pre-left-hmeq-left-reduction ,space)))) :orgn `(ls-pre-left-hmeq-left-reduction ,space))))
(DEFUN LS-LEFT-HMEQ-LEFT-REDUCTION (space (DEFUN LS-LEFT-HMEQ-LEFT-REDUCTION (space
&aux (ls-pre-left-hmeq-left-reduction &aux (ls-pre-left-hmeq-left-reduction
(ls-pre-left-hmeq-left-reduction (ls-pre-left-hmeq-left-reduction
space)) space))
(ls-hat-right-perturbation (ls-hat-right-perturbation
(ls-hat-right-perturbation space))) (ls-hat-right-perturbation space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type reduction ls-pre-left-hmeq-left-reduction) (type reduction ls-pre-left-hmeq-left-reduction)
(type morphism ls-hat-right-perturbation)) (type morphism ls-hat-right-perturbation))
(the reduction (the reduction
(progn (progn
(dstr-change-sorc-trgt ls-hat-right-perturbation (dstr-change-sorc-trgt ls-hat-right-perturbation
:new-sorc (tcc ls-pre-left-hmeq-left-reduction) :new-sorc (tcc ls-pre-left-hmeq-left-reduction)
:new-trgt (tcc ls-pre-left-hmeq-left-reduction)) :new-trgt (tcc ls-pre-left-hmeq-left-reduction))
(let ((rslt (special-bpl ls-pre-left-hmeq-left-reduction (let ((rslt (special-bpl ls-pre-left-hmeq-left-reduction
ls-hat-right-perturbation))) ls-hat-right-perturbation)))
(declare (type reduction rslt)) (declare (type reduction rslt))
(with-slots (tcc f g h) rslt (with-slots (tcc f g h) rslt
(setf tcc (ls-left-hmeq-hat space) (setf tcc (ls-left-hmeq-hat space)
(slot-value f 'sorc) tcc (slot-value f 'sorc) tcc
(slot-value g 'trgt) tcc (slot-value g 'trgt) tcc
(slot-value h 'sorc) tcc (slot-value h 'sorc) tcc
(slot-value h 'trgt) tcc) (slot-value h 'trgt) tcc)
rslt))))) rslt)))))
;;; -[CLISP ;;; -[CLISP
@ -309,14 +311,14 @@
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(with-cmbn (degr list) cmbn (with-cmbn (degr list) cmbn
(let ((tail (member 0 list :test #'= :key #'cadddr))) (let ((tail (member 0 list :test #'= :key #'cadddr)))
(make-cmbn :degr degr (make-cmbn :degr degr
:list (mapcar :list (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (cffc tnpr) term (with-term (cffc tnpr) term
(term cffc (gnrt1 tnpr)))) (term cffc (gnrt1 tnpr))))
tail)))))) tail))))))
|# |#
;;; LISP]- ;;; LISP]-
;;; +[CLISP ;;; +[CLISP
@ -324,74 +326,74 @@
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(with-cmbn (degr list) cmbn (with-cmbn (degr list) cmbn
(let ((tail (member 0 list (let ((tail (member 0 list
:key #'(lambda (term) :key #'(lambda (term)
(declare (type term term)) (declare (type term term))
(degr2 (gnrt term)))))) (degr2 (gnrt term))))))
(make-cmbn :degr degr (make-cmbn :degr degr
:list (mapcar :list (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (cffc tnpr) term (with-term (cffc tnpr) term
(term cffc (gnrt1 tnpr)))) (term cffc (gnrt1 tnpr))))
tail)))))) tail))))))
;;; CLISP]+ ;;; CLISP]+
(DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-F (space (DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-F (space
&aux (ls-hat-u-t (ls-hat-u-t space)) &aux (ls-hat-u-t (ls-hat-u-t space))
(cobar (cobar space))) (cobar (cobar space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type chain-complex ls-hat-u-t cobar)) (type chain-complex ls-hat-u-t cobar))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc ls-hat-u-t :trgt cobar :degr 0 :sorc ls-hat-u-t :trgt cobar :degr 0
:intr #'ls-pre-left-hmeq-right-reduction-intr-f :intr #'ls-pre-left-hmeq-right-reduction-intr-f
:strt :cmbn :strt :cmbn
:orgn `(ls-pre-left-hmeq-right-reduction-f ,space)))) :orgn `(ls-pre-left-hmeq-right-reduction-f ,space))))
(DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-G (bspn) (DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-G (bspn)
(declare (type gmsm bspn)) (declare (type gmsm bspn))
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(with-cmbn (with-cmbn
(degr list) cmbn (degr list) cmbn
(let ((bsgn (tnpr 0 bspn 0 +null-loop+))) (let ((bsgn (tnpr 0 bspn 0 +null-loop+)))
(declare (type tnpr bsgn)) (declare (type tnpr bsgn))
(make-cmbn :degr degr (make-cmbn :degr degr
:list (mapcar :list (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc gnrt) term (cffc gnrt) term
(term cffc (tnpr degr gnrt 0 (term cffc (tnpr degr gnrt 0
bsgn)))) bsgn))))
list))))))) list)))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
(DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-G (space (DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-G (space
&aux (ls-hat-u-t (ls-hat-u-t space)) &aux (ls-hat-u-t (ls-hat-u-t space))
(cobar (cobar space)) (cobar (cobar space))
(bspn (bspn space))) (bspn (bspn space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type chain-complex ls-hat-u-t cobar) (type chain-complex ls-hat-u-t cobar)
(type gmsm bspn)) (type gmsm bspn))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc cobar :trgt ls-hat-u-t :degr 0 :sorc cobar :trgt ls-hat-u-t :degr 0
:intr (ls-pre-left-hmeq-right-reduction-intr-g bspn) :intr (ls-pre-left-hmeq-right-reduction-intr-g bspn)
:strt :cmbn :strt :cmbn
:orgn `(ls-pre-left-hmeq-right-reduction-g ,space)))) :orgn `(ls-pre-left-hmeq-right-reduction-g ,space))))
(DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-H (space (DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-H (space
&aux (cobar (cobar space)) &aux (cobar (cobar space))
(tnpr-contraction (tnpr-contraction
(tnpr-contraction space))) (tnpr-contraction space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type chain-complex cobar) (type chain-complex cobar)
@ -404,18 +406,18 @@
(declare (type simplicial-set space)) (declare (type simplicial-set space))
(the reduction (the reduction
(build-rdct (build-rdct
:f (ls-pre-left-hmeq-right-reduction-f space) :f (ls-pre-left-hmeq-right-reduction-f space)
:g (ls-pre-left-hmeq-right-reduction-g space) :g (ls-pre-left-hmeq-right-reduction-g space)
:h (ls-pre-left-hmeq-right-reduction-h space) :h (ls-pre-left-hmeq-right-reduction-h space)
:orgn `(ls-pre-left-hmeq-right-reduction ,space)))) :orgn `(ls-pre-left-hmeq-right-reduction ,space))))
(DEFUN LS-LEFT-HMEQ-RIGHT-REDUCTION (space (DEFUN LS-LEFT-HMEQ-RIGHT-REDUCTION (space
&aux (pre-reduction &aux (pre-reduction
(ls-pre-left-hmeq-right-reduction (ls-pre-left-hmeq-right-reduction
space)) space))
(perturbation (perturbation
(ls-hat-left-perturbation space))) (ls-hat-left-perturbation space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type reduction pre-reduction) (type reduction pre-reduction)
@ -431,15 +433,15 @@
(declare (type simplicial-set space)) (declare (type simplicial-set space))
(the homotopy-equivalence (the homotopy-equivalence
(build-hmeq (build-hmeq
:lrdct (ls-left-hmeq-left-reduction space) :lrdct (ls-left-hmeq-left-reduction space)
:rrdct (ls-left-hmeq-right-reduction space) :rrdct (ls-left-hmeq-right-reduction space)
:orgn `(ls-left-hmeq ,space)))) :orgn `(ls-left-hmeq ,space))))
(DEFUN LOOP-SPACE-EFHM (space) (DEFUN LOOP-SPACE-EFHM (space)
(declare (type simplicial-set space)) (declare (type simplicial-set space))
(let ((ls-left-hmeq (ls-left-hmeq 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)) (declare (type homotopy-equivalence ls-left-hmeq right-hmeq))
(cmps ls-left-hmeq right-hmeq))) (cmps ls-left-hmeq right-hmeq)))

532
src/ls-twisted-products.lisp
View File

@ -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 ;;; 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)) (type absm absm loop-absm))
(the absm (the absm
(with-absm (with-absm
(dgop1 gmsm1) absm (dgop1 gmsm1) absm
(when (logbitp (1- dmns) dgop1) (when (logbitp (1- dmns) dgop1)
(return-from absm-loopabsm loop-absm)) (return-from absm-loopabsm loop-absm))
(with-absm (with-absm
(dgop2 loop2) loop-absm (dgop2 loop2) loop-absm
(let ((iloop2 (loop-list loop2))) (let ((iloop2 (loop-list loop2)))
(declare (list iloop2)) (declare (list iloop2))
(unless iloop2 (unless iloop2
(return-from absm-loopabsm (return-from absm-loopabsm
(absm dgop1 (make-loop :list (list (apowr 0 gmsm1 +1)))))) (absm dgop1 (make-loop :list (list (apowr 0 gmsm1 +1))))))
(let ((apowr (first iloop2))) (let ((apowr (first iloop2)))
(declare (type apowr apowr)) (declare (type apowr apowr))
(with-apowr (with-apowr
(dgop22 gmsm2 expn2) apowr (dgop22 gmsm2 expn2) apowr
(if (and (= dgop1 (dgop*dgop dgop2 dgop22)) (if (and (= dgop1 (dgop*dgop dgop2 dgop22))
(eq :equal (funcall cmpr gmsm1 gmsm2))) (eq :equal (funcall cmpr gmsm1 gmsm2)))
;; the absm is eaten by the first component of the loop ;; the absm is eaten by the first component of the loop
(if (= -1 expn2) (if (= -1 expn2)
;; the first item of the loop disappears. ;; the first item of the loop disappears.
(let ((iloop2-rest (rest iloop2))) (let ((iloop2-rest (rest iloop2)))
(if iloop2-rest (if iloop2-rest
(let ((loop-rest (normalize-loop (let ((loop-rest (normalize-loop
(1- dmns) iloop2-rest))) (1- dmns) iloop2-rest)))
(declare (type absm loop-rest)) (declare (type absm loop-rest))
(absm (dgop*dgop dgop2 (dgop loop-rest)) (absm (dgop*dgop dgop2 (dgop loop-rest))
(gmsm loop-rest))) (gmsm loop-rest)))
(absm (mask (1- dmns)) +null-loop+))) (absm (mask (1- dmns)) +null-loop+)))
;; the exponent of the first item is increased by 1 ;; the exponent of the first item is increased by 1
(absm dgop2 (make-loop :list (absm dgop2 (make-loop :list
(cons (apowr dgop22 (cons (apowr dgop22
gmsm2 gmsm2
(1+ expn2)) (1+ expn2))
(rest iloop2))))) (rest iloop2)))))
;; a concatenation must be done ;; a concatenation must be done
(multiple-value-bind (dgop dgop1 dgop2) (multiple-value-bind (dgop dgop1 dgop2)
(extract-common-dgop dgop1 dgop2) (extract-common-dgop dgop1 dgop2)
(declare (fixnum dgop dgop1 dgop2)) (declare (fixnum dgop dgop1 dgop2))
(absm dgop (absm dgop
(make-loop (make-loop
:list (cons (apowr dgop1 gmsm1 +1) :list (cons (apowr dgop1 gmsm1 +1)
(if (zerop dgop2) (if (zerop dgop2)
iloop2 iloop2
(mapcar (mapcar
#'(lambda (apowr) #'(lambda (apowr)
(declare (declare
(type apowr apowr)) (type apowr apowr))
(cons (dgop*dgop (cons (dgop*dgop
dgop2 (apdgop dgop2 (apdgop
apowr)) apowr))
(cdr apowr))) (cdr apowr)))
iloop2)))))))))))))) iloop2))))))))))))))
(DEFUN TWISTED-CRTS-PRDC-FACE (cmpr space-face loop-space-face non-twisted-face) (DEFUN TWISTED-CRTS-PRDC-FACE (cmpr space-face loop-space-face non-twisted-face)
@ -76,52 +78,52 @@
(type cmprf cmpr) (type cmprf cmpr)
(type face space-face loop-space-face non-twisted-face)) (type face space-face loop-space-face non-twisted-face))
(flet ((rslt (indx dmns crpr) (flet ((rslt (indx dmns crpr)
(declare (declare
(fixnum indx dmns) (fixnum indx dmns)
(type crpr crpr)) (type crpr crpr))
(the absm (the absm
(progn (progn
(unless (= indx dmns) (unless (= indx dmns)
(return-from rslt (return-from rslt
(funcall non-twisted-face indx dmns crpr))) (funcall non-twisted-face indx dmns crpr)))
(with-crpr (absm1 absm2) crpr (with-crpr (absm1 absm2) crpr
(let ((face1 (a-face4 space-face dmns dmns absm1)) (let ((face1 (a-face4 space-face dmns dmns absm1))
(face2 (a-face4 loop-space-face dmns dmns (face2 (a-face4 loop-space-face dmns dmns
absm2))) absm2)))
(declare (type absm face1 face2)) (declare (type absm face1 face2))
(setf face2 (absm-loopabsm cmpr dmns absm1 (setf face2 (absm-loopabsm cmpr dmns absm1
face2)) face2))
(2absm-acrpr face1 face2))))))) (2absm-acrpr face1 face2)))))))
(the face #'rslt))) (the face #'rslt)))
(DEFUN TWISTED-CRTS-PRDC (space (DEFUN TWISTED-CRTS-PRDC (space
&aux (loop-space (loop-space space)) &aux (loop-space (loop-space space))
(crts-prdc (crts-prdc space loop-space))) (crts-prdc (crts-prdc space loop-space)))
(declare (type simplicial-set space loop-space crts-prdc)) (declare (type simplicial-set space loop-space crts-prdc))
(the simplicial-set (the simplicial-set
(with-slots ((space-cmpr cmpr) (space-face face)) space (with-slots ((space-cmpr cmpr) (space-face face)) space
(declare (declare
(type cmprf space-cmpr) (type cmprf space-cmpr)
(type face space-face)) (type face space-face))
(with-slots ((loop-space-face face)) loop-space (with-slots ((loop-space-face face)) loop-space
(declare (type face loop-space-face)) (declare (type face loop-space-face))
(with-slots ((crts-prdc-cmpr cmpr) basis bsgn (crts-prdc-face face)) (with-slots ((crts-prdc-cmpr cmpr) basis bsgn (crts-prdc-face face))
crts-prdc crts-prdc
(declare (declare
(type cmprf crts-prdc-cmpr) (type cmprf crts-prdc-cmpr)
(type basis basis) (type basis basis)
(type face crts-prdc-face) (type face crts-prdc-face)
(type gmsm bsgn)) (type gmsm bsgn))
(let ((rslt (build-smst (let ((rslt (build-smst
:cmpr crts-prdc-cmpr :cmpr crts-prdc-cmpr
:basis basis :basis basis
:bspn bsgn :bspn bsgn
:face (twisted-crts-prdc-face :face (twisted-crts-prdc-face
space-cmpr space-face loop-space-face space-cmpr space-face loop-space-face
crts-prdc-face) crts-prdc-face)
:orgn `(twisted-crts-prdc ,space)))) :orgn `(twisted-crts-prdc ,space))))
(setf (slot-value rslt 'grmd) crts-prdc) (setf (slot-value rslt 'grmd) crts-prdc)
rslt)))))) rslt))))))
(DEFUN DTAU-D-INTR (crts-prdc-cmpr crts-prdc-face twisted-crts-prdc-face) (DEFUN DTAU-D-INTR (crts-prdc-cmpr crts-prdc-face twisted-crts-prdc-face)
@ -129,93 +131,93 @@
(type cmprf crts-prdc-cmpr) (type cmprf crts-prdc-cmpr)
(type face crts-prdc-face twisted-crts-prdc-face)) (type face crts-prdc-face twisted-crts-prdc-face))
(flet ((rslt (dmns crpr) (flet ((rslt (dmns crpr)
(declare (declare
(fixnum dmns) (fixnum dmns)
(type crpr crpr)) (type crpr crpr))
(when (zerop dmns) (when (zerop dmns)
(return-from rslt +zero-negative-cmbn+)) (return-from rslt +zero-negative-cmbn+))
(the cmbn (the cmbn
(let ((dmns-1 (1- dmns))) (let ((dmns-1 (1- dmns)))
(declare (fixnum dmns-1)) (declare (fixnum dmns-1))
(when (logbitp dmns-1 (dgop1 crpr)) (when (logbitp dmns-1 (dgop1 crpr))
(return-from rslt (zero-cmbn dmns-1))) (return-from rslt (zero-cmbn dmns-1)))
(let ((face-tau (funcall twisted-crts-prdc-face dmns dmns (let ((face-tau (funcall twisted-crts-prdc-face dmns dmns
crpr)) crpr))
(face (funcall crts-prdc-face dmns dmns crpr)) (face (funcall crts-prdc-face dmns dmns crpr))
(sign (-1-expt-n dmns))) (sign (-1-expt-n dmns)))
(declare (declare
(type absm face-tau face) (type absm face-tau face)
(fixnum sign)) (fixnum sign))
(with-absm (with-absm
(dgop-tau gmsm-tau) face-tau (dgop-tau gmsm-tau) face-tau
(with-absm (with-absm
(dgop gmsm) face (dgop gmsm) face
(if (plusp dgop-tau) (if (plusp dgop-tau)
(if (plusp dgop) (if (plusp dgop)
(zero-cmbn dmns-1) (zero-cmbn dmns-1)
(term-cmbn dmns-1 (- sign) gmsm)) (term-cmbn dmns-1 (- sign) gmsm))
(if (plusp dgop) (if (plusp dgop)
(term-cmbn dmns-1 sign gmsm-tau) (term-cmbn dmns-1 sign gmsm-tau)
(ecase (funcall crts-prdc-cmpr gmsm-tau (ecase (funcall crts-prdc-cmpr gmsm-tau
gmsm) gmsm)
(:less (:less
(cmbn dmns-1 sign gmsm-tau (- sign) (cmbn dmns-1 sign gmsm-tau (- sign)
gmsm)) gmsm))
(:greater (:greater
(cmbn dmns-1 (- sign) gmsm sign (cmbn dmns-1 (- sign) gmsm sign
gmsm-tau)) gmsm-tau))
(:equal (:equal
(error "Surprise in DTAU-D-INTR.~@ (error "Surprise in DTAU-D-INTR.~@
Crpr = ~A~@ Crpr = ~A~@
D-tau = ~A~@ D-tau = ~A~@
D = ~A" D = ~A"
crpr gmsm-tau gmsm)))))))))))) crpr gmsm-tau gmsm))))))))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
(DEFUN DTAU-D (space (DEFUN DTAU-D (space
&aux (loop-space (loop-space space)) &aux (loop-space (loop-space space))
(crts-prdc (crts-prdc space loop-space)) (crts-prdc (crts-prdc space loop-space))
(crts-prdc-cmpr (cmpr crts-prdc)) (crts-prdc-cmpr (cmpr crts-prdc))
(crts-prdc-face (face crts-prdc)) (crts-prdc-face (face crts-prdc))
(twisted-crts-prdc (twisted-crts-prdc space)) (twisted-crts-prdc (twisted-crts-prdc space))
(twisted-crts-prdc-face (face twisted-crts-prdc))) (twisted-crts-prdc-face (face twisted-crts-prdc)))
(declare (declare
(type simplicial-set space loop-space crts-prdc twisted-crts-prdc) (type simplicial-set space loop-space crts-prdc twisted-crts-prdc)
(type cmprf crts-prdc-cmpr) (type cmprf crts-prdc-cmpr)
(type face crts-prdc-face twisted-crts-prdc-face)) (type face crts-prdc-face twisted-crts-prdc-face))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc crts-prdc :trgt crts-prdc :degr -1 :sorc crts-prdc :trgt crts-prdc :degr -1
:intr (dtau-d-intr crts-prdc-cmpr crts-prdc-face :intr (dtau-d-intr crts-prdc-cmpr crts-prdc-face
twisted-crts-prdc-face) twisted-crts-prdc-face)
:strt :gnrt :strt :gnrt
:orgn `(dtau-d ,space)))) :orgn `(dtau-d ,space))))
(DEFUN SZCZARBA (space (DEFUN SZCZARBA (space
&aux (loop-space (loop-space space)) &aux (loop-space (loop-space space))
(twisted-crts-prdc (twisted-crts-prdc space)) (twisted-crts-prdc (twisted-crts-prdc space))
(ez (ez space loop-space)) (ez (ez space loop-space))
(dtau-d (dtau-d space))) (dtau-d (dtau-d space)))
(declare (declare
(type simplicial-set space loop-space twisted-crts-prdc) (type simplicial-set space loop-space twisted-crts-prdc)
(type reduction ez) (type reduction ez)
(type morphism dtau-d)) (type morphism dtau-d))
(the (values reduction morphism) (the (values reduction morphism)
(multiple-value-bind (szczarba bottom-perturbation) (multiple-value-bind (szczarba bottom-perturbation)
(add ez dtau-d) (add ez dtau-d)
(with-slots (tcc f g h) szczarba (with-slots (tcc f g h) szczarba
(setf tcc twisted-crts-prdc (setf tcc twisted-crts-prdc
(slot-value f 'sorc) twisted-crts-prdc (slot-value f 'sorc) twisted-crts-prdc
(slot-value g 'trgt) twisted-crts-prdc (slot-value g 'trgt) twisted-crts-prdc
(slot-value h 'sorc) twisted-crts-prdc (slot-value h 'sorc) twisted-crts-prdc
(slot-value h 'trgt) twisted-crts-prdc)) (slot-value h 'trgt) twisted-crts-prdc))
(values szczarba bottom-perturbation)))) (values szczarba bottom-perturbation))))
(DEFUN TWISTED-TNSR-PRDC (space (DEFUN TWISTED-TNSR-PRDC (space
&aux (szczarba (szczarba space))) &aux (szczarba (szczarba space)))
(declare (declare
(type simplicial-set space) (type simplicial-set space)
(type reduction szczarba)) (type reduction szczarba))
@ -231,32 +233,32 @@
(the (values (member -1 0 1) (or nil absm) absm) (the (values (member -1 0 1) (or nil absm) absm)
(progn (progn
(unless iloop (unless iloop
(return-from pop-first-absm (return-from pop-first-absm
(values 0 nil iloop))) (values 0 nil iloop)))
(let ((apowr (first iloop)) (let ((apowr (first iloop))
(niloop-rest (rest iloop))) (niloop-rest (rest iloop)))
(declare (declare
(type apowr apowr) (type apowr apowr)
(type iloop niloop-rest)) (type iloop niloop-rest))
(with-apowr (with-apowr
(dgop gmsm expn) apowr (dgop gmsm expn) apowr
(let ((popped-absm (absm dgop gmsm))) (let ((popped-absm (absm dgop gmsm)))
(declare (type absm popped-absm)) (declare (type absm popped-absm))
(cond ((< expn -1) (cond ((< expn -1)
(values -1 popped-absm (values -1 popped-absm
(absm 0 (absm 0
(make-loop (make-loop
:list (cons (apowr dgop gmsm (1+ expn)) :list (cons (apowr dgop gmsm (1+ expn))
niloop-rest))))) niloop-rest)))))
((> expn +1) ((> expn +1)
(values +1 popped-absm (values +1 popped-absm
(absm 0 (absm 0
(make-loop (make-loop
:list (cons (apowr dgop gmsm (1- expn)) :list (cons (apowr dgop gmsm (1- expn))
niloop-rest))))) niloop-rest)))))
(t (t
(values expn popped-absm (values expn popped-absm
(normalize-loop dmns niloop-rest)))))))))) (normalize-loop dmns niloop-rest))))))))))
@ -267,109 +269,109 @@
(type face base-face)) (type face base-face))
(flet ((rslt (n crpr) (flet ((rslt (n crpr)
(declare (declare
(fixnum n) (fixnum n)
(type crpr crpr)) (type crpr crpr))
(the cmbn (the cmbn
(let ((n+1 (1+ n))) (let ((n+1 (1+ n)))
(declare (fixnum n+1)) (declare (fixnum n+1))
(labels ( (labels (
(hh (x-n g-n) (hh (x-n g-n)
(declare (type absm x-n g-n)) (declare (type absm x-n g-n))
(if (bspn-p base-cmpr base-bspn n x-n) (if (bspn-p base-cmpr base-bspn n x-n)
(if (degenerate-p g-n) (if (degenerate-p g-n)
(zero-cmbn n+1) (zero-cmbn n+1)
(h-hat (loop-list (gmsm g-n)))) (h-hat (loop-list (gmsm g-n))))
(if (degenerate-p g-n) (if (degenerate-p g-n)
(h-tilde (1dgnr n x-n) g-n) (h-tilde (1dgnr n x-n) g-n)
(2cmbn-add crts-cmpr (2cmbn-add crts-cmpr
(h-hat (loop-list (gmsm g-n))) (h-hat (loop-list (gmsm g-n)))
(h-tilde (1dgnr n x-n) g-n))))) (h-tilde (1dgnr n x-n) g-n)))))
(h-tilde (x-n+1 g-n) (h-tilde (x-n+1 g-n)
(declare (type absm 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) (when (bspn-p base-cmpr base-bspn n+1 x-n+1)
(return-from h-tilde (return-from h-tilde
(zero-cmbn n+1))) (zero-cmbn n+1)))
(do ((i n (1- i)) (do ((i n (1- i))
(dgop 0 (+ dgop (2-exp i))) (dgop 0 (+ dgop (2-exp i)))
(sign (-1-expt-n+1 n) (- sign)) (sign (-1-expt-n+1 n) (- sign))
(del-i x-n+1 (a-face4 base-face i (1+ i) (del-i x-n+1 (a-face4 base-face i (1+ i)
del-i)) del-i))
(rslt (zero-cmbn n+1))) (rslt (zero-cmbn n+1)))
((minusp i) rslt) ((minusp i) rslt)
(declare (declare
(fixnum i dgop sign) (fixnum i dgop sign)
(type absm del-i) (type absm del-i)
(type cmbn rslt)) (type cmbn rslt))
(let ((absm1 (ndgnr dgop del-i)) (let ((absm1 (ndgnr dgop del-i))
(loop-absm2 (1dgnr i g-n))) (loop-absm2 (1dgnr i g-n)))
(declare (type absm absm1 loop-absm2)) (declare (type absm absm1 loop-absm2))
(unless (plusp (logand (dgop absm1) (unless (plusp (logand (dgop absm1)
(dgop loop-absm2))) (dgop loop-absm2)))
(dstr-add-term-to-cmbn (dstr-add-term-to-cmbn
crts-cmpr crts-cmpr
sign (crpr absm1 loop-absm2) sign (crpr absm1 loop-absm2)
rslt))))) rslt)))))
(h-hat (g-n) (h-hat (g-n)
(declare (type iloop g-n)) ;;; *** (declare (type iloop g-n)) ;;; ***
(multiple-value-bind (expn y-n+1 gp-n) (multiple-value-bind (expn y-n+1 gp-n)
(pop-first-absm n g-n) (pop-first-absm n g-n)
(declare (declare
(fixnum expn) (fixnum expn)
(type (or absm null) y-n+1 gp-n)) (type (or absm null) y-n+1 gp-n))
(ecase expn (ecase expn
(0 (zero-cmbn (1+ n))) (0 (zero-cmbn (1+ n)))
(+1 (+1
(let ((h-tildes (let ((h-tildes
(2cmbn-sbtr (2cmbn-sbtr
crts-cmpr (h-tilde y-n+1 gp-n) crts-cmpr (h-tilde y-n+1 gp-n)
(h-tilde (1dgnr n (a-face4 base-face (h-tilde (1dgnr n (a-face4 base-face
(1+ n) (1+ n)
(1+ n) (1+ n)
y-n+1)) y-n+1))
(absm 0 (make-loop :list (absm 0 (make-loop :list
g-n)))))) g-n))))))
(declare (type cmbn h-tildes)) (declare (type cmbn h-tildes))
(if (degenerate-p gp-n) (if (degenerate-p gp-n)
h-tildes h-tildes
(2cmbn-add crts-cmpr (2cmbn-add crts-cmpr
(h-hat (loop-list (h-hat (loop-list
(gmsm gp-n))) (gmsm gp-n)))
h-tildes)))) h-tildes))))
(-1 (-1
(let ((next-x-n (a-face4 base-face (1+ n) (let ((next-x-n (a-face4 base-face (1+ n)
(1+ n) y-n+1)) (1+ n) y-n+1))
(h-tilde (h-tilde
(h-tilde y-n+1 (h-tilde y-n+1
(absm 0 (make-loop (absm 0 (make-loop
:list g-n))))) :list g-n)))))
(declare (declare
(type absm next-x-n) (type absm next-x-n)
(type cmbn h-tilde)) (type cmbn h-tilde))
(if (zerop (logand (dgop next-x-n) (if (zerop (logand (dgop next-x-n)
(dgop gp-n))) (dgop gp-n)))
(2cmbn-sbtr crts-cmpr (2cmbn-sbtr crts-cmpr
(hh next-x-n gp-n) h-tilde) (hh next-x-n gp-n) h-tilde)
(cmbn-opps h-tilde)))))))) (cmbn-opps h-tilde))))))))
(with-crpr (absm1 loop-absm2) crpr (with-crpr (absm1 loop-absm2) crpr
(hh absm1 loop-absm2))))))) (hh absm1 loop-absm2)))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
(DEFUN CRTS-CONTRACTION (space (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)) (declare (type simplicial-set space twisted-crts-prdc))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc twisted-crts-prdc :trgt twisted-crts-prdc :degr +1 :sorc twisted-crts-prdc :trgt twisted-crts-prdc :degr +1
:intr (crts-contraction-intr (cmpr space) (bspn space) (face space) :intr (crts-contraction-intr (cmpr space) (bspn space) (face space)
(cmpr twisted-crts-prdc)) (cmpr twisted-crts-prdc))
:strt :gnrt :strt :gnrt
:orgn `(crts-contraction ,space)))) :orgn `(crts-contraction ,space))))
(DEFUN TNPR-CONTRACTION (space (DEFUN TNPR-CONTRACTION (space
&aux &aux
(szczarba (szczarba space)) (szczarba (szczarba space))
(f (f szczarba)) (f (f szczarba))
(g (g szczarba)) (g (g szczarba))

2
src/macros.lisp
View File

@ -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
;;; MACROS MACROS MACROS MACROS MACROS MACROS MACROS ;;; MACROS MACROS MACROS MACROS MACROS MACROS MACROS

12
src/searching-homology.lisp
View File

@ -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 ;;; 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)) (declare (ignore class))
(the homotopy-equivalence (the homotopy-equivalence
(let ((efhm (search-efhm chcm (first (orgn chcm))))) (let ((efhm (search-efhm chcm (first (orgn chcm)))))
(setf (efhm chcm) (setf (efhm chcm)
(or efhm (or efhm
(when (functionp (basis chcm)) (when (functionp (basis chcm))
(trivial-hmeq chcm)) (trivial-hmeq chcm))
(error "I don't know how to determine ~ (error "I don't know how to determine ~
the effective homology of:~@ the effective homology of:~@
~A (Origin: ~A)." chcm (orgn chcm))))))) ~A (Origin: ~A)." chcm (orgn chcm)))))))

218
src/serre.lisp
View File

@ -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 ;;; 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 (DEFUN FIBRATION-DTAU-D-INTR
(fibration &aux (base (sorc fibration)) (fibration &aux (base (sorc fibration))
(bface (face base)) (bface (face base))
(fibre (trgt fibration)) (fibre (trgt fibration))
(fface (face fibre)) (fface (face fibre))
(sintr-grml (sintr (grml fibre))) (sintr-grml (sintr (grml fibre)))
(fbspn (bspn fibre)) (fbspn (bspn fibre))
(sintr-twist (sintr fibration)) (sintr-twist (sintr fibration))
(total (fibration-total fibration)) (total (fibration-total fibration))
(total-cmpr (cmpr total))) (total-cmpr (cmpr total)))
(declare (declare
(type fibration fibration) (type fibration fibration)
(type simplicial-set base total) (type simplicial-set base total)
@ -26,80 +28,80 @@
(type cmprf total-cmpr)) (type cmprf total-cmpr))
(flet ((rslt (dmns crpr (flet ((rslt (dmns crpr
&aux (dmns-1 (1- dmns))) &aux (dmns-1 (1- dmns)))
(declare (declare
(fixnum dmns dmns-1) (fixnum dmns dmns-1)
(type crpr crpr)) (type crpr crpr))
(unless (plusp dmns) (unless (plusp dmns)
(return-from rslt (return-from rslt
(zero-cmbn dmns-1))) (zero-cmbn dmns-1)))
(with-crpr (with-crpr
(b-absm f-absm) crpr (b-absm f-absm) crpr
(let ((tau-b (let ((tau-b
(tw-a-sintr3 sintr-twist dmns (tw-a-sintr3 sintr-twist dmns
b-absm fbspn))) b-absm fbspn)))
(declare (type absm tau-b)) (declare (type absm tau-b))
(when (= (dgop tau-b) (mask dmns-1)) (when (= (dgop tau-b) (mask dmns-1))
(return-from rslt (return-from rslt
(zero-cmbn dmns-1))) (zero-cmbn dmns-1)))
(let ((deln-b (let ((deln-b
(a-face4 bface dmns dmns (a-face4 bface dmns dmns
b-absm)) b-absm))
(deln-f (deln-f
(a-face4 fface dmns dmns (a-face4 fface dmns dmns
f-absm))) f-absm)))
(declare (declare
(type absm deln-b deln-f tau-b)) (type absm deln-b deln-f tau-b))
(let ((acrpr1 (2absm-acrpr deln-b deln-f)) (let ((acrpr1 (2absm-acrpr deln-b deln-f))
(acrpr2 (acrpr2
(2absm-acrpr (2absm-acrpr
deln-b deln-b
(a-grml4 sintr-grml (1- dmns) (a-grml4 sintr-grml (1- dmns)
tau-b deln-f)))) tau-b deln-f))))
(declare (type absm acrpr1 acrpr2)) (declare (type absm acrpr1 acrpr2))
(with-absm (with-absm
(dgop1 crpr1) acrpr1 (dgop1 crpr1) acrpr1
(with-absm (with-absm
(dgop2 crpr2) acrpr2 (dgop2 crpr2) acrpr2
(if (zerop dgop1) (if (zerop dgop1)
(if (zerop dgop2) (if (zerop dgop2)
(dstr-add-term-to-cmbn (dstr-add-term-to-cmbn
total-cmpr total-cmpr
(-1-expt-n+1 dmns) crpr1 (-1-expt-n+1 dmns) crpr1
(term-cmbn dmns-1 (term-cmbn dmns-1
(-1-expt-n dmns) (-1-expt-n dmns)
crpr2)) crpr2))
(term-cmbn dmns-1 (term-cmbn dmns-1
(-1-expt-n+1 dmns) (-1-expt-n+1 dmns)
crpr1)) crpr1))
(if (zerop dgop2) (if (zerop dgop2)
(term-cmbn dmns-1 (term-cmbn dmns-1
(-1-expt-n dmns) (-1-expt-n dmns)
crpr2) crpr2)
(zero-cmbn dmns-1))))))))))) (zero-cmbn dmns-1)))))))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
(DEFUN FIBRATION-DTAU-D (fibration (DEFUN FIBRATION-DTAU-D (fibration
&aux (base (sorc fibration)) &aux (base (sorc fibration))
(fibre (trgt fibration)) (fibre (trgt fibration))
(utotal (crts-prdc base fibre))) (utotal (crts-prdc base fibre)))
(declare (type fibration fibration)) (declare (type fibration fibration))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc utotal :sorc utotal
:trgt utotal :trgt utotal
:degr -1 :degr -1
:intr (fibration-dtau-d-intr fibration) :intr (fibration-dtau-d-intr fibration)
:strt :gnrt :strt :gnrt
:orgn `(fibration-dtau-d ,fibration)))) :orgn `(fibration-dtau-d ,fibration))))
(DEFUN BROWN-REDUCTION (fibration (DEFUN BROWN-REDUCTION (fibration
&aux (base (sorc fibration)) &aux (base (sorc fibration))
(fibre (trgt fibration)) (fibre (trgt fibration))
(total (fibration-total fibration)) (total (fibration-total fibration))
(ez (eilenberg-zilber base fibre)) (ez (eilenberg-zilber base fibre))
(t-perturbation (fibration-dtau-d fibration))) (t-perturbation (fibration-dtau-d fibration)))
(declare (declare
(type fibration fibration) (type fibration fibration)
(type simplicial-set base fibre total) (type simplicial-set base fibre total)
@ -107,15 +109,15 @@
(type morphism t-perturbation)) (type morphism t-perturbation))
(the (values reduction morphism) (the (values reduction morphism)
(multiple-value-bind (rslt b-perturbation) (add ez t-perturbation) (multiple-value-bind (rslt b-perturbation) (add ez t-perturbation)
(declare (declare
(type reduction rslt) (type reduction rslt)
(type morphism b-perturbation)) (type morphism b-perturbation))
(with-slots (f g h tcc) rslt (with-slots (f g h tcc) rslt
(setf tcc total) (setf tcc total)
(dstr-change-sorc-trgt f :new-sorc total) (dstr-change-sorc-trgt f :new-sorc total)
(dstr-change-sorc-trgt g :new-trgt total) (dstr-change-sorc-trgt g :new-trgt total)
(dstr-change-sorc-trgt h :new-sorc total :new-trgt total) (dstr-change-sorc-trgt h :new-sorc total :new-trgt total)
(values rslt b-perturbation))))) (values rslt b-perturbation)))))
(DEFUN LEFT-SERRE-EFHM (fibration) (DEFUN LEFT-SERRE-EFHM (fibration)
@ -123,49 +125,49 @@
(the homotopy-equivalence (the homotopy-equivalence
(build-hmeq (build-hmeq
:lrdct (trivial-rdct (fibration-total fibration)) :lrdct (trivial-rdct (fibration-total fibration))
:rrdct (brown-reduction fibration)))) :rrdct (brown-reduction fibration))))
(DEFUN RIGHT-SERRE-EFHM (fibration (DEFUN RIGHT-SERRE-EFHM (fibration
&aux (base (sorc fibration)) &aux (base (sorc fibration))
(fibre (trgt fibration)) (fibre (trgt fibration))
(base-efhm (efhm base)) (base-efhm (efhm base))
(fibre-efhm (efhm fibre)) (fibre-efhm (efhm fibre))
(uprdc-efhm (tnsr-prdc base-efhm fibre-efhm))) (uprdc-efhm (tnsr-prdc base-efhm fibre-efhm)))
(declare (declare
(type fibration fibration) (type fibration fibration)
(type simplicial-set base fibre) (type simplicial-set base fibre)
(type homotopy-equivalence base-efhm fibre-efhm uprdc-efhm)) (type homotopy-equivalence base-efhm fibre-efhm uprdc-efhm))
(the homotopy-equivalence (the homotopy-equivalence
(multiple-value-bind (brown b-perturbation) (brown-reduction fibration) (multiple-value-bind (brown b-perturbation) (brown-reduction fibration)
(declare (declare
(type reduction brown) (type reduction brown)
(type morphism b-perturbation)) (type morphism b-perturbation))
(let ((rslt (add uprdc-efhm b-perturbation))) (let ((rslt (add uprdc-efhm b-perturbation)))
(declare (type homotopy-equivalence rslt)) (declare (type homotopy-equivalence rslt))
(with-slots (lbcc lf lg lrdct) rslt (with-slots (lbcc lf lg lrdct) rslt
(declare (declare
(type chain-complex lbcc) (type chain-complex lbcc)
(type morphism lf lg) (type morphism lf lg)
(type reduction lrdct)) (type reduction lrdct))
(setf lbcc (bcc brown)) (setf lbcc (bcc brown))
(dstr-change-sorc-trgt lf :new-trgt lbcc) (dstr-change-sorc-trgt lf :new-trgt lbcc)
(dstr-change-sorc-trgt lg :new-sorc lbcc) (dstr-change-sorc-trgt lg :new-sorc lbcc)
(with-slots (bcc f g) lrdct (with-slots (bcc f g) lrdct
(declare (declare
(type chain-complex bcc) (type chain-complex bcc)
(type morphism f g)) (type morphism f g))
(setf bcc lbcc) (setf bcc lbcc)
(dstr-change-sorc-trgt f :new-trgt lbcc) (dstr-change-sorc-trgt f :new-trgt lbcc)
(dstr-change-sorc-trgt g :new-sorc lbcc))) (dstr-change-sorc-trgt g :new-sorc lbcc)))
rslt)))) rslt))))
(DEFUN FIBRATION-TOTAL-EFHM (fibration) (DEFUN FIBRATION-TOTAL-EFHM (fibration)
(declare (type fibration fibration)) (declare (type fibration fibration))
(the homotopy-equivalence (the homotopy-equivalence
(cmps (left-serre-efhm fibration) (cmps (left-serre-efhm fibration)
(right-serre-efhm fibration)))) (right-serre-efhm fibration))))
(DEFMETHOD SEARCH-EFHM (smst (orgn (eql 'fibration-total))) (DEFMETHOD SEARCH-EFHM (smst (orgn (eql 'fibration-total)))

174
src/simplicial-groups.lisp
View File

@ -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 ;;; 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) (DEFMETHOD PRINT-OBJECT ((smgr simplicial-group) stream)
(the simplicial-group (the simplicial-group
(progn (progn
(format stream "[K~D Simplicial-Group]" (idnm smgr)) (format stream "[K~D Simplicial-Group]" (idnm smgr))
smgr))) smgr)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t)) (setf (ext:package-lock :clos) t))
@ -28,8 +30,8 @@
(DEFMETHOD PRINT-OBJECT ((smgr ab-simplicial-group) stream) (DEFMETHOD PRINT-OBJECT ((smgr ab-simplicial-group) stream)
(the simplicial-group (the simplicial-group
(progn (progn
(format stream "[K~D Abelian-Simplicial-Group]" (idnm smgr)) (format stream "[K~D Abelian-Simplicial-Group]" (idnm smgr))
smgr))) smgr)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t)) (setf (ext:package-lock :clos) t))
@ -55,20 +57,20 @@
(when already (when already
(return-from build-smgr already))) (return-from build-smgr already)))
(let ((rslt (build-smst (let ((rslt (build-smst
:cmpr cmpr :basis basis :bspn bspn :cmpr cmpr :basis basis :bspn bspn
:face face :face* face* :intr-bndr intr-bndr :face face :face* face* :intr-bndr intr-bndr
:bndr-strt bndr-strt :intr-dgnl intr-dgnl :bndr-strt bndr-strt :intr-dgnl intr-dgnl
:dgnl-strt dgnl-strt :orgn orgn))) :dgnl-strt dgnl-strt :orgn orgn)))
(declare (type simplicial-set rslt)) (declare (type simplicial-set rslt))
(change-class rslt 'simplicial-group) (change-class rslt 'simplicial-group)
(setf (slot-value rslt 'grml) (setf (slot-value rslt 'grml)
(build-smmr (build-smmr
:sorc (crts-prdc rslt rslt) :trgt rslt :degr 0 :sorc (crts-prdc rslt rslt) :trgt rslt :degr 0
:sintr sintr-grml :orgn `(group-multiplication ,rslt)) :sintr sintr-grml :orgn `(group-multiplication ,rslt))
(slot-value rslt 'grin) (slot-value rslt 'grin)
(build-smmr (build-smmr
:sorc rslt :trgt rslt :degr 0 :sorc rslt :trgt rslt :degr 0
:sintr sintr-grin :orgn `(group-inversion ,rslt))) :sintr sintr-grin :orgn `(group-inversion ,rslt)))
(push rslt *smgr-list*) (push rslt *smgr-list*)
rslt)) rslt))
@ -79,12 +81,12 @@
(type absm absm1 absm2)) (type absm absm1 absm2))
(the absm (the absm
(let ((acrpr (2absm-acrpr absm1 absm2))) (let ((acrpr (2absm-acrpr absm1 absm2)))
(declare (type absm acrpr)) (declare (type absm acrpr))
(with-absm (dgop crpr) acrpr (with-absm (dgop crpr) acrpr
(ndgnr dgop (ndgnr dgop
(funcall sintr-grml (funcall sintr-grml
(- dmns (logcount dgop)) (- dmns (logcount dgop))
crpr)))))) crpr))))))
(DEFUN A-GRIN4 (sintr-grin dmns absm) (DEFUN A-GRIN4 (sintr-grin dmns absm)
@ -94,73 +96,73 @@
(type absm absm)) (type absm absm))
(the absm (the absm
(with-absm (dgop gmsm) absm (with-absm (dgop gmsm) absm
(absm dgop (absm dgop
(gmsm (gmsm
(funcall sintr-grin (- dmns (logcount dgop)) (funcall sintr-grin (- dmns (logcount dgop))
gmsm)))))) gmsm))))))
(DEFMETHOD SLOT-UNBOUND (class (smgr simplicial-group) (DEFMETHOD SLOT-UNBOUND (class (smgr simplicial-group)
(name (eql 'kfll))) (name (eql 'kfll)))
(declare (ignore class)) (declare (ignore class))
(the kfll (the kfll
(progn (progn
(push smgr *kan-list*) (push smgr *kan-list*)
(setf (slot-value smgr 'kfll) (smgr-kfll smgr))))) (setf (slot-value smgr 'kfll) (smgr-kfll smgr)))))
(DEFUN SMGR-KFLL-INTR (face sintr-grml sintr-grin) (DEFUN SMGR-KFLL-INTR (face sintr-grml sintr-grin)
(flet ((rslt (indx dmns hat (flet ((rslt (indx dmns hat
&aux (dmns-1 (1- dmns))) &aux (dmns-1 (1- dmns)))
(declare (declare
(fixnum indx dmns dmns-1) (fixnum indx dmns dmns-1)
(list hat)) (list hat))
(the absm (the absm
(let ((rslt (absm 0 nil))) (let ((rslt (absm 0 nil)))
(declare (type absm rslt)) (declare (type absm rslt))
(when (plusp indx) (when (plusp indx)
(setf rslt (1dgnr 0 (pop hat))) (setf rslt (1dgnr 0 (pop hat)))
(do ((i 1 (1+ i))) (do ((i 1 (1+ i)))
((= i indx)) ((= i indx))
(declare (fixnum i)) (declare (fixnum i))
(setf rslt (setf rslt
(a-grml4 (a-grml4
sintr-grml dmns sintr-grml dmns
rslt rslt
(1dgnr i (1dgnr i
(a-grml4 (a-grml4
sintr-grml dmns-1 sintr-grml dmns-1
(a-grin4 (a-grin4
sintr-grin dmns-1 sintr-grin dmns-1
(a-face4 face (a-face4 face
i dmns rslt)) i dmns rslt))
(pop hat))))))) (pop hat)))))))
(when (< indx dmns) (when (< indx dmns)
(setf hat (reverse hat)) (setf hat (reverse hat))
(when (zerop indx) (when (zerop indx)
(setf rslt (1dgnr dmns-1 (pop hat)))) (setf rslt (1dgnr dmns-1 (pop hat))))
(do ((i (if (zerop indx) (do ((i (if (zerop indx)
dmns-1 dmns-1
dmns) dmns)
(1- i))) (1- i)))
((endp hat) rslt) ((endp hat) rslt)
(declare (declare
(type absm rslt) (type absm rslt)
(fixnum i)) (fixnum i))
(setf rslt (setf rslt
(a-grml4 (a-grml4
sintr-grml dmns sintr-grml dmns
rslt rslt
(1dgnr (1- i) (1dgnr (1- i)
(a-grml4 (a-grml4
sintr-grml dmns-1 sintr-grml dmns-1
(a-grin4 (a-grin4
sintr-grin dmns-1 sintr-grin dmns-1
(a-face4 (a-face4
face face
i dmns rslt)) i dmns rslt))
(pop hat))))))) (pop hat)))))))
rslt)))) rslt))))
(the kfll #'rslt))) (the kfll #'rslt)))
@ -174,20 +176,20 @@
(DEFMETHOD SLOT-UNBOUND (class (smgr simplicial-group) (DEFMETHOD SLOT-UNBOUND (class (smgr simplicial-group)
(name (eql 'aprd))) (name (eql 'aprd)))
(declare (ignore class)) (declare (ignore class))
(the morphism (the morphism
(progn (progn
(push smgr *hopf-list*) (push smgr *hopf-list*)
(setf (slot-value smgr 'aprd) (smgr-aprd smgr))))) (setf (slot-value smgr 'aprd) (smgr-aprd smgr)))))
(DEFUN SMGR-APRD (smgr) (DEFUN SMGR-APRD (smgr)
(declare (type simplicial-group smgr)) (declare (type simplicial-group smgr))
(the morphism (the morphism
(let ((eml (eml smgr smgr)) (let ((eml (eml smgr smgr))
(grml (grml smgr))) (grml (grml smgr)))
(declare (declare
(type morphism eml) (type morphism eml)
(type simplicial-mrph grml)) (type simplicial-mrph grml))
(cmps grml eml)))) (cmps grml eml))))

114
src/simplicial-mrphs.lisp
View File

@ -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 ;;; 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 (typecase absm-or-gmsm
(absm (absm
(with-absm (dgop gmsm) absm-or-gmsm (with-absm (dgop gmsm) absm-or-gmsm
(let ((gmsm-smmr (funcall (sintr smmr) (let ((gmsm-smmr (funcall (sintr smmr)
(- dmns (logcount dgop)) gmsm))) (- dmns (logcount dgop)) gmsm)))
(declare (type absm gmsm-smmr)) (declare (type absm gmsm-smmr))
(ndgnr dgop gmsm-smmr)))) (ndgnr dgop gmsm-smmr))))
(otherwise (otherwise
(funcall (sintr smmr) dmns absm-or-gmsm)))) (funcall (sintr smmr) dmns absm-or-gmsm))))
@ -26,12 +28,12 @@
(DEFMETHOD PRINT-OBJECT ((smmr simplicial-mrph) stream) (DEFMETHOD PRINT-OBJECT ((smmr simplicial-mrph) stream)
(the simplicial-mrph (the simplicial-mrph
(progn (progn
(if (= -1 (degr smmr)) (if (= -1 (degr smmr))
(format stream "[K~D Fibration K~D -> K~D]" (format stream "[K~D Fibration K~D -> K~D]"
(idnm smmr) (idnm (sorc smmr)) (idnm (trgt smmr))) (idnm smmr) (idnm (sorc smmr)) (idnm (trgt smmr)))
(format stream "[K~D Simplicial-Morphism K~D -> K~D]" (format stream "[K~D Simplicial-Morphism K~D -> K~D]"
(idnm smmr) (idnm (sorc smmr)) (idnm (trgt smmr)))) (idnm smmr) (idnm (sorc smmr)) (idnm (trgt smmr))))
smmr))) smmr)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t)) (setf (ext:package-lock :clos) t))
@ -45,16 +47,16 @@
(DEFUN SINTR-INTR (sintr) (DEFUN SINTR-INTR (sintr)
(declare (type sintr sintr)) (declare (type sintr sintr))
(flet ((rslt (dmns gmsm) (flet ((rslt (dmns gmsm)
(declare (declare
(fixnum dmns) (fixnum dmns)
(type gmsm gmsm)) (type gmsm gmsm))
(when (minusp dmns) (when (minusp dmns)
(return-from rslt (zero-cmbn dmns))) (return-from rslt (zero-cmbn dmns)))
(let ((rslt (funcall sintr dmns gmsm))) (let ((rslt (funcall sintr dmns gmsm)))
(declare (type absm rslt)) (declare (type absm rslt))
(if (degenerate-p rslt) (if (degenerate-p rslt)
(zero-cmbn dmns) (zero-cmbn dmns)
(term-cmbn dmns 1 (gmsm rslt)))))) (term-cmbn dmns 1 (gmsm rslt))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
@ -68,26 +70,26 @@
(list orgn)) (list orgn))
(the simplicial-mrph (the simplicial-mrph
(progn (progn
(let ((already (find orgn *smmr-list* :test #'equal :key #'orgn))) (let ((already (find orgn *smmr-list* :test #'equal :key #'orgn)))
(declare (type (or simplicial-mrph null) already)) (declare (type (or simplicial-mrph null) already))
(when already (when already
(return-from build-smmr already))) (return-from build-smmr already)))
(if (zerop degr) (if (zerop degr)
(if intr (if intr
(unless strt (unless strt
(error "In BUILD-SMMR, an intr is given but not its strt")) (error "In BUILD-SMMR, an intr is given but not its strt"))
(setf strt :gnrt (setf strt :gnrt
intr (sintr-intr sintr))) intr (sintr-intr sintr)))
(setf intr nil strt :gnrt)) (setf intr nil strt :gnrt))
(let ((rslt (build-mrph (let ((rslt (build-mrph
:sorc sorc :trgt trgt :degr degr :sorc sorc :trgt trgt :degr degr
:intr intr :strt strt :intr intr :strt strt
:orgn orgn))) :orgn orgn)))
(declare (type morphism rslt)) (declare (type morphism rslt))
(change-class rslt 'simplicial-mrph) (change-class rslt 'simplicial-mrph)
(setf (slot-value rslt 'sintr) sintr) (setf (slot-value rslt 'sintr) sintr)
(push rslt *smmr-list*) (push rslt *smmr-list*)
rslt)))) rslt))))
#| ???? #| ????
@ -98,7 +100,7 @@
(type iabsm iabsm)) (type iabsm iabsm))
(the absm (the absm
(with-iabsm (dgop gmsm) iabsm (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) (DEFUN A-SINTR3 (sintr dmns absm)
(declare (declare
@ -107,7 +109,7 @@
(type absm absm)) (type absm absm))
(the absm (the absm
(with-absm (dgop gmsm) 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)) (type gmsm bspn))
(the absm (the absm
(with-absm (dgop gmsm) absm (with-absm (dgop gmsm) absm
(let ((dmns-1 (1- dmns))) (let ((dmns-1 (1- dmns)))
(declare (fixnum dmns-1)) (declare (fixnum dmns-1))
(if (logbitp dmns-1 dgop) (if (logbitp dmns-1 dgop)
(absm (mask dmns-1) bspn) (absm (mask dmns-1) bspn)
(ndgnr dgop (funcall sintr (ndgnr dgop (funcall sintr
(- dmns (logcount dgop)) (- dmns (logcount dgop))
gmsm))))))) gmsm)))))))
#| #|
(DEFUN TW-IA-SINTR3 (sintr dmns iabsm bspn) (DEFUN TW-IA-SINTR3 (sintr dmns iabsm bspn)
@ -136,11 +138,11 @@
(type gmsm bspn)) (type gmsm bspn))
(the absm (the absm
(with-iabsm (dgop gmsm) iabsm (with-iabsm (dgop gmsm) iabsm
(let ((dmns-1 (1- dmns))) (let ((dmns-1 (1- dmns)))
(declare (fixnum dmns-1)) (declare (fixnum dmns-1))
(if (logbitp dmns-1 dgop) (if (logbitp dmns-1 dgop)
(absm (mask dmns-1) bspn) (absm (mask dmns-1) bspn)
(ndgnr dgop (funcall sintr (ndgnr dgop (funcall sintr
(- dmns (logcount dgop)) (- dmns (logcount dgop))
gmsm))))))) gmsm)))))))
|# |#

412
src/simplicial-sets.lisp
View File

@ -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 ;;; 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))) (error "In DGOP-EXT-INT, the external dgop ~A is not decreasing." ext-dgop)))
(the fixnum (the fixnum
(apply #'logxor (mapcar (apply #'logxor (mapcar
#'(lambda (item) #'(lambda (item)
(declare (fixnum item)) (declare (fixnum item))
(the fixnum (2-exp item))) (the fixnum (2-exp item)))
ext-dgop)))) ext-dgop))))
(DEFUN DGOP-INT-EXT (dgop) (DEFUN DGOP-INT-EXT (dgop)
@ -27,14 +29,14 @@
(error "In DXOP-INT-EXT, ~A is not a dxop." dgop)) (error "In DXOP-INT-EXT, ~A is not a dxop." dgop))
(the list (the list
(do ((dgop dgop (ash dgop -1)) (do ((dgop dgop (ash dgop -1))
(rslt +empty-list+) (rslt +empty-list+)
(bmark 0 (1+ bmark))) (bmark 0 (1+ bmark)))
((zerop dgop) rslt) ((zerop dgop) rslt)
(declare (declare
(fixnum dgop bmark) (fixnum dgop bmark)
(list rslt)) (list rslt))
(when (oddp dgop) (when (oddp dgop)
(push bmark rslt))))) (push bmark rslt)))))
(DEFUN HYPHENIZE-LIST (list) (DEFUN HYPHENIZE-LIST (list)
@ -50,9 +52,9 @@
(type stream stream) (type stream stream)
(ignore depth)) (ignore depth))
(format stream (format stream
"<AbSm ~A ~A>" "<AbSm ~A ~A>"
(hyphenize-list (dgop-int-ext (dgop absm))) (hyphenize-list (dgop-int-ext (dgop absm)))
(gmsm absm)) (gmsm absm))
absm) absm)
@ -68,7 +70,7 @@
(the simplicial-set (the simplicial-set
(progn (progn
(format stream "[K~D Simplicial-Set]" (idnm smst)) (format stream "[K~D Simplicial-Set]" (idnm smst))
smst))) smst)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t)) (setf (ext:package-lock :clos) t))
@ -97,24 +99,24 @@
(return-from build-smst already))) (return-from build-smst already)))
(if intr-bndr (if intr-bndr
(unless bndr-strt (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* (cond (face*
(setf bndr-strt :gnrt (setf bndr-strt :gnrt
intr-bndr (face*-bndr cmpr face*))) intr-bndr (face*-bndr cmpr face*)))
(face (face
(setf bndr-strt :gnrt (setf bndr-strt :gnrt
intr-bndr (face-bndr cmpr face))))) intr-bndr (face-bndr cmpr face)))))
(if intr-dgnl (if intr-dgnl
(unless dgnl-strt (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 (setf dgnl-strt :gnrt
intr-dgnl (intr-diagonal face))) intr-dgnl (intr-diagonal face)))
(the simplicial-set (the simplicial-set
(let ((rslt (build-chcm :cmpr cmpr :basis basis :bsgn bspn (let ((rslt (build-chcm :cmpr cmpr :basis basis :bsgn bspn
:intr-dffr intr-bndr :intr-dffr intr-bndr
:strt bndr-strt :orgn orgn))) :strt bndr-strt :orgn orgn)))
(change-chcm-to-clgb rslt (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) (setf (slot-value (dgnl rslt) 'orgn)
`(diagonal ,rslt)) `(diagonal ,rslt))
(change-class rslt 'simplicial-set) (change-class rslt 'simplicial-set)
@ -129,53 +131,53 @@
(fixnum dmns)) (fixnum dmns))
(the list (the list
(let ((basis-array (make-array (1+ dmns) :element-type 'list))) (let ((basis-array (make-array (1+ dmns) :element-type 'list)))
(declare (type (vector list) basis-array)) (declare (type (vector list) basis-array))
(dotimes (i (1+ dmns)) (dotimes (i (1+ dmns))
(declare (fixnum i)) (declare (fixnum i))
(setf (aref basis-array i) (funcall basis i))) (setf (aref basis-array i) (funcall basis i)))
(do ((dgop (mask dmns) (1- dgop)) (do ((dgop (mask dmns) (1- dgop))
(rslt +empty-list+ (rslt +empty-list+
(nconc (mapcar (nconc (mapcar
#'(lambda (gmsm) #'(lambda (gmsm)
(declare (type gmsm gmsm)) (declare (type gmsm gmsm))
(absm dgop gmsm)) (absm dgop gmsm))
(aref basis-array (- dmns (logcount dgop)))) (aref basis-array (- dmns (logcount dgop))))
rslt))) rslt)))
((minusp dgop) rslt))))) ((minusp dgop) rslt)))))
(DEFUN INTR-DIAGONAL (face) (DEFUN INTR-DIAGONAL (face)
(declare (type face face)) (declare (type face face))
(flet ((rslt (dmns gmsm) (flet ((rslt (dmns gmsm)
(declare (declare
(fixnum dmns) (fixnum dmns)
(type gmsm gmsm)) (type gmsm gmsm))
(the cmbn (the cmbn
(let ((del-0-s +empty-list+) (let ((del-0-s +empty-list+)
(rslt +empty-list+)) (rslt +empty-list+))
(declare (list del-0-s rslt)) (declare (list del-0-s rslt))
(do ((dmns dmns (1- dmns)) (do ((dmns dmns (1- dmns))
(absm (absm 0 gmsm) (a-face4 face 0 dmns absm))) (absm (absm 0 gmsm) (a-face4 face 0 dmns absm)))
((zerop dmns) (push absm del-0-s)) ((zerop dmns) (push absm del-0-s))
(declare (fixnum dmns) (type absm absm)) (declare (fixnum dmns) (type absm absm))
(push absm del-0-s)) (push absm del-0-s))
(do ((ldmns dmns (1- ldmns)) (do ((ldmns dmns (1- ldmns))
(rdmns 0 (1+ rdmns)) (rdmns 0 (1+ rdmns))
(absm (absm 0 gmsm) (a-face4 face ldmns ldmns absm)) (absm (absm 0 gmsm) (a-face4 face ldmns ldmns absm))
(mark-del-0 del-0-s (cdr mark-del-0))) (mark-del-0 del-0-s (cdr mark-del-0)))
((zerop ldmns) ((zerop ldmns)
(push (term 1 (tnpr 0 (gmsm absm) dmns gmsm)) (push (term 1 (tnpr 0 (gmsm absm) dmns gmsm))
rslt)) rslt))
(declare (declare
(fixnum ldmns rdmns) (fixnum ldmns rdmns)
(type gmsm gmsm) (type gmsm gmsm)
(list mark-del-0)) (list mark-del-0))
(unless (or (plusp (dgop absm)) (unless (or (plusp (dgop absm))
(plusp (dgop (car mark-del-0)))) (plusp (dgop (car mark-del-0))))
(push (term 1 (tnpr ldmns (gmsm absm) (push (term 1 (tnpr ldmns (gmsm absm)
rdmns (gmsm (car mark-del-0)))) rdmns (gmsm (car mark-del-0))))
rslt))) rslt)))
(make-cmbn :degr dmns :list rslt))))) (make-cmbn :degr dmns :list rslt)))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
@ -184,24 +186,24 @@
(type cmprf cmpr) (type cmprf cmpr)
(type face face)) (type face face))
(flet ((rslt (dmns gmsm) (flet ((rslt (dmns gmsm)
(declare (declare
(fixnum dmns) (fixnum dmns)
(type gmsm gmsm)) (type gmsm gmsm))
(the cmbn (the cmbn
(progn (progn
(when (zerop dmns) (when (zerop dmns)
(return-from rslt +zero-negative-cmbn+)) (return-from rslt +zero-negative-cmbn+))
(let ((pre-rslt +empty-list+)) (let ((pre-rslt +empty-list+))
(declare (list pre-rslt)) (declare (list pre-rslt))
;; (list (cons cffc face)) ;; (list (cons cffc face))
(dotimes (indx (1+ dmns)) (dotimes (indx (1+ dmns))
(declare (fixnum indx)) (declare (fixnum indx))
(let ((face (funcall face indx dmns gmsm))) (let ((face (funcall face indx dmns gmsm)))
(declare (type absm face)) (declare (type absm face))
(unless (degenerate-p face) (unless (degenerate-p face)
(push (term (-1-expt-n indx) (gmsm face)) (push (term (-1-expt-n indx) (gmsm face))
pre-rslt)))) pre-rslt))))
(apply #'nterm-add cmpr (1- dmns) pre-rslt)))))) (apply #'nterm-add cmpr (1- dmns) pre-rslt))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
@ -210,23 +212,23 @@
(type cmprf cmpr) (type cmprf cmpr)
(type face* face*)) (type face* face*))
(flet ((rslt (dmns gmsm) (flet ((rslt (dmns gmsm)
(declare (declare
(fixnum dmns) (fixnum dmns)
(type gmsm gmsm)) (type gmsm gmsm))
(the cmbn (the cmbn
(progn (progn
(when (zerop dmns) (when (zerop dmns)
(return-from rslt +zero-negative-cmbn+)) (return-from rslt +zero-negative-cmbn+))
(let ((pre-rslt +empty-list+)) (let ((pre-rslt +empty-list+))
(declare (list pre-rslt)) (declare (list pre-rslt))
;; (list (list gmsm fixnum)) ;; (list (list gmsm fixnum))
(dotimes (indx (1+ dmns)) (dotimes (indx (1+ dmns))
(declare (fixnum indx)) (declare (fixnum indx))
(let ((face (funcall face* indx dmns gmsm))) (let ((face (funcall face* indx dmns gmsm)))
(declare (type (or gmsm (eql :degenerate)) face)) (declare (type (or gmsm (eql :degenerate)) face))
(unless (eq face :degenerate) (unless (eq face :degenerate)
(push (term (-1-expt-n indx) face) pre-rslt)))) (push (term (-1-expt-n indx) face) pre-rslt))))
(apply #'nterm-add cmpr (1- dmns) pre-rslt)))))) (apply #'nterm-add cmpr (1- dmns) pre-rslt))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
@ -236,10 +238,10 @@
(type absm absm1 absm2)) (type absm absm1 absm2))
(the cmpr (the cmpr
(with-absm (dgop1 gmsm1) absm1 (with-absm (dgop1 gmsm1) absm1
(with-absm (dgop2 gmsm2) absm2 (with-absm (dgop2 gmsm2) absm2
(lexico (lexico
(f-cmpr dgop1 dgop2) (f-cmpr dgop1 dgop2)
(funcall cmpr gmsm1 gmsm2)))))) (funcall cmpr gmsm1 gmsm2))))))
(DEFUN BSPN-P (cmpr bspn dmns absm) (DEFUN BSPN-P (cmpr bspn dmns absm)
@ -251,8 +253,8 @@
(type absm absm)) (type absm absm))
(the boolean (the boolean
(with-absm (dgop gmsm) absm (with-absm (dgop gmsm) absm
(and (= dgop (mask dmns)) (and (= dgop (mask dmns))
(eq :equal (funcall cmpr bspn gmsm)))))) (eq :equal (funcall cmpr bspn gmsm))))))
(DEFUN DLOP-EXT-INT (ext-dlop) (DEFUN DLOP-EXT-INT (ext-dlop)
@ -263,10 +265,10 @@
(error "In DLOP-EXT-INT, the external dlop ~A is not increasing." ext-dlop))) (error "In DLOP-EXT-INT, the external dlop ~A is not increasing." ext-dlop)))
(the fixnum (the fixnum
(apply #'logxor (apply #'logxor
(mapcar #'(lambda (item) (mapcar #'(lambda (item)
(declare (fixnum item)) (declare (fixnum item))
(the fixnum (2-exp item))) (the fixnum (2-exp item)))
ext-dlop)))) ext-dlop))))
(DEFUN DLOP-INT-EXT (dlop) (DEFUN DLOP-INT-EXT (dlop)
@ -283,29 +285,29 @@
(let ((share (ash -1 1dgop))) (let ((share (ash -1 1dgop)))
(declare (fixnum share)) (declare (fixnum share))
(logxor (logxor
(ash (logand share dgop) 1) (ash (logand share dgop) 1)
(2-exp 1dgop) (2-exp 1dgop)
(logandc1 share dgop))))) (logandc1 share dgop)))))
(DEFUN DGOP*DGOP (dgop1 dgop2) (DEFUN DGOP*DGOP (dgop1 dgop2)
(declare (type fixnum dgop1 dgop2)) (declare (type fixnum dgop1 dgop2))
(let ((dgop 0) (let ((dgop 0)
(bmark 0)) (bmark 0))
(declare (fixnum dgop bmark)) (declare (fixnum dgop bmark))
(loop (loop
(when (zerop dgop1) (when (zerop dgop1)
(return-from dgop*dgop (return-from dgop*dgop
(logxor dgop (ash dgop2 bmark)))) (logxor dgop (ash dgop2 bmark))))
(when (zerop dgop2) (when (zerop dgop2)
(return-from dgop*dgop (return-from dgop*dgop
(logxor dgop (ash dgop1 bmark)))) (logxor dgop (ash dgop1 bmark))))
(cond ((evenp dgop1) (cond ((evenp dgop1)
(when (oddp dgop2) (when (oddp dgop2)
(incf dgop (2-exp bmark))) (incf dgop (2-exp bmark)))
(setf dgop2 (ash dgop2 -1))) (setf dgop2 (ash dgop2 -1)))
(t (t
(incf dgop (2-exp bmark)))) (incf dgop (2-exp bmark))))
(setf dgop1 (ash dgop1 -1)) (setf dgop1 (ash dgop1 -1))
(incf bmark)))) (incf bmark))))
@ -315,18 +317,18 @@
(the fixnum (the fixnum
(let ((cut (2-exp indx))) (let ((cut (2-exp indx)))
(multiple-value-bind (quotient remainder) (truncate n cut) (multiple-value-bind (quotient remainder) (truncate n cut)
(declare (fixnum quotient remainder)) (declare (fixnum quotient remainder))
(+ (ash (ash quotient -1) indx) remainder))))) (+ (ash (ash quotient -1) indx) remainder)))))
(DEFUN DGOP/DGOP (dgop1 dgop2) (DEFUN DGOP/DGOP (dgop1 dgop2)
(declare (fixnum dgop1 dgop2)) (declare (fixnum dgop1 dgop2))
(the fixnum (the fixnum
(do ((indx (1- (integer-length dgop2)) (1- indx))) (do ((indx (1- (integer-length dgop2)) (1- indx)))
((minusp indx) dgop1) ((minusp indx) dgop1)
(declare (fixnum indx)) (declare (fixnum indx))
(when (logbitp indx dgop2) (when (logbitp indx dgop2)
(setf dgop1 (remove-bit dgop1 indx)))))) (setf dgop1 (remove-bit dgop1 indx))))))
(DEFUN 1DLOP-DGOP (1dlop dgop) (DEFUN 1DLOP-DGOP (1dlop dgop)
@ -336,32 +338,32 @@
(the (values fixnum (or fixnum null)) (the (values fixnum (or fixnum null))
(progn (progn
(when (logbitp 1dlop dgop) (when (logbitp 1dlop dgop)
(let ((share (ash -1 1dlop))) (let ((share (ash -1 1dlop)))
(declare (fixnum share)) (declare (fixnum share))
(return-from 1dlop-dgop (return-from 1dlop-dgop
(values (values
(logxor (logxor
(logand share (ash dgop -1)) (logand share (ash dgop -1))
(logandc1 share dgop)) (logandc1 share dgop))
nil)))) nil))))
(when (and (plusp 1dlop) (when (and (plusp 1dlop)
(logbitp (1- 1dlop) dgop)) (logbitp (1- 1dlop) dgop))
(let ((share (ash -1 1dlop))) ;;; (let ((share (ash -1 1dlop))) ;;;
(declare (fixnum share)) (declare (fixnum share))
(setf share (ash share -1)) ;;; because of the compiler bug (setf share (ash share -1)) ;;; because of the compiler bug
(return-from 1dlop-dgop (return-from 1dlop-dgop
(values (values
(logxor (logxor
(logand share (ash dgop -1)) (logand share (ash dgop -1))
(logandc1 share dgop)) (logandc1 share dgop))
nil)))) nil))))
(let ((share (ash -1 1dlop))) (let ((share (ash -1 1dlop)))
(declare (fixnum share)) (declare (fixnum share))
(let ((right (logandc1 share dgop))) (let ((right (logandc1 share dgop)))
(declare (fixnum right)) (declare (fixnum right))
(values (values
(logxor right (logand share (ash dgop -1))) (logxor right (logand share (ash dgop -1)))
(- 1dlop (logcount right)))))))) (- 1dlop (logcount right))))))))
(DEFUN A-FACE4 (face indx dmns absm) (DEFUN A-FACE4 (face indx dmns absm)
@ -371,20 +373,20 @@
(type absm absm)) (type absm absm))
(the absm (the absm
(with-absm (with-absm
(dgop gmsm) absm (dgop gmsm) absm
(multiple-value-bind (dgop2 1dlop) (1dlop-dgop indx dgop) (multiple-value-bind (dgop2 1dlop) (1dlop-dgop indx dgop)
(declare (fixnum dgop2) (declare (fixnum dgop2)
#-(or ccl ecl lispworks sbcl) #-(or ccl ecl lispworks sbcl)
(type (or fixnum nil) 1dlop)) (type (or fixnum nil) 1dlop))
;; Bug LispWorks if this or-type defined ;; Bug LispWorks if this or-type defined
(unless 1dlop (unless 1dlop
(return-from a-face4 (absm dgop2 gmsm))) (return-from a-face4 (absm dgop2 gmsm)))
(locally (declare (fixnum 1dlop)) (locally (declare (fixnum 1dlop))
(let ((gmsm-face (funcall face 1dlop (- dmns (logcount dgop)) (let ((gmsm-face (funcall face 1dlop (- dmns (logcount dgop))
gmsm))) gmsm)))
(declare (type absm gmsm-face)) (declare (type absm gmsm-face))
(with-absm (dgop3 gmsm3) gmsm-face (with-absm (dgop3 gmsm3) gmsm-face
(absm (dgop*dgop dgop2 dgop3) gmsm3)))))))) (absm (dgop*dgop dgop2 dgop3) gmsm3))))))))
(DEFUN 1DGNR (indx absm) (DEFUN 1DGNR (indx absm)
@ -393,7 +395,7 @@
(type absm absm)) (type absm absm))
(the absm (the absm
(with-absm (dgop gmsm) absm (with-absm (dgop gmsm) absm
(absm (1dgop*dgop indx dgop) gmsm)))) (absm (1dgop*dgop indx dgop) gmsm))))
(DEFUN NDGNR (dgop absm) (DEFUN NDGNR (dgop absm)
@ -402,7 +404,7 @@
(type absm absm)) (type absm absm))
(the absm (the absm
(with-absm (dgop2 gmsm) absm (with-absm (dgop2 gmsm) absm
(absm (dgop*dgop dgop dgop2) gmsm)))) (absm (dgop*dgop dgop dgop2) gmsm))))
(DEFUN NFACE (face dlop dmns gmsm) (DEFUN NFACE (face dlop dmns gmsm)
@ -412,11 +414,11 @@
(fixnum dmns) (fixnum dmns)
(type gmsm gmsm)) (type gmsm gmsm))
(do* ((gmsm gmsm) (do* ((gmsm gmsm)
(dmns dmns) (dmns dmns)
(dgop 0) (dgop 0)
(dlop dlop (- dlop (2-exp bark))) (dlop dlop (- dlop (2-exp bark)))
(bark (1- (integer-length dlop)) (bark (1- (integer-length dlop))
(1- (integer-length dlop)))) (1- (integer-length dlop))))
((zerop dlop) (absm dgop gmsm)) ((zerop dlop) (absm dgop gmsm))
(declare (declare
(type gmsm gmsm) (type gmsm gmsm)
@ -426,15 +428,15 @@
(fixnum dgop2) (fixnum dgop2)
(type (or null fixnum) indx)) (type (or null fixnum) indx))
(if indx (if indx
(locally (declare (fixnum indx)) (locally (declare (fixnum indx))
(let ((new-absm (funcall face indx dmns gmsm))) (let ((new-absm (funcall face indx dmns gmsm)))
(declare (type absm new-absm)) (declare (type absm new-absm))
(with-absm (dgop3 gmsm2) new-absm (with-absm (dgop3 gmsm2) new-absm
(setf gmsm gmsm2 (setf gmsm gmsm2
dmns (- dmns 1 dmns (- dmns 1
(logcount dgop3)) (logcount dgop3))
dgop (dgop*dgop dgop2 dgop3))))) dgop (dgop*dgop dgop2 dgop3)))))
(setf dgop dgop2))))) (setf dgop dgop2)))))
(DEFUN CHECK-FACES (cmpr face dmns gmsm) (DEFUN CHECK-FACES (cmpr face dmns gmsm)
@ -446,25 +448,25 @@
(the boolean (the boolean
(progn (progn
(when (> dmns 1) (when (> dmns 1)
(let ((dmns-1 (1- dmns))) (let ((dmns-1 (1- dmns)))
(declare (fixnum dmns-1)) (declare (fixnum dmns-1))
(dotimes (i dmns) (dotimes (i dmns)
(declare (fixnum i)) (declare (fixnum i))
(dotimes (j (1+ i)) (dotimes (j (1+ i))
(declare (fixnum j)) (declare (fixnum j))
(let ((rslt1 (a-face4 face i dmns-1 (let ((rslt1 (a-face4 face i dmns-1
(funcall face j dmns gmsm))) (funcall face j dmns gmsm)))
(rslt2 (a-face4 face j dmns-1 (rslt2 (a-face4 face j dmns-1
(funcall face (1+ i) dmns gmsm)))) (funcall face (1+ i) dmns gmsm))))
(declare (type absm rslt1 rslt2)) (declare (type absm rslt1 rslt2))
(unless (eq (a-cmpr3 cmpr rslt1 rslt2) :equal) (unless (eq (a-cmpr3 cmpr rslt1 rslt2) :equal)
(cerror "CHECK-FACES will return NIL." (cerror "CHECK-FACES will return NIL."
"Noncoherent boundary operators detected by CHECK-FACES :~@ "Noncoherent boundary operators detected by CHECK-FACES :~@
Simplex => ~A~@ Simplex => ~A~@
del_~D o del_~D => ~A~@ del_~D o del_~D => ~A~@
del_~D o del_~D => ~A" del_~D o del_~D => ~A"
gmsm i j rslt1 j (1+ i) rslt2) gmsm i j rslt1 j (1+ i) rslt2)
(return-from check-faces nil))))))) (return-from check-faces nil)))))))
t))) t)))
@ -480,16 +482,16 @@
(error "In CHECK-SMST, the locally-effective simplicial-set ~A~@ (error "In CHECK-SMST, the locally-effective simplicial-set ~A~@
cannot be checked." smst)) cannot be checked." smst))
(do ((rslt t) (do ((rslt t)
(dmns dmns1 (1+ dmns))) (dmns dmns1 (1+ dmns)))
((>= dmns dmns2) rslt) ((>= dmns dmns2) rslt)
(declare (declare
(type boolean rslt) (type boolean rslt)
(fixnum dmns)) (fixnum dmns))
(format t "~%Checking the ~D-simplices..." dmns) (format t "~%Checking the ~D-simplices..." dmns)
(dolist (gmsm (funcall basis dmns)) (dolist (gmsm (funcall basis dmns))
(declare (type gmsm gmsm)) (declare (type gmsm gmsm))
(unless (check-faces cmpr face dmns gmsm) (unless (check-faces cmpr face dmns gmsm)
(setf rslt nil)))))) (setf rslt nil))))))
(DEFUN SHOW-STRUCTURE (smst dmns) (DEFUN SHOW-STRUCTURE (smst dmns)
@ -506,9 +508,9 @@ from dimension 0 up to and including dimension DMNS.
(dotimes (i (1+ dmns)) (dotimes (i (1+ dmns))
(format t "~2%Dimension = ~D:" i) (format t "~2%Dimension = ~D:" i)
(case i (case i
(0 (format t "~2%~8TVertices : ~8T~A" (basis smst 0))) (0 (format t "~2%~8TVertices : ~8T~A" (basis smst 0)))
(otherwise (otherwise
(dolist (s (basis smst i)) (dolist (s (basis smst i))
(format t "~2%~8TSimplex : ~A~2%~16TFaces : ~A" (format t "~2%~8TSimplex : ~A~2%~16TFaces : ~A"
s (mapcar #'(lambda (j) (face smst j i s)) s (mapcar #'(lambda (j) (face smst j i s))
(<a-b> 0 i))))))))) (<a-b> 0 i)))))))))

1092
src/smith.lisp
View File

File diff suppressed because it is too large Load Diff

1
src/special-smsts.lisp
View File

@ -1,4 +1,5 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* ;;;; -*- 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 ;;; 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

260
src/suspensions.lisp
View File

@ -1,3 +1,5 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
;;; SUSPENSIONS SUSPENSIONS SUSPENSIONS SUSPENSIONS ;;; SUSPENSIONS SUSPENSIONS SUSPENSIONS SUSPENSIONS
;;; SUSPENSIONS SUSPENSIONS SUSPENSIONS SUSPENSIONS ;;; SUSPENSIONS SUSPENSIONS SUSPENSIONS SUSPENSIONS
;;; SUSPENSIONS SUSPENSIONS SUSPENSIONS SUSPENSIONS ;;; SUSPENSIONS SUSPENSIONS SUSPENSIONS SUSPENSIONS
@ -9,10 +11,10 @@
(DEFUN SUSPENSION-CMPR (cmpr) (DEFUN SUSPENSION-CMPR (cmpr)
(declare (type cmprf cmpr)) (declare (type cmprf cmpr))
(flet ((rslt (gnrt1 gnrt2) (flet ((rslt (gnrt1 gnrt2)
(declare (type gnrt gnrt1 gnrt2)) (declare (type gnrt gnrt1 gnrt2))
(if (eq gnrt1 :s-bsgn) (if (eq gnrt1 :s-bsgn)
:equal :equal
(funcall cmpr gnrt1 gnrt2)))) (funcall cmpr gnrt1 gnrt2))))
(the cmprf #'rslt))) (the cmprf #'rslt)))
@ -21,35 +23,35 @@
(when (eq basis :locally-effective) (when (eq basis :locally-effective)
(return-from suspension-basis :locally-effective)) (return-from suspension-basis :locally-effective))
(flet ((rslt (degr) (flet ((rslt (degr)
(declare (fixnum degr)) (declare (fixnum degr))
(case degr (case degr
(0 (list :s-bsgn)) (0 (list :s-bsgn))
(1 +empty-list+) (1 +empty-list+)
(otherwise (funcall basis (1- degr)))))) (otherwise (funcall basis (1- degr))))))
(the basis #'rslt))) (the basis #'rslt)))
(DEFUN SUSPENSION-INTR-DFFR (dffr) (DEFUN SUSPENSION-INTR-DFFR (dffr)
(declare (type morphism dffr)) (declare (type morphism dffr))
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(with-cmbn (with-cmbn
(degr list) cmbn (degr list) cmbn
(decf degr) (decf degr)
(if (<= degr 0) (if (<= degr 0)
(zero-cmbn degr) (zero-cmbn degr)
(make-cmbn :degr degr (make-cmbn :degr degr
:list (cmbn-list :list (cmbn-list
(cmbn-? dffr (cmbn-? dffr
(make-cmbn :degr degr (make-cmbn :degr degr
:list list)))))))) :list list))))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
(DEFUN SUSPENSION (obj &optional (n 1)) (DEFUN SUSPENSION (obj &optional (n 1))
(declare (type (or chain-complex morphism reduction (declare (type (or chain-complex morphism reduction
homotopy-equivalence) obj) homotopy-equivalence) obj)
(fixnum n)) (fixnum n))
(if (= n 0) (if (= n 0)
obj obj
(suspension-1 (suspension obj (1- n))))) (suspension-1 (suspension obj (1- n)))))
@ -61,91 +63,91 @@
(DEFMETHOD SUSPENSION-1 ((chcm chain-complex)) (DEFMETHOD SUSPENSION-1 ((chcm chain-complex))
(the chain-complex (the chain-complex
(with-slots (cmpr basis dffr) chcm (with-slots (cmpr basis dffr) chcm
(build-chcm (build-chcm
:cmpr (suspension-cmpr cmpr) :cmpr (suspension-cmpr cmpr)
:basis (suspension-basis basis) :basis (suspension-basis basis)
:bsgn :s-bsgn :bsgn :s-bsgn
:intr-dffr (suspension-intr-dffr dffr) :intr-dffr (suspension-intr-dffr dffr)
:strt :cmbn :strt :cmbn
:orgn `(suspension ,chcm))))) :orgn `(suspension ,chcm)))))
(DEFUN SUSPENSION-INTR-CPRD (cmbn) (DEFUN SUSPENSION-INTR-CPRD (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(with-cmbn (with-cmbn
(degr list) cmbn (degr list) cmbn
(if (zerop degr) (if (zerop degr)
(make-cmbn :degr 0 (make-cmbn :degr 0
:list (if list :list (if list
(list (term (-cffc list) (list (term (-cffc list)
(tnpr 0 :s-bsgn (tnpr 0 :s-bsgn
0 :s-bsgn))) 0 :s-bsgn)))
+empty-list+)) +empty-list+))
(make-cmbn :degr degr (make-cmbn :degr degr
:list (let ((list1 +empty-list+) :list (let ((list1 +empty-list+)
(list2 +empty-list+)) (list2 +empty-list+))
(declare (list list1 list2)) (declare (list list1 list2))
(mapc (mapc
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (with-term
(cffc gnrt) term (cffc gnrt) term
(push (term cffc (push (term cffc
(tnpr 0 :s-bsgn (tnpr 0 :s-bsgn
degr gnrt)) degr gnrt))
list1) list1)
(push (term cffc (push (term cffc
(tnpr degr gnrt (tnpr degr gnrt
0 :s-bsgn)) 0 :s-bsgn))
list2))) list2)))
list) list)
(nreconc list1 (nreverse list2)))))))) (nreconc list1 (nreverse list2))))))))
(DEFMETHOD SUSPENSION-1 ((clgb coalgebra)) (DEFMETHOD SUSPENSION-1 ((clgb coalgebra))
(the coalgebra (the coalgebra
(let ((irslt (call-next-method))) (let ((irslt (call-next-method)))
(declare (type (or chain-complex coalgebra) irslt)) (declare (type (or chain-complex coalgebra) irslt))
(when (typep irslt 'coalgebra) (when (typep irslt 'coalgebra)
(return-from suspension-1 irslt)) (return-from suspension-1 irslt))
(change-chcm-to-clgb irslt :intr-cprd #'suspension-intr-cprd (change-chcm-to-clgb irslt :intr-cprd #'suspension-intr-cprd
:cprd-strt :cmbn) :cprd-strt :cmbn)
(setf (slot-value irslt 'orgn) `(suspension ,clgb)) (setf (slot-value irslt 'orgn) `(suspension ,clgb))
(setf (slot-value (slot-value irslt 'cprd) 'orgn) (setf (slot-value (slot-value irslt 'cprd) 'orgn)
`(coproduct ,irslt)) `(coproduct ,irslt))
irslt))) irslt)))
(DEFUN SUSPENSION-FACE (face) (DEFUN SUSPENSION-FACE (face)
(declare (type face face)) (declare (type face face))
(flet ((rslt (indx dmns gmsm) (flet ((rslt (indx dmns gmsm)
(declare (declare
(fixnum indx dmns) (fixnum indx dmns)
(type gmsm gmsm)) (type gmsm gmsm))
(assert (> dmns 1)) (assert (> dmns 1))
(if (= indx dmns) (if (= indx dmns)
(absm (mask (1- dmns)) :s-bsgn) (absm (mask (1- dmns)) :s-bsgn)
(let ((irslt (funcall face indx (1- dmns) gmsm))) (let ((irslt (funcall face indx (1- dmns) gmsm)))
(declare (type absm irslt)) (declare (type absm irslt))
(if (= (dgop irslt) (mask (- dmns 2))) (if (= (dgop irslt) (mask (- dmns 2)))
(absm (mask (1- dmns)) :s-bsgn) (absm (mask (1- dmns)) :s-bsgn)
irslt))))) irslt)))))
(the face #'rslt))) (the face #'rslt)))
(DEFMETHOD SUSPENSION-1 ((smst simplicial-set)) (DEFMETHOD SUSPENSION-1 ((smst simplicial-set))
(the simplicial-set (the simplicial-set
(let ((irslt (call-next-method))) (let ((irslt (call-next-method)))
(declare (type coalgebra irslt)) (declare (type coalgebra irslt))
(when (typep irslt 'simplicial-set) (when (typep irslt 'simplicial-set)
(return-from suspension-1 irslt)) (return-from suspension-1 irslt))
(change-class irslt 'simplicial-set) (change-class irslt 'simplicial-set)
(setf (slot-value irslt 'face) (setf (slot-value irslt 'face)
(suspension-face (face smst))) (suspension-face (face smst)))
(setf (slot-value (slot-value irslt 'cprd) 'orgn) (setf (slot-value (slot-value irslt 'cprd) 'orgn)
`(diagonal ,irslt)) `(diagonal ,irslt))
irslt))) irslt)))
(DEFUN SUSPENSION-INTR (mrph) (DEFUN SUSPENSION-INTR (mrph)
@ -153,64 +155,64 @@
(let ((mdegr (degr mrph))) (let ((mdegr (degr mrph)))
(declare (fixnum mdegr)) (declare (fixnum mdegr))
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(with-cmbn (with-cmbn
(cdegr list) cmbn (cdegr list) cmbn
(when (zerop cdegr) (when (zerop cdegr)
(return-from rslt (return-from rslt
(if (zerop mdegr) (if (zerop mdegr)
cmbn cmbn
(zero-cmbn (+ mdegr cdegr))))) (zero-cmbn (+ mdegr cdegr)))))
(make-cmbn :degr (+ mdegr cdegr) (make-cmbn :degr (+ mdegr cdegr)
:list (cmbn-list :list (cmbn-list
(cmbn-? mrph (make-cmbn :degr (1- cdegr) (cmbn-? mrph (make-cmbn :degr (1- cdegr)
:list list))))))) :list list)))))))
(the intr-mrph #'rslt)))) (the intr-mrph #'rslt))))
(DEFMETHOD SUSPENSION-1 ((mrph morphism)) (DEFMETHOD SUSPENSION-1 ((mrph morphism))
(the morphism (the morphism
(let ((orgn (orgn mrph))) (let ((orgn (orgn mrph)))
(declare (list orgn)) (declare (list orgn))
(when (eq (first orgn) 'zero-mrph) (when (eq (first orgn) 'zero-mrph)
(return-from suspension-1 (return-from suspension-1
(zero-mrph (suspension (sorc mrph)) (zero-mrph (suspension (sorc mrph))
(suspension (trgt mrph)) (suspension (trgt mrph))
(degr mrph)))) (degr mrph))))
(when (eq (first orgn) 'idnt-mrph) (when (eq (first orgn) 'idnt-mrph)
(return-from suspension-1 (return-from suspension-1
(idnt-mrph (suspension (sorc mrph))))) (idnt-mrph (suspension (sorc mrph)))))
(build-mrph (build-mrph
:sorc (suspension (sorc mrph)) :sorc (suspension (sorc mrph))
:trgt (suspension (trgt mrph)) :trgt (suspension (trgt mrph))
:degr (degr mrph) :degr (degr mrph)
:intr (suspension-intr mrph) :intr (suspension-intr mrph)
:strt :cmbn :strt :cmbn
:orgn `(suspension ,mrph))))) :orgn `(suspension ,mrph)))))
(DEFMETHOD SUSPENSION-1 ((rdct reduction)) (DEFMETHOD SUSPENSION-1 ((rdct reduction))
(the reduction (progn (the reduction (progn
(when (eq (first (orgn rdct)) 'trivial-rdct) (when (eq (first (orgn rdct)) 'trivial-rdct)
(return-from suspension-1 (return-from suspension-1
(trivial-rdct (suspension (second (orgn rdct)))))) (trivial-rdct (suspension (second (orgn rdct))))))
(build-rdct (build-rdct
:f (suspension (f rdct)) :f (suspension (f rdct))
:g (suspension (g rdct)) :g (suspension (g rdct))
:h (suspension (h rdct)) :h (suspension (h rdct))
:orgn `(suspension ,rdct))))) :orgn `(suspension ,rdct)))))
(DEFMETHOD SUSPENSION-1 ((hmeq homotopy-equivalence)) (DEFMETHOD SUSPENSION-1 ((hmeq homotopy-equivalence))
(the homotopy-equivalence (progn (the homotopy-equivalence (progn
(when (eq (first (orgn hmeq)) 'trivial-hmeq) (when (eq (first (orgn hmeq)) 'trivial-hmeq)
(return-from suspension-1 (return-from suspension-1
(trivial-hmeq (suspension (trivial-hmeq (suspension
(second (orgn hmeq)))))) (second (orgn hmeq))))))
(build-hmeq (build-hmeq
:lrdct (suspension (lrdct hmeq)) :lrdct (suspension (lrdct hmeq))
:rrdct (suspension (rrdct hmeq)) :rrdct (suspension (rrdct hmeq))
:orgn `(suspension ,hmeq))))) :orgn `(suspension ,hmeq)))))
(DEFMETHOD SEARCH-EFHM (suspension (orgn (eql 'suspension))) (DEFMETHOD SEARCH-EFHM (suspension (orgn (eql 'suspension)))

360
src/tensor-products.lisp
View File

@ -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 ;;; 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)) (ignore depth))
(the tnpr (the tnpr
(progn (progn
(with-tnpr (degr1 gnrt1 degr2 gnrt2) tnpr (with-tnpr (degr1 gnrt1 degr2 gnrt2) tnpr
(format stream (format stream
"<TnPr~:[~*~; ~D~] ~A~:[~*~; ~D~] ~A>" "<TnPr~:[~*~; ~D~] ~A~:[~*~; ~D~] ~A>"
*tnpr-with-degrees* degr1 gnrt1 *tnpr-with-degrees* degr1 gnrt1
*tnpr-with-degrees* degr2 gnrt2)) *tnpr-with-degrees* degr2 gnrt2))
tnpr))) tnpr)))
(DEFUN 2CMBN-TNPR (cmbn1 cmbn2) (DEFUN 2CMBN-TNPR (cmbn1 cmbn2)
(declare (type cmbn cmbn1 cmbn2)) (declare (type cmbn cmbn1 cmbn2))
(the cmbn (the cmbn
(with-cmbn (with-cmbn
(degr1 list1) cmbn1 (degr1 list1) cmbn1
(with-cmbn (with-cmbn
(degr2 list2) cmbn2 (degr2 list2) cmbn2
(make-cmbn (make-cmbn
:degr (+ degr1 degr2) :degr (+ degr1 degr2)
:list (mapcan :list (mapcan
#'(lambda (term1) #'(lambda (term1)
(declare (type term term1)) (declare (type term term1))
(the list (the list
(with-term (with-term
(cffc1 gnrt1) term1 (cffc1 gnrt1) term1
(mapcar (mapcar
#'(lambda (term2) #'(lambda (term2)
(declare (type term term2)) (declare (type term term2))
(the term (the term
(term (term
(* cffc1 (cffc term2)) (* cffc1 (cffc term2))
(tnpr degr1 gnrt1 degr2 (tnpr degr1 gnrt1 degr2
(gnrt term2))))) (gnrt term2)))))
list2)))) list2))))
list1)))))) list1))))))
#| #|
(DEFUN TNSR-PRDC-CMPR (cmpr1 cmpr2) (DEFUN TNSR-PRDC-CMPR (cmpr1 cmpr2)
(declare (type cmprf cmpr1 cmpr2)) (declare (type cmprf cmpr1 cmpr2))
(flet ((rslt (tnpr1 tnpr2) (flet ((rslt (tnpr1 tnpr2)
(declare (type tnpr tnpr1 tnpr2)) (declare (type tnpr tnpr1 tnpr2))
(let ((left-cons-1 (cadr tnpr1)) (let ((left-cons-1 (cadr tnpr1))
(left-cons-2 (cadr tnpr2))) (left-cons-2 (cadr tnpr2)))
(declare (cons left-cons-1 left-cons-2)) (declare (cons left-cons-1 left-cons-2))
(lexico (lexico
(f-cmpr (car left-cons-1) (car left-cons-2)) (f-cmpr (car left-cons-1) (car left-cons-2))
(funcall cmpr1 (cdr left-cons-1) (cdr left-cons-2)) (funcall cmpr1 (cdr left-cons-1) (cdr left-cons-2))
(funcall cmpr2 (gnrt2 tnpr1) (gnrt2 tnpr2)))))) (funcall cmpr2 (gnrt2 tnpr1) (gnrt2 tnpr2))))))
(the cmprf #'rslt))) (the cmprf #'rslt)))
|# |#
(DEFUN TNSR-PRDC-CMPR (cmpr1 cmpr2) (DEFUN TNSR-PRDC-CMPR (cmpr1 cmpr2)
@ -66,87 +68,87 @@
(flet ((rslt (tnpr1 tnpr2) (flet ((rslt (tnpr1 tnpr2)
(declare (type tnpr tnpr1 tnpr2)) (declare (type tnpr tnpr1 tnpr2))
(the cmpr (the cmpr
(lexico (lexico
(f-cmpr (degr1 tnpr1) (degr1 tnpr2)) (f-cmpr (degr1 tnpr1) (degr1 tnpr2))
(funcall cmpr1 (gnrt1 tnpr1) (gnrt1 tnpr2)) (funcall cmpr1 (gnrt1 tnpr1) (gnrt1 tnpr2))
(funcall cmpr2 (gnrt2 tnpr1) (gnrt2 tnpr2)))))) (funcall cmpr2 (gnrt2 tnpr1) (gnrt2 tnpr2))))))
(the cmprf #'rslt))) (the cmprf #'rslt)))
(DEFUN TNSR-PRDC-BASIS (basis1 basis2) (DEFUN TNSR-PRDC-BASIS (basis1 basis2)
(declare (type basis basis1 basis2)) (declare (type basis basis1 basis2))
(when (or (eq basis1 :locally-effective) (when (or (eq basis1 :locally-effective)
(eq basis2 :locally-effective)) (eq basis2 :locally-effective))
(return-from tnsr-prdc-basis :locally-effective)) (return-from tnsr-prdc-basis :locally-effective))
(flet ((rslt (degr) (flet ((rslt (degr)
(declare (fixnum degr)) (declare (fixnum degr))
(the list (the list
(progn (progn
(when (minusp degr) (when (minusp degr)
(return-from rslt +empty-list+)) (return-from rslt +empty-list+))
(mapcan (mapcan
#'(lambda (degr1) #'(lambda (degr1)
(declare (fixnum degr1)) (declare (fixnum degr1))
(let* ((basis1 (funcall basis1 degr1)) (let* ((basis1 (funcall basis1 degr1))
(degr2 (- degr degr1)) (degr2 (- degr degr1))
(basis2 (funcall basis2 degr2))) (basis2 (funcall basis2 degr2)))
(declare (declare
(fixnum degr2) (fixnum degr2)
(list basis1 basis2)) (list basis1 basis2))
(the list (the list
(mapcan (mapcan
#'(lambda (gnrt1) #'(lambda (gnrt1)
(declare (type gnrt gnrt1)) (declare (type gnrt gnrt1))
(the list (the list
(mapcar (mapcar
#'(lambda (gnrt2) #'(lambda (gnrt2)
(declare (type gnrt gnrt2)) (declare (type gnrt gnrt2))
(the tnpr (the tnpr
(tnpr degr1 gnrt1 degr2 (tnpr degr1 gnrt1 degr2
gnrt2))) gnrt2)))
basis2))) basis2)))
basis1)))) basis1))))
(<a-b> 0 degr)))))) (<a-b> 0 degr))))))
(the basis #'rslt))) (the basis #'rslt)))
(DEFUN TNSR-PRDC-INTR-DFFR (dffr1 dffr2) (DEFUN TNSR-PRDC-INTR-DFFR (dffr1 dffr2)
(declare (type morphism dffr1 dffr2)) (declare (type morphism dffr1 dffr2))
(flet ((rslt (degr tnpr) (flet ((rslt (degr tnpr)
(declare (declare
(fixnum degr) (fixnum degr)
(type tnpr tnpr)) (type tnpr tnpr))
(the cmbn (the cmbn
(with-tnpr (with-tnpr
(degr1 gnrt1 degr2 gnrt2) tnpr (degr1 gnrt1 degr2 gnrt2) tnpr
(let ((degr1-1 (1- degr1)) (let ((degr1-1 (1- degr1))
(degr2-1 (1- degr2)) (degr2-1 (1- degr2))
(sign (oddp degr1)) (sign (oddp degr1))
(list1 (cmbn-list (gnrt-? dffr1 degr1 gnrt1))) (list1 (cmbn-list (gnrt-? dffr1 degr1 gnrt1)))
(list2 (cmbn-list (gnrt-? dffr2 degr2 gnrt2)))) (list2 (cmbn-list (gnrt-? dffr2 degr2 gnrt2))))
(declare (declare
(fixnum degr1-1 degr2-1) (fixnum degr1-1 degr2-1)
(boolean sign) (boolean sign)
(list list1 list2)) (list list1 list2))
(make-cmbn (make-cmbn
:degr (1- degr) :degr (1- degr)
:list (nconc :list (nconc
(mapcar (mapcar
#'(lambda (term1) #'(lambda (term1)
(declare (type term term1)) (declare (type term term1))
(with-term (with-term
(cffc1 gnrt1) term1 (cffc1 gnrt1) term1
(term cffc1 (tnpr degr1-1 gnrt1 (term cffc1 (tnpr degr1-1 gnrt1
degr2 gnrt2)))) degr2 gnrt2))))
list1) list1)
(mapcar (mapcar
#'(lambda (term2) #'(lambda (term2)
(declare (type term term2)) (declare (type term term2))
(with-term (cffc2 gnrt2) term2 (with-term (cffc2 gnrt2) term2
(term (if sign (- cffc2) cffc2) (term (if sign (- cffc2) cffc2)
(tnpr degr1 gnrt1 (tnpr degr1 gnrt1
degr2-1 gnrt2)))) degr2-1 gnrt2))))
list2)))))))) list2))))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
@ -156,28 +158,28 @@
(the chain-complex (the chain-complex
(with-slots ((cmpr1 cmpr) (basis1 basis) (dffr1 dffr)) chcm1 (with-slots ((cmpr1 cmpr) (basis1 basis) (dffr1 dffr)) chcm1
(declare (declare
(type cmprf cmpr1) (type cmprf cmpr1)
(type basis basis1) (type basis basis1)
(type morphism dffr1)) (type morphism dffr1))
(with-slots ((cmpr2 cmpr) (basis2 basis) (dffr2 dffr)) chcm2 (with-slots ((cmpr2 cmpr) (basis2 basis) (dffr2 dffr)) chcm2
(declare (declare
(type cmprf cmpr2) (type cmprf cmpr2)
(type basis basis2) (type basis basis2)
(type morphism dffr2)) (type morphism dffr2))
(let ((rslt (let ((rslt
(build-chcm (build-chcm
:cmpr (tnsr-prdc-cmpr cmpr1 cmpr2) :cmpr (tnsr-prdc-cmpr cmpr1 cmpr2)
:basis (tnsr-prdc-basis basis1 basis2) :basis (tnsr-prdc-basis basis1 basis2)
:intr-dffr (tnsr-prdc-intr-dffr dffr1 dffr2) :intr-dffr (tnsr-prdc-intr-dffr dffr1 dffr2)
:strt :gnrt :strt :gnrt
:orgn `(tnsr-prdc ,chcm1 ,chcm2)))) :orgn `(tnsr-prdc ,chcm1 ,chcm2))))
(declare (type chain-complex rslt)) (declare (type chain-complex rslt))
(if (and (slot-boundp chcm1 'bsgn) (if (and (slot-boundp chcm1 'bsgn)
(slot-boundp chcm2 'bsgn)) (slot-boundp chcm2 'bsgn))
(setf (slot-value rslt 'bsgn) (setf (slot-value rslt 'bsgn)
(tnpr 0 (bsgn chcm1) 0 (bsgn chcm2))) (tnpr 0 (bsgn chcm1) 0 (bsgn chcm2)))
(slot-makunbound rslt 'bsgn)) (slot-makunbound rslt 'bsgn))
rslt))))) rslt)))))
(DEFUN TNSR-PRDC-INTR (mrph1 mrph2) (DEFUN TNSR-PRDC-INTR (mrph1 mrph2)
@ -186,84 +188,84 @@
(let ((mrph2-sign (oddp (degr mrph2)))) (let ((mrph2-sign (oddp (degr mrph2))))
(declare (type boolean mrph2-sign)) (declare (type boolean mrph2-sign))
(flet ((rslt (degr tnpr) (flet ((rslt (degr tnpr)
(declare (declare
(ignore degr) (ignore degr)
(type tnpr tnpr)) (type tnpr tnpr))
(with-tnpr (degr1 gnrt1 degr2 gnrt2) tnpr (with-tnpr (degr1 gnrt1 degr2 gnrt2) tnpr
(let ((rslt (2cmbn-tnpr (let ((rslt (2cmbn-tnpr
(gnrt-? mrph1 degr1 gnrt1) (gnrt-? mrph1 degr1 gnrt1)
(gnrt-? mrph2 degr2 gnrt2)))) (gnrt-? mrph2 degr2 gnrt2))))
(declare (type cmbn rslt)) (declare (type cmbn rslt))
(when (and mrph2-sign (when (and mrph2-sign
(oddp degr1)) (oddp degr1))
(mapc #'(lambda (term) (mapc #'(lambda (term)
(declare (type term term)) (declare (type term term))
(setf (the fixnum (cffc term)) (setf (the fixnum (cffc term))
(the fixnum (- (cffc term))))) (the fixnum (- (cffc term)))))
(cmbn-list rslt))) (cmbn-list rslt)))
rslt)))) rslt))))
(the intr-mrph #'rslt)))) (the intr-mrph #'rslt))))
(DEFMETHOD TNSR-PRDC ((mrph1 morphism) (mrph2 morphism)) (DEFMETHOD TNSR-PRDC ((mrph1 morphism) (mrph2 morphism))
(the morphism (the morphism
(with-slots ((sorc1 sorc) (trgt1 trgt) (degr1 degr)) mrph1 (with-slots ((sorc1 sorc) (trgt1 trgt) (degr1 degr)) mrph1
(with-slots ((sorc2 sorc) (trgt2 trgt) (degr2 degr)) mrph2 (with-slots ((sorc2 sorc) (trgt2 trgt) (degr2 degr)) mrph2
(the morphism (the morphism
(progn (progn
(when (and (eq 'idnt-mrph (first (orgn mrph1))) (when (and (eq 'idnt-mrph (first (orgn mrph1)))
(eq 'idnt-mrph (first (orgn mrph2)))) (eq 'idnt-mrph (first (orgn mrph2))))
(return-from tnsr-prdc (return-from tnsr-prdc
(idnt-mrph (tnsr-prdc sorc1 sorc2)))) (idnt-mrph (tnsr-prdc sorc1 sorc2))))
(when (or (eq 'zero-mrph (first (orgn mrph1))) (when (or (eq 'zero-mrph (first (orgn mrph1)))
(eq 'zero-mrph (first (orgn mrph2)))) (eq 'zero-mrph (first (orgn mrph2))))
(return-from tnsr-prdc (return-from tnsr-prdc
(zero-mrph (tnsr-prdc sorc1 sorc2) (zero-mrph (tnsr-prdc sorc1 sorc2)
(tnsr-prdc trgt1 trgt2) (tnsr-prdc trgt1 trgt2)
(+ degr1 degr2)))) (+ degr1 degr2))))
(build-mrph (build-mrph
:sorc (tnsr-prdc sorc1 sorc2) :sorc (tnsr-prdc sorc1 sorc2)
:trgt (tnsr-prdc trgt1 trgt2) :trgt (tnsr-prdc trgt1 trgt2)
:degr (+ degr1 degr2) :degr (+ degr1 degr2)
:intr (tnsr-prdc-intr mrph1 mrph2) :intr (tnsr-prdc-intr mrph1 mrph2)
:strt :gnrt :strt :gnrt
:orgn `(tnsr-prdc ,mrph1 ,mrph2)))))))) :orgn `(tnsr-prdc ,mrph1 ,mrph2))))))))
(DEFMETHOD TNSR-PRDC ((rdct1 reduction) (rdct2 reduction)) (DEFMETHOD TNSR-PRDC ((rdct1 reduction) (rdct2 reduction))
(the reduction (the reduction
(progn (progn
(when (and (eq 'trivial-rdct (first (orgn rdct1))) (when (and (eq 'trivial-rdct (first (orgn rdct1)))
(eq 'trivial-rdct (first (orgn rdct2)))) (eq 'trivial-rdct (first (orgn rdct2))))
(return-from tnsr-prdc (return-from tnsr-prdc
(trivial-rdct (tnsr-prdc (bcc rdct1) (bcc rdct2))))) (trivial-rdct (tnsr-prdc (bcc rdct1) (bcc rdct2)))))
(with-slots ((tcc1 tcc) (bcc1 bcc) (f1 f) (g1 g) (h1 h)) rdct1 (with-slots ((tcc1 tcc) (bcc1 bcc) (f1 f) (g1 g) (h1 h)) rdct1
(declare (declare
(type chain-complex tcc1 bcc1) (type chain-complex tcc1 bcc1)
(type morphism f1 g1 h1)) (type morphism f1 g1 h1))
(with-slots ((tcc2 tcc) (bcc2 bcc) (f2 f) (g2 g) (h2 h)) rdct2 (with-slots ((tcc2 tcc) (bcc2 bcc) (f2 f) (g2 g) (h2 h)) rdct2
(declare (declare
(type chain-complex tcc2 bcc2) (type chain-complex tcc2 bcc2)
(type morphism f2 g2 h2)) (type morphism f2 g2 h2))
(build-rdct (build-rdct
:f (tnsr-prdc f1 f2) :f (tnsr-prdc f1 f2)
:g (tnsr-prdc g1 g2) :g (tnsr-prdc g1 g2)
:h (add :h (add
(tnsr-prdc h1 (cmps g2 f2)) (tnsr-prdc h1 (cmps g2 f2))
(tnsr-prdc (idnt-mrph tcc1) h2)) (tnsr-prdc (idnt-mrph tcc1) h2))
:orgn `(tnsr-prdc ,rdct1 ,rdct2))))))) :orgn `(tnsr-prdc ,rdct1 ,rdct2)))))))
(DEFMETHOD TNSR-PRDC ((hmeq1 homotopy-equivalence) (DEFMETHOD TNSR-PRDC ((hmeq1 homotopy-equivalence)
(hmeq2 homotopy-equivalence)) (hmeq2 homotopy-equivalence))
(the homotopy-equivalence (the homotopy-equivalence
(build-hmeq (build-hmeq
:lrdct (tnsr-prdc (lrdct hmeq1) (lrdct hmeq2)) :lrdct (tnsr-prdc (lrdct hmeq1) (lrdct hmeq2))
:rrdct (tnsr-prdc (rrdct hmeq1) (rrdct hmeq2)) :rrdct (tnsr-prdc (rrdct hmeq1) (rrdct hmeq2))
:orgn `(tnsr-prdc ,hmeq1 ,hmeq2)))) :orgn `(tnsr-prdc ,hmeq1 ,hmeq2))))
(DEFMETHOD SEARCH-EFHM (chcm (orgn (eql 'tnsr-prdc))) (DEFMETHOD SEARCH-EFHM (chcm (orgn (eql 'tnsr-prdc)))
(declare (type chain-complex chcm)) (declare (type chain-complex chcm))
(the homotopy-equivalence (the homotopy-equivalence
(tnsr-prdc (efhm (second (orgn chcm))) (tnsr-prdc (efhm (second (orgn chcm)))
(efhm (third (orgn chcm)))))) (efhm (third (orgn chcm))))))

2
src/various.lisp
View File

@ -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
;;; VARIOUS VARIOUS VARIOUS VARIOUS VARIOUS VARIOUS ;;; VARIOUS VARIOUS VARIOUS VARIOUS VARIOUS VARIOUS

112
src/whitehead.lisp
View File

@ -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 ;;; 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 (DEFUN Z-WWHITEHEAD-SINTR (smst n chml-clss
&aux (face (face smst)) &aux (face (face smst))
(k-z-n (k-z n)) (k-z-n (k-z n))
(idnt (bspn k-z-n)) (idnt (bspn k-z-n))
(efhm (efhm smst))) (efhm (efhm smst)))
(declare (declare
(type simplicial-set smst) (type simplicial-set smst)
(fixnum n) (fixnum n)
@ -24,23 +26,23 @@
(type gmsm idnt) (type gmsm idnt)
(type homotopy-equivalence efhm)) (type homotopy-equivalence efhm))
(setf chml-clss (setf chml-clss
(i-cmps chml-clss (rf efhm) (lg efhm))) (i-cmps chml-clss (rf efhm) (lg efhm)))
(flet ((rslt (dmns gmsm) (flet ((rslt (dmns gmsm)
(declare (declare
(fixnum dmns) (fixnum dmns)
(type gmsm gmsm)) (type gmsm gmsm))
(if (< dmns n) (if (< dmns n)
(absm (mask dmns) idnt) (absm (mask dmns) idnt)
(z-cocycle-gbar n dmns (z-cocycle-gbar n dmns
(gmsm-cocycle face n dmns gmsm chml-clss))))) (gmsm-cocycle face n dmns gmsm chml-clss)))))
(the sintr #'rslt))) (the sintr #'rslt)))
(DEFUN Z-WHITEHEAD-SINTR (smst n chml-clss (DEFUN Z-WHITEHEAD-SINTR (smst n chml-clss
&aux (face (face smst)) &aux (face (face smst))
(k-z-n-1 (k-z (1- n))) (k-z-n-1 (k-z (1- n)))
(idnt (bspn k-z-n-1)) (idnt (bspn k-z-n-1))
(efhm (efhm smst))) (efhm (efhm smst)))
(declare (declare
(type simplicial-set smst) (type simplicial-set smst)
(fixnum n) (fixnum n)
@ -50,15 +52,15 @@
(type gmsm idnt) (type gmsm idnt)
(type homotopy-equivalence efhm)) (type homotopy-equivalence efhm))
(setf chml-clss (setf chml-clss
(i-cmps chml-clss (rf efhm) (lg efhm))) (i-cmps chml-clss (rf efhm) (lg efhm)))
(flet ((rslt (dmns gmsm) (flet ((rslt (dmns gmsm)
(declare (declare
(fixnum dmns) (fixnum dmns)
(type gmsm gmsm)) (type gmsm gmsm))
(if (< dmns n) (if (< dmns n)
(absm (mask (1- dmns)) idnt) (absm (mask (1- dmns)) idnt)
(z-cocycle-gbar-head n dmns (z-cocycle-gbar-head n dmns
(gmsm-cocycle face n dmns gmsm chml-clss))))) (gmsm-cocycle face n dmns gmsm chml-clss)))))
(the sintr #'rslt))) (the sintr #'rslt)))
@ -69,19 +71,19 @@
(type morphism chml-clss)) (type morphism chml-clss))
(the fibration (the fibration
(build-smmr (build-smmr
:sorc smst :trgt (k-z (1- n)) :degr -1 :sorc smst :trgt (k-z (1- n)) :degr -1
:sintr (z-whitehead-sintr smst n chml-clss) :sintr (z-whitehead-sintr smst n chml-clss)
:orgn `(z-whitehead ,smst)))) :orgn `(z-whitehead ,smst))))
;;; ;;;
;;; Z/2Z ;;; Z/2Z
;;; ;;;
(DEFUN Z2-WWHITEHEAD-SINTR (smst n chml-clss (DEFUN Z2-WWHITEHEAD-SINTR (smst n chml-clss
&aux (face (face smst)) &aux (face (face smst))
(k-z2-n (k-z2 n)) (k-z2-n (k-z2 n))
(idnt (bspn k-z2-n)) (idnt (bspn k-z2-n))
(efhm (efhm smst))) (efhm (efhm smst)))
(declare (declare
(type simplicial-set smst) (type simplicial-set smst)
(fixnum n) (fixnum n)
@ -91,23 +93,23 @@
(type gmsm idnt) (type gmsm idnt)
(type homotopy-equivalence efhm)) (type homotopy-equivalence efhm))
(setf chml-clss (setf chml-clss
(i-cmps chml-clss (rf efhm) (lg efhm))) (i-cmps chml-clss (rf efhm) (lg efhm)))
(flet ((rslt (dmns gmsm) (flet ((rslt (dmns gmsm)
(declare (declare
(fixnum dmns) (fixnum dmns)
(type gmsm gmsm)) (type gmsm gmsm))
(if (< dmns n) (if (< dmns n)
(absm (mask dmns) idnt) (absm (mask dmns) idnt)
(z2-cocycle-gbar n dmns (z2-cocycle-gbar n dmns
(gmsm-cocycle face n dmns gmsm chml-clss))))) (gmsm-cocycle face n dmns gmsm chml-clss)))))
(the sintr #'rslt))) (the sintr #'rslt)))
(DEFUN Z2-WHITEHEAD-SINTR (smst n chml-clss (DEFUN Z2-WHITEHEAD-SINTR (smst n chml-clss
&aux (face (face smst)) &aux (face (face smst))
(k-z2-n-1 (k-z2 (1- n))) (k-z2-n-1 (k-z2 (1- n)))
(idnt (bspn k-z2-n-1)) (idnt (bspn k-z2-n-1))
(efhm (efhm smst))) (efhm (efhm smst)))
(declare (declare
(type simplicial-set smst) (type simplicial-set smst)
(fixnum n) (fixnum n)
@ -117,16 +119,16 @@
(type gmsm idnt) (type gmsm idnt)
(type homotopy-equivalence efhm)) (type homotopy-equivalence efhm))
(setf chml-clss (setf chml-clss
(i-cmps chml-clss (rf efhm) (lg efhm))) (i-cmps chml-clss (rf efhm) (lg efhm)))
(flet ((rslt (dmns gmsm) (flet ((rslt (dmns gmsm)
(declare (declare
(fixnum dmns) (fixnum dmns)
(type gmsm gmsm)) (type gmsm gmsm))
(if (< dmns n) (if (< dmns n)
(absm (mask (1- dmns)) idnt) (absm (mask (1- dmns)) idnt)
(z2-cocycle-gbar-head n dmns (z2-cocycle-gbar-head n dmns
(gmsm-cocycle face n dmns gmsm (gmsm-cocycle face n dmns gmsm
chml-clss))))) chml-clss)))))
(the sintr #'rslt))) (the sintr #'rslt)))
@ -137,6 +139,6 @@
(type morphism chml-clss)) (type morphism chml-clss))
(the fibration (the fibration
(build-smmr (build-smmr
:sorc smst :trgt (k-z2 (1- n)) :degr -1 :sorc smst :trgt (k-z2 (1- n)) :degr -1
:sintr (Z2-whitehead-sintr smst n chml-clss) :sintr (Z2-whitehead-sintr smst n chml-clss)
:orgn `(Z2-whitehead ,smst)))) :orgn `(Z2-whitehead ,smst))))

4
test/Test.lisp
View File

@ -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 ;;; 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
@ -33,7 +35,7 @@
(setf f5 (z-whitehead x5 ch5)) (setf f5 (z-whitehead x5 ch5))
(setf x6 (fibration-total f5)) (setf x6 (fibration-total f5))
)) ))
(time (homology o2s3 7)) (time (homology o2s3 7))
(time (homology x6 6)) (time (homology x6 6))

2
test/bar-test.lisp
View File

@ -1,4 +1,4 @@
;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)

165
test/bicones-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -5,114 +6,114 @@
(test bicn-cmbn (test bicn-cmbn
(let* ((comb-bic (cat:cmbn 3 2 (cat:bcnb 'b1) 4 (cat:bcnb 'b2) (let* ((comb-bic (cat:cmbn 3 2 (cat:bcnb 'b1) 4 (cat:bcnb 'b2)
6 (cat:bcnb 'b3) 3 (cat:bcnc 'c1) 6 (cat:bcnb 'b3) 3 (cat:bcnc 'c1)
5 (cat:bcnc 'c2) 7 (cat:bcnd 'd1)))) 5 (cat:bcnc 'c2) 7 (cat:bcnd 'd1))))
(cat:cmbn-list comb-bic) (cat:cmbn-list comb-bic)
(cat:dispatch-bicn-cmbn (cat:cmbn 3 3 (cat:bcnb 'b1) (cat:dispatch-bicn-cmbn (cat:cmbn 3 3 (cat:bcnb 'b1)
4 (cat:bcnb 'b2) 4 (cat:bcnb 'b2)
33 (cat:bcnc 'c) 33 (cat:bcnc 'c)
333 (cat:bcnd 'd))))) 333 (cat:bcnd 'd)))))
(test bicn-cmbn-cmbn* (test bicn-cmbn-cmbn*
(is (cat:cmbn-non-zero-p (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 (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 (is (cat:cmbn-non-zero-p
(cat:bicn-cmbn-cmbnc (cat:cmbn 3 1 (cat:bcnb 'a) 2 (cat:bcnc 'b) (cat:bicn-cmbn-cmbnc (cat:cmbn 3 1 (cat:bcnb 'a) 2 (cat:bcnc 'b)
3 (cat:bcnd 'c))))) 3 (cat:bcnd 'c)))))
(is (cat:cmbn-zero-p (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 (is (cat:cmbn-non-zero-p
(cat:bicn-cmbn-cmbnd (cat:cmbn 3 1 (cat:bcnb 'a) 2 (cat:bcnc 'b) (cat:bicn-cmbn-cmbnd (cat:cmbn 3 1 (cat:bcnb 'a) 2 (cat:bcnc 'b)
3 (cat:bcnd 'c))))) 3 (cat:bcnd 'c)))))
(is (cat:cmbn-zero-p (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 (test make-bicn-cmbn
(multiple-value-call #'cat:make-bicn-cmbn (multiple-value-call #'cat:make-bicn-cmbn
(cat:dispatch-bicn-cmbn (cat:dispatch-bicn-cmbn
(cat:cmbn 3 3 (cat:bcnb 'b1) 4 (cat:bcnb 'b2) 33 (cat:bcnc 'c) (cat:cmbn 3 3 (cat:bcnb 'b1) 4 (cat:bcnb 'b2) 33 (cat:bcnc 'c)
333 (cat:bcnd 'd))))) 333 (cat:bcnd 'd)))))
(test bicn-print (test bicn-print
(let ((a (format nil "~A" (cat:bcnb 'a))) (let ((a (format nil "~A" (cat:bcnb 'a)))
(b (format nil "~A" (cat:bcnc 'b))) (b (format nil "~A" (cat:bcnc 'b)))
(c (format nil "~A" (cat:bcnd 'c)))) (c (format nil "~A" (cat:bcnd 'c))))
(is (string= a "<BcnB A>")) (is (string= a "<BcnB A>"))
(is (string= b "<BcnC B>")) (is (string= b "<BcnC B>"))
(is (string= c "<BcnD C>")))) (is (string= c "<BcnD C>"))))
(test bicone-cmpr (test bicone-cmpr
(let ((r (cat:bicone-cmpr #'cat:f-cmpr #'cat:f-cmpr #'cat:f-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:bcnc 0))))
(is (equal :less (funcall r (cat:bcnb 1) (cat:bcnb 2)))))) (is (equal :less (funcall r (cat:bcnb 1) (cat:bcnb 2))))))
(test bicone-basis (test bicone-basis
(is (equal :locally-effective (is (equal :locally-effective
(cat:bicone-basis :locally-effective (cat:bicone-basis :locally-effective
:locally-effective :locally-effective
:locally-effective))) :locally-effective)))
(let* ((b #'(lambda (degr) (let* ((b #'(lambda (degr)
(mapcar #'(lambda (item) (mapcar #'(lambda (item)
(cons degr item)) (cat:<a-b> 0 degr)))) (cons degr item)) (cat:<a-b> 0 degr))))
(r (cat:bicone-basis b b b))) (r (cat:bicone-basis b b b)))
(is (not (null (funcall r 3)))))) (is (not (null (funcall r 3))))))
(test bicone (test bicone
(progn (progn
(cat:cat-init) (cat:cat-init)
(let ((delta3 (cdelta1 3)) (let ((delta3 (cdelta1 3))
(bic (cat:bicone (make-rdct1 3 2) (make-rdct1 4 2)))) (bic (cat:bicone (make-rdct1 3 2) (make-rdct1 4 2))))
#| #|
(princ (cat:basis delta3 0)) (princ (cat:basis delta3 0))
(princ (cat:basis delta3 1)) (princ (cat:basis delta3 1))
(princ (cat:basis delta3 2)) (princ (cat:basis delta3 2))
(princ (cat:basis delta3 3)) (princ (cat:basis delta3 3))
(princ (cat:basis delta3 4)) (princ (cat:basis delta3 4))
|# |#
(princ (cat:basis bic 0)) (princ (cat:basis bic 0))
(princ (cat:basis bic 1)) (princ (cat:basis bic 1))
(princ (cat:basis bic 4)) (princ (cat:basis bic 4))
(princ (cat:? bic (cat:cmbn 2 3 (cat:bcnb '(0 1 3)) (princ (cat:? bic (cat:cmbn 2 3 (cat:bcnb '(0 1 3))
4 (cat:bcnc '(0 1 2 3)) 4 (cat:bcnc '(0 1 2 3))
5 (cat:bcnd '(0 1 4))))) 5 (cat:bcnd '(0 1 4)))))
(is (cat:cmbn-zero-p (is (cat:cmbn-zero-p
(cat:? bic (cat:? bic
(cat:? bic (cat:cmbn 2 3 (cat:bcnb '(0 1 3)) (cat:? bic (cat:cmbn 2 3 (cat:bcnb '(0 1 3))
4 (cat:bcnc '(0 1 2 3)) 4 (cat:bcnc '(0 1 2 3))
5 (cat:bcnd '(0 1 4)))))))))) 5 (cat:bcnd '(0 1 4))))))))))
(test cmps (test cmps
(progn (progn
(cat:cat-init) (cat:cat-init)
(let* ((c (cat:build-chcm (let* ((c (cat:build-chcm
:cmpr #'cat:s-cmpr :cmpr #'cat:s-cmpr
:basis #'(lambda (dmns) '(a)) :basis #'(lambda (dmns) '(a))
:bsgn 'a :bsgn 'a
:intr-dffr #'cat:zero-intr-dffr :intr-dffr #'cat:zero-intr-dffr
:strt :cmbn :strt :cmbn
:orgn '(c))) :orgn '(c)))
(h1 (cat:trivial-hmeq c)) (h1 (cat:trivial-hmeq c))
(h2 (cat:cmps h1 h1)) (h2 (cat:cmps h1 h1))
(h3 (cat:cmps h2 h2))) (h3 (cat:cmps h2 h2)))
(cat:pre-check-rdct (cat:lrdct h2)) (cat:pre-check-rdct (cat:lrdct h2))
(setf cat:*tc* (cat:cmbn 3 1 (cat:bcnB 'a) 10 (cat:bcnC 'a) (setf cat:*tc* (cat:cmbn 3 1 (cat:bcnB 'a) 10 (cat:bcnC 'a)
100 (cat:bcnD 'a))) 100 (cat:bcnD 'a)))
(setf cat:*bc* (cat:cmbn 3 1 'a)) (setf cat:*bc* (cat:cmbn 3 1 'a))
(check-rdct) (check-rdct)
(cat:pre-check-rdct (cat:rrdct h2)) (cat:pre-check-rdct (cat:rrdct h2))
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn 3 1 (cat:bcnB (cat:bcnB 'a)) (setf cat:*tc* (cat:cmbn 3 1 (cat:bcnB (cat:bcnB 'a))
10 (cat:bcnB (cat:bcnC 'a)) 10 (cat:bcnB (cat:bcnC 'a))
100 (cat:bcnB (cat:bcnD 'a)) 100 (cat:bcnB (cat:bcnD 'a))
1000 (cat:bcnC 'a) 1000 (cat:bcnC 'a)
10000 (cat:bcnD (cat:bcnB 'a)) 10000 (cat:bcnD (cat:bcnB 'a))
5234 (cat:bcnD (cat:bcnC 'a)) 5234 (cat:bcnD (cat:bcnC 'a))
223 (cat:bcnD (cat:bcnD 'a)))) 223 (cat:bcnD (cat:bcnD 'a))))
(cat:pre-check-rdct (cat:lrdct h3)) (cat:pre-check-rdct (cat:lrdct h3))
(check-rdct) (check-rdct)
(cat:pre-check-rdct (cat:rrdct h3)) (cat:pre-check-rdct (cat:rrdct h3))
(check-rdct)))) (check-rdct))))

157
test/cartesian-products-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -5,12 +6,12 @@
(test extract-common-dgop (test extract-common-dgop
(dotimes (i 100) (dotimes (i 100)
(dotimes (j 100) (dotimes (j 100)
(multiple-value-bind (dgop dgop1 dgop2) (cat:extract-common-dgop i j) (multiple-value-bind (dgop dgop1 dgop2) (cat:extract-common-dgop i j)
(unless (and (= i (cat:dgop*dgop dgop dgop1)) (unless (and (= i (cat:dgop*dgop dgop dgop1))
(= j (cat:dgop*dgop dgop dgop2))) (= j (cat:dgop*dgop dgop dgop2)))
(error "i = ~D, j = ~D, dgop = ~D, dgop1 = ~D, dgop2 = ~D" (error "i = ~D, j = ~D, dgop = ~D, dgop1 = ~D, dgop2 = ~D"
i j dgop dgop1 dgop2)))))) i j dgop dgop1 dgop2))))))
(test 2absm-acrpr (test 2absm-acrpr
@ -19,96 +20,96 @@
(test crts-prdc-cmpr (test crts-prdc-cmpr
(let* ((c (cat:cmpr (cat:delta-infinity))) (let* ((c (cat:cmpr (cat:delta-infinity)))
(rslt (cat:crts-prdc-cmpr c c))) (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 :less (funcall rslt (cat:crpr 0 3 0 3) (cat:crpr 1 1 0 3))))
(is (equal :greater (is (equal :greater
(funcall rslt (cat:crpr 4 3 0 7) (cat:crpr 3 1 0 7)))) (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 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 5 0 3))))
(is (equal :less (funcall rslt (cat:crpr 0 3 0 3) (cat:crpr 0 3 0 5)))) (is (equal :less (funcall rslt (cat:crpr 0 3 0 3) (cat:crpr 0 3 0 5))))
(is (equal :equal (is (equal :equal
(funcall rslt (cat:crpr 0 3 0 3) (cat:crpr 0 3 0 3)))))) (funcall rslt (cat:crpr 0 3 0 3) (cat:crpr 0 3 0 3))))))
(test crts-prdc-basis (test crts-prdc-basis
(let* ((b (cat:basis (cat:delta 1))) (let* ((b (cat:basis (cat:delta 1)))
(r (cat:crts-prdc-basis b b)) (r (cat:crts-prdc-basis b b))
(d3 (cat:basis (cat:delta 3)))) (d3 (cat:basis (cat:delta 3))))
(funcall r 0) (funcall r 0)
(funcall r 1) (funcall r 1)
(funcall r 2) (funcall r 2)
(funcall r 3) (funcall r 3)
(setf r (cat:crts-prdc-basis d3 d3)) (setf r (cat:crts-prdc-basis d3 d3))
(time (dotimes (i 7) (time (dotimes (i 7)
(print (length (funcall r i))))) (print (length (funcall r i)))))
(setf s3 (cat:basis (cat:sphere 3))) (setf s3 (cat:basis (cat:sphere 3)))
(setf p (cat:crts-prdc-basis s3 s3)) (setf p (cat:crts-prdc-basis s3 s3))
(dotimes (i 8) (dotimes (i 8)
(print (funcall p i))))) (print (funcall p i)))))
(test crts-prdc-face (test crts-prdc-face
(let* ((d2 (cat:delta 2)) (let* ((d2 (cat:delta 2))
(b2 (cat:basis d2)) (b2 (cat:basis d2))
(f2 (cat:face d2)) (f2 (cat:face d2))
(b (cat:crts-prdc-basis b2 b2)) (b (cat:crts-prdc-basis b2 b2))
(r (cat:crts-prdc-face f2 f2))) (r (cat:crts-prdc-face f2 f2)))
(dotimes (i 5) (dotimes (i 5)
(unless (zerop i) (unless (zerop i)
(dolist (item (funcall b i)) (dolist (item (funcall b i))
(dotimes (j (1+ i)) (dotimes (j (1+ i))
(format t "~%del-~D ~A = ~A" (format t "~%del-~D ~A = ~A"
j item (funcall r j i item)))))))) j item (funcall r j i item))))))))
(test crts-prdc-face* (test crts-prdc-face*
(let* ((d2 (cat:delta 2)) (let* ((d2 (cat:delta 2))
(b2 (cat:basis d2)) (b2 (cat:basis d2))
(f2 (cat:face d2)) (f2 (cat:face d2))
(b (cat:crts-prdc-basis b2 b2)) (b (cat:crts-prdc-basis b2 b2))
(r (cat:crts-prdc-face* f2 f2))) (r (cat:crts-prdc-face* f2 f2)))
(dotimes (i 5) (dotimes (i 5)
(unless (zerop i) (unless (zerop i)
(dolist (item (coerce (funcall b i) 'list)) (dolist (item (coerce (funcall b i) 'list))
(dotimes (j (1+ i)) (dotimes (j (1+ i))
(format t "~%del-~D ~A = ~A" (format t "~%del-~D ~A = ~A"
j item (funcall r j i item))))))) j item (funcall r j i item)))))))
(let* ((s3 (cat:sphere 3)) (let* ((s3 (cat:sphere 3))
(b3 (cat:basis s3)) (b3 (cat:basis s3))
(f3 (cat:face s3)) (f3 (cat:face s3))
(b (cat:crts-prdc-basis b3 b3)) (b (cat:crts-prdc-basis b3 b3))
(r (cat:crts-prdc-face* f3 f3))) (r (cat:crts-prdc-face* f3 f3)))
(dotimes (i 7) (dotimes (i 7)
(unless (zerop i) (unless (zerop i)
(dolist (item (coerce (funcall b i) 'list)) (dolist (item (coerce (funcall b i) 'list))
(dotimes (j (1+ i)) (dotimes (j (1+ i))
(format t "~%del-~D ~A = ~A" (format t "~%del-~D ~A = ~A"
j item (funcall r j i item)))))))) j item (funcall r j i item))))))))
(test crts-prdc (test crts-prdc
(let ((p (cat:crts-prdc (cat:delta 3) (cat:delta 3)))) (let ((p (cat:crts-prdc (cat:delta 3) (cat:delta 3))))
(cat:? p 0 (cat:crpr 0 1 0 2)) (cat:? p 0 (cat:crpr 0 1 0 2))
(cat:? p 1 (cat:crpr 0 3 0 3)) (cat:? p 1 (cat:crpr 0 3 0 3))
(cat:? p 2 (cat:crpr 0 7 0 7)) (cat:? p 2 (cat:crpr 0 7 0 7))
(cat:? p 3 (cat:crpr 0 15 0 15)) (cat:? p 3 (cat:crpr 0 15 0 15))
(cat:? p 4 (cat:crpr 1 15 2 15)))) (cat:? p 4 (cat:crpr 1 15 2 15))))
(test eat (test eat
(let* ((s5 (cat:sphere 5)) (let* ((s5 (cat:sphere 5))
(p (cat:crts-prdc s5 s5)) (p (cat:crts-prdc s5 s5))
(b (cat:basis p)) (b (cat:basis p))
(d (cat:bndr p)) (d (cat:bndr p))
(basis (funcall b 10)) (basis (funcall b 10))
(c (cat:make-cmbn :degr 10 (c (cat:make-cmbn :degr 10
:list (mapcar #'(lambda (item) :list (mapcar #'(lambda (item)
(cat:term (1+ (random 5)) (cat:term (1+ (random 5))
item)) item))
basis)))) basis))))
(length basis) (length basis)
(setf cat:+too-much-time+ -1) (setf cat:+too-much-time+ -1)
(cat:cmbn-? d (cat:cmbn-? d c)) (cat:cmbn-? d (cat:cmbn-? d c))
(time (time
(dotimes (i 5) (dotimes (i 5)
(cat:cmbn-? d (cat:cmbn-? d c)))))) (cat:cmbn-? d (cat:cmbn-? d c))))))

161
test/ccn.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -6,87 +7,87 @@
(defun ccn () (defun ccn ()
(the cat:chain-complex (the cat:chain-complex
(cat:build-chcm (cat:build-chcm
:cmpr #'cat:f-cmpr :cmpr #'cat:f-cmpr
:basis #'(lambda (n) :basis #'(lambda (n)
(cat:<a-b< (* 10 n) (* 10 (1+ n)))) (cat:<a-b< (* 10 n) (* 10 (1+ n))))
:bsgn 0 :bsgn 0
:intr-dffr #'(lambda (dgr gnr) :intr-dffr #'(lambda (dgr gnr)
(if (evenp (+ dgr gnr)) (if (evenp (+ dgr gnr))
(cat:cmbn (1- dgr) 1 (- gnr 10)) (cat:cmbn (1- dgr) 1 (- gnr 10))
(cat:cmbn (1- dgr)))) (cat:cmbn (1- dgr))))
:strt :gnrt :strt :gnrt
:orgn '(ccn)))) :orgn '(ccn))))
(test ccn (test ccn
(progn (progn
(cat:cat-init) (cat:cat-init)
(let* ((ccn (ccn)) (let* ((ccn (ccn))
(upper-shift (cat:build-mrph (upper-shift (cat:build-mrph
:sorc ccn :trgt ccn :strt :gnrt :degr 1 :sorc ccn :trgt ccn :strt :gnrt :degr 1
:intr #'(lambda (d gn) (cat:cmbn (1+ d) :intr #'(lambda (d gn) (cat:cmbn (1+ d)
1 (+ gn 10))) 1 (+ gn 10)))
:orgn '(ccn shift +10))) :orgn '(ccn shift +10)))
(lower-shift (cat:build-mrph (lower-shift (cat:build-mrph
:sorc ccn :trgt ccn :strt :gnrt :degr -1 :sorc ccn :trgt ccn :strt :gnrt :degr -1
:intr #'(lambda (d gn) (cat:cmbn (1- d) :intr #'(lambda (d gn) (cat:cmbn (1- d)
1 (- gn 10))) 1 (- gn 10)))
:orgn '(ccn shift -10))) :orgn '(ccn shift -10)))
(comb1 (cat:? ccn 2 22)) (comb1 (cat:? ccn 2 22))
(combn (cat:cmbn 5 1 50 5 55 9 59)) (combn (cat:cmbn 5 1 50 5 55 9 59))
(d-combn (cat:? ccn combn)) (d-combn (cat:? ccn combn))
(dd-combn (cat:? ccn d-combn)) (dd-combn (cat:? ccn d-combn))
(comb2 (cat:? upper-shift 0 6)) (comb2 (cat:? upper-shift 0 6))
(comb3 (cat:? lower-shift 5 51)) (comb3 (cat:? lower-shift 5 51))
(comb4 (cat:? lower-shift comb3)) (comb4 (cat:? lower-shift comb3))
(identity? (cat:cmps upper-shift lower-shift)) (identity? (cat:cmps upper-shift lower-shift))
(comb5 (cat:cmbn 1 1 10 2 11 3 12 4 13)) (comb5 (cat:cmbn 1 1 10 2 11 3 12 4 13))
(comb6 (cat:? identity? comb5)) (comb6 (cat:? identity? comb5))
(comb7 (cat:2cmbn-sbtr (cat:cmpr ccn) comb5 comb6)) (comb7 (cat:2cmbn-sbtr (cat:cmpr ccn) comb5 comb6))
(upper2-shift (cat:cmps upper-shift upper-shift)) (upper2-shift (cat:cmps upper-shift upper-shift))
(comb8 (cat:? upper2-shift comb5)) (comb8 (cat:? upper2-shift comb5))
(twice-up-shift (cat:add upper-shift upper-shift)) (twice-up-shift (cat:add upper-shift upper-shift))
(comb9 (cat:? twice-up-shift comb5)) (comb9 (cat:? twice-up-shift comb5))
(up-d (cat:cmps upper-shift (cat:dffr1 ccn))) (up-d (cat:cmps upper-shift (cat:dffr1 ccn)))
(d-up (cat:cmps (cat:dffr1 ccn) upper-shift)) (d-up (cat:cmps (cat:dffr1 ccn) upper-shift))
(comb10 (cat:? up-d 1 11)) (comb10 (cat:? up-d 1 11))
(comb11 (cat:? d-up 1 11)) (comb11 (cat:? d-up 1 11))
(comb12 (cat:cmbn 1 1 10 2 11 3 12 4 13 5 14 6 15)) (comb12 (cat:cmbn 1 1 10 2 11 3 12 4 13 5 14 6 15))
(comb13 (cat:? up-d comb12)) (comb13 (cat:? up-d comb12))
(comb14 (cat:? d-up comb12)) (comb14 (cat:? d-up comb12))
) )
(is (equal (cat:cmbn-degr comb1) 1)) (is (equal (cat:cmbn-degr comb1) 1))
(is (equal (cat:cmbn-list comb1) '((1 . 12)))) (is (equal (cat:cmbn-list comb1) '((1 . 12))))
(is (null (cat:cmbn-non-zero-p (cat:? ccn comb1)))) (is (null (cat:cmbn-non-zero-p (cat:? ccn comb1))))
(is (equal (cat:cmbn-degr d-combn) 4)) (is (equal (cat:cmbn-degr d-combn) 4))
(is (equal (cat:cmbn-list d-combn) '((5 . 45) (9 . 49)))) (is (equal (cat:cmbn-list d-combn) '((5 . 45) (9 . 49))))
(is (equal (cat:cmbn-degr dd-combn) 3)) (is (equal (cat:cmbn-degr dd-combn) 3))
(is (equal (cat:cmbn-list dd-combn) nil)) (is (equal (cat:cmbn-list dd-combn) nil))
(is (equal (cat:cmbn-degr comb2) 1)) (is (equal (cat:cmbn-degr comb2) 1))
(is (equal (cat:cmbn-list comb2) '((1 . 16)))) (is (equal (cat:cmbn-list comb2) '((1 . 16))))
(is (equal (cat:cmbn-degr comb3) 4)) (is (equal (cat:cmbn-degr comb3) 4))
(is (equal (cat:cmbn-list comb3) '((1 . 41)))) (is (equal (cat:cmbn-list comb3) '((1 . 41))))
(is (equal (cat:cmbn-degr comb4) 3)) (is (equal (cat:cmbn-degr comb4) 3))
(is (equal (cat:cmbn-list comb4) '((1 . 31)))) (is (equal (cat:cmbn-list comb4) '((1 . 31))))
(is (equal (cat:degr identity?) 0)) (is (equal (cat:degr identity?) 0))
(is (equal (cat:cmbn-degr comb6) 1)) (is (equal (cat:cmbn-degr comb6) 1))
(is (equal (cat:cmbn-list comb6) '((1 . 10) (2 . 11) (3 . 12) (is (equal (cat:cmbn-list comb6) '((1 . 10) (2 . 11) (3 . 12)
(4 . 13)))) (4 . 13))))
(is (equal (cat:cmbn-degr comb7) 1)) (is (equal (cat:cmbn-degr comb7) 1))
(is (equal (cat:cmbn-list comb7) nil)) (is (equal (cat:cmbn-list comb7) nil))
(is (equal (cat:degr upper2-shift) 2)) (is (equal (cat:degr upper2-shift) 2))
(is (equal (cat:cmbn-degr comb8) 3)) (is (equal (cat:cmbn-degr comb8) 3))
(is (equal (cat:cmbn-list comb8) '((1 . 30) (2 . 31) (3 . 32) (is (equal (cat:cmbn-list comb8) '((1 . 30) (2 . 31) (3 . 32)
(4 . 33)))) (4 . 33))))
(is (equal (cat:degr twice-up-shift) 1)) (is (equal (cat:degr twice-up-shift) 1))
(is (equal (cat:cmbn-degr comb9) 2)) (is (equal (cat:cmbn-degr comb9) 2))
(is (equal (cat:cmbn-list comb9) '((2 . 20) (4 . 21) (6 . 22) (is (equal (cat:cmbn-list comb9) '((2 . 20) (4 . 21) (6 . 22)
(8 . 23)))) (8 . 23))))
(is (equal (cat:cmbn-degr comb10) 1)) (is (equal (cat:cmbn-degr comb10) 1))
(is (equal (cat:cmbn-list comb10) '((1 . 11)))) (is (equal (cat:cmbn-list comb10) '((1 . 11))))
(is (equal (cat:cmbn-degr comb11) 1)) (is (equal (cat:cmbn-degr comb11) 1))
(is (equal (cat:cmbn-list comb11) nil)) (is (equal (cat:cmbn-list comb11) nil))
(is (equal (cat:cmbn-degr comb13) 1)) (is (equal (cat:cmbn-degr comb13) 1))
(is (equal (cat:cmbn-list comb13) '((2 . 11) (4 . 13) (6 . 15)))) (is (equal (cat:cmbn-list comb13) '((2 . 11) (4 . 13) (6 . 15))))
(is (equal (cat:cmbn-degr comb14) 1)) (is (equal (cat:cmbn-degr comb14) 1))
(is (equal (cat:cmbn-list comb14) '((1 . 10) (3 . 12) (5 . 14))))))) (is (equal (cat:cmbn-list comb14) '((1 . 10) (3 . 12) (5 . 14)))))))

107
test/chain-complexes-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -5,67 +6,67 @@
(test do-control (test do-control
(let ((comb (cat:do-control #'cat:s-cmpr (cat:cmbn 0 1 'a 1 'b -1 'c)))) (let ((comb (cat:do-control #'cat:s-cmpr (cat:cmbn 0 1 'a 1 'b -1 'c))))
(is (equal (cat:cmbn-degr comb) 0)) (is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((1 . a) (1 . b) (-1 . c))))) (is (equal (cat:cmbn-list comb) '((1 . a) (1 . b) (-1 . c)))))
(signals simple-error (cat:do-control #'cat:s-cmpr (signals simple-error (cat:do-control #'cat:s-cmpr
(cat:cmbn 0 1 'b 1 'b -1 'c))) (cat:cmbn 0 1 'b 1 'b -1 'c)))
(signals simple-error (cat:do-control #'cat:s-cmpr (signals simple-error (cat:do-control #'cat:s-cmpr
(cat:cmbn 0 1 'a 1 'b -1 'b))) (cat:cmbn 0 1 'a 1 'b -1 'b)))
(setf cat:*cmbn-control* nil) (setf cat:*cmbn-control* nil)
(is (not (null (cat:do-control #'cat:s-cmpr (is (not (null (cat:do-control #'cat:s-cmpr
(cat:cmbn 0 1 'a 1 'b -1 'b))))) (cat:cmbn 0 1 'a 1 'b -1 'b)))))
(setf cat:*cmbn-control* t) (setf cat:*cmbn-control* t)
(signals simple-error (cat:do-control #'cat:s-cmpr (signals simple-error (cat:do-control #'cat:s-cmpr
(cat:cmbn 0 1 'a 1 'b -1 'b)))) (cat:cmbn 0 1 'a 1 'b -1 'b))))
(test gnrt-? (test gnrt-?
(progn (progn
(cat:cat-init) (cat:cat-init)
(let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr (let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr
:basis :locally-effective :basis :locally-effective
:bsgn 0 :bsgn 0
:intr-dffr #'(lambda (cmbn) :intr-dffr #'(lambda (cmbn)
(cat:cmbn (cat:cmbn
(1- (cat:cmbn-degr cmbn)))) (1- (cat:cmbn-degr cmbn))))
:strt :cmbn :strt :cmbn
:orgn '(Z of Z))) :orgn '(Z of Z)))
(ff (cat:build-mrph :sorc cc :trgt cc :degr 0 (ff (cat:build-mrph :sorc cc :trgt cc :degr 0
:intr #'(lambda (degr n) :intr #'(lambda (degr n)
(cat:cmbn degr 1 n)) (cat:cmbn degr 1 n))
:strt :gnrt :orgn '(test)))) :strt :gnrt :orgn '(test))))
(setf cat:+too-much-time+ -1) (setf cat:+too-much-time+ -1)
(dotimes (i 20) (dotimes (i 20)
(let* ((n (- (random 50) 50)) (let* ((n (- (random 50) 50))
(comb (cat:gnrt-? ff 0 n))) (comb (cat:gnrt-? ff 0 n)))
(is (equal (cat:cmbn-degr comb) 0)) (is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) (cons (cons 1 n) nil)))))))) (is (equal (cat:cmbn-list comb) (cons (cons 1 n) nil))))))))
(setf *n* 10) (setf *n* 10)
(test cmbn-? (test cmbn-?
(progn (progn
(compile 'ff) (compile 'ff)
(cat:cat-init) (cat:cat-init)
(let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr (let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr
:basis :locally-effective :basis :locally-effective
:bsgn 0 :bsgn 0
:intr-dffr #'(lambda (cmbn) :intr-dffr #'(lambda (cmbn)
(cat:cmbn (cat:cmbn
(1- (cat:cmbn-degr cmbn)))) (1- (cat:cmbn-degr cmbn))))
:strt :cmbn :strt :cmbn
:orgn '(Z of Z))) :orgn '(Z of Z)))
(mrph (cat:build-mrph :sorc cc :trgt cc :degr 0 (mrph (cat:build-mrph :sorc cc :trgt cc :degr 0
:intr #'ff :strt :gnrt :orgn '(test)))) :intr #'ff :strt :gnrt :orgn '(test))))
(let ((comb (cat:cmbn-? mrph (cat:cmbn 0 1 100)))) (let ((comb (cat:cmbn-? mrph (cat:cmbn 0 1 100))))
(is (equal (cat:cmbn-degr comb) 0)) (is (equal (cat:cmbn-degr comb) 0))
(setq comb (cat:cmbn-? mrph comb)) (setq comb (cat:cmbn-? mrph comb))
(setq comb (cat:cmbn-? mrph comb)) (setq comb (cat:cmbn-? mrph comb))
(setq comb (cat:cmbn-? mrph comb)) (setq comb (cat:cmbn-? mrph comb))
(setq comb (cat:cmbn-? mrph comb)) (setq comb (cat:cmbn-? mrph comb))
(setq comb (cat:cmbn-? mrph comb)))))) (setq comb (cat:cmbn-? mrph comb))))))

271
test/chcm-elementary-op-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -5,170 +6,170 @@
(test zero-mrph (test zero-mrph
(progn (progn
(cat:cat-init) (cat:cat-init)
(let* ((z (cat:zero-mrph (cat:Z-chcm) (cat:Z-chcm) 2)) (let* ((z (cat:zero-mrph (cat:Z-chcm) (cat:Z-chcm) 2))
(z2 (cat:zero-mrph (cat:Z-chcm) (cat:Z-chcm) 2)) (z2 (cat:zero-mrph (cat:Z-chcm) (cat:Z-chcm) 2))
(z3 (cat:zero-mrph (cat:Z-chcm) (cat:Z-chcm) 3)) (z3 (cat:zero-mrph (cat:Z-chcm) (cat:Z-chcm) 3))
(comb (cat:gnrt-? z 0 :z-gnrt)) (comb (cat:gnrt-? z 0 :z-gnrt))
(comb1 (cat:cmbn-? z (cat:cmbn 3))) (comb1 (cat:cmbn-? z (cat:cmbn 3)))
(comb2 (cat:gnrt-? z3 0 :z-gnrt))) (comb2 (cat:gnrt-? z3 0 :z-gnrt)))
(is (equal (cat:cmbn-degr comb) 2)) (is (equal (cat:cmbn-degr comb) 2))
(is (equal (cat:cmbn-list comb) nil)) (is (equal (cat:cmbn-list comb) nil))
(is (equal (cat:cmbn-degr comb1) 5)) (is (equal (cat:cmbn-degr comb1) 5))
(is (equal (cat:cmbn-list comb1) nil)) (is (equal (cat:cmbn-list comb1) nil))
(is (eq z z2)) (is (eq z z2))
(is (equal (cat:cmbn-degr comb2) 3)) (is (equal (cat:cmbn-degr comb2) 3))
(is (equal (cat:cmbn-list comb2) nil)) (is (equal (cat:cmbn-list comb2) nil))
(is (not (eq z z3)))))) (is (not (eq z z3))))))
(test idnt-mrph (test idnt-mrph
(progn (progn
(cat:cat-init) (cat:cat-init)
(let* ((zi (cat:idnt-mrph (cat:Z-chcm))) (let* ((zi (cat:idnt-mrph (cat:Z-chcm)))
(comb (cat:gnrt-? zi 0 :z-gnrt)) (comb (cat:gnrt-? zi 0 :z-gnrt))
(zi2 (cat:idnt-mrph (cat:Z-chcm)))) (zi2 (cat:idnt-mrph (cat:Z-chcm))))
(is (equal (cat:cmbn-degr comb) 0)) (is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) (cons (cons 1 :z-gnrt) nil))) (is (equal (cat:cmbn-list comb) (cons (cons 1 :z-gnrt) nil)))
(is (eq zi zi2))))) (is (eq zi zi2)))))
(test opps (test opps
(progn (progn
(cat:cat-init) (cat:cat-init)
(let* ((-zi (cat:opps (cat:idnt-mrph (cat:Z-chcm)))) (let* ((-zi (cat:opps (cat:idnt-mrph (cat:Z-chcm))))
(comb (cat:gnrt-? -zi 0 :z-gnrt)) (comb (cat:gnrt-? -zi 0 :z-gnrt))
(-zi2 (cat:opps (cat:idnt-mrph (cat:Z-chcm))))) (-zi2 (cat:opps (cat:idnt-mrph (cat:Z-chcm)))))
(is (equal (cat:cmbn-degr comb) 0)) (is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) (cons (cons -1 :z-gnrt) nil))) (is (equal (cat:cmbn-list comb) (cons (cons -1 :z-gnrt) nil)))
(is (eq -zi -zi2))))) (is (eq -zi -zi2)))))
(setf *n* 5) (setf *n* 5)
(test cmps (test cmps
(progn (progn
(cat:cat-init) (cat:cat-init)
(let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr (let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr
:basis :locally-effective :basis :locally-effective
:bsgn 0 :bsgn 0
:intr-dffr #'(lambda (cmbn) :intr-dffr #'(lambda (cmbn)
(cat:cmbn (cat:cmbn
(1- (cat:cmbn-degr cmbn)))) (1- (cat:cmbn-degr cmbn))))
:strt :cmbn :strt :cmbn
:orgn '(Z of Z))) :orgn '(Z of Z)))
(mrph (cat:build-mrph :sorc cc :trgt cc :degr 0 (mrph (cat:build-mrph :sorc cc :trgt cc :degr 0
:intr #'ff :strt :gnrt :orgn '(test))) :intr #'ff :strt :gnrt :orgn '(test)))
(mrph2 (cat:cmps mrph mrph :gnrt)) (mrph2 (cat:cmps mrph mrph :gnrt))
(comb (cat:gnrt-? mrph2 0 0)) (comb (cat:gnrt-? mrph2 0 0))
(mrph3 (cat:cmps mrph mrph :cmbn)) (mrph3 (cat:cmps mrph mrph :cmbn))
(comb1 (cat:gnrt-? mrph3 0 0)) (comb1 (cat:gnrt-? mrph3 0 0))
(mrph33 (cat:cmps mrph mrph :cmbn))) (mrph33 (cat:cmps mrph mrph :cmbn)))
(dotimes (i 5) (dotimes (i 5)
(setq comb (cat:gnrt-? mrph2 0 i)) (setq comb (cat:gnrt-? mrph2 0 i))
(is (equal (cat:cmbn-degr comb) 0))) (is (equal (cat:cmbn-degr comb) 0)))
(dotimes (i 5) (dotimes (i 5)
(setq comb1 (cat:gnrt-? mrph3 0 i)) (setq comb1 (cat:gnrt-? mrph3 0 i))
(is (equal (cat:cmbn-degr comb1) 0))) (is (equal (cat:cmbn-degr comb1) 0)))
(is (eq mrph3 mrph33))))) (is (eq mrph3 mrph33)))))
#| #|
(setf s3 (sphere 3)) (setf s3 (sphere 3))
(setf ch3 (chml-clss s3 3)) (setf ch3 (chml-clss s3 3))
(setf 2ch3 (n-mrph 2 ch3)) (setf 2ch3 (n-mrph 2 ch3))
(setf f3 (z-whitehead s3 2ch3)) (setf f3 (z-whitehead s3 2ch3))
(setf x (fibration-total f3)) (setf x (fibration-total f3))
(homology x 0 10) (homology x 0 10)
(setf k (k-z 3)) (setf k (k-z 3))
(setf ch3 (chml-clss k 3)) (setf ch3 (chml-clss k 3))
(setf 2ch3 (n-mrph 2 ch3)) (setf 2ch3 (n-mrph 2 ch3))
(setf f3 (z-whitehead k 2ch3)) (setf f3 (z-whitehead k 2ch3))
(setf x (fibration-total f3)) (setf x (fibration-total f3))
(homology x 0 10) (homology x 0 10)
|# |#
(test n-mrph (test n-mrph
(progn (progn
(cat:cat-init) (cat:cat-init)
(let* ((s3 (cat:sphere 3)) (let* ((s3 (cat:sphere 3))
(ch3 (cat:chml-clss s3 3)) (ch3 (cat:chml-clss s3 3))
(2ch3 (cat:n-mrph 2 ch3)) (2ch3 (cat:n-mrph 2 ch3))
;; (f3 (cat:z-whitehead s3 2ch3)) ;; (f3 (cat:z-whitehead s3 2ch3))
;; (x (cat:fibration-total f3)) ;; (x (cat:fibration-total f3))
(k (cat:k-z 3))) (k (cat:k-z 3)))
;; (cat:homology x 0 10) ;; (cat:homology x 0 10)
;; (setf ch3 (cat:chml-clss k 3)) ;; (setf ch3 (cat:chml-clss k 3))
;; (setf 2ch3 (cat:n-mrph 2 ch3)) ;; (setf 2ch3 (cat:n-mrph 2 ch3))
;; (setf f3 (cat:z-whitehead k 2ch3)) ;; (setf f3 (cat:z-whitehead k 2ch3))
;; (setf x (cat:fibration-total f3)) ;; (setf x (cat:fibration-total f3))
;; (cat:homology x 0 10) ;; (cat:homology x 0 10)
))) )))
(setf *n* 10) (setf *n* 10)
(setf cat:+too-much-time+ -1) (setf cat:+too-much-time+ -1)
(test add (test add
(progn (progn
(cat:cat-init) (cat:cat-init)
(let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr (let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr
:basis :locally-effective :basis :locally-effective
:bsgn 0 :bsgn 0
:intr-dffr #'(lambda (cmbn) :intr-dffr #'(lambda (cmbn)
(cat:cmbn (cat:cmbn
(1- (cat:cmbn-degr cmbn)))) (1- (cat:cmbn-degr cmbn))))
:strt :cmbn :strt :cmbn
:orgn '(Z of Z))) :orgn '(Z of Z)))
(mrph1 (cat:build-mrph :sorc cc :trgt cc :degr 0 (mrph1 (cat:build-mrph :sorc cc :trgt cc :degr 0
:intr #'ff :strt :gnrt :orgn '(test))) :intr #'ff :strt :gnrt :orgn '(test)))
(mrph2 (cat:build-mrph :sorc cc :trgt cc :degr 0 (mrph2 (cat:build-mrph :sorc cc :trgt cc :degr 0
:intr #'ff :strt :gnrt :orgn '(test2))) :intr #'ff :strt :gnrt :orgn '(test2)))
(mrph3 (cat:add mrph1 mrph2 :gnrt)) (mrph3 (cat:add mrph1 mrph2 :gnrt))
(comb1 (cat:gnrt-? mrph1 0 0)) (comb1 (cat:gnrt-? mrph1 0 0))
(comb2 (cat:gnrt-? mrph2 0 0)) (comb2 (cat:gnrt-? mrph2 0 0))
(comb3 (cat:gnrt-? mrph3 0 0)) (comb3 (cat:gnrt-? mrph3 0 0))
(mrph4 (cat:add mrph1 mrph2 :cmbn)) (mrph4 (cat:add mrph1 mrph2 :cmbn))
(comb4 (cat:gnrt-? mrph4 0 0)) (comb4 (cat:gnrt-? mrph4 0 0))
(mrph44 (cat:add mrph1 mrph2 :cmbn))) (mrph44 (cat:add mrph1 mrph2 :cmbn)))
(is (equal (cat:cmbn-degr comb1) 0)) (is (equal (cat:cmbn-degr comb1) 0))
(is (equal (length (cat:cmbn-list comb1)) 10)) (is (equal (length (cat:cmbn-list comb1)) 10))
(is (equal (cat:cmbn-degr comb2) 0)) (is (equal (cat:cmbn-degr comb2) 0))
(is (equal (length (cat:cmbn-list comb2)) 10)) (is (equal (length (cat:cmbn-list comb2)) 10))
(is (equal (cat:cmbn-degr comb3) 0)) (is (equal (cat:cmbn-degr comb3) 0))
(is (<= (length (cat:cmbn-list comb3)) 20)) (is (<= (length (cat:cmbn-list comb3)) 20))
(is (equal (cat:cmbn-degr comb4) 0)) (is (equal (cat:cmbn-degr comb4) 0))
(is (<= (length (cat:cmbn-list comb4)) 20)) (is (<= (length (cat:cmbn-list comb4)) 20))
(is (eq mrph4 mrph44))))) (is (eq mrph4 mrph44)))))
(test sbtr (test sbtr
(progn (progn
(cat:cat-init) (cat:cat-init)
(let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr (let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr
:basis :locally-effective :basis :locally-effective
:bsgn 0 :bsgn 0
:intr-dffr #'(lambda (cmbn) :intr-dffr #'(lambda (cmbn)
(cat:cmbn (cat:cmbn
(1- (cat:cmbn-degr cmbn)))) (1- (cat:cmbn-degr cmbn))))
:strt :cmbn :strt :cmbn
:orgn '(Z of Z))) :orgn '(Z of Z)))
(mrph1 (cat:build-mrph :sorc cc :trgt cc :degr 0 (mrph1 (cat:build-mrph :sorc cc :trgt cc :degr 0
:intr #'ff :strt :gnrt :orgn '(test))) :intr #'ff :strt :gnrt :orgn '(test)))
(mrph2 (cat:build-mrph :sorc cc :trgt cc :degr 0 (mrph2 (cat:build-mrph :sorc cc :trgt cc :degr 0
:intr #'ff :strt :gnrt :orgn '(test2))) :intr #'ff :strt :gnrt :orgn '(test2)))
(mrph3 (cat:sbtr mrph1 mrph2 :gnrt)) (mrph3 (cat:sbtr mrph1 mrph2 :gnrt))
(comb1 (cat:gnrt-? mrph1 0 0)) (comb1 (cat:gnrt-? mrph1 0 0))
(comb2 (cat:gnrt-? mrph2 0 0)) (comb2 (cat:gnrt-? mrph2 0 0))
(comb3 (cat:gnrt-? mrph3 0 0)) (comb3 (cat:gnrt-? mrph3 0 0))
(mrph4 (cat:sbtr mrph1 mrph2 :cmbn)) (mrph4 (cat:sbtr mrph1 mrph2 :cmbn))
(comb4 (cat:gnrt-? mrph4 0 0)) (comb4 (cat:gnrt-? mrph4 0 0))
(mrph44 (cat:sbtr mrph1 mrph2 :cmbn))) (mrph44 (cat:sbtr mrph1 mrph2 :cmbn)))
(is (equal (cat:cmbn-degr comb1) 0)) (is (equal (cat:cmbn-degr comb1) 0))
(is (equal (length (cat:cmbn-list comb1)) 10)) (is (equal (length (cat:cmbn-list comb1)) 10))
(is (equal (cat:cmbn-degr comb2) 0)) (is (equal (cat:cmbn-degr comb2) 0))
(is (equal (length (cat:cmbn-list comb2)) 10)) (is (equal (length (cat:cmbn-list comb2)) 10))
(is (equal (cat:cmbn-degr comb3) 0)) (is (equal (cat:cmbn-degr comb3) 0))
(is (<= (length (cat:cmbn-list comb3)) 20)) (is (<= (length (cat:cmbn-list comb3)) 20))
(is (equal (cat:cmbn-degr comb4) 0)) (is (equal (cat:cmbn-degr comb4) 0))
(is (<= (length (cat:cmbn-list comb4)) 20)) (is (<= (length (cat:cmbn-list comb4)) 20))
(is (eq mrph4 mrph44))))) (is (eq mrph4 mrph44)))))

7
test/circle.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -7,6 +8,6 @@
(test circle (test circle
(cat:cat-init) (cat:cat-init)
(let ((circle (cat:circle))) (let ((circle (cat:circle)))
(is (equal (cat:basis circle 0) '(*))) (is (equal (cat:basis circle 0) '(*)))
(is (equal (cat:basis circle 1) '(cat::s1))) (is (equal (cat:basis circle 1) '(cat::s1)))
(is (equal (cat:basis circle 2) cat:+empty-list+)))) (is (equal (cat:basis circle 2) cat:+empty-list+))))

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

@ -1,3 +1,5 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
(in-suite :kenzo) (in-suite :kenzo)
@ -358,9 +360,9 @@
(let* ((h (cat:cs-left-hmeq (cat:k-z-1))) (let* ((h (cat:cs-left-hmeq (cat:k-z-1)))
(abar (cat:abar 2 '(2) 3 '(3 4)))) (abar (cat:abar 2 '(2) 3 '(3 4))))
(cat:rf h (cat:rf h
(cat:lg h (cat:lg h
(cat:lf h (cat:lf h
(cat:rg h 5 abar)))))) (cat:rg h 5 abar))))))
(test classifying-space (test classifying-space

145
test/classifying-spaces-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -10,59 +11,59 @@
(cat:normalize-gbar (list 2 (cat:absm 1 'i) (cat:absm 0 'i))) (cat:normalize-gbar (list 2 (cat:absm 1 'i) (cat:absm 0 'i)))
(cat:normalize-gbar (list 2 (cat:absm 0 'a) (cat:absm 0 'i))) (cat:normalize-gbar (list 2 (cat:absm 0 'a) (cat:absm 0 'i)))
(cat:normalize-gbar (list 4 (cat:absm 0 'a) (cat:absm 0 'b) (cat:normalize-gbar (list 4 (cat:absm 0 'a) (cat:absm 0 'b)
(cat:absm 0 'c) (cat:absm 0 'i))) (cat:absm 0 'c) (cat:absm 0 'i)))
(cat:normalize-gbar (list 4 (cat:absm 7 'i) (cat:absm 3 'i) (cat:normalize-gbar (list 4 (cat:absm 7 'i) (cat:absm 3 'i)
(cat:absm 1 'i) (cat:absm 0 'i))) (cat:absm 1 'i) (cat:absm 0 'i)))
(cat:normalize-gbar (list 4 (cat:absm 0 'a) (cat:absm 3 'i) (cat:normalize-gbar (list 4 (cat:absm 0 'a) (cat:absm 3 'i)
(cat:absm 0 'c) (cat:absm 0 'i))) (cat:absm 0 'c) (cat:absm 0 'i)))
(cat:normalize-gbar (list 4 (cat:absm 1 'a) (cat:absm 3 'i) (cat:normalize-gbar (list 4 (cat:absm 1 'a) (cat:absm 3 'i)
(cat:absm 0 'c) (cat:absm 0 'i))) (cat:absm 0 'c) (cat:absm 0 'i)))
(cat:normalize-gbar (list 4 (cat:absm 2 'a) (cat:absm 3 'i) (cat:normalize-gbar (list 4 (cat:absm 2 'a) (cat:absm 3 'i)
(cat:absm 0 'c) (cat:absm 0 'i))) (cat:absm 0 'c) (cat:absm 0 'i)))
(cat:normalize-gbar (list 4 (cat:absm 4 'a) (cat:absm 3 'i) (cat:normalize-gbar (list 4 (cat:absm 4 'a) (cat:absm 3 'i)
(cat:absm 0 'c) (cat:absm 0 'i))) (cat:absm 0 'c) (cat:absm 0 'i)))
(cat:normalize-gbar (list 4 (cat:absm 3 'a) (cat:absm 3 'i) (cat:normalize-gbar (list 4 (cat:absm 3 'a) (cat:absm 3 'i)
(cat:absm 0 'c) (cat:absm 0 'i))) (cat:absm 0 'c) (cat:absm 0 'i)))
(cat:normalize-gbar (list 4 (cat:absm 5 'a) (cat:absm 3 'i) (cat:normalize-gbar (list 4 (cat:absm 5 'a) (cat:absm 3 'i)
(cat:absm 0 'c) (cat:absm 0 'i))) (cat:absm 0 'c) (cat:absm 0 'i)))
(cat:normalize-gbar (list 4 (cat:absm 6 'a) (cat:absm 3 'i) (cat:normalize-gbar (list 4 (cat:absm 6 'a) (cat:absm 3 'i)
(cat:absm 0 'c) (cat:absm 0 'i))) (cat:absm 0 'c) (cat:absm 0 'i)))
(cat:normalize-gbar (list 4 (cat:absm 1 'a) (cat:absm 3 'i) (cat:normalize-gbar (list 4 (cat:absm 1 'a) (cat:absm 3 'i)
(cat:absm 1 'i) (cat:absm 0 'i)))) (cat:absm 1 'i) (cat:absm 0 'i))))
(test unnormalize-gbar (test unnormalize-gbar
(cat:unnormalize-gbar (cat:absm 1 cat:+null-gbar+) 'i) (cat:unnormalize-gbar (cat:absm 1 cat:+null-gbar+) 'i)
(cat:unnormalize-gbar (cat:absm 15 cat:+null-gbar+) 'i) (cat:unnormalize-gbar (cat:absm 15 cat:+null-gbar+) 'i)
(cat:normalize-gbar (cat:unnormalize-gbar (cat:normalize-gbar (cat:unnormalize-gbar
(cat:absm 15 cat:+null-gbar+) 'i)) (cat:absm 15 cat:+null-gbar+) 'i))
(cat:unnormalize-gbar (cat:unnormalize-gbar
(cat:absm 0 (cat:make-gbar :dmns 4 (cat:absm 0 (cat:make-gbar :dmns 4
:list (list (cat:absm 0 'a) (cat:absm 0 'b) :list (list (cat:absm 0 'a) (cat:absm 0 'b)
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i) (cat:absm 0 'c) (cat:absm 0 'i)))) 'i)
(cat:normalize-gbar (cat:normalize-gbar
(cat:unnormalize-gbar (cat:unnormalize-gbar
(cat:absm 0 (cat:make-gbar :dmns 4 (cat:absm 0 (cat:make-gbar :dmns 4
:list (list (cat:absm 0 'a) (cat:absm 0 'b) :list (list (cat:absm 0 'a) (cat:absm 0 'b)
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i)) (cat:absm 0 'c) (cat:absm 0 'i)))) 'i))
(cat:unnormalize-gbar (cat:unnormalize-gbar
(cat:absm 5 (cat:make-gbar :dmns 4 (cat:absm 5 (cat:make-gbar :dmns 4
:list (list (cat:absm 0 'a) (cat:absm 0 'b) :list (list (cat:absm 0 'a) (cat:absm 0 'b)
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i) (cat:absm 0 'c) (cat:absm 0 'i)))) 'i)
(cat:normalize-gbar (cat:normalize-gbar
(cat:unnormalize-gbar (cat:unnormalize-gbar
(cat:absm 5 (cat:make-gbar :dmns 4 (cat:absm 5 (cat:make-gbar :dmns 4
:list (list (cat:absm 0 'a) (cat:absm 0 'b) :list (list (cat:absm 0 'a) (cat:absm 0 'b)
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i)) (cat:absm 0 'c) (cat:absm 0 'i)))) 'i))
(cat:unnormalize-gbar (cat:unnormalize-gbar
(cat:absm 9 (cat:make-gbar :dmns 4 (cat:absm 9 (cat:make-gbar :dmns 4
:list (list (cat:absm 0 'a) (cat:absm 0 'b) :list (list (cat:absm 0 'a) (cat:absm 0 'b)
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i) (cat:absm 0 'c) (cat:absm 0 'i)))) 'i)
(cat:normalize-gbar (cat:normalize-gbar
(cat:unnormalize-gbar (cat:unnormalize-gbar
(cat:absm 9 (cat:make-gbar :dmns 4 (cat:absm 9 (cat:make-gbar :dmns 4
:list (list (cat:absm 0 'a) (cat:absm 0 'b) :list (list (cat:absm 0 'a) (cat:absm 0 'b)
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i))) (cat:absm 0 'c) (cat:absm 0 'i)))) 'i)))
(test gbar (test gbar
@ -73,75 +74,75 @@
(test classifying-space-cmpr (test classifying-space-cmpr
(let ((cmpr (cat:classifying-space-cmpr #'cat:s-cmpr))) (let ((cmpr (cat:classifying-space-cmpr #'cat:s-cmpr)))
(is (equal :less (funcall cmpr (is (equal :less (funcall cmpr
(cat:gbar 2 0 'a 0 'a) (cat:gbar 2 0 'a 0 'a)
(cat:gbar 2 1 'a 0 'a)))) (cat:gbar 2 1 'a 0 'a))))
(is (equal :less (funcall cmpr (is (equal :less (funcall cmpr
(cat:gbar 2 0 'a 0 'a) (cat:gbar 2 0 'a 0 'a)
(cat:gbar 2 0 'b 0 'a)))) (cat:gbar 2 0 'b 0 'a))))
(is (equal :equal (funcall cmpr (is (equal :equal (funcall cmpr
(cat:gbar 2 0 'a 0 'a) (cat:gbar 2 0 'a 0 'a)
(cat:gbar 2 0 'a 0 'a)))))) (cat:gbar 2 0 'a 0 'a))))))
(test classifying-space-basis (test classifying-space-basis
(cat:cat-init) (cat:cat-init)
(let* ((k (cat:k-z2-1)) (let* ((k (cat:k-z2-1))
(b (cat:classifying-space-basis (cat:basis k)))) (b (cat:classifying-space-basis (cat:basis k))))
(funcall b 0) (funcall b 0)
(funcall b 1) (funcall b 1)
(dotimes (i 5) (print (funcall b i))))) (dotimes (i 5) (print (funcall b i)))))
(test classifying-space-face (test classifying-space-face
(let* ((om (cat:loop-space (cat:moore 2 2))) (let* ((om (cat:loop-space (cat:moore 2 2)))
(face (cat:classifying-space-face (cat:face om) (face (cat:classifying-space-face (cat:face om)
(cat:sintr (cat:grml om)))) (cat:sintr (cat:grml om))))
(gbar (cat:gbar 4 0 (cat:loop3 3 'm2 1 4 'n3 1) (gbar (cat:gbar 4 0 (cat:loop3 3 'm2 1 4 'n3 1)
0 (cat:loop3 0 'n3 1) 0 (cat:loop3 0 'n3 1)
0 (cat:loop3 0 'm2 1) 0 (cat:loop3 0 'm2 1)
0 cat:+null-loop+))) 0 cat:+null-loop+)))
(dotimes (i 5) (dotimes (i 5)
(print (funcall face i 4 gbar))))) (print (funcall face i 4 gbar)))))
(test classifying-space (test classifying-space
(cat:cat-init) (cat:cat-init)
(let ((c (cat:classifying-space (cat:k-z2-1)))) (let ((c (cat:classifying-space (cat:k-z2-1))))
(cat:orgn c) (cat:orgn c)
(first (cat:basis c 4)) (first (cat:basis c 4))
(cat:? c 4 (first (cat:basis c 4))) (cat:? c 4 (first (cat:basis c 4)))
(cat:? c (cat:? c 4 (first (cat:basis c 4)))) (cat:? c (cat:? c 4 (first (cat:basis c 4))))
(cat:cprd c 4 (first (cat:basis c 4))) (cat:cprd c 4 (first (cat:basis c 4)))
(dotimes (i 5) (dotimes (i 5)
(print (cat:face c i 4 (first (cat:basis c 4))))))) (print (cat:face c i 4 (first (cat:basis c 4)))))))
(test classifying-space-grml-sintr (test classifying-space-grml-sintr
(let ((grml (cat:classifying-space-grml-sintr (let ((grml (cat:classifying-space-grml-sintr
'() (cat:sintr (cat:grml (cat:k-z-1)))))) '() (cat:sintr (cat:grml (cat:k-z-1))))))
(funcall grml 3 (cat:crpr 0 (cat:gbar 3 0 '(1 2) 0 '(3) 0 '()) (funcall grml 3 (cat:crpr 0 (cat:gbar 3 0 '(1 2) 0 '(3) 0 '())
0 (cat:gbar 3 0 '(-1 -2) 0 '(-3) 0 '()))) 0 (cat:gbar 3 0 '(-1 -2) 0 '(-3) 0 '())))
(funcall grml 3 (cat:crpr 0 (cat:gbar 3 0 '(1 2) 0 '(3) 0 '()) (funcall grml 3 (cat:crpr 0 (cat:gbar 3 0 '(1 2) 0 '(3) 0 '())
4 (cat:gbar 2 0 '(-3) 0 '()))) 4 (cat:gbar 2 0 '(-3) 0 '())))
(funcall grml 3 (cat:crpr 0 (cat:gbar 3 0 '(1 2) 0 '(3) 0 '()) (funcall grml 3 (cat:crpr 0 (cat:gbar 3 0 '(1 2) 0 '(3) 0 '())
1 (cat:gbar 2 0 '(-3) 0 '()))))) 1 (cat:gbar 2 0 '(-3) 0 '())))))
(test classifying-space-grin-sintr (test classifying-space-grin-sintr
(let ((grin (cat:classifying-space-grin-sintr (let ((grin (cat:classifying-space-grin-sintr
(cat:sintr (cat:grin (cat:k-z-1)))))) (cat:sintr (cat:grin (cat:k-z-1))))))
(funcall grin 3 (cat:gbar 3 0 '(1 2) 1 '() 0 '())))) (funcall grin 3 (cat:gbar 3 0 '(1 2) 1 '() 0 '()))))
(test classifying-space1 (test classifying-space1
(cat:cat-init) (cat:cat-init)
(let* ((k-z-1 (cat:k-z-1)) (let* ((k-z-1 (cat:k-z-1))
(k-z-2 (cat:classifying-space k-z-1)) (k-z-2 (cat:classifying-space k-z-1))
(k-z-3 (cat:classifying-space k-z-2)) (k-z-3 (cat:classifying-space k-z-2))
(k-z2-1 (cat:k-z2-1)) (k-z2-1 (cat:k-z2-1))
(k-z2-2 (cat:classifying-space k-z2-1)) (k-z2-2 (cat:classifying-space k-z2-1))
(k-z2-3 (cat:classifying-space k-z2-2)) (k-z2-3 (cat:classifying-space k-z2-2))
(k-z2-4 (cat:classifying-space k-z2-3)) (k-z2-4 (cat:classifying-space k-z2-3))
(k-z2-5 (cat:classifying-space k-z2-4))) (k-z2-5 (cat:classifying-space k-z2-4)))
(cat:homology k-z-3 0 10) (cat:homology k-z-3 0 10)
(cat:homology k-z2-5 0 7))) (cat:homology k-z2-5 0 7)))

337
test/cobar-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -12,94 +13,94 @@
(test cobar-cmpr (test cobar-cmpr
(let ((r (cat:cobar-cmpr #'cat:s-cmpr))) (let ((r (cat:cobar-cmpr #'cat:s-cmpr)))
(is (equal :equal (funcall r (cat:allp) (cat:allp)))) (is (equal :equal (funcall r (cat:allp) (cat:allp))))
(is (equal :greater (funcall r (cat:allp 3 'a) (cat:allp)))) (is (equal :greater (funcall r (cat:allp 3 'a) (cat:allp))))
(is (equal :less (funcall r (cat:allp 3 'a) (cat:allp 2 'a 1 'b)))) (is (equal :less (funcall r (cat:allp 3 'a) (cat:allp 2 'a 1 'b))))
(is (equal :less (funcall r (cat:allp 3 'a) (cat:allp 3 'b)))) (is (equal :less (funcall r (cat:allp 3 'a) (cat:allp 3 'b))))
(is (equal :equal (funcall r (cat:allp 3 'a) (cat:allp 3 'a)))))) (is (equal :equal (funcall r (cat:allp 3 'a) (cat:allp 3 'a))))))
(test cobar-basis-length (test cobar-basis-length
(let ((basis #'(lambda (degr) (list degr)))) (let ((basis #'(lambda (degr) (list degr))))
(cat:cobar-basis-length basis 1 1) (cat:cobar-basis-length basis 1 1)
(cat:cobar-basis-length basis 2 1) (cat:cobar-basis-length basis 2 1)
(cat:cobar-basis-length basis 2 2) (cat:cobar-basis-length basis 2 2)
(cat:cobar-basis-length basis 3 1) (cat:cobar-basis-length basis 3 1)
(cat:cobar-basis-length basis 3 2) (cat:cobar-basis-length basis 3 2)
(cat:cobar-basis-length basis 3 3))) (cat:cobar-basis-length basis 3 3)))
(test cobar-basis (test cobar-basis
(let* ((basis #'(lambda (degr) (list degr))) (let* ((basis #'(lambda (degr) (list degr)))
(r (cat:cobar-basis basis))) (r (cat:cobar-basis basis)))
(funcall r 0) (funcall r 0)
(funcall r 1) (funcall r 1)
(funcall r 2) (funcall r 2)
(dotimes (i 7) (dotimes (i 7)
(print (funcall r i))) (print (funcall r i)))
(cat:cobar-basis :locally-effective))) (cat:cobar-basis :locally-effective)))
(test cobar-intr-vrtc-dffr (test cobar-intr-vrtc-dffr
(let* ((d (cat:soft-delta-infinity)) (let* ((d (cat:soft-delta-infinity))
(r (cat:cobar-intr-vrtc-dffr (cat:dffr d)))) (r (cat:cobar-intr-vrtc-dffr (cat:dffr d))))
(funcall r 0 (cat:allp)) (funcall r 0 (cat:allp))
(funcall r 3 (cat:allp 3 (cat:d 15))) (funcall r 3 (cat:allp 3 (cat:d 15)))
(funcall r 5 (cat:allp 3 (cat:d (cat:mask 5)) 2 (cat:d (cat:mask 4)))) (funcall r 5 (cat:allp 3 (cat:d (cat:mask 5)) 2 (cat:d (cat:mask 4))))
(funcall r 5 (cat:allp 2 (cat:d (cat:mask 4)) (funcall r 5 (cat:allp 2 (cat:d (cat:mask 4))
3 (cat:d (cat:mask 5)))))) 3 (cat:d (cat:mask 5))))))
(test vrtc-cobar (test vrtc-cobar
(cat:cat-init) (cat:cat-init)
(let ((v (cat:vrtc-cobar (cat:soft-delta-infinity)))) (let ((v (cat:vrtc-cobar (cat:soft-delta-infinity))))
(dotimes (i 10) (print (random-allp 5))) (dotimes (i 10) (print (random-allp 5)))
(dotimes (i 10) (dotimes (i 10)
(let ((allp (random-allp 3))) (let ((allp (random-allp 3)))
(print allp) (print allp)
(print (cat:? v (apply #'+ (mapcar #'car (cat:allp-list allp))) (print (cat:? v (apply #'+ (mapcar #'car (cat:allp-list allp)))
allp)) allp))
(print (cat:? v (cat:? v (apply #'+ (mapcar #'car (print (cat:? v (cat:? v (apply #'+ (mapcar #'car
(cat:allp-list allp))) (cat:allp-list allp)))
allp))))))) allp)))))))
(test cobar-intr-hrzn-dffr (test cobar-intr-hrzn-dffr
(let* ((d (cat:soft-delta-infinity)) (let* ((d (cat:soft-delta-infinity))
(r (cat:cobar-intr-hrzn-dffr (cat:cprd d)))) (r (cat:cobar-intr-hrzn-dffr (cat:cprd d))))
(funcall r 0 (cat:allp)) (funcall r 0 (cat:allp))
(funcall r 3 (cat:allp 3 (cat:d (cat:mask 5)))) (funcall r 3 (cat:allp 3 (cat:d (cat:mask 5))))
(funcall r 5 (cat:allp 3 (cat:d (cat:mask 5)) 2 (cat:d (cat:mask 4)))) (funcall r 5 (cat:allp 3 (cat:d (cat:mask 5)) 2 (cat:d (cat:mask 4))))
(funcall r 5 (cat:allp 2 (cat:d (cat:mask 4)) (funcall r 5 (cat:allp 2 (cat:d (cat:mask 4))
3 (cat:d (cat:mask 5)))))) 3 (cat:d (cat:mask 5))))))
#| #|
(test cobar-hrzn-dffr (test cobar-hrzn-dffr
(cat:cat-init) (cat:cat-init)
(let ((h (cat:cobar-hrzn-dffr (cat:soft-delta-infinity))) (let ((h (cat:cobar-hrzn-dffr (cat:soft-delta-infinity)))
(allp (random-allp 4))) (allp (random-allp 4)))
(dotimes (i 10) (print (random-allp 5))) (dotimes (i 10) (print (random-allp 5)))
(cat:? h (apply #'+ (mapcar #'car (cat:allp-list allp))) allp) (cat:? h (apply #'+ (mapcar #'car (cat:allp-list allp))) allp)
(cat:? h (cat:? h (apply #'+ (mapcar #'car (cat:allp-list allp))) (cat:? h (cat:? h (apply #'+ (mapcar #'car (cat:allp-list allp)))
allp)) allp))
(dotimes (i 10) (dotimes (i 10)
(let ((allp (random-allp 3))) (let ((allp (random-allp 3)))
(print allp) (print allp)
(print (cat:? h (apply #'+ (mapcar #'car (cat:allp-list allp))) (print (cat:? h (apply #'+ (mapcar #'car (cat:allp-list allp)))
allp)) allp))
(print (cat:? h (cat:? h (apply #'+ (mapcar #'car (print (cat:? h (cat:? h (apply #'+ (mapcar #'car
(cat:allp-list allp))) (cat:allp-list allp)))
allp))))))) allp)))))))
|# |#
(defun random-allp1 (length) (defun random-allp1 (length)
(let ((rslt nil)) (let ((rslt nil))
(dotimes (i length) (dotimes (i length)
(let* ((gmsm (random (cat:mask 9))) (let* ((gmsm (random (cat:mask 9)))
(dmns (1- (logcount gmsm)))) (dmns (1- (logcount gmsm))))
(when (plusp dmns) (when (plusp dmns)
(push (cat:cbgn (1- dmns) gmsm) rslt)))) (push (cat:cbgn (1- dmns) gmsm) rslt))))
(cat:make-allp :list rslt))) (cat:make-allp :list rslt)))
@ -107,19 +108,19 @@
(test cobar (test cobar
(cat:cat-init) (cat:cat-init)
(let ((c (cat:cobar (cat:deltab))) (let ((c (cat:cobar (cat:deltab)))
(allp (random-allp1 4))) (allp (random-allp1 4)))
(dotimes (i 10) (print (random-allp1 5))) (dotimes (i 10) (print (random-allp1 5)))
(cat:? c (apply #'+ (mapcar #'car (cat:allp-list allp))) allp) (cat:? c (apply #'+ (mapcar #'car (cat:allp-list allp))) allp)
(cat:? c (cat:? c (apply #'+ (mapcar #'car (cat:allp-list allp))) (cat:? c (cat:? c (apply #'+ (mapcar #'car (cat:allp-list allp)))
allp)) allp))
(dotimes (i 10) (dotimes (i 10)
(let ((allp (random-allp1 3))) (let ((allp (random-allp1 3)))
(print allp) (print allp)
(print (cat:? c (apply #'+ (mapcar #'car (cat:allp-list allp))) (print (cat:? c (apply #'+ (mapcar #'car (cat:allp-list allp)))
allp)) allp))
(print (cat:? c (cat:? c (apply #'+ (mapcar #'car (print (cat:? c (cat:? c (apply #'+ (mapcar #'car
(cat:allp-list allp))) (cat:allp-list allp)))
allp))))))) allp)))))))
|# |#
(test ncmbn-cobar (test ncmbn-cobar
@ -127,131 +128,131 @@
(cat:ncmbn-cobar (list (cat:cmbn 3 2 'a 3 'b))) (cat:ncmbn-cobar (list (cat:cmbn 3 2 'a 3 'b)))
(cat:ncmbn-cobar (list (cat:cmbn 1 2 'a 3 'b) (cat:cmbn 2 4 'c 5 'd))) (cat:ncmbn-cobar (list (cat:cmbn 1 2 'a 3 'b) (cat:cmbn 2 4 'c 5 'd)))
(cat:ncmbn-cobar (list (cat:cmbn 1 2 'a 3 'b) (cat:cmbn 1 4 'c 5 'd) (cat:ncmbn-cobar (list (cat:cmbn 1 2 'a 3 'b) (cat:cmbn 1 4 'c 5 'd)
(cat:cmbn 1 6 'e 7 'f)))) (cat:cmbn 1 6 'e 7 'f))))
(test mrph-vrtc-cobar-intr (test mrph-vrtc-cobar-intr
(let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr :strt :cmbn)) (let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr :strt :cmbn))
(m (cat:build-mrph :sorc cc :trgt cc :degr 0 :intr (m (cat:build-mrph :sorc cc :trgt cc :degr 0 :intr
#'(lambda (degr gnrt) #'(lambda (degr gnrt)
(cat:cmbn degr 2 gnrt 3 (1+ gnrt))) (cat:cmbn degr 2 gnrt 3 (1+ gnrt)))
:strt :gnrt :orgn '(test))) :strt :gnrt :orgn '(test)))
(r (cat:mrph-vrtc-cobar-intr m))) (r (cat:mrph-vrtc-cobar-intr m)))
(funcall r 4 (cat:allp 2 3 2 4)))) (funcall r 4 (cat:allp 2 3 2 4))))
(test vrtc-cobar (test vrtc-cobar
(cat:cat-init) (cat:cat-init)
(let* ((f (cat:aw (cat:soft-delta-infinity) (cat:soft-delta-infinity))) (let* ((f (cat:aw (cat:soft-delta-infinity) (cat:soft-delta-infinity)))
(cf (cat:vrtc-cobar f))) (cf (cat:vrtc-cobar f)))
(cat:? cf 2 (cat:allp 1 (cat:crpr 0 (cat:d 7) 0 (cat:d 7)) (cat:? cf 2 (cat:allp 1 (cat:crpr 0 (cat:d 7) 0 (cat:d 7))
1 (cat:crpr 0 (cat:d 56) 0 (cat:d 56)))))) 1 (cat:crpr 0 (cat:d 56) 0 (cat:d 56))))))
(test hmtp-vrtc-cobar-intr (test hmtp-vrtc-cobar-intr
(cat:cat-init) (cat:cat-init)
(let* ((ez (cat:ez (cat:delta-infinity) (cat:delta-infinity))) (let* ((ez (cat:ez (cat:delta-infinity) (cat:delta-infinity)))
(h (cat:h ez)) (h (cat:h ez))
(gf (cat:cmps (cat:g ez) (cat:f ez))) (gf (cat:cmps (cat:g ez) (cat:f ez)))
(r (cat:hmtp-vrtc-cobar-intr h gf))) (r (cat:hmtp-vrtc-cobar-intr h gf)))
(funcall r 3 (cat:allp 1 (cat:crpr 0 7 0 7) (funcall r 3 (cat:allp 1 (cat:crpr 0 7 0 7)
1 (cat:crpr 0 14 0 14) 1 (cat:crpr 0 14 0 14)
1 (cat:crpr 0 14 0 14))))) 1 (cat:crpr 0 14 0 14)))))
#| #|
(test rdct (test rdct
(cat:cat-init) (cat:cat-init)
(let* ((tcc (cat:build-chcm (let* ((tcc (cat:build-chcm
:cmpr #'cat:s-cmpr :cmpr #'cat:s-cmpr
:basis #'(lambda (degr) '(a b c d)) :basis #'(lambda (degr) '(a b c d))
:bsgn 'd :bsgn 'd
:intr-dffr #'(lambda (degr gnrt) :intr-dffr #'(lambda (degr gnrt)
(ecase gnrt (ecase gnrt
(a (cat:cmbn (1- degr) 1 'b 1 'd)) (a (cat:cmbn (1- degr) 1 'b 1 'd))
((b d) (cat:cmbn (1- degr))) ((b d) (cat:cmbn (1- degr)))
(c (cat:cmbn (1- degr) 1 'd)))) (c (cat:cmbn (1- degr) 1 'd))))
:strt :gnrt :strt :gnrt
:orgn '(tcc))) :orgn '(tcc)))
(bcc (cat:build-chcm (bcc (cat:build-chcm
:cmpr #'cat:s-cmpr :cmpr #'cat:s-cmpr
:basis #'(lambda (degr) '(c d)) :basis #'(lambda (degr) '(c d))
:bsgn 'd :bsgn 'd
:intr-dffr #'(lambda (degr gnrt) :intr-dffr #'(lambda (degr gnrt)
(ecase gnrt (ecase gnrt
(d (cat:cmbn (1- degr))) (d (cat:cmbn (1- degr)))
(c (cat:cmbn (1- degr) 1 'd)))) (c (cat:cmbn (1- degr) 1 'd))))
:strt :gnrt :strt :gnrt
:orgn '(bcc))) :orgn '(bcc)))
(f (cat:build-mrph :sorc tcc :trgt bcc :degr 0 (f (cat:build-mrph :sorc tcc :trgt bcc :degr 0
:intr #'(lambda (degr gnrt) :intr #'(lambda (degr gnrt)
(ecase gnrt (ecase gnrt
(a (cat:cmbn degr 1 'c 1 'd)) (a (cat:cmbn degr 1 'c 1 'd))
(b (cat:cmbn degr)) (b (cat:cmbn degr))
((c d) (cat:cmbn degr 1 gnrt)))) ((c d) (cat:cmbn degr 1 gnrt))))
:strt :gnrt :orgn '(f))) :strt :gnrt :orgn '(f)))
(g (cat:build-mrph :sorc bcc :trgt tcc :degr 0 (g (cat:build-mrph :sorc bcc :trgt tcc :degr 0
:intr #'identity :strt :cmbn :orgn '(g))) :intr #'identity :strt :cmbn :orgn '(g)))
(h (cat:build-mrph :sorc tcc :trgt tcc :degr +1 (h (cat:build-mrph :sorc tcc :trgt tcc :degr +1
:intr #'(lambda (degr gnrt) :intr #'(lambda (degr gnrt)
(ecase gnrt (ecase gnrt
((a b) (cat:cmbn (1+ degr) 1 'a ((a b) (cat:cmbn (1+ degr) 1 'a
-1 'b -1 'c -1 'b -1 'c
-1 'd)) -1 'd))
((c d) (cat:cmbn (1+ degr))))) ((c d) (cat:cmbn (1+ degr)))))
:strt :gnrt :orgn '(h))) :strt :gnrt :orgn '(h)))
(rdct (cat:build-rdct :f f :g g :h h :orgn '(rdct))) (rdct (cat:build-rdct :f f :g g :h h :orgn '(rdct)))
cobar) cobar)
(cat:tcc rdct 3 'a) (cat:tcc rdct 3 'a)
(cat:g rdct (cat:f rdct 3 'a)) (cat:g rdct (cat:f rdct 3 'a))
(cat:h rdct 3 'a) (cat:h rdct 3 'a)
(setf cobar (cat:vrtc-cobar rdct)) (setf cobar (cat:vrtc-cobar rdct))
(cat:pre-check-rdct cobar) (cat:pre-check-rdct cobar)
(aleat-tc) (aleat-tc)
;;(aleat-bc) ;;(aleat-bc)
;;(loop (c)) ;;(loop (c))
;; degrees >= 15 is possible => error. ;; degrees >= 15 is possible => error.
)) ))
|# |#
#| #|
(cat-init) (cat-init)
(setf tcc (build-chcm (setf tcc (build-chcm
:cmpr #'s-cmpr :cmpr #'s-cmpr
:basis #'(lambda (degr) '(a b c d)) :basis #'(lambda (degr) '(a b c d))
:bsgn 'd :bsgn 'd
:intr-dffr #'(lambda (degr gnrt) :intr-dffr #'(lambda (degr gnrt)
(ecase gnrt (ecase gnrt
(a (cmbn (1- degr) 1 'b 1 'd)) (a (cmbn (1- degr) 1 'b 1 'd))
((b d) (cmbn (1- degr))) ((b d) (cmbn (1- degr)))
(c (cmbn (1- degr) 1 'd)))) (c (cmbn (1- degr) 1 'd))))
:strt :gnrt :strt :gnrt
:orgn '(tcc))) :orgn '(tcc)))
(setf bcc (build-chcm (setf bcc (build-chcm
:cmpr #'s-cmpr :cmpr #'s-cmpr
:basis #'(lambda (degr) '(c d)) :basis #'(lambda (degr) '(c d))
:bsgn 'd :bsgn 'd
:intr-dffr #'(lambda (degr gnrt) :intr-dffr #'(lambda (degr gnrt)
(ecase gnrt (ecase gnrt
(d (cmbn (1- degr))) (d (cmbn (1- degr)))
(c (cmbn (1- degr) 1 'd)))) (c (cmbn (1- degr) 1 'd))))
:strt :gnrt :strt :gnrt
:orgn '(bcc))) :orgn '(bcc)))
(setf f (build-mrph :sorc tcc :trgt bcc :degr 0 (setf f (build-mrph :sorc tcc :trgt bcc :degr 0
:intr #'(lambda (degr gnrt) :intr #'(lambda (degr gnrt)
(ecase gnrt (ecase gnrt
(a (cmbn degr 1 'c 1 'd)) (a (cmbn degr 1 'c 1 'd))
(b (cmbn degr)) (b (cmbn degr))
((c d) (cmbn degr 1 gnrt)))) ((c d) (cmbn degr 1 gnrt))))
:strt :gnrt :orgn '(f))) :strt :gnrt :orgn '(f)))
(setf g (build-mrph :sorc bcc :trgt tcc :degr 0 (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 (setf h (build-mrph :sorc tcc :trgt tcc :degr +1
:intr #'(lambda (degr gnrt) :intr #'(lambda (degr gnrt)
(ecase gnrt (ecase gnrt
((a b) (cmbn (1+ degr) 1 'a -1 'b -1 'c -1 'd)) ((a b) (cmbn (1+ degr) 1 'a -1 'b -1 'c -1 'd))
((c d) (cmbn (1+ degr))))) ((c d) (cmbn (1+ degr)))))
:strt :gnrt :orgn '(h))) :strt :gnrt :orgn '(h)))
(setf rdct (build-rdct :f f :g g :h h :orgn '(rdct))) (setf rdct (build-rdct :f f :g g :h h :orgn '(rdct)))
(tcc rdct 3 'a) (tcc rdct 3 'a)
(g rdct (f rdct 3 'a)) (g rdct (f rdct 3 'a))
@ -262,7 +263,7 @@
(do ((tdegr 0 (+ tdegr degr)) (do ((tdegr 0 (+ tdegr degr))
(degr (1+ (random 4)) (1+ (random 4))) (degr (1+ (random 4)) (1+ (random 4)))
(gnrt (intern (coerce (vector (+ 65 (random 4))) 'string)) (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))) (rslt nil (cons (cbgn degr gnrt) rslt)))
((> tdegr 10) (setf *tc* (cmbn tdegr 1 (make-allp :list rslt)))))) ((> tdegr 10) (setf *tc* (cmbn tdegr 1 (make-allp :list rslt))))))
(aleat-tc) (aleat-tc)
@ -270,7 +271,7 @@
(do ((tdegr 0 (+ tdegr degr)) (do ((tdegr 0 (+ tdegr degr))
(degr (1+ (random 4)) (1+ (random 4))) (degr (1+ (random 4)) (1+ (random 4)))
(gnrt (intern (coerce (vector (+ 67 (random 2))) 'string)) (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))) (rslt nil (cons (cbgn degr gnrt) rslt)))
((> tdegr 10) (setf *bc* (cmbn tdegr 1 (make-allp :list rslt)))))) ((> tdegr 10) (setf *bc* (cmbn tdegr 1 (make-allp :list rslt))))))
(aleat-bc) (aleat-bc)
@ -286,6 +287,6 @@
(test left-hmeq (test left-hmeq
(cat:cat-init) (cat:cat-init)
(let* ((h (cat:left-hmeq (cat:sphere 3))) (let* ((h (cat:left-hmeq (cat:sphere 3)))
(c (cat:cobar h))) (c (cat:cobar h)))
(inspect c))) (inspect c)))
|# |#

511
test/combinations-test.lisp
View File

@ -1,324 +1,325 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
(in-suite :kenzo) (in-suite :kenzo)
(test f-cmpr (test f-cmpr
(is (equal (cat:f-cmpr 1 2) :less)) (is (equal (cat:f-cmpr 1 2) :less))
(is (equal (cat:f-cmpr 2 2) :equal)) (is (equal (cat:f-cmpr 2 2) :equal))
(is (equal (cat:f-cmpr 3 2) :greater)) (is (equal (cat:f-cmpr 3 2) :greater))
(is (equal (cat:f-cmpr 123 789) :less)) (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 3)) :less))
(is (equal (cat:maplexico #'cat:f-cmpr '(1 2 3) '(1 1)) :greater)) (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) '(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 0) '(1 1)) :greater))
(is (equal (cat:maplexico #'cat:f-cmpr '(1 1) '(1 1)) :equal)) (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:maplexico #'cat:f-cmpr nil nil) :equal)))
(test l-cmpr (test l-cmpr
(is (equal (cat:l-cmpr nil nil) :equal)) (is (equal (cat:l-cmpr nil nil) :equal))
(is (equal (cat:l-cmpr nil '(1)) :less)) (is (equal (cat:l-cmpr nil '(1)) :less))
(is (equal (cat:l-cmpr '(1) nil) :greater)) (is (equal (cat:l-cmpr '(1) nil) :greater))
(is (equal (cat:l-cmpr '(a) '(a)) :equal)) (is (equal (cat:l-cmpr '(a) '(a)) :equal))
(is (equal (cat:l-cmpr '(a) '(1)) :greater)) (is (equal (cat:l-cmpr '(a) '(1)) :greater))
(is (equal (cat:l-cmpr '(1) '(a)) :less)) (is (equal (cat:l-cmpr '(1) '(a)) :less))
(is (equal (cat:l-cmpr '(1) '(1)) :equal)) (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) '(1 1)) :greater))
(is (equal (cat:l-cmpr '(1 a b) '(1 a)) :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 '(1 a) '(1 a b)) :less)))
(test s-cmpr (test s-cmpr
(is (equal (cat:s-cmpr 'a 'b) :less)) (is (equal (cat:s-cmpr 'a 'b) :less))
(is (equal (cat:s-cmpr 'b 'b) :equal)) (is (equal (cat:s-cmpr 'b 'b) :equal))
(is (equal (cat:s-cmpr 'c 'b) :greater)) (is (equal (cat:s-cmpr 'c 'b) :greater))
(is (equal (cat:s-cmpr 'circulation 'circular) :greater)) (is (equal (cat:s-cmpr 'circulation 'circular) :greater))
(is (equal (cat:s-cmpr 'qwerty 'qwerty) :equal))) (is (equal (cat:s-cmpr 'qwerty 'qwerty) :equal)))
(test cmbn (test cmbn
(let ((comb (cat:cmbn 2))) (let ((comb (cat:cmbn 2)))
(is (equal (cat:cmbn-degr comb) 2)) (is (equal (cat:cmbn-degr comb) 2))
(is (equal (cat:cmbn-list comb) nil))) (is (equal (cat:cmbn-list comb) nil)))
(let ((comb (cat:cmbn 2 2 'a))) (let ((comb (cat:cmbn 2 2 'a)))
(is (equal (cat:cmbn-degr comb) 2)) (is (equal (cat:cmbn-degr comb) 2))
(is (equal (cat:cmbn-list comb) '((2 . a))))) (is (equal (cat:cmbn-list comb) '((2 . a)))))
(let ((comb (cat:cmbn 2 'a))) (let ((comb (cat:cmbn 2 'a)))
(is (equal (cat:cmbn-degr comb) 2)) (is (equal (cat:cmbn-degr comb) 2))
(is (equal (cat:cmbn-list comb) '((a))))) (is (equal (cat:cmbn-list comb) '((a)))))
(let ((comb (cat:cmbn 2 2 'a -3 'b))) (let ((comb (cat:cmbn 2 2 'a -3 'b)))
(is (equal (cat:cmbn-degr comb) 2)) (is (equal (cat:cmbn-degr comb) 2))
(is (equal (cat:cmbn-list comb) '((2 . a) (-3 . b))))) (is (equal (cat:cmbn-list comb) '((2 . a) (-3 . b)))))
(let ((comb (cat:term-cmbn 3 -5 'a))) (let ((comb (cat:term-cmbn 3 -5 'a)))
(is (equal (cat:cmbn-degr comb) 3)) (is (equal (cat:cmbn-degr comb) 3))
(is (equal (cat:cmbn-list comb) '((-5 . a)))))) (is (equal (cat:cmbn-list comb) '((-5 . a))))))
(test zero-cmbn (test zero-cmbn
(let ((comb (cat:zero-cmbn 3))) (let ((comb (cat:zero-cmbn 3)))
(is (equal (cat:cmbn-degr comb) 3)) (is (equal (cat:cmbn-degr comb) 3))
(is (equal (cat:cmbn-list comb) nil))) (is (equal (cat:cmbn-list comb) nil)))
(let ((comb (cat:zero-intr-dffr (cat:cmbn 2)))) (let ((comb (cat:zero-intr-dffr (cat:cmbn 2))))
(is (equal (cat:cmbn-degr comb) 1)) (is (equal (cat:cmbn-degr comb) 1))
(is (equal (cat:cmbn-list comb) nil))) (is (equal (cat:cmbn-list comb) nil)))
(is (null (cat:cmbn-non-zero-p (cat:cmbn 0)))) (is (null (cat:cmbn-non-zero-p (cat:cmbn 0))))
(is (cat:cmbn-non-zero-p (cat:cmbn 0 1 'a))) (is (cat:cmbn-non-zero-p (cat:cmbn 0 1 'a)))
(is (cat:cmbn-zero-p (cat:cmbn 0))) (is (cat:cmbn-zero-p (cat:cmbn 0)))
(is (null (cat:cmbn-zero-p (cat:cmbn 0 1 'a))))) (is (null (cat:cmbn-zero-p (cat:cmbn 0 1 'a)))))
(test cmbn-opps (test cmbn-opps
(let* ((comb (cat:cmbn 0 1 'a -2 'b)) (let* ((comb (cat:cmbn 0 1 'a -2 'b))
(comb1 (cat:cmbn-opps comb))) (comb1 (cat:cmbn-opps comb)))
(is (equal (cat:cmbn-degr comb) 0)) (is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((1 . a) (-2 . b)))) (is (equal (cat:cmbn-list comb) '((1 . a) (-2 . b))))
(is (equal (cat:cmbn-degr comb1) 0)) (is (equal (cat:cmbn-degr comb1) 0))
(is (equal (cat:cmbn-list comb1) '((-1 . a) (2 . b)))))) (is (equal (cat:cmbn-list comb1) '((-1 . a) (2 . b))))))
(test n-cmbn (test n-cmbn
(let* ((comb (cat:cmbn 2 3 'a)) (let* ((comb (cat:cmbn 2 3 'a))
(comb1 (cat:n-cmbn 1 comb)) (comb1 (cat:n-cmbn 1 comb))
(comb2 (cat:n-cmbn -1 comb)) (comb2 (cat:n-cmbn -1 comb))
(comb3 (cat:n-cmbn -3 comb))) (comb3 (cat:n-cmbn -3 comb)))
(is (eq comb comb1)) (is (eq comb comb1))
(is (equal (cat:cmbn-degr comb2) 2)) (is (equal (cat:cmbn-degr comb2) 2))
(is (equal (cat:cmbn-list comb2) '((-3 . a)))) (is (equal (cat:cmbn-list comb2) '((-3 . a))))
(is (equal (cat:cmbn-degr comb3) 2)) (is (equal (cat:cmbn-degr comb3) 2))
(is (equal (cat:cmbn-list comb3) '((-9 . a)))))) (is (equal (cat:cmbn-list comb3) '((-9 . a))))))
(test 2cmbn-add (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)))) (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-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((1 . a))))) (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)))) (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-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((3 . a))))) (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)))) (let ((comb (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0 1 'a) (cat:cmbn 0 -1 'a))))
(is (cat:cmbn-zero-p comb))) (is (cat:cmbn-zero-p comb)))
(let ((comb (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0 1 'a) (cat:cmbn 0 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-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((1 . a) (2 . b))))) (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) (let ((comb (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0 1 'a -2 'b)
(cat:cmbn 0 2 'b)))) (cat:cmbn 0 2 'b))))
(is (equal (cat:cmbn-degr comb) 0)) (is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((1 . a))))) (is (equal (cat:cmbn-list comb) '((1 . a)))))
(let ((comb (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0 2 'b) (let ((comb (cat:2cmbn-add #'cat:s-cmpr (cat:cmbn 0 2 'b)
(cat:cmbn 0 1 'a 3 'c)))) (cat:cmbn 0 1 'a 3 'c))))
(is (equal (cat:cmbn-degr comb) 0)) (is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((1 . a) (2 . b) (3 . c)))))) (is (equal (cat:cmbn-list comb) '((1 . a) (2 . b) (3 . c))))))
(test 2cmbn-sbtr (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)))) (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-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((-1 . a))))) (is (equal (cat:cmbn-list comb) '((-1 . a)))))
(let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0 2 'b) (cat:cmbn 0)))) (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-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((2 . b))))) (is (equal (cat:cmbn-list comb) '((2 . b)))))
(is (cat:cmbn-zero-p (cat:2cmbn-sbtr #'cat:s-cmpr (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)))) (cat:cmbn 0 3 'b))))
(let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0 3 'b) (cat:cmbn 0 4 '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-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((-1 . b))))) (is (equal (cat:cmbn-list comb) '((-1 . b)))))
(let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr (let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr
(cat:cmbn 0 1 'a 2 'c 2 'd 3 'g) (cat:cmbn 0 1 'a 2 'c 2 'd 3 'g)
(cat:cmbn 0 1 'c -2 'd 4 'f -3 'g 4 'h)))) (cat:cmbn 0 1 'c -2 'd 4 'f -3 'g 4 'h))))
(is (equal (cat:cmbn-degr comb) 0)) (is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((1 . a) (1 . c) (4 . d) (-4 . f) (6 . g) (is (equal (cat:cmbn-list comb) '((1 . a) (1 . c) (4 . d) (-4 . f) (6 . g)
(-4 . h))))) (-4 . h)))))
(let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr (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 'c -2 'd 4 'f -3 'g 4 'h)
(cat:cmbn 0 1 'a 2 'c 2 'd 3 'g)))) (cat:cmbn 0 1 'a 2 'c 2 'd 3 'g))))
(is (equal (cat:cmbn-degr comb) 0)) (is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((-1 . a) (-1 . c) (-4 . d) (4 . f) (is (equal (cat:cmbn-list comb) '((-1 . a) (-1 . c) (-4 . d) (4 . f)
(-6 . g) (4 . h))))) (-6 . g) (4 . h)))))
(let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr (let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr
(cat:cmbn 0 1 'c -2 'd 4 'f -3 'g) (cat:cmbn 0 1 'c -2 'd 4 'f -3 'g)
(cat:cmbn 0 1 'a 2 'c 2 'd 3 'g)))) (cat:cmbn 0 1 'a 2 'c 2 'd 3 'g))))
(is (equal (cat:cmbn-degr comb) 0)) (is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((-1 . a) (-1 . c) (-4 . d) (4 . f) (is (equal (cat:cmbn-list comb) '((-1 . a) (-1 . c) (-4 . d) (4 . f)
(-6 . g))))) (-6 . g)))))
(let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0 1 'b 2 'a) (let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0 1 'b 2 'a)
(cat:cmbn 0 1 'a 1 'b)))) (cat:cmbn 0 1 'a 1 'b))))
(is (equal (cat:cmbn-degr comb) 0)) (is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((-1 . a) (2 . a))))) (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) (let ((comb (cat:2cmbn-sbtr #'cat:s-cmpr (cat:cmbn 0 1 'b 2 'c)
(cat:cmbn 0 1 'a 1 'b)))) (cat:cmbn 0 1 'a 1 'b))))
(is (equal (cat:cmbn-degr comb) 0)) (is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((-1 . a) (2 . c)))))) (is (equal (cat:cmbn-list comb) '((-1 . a) (2 . c))))))
(test 2n-2cmbn (test 2n-2cmbn
(signals simple-error (cat:2n-2cmbn #'cat:s-cmpr 3 (cat:cmbn 0) (signals simple-error (cat:2n-2cmbn #'cat:s-cmpr 3 (cat:cmbn 0)
4 (cat:cmbn 1))) 4 (cat:cmbn 1)))
(is (cat:cmbn-zero-p (cat:2n-2cmbn #'cat:s-cmpr 3 (cat:cmbn 0) (is (cat:cmbn-zero-p (cat:2n-2cmbn #'cat:s-cmpr 3 (cat:cmbn 0)
4 (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)))) (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-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((3 . a))))) (is (equal (cat:cmbn-list comb) '((3 . a)))))
(let ((comb (cat:2n-2cmbn #'cat:s-cmpr (let ((comb (cat:2n-2cmbn #'cat:s-cmpr
3 (cat:cmbn 0 1 'a 2 'b 3 'c) 3 (cat:cmbn 0 1 'a 2 'b 3 'c)
1 (cat:cmbn 0 -3 'a 2 'b 4 'd)))) 1 (cat:cmbn 0 -3 'a 2 'b 4 'd))))
(is (equal (cat:cmbn-degr comb) 0)) (is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((8 . b) (9 . c) (4 . d))))) (is (equal (cat:cmbn-list comb) '((8 . b) (9 . c) (4 . d)))))
(let ((comb (cat:2n-2cmbn #'cat:s-cmpr (let ((comb (cat:2n-2cmbn #'cat:s-cmpr
3 (cat:cmbn 0 -3 'a 2 'b 4 'd) 3 (cat:cmbn 0 -3 'a 2 'b 4 'd)
1 (cat:cmbn 0 1 'a 2 'b 3 'c)))) 1 (cat:cmbn 0 1 'a 2 'b 3 'c))))
(is (equal (cat:cmbn-degr comb) 0)) (is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((-8 . a) (8 . b) (3 . c) (12 . d))))) (is (equal (cat:cmbn-list comb) '((-8 . a) (8 . b) (3 . c) (12 . d)))))
(let ((comb (cat:2n-2cmbn #'cat:s-cmpr (let ((comb (cat:2n-2cmbn #'cat:s-cmpr
1 (cat:cmbn 0 1 'a 2 'b 3 'c) 1 (cat:cmbn 0 1 'a 2 'b 3 'c)
1 (cat:cmbn 0 -3 'a 2 'b 4 'd)))) 1 (cat:cmbn 0 -3 'a 2 'b 4 'd))))
(is (equal (cat:cmbn-degr comb) 0)) (is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((-2 . a) (4 . b) (3 . c) (4 . d))))) (is (equal (cat:cmbn-list comb) '((-2 . a) (4 . b) (3 . c) (4 . d)))))
(let ((comb (cat:2n-2cmbn #'cat:s-cmpr (let ((comb (cat:2n-2cmbn #'cat:s-cmpr
1 (cat:cmbn 0 -3 'a 2 'b 4 'd) 1 (cat:cmbn 0 -3 'a 2 'b 4 'd)
1 (cat:cmbn 0 1 'a 2 'b 3 'c)))) 1 (cat:cmbn 0 1 'a 2 'b 3 'c))))
(is (equal (cat:cmbn-degr comb) 0)) (is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((-2 . a) (4 . b) (3 . c) (4 . d))))) (is (equal (cat:cmbn-list comb) '((-2 . a) (4 . b) (3 . c) (4 . d)))))
(let ((comb (cat:2n-2cmbn #'cat:s-cmpr (let ((comb (cat:2n-2cmbn #'cat:s-cmpr
1 (cat:cmbn 0 -3 'a 2 'b 4 'd) 1 (cat:cmbn 0 -3 'a 2 'b 4 'd)
3 (cat:cmbn 0 1 'a 2 'b 3 'c)))) 3 (cat:cmbn 0 1 'a 2 'b 3 'c))))
(is (equal (cat:cmbn-degr comb) 0)) (is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((8 . b) (9 . c) (4 . d)))))) (is (equal (cat:cmbn-list comb) '((8 . b) (9 . c) (4 . d))))))
(test cmbn-cmbn (test cmbn-cmbn
(let* ((cons (cons 3 (cat:cmbn 0 4 'a))) (let* ((cons (cons 3 (cat:cmbn 0 4 'a)))
(comb (cat:cmbn-cmbn #'cat:s-cmpr (comb (cat:cmbn-cmbn #'cat:s-cmpr
(make-list 5 :initial-element cons)))) (make-list 5 :initial-element cons))))
(is (equal (cat:cmbn-degr comb) 0)) (is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) '((60 . a))))) (is (equal (cat:cmbn-list comb) '((60 . a)))))
(let* ((cffc '(12 24 36 48 60 72 84 96 108 120)) (let* ((cffc '(12 24 36 48 60 72 84 96 108 120))
(cons (cons 3 (cat:cmbn 0 4 'a)))) (cons (cons 3 (cat:cmbn 0 4 'a))))
(dotimes (i 10) (dotimes (i 10)
(is (equal (nth i cffc) (is (equal (nth i cffc)
(cat:cffc (first (cat:cmbn-list (cat:cffc (first (cat:cmbn-list
(cat:cmbn-cmbn #'cat:s-cmpr (cat:cmbn-cmbn #'cat:s-cmpr
(make-list (1+ i) (make-list (1+ i)
:initial-element :initial-element
cons)))))))))) cons))))))))))
(test nterm-add (test nterm-add
(let ((comb (cat:nterm-add #'cat:s-cmpr 11))) (let ((comb (cat:nterm-add #'cat:s-cmpr 11)))
(is (equal (cat:cmbn-degr comb) 11)) (is (equal (cat:cmbn-degr comb) 11))
(is (equal (cat:cmbn-list comb) nil))) (is (equal (cat:cmbn-list comb) nil)))
(let ((comb (cat:nterm-add #'cat:s-cmpr 11 (cat:term 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-degr comb) 11))
(is (equal (cat:cmbn-list comb) '((1 . a))))) (is (equal (cat:cmbn-list comb) '((1 . a)))))
(let ((comb (cat:nterm-add #'cat:s-cmpr 11 (cat:term 1 'a) (let ((comb (cat:nterm-add #'cat:s-cmpr 11 (cat:term 1 'a)
(cat:term 2 'b)))) (cat:term 2 'b))))
(is (equal (cat:cmbn-degr comb) 11)) (is (equal (cat:cmbn-degr comb) 11))
(is (equal (cat:cmbn-list comb) '((1 . a) (2 . b))))) (is (equal (cat:cmbn-list comb) '((1 . a) (2 . b)))))
(let ((comb (cat:nterm-add #'cat:s-cmpr 11 (cat:term 1 '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 'a) (cat:term 3 'aa)
(cat:term -2 'aa) (cat:term -2 'a) (cat:term -2 'aa) (cat:term -2 'a)
(cat:term 4 'aa) (cat:term 5 'c)))) (cat:term 4 'aa) (cat:term 5 'c))))
(is (equal (cat:cmbn-degr comb) 11)) (is (equal (cat:cmbn-degr comb) 11))
(is (equal (cat:cmbn-list comb) '((5 . aa) (1 . b) (5 . c)))))) (is (equal (cat:cmbn-list comb) '((5 . aa) (1 . b) (5 . c))))))
(test ncmbn-add (test ncmbn-add
(let* ((c (cat:cmbn 3 4 'a)) (let* ((c (cat:cmbn 3 4 'a))
(comb (cat:ncmbn-add #'cat:s-cmpr c c c c c))) (comb (cat:ncmbn-add #'cat:s-cmpr c c c c c)))
(is (equal (cat:cmbn-degr comb) 3)) (is (equal (cat:cmbn-degr comb) 3))
(is (equal (cat:cmbn-list comb) '((20 . a)))))) (is (equal (cat:cmbn-list comb) '((20 . a))))))
(test dstr-add-term-to-cmbn (test dstr-add-term-to-cmbn
(let* ((c (cat:zero-cmbn 10)) (let* ((c (cat:zero-cmbn 10))
(comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr 3 'f c))) (comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr 3 'f c)))
(is (eq comb c)) (is (eq comb c))
(is (equal (cat:cmbn-degr comb) 10)) (is (equal (cat:cmbn-degr comb) 10))
(is (equal (cat:cmbn-list comb) '((3 . f)))) (is (equal (cat:cmbn-list comb) '((3 . f))))
(setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr 3 'g c)) (setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr 3 'g c))
(is (eq comb c)) (is (eq comb c))
(is (equal (cat:cmbn-degr comb) 10)) (is (equal (cat:cmbn-degr comb) 10))
(is (equal (cat:cmbn-list comb) '((3 . f) (3 . g)))) (is (equal (cat:cmbn-list comb) '((3 . f) (3 . g))))
(setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr 3 'a c)) (setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr 3 'a c))
(is (eq comb c)) (is (eq comb c))
(is (equal (cat:cmbn-degr comb) 10)) (is (equal (cat:cmbn-degr comb) 10))
(is (equal (cat:cmbn-list comb) '((3 . a) (3 . f) (3 . g)))) (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)) (setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr 3 'd c))
(is (eq comb c)) (is (eq comb c))
(is (equal (cat:cmbn-degr comb) 10)) (is (equal (cat:cmbn-degr comb) 10))
(is (equal (cat:cmbn-list comb) '((3 . a) (3 . d) (3 . f) (3 . g)))) (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)) (setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr -3 'd c))
(is (eq comb c)) (is (eq comb c))
(is (equal (cat:cmbn-degr comb) 10)) (is (equal (cat:cmbn-degr comb) 10))
(is (equal (cat:cmbn-list comb) '((3 . a) (3 . f) (3 . g)))) (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)) (setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr -2 'a c))
(is (eq comb c)) (is (eq comb c))
(is (equal (cat:cmbn-degr comb) 10)) (is (equal (cat:cmbn-degr comb) 10))
(is (equal (cat:cmbn-list comb) '((1 . a) (3 . f) (3 . g)))) (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)) (setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr -1 'a c))
(is (eq comb c)) (is (eq comb c))
(is (equal (cat:cmbn-degr comb) 10)) (is (equal (cat:cmbn-degr comb) 10))
(is (equal (cat:cmbn-list comb) '((3 . f) (3 . g)))) (is (equal (cat:cmbn-list comb) '((3 . f) (3 . g))))
(setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr -3 'g c)) (setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr -3 'g c))
(is (eq comb c)) (is (eq comb c))
(is (equal (cat:cmbn-degr comb) 10)) (is (equal (cat:cmbn-degr comb) 10))
(is (equal (cat:cmbn-list comb) '((3 . f)))) (is (equal (cat:cmbn-list comb) '((3 . f))))
(setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr -3 'f c)) (setq comb (cat:dstr-add-term-to-cmbn #'cat:s-cmpr -3 'f c))
(is (eq comb c)) (is (eq comb c))
(is (equal (cat:cmbn-degr comb) 10)) (is (equal (cat:cmbn-degr comb) 10))
(is (equal (cat:cmbn-list comb) nil)))) (is (equal (cat:cmbn-list comb) nil))))
(test uvwz (test uvwz
(let* ((comb1 (cat:cmbn 1 1 'u 2 'v 3 'w 4 'z)) (let* ((comb1 (cat:cmbn 1 1 'u 2 'v 3 'w 4 'z))
(comb1-list (cat:cmbn-list comb1)) (comb1-list (cat:cmbn-list comb1))
(term3 (third comb1-list)) (term3 (third comb1-list))
(mcomb1 (cat:cmbn-opps comb1)) (mcomb1 (cat:cmbn-opps comb1))
(comb2 (cat:n-cmbn 10 comb1)) (comb2 (cat:n-cmbn 10 comb1))
(comb12 (cat:2cmbn-add #'cat:s-cmpr comb1 comb2)) (comb12 (cat:2cmbn-add #'cat:s-cmpr comb1 comb2))
(comb112 (cat:2cmbn-sbtr #'cat:s-cmpr comb1 comb12)) (comb112 (cat:2cmbn-sbtr #'cat:s-cmpr comb1 comb12))
(comb12n (cat:ncmbn-add #'cat:s-cmpr comb1 comb2 comb1 comb2 (comb12n (cat:ncmbn-add #'cat:s-cmpr comb1 comb2 comb1 comb2
comb1 comb2 comb1 comb2 comb1 comb2))) comb1 comb2 comb1 comb2 comb1 comb2)))
(is (cat:cmbn-non-zero-p comb1)) (is (cat:cmbn-non-zero-p comb1))
(is (equal comb1-list '((1 . u) (2 . v) (3 . w) (4 . z)))) (is (equal comb1-list '((1 . u) (2 . v) (3 . w) (4 . z))))
(is (equal (cat:cffc term3) 3)) (is (equal (cat:cffc term3) 3))
(is (equal (cat:gnrt term3) 'w)) (is (equal (cat:gnrt term3) 'w))
(is (equal (cat:cmbn-degr comb1) (cat:cmbn-degr mcomb1))) (is (equal (cat:cmbn-degr comb1) (cat:cmbn-degr mcomb1)))
(is (equal (cat:cmbn-list mcomb1) '((-1 . u) (-2 . v) (is (equal (cat:cmbn-list mcomb1) '((-1 . u) (-2 . v)
(-3 . w) (-4 . z)))) (-3 . w) (-4 . z))))
(is (equal (cat:cmbn-degr comb1) (cat:cmbn-degr comb2))) (is (equal (cat:cmbn-degr comb1) (cat:cmbn-degr comb2)))
(is (equal (cat:cmbn-list comb2) '((10 . u) (20 . v) (is (equal (cat:cmbn-list comb2) '((10 . u) (20 . v)
(30 . w) (40 . z)))) (30 . w) (40 . z))))
(is (equal (cat:cmbn-degr comb1) (cat:cmbn-degr comb12))) (is (equal (cat:cmbn-degr comb1) (cat:cmbn-degr comb12)))
(is (equal (cat:cmbn-list comb12) '((11 . u) (22 . v) (is (equal (cat:cmbn-list comb12) '((11 . u) (22 . v)
(33 . w) (44 . z)))) (33 . w) (44 . z))))
(is (equal (cat:cmbn-degr comb1) (cat:cmbn-degr comb112))) (is (equal (cat:cmbn-degr comb1) (cat:cmbn-degr comb112)))
(is (equal (cat:cmbn-list comb112) '((-10 . u) (-20 . v) (is (equal (cat:cmbn-list comb112) '((-10 . u) (-20 . v)
(-30 . w) (-40 . z)))) (-30 . w) (-40 . z))))
(is (equal (cat:cmbn-degr comb1) (cat:cmbn-degr comb12n))) (is (equal (cat:cmbn-degr comb1) (cat:cmbn-degr comb12n)))
(is (equal (cat:cmbn-list comb12n) '((55 . u) (110 . v) (is (equal (cat:cmbn-list comb12n) '((55 . u) (110 . v)
(165 . w) (220 . z)))))) (165 . w) (220 . z))))))

33
test/common.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -83,10 +84,10 @@
(defun make-rdct (tdmns bdmns) (defun make-rdct (tdmns bdmns)
(let ((rdct (cat:build-rdct (let ((rdct (cat:build-rdct
:f (make-f tdmns bdmns) :f (make-f tdmns bdmns)
:g (make-g tdmns bdmns) :g (make-g tdmns bdmns)
:h (make-h tdmns bdmns) :h (make-h tdmns bdmns)
:orgn `(reduction delta ,tdmns ,bdmns)))) :orgn `(reduction delta ,tdmns ,bdmns))))
rdct)) rdct))
(defun cdelta1 (dmns) (defun cdelta1 (dmns)
@ -151,10 +152,10 @@
(defun make-rdct1 (tdmns bdmns) (defun make-rdct1 (tdmns bdmns)
(let ((rdct (cat:build-rdct (let ((rdct (cat:build-rdct
:f (make-f1 tdmns bdmns) :f (make-f1 tdmns bdmns)
:g (make-g1 tdmns bdmns) :g (make-g1 tdmns bdmns)
:h (make-h1 tdmns bdmns) :h (make-h1 tdmns bdmns)
:orgn `(reduction delta ,tdmns ,bdmns)))) :orgn `(reduction delta ,tdmns ,bdmns))))
rdct)) rdct))
@ -177,7 +178,7 @@
(intern (coerce (vector (code-char (+ 65 (random 4)))) 'string))) (intern (coerce (vector (code-char (+ 65 (random 4)))) 'string)))
(rslt nil (cons (cat:brgn degr gnrt) rslt))) (rslt nil (cons (cat:brgn degr gnrt) rslt)))
((> tdegr 8) (setf cat:*tc* (cat:cmbn tdegr 1 (cat:make-abar ((> tdegr 8) (setf cat:*tc* (cat:cmbn tdegr 1 (cat:make-abar
:list rslt)))))) :list rslt))))))
(defun aleat-bc () (defun aleat-bc ()
@ -187,7 +188,7 @@
(intern (coerce (vector (code-char (+ 67 (random 2)))) 'string))) (intern (coerce (vector (code-char (+ 67 (random 2)))) 'string)))
(rslt nil (cons (cat:brgn degr gnrt) rslt))) (rslt nil (cons (cat:brgn degr gnrt) rslt)))
((> tdegr 8) (setf cat:*bc* (cat:cmbn tdegr 1 (cat:make-abar ((> tdegr 8) (setf cat:*bc* (cat:cmbn tdegr 1 (cat:make-abar
:list rslt)))))) :list rslt))))))
(defun c () (defun c ()
@ -203,12 +204,12 @@
((>= cum-degr tot-degr~) (cat:make-abar :list rslt)) ((>= cum-degr tot-degr~) (cat:make-abar :list rslt))
(setf degr (1+ (random max-degr))) (setf degr (1+ (random max-degr)))
(push (cat:brgn (1+ degr) (push (cat:brgn (1+ degr)
(let ((list (make-list degr))) (let ((list (make-list degr)))
(mapl (mapl
#'(lambda (sublist) #'(lambda (sublist)
(setf (car sublist) (- (random 21) 10))) (setf (car sublist) (- (random 21) 10)))
list) list)
list)) list))
rslt))) rslt)))

97
test/cones-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -15,20 +16,20 @@
(test cone-cmpr (test cone-cmpr
(let ((cmpr (cat:cone-cmpr #'cat:s-cmpr #'cat:f-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 :less (funcall cmpr (cat:con0 'a) (cat:con0 'b))))
(is (equal :equal (funcall cmpr (cat:con0 'b) (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 :greater (funcall cmpr (cat:con0 'b) (cat:con0 'a))))
(is (equal :less (funcall cmpr (cat:con0 'b) (cat:con1 '2)))) (is (equal :less (funcall cmpr (cat:con0 'b) (cat:con1 '2))))
(is (equal :greater (funcall cmpr (cat:con1 '2) (cat:con0 'b)))) (is (equal :greater (funcall cmpr (cat:con1 '2) (cat:con0 'b))))
(is (equal :less (funcall cmpr (cat:con1 '1) (cat:con1 '2)))) (is (equal :less (funcall cmpr (cat:con1 '1) (cat:con1 '2))))
(is (equal :equal (funcall cmpr (cat:con1 '2) (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 :greater (funcall cmpr (cat:con1 '2) (cat:con1 '1))))))
(test cone-basis (test cone-basis
(let ((basis (cat:cone-basis #'(lambda (n) (list n)) (let ((basis (cat:cone-basis #'(lambda (n) (list n))
#'(lambda (n) (list n))))) #'(lambda (n) (list n)))))
(funcall basis 4))) (funcall basis 4)))
(test term-con (test term-con
@ -54,58 +55,58 @@
(test cone-2mrph-diag-impl (test cone-2mrph-diag-impl
(let* ((mrph (cat:dffr (cat:delta 4))) (let* ((mrph (cat:dffr (cat:delta 4)))
(rslt (cat:cone-2mrph-diag-impl mrph mrph))) (rslt (cat:cone-2mrph-diag-impl mrph mrph)))
(funcall rslt (cat:cmbn 3 4 (cat:con0 15) 5 (cat:con1 7))))) (funcall rslt (cat:cmbn 3 4 (cat:con0 15) 5 (cat:con1 7)))))
(test cone-3mrph-triangle-impl (test cone-3mrph-triangle-impl
(let ((rslt (cat:cone-3mrph-triangle-impl #'cat:f-cmpr (let ((rslt (cat:cone-3mrph-triangle-impl #'cat:f-cmpr
(cat:dffr (cat:delta 4)) (cat:dffr (cat:delta 4))
(cat:dffr (cat:delta 4)) (cat:dffr (cat:delta 4))
(cat:idnt-mrph (cat:delta 4))))) (cat:idnt-mrph (cat:delta 4)))))
(funcall rslt 4 (cat:con0 '31)) (funcall rslt 4 (cat:con0 '31))
(funcall rslt 5 (cat:con1 '31)) (funcall rslt 5 (cat:con1 '31))
(funcall rslt 4 (cat:con1 '15)))) (funcall rslt 4 (cat:con1 '15))))
(test cone (test cone
(progn (progn
(cat:cat-init) (cat:cat-init)
(let* ((k (cat:k-z 1)) (let* ((k (cat:k-z 1))
(u (cat:idnt-mrph k)) (u (cat:idnt-mrph k))
(c (cat:cone u)) (c (cat:cone u))
(cone)) (cone))
(setf cat:*tc* (cat:cmbn 4 1 (cat:con0 '(1 2 3 4)))) (setf cat:*tc* (cat:cmbn 4 1 (cat:con0 '(1 2 3 4))))
(cat:? c 4 (cat:con0 '(1 2 3 4))) (cat:? c 4 (cat:con0 '(1 2 3 4)))
(cat:? c cat:*tc*) (cat:? c cat:*tc*)
(setf cone (cat:cone (cat:idnt-mrph (cat:delta 4)))) (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:cmbn 4 1 (cat:con0 '31) -1 (cat:con1 '15)))
(cat:? cone (cat:? cone
(cat:? cone (cat:cmbn 4 (cat:? cone (cat:cmbn 4
1 (cat:con0 '31) -1 (cat:con1 '15))))))) 1 (cat:con0 '31) -1 (cat:con1 '15)))))))
(test cone-2mrph-diag (test cone-2mrph-diag
(let* ((idnt (cat:idnt-mrph (cat:delta 4))) (let* ((idnt (cat:idnt-mrph (cat:delta 4)))
(cone (cat:cone idnt)) (cone (cat:cone idnt))
(ff (cat:cone-2mrph-diag cone cone idnt idnt))) (ff (cat:cone-2mrph-diag cone cone idnt idnt)))
(cat:? ff (cat:cmbn 4 1 (cat:con0 '31) 10 (cat:con1 '15))))) (cat:? ff (cat:cmbn 4 1 (cat:con0 '31) 10 (cat:con1 '15)))))
(test cone-3mrph-triangle (test cone-3mrph-triangle
(progn (progn
(cat:cat-init) (cat:cat-init)
(let* ((d (cat:delta 4)) (let* ((d (cat:delta 4))
(df (cat:dffr (cat:delta 4))) (df (cat:dffr (cat:delta 4)))
(n (cat:idnt-mrph d)) (n (cat:idnt-mrph d))
(c (cat:cone n)) (c (cat:cone n))
(z (cat:sbtr (cat:dffr c) (z (cat:sbtr (cat:dffr c)
(cat:cone-3mrph-triangle c c df (cat:cone-3mrph-triangle c c df
(cat:n-mrph -1 df) n)))) (cat:n-mrph -1 df) n))))
(cat:? z 0 (cat:con0 '1)) (cat:? z 0 (cat:con0 '1))
(cat:? z 1 (cat:con1 '1)) (cat:? z 1 (cat:con1 '1))
(cat:? z 1 (cat:con0 '3)) (cat:? z 1 (cat:con0 '3))
(cat:? z 2 (cat:con1 '3)) (cat:? z 2 (cat:con1 '3))
(cat:? z 4 (cat:con0 '31)) (cat:? z 4 (cat:con0 '31))
(cat:? z 5 (cat:con1 '31))))) (cat:? z 5 (cat:con1 '31)))))

155
test/cs-twisted-products-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -6,92 +7,92 @@
(test smgr-fibration (test smgr-fibration
(cat:cat-init) (cat:cat-init)
(let* ((k1 (cat:k-z-1)) (let* ((k1 (cat:k-z-1))
(tw (cat:smgr-fibration k1)) (tw (cat:smgr-fibration k1))
(k2 (cat:sorc tw)) (k2 (cat:sorc tw))
(tt (cat:fibration-total tw)) (tt (cat:fibration-total tw))
(gmsm (cat:crpr 0 (cat:gbar 4 0 '(10 11 12) 0 '(20 21) (gmsm (cat:crpr 0 (cat:gbar 4 0 '(10 11 12) 0 '(20 21)
0 '(30) 0 '()) 0 '(30) 0 '())
0 '(2 4 6 8))) 0 '(2 4 6 8)))
(br (cat:brown-reduction tw)) (br (cat:brown-reduction tw))
(tw-pr (cat:bcc br))) (tw-pr (cat:bcc br)))
(dotimes (i 5) (dotimes (i 5)
(print (cat:face tt i 4 gmsm))) (print (cat:face tt i 4 gmsm)))
(cat:? tw-pr 4 (cat:tnpr 4 (cat:gbar 4 0 '(1 10 100) 0 '(1000 10000) (cat:? tw-pr 4 (cat:tnpr 4 (cat:gbar 4 0 '(1 10 100) 0 '(1000 10000)
0 '(100000) 0 '()) 0 '(100000) 0 '())
0 '())))) 0 '()))))
#| #|
(test smgr-crts-contraction (test smgr-crts-contraction
(cat:cat-init) (cat:cat-init)
(let* ((chi (cat:smgr-crts-contraction (cat:k-z-1))) (let* ((chi (cat:smgr-crts-contraction (cat:k-z-1)))
(rdct (cat:build-rdct :f (cat:zero-mrph (cat:sorc chi) (rdct (cat:build-rdct :f (cat:zero-mrph (cat:sorc chi)
(cat:z-chcm)) (cat:z-chcm))
:g (cat:zero-mrph (cat:z-chcm) :g (cat:zero-mrph (cat:z-chcm)
(cat:sorc chi)) (cat:sorc chi))
:h chi))) :h chi)))
(cat:pre-check-rdct rdct) (cat:pre-check-rdct rdct)
(setf cat:*tc* (cat:cmbn 0 1 (cat:crpr 0 cat:+null-gbar+ 0 '()))) (setf cat:*tc* (cat:cmbn 0 1 (cat:crpr 0 cat:+null-gbar+ 0 '())))
(setf cat:*bc* (cat:cmbn 0 1 :z-gnrt)) (setf cat:*bc* (cat:cmbn 0 1 :z-gnrt))
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn 1 1 (cat:crpr 1 cat:+null-gbar+ 0 '(1)))) (setf cat:*tc* (cat:cmbn 1 1 (cat:crpr 1 cat:+null-gbar+ 0 '(1))))
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn 4 1 (cat:crpr 0 (cat:gbar 4 0 '(10 11 12) (setf cat:*tc* (cat:cmbn 4 1 (cat:crpr 0 (cat:gbar 4 0 '(10 11 12)
0 '(20 21) 0 '(20 21)
0 '(30) 0 '()) 0 '(30) 0 '())
0 '(2 4 6 8)))) 0 '(2 4 6 8))))
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn 3 1 (cat:crpr 0 (cat:gbar 3 0 '(10 11) (setf cat:*tc* (cat:cmbn 3 1 (cat:crpr 0 (cat:gbar 3 0 '(10 11)
0 '(20) 0 '()) 0 '(20) 0 '())
0 '(2 4 6)))) 0 '(2 4 6))))
(check-rdct))) (check-rdct)))
|# |#
#| #|
(test smgr-tnpr-contraction (test smgr-tnpr-contraction
(cat:cat-init) (cat:cat-init)
(let* ((chi (cat:smgr-tnpr-contraction (cat:k-z-1))) (let* ((chi (cat:smgr-tnpr-contraction (cat:k-z-1)))
(rdct (cat:build-rdct :f (cat:zero-mrph (cat:sorc chi) (rdct (cat:build-rdct :f (cat:zero-mrph (cat:sorc chi)
(cat:z-chcm)) (cat:z-chcm))
:g (cat:zero-mrph (cat:z-chcm) :g (cat:zero-mrph (cat:z-chcm)
(cat:sorc chi)) (cat:sorc chi))
:h chi))) :h chi)))
(cat:pre-check-rdct rdct) (cat:pre-check-rdct rdct)
(setf cat:*tc* (cat:cmbn 0 1 (cat:tnpr 0 cat:+null-gbar+ 0 '()))) (setf cat:*tc* (cat:cmbn 0 1 (cat:tnpr 0 cat:+null-gbar+ 0 '())))
(setf cat:*bc* (cat:cmbn 0 1 :z-gnrt)) (setf cat:*bc* (cat:cmbn 0 1 :z-gnrt))
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn 1 1 (cat:tnpr 0 cat:+null-gbar+ 1 '(1)))) (setf cat:*tc* (cat:cmbn 1 1 (cat:tnpr 0 cat:+null-gbar+ 1 '(1))))
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn 3 1 (cat:tnpr 0 cat:+null-gbar+ (setf cat:*tc* (cat:cmbn 3 1 (cat:tnpr 0 cat:+null-gbar+
3 '(1 10 100)))) 3 '(1 10 100))))
(cat:? chi cat:*tc*) (cat:? chi cat:*tc*)
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn 3 1 (cat:tnpr 2 (cat:gbar 2 0 '(1) 0 '()) (setf cat:*tc* (cat:cmbn 3 1 (cat:tnpr 2 (cat:gbar 2 0 '(1) 0 '())
1 '(10)))) 1 '(10))))
(cat:? chi cat:*tc*) (cat:? chi cat:*tc*)
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn 3 1 (cat:tnpr 3 (cat:gbar 3 0 '(1 10) (setf cat:*tc* (cat:cmbn 3 1 (cat:tnpr 3 (cat:gbar 3 0 '(1 10)
0 '(100) 0 '()) 0 '(100) 0 '())
0 '()))) 0 '())))
(cat:? chi cat:*tc*) (cat:? chi cat:*tc*)
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn 4 1 (cat:tnpr 0 cat:+null-gbar+ (setf cat:*tc* (cat:cmbn 4 1 (cat:tnpr 0 cat:+null-gbar+
4 '(1 10 100 1000)))) 4 '(1 10 100 1000))))
(cat:? chi cat:*tc*) (cat:? chi cat:*tc*)
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn 4 1 (cat:tnpr 2 (cat:gbar 2 0 '(1) 0 '()) (setf cat:*tc* (cat:cmbn 4 1 (cat:tnpr 2 (cat:gbar 2 0 '(1) 0 '())
2 '(10 100)))) 2 '(10 100))))
(cat:? chi cat:*tc*) (cat:? chi cat:*tc*)
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn 4 1 (cat:tnpr 3 (cat:gbar 3 0 '(1 10) (setf cat:*tc* (cat:cmbn 4 1 (cat:tnpr 3 (cat:gbar 3 0 '(1 10)
0 '(100) 0 '()) 0 '(100) 0 '())
1 '(1000)))) 1 '(1000))))
(cat:? chi cat:*tc*) (cat:? chi cat:*tc*)
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn 4 1 (cat:tnpr 4 (cat:gbar 4 0 '(1 10 100) (setf cat:*tc* (cat:cmbn 4 1 (cat:tnpr 4 (cat:gbar 4 0 '(1 10 100)
0 '(1000 10000) 0 '(1000 10000)
0 '(100000) 0 '(100000)
0 '()) 0 '())
0 '()))) 0 '())))
(cat:? chi cat:*tc*) (cat:? chi cat:*tc*)
(check-rdct))) (check-rdct)))
|# |#

93
test/delta-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -22,11 +23,11 @@
(is (equal '(0 2 4) (faces 3 '(0 2 4 6)))) (is (equal '(0 2 4) (faces 3 '(0 2 4 6))))
(dotimes (i 4) (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) (dotimes (i 4)
(print (cat:soft-delta-face i 3 (cat:d (print (cat:soft-delta-face i 3 (cat:d
(cat:dlop-ext-int '(0 2 4 6))))))) (cat:dlop-ext-int '(0 2 4 6)))))))
(test delta-bndr (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 15)))
(is (cat:cmbn-non-zero-p (cat:delta-dgnl 3 170))) (is (cat:cmbn-non-zero-p (cat:delta-dgnl 3 170)))
(is (cat:cmbn-non-zero-p (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)))) (is (cat:cmbn-non-zero-p (cat:delta-dgnl 0 64))))
@ -58,64 +59,64 @@
(test soft-delta-infinity (test soft-delta-infinity
(progn (progn
(cat:cat-init) (cat:cat-init)
(cat:cmpr (cat:soft-delta-infinity) (cat:d 2) (cat:d 4)) (cat:cmpr (cat:soft-delta-infinity) (cat:d 2) (cat:d 4))
(cat:face (cat:soft-delta-infinity) 1 2 (cat:face (cat:soft-delta-infinity) 1 2
(cat:d (cat:dlop-ext-int '(1 3 5)))) (cat:d (cat:dlop-ext-int '(1 3 5))))
(cat:cprd (cat:soft-delta-infinity) 3 (cat:d 15)) (cat:cprd (cat:soft-delta-infinity) 3 (cat:d 15))
(cat:dgnl (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:? (cat:soft-delta-infinity) 2
(cat:d (cat:dlop-ext-int '(0 2 4)))))) (cat:d (cat:dlop-ext-int '(0 2 4))))))
(test basis (test basis
(let ((basis (cat:delta-n-basis 3)) (let ((basis (cat:delta-n-basis 3))
(soft-basis (cat:soft-delta-n-basis 3))) (soft-basis (cat:soft-delta-n-basis 3)))
(dotimes (i 5) (dotimes (i 5)
(print (funcall basis i))) (print (funcall basis i)))
(dotimes (i 5) (dotimes (i 5)
(print (funcall soft-basis i))))) (print (funcall soft-basis i)))))
(test delta (test delta
(progn (progn
(cat:cat-init) (cat:cat-init)
(let ((d3 (cat:delta 3)) (let ((d3 (cat:delta 3))
(d)) (d))
(is (equal :less (cat:cmpr d3 2 4))) (is (equal :less (cat:cmpr d3 2 4)))
(is (equal :equal (cat:cmpr d3 4 4))) (is (equal :equal (cat:cmpr d3 4 4)))
(is (equal :greater (cat:cmpr d3 8 4))) (is (equal :greater (cat:cmpr d3 8 4)))
(cat:basis d3 1) (cat:basis d3 1)
(cat:dgnl d3 3 15) (cat:dgnl d3 3 15)
(cat:face d3 1 2 21) (cat:face d3 1 2 21)
(cat:? d3 2 13) (cat:? d3 2 13)
(setf d (cat:delta-infinity)) (setf d (cat:delta-infinity))
(cat:basis d)))) (cat:basis d))))
(test soft-delta (test soft-delta
(progn (progn
(cat:cat-init) (cat:cat-init)
(let ((d3 (cat:soft-delta 3))) (let ((d3 (cat:soft-delta 3)))
(cat:cmpr d3 (cat:d 2) (cat:d 4)) (cat:cmpr d3 (cat:d 2) (cat:d 4))
(cat:basis d3 1) (cat:basis d3 1)
(cat:dgnl d3 3 (cat:d 15)) (cat:dgnl d3 3 (cat:d 15))
(cat:face d3 1 2 (cat:d 21)) (cat:face d3 1 2 (cat:d 21))
(cat:? d3 2 (cat:d 13))))) (cat:? d3 2 (cat:d 13)))))
(test eat (test eat
(let* ((delta (cat:delta-infinity)) (let* ((delta (cat:delta-infinity))
(d (cat:bndr delta)) (d (cat:bndr delta))
(s14 (cat:mask 15))) (s14 (cat:mask 15)))
(cat:cmbn-? d (cat:gnrt-? d 14 s14)) (cat:cmbn-? d (cat:gnrt-? d 14 s14))
(defun t1 (n) (defun t1 (n)
(time (dotimes (i n) (cat:cmbn-? d (cat:gnrt-? d 14 s14))))) (time (dotimes (i n) (cat:cmbn-? d (cat:gnrt-? d 14 s14)))))
(compile 't1) (compile 't1)
(t1 500) (t1 500)
(setf cat:+too-much-time+ -1) (setf cat:+too-much-time+ -1)
(t1 500))) (t1 500)))
(test deltab2-dgnl (test deltab2-dgnl
(dotimes (i 7) (dotimes (i 7)
(print (cat:deltab2-dgnl i (cat:mask (1+ i)))))) (print (cat:deltab2-dgnl i (cat:mask (1+ i))))))
(test deltab2-bndr (test deltab2-bndr

51
test/diabolo.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -16,34 +17,34 @@
(case dmn (case dmn
(0 (cat:cmbn -1)) (0 (cat:cmbn -1))
(1 (case gnr (1 (case gnr
(s01 (cat:cmbn 0 -1 's0 1 's1)) (s01 (cat:cmbn 0 -1 's0 1 's1))
(s02 (cat:cmbn 0 -1 's0 1 's2)) (s02 (cat:cmbn 0 -1 's0 1 's2))
(s12 (cat:cmbn 0 -1 's1 1 's2)) (s12 (cat:cmbn 0 -1 's1 1 's2))
(s23 (cat:cmbn 0 -1 's2 1 's3)) (s23 (cat:cmbn 0 -1 's2 1 's3))
(s34 (cat:cmbn 0 -1 's3 1 's4)) (s34 (cat:cmbn 0 -1 's3 1 's4))
(s35 (cat:cmbn 0 -1 's3 1 's5)) (s35 (cat:cmbn 0 -1 's3 1 's5))
(s45 (cat:cmbn 0 -1 's4 1 's5)))) (s45 (cat:cmbn 0 -1 's4 1 's5))))
(2 (case gnr (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.")))) (otherwise (error "Bad generator for complex diabolo."))))
(test diabolo (test diabolo
(progn (progn
(cat:cat-init) (cat:cat-init)
(let ((diabolo (cat:build-chcm :cmpr #'cat:s-cmpr (let ((diabolo (cat:build-chcm :cmpr #'cat:s-cmpr
:basis #'diabolo-basis :basis #'diabolo-basis
:bsgn 's0 :bsgn 's0
:intr-dffr #'diabolo-pure-dffr :intr-dffr #'diabolo-pure-dffr
:strt :GNRT :strt :GNRT
:orgn '(diabolo-for-example)))) :orgn '(diabolo-for-example))))
(is (equal (cat:basis diabolo 0) '(s0 s1 s2 s3 s4 s5))) (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 1) '(s01 s02 s12 s23 s34 s35 s45)))
(is (equal (cat:basis diabolo 2) '(s345))) (is (equal (cat:basis diabolo 2) '(s345)))
(is (null (cat:basis diabolo 10))) (is (null (cat:basis diabolo 10)))
(let* ((comb (cat:dffr diabolo 2 's345)) (let* ((comb (cat:dffr diabolo 2 's345))
(comb1 (cat:dffr diabolo comb))) (comb1 (cat:dffr diabolo comb)))
(is (equal (cat:cmbn-degr comb) 1)) (is (equal (cat:cmbn-degr comb) 1))
(is (equal (cat:cmbn-list comb) '((1 . s34) (-1 . s35) (1 . s45)))) (is (equal (cat:cmbn-list comb) '((1 . s34) (-1 . s35) (1 . s45))))
(is (equal (cat:cmbn-degr comb1) 0)) (is (equal (cat:cmbn-degr comb1) 0))
(is (equal (cat:cmbn-list comb1) nil)))))) (is (equal (cat:cmbn-list comb1) nil))))))

193
test/disk-pasting-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -5,144 +6,144 @@
(test disk-pasting-cmpr (test disk-pasting-cmpr
(let* ((c (cat:delta 3)) (let* ((c (cat:delta 3))
(cmpr (cat:disk-pasting-cmpr (cat:cmpr c) 'new))) (cmpr (cat:disk-pasting-cmpr (cat:cmpr c) 'new)))
(is (equal :equal (funcall cmpr 'new 'new))) (is (equal :equal (funcall cmpr 'new 'new)))
(is (equal :less (funcall cmpr 'new 5))) (is (equal :less (funcall cmpr 'new 5)))
(is (equal :greater (funcall cmpr 5 'new))) (is (equal :greater (funcall cmpr 5 'new)))
(is (equal :equal (funcall cmpr 5 5))) (is (equal :equal (funcall cmpr 5 5)))
(is (equal :less (funcall cmpr 5 6))) (is (equal :less (funcall cmpr 5 6)))
(is (equal :greater (funcall cmpr 6 5))))) (is (equal :greater (funcall cmpr 6 5)))))
(test disk-pasting-basis (test disk-pasting-basis
(cat:cat-init) (cat:cat-init)
(let* ((c (cat:delta 3)) (let* ((c (cat:delta 3))
(basis (cat:disk-pasting-basis (cat:basis c) 3 'new))) (basis (cat:disk-pasting-basis (cat:basis c) 3 'new)))
(funcall basis 3) (funcall basis 3)
(funcall basis 2))) (funcall basis 2)))
(test disk-pasting-intr-dffr (test disk-pasting-intr-dffr
(cat:cat-init) (cat:cat-init)
(let* ((c (cat:delta 3)) (let* ((c (cat:delta 3))
intr) intr)
(signals simple-error (signals simple-error
(setf intr (cat:disk-pasting-intr-dffr (setf intr (cat:disk-pasting-intr-dffr
(cat:dffr c) 3 'new (cat:cmbn 2 1 7)))) (cat:dffr c) 3 'new (cat:cmbn 2 1 7))))
(setf intr (cat:disk-pasting-intr-dffr (cat:dffr c) (setf intr (cat:disk-pasting-intr-dffr (cat:dffr c)
3 'new (cat:? c 3 15))) 3 'new (cat:? c 3 15)))
(funcall intr (cat:cmbn 2 1 7)) (funcall intr (cat:cmbn 2 1 7))
(funcall intr (cat:cmbn 3)) (funcall intr (cat:cmbn 3))
(funcall intr (cat:cmbn 3 1 15)) (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))
(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 (test chcm-disk-pasting
(cat:cat-init) (cat:cat-init)
(let* ((c (cat:delta 3)) (let* ((c (cat:delta 3))
(s3 (cat:chcm-disk-pasting c 3 'new (cat:? c 3 15)))) (s3 (cat:chcm-disk-pasting c 3 'new (cat:? c 3 15))))
(cat:homology s3 0 5))) (cat:homology s3 0 5)))
(test disk-pasting-face (test disk-pasting-face
(cat:cat-init) (cat:cat-init)
(let* ((c (cat:delta 3)) (let* ((c (cat:delta 3))
(face (cat:disk-pasting-face (cat:cmpr c) (cat:face c) (face (cat:disk-pasting-face (cat:cmpr c) (cat:face c)
3 'new 3 'new
(list 14 (cat:absm 0 13) 11 7)))) (list 14 (cat:absm 0 13) 11 7))))
(funcall face 0 2 7) (funcall face 0 2 7)
(funcall face 0 3 15) (funcall face 0 3 15)
(dotimes (i 4) (print (funcall face i 3 'new))))) (dotimes (i 4) (print (funcall face i 3 'new)))))
(test disk-pasting (test disk-pasting
(cat:cat-init) (cat:cat-init)
(let* ((d2 (cat:delta 2)) (let* ((d2 (cat:delta 2))
(s2 (cat:disk-pasting d2 2 'new '(6 5 3))) (s2 (cat:disk-pasting d2 2 'new '(6 5 3)))
s2xs2) s2xs2)
(cat:homology s2 0 4) (cat:homology s2 0 4)
(setf s2xs2 (cat:crts-prdc s2 s2)) (setf s2xs2 (cat:crts-prdc s2 s2))
(cat:homology s2xs2 0 6))) (cat:homology s2xs2 0 6)))
(test mrph-disk-pasting-intr (test mrph-disk-pasting-intr
(cat:cat-init) (cat:cat-init)
(let* ((m (cat:idnt-mrph (cat:delta 3))) (let* ((m (cat:idnt-mrph (cat:delta 3)))
(intr (cat:mrph-disk-pasting-intr m (cat:cmpr (cat:delta 3)) (intr (cat:mrph-disk-pasting-intr m (cat:cmpr (cat:delta 3))
3 'new (cat:cmbn 3 -1 15)))) 3 'new (cat:cmbn 3 -1 15))))
(funcall intr (cat:cmbn 2 3 7)) (funcall intr (cat:cmbn 2 3 7))
(funcall intr (cat:cmbn 3)) (funcall intr (cat:cmbn 3))
(funcall intr (cat:cmbn 3 4 15)) (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))
(funcall intr (cat:cmbn 3 -1 'new 1 15)))) (funcall intr (cat:cmbn 3 -1 'new 1 15))))
(test mrph-disk-pasting (test mrph-disk-pasting
(cat:cat-init) (cat:cat-init)
(let* ((d (cat:delta 3)) (let* ((d (cat:delta 3))
(m (cat:idnt-mrph d)) (m (cat:idnt-mrph d))
(sorc (cat:chcm-disk-pasting d 3 'new (cat:? d 3 15))) (sorc (cat:chcm-disk-pasting d 3 'new (cat:? d 3 15)))
(nm (cat:mrph-disk-pasting m sorc sorc 3 'new (nm (cat:mrph-disk-pasting m sorc sorc 3 'new
(cat:cmbn 3 1 'new)))) (cat:cmbn 3 1 'new))))
(cat:? nm (cat:cmbn 3 2 'new 3 15)))) (cat:? nm (cat:cmbn 3 2 'new 3 15))))
(test disk-pasting1 (test disk-pasting1
(cat:cat-init) (cat:cat-init)
(let* ((d (cat:delta 2)) (let* ((d (cat:delta 2))
(s2 (cat:disk-pasting d 2 'new '(6 5 3)))) (s2 (cat:disk-pasting d 2 'new '(6 5 3))))
(cat:homology s2 0 4))) (cat:homology s2 0 4)))
(test hmeq-disk-pasting (test hmeq-disk-pasting
(cat:cat-init) (cat:cat-init)
(let* ((tcc (cat:build-chcm (let* ((tcc (cat:build-chcm
:cmpr #'cat:s-cmpr :cmpr #'cat:s-cmpr
:basis #'(lambda (degr) :basis #'(lambda (degr)
(case degr (case degr
(0 (list 'a)) (0 (list 'a))
(1 (list 'b)) (1 (list 'b))
(otherwise nil))) (otherwise nil)))
:intr-dffr #'(lambda (degr gnrt) :intr-dffr #'(lambda (degr gnrt)
(if (= 1 degr) (if (= 1 degr)
(cat:cmbn 0 1 'a) (cat:cmbn 0 1 'a)
(cat:zero-cmbn (1- degr)))) (cat:zero-cmbn (1- degr))))
:strt :gnrt :strt :gnrt
:orgn '(z-z))) :orgn '(z-z)))
(bcc (cat:build-chcm (bcc (cat:build-chcm
:cmpr #'cat:s-cmpr :cmpr #'cat:s-cmpr
:basis #'(lambda (degr) nil) :basis #'(lambda (degr) nil)
:intr-dffr #'(lambda (degr gnrt) (error "Impossible.")) :intr-dffr #'(lambda (degr gnrt) (error "Impossible."))
:strt :gnrt :strt :gnrt
:orgn '(zero))) :orgn '(zero)))
(rh (cat:build-mrph (rh (cat:build-mrph
:sorc tcc :trgt tcc :degr +1 :sorc tcc :trgt tcc :degr +1
:intr #'(lambda (degr gnrt) :intr #'(lambda (degr gnrt)
(if (zerop degr) (if (zerop degr)
(cat:cmbn 1 1 'b) (cat:cmbn 1 1 'b)
(cat:zero-cmbn 2))) (cat:zero-cmbn 2)))
:strt :gnrt :strt :gnrt
:orgn '(rh))) :orgn '(rh)))
(hmeq (cat:build-hmeq (hmeq (cat:build-hmeq
:lrdct (cat:trivial-rdct tcc) :lrdct (cat:trivial-rdct tcc)
:rrdct (cat:build-rdct :rrdct (cat:build-rdct
:f (cat:zero-mrph tcc bcc 0) :f (cat:zero-mrph tcc bcc 0)
:g (cat:zero-mrph bcc tcc 0) :g (cat:zero-mrph bcc tcc 0)
:h rh :h rh
:orgn '(rrdct)))) :orgn '(rrdct))))
(nhmeq (cat:hmeq-disk-pasting hmeq 1 'new (cat:cmbn 0 1 'a)))) (nhmeq (cat:hmeq-disk-pasting hmeq 1 'new (cat:cmbn 0 1 'a))))
(cat:pre-check-rdct (cat:lrdct nhmeq)) (cat:pre-check-rdct (cat:lrdct nhmeq))
(setf cat:*tc* (cat:cmbn 0 1 'a)) (setf cat:*tc* (cat:cmbn 0 1 'a))
(setf cat:*bc* cat:*tc*) (setf cat:*bc* cat:*tc*)
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn 1 1 'new 10 'b)) (setf cat:*tc* (cat:cmbn 1 1 'new 10 'b))
(setf cat:*bc* cat:*tc*) (setf cat:*bc* cat:*tc*)
(check-rdct) (check-rdct)
(cat:pre-check-rdct (cat:rrdct nhmeq)) (cat:pre-check-rdct (cat:rrdct nhmeq))
(setf cat:*bc* (cat:zero-cmbn 0)) (setf cat:*bc* (cat:zero-cmbn 0))
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn 0 1 'a)) (setf cat:*tc* (cat:cmbn 0 1 'a))
(check-rdct))) (check-rdct)))

159
test/effective-homology-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -5,107 +6,107 @@
(test cdelta (test cdelta
(progn (progn
(cat:cat-init) (cat:cat-init)
(let* ((cc (cdelta 5)) (let* ((cc (cdelta 5))
(hmeq (cat:trivial-hmeq cc))) (hmeq (cat:trivial-hmeq cc)))
(declare (ignore hmeq)) (declare (ignore hmeq))
(signals simple-error (equal (cat:basis cc 0) cat:+empty-list+)) (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 1) cat:+empty-list+))
(signals simple-error (equal (cat:basis cc 2) 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 3) cat:+empty-list+))
(signals simple-error (equal (cat:basis cc 4) 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+))))) (signals simple-error (equal (cat:basis cc 5) cat:+empty-list+)))))
(test make-rdct (test make-rdct
(progn (progn
(cat:cat-init) (cat:cat-init)
(let ((rdct (make-rdct 6 3))) (let ((rdct (make-rdct 6 3)))
(is (equal (cat:orgn rdct) '(REDUCTION DELTA 6 3))) (is (equal (cat:orgn rdct) '(REDUCTION DELTA 6 3)))
(cat:pre-check-rdct rdct) (cat:pre-check-rdct rdct)
(setf cat:*tc* (cat:cmbn 2 1 '(0 1 2) 10 '(1 2 3) 100 '(1 2 4) (setf cat:*tc* (cat:cmbn 2 1 '(0 1 2) 10 '(1 2 3) 100 '(1 2 4)
1000 '(2 3 4))) 1000 '(2 3 4)))
(setf cat:*bc* (cat:cmbn 3 4 '(0 1 2 3))) (setf cat:*bc* (cat:cmbn 3 4 '(0 1 2 3)))
(check-rdct)))) (check-rdct))))
(test cmps (test cmps
(progn (progn
(cat:cat-init) (cat:cat-init)
(let* ((trdct (make-rdct 6 4)) (let* ((trdct (make-rdct 6 4))
(brdct (make-rdct 4 3)) (brdct (make-rdct 4 3))
(rdct (cat:cmps brdct trdct))) (rdct (cat:cmps brdct trdct)))
(cat:pre-check-rdct rdct) (cat:pre-check-rdct rdct)
(setf cat:*tc* (cat:cmbn 2 1 '(0 1 2) 10 '(1 2 3) 100 '(1 2 4) (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))) 100 '(1 3 5) 10 '(1 4 5) 1 '(3 4 5)))
(setf cat:*bc* (cat:cmbn 2 1 '(0 1 3))) (setf cat:*bc* (cat:cmbn 2 1 '(0 1 3)))
(check-rdct)))) (check-rdct))))
(test zero-mrph (test zero-mrph
(progn (progn
(cat:cat-init) (cat:cat-init)
(let* ((rdct (make-rdct 6 3)) (let* ((rdct (make-rdct 6 3))
(perturb (cat:zero-mrph (cdelta 6) (cdelta 6) -1)) (perturb (cat:zero-mrph (cdelta 6) (cdelta 6) -1))
(new-rdct (cat:add rdct perturb))) (new-rdct (cat:add rdct perturb)))
(cat:pre-check-rdct new-rdct) (cat:pre-check-rdct new-rdct)
(setf cat:*tc* (cat:cmbn 2 3 '(0 1 2))) (setf cat:*tc* (cat:cmbn 2 3 '(0 1 2)))
(setf cat:*bc* (cat:cmbn 3 4 '(0 1 2 3))) (setf cat:*bc* (cat:cmbn 3 4 '(0 1 2 3)))
(check-rdct)))) (check-rdct))))
(test opps (test opps
(progn (progn
(cat:cat-init) (cat:cat-init)
(let* ((rdct (make-rdct 6 3)) (let* ((rdct (make-rdct 6 3))
(perturb (cat:opps (cat:dffr (cat:tcc rdct)))) (perturb (cat:opps (cat:dffr (cat:tcc rdct))))
(new-rdct (cat:add rdct perturb))) (new-rdct (cat:add rdct perturb)))
(cat:pre-check-rdct new-rdct) (cat:pre-check-rdct new-rdct)
(setf cat:*tc* (cat:cmbn 2 3 '(0 1 2))) (setf cat:*tc* (cat:cmbn 2 3 '(0 1 2)))
(setf cat:*bc* (cat:cmbn 3 4 '(0 1 2 3))) (setf cat:*bc* (cat:cmbn 3 4 '(0 1 2 3)))
(check-rdct)))) (check-rdct))))
;; an absurd reduction ; just to test bpl-*-sigma ;; an absurd reduction ; just to test bpl-*-sigma
(test bpl-*-sigma (test bpl-*-sigma
(progn (progn
(cat:cat-init) (cat:cat-init)
(let* ((tcc (cat:build-chcm (let* ((tcc (cat:build-chcm
:cmpr #'cat:l-cmpr :cmpr #'cat:l-cmpr
:basis :locally-effective :basis :locally-effective
:bsgn '(0) :bsgn '(0)
:intr-dffr #'(lambda (degr gnrt) :intr-dffr #'(lambda (degr gnrt)
(cat:cmbn (1- degr) 1 gnrt)) (cat:cmbn (1- degr) 1 gnrt))
:strt :gnrt :strt :gnrt
:orgn '(test1))) :orgn '(test1)))
(rdct (cat:trivial-rdct tcc)) (rdct (cat:trivial-rdct tcc))
(perturb (cat:build-mrph (perturb (cat:build-mrph
:sorc tcc :trgt tcc :degr -1 :sorc tcc :trgt tcc :degr -1
:intr #'(lambda (degr gnrt) :intr #'(lambda (degr gnrt)
(if (zerop (first gnrt)) (if (zerop (first gnrt))
(cat:zero-cmbn (1- degr)) (cat:zero-cmbn (1- degr))
(cat:cmbn (1- degr) 1 (cat:cmbn (1- degr) 1
(list (1- (first gnrt)) (list (1- (first gnrt))
(1+ (second gnrt)))))) (1+ (second gnrt))))))
:strt :gnrt :strt :gnrt
:orgn '(test3))) :orgn '(test3)))
(new-rdct)) (new-rdct))
(setf (slot-value rdct 'cat:h) (setf (slot-value rdct 'cat:h)
(cat:build-mrph (cat:build-mrph
:sorc tcc :trgt tcc :degr +1 :sorc tcc :trgt tcc :degr +1
:intr #'(lambda (degr gnrt) :intr #'(lambda (degr gnrt)
(cat:cmbn (1+ degr) 1 gnrt)) (cat:cmbn (1+ degr) 1 gnrt))
:strt :gnrt :strt :gnrt
:orgn '(test2))) :orgn '(test2)))
(setf new-rdct (cat:add rdct perturb)) (setf new-rdct (cat:add rdct perturb))
(cat:gnrt-? (cat:dffr (cat:tcc new-rdct)) 3 '(3 5)) (cat:gnrt-? (cat:dffr (cat:tcc new-rdct)) 3 '(3 5))
(cat:gnrt-? (cat:dffr (cat:bcc new-rdct)) 3 '(3 5))))) (cat:gnrt-? (cat:dffr (cat:bcc new-rdct)) 3 '(3 5)))))
(test trivial-hmeq (test trivial-hmeq
(progn (progn
(cat:cat-init) (cat:cat-init)
(let ((hmeq (cat:trivial-hmeq (cdelta 4)))) (let ((hmeq (cat:trivial-hmeq (cdelta 4))))
(cat:add (cat:lrdct hmeq) (cat:opps (cat:dffr (cdelta 4)))) (cat:add (cat:lrdct hmeq) (cat:opps (cat:dffr (cdelta 4))))
(setf hmeq (cat:add 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:gnrt-? (cat:dffr (cat:rbcc hmeq)) 3 '(0 1 2 3)))))

121
test/eilenberg-zilber-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -6,115 +7,115 @@
(test shuffle-sign (test shuffle-sign
(dotimes (i 30) (dotimes (i 30)
(format t "~%~A => ~@D" (cat:hyphenize-list (cat:dlop-int-ext i)) (format t "~%~A => ~@D" (cat:hyphenize-list (cat:dlop-int-ext i))
(cat:shuffle-sign i)))) (cat:shuffle-sign i))))
(test intr-eml (test intr-eml
(cat:intr-eml (cat:cmbn 3 1 (cat:tnpr 0 'a 3 'b) (cat:intr-eml (cat:cmbn 3 1 (cat:tnpr 0 'a 3 'b)
2 (cat:tnpr 2 'a 1 'b) 2 (cat:tnpr 2 'a 1 'b)
3 (cat:tnpr 2 'aa 1 'bb) 3 (cat:tnpr 2 'aa 1 'bb)
4 (cat:tnpr 3 'a 0 'b))) 4 (cat:tnpr 3 'a 0 'b)))
(cat:intr-eml (cat:cmbn 3 1 (cat:tnpr 1 'c 2 'd) (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) (cat:intr-eml (cat:cmbn 3 10 (cat:tnpr 1 'c 2 'd)
1 (cat:tnpr 2 'a 1 'b) 1 (cat:tnpr 2 'a 1 'b)
100 (cat:tnpr 2 'aa 1 'bb))) 100 (cat:tnpr 2 'aa 1 'bb)))
(cat:intr-eml (cat:cmbn 3 10 (cat:tnpr 1 'c 2 'd) (cat:intr-eml (cat:cmbn 3 10 (cat:tnpr 1 'c 2 'd)
100 (cat:tnpr 1 'cc 2 'dd) 100 (cat:tnpr 1 'cc 2 'dd)
1 (cat:tnpr 2 'a 1 'b)))) 1 (cat:tnpr 2 'a 1 'b))))
(test eml (test eml
(cat:cat-init) (cat:cat-init)
(let* ((d (cat:delta-infinity)) (let* ((d (cat:delta-infinity))
(eml (cat:eml d d))) (eml (cat:eml d d)))
(cat:? eml (cat:cmbn 3 1 (cat:tnpr 0 1 3 30) (cat:? eml (cat:cmbn 3 1 (cat:tnpr 0 1 3 30)
10 (cat:tnpr 1 3 2 28) 10 (cat:tnpr 1 3 2 28)
100 (cat:tnpr 2 7 1 24) 100 (cat:tnpr 2 7 1 24)
1000 (cat:tnpr 3 15 0 16))))) 1000 (cat:tnpr 3 15 0 16)))))
(test intr-phi (test intr-phi
(cat:cat-init) (cat:cat-init)
(let* ((d (cat:delta-infinity)) (let* ((d (cat:delta-infinity))
(rslt (cat:intr-phi d d))) (rslt (cat:intr-phi d d)))
(funcall rslt (cat:cmbn 3 1 (cat:crpr 0 15 0 15))) (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 2 1 (cat:crpr 0 7 0 7)))
(funcall rslt (cat:cmbn 1 1 (cat:crpr 0 3 0 3))) (funcall rslt (cat:cmbn 1 1 (cat:crpr 0 3 0 3)))
(funcall rslt (cat:cmbn 0 1 (cat:crpr 0 1 0 1))))) (funcall rslt (cat:cmbn 0 1 (cat:crpr 0 1 0 1)))))
(test phi (test phi
(cat:cat-init) (cat:cat-init)
(let ((phi (cat:phi (cat:delta-infinity) (cat:delta-infinity)))) (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 (test eat
(cat:cat-init) (cat:cat-init)
(let* ((s (cat:sphere 5)) (let* ((s (cat:sphere 5))
(p (cat:crts-prdc s s)) (p (cat:crts-prdc s s))
(b (cat:basis p 8)) (b (cat:basis p 8))
(c (cat:make-cmbn :degr 8 (c (cat:make-cmbn :degr 8
:list (mapcar #'(lambda (item) :list (mapcar #'(lambda (item)
(cat:term (1+ (random 5)) (cat:term (1+ (random 5))
item)) item))
b))) b)))
(phi (cat:phi s s))) (phi (cat:phi s s)))
(time (cat:? phi c)))) (time (cat:? phi c))))
(test intr-aw (test intr-aw
(cat:cat-init) (cat:cat-init)
(let* ((r (cat:intr-aw #'cat:delta-face #'cat:delta-face)) (let* ((r (cat:intr-aw #'cat:delta-face #'cat:delta-face))
(s (cat:sphere 3)) (s (cat:sphere 3))
(f (cat:face s))) (f (cat:face s)))
(funcall r 3 (cat:crpr 0 15 0 15)) (funcall r 3 (cat:crpr 0 15 0 15))
(setf r (cat:intr-aw f f)) (setf r (cat:intr-aw f f))
(funcall r 3 (cat:crpr 0 's3 0 's3)))) (funcall r 3 (cat:crpr 0 's3 0 's3))))
(test aw (test aw
(cat:cat-init) (cat:cat-init)
(let ((aw (cat:aw (cat:delta-infinity) (cat:delta-infinity)))) (let ((aw (cat:aw (cat:delta-infinity) (cat:delta-infinity))))
(cat:? aw (cat:cmbn 3 1 (cat:crpr 0 15 0 30) (cat:? aw (cat:cmbn 3 1 (cat:crpr 0 15 0 30)
-1 (cat:crpr 0 23 0 29))))) -1 (cat:crpr 0 23 0 29)))))
(test ez (test ez
(cat:cat-init) (cat:cat-init)
(let ((ez (cat:ez (cat:delta-infinity) (cat:delta-infinity)))) (let ((ez (cat:ez (cat:delta-infinity) (cat:delta-infinity))))
(setf cat:*bc* (cat:cmbn 3 1 (cat:tnpr 0 1 3 30) (setf cat:*bc* (cat:cmbn 3 1 (cat:tnpr 0 1 3 30)
10 (cat:tnpr 1 96 2 896) 10 (cat:tnpr 1 96 2 896)
100 (cat:tnpr 2 7168 1 3) 100 (cat:tnpr 2 7168 1 3)
1000 (cat:tnpr 3 15 0 4096))) 1000 (cat:tnpr 3 15 0 4096)))
(setf cat:*tc* (cat:cmbn 3 1 (cat:crpr 0 15 0 480) (setf cat:*tc* (cat:cmbn 3 1 (cat:crpr 0 15 0 480)
100 (cat:crpr 0 15 5 96) 100 (cat:crpr 0 15 5 96)
10 (cat:crpr 6 3 0 480) 10 (cat:crpr 6 3 0 480)
1000 (cat:crpr 6 3 1 224))) 1000 (cat:crpr 6 3 1 224)))
(cat:pre-check-rdct ez) (cat:pre-check-rdct ez)
(check-rdct))) (check-rdct)))
(test eat1 (test eat1
(cat:cat-init) (cat:cat-init)
(let* ((s (cat:sphere 5)) (let* ((s (cat:sphere 5))
(ez (cat:ez s s)) (ez (cat:ez s s))
(b (cat:basis (cat:tcc ez) 8)) (b (cat:basis (cat:tcc ez) 8))
(c (cat:make-cmbn :degr 8 (c (cat:make-cmbn :degr 8
:list (mapcar #'(lambda (item) :list (mapcar #'(lambda (item)
(cat:term (1+ (random 5)) (cat:term (1+ (random 5))
item)) item))
b)))) b))))
(cat:pre-check-rdct ez) (cat:pre-check-rdct ez)
(setf cat:+too-much-time+ -1) (setf cat:+too-much-time+ -1)
(time (cat:? cat:*id-gf-dh-hd* c)) (time (cat:? cat:*id-gf-dh-hd* c))
(time (cat:? cat:*id-gf-dh-hd* c)))) (time (cat:? cat:*id-gf-dh-hd* c))))
(test crts-prdc (test crts-prdc
(cat:cat-init) (cat:cat-init)
(let* ((k (cat:k-z 2)) (let* ((k (cat:k-z 2))
(k2 (cat:crts-prdc k k))) (k2 (cat:crts-prdc k k)))
(cat:homology k2 0 10))) (cat:homology k2 0 10)))

85
test/fibrations-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -8,67 +9,67 @@
(test fibration-total-face (test fibration-total-face
(cat:cat-init) (cat:cat-init)
(let* ((h (cat:hopf 1)) (let* ((h (cat:hopf 1))
(sf (cat:serre-face h))) (sf (cat:serre-face h)))
(funcall sf 0 2 (cat:crpr 0 's2 0 '(2 4))) (funcall sf 0 2 (cat:crpr 0 's2 0 '(2 4)))
(funcall sf 1 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 2 2 (cat:crpr 0 's2 0 '(2 4)))
(funcall sf 3 3 (cat:crpr 1 's2 2 '(2 4))))) (funcall sf 3 3 (cat:crpr 1 's2 2 '(2 4)))))
|# |#
(test fibration-total (test fibration-total
(cat:cat-init) (cat:cat-init)
(let* ((s2 (cat:sphere 2)) (let* ((s2 (cat:sphere 2))
(k (cat:k-z-1)) (k (cat:k-z-1))
(tw (cat:build-smmr (tw (cat:build-smmr
:sorc s2 :sorc s2
:trgt k :trgt k
:degr -1 :degr -1
:sintr #'(lambda (dmns gmsm) :sintr #'(lambda (dmns gmsm)
(cat:absm 0 (list 1))) (cat:absm 0 (list 1)))
:orgn '(s2-tw-kz1))) :orgn '(s2-tw-kz1)))
(e (cat:fibration-total tw))) (e (cat:fibration-total tw)))
(cat:homology e 2) (cat:homology e 2)
(cat:homology e 0 8))) (cat:homology e 0 8)))
(test fibration-total1 (test fibration-total1
(cat:cat-init) (cat:cat-init)
(let* ((s2 (cat:sphere 2)) (let* ((s2 (cat:sphere 2))
(k (cat:k-z2-1)) (k (cat:k-z2-1))
(tw (cat:build-smmr (tw (cat:build-smmr
:sorc s2 :sorc s2
:trgt k :trgt k
:degr -1 :degr -1
:sintr #'(lambda (dmns gmsm) :sintr #'(lambda (dmns gmsm)
(cat:absm 0 1)) (cat:absm 0 1))
:orgn '(s2-tw-kz2))) :orgn '(s2-tw-kz2)))
(e (cat:fibration-total tw))) (e (cat:fibration-total tw)))
(cat:homology e 2) (cat:homology e 2)
(cat:homology e 0 8))) (cat:homology e 0 8)))
#| #|
(test fibration-total2 (test fibration-total2
(cat:cat-init) (cat:cat-init)
(let* ((tw (cat:kdivide-z2-twist opr opr-chml-clss)) (let* ((tw (cat:kdivide-z2-twist opr opr-chml-clss))
(pr-4 (cat:fibration-total tw)) (pr-4 (cat:fibration-total tw))
(absm (cat:absm 0 (cat:crpr 0 (cat:loop3 0 5 2) 0 4))) (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)) (hat (mapcar #'(lambda (i) (cat:face pr-4 i 4 absm))
(cat:<a-b> 0 4)))) (cat:<a-b> 0 4))))
(dotimes (i 5) (dotimes (i 5)
(print (cat:kfll pr-4 i 4 (remove (nth i hat) hat))) (print (cat:kfll pr-4 i 4 (remove (nth i hat) hat)))
(cat:check-kan pr-4 i 4 (remove (nth i hat) hat))))) (cat:check-kan pr-4 i 4 (remove (nth i hat) hat)))))
(test fibration-total3 (test fibration-total3
(cat:cat-init) (cat:cat-init)
(let* ((os3-fibration os3-fibration) (let* ((os3-fibration os3-fibration)
(total (cat:fibration-total os3-fibration)) (total (cat:fibration-total os3-fibration))
(absm (cat:absm 1 (cat:crpr 0 (cat:loop3 1 's3 1 2 's3 -2) (absm (cat:absm 1 (cat:crpr 0 (cat:loop3 1 's3 1 2 's3 -2)
0 '(-2 1 1)))) 0 '(-2 1 1))))
(hat (mapcar #'(lambda (i) (cat:face total i 4 absm)) (hat (mapcar #'(lambda (i) (cat:face total i 4 absm))
'(0 1 2 3 4)))) '(0 1 2 3 4))))
(dotimes (i 5) (dotimes (i 5)
(print (kfll total i 4 (remove (nth i hat) hat))) (print (kfll total i 4 (remove (nth i hat) hat)))
(check-kan total i 4 (remove (nth i hat) hat))))) (check-kan total i 4 (remove (nth i hat) hat)))))
|# |#

25
test/homology-groups-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -5,24 +6,24 @@
(test chcm-mat (test chcm-mat
(progn (progn
(let ((d (cat:delta 3))) (let ((d (cat:delta 3)))
(princ (cat:chcm-mat d 2)) (princ (cat:chcm-mat d 2))
(princ (cat:chcm-mat d 3)) (princ (cat:chcm-mat d 3))
(princ (cat:chcm-mat d 4))))) (princ (cat:chcm-mat d 4)))))
(test chcm-homology (test chcm-homology
(progn (progn
(let ((d (cat:sphere 3))) (let ((d (cat:sphere 3)))
(princ (cat:chcm-homology d 2)) (princ (cat:chcm-homology d 2))
(princ (cat:chcm-homology d 3)) (princ (cat:chcm-homology d 3))
(princ (cat:chcm-homology d 4))))) (princ (cat:chcm-homology d 4)))))
(test chcm-homology-gen (test chcm-homology-gen
(progn (progn
(let ((d (cat:sphere 3))) (let ((d (cat:sphere 3)))
(princ (cat:chcm-homology-gen d 2)) (princ (cat:chcm-homology-gen d 2))
(princ (cat:chcm-homology-gen d 3)) (princ (cat:chcm-homology-gen d 3))
(princ (cat:chcm-homology-gen d 4))))) (princ (cat:chcm-homology-gen d 4)))))
#| #|

413
test/k-pi-n-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -22,7 +23,7 @@
(cat:z-absm-bar (cat:absm 1 '())) (cat:z-absm-bar (cat:absm 1 '()))
(cat:z-absm-bar (cat:absm 0 '(2))) (cat:z-absm-bar (cat:absm 0 '(2)))
(dotimes (i 8) (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 (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 1 '())))
(cat:z-bar-absm (cat:z-absm-bar (cat:absm 0 '(2)))) (cat:z-bar-absm (cat:z-absm-bar (cat:absm 0 '(2))))
(dotimes (i 8) (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 (test k-z-1-grml
@ -46,35 +47,35 @@
(test k-z-1-grin (test k-z-1-grin
(cat:k-z-1-grin 3 '(2 3 -4)) (cat:k-z-1-grin 3 '(2 3 -4))
(let ((gmsm '(2 3 -4))) (let ((gmsm '(2 3 -4)))
(cat:k-z-1-grml 3 (cat:crpr 0 gmsm 0 (cat:k-z-1-grml 3 (cat:crpr 0 gmsm 0
(cat:gmsm (cat:k-z-1-grin 3 gmsm)))))) (cat:gmsm (cat:k-z-1-grin 3 gmsm))))))
(defun aleat-list (max length) (defun aleat-list (max length)
(let ((rslt nil) (let ((rslt nil)
(2max (+ max max))) (2max (+ max max)))
(dotimes (i length) (dotimes (i length)
(push (let ((k (- (random 2max) max))) (push (let ((k (- (random 2max) max)))
(if (zerop k) (if (zerop k)
max max
k)) k))
rslt)) rslt))
rslt)) rslt))
(test k-z-1 (test k-z-1
(let ((k (cat:k-z-1)) (let ((k (cat:k-z-1))
zero?) zero?)
(cat:? k (cat:? k 14 (aleat-list 200 14))) (cat:? k (cat:? k 14 (aleat-list 200 14)))
(setf zero? (cat:add (cat:idnt-mrph k) (cat:grin k))) (setf zero? (cat:add (cat:idnt-mrph k) (cat:grin k)))
(cat:? zero? 14 (aleat-list 200 14)))) (cat:? zero? 14 (aleat-list 200 14))))
(test circle (test circle
(let ((c (cat:circle))) (let ((c (cat:circle)))
(cat:cmpr c '* '*) (cat:cmpr c '* '*)
(cat:basis c 1) (cat:basis c 1)
(cat:? c 1 's1))) (cat:? c 1 's1)))
(test kz1-rdct-f-intr (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))) (setf cat:*tc* (cat:cmbn 2 1 '(-4 2) 10 '(-1 3) 100 '(1 -4) 1000 '(5 5)))
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn 3 1 '(-4 -4 5) 10 '(-1 2 1) (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)) (check-rdct))
@ -122,18 +123,18 @@
(test k-z2-1-homology (test k-z2-1-homology
(let ((k (cat:k-z2-1))) (let ((k (cat:k-z2-1)))
(cat:homology k 0 4))) (cat:homology k 0 4)))
(test k-z2-homology (test k-z2-homology
(let ((k3 (cat:k-z2 3))) (let ((k3 (cat:k-z2 3)))
(cat:homology k3 7))) (cat:homology k3 7)))
(test z2-bar-absm (test z2-bar-absm
(dotimes (i 8) ;;; not really legal (dotimes (i 8) ;;; not really legal
(dotimes (j 8) (dotimes (j 8)
(print (cat:z2-bar-absm (cat:z2-absm-bar (cat:absm i j))))))) (print (cat:z2-bar-absm (cat:z2-absm-bar (cat:absm i j)))))))
(test z-fundamental-gmsm (test z-fundamental-gmsm
@ -145,129 +146,129 @@
(test interesting-faces (test interesting-faces
(let* ((d (cat:delta 14)) (let* ((d (cat:delta 14))
(f (cat:face d))) (f (cat:face d)))
(do ((i 5 (1- i))) (do ((i 5 (1- i)))
((minusp i)) ((minusp i))
(print (cat:interesting-faces f i 5 (cat:mask 6)))))) (print (cat:interesting-faces f i 5 (cat:mask 6))))))
(test gmsm-cocycle (test gmsm-cocycle
(cat:cat-init) (cat:cat-init)
(let* ((d (cat:delta 10)) (let* ((d (cat:delta 10))
(chml-clss (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -2 (chml-clss (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -2
:intr #'(lambda (dmns gmsm) :intr #'(lambda (dmns gmsm)
(cat:term-cmbn 0 gmsm (cat:term-cmbn 0 gmsm
:gnrt-z)) :gnrt-z))
:strt :gnrt :strt :gnrt
:orgn '(essai-1)))) :orgn '(essai-1))))
(cat:gmsm-cocycle (cat:face d) 2 4 31 chml-clss) (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 (setf chml-clss (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -1
:intr #'(lambda (dmns gmsm) :intr #'(lambda (dmns gmsm)
(cat:term-cmbn 0 gmsm (cat:term-cmbn 0 gmsm
:gnrt-z)) :gnrt-z))
:strt :gnrt :strt :gnrt
:orgn '(essai-2))) :orgn '(essai-2)))
(cat:gmsm-cocycle (cat:face d) 1 4 31 chml-clss))) (cat:gmsm-cocycle (cat:face d) 1 4 31 chml-clss)))
(test z-cocycle-gbar (test z-cocycle-gbar
(cat:cat-init) (cat:cat-init)
(let* ((d (cat:delta 10)) (let* ((d (cat:delta 10))
(chml-clss (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -1 (chml-clss (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -1
:intr #'(lambda (dmns gmsm) :intr #'(lambda (dmns gmsm)
(cat:term-cmbn 0 gmsm (cat:term-cmbn 0 gmsm
:gnrt-z)) :gnrt-z))
:strt :gnrt :strt :gnrt
:orgn '(essai-1)))) :orgn '(essai-1))))
(cat:gmsm-cocycle (cat:face d) 1 4 31 chml-clss) (cat:gmsm-cocycle (cat:face d) 1 4 31 chml-clss)
(cat:z-cocycle-gbar 1 4 (cat:gmsm-cocycle (cat:face d) (cat:z-cocycle-gbar 1 4 (cat:gmsm-cocycle (cat:face d)
1 4 31 chml-clss)) 1 4 31 chml-clss))
(setf chml-clss (setf chml-clss
(cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -2 (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -2
:intr #'(lambda (dmns gmsm) :intr #'(lambda (dmns gmsm)
(cat:term-cmbn 0 gmsm :gnrt-z)) (cat:term-cmbn 0 gmsm :gnrt-z))
:strt :gnrt :strt :gnrt
:orgn '(essai-2))) :orgn '(essai-2)))
(cat:gmsm-cocycle (cat:face d) 2 2 7 chml-clss) (cat:gmsm-cocycle (cat:face d) 2 2 7 chml-clss)
(cat:z-cocycle-gbar 2 2 (cat:gmsm-cocycle (cat:face d) (cat:z-cocycle-gbar 2 2 (cat:gmsm-cocycle (cat:face d)
2 2 7 chml-clss)) 2 2 7 chml-clss))
(cat:gmsm-cocycle (cat:face d) 2 2 0 chml-clss) ;; normally illegal (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) (cat:z-cocycle-gbar 2 2 (cat:gmsm-cocycle (cat:face d)
2 2 0 chml-clss)) 2 2 0 chml-clss))
(cat:gmsm-cocycle (cat:face d) 2 3 15 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) (cat:z-cocycle-gbar 2 3 (cat:gmsm-cocycle (cat:face d)
2 3 15 chml-clss)) 2 3 15 chml-clss))
(cat:gmsm-cocycle (cat:face d) 2 4 31 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) (cat:z-cocycle-gbar 2 4 (cat:gmsm-cocycle (cat:face d)
2 4 31 chml-clss)) 2 4 31 chml-clss))
(setf chml-clss (setf chml-clss
(cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -3 (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -3
:intr #'(lambda (dmns gmsm) :intr #'(lambda (dmns gmsm)
(cat:term-cmbn 0 gmsm :gnrt-z)) (cat:term-cmbn 0 gmsm :gnrt-z))
:strt :gnrt :strt :gnrt
:orgn '(essai-3))) :orgn '(essai-3)))
(cat:gmsm-cocycle (cat:face d) 3 4 31 chml-clss) (cat:gmsm-cocycle (cat:face d) 3 4 31 chml-clss)
(cat:z-cocycle-gbar 3 4 (cat:gmsm-cocycle (cat:face d) (cat:z-cocycle-gbar 3 4 (cat:gmsm-cocycle (cat:face d)
3 4 31 chml-clss)) 3 4 31 chml-clss))
(setf chml-clss (setf chml-clss
(cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -3 (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -3
:intr #'(lambda (dmns gmsm) :intr #'(lambda (dmns gmsm)
(cat:zero-cmbn 0)) (cat:zero-cmbn 0))
:strt :gnrt :strt :gnrt
:orgn '(essai-33))) :orgn '(essai-33)))
(cat:gmsm-cocycle (cat:face d) 3 4 31 chml-clss) (cat:gmsm-cocycle (cat:face d) 3 4 31 chml-clss)
(cat:z-cocycle-gbar 3 4 (cat:gmsm-cocycle (cat:face d) (cat:z-cocycle-gbar 3 4 (cat:gmsm-cocycle (cat:face d)
3 4 31 chml-clss)))) 3 4 31 chml-clss))))
(test z-cocycle-gbar-head (test z-cocycle-gbar-head
(cat:cat-init) (cat:cat-init)
(let* ((d (cat:delta 10)) (let* ((d (cat:delta 10))
(chml-clss (chml-clss
(cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -1 (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -1
:intr #'(lambda (dmns gmsm) :intr #'(lambda (dmns gmsm)
(cat:term-cmbn 0 gmsm :gnrt-z)) (cat:term-cmbn 0 gmsm :gnrt-z))
:strt :gnrt :strt :gnrt
:orgn '(essai-1))) :orgn '(essai-1)))
(x (cat:gmsm-cocycle (cat:face d) 1 4 31 chml-clss))) (x (cat:gmsm-cocycle (cat:face d) 1 4 31 chml-clss)))
(cat:z-cocycle-gbar 1 4 x) (cat:z-cocycle-gbar 1 4 x)
(signals simple-error (cat:z-cocycle-gbar-head 1 4 x)) (signals simple-error (cat:z-cocycle-gbar-head 1 4 x))
(setf chml-clss (setf chml-clss
(cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -2 (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -2
:intr #'(lambda (dmns gmsm) :intr #'(lambda (dmns gmsm)
(cat:term-cmbn 0 gmsm :gnrt-z)) (cat:term-cmbn 0 gmsm :gnrt-z))
:strt :gnrt :strt :gnrt
:orgn '(essai-2))) :orgn '(essai-2)))
(setf x (cat:gmsm-cocycle (cat:face d) 2 2 7 chml-clss)) (setf x (cat:gmsm-cocycle (cat:face d) 2 2 7 chml-clss))
(cat:z-cocycle-gbar 2 2 x) (cat:z-cocycle-gbar 2 2 x)
(cat:z-cocycle-gbar-head 2 2 x) (cat:z-cocycle-gbar-head 2 2 x)
;; normally illegal ;; normally illegal
(setf x (cat:gmsm-cocycle (cat:face d) 2 2 0 chml-clss)) (setf x (cat:gmsm-cocycle (cat:face d) 2 2 0 chml-clss))
(cat:z-cocycle-gbar 2 2 x) (cat:z-cocycle-gbar 2 2 x)
(cat:z-cocycle-gbar-head 2 2 x) (cat:z-cocycle-gbar-head 2 2 x)
(setf x (cat:gmsm-cocycle (cat:face d) 2 3 15 chml-clss)) (setf x (cat:gmsm-cocycle (cat:face d) 2 3 15 chml-clss))
(cat:z-cocycle-gbar 2 3 x) (cat:z-cocycle-gbar 2 3 x)
(cat:z-cocycle-gbar-head 2 3 x) (cat:z-cocycle-gbar-head 2 3 x)
(setf x (cat:gmsm-cocycle (cat:face d) 2 4 31 chml-clss)) (setf x (cat:gmsm-cocycle (cat:face d) 2 4 31 chml-clss))
(cat:z-cocycle-gbar 2 4 x) (cat:z-cocycle-gbar 2 4 x)
(cat:z-cocycle-gbar-head 2 4 x) (cat:z-cocycle-gbar-head 2 4 x)
(setf chml-clss (setf chml-clss
(cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -3 (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -3
:intr #'(lambda (dmns gmsm) :intr #'(lambda (dmns gmsm)
(cat:term-cmbn 0 gmsm :gnrt-z)) (cat:term-cmbn 0 gmsm :gnrt-z))
:strt :gnrt :strt :gnrt
:orgn '(essai-3))) :orgn '(essai-3)))
(setf x (cat:gmsm-cocycle (cat:face d) 3 4 31 chml-clss)) (setf x (cat:gmsm-cocycle (cat:face d) 3 4 31 chml-clss))
(cat:z-cocycle-gbar 3 4 x) (cat:z-cocycle-gbar 3 4 x)
(cat:z-cocycle-gbar-head 3 4 x) (cat:z-cocycle-gbar-head 3 4 x)
(setf chml-clss (setf chml-clss
(cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -3 (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -3
:intr #'(lambda (dmns gmsm) :intr #'(lambda (dmns gmsm)
(cat:zero-cmbn 0)) (cat:zero-cmbn 0))
:strt :gnrt :strt :gnrt
:orgn '(essai-33))) :orgn '(essai-33)))
(setf x (cat:gmsm-cocycle (cat:face d) 3 4 31 chml-clss)) (setf x (cat:gmsm-cocycle (cat:face d) 3 4 31 chml-clss))
(cat:z-cocycle-gbar 3 4 x) (cat:z-cocycle-gbar 3 4 x)
(cat:z-cocycle-gbar-head 3 4 x))) (cat:z-cocycle-gbar-head 3 4 x)))
(test Z2-fundamental-gmsm (test Z2-fundamental-gmsm
@ -280,94 +281,94 @@
(test z2-cocycle-gbar (test z2-cocycle-gbar
(cat:cat-init) (cat:cat-init)
(let* ((d (cat:delta 10)) (let* ((d (cat:delta 10))
(chml-clss (chml-clss
(cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -1 (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -1
:intr #'(lambda (dmns gmsm) :intr #'(lambda (dmns gmsm)
(cat:term-cmbn 0 (mod gmsm 2) :gnrt-z)) (cat:term-cmbn 0 (mod gmsm 2) :gnrt-z))
:strt :gnrt :strt :gnrt
:orgn '(essai-1))) :orgn '(essai-1)))
(x (cat:gmsm-cocycle (cat:face d) 1 4 31 chml-clss))) (x (cat:gmsm-cocycle (cat:face d) 1 4 31 chml-clss)))
(cat:z2-cocycle-gbar 1 4 x) (cat:z2-cocycle-gbar 1 4 x)
(setf chml-clss (setf chml-clss
(cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -2 (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -2
:intr #'(lambda (dmns gmsm) :intr #'(lambda (dmns gmsm)
(cat:term-cmbn 0 (mod gmsm 2) :gnrt-z)) (cat:term-cmbn 0 (mod gmsm 2) :gnrt-z))
:strt :gnrt :strt :gnrt
:orgn '(essai-2))) :orgn '(essai-2)))
(setf x (cat:gmsm-cocycle (cat:face d) 2 2 7 chml-clss)) (setf x (cat:gmsm-cocycle (cat:face d) 2 2 7 chml-clss))
(cat:z2-cocycle-gbar 2 2 x) (cat:z2-cocycle-gbar 2 2 x)
;; normally illegal ;; normally illegal
(setf x (cat:gmsm-cocycle (cat:face d) 2 2 0 chml-clss)) (setf x (cat:gmsm-cocycle (cat:face d) 2 2 0 chml-clss))
(cat:z2-cocycle-gbar 2 2 x) (cat:z2-cocycle-gbar 2 2 x)
(setf x (cat:gmsm-cocycle (cat:face d) 2 3 15 chml-clss)) (setf x (cat:gmsm-cocycle (cat:face d) 2 3 15 chml-clss))
(cat:z2-cocycle-gbar 2 3 x) (cat:z2-cocycle-gbar 2 3 x)
(setf x (cat:gmsm-cocycle (cat:face d) 2 4 31 chml-clss)) (setf x (cat:gmsm-cocycle (cat:face d) 2 4 31 chml-clss))
(cat:z2-cocycle-gbar 2 4 x) (cat:z2-cocycle-gbar 2 4 x)
(setf chml-clss (setf chml-clss
(cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -3 (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -3
:intr #'(lambda (dmns gmsm) :intr #'(lambda (dmns gmsm)
(cat:term-cmbn 0 (mod gmsm 2) :gnrt-z)) (cat:term-cmbn 0 (mod gmsm 2) :gnrt-z))
:strt :gnrt :strt :gnrt
:orgn '(essai-3))) :orgn '(essai-3)))
(setf x (cat:gmsm-cocycle (cat:face d) 3 4 31 chml-clss)) (setf x (cat:gmsm-cocycle (cat:face d) 3 4 31 chml-clss))
(cat:z2-cocycle-gbar 3 4 x))) (cat:z2-cocycle-gbar 3 4 x)))
(test z2-cocycle-gbar-head (test z2-cocycle-gbar-head
(cat:cat-init) (cat:cat-init)
(let* ((d (cat:delta 10)) (let* ((d (cat:delta 10))
(chml-clss (chml-clss
(cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -1 (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -1
:intr #'(lambda (dmns gmsm) :intr #'(lambda (dmns gmsm)
(cat:term-cmbn 0 (mod gmsm 2) :gnrt-z)) (cat:term-cmbn 0 (mod gmsm 2) :gnrt-z))
:strt :gnrt :strt :gnrt
:orgn '(essai-1))) :orgn '(essai-1)))
(x (cat:gmsm-cocycle (cat:face d) 1 4 31 chml-clss))) (x (cat:gmsm-cocycle (cat:face d) 1 4 31 chml-clss)))
(cat:z2-cocycle-gbar 1 4 x) (cat:z2-cocycle-gbar 1 4 x)
(signals simple-error (cat:z2-cocycle-gbar-head 1 4 x)) (signals simple-error (cat:z2-cocycle-gbar-head 1 4 x))
(setf chml-clss (setf chml-clss
(cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -2 (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -2
:intr #'(lambda (dmns gmsm) :intr #'(lambda (dmns gmsm)
(cat:term-cmbn 0 (mod gmsm 2) :gnrt-z)) (cat:term-cmbn 0 (mod gmsm 2) :gnrt-z))
:strt :gnrt :strt :gnrt
:orgn '(essai-2))) :orgn '(essai-2)))
(setf x (cat:gmsm-cocycle (cat:face d) 2 2 7 chml-clss)) (setf x (cat:gmsm-cocycle (cat:face d) 2 2 7 chml-clss))
(cat:z2-cocycle-gbar 2 2 x) (cat:z2-cocycle-gbar 2 2 x)
(cat:z2-cocycle-gbar-head 2 2 x) (cat:z2-cocycle-gbar-head 2 2 x)
;; normally illegal ;; normally illegal
(setf x (cat:gmsm-cocycle (cat:face d) 2 2 0 chml-clss)) (setf x (cat:gmsm-cocycle (cat:face d) 2 2 0 chml-clss))
(cat:z2-cocycle-gbar 2 2 x) (cat:z2-cocycle-gbar 2 2 x)
(cat:z2-cocycle-gbar-head 2 2 x) (cat:z2-cocycle-gbar-head 2 2 x)
(setf x (cat:gmsm-cocycle (cat:face d) 2 3 15 chml-clss)) (setf x (cat:gmsm-cocycle (cat:face d) 2 3 15 chml-clss))
(cat:z2-cocycle-gbar 2 3 x) (cat:z2-cocycle-gbar 2 3 x)
(cat:z2-cocycle-gbar-head 2 3 x) (cat:z2-cocycle-gbar-head 2 3 x)
(setf x (cat:gmsm-cocycle (cat:face d) 2 4 31 chml-clss)) (setf x (cat:gmsm-cocycle (cat:face d) 2 4 31 chml-clss))
(cat:z2-cocycle-gbar 2 4 x) (cat:z2-cocycle-gbar 2 4 x)
(cat:z2-cocycle-gbar-head 2 4 x) (cat:z2-cocycle-gbar-head 2 4 x)
(setf chml-clss (setf chml-clss
(cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -3 (cat:build-mrph :sorc d :trgt (cat:z-chcm) :degr -3
:intr #'(lambda (dmns gmsm) :intr #'(lambda (dmns gmsm)
(cat:term-cmbn 0 (mod gmsm 2) :gnrt-z)) (cat:term-cmbn 0 (mod gmsm 2) :gnrt-z))
:strt :gnrt :strt :gnrt
:orgn '(essai-3))) :orgn '(essai-3)))
(setf x (cat:gmsm-cocycle (cat:face d) 3 4 31 chml-clss)) (setf x (cat:gmsm-cocycle (cat:face d) 3 4 31 chml-clss))
(cat:z2-cocycle-gbar 3 4 x) (cat:z2-cocycle-gbar 3 4 x)
(cat:z2-cocycle-gbar-head 3 4 x))) (cat:z2-cocycle-gbar-head 3 4 x)))
(test k-z-fundamental-class (test k-z-fundamental-class
(cat:cat-init) (cat:cat-init)
(let ((c1 (cat:k-z-fundamental-class 1)) (let ((c1 (cat:k-z-fundamental-class 1))
(c3 (cat:k-z-fundamental-class 3))) (c3 (cat:k-z-fundamental-class 3)))
(cat:? c1 1 '(34)) (cat:? c1 1 '(34))
(cat:? c1 2 '(34 45)) (cat:? c1 2 '(34 45))
(cat:? c3 3 (cat:z-fundamental-gmsm 3 45)))) (cat:? c3 3 (cat:z-fundamental-gmsm 3 45))))
(test k-z2-fundamental-class (test k-z2-fundamental-class
(cat:cat-init) (cat:cat-init)
(let ((c1 (cat:k-z2-fundamental-class 1)) (let ((c1 (cat:k-z2-fundamental-class 1))
(c3 (cat:k-z2-fundamental-class 3))) (c3 (cat:k-z2-fundamental-class 3)))
(cat:? c1 1 1) (cat:? c1 1 1)
(cat:? c1 2 2) (cat:? c1 2 2)
(cat:? c3 3 (cat:z2-fundamental-gmsm 3 1)))) (cat:? c3 3 (cat:z2-fundamental-gmsm 3 1))))

225
test/loop-spaces-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -43,57 +44,57 @@
(test loop-space-cmpr (test loop-space-cmpr
(let ((cmpr (cat:loop-space-cmpr #'cat:s-cmpr))) (let ((cmpr (cat:loop-space-cmpr #'cat:s-cmpr)))
(is (equal :greater (funcall cmpr (cat:loop3 '(1 a 2)) (is (equal :greater (funcall cmpr (cat:loop3 '(1 a 2))
(cat:loop3 '(1 a -1))))) (cat:loop3 '(1 a -1)))))
(is (equal :greater (funcall cmpr (cat:loop3 '(3 b 4 1 a 2)) (is (equal :greater (funcall cmpr (cat:loop3 '(3 b 4 1 a 2))
(cat:loop3 '(3 b 4 1 a -1))))))) (cat:loop3 '(3 b 4 1 a -1)))))))
(test apowr-face4 (test apowr-face4
(cat:cat-init) (cat:cat-init)
(let ((face (cat:face (cat:delta-infinity)))) (let ((face (cat:face (cat:delta-infinity))))
(cat:apowr-face4 face 3 4 (cat:apowr 1 31 5)) (cat:apowr-face4 face 3 4 (cat:apowr 1 31 5))
(setf face (cat:face (cat:sphere 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 1 's5 4))
(cat:apowr-face4 face 2 5 (cat:apowr 2 's5 4)))) (cat:apowr-face4 face 2 5 (cat:apowr 2 's5 4))))
(test apowr-lastface4 (test apowr-lastface4
(cat:cat-init) (cat:cat-init)
(let ((cmpr #'cat:f-cmpr) (let ((cmpr #'cat:f-cmpr)
(face (cat:face (cat:delta-infinity)))) (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 -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 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)) (cat:apowr-lastface4 cmpr face 4 (cat:apowr 8 31 1))
(setf face #'(lambda (indx dmns gmsm) ; dmns = 5 (setf face #'(lambda (indx dmns gmsm) ; dmns = 5
(case indx (case indx
(5 (cat:absm 8 'a)) (5 (cat:absm 8 'a))
(4 (cat:absm 8 'a))))) (4 (cat:absm 8 'a)))))
(setf cmpr #'cat:s-cmpr) (setf cmpr #'cat:s-cmpr)
(cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 'a 2)) (cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 'a 2))
(setf face #'(lambda (indx dmns gmsm) ; dmns = 5 (setf face #'(lambda (indx dmns gmsm) ; dmns = 5
(case indx (case indx
(5 (cat:absm 1 'a)) (5 (cat:absm 1 'a))
(4 (cat:absm 8 'a))))) (4 (cat:absm 8 'a)))))
(cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 'a 2)) (cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 'a 2))
(setf face #'(lambda (indx dmns gmsm) ; dmns = 5 (setf face #'(lambda (indx dmns gmsm) ; dmns = 5
(case indx (case indx
(5 (cat:absm 1 'a)) (5 (cat:absm 1 'a))
(4 (cat:absm 1 'a))))) (4 (cat:absm 1 'a)))))
(cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 'a 2)))) (cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 'a 2))))
(test loop-space-face (test loop-space-face
(cat:cat-init) (cat:cat-init)
(let* ((cmpr #'cat:f-cmpr) (let* ((cmpr #'cat:f-cmpr)
(face (cat:face (cat:delta-infinity))) (face (cat:face (cat:delta-infinity)))
(rslt (cat:loop-space-face cmpr face))) (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 1 31 -3)))
(funcall rslt 2 4 (cat:loop3 '(0 63 3 0 63 -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 0 63 -3)))
(funcall rslt 4 4 (cat:loop3 '(0 63 3))))) (funcall rslt 4 4 (cat:loop3 '(0 63 3)))))
(test loop-space-grin-sintr (test loop-space-grin-sintr
@ -102,94 +103,94 @@
(test loop-space-grml-sintr (test loop-space-grml-sintr
(let* ((cmpr #'cat:s-cmpr) (let* ((cmpr #'cat:s-cmpr)
(ml (cat:loop-space-grml-sintr 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 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) 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 -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 '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 (cat:loop3 0 'b -3)))
(funcall ml 2 (cat:crpr 0 (cat:loop3 0 'a 2 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))))) 0 (cat:loop3 0 'b +3 0 'a -2)))))
(test loop-space (test loop-space
(cat:cat-init) (cat:cat-init)
(let ((g (cat:gdeltab)) (let ((g (cat:gdeltab))
basis cmbn cmbn2 dd echcm efhm hat loop-list rslt x) 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 :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 3 3))))
(is (equal :less (cat:cmpr g (cat:loop3 0 3 2) (cat:loop3 0 5 2)))) (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)))) (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 12 7 3))
(cat:face g 3 3 (cat:loop3 5 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 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: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:check-faces (cat:cmpr g) (cat:face g) 3
(cat:loop3 6 7 -3 5 7 -3 3 7 -3)) (cat:loop3 6 7 -3 5 7 -3 3 7 -3))
(setf dd (cat:cmps g g)) (setf dd (cat:cmps g g))
(cat:? dd 3 (cat:loop3 6 7 3 5 7 3 3 7 3)) (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: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)) (cat:grin g 2 (cat:loop3 0 15 -2))
(setf rslt (cat:loop3 0 31 1)) (setf rslt (cat:loop3 0 31 1))
(setf hat (mapcar #'(lambda (i) (cat:face g i 3 rslt)) (setf hat (mapcar #'(lambda (i) (cat:face g i 3 rslt))
(cat:<a-b> 0 3))) (cat:<a-b> 0 3)))
(dotimes (i 4) (dotimes (i 4)
(print (cat:kfll g i 3 (remove (nth i hat) hat :test #'equal))) (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))) (cat:check-kan g i 3 (remove (nth i hat) hat :test #'equal)))
(setf g (cat:loop-space (cat:sphere 2))) (setf g (cat:loop-space (cat:sphere 2)))
(setf rslt (cat:loop3 3 's2 2 5 's2 -2 6 's2 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)) (setf hat (mapcar #'(lambda (i) (cat:face g i 3 rslt))
(cat:<a-b> 0 3))) (cat:<a-b> 0 3)))
(dotimes (i 4) (dotimes (i 4)
(print (cat:kfll g i 3 (remove (nth i hat) hat :test #'equal))) (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))) (cat:check-kan g i 3 (remove (nth i hat) hat :test #'equal)))
(setf g (cat:loop-space (cat:sphere 3) 2)) (setf g (cat:loop-space (cat:sphere 3) 2))
(setf x (first (cat:basis (cat:echcm g) 4))) (setf x (first (cat:basis (cat:echcm g) 4)))
(setf efhm (cat:efhm g)) (setf efhm (cat:efhm g))
(setf x (cat:lf efhm (cat:rg efhm 4 x))) (setf x (cat:lf efhm (cat:rg efhm 4 x)))
(setf rslt (cat:gnrt (first (cat:cmbn-list x)))) (setf rslt (cat:gnrt (first (cat:cmbn-list x))))
(setf hat (mapcar #'(lambda (i) (cat:face g i 4 rslt)) (setf hat (mapcar #'(lambda (i) (cat:face g i 4 rslt))
(cat:<a-b> 0 4))) (cat:<a-b> 0 4)))
(dotimes (i 5) (dotimes (i 5)
(print (cat:kfll g i 4 (remove (nth i hat) hat :test #'equal))) (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))) (cat:check-kan g i 4 (remove (nth i hat) hat :test #'equal)))
(setf rslt (cat:gnrt (third (cat:cmbn-list x)))) (setf rslt (cat:gnrt (third (cat:cmbn-list x))))
(setf hat (mapcar #'(lambda (i) (cat:face g i 4 rslt)) (setf hat (mapcar #'(lambda (i) (cat:face g i 4 rslt))
(cat:<a-b> 0 4))) (cat:<a-b> 0 4)))
(dotimes (i 5) (dotimes (i 5)
(print (cat:kfll g i 4 (remove (nth i hat) hat :test #'equal))) (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))) (cat:check-kan g i 4 (remove (nth i hat) hat :test #'equal)))
(setf g (cat:loop-space (cat:sphere 3) 2)) (setf g (cat:loop-space (cat:sphere 3) 2))
(setf efhm (cat:efhm g)) (setf efhm (cat:efhm g))
(setf echcm (cat:rbcc efhm)) (setf echcm (cat:rbcc efhm))
(setf basis (cat:basis echcm 4)) (setf basis (cat:basis echcm 4))
(setf cmbn (cat:cmbn 4 1 (first basis) 10 (second basis) (setf cmbn (cat:cmbn 4 1 (first basis) 10 (second basis)
100 (third basis))) 100 (third basis)))
(setf cmbn2 (cat:lf efhm (cat:rg efhm cmbn))) (setf cmbn2 (cat:lf efhm (cat:rg efhm cmbn)))
(setf loop-list (mapcar #'cdr (cat:cmbn-list cmbn2))) (setf loop-list (mapcar #'cdr (cat:cmbn-list cmbn2)))
(dolist (loop loop-list) (dolist (loop loop-list)
(setf hat (mapcar #'(lambda (i) (cat:face g i 4 loop)) (setf hat (mapcar #'(lambda (i) (cat:face g i 4 loop))
(cat:<a-b> 0 4))) (cat:<a-b> 0 4)))
(dotimes (i 5) (dotimes (i 5)
(print (cat:kfll g i 4 (remove (nth i hat) hat))) (print (cat:kfll g i 4 (remove (nth i hat) hat)))
(cat:check-kan g i 4 (remove (nth i hat) hat)))))) (cat:check-kan g i 4 (remove (nth i hat) hat))))))
(test loop-space2 (test loop-space2
(cat:cat-init) (cat:cat-init)
(let* ((p (cat:r-proj-space 3)) (let* ((p (cat:r-proj-space 3))
(op (cat:loop-space p)) (op (cat:loop-space p))
cmpr c) cmpr c)
(dotimes (i 15) (print (random-apowr 8 3))) (dotimes (i 15) (print (random-apowr 8 3)))
(dotimes (i 20) (dotimes (i 20)
(print (cat:normalize-loop 7 (random-niloop 7 3 3)))) (print (cat:normalize-loop 7 (random-niloop 7 3 3))))
(setf cmpr (cat:cmpr op)) (setf cmpr (cat:cmpr op))
(setf cat:+too-much-time+ -1) (setf cat:+too-much-time+ -1)
(setf c (random-loop-cmbn cmpr 8 10 4 4 100)) (setf c (random-loop-cmbn cmpr 8 10 4 4 100))
(time (cat:? op (cat:? op c))) (time (cat:? op (cat:? op c)))
(time (cat:? op (cat:? op c))))) (time (cat:? op (cat:? op c)))))

372
test/lp-space-efhm-test.lisp
View File

@ -1,3 +1,5 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
(in-suite :kenzo) (in-suite :kenzo)
@ -6,168 +8,168 @@
(test ls-hat-t-u (test ls-hat-t-u
(cat:cat-init) (cat:cat-init)
(let ((c (cat:ls-hat-t-u (cat:deltab))) (let ((c (cat:ls-hat-t-u (cat:deltab)))
allp allp-degr gnrt) allp allp-degr gnrt)
(dotimes (i 10) (dotimes (i 10)
(let ((allp (random-allp 3))) (let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(setf gnrt (cat:tnpr allp-degr allp 4 (setf gnrt (cat:tnpr allp-degr allp 4
(cat:tnpr 2 7 2 (cat:loop3 0 15 2)))) (cat:tnpr 2 7 2 (cat:loop3 0 15 2))))
(unless (>= allp-degr 11) (unless (>= allp-degr 11)
(print (cat:? c (+ 4 allp-degr) gnrt)) (print (cat:? c (+ 4 allp-degr) gnrt))
(print (cat:? c (cat:? c (+ 4 allp-degr) gnrt)))))) (print (cat:? c (cat:? c (+ 4 allp-degr) gnrt))))))
(dotimes (i 20) (dotimes (i 20)
(let ((allp (random-allp 3))) (let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(setf gnrt (cat:tnpr allp-degr allp 5 (setf gnrt (cat:tnpr allp-degr allp 5
(cat:tnpr 3 15 2 (cat:loop3 0 15 2)))) (cat:tnpr 3 15 2 (cat:loop3 0 15 2))))
(unless (>= allp-degr 10) (unless (>= allp-degr 10)
(print (cat:? c (+ 5 allp-degr) gnrt)) (print (cat:? c (+ 5 allp-degr) gnrt))
(print (cat:? c (cat:? c (+ 5 allp-degr) gnrt)))))) (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt))))))
(dotimes (i 20) (dotimes (i 20)
(let ((allp (random-allp 3))) (let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(setf gnrt (cat:tnpr allp-degr allp 5 (setf gnrt (cat:tnpr allp-degr allp 5
(cat:tnpr 2 7 3 (cat:loop3 0 31 2)))) (cat:tnpr 2 7 3 (cat:loop3 0 31 2))))
(unless (>= allp-degr 10) (unless (>= allp-degr 10)
(print (cat:? c (+ 5 allp-degr) gnrt)) (print (cat:? c (+ 5 allp-degr) gnrt))
(print (cat:? c (cat:? c (+ 5 allp-degr) gnrt)))))))) (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt))))))))
(test ls-hat-u-t (test ls-hat-u-t
(cat:cat-init) (cat:cat-init)
(let ((c (cat:ls-hat-u-t (cat:deltab))) (let ((c (cat:ls-hat-u-t (cat:deltab)))
allp allp-degr gnrt) allp allp-degr gnrt)
(dotimes (i 10) (dotimes (i 10)
(let ((allp (random-allp 3))) (let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(setf gnrt (cat:tnpr allp-degr allp 4 (setf gnrt (cat:tnpr allp-degr allp 4
(cat:tnpr 2 7 2 (cat:loop3 0 15 2)))) (cat:tnpr 2 7 2 (cat:loop3 0 15 2))))
(unless (>= allp-degr 11) (unless (>= allp-degr 11)
(print (cat:? c (+ 4 allp-degr) gnrt)) (print (cat:? c (+ 4 allp-degr) gnrt))
(print (cat:? c (cat:? c (+ 4 allp-degr) gnrt)))))) (print (cat:? c (cat:? c (+ 4 allp-degr) gnrt))))))
(dotimes (i 20) (dotimes (i 20)
(let ((allp (random-allp 3))) (let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(setf gnrt (cat:tnpr allp-degr allp 5 (setf gnrt (cat:tnpr allp-degr allp 5
(cat:tnpr 3 15 2 (cat:loop3 0 15 2)))) (cat:tnpr 3 15 2 (cat:loop3 0 15 2))))
(unless (>= allp-degr 10) (unless (>= allp-degr 10)
(print (cat:? c (+ 5 allp-degr) gnrt)) (print (cat:? c (+ 5 allp-degr) gnrt))
(print (cat:? c (cat:? c (+ 5 allp-degr) gnrt)))))) (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt))))))
(dotimes (i 20) (dotimes (i 20)
(let ((allp (random-allp 3))) (let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(setf gnrt (cat:tnpr allp-degr allp 5 (setf gnrt (cat:tnpr allp-degr allp 5
(cat:tnpr 2 7 3 (cat:loop3 0 31 2)))) (cat:tnpr 2 7 3 (cat:loop3 0 31 2))))
(unless (>= allp-degr 10) (unless (>= allp-degr 10)
(print (cat:? c (+ 5 allp-degr) gnrt)) (print (cat:? c (+ 5 allp-degr) gnrt))
(print (cat:? c (cat:? c (+ 5 allp-degr) gnrt)))))))) (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt))))))))
(test ls-left-hmeq-hat (test ls-left-hmeq-hat
(cat:cat-init) (cat:cat-init)
(let ((c (cat:ls-left-hmeq-hat (cat:deltab))) (let ((c (cat:ls-left-hmeq-hat (cat:deltab)))
allp allp-degr gnrt) allp allp-degr gnrt)
(dotimes (i 10) (dotimes (i 10)
(let ((allp (random-allp 3))) (let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(setf gnrt (cat:tnpr allp-degr allp 4 (setf gnrt (cat:tnpr allp-degr allp 4
(cat:tnpr 2 7 2 (cat:loop3 0 15 2)))) (cat:tnpr 2 7 2 (cat:loop3 0 15 2))))
(unless (>= allp-degr 11) (unless (>= allp-degr 11)
(print (cat:? c (+ 4 allp-degr) gnrt)) (print (cat:? c (+ 4 allp-degr) gnrt))
(print (cat:? c (cat:? c (+ 4 allp-degr) gnrt)))))) (print (cat:? c (cat:? c (+ 4 allp-degr) gnrt))))))
(dotimes (i 20) (dotimes (i 20)
(let ((allp (random-allp 3))) (let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(setf gnrt (cat:tnpr allp-degr allp 5 (setf gnrt (cat:tnpr allp-degr allp 5
(cat:tnpr 3 15 2 (cat:loop3 0 15 2)))) (cat:tnpr 3 15 2 (cat:loop3 0 15 2))))
(unless (>= allp-degr 10) (unless (>= allp-degr 10)
(print (cat:? c (+ 5 allp-degr) gnrt)) (print (cat:? c (+ 5 allp-degr) gnrt))
(print (cat:? c (cat:? c (+ 5 allp-degr) gnrt)))))) (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt))))))
(dotimes (i 20) (dotimes (i 20)
(let ((allp (random-allp 3))) (let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (setf allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(setf gnrt (cat:tnpr allp-degr allp 5 (setf gnrt (cat:tnpr allp-degr allp 5
(cat:tnpr 2 7 3 (cat:loop3 0 31 2)))) (cat:tnpr 2 7 3 (cat:loop3 0 31 2))))
(unless (>= allp-degr 10) (unless (>= allp-degr 10)
(print (cat:? c (+ 5 allp-degr) gnrt)) (print (cat:? c (+ 5 allp-degr) gnrt))
(print (cat:? c (cat:? c (+ 5 allp-degr) gnrt)))))))) (print (cat:? c (cat:? c (+ 5 allp-degr) gnrt))))))))
(test ls-pre-left-hmeq-left-reduction-intr-f (test ls-pre-left-hmeq-left-reduction-intr-f
(cat: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)) (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)) 50 (cat:tnpr 0 'a 6 (cat:tnpr 0 'b 6 'cc))
10 (cat:tnpr 0 'a 6 (cat:tnpr 2 'b 4 'c)) 10 (cat:tnpr 0 'a 6 (cat:tnpr 2 'b 4 'c))
1 (cat:tnpr 2 'a 4 (cat:tnpr 2 'b 2 'cc))))) 1 (cat:tnpr 2 'a 4 (cat:tnpr 2 'b 2 'cc)))))
(test ls-left-hmeq-left-reduction-g-intr (test ls-left-hmeq-left-reduction-g-intr
(let ((r (cat: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 (test ls-pre-left-hmeq-left-reduction-h-intr
(cat:cat-init) (cat:cat-init)
(let ((r (cat:ls-pre-left-hmeq-left-reduction-h-intr (cat:deltab)))) (let ((r (cat:ls-pre-left-hmeq-left-reduction-h-intr (cat:deltab))))
(setf cat:*tnpr-with-degrees* t) (setf cat:*tnpr-with-degrees* t)
(funcall r (cat:cmbn 10 1 (cat:tnpr 3 (cat:allp 2 'a 1 'b) (funcall r (cat:cmbn 10 1 (cat:tnpr 3 (cat:allp 2 'a 1 'b)
7 (cat:tnpr 5 'c 2 'd)) 7 (cat:tnpr 5 'c 2 'd))
1 (cat:tnpr 7 (cat:allp 2 'a 5 'b) 1 (cat:tnpr 7 (cat:allp 2 'a 5 'b)
3 (cat:tnpr 0 '* 3 'c)) 3 (cat:tnpr 0 '* 3 'c))
10 (cat:tnpr 8 (cat:allp 4 'aa 4 'bb) 10 (cat:tnpr 8 (cat:allp 4 'aa 4 'bb)
2 (cat:tnpr 0 '* 2 'cc)))) 2 (cat:tnpr 0 '* 2 'cc))))
(funcall r (cat:cmbn 10 1 (cat:tnpr 3 (cat:allp 2 'a 1 'b) (funcall r (cat:cmbn 10 1 (cat:tnpr 3 (cat:allp 2 'a 1 'b)
7 (cat:tnpr 5 'c 2 'd)) 7 (cat:tnpr 5 'c 2 'd))
1 (cat:tnpr 7 (cat:allp 4 'a 3 'b) 1 (cat:tnpr 7 (cat:allp 4 'a 3 'b)
3 (cat:tnpr 0 '* 3 'c)) 3 (cat:tnpr 0 '* 3 'c))
10 (cat:tnpr 8 (cat:allp 3 'aa 5 'bb) 10 (cat:tnpr 8 (cat:allp 3 'aa 5 'bb)
2 (cat:tnpr 0 '* 2 'cc)))) 2 (cat:tnpr 0 '* 2 'cc))))
(setf cat:*tnpr-with-degrees* nil))) (setf cat:*tnpr-with-degrees* nil)))
#| #|
(test ls-pre-left-hmeq-left-reduction (test ls-pre-left-hmeq-left-reduction
(cat:cat-init) (cat:cat-init)
(let* ((rdct (cat:ls-pre-left-hmeq-left-reduction (cat:deltab))) (let* ((rdct (cat:ls-pre-left-hmeq-left-reduction (cat:deltab)))
(allp (random-allp 3)) (allp (random-allp 3))
(allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp)))) (allp-degr (apply #'+ (mapcar #'car (cat:allp-list allp))))
(gnrt (cat:tnpr allp-degr allp 4 (cat:tnpr 2 7 2 (gnrt (cat:tnpr allp-degr allp 4 (cat:tnpr 2 7 2
(cat:loop3 0 15 2))))) (cat:loop3 0 15 2)))))
(cat:pre-check-rdct rdct) (cat:pre-check-rdct rdct)
(setf cat:*tc* (cat:cmbn (+ 4 allp-degr) 1 gnrt)) (setf cat:*tc* (cat:cmbn (+ 4 allp-degr) 1 gnrt))
(setf cat:*bc* (cat:cmbn 2 1 (cat:loop3 0 15 2))) (setf cat:*bc* (cat:cmbn 2 1 (cat:loop3 0 15 2)))
(check-rdct) (check-rdct)
(setf gnrt (cat:tnpr allp-degr allp 4 (setf gnrt (cat:tnpr allp-degr allp 4
(cat:tnpr 0 1 4 (cat:loop3 0 (cat:mask 6) 2)))) (cat:tnpr 0 1 4 (cat:loop3 0 (cat:mask 6) 2))))
(setf cat:*tc* (cat:cmbn (+ 4 allp-degr) 1 gnrt)) (setf cat:*tc* (cat:cmbn (+ 4 allp-degr) 1 gnrt))
(check-rdct) (check-rdct)
(setf cat:*bc* (cat:cmbn 0 1 (cat:bspn (cat:bcc 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)))) (setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn (cat:tcc rdct))))
(check-rdct))) (check-rdct)))
|# |#
(defun a (d1 d2 d3) (defun a (d1 d2 d3)
(setf cat:*tc* (cat:cmbn (+ d1 d2 d3) (setf cat:*tc* (cat:cmbn (+ d1 d2 d3)
1 (cat:tnpr 1 (cat:tnpr
d1 (cat:allp d1 (cat:mask (+ d1 2))) d1 (cat:allp d1 (cat:mask (+ d1 2)))
(+ d2 d3) (+ d2 d3)
(cat:tnpr d2 (cat:mask (1+ d2)) (cat:tnpr d2 (cat:mask (1+ d2))
d3 (cat:loop3 d3 (cat:loop3
0 (cat:mask (+ d3 2)) 1)))) 0 (cat:mask (+ d3 2)) 1))))
cat:*bc* (cat:cmbn d3 1 (cat:loop3 0 (cat:mask (+ d3 2)) -1))) cat:*bc* (cat:cmbn d3 1 (cat:loop3 0 (cat:mask (+ d3 2)) -1)))
(check-rdct)) (check-rdct))
(test ls-left-hmeq-left-reduction (test ls-left-hmeq-left-reduction
(cat:cat-init) (cat:cat-init)
(let ((rdct (cat:ls-left-hmeq-left-reduction (cat:deltab2)))) (let ((rdct (cat:ls-left-hmeq-left-reduction (cat:deltab2))))
(cat:pre-check-rdct rdct) (cat:pre-check-rdct rdct)
#| #|
(a 1 0 1) (a 1 0 1)
(a 1 1 1) ;; error because 3 does not exist in deltab2 (a 1 1 1) ;; error because 3 does not exist in deltab2
(a 1 2 1) (a 1 2 1)
(a 2 2 1) (a 2 2 1)
|# |#
) )
) )
@ -178,86 +180,86 @@
(test ls-pre-left-hmeq-right-reduction-intr-g (test ls-pre-left-hmeq-right-reduction-intr-g
(let ((r (cat: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 (test ls-pre-left-hmeq-right-reduction
(cat:cat-init) (cat:cat-init)
(let ((r (cat:ls-pre-left-hmeq-right-reduction (cat:deltab2)))) (let ((r (cat:ls-pre-left-hmeq-right-reduction (cat:deltab2))))
(cat:pre-check-rdct r) (cat:pre-check-rdct r)
(setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn (cat:tcc 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)))) (setf cat:*bc* (cat:cmbn 0 1 (cat:bsgn (cat:bcc r))))
(check-rdct) (check-rdct)
#| #|
(setf cat:*tc* (cat:cmbn (setf cat:*tc* (cat:cmbn
3 1 (cat:tnpr 3 (cat:allp 3 (cat:mask 5)) 3 1 (cat:tnpr 3 (cat:allp 3 (cat:mask 5))
0 (cat:tnpr 0 1 0 cat:+null-loop+)))) 0 (cat:tnpr 0 1 0 cat:+null-loop+))))
(setf cat:*bc* (cat:cmbn 3 1 (cat:allp 1 7 2 15))) (setf cat:*bc* (cat:cmbn 3 1 (cat:allp 1 7 2 15)))
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn (setf cat:*tc* (cat:cmbn
6 1 (cat:tnpr 3 (cat:allp 1 7 2 15) 6 1 (cat:tnpr 3 (cat:allp 1 7 2 15)
3 (cat:tnpr 2 7 1 (cat:loop3 0 7 2))))) 3 (cat:tnpr 2 7 1 (cat:loop3 0 7 2)))))
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn (setf cat:*tc* (cat:cmbn
6 1 (cat:tnpr 6 1 (cat:tnpr
3 (cat:allp 1 7 2 15) 3 (cat:allp 1 7 2 15)
3 (cat:tnpr 0 1 3 3 (cat:tnpr 0 1 3
(cat:loop3 0 (cat:mask 5) 2))))) (cat:loop3 0 (cat:mask 5) 2)))))
(check-rdct) (check-rdct)
|# |#
)) ))
(test ls-left-hmeq-right-reduction (test ls-left-hmeq-right-reduction
(cat:cat-init) (cat:cat-init)
(let ((r (cat:ls-left-hmeq-right-reduction (cat:deltab2)))) (let ((r (cat:ls-left-hmeq-right-reduction (cat:deltab2))))
(cat:pre-check-rdct r) (cat:pre-check-rdct r)
(setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn (cat:tcc 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)))) (setf cat:*bc* (cat:cmbn 0 1 (cat:bsgn (cat:bcc r))))
(check-rdct) (check-rdct)
#| #|
(setf cat:*tc* (cat:cmbn 3 1 (cat:tnpr 3 (cat:allp 3 (cat:mask 5)) (setf cat:*tc* (cat:cmbn 3 1 (cat:tnpr 3 (cat:allp 3 (cat:mask 5))
0 (cat:tnpr 0 1 0 0 (cat:tnpr 0 1 0
cat:+null-loop+)))) cat:+null-loop+))))
(setf cat:*bc* (cat:cmbn 3 1 (cat:allp 1 7 2 15))) (setf cat:*bc* (cat:cmbn 3 1 (cat:allp 1 7 2 15)))
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn (setf cat:*tc* (cat:cmbn
6 1 (cat:tnpr 3 (cat:allp 1 7 2 15) 6 1 (cat:tnpr 3 (cat:allp 1 7 2 15)
3 (cat:tnpr 2 7 1 (cat:loop3 0 7 2))))) 3 (cat:tnpr 2 7 1 (cat:loop3 0 7 2)))))
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn (setf cat:*tc* (cat:cmbn
6 1 (cat:tnpr 3 (cat:allp 1 7 2 15) 6 1 (cat:tnpr 3 (cat:allp 1 7 2 15)
3 (cat:tnpr 0 1 3 3 (cat:tnpr 0 1 3
(cat:loop3 0 (mask 5) 2))))) (cat:loop3 0 (mask 5) 2)))))
(check-rdct) (check-rdct)
|# |#
)) ))
#| #|
(test ls-left-hmeq (test ls-left-hmeq
(cat:cat-init) (cat:cat-init)
(let* ((h (cat:ls-left-hmeq (cat:deltab2))) (let* ((h (cat:ls-left-hmeq (cat:deltab2)))
(loop (cat:loop3 0 (cat:mask 5) 2)) (loop (cat:loop3 0 (cat:mask 5) 2))
(allp (cat:allp 2 (cat:mask 4) 3 (cat:mask 5))) (allp (cat:allp 2 (cat:mask 4) 3 (cat:mask 5)))
x) x)
(setf x (cat:lg h 3 loop)) (setf x (cat:lg h 3 loop))
(setf x (cat:rf h x)) (setf x (cat:rf h x))
(setf x (cat:rg h x)) (setf x (cat:rg h x))
(setf x (cat:lf h x)) (setf x (cat:lf h x))
(setf x (cat:rg h 5 allp)) (setf x (cat:rg h 5 allp))
(setf x (cat:lf h x)) (setf x (cat:lf h x))
(setf x (cat:lg h x)) (setf x (cat:lg h x))
(setf x (cat:rf h x)) ;; = allp, but why ? (setf x (cat:rf h x)) ;; = allp, but why ?
)) ))
|# |#
(test loop-space (test loop-space
(cat:cat-init) (cat:cat-init)
(let ((l (cat:loop-space (cat:sphere 2))) (let ((l (cat:loop-space (cat:sphere 2)))
(oos3 (cat:loop-space (cat:loop-space (cat:sphere 3)))) (oos3 (cat:loop-space (cat:loop-space (cat:sphere 3))))
(ooos4 (cat:loop-space (cat:loop-space (cat:loop-space (ooos4 (cat:loop-space (cat:loop-space (cat:loop-space
(cat:sphere 4)))))) (cat:sphere 4))))))
(cat:homology l 6) (cat:homology l 6)
(cat:homology oos3 3) (cat:homology oos3 3)
(cat:homology ooos4 2))) (cat:homology ooos4 2)))

251
test/ls-twisted-products-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -6,75 +7,75 @@
(test absm-loopabsm (test absm-loopabsm
(let ((cmpr (cat:cmpr (cat:deltab)))) (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 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 0 15) (cat:absm 7 cat:+null-loop+))
(cat:absm-loopabsm cmpr 3 (cat:absm 2 7) (cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
(cat:absm 2 (cat:loop3 0 7 4))) (cat:absm 2 (cat:loop3 0 7 4)))
(cat:absm-loopabsm cmpr 3 (cat:absm 2 7) (cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
(cat:absm 2 (cat:loop3 0 7 4 1 12 -1))) (cat:absm 2 (cat:loop3 0 7 4 1 12 -1)))
(cat:absm-loopabsm cmpr 3 (cat:absm 2 7) (cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
(cat:absm 2 (cat:loop3 0 7 -1))) (cat:absm 2 (cat:loop3 0 7 -1)))
(cat:absm-loopabsm cmpr 3 (cat:absm 2 7) (cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
(cat:absm 2 (cat:loop3 0 7 -1 1 12 -1))) (cat:absm 2 (cat:loop3 0 7 -1 1 12 -1)))
(cat:absm-loopabsm cmpr 3 (cat:absm 2 7) (cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
(cat:absm 2 (cat:loop3 0 7 4))) (cat:absm 2 (cat:loop3 0 7 4)))
(cat:absm-loopabsm cmpr 3 (cat:absm 2 7) (cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
(cat:absm 0 (cat:loop3 2 7 4 1 14 -1))) (cat:absm 0 (cat:loop3 2 7 4 1 14 -1)))
;; in principle illegal but works ;; in principle illegal but works
(cat:absm-loopabsm cmpr 3 (cat:absm 2 7) (cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
(cat:absm 0 (cat:loop3 2 7 -1))) (cat:absm 0 (cat:loop3 2 7 -1)))
(cat:absm-loopabsm cmpr 3 (cat:absm 2 7) (cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
(cat:absm 0 (cat:loop3 2 7 -1 1 14 -1))) (cat:absm 0 (cat:loop3 2 7 -1 1 14 -1)))
(cat:absm-loopabsm cmpr 3 (cat:absm 2 7) (cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
(cat:absm 0 (cat:loop3 0 15 -1 1 14 -1))) (cat:absm 0 (cat:loop3 0 15 -1 1 14 -1)))
(cat:absm-loopabsm cmpr 3 (cat:absm 0 15) (cat:absm-loopabsm cmpr 3 (cat:absm 0 15)
(cat:absm 2 (cat:loop3 0 7 -1 0 14 -1))) (cat:absm 2 (cat:loop3 0 7 -1 0 14 -1)))
(cat:absm-loopabsm cmpr 3 (cat:absm 2 7) (cat:absm-loopabsm cmpr 3 (cat:absm 2 7)
(cat:absm 2 (cat:loop3 0 28 -1 0 14 -1))))) (cat:absm 2 (cat:loop3 0 28 -1 0 14 -1)))))
(test twisted-crts-prdc (test twisted-crts-prdc
(cat:cat-init) (cat:cat-init)
(let* ((p (cat:r-proj-space 3)) (let* ((p (cat:r-proj-space 3))
(tw (cat:twisted-crts-prdc p)) (tw (cat:twisted-crts-prdc p))
(cmpr (cat:cmpr tw)) (cmpr (cat:cmpr tw))
(c (random-cmbn cmpr 8 10 4 4 100))) (c (random-cmbn cmpr 8 10 4 4 100)))
(time (cat:? tw (cat:? tw c))) (time (cat:? tw (cat:? tw c)))
(time (cat:? tw (cat:? tw c))))) (time (cat:? tw (cat:? tw c)))))
(test dtau-d-intr (test dtau-d-intr
(cat:cat-init) (cat:cat-init)
(let* ((d (cat:deltab)) (let* ((d (cat:deltab))
(p (cat:crts-prdc d (cat:loop-space d))) (p (cat:crts-prdc d (cat:loop-space d)))
(tw (cat:twisted-crts-prdc d)) (tw (cat:twisted-crts-prdc d))
(crts-prdc-cmpr (cat:cmpr p)) (crts-prdc-cmpr (cat:cmpr p))
(crts-prdc-face (cat:face p)) (crts-prdc-face (cat:face p))
(twisted-crts-prdc-face (cat:face tw)) (twisted-crts-prdc-face (cat:face tw))
(delta (cat:dtau-d-intr crts-prdc-cmpr crts-prdc-face (delta (cat:dtau-d-intr crts-prdc-cmpr crts-prdc-face
twisted-crts-prdc-face))) twisted-crts-prdc-face)))
(funcall delta 3 (cat:crpr 0 15 0 (cat:loop3 0 (- 2048 64) 1))) (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 10 15 5 (cat:loop3 0 (- 2048 64) 1)))
(funcall delta 5 (cat:crpr 5 15 10 (cat:loop3 0 (- 2048 64) 1))))) (funcall delta 5 (cat:crpr 5 15 10 (cat:loop3 0 (- 2048 64) 1)))))
(test szczarba (test szczarba
(cat:cat-init) (cat:cat-init)
(let ((rdct (cat:szczarba (cat:deltab))) (let ((rdct (cat:szczarba (cat:deltab)))
bcc) bcc)
(cat:pre-check-rdct rdct) (cat:pre-check-rdct rdct)
(setf cat:*tc* (cat:cmbn 2 1 (cat:crpr 0 7 0 (setf cat:*tc* (cat:cmbn 2 1 (cat:crpr 0 7 0
(cat:loop3 0 (- 512 32) 1))) (cat:loop3 0 (- 512 32) 1)))
cat:*bc* (cat:cmbn 2 1 (cat:tnpr 0 1 2 cat:*bc* (cat:cmbn 2 1 (cat:tnpr 0 1 2
(cat:loop3 0 (- 512 32) 1)) (cat:loop3 0 (- 512 32) 1))
10 (cat:tnpr 1 (- 4096 1024) 1 10 (cat:tnpr 1 (- 4096 1024) 1
(cat:loop3 0 7 1)) (cat:loop3 0 7 1))
100 (cat:tnpr 2 7 0 100 (cat:tnpr 2 7 0
(cat:loop3 0 (- 4096 1024) 1)))) (cat:loop3 0 (- 4096 1024) 1))))
(check-rdct) (check-rdct)
(setf bcc (cat:bcc rdct)) (setf bcc (cat:bcc rdct))
(time (cat:? bcc 5 (cat:tnpr 5 (cat:mask 6) 0 cat:+null-loop+))) (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+))))) (time (cat:? bcc 6 (cat:tnpr 6 (cat:mask 7) 0 cat:+null-loop+)))))
(test pop-first-absm (test pop-first-absm
@ -94,88 +95,88 @@
(test crts-contraction-intr (test crts-contraction-intr
(cat:cat-init) (cat:cat-init)
(let* ((delta (cat:deltab)) (let* ((delta (cat:deltab))
(tw (cat:twisted-crts-prdc delta)) (tw (cat:twisted-crts-prdc delta))
(d (cat:bndr tw)) (d (cat:bndr tw))
(base-cmpr (cat:cmpr delta)) (base-cmpr (cat:cmpr delta))
(base-bspn (cat:bspn delta)) (base-bspn (cat:bspn delta))
(base-face (cat:face delta)) (base-face (cat:face delta))
(crts-cmpr (cat:cmpr tw)) (crts-cmpr (cat:cmpr tw))
(r (cat:crts-contraction-intr base-cmpr base-bspn base-face (r (cat:crts-contraction-intr base-cmpr base-bspn base-face
crts-cmpr)) crts-cmpr))
(h (cat:build-mrph :sorc tw :trgt tw :degr +1 (h (cat:build-mrph :sorc tw :trgt tw :degr +1
:intr r :strt :gnrt :intr r :strt :gnrt
:orgn `(crts-contraction ,delta))) :orgn `(crts-contraction ,delta)))
(z (cat:i-sbtr (cat:idnt-mrph tw) (cat:cmps d h) (cat:cmps h d)))) (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+)) (cat:? z 0 (cat:crpr 0 1 0 cat:+null-loop+))
(funcall r 0 (cat:crpr 0 1 0 (cat:loop3 0 96 1))) (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)))
(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)))
(cat:? z 0 (cat:crpr 0 1 0 (cat:loop3 0 96 1 0 (+ 256 128) (cat:? z 0 (cat:crpr 0 1 0 (cat:loop3 0 96 1 0 (+ 256 128)
1 0 (+ 512 1024) 1))) 1 0 (+ 512 1024) 1)))
(cat:? z 0 (cat:crpr 0 1 0 (cat:loop3 0 96 2))) (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 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 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) (cat:? z 3 (cat:crpr 2 7 1 (cat:loop3 2 (+ 32 64 128)
2 4 (+ 32 64 128) -2))) 2 4 (+ 32 64 128) -2)))
(cat:? z 3 (cat:crpr 2 7 4 (cat:loop3 2 (+ 32 64 128) (cat:? z 3 (cat:crpr 2 7 4 (cat:loop3 2 (+ 32 64 128)
2 1 (+ 32 64 128) -2))) 2 1 (+ 32 64 128) -2)))
(cat:? z 3 (cat:crpr 2 7 1 (cat:loop3 2 (+ 32 64 128) (cat:? z 3 (cat:crpr 2 7 1 (cat:loop3 2 (+ 32 64 128)
-2 4 (+ 32 64 128) 2))) -2 4 (+ 32 64 128) 2)))
(cat:? z 3 (cat:crpr 2 7 4 (cat:loop3 2 (+ 32 64 128) (cat:? z 3 (cat:crpr 2 7 4 (cat:loop3 2 (+ 32 64 128)
-2 1 (+ 32 64 128) 2))) -2 1 (+ 32 64 128) 2)))
(cat:? z 3 (cat:crpr 1 7 2 (cat:loop3 2 (+ 32 64 128) (cat:? z 3 (cat:crpr 1 7 2 (cat:loop3 2 (+ 32 64 128)
2 4 (+ 32 64 128) -2))) 2 4 (+ 32 64 128) -2)))
(cat:? z 3 (cat:crpr 4 7 2 (cat:loop3 2 (+ 32 64 128) (cat:? z 3 (cat:crpr 4 7 2 (cat:loop3 2 (+ 32 64 128)
2 1 (+ 32 64 128) -2))) 2 1 (+ 32 64 128) -2)))
(cat:? z 3 (cat:crpr 1 7 2 (cat:loop3 2 (+ 32 64 128) (cat:? z 3 (cat:crpr 1 7 2 (cat:loop3 2 (+ 32 64 128)
-2 4 (+ 32 64 128) 2))) -2 4 (+ 32 64 128) 2)))
(cat:? z 3 (cat:crpr 4 7 2 (cat:loop3 2 (+ 32 64 128) (cat:? z 3 (cat:crpr 4 7 2 (cat:loop3 2 (+ 32 64 128)
-2 1 (+ 32 64 128) 2))))) -2 1 (+ 32 64 128) 2)))))
(test crts-contraction (test crts-contraction
(cat:cat-init) (cat:cat-init)
(let* ((p (cat:r-proj-space 3)) (let* ((p (cat:r-proj-space 3))
(tw (cat:twisted-crts-prdc p)) (tw (cat:twisted-crts-prdc p))
(cmpr (cat:cmpr tw)) (cmpr (cat:cmpr tw))
(r (cat:crts-contraction-intr (cat:cmpr p) (cat:bspn p) (r (cat:crts-contraction-intr (cat:cmpr p) (cat:bspn p)
(cat:face p) (cat:cmpr tw))) (cat:face p) (cat:cmpr tw)))
(h (cat:build-mrph :sorc tw :trgt tw :degr +1 (h (cat:build-mrph :sorc tw :trgt tw :degr +1
:intr r :strt :gnrt :intr r :strt :gnrt
:orgn `(cat:crts-contraction ,p))) :orgn `(cat:crts-contraction ,p)))
(d (cat:bndr tw)) (d (cat:bndr tw))
(z (cat:i-sbtr (cat:idnt-mrph tw) (cat:cmps h d) (cat:cmps d h))) (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))) (c (random-cmbn cmpr 5 10 2 2 1)))
(cat:? z c) (cat:? z c)
(setf c (random-cmbn cmpr 6 10 3 3 3)) (setf c (random-cmbn cmpr 6 10 3 3 3))
(cat:? z c) (cat:? z c)
(setf c (random-cmbn cmpr 7 10 4 4 6)) (setf c (random-cmbn cmpr 7 10 4 4 6))
(cat:? z c) (cat:? z c)
(setf c (random-cmbn cmpr 8 10 4 4 20)) (setf c (random-cmbn cmpr 8 10 4 4 20))
(cat:? z c) (cat:? z c)
(cat:? h c) (cat:? h c)
(cat:? d (cat:? h c)) (cat:? d (cat:? h c))
(print (length (cat:cmbn-list (cat:? d (cat:? h c))))))) (print (length (cat:cmbn-list (cat:? d (cat:? h c)))))))
(test crts-contraction1 (test crts-contraction1
(let* ((h (cat:crts-contraction (cat:deltab))) (let* ((h (cat:crts-contraction (cat:deltab)))
(d (cat:bndr (cat:twisted-crts-prdc (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) (z (cat:i-sbtr (cat:idnt-mrph (cat:sorc d)) (cat:cmps d h)
(cat:cmps h d)))) (cat:cmps h d))))
(cat:? z 3 (cat:crpr 4 7 2 (cat:loop3 2 (+ 32 64 128) (cat:? z 3 (cat:crpr 4 7 2 (cat:loop3 2 (+ 32 64 128)
-2 1 (+ 32 64 128) 2))))) -2 1 (+ 32 64 128) 2)))))
(test tnpr-contraction (test tnpr-contraction
(cat:cat-init) (cat:cat-init)
(let* ((delta (cat:deltab)) (let* ((delta (cat:deltab))
(sz (cat:szczarba (cat:deltab))) (sz (cat:szczarba (cat:deltab)))
(tw (cat:bcc sz)) (tw (cat:bcc sz))
(h (cat:tnpr-contraction delta)) (h (cat:tnpr-contraction delta))
(z (cat:i-sbtr (cat:idnt-mrph tw) (cat:cmps tw h) (z (cat:i-sbtr (cat:idnt-mrph tw) (cat:cmps tw h)
(cat:cmps h tw)))) (cat:cmps h tw))))
(time (cat:? z 3 (cat:tnpr 0 1 3 (cat:loop3 0 (cat:mask 5) (time (cat:? z 3 (cat:tnpr 0 1 3 (cat:loop3 0 (cat:mask 5)
2 0 (* 32 (cat:mask 5)) 2 0 (* 32 (cat:mask 5))
-1)))) -1))))
(cat:? h 4 (cat:tnpr 0 1 0 (cat:loop3 0 (cat:mask 6) 1))))) (cat:? h 4 (cat:tnpr 0 1 0 (cat:loop3 0 (cat:mask 6) 1)))))

57
test/macros-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -21,30 +22,30 @@
(test lexico (test lexico
(setf cl:*print-level* nil) (setf cl:*print-level* nil)
(pprint (macroexpand-1 (pprint (macroexpand-1
'(cat:lexico '(cat:lexico
comparison1 comparison1
comparison2 comparison2
comparison3 comparison3
comparison4)))) comparison4))))
(test with-term (test with-term
(macroexpand-1 '(cat:with-term (cffc gnrt) term (macroexpand-1 '(cat:with-term (cffc gnrt) term
(statement-1) (statement-1)
(statement-2))) (statement-2)))
(macroexpand-1 '(cat:with-term (nil gnrt) term (macroexpand-1 '(cat:with-term (nil gnrt) term
(statement-1) (statement-1)
(statement-2)))) (statement-2))))
(test with--term (test with--term
(macroexpand-1 '(cat:with--term (cffc gnrt) mark (macroexpand-1 '(cat:with--term (cffc gnrt) mark
(statement-1) (statement-1)
(statement-2)))) (statement-2))))
(test with-cmbn (test with-cmbn
(macroexpand-1 '(cat:with-cmbn (degr list) cmbn (macroexpand-1 '(cat:with-cmbn (degr list) cmbn
(statement-1) (statement-1)
(statement-2)))) (statement-2))))
(test cmpr (test cmpr
@ -88,11 +89,11 @@
(test with-tnpr (test with-tnpr
(macroexpand-1 '(cat:with-tnpr (degr1 gnrt1 degr2 gnrt2) tnpr (macroexpand-1 '(cat:with-tnpr (degr1 gnrt1 degr2 gnrt2) tnpr
(statement-1) (statement-1)
(statement-2))) (statement-2)))
(macroexpand-1 '(cat:with-tnpr (nil gnrt1 degr2 gnrt2) tnpr (macroexpand-1 '(cat:with-tnpr (nil gnrt1 degr2 gnrt2) tnpr
(statement-1) (statement-1)
(statement-2)))) (statement-2))))
(test crpr (test crpr
@ -101,23 +102,21 @@
(macroexpand '(cat:crpr absm1 absm2)) (macroexpand '(cat:crpr absm1 absm2))
(macroexpand '(cat:crpr dgop1 gmsm1 dgop2 gmsm2)) (macroexpand '(cat:crpr dgop1 gmsm1 dgop2 gmsm2))
(let ((c (cat:crpr 1 'a 2 'b))) (let ((c (cat:crpr 1 'a 2 'b)))
(cat:dgop1 c) (cat:dgop1 c)
(cat:gmsm1 c) (cat:gmsm1 c)
(cat:dgop2 c) (cat:dgop2 c)
(cat:gmsm2 c) (cat:gmsm2 c)
(cat:absm1 c) (cat:absm1 c)
(cat:absm2 c))) (cat:absm2 c)))
(test with-crpr (test with-crpr
(cat:with-crpr (absm1 absm2) (cat:crpr 3 'a 4 'b) (list absm1 absm2)) (cat:with-crpr (absm1 absm2) (cat:crpr 3 'a 4 'b) (list absm1 absm2))
(macroexpand-1 (macroexpand-1
(macroexpand-1 '(cat:with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr (macroexpand-1 '(cat:with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr
(statement-1) (statement-1)
(statement-2)))) (statement-2))))
(macroexpand-1 (macroexpand-1
(macroexpand-1 '(cat:with-crpr (absm1 absm2) crpr (macroexpand-1 '(cat:with-crpr (absm1 absm2) crpr
(statement-1) (statement-1)
(statement-2))))) (statement-2)))))

3
test/package.lisp
View File

@ -1,3 +1,5 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
;;;; package.lisp ;;;; package.lisp
(defpackage :kenzo-test (defpackage :kenzo-test
@ -6,4 +8,3 @@
(in-package :kenzo-test) (in-package :kenzo-test)
(def-suite :kenzo) (def-suite :kenzo)

7
test/searching-homology-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -5,6 +6,6 @@
(test homology (test homology
(progn (progn
(cat:cat-init) (cat:cat-init)
(let ((d (cat:delta 3))) (let ((d (cat:delta 3)))
(princ (cat:homology d 0))))) (princ (cat:homology d 0)))))

177
test/serre-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -7,123 +8,123 @@
(test fibration-dtau-d-intr (test fibration-dtau-d-intr
(cat:cat-init) (cat:cat-init)
(let* ((s2 (cat:sphere 2)) (let* ((s2 (cat:sphere 2))
(k (cat:k-z2-1)) (k (cat:k-z2-1))
(tw (cat:build-smmr (tw (cat:build-smmr
:sorc s2 :sorc s2
:trgt k :trgt k
:degr -1 :degr -1
:sintr #'(lambda (dmns gmsm) :sintr #'(lambda (dmns gmsm)
(cat:absm 0 1)) (cat:absm 0 1))
:orgn '(s2-tw-kz2))) :orgn '(s2-tw-kz2)))
(dt-d (cat:fibration-dtau-d-intr tw))) (dt-d (cat:fibration-dtau-d-intr tw)))
(funcall dt-d 0 (cat:crpr 0 '* 0 0)) (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 4 's2 0 3))
(funcall dt-d 3 (cat:crpr 2 '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 3 (cat:crpr 2 's2 5 1))
(funcall dt-d 2 (cat:crpr 0 's2 0 2)))) (funcall dt-d 2 (cat:crpr 0 's2 0 2))))
(test fibration-dtau-d-intr1 (test fibration-dtau-d-intr1
(cat:cat-init) (cat:cat-init)
(let* ((s2 (cat:sphere 2)) (let* ((s2 (cat:sphere 2))
(k (cat:k-z-1)) (k (cat:k-z-1))
(tw (cat:build-smmr (tw (cat:build-smmr
:sorc s2 :sorc s2
:trgt k :trgt k
:degr -1 :degr -1
:sintr #'(lambda (dmns gmsm) :sintr #'(lambda (dmns gmsm)
(cat:absm 0 (list 1))) (cat:absm 0 (list 1)))
:orgn '(s2-tw-kz))) :orgn '(s2-tw-kz)))
(dt-d (cat:fibration-dtau-d-intr tw))) (dt-d (cat:fibration-dtau-d-intr tw)))
(funcall dt-d 0 (cat:crpr 0 '* 0 nil)) (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 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 0 '(2 3 4)))
(funcall dt-d 3 (cat:crpr 2 's2 5 '(5))) (funcall dt-d 3 (cat:crpr 2 's2 5 '(5)))
(funcall dt-d 2 (cat:crpr 0 's2 0 '(3 -2))))) (funcall dt-d 2 (cat:crpr 0 's2 0 '(3 -2)))))
(test fibration-dtau-d (test fibration-dtau-d
(cat:cat-init) (cat:cat-init)
(let* ((s2 (cat:sphere 2)) (let* ((s2 (cat:sphere 2))
(k (cat:k-z-1)) (k (cat:k-z-1))
(tw (cat:build-smmr (tw (cat:build-smmr
:sorc s2 :sorc s2
:trgt k :trgt k
:degr -1 :degr -1
:sintr #'(lambda (dmns gmsm) :sintr #'(lambda (dmns gmsm)
(cat:absm 0 (list 1))) (cat:absm 0 (list 1)))
:orgn '(s2-tw-kz))) :orgn '(s2-tw-kz)))
(dt-d (cat:fibration-dtau-d tw))) (dt-d (cat:fibration-dtau-d tw)))
(cat:? dt-d 0 (cat:crpr 0 '* 0 nil)) (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 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 0 '(2 3 4)))
(cat:? dt-d 3 (cat:crpr 2 's2 5 '(5))) (cat:? dt-d 3 (cat:crpr 2 's2 5 '(5)))
(cat:? dt-d 2 (cat:crpr 0 's2 0 '(3 -2))))) (cat:? dt-d 2 (cat:crpr 0 's2 0 '(3 -2)))))
(test brown-reduction (test brown-reduction
(cat:cat-init) (cat:cat-init)
(let* ((s2 (cat:sphere 2)) (let* ((s2 (cat:sphere 2))
(k (cat:k-z2-1)) (k (cat:k-z2-1))
(tw (cat:build-smmr (tw (cat:build-smmr
:sorc s2 :sorc s2
:trgt k :trgt k
:degr -1 :degr -1
:sintr #'(lambda (dmns gmsm) :sintr #'(lambda (dmns gmsm)
(cat:absm 0 1)) (cat:absm 0 1))
:orgn '(s2-tw-kz2))) :orgn '(s2-tw-kz2)))
(brown (cat:brown-reduction tw)) (brown (cat:brown-reduction tw))
(tcc (cat:tcc brown)) (tcc (cat:tcc brown))
(bcc (cat:bcc brown))) (bcc (cat:bcc brown)))
(cat:homology bcc 3) (cat:homology bcc 3)
(cat:homology tcc 1 8) (cat:homology tcc 1 8)
(cat:homology bcc 1 8))) (cat:homology bcc 1 8)))
#| #|
(test brown-reduction1 (test brown-reduction1
(cat:cat-init) (cat:cat-init)
(let* ((s2 (cat:sphere 2)) (let* ((s2 (cat:sphere 2))
(k (cat:k-z-1)) (k (cat:k-z-1))
(tw (cat:build-smmr (tw (cat:build-smmr
:sorc s2 :sorc s2
:trgt k :trgt k
:degr -1 :degr -1
:sintr #'(lambda (dmns gmsm) :sintr #'(lambda (dmns gmsm)
(cat:absm 0 (list 1))) (cat:absm 0 (list 1)))
:orgn '(s2-tw-kz))) :orgn '(s2-tw-kz)))
(brown (cat:brown-reduction tw))) (brown (cat:brown-reduction tw)))
(cat:homology (cat:tcc brown) 1 5) (cat:homology (cat:tcc brown) 1 5)
(cat:homology (cat:bcc brown) 1 5))) (cat:homology (cat:bcc brown) 1 5)))
|# |#
(test right-serre-efhm (test right-serre-efhm
(cat:cat-init) (cat:cat-init)
(let* ((s2 (cat:sphere 2)) (let* ((s2 (cat:sphere 2))
(k (cat:k-z-1)) (k (cat:k-z-1))
(tw (cat:build-smmr (tw (cat:build-smmr
:sorc s2 :sorc s2
:trgt k :trgt k
:degr -1 :degr -1
:sintr #'(lambda (dmns gmsm) :sintr #'(lambda (dmns gmsm)
(cat:absm 0 (list 1))) (cat:absm 0 (list 1)))
:orgn '(s2-tw-kz1))) :orgn '(s2-tw-kz1)))
(rh (cat:right-serre-efhm tw)) (rh (cat:right-serre-efhm tw))
(rbcc (cat:rbcc rh))) (rbcc (cat:rbcc rh)))
(cat:homology rbcc 0 5))) (cat:homology rbcc 0 5)))
(test fibration-total (test fibration-total
(cat:cat-init) (cat:cat-init)
(let* ((s2 (cat:sphere 2)) (let* ((s2 (cat:sphere 2))
(k (cat:k-z-1)) (k (cat:k-z-1))
(tw (cat:build-smmr (tw (cat:build-smmr
:sorc s2 :sorc s2
:trgt k :trgt k
:degr -1 :degr -1
:sintr #'(lambda (dmns gmsm) :sintr #'(lambda (dmns gmsm)
(cat:absm 0 (list 1))) (cat:absm 0 (list 1)))
:orgn '(s2-tw-kz1))) :orgn '(s2-tw-kz1)))
(p3r (cat:fibration-total tw))) (p3r (cat:fibration-total tw)))
(cat:homology p3r 1))) (cat:homology p3r 1)))
(test dummy (test dummy

11
test/simplicial-groups-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -6,8 +7,8 @@
(test check-kan (test check-kan
(cat:cat-init) (cat:cat-init)
(let* ((k (cat:k-z-1)) (let* ((k (cat:k-z-1))
(rslt '(1 10 100)) (rslt '(1 10 100))
(hat (mapcar #'(lambda (i) (cat:face k i 3 rslt)) (hat (mapcar #'(lambda (i) (cat:face k i 3 rslt))
(cat:<a-b> 0 3)))) (cat:<a-b> 0 3))))
(dotimes (i 4) (dotimes (i 4)
(cat:check-kan k i 3 (remove (nth i hat) hat :test #'equal))))) (cat:check-kan k i 3 (remove (nth i hat) hat :test #'equal)))))

23
test/simplicial-mrphs-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -6,14 +7,14 @@
(test build-smmr (test build-smmr
(let* ((d (cat:delta 3)) (let* ((d (cat:delta 3))
(m (cat:build-smmr (m (cat:build-smmr
:sorc d :trgt d :degr 0 :sorc d :trgt d :degr 0
:sintr #'(lambda (dmns gmsm) (cat:absm 0 gmsm)) :sintr #'(lambda (dmns gmsm) (cat:absm 0 gmsm))
:orgn '(identity delta-3))) :orgn '(identity delta-3)))
(m2 (cat:build-smmr (m2 (cat:build-smmr
:sorc d :trgt d :degr 0 :sorc d :trgt d :degr 0
:sintr #'(lambda (dmns gmsm) (cat:absm (cat:mask dmns) 1)) :sintr #'(lambda (dmns gmsm) (cat:absm (cat:mask dmns) 1))
:orgn '(null delta-3)))) :orgn '(null delta-3))))
(cat:? m2 2 7) (cat:? m2 2 7)
;; (s? m2 2 7) ;; (s? m2 2 7)
)) ))

185
test/simplicial-sets-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -14,7 +15,7 @@
(is (equal '(2) (cat:dgop-int-ext 4))) (is (equal '(2) (cat:dgop-int-ext 4)))
(is (equal '(5 4 3 2 1 0) (cat:dgop-int-ext 63))) (is (equal '(5 4 3 2 1 0) (cat:dgop-int-ext 63)))
(dotimes (i 33) (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 (test hyphenize-list
@ -25,89 +26,89 @@
(test moore (test moore
(let ((m (cat:moore 2 2))) (let ((m (cat:moore 2 2)))
(dotimes (i 4) (dotimes (i 4)
(print (cat:basis m i :dgnr))))) (print (cat:basis m i :dgnr)))))
#| #|
(test intr-diagonal (test intr-diagonal
(let* ((cmpr #'cat:f-cmpr) (let* ((cmpr #'cat:f-cmpr)
(face #'cat:delta-face) (face #'cat:delta-face)
(diag (cat:intr-diagonal face))) (diag (cat:intr-diagonal face)))
(funcall diag 4 (cat:mask 5)) (funcall diag 4 (cat:mask 5))
(funcall diag 0 4) (funcall diag 0 4)
(setf cmpr #'cat:s-cmpr face (cat:sphere-face 4)) (setf cmpr #'cat:s-cmpr face (cat:sphere-face 4))
(setf diag (cat:intr-diagonal face)) (setf diag (cat:intr-diagonal face))
(funcall diag 4 's4) (funcall diag 4 's4)
(funcall diag 0 '*) (funcall diag 0 '*)
(setf s4 (cat:sphere 4)) (setf s4 (cat:sphere 4))
(cat:dgnl s4 4 's4))) (cat:dgnl s4 4 's4)))
|# |#
(test face-bndr (test face-bndr
(let* ((face #'(lambda (indx dmns gmsm) (let* ((face #'(lambda (indx dmns gmsm)
(cat:absm 0 (append (cat:absm 0 (append
(subseq gmsm 0 indx) (subseq gmsm 0 indx)
(subseq gmsm (1+ indx)))))) (subseq gmsm (1+ indx))))))
(bndr (cat:face-bndr #'cat:l-cmpr face))) (bndr (cat:face-bndr #'cat:l-cmpr face)))
(funcall bndr 0 '(a)) (funcall bndr 0 '(a))
(funcall bndr 1 '(a b)) (funcall bndr 1 '(a b))
(funcall bndr 2 '(a b c)) (funcall bndr 2 '(a b c))
(funcall bndr 3 '(a b c d)) (funcall bndr 3 '(a b c d))
(funcall bndr 3 '(d c b a)) (funcall bndr 3 '(d c b a))
(funcall bndr 1 '(a a)) (funcall bndr 1 '(a a))
(funcall bndr 2 '(a a a)) (funcall bndr 2 '(a a a))
(funcall bndr 3 '(a a a a)) (funcall bndr 3 '(a a a a))
(setf face #'(lambda (index dmns gmsm) (setf face #'(lambda (index dmns gmsm)
(cat:absm (cat:dgop-ext-int (cat:absm (cat:dgop-ext-int
(nreverse (cat:<a-b< 0 (1- dmns)))) 'a))) (nreverse (cat:<a-b< 0 (1- dmns)))) 'a)))
(setf bndr (cat:face-bndr #'cat:s-cmpr face)) (setf bndr (cat:face-bndr #'cat:s-cmpr face))
(funcall bndr 1 '(a b)) (funcall bndr 1 '(a b))
(funcall bndr 2 '(a b c)))) (funcall bndr 2 '(a b c))))
(test face*-bndr (test face*-bndr
(let* ((face* #'(lambda (indx dmns gmsm) (let* ((face* #'(lambda (indx dmns gmsm)
(if (and (= dmns 3) (evenp indx)) (if (and (= dmns 3) (evenp indx))
'm2 'm2
:degenerate))) :degenerate)))
(bndr (cat:face*-bndr #'cat:s-cmpr face*))) (bndr (cat:face*-bndr #'cat:s-cmpr face*)))
(funcall bndr 3 'm3) (funcall bndr 3 'm3)
(funcall bndr 2 'm2) (funcall bndr 2 'm2)
(funcall bndr 0 '*) (funcall bndr 0 '*)
(setf face* #'(lambda (indx dmns gmsm) (setf face* #'(lambda (indx dmns gmsm)
(if (and (= dmns 3) (< indx 2)) (if (and (= dmns 3) (< indx 2))
'm2 'm2
:degenerate))) :degenerate)))
(setf bndr (cat:face*-bndr #'cat:s-cmpr face*)) (setf bndr (cat:face*-bndr #'cat:s-cmpr face*))
(funcall bndr 3 'm3) (funcall bndr 3 'm3)
(funcall bndr 2 'm2) (funcall bndr 2 'm2)
(funcall bndr 0 '*))) (funcall bndr 0 '*)))
(test a-cmpr3 (test a-cmpr3
(is (equal :less (cat:a-cmpr3 #'cat:s-cmpr (is (equal :less (cat:a-cmpr3 #'cat:s-cmpr
(cat:absm 0 'a) (cat:absm 0 'a)
(cat:absm 1 'b)))) (cat:absm 1 'b))))
(is (equal :greater (cat:a-cmpr3 #'cat:s-cmpr (is (equal :greater (cat:a-cmpr3 #'cat:s-cmpr
(cat:absm 2 'a) (cat:absm 2 'a)
(cat:absm 1 'b)))) (cat:absm 1 'b))))
(is (equal :less (cat:a-cmpr3 #'cat:s-cmpr (is (equal :less (cat:a-cmpr3 #'cat:s-cmpr
(cat:absm 1 'a) (cat:absm 1 'a)
(cat:absm 1 'b)))) (cat:absm 1 'b))))
(is (equal :greater (cat:a-cmpr3 #'cat:s-cmpr (is (equal :greater (cat:a-cmpr3 #'cat:s-cmpr
(cat:absm 1 'c) (cat:absm 1 'c)
(cat:absm 1 'b)))) (cat:absm 1 'b))))
(is (equal :equal (cat:a-cmpr3 #'cat:s-cmpr (is (equal :equal (cat:a-cmpr3 #'cat:s-cmpr
(cat:absm 1 'a) (cat:absm 1 'a)
(cat:absm 1 'a))))) (cat:absm 1 'a)))))
(test bspn-p (test bspn-p
(let* ((d (cat:delta-infinity)) (let* ((d (cat:delta-infinity))
(cmpr (cat:cmpr d))) (cmpr (cat:cmpr d)))
(is (cat:bspn-p cmpr 1 5 (cat:absm (cat:mask 5) 1))) (is (cat:bspn-p cmpr 1 5 (cat:absm (cat:mask 5) 1)))
(is (not (cat:bspn-p cmpr 1 5 (cat:absm (cat:mask 5) 2)))) (is (not (cat:bspn-p cmpr 1 5 (cat:absm (cat:mask 5) 2))))
(is (not (cat:bspn-p cmpr 1 5 (cat:absm (cat:mask 4) 3)))))) (is (not (cat:bspn-p cmpr 1 5 (cat:absm (cat:mask 4) 3))))))
(test dlop-ext-int (test dlop-ext-int
@ -121,23 +122,23 @@
(is (equal '(2) (cat:dlop-int-ext 4))) (is (equal '(2) (cat:dlop-int-ext 4)))
(is (equal '(0 1 2 3 4 5) (cat:dlop-int-ext 63))) (is (equal '(0 1 2 3 4 5) (cat:dlop-int-ext 63)))
(dotimes (i 33) (dotimes (i 33)
(is (= i (cat:dlop-ext-int (cat:dlop-int-ext i)))))) (is (= i (cat:dlop-ext-int (cat:dlop-int-ext i))))))
(test 1dgop*dgop (test 1dgop*dgop
(dotimes (i 20) (dotimes (i 20)
(dotimes (j 5) (dotimes (j 5)
(format t "~% (~D) o ~A = ~A" (format t "~% (~D) o ~A = ~A"
j (cat:dgop-int-ext i) j (cat:dgop-int-ext i)
(cat:dgop-int-ext (cat:1dgop*dgop j i)))))) (cat:dgop-int-ext (cat:1dgop*dgop j i))))))
(test dgop*dgop (test dgop*dgop
(dotimes (i 10) (dotimes (i 10)
(dotimes (j 10) (dotimes (j 10)
(format t "~%~A o ~A = ~A" (format t "~%~A o ~A = ~A"
(cat:dgop-int-ext i) (cat:dgop-int-ext j) (cat:dgop-int-ext i) (cat:dgop-int-ext j)
(cat:dgop-int-ext (cat:dgop*dgop i j)))))) (cat:dgop-int-ext (cat:dgop*dgop i j))))))
(test remove-bit (test remove-bit
@ -152,23 +153,23 @@
(test 1dlop-dgop (test 1dlop-dgop
(dotimes (i 5) (dotimes (i 5)
(dotimes (j 17) (dotimes (j 17)
(multiple-value-bind (dgop 1dlop) (cat:1dlop-dgop i j) (multiple-value-bind (dgop 1dlop) (cat:1dlop-dgop i j)
(format t "~% del-~D o ~A = ~A o del-~A" (format t "~% del-~D o ~A = ~A o del-~A"
i (cat:dgop-int-ext j) (cat:dgop-int-ext dgop) 1dlop))))) i (cat:dgop-int-ext j) (cat:dgop-int-ext dgop) 1dlop)))))
#| #|
(test a-face4 (test a-face4
(let ((simp (cat:dlop-ext-int '(0 1 2 3 4 5 6)))) (let ((simp (cat:dlop-ext-int '(0 1 2 3 4 5 6))))
(dotimes (i 5) (dotimes (i 5)
(dotimes (j 17) (dotimes (j 17)
(let ((face (cat:a-face4 (cat:face (cat:delta-infinity)) (let ((face (cat:a-face4 (cat:face (cat:delta-infinity))
i (+ 6 (logcount j)) i (+ 6 (logcount j))
(cat:absm j simp)))) (cat:absm j simp))))
(format t "~%del-~D o ~A (0 1 2 3 4 5 6) = ~A ~A" (format t "~%del-~D o ~A (0 1 2 3 4 5 6) = ~A ~A"
i (cat:dgop-int-ext j) i (cat:dgop-int-ext j)
(cat:dgop-int-ext (cat:dgop face)) (cat:dgop-int-ext (cat:dgop face))
(cat:dlop-int-ext (cat:gmsm face)))))))) (cat:dlop-int-ext (cat:gmsm face))))))))
|# |#
@ -182,20 +183,20 @@
(test nface (test nface
(let ((f (cat:face (cat:delta-infinity))) (let ((f (cat:face (cat:delta-infinity)))
p) p)
(dotimes (dlop 31) (dotimes (dlop 31)
(print (cat:dlop-int-ext (cat:gmsm (cat:nface f dlop 4 31))))) (print (cat:dlop-int-ext (cat:gmsm (cat:nface f dlop 4 31)))))
(setf p (cat:r-proj-space)) (setf p (cat:r-proj-space))
(setf f (cat:face p)) (setf f (cat:face p))
(dotimes (dlop 31) (dotimes (dlop 31)
(format t "~%~A ~A" (format t "~%~A ~A"
(cat:hyphenize-list (cat:dlop-int-ext dlop)) (cat:hyphenize-list (cat:dlop-int-ext dlop))
(cat:nface f dlop 4 4))))) (cat:nface f dlop 4 4)))))
(test check-faces (test check-faces
(let ((d (cat:delta-infinity))) (let ((d (cat:delta-infinity)))
(is (cat:check-faces #'cat:f-cmpr (cat:face d) 4 31)))) (is (cat:check-faces #'cat:f-cmpr (cat:face d) 4 31))))
(test check-smst (test check-smst

447
test/smith-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -13,189 +14,189 @@
(test copy-mtrx (test copy-mtrx
(let ((m (cat:random-matrix 3 4 10))) (let ((m (cat:random-matrix 3 4 10)))
(is (equalp m (cat:copy-mtrx m))))) (is (equalp m (cat:copy-mtrx m)))))
(test left-submatrix (test left-submatrix
(let ((m (cat:random-matrix 3 4 10))) (let ((m (cat:random-matrix 3 4 10)))
(cat:left-submatrix m 2))) (cat:left-submatrix m 2)))
(test mtrx-prdc (test mtrx-prdc
(let ((m1 (cat:random-matrix 2 3 10)) (let ((m1 (cat:random-matrix 2 3 10))
(m2 (cat:random-matrix 3 2 10))) (m2 (cat:random-matrix 3 2 10)))
(cat:mtrx-prdc m1 m2) (cat:mtrx-prdc m1 m2)
(cat:mtrx-prdc m2 m1))) (cat:mtrx-prdc m2 m1)))
(test chcm-mtrx (test chcm-mtrx
(cat:cat-init) (cat:cat-init)
(let ((d (cat:delta 5)) (let ((d (cat:delta 5))
(m (cat:moore 2 2))) (m (cat:moore 2 2)))
(cat:chcm-mtrx d 3) (cat:chcm-mtrx d 3)
(dotimes (i 5) (dotimes (i 5)
(print (cat:chcm-mtrx m i))) (print (cat:chcm-mtrx m i)))
(dotimes (i 6) (dotimes (i 6)
(print (array-dimensions (cat:chcm-mtrx m i)))))) (print (array-dimensions (cat:chcm-mtrx m i))))))
(test line-op (test line-op
(let ((m (cat:random-matrix 3 4 10))) (let ((m (cat:random-matrix 3 4 10)))
(cat:line-op m 1 3 2 0))) (cat:line-op m 1 3 2 0)))
;; mtrx-list = (P P^-1 M Q Q^-1) ;; mtrx-list = (P P^-1 M Q Q^-1)
(test line-op-5 (test line-op-5
(let* ((p (cat:idnt-mtrx 4)) (let* ((p (cat:idnt-mtrx 4))
(p-1 (cat:idnt-mtrx 4)) (p-1 (cat:idnt-mtrx 4))
(m (cat:random-matrix 4 5 10)) (m (cat:random-matrix 4 5 10))
(q (cat:idnt-mtrx 5) ) (q (cat:idnt-mtrx 5) )
(q-1 (cat:idnt-mtrx 5)) (q-1 (cat:idnt-mtrx 5))
(list (list p p-1 m q q-1)) (list (list p p-1 m q q-1))
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1)))) (t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:line-op-5 list 0 3 1 3) (cat:line-op-5 list 0 3 1 3)
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1)))) (is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:mtrx-prdc p p-1))) (cat:mtrx-prdc p p-1)))
(test column-op (test column-op
(let ((m (cat:random-matrix 3 4 10))) (let ((m (cat:random-matrix 3 4 10)))
(cat:column-op m 1 3 2 0))) (cat:column-op m 1 3 2 0)))
(test column-op-5 (test column-op-5
(let* ((p (cat:idnt-mtrx 4)) (let* ((p (cat:idnt-mtrx 4))
(p-1 (cat:idnt-mtrx 4)) (p-1 (cat:idnt-mtrx 4))
(m (cat:random-matrix 4 5 10)) (m (cat:random-matrix 4 5 10))
(q (cat:idnt-mtrx 5)) (q (cat:idnt-mtrx 5))
(q-1 (cat:idnt-mtrx 5)) (q-1 (cat:idnt-mtrx 5))
(list (list p p-1 m q q-1)) (list (list p p-1 m q q-1))
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1)))) (t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:column-op-5 list 0 3 1 3) (cat:column-op-5 list 0 3 1 3)
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1)))) (is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:mtrx-prdc p p-1) (cat:mtrx-prdc p p-1)
(cat:mtrx-prdc q q-1))) (cat:mtrx-prdc q q-1)))
(test line-swap (test line-swap
(let ((m (cat:random-matrix 3 4 10))) (let ((m (cat:random-matrix 3 4 10)))
(cat:line-swap m 1 0 2))) (cat:line-swap m 1 0 2)))
(test line-swap-5 (test line-swap-5
(let* ((p (cat:idnt-mtrx 4)) (let* ((p (cat:idnt-mtrx 4))
(p-1 (cat:idnt-mtrx 4)) (p-1 (cat:idnt-mtrx 4))
(m (cat:random-matrix 4 5 10)) (m (cat:random-matrix 4 5 10))
(q (cat:idnt-mtrx 5)) (q (cat:idnt-mtrx 5))
(q-1 (cat:idnt-mtrx 5)) (q-1 (cat:idnt-mtrx 5))
(list (list p p-1 m q q-1)) (list (list p p-1 m q q-1))
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1)))) (t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:line-swap-5 list 0 1 3) (cat:line-swap-5 list 0 1 3)
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1)))) (is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:mtrx-prdc p p-1) (cat:mtrx-prdc p p-1)
(cat:mtrx-prdc q q-1))) (cat:mtrx-prdc q q-1)))
(test column-swap (test column-swap
(let ((m (cat:random-matrix 3 4 10))) (let ((m (cat:random-matrix 3 4 10)))
(cat:column-swap m 1 0 2))) (cat:column-swap m 1 0 2)))
(test column-swap-5 (test column-swap-5
(let* ((p (cat:idnt-mtrx 4)) (let* ((p (cat:idnt-mtrx 4))
(p-1 (cat:idnt-mtrx 4)) (p-1 (cat:idnt-mtrx 4))
(m (cat:random-matrix 4 5 10)) (m (cat:random-matrix 4 5 10))
(q (cat:idnt-mtrx 5)) (q (cat:idnt-mtrx 5))
(q-1 (cat:idnt-mtrx 5)) (q-1 (cat:idnt-mtrx 5))
(list (list p p-1 m q q-1)) (list (list p p-1 m q q-1))
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1)))) (t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:column-swap-5 list 0 1 3) (cat:column-swap-5 list 0 1 3)
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1)))) (is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:mtrx-prdc p p-1) (cat:mtrx-prdc p p-1)
(cat:mtrx-prdc q q-1))) (cat:mtrx-prdc q q-1)))
(test column-minus (test column-minus
(let ((m (cat:random-matrix 3 4 10))) (let ((m (cat:random-matrix 3 4 10)))
(cat:line-minus m 1 2) (cat:line-minus m 1 2)
(cat:column-minus m 1 2))) (cat:column-minus m 1 2)))
(test column-minus-5 (test column-minus-5
(let* ((p (cat:idnt-mtrx 4)) (let* ((p (cat:idnt-mtrx 4))
(p-1 (cat:idnt-mtrx 4)) (p-1 (cat:idnt-mtrx 4))
(m (cat:random-matrix 4 5 10)) (m (cat:random-matrix 4 5 10))
(q (cat:idnt-mtrx 5)) (q (cat:idnt-mtrx 5))
(q-1 (cat:idnt-mtrx 5)) (q-1 (cat:idnt-mtrx 5))
(list (list p p-1 m q q-1)) (list (list p p-1 m q q-1))
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1)))) (t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:line-minus-5 list 0 3) (cat:line-minus-5 list 0 3)
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1)))) (is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:mtrx-prdc p p-1) (cat:mtrx-prdc p p-1)
(cat:mtrx-prdc q q-1) (cat:mtrx-prdc q q-1)
(cat:column-minus-5 list 0 2) (cat:column-minus-5 list 0 2)
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1)))) (is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:mtrx-prdc p p-1) (cat:mtrx-prdc p p-1)
(cat:mtrx-prdc q q-1))) (cat:mtrx-prdc q q-1)))
(test minimal-term (test minimal-term
(let ((m (cat:random-matrix 4 5 10))) (let ((m (cat:random-matrix 4 5 10)))
(cat:minimal-term m 1))) (cat:minimal-term m 1)))
#| #|
;; potential divide by 0 ;; potential divide by 0
(test minimal-rest-1 (test minimal-rest-1
(let ((m (cat:random-matrix 4 5 10))) (let ((m (cat:random-matrix 4 5 10)))
(cat:minimal-rest-1 m 1))) (cat:minimal-rest-1 m 1)))
(test minimal-rest-2 (test minimal-rest-2
(let ((m (cat:random-matrix 4 5 10))) (let ((m (cat:random-matrix 4 5 10)))
(cat:minimal-rest-2 m 1))) (cat:minimal-rest-2 m 1)))
|# |#
(test minimal-term-top-left (test minimal-term-top-left
(let* ((p (cat:idnt-mtrx 4)) (let* ((p (cat:idnt-mtrx 4))
(p-1 (cat:idnt-mtrx 4)) (p-1 (cat:idnt-mtrx 4))
(m (cat:random-matrix 4 5 10)) (m (cat:random-matrix 4 5 10))
(q (cat:idnt-mtrx 5)) (q (cat:idnt-mtrx 5))
(q-1 (cat:idnt-mtrx 5)) (q-1 (cat:idnt-mtrx 5))
(list (list p p-1 m q q-1)) (list (list p p-1 m q q-1))
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1)))) (t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:minimal-term-top-left list 0 1 3) (cat:minimal-term-top-left list 0 1 3)
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1)))) (is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:mtrx-prdc p p-1) (cat:mtrx-prdc p p-1)
(cat:mtrx-prdc q q-1))) (cat:mtrx-prdc q q-1)))
(test minimal-term-top-left1 (test minimal-term-top-left1
(let* ((p (cat:idnt-mtrx 4)) (let* ((p (cat:idnt-mtrx 4))
(p-1 (cat:idnt-mtrx 4)) (p-1 (cat:idnt-mtrx 4))
(m (cat:random-matrix 4 5 10)) (m (cat:random-matrix 4 5 10))
(q (cat:idnt-mtrx 5)) (q (cat:idnt-mtrx 5))
(q-1 (cat:idnt-mtrx 5)) (q-1 (cat:idnt-mtrx 5))
(list (list p p-1 m q q-1)) (list (list p p-1 m q q-1))
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1)))) (t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:pivott list 0) (cat:pivott list 0)
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1)))) (is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:mtrx-prdc p p-1) (cat:mtrx-prdc p p-1)
(cat:mtrx-prdc q q-1))) (cat:mtrx-prdc q q-1)))
(test list-smith (test list-smith
(let* ((p (cat:idnt-mtrx 4)) (let* ((p (cat:idnt-mtrx 4))
(p-1 (cat:idnt-mtrx 4)) (p-1 (cat:idnt-mtrx 4))
(m (cat:random-matrix 4 5 10)) (m (cat:random-matrix 4 5 10))
(q (cat:idnt-mtrx 5)) (q (cat:idnt-mtrx 5))
(q-1 (cat:idnt-mtrx 5)) (q-1 (cat:idnt-mtrx 5))
(list (list p p-1 m q q-1)) (list (list p p-1 m q q-1))
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1)))) (t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(third (cat:list-smith list)) (third (cat:list-smith list))
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1)))) (is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:mtrx-prdc p p-1) (cat:mtrx-prdc p p-1)
(cat:mtrx-prdc q q-1))) (cat:mtrx-prdc q q-1)))
(test gnrt-name-basis (test gnrt-name-basis
@ -205,156 +206,156 @@
(test echcm-kill-epi-f-intr (test echcm-kill-epi-f-intr
(let* ((q-1 (cat:random-matrix 5 5 10)) (let* ((q-1 (cat:random-matrix 5 5 10))
(f (cat:echcm-kill-epi-f-intr #'cat:s-cmpr 2 2 5 '(a b c d e) (f (cat:echcm-kill-epi-f-intr #'cat:s-cmpr 2 2 5 '(a b c d e)
(list 0 0 0 0 q-1)))) (list 0 0 0 0 q-1))))
(funcall f (cat:cmbn 2 1 'a)) (funcall f (cat:cmbn 2 1 'a))
(funcall f (cat:cmbn 4 1 'a)) (funcall f (cat:cmbn 4 1 'a))
(funcall f (cat:cmbn 3 1 'a 10 'b 100 'c 1000 'd 10000 'e)))) (funcall f (cat:cmbn 3 1 'a 10 'b 100 'c 1000 'd 10000 'e))))
#| #|
(test echcm-kill-epi-g-intr (test echcm-kill-epi-g-intr
(let* ((q (cat:random-matrix 5 5 10)) (let* ((q (cat:random-matrix 5 5 10))
(g (cat:echcm-kill-epi-g-intr 2 2 5 '(a b c d e) (g (cat:echcm-kill-epi-g-intr 2 2 5 '(a b c d e)
(list 0 0 0 q 0)))) (list 0 0 0 q 0))))
(funcall g (cat:cmbn 2)) (funcall g (cat:cmbn 2))
(funcall g (cat:cmbn 4 1 'a)) (funcall g (cat:cmbn 4 1 'a))
(funcall g (cat:cmbn 3 1 :gn-0 10 :gn-1 100 :gn-2)))) (funcall g (cat:cmbn 3 1 :gn-0 10 :gn-1 100 :gn-2))))
|# |#
(test echcm-kill-epi-h-intr (test echcm-kill-epi-h-intr
(let* ((p-1 (cat:random-matrix 2 2 10)) (let* ((p-1 (cat:random-matrix 2 2 10))
(q (cat:random-matrix 5 5 10)) (q (cat:random-matrix 5 5 10))
(h (cat:echcm-kill-epi-h-intr #'cat:s-cmpr 2 2 5 '(a b) (h (cat:echcm-kill-epi-h-intr #'cat:s-cmpr 2 2 5 '(a b)
'(a b c d e) '(a b c d e)
(list 0 p-1 0 q 0)))) (list 0 p-1 0 q 0))))
(funcall h (cat:cmbn 2 1 'a 1000 'b)) (funcall h (cat:cmbn 2 1 'a 1000 'b))
(funcall h (cat:cmbn 4 1 'a)))) (funcall h (cat:cmbn 4 1 'a))))
(test echcm-kill-epi (test echcm-kill-epi
(cat:cat-init) (cat:cat-init)
(let* ((s3 (cat:sphere 3)) (let* ((s3 (cat:sphere 3))
(s3-chml-clss (cat:chml-clss s3 3)) (s3-chml-clss (cat:chml-clss s3 3))
(s3-fibration (cat:z-whitehead s3 s3-chml-clss)) (s3-fibration (cat:z-whitehead s3 s3-chml-clss))
(s3-4 (cat:fibration-total s3-fibration)) (s3-4 (cat:fibration-total s3-fibration))
(ecc (cat:echcm s3-4)) (ecc (cat:echcm s3-4))
(rdct (cat:echcm-kill-epi ecc 2)) (rdct (cat:echcm-kill-epi ecc 2))
s3-4-chml-clss s3-4-fibration s3-5 s3-4-chml-clss s3-4-fibration s3-5
rdct1 rdct2 rdct3 rdct12 rdct123) rdct1 rdct2 rdct3 rdct12 rdct123)
(cat:pre-check-rdct rdct) (cat:pre-check-rdct rdct)
(setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn ecc)) (setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn ecc))
cat:*bc* cat:*tc*) cat:*bc* cat:*tc*)
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn 2 1 (first (cat:basis ecc 2)))) (setf cat:*tc* (cat:cmbn 2 1 (first (cat:basis ecc 2))))
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn 3 1 (first (cat:basis ecc 3)))) (setf cat:*tc* (cat:cmbn 3 1 (first (cat:basis ecc 3))))
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn 4 1 (first (cat:basis ecc 4))) (setf cat:*tc* (cat:cmbn 4 1 (first (cat:basis ecc 4)))
cat:*bc* cat:*tc*) cat:*bc* cat:*tc*)
(check-rdct) (check-rdct)
(setf s3-4-chml-clss (cat:chml-clss s3-4 4)) (setf s3-4-chml-clss (cat:chml-clss s3-4 4))
(setf s3-4-fibration (cat:z2-whitehead s3-4 s3-4-chml-clss)) (setf s3-4-fibration (cat:z2-whitehead s3-4 s3-4-chml-clss))
(setf s3-5 (cat:fibration-total s3-4-fibration)) (setf s3-5 (cat:fibration-total s3-4-fibration))
(setf ecc (cat:echcm s3-5)) (setf ecc (cat:echcm s3-5))
(dotimes (i 7) (dotimes (i 7)
(format t "~%DIM = ~D ; LENGTH = ~D" i (length (cat:basis ecc i)))) (format t "~%DIM = ~D ; LENGTH = ~D" i (length (cat:basis ecc i))))
(setf rdct1 (cat:echcm-kill-epi ecc 2)) (setf rdct1 (cat:echcm-kill-epi ecc 2))
(setf rdct2 (cat:echcm-kill-epi (cat:bcc rdct1) 3)) (setf rdct2 (cat:echcm-kill-epi (cat:bcc rdct1) 3))
(setf rdct3 (cat:echcm-kill-epi (cat:bcc rdct2) 4)) (setf rdct3 (cat:echcm-kill-epi (cat:bcc rdct2) 4))
(setf rdct12 (cat:cmps rdct2 rdct1)) (setf rdct12 (cat:cmps rdct2 rdct1))
(setf rdct123 (cat:cmps rdct3 rdct12)) (setf rdct123 (cat:cmps rdct3 rdct12))
(cat:pre-check-rdct rdct123) (cat:pre-check-rdct rdct123)
(setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn ecc)) cat:*bc* cat:*tc*) (setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn ecc)) cat:*bc* cat:*tc*)
(check-rdct) (check-rdct)
(setf cat:*tc* (cat:cmbn 2 1 (first (cat:basis ecc 2)))) (setf cat:*tc* (cat:cmbn 2 1 (first (cat:basis ecc 2))))
(check-rdct) (check-rdct)
(let ((b3 (cat:basis ecc 3))) (let ((b3 (cat:basis ecc 3)))
(setf cat:*tc* (cat:cmbn 3 1 (first b3) 10 (second b3)))) (setf cat:*tc* (cat:cmbn 3 1 (first b3) 10 (second b3))))
(check-rdct) (check-rdct)
(let ((b4 (cat:basis ecc 4))) (let ((b4 (cat:basis ecc 4)))
(setf cat:*tc* (cat:cmbn 4 1 (first b4) 10 (second b4)))) (setf cat:*tc* (cat:cmbn 4 1 (first b4) 10 (second b4))))
(check-rdct) (check-rdct)
(let ((b5 (cat:basis ecc 5))) (let ((b5 (cat:basis ecc 5)))
(setf cat:*tc* (cat:cmbn 5 1 (first b5) (setf cat:*tc* (cat:cmbn 5 1 (first b5)
10 (second b5) 10 (second b5)
100 (third b5) 100 (third b5)
1000 (fourth b5)))) 1000 (fourth b5))))
(check-rdct) (check-rdct)
(let ((b6 (cat:basis ecc 6))) (let ((b6 (cat:basis ecc 6)))
(setf cat:*tc* (cat:cmbn 6 1 (first b6) (setf cat:*tc* (cat:cmbn 6 1 (first b6)
10 (second b6) 10 (second b6)
100 (third b6) 100 (third b6)
1000 (fourth b6) 1000 (fourth b6)
10000 (fifth b6) 10000 (fifth b6)
100000 (sixth b6) 100000 (sixth b6)
1000000 (seventh b6)))) 1000000 (seventh b6))))
(check-rdct))) (check-rdct)))
(test kill-epis (test kill-epis
(cat:cat-init) (cat:cat-init)
(let* ((s3 (cat:sphere 3)) (let* ((s3 (cat:sphere 3))
(s3-chml-clss (cat:chml-clss s3 3)) (s3-chml-clss (cat:chml-clss s3 3))
(s3-fibration (cat:z-whitehead s3 s3-chml-clss)) (s3-fibration (cat:z-whitehead s3 s3-chml-clss))
(s3-4 (cat:fibration-total s3-fibration)) (s3-4 (cat:fibration-total s3-fibration))
(s3-4-chml-clss (cat:chml-clss s3-4 4)) (s3-4-chml-clss (cat:chml-clss s3-4 4))
(s3-4-fibration (cat:z2-whitehead s3-4 s3-4-chml-clss)) (s3-4-fibration (cat:z2-whitehead s3-4 s3-4-chml-clss))
(s3-5 (cat:fibration-total s3-4-fibration))) (s3-5 (cat:fibration-total s3-4-fibration)))
(time (cat:homology s3-5 6)) (time (cat:homology s3-5 6))
(cat:kill-epis s3-5 2 5) (cat:kill-epis s3-5 2 5)
(cat:homology s3-5 0 7))) (cat:homology s3-5 0 7)))
(test kill-epi (test kill-epi
(cat:cat-init) (cat:cat-init)
(let* ((s3 (cat:sphere 3)) (let* ((s3 (cat:sphere 3))
(s3-chml-clss (cat:chml-clss s3 3)) (s3-chml-clss (cat:chml-clss s3 3))
(s3-fibration (cat:z-whitehead s3 s3-chml-clss)) (s3-fibration (cat:z-whitehead s3 s3-chml-clss))
(s3-4 (cat:fibration-total s3-fibration)) (s3-4 (cat:fibration-total s3-fibration))
s3-4-chml-clss s3-4-fibration s3-5) s3-4-chml-clss s3-4-fibration s3-5)
(cat:kill-epi s3-4 2) (cat:kill-epi s3-4 2)
(setf s3-4-chml-clss (cat:chml-clss s3-4 4)) (setf s3-4-chml-clss (cat:chml-clss s3-4 4))
(setf s3-4-fibration (cat:z2-whitehead s3-4 s3-4-chml-clss)) (setf s3-4-fibration (cat:z2-whitehead s3-4 s3-4-chml-clss))
(setf s3-5 (cat:fibration-total s3-4-fibration)) (setf s3-5 (cat:fibration-total s3-4-fibration))
(time (cat:homology s3-5 6)))) (time (cat:homology s3-5 6))))
(test chml-clss-intr (test chml-clss-intr
(cat:cat-init) (cat:cat-init)
(let* ((s3 (cat:sphere 3)) (let* ((s3 (cat:sphere 3))
(c (cat:chml-clss-intr s3 3)) (c (cat:chml-clss-intr s3 3))
(s3-chml-clss (cat:chml-clss s3 3)) (s3-chml-clss (cat:chml-clss s3 3))
(s3-fibration (cat:z-whitehead s3 s3-chml-clss)) (s3-fibration (cat:z-whitehead s3 s3-chml-clss))
(s3-4 (cat:fibration-total s3-fibration)) (s3-4 (cat:fibration-total s3-fibration))
s3-4-chml-clss s3-4-fibration s3-5) s3-4-chml-clss s3-4-fibration s3-5)
(funcall c (cat:cmbn 3 5 's3)) (funcall c (cat:cmbn 3 5 's3))
(cat:kill-epi s3-4 2) (cat:kill-epi s3-4 2)
(setf c (cat:chml-clss-intr s3-4 4)) (setf c (cat:chml-clss-intr s3-4 4))
(funcall c (cat:cmbn 4 5 (first (cat:basis (cat:echcm s3-4) 4)))) (funcall c (cat:cmbn 4 5 (first (cat:basis (cat:echcm s3-4) 4))))
(setf s3-4-chml-clss (cat:chml-clss s3-4 4)) (setf s3-4-chml-clss (cat:chml-clss s3-4 4))
(setf s3-4-fibration (cat:z2-whitehead s3-4 s3-4-chml-clss)) (setf s3-4-fibration (cat:z2-whitehead s3-4 s3-4-chml-clss))
(setf s3-5 (cat:fibration-total s3-4-fibration)) (setf s3-5 (cat:fibration-total s3-4-fibration))
(cat:kill-epis s3-5 3 5) (cat:kill-epis s3-5 3 5)
(setf c (cat:chml-clss-intr s3-5 5)) (setf c (cat:chml-clss-intr s3-5 5))
(let ((b5 (cat:basis (cat:echcm s3-5) 5))) (let ((b5 (cat:basis (cat:echcm s3-5) 5)))
(funcall c (cat:cmbn 5 1 (first b5) 10 (second b5)))))) (funcall c (cat:cmbn 5 1 (first b5) 10 (second b5))))))
(test chml-clss (test chml-clss
(cat:cat-init) (cat:cat-init)
(let* ((s3 (cat:sphere 3)) (let* ((s3 (cat:sphere 3))
(s3-chml-clss (cat:chml-clss s3 3)) (s3-chml-clss (cat:chml-clss s3 3))
(s3-fibration (cat:z-whitehead s3 s3-chml-clss)) (s3-fibration (cat:z-whitehead s3 s3-chml-clss))
(s3-4 (cat:fibration-total s3-fibration)) (s3-4 (cat:fibration-total s3-fibration))
s3-4-chml-clss s3-4-fibration s3-5 s3-5-chml-clss s3-5-fibration) s3-4-chml-clss s3-4-fibration s3-5 s3-5-chml-clss s3-5-fibration)
(cat:homology s3-4 0 6) (cat:homology s3-4 0 6)
(cat:kill-epi s3-4 2) (cat:kill-epi s3-4 2)
(setf s3-4-chml-clss (cat:chml-clss s3-4 4)) (setf s3-4-chml-clss (cat:chml-clss s3-4 4))
(setf s3-4-fibration (cat:z2-whitehead s3-4 s3-4-chml-clss)) (setf s3-4-fibration (cat:z2-whitehead s3-4 s3-4-chml-clss))
(setf s3-5 (cat:fibration-total s3-4-fibration)) (setf s3-5 (cat:fibration-total s3-4-fibration))
(cat:homology s3-5 0 6) (cat:homology s3-5 0 6)
(cat:kill-epis s3-5 3 5) (cat:kill-epis s3-5 3 5)
(setf s3-5-chml-clss (cat:chml-clss s3-5 5)) (setf s3-5-chml-clss (cat:chml-clss s3-5 5))
(setf s3-5-fibration (cat:z2-whitehead s3-5 s3-5-chml-clss)) (setf s3-5-fibration (cat:z2-whitehead s3-5 s3-5-chml-clss))
(setf s3-6 (cat:fibration-total s3-5-fibration)) (setf s3-6 (cat:fibration-total s3-5-fibration))
(cat:homology s3-6 0 7))) (cat:homology s3-6 0 7)))

197
test/special-smsts-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -5,21 +6,21 @@
(test finite-ss-pre-table (test finite-ss-pre-table
(let ((p (cat:finite-ss-pre-table '(0 v0 v1 v2)))) (let ((p (cat:finite-ss-pre-table '(0 v0 v1 v2))))
(signals simple-error (cat:finite-ss-pre-table '(0 v0 v0 v2))) (signals simple-error (cat:finite-ss-pre-table '(0 v0 v0 v2)))
(setf p (cat:finite-ss-pre-table '(0 v0 v1 1 e0 e1 e2))) (setf p (cat:finite-ss-pre-table '(0 v0 v1 1 e0 e1 e2)))
(signals simple-error (cat:finite-ss-pre-table '(0 v0 v1 1 e0 e1 v1))) (signals simple-error (cat:finite-ss-pre-table '(0 v0 v1 1 e0 e1 v1)))
(setf p (cat:finite-ss-pre-table '(0 v0 (v0 v0)))) (setf p (cat:finite-ss-pre-table '(0 v0 (v0 v0))))
(setf p (cat:finite-ss-pre-table '(0 v0 v1 v2 0 v3))) (setf p (cat:finite-ss-pre-table '(0 v0 v1 v2 0 v3)))
(signals simple-error (cat:finite-ss-pre-table '(0 v0 (v0 v0) (signals simple-error (cat:finite-ss-pre-table '(0 v0 (v0 v0)
(v1 v1)))) (v1 v1))))
(signals simple-error (cat:finite-ss-pre-table '(0 (v0 v0) (v1 v1)))) (signals simple-error (cat:finite-ss-pre-table '(0 (v0 v0) (v1 v1))))
(signals #-(or ecl sbcl) simple-error #+(or ecl sbcl) type-error (signals #-(or ecl sbcl) simple-error #+(or ecl sbcl) type-error
(cat:finite-ss-pre-table '(0 v0 (v0 v0) #(1 2)))))) (cat:finite-ss-pre-table '(0 v0 (v0 v0) #(1 2))))))
(test finite-ss-pre-table-table (test finite-ss-pre-table-table
(let ((p (cat:finite-ss-pre-table-table (let ((p (cat:finite-ss-pre-table-table
(cat:finite-ss-pre-table '(2 v0 (e1 e2) v1 1 e0 e1 e2))))))) (cat:finite-ss-pre-table '(2 v0 (e1 e2) v1 1 e0 e1 e2)))))))
(test finite-ss-table (test finite-ss-table
@ -28,7 +29,7 @@
(cat:finite-ss-table '(a b 1 c (b a))) (cat:finite-ss-table '(a b 1 c (b a)))
(cat:finite-ss-table '(* 2 s2 3 s3)) (cat:finite-ss-table '(* 2 s2 3 s3))
(cat:finite-ss-table '(s0 s1 s2 1 s01 (s1 s0) s02 (s2 s0) s12 (s2 s1) (cat:finite-ss-table '(s0 s1 s2 1 s01 (s1 s0) s02 (s2 s0) s12 (s2 s1)
2 s012 (s12 s02 s01))) 2 s012 (s12 s02 s01)))
(cat:finite-ss-table '(* 4 s4 ((2 1 0 *)))) (cat:finite-ss-table '(* 4 s4 ((2 1 0 *))))
(signals simple-error (cat:finite-ss-table '(* 4 s4 ((1 1 0 *))))) (signals simple-error (cat:finite-ss-table '(* 4 s4 ((1 1 0 *)))))
(signals simple-error (cat:finite-ss-table '(* 1 s (t)))) (signals simple-error (cat:finite-ss-table '(* 1 s (t))))
@ -41,122 +42,122 @@ TR is NIL. Why?
(test build-finite-ss (test build-finite-ss
(cat:cat-init) (cat:cat-init)
(let (tr (cat:build-finite-ss '(s0 s1 s2 (let (tr (cat:build-finite-ss '(s0 s1 s2
1 s01 (s1 s0) s02 (s2 s0) s12 (s2 s1) 1 s01 (s1 s0) s02 (s2 s0) s12 (s2 s1)
2 s012 (s12 s02 s01)))) 2 s012 (s12 s02 s01))))
(cat:cmpr tr 's01 's02) (cat:cmpr tr 's01 's02)
(cat:basis tr 2) (cat:basis tr 2)
(cat:bspn tr) (cat:bspn tr)
(cat:face tr 1 2 's012) (cat:face tr 1 2 's012)
(cat:? tr 2 's012) (cat:? tr 2 's012)
(cat:? tr (cat:? tr 2 's012)) (cat:? tr (cat:? tr 2 's012))
(mapcar #'(lambda (s) (length (eval s))) cat:*list-list*) (mapcar #'(lambda (s) (length (eval s))) cat:*list-list*)
(setf tr (cat:build-finite-ss '(s0 s1 s2 (setf tr (cat:build-finite-ss '(s0 s1 s2
1 s01 (s1 s1) s02 (s2 s0) s12 (s2 s1) 1 s01 (s1 s1) s02 (s2 s0) s12 (s2 s1)
2 s012 (s12 s02 s01)))) 2 s012 (s12 s02 s01))))
(mapcar #'(lambda (s) (length (eval s))) cat:*list-list*))) (mapcar #'(lambda (s) (length (eval s))) cat:*list-list*)))
|# |#
(test sphere (test sphere
(cat:cat-init) (cat:cat-init)
(let ((s3 (cat:sphere 3)) (let ((s3 (cat:sphere 3))
d) d)
(funcall (cat:cmpr s3) 's3 's3) (funcall (cat:cmpr s3) 's3 's3)
(dotimes (i 5) (dotimes (i 5)
(print (funcall (cat:basis s3) i))) (print (funcall (cat:basis s3) i)))
(mapcar #'(lambda (i) (funcall (cat:face s3) i 3 's3)) (cat:<a-b> 0 3)) (mapcar #'(lambda (i) (funcall (cat:face s3) i 3 's3)) (cat:<a-b> 0 3))
(cat:? s3 3 's3) (cat:? s3 3 's3)
(cat:smst (cat:idnm s3)) (cat:smst (cat:idnm s3))
(cat:chcm (cat:idnm s3)) (cat:chcm (cat:idnm s3))
(setf d (cat:bndr s3)) (setf d (cat:bndr s3))
(cat:add d d))) (cat:add d d)))
(test sphere-wedge (test sphere-wedge
(cat:cat-init) (cat:cat-init)
(let ((w (cat:sphere-wedge 3 2 3))) (let ((w (cat:sphere-wedge 3 2 3)))
(funcall (cat:cmpr w) 's3-1 's3-2) (funcall (cat:cmpr w) 's3-1 's3-2)
(dotimes (i 5) (print (funcall (cat:basis w) i))) (dotimes (i 5) (print (funcall (cat:basis w) i)))
(funcall (cat:face w) 2 3 's3-1) (funcall (cat:face w) 2 3 's3-1)
(cat:gnrt-? (cat:bndr w) 3 's3-2))) (cat:gnrt-? (cat:bndr w) 3 's3-2)))
(test moore (test moore
(cat:cat-init) (cat:cat-init)
(let ((m4 (cat:moore 2 4))) (let ((m4 (cat:moore 2 4)))
(cat:cmpr m4 'n5 'n5) (cat:cmpr m4 'n5 'n5)
(dotimes (i 7) (dotimes (i 7)
(print (cat:basis m4 i))) (print (cat:basis m4 i)))
(mapcar #'(lambda (i) (cat:face m4 i 5 'n5)) (cat:<a-b> 0 5)) (mapcar #'(lambda (i) (cat:face m4 i 5 'n5)) (cat:<a-b> 0 5))
(cat:? m4 4 'm4) (cat:? m4 4 'm4)
(cat:? m4 5 'n5))) (cat:? m4 5 'n5)))
(test r-proj-space-basis (test r-proj-space-basis
(let ((b (cat:r-proj-space-basis 1 :infinity))) (let ((b (cat:r-proj-space-basis 1 :infinity)))
(dotimes (i 5) (print (funcall b i))) (dotimes (i 5) (print (funcall b i)))
(setf b (cat:r-proj-space-basis 1 5)) (setf b (cat:r-proj-space-basis 1 5))
(dotimes (i 8) (print (funcall b i))) (dotimes (i 8) (print (funcall b i)))
(setf b (cat:r-proj-space-basis 3 :infinity)) (setf b (cat:r-proj-space-basis 3 :infinity))
(dotimes (i 5) (print (funcall b i))) (dotimes (i 5) (print (funcall b i)))
(setf b (cat:r-proj-space-basis 3 6)) (setf b (cat:r-proj-space-basis 3 6))
(dotimes (i 10) (print (funcall b i))))) (dotimes (i 10) (print (funcall b i)))))
(test R-proj-space (test R-proj-space
(cat:cat-init) (cat:cat-init)
(let ((p (cat:R-proj-space))) (let ((p (cat:R-proj-space)))
(cat:basis p 4) (cat:basis p 4)
(dotimes (i 5) (dotimes (i 5)
(print (cat:face p i 4 4))) (print (cat:face p i 4 4)))
(dotimes (i 5) (dotimes (i 5)
(print (cat:? p i i))) (print (cat:? p i i)))
(setf dd (cat:cmps p p)) (setf dd (cat:cmps p p))
(dotimes (i 6) (dotimes (i 6)
(print (cat:? dd i i))) (print (cat:? dd i i)))
(setf p (cat:R-proj-space 3)) (setf p (cat:R-proj-space 3))
(dotimes (i 7) (dotimes (i 7)
(print (cat:basis p i))) (print (cat:basis p i)))
(dotimes (i 5) (dotimes (i 5)
(print (cat:face p i 4 4))) (print (cat:face p i 4 4)))
(dotimes (i 7) (dotimes (i 7)
(print (cat:? p i i))) (print (cat:? p i i)))
(setf dd (cat:cmps p p)) (setf dd (cat:cmps p p))
(dotimes (i 7) (dotimes (i 7)
(print (cat:? dd i i))))) (print (cat:? dd i i)))))
(test gmsms-subsmst (test gmsms-subsmst
(cat:cat-init) (cat:cat-init)
(let* ((k (cat:k-z 2)) (let* ((k (cat:k-z 2))
(efhm (cat:efhm k)) (efhm (cat:efhm k))
g cmbn kf incl cone s2 cl2 f2 s3 g cmbn kf incl cone s2 cl2 f2 s3
) )
(setf cat:*homology-verbose* nil) (setf cat:*homology-verbose* nil)
(setf g (first (cat:chcm-homology-gen (cat:rbcc efhm) 4))) (setf g (first (cat:chcm-homology-gen (cat:rbcc efhm) 4)))
(setf cmbn (cat:lf efhm (cat:rg efhm g))) (setf cmbn (cat:lf efhm (cat:rg efhm g)))
(multiple-value-setq (kf incl) (cat:gmsms-subsmst k cmbn)) (multiple-value-setq (kf incl) (cat:gmsms-subsmst k cmbn))
(setf cone (cat:cone incl)) (setf cone (cat:cone incl))
(cat:efhm cone) (cat:efhm cone)
(cat:homology kf 0 5) (cat:homology kf 0 5)
(cat:homology (cat:cone incl) 0 6) (cat:homology (cat:cone incl) 0 6)
(setf g (first (cat:chcm-homology-gen (cat:rbcc efhm) 8))) (setf g (first (cat:chcm-homology-gen (cat:rbcc efhm) 8)))
(setf cmbn (cat:lf efhm (cat:rg efhm g))) (setf cmbn (cat:lf efhm (cat:rg efhm g)))
(multiple-value-setq (kf incl) (cat:gmsms-subsmst k cmbn)) (multiple-value-setq (kf incl) (cat:gmsms-subsmst k cmbn))
(setf cone (cat:cone incl)) (setf cone (cat:cone incl))
(cat:efhm cone) (cat:efhm cone)
(cat:homology kf 0 9) (cat:homology kf 0 9)
(cat:homology (cat:cone incl) 0 10) (cat:homology (cat:cone incl) 0 10)
(dotimes (i 9) (print (length (cat:basis kf i)))) (dotimes (i 9) (print (length (cat:basis kf i))))
(setf s2 (cat:sphere 2)) (setf s2 (cat:sphere 2))
(setf cl2 (cat:chml-clss s2 2)) (setf cl2 (cat:chml-clss s2 2))
(setf f2 (cat:z-whitehead s2 cl2)) (setf f2 (cat:z-whitehead s2 cl2))
(setf s3 (cat:fibration-total f2)) (setf s3 (cat:fibration-total f2))
(setf efhm (cat:efhm s3)) (setf efhm (cat:efhm s3))
(cat:basis (cat:rbcc efhm) 3) (cat:basis (cat:rbcc efhm) 3)
(setf cmbn (cat:lf efhm (cat:rg efhm 3 (first (cat:basis (setf cmbn (cat:lf efhm (cat:rg efhm 3 (first (cat:basis
(cat:rbcc efhm) 3))))) (cat:rbcc efhm) 3)))))
(setf kf (cat:gmsms-subsmst s3 cmbn)) (setf kf (cat:gmsms-subsmst s3 cmbn))
(cat:homology kf 0 4))) (cat:homology kf 0 4)))

153
test/suspensions-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -6,38 +7,38 @@
(test suspension-cmpr (test suspension-cmpr
(cat:cat-init) (cat:cat-init)
(let* ((cc (cat:deltab)) (let* ((cc (cat:deltab))
(cmpr (cat:suspension-cmpr (cat:cmpr cc)))) (cmpr (cat:suspension-cmpr (cat:cmpr cc))))
(is (equal :equal (funcall cmpr :s-bsgn :s-bsgn))) (is (equal :equal (funcall cmpr :s-bsgn :s-bsgn)))
(is (equal :greater (funcall cmpr 6 5))))) (is (equal :greater (funcall cmpr 6 5)))))
(test suspension-basis (test suspension-basis
(cat:cat-init) (cat:cat-init)
(let* ((cc (cat:sphere 2)) (let* ((cc (cat:sphere 2))
(basis (cat:suspension-basis (cat:basis cc)))) (basis (cat:suspension-basis (cat:basis cc))))
(dotimes (i 6) (dotimes (i 6)
(print (funcall basis i))) (print (funcall basis i)))
(cat:suspension-basis :locally-effective))) (cat:suspension-basis :locally-effective)))
(test suspension-intr-dffr (test suspension-intr-dffr
(cat:cat-init) (cat:cat-init)
(let* ((cc (cat:deltab)) (let* ((cc (cat:deltab))
(intr (cat:suspension-intr-dffr (cat:dffr cc)))) (intr (cat:suspension-intr-dffr (cat:dffr cc))))
(funcall intr (cat:cmbn 0 3 :s-bsgn)) (funcall intr (cat:cmbn 0 3 :s-bsgn))
(funcall intr (cat:cmbn 3 66 7)))) (funcall intr (cat:cmbn 3 66 7))))
(test suspension (test suspension
(cat:cat-init) (cat:cat-init)
(let* ((cc (cat:deltab)) (let* ((cc (cat:deltab))
(scc (cat:suspension cc))) (scc (cat:suspension cc)))
(cat:cmpr scc 7 11) (cat:cmpr scc 7 11)
(signals simple-error (cat:basis scc 3)) (signals simple-error (cat:basis scc 3))
(cat:bsgn scc) (cat:bsgn scc)
(cat:? scc 3 11) (cat:? scc 3 11)
(setf scc (cat:suspension cc 2)) (setf scc (cat:suspension cc 2))
(cat:? scc 4 11))) (cat:? scc 4 11)))
(test suspension-intr-cprd (test suspension-intr-cprd
@ -49,92 +50,92 @@
(test coal (test coal
(cat:cat-init) (cat:cat-init)
(let* ((coal (cat:deltab)) (let* ((coal (cat:deltab))
(scoal (cat:suspension coal))) (scoal (cat:suspension coal)))
(setf scoal (cat:suspension coal)) (setf scoal (cat:suspension coal))
(cat:? scoal 3 7) (cat:? scoal 3 7)
(cat:cprd scoal 3 7))) (cat:cprd scoal 3 7)))
(test suspension-face (test suspension-face
(cat:cat-init) (cat:cat-init)
(let* ((ss (cat:deltab)) (let* ((ss (cat:deltab))
(face (cat:suspension-face (cat:face ss))) (face (cat:suspension-face (cat:face ss)))
(m (cat:moore 2 3))) (m (cat:moore 2 3)))
(funcall face 4 4 15) (funcall face 4 4 15)
(funcall face 0 4 15) (funcall face 0 4 15)
#+(or ecl sbcl) #+(or ecl sbcl)
(signals type-error (cat:check-faces #'cat:f-cmpr face 4 15)) (signals type-error (cat:check-faces #'cat:f-cmpr face 4 15))
#+(or ecl sbcl) #+(or ecl sbcl)
(signals type-error (cat:check-faces #'cat:f-cmpr face 3 7)) (signals type-error (cat:check-faces #'cat:f-cmpr face 3 7))
#+(or ecl sbcl) #+(or ecl sbcl)
(signals type-error (cat:check-faces #'cat:f-cmpr face 2 3)) (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 4 15)
#-(or ecl sbcl) (cat:check-faces #'cat:f-cmpr face 3 7) #-(or ecl sbcl) (cat:check-faces #'cat:f-cmpr face 3 7)
#-(or ecl sbcl) (cat:check-faces #'cat:f-cmpr face 2 3) #-(or ecl sbcl) (cat:check-faces #'cat:f-cmpr face 2 3)
(setf face (cat:suspension-face (cat:face m))) (setf face (cat:suspension-face (cat:face m)))
(dotimes (i 5) (print (funcall face i 4 'm3))) (dotimes (i 5) (print (funcall face i 4 'm3)))
(dotimes (i 6) (print (funcall face i 5 'mm4))) (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 4 'm3)
(cat:check-faces #'cat:s-cmpr face 5 'mm4) (cat:check-faces #'cat:s-cmpr face 5 'mm4)
)) ))
(test suspension1 (test suspension1
(cat:cat-init) (cat:cat-init)
(let* ((d (cat:deltab)) (let* ((d (cat:deltab))
(sd (cat:suspension d)) (sd (cat:suspension d))
(m (cat:moore 2 1)) (m (cat:moore 2 1))
(sm (cat:suspension m))) (sm (cat:suspension m)))
(setf sd (cat:suspension d)) (setf sd (cat:suspension d))
(cat:? sd 3 7) (cat:? sd 3 7)
(cat:cprd sd 3 7) (cat:cprd sd 3 7)
(cat:face sd 3 3 7) (cat:face sd 3 3 7)
(cat:face sd 2 3 7) (cat:face sd 2 3 7)
(cat:homology sm 0 5) (cat:homology sm 0 5)
(setf ssm (cat:suspension sm)) (setf ssm (cat:suspension sm))
(cat:homology ssm 0 6))) (cat:homology ssm 0 6)))
(test suspension-intr (test suspension-intr
(cat:cat-init) (cat:cat-init)
(let* ((f (cat:idnt-mrph (cat:deltab))) (let* ((f (cat:idnt-mrph (cat:deltab)))
(sf (cat:suspension-intr f)) (sf (cat:suspension-intr f))
(d (cat:dffr (cat:deltab))) (d (cat:dffr (cat:deltab)))
(sd (cat:suspension-intr d))) (sd (cat:suspension-intr d)))
(funcall sf (cat:cmbn 0 3 :s-bsgn)) (funcall sf (cat:cmbn 0 3 :s-bsgn))
(funcall sf (cat:cmbn 2 4 3)) (funcall sf (cat:cmbn 2 4 3))
(funcall sd (cat:cmbn 0 3 :s-bsgn)) (funcall sd (cat:cmbn 0 3 :s-bsgn))
(funcall sd (cat:cmbn 2 4 3)) (funcall sd (cat:cmbn 2 4 3))
(funcall sd (cat:cmbn 3 4 7)))) (funcall sd (cat:cmbn 3 4 7))))
(test suspension2 (test suspension2
(cat:cat-init) (cat:cat-init)
(let* ((f (cat:idnt-mrph (cat:deltab))) (let* ((f (cat:idnt-mrph (cat:deltab)))
(sf (cat:suspension f)) (sf (cat:suspension f))
(d (cat:dffr (cat:deltab))) (d (cat:dffr (cat:deltab)))
(sd (cat:suspension d))) (sd (cat:suspension d)))
(cat:? sf (cat:cmbn 0 3 :s-bsgn)) (cat:? sf (cat:cmbn 0 3 :s-bsgn))
(cat:? sf (cat:cmbn 2 4 3)) (cat:? sf (cat:cmbn 2 4 3))
(cat:? sd (cat:cmbn 0 3 :s-bsgn)) (cat:? sd (cat:cmbn 0 3 :s-bsgn))
(cat:? sd (cat:cmbn 2 4 3)) (cat:? sd (cat:cmbn 2 4 3))
(cat:? sd (cat:cmbn 3 4 7)))) (cat:? sd (cat:cmbn 3 4 7))))
(test suspension3 (test suspension3
(cat:cat-init) (cat:cat-init)
(let* ((rdct (cat:ez (cat:deltab) (cat:deltab))) (let* ((rdct (cat:ez (cat:deltab) (cat:deltab)))
(srdct (cat:suspension rdct))) (srdct (cat:suspension rdct)))
(cat:pre-check-rdct srdct) (cat:pre-check-rdct srdct)
(setf cat:*tc* (cat:cmbn 4 1 (cat:crpr 0 15 0 15))) (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) (setf cat:*bc* (cat:cmbn 4 1 (cat:tnpr 0 1 3 15)
5 (cat:tnpr 1 3 2 7) 5 (cat:tnpr 1 3 2 7)
10 (cat:tnpr 2 7 1 3) 10 (cat:tnpr 2 7 1 3)
100 (cat:tnpr 3 15 0 1))) 100 (cat:tnpr 3 15 0 1)))
(check-rdct))) (check-rdct)))
(test suspension4 (test suspension4
(cat:cat-init) (cat:cat-init)
(let ((sk (cat:suspension (cat:k-z 2)))) (let ((sk (cat:suspension (cat:k-z 2))))
(cat:homology sk 0 10))) (cat:homology sk 0 10)))

181
test/tensor-products-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -14,32 +15,32 @@
(test 2cmbn-tnpr (test 2cmbn-tnpr
(setf cat:*tnpr-with-degrees* t) (setf cat:*tnpr-with-degrees* t)
(cat:2cmbn-tnpr (cat:cmbn 2 3 'a 4 'b -5 'c) (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 (test tnsr-prdc-cmpr
(let ((cmpr (cat:tnsr-prdc-cmpr #'cat:s-cmpr #'cat:s-cmpr))) (let ((cmpr (cat:tnsr-prdc-cmpr #'cat:s-cmpr #'cat:s-cmpr)))
(is (equal :less (funcall cmpr (is (equal :less (funcall cmpr
(cat:tnpr 2 'a 3 'b) (cat:tnpr 2 'a 3 'b)
(cat:tnpr 3 'a 2 'b)))) (cat:tnpr 3 'a 2 'b))))
(is (equal :greater (funcall cmpr (is (equal :greater (funcall cmpr
(cat:tnpr 3 'a 2 'b) (cat:tnpr 3 'a 2 'b)
(cat:tnpr 2 'a 3 'b)))) (cat:tnpr 2 'a 3 'b))))
(is (equal :less (funcall cmpr (is (equal :less (funcall cmpr
(cat:tnpr 2 'a 3 'b) (cat:tnpr 2 'a 3 'b)
(cat:tnpr 2 'b 3 'b)))) (cat:tnpr 2 'b 3 'b))))
(is (equal :greater (funcall cmpr (is (equal :greater (funcall cmpr
(cat:tnpr 2 'b 3 'b) (cat:tnpr 2 'b 3 'b)
(cat:tnpr 2 'a 3 'b)))) (cat:tnpr 2 'a 3 'b))))
(is (equal :less (funcall cmpr (is (equal :less (funcall cmpr
(cat:tnpr 2 'a 3 'a) (cat:tnpr 2 'a 3 'a)
(cat:tnpr 2 'a 3 'b)))) (cat:tnpr 2 'a 3 'b))))
(is (equal :greater (funcall cmpr (is (equal :greater (funcall cmpr
(cat:tnpr 2 'a 3 'c) (cat:tnpr 2 'a 3 'c)
(cat:tnpr 2 'a 3 'b)))) (cat:tnpr 2 'a 3 'b))))
(is (equal :equal (funcall cmpr (is (equal :equal (funcall cmpr
(cat:tnpr 2 'a 3 'b) (cat:tnpr 2 'a 3 'b)
(cat:tnpr 2 'a 3 'b)))))) (cat:tnpr 2 'a 3 'b))))))
(defun bas (degr) (defun bas (degr)
@ -52,99 +53,99 @@
(test tnsr-prdc-basis (test tnsr-prdc-basis
(let ((bas (cat:tnsr-prdc-basis #'bas #'bas))) (let ((bas (cat:tnsr-prdc-basis #'bas #'bas)))
(dotimes (i 8) (dotimes (i 8)
(print (funcall bas i))))) (print (funcall bas i)))))
(test tnsr-prdc-intr-dffr (test tnsr-prdc-intr-dffr
(cat:cat-init) (cat:cat-init)
(let* ((chcm (cat:build-chcm :cmpr #'cat:s-cmpr (let* ((chcm (cat:build-chcm :cmpr #'cat:s-cmpr
:basis :locally-effective :basis :locally-effective
:intr-dffr #'cat:zero-mrph :intr-dffr #'cat:zero-mrph
:strt :gnrt :orgn '(test-1))) :strt :gnrt :orgn '(test-1)))
(dffr (cat:build-mrph (dffr (cat:build-mrph
:sorc chcm :trgt chcm :degr -1 :sorc chcm :trgt chcm :degr -1
:intr #'(lambda (degr gnrt) :intr #'(lambda (degr gnrt)
(ecase gnrt (ecase gnrt
(a (cat:cmbn (1- degr) 2 'd1a -3 'd2a)) (a (cat:cmbn (1- degr) 2 'd1a -3 'd2a))
(b (cat:cmbn (1- degr) 3 'd1b -4 'd2b)))) (b (cat:cmbn (1- degr) 3 'd1b -4 'd2b))))
:strt :gnrt :orgn '(test-2))) :strt :gnrt :orgn '(test-2)))
(rslt (cat:tnsr-prdc-intr-dffr dffr dffr))) (rslt (cat:tnsr-prdc-intr-dffr dffr dffr)))
(funcall rslt 4 (cat:tnpr 2 'a 2 'b)) (funcall rslt 4 (cat:tnpr 2 'a 2 'b))
(funcall rslt 5 (cat:tnpr 3 'a 2 'b)) (funcall rslt 5 (cat:tnpr 3 'a 2 'b))
(funcall rslt 5 (cat:tnpr 2 'a 3 'b)) (funcall rslt 5 (cat:tnpr 2 'a 3 'b))
(funcall rslt 6 (cat:tnpr 3 'a 3 'b)))) (funcall rslt 6 (cat:tnpr 3 'a 3 'b))))
(test tnsr-prdc (test tnsr-prdc
(let ((dd (cat:tnsr-prdc (cat:delta 2) (cat:delta 3)))) (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:cmpr dd (cat:tnpr 2 7 2 11) (cat:tnpr 2 7 2 14))
(cat:basis dd 3) (cat:basis dd 3)
(cat:? dd 4 (cat:tnpr 2 7 2 14)) (cat:? dd 4 (cat:tnpr 2 7 2 14))
(cat:? dd 3 (cat:tnpr 1 6 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 4 (cat:tnpr 2 7 2 14)))
(cat:? dd (cat:? dd 3 (cat:tnpr 1 6 2 14))))) (cat:? dd (cat:? dd 3 (cat:tnpr 1 6 2 14)))))
(test tnsr-prdc-intr (test tnsr-prdc-intr
(cat:cat-init) (cat:cat-init)
(let* ((chcm (cat:build-chcm :cmpr #'cat:s-cmpr (let* ((chcm (cat:build-chcm :cmpr #'cat:s-cmpr
:basis :locally-effective :basis :locally-effective
:intr-dffr #'cat:zero-mrph :intr-dffr #'cat:zero-mrph
:strt :gnrt :strt :gnrt
:orgn '(test-1))) :orgn '(test-1)))
(mrph (cat:build-mrph (mrph (cat:build-mrph
:sorc chcm :trgt chcm :degr 0 :sorc chcm :trgt chcm :degr 0
:intr #'(lambda (degr gnrt) :intr #'(lambda (degr gnrt)
(ecase gnrt (ecase gnrt
(a (cat:cmbn degr 2 'd1a -3 'd2a)) (a (cat:cmbn degr 2 'd1a -3 'd2a))
(b (cat:cmbn degr 3 'd1b -4 'd2b)))) (b (cat:cmbn degr 3 'd1b -4 'd2b))))
:strt :gnrt :orgn '(test-2))) :strt :gnrt :orgn '(test-2)))
(rslt (cat:tnsr-prdc-intr mrph mrph))) (rslt (cat:tnsr-prdc-intr mrph mrph)))
(funcall rslt 6 (cat:tnpr 2 'a 4 'b)) (funcall rslt 6 (cat:tnpr 2 'a 4 'b))
(funcall rslt 5 (cat:tnpr 3 'a 2 'b)) (funcall rslt 5 (cat:tnpr 3 'a 2 'b))
(setf mrph (cat:build-mrph (setf mrph (cat:build-mrph
:sorc chcm :trgt chcm :degr 1 :sorc chcm :trgt chcm :degr 1
:intr #'(lambda (degr gnrt) :intr #'(lambda (degr gnrt)
(ecase gnrt (ecase gnrt
(a (cat:cmbn (1+ degr) 2 'd1a -3 'd2a)) (a (cat:cmbn (1+ degr) 2 'd1a -3 'd2a))
(b (cat:cmbn (1+ degr) 3 'd1b -4 'd2b)))) (b (cat:cmbn (1+ degr) 3 'd1b -4 'd2b))))
:strt :gnrt :orgn '(test-3))) :strt :gnrt :orgn '(test-3)))
(setf rslt (cat:tnsr-prdc-intr mrph mrph)) (setf rslt (cat:tnsr-prdc-intr mrph mrph))
(funcall rslt 6 (cat:tnpr 2 'a 4 'b)) (funcall rslt 6 (cat:tnpr 2 'a 4 'b))
(funcall rslt 5 (cat:tnpr 3 'a 2 'b)))) (funcall rslt 5 (cat:tnpr 3 'a 2 'b))))
(test tnsr-prdc (test tnsr-prdc
(cat:cat-init) (cat:cat-init)
(let* ((d (cat:dffr (cat:delta-infinity))) (let* ((d (cat:dffr (cat:delta-infinity)))
(dd (cat:tnsr-prdc d d)) (dd (cat:tnsr-prdc d d))
(ddd (cat:cmps dd dd))) (ddd (cat:cmps dd dd)))
(is (eq (cat:sorc dd) (cat:tnsr-prdc (cat:delta-infinity) (is (eq (cat:sorc dd) (cat:tnsr-prdc (cat:delta-infinity)
(cat:delta-infinity)))) (cat:delta-infinity))))
(cat:? dd 5 (cat:tnpr 2 7 3 15)) (cat:? dd 5 (cat:tnpr 2 7 3 15))
(cat:? dd 5 (cat:tnpr 3 15 2 7)) (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 2 7 3 15)))
(cat:? dd (cat:? dd 5 (cat:tnpr 3 15 2 7))) (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 2 7 3 15))
(cat:? ddd 5 (cat:tnpr 3 15 2 7)))) (cat:? ddd 5 (cat:tnpr 3 15 2 7))))
(test tnsr-prdc1 (test tnsr-prdc1
(cat:cat-init) (cat:cat-init)
(let* ((r (cat:ez (cat:delta-infinity) (cat:delta-infinity))) (let* ((r (cat:ez (cat:delta-infinity) (cat:delta-infinity)))
(r2 (cat:tnsr-prdc r r))) (r2 (cat:tnsr-prdc r r)))
(setf cat:*bc* (cat:cmbn 4 1 (cat:tnpr 2 (cat:tnpr 1 3 1 3) 2 (setf cat:*bc* (cat:cmbn 4 1 (cat:tnpr 2 (cat:tnpr 1 3 1 3) 2
(cat:tnpr 1 3 1 3))) (cat:tnpr 1 3 1 3)))
cat:*tc* (cat:cmbn 2 1 (cat:tnpr 1 (cat:crpr 0 3 0 3) 1 cat:*tc* (cat:cmbn 2 1 (cat:tnpr 1 (cat:crpr 0 3 0 3) 1
(cat:crpr 0 3 0 3)))) (cat:crpr 0 3 0 3))))
(cat:pre-check-rdct r2) (cat:pre-check-rdct r2)
(check-rdct))) (check-rdct)))
(test tnsr-prdc2 (test tnsr-prdc2
(cat:cat-init) (cat:cat-init)
(let* ((k (cat:k-z 2)) (let* ((k (cat:k-z 2))
(k2 (cat:tnsr-prdc k k))) (k2 (cat:tnsr-prdc k k)))
(cat:homology k2 0 10))) (cat:homology k2 0 10)))

25
test/various-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -5,15 +6,15 @@
(test binomial-n-p (test binomial-n-p
(let ((rslt '(1 5 10 10 5 1))) (let ((rslt '(1 5 10 10 5 1)))
(dotimes (i 6) (dotimes (i 6)
(is (equal (cat:binomial-n-p 5 i) (is (equal (cat:binomial-n-p 5 i)
(nth i rslt)))))) (nth i rslt))))))
(test binomial-p-q (test binomial-p-q
(let ((rslt '(1 5 10 10 5 1))) (let ((rslt '(1 5 10 10 5 1)))
(dotimes (i 6) (dotimes (i 6)
(is (equal (cat:binomial-p-q (- 5 i) i) (is (equal (cat:binomial-p-q (- 5 i) i)
(nth i rslt)))))) (nth i rslt))))))
(test <a-b< (test <a-b<
(is (equal (cat:<a-b< 0 5) '(0 1 2 3 4)))) (is (equal (cat:<a-b< 0 5) '(0 1 2 3 4))))
@ -29,12 +30,12 @@
(test v<a-b> (test v<a-b>
(is (equalp (cat:v<a-b> -5 5) (is (equalp (cat:v<a-b> -5 5)
(make-array 11 :element-type 'fixnum (make-array 11 :element-type 'fixnum
:initial-contents '(-5 -4 -3 -2 -1 :initial-contents '(-5 -4 -3 -2 -1
0 1 2 3 4 5))))) 0 1 2 3 4 5)))))
(test srandom (test srandom
(dotimes (i 20) (dotimes (i 20)
(let ((rslt (cat:srandom 3))) (let ((rslt (cat:srandom 3)))
(is (and (typep rslt 'fixnum) (is (and (typep rslt 'fixnum)
(<= -3 rslt 3)))))) (<= -3 rslt 3))))))

179
test/whitehead-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
@ -7,88 +8,88 @@
(test z-whitehead-sintr (test z-whitehead-sintr
(cat:cat-init) (cat:cat-init)
(let* ((k (cat:k-z 2)) (let* ((k (cat:k-z 2))
(ecc (cat:echcm k)) (ecc (cat:echcm k))
(chml-clss (chml-clss
(cat:build-mrph (cat:build-mrph
:sorc ecc :trgt (cat:z-chcm) :degr 2 :sorc ecc :trgt (cat:z-chcm) :degr 2
:intr #'(lambda (degr gnrt) :intr #'(lambda (degr gnrt)
(if (= degr 2) (if (= degr 2)
(cat:term-cmbn 0 1 :z-gnrt) (cat:term-cmbn 0 1 :z-gnrt)
(cat:zero-cmbn (- degr 2)))) (cat:zero-cmbn (- degr 2))))
:strt :gnrt :orgn '(fundamental-class k-z-2))) :strt :gnrt :orgn '(fundamental-class k-z-2)))
(tw (cat:z-whitehead-sintr k 2 chml-clss))) (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 1 (cat:absm 1 cat:+null-gbar+) '())
(cat:tw-a-sintr3 tw 2 (cat:absm 3 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 2 (cat:gbar 2 0 '(55) 0 '()))
(funcall tw 3 (cat:gbar 3 0 '(12 23) 0 '(34) 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 '())) (funcall tw 4 (cat:gbar 4 0 '(12 23 34) 2 '(45) 0 '(56) 0 '()))
(setf k (cat:k-z 3)) (setf k (cat:k-z 3))
(setf ecc (cat:echcm k)) (setf ecc (cat:echcm k))
(setf chml-clss (setf chml-clss
(cat:build-mrph (cat:build-mrph
:sorc ecc :trgt (cat:z-chcm) :degr 3 :sorc ecc :trgt (cat:z-chcm) :degr 3
:intr #'(lambda (degr gnrt) :intr #'(lambda (degr gnrt)
(if (= degr 3) (if (= degr 3)
(cat:term-cmbn 0 -1 :z-gnrt) (cat:term-cmbn 0 -1 :z-gnrt)
(cat:zero-cmbn (- degr 3)))) (cat:zero-cmbn (- degr 3))))
:strt :gnrt :orgn '(fundamental-class k-z-3))) :strt :gnrt :orgn '(fundamental-class k-z-3)))
(setf tw (cat:z-whitehead-sintr k 3 chml-clss)) (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 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 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+) (cat:tw-a-sintr3 tw 3 (cat:absm 7 cat:+null-gbar+) cat:+null-gbar+)
(funcall tw 3 (cat:z-fundamental-gmsm 3 55)) (funcall tw 3 (cat:z-fundamental-gmsm 3 55))
(is (equalp (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)))) (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 '()) (funcall tw 4 (cat:gbar 4 0 (cat:gbar 3 0 '(12 23) 0 '(34) 0 '())
0 (cat:gbar 2 0 '(45) 0 '()) 0 (cat:gbar 2 0 '(45) 0 '())
1 (cat:gbar 0) 1 (cat:gbar 0)
0 (cat:gbar 0))))) 0 (cat:gbar 0)))))
(test Z2-whitehead-sintr (test Z2-whitehead-sintr
(cat:cat-init) (cat:cat-init)
(let* ((k (cat:k-z2 2)) (let* ((k (cat:k-z2 2))
(ecc (cat:echcm k)) (ecc (cat:echcm k))
(chml-clss (chml-clss
(cat:build-mrph (cat:build-mrph
:sorc ecc :trgt (cat:z-chcm) :degr 2 :sorc ecc :trgt (cat:z-chcm) :degr 2
:intr #'(lambda (degr gnrt) :intr #'(lambda (degr gnrt)
(if (= degr 2) (if (= degr 2)
(cat:term-cmbn 0 1 :z-gnrt) (cat:term-cmbn 0 1 :z-gnrt)
(cat:zero-cmbn (- degr 2)))) (cat:zero-cmbn (- degr 2))))
:strt :gnrt :orgn '(fundamental-class k-z-2))) :strt :gnrt :orgn '(fundamental-class k-z-2)))
(tw (cat:Z2-whitehead-sintr k 2 chml-clss))) (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 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 2 (cat:absm 3 cat:+null-gbar+) 0)
(funcall tw 2 (cat:gbar 2 0 1 0 '())) (funcall tw 2 (cat:gbar 2 0 1 0 '()))
(funcall tw 3 (cat:gbar 3 0 2 (funcall tw 3 (cat:gbar 3 0 2
0 1 0 1
0 0)) 0 0))
(funcall tw 4 (cat:gbar 4 0 3 (funcall tw 4 (cat:gbar 4 0 3
2 1 2 1
0 1 0 1
0 0)) 0 0))
(setf k (cat:k-z2 3)) (setf k (cat:k-z2 3))
(setf ecc (cat:echcm k)) (setf ecc (cat:echcm k))
(setf chml-clss (setf chml-clss
(cat:build-mrph (cat:build-mrph
:sorc ecc :trgt (cat:z-chcm) :degr 3 :sorc ecc :trgt (cat:z-chcm) :degr 3
:intr #'(lambda (degr gnrt) :intr #'(lambda (degr gnrt)
(if (= degr 3) (if (= degr 3)
(cat:term-cmbn 0 -1 :z-gnrt) (cat:term-cmbn 0 -1 :z-gnrt)
(cat:zero-cmbn (- degr 3)))) (cat:zero-cmbn (- degr 3))))
:strt :gnrt :orgn '(fundamental-class k-z-3))) :strt :gnrt :orgn '(fundamental-class k-z-3)))
(setf tw (cat:Z2-whitehead-sintr k 3 chml-clss)) (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 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 2 (cat:absm 3 cat:+null-gbar+) 0)
(cat:tw-a-sintr3 tw 3 (cat:absm 7 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)) (funcall tw 3 (cat:Z2-fundamental-gmsm 3 1))
(is (equalp (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)))) (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) (funcall tw 4 (cat:gbar 4 0 (cat:gbar 3 0 2 0 1 0 0)
0 (cat:gbar 2 0 1 0 0) 0 (cat:gbar 2 0 1 0 0)
1 (cat:gbar 0) 1 (cat:gbar 0)
0 (cat:gbar 0))))) 0 (cat:gbar 0)))))
#| #|
@ -98,16 +99,16 @@
(test Z2-whitehead (test Z2-whitehead
(cat:cat-init) (cat:cat-init)
(let* ((m (cat:moore 2 4)) (let* ((m (cat:moore 2 4))
(chml-clss (chml-clss
(cat:build-mrph (cat:build-mrph
:sorc m :trgt (cat:z-chcm) :degr -4 :sorc m :trgt (cat:z-chcm) :degr -4
:intr #'(lambda (dmns gmsm) :intr #'(lambda (dmns gmsm)
(if (= 4 dmns) (if (= 4 dmns)
(cat:cmbn 0 1 :z-gnrt) (cat:cmbn 0 1 :z-gnrt)
(cat:zero-cmbn (- dmns 4)))) (cat:zero-cmbn (- dmns 4))))
:strt :gnrt :strt :gnrt
:orgn '(chml-clss moore 2 4))) :orgn '(chml-clss moore 2 4)))
(mf (cat:z2-whitehead m chml-clss)) (mf (cat:z2-whitehead m chml-clss))
(mt (cat:fibration-total mf))) (mt (cat:fibration-total mf)))
(cat:homology mt 0 10))) (cat:homology mt 0 10)))
|# |#