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
: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)
@ -16,52 +16,51 @@
:components
((:file "package")
(:module "src"
:components
((:file "kenzo")
(:file "abbreviations")
(:file "macros")
(:file "various")
(:file "classes")
(:file "combinations")
(:file "chain-complexes")
(:file "chcm-elementary-op")
(:file "effective-homology")
(:file "homology-groups")
(:file "searching-homology")
(:file "cones")
(:file "bicones")
(:file "tensor-products")
(:file "coalgebras")
(:file "cobar")
(:file "algebras")
(:file "bar")
(:file "simplicial-sets")
(:file "simplicial-mrphs")
(:file "delta")
(:file "special-smsts")
(:file "suspensions")
(:file "disk-pasting")
(:file "cartesian-products")
(:file "eilenberg-zilber")
(:file "kan")
(:file "simplicial-groups")
(:file "fibrations")
(:file "loop-spaces")
(:file "ls-twisted-products")
(:file "lp-space-efhm")
(:file "classifying-spaces")
(:file "k-pi-n")
(:file "serre")
(:file "cs-twisted-products")
(:file "cl-space-efhm")
(:file "whitehead")
(:file "smith")
#|
(:module "anromero"
:components
((:file "bicomplexes")
(:file "filtered-complexes")
(:file "spectral-sequences")))
|#
))))
:components
((:file "kenzo")
(:file "abbreviations")
(:file "macros")
(:file "various")
(:file "classes")
(:file "combinations")
(:file "chain-complexes")
(:file "chcm-elementary-op")
(:file "effective-homology")
(:file "homology-groups")
(:file "searching-homology")
(:file "cones")
(:file "bicones")
(:file "tensor-products")
(:file "coalgebras")
(:file "cobar")
(:file "algebras")
(:file "bar")
(:file "simplicial-sets")
(:file "simplicial-mrphs")
(:file "delta")
(:file "special-smsts")
(:file "suspensions")
(:file "disk-pasting")
(:file "cartesian-products")
(:file "eilenberg-zilber")
(:file "kan")
(:file "simplicial-groups")
(:file "fibrations")
(:file "loop-spaces")
(:file "ls-twisted-products")
(:file "lp-space-efhm")
(:file "classifying-spaces")
(:file "k-pi-n")
(:file "serre")
(:file "cs-twisted-products")
(:file "cl-space-efhm")
(:file "whitehead")
(:file "smith")
#|
(:module "anromero"
:components
((:file "bicomplexes")
(:file "filtered-complexes")
(:file "spectral-sequences")))
|#
))))

4
package.lisp
View File

@ -1,6 +1,4 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;;
;;;; package.lisp
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(defpackage #:cat
(: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)))

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

9
src/abbreviations.lisp
View File

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

14
src/kenzo.lisp
View File

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

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

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

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

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

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

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

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

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

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

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

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

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

10
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
@ -16,9 +18,9 @@
(homology (loop-space (moore 2 4) 2) 7)
(homology (k-z2 2) 3 8)
(homology (k-z2 3) 3 8)
(setf s3 (sphere 3))
(homology s3 3)
(setf ch3 (chml-clss s3 3))
@ -33,7 +35,7 @@
(setf f5 (z-whitehead x5 ch5))
(setf x6 (fibration-total f5))
))
))
(time (homology o2s3 7))
(time (homology x6 6))
(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)

165
test/bicones-test.lisp
View File

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

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

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

161
test/ccn.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test)
@ -6,87 +7,87 @@
(defun ccn ()
(the cat:chain-complex
(cat:build-chcm
:cmpr #'cat:f-cmpr
:basis #'(lambda (n)
(cat:<a-b< (* 10 n) (* 10 (1+ n))))
:bsgn 0
:intr-dffr #'(lambda (dgr gnr)
(if (evenp (+ dgr gnr))
(cat:cmbn (1- dgr) 1 (- gnr 10))
(cat:cmbn (1- dgr))))
:strt :gnrt
:orgn '(ccn))))
:cmpr #'cat:f-cmpr
:basis #'(lambda (n)
(cat:<a-b< (* 10 n) (* 10 (1+ n))))
:bsgn 0
:intr-dffr #'(lambda (dgr gnr)
(if (evenp (+ dgr gnr))
(cat:cmbn (1- dgr) 1 (- gnr 10))
(cat:cmbn (1- dgr))))
:strt :gnrt
:orgn '(ccn))))
(test ccn
(progn
(cat:cat-init)
(let* ((ccn (ccn))
(upper-shift (cat:build-mrph
:sorc ccn :trgt ccn :strt :gnrt :degr 1
:intr #'(lambda (d gn) (cat:cmbn (1+ d)
1 (+ gn 10)))
:orgn '(ccn shift +10)))
(lower-shift (cat:build-mrph
:sorc ccn :trgt ccn :strt :gnrt :degr -1
:intr #'(lambda (d gn) (cat:cmbn (1- d)
1 (- gn 10)))
:orgn '(ccn shift -10)))
(comb1 (cat:? ccn 2 22))
(combn (cat:cmbn 5 1 50 5 55 9 59))
(d-combn (cat:? ccn combn))
(dd-combn (cat:? ccn d-combn))
(comb2 (cat:? upper-shift 0 6))
(comb3 (cat:? lower-shift 5 51))
(comb4 (cat:? lower-shift comb3))
(identity? (cat:cmps upper-shift lower-shift))
(comb5 (cat:cmbn 1 1 10 2 11 3 12 4 13))
(comb6 (cat:? identity? comb5))
(comb7 (cat:2cmbn-sbtr (cat:cmpr ccn) comb5 comb6))
(upper2-shift (cat:cmps upper-shift upper-shift))
(comb8 (cat:? upper2-shift comb5))
(twice-up-shift (cat:add upper-shift upper-shift))
(comb9 (cat:? twice-up-shift comb5))
(up-d (cat:cmps upper-shift (cat:dffr1 ccn)))
(d-up (cat:cmps (cat:dffr1 ccn) upper-shift))
(comb10 (cat:? up-d 1 11))
(comb11 (cat:? d-up 1 11))
(comb12 (cat:cmbn 1 1 10 2 11 3 12 4 13 5 14 6 15))
(comb13 (cat:? up-d comb12))
(comb14 (cat:? d-up comb12))
)
(is (equal (cat:cmbn-degr comb1) 1))
(is (equal (cat:cmbn-list comb1) '((1 . 12))))
(is (null (cat:cmbn-non-zero-p (cat:? ccn comb1))))
(is (equal (cat:cmbn-degr d-combn) 4))
(is (equal (cat:cmbn-list d-combn) '((5 . 45) (9 . 49))))
(is (equal (cat:cmbn-degr dd-combn) 3))
(is (equal (cat:cmbn-list dd-combn) nil))
(is (equal (cat:cmbn-degr comb2) 1))
(is (equal (cat:cmbn-list comb2) '((1 . 16))))
(is (equal (cat:cmbn-degr comb3) 4))
(is (equal (cat:cmbn-list comb3) '((1 . 41))))
(is (equal (cat:cmbn-degr comb4) 3))
(is (equal (cat:cmbn-list comb4) '((1 . 31))))
(is (equal (cat:degr identity?) 0))
(is (equal (cat:cmbn-degr comb6) 1))
(is (equal (cat:cmbn-list comb6) '((1 . 10) (2 . 11) (3 . 12)
(4 . 13))))
(is (equal (cat:cmbn-degr comb7) 1))
(is (equal (cat:cmbn-list comb7) nil))
(is (equal (cat:degr upper2-shift) 2))
(is (equal (cat:cmbn-degr comb8) 3))
(is (equal (cat:cmbn-list comb8) '((1 . 30) (2 . 31) (3 . 32)
(4 . 33))))
(is (equal (cat:degr twice-up-shift) 1))
(is (equal (cat:cmbn-degr comb9) 2))
(is (equal (cat:cmbn-list comb9) '((2 . 20) (4 . 21) (6 . 22)
(8 . 23))))
(is (equal (cat:cmbn-degr comb10) 1))
(is (equal (cat:cmbn-list comb10) '((1 . 11))))
(is (equal (cat:cmbn-degr comb11) 1))
(is (equal (cat:cmbn-list comb11) nil))
(is (equal (cat:cmbn-degr comb13) 1))
(is (equal (cat:cmbn-list comb13) '((2 . 11) (4 . 13) (6 . 15))))
(is (equal (cat:cmbn-degr comb14) 1))
(is (equal (cat:cmbn-list comb14) '((1 . 10) (3 . 12) (5 . 14)))))))
(cat:cat-init)
(let* ((ccn (ccn))
(upper-shift (cat:build-mrph
:sorc ccn :trgt ccn :strt :gnrt :degr 1
:intr #'(lambda (d gn) (cat:cmbn (1+ d)
1 (+ gn 10)))
:orgn '(ccn shift +10)))
(lower-shift (cat:build-mrph
:sorc ccn :trgt ccn :strt :gnrt :degr -1
:intr #'(lambda (d gn) (cat:cmbn (1- d)
1 (- gn 10)))
:orgn '(ccn shift -10)))
(comb1 (cat:? ccn 2 22))
(combn (cat:cmbn 5 1 50 5 55 9 59))
(d-combn (cat:? ccn combn))
(dd-combn (cat:? ccn d-combn))
(comb2 (cat:? upper-shift 0 6))
(comb3 (cat:? lower-shift 5 51))
(comb4 (cat:? lower-shift comb3))
(identity? (cat:cmps upper-shift lower-shift))
(comb5 (cat:cmbn 1 1 10 2 11 3 12 4 13))
(comb6 (cat:? identity? comb5))
(comb7 (cat:2cmbn-sbtr (cat:cmpr ccn) comb5 comb6))
(upper2-shift (cat:cmps upper-shift upper-shift))
(comb8 (cat:? upper2-shift comb5))
(twice-up-shift (cat:add upper-shift upper-shift))
(comb9 (cat:? twice-up-shift comb5))
(up-d (cat:cmps upper-shift (cat:dffr1 ccn)))
(d-up (cat:cmps (cat:dffr1 ccn) upper-shift))
(comb10 (cat:? up-d 1 11))
(comb11 (cat:? d-up 1 11))
(comb12 (cat:cmbn 1 1 10 2 11 3 12 4 13 5 14 6 15))
(comb13 (cat:? up-d comb12))
(comb14 (cat:? d-up comb12))
)
(is (equal (cat:cmbn-degr comb1) 1))
(is (equal (cat:cmbn-list comb1) '((1 . 12))))
(is (null (cat:cmbn-non-zero-p (cat:? ccn comb1))))
(is (equal (cat:cmbn-degr d-combn) 4))
(is (equal (cat:cmbn-list d-combn) '((5 . 45) (9 . 49))))
(is (equal (cat:cmbn-degr dd-combn) 3))
(is (equal (cat:cmbn-list dd-combn) nil))
(is (equal (cat:cmbn-degr comb2) 1))
(is (equal (cat:cmbn-list comb2) '((1 . 16))))
(is (equal (cat:cmbn-degr comb3) 4))
(is (equal (cat:cmbn-list comb3) '((1 . 41))))
(is (equal (cat:cmbn-degr comb4) 3))
(is (equal (cat:cmbn-list comb4) '((1 . 31))))
(is (equal (cat:degr identity?) 0))
(is (equal (cat:cmbn-degr comb6) 1))
(is (equal (cat:cmbn-list comb6) '((1 . 10) (2 . 11) (3 . 12)
(4 . 13))))
(is (equal (cat:cmbn-degr comb7) 1))
(is (equal (cat:cmbn-list comb7) nil))
(is (equal (cat:degr upper2-shift) 2))
(is (equal (cat:cmbn-degr comb8) 3))
(is (equal (cat:cmbn-list comb8) '((1 . 30) (2 . 31) (3 . 32)
(4 . 33))))
(is (equal (cat:degr twice-up-shift) 1))
(is (equal (cat:cmbn-degr comb9) 2))
(is (equal (cat:cmbn-list comb9) '((2 . 20) (4 . 21) (6 . 22)
(8 . 23))))
(is (equal (cat:cmbn-degr comb10) 1))
(is (equal (cat:cmbn-list comb10) '((1 . 11))))
(is (equal (cat:cmbn-degr comb11) 1))
(is (equal (cat:cmbn-list comb11) nil))
(is (equal (cat:cmbn-degr comb13) 1))
(is (equal (cat:cmbn-list comb13) '((2 . 11) (4 . 13) (6 . 15))))
(is (equal (cat:cmbn-degr comb14) 1))
(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)
@ -5,67 +6,67 @@
(test do-control
(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-list comb) '((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-list comb) '((1 . a) (1 . b) (-1 . c)))))
(signals simple-error (cat:do-control #'cat:s-cmpr
(cat:cmbn 0 1 'b 1 'b -1 'c)))
(signals simple-error (cat:do-control #'cat:s-cmpr
(cat:cmbn 0 1 'b 1 'b -1 'c)))
(signals simple-error (cat:do-control #'cat:s-cmpr
(cat:cmbn 0 1 'a 1 'b -1 'b)))
(signals simple-error (cat:do-control #'cat:s-cmpr
(cat:cmbn 0 1 'a 1 'b -1 'b)))
(setf cat:*cmbn-control* nil)
(is (not (null (cat:do-control #'cat:s-cmpr
(cat:cmbn 0 1 'a 1 'b -1 'b)))))
(setf cat:*cmbn-control* t)
(signals simple-error (cat:do-control #'cat:s-cmpr
(cat:cmbn 0 1 'a 1 'b -1 'b))))
(setf cat:*cmbn-control* nil)
(is (not (null (cat:do-control #'cat:s-cmpr
(cat:cmbn 0 1 'a 1 'b -1 'b)))))
(setf cat:*cmbn-control* t)
(signals simple-error (cat:do-control #'cat:s-cmpr
(cat:cmbn 0 1 'a 1 'b -1 'b))))
(test gnrt-?
(progn
(cat:cat-init)
(let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr
:basis :locally-effective
:bsgn 0
:intr-dffr #'(lambda (cmbn)
(cat:cmbn
(1- (cat:cmbn-degr cmbn))))
:strt :cmbn
:orgn '(Z of Z)))
(ff (cat:build-mrph :sorc cc :trgt cc :degr 0
:intr #'(lambda (degr n)
(cat:cmbn degr 1 n))
:strt :gnrt :orgn '(test))))
(setf cat:+too-much-time+ -1)
(dotimes (i 20)
(let* ((n (- (random 50) 50))
(comb (cat:gnrt-? ff 0 n)))
(is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) (cons (cons 1 n) nil))))))))
(progn
(cat:cat-init)
(let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr
:basis :locally-effective
:bsgn 0
:intr-dffr #'(lambda (cmbn)
(cat:cmbn
(1- (cat:cmbn-degr cmbn))))
:strt :cmbn
:orgn '(Z of Z)))
(ff (cat:build-mrph :sorc cc :trgt cc :degr 0
:intr #'(lambda (degr n)
(cat:cmbn degr 1 n))
:strt :gnrt :orgn '(test))))
(setf cat:+too-much-time+ -1)
(dotimes (i 20)
(let* ((n (- (random 50) 50))
(comb (cat:gnrt-? ff 0 n)))
(is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) (cons (cons 1 n) nil))))))))
(setf *n* 10)
(test cmbn-?
(progn
(compile 'ff)
(cat:cat-init)
(let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr
:basis :locally-effective
:bsgn 0
:intr-dffr #'(lambda (cmbn)
(cat:cmbn
(1- (cat:cmbn-degr cmbn))))
:strt :cmbn
:orgn '(Z of Z)))
(mrph (cat:build-mrph :sorc cc :trgt cc :degr 0
:intr #'ff :strt :gnrt :orgn '(test))))
(progn
(compile 'ff)
(cat:cat-init)
(let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr
:basis :locally-effective
:bsgn 0
:intr-dffr #'(lambda (cmbn)
(cat:cmbn
(1- (cat:cmbn-degr cmbn))))
:strt :cmbn
:orgn '(Z of Z)))
(mrph (cat:build-mrph :sorc cc :trgt cc :degr 0
:intr #'ff :strt :gnrt :orgn '(test))))
(let ((comb (cat:cmbn-? mrph (cat:cmbn 0 1 100))))
(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))))))
(let ((comb (cat:cmbn-? mrph (cat:cmbn 0 1 100))))
(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))))))

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)
@ -5,170 +6,170 @@
(test zero-mrph
(progn
(cat:cat-init)
(let* ((z (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))
(comb (cat:gnrt-? z 0 :z-gnrt))
(comb1 (cat:cmbn-? z (cat:cmbn 3)))
(comb2 (cat:gnrt-? z3 0 :z-gnrt)))
(is (equal (cat:cmbn-degr comb) 2))
(is (equal (cat:cmbn-list comb) nil))
(is (equal (cat:cmbn-degr comb1) 5))
(is (equal (cat:cmbn-list comb1) nil))
(is (eq z z2))
(is (equal (cat:cmbn-degr comb2) 3))
(is (equal (cat:cmbn-list comb2) nil))
(is (not (eq z z3))))))
(cat:cat-init)
(let* ((z (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))
(comb (cat:gnrt-? z 0 :z-gnrt))
(comb1 (cat:cmbn-? z (cat:cmbn 3)))
(comb2 (cat:gnrt-? z3 0 :z-gnrt)))
(is (equal (cat:cmbn-degr comb) 2))
(is (equal (cat:cmbn-list comb) nil))
(is (equal (cat:cmbn-degr comb1) 5))
(is (equal (cat:cmbn-list comb1) nil))
(is (eq z z2))
(is (equal (cat:cmbn-degr comb2) 3))
(is (equal (cat:cmbn-list comb2) nil))
(is (not (eq z z3))))))
(test idnt-mrph
(progn
(cat:cat-init)
(let* ((zi (cat:idnt-mrph (cat:Z-chcm)))
(comb (cat:gnrt-? zi 0 :z-gnrt))
(zi2 (cat:idnt-mrph (cat:Z-chcm))))
(is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) (cons (cons 1 :z-gnrt) nil)))
(is (eq zi zi2)))))
(cat:cat-init)
(let* ((zi (cat:idnt-mrph (cat:Z-chcm)))
(comb (cat:gnrt-? zi 0 :z-gnrt))
(zi2 (cat:idnt-mrph (cat:Z-chcm))))
(is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) (cons (cons 1 :z-gnrt) nil)))
(is (eq zi zi2)))))
(test opps
(progn
(cat:cat-init)
(let* ((-zi (cat:opps (cat:idnt-mrph (cat:Z-chcm))))
(comb (cat:gnrt-? -zi 0 :z-gnrt))
(-zi2 (cat:opps (cat:idnt-mrph (cat:Z-chcm)))))
(is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) (cons (cons -1 :z-gnrt) nil)))
(is (eq -zi -zi2)))))
(cat:cat-init)
(let* ((-zi (cat:opps (cat:idnt-mrph (cat:Z-chcm))))
(comb (cat:gnrt-? -zi 0 :z-gnrt))
(-zi2 (cat:opps (cat:idnt-mrph (cat:Z-chcm)))))
(is (equal (cat:cmbn-degr comb) 0))
(is (equal (cat:cmbn-list comb) (cons (cons -1 :z-gnrt) nil)))
(is (eq -zi -zi2)))))
(setf *n* 5)
(test cmps
(progn
(cat:cat-init)
(let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr
:basis :locally-effective
:bsgn 0
:intr-dffr #'(lambda (cmbn)
(cat:cmbn
(1- (cat:cmbn-degr cmbn))))
:strt :cmbn
:orgn '(Z of Z)))
(mrph (cat:build-mrph :sorc cc :trgt cc :degr 0
:intr #'ff :strt :gnrt :orgn '(test)))
(mrph2 (cat:cmps mrph mrph :gnrt))
(comb (cat:gnrt-? mrph2 0 0))
(mrph3 (cat:cmps mrph mrph :cmbn))
(cat:cat-init)
(let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr
:basis :locally-effective
:bsgn 0
:intr-dffr #'(lambda (cmbn)
(cat:cmbn
(1- (cat:cmbn-degr cmbn))))
:strt :cmbn
:orgn '(Z of Z)))
(mrph (cat:build-mrph :sorc cc :trgt cc :degr 0
:intr #'ff :strt :gnrt :orgn '(test)))
(mrph2 (cat:cmps mrph mrph :gnrt))
(comb (cat:gnrt-? mrph2 0 0))
(mrph3 (cat:cmps mrph mrph :cmbn))
(comb1 (cat:gnrt-? mrph3 0 0))
(mrph33 (cat:cmps mrph mrph :cmbn)))
(dotimes (i 5)
(setq comb (cat:gnrt-? mrph2 0 i))
(is (equal (cat:cmbn-degr comb) 0)))
(dotimes (i 5)
(setq comb1 (cat:gnrt-? mrph3 0 i))
(is (equal (cat:cmbn-degr comb1) 0)))
(is (eq mrph3 mrph33)))))
(mrph33 (cat:cmps mrph mrph :cmbn)))
(dotimes (i 5)
(setq comb (cat:gnrt-? mrph2 0 i))
(is (equal (cat:cmbn-degr comb) 0)))
(dotimes (i 5)
(setq comb1 (cat:gnrt-? mrph3 0 i))
(is (equal (cat:cmbn-degr comb1) 0)))
(is (eq mrph3 mrph33)))))
#|
(setf s3 (sphere 3))
(setf ch3 (chml-clss s3 3))
(setf 2ch3 (n-mrph 2 ch3))
(setf f3 (z-whitehead s3 2ch3))
(setf x (fibration-total f3))
(homology x 0 10)
(setf k (k-z 3))
(setf ch3 (chml-clss k 3))
(setf 2ch3 (n-mrph 2 ch3))
(setf f3 (z-whitehead k 2ch3))
(setf x (fibration-total f3))
(homology x 0 10)
(setf s3 (sphere 3))
(setf ch3 (chml-clss s3 3))
(setf 2ch3 (n-mrph 2 ch3))
(setf f3 (z-whitehead s3 2ch3))
(setf x (fibration-total f3))
(homology x 0 10)
(setf k (k-z 3))
(setf ch3 (chml-clss k 3))
(setf 2ch3 (n-mrph 2 ch3))
(setf f3 (z-whitehead k 2ch3))
(setf x (fibration-total f3))
(homology x 0 10)
|#
(test n-mrph
(progn
(cat:cat-init)
(let* ((s3 (cat:sphere 3))
(ch3 (cat:chml-clss s3 3))
(2ch3 (cat:n-mrph 2 ch3))
;; (f3 (cat:z-whitehead s3 2ch3))
;; (x (cat:fibration-total f3))
(k (cat:k-z 3)))
;; (cat:homology x 0 10)
;; (setf ch3 (cat:chml-clss k 3))
;; (setf 2ch3 (cat:n-mrph 2 ch3))
;; (setf f3 (cat:z-whitehead k 2ch3))
;; (setf x (cat:fibration-total f3))
;; (cat:homology x 0 10)
)))
(cat:cat-init)
(let* ((s3 (cat:sphere 3))
(ch3 (cat:chml-clss s3 3))
(2ch3 (cat:n-mrph 2 ch3))
;; (f3 (cat:z-whitehead s3 2ch3))
;; (x (cat:fibration-total f3))
(k (cat:k-z 3)))
;; (cat:homology x 0 10)
;; (setf ch3 (cat:chml-clss k 3))
;; (setf 2ch3 (cat:n-mrph 2 ch3))
;; (setf f3 (cat:z-whitehead k 2ch3))
;; (setf x (cat:fibration-total f3))
;; (cat:homology x 0 10)
)))
(setf *n* 10)
(setf cat:+too-much-time+ -1)
(test add
(progn
(cat:cat-init)
(let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr
:basis :locally-effective
:bsgn 0
:intr-dffr #'(lambda (cmbn)
(cat:cmbn
(1- (cat:cmbn-degr cmbn))))
:strt :cmbn
:orgn '(Z of Z)))
(mrph1 (cat:build-mrph :sorc cc :trgt cc :degr 0
:intr #'ff :strt :gnrt :orgn '(test)))
(mrph2 (cat:build-mrph :sorc cc :trgt cc :degr 0
:intr #'ff :strt :gnrt :orgn '(test2)))
(mrph3 (cat:add mrph1 mrph2 :gnrt))
(cat:cat-init)
(let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr
:basis :locally-effective
:bsgn 0
:intr-dffr #'(lambda (cmbn)
(cat:cmbn
(1- (cat:cmbn-degr cmbn))))
:strt :cmbn
:orgn '(Z of Z)))
(mrph1 (cat:build-mrph :sorc cc :trgt cc :degr 0
:intr #'ff :strt :gnrt :orgn '(test)))
(mrph2 (cat:build-mrph :sorc cc :trgt cc :degr 0
:intr #'ff :strt :gnrt :orgn '(test2)))
(mrph3 (cat:add mrph1 mrph2 :gnrt))
(comb1 (cat:gnrt-? mrph1 0 0))
(comb2 (cat:gnrt-? mrph2 0 0))
(comb3 (cat:gnrt-? mrph3 0 0))
(mrph4 (cat:add mrph1 mrph2 :cmbn))
(comb4 (cat:gnrt-? mrph4 0 0))
(mrph44 (cat:add mrph1 mrph2 :cmbn)))
(is (equal (cat:cmbn-degr comb1) 0))
(is (equal (length (cat:cmbn-list comb1)) 10))
(is (equal (cat:cmbn-degr comb2) 0))
(is (equal (length (cat:cmbn-list comb2)) 10))
(is (equal (cat:cmbn-degr comb3) 0))
(is (<= (length (cat:cmbn-list comb3)) 20))
(is (equal (cat:cmbn-degr comb4) 0))
(is (<= (length (cat:cmbn-list comb4)) 20))
(is (eq mrph4 mrph44)))))
(comb1 (cat:gnrt-? mrph1 0 0))
(comb2 (cat:gnrt-? mrph2 0 0))
(comb3 (cat:gnrt-? mrph3 0 0))
(mrph4 (cat:add mrph1 mrph2 :cmbn))
(comb4 (cat:gnrt-? mrph4 0 0))
(mrph44 (cat:add mrph1 mrph2 :cmbn)))
(is (equal (cat:cmbn-degr comb1) 0))
(is (equal (length (cat:cmbn-list comb1)) 10))
(is (equal (cat:cmbn-degr comb2) 0))
(is (equal (length (cat:cmbn-list comb2)) 10))
(is (equal (cat:cmbn-degr comb3) 0))
(is (<= (length (cat:cmbn-list comb3)) 20))
(is (equal (cat:cmbn-degr comb4) 0))
(is (<= (length (cat:cmbn-list comb4)) 20))
(is (eq mrph4 mrph44)))))
(test sbtr
(progn
(cat:cat-init)
(let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr
:basis :locally-effective
:bsgn 0
:intr-dffr #'(lambda (cmbn)
(cat:cmbn
(1- (cat:cmbn-degr cmbn))))
:strt :cmbn
:orgn '(Z of Z)))
(mrph1 (cat:build-mrph :sorc cc :trgt cc :degr 0
:intr #'ff :strt :gnrt :orgn '(test)))
(mrph2 (cat:build-mrph :sorc cc :trgt cc :degr 0
:intr #'ff :strt :gnrt :orgn '(test2)))
(mrph3 (cat:sbtr mrph1 mrph2 :gnrt))
(comb1 (cat:gnrt-? mrph1 0 0))
(comb2 (cat:gnrt-? mrph2 0 0))
(comb3 (cat:gnrt-? mrph3 0 0))
(mrph4 (cat:sbtr mrph1 mrph2 :cmbn))
(comb4 (cat:gnrt-? mrph4 0 0))
(mrph44 (cat:sbtr mrph1 mrph2 :cmbn)))
(is (equal (cat:cmbn-degr comb1) 0))
(is (equal (length (cat:cmbn-list comb1)) 10))
(is (equal (cat:cmbn-degr comb2) 0))
(is (equal (length (cat:cmbn-list comb2)) 10))
(is (equal (cat:cmbn-degr comb3) 0))
(is (<= (length (cat:cmbn-list comb3)) 20))
(is (equal (cat:cmbn-degr comb4) 0))
(is (<= (length (cat:cmbn-list comb4)) 20))
(is (eq mrph4 mrph44)))))
(cat:cat-init)
(let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr
:basis :locally-effective
:bsgn 0
:intr-dffr #'(lambda (cmbn)
(cat:cmbn
(1- (cat:cmbn-degr cmbn))))
:strt :cmbn
:orgn '(Z of Z)))
(mrph1 (cat:build-mrph :sorc cc :trgt cc :degr 0
:intr #'ff :strt :gnrt :orgn '(test)))
(mrph2 (cat:build-mrph :sorc cc :trgt cc :degr 0
:intr #'ff :strt :gnrt :orgn '(test2)))
(mrph3 (cat:sbtr mrph1 mrph2 :gnrt))
(comb1 (cat:gnrt-? mrph1 0 0))
(comb2 (cat:gnrt-? mrph2 0 0))
(comb3 (cat:gnrt-? mrph3 0 0))
(mrph4 (cat:sbtr mrph1 mrph2 :cmbn))
(comb4 (cat:gnrt-? mrph4 0 0))
(mrph44 (cat:sbtr mrph1 mrph2 :cmbn)))
(is (equal (cat:cmbn-degr comb1) 0))
(is (equal (length (cat:cmbn-list comb1)) 10))
(is (equal (cat:cmbn-degr comb2) 0))
(is (equal (length (cat:cmbn-list comb2)) 10))
(is (equal (cat:cmbn-degr comb3) 0))
(is (<= (length (cat:cmbn-list comb3)) 20))
(is (equal (cat:cmbn-degr comb4) 0))
(is (<= (length (cat:cmbn-list comb4)) 20))
(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)
@ -7,6 +8,6 @@
(test circle
(cat:cat-init)
(let ((circle (cat:circle)))
(is (equal (cat:basis circle 0) '(*)))
(is (equal (cat:basis circle 1) '(cat::s1)))
(is (equal (cat:basis circle 2) cat:+empty-list+))))
(is (equal (cat:basis circle 0) '(*)))
(is (equal (cat:basis circle 1) '(cat::s1)))
(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-suite :kenzo)
@ -358,9 +360,9 @@
(let* ((h (cat:cs-left-hmeq (cat:k-z-1)))
(abar (cat:abar 2 '(2) 3 '(3 4))))
(cat:rf h
(cat:lg h
(cat:lf h
(cat:rg h 5 abar))))))
(cat:lg h
(cat:lf h
(cat:rg h 5 abar))))))
(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)
@ -10,59 +11,59 @@
(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 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: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: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: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: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: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: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: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: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:absm 1 'i) (cat:absm 0 'i))))
(cat:absm 1 'i) (cat:absm 0 'i))))
(test unnormalize-gbar
(cat:unnormalize-gbar (cat:absm 1 cat:+null-gbar+) 'i)
(cat:unnormalize-gbar (cat:absm 15 cat:+null-gbar+) 'i)
(cat:normalize-gbar (cat:unnormalize-gbar
(cat:absm 15 cat:+null-gbar+) 'i))
(cat:absm 15 cat:+null-gbar+) 'i))
(cat:unnormalize-gbar
(cat:absm 0 (cat:make-gbar :dmns 4
:list (list (cat:absm 0 'a) (cat:absm 0 'b)
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i)
:list (list (cat:absm 0 'a) (cat:absm 0 'b)
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i)
(cat:normalize-gbar
(cat:unnormalize-gbar
(cat:absm 0 (cat:make-gbar :dmns 4
:list (list (cat:absm 0 'a) (cat:absm 0 'b)
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i))
(cat:absm 0 (cat:make-gbar :dmns 4
:list (list (cat:absm 0 'a) (cat:absm 0 'b)
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i))
(cat:unnormalize-gbar
(cat:absm 5 (cat:make-gbar :dmns 4
:list (list (cat:absm 0 'a) (cat:absm 0 'b)
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i)
:list (list (cat:absm 0 'a) (cat:absm 0 'b)
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i)
(cat:normalize-gbar
(cat:unnormalize-gbar
(cat:absm 5 (cat:make-gbar :dmns 4
:list (list (cat:absm 0 'a) (cat:absm 0 'b)
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i))
(cat:absm 5 (cat:make-gbar :dmns 4
:list (list (cat:absm 0 'a) (cat:absm 0 'b)
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i))
(cat:unnormalize-gbar
(cat:absm 9 (cat:make-gbar :dmns 4
:list (list (cat:absm 0 'a) (cat:absm 0 'b)
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i)
:list (list (cat:absm 0 'a) (cat:absm 0 'b)
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i)
(cat:normalize-gbar
(cat:unnormalize-gbar
(cat:absm 9 (cat:make-gbar :dmns 4
:list (list (cat:absm 0 'a) (cat:absm 0 'b)
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i)))
(cat:absm 9 (cat:make-gbar :dmns 4
:list (list (cat:absm 0 'a) (cat:absm 0 'b)
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i)))
(test gbar
@ -73,75 +74,75 @@
(test classifying-space-cmpr
(let ((cmpr (cat:classifying-space-cmpr #'cat:s-cmpr)))
(is (equal :less (funcall cmpr
(cat:gbar 2 0 'a 0 'a)
(cat:gbar 2 1 'a 0 'a))))
(is (equal :less (funcall cmpr
(cat:gbar 2 0 'a 0 'a)
(cat:gbar 2 0 'b 0 'a))))
(is (equal :equal (funcall cmpr
(cat:gbar 2 0 'a 0 'a)
(cat:gbar 2 0 'a 0 'a))))))
(is (equal :less (funcall cmpr
(cat:gbar 2 0 'a 0 'a)
(cat:gbar 2 1 'a 0 'a))))
(is (equal :less (funcall cmpr
(cat:gbar 2 0 'a 0 'a)
(cat:gbar 2 0 'b 0 'a))))
(is (equal :equal (funcall cmpr
(cat:gbar 2 0 'a 0 'a)
(cat:gbar 2 0 'a 0 'a))))))
(test classifying-space-basis
(cat:cat-init)
(let* ((k (cat:k-z2-1))
(b (cat:classifying-space-basis (cat:basis k))))
(funcall b 0)
(funcall b 1)
(dotimes (i 5) (print (funcall b i)))))
(b (cat:classifying-space-basis (cat:basis k))))
(funcall b 0)
(funcall b 1)
(dotimes (i 5) (print (funcall b i)))))
(test classifying-space-face
(let* ((om (cat:loop-space (cat:moore 2 2)))
(face (cat:classifying-space-face (cat:face om)
(cat:sintr (cat:grml om))))
(gbar (cat:gbar 4 0 (cat:loop3 3 'm2 1 4 'n3 1)
0 (cat:loop3 0 'n3 1)
0 (cat:loop3 0 'm2 1)
0 cat:+null-loop+)))
(dotimes (i 5)
(print (funcall face i 4 gbar)))))
(face (cat:classifying-space-face (cat:face om)
(cat:sintr (cat:grml om))))
(gbar (cat:gbar 4 0 (cat:loop3 3 'm2 1 4 'n3 1)
0 (cat:loop3 0 'n3 1)
0 (cat:loop3 0 'm2 1)
0 cat:+null-loop+)))
(dotimes (i 5)
(print (funcall face i 4 gbar)))))
(test classifying-space
(cat:cat-init)
(let ((c (cat:classifying-space (cat:k-z2-1))))
(cat:orgn c)
(first (cat:basis c 4))
(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)))
(dotimes (i 5)
(print (cat:face c i 4 (first (cat:basis c 4)))))))
(cat:orgn c)
(first (cat:basis c 4))
(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)))
(dotimes (i 5)
(print (cat:face c i 4 (first (cat:basis c 4)))))))
(test classifying-space-grml-sintr
(let ((grml (cat:classifying-space-grml-sintr
'() (cat:sintr (cat:grml (cat:k-z-1))))))
(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 '())))
(funcall grml 3 (cat:crpr 0 (cat:gbar 3 0 '(1 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 '())
1 (cat:gbar 2 0 '(-3) 0 '())))))
'() (cat:sintr (cat:grml (cat:k-z-1))))))
(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 '())))
(funcall grml 3 (cat:crpr 0 (cat:gbar 3 0 '(1 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 '())
1 (cat:gbar 2 0 '(-3) 0 '())))))
(test classifying-space-grin-sintr
(let ((grin (cat:classifying-space-grin-sintr
(cat:sintr (cat:grin (cat:k-z-1))))))
(funcall grin 3 (cat:gbar 3 0 '(1 2) 1 '() 0 '()))))
(cat:sintr (cat:grin (cat:k-z-1))))))
(funcall grin 3 (cat:gbar 3 0 '(1 2) 1 '() 0 '()))))
(test classifying-space1
(cat:cat-init)
(let* ((k-z-1 (cat:k-z-1))
(k-z-2 (cat:classifying-space k-z-1))
(k-z-3 (cat:classifying-space k-z-2))
(k-z2-1 (cat:k-z2-1))
(k-z2-2 (cat:classifying-space k-z2-1))
(k-z2-3 (cat:classifying-space k-z2-2))
(k-z2-4 (cat:classifying-space k-z2-3))
(k-z2-5 (cat:classifying-space k-z2-4)))
(cat:homology k-z-3 0 10)
(cat:homology k-z2-5 0 7)))
(k-z-2 (cat:classifying-space k-z-1))
(k-z-3 (cat:classifying-space k-z-2))
(k-z2-1 (cat:k-z2-1))
(k-z2-2 (cat:classifying-space k-z2-1))
(k-z2-3 (cat:classifying-space k-z2-2))
(k-z2-4 (cat:classifying-space k-z2-3))
(k-z2-5 (cat:classifying-space k-z2-4)))
(cat:homology k-z-3 0 10)
(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)
@ -12,94 +13,94 @@
(test cobar-cmpr
(let ((r (cat:cobar-cmpr #'cat:s-cmpr)))
(is (equal :equal (funcall r (cat:allp) (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 3 'b))))
(is (equal :equal (funcall r (cat:allp 3 'a) (cat:allp 3 'a))))))
(is (equal :equal (funcall r (cat:allp) (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 3 'b))))
(is (equal :equal (funcall r (cat:allp 3 'a) (cat:allp 3 'a))))))
(test cobar-basis-length
(let ((basis #'(lambda (degr) (list degr))))
(cat:cobar-basis-length basis 1 1)
(cat:cobar-basis-length basis 2 1)
(cat:cobar-basis-length basis 2 2)
(cat:cobar-basis-length basis 3 1)
(cat:cobar-basis-length basis 3 2)
(cat:cobar-basis-length basis 3 3)))
(cat:cobar-basis-length basis 1 1)
(cat:cobar-basis-length basis 2 1)
(cat:cobar-basis-length basis 2 2)
(cat:cobar-basis-length basis 3 1)
(cat:cobar-basis-length basis 3 2)
(cat:cobar-basis-length basis 3 3)))
(test cobar-basis
(let* ((basis #'(lambda (degr) (list degr)))
(r (cat:cobar-basis basis)))
(funcall r 0)
(funcall r 1)
(funcall r 2)
(dotimes (i 7)
(print (funcall r i)))
(cat:cobar-basis :locally-effective)))
(r (cat:cobar-basis basis)))
(funcall r 0)
(funcall r 1)
(funcall r 2)
(dotimes (i 7)
(print (funcall r i)))
(cat:cobar-basis :locally-effective)))
(test cobar-intr-vrtc-dffr
(let* ((d (cat:soft-delta-infinity))
(r (cat:cobar-intr-vrtc-dffr (cat:dffr d))))
(funcall r 0 (cat:allp))
(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 2 (cat:d (cat:mask 4))
3 (cat:d (cat:mask 5))))))
(r (cat:cobar-intr-vrtc-dffr (cat:dffr d))))
(funcall r 0 (cat:allp))
(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 2 (cat:d (cat:mask 4))
3 (cat:d (cat:mask 5))))))
(test vrtc-cobar
(cat:cat-init)
(let ((v (cat:vrtc-cobar (cat:soft-delta-infinity))))
(dotimes (i 10) (print (random-allp 5)))
(dotimes (i 10)
(let ((allp (random-allp 3)))
(print allp)
(print (cat:? v (apply #'+ (mapcar #'car (cat:allp-list allp)))
allp))
(print (cat:? v (cat:? v (apply #'+ (mapcar #'car
(cat:allp-list allp)))
allp)))))))
(dotimes (i 10) (print (random-allp 5)))
(dotimes (i 10)
(let ((allp (random-allp 3)))
(print allp)
(print (cat:? v (apply #'+ (mapcar #'car (cat:allp-list allp)))
allp))
(print (cat:? v (cat:? v (apply #'+ (mapcar #'car
(cat:allp-list allp)))
allp)))))))
(test cobar-intr-hrzn-dffr
(let* ((d (cat:soft-delta-infinity))
(r (cat:cobar-intr-hrzn-dffr (cat:cprd d))))
(funcall r 0 (cat:allp))
(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 2 (cat:d (cat:mask 4))
3 (cat:d (cat:mask 5))))))
(r (cat:cobar-intr-hrzn-dffr (cat:cprd d))))
(funcall r 0 (cat:allp))
(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 2 (cat:d (cat:mask 4))
3 (cat:d (cat:mask 5))))))
#|
(test cobar-hrzn-dffr
(cat:cat-init)
(let ((h (cat:cobar-hrzn-dffr (cat:soft-delta-infinity)))
(allp (random-allp 4)))
(dotimes (i 10) (print (random-allp 5)))
(cat:? h (apply #'+ (mapcar #'car (cat:allp-list allp))) allp)
(cat:? h (cat:? h (apply #'+ (mapcar #'car (cat:allp-list allp)))
allp))
(dotimes (i 10)
(let ((allp (random-allp 3)))
(print allp)
(print (cat:? h (apply #'+ (mapcar #'car (cat:allp-list allp)))
allp))
(print (cat:? h (cat:? h (apply #'+ (mapcar #'car
(cat:allp-list allp)))
allp)))))))
(allp (random-allp 4)))
(dotimes (i 10) (print (random-allp 5)))
(cat:? h (apply #'+ (mapcar #'car (cat:allp-list allp))) allp)
(cat:? h (cat:? h (apply #'+ (mapcar #'car (cat:allp-list allp)))
allp))
(dotimes (i 10)
(let ((allp (random-allp 3)))
(print allp)
(print (cat:? h (apply #'+ (mapcar #'car (cat:allp-list allp)))
allp))
(print (cat:? h (cat:? h (apply #'+ (mapcar #'car
(cat:allp-list allp)))
allp)))))))
|#
(defun random-allp1 (length)
(let ((rslt nil))
(dotimes (i length)
(let* ((gmsm (random (cat:mask 9)))
(dmns (1- (logcount gmsm))))
(when (plusp dmns)
(push (cat:cbgn (1- dmns) gmsm) rslt))))
(dmns (1- (logcount gmsm))))
(when (plusp dmns)
(push (cat:cbgn (1- dmns) gmsm) rslt))))
(cat:make-allp :list rslt)))
@ -107,19 +108,19 @@
(test cobar
(cat:cat-init)
(let ((c (cat:cobar (cat:deltab)))
(allp (random-allp1 4)))
(dotimes (i 10) (print (random-allp1 5)))
(cat:? c (apply #'+ (mapcar #'car (cat:allp-list allp))) allp)
(cat:? c (cat:? c (apply #'+ (mapcar #'car (cat:allp-list allp)))
allp))
(dotimes (i 10)
(let ((allp (random-allp1 3)))
(print allp)
(print (cat:? c (apply #'+ (mapcar #'car (cat:allp-list allp)))
allp))
(print (cat:? c (cat:? c (apply #'+ (mapcar #'car
(cat:allp-list allp)))
allp)))))))
(allp (random-allp1 4)))
(dotimes (i 10) (print (random-allp1 5)))
(cat:? c (apply #'+ (mapcar #'car (cat:allp-list allp))) allp)
(cat:? c (cat:? c (apply #'+ (mapcar #'car (cat:allp-list allp)))
allp))
(dotimes (i 10)
(let ((allp (random-allp1 3)))
(print allp)
(print (cat:? c (apply #'+ (mapcar #'car (cat:allp-list allp)))
allp))
(print (cat:? c (cat:? c (apply #'+ (mapcar #'car
(cat:allp-list allp)))
allp)))))))
|#
(test ncmbn-cobar
@ -127,131 +128,131 @@
(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 1 4 'c 5 'd)
(cat:cmbn 1 6 'e 7 'f))))
(cat:cmbn 1 6 'e 7 'f))))
(test mrph-vrtc-cobar-intr
(let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr :strt :cmbn))
(m (cat:build-mrph :sorc cc :trgt cc :degr 0 :intr
#'(lambda (degr gnrt)
(cat:cmbn degr 2 gnrt 3 (1+ gnrt)))
:strt :gnrt :orgn '(test)))
(r (cat:mrph-vrtc-cobar-intr m)))
(funcall r 4 (cat:allp 2 3 2 4))))
(m (cat:build-mrph :sorc cc :trgt cc :degr 0 :intr
#'(lambda (degr gnrt)
(cat:cmbn degr 2 gnrt 3 (1+ gnrt)))
:strt :gnrt :orgn '(test)))
(r (cat:mrph-vrtc-cobar-intr m)))
(funcall r 4 (cat:allp 2 3 2 4))))
(test vrtc-cobar
(cat:cat-init)
(let* ((f (cat:aw (cat:soft-delta-infinity) (cat:soft-delta-infinity)))
(cf (cat:vrtc-cobar f)))
(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))))))
(cf (cat:vrtc-cobar f)))
(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))))))
(test hmtp-vrtc-cobar-intr
(cat:cat-init)
(let* ((ez (cat:ez (cat:delta-infinity) (cat:delta-infinity)))
(h (cat:h ez))
(gf (cat:cmps (cat:g ez) (cat:f ez)))
(r (cat:hmtp-vrtc-cobar-intr h gf)))
(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)))))
(h (cat:h ez))
(gf (cat:cmps (cat:g ez) (cat:f ez)))
(r (cat:hmtp-vrtc-cobar-intr h gf)))
(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)))))
#|
(test rdct
(cat:cat-init)
(let* ((tcc (cat:build-chcm
:cmpr #'cat:s-cmpr
:basis #'(lambda (degr) '(a b c d))
:bsgn 'd
:intr-dffr #'(lambda (degr gnrt)
(ecase gnrt
(a (cat:cmbn (1- degr) 1 'b 1 'd))
((b d) (cat:cmbn (1- degr)))
(c (cat:cmbn (1- degr) 1 'd))))
:strt :gnrt
:orgn '(tcc)))
(bcc (cat:build-chcm
:cmpr #'cat:s-cmpr
:basis #'(lambda (degr) '(c d))
:bsgn 'd
:intr-dffr #'(lambda (degr gnrt)
(ecase gnrt
(d (cat:cmbn (1- degr)))
(c (cat:cmbn (1- degr) 1 'd))))
:strt :gnrt
:orgn '(bcc)))
(f (cat:build-mrph :sorc tcc :trgt bcc :degr 0
:intr #'(lambda (degr gnrt)
(ecase gnrt
(a (cat:cmbn degr 1 'c 1 'd))
(b (cat:cmbn degr))
((c d) (cat:cmbn degr 1 gnrt))))
:strt :gnrt :orgn '(f)))
(g (cat:build-mrph :sorc bcc :trgt tcc :degr 0
:intr #'identity :strt :cmbn :orgn '(g)))
(h (cat:build-mrph :sorc tcc :trgt tcc :degr +1
:intr #'(lambda (degr gnrt)
(ecase gnrt
((a b) (cat:cmbn (1+ degr) 1 'a
-1 'b -1 'c
-1 'd))
((c d) (cat:cmbn (1+ degr)))))
:strt :gnrt :orgn '(h)))
(rdct (cat:build-rdct :f f :g g :h h :orgn '(rdct)))
cobar)
(cat:tcc rdct 3 'a)
(cat:g rdct (cat:f rdct 3 'a))
(cat:h rdct 3 'a)
(setf cobar (cat:vrtc-cobar rdct))
(cat:pre-check-rdct cobar)
(aleat-tc)
;;(aleat-bc)
;;(loop (c))
;; degrees >= 15 is possible => error.
))
:cmpr #'cat:s-cmpr
:basis #'(lambda (degr) '(a b c d))
:bsgn 'd
:intr-dffr #'(lambda (degr gnrt)
(ecase gnrt
(a (cat:cmbn (1- degr) 1 'b 1 'd))
((b d) (cat:cmbn (1- degr)))
(c (cat:cmbn (1- degr) 1 'd))))
:strt :gnrt
:orgn '(tcc)))
(bcc (cat:build-chcm
:cmpr #'cat:s-cmpr
:basis #'(lambda (degr) '(c d))
:bsgn 'd
:intr-dffr #'(lambda (degr gnrt)
(ecase gnrt
(d (cat:cmbn (1- degr)))
(c (cat:cmbn (1- degr) 1 'd))))
:strt :gnrt
:orgn '(bcc)))
(f (cat:build-mrph :sorc tcc :trgt bcc :degr 0
:intr #'(lambda (degr gnrt)
(ecase gnrt
(a (cat:cmbn degr 1 'c 1 'd))
(b (cat:cmbn degr))
((c d) (cat:cmbn degr 1 gnrt))))
:strt :gnrt :orgn '(f)))
(g (cat:build-mrph :sorc bcc :trgt tcc :degr 0
:intr #'identity :strt :cmbn :orgn '(g)))
(h (cat:build-mrph :sorc tcc :trgt tcc :degr +1
:intr #'(lambda (degr gnrt)
(ecase gnrt
((a b) (cat:cmbn (1+ degr) 1 'a
-1 'b -1 'c
-1 'd))
((c d) (cat:cmbn (1+ degr)))))
:strt :gnrt :orgn '(h)))
(rdct (cat:build-rdct :f f :g g :h h :orgn '(rdct)))
cobar)
(cat:tcc rdct 3 'a)
(cat:g rdct (cat:f rdct 3 'a))
(cat:h rdct 3 'a)
(setf cobar (cat:vrtc-cobar rdct))
(cat:pre-check-rdct cobar)
(aleat-tc)
;;(aleat-bc)
;;(loop (c))
;; degrees >= 15 is possible => error.
))
|#
#|
(cat-init)
(setf tcc (build-chcm
:cmpr #'s-cmpr
:basis #'(lambda (degr) '(a b c d))
:bsgn 'd
:intr-dffr #'(lambda (degr gnrt)
(ecase gnrt
(a (cmbn (1- degr) 1 'b 1 'd))
((b d) (cmbn (1- degr)))
(c (cmbn (1- degr) 1 'd))))
:strt :gnrt
:orgn '(tcc)))
:cmpr #'s-cmpr
:basis #'(lambda (degr) '(a b c d))
:bsgn 'd
:intr-dffr #'(lambda (degr gnrt)
(ecase gnrt
(a (cmbn (1- degr) 1 'b 1 'd))
((b d) (cmbn (1- degr)))
(c (cmbn (1- degr) 1 'd))))
:strt :gnrt
:orgn '(tcc)))
(setf bcc (build-chcm
:cmpr #'s-cmpr
:basis #'(lambda (degr) '(c d))
:bsgn 'd
:intr-dffr #'(lambda (degr gnrt)
(ecase gnrt
(d (cmbn (1- degr)))
(c (cmbn (1- degr) 1 'd))))
:strt :gnrt
:orgn '(bcc)))
:cmpr #'s-cmpr
:basis #'(lambda (degr) '(c d))
:bsgn 'd
:intr-dffr #'(lambda (degr gnrt)
(ecase gnrt
(d (cmbn (1- degr)))
(c (cmbn (1- degr) 1 'd))))
:strt :gnrt
:orgn '(bcc)))
(setf f (build-mrph :sorc tcc :trgt bcc :degr 0
:intr #'(lambda (degr gnrt)
(ecase gnrt
(a (cmbn degr 1 'c 1 'd))
(b (cmbn degr))
((c d) (cmbn degr 1 gnrt))))
:strt :gnrt :orgn '(f)))
:intr #'(lambda (degr gnrt)
(ecase gnrt
(a (cmbn degr 1 'c 1 'd))
(b (cmbn degr))
((c d) (cmbn degr 1 gnrt))))
:strt :gnrt :orgn '(f)))
(setf g (build-mrph :sorc bcc :trgt tcc :degr 0
:intr #'identity :strt :cmbn :orgn '(g)))
:intr #'identity :strt :cmbn :orgn '(g)))
(setf h (build-mrph :sorc tcc :trgt tcc :degr +1
:intr #'(lambda (degr gnrt)
(ecase gnrt
((a b) (cmbn (1+ degr) 1 'a -1 'b -1 'c -1 'd))
((c d) (cmbn (1+ degr)))))
:strt :gnrt :orgn '(h)))
:intr #'(lambda (degr gnrt)
(ecase gnrt
((a b) (cmbn (1+ degr) 1 'a -1 'b -1 'c -1 'd))
((c d) (cmbn (1+ degr)))))
:strt :gnrt :orgn '(h)))
(setf rdct (build-rdct :f f :g g :h h :orgn '(rdct)))
(tcc rdct 3 'a)
(g rdct (f rdct 3 'a))
@ -262,7 +263,7 @@
(do ((tdegr 0 (+ tdegr degr))
(degr (1+ (random 4)) (1+ (random 4)))
(gnrt (intern (coerce (vector (+ 65 (random 4))) 'string))
(intern (coerce (vector (+ 65 (random 4))) 'string)))
(intern (coerce (vector (+ 65 (random 4))) 'string)))
(rslt nil (cons (cbgn degr gnrt) rslt)))
((> tdegr 10) (setf *tc* (cmbn tdegr 1 (make-allp :list rslt))))))
(aleat-tc)
@ -270,7 +271,7 @@
(do ((tdegr 0 (+ tdegr degr))
(degr (1+ (random 4)) (1+ (random 4)))
(gnrt (intern (coerce (vector (+ 67 (random 2))) 'string))
(intern (coerce (vector (+ 67 (random 2))) 'string)))
(intern (coerce (vector (+ 67 (random 2))) 'string)))
(rslt nil (cons (cbgn degr gnrt) rslt)))
((> tdegr 10) (setf *bc* (cmbn tdegr 1 (make-allp :list rslt))))))
(aleat-bc)
@ -286,6 +287,6 @@
(test left-hmeq
(cat:cat-init)
(let* ((h (cat:left-hmeq (cat:sphere 3)))
(c (cat:cobar h)))
(inspect c)))
(c (cat:cobar h)))
(inspect c)))
|#

511
test/combinations-test.lisp
View File

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

33
test/common.lisp
View File

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

97
test/cones-test.lisp
View File

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

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

93
test/delta-test.lisp
View File

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

51
test/diabolo.lisp
View File

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

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

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

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

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

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

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

85
test/fibrations-test.lisp
View File

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

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

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

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

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

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

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

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

57
test/macros-test.lisp
View File

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

3
test/package.lisp
View File

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

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

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

177
test/serre-test.lisp
View File

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

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

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test)
@ -6,8 +7,8 @@
(test check-kan
(cat:cat-init)
(let* ((k (cat:k-z-1))
(rslt '(1 10 100))
(hat (mapcar #'(lambda (i) (cat:face k i 3 rslt))
(cat:<a-b> 0 3))))
(dotimes (i 4)
(cat:check-kan k i 3 (remove (nth i hat) hat :test #'equal)))))
(rslt '(1 10 100))
(hat (mapcar #'(lambda (i) (cat:face k i 3 rslt))
(cat:<a-b> 0 3))))
(dotimes (i 4)
(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)
@ -6,14 +7,14 @@
(test build-smmr
(let* ((d (cat:delta 3))
(m (cat:build-smmr
:sorc d :trgt d :degr 0
:sintr #'(lambda (dmns gmsm) (cat:absm 0 gmsm))
:orgn '(identity delta-3)))
(m2 (cat:build-smmr
:sorc d :trgt d :degr 0
:sintr #'(lambda (dmns gmsm) (cat:absm (cat:mask dmns) 1))
:orgn '(null delta-3))))
(cat:? m2 2 7)
;; (s? m2 2 7)
))
(m (cat:build-smmr
:sorc d :trgt d :degr 0
:sintr #'(lambda (dmns gmsm) (cat:absm 0 gmsm))
:orgn '(identity delta-3)))
(m2 (cat:build-smmr
:sorc d :trgt d :degr 0
:sintr #'(lambda (dmns gmsm) (cat:absm (cat:mask dmns) 1))
:orgn '(null delta-3))))
(cat:? m2 2 7)
;; (s? m2 2 7)
))

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

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

447
test/smith-test.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test)
@ -13,189 +14,189 @@
(test copy-mtrx
(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
(let ((m (cat:random-matrix 3 4 10)))
(cat:left-submatrix m 2)))
(cat:left-submatrix m 2)))
(test mtrx-prdc
(let ((m1 (cat:random-matrix 2 3 10))
(m2 (cat:random-matrix 3 2 10)))
(cat:mtrx-prdc m1 m2)
(cat:mtrx-prdc m2 m1)))
(m2 (cat:random-matrix 3 2 10)))
(cat:mtrx-prdc m1 m2)
(cat:mtrx-prdc m2 m1)))
(test chcm-mtrx
(cat:cat-init)
(let ((d (cat:delta 5))
(m (cat:moore 2 2)))
(cat:chcm-mtrx d 3)
(dotimes (i 5)
(print (cat:chcm-mtrx m i)))
(dotimes (i 6)
(print (array-dimensions (cat:chcm-mtrx m i))))))
(m (cat:moore 2 2)))
(cat:chcm-mtrx d 3)
(dotimes (i 5)
(print (cat:chcm-mtrx m i)))
(dotimes (i 6)
(print (array-dimensions (cat:chcm-mtrx m i))))))
(test line-op
(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)
(test line-op-5
(let* ((p (cat:idnt-mtrx 4))
(p-1 (cat:idnt-mtrx 4))
(m (cat:random-matrix 4 5 10))
(q (cat:idnt-mtrx 5) )
(q-1 (cat:idnt-mtrx 5))
(list (list p p-1 m q q-1))
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:line-op-5 list 0 3 1 3)
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:mtrx-prdc p p-1)))
(p-1 (cat:idnt-mtrx 4))
(m (cat:random-matrix 4 5 10))
(q (cat:idnt-mtrx 5) )
(q-1 (cat:idnt-mtrx 5))
(list (list p p-1 m q q-1))
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:line-op-5 list 0 3 1 3)
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:mtrx-prdc p p-1)))
(test column-op
(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
(let* ((p (cat:idnt-mtrx 4))
(p-1 (cat:idnt-mtrx 4))
(m (cat:random-matrix 4 5 10))
(q (cat:idnt-mtrx 5))
(q-1 (cat:idnt-mtrx 5))
(list (list p p-1 m q q-1))
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:column-op-5 list 0 3 1 3)
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:mtrx-prdc p p-1)
(cat:mtrx-prdc q q-1)))
(p-1 (cat:idnt-mtrx 4))
(m (cat:random-matrix 4 5 10))
(q (cat:idnt-mtrx 5))
(q-1 (cat:idnt-mtrx 5))
(list (list p p-1 m q q-1))
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:column-op-5 list 0 3 1 3)
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:mtrx-prdc p p-1)
(cat:mtrx-prdc q q-1)))
(test line-swap
(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
(let* ((p (cat:idnt-mtrx 4))
(p-1 (cat:idnt-mtrx 4))
(m (cat:random-matrix 4 5 10))
(q (cat:idnt-mtrx 5))
(q-1 (cat:idnt-mtrx 5))
(list (list p p-1 m q q-1))
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:line-swap-5 list 0 1 3)
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:mtrx-prdc p p-1)
(cat:mtrx-prdc q q-1)))
(p-1 (cat:idnt-mtrx 4))
(m (cat:random-matrix 4 5 10))
(q (cat:idnt-mtrx 5))
(q-1 (cat:idnt-mtrx 5))
(list (list p p-1 m q q-1))
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:line-swap-5 list 0 1 3)
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:mtrx-prdc p p-1)
(cat:mtrx-prdc q q-1)))
(test column-swap
(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
(let* ((p (cat:idnt-mtrx 4))
(p-1 (cat:idnt-mtrx 4))
(m (cat:random-matrix 4 5 10))
(q (cat:idnt-mtrx 5))
(q-1 (cat:idnt-mtrx 5))
(list (list p p-1 m q q-1))
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:column-swap-5 list 0 1 3)
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:mtrx-prdc p p-1)
(cat:mtrx-prdc q q-1)))
(p-1 (cat:idnt-mtrx 4))
(m (cat:random-matrix 4 5 10))
(q (cat:idnt-mtrx 5))
(q-1 (cat:idnt-mtrx 5))
(list (list p p-1 m q q-1))
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:column-swap-5 list 0 1 3)
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:mtrx-prdc p p-1)
(cat:mtrx-prdc q q-1)))
(test column-minus
(let ((m (cat:random-matrix 3 4 10)))
(cat:line-minus m 1 2)
(cat:column-minus m 1 2)))
(cat:line-minus m 1 2)
(cat:column-minus m 1 2)))
(test column-minus-5
(let* ((p (cat:idnt-mtrx 4))
(p-1 (cat:idnt-mtrx 4))
(m (cat:random-matrix 4 5 10))
(q (cat:idnt-mtrx 5))
(q-1 (cat:idnt-mtrx 5))
(list (list p p-1 m q q-1))
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:line-minus-5 list 0 3)
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:mtrx-prdc p p-1)
(cat:mtrx-prdc q q-1)
(cat:column-minus-5 list 0 2)
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:mtrx-prdc p p-1)
(cat:mtrx-prdc q q-1)))
(p-1 (cat:idnt-mtrx 4))
(m (cat:random-matrix 4 5 10))
(q (cat:idnt-mtrx 5))
(q-1 (cat:idnt-mtrx 5))
(list (list p p-1 m q q-1))
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:line-minus-5 list 0 3)
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:mtrx-prdc p p-1)
(cat:mtrx-prdc q q-1)
(cat:column-minus-5 list 0 2)
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:mtrx-prdc p p-1)
(cat:mtrx-prdc q q-1)))
(test minimal-term
(let ((m (cat:random-matrix 4 5 10)))
(cat:minimal-term m 1)))
(cat:minimal-term m 1)))
#|
;; potential divide by 0
(test minimal-rest-1
(let ((m (cat:random-matrix 4 5 10)))
(cat:minimal-rest-1 m 1)))
(cat:minimal-rest-1 m 1)))
(test minimal-rest-2
(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
(let* ((p (cat:idnt-mtrx 4))
(p-1 (cat:idnt-mtrx 4))
(m (cat:random-matrix 4 5 10))
(q (cat:idnt-mtrx 5))
(q-1 (cat:idnt-mtrx 5))
(list (list p p-1 m q q-1))
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:minimal-term-top-left list 0 1 3)
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:mtrx-prdc p p-1)
(cat:mtrx-prdc q q-1)))
(p-1 (cat:idnt-mtrx 4))
(m (cat:random-matrix 4 5 10))
(q (cat:idnt-mtrx 5))
(q-1 (cat:idnt-mtrx 5))
(list (list p p-1 m q q-1))
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:minimal-term-top-left list 0 1 3)
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:mtrx-prdc p p-1)
(cat:mtrx-prdc q q-1)))
(test minimal-term-top-left1
(let* ((p (cat:idnt-mtrx 4))
(p-1 (cat:idnt-mtrx 4))
(m (cat:random-matrix 4 5 10))
(q (cat:idnt-mtrx 5))
(q-1 (cat:idnt-mtrx 5))
(list (list p p-1 m q q-1))
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:pivott list 0)
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:mtrx-prdc p p-1)
(cat:mtrx-prdc q q-1)))
(p-1 (cat:idnt-mtrx 4))
(m (cat:random-matrix 4 5 10))
(q (cat:idnt-mtrx 5))
(q-1 (cat:idnt-mtrx 5))
(list (list p p-1 m q q-1))
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:pivott list 0)
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:mtrx-prdc p p-1)
(cat:mtrx-prdc q q-1)))
(test list-smith
(let* ((p (cat:idnt-mtrx 4))
(p-1 (cat:idnt-mtrx 4))
(m (cat:random-matrix 4 5 10))
(q (cat:idnt-mtrx 5))
(q-1 (cat:idnt-mtrx 5))
(list (list p p-1 m q q-1))
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(third (cat:list-smith list))
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:mtrx-prdc p p-1)
(cat:mtrx-prdc q q-1)))
(p-1 (cat:idnt-mtrx 4))
(m (cat:random-matrix 4 5 10))
(q (cat:idnt-mtrx 5))
(q-1 (cat:idnt-mtrx 5))
(list (list p p-1 m q q-1))
(t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(third (cat:list-smith list))
(is (equalp t1 (cat:mtrx-prdc p (cat:mtrx-prdc m q-1))))
(cat:mtrx-prdc p p-1)
(cat:mtrx-prdc q q-1)))
(test gnrt-name-basis
@ -205,156 +206,156 @@
(test echcm-kill-epi-f-intr
(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)
(list 0 0 0 0 q-1))))
(funcall f (cat:cmbn 2 1 'a))
(funcall f (cat:cmbn 4 1 'a))
(funcall f (cat:cmbn 3 1 'a 10 'b 100 'c 1000 'd 10000 '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))))
(funcall f (cat:cmbn 2 1 'a))
(funcall f (cat:cmbn 4 1 'a))
(funcall f (cat:cmbn 3 1 'a 10 'b 100 'c 1000 'd 10000 'e))))
#|
(test echcm-kill-epi-g-intr
(let* ((q (cat:random-matrix 5 5 10))
(g (cat:echcm-kill-epi-g-intr 2 2 5 '(a b c d e)
(list 0 0 0 q 0))))
(funcall g (cat:cmbn 2))
(funcall g (cat:cmbn 4 1 'a))
(funcall g (cat:cmbn 3 1 :gn-0 10 :gn-1 100 :gn-2))))
(g (cat:echcm-kill-epi-g-intr 2 2 5 '(a b c d e)
(list 0 0 0 q 0))))
(funcall g (cat:cmbn 2))
(funcall g (cat:cmbn 4 1 'a))
(funcall g (cat:cmbn 3 1 :gn-0 10 :gn-1 100 :gn-2))))
|#
(test echcm-kill-epi-h-intr
(let* ((p-1 (cat:random-matrix 2 2 10))
(q (cat:random-matrix 5 5 10))
(h (cat:echcm-kill-epi-h-intr #'cat:s-cmpr 2 2 5 '(a b)
'(a b c d e)
(list 0 p-1 0 q 0))))
(funcall h (cat:cmbn 2 1 'a 1000 'b))
(funcall h (cat:cmbn 4 1 'a))))
(q (cat:random-matrix 5 5 10))
(h (cat:echcm-kill-epi-h-intr #'cat:s-cmpr 2 2 5 '(a b)
'(a b c d e)
(list 0 p-1 0 q 0))))
(funcall h (cat:cmbn 2 1 'a 1000 'b))
(funcall h (cat:cmbn 4 1 'a))))
(test echcm-kill-epi
(cat:cat-init)
(let* ((s3 (cat:sphere 3))
(s3-chml-clss (cat:chml-clss s3 3))
(s3-fibration (cat:z-whitehead s3 s3-chml-clss))
(s3-4 (cat:fibration-total s3-fibration))
(ecc (cat:echcm s3-4))
(rdct (cat:echcm-kill-epi ecc 2))
s3-4-chml-clss s3-4-fibration s3-5
rdct1 rdct2 rdct3 rdct12 rdct123)
(cat:pre-check-rdct rdct)
(setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn ecc))
cat:*bc* cat:*tc*)
(check-rdct)
(setf cat:*tc* (cat:cmbn 2 1 (first (cat:basis ecc 2))))
(check-rdct)
(setf cat:*tc* (cat:cmbn 3 1 (first (cat:basis ecc 3))))
(check-rdct)
(setf cat:*tc* (cat:cmbn 4 1 (first (cat:basis ecc 4)))
cat:*bc* cat:*tc*)
(check-rdct)
(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-5 (cat:fibration-total s3-4-fibration))
(setf ecc (cat:echcm s3-5))
(dotimes (i 7)
(format t "~%DIM = ~D ; LENGTH = ~D" i (length (cat:basis ecc i))))
(setf rdct1 (cat:echcm-kill-epi ecc 2))
(setf rdct2 (cat:echcm-kill-epi (cat:bcc rdct1) 3))
(setf rdct3 (cat:echcm-kill-epi (cat:bcc rdct2) 4))
(setf rdct12 (cat:cmps rdct2 rdct1))
(setf rdct123 (cat:cmps rdct3 rdct12))
(cat:pre-check-rdct rdct123)
(setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn ecc)) cat:*bc* cat:*tc*)
(check-rdct)
(setf cat:*tc* (cat:cmbn 2 1 (first (cat:basis ecc 2))))
(check-rdct)
(let ((b3 (cat:basis ecc 3)))
(setf cat:*tc* (cat:cmbn 3 1 (first b3) 10 (second b3))))
(check-rdct)
(let ((b4 (cat:basis ecc 4)))
(setf cat:*tc* (cat:cmbn 4 1 (first b4) 10 (second b4))))
(check-rdct)
(let ((b5 (cat:basis ecc 5)))
(setf cat:*tc* (cat:cmbn 5 1 (first b5)
10 (second b5)
100 (third b5)
1000 (fourth b5))))
(check-rdct)
(let ((b6 (cat:basis ecc 6)))
(setf cat:*tc* (cat:cmbn 6 1 (first b6)
10 (second b6)
100 (third b6)
1000 (fourth b6)
10000 (fifth b6)
100000 (sixth b6)
1000000 (seventh b6))))
(check-rdct)))
(s3-chml-clss (cat:chml-clss s3 3))
(s3-fibration (cat:z-whitehead s3 s3-chml-clss))
(s3-4 (cat:fibration-total s3-fibration))
(ecc (cat:echcm s3-4))
(rdct (cat:echcm-kill-epi ecc 2))
s3-4-chml-clss s3-4-fibration s3-5
rdct1 rdct2 rdct3 rdct12 rdct123)
(cat:pre-check-rdct rdct)
(setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn ecc))
cat:*bc* cat:*tc*)
(check-rdct)
(setf cat:*tc* (cat:cmbn 2 1 (first (cat:basis ecc 2))))
(check-rdct)
(setf cat:*tc* (cat:cmbn 3 1 (first (cat:basis ecc 3))))
(check-rdct)
(setf cat:*tc* (cat:cmbn 4 1 (first (cat:basis ecc 4)))
cat:*bc* cat:*tc*)
(check-rdct)
(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-5 (cat:fibration-total s3-4-fibration))
(setf ecc (cat:echcm s3-5))
(dotimes (i 7)
(format t "~%DIM = ~D ; LENGTH = ~D" i (length (cat:basis ecc i))))
(setf rdct1 (cat:echcm-kill-epi ecc 2))
(setf rdct2 (cat:echcm-kill-epi (cat:bcc rdct1) 3))
(setf rdct3 (cat:echcm-kill-epi (cat:bcc rdct2) 4))
(setf rdct12 (cat:cmps rdct2 rdct1))
(setf rdct123 (cat:cmps rdct3 rdct12))
(cat:pre-check-rdct rdct123)
(setf cat:*tc* (cat:cmbn 0 1 (cat:bsgn ecc)) cat:*bc* cat:*tc*)
(check-rdct)
(setf cat:*tc* (cat:cmbn 2 1 (first (cat:basis ecc 2))))
(check-rdct)
(let ((b3 (cat:basis ecc 3)))
(setf cat:*tc* (cat:cmbn 3 1 (first b3) 10 (second b3))))
(check-rdct)
(let ((b4 (cat:basis ecc 4)))
(setf cat:*tc* (cat:cmbn 4 1 (first b4) 10 (second b4))))
(check-rdct)
(let ((b5 (cat:basis ecc 5)))
(setf cat:*tc* (cat:cmbn 5 1 (first b5)
10 (second b5)
100 (third b5)
1000 (fourth b5))))
(check-rdct)
(let ((b6 (cat:basis ecc 6)))
(setf cat:*tc* (cat:cmbn 6 1 (first b6)
10 (second b6)
100 (third b6)
1000 (fourth b6)
10000 (fifth b6)
100000 (sixth b6)
1000000 (seventh b6))))
(check-rdct)))
(test kill-epis
(cat:cat-init)
(let* ((s3 (cat:sphere 3))
(s3-chml-clss (cat:chml-clss s3 3))
(s3-fibration (cat:z-whitehead s3 s3-chml-clss))
(s3-4 (cat:fibration-total s3-fibration))
(s3-4-chml-clss (cat:chml-clss s3-4 4))
(s3-4-fibration (cat:z2-whitehead s3-4 s3-4-chml-clss))
(s3-5 (cat:fibration-total s3-4-fibration)))
(time (cat:homology s3-5 6))
(cat:kill-epis s3-5 2 5)
(cat:homology s3-5 0 7)))
(s3-chml-clss (cat:chml-clss s3 3))
(s3-fibration (cat:z-whitehead s3 s3-chml-clss))
(s3-4 (cat:fibration-total s3-fibration))
(s3-4-chml-clss (cat:chml-clss s3-4 4))
(s3-4-fibration (cat:z2-whitehead s3-4 s3-4-chml-clss))
(s3-5 (cat:fibration-total s3-4-fibration)))
(time (cat:homology s3-5 6))
(cat:kill-epis s3-5 2 5)
(cat:homology s3-5 0 7)))
(test kill-epi
(cat:cat-init)
(let* ((s3 (cat:sphere 3))
(s3-chml-clss (cat:chml-clss s3 3))
(s3-fibration (cat:z-whitehead s3 s3-chml-clss))
(s3-4 (cat:fibration-total s3-fibration))
s3-4-chml-clss s3-4-fibration s3-5)
(cat:kill-epi s3-4 2)
(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-5 (cat:fibration-total s3-4-fibration))
(time (cat:homology s3-5 6))))
(s3-chml-clss (cat:chml-clss s3 3))
(s3-fibration (cat:z-whitehead s3 s3-chml-clss))
(s3-4 (cat:fibration-total s3-fibration))
s3-4-chml-clss s3-4-fibration s3-5)
(cat:kill-epi s3-4 2)
(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-5 (cat:fibration-total s3-4-fibration))
(time (cat:homology s3-5 6))))
(test chml-clss-intr
(cat:cat-init)
(let* ((s3 (cat:sphere 3))
(c (cat:chml-clss-intr s3 3))
(s3-chml-clss (cat:chml-clss s3 3))
(s3-fibration (cat:z-whitehead s3 s3-chml-clss))
(s3-4 (cat:fibration-total s3-fibration))
s3-4-chml-clss s3-4-fibration s3-5)
(funcall c (cat:cmbn 3 5 's3))
(cat:kill-epi s3-4 2)
(setf c (cat:chml-clss-intr 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-fibration (cat:z2-whitehead s3-4 s3-4-chml-clss))
(setf s3-5 (cat:fibration-total s3-4-fibration))
(cat:kill-epis s3-5 3 5)
(setf c (cat:chml-clss-intr s3-5 5))
(let ((b5 (cat:basis (cat:echcm s3-5) 5)))
(funcall c (cat:cmbn 5 1 (first b5) 10 (second b5))))))
(c (cat:chml-clss-intr s3 3))
(s3-chml-clss (cat:chml-clss s3 3))
(s3-fibration (cat:z-whitehead s3 s3-chml-clss))
(s3-4 (cat:fibration-total s3-fibration))
s3-4-chml-clss s3-4-fibration s3-5)
(funcall c (cat:cmbn 3 5 's3))
(cat:kill-epi s3-4 2)
(setf c (cat:chml-clss-intr 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-fibration (cat:z2-whitehead s3-4 s3-4-chml-clss))
(setf s3-5 (cat:fibration-total s3-4-fibration))
(cat:kill-epis s3-5 3 5)
(setf c (cat:chml-clss-intr s3-5 5))
(let ((b5 (cat:basis (cat:echcm s3-5) 5)))
(funcall c (cat:cmbn 5 1 (first b5) 10 (second b5))))))
(test chml-clss
(cat:cat-init)
(let* ((s3 (cat:sphere 3))
(s3-chml-clss (cat:chml-clss s3 3))
(s3-fibration (cat:z-whitehead s3 s3-chml-clss))
(s3-4 (cat:fibration-total s3-fibration))
s3-4-chml-clss s3-4-fibration s3-5 s3-5-chml-clss s3-5-fibration)
(cat:homology s3-4 0 6)
(cat:kill-epi s3-4 2)
(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-5 (cat:fibration-total s3-4-fibration))
(cat:homology s3-5 0 6)
(cat:kill-epis s3-5 3 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-6 (cat:fibration-total s3-5-fibration))
(cat:homology s3-6 0 7)))
(s3-chml-clss (cat:chml-clss s3 3))
(s3-fibration (cat:z-whitehead s3 s3-chml-clss))
(s3-4 (cat:fibration-total s3-fibration))
s3-4-chml-clss s3-4-fibration s3-5 s3-5-chml-clss s3-5-fibration)
(cat:homology s3-4 0 6)
(cat:kill-epi s3-4 2)
(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-5 (cat:fibration-total s3-4-fibration))
(cat:homology s3-5 0 6)
(cat:kill-epis s3-5 3 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-6 (cat:fibration-total s3-5-fibration))
(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)
@ -5,21 +6,21 @@
(test finite-ss-pre-table
(let ((p (cat:finite-ss-pre-table '(0 v0 v1 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)))
(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 v1 v2 0 v3)))
(signals simple-error (cat:finite-ss-pre-table '(0 v0 (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
(cat:finite-ss-pre-table '(0 v0 (v0 v0) #(1 2))))))
(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)))
(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 v1 v2 0 v3)))
(signals simple-error (cat:finite-ss-pre-table '(0 v0 (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
(cat:finite-ss-pre-table '(0 v0 (v0 v0) #(1 2))))))
(test 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
@ -28,7 +29,7 @@
(cat:finite-ss-table '(a b 1 c (b a)))
(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)
2 s012 (s12 s02 s01)))
2 s012 (s12 s02 s01)))
(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 '(* 1 s (t))))
@ -41,122 +42,122 @@ TR is NIL. Why?
(test build-finite-ss
(cat:cat-init)
(let (tr (cat:build-finite-ss '(s0 s1 s2
1 s01 (s1 s0) s02 (s2 s0) s12 (s2 s1)
2 s012 (s12 s02 s01))))
(cat:cmpr tr 's01 's02)
1 s01 (s1 s0) s02 (s2 s0) s12 (s2 s1)
2 s012 (s12 s02 s01))))
(cat:cmpr tr 's01 's02)
(cat:basis tr 2)
(cat:bspn tr)
(cat:face tr 1 2 's012)
(cat:? tr 2 's012)
(cat:? tr (cat:? tr 2 's012))
(mapcar #'(lambda (s) (length (eval s))) cat:*list-list*)
(setf tr (cat:build-finite-ss '(s0 s1 s2
1 s01 (s1 s1) s02 (s2 s0) s12 (s2 s1)
2 s012 (s12 s02 s01))))
(mapcar #'(lambda (s) (length (eval s))) cat:*list-list*)))
(cat:bspn tr)
(cat:face tr 1 2 's012)
(cat:? tr 2 's012)
(cat:? tr (cat:? tr 2 's012))
(mapcar #'(lambda (s) (length (eval s))) cat:*list-list*)
(setf tr (cat:build-finite-ss '(s0 s1 s2
1 s01 (s1 s1) s02 (s2 s0) s12 (s2 s1)
2 s012 (s12 s02 s01))))
(mapcar #'(lambda (s) (length (eval s))) cat:*list-list*)))
|#
(test sphere
(cat:cat-init)
(let ((s3 (cat:sphere 3))
d)
(funcall (cat:cmpr s3) 's3 's3)
(dotimes (i 5)
(print (funcall (cat:basis s3) i)))
(mapcar #'(lambda (i) (funcall (cat:face s3) i 3 's3)) (cat:<a-b> 0 3))
(cat:? s3 3 's3)
(cat:smst (cat:idnm s3))
(cat:chcm (cat:idnm s3))
(setf d (cat:bndr s3))
(cat:add d d)))
d)
(funcall (cat:cmpr s3) 's3 's3)
(dotimes (i 5)
(print (funcall (cat:basis s3) i)))
(mapcar #'(lambda (i) (funcall (cat:face s3) i 3 's3)) (cat:<a-b> 0 3))
(cat:? s3 3 's3)
(cat:smst (cat:idnm s3))
(cat:chcm (cat:idnm s3))
(setf d (cat:bndr s3))
(cat:add d d)))
(test sphere-wedge
(cat:cat-init)
(let ((w (cat:sphere-wedge 3 2 3)))
(funcall (cat:cmpr w) 's3-1 's3-2)
(dotimes (i 5) (print (funcall (cat:basis w) i)))
(funcall (cat:face w) 2 3 's3-1)
(cat:gnrt-? (cat:bndr w) 3 's3-2)))
(funcall (cat:cmpr w) 's3-1 's3-2)
(dotimes (i 5) (print (funcall (cat:basis w) i)))
(funcall (cat:face w) 2 3 's3-1)
(cat:gnrt-? (cat:bndr w) 3 's3-2)))
(test moore
(cat:cat-init)
(let ((m4 (cat:moore 2 4)))
(cat:cmpr m4 'n5 'n5)
(dotimes (i 7)
(print (cat:basis m4 i)))
(mapcar #'(lambda (i) (cat:face m4 i 5 'n5)) (cat:<a-b> 0 5))
(cat:? m4 4 'm4)
(cat:? m4 5 'n5)))
(cat:cmpr m4 'n5 'n5)
(dotimes (i 7)
(print (cat:basis m4 i)))
(mapcar #'(lambda (i) (cat:face m4 i 5 'n5)) (cat:<a-b> 0 5))
(cat:? m4 4 'm4)
(cat:? m4 5 'n5)))
(test r-proj-space-basis
(let ((b (cat:r-proj-space-basis 1 :infinity)))
(dotimes (i 5) (print (funcall b i)))
(setf b (cat:r-proj-space-basis 1 5))
(dotimes (i 8) (print (funcall b i)))
(setf b (cat:r-proj-space-basis 3 :infinity))
(dotimes (i 5) (print (funcall b i)))
(setf b (cat:r-proj-space-basis 3 6))
(dotimes (i 10) (print (funcall b i)))))
(dotimes (i 5) (print (funcall b i)))
(setf b (cat:r-proj-space-basis 1 5))
(dotimes (i 8) (print (funcall b i)))
(setf b (cat:r-proj-space-basis 3 :infinity))
(dotimes (i 5) (print (funcall b i)))
(setf b (cat:r-proj-space-basis 3 6))
(dotimes (i 10) (print (funcall b i)))))
(test R-proj-space
(cat:cat-init)
(let ((p (cat:R-proj-space)))
(cat:basis p 4)
(dotimes (i 5)
(print (cat:face p i 4 4)))
(dotimes (i 5)
(print (cat:? p i i)))
(setf dd (cat:cmps p p))
(dotimes (i 6)
(print (cat:? dd i i)))
(setf p (cat:R-proj-space 3))
(dotimes (i 7)
(print (cat:basis p i)))
(dotimes (i 5)
(print (cat:face p i 4 4)))
(dotimes (i 7)
(print (cat:? p i i)))
(setf dd (cat:cmps p p))
(dotimes (i 7)
(print (cat:? dd i i)))))
(cat:basis p 4)
(dotimes (i 5)
(print (cat:face p i 4 4)))
(dotimes (i 5)
(print (cat:? p i i)))
(setf dd (cat:cmps p p))
(dotimes (i 6)
(print (cat:? dd i i)))
(setf p (cat:R-proj-space 3))
(dotimes (i 7)
(print (cat:basis p i)))
(dotimes (i 5)
(print (cat:face p i 4 4)))
(dotimes (i 7)
(print (cat:? p i i)))
(setf dd (cat:cmps p p))
(dotimes (i 7)
(print (cat:? dd i i)))))
(test gmsms-subsmst
(cat:cat-init)
(let* ((k (cat:k-z 2))
(efhm (cat:efhm k))
g cmbn kf incl cone s2 cl2 f2 s3
(efhm (cat:efhm k))
g cmbn kf incl cone s2 cl2 f2 s3
)
(setf cat:*homology-verbose* nil)
(setf g (first (cat:chcm-homology-gen (cat:rbcc efhm) 4)))
(setf cmbn (cat:lf efhm (cat:rg efhm g)))
(multiple-value-setq (kf incl) (cat:gmsms-subsmst k cmbn))
(setf cone (cat:cone incl))
(cat:efhm cone)
(cat:homology kf 0 5)
(cat:homology (cat:cone incl) 0 6)
)
(setf cat:*homology-verbose* nil)
(setf g (first (cat:chcm-homology-gen (cat:rbcc efhm) 4)))
(setf cmbn (cat:lf efhm (cat:rg efhm g)))
(multiple-value-setq (kf incl) (cat:gmsms-subsmst k cmbn))
(setf cone (cat:cone incl))
(cat:efhm cone)
(cat:homology kf 0 5)
(cat:homology (cat:cone incl) 0 6)
(setf g (first (cat:chcm-homology-gen (cat:rbcc efhm) 8)))
(setf cmbn (cat:lf efhm (cat:rg efhm g)))
(multiple-value-setq (kf incl) (cat:gmsms-subsmst k cmbn))
(setf cone (cat:cone incl))
(cat:efhm cone)
(cat:homology kf 0 9)
(cat:homology (cat:cone incl) 0 10)
(dotimes (i 9) (print (length (cat:basis kf i))))
(setf g (first (cat:chcm-homology-gen (cat:rbcc efhm) 8)))
(setf cmbn (cat:lf efhm (cat:rg efhm g)))
(multiple-value-setq (kf incl) (cat:gmsms-subsmst k cmbn))
(setf cone (cat:cone incl))
(cat:efhm cone)
(cat:homology kf 0 9)
(cat:homology (cat:cone incl) 0 10)
(dotimes (i 9) (print (length (cat:basis kf i))))
(setf s2 (cat:sphere 2))
(setf cl2 (cat:chml-clss s2 2))
(setf f2 (cat:z-whitehead s2 cl2))
(setf s3 (cat:fibration-total f2))
(setf efhm (cat:efhm s3))
(cat:basis (cat:rbcc efhm) 3)
(setf cmbn (cat:lf efhm (cat:rg efhm 3 (first (cat:basis
(cat:rbcc efhm) 3)))))
(setf kf (cat:gmsms-subsmst s3 cmbn))
(cat:homology kf 0 4)))
(setf s2 (cat:sphere 2))
(setf cl2 (cat:chml-clss s2 2))
(setf f2 (cat:z-whitehead s2 cl2))
(setf s3 (cat:fibration-total f2))
(setf efhm (cat:efhm s3))
(cat:basis (cat:rbcc efhm) 3)
(setf cmbn (cat:lf efhm (cat:rg efhm 3 (first (cat:basis
(cat:rbcc efhm) 3)))))
(setf kf (cat:gmsms-subsmst s3 cmbn))
(cat:homology kf 0 4)))

153
test/suspensions-test.lisp
View File

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

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

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

25
test/various-test.lisp
View File

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

179
test/whitehead-test.lisp
View File

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