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

Kenzo 1.1.7

Browse Source 
Download from http://www-fourier.ujf-grenoble.fr/~sergerar/Kenzo/
This commit is contained in:
gheber 2014-12-24 03:50:18 -06:00
commit 378973dc78
47 changed files with 20537 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

100
Kenzo-1/Demo.cl Normal file
View File

@ -0,0 +1,100 @@
;;; 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
(IN-PACKAGE :USER)
(DEFVAR *STATEMENT*)
;; C = comment
(DEFUN C (string)
(terpri)
(dotimes (i 50) (princ "-"))
(princ "<Comment>")
; (dotimes (i 31) (princ "-"))
; (terpri)
(princ string)
; (terpri)
(dotimes (i 50) (princ "-"))
(values))
;; R = read
(DEFMACRO R (statement)
(declare (special *statement*))
(setf *statement* statement)
`(progn
(terpri)
(dotimes (i 50) (princ "-"))
(princ "<Lisp Statement>")
; (dotimes (i 29) (princ "-"))
; (terpri)
(pprint ',statement)
(terpri) ; (terpri)
(dotimes (i 50) (princ "-"))
(values)))
(DEFUN STRIP-INITIAL-SPACES (st)
(let ((st2 (make-string (- (length st) (count #\Newline st)))))
(declare (type string st2))
(do ((i 0 (1+ i))
(j 0 (1+ j)))
((= i (length st)))
(let ((char (aref st i)))
(when (char= char #\newline)
(incf i))
(setf (aref st2 j) char)))
st2))
(DEFMACRO R2 (dstatement)
(declare (special *statement* *dstatement*))
(setf *dstatement* dstatement)
(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)))
;; E = EXECUTE
(DEFUN E ()
(declare (special *statement*))
(terpri)
(dotimes (i 50) (princ "-"))
(princ "<Result>")
; (dotimes (i 32) (princ "-"))
(terpri) ; (terpri)
(prin1 (eval *statement*))
(terpri) ; (terpri)
(dotimes (i 50) (princ "-"))
(values))
(DEFUN EE ()
(declare (special *statement*))
(terpri)
(dotimes (i 10) (princ "-"))
(princ " Error ")
(dotimes (i 33) (princ "-"))
(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*))
(my-restart () (values)))
(terpri) (terpri)
(dotimes (i 50) (princ "-"))
(values))
(DEFMACRO M (statement)
(eval statement)
'(values ))

214
Kenzo-1/How-to-Compile-Kenzo-with-Acl8.txt Normal file
View File

@ -0,0 +1,214 @@
;;;
;;; [[ Comments added to the listing.]]
;;;
International Allegro CL Free Express Edition
8.0 [Windows] (Dec 27, 2006 16:11)
Copyright (C) 1985-2006, Franz Inc., Oakland, CA, USA. All Rights Reserved.
This development copy of Allegro CL is licensed to:
Trial User
CG version 1.81.2.23 / IDE version 1.80.2.21
Loaded options from C:\Documents and Settings\Fourier\Mes documents\allegro-prefs.cl.
;; Optimization settings: safety 1, space 1, speed 1, debug 2.
;; For a complete description of all compiler switches given the current
;; optimization settings evaluate (EXPLAIN-COMPILER-SETTINGS).
;;;
;;; [[ Don't forget to define the standard package "COMMON-LISP-USER"
;;; [[ before starting.
;;; [[ Cf Tools > IDE 1 > Initial Package := COMMON-LISP-USER
;;;
CL-USER(1): (load "cat-init")
; Loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\cat-init.cl
FILE 1: macros
FILE 2: various
FILE 3: classes
FILE 4: combinations
FILE 5: chain-complexes
FILE 6: chcm-elementary-op
FILE 7: effective-homology
FILE 8: homology-groups
FILE 9: searching-homology
FILE 10: cones
FILE 11: tensor-products
FILE 12: coalgebras
FILE 13: cobar
FILE 14: algebras
FILE 15: bar
FILE 16: simplicial-sets
FILE 17: simplicial-mrphs
FILE 18: delta
FILE 19: special-smsts
FILE 20: suspensions
FILE 21: disk-pasting
FILE 22: cartesian-products
FILE 23: eilenberg-zilber
FILE 24: kan
FILE 25: simplicial-groups
FILE 26: fibrations
FILE 27: loop-spaces
FILE 28: ls-twisted-products
FILE 29: lp-space-efhm
FILE 30: classifying-spaces
FILE 31: k-pi-n
FILE 32: serre
FILE 33: cs-twisted-products
FILE 34: cl-space-efhm
FILE 35: whitehead
FILE 36: smith
T
CL-USER(2): (compile-files)
*CMBN-CONTROL* = T
;;; Compiling file macros.cl
;;; Writing fasl file macros.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\macros.fasl
;;; Compiling file various.cl
;;; Writing fasl file various.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\various.fasl
;;; Compiling file classes.cl
;;; Writing fasl file classes.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\classes.fasl
;;; Compiling file combinations.cl
;;; Writing fasl file combinations.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\combinations.fasl
;;; Compiling file chain-complexes.cl
;;; Writing fasl file chain-complexes.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\chain-complexes.fasl
;;; Compiling file chcm-elementary-op.cl
;;; Writing fasl file chcm-elementary-op.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\chcm-elementary-op.fasl
;;; Compiling file effective-homology.cl
;;; Writing fasl file effective-homology.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\effective-homology.fasl
;;; Compiling file homology-groups.cl
;;; Writing fasl file homology-groups.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\homology-groups.fasl
;;; Compiling file searching-homology.cl
;;; Writing fasl file searching-homology.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\searching-homology.fasl
;;; Compiling file cones.cl
;;; Writing fasl file cones.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\cones.fasl
;;; Compiling file tensor-products.cl
;;; Writing fasl file tensor-products.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\tensor-products.fasl
;;; Compiling file coalgebras.cl
;;; Writing fasl file coalgebras.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\coalgebras.fasl
;;; Compiling file cobar.cl
;;; Writing fasl file cobar.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\cobar.fasl
;;; Compiling file algebras.cl
;;; Writing fasl file algebras.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\algebras.fasl
;;; Compiling file bar.cl
;;; Writing fasl file bar.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\bar.fasl
;;; Compiling file simplicial-sets.cl
;;; Writing fasl file simplicial-sets.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\simplicial-sets.fasl
;;; Compiling file simplicial-mrphs.cl
;;; Writing fasl file simplicial-mrphs.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\simplicial-mrphs.fasl
;;; Compiling file delta.cl
;;; Writing fasl file delta.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\delta.fasl
;;; Compiling file special-smsts.cl
;;; Writing fasl file special-smsts.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\special-smsts.fasl
;;; Compiling file suspensions.cl
;;; Writing fasl file suspensions.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\suspensions.fasl
;;; Compiling file disk-pasting.cl
;;; Writing fasl file disk-pasting.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\disk-pasting.fasl
;;; Compiling file cartesian-products.cl
;;; Writing fasl file cartesian-products.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\cartesian-products.fasl
;;; Compiling file eilenberg-zilber.cl
;;; Writing fasl file eilenberg-zilber.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\eilenberg-zilber.fasl
;;; Compiling file kan.cl
;;; Writing fasl file kan.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\kan.fasl
;;; Compiling file simplicial-groups.cl
;;; Writing fasl file simplicial-groups.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\simplicial-groups.fasl
;;; Compiling file fibrations.cl
;;; Writing fasl file fibrations.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\fibrations.fasl
;;; Compiling file loop-spaces.cl
;;; Writing fasl file loop-spaces.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\loop-spaces.fasl
;;; Compiling file ls-twisted-products.cl
;;; Writing fasl file ls-twisted-products.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\ls-twisted-products.fasl
;;; Compiling file lp-space-efhm.cl
;;; Writing fasl file lp-space-efhm.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\lp-space-efhm.fasl
;;; Compiling file classifying-spaces.cl
;;; Writing fasl file classifying-spaces.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\classifying-spaces.fasl
;;; Compiling file k-pi-n.cl
;;; Writing fasl file k-pi-n.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\k-pi-n.fasl
;;; Compiling file serre.cl
;;; Writing fasl file serre.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\serre.fasl
;;; Compiling file cs-twisted-products.cl
;;; Writing fasl file cs-twisted-products.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\cs-twisted-products.fasl
;;; Compiling file cl-space-efhm.cl
;;; Writing fasl file cl-space-efhm.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\cl-space-efhm.fasl
;;; Compiling file whitehead.cl
;;; Writing fasl file whitehead.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\whitehead.fasl
;;; Compiling file smith.cl
;;; Writing fasl file smith.fasl
;;; Fasl write complete
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\smith.fasl
("macros" "various" "classes" "combinations" "chain-complexes" "chcm-elementary-op"
"effective-homology" "homology-groups" "searching-homology" "cones" ...)
CL-USER(3): (exit)

257
Kenzo-1/How-to-Compile-Kenzo-with-CLisp.txt Normal file
View File

@ -0,0 +1,257 @@
c:\Documents and Settings\Francis\AA\Kenzo\Kenzo-1.1-CLisp>CLisp
i i i i i i i ooooo o ooooooo ooooo ooooo
I I I I I I I 8 8 8 8 8 o 8 8
I \ `+' / I 8 8 8 8 8 8
\ `-+-' / 8 8 8 ooooo 8oooo
`-__|__-' 8 8 8 8 8
| 8 o 8 8 o 8 8
------+------ ooooo 8oooooo ooo8ooo ooooo 8
Copyright (c) Bruno Haible, Michael Stoll 1992, 1993
Copyright (c) Bruno Haible, Marcus Daniels 1994-1997
Copyright (c) Bruno Haible, Pierpaolo Bernardi, Sam Steingold 1998
Copyright (c) Bruno Haible, Sam Steingold 1999-2000
Copyright (c) Sam Steingold, Bruno Haible 2001-2006
[1]> (load "cat-init")
;; Loading file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\cat-init.cl ...
FILE 1: macros
FILE 2: various
FILE 3: classes
FILE 4: combinations
FILE 5: chain-complexes
FILE 6: chcm-elementary-op
FILE 7: effective-homology
FILE 8: homology-groups
FILE 9: searching-homology
FILE 10: cones
FILE 11: tensor-products
FILE 12: coalgebras
FILE 13: cobar
FILE 14: algebras
FILE 15: bar
FILE 16: simplicial-sets
FILE 17: simplicial-mrphs
FILE 18: delta
FILE 19: special-smsts
FILE 20: suspensions
FILE 21: disk-pasting
FILE 22: cartesian-products
FILE 23: eilenberg-zilber
FILE 24: kan
FILE 25: simplicial-groups
FILE 26: fibrations
FILE 27: loop-spaces
FILE 28: ls-twisted-products
FILE 29: lp-space-efhm
FILE 30: classifying-spaces
FILE 31: k-pi-n
FILE 32: serre
FILE 33: cs-twisted-products
FILE 34: cl-space-efhm
FILE 35: whitehead
FILE 36: smith
;; Loaded file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\cat-init.cl
T
[2]> (compile-files)
*CMBN-CONTROL* = T
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\macros.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\macros.fas
0 errors, 0 warnings
;; Loading file macros.fas ...
;; Loaded file macros.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\various.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\various.fas
0 errors, 0 warnings
;; Loading file various.fas ...
;; Loaded file various.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\classes.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\classes.fas
;;;
;;; [[ Do not take account of this warning.
;;; [[ For coherence, these functions are defined in later files.
;;;
The following functions were used but not defined:
CMBN-PRINT RESULT-PRINT BICN-PRINT TNPR-PRINT ALLP-PRINT ABAR-PRINT
ABSM-PRINT CRPR-PRINT LOOP-PRINT GBAR-PRINT
0 errors, 0 warnings
;; Loading file classes.fas ...
;; Loaded file classes.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\combinations.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\combinations.fas
0 errors, 0 warnings
;; Loading file combinations.fas ...
;; Loaded file combinations.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\chain-complexes.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\chain-complexes.fas
0 errors, 0 warnings
;; Loading file chain-complexes.fas ...
;; Loaded file chain-complexes.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\chcm-elementary-op.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\chcm-elementary-op.fas
0 errors, 0 warnings
;; Loading file chcm-elementary-op.fas ...
;; Loaded file chcm-elementary-op.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\effective-homology.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\effective-homology.fas
0 errors, 0 warnings
;; Loading file effective-homology.fas ...
;; Loaded file effective-homology.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\homology-groups.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\homology-groups.fas
0 errors, 0 warnings
;; Loading file homology-groups.fas ...
;; Loaded file homology-groups.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\searching-homology.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\searching-homology.fas
0 errors, 0 warnings
;; Loading file searching-homology.fas ...
;; Loaded file searching-homology.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\cones.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\cones.fas
0 errors, 0 warnings
;; Loading file cones.fas ...
;; Loaded file cones.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\tensor-products.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\tensor-products.fas
0 errors, 0 warnings
;; Loading file tensor-products.fas ...
;; Loaded file tensor-products.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\coalgebras.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\coalgebras.fas
0 errors, 0 warnings
;; Loading file coalgebras.fas ...
;; Loaded file coalgebras.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\cobar.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\cobar.fas
0 errors, 0 warnings
;; Loading file cobar.fas ...
;; Loaded file cobar.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\algebras.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\algebras.fas
0 errors, 0 warnings
;; Loading file algebras.fas ...
;; Loaded file algebras.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\bar.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\bar.fas
0 errors, 0 warnings
;; Loading file bar.fas ...
;; Loaded file bar.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\simplicial-sets.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\simplicial-sets.fas
0 errors, 0 warnings
;; Loading file simplicial-sets.fas ...
;; Loaded file simplicial-sets.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\simplicial-mrphs.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\simplicial-mrphs.fas
0 errors, 0 warnings
;; Loading file simplicial-mrphs.fas ...
;; Loaded file simplicial-mrphs.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\delta.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\delta.fas
0 errors, 0 warnings
;; Loading file delta.fas ...
;; Loaded file delta.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\special-smsts.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\special-smsts.fas
0 errors, 0 warnings
;; Loading file special-smsts.fas ...
;; Loaded file special-smsts.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\suspensions.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\suspensions.fas
0 errors, 0 warnings
;; Loading file suspensions.fas ...
;; Loaded file suspensions.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\disk-pasting.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\disk-pasting.fas
0 errors, 0 warnings
;; Loading file disk-pasting.fas ...
;; Loaded file disk-pasting.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\cartesian-products.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\cartesian-products.fas
0 errors, 0 warnings
;; Loading file cartesian-products.fas ...
;; Loaded file cartesian-products.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\eilenberg-zilber.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\eilenberg-zilber.fas
0 errors, 0 warnings
;; Loading file eilenberg-zilber.fas ...
;; Loaded file eilenberg-zilber.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\kan.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\kan.fas
0 errors, 0 warnings
;; Loading file kan.fas ...
;; Loaded file kan.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\simplicial-groups.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\simplicial-groups.fas
0 errors, 0 warnings
;; Loading file simplicial-groups.fas ...
;; Loaded file simplicial-groups.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\fibrations.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\fibrations.fas
0 errors, 0 warnings
;; Loading file fibrations.fas ...
;; Loaded file fibrations.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\loop-spaces.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\loop-spaces.fas
0 errors, 0 warnings
;; Loading file loop-spaces.fas ...
;; Loaded file loop-spaces.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\ls-twisted-products.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\ls-twisted-products.fas
0 errors, 0 warnings
;; Loading file ls-twisted-products.fas ...
;; Loaded file ls-twisted-products.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\lp-space-efhm.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\lp-space-efhm.fas
0 errors, 0 warnings
;; Loading file lp-space-efhm.fas ...
;; Loaded file lp-space-efhm.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\classifying-spaces.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\classifying-spaces.fas
0 errors, 0 warnings
;; Loading file classifying-spaces.fas ...
;; Loaded file classifying-spaces.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\k-pi-n.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\k-pi-n.fas
0 errors, 0 warnings
;; Loading file k-pi-n.fas ...
;; Loaded file k-pi-n.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\serre.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\serre.fas
0 errors, 0 warnings
;; Loading file serre.fas ...
;; Loaded file serre.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\cs-twisted-products.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\cs-twisted-products.fas
0 errors, 0 warnings
;; Loading file cs-twisted-products.fas ...
;; Loaded file cs-twisted-products.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\cl-space-efhm.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\cl-space-efhm.fas
0 errors, 0 warnings
;; Loading file cl-space-efhm.fas ...
;; Loaded file cl-space-efhm.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\whitehead.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\whitehead.fas
0 errors, 0 warnings
;; Loading file whitehead.fas ...
;; Loaded file whitehead.fas
;; Compiling file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\smith.cl ...
;; Wrote file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\smith.fas
0 errors, 0 warnings
;; Loading file smith.fas ...
;; Loaded file smith.fas
("macros" "various" "classes" "combinations" "chain-complexes" "chcm-elementary-op" "effective-homology"
"homology-groups" "searching-homology" "cones" ...)
[3]> (exit)
Bye.
C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp>

1338
Kenzo-1/How-to-Compile-Kenzo-with-LispWorks.txt Normal file
View File

File diff suppressed because it is too large Load Diff

350
Kenzo-1/How-to-Use-Kenzo-with-Acl8.txt Normal file
View File

@ -0,0 +1,350 @@
;;;
;;; [[ Comments added to the listing.]]
;;;
International Allegro CL Free Express Edition
8.0 [Windows] (Dec 27, 2006 16:11)
Copyright (C) 1985-2006, Franz Inc., Oakland, CA, USA. All Rights Reserved.
This development copy of Allegro CL is licensed to:
Trial User
CG version 1.81.2.23 / IDE version 1.80.2.21
Loaded options from C:\Documents and Settings\Fourier\Mes documents\allegro-prefs.cl.
;; Optimization settings: safety 1, space 1, speed 1, debug 2.
;; For a complete description of all compiler switches given the current
;; optimization settings evaluate (EXPLAIN-COMPILER-SETTINGS).
;;;
;;; [[ Don't forget to define the standard package "COMMON-LISP-USER"
;;; [[ before starting.
;;; [[ Cf Tools > IDE 1 > Initial Package := COMMON-LISP-USER
;;;
;;; [[ You must anyway load the "cat-init" file
;;;
CL-USER(1): (load "cat-init")
; Loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\cat-init.cl
FILE 1: macros
FILE 2: various
FILE 3: classes
FILE 4: combinations
FILE 5: chain-complexes
FILE 6: chcm-elementary-op
FILE 7: effective-homology
FILE 8: homology-groups
FILE 9: searching-homology
FILE 10: cones
FILE 11: tensor-products
FILE 12: coalgebras
FILE 13: cobar
FILE 14: algebras
FILE 15: bar
FILE 16: simplicial-sets
FILE 17: simplicial-mrphs
FILE 18: delta
FILE 19: special-smsts
FILE 20: suspensions
FILE 21: disk-pasting
FILE 22: cartesian-products
FILE 23: eilenberg-zilber
FILE 24: kan
FILE 25: simplicial-groups
FILE 26: fibrations
FILE 27: loop-spaces
FILE 28: ls-twisted-products
FILE 29: lp-space-efhm
FILE 30: classifying-spaces
FILE 31: k-pi-n
FILE 32: serre
FILE 33: cs-twisted-products
FILE 34: cl-space-efhm
FILE 35: whitehead
FILE 36: smith
T
;;;
;;; [[ Then the Kenzo function "load-cfiles" load the *compiled* files.
;;; [[ The Kenzo function "load-sfiles" would load the *source* files
;;; [[ and later the code is interpreted (much slower).
;;;
CL-USER(2): (load-cfiles)
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\macros.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\various.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\classes.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\combinations.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\chain-complexes.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\chcm-elementary-op.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\effective-homology.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\homology-groups.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\searching-homology.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\cones.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\tensor-products.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\coalgebras.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\cobar.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\algebras.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\bar.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\simplicial-sets.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\simplicial-mrphs.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\delta.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\special-smsts.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\suspensions.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\disk-pasting.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\cartesian-products.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\eilenberg-zilber.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\kan.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\simplicial-groups.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\fibrations.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\loop-spaces.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\ls-twisted-products.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\lp-space-efhm.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\classifying-spaces.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\k-pi-n.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\serre.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\cs-twisted-products.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\cl-space-efhm.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\whitehead.fasl
; Fast loading C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-Acl8\smith.fasl
("macros" "various" "classes" "combinations" "chain-complexes" "chcm-elementary-op"
"effective-homology" "homology-groups" "searching-homology" "cones" ...)
;;;
;;; [[ Now Kenzo is ready.
;;; [[ For example the computing time
;;; [[ for the homology group H_7(\Omega^2 S^3).
;;;
CL-USER(3): (time (homology (loop-space (sphere 3) 2) 7))
Computing boundary-matrix in dimension 7.
Rank of the source-module : 13.
;; Clock -> 2007-02-05, 14h 48m 1s.
Computing the boundary of the generator 1 (dimension 7) :
<<AlLp[7 <<AlLp[2 S3][2 S3][2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 8s.
Computing the boundary of the generator 2 (dimension 7) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][5 <<AlLp[2 S3][2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 8s.
Computing the boundary of the generator 3 (dimension 7) :
<<AlLp[1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][3 <<AlLp[2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 8s.
Computing the boundary of the generator 4 (dimension 7) :
<<AlLp[1 <<AlLp[2 S3]>>][5 <<AlLp[2 S3][2 S3][2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 8s.
Computing the boundary of the generator 5 (dimension 7) :
<<AlLp[3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 8s.
Computing the boundary of the generator 6 (dimension 7) :
<<AlLp[3 <<AlLp[2 S3][2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 8s.
Computing the boundary of the generator 7 (dimension 7) :
<<AlLp[5 <<AlLp[2 S3][2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 8s.
Computing the boundary of the generator 8 (dimension 7) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 8s.
Computing the boundary of the generator 9 (dimension 7) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 8s.
Computing the boundary of the generator 10 (dimension 7) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 8s.
Computing the boundary of the generator 11 (dimension 7) :
<<AlLp[1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 8s.
Computing the boundary of the generator 12 (dimension 7) :
<<AlLp[3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 8s.
Computing the boundary of the generator 13 (dimension 7) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
Computing boundary-matrix in dimension 8.
Rank of the source-module : 21.
;; Clock -> 2007-02-05, 14h 48m 8s.
Computing the boundary of the generator 1 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][7 <<AlLp[2 S3][2 S3][2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 9s.
Computing the boundary of the generator 2 (dimension 8) :
<<AlLp[3 <<AlLp[2 S3][2 S3]>>][5 <<AlLp[2 S3][2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 9s.
Computing the boundary of the generator 3 (dimension 8) :
<<AlLp[5 <<AlLp[2 S3][2 S3][2 S3]>>][3 <<AlLp[2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 9s.
Computing the boundary of the generator 4 (dimension 8) :
<<AlLp[7 <<AlLp[2 S3][2 S3][2 S3][2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 9s.
Computing the boundary of the generator 5 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][5 <<AlLp[2 S3][2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 10s.
Computing the boundary of the generator 6 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][3 <<AlLp[2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 10s.
Computing the boundary of the generator 7 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][5 <<AlLp[2 S3][2 S3][2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 10s.
Computing the boundary of the generator 8 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 10s.
Computing the boundary of the generator 9 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 10s.
Computing the boundary of the generator 10 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][5 <<AlLp[2 S3][2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 10s.
Computing the boundary of the generator 11 (dimension 8) :
<<AlLp[3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 10s.
Computing the boundary of the generator 12 (dimension 8) :
<<AlLp[3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 10s.
Computing the boundary of the generator 13 (dimension 8) :
<<AlLp[3 <<AlLp[2 S3][2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 10s.
Computing the boundary of the generator 14 (dimension 8) :
<<AlLp[5 <<AlLp[2 S3][2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 11s.
Computing the boundary of the generator 15 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 12s.
Computing the boundary of the generator 16 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 12s.
Computing the boundary of the generator 17 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 12s.
Computing the boundary of the generator 18 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 12s.
Computing the boundary of the generator 19 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 12s.
Computing the boundary of the generator 20 (dimension 8) :
<<AlLp[3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 14h 48m 12s.
Computing the boundary of the generator 21 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
Homology in dimension 7 :
Component Z/2Z
Component Z/2Z
---done---
;; Clock -> 2007-02-05, 14h 48m 13s.
; cpu time (non-gc) 7,633 msec user, 421 msec system
; cpu time (gc) 3,293 msec user, 40 msec system
; cpu time (total) 10,926 msec user, 461 msec system
; real time 11,497 msec
; space allocation:
; 3,324,666 cons cells, 94,505,896 other bytes, 0 static bytes
NIL
CL-USER(4): (exit)

386
Kenzo-1/How-to-Use-Kenzo-with-CLisp.txt Normal file
View File

@ -0,0 +1,386 @@
;;;
;;; [[ Added comments.
;;;
c:\Documents and Settings\Francis\AA\Kenzo\Kenzo-1.1-CLisp>clisp
i i i i i i i ooooo o ooooooo ooooo ooooo
I I I I I I I 8 8 8 8 8 o 8 8
I \ `+' / I 8 8 8 8 8 8
\ `-+-' / 8 8 8 ooooo 8oooo
`-__|__-' 8 8 8 8 8
| 8 o 8 8 o 8 8
------+------ ooooo 8oooooo ooo8ooo ooooo 8
Copyright (c) Bruno Haible, Michael Stoll 1992, 1993
Copyright (c) Bruno Haible, Marcus Daniels 1994-1997
Copyright (c) Bruno Haible, Pierpaolo Bernardi, Sam Steingold 1998
Copyright (c) Bruno Haible, Sam Steingold 1999-2000
Copyright (c) Sam Steingold, Bruno Haible 2001-2006
;;;
;;; [[ You must anyway load the "cat-init" file
;;;
[1]> (load "cat-init")
;; Loading file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\cat-init.cl ...
FILE 1: macros
FILE 2: various
FILE 3: classes
FILE 4: combinations
FILE 5: chain-complexes
FILE 6: chcm-elementary-op
FILE 7: effective-homology
FILE 8: homology-groups
FILE 9: searching-homology
FILE 10: cones
FILE 11: tensor-products
FILE 12: coalgebras
FILE 13: cobar
FILE 14: algebras
FILE 15: bar
FILE 16: simplicial-sets
FILE 17: simplicial-mrphs
FILE 18: delta
FILE 19: special-smsts
FILE 20: suspensions
FILE 21: disk-pasting
FILE 22: cartesian-products
FILE 23: eilenberg-zilber
FILE 24: kan
FILE 25: simplicial-groups
FILE 26: fibrations
FILE 27: loop-spaces
FILE 28: ls-twisted-products
FILE 29: lp-space-efhm
FILE 30: classifying-spaces
FILE 31: k-pi-n
FILE 32: serre
FILE 33: cs-twisted-products
FILE 34: cl-space-efhm
FILE 35: whitehead
FILE 36: smith
;; Loaded file C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp\cat-init.cl
T
;;;
;;; [[ Then the Kenzo function "load-cfiles" load the *compiled* files.
;;; [[ The Kenzo function "load-sfiles" would load the *source* files
;;; [[ and later the code is interpreted (much slower).
;;;
[2]> (load-cfiles)
;; Loading file macros.fas ...
;; Loaded file macros.fas
;; Loading file various.fas ...
;; Loaded file various.fas
;; Loading file classes.fas ...
;; Loaded file classes.fas
;; Loading file combinations.fas ...
;; Loaded file combinations.fas
;; Loading file chain-complexes.fas ...
;; Loaded file chain-complexes.fas
;; Loading file chcm-elementary-op.fas ...
;; Loaded file chcm-elementary-op.fas
;; Loading file effective-homology.fas ...
;; Loaded file effective-homology.fas
;; Loading file homology-groups.fas ...
;; Loaded file homology-groups.fas
;; Loading file searching-homology.fas ...
;; Loaded file searching-homology.fas
;; Loading file cones.fas ...
;; Loaded file cones.fas
;; Loading file tensor-products.fas ...
;; Loaded file tensor-products.fas
;; Loading file coalgebras.fas ...
;; Loaded file coalgebras.fas
;; Loading file cobar.fas ...
;; Loaded file cobar.fas
;; Loading file algebras.fas ...
;; Loaded file algebras.fas
;; Loading file bar.fas ...
;; Loaded file bar.fas
;; Loading file simplicial-sets.fas ...
;; Loaded file simplicial-sets.fas
;; Loading file simplicial-mrphs.fas ...
;; Loaded file simplicial-mrphs.fas
;; Loading file delta.fas ...
;; Loaded file delta.fas
;; Loading file special-smsts.fas ...
;; Loaded file special-smsts.fas
;; Loading file suspensions.fas ...
;; Loaded file suspensions.fas
;; Loading file disk-pasting.fas ...
;; Loaded file disk-pasting.fas
;; Loading file cartesian-products.fas ...
;; Loaded file cartesian-products.fas
;; Loading file eilenberg-zilber.fas ...
;; Loaded file eilenberg-zilber.fas
;; Loading file kan.fas ...
;; Loaded file kan.fas
;; Loading file simplicial-groups.fas ...
;; Loaded file simplicial-groups.fas
;; Loading file fibrations.fas ...
;; Loaded file fibrations.fas
;; Loading file loop-spaces.fas ...
;; Loaded file loop-spaces.fas
;; Loading file ls-twisted-products.fas ...
;; Loaded file ls-twisted-products.fas
;; Loading file lp-space-efhm.fas ...
;; Loaded file lp-space-efhm.fas
;; Loading file classifying-spaces.fas ...
;; Loaded file classifying-spaces.fas
;; Loading file k-pi-n.fas ...
;; Loaded file k-pi-n.fas
;; Loading file serre.fas ...
;; Loaded file serre.fas
;; Loading file cs-twisted-products.fas ...
;; Loaded file cs-twisted-products.fas
;; Loading file cl-space-efhm.fas ...
;; Loaded file cl-space-efhm.fas
;; Loading file whitehead.fas ...
;; Loaded file whitehead.fas
;; Loading file smith.fas ...
;; Loaded file smith.fas
("macros" "various" "classes" "combinations" "chain-complexes" "chcm-elementary-op" "effective-homology"
"homology-groups" "searching-homology" "cones" ...)
;;;
;;; [[ Now Kenzo is ready.
;;; [[ For example the computing time
;;; [[ for the homology group H_7(\Omega^2 S^3).
;;;
[3]> (time (homology (loop-space (sphere 3) 2) 7))
Computing boundary-matrix in dimension 7.
Rank of the source-module : 13.
;; Clock -> 2007-02-05, 15h 55m 4s.
Computing the boundary of the generator 1 (dimension 7) :
<<AlLp[7 <<AlLp[2 S3][2 S3][2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 15s.
Computing the boundary of the generator 2 (dimension 7) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][5 <<AlLp[2 S3][2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 15s.
Computing the boundary of the generator 3 (dimension 7) :
<<AlLp[1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][3 <<AlLp[2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 16s.
Computing the boundary of the generator 4 (dimension 7) :
<<AlLp[1 <<AlLp[2 S3]>>][5 <<AlLp[2 S3][2 S3][2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 16s.
Computing the boundary of the generator 5 (dimension 7) :
<<AlLp[3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 16s.
Computing the boundary of the generator 6 (dimension 7) :
<<AlLp[3 <<AlLp[2 S3][2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 16s.
Computing the boundary of the generator 7 (dimension 7) :
<<AlLp[5 <<AlLp[2 S3][2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 16s.
Computing the boundary of the generator 8 (dimension 7) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 16s.
Computing the boundary of the generator 9 (dimension 7) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 16s.
Computing the boundary of the generator 10 (dimension 7) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 16s.
Computing the boundary of the generator 11 (dimension 7) :
<<AlLp[1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 17s.
Computing the boundary of the generator 12 (dimension 7) :
<<AlLp[3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 17s.
Computing the boundary of the generator 13 (dimension 7) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
Computing boundary-matrix in dimension 8.
Rank of the source-module : 21.
;; Clock -> 2007-02-05, 15h 55m 17s.
Computing the boundary of the generator 1 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][7 <<AlLp[2 S3][2 S3][2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 18s.
Computing the boundary of the generator 2 (dimension 8) :
<<AlLp[3 <<AlLp[2 S3][2 S3]>>][5 <<AlLp[2 S3][2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 18s.
Computing the boundary of the generator 3 (dimension 8) :
<<AlLp[5 <<AlLp[2 S3][2 S3][2 S3]>>][3 <<AlLp[2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 19s.
Computing the boundary of the generator 4 (dimension 8) :
<<AlLp[7 <<AlLp[2 S3][2 S3][2 S3][2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 20s.
Computing the boundary of the generator 5 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][5 <<AlLp[2 S3][2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 20s.
Computing the boundary of the generator 6 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][3 <<AlLp[2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 21s.
Computing the boundary of the generator 7 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][5 <<AlLp[2 S3][2 S3][2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 21s.
Computing the boundary of the generator 8 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 21s.
Computing the boundary of the generator 9 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 21s.
Computing the boundary of the generator 10 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][5 <<AlLp[2 S3][2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 22s.
Computing the boundary of the generator 11 (dimension 8) :
<<AlLp[3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 22s.
Computing the boundary of the generator 12 (dimension 8) :
<<AlLp[3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 22s.
Computing the boundary of the generator 13 (dimension 8) :
<<AlLp[3 <<AlLp[2 S3][2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 22s.
Computing the boundary of the generator 14 (dimension 8) :
<<AlLp[5 <<AlLp[2 S3][2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 23s.
Computing the boundary of the generator 15 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 23s.
Computing the boundary of the generator 16 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 24s.
Computing the boundary of the generator 17 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 24s.
Computing the boundary of the generator 18 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 24s.
Computing the boundary of the generator 19 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 25s.
Computing the boundary of the generator 20 (dimension 8) :
<<AlLp[3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 15h 55m 25s.
Computing the boundary of the generator 21 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
Homology in dimension 7 :
Component Z/2Z
Component Z/2Z
---done---
;; Clock -> 2007-02-05, 15h 55m 25s.
Real time: 21.330671 sec.
Run time: 21.310644 sec.
Space: 256716896 Bytes
GC: 256, GC time: 3.8255007 sec.
NIL
[4]> (exit)
Bye.
C:\DOCUME~1\Francis\AA\Kenzo\Kenzo-1.1-CLisp>

365
Kenzo-1/How-to-Use-Kenzo-with-LispWorks.txt Normal file
View File

@ -0,0 +1,365 @@
;;;
;;; [[ Loading the initialization file.
;;; [[ Do not forget the extension ".cl" not guessed by LispWorks.
;;;
CL-USER 1 > (load "cat-init.cl")
; Loading text file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\cat-init.cl
FILE 1: macros
FILE 2: various
FILE 3: classes
FILE 4: combinations
FILE 5: chain-complexes
FILE 6: chcm-elementary-op
FILE 7: effective-homology
FILE 8: homology-groups
FILE 9: searching-homology
FILE 10: cones
FILE 11: tensor-products
FILE 12: coalgebras
FILE 13: cobar
FILE 14: algebras
FILE 15: bar
FILE 16: simplicial-sets
FILE 17: simplicial-mrphs
FILE 18: delta
FILE 19: special-smsts
FILE 20: suspensions
FILE 21: disk-pasting
FILE 22: cartesian-products
FILE 23: eilenberg-zilber
FILE 24: kan
FILE 25: simplicial-groups
FILE 26: fibrations
FILE 27: loop-spaces
FILE 28: ls-twisted-products
FILE 29: lp-space-efhm
FILE 30: classifying-spaces
FILE 31: k-pi-n
FILE 32: serre
FILE 33: cs-twisted-products
FILE 34: cl-space-efhm
FILE 35: whitehead
FILE 36: smith
#P"C:/Docume~1/Francis/AA/Kenzo/Kenzo-1.1-LispWorks/cat-init.cl"
CL-USER 2 > (load-cfiles)
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\macros.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\various.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\classes.ofasl
;;;
;;; [[ Do not take account of these warnings.
;;; [[ These classes are mutually recursive
;;; [[ and redefinitions are necessary.
;;;
Warning: (DEFCLASS CHAIN-COMPLEX) defined more than once in C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\classes.cl.
Warning: (DEFCLASS MORPHISM) defined more than once in C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\classes.cl.
Warning: (DEFCLASS HOMOTOPY-EQUIVALENCE) defined more than once in C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\classes.cl.
;;;
;;; [[ Defining (METHOD PRINT-OBJECT (LOOP T))
;;; [[ is not at all an error.
;;; [[ LispWorks complains for Loop being an identifier
;;; [[ of the Common-Lisp Package and is afraid we damage the system!
;;; [[ The loops here are the loops of Algebraic Topology
;;; [[ not the iterated loops of standard programming !!!
;;;
Error: Defining (METHOD PRINT-OBJECT (LOOP T)) visible from packages COMMON-LISP, CLOS.
1 (continue) Define it anyway.
2 Discard the new method.
3 Try loading classes.ofasl again.
4 Give up loading classes.ofasl.
5 Try loading another file instead of classes.ofasl.
6 (abort) Return to level 0.
7 Return to top loop level 0.
Type :b for backtrace, :c <option number> to proceed, or :? for other options
;;;
;;; [[ To bypass this claimed "error", answer ":c 1".
;;;
CL-USER 3 : 1 > :c 1
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\combinations.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\chain-complexes.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\chcm-elementary-op.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\effective-homology.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\homology-groups.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\searching-homology.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\cones.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\tensor-products.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\coalgebras.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\cobar.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\algebras.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\bar.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\simplicial-sets.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\simplicial-mrphs.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\delta.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\special-smsts.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\suspensions.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\disk-pasting.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\cartesian-products.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\eilenberg-zilber.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\kan.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\simplicial-groups.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\fibrations.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\loop-spaces.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\ls-twisted-products.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\lp-space-efhm.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\classifying-spaces.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\k-pi-n.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\serre.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\cs-twisted-products.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\cl-space-efhm.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\whitehead.ofasl
; Loading fasl file C:\Docume~1\Francis\AA\Kenzo\Kenzo-1.1-LispWorks\smith.ofasl
("macros" "various" "classes" "combinations" "chain-complexes" "chcm-elementary-op" "effective-homology" "homology-groups" "searching-homology" "cones" ...)
;;;
;;; [[ Now Kenzo is ready.
;;; [[ For example the computing time
;;; [[ for the homology group H_7(\Omega^2 S^3).
;;;
CL-USER 4 > (time (homology (loop-space (sphere 3) 2) 7))
Timing the evaluation of (HOMOLOGY (LOOP-SPACE (SPHERE 3) 2) 7)
Computing boundary-matrix in dimension 7.
Rank of the source-module : 13.
;; Clock -> 2007-02-05, 16h 4m 5s.
Computing the boundary of the generator 1 (dimension 7) :
<<AlLp[7 <<AlLp[2 S3][2 S3][2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 8s.
Computing the boundary of the generator 2 (dimension 7) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][5 <<AlLp[2 S3][2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 8s.
Computing the boundary of the generator 3 (dimension 7) :
<<AlLp[1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][3 <<AlLp[2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 8s.
Computing the boundary of the generator 4 (dimension 7) :
<<AlLp[1 <<AlLp[2 S3]>>][5 <<AlLp[2 S3][2 S3][2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 8s.
Computing the boundary of the generator 5 (dimension 7) :
<<AlLp[3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 8s.
Computing the boundary of the generator 6 (dimension 7) :
<<AlLp[3 <<AlLp[2 S3][2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 8s.
Computing the boundary of the generator 7 (dimension 7) :
<<AlLp[5 <<AlLp[2 S3][2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 8s.
Computing the boundary of the generator 8 (dimension 7) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 8s.
Computing the boundary of the generator 9 (dimension 7) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 8s.
Computing the boundary of the generator 10 (dimension 7) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 8s.
Computing the boundary of the generator 11 (dimension 7) :
<<AlLp[1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 8s.
Computing the boundary of the generator 12 (dimension 7) :
<<AlLp[3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 8s.
Computing the boundary of the generator 13 (dimension 7) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
Computing boundary-matrix in dimension 8.
Rank of the source-module : 21.
;; Clock -> 2007-02-05, 16h 4m 8s.
Computing the boundary of the generator 1 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][7 <<AlLp[2 S3][2 S3][2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 9s.
Computing the boundary of the generator 2 (dimension 8) :
<<AlLp[3 <<AlLp[2 S3][2 S3]>>][5 <<AlLp[2 S3][2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 9s.
Computing the boundary of the generator 3 (dimension 8) :
<<AlLp[5 <<AlLp[2 S3][2 S3][2 S3]>>][3 <<AlLp[2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 9s.
Computing the boundary of the generator 4 (dimension 8) :
<<AlLp[7 <<AlLp[2 S3][2 S3][2 S3][2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 9s.
Computing the boundary of the generator 5 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][5 <<AlLp[2 S3][2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 9s.
Computing the boundary of the generator 6 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][3 <<AlLp[2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 10s.
Computing the boundary of the generator 7 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][5 <<AlLp[2 S3][2 S3][2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 10s.
Computing the boundary of the generator 8 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 10s.
Computing the boundary of the generator 9 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 10s.
Computing the boundary of the generator 10 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][5 <<AlLp[2 S3][2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 10s.
Computing the boundary of the generator 11 (dimension 8) :
<<AlLp[3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 10s.
Computing the boundary of the generator 12 (dimension 8) :
<<AlLp[3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 10s.
Computing the boundary of the generator 13 (dimension 8) :
<<AlLp[3 <<AlLp[2 S3][2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 10s.
Computing the boundary of the generator 14 (dimension 8) :
<<AlLp[5 <<AlLp[2 S3][2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 10s.
Computing the boundary of the generator 15 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 11s.
Computing the boundary of the generator 16 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 11s.
Computing the boundary of the generator 17 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 11s.
Computing the boundary of the generator 18 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 11s.
Computing the boundary of the generator 19 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 11s.
Computing the boundary of the generator 20 (dimension 8) :
<<AlLp[3 <<AlLp[2 S3][2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
;; Clock -> 2007-02-05, 16h 4m 11s.
Computing the boundary of the generator 21 (dimension 8) :
<<AlLp[1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>][1 <<AlLp[2 S3]>>]>>
End of computing.
Homology in dimension 7 :
Component Z/2Z
Component Z/2Z
---done---
;; Clock -> 2007-02-05, 16h 4m 11s.
User time = 6.088
System time = 0.050
Elapsed time = 6.139
Allocation = 123378148 bytes
0 Page faults
NIL
CL-USER 5 > (exit)

BIN
Kenzo-1/Kenzo-Doc.pdf Normal file
View File

Binary file not shown.

39
Kenzo-1/Test.cl Normal file
View File

@ -0,0 +1,39 @@
;;; 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
(kenzo-version)
(time (progn
(cat-init)
(setf s3 (sphere 3))
(homology s3 3)
(setf os3 (loop-space s3))
(homology os3 4)
(setf o2s3 (loop-space os3))
(homology o2s3 5)
(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))
(setf f3 (z-whitehead s3 ch3))
(setf x4 (fibration-total f3))
(homology x4 4)
(setf ch4 (chml-clss x4 4))
(setf f4 (z2-whitehead x4 ch4))
(setf x5 (fibration-total f4))
(homology x5 5)
(setf ch5 (chml-clss x5 5))
(setf f5 (z-whitehead x5 ch5))
(setf x6 (fibration-total f5))
))
(time (homology o2s3 7))
(time (homology x6 6))

98
Kenzo-1/algebras.cl Normal file
View File

@ -0,0 +1,98 @@
;;; ALGEBRAS ALGEBRAS ALGEBRAS ALGEBRAS ALGEBRAS ALGEBRAS
;;; ALGEBRAS ALGEBRAS ALGEBRAS ALGEBRAS ALGEBRAS ALGEBRAS
;;; ALGEBRAS ALGEBRAS ALGEBRAS ALGEBRAS ALGEBRAS ALGEBRAS
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "algebras")
(DEFVAR *ALGB-LIST*)
(SETF *ALGB-LIST* +empty-list+)
(PUSHNEW '*ALGB-LIST* *list-list*)
#+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)))
#+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)))
(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
(let ((already (find orgn *algb-list* :key #'orgn :test #'equal)))
(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))))
(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)))
(DEFVAR *HOPF-LIST*)
(SETF *HOPF-LIST* +empty-list+)
(PUSHNEW '*HOPF-LIST* *list-list*)
#+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)))
#+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)))

719
Kenzo-1/bar.cl Normal file
View File

@ -0,0 +1,719 @@
;;; 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
;;;
;;; MAC-LANE signs (p. 306)
;;;
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "bar")
(DEFUN ABAR (&rest list)
(when (= 1 (length list))
(setf list (first list)))
(unless (evenp (length list))
(error "In ABAR, the length list should be even."))
(the abar
(let ((rslt +empty-list+))
(declare (list rslt))
(do ((mark list (cddr mark)))
((endp mark))
(declare (list mark))
(push (brgn (car mark) (cadr mark)) rslt))
(make-abar :list rslt))))
#|
()
(abar )
(abar '(2 a 3 b))
(abar 2 'a 3 'b)
(abar 2 'a 3)) ;; error
|#
(DEFCONSTANT +NULL-ABAR+ (make-abar :list +empty-list+))
;;; -[CLISP
#|
(DEFMETHOD PRINT-KEYCONS ((car (eql :abar)) cdr stream)
(declare
(list cdr)
(stream stream))
(the abar
(progn
(format stream "<<Abar")
(dolist (brgn cdr)
(declare (type brgn brgn))
(with-brgn (degr gnrt) brgn
(format stream "[~D ~A]" degr gnrt)))
(format stream ">>")
(cons car cdr))))
|#
;;; CLISP]-
;;; +[CLISP
(DEFUN ABAR-PRINT (abar stream depth)
(declare
(type abar abar) (stream stream)
(ignore depth))
(the abar
(progn
(format stream "<<Abar")
(dolist (brgn (abar-list abar))
(declare (type brgn brgn))
(with-brgn (degr gnrt) brgn
(format stream "[~D ~A]" degr gnrt)))
(format stream ">>")
abar)))
;;; CLISP]+
(DEFUN BAR-CMPR (cmpr)
(declare (type cmprf cmpr))
(flet ((rslt (abar1 abar2)
(declare (type abar abar1 abar2))
(the cmpr
(let ((list1 (abar-list abar1))
(list2 (abar-list abar2)))
(declare (list list1 list2))
(lexico
(f-cmpr (length list1) (length list2))
(maplexico
#'(lambda (brgn1 brgn2)
(lexico
(f-cmpr (bdegr brgn1) (bdegr brgn2))
(funcall cmpr (bgnrt brgn1) (bgnrt brgn2))))
list1 list2))))))
(the cmprf #'rslt)))
#|
(setf r (bar-cmpr #'s-cmpr))
(funcall r (abar) (abar))
(funcall r (abar 3 'a) (abar))
(funcall r (abar 3 'a) (abar 2 'a 1 'b))
(funcall r (abar 3 'a) (abar 3 'b))
(funcall r (abar 3 'a) (abar 3 'a)))
|#
(DEFUN BAR-BASIS-LENGTH (basis degr length)
(declare
(type basis basis)
(fixnum degr length))
(the list
(progn
(when (= 1 length)
(return-from bar-basis-length
(mapcar
#'(lambda (item)
(declare (type gnrt item))
(list (brgn degr item)))
(funcall basis (1- degr)))))
(when (< degr 4)
(return-from bar-basis-length +empty-list+))
(mapcan
#'(lambda (degr1)
(declare (fixnum degr1))
(let ((list1 (funcall basis (1- degr1)))
(list2 (bar-basis-length
basis (- degr degr1) (1- length))))
(declare (list list1 list2))
(mapcan
#'(lambda (item1)
(declare (type gnrt item1))
(mapcar
#'(lambda (item2)
(declare (type iabar item2))
(cons (brgn degr1 item1) item2))
list2))
list1)))
(>a-b< 1 (1- degr))))))
#|
()
(setf basis #'(lambda (degr)
(list degr)))
(bar-basis-length basis 2 1)
(bar-basis-length basis 2 2)
(bar-basis-length basis 3 1)
(bar-basis-length basis 3 2)
(bar-basis-length basis 4 1)
(bar-basis-length basis 4 2)
(bar-basis-length basis 4 3)
(bar-basis-length basis 4 4)
(bar-basis-length basis 8 1)
(bar-basis-length basis 8 2)
(bar-basis-length basis 8 3)
(bar-basis-length basis 8 4)
(bar-basis-length basis 8 5)
(bar-basis-length basis 8 6)
(bar-basis-length basis 8 11))
|#
(DEFUN BAR-BASIS (basis)
(declare (type basis basis))
(the basis
(progn
(when (eq :locally-effective basis)
(return-from bar-basis :locally-effective))
(flet
((rslt (degr)
(declare (fixnum degr))
(cond ((zerop degr) (list +null-abar+))
((< degr 2) +empty-list+)
(t
(mapcan
#'(lambda (length)
(declare (fixnum length))
(mapcar
#'(lambda (iabar)
(declare (type iabar iabar))
(make-abar :list iabar))
(bar-basis-length basis degr length)))
(>a-b> 0 (floor degr 2)))))))
#'rslt))))
#|
()
(setf basis #'(lambda (degr)
(list degr)))
(setf r (bar-basis basis))
(funcall r 0)
(funcall r 1)
(funcall r 2)
(dotimes (i 7)
(print (funcall r i)))
(bar-basis :locally-effective))
|#
(DEFUN BAR-INTR-VRTC-DFFR (dffr)
(declare (type morphism dffr))
(labels ((rslt (degr iabar)
;; the argument iabar is an internal algebraic bar,
;; without the keyword :abar
;; rslt returns an internal combination
;; without the keyword :cmbn, without degree
(declare
(fixnum degr)
(type iabar iabar))
(progn
(unless iabar
(return-from rslt +empty-list+))
(let ((brgn1 (first iabar))
(rest2 (rest iabar)))
(declare
(type brgn brgn1)
(type iabar rest2))
(with-brgn (degr1 gnrt1) brgn1
(let ((d-gnrt1 (cmbn-list (gnrt-? dffr (1- degr1) gnrt1)))
(d-rest2 (rslt (- degr degr1) rest2))
(degr1-1 (1- degr1))
(rest-sign (-1-expt-n degr1)))
(declare
(type icmbn d-gnrt1 d-rest2)
(fixnum degr1-1 rest-sign))
(nconc
(mapcar
#'(lambda (term)
(declare (type term term))
(with-term (cffc gnrt) term
(term (- cffc)
(cons (brgn degr1-1 gnrt) rest2))))
d-gnrt1)
(mapcar
#'(lambda (term)
(with-term (cffc gnrt) term
(term (* rest-sign cffc)
(cons brgn1 gnrt))))
d-rest2))))))))
(the intr-mrph
#'(lambda (degr abar)
(declare
(fixnum degr)
(type abar abar))
(make-cmbn
:degr (1- degr)
:list (mapcar
#'(lambda (term)
(with-term (cffc iabar) term
(term cffc (make-abar :list iabar))))
(rslt degr (abar-list abar))))))))
#|
(setf d (soft-delta-infinity))
(setf r (bar-intr-vrtc-dffr (dffr d)))
(funcall r 0 (abar))
(funcall r 3 (abar 3 (d 7)))
(funcall r 5 (abar 3 (d 7) 2 (d 3)))
(funcall r 5 (abar 2 (d 3) 3 (d 7))))
|#
(DEFMETHOD VRTC-BAR ((chcm chain-complex))
(the chain-complex
(with-slots (cmpr basis dffr) chcm
(declare
(type cmprf cmpr)
(type basis basis)
(type morphism dffr))
(build-chcm
:cmpr (bar-cmpr cmpr)
:basis (bar-basis basis)
:bsgn +null-abar+
:intr-dffr (bar-intr-vrtc-dffr dffr)
:strt :gnrt
:orgn `(vrtc-bar ,chcm)))))
#|
(cat-init)
(setf v (vrtc-bar (soft-delta-infinity)))
(defun random-abar (length)
(let ((rslt nil))
(dotimes (i length)
(let* ((gmsm (random (mask 7)))
(dmns (1- (logcount gmsm))))
(when (plusp dmns)
(push (brgn (1+ dmns) (d gmsm)) rslt))))
(make-abar :list rslt)))
(dotimes (i 10) (print (random-abar 5)))
(dotimes (i 10)
(let ((abar (random-abar 3)))
(print abar)
(print (? v (apply #'+ (mapcar #'car (abar-list abar))) abar))
(print (? v (? v (apply #'+ (mapcar #'car (abar-list abar))) abar)))))
|#
(DEFUN BAR-INTR-HRZN-DFFR (aprd)
(declare (type morphism aprd))
(labels ((rslt (degr iabar)
(declare
(fixnum degr)
(type iabar iabar))
(the icmbn
(progn
(unless (cdr iabar)
(return-from rslt +empty-list+))
(let ((brgn1 (first iabar))
(brgn2 (second iabar))
(rest1 (rest iabar))
(rest2 (cddr iabar)))
(declare
(type brgn brgn1 brgn2)
(type iabar rest1 rest2))
(with-brgn (degr1 gnrt1) brgn1
(with-brgn (degr2 gnrt2) brgn2
(let ((sign (-1-expt-n degr1))
(aprd-brgn1-brgn2 (gnrt-? aprd (+ degr1 degr2 -2)
(tnpr (1- degr1) gnrt1
(1- degr2) gnrt2)))
(aprd-rest1 (rslt (- degr degr1) rest1)))
(declare
(type icmbn aprd-brgn1-brgn2 aprd-rest1))
(with-cmbn (degr12 icmbn12) aprd-brgn1-brgn2
(incf degr12)
(nconc
(mapcar
#'(lambda (term2)
(declare (type term term2))
(with-term (cffc2 iabar2) term2
(term (* sign cffc2) (cons brgn1 iabar2))))
aprd-rest1)
(mapcar
#'(lambda (term1)
(declare (type term term1))
(with-term (cffc1 gnrt12) term1
(term (* sign cffc1) (cons (brgn degr12 gnrt12) rest2))))
icmbn12)))))))))))
(the intr-mrph
#'(lambda (degr abar)
(declare
(fixnum degr)
(type abar abar))
(the cmbn
(make-cmbn :degr (1- degr)
:list (mapcar #'(lambda (term)
(declare (type term term))
(with-term (cffc iabar) term
(term cffc (make-abar :list iabar))))
(rslt degr (abar-list abar)))))))))
#|
(setf k (k-z-1))
(setf r (bar-intr-hrzn-dffr (aprd k)))
(funcall r 0 (abar ))
(funcall r 3 (abar 3 '(2 3)))
(funcall r 6 (abar 3 '(2 3) 3 '(-2 -3)))
(funcall r 9 (abar 3 '(2 3) 3 '(-2 -3) 3 '(2 3)))
(funcall r 11 (abar 3 '(2 3) 3 '(-2 -3) 2 '(-2) 3 '(-2 -3))))
|#
(DEFUN BAR-HRZN-DFFR (algb)
(declare (type algebra algb))
(the morphism
(with-slots (aprd) algb
(declare (type morphism aprd))
(build-mrph
:sorc (vrtc-bar algb) :trgt (vrtc-bar algb) :degr -1
:intr (bar-intr-hrzn-dffr aprd) :strt :gnrt
:orgn `(bar-hrzn-dffr ,algb)))))
#|
(cat-init)
(setf h (bar-hrzn-dffr (k-z-1)))
(defun random-abar (tot-degr~ max-degr)
(do ((rslt nil)
(cum-degr 0 (+ cum-degr degr 1))
(degr))
((>= cum-degr tot-degr~) (make-abar :list rslt))
(setf degr (1+ (random max-degr)))
(push (brgn (1+ degr)
(let ((list (make-list degr)))
(mapl
#'(lambda (sublist)
(setf (car sublist) (- (random 21) 10)))
list)
list))
rslt)))
(dotimes (i 10) (print (random-abar 10 5)))
(setf abar (random-abar 10 5))
(? h (apply #'+ (mapcar #'car (abar-list abar))) abar)
(? h (? h (apply #'+ (mapcar #'car (abar-list abar))) abar))
(dotimes (i 10)
(let ((abar (random-abar 10 3)))
(print abar)
(print (? h (apply #'+ (mapcar #'car (abar-list abar))) abar))
(print (? h (? h (apply #'+ (mapcar #'car (abar-list abar))) abar)))))
|#
(DEFUN BAR-INTR-DFFR (vrtc-dffr hrzn-dffr)
(declare (type morphism vrtc-dffr hrzn-dffr))
(flet ((rslt (degr abar)
(declare
(fixnum degr)
(type abar abar))
(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-? hrzn-dffr degr abar))
(cmbn-list (gnrt-? vrtc-dffr degr abar))))))
(the intr-mrph #'rslt)))
(DEFMETHOD BAR ((algebra algebra))
(let ((vrtc-bar (vrtc-bar algebra))
(bar-hrzn-dffr (bar-hrzn-dffr algebra)))
(declare (type chain-complex vrtc-bar)
(type morphism bar-hrzn-dffr))
(the chain-complex
(let ((rslt (build-chcm
:cmpr (cmpr vrtc-bar)
:basis (basis vrtc-bar)
:bsgn +null-abar+
:intr-dffr (bar-intr-dffr (dffr vrtc-bar) bar-hrzn-dffr)
:strt :gnrt
:orgn `(add ,vrtc-bar ,bar-hrzn-dffr))))
(declare (type chain-complex rslt))
(setf (slot-value rslt 'grmd) (grmd vrtc-bar))
rslt))))
#|
(cat-init)
(setf b (bar (k-z-1)))
(defun random-abar (tot-degr~ max-degr)
(do ((rslt nil)
(cum-degr 0 (+ cum-degr degr 1))
(degr))
((>= cum-degr tot-degr~) (make-abar :list rslt))
(setf degr (1+ (random max-degr)))
(push (brgn (1+ degr)
(let ((list (make-list degr)))
(mapl
#'(lambda (sublist)
(setf (car sublist) (- (random 21) 10)))
list)
list))
rslt)))
(setf abar (random-abar 10 3))
(? b (apply #'+ (mapcar #'car (abar-list abar))) abar)
(? b (? b (apply #'+ (mapcar #'car (abar-list abar))) abar))
(dotimes (i 10)
(let ((abar (random-abar 10 3)))
(print abar)
(print (? b (apply #'+ (mapcar #'car (abar-list abar))) abar))
(print (? b (? b (apply #'+ (mapcar #'car (abar-list abar))) abar)))))
|#
(DEFUN CMBN-ABAR-CMBN-TNPR (cmbn abar-cmbn)
(declare (type cmbn cmbn abar-cmbn))
(the cmbn
(with-cmbn (degr1 list1) cmbn
(incf degr1) ;; because abar organization
(with-cmbn (degrr listr) abar-cmbn
(make-cmbn
:degr (+ degr1 degrr)
:list
(mapcan
#'(lambda (term1)
(declare (type term term1))
(with-term (cffc1 gnrt1) term1
(let ((brgn1 (brgn degr1 gnrt1)))
(declare (type brgn brgn1))
(mapcar
#'(lambda (termr)
(declare (type term termr))
(with-term (cffcr abarr) termr
(term (* cffc1 cffcr)
(make-abar
:list (cons brgn1 (abar-list abarr))))))
listr))))
list1))))))
(DEFUN NCMBN-BAR (cmbn-list)
(declare (list cmbn-list))
(the cmbn
(progn
(unless cmbn-list
(return-from ncmbn-bar (cmbn 0 1 +null-abar+)))
(cmbn-abar-cmbn-tnpr
(first cmbn-list)
(ncmbn-bar (rest cmbn-list))))))
#|
(ncmbn-bar nil)
(ncmbn-bar (list (cmbn 3 2 'a 3 'b)))
(ncmbn-bar (list (cmbn 1 2 'a 3 'b) (cmbn 2 4 'c 5 'd)))
(ncmbn-bar (list (cmbn 1 2 'a 3 'b) (cmbn 1 4 'c 5 'd) (cmbn 1 6 'e 7 'f))))
|#
(DEFUN MRPH-VRTC-BAR-INTR (mrph)
(declare (type morphism mrph))
(flet ((rslt (degr abar)
(declare
(ignore degr)
(type abar abar))
(the cmbn
(ncmbn-bar
(mapcar #'(lambda (brgn)
(declare (type brgn brgn))
(with-brgn (degr gnrt) brgn
(gnrt-? mrph (1- degr) gnrt)))
(abar-list abar))))))
(the intr-mrph #'rslt)))
#|
(setf cc (build-chcm :cmpr #'f-cmpr :strt :cmbn))
(setf m (build-mrph :sorc cc :trgt cc :degr 0 :intr
#'(lambda (degr gnrt) (cmbn degr 2 gnrt 3 (1+ gnrt)))
:strt :gnrt :orgn '(test)))
(setf r (mrph-vrtc-bar-intr m))
(funcall r 4 (abar 2 3 2 4))
|#
(DEFMETHOD VRTC-BAR ((mrph morphism))
(the morphism
(if (eq (first (orgn mrph)) 'idnt-mrph)
(idnt-mrph (vrtc-bar (sorc mrph)))
(build-mrph
:sorc (vrtc-bar (sorc mrph))
:trgt (vrtc-bar (trgt mrph))
:degr 0
:intr (mrph-vrtc-bar-intr mrph)
:strt :gnrt
:orgn `(vrtc-bar ,mrph)))))
#|
(cat-init)
(setf f (aw (soft-delta-infinity) (soft-delta-infinity)))
(setf cf (vrtc-bar f))
(? cf 6 (abar 3 (crpr 0 (d 7) 0 (d 7)) 3 (crpr 0 (d 56) 0 (d 56))))
|#
(DEFUN HMTP-VRTC-BAR-INTR (h gf)
(declare (type morphism h gf))
(labels ((rslt (degr iabar)
(declare
(fixnum degr)
(type iabar iabar))
(unless iabar
(return-from rslt +empty-list+))
(let ((brgn1 (first iabar))
(rest2 (rest iabar)))
(declare
(type brgn brgn1)
(list rest2))
(with-brgn (degr1 gnrt1) brgn1
(let ((h-gnrt1 (cmbn-list (gnrt-? h (1- degr1) gnrt1)))
(h-rest2 (rslt (- degr degr1) rest2))
(degr1+1 (1+ degr1))
(rest-sign (-1-expt-n degr1))
(gf-gnrt1 (cmbn-list (gnrt-? gf (1- degr1) gnrt1))))
(declare
(fixnum degr1+1 rest-sign)
(type icmbn h-gnrt1 h-rest2 gf-gnrt1))
(nconc
(mapcan
#'(lambda (term1)
(declare (type term term1))
(with-term (cffc1 gnrt11) term1
(mapcar
#'(lambda (term2)
(declare (type term term2))
(with-term (cffc2 iabar2) term2
(term (* rest-sign cffc1 cffc2)
(cons (brgn degr1 gnrt11) iabar2))))
h-rest2)))
gf-gnrt1)
(mapcar
#'(lambda (term1)
(declare (type term term1))
(with-term (cffc1 gnrt11) term1
(term (- cffc1)
(cons (brgn degr1+1 gnrt11) rest2))))
h-gnrt1)))))))
(the intr-mrph
#'(lambda (degr abar)
(declare
(fixnum degr)
(type abar abar))
(make-cmbn
:degr (1+ degr)
:list (mapcar
#'(lambda (term)
(declare (type term term))
(with-term (cffc iabar) term
(declare
(fixnum cffc)
(type iabar iabar))
(term cffc (make-abar :list iabar))))
(rslt degr (abar-list abar))))))))
#|
(cat-init)
(setf ez (ez (delta-infinity) (delta-infinity)))
(setf h (h ez) gf (cmps (g ez) (f ez)))
(setf r (hmtp-vrtc-bar-intr h gf))
(funcall r 3 (abar 3 (crpr 0 7 0 7)))
(funcall r 9 (abar 3 (crpr 0 7 0 7) 3 (crpr 0 14 0 14) 3 (crpr 0 14 0 14)))
|#
(DEFUN HMTP-VRTC-BAR (h gf)
(declare (type morphism h gf))
(unless (and (= +1 (degr h))
(= +0 (degr gf)))
(error "In HMTP-VRTC-BAR, 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)))
(error "In HMTP-VRTC-BAR, fg-h sources and targets are not the same."))
(the morphism
(if (eq (first (orgn h)) 'zero-mrph)
(zero-mrph (vrtc-bar (sorc h)))
(build-mrph
:sorc (vrtc-bar (sorc h)) :trgt (vrtc-bar (sorc h)) :degr +1
:intr (hmtp-vrtc-bar-intr h gf)
:strt :gnrt
:orgn `(hmtp-vrtc-bar ,h ,gf)))))
(DEFMETHOD VRTC-BAR ((rdct reduction))
(the reduction
(if (eq (first (orgn rdct)) 'trivial-rdct)
(trivial-rdct (vrtc-bar (bcc rdct)))
(with-slots (f g h) rdct
(build-rdct
:f (vrtc-bar f)
:g (vrtc-bar g)
:h (hmtp-vrtc-bar h (cmps g f))
:orgn `(vrtc-bar ,rdct))))))
#|
(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)))
(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)))
(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)))
(setf g (build-mrph :sorc bcc :trgt tcc :degr 0
: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)))
(setf rdct (build-rdct :f f :g g :h h :orgn '(rdct)))
(tcc rdct 3 'a)
(g rdct (f rdct 3 'a))
(h rdct 3 'a)
(setf bar (vrtc-bar rdct))
(pre-check-rdct bar)
(defun aleat-tc ()
(do ((tdegr 0 (+ tdegr degr))
(degr (+ 2 (random 3)) (+ 2 (random 3)))
(gnrt (intern (coerce (vector (code-char (+ 65 (random 4)))) 'string))
(intern (coerce (vector (code-char (+ 65 (random 4)))) 'string)))
(rslt nil (cons (brgn degr gnrt) rslt)))
((> tdegr 10) (setf *tc* (cmbn tdegr 1 (make-abar :list rslt))))))
(aleat-tc)
(defun aleat-bc ()
(do ((tdegr 0 (+ tdegr degr))
(degr (+ 2 (random 3)) (+ 2 (random 3)))
(gnrt (intern (coerce (vector (code-char (+ 67 (random 2)))) 'string))
(intern (coerce (vector (code-char (+ 67 (random 2)))) 'string)))
(rslt nil (cons (brgn degr gnrt) rslt)))
((> tdegr 10) (setf *bc* (cmbn tdegr 1 (make-abar :list rslt))))))
(aleat-bc)
(defun c ()
(aleat-tc)
(aleat-bc)
(check-rdct))
(loop (c)) ;; degrees >= 15 is possible => error.
|#
(DEFMETHOD VRTC-BAR ((hmeq homotopy-equivalence))
(the homotopy-equivalence
(if (eq (first (orgn hmeq)) 'trivial-hmeq)
(trivial-hmeq (vrtc-bar (lbcc hmeq)))
(with-slots (lrdct rrdct) hmeq
(build-hmeq
:lrdct (vrtc-bar lrdct)
:rrdct (vrtc-bar rrdct)
:orgn `(vrtc-bar ,hmeq))))))
(DEFMETHOD BAR ((hmeq homotopy-equivalence))
(unless (typep (lbcc hmeq) 'algebra)
(error "In (BAR HMEQ), the LBCC should be a algebra."))
(the homotopy-equivalence
(if (eq (first (orgn hmeq)) 'trivial-hmeq)
(trivial-hmeq (bar (lbcc hmeq)))
(add (vrtc-bar hmeq) (bar-hrzn-dffr (lbcc hmeq))))))
#|
(cat-init)
(setf h (efhm (k-z-1)))
(setf b (bar h))
(inspect b)
(homology (rbcc b) 0 11)
|#

444
Kenzo-1/bicones.cl Normal file
View File

@ -0,0 +1,444 @@
;;; BICONES BICONES BICONES BICONES BICONES BICONES BICONES BICONES
;;; BICONES BICONES BICONES BICONES BICONES BICONES BICONES BICONES
;;; BICONES BICONES BICONES BICONES BICONES BICONES BICONES BICONES
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "bicones")
(DEFUN DISPATCH-BICN-CMBN (cmbn)
(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)))))))
#|
()
(dispatch-bicn-cmbn (cmbn 3 3 (bcnb 'b1) 4 (bcnb 'b2) 33 (bcnc 'c) 333 (bcnd 'd)))
|#
(DEFUN BICN-CMBN-CMBNB (cmbn)
(declare (type cmbn cmbn))
(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))))))))))
(DEFUN BICN-CMBN-CMBNC (cmbn)
(declare (type cmbn cmbn))
(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))))))))))
(DEFUN BICN-CMBN-CMBND (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 bicn) term
(term cffc (ibicn bicn))))
(member :bcnd list
:key #'(lambda (term)
(declare (type term term))
(the keyword (bcnx (gnrt term))))))))))
#|
()
(bicn-cmbn-cmbnb (cmbn 3 1 (bcnb 'a) 2 (bcnc 'b)))
(bicn-cmbn-cmbnb (cmbn 3 2 (bcnc 'b)))
(bicn-cmbn-cmbnc (cmbn 3 1 (bcnb 'a) 2 (bcnc 'b) 3 (bcnd 'c)))
(bicn-cmbn-cmbnc (cmbn 3 1 (bcnb 'a) 3 (bcnd 'c)))
(bicn-cmbn-cmbnd (cmbn 3 1 (bcnb 'a) 2 (bcnc 'b) 3 (bcnd 'c)))
(bicn-cmbn-cmbnd (cmbn 3 2 (bcnb 'b)))
|#
(DEFUN MAKE-BICN-CMBN (cmbnb cmbnc cmbnd)
(declare (type cmbn cmbnb cmbnc cmbnd))
(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))))))))
#|
()
(multiple-value-call #'make-bicn-cmbn
(dispatch-bicn-cmbn (cmbn 3 3 (bcnb 'b1) 4 (bcnb 'b2) 33 (bcnc 'c) 333 (bcnd 'd))))
|#
(DEFUN BICN-PRINT (bicn stream depth)
(declare
(type bicn bicn) (stream stream)
(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)))
#|
()
(bcnb 'a)
(bcnc 'b)
(bcnd 'c)
|#
(DEFUN BICONE-CMPR (cmprb cmprc cmprd)
(declare (type cmprf cmprb cmprc 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))))))))
(the cmprf #'rslt)))
#|
()
(setf r (bicone-cmpr #'f-cmpr #'f-cmpr #'f-cmpr))
(funcall r (bcnb 1) (bcnc 0))
(funcall r (bcnb 1) (bcnb 2))
|#
(DEFUN BICONE-BASIS (basisb basisc basisd)
(declare (type basis basisb basisc basisd))
(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)))))
#|
()
(bicone-basis :locally-effective :locally-effective :locally-effective)
(setf b #'(lambda (degr) (mapcar #'(lambda (item) (cons degr item)) (<a-b> 0 degr))))
(setf r (bicone-basis b b b))
(funcall r 3)
|#
(DEFUN BICONE-INTR-DFFR (cmprc dffrb dffrc dffrd f1 f2)
(declare
(type cmprf cmprc)
(type morphism dffrb dffrc dffrd f1 f2))
(flet ((rslt (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)))))))
(the intr-mrph #'rslt)))
(DEFUN BICONE (rdct1 rdct2)
(declare (type reduction rdct1 rdct2))
(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 tcc2 bcc2)
(type morphism f2))
(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))
:bsgn :undefined
:intr-dffr (bicone-intr-dffr (cmpr bcc1)
(dffr tcc1) (dffr bcc1) (dffr tcc2)
f1 f2)
:strt :cmbn
:orgn `(bicone ,rdct1 ,rdct2))))
(declare (type chain-complex rslt))
; (slot-makunbound rslt 'bsgn)
rslt)))))
#|
()
(cat-init)
(progn
(defun cdelta (dmns)
(build-chcm
:cmpr #'l-cmpr
:basis #'(lambda (n)
(mapcar #'dlop-int-ext (funcall (delta-n-basis dmns) n)))
:bsgn '(0)
:intr-dffr #'(lambda (degr gmsm)
(make-cmbn
:degr (1- degr)
:list (do ((rslt +empty-list+
(cons (cons sign (append
(subseq gmsm 0 nark)
(subseq gmsm (1+ nark))))
rslt))
(sign 1 (- sign))
(nark 0 (1+ nark)))
((> nark degr) rslt))))
:strt :gnrt
:orgn `(locally effective version of C_* delta ,dmns)))
(defun make-f (tdmns bdmns)
(build-mrph
:sorc (cdelta tdmns) :trgt (cdelta bdmns) :degr 0
:intr #'(lambda (degr gmsm)
(let ((pos (position-if #'(lambda (vertex) (>= vertex bdmns)) gmsm)))
(if pos
(if (< pos degr)
(zero-cmbn degr)
(cmbn degr 1 (nconc (butlast gmsm) (list bdmns))))
(cmbn degr 1 gmsm))))
:strt :gnrt
:orgn `(projection delta ,tdmns => delta ,bdmns)))
(defun make-g (tdmns bdmns)
(build-mrph
:sorc (cdelta bdmns) :trgt (cdelta tdmns) :degr 0
:intr #'identity
:strt :cmbn
:orgn `(injection delta ,bdmns => delta ,tdmns)))
(defun make-h (tdmns bdmns)
(build-mrph
:sorc (cdelta tdmns) :trgt (cdelta tdmns) :degr +1
:intr #'(lambda (degr gmsm)
(let ((pos (position-if #'(lambda (vertex) (>= vertex bdmns)) gmsm)))
(if pos
(if (member bdmns gmsm)
(zero-cmbn (1+ degr))
(cmbn (1+ degr) (-1-expt-n pos)
(append (subseq gmsm 0 pos) (list bdmns) (subseq gmsm pos))))
(zero-cmbn (1+ degr)))))
:strt :gnrt
:orgn `(homotopy for delta ,tdmns => ,bdmns)))
(defun make-rdct (tdmns bdmns)
(setf rdct (build-rdct
:f (make-f tdmns bdmns)
:g (make-g tdmns bdmns)
:h (make-h tdmns bdmns)
:orgn `(reduction delta ,tdmns ,bdmns)))))
(setf b (bicone (make-rdct 3 2) (make-rdct 4 2)))
(basis b 1)
(? b (cmbn 1 3 (bcnb '(0 3)) 4 (bcnc '(0 1 2)) 5 (bcnd '(0 4))))
|#
(DEFMETHOD CMPS ((hmeq1 homotopy-equivalence) (hmeq2 homotopy-equivalence) &optional dummy)
(declare (ignore dummy))
(the homotopy-equivalence
(progn
(when (eq 'trivial-hmeq (orgn hmeq2))
(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))
(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)))
(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)))
(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)))
(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)))
(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)))
(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)))
(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)))))))))
#|
()
(cat-init)
(setf c (build-chcm
:cmpr #'s-cmpr
:basis #'(lambda (dmns) '(a))
:bsgn 'a
:intr-dffr #'zero-intr-dffr
:strt :cmbn
:orgn '(c)))
(setf h1 (trivial-hmeq c))
(setf h2 (cmps h1 h1))
(pre-check-rdct (lrdct h2))
(setf *tc* (cmbn 3 1 (bcnB 'a) 10 (bcnC 'a) 100 (bcnD 'a)))
(setf *bc* (cmbn 3 1 'a))
(check-rdct)
(pre-check-rdct (rrdct h2))
(check-rdct)
(setf h3 (cmps h2 h2))
(setf *tc* (cmbn 3 1 (bcnB (bcnB 'a)) 10 (bcnB (bcnC 'a)) 100 (bcnB (bcnD 'a))
1000 (bcnC 'a)
10000 (bcnD (bcnB 'a)) 5234 (bcnD (bcnC 'a)) 223 (bcnD (bcnD 'a))))
(pre-check-rdct (lrdct h3))
(check-rdct)
(pre-check-rdct (rrdct h3))
(check-rdct)
|#

326
Kenzo-1/cartesian-products.cl Normal file
View File

@ -0,0 +1,326 @@
;;; CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS
;;; CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS
;;; CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "cartesian-products")
(DEFUN CRPR-PRINT (crpr stream depth)
(declare
(type crpr crpr)
(stream stream)
(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)
crpr))
(DEFUN EXTRACT-COMMON-DGOP (dgop1 dgop2)
(declare (fixnum dgop1 dgop2))
(let ((dgop (logand dgop1 dgop2)))
(declare (fixnum dgop))
(do ((indx (1- (integer-length dgop)) (1- indx)))
((minusp indx))
(declare (fixnum indx))
(when (logbitp indx dgop)
(setf dgop1 (remove-bit dgop1 indx)
dgop2 (remove-bit dgop2 indx))))
(values dgop dgop1 dgop2)))
#|
(dotimes (i 100)
(dotimes (j 100)
(multiple-value-bind (dgop dgop1 dgop2) (extract-common-dgop i j)
(unless (and (= i (dgop*dgop dgop dgop1))
(= j (dgop*dgop dgop dgop2)))
(error "i = ~D, j = ~D, dgop = ~D, dgop1 = ~D, dgop2 = ~D"
i j dgop dgop1 dgop2)))))
|#
(DEFUN 2ABSM-ACRPR (absm1 absm2)
(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)))))))
#|
(2absm-acrpr (absm 5 'a) (absm 3 'b))
|#
#|
(DEFUN CRTS-PRDC-CMPR (cmpr1 cmpr2)
(declare (type cmprf cmpr1 cmpr2))
(flet ((rslt (crpr1 crpr2)
(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)))))))))
(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))))))
(the cmprf #'rslt)))
#|
()
(setf c (cmpr (delta-infinity)))
(setf rslt (crts-prdc-cmpr c c))
(funcall rslt (crpr 0 3 0 3) (crpr 1 1 0 3))
(funcall rslt (crpr 4 3 0 7) (crpr 3 1 0 7))
(funcall rslt (crpr 0 3 0 3) (crpr 0 3 1 1))
(funcall rslt (crpr 0 3 0 3) (crpr 0 5 0 3))
(funcall rslt (crpr 0 3 0 3) (crpr 0 3 0 5))
(funcall rslt (crpr 0 3 0 3) (crpr 0 3 0 3)))
|#
(DEFUN CRTS-PRDC-BASIS (basis1 basis2)
(declare (type basis basis1 basis2))
(when (or (eq basis1 :locally-effective)
(eq basis2 :locally-effective))
(return-from crts-prdc-basis :locally-effective))
(flet ((rslt (dmns)
(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)))))
(the basis #'rslt)))
#|
(setf b (basis (delta 1)))
(setf r (crts-prdc-basis b b))
(funcall r 0)
(funcall r 1)
(funcall r 2)
(funcall r 3)
(setf d3 (basis (delta 3)))
(setf r (crts-prdc-basis d3 d3))
(time (dotimes (i 7)
(print (length (funcall r i)))))
(setf s3 (basis (sphere 3)))
(setf p (crts-prdc-basis s3 s3))
(dotimes (i 8)
(print (funcall p i)))
|#
(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 dgop dgop1 dgop2))
(absm dgop (crpr dgop1 gmsm1 dgop2 gmsm2))))))))
(the face #'rslt)))
#|
(setf d2 (delta 2))
(setf b2 (basis d2))
(setf f2 (face d2))
(setf b (crts-prdc-basis b2 b2))
(setf r (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))))))
|#
(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)))))))
(the intr-mrph #'rslt)))
#|
(setf d2 (delta 2))
(setf b2 (basis d2))
(setf f2 (face d2))
(setf b (crts-prdc-basis b2 b2))
(setf r (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))))))
(setf s3 (sphere 3))
(setf b3 (basis s3))
(setf f3 (face s3))
(setf b (crts-prdc-basis b3 b3))
(setf r (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))))))
|#
(DEFUN CRTS-PRDC (smst1 smst2)
(declare (type simplicial-set smst1 smst2))
(with-slots ((cmpr1 cmpr) (basis1 basis) (face1 face) (bspn1 bsgn)) smst1
(declare
(type cmprf cmpr1)
(type basis basis1)
(type face face1))
(with-slots ((cmpr2 cmpr) (basis2 basis) (face2 face) (bspn2 bsgn)) smst2
(declare
(type cmprf cmpr2)
(type basis basis2)
(type face face2))
(the simplicial-set
(build-smst
:cmpr (crts-prdc-cmpr cmpr1 cmpr2)
:basis (crts-prdc-basis basis1 basis2)
:bspn (crpr 0 bspn1 0 bspn2)
:face (crts-prdc-face face1 face2)
:face* (crts-prdc-face* face1 face2)
:orgn `(crts-prdc ,smst1 ,smst2))))))
#|
(setf p (crts-prdc (delta 3) (delta 3)))
(? p 0 (crpr 0 1 0 2))
(? p 1 (crpr 0 3 0 3))
(? p 2 (crpr 0 7 0 7))
(? p 3 (crpr 0 15 0 15))
(? p 4 (crpr 1 15 2 15))
|#
#|
;; For comparison with EAT.
;; In CAT.
(setf s5 (sphere 5))
(setf p (crts-prdc s5 s5))
(setf b (basis p))
(setf d (bndr p))
(setf basis (funcall b 10))
(length basis)
(setf c (make-cmbn :degr 10 :list (mapcar #'(lambda (item)
(term (1+ (random 5)) item))
basis)))
(setf +too-much-time+ -1)
(cmbn-? d (cmbn-? d c))
(time (dotimes (i 5) (cmbn-? d (cmbn-? d c))))
|#
#|
;; In EAT.
(setf s5 (sphere 5))
(setf p (cpr-2ss s5 s5))
(setf d (cc-d (ss-cc p)))
(setf basis (sbs p 10))
(length basis)
(setf c (make-cmb :dgr 10 :lst (mapcar #'(lambda (item)
(mnm (1+ (random 5)) item))
basis)))
(??? d (??? d c))
(time (dotimes (i 5) (??? d (??? d c))))
|#

86
Kenzo-1/cat-init.cl Normal file
View File

@ -0,0 +1,86 @@
;;; 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
(IN-PACKAGE "COMMON-LISP-USER")
(DEFUN KENZO-VERSION ()
(format t "~%*** Kenzo-Version 1.1.7 ***~2%")
(values))
(PROCLAIM '(OPTIMIZE (speed 3) (safety 1) (space 0) (debug 0)))
(DEFCONSTANT +FILE-LIST+
'("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)))
(DEFCONSTANT +SOURCE-EXTENSION+
#+(or allegro clisp lispworks) "cl"
#-(or allegro clisp lispworks)
(error "Not an Allegro or CLisp or LispWorks environment."))
(DEFCONSTANT +COMPILED-EXTENSION+
#+allegro "fasl"
#+clisp "fas"
#+lispworks "ofasl")
(DEFUN LOAD-SFILES ()
(mapc #'(lambda (file-name)
(load (concatenate 'string file-name "." +source-extension+)))
+file-list+))
(DEFVAR *CMBN-CONTROL*)
(SETF *CMBN-CONTROL* T)
(DEFUN COMPILE-FILES ()
(format t "~%*CMBN-CONTROL* = ~A~2%" *cmbn-control*)
(mapc #'(lambda (file-name)
(compile-file (concatenate 'string file-name "." +source-extension+))
(load (concatenate 'string file-name "." +compiled-extension+)))
+file-list+))
(DEFUN LOAD-CFILES ()
(mapc #'(lambda (file-name)
(load (concatenate 'string file-name "." +compiled-extension+)))
+file-list+))

605
Kenzo-1/chain-complexes.cl Normal file
View File

@ -0,0 +1,605 @@
;;; CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES
;;; CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES
;;; CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "chain-complexes")
(DEFVAR *LIST-LIST* +empty-list+)
(DEFUN CAT-INIT ()
(declare (special *idnm-counter* *results-n* *results-cmlt-tm*))
(setf *idnm-counter* 0 *results-n* 0 *results-cmlt-tm* 0.0)
(map nil #'(lambda (listname)
(declare (symbol listname))
(setf (symbol-value listname) +empty-list+))
*list-list*)
(done))
(DEFUN HOW-MANY-OBJECTS ()
(mapc #'(lambda (symbol)
(declare (type (or string symbol) symbol))
(let ((length (length (eval symbol))))
(declare (fixnum length))
(setf symbol (symbol-name symbol))
(setf symbol (subseq symbol 1 (- (length symbol) 6)))
(format t "~%~6D ~As" length symbol)))
*list-list*)
(done))
(DEFUN ALL-OBJECTS ()
(let ((object-list
(sort (delete-duplicates
(mapcan #'(lambda (symbol)
(copy-list (eval symbol)))
*list-list*)
:test #'eq)
#'< :key #'idnm)))
(declare (list object-list))
(dolist (item object-list)
(format t "~%~A = ~A" item (orgn item))))
(done))
(DEFUN KD (idnm)
(declare (fixnum idnm))
(dolist (list *list-list*)
(let ((found (find idnm (eval list) :key #'idnm)))
(when found
(format t "~%Object: ~A
~3TOrigin: ~A~2%" found (orgn found))
(return-from kd (values))))))
(DEFUN K (idnm)
(declare (fixnum idnm))
(dolist (list *list-list*)
(let ((found (find idnm (eval list) :key #'idnm)))
(when found
(return-from k found)))))
(DEFUN KD2 (idnm)
(declare (fixnum idnm))
(let ((k-list (k idnm)))
(declare (list k-list))
(unless k-list
(return-from kd2 nil))
(setf k-list (list k-list))
(do ((idnm (1- idnm) (1- idnm)))
((zerop idnm))
(declare (fixnum idnm))
(let ((found (find-if
#'(lambda (item)
(declare (type (or chain-complex morphism) item))
(member (k idnm) (orgn item)))
k-list)))
(declare (type (or null chain-complex morphism) found))
(when found
(push (k idnm) k-list))))
(mapc #'kd (nreverse (mapcar #'idnm k-list)))))
(DEFVAR *CHCM-LIST*)
(SETF *CHCM-LIST* +empty-list+)
(PUSHNEW '*CHCM-LIST* *list-list*)
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) nil))
(DEFMETHOD PRINT-OBJECT ((chcm chain-complex) stream)
(the chain-complex
(progn
(format stream "[K~D Chain-Complex]" (idnm chcm))
chcm)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t))
(DEFUN CHCM (idnm)
(declare (fixnum idnm))
(the (or chain-complex null)
(find idnm *chcm-list* :key #'idnm)))
(DEFUN RESULT-PRINT (result stream depth)
(declare
(type result result) (stream stream)
(ignore depth))
(format stream "~%<Rslt>
~4TGNRT-> ~A
~3TVALUE-> ~A
~4TCLNM-> ~6D
~4TRNTM-> ~11,3F"
(result-gnrt result) (result-value result)
(result-clnm result) (result-rntm result))
result)
#|
()
(make-result :gnrt 'a :value '(a a) :clnm 23 :rntm 2.345)
|#
(DEFPARAMETER +MAXIMAL-DIMENSION+ 15)
(DEFVAR *MRPH-LIST*)
(SETF *MRPH-LIST* +empty-list+)
(PUSHNEW '*MRPH-LIST* *list-list*)
(DEFMETHOD ?2 ((mrph morphism) cmbn)
(declare (type cmbn cmbn))
(the cmbn
(cmbn-? mrph cmbn)))
(DEFMETHOD ?2 ((chcm chain-complex) cmbn)
(declare
(type cmbn cmbn))
(the cmbn
(cmbn-? (dffr1 chcm) cmbn)))
(DEFMETHOD ?3 ((mrph morphism) degr gnrt)
(declare
(fixnum degr)
(type gnrt gnrt))
(the cmbn
(gnrt-? mrph degr gnrt)))
(DEFMETHOD ?3 ((chcm chain-complex) degr gnrt)
(declare
(fixnum degr)
(type gnrt gnrt))
(gnrt-? (dffr1 chcm) degr gnrt))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) nil))
(DEFMETHOD PRINT-OBJECT ((mrph morphism) stream)
(the morphism
(progn
(if (eq (first (orgn (trgt mrph))) 'z-chcm)
(format stream "[K~D Cohomology-Class on K~D of degree ~D]"
(idnm mrph) (idnm (sorc mrph)) (- (degr mrph)))
(format stream "[K~D Morphism (degree ~D): K~D -> K~D]"
(idnm mrph) (degr mrph)
(idnm (sorc mrph)) (idnm (trgt mrph))))
mrph)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t))
(DEFUN MRPH (n)
(declare (fixnum n))
(the (or morphism null)
(find n *mrph-list* :key #'idnm)))
(DEFUN BUILD-CHCM (&key cmpr basis bsgn intr-dffr strt orgn)
(declare
(type cmprf cmpr)
(type basis basis)
(type gnrt bsgn)
(type intr-mrph intr-dffr)
(type strt strt)
(type list orgn))
(the chain-complex
(progn
(let ((already (find orgn *chcm-list* :test #'equal :key #'orgn)))
(declare (type (or chain-complex null) already))
(when already
(return-from build-chcm already)))
(unless basis
(setf basis :locally-effective))
(let ((chcm (make-instance 'chain-complex
:cmpr cmpr
:basis basis
:bsgn bsgn
:orgn orgn)))
(declare (type chain-complex chcm))
(setf (slot-value chcm 'dffr)
(build-mrph
:sorc chcm :trgt chcm :degr -1
:intr intr-dffr :strt strt
:orgn `(dffr ,chcm)))
(setf (slot-value chcm 'grmd) chcm)
(push chcm *chcm-list*)
chcm))))
(DEFUN BASIS2 (object n) ;;;
(declare
(type t object)
(fixnum n))
(the list
(with-slots (basis) object
(declare (type basis basis))
(when (eq :locally-effective basis)
(error "The object ~A is locally-effective." object))
(funcall basis n))))
(DEFUN BUILD-MRPH (&key sorc trgt degr intr strt orgn)
(declare
(type chain-complex sorc trgt)
(fixnum degr)
(type intr-mrph intr)
(type strt strt)
(list orgn))
(the morphism
(progn
(let ((already (find orgn *mrph-list* :test #'equal :key #'orgn)))
(declare (type (or morphism null) already))
(when already
(return-from build-mrph already)))
(let ((mrph (make-instance 'morphism
:sorc sorc :trgt trgt :degr degr
:intr intr :strt strt
:orgn orgn)))
(declare (type morphism mrph))
(setf (slot-value mrph 'rslts)
(ecase strt
(:gnrt (map 'simple-vector
;; (vector (vector result))
#'(lambda (dummy)
(declare (ignore dummy))
(make-array 0
:adjustable t
:fill-pointer 0))
(make-list +maximal-dimension+)))
(:cmbn nil)))
(push mrph *mrph-list*)
mrph))))
;;; FUNCTIONS
(DEFVAR *START-STACK* +empty-list+)
(DEFPARAMETER +TOO-MUCH-TIME+ -1)
(DEFVAR *RESULTS-MAX* (expt 10 5))
(DEFVAR *RESULTS-COEF* 3.0)
(DEFVAR *RESULTS-CMLT-TM* 0.0)
(DEFVAR *RESULTS-N* 0)
(DEFVAR *RESULTS-VERBOSE* t)
(DEFUN NRESULTS ()
(the fixnum
(let ((nrslts 0))
(declare (fixnum nrslts))
(dolist (item *mrph-list*)
(declare (type morphism item))
(when (eq :gnrt (strt item))
(map nil
#'(lambda (drslt)
(declare (vector drslt))
(incf nrslts (length drslt)))
(rslts item))))
nrslts)))
(DEFUN TIME-LIST ()
(the list
(let ((time-list +empty-list+))
(declare (list time-list))
(dolist (item *mrph-list*)
(declare (type morphism item))
(when (eq :gnrt (strt item))
(map nil #'(lambda (drslt)
(declare (vector drslt))
(map nil #'(lambda (rslt)
(declare (type result rslt))
(let ((rntm (result-rntm rslt)))
(declare (integer rntm))
(when (plusp rntm)
(push rntm time-list))))
drslt))
(rslts item))))
(sort time-list #'>))))
(DEFUN CLEAN-RESULTS (&optional (results-coef *results-coef*))
(declare
(single-float results-coef)
(special *results-coef* *results-cmlt-tm* *results-n* *results-verbose*))
(the (values )
(let ((cut (* results-coef (/ *results-cmlt-tm* *results-n*))))
(declare (single-float cut))
(setf *results-n* 0 *results-cmlt-tm* 0.0)
(dolist (item *mrph-list*)
(declare (type morphism item))
(when (eq :gnrt (strt item))
(let ((rslts (rslts item)))
(declare (vector rslts))
(dotimes (i +maximal-dimension+)
(declare (fixnum i))
(let ((rslts-i (aref rslts i))
(output (make-array 0 :adjustable t :fill-pointer 0)))
(declare (vector rslts-i output))
(map nil
#'(lambda (rslt)
(declare (type result rslt))
(let ((rntm (result-rntm rslt)))
(declare (single-float rntm))
(when (> rntm cut)
(incf *results-n*)
(incf *results-cmlt-tm* rntm)
(vector-push-extend rslt output))))
rslts-i)
(setf (aref rslts i) output))))))
(when *results-verbose*
(format t "~%*CR* -- Cut = ~A -- N = ~A" cut *results-n*)))))
(DEFUN MRPH-GNRT (cmpr2 intr degr gnrt memory &optional (left -1) (right (fill-pointer memory)))
(declare
(type intr-mrph intr)
;; (function (fixnum gnrt) cmbn)
(type cmprf cmpr2)
(fixnum degr left right)
(type gnrt gnrt)
(vector memory)
(special *results-n*)
(fixnum *results-n*))
;; (vector result)
(the (values cmbn fixnum)
;;; cmbn = image of the generator
;;; fixnum = index "exact" or just "lower" of the maybe stored result
(loop
(when (= right (1+ left)) ;; the result for gnrt is not available
(push (get-internal-run-time) *start-stack*)
(let ((value (funcall intr degr gnrt))
(runtime (- (get-internal-run-time) (pop *start-stack*))))
(declare
(type cmbn value)
(integer runtime))
(if (> runtime +too-much-time+)
;;; the condition deciding whether
;;; storing must happen
(let ((old-length (vector-push-extend nil memory)))
(declare (fixnum old-length))
(replace memory memory
:start1 (1+ right) :end1 (1+ old-length)
:start2 right :end2 old-length)
(setf (aref memory right)
(make-result
:gnrt gnrt :value value
:clnm 1
:rntm (let ((rntm
(float
(/ runtime internal-time-units-per-second))))
(declare (single-float rntm))
(incf *results-cmlt-tm* rntm)
rntm)))
(mapl #'(lambda (mark)
(declare (cons mark))
(incf (car mark) runtime))
*start-stack*)
(when (> (incf *results-n*) *results-max*)
(clean-results))
(return (values value right)))
(return (values value left)))))
(let ((middle (truncate (+ right left) 2)))
(declare (fixnum middle))
(ecase (funcall cmpr2 gnrt (result-gnrt (aref memory middle)))
(:equal (let ((rslt (aref memory middle)))
(declare (type cons rslt))
(incf (result-clnm rslt))
(return (values (result-value rslt) middle))))
(:less (setf right middle))
(:greater (setf left middle)))))))
(DEFUN MRPH-CMBN (scmpr2 tcmpr2 intr cmbn memory)
(declare
(type intr-mrph intr)
;; (function (fixnum gnrt) cmbn)
(type cmprf scmpr2 tcmpr2)
(type cmbn cmbn) ;;; cmbn is a non-zero one
(vector memory))
;; (vector result)
(the cmbn
(with-cmbn (degr list) cmbn
(let ((n-cmbn-list +empty-list+))
(declare (list n-cmbn-list))
(do ((mark list (cdr mark))
(left -1))
((endp mark))
(declare (list mark))
(multiple-value-bind (rslt new-left)
(mrph-gnrt scmpr2 intr degr (-gnrt mark) memory left)
(setf left new-left)
(push (cons (-cffc mark) rslt) n-cmbn-list)))
(cmbn-cmbn tcmpr2 n-cmbn-list)))))
(DEFUN DO-CONTROL (cmpr cmbn)
(declare
(type cmprf cmpr)
(type cmbn cmbn))
(let ((list (cmbn-list cmbn)))
(declare (list list))
(do ((mark1 (rest list) (cdr mark1))
(mark2 list mark1))
((endp mark1))
(declare (list mark1 mark2))
(unless (eq :less (funcall cmpr (-gnrt mark2) (-gnrt mark1)))
(setf *wrong-cmbn* cmbn)
(error "In the combination located by *WRONG-CMBN*, the generators:~@
~A and ~A are in a wrong order." (cdar mark2) (cdar mark1)))))
cmbn)
#|
(do-control #'s-cmpr (cmbn 0 1 'a 1 'b -1 'c))
(do-control #'s-cmpr (cmbn 0 1 'b 1 'b -1 'c))
(do-control #'s-cmpr (cmbn 0 1 'a 1 'b -1 'b))
(setf *cmbn-control* nil)
(control #'s-cmpr (cmbn 0 1 'a 1 'b -1 'b))
(setf *cmbn-control* t)
(control #'s-cmpr (cmbn 0 1 'a 1 'b -1 'b))
|#
#|
(DEFVAR *PROFILER-STACK*)
(SETF *PROFILER-STACK* +empty-list+)
(DEFUN PROFILER-INIT ()
(mapc #'(lambda (mrph)
(declare (type morphism mrph))
(setf (wrtm mrph) 0))
*mrph-list*))
(DEFUN PROFILER-ON ()
(push (get-internal-run-time) *profiler-stack*))
(DEFUN PROFILER-OFF (mrph)
(declare (type morphism mrph))
(let ((time-spent
(- (get-internal-run-time) (pop *profiler-stack*))))
(declare (integer time-spent))
(mapl #'(lambda (mark)
(declare (cons mark))
(incf (car mark) time-spent))
*profiler-stack*)
(incf (wrtm mrph) time-spent)))
|#
(DEFVAR *FUTURE-DISPLAY* nil)
(DEFVAR *TIME-INTERVAL* 60000)
(DEFUN GNRT-? (mrph degr gnrt)
(declare
(type morphism mrph)
(fixnum degr)
(type gnrt gnrt))
(the cmbn
(progn
;; (profiler-on)
(when (and *future-display*
(> (get-internal-run-time) *future-display*))
(format t "~%GNRT-?
~3T~A ORGN = ~A
~3TDEGR = ~D
~3TGNRT = ~A"
mrph (orgn mrph) degr gnrt)
(setf *future-display* (+ (get-internal-run-time) *time-interval*)))
(with-slots (sorc (mdegr degr) intr strt ?-clnm) mrph
(declare
(type chain-complex sorc)
(fixnum mdegr ?-clnm)
(type intr-mrph intr)
(type strt strt))
(with-slots ((scmpr cmpr)) sorc
(declare (type cmprf scmpr))
(control (slot-value (slot-value mrph 'trgt) 'cmpr)
(progn
(incf ?-clnm)
(prog1
(ecase strt
(:gnrt
(mrph-gnrt scmpr intr
degr gnrt (svref (rslts mrph) degr)))
(:cmbn
(funcall intr (term-cmbn degr 1 gnrt))))
;; (profiler-off mrph)
))))))))
#|
()
(cat-init)
(setf cc (build-chcm :cmpr #'f-cmpr
:basis :locally-effective
:bsgn 0
:intr-dffr #'(lambda (cmbn)
(cmbn (1- (cmbn-degr cmbn))))
:strt :cmbn
:orgn '(Z of Z)))
(setf cc (build-chcm :cmpr #'f-cmpr
:basis :locally-effective
:bsgn 0
:intr-dffr #'(lambda (cmbn)
(cmbn (1- (cmbn-degr cmbn))))
:strt :cmbn
:orgn '(Z of Z)))
(setf ff (build-mrph :sorc cc :trgt cc :degr 0
:intr #'(lambda (degr n) (cmbn degr 1 n))
:strt :gnrt :orgn '(test)))
(setf ff (build-mrph :sorc cc :trgt cc :degr 0
:intr #'(lambda (degr n) (cmbn degr 1 n))
:strt :gnrt :orgn '(test)))
(dotimes (i 20)
(let ((n (- (random 50) 50)))
(format t "~%~D ~D" n (gnrt-? ff 0 n))))
(setf +too-much-time+ -1)
(dotimes (i 20)
(let ((n (- (random 50) 50)))
(format t "~%~D ~D" n (gnrt-? ff 0 n))))
(setf +too-much-time+ 50)
|#
(DEFUN CMBN-? (mrph cmbn)
(declare
(type morphism mrph)
(type cmbn cmbn))
(the cmbn
(progn
;; (profiler-on)
(when (and *future-display*
(> (get-internal-run-time) *future-display*))
(format t "~%CMBN-?
~3T~A ORGN = ~A
~3TCMBN = ~A"
mrph (orgn mrph) cmbn)
(setf *future-display* (+ (get-internal-run-time) *time-interval*)))
(with-slots (sorc trgt degr intr strt ???-clnm) mrph
(declare
(type chain-complex sorc trgt)
(fixnum degr ???-clnm)
(type intr-mrph intr)
(type strt strt))
(with-slots ((scmpr cmpr)) sorc
(declare (type cmprf scmpr))
(with-slots ((tcmpr cmpr)) trgt
(declare (type cmprf tcmpr))
(control tcmpr
(progn
(controln scmpr cmbn)
(incf ???-clnm)
(when (eq strt :cmbn)
(return-from cmbn-? (funcall intr cmbn)))
(prog1
(if (cmbn-zero-p cmbn)
(zero-cmbn (+ (cmbn-degr cmbn) degr))
(mrph-cmbn scmpr tcmpr intr
cmbn (svref (rslts mrph) (cmbn-degr cmbn))))
;; (profiler-off mrph)
)))))))))
#|
()
(cat-init)
(setf cc (build-chcm :cmpr #'f-cmpr
:basis :locally-effective
:bsgn 0
:intr-dffr #'(lambda (cmbn)
(cmbn (1- (cmbn-degr cmbn))))
:strt :cmbn
:orgn '(Z of Z)))
(setf *n* 10)
(defun ff (degr i)
(do ((*2n* (ash *n* 1))
(rslt +empty-list+
(cons (cons (let ((cffc (- (random *2n*) *n*)))
(if (minusp cffc) cffc (1+ cffc)))
(decf gnrt (1+ (random *n*))))
rslt))
(gnrt i)
(k 0 (1+ k)))
((= k *n*)
(make-cmbn
:degr 0
:list rslt))))
(ff 0 20)
(compile 'ff)
(setf mrph (build-mrph :sorc cc :trgt cc :degr 0
:intr #'ff :strt :gnrt :orgn '(test)))
(cmbn-? mrph (cmbn 0 1 100))
(cmbn-? mrph *)
(cmbn-? mrph *)
(cmbn-? mrph *)
(cmbn-? mrph *)
(cmbn-? mrph *)
(time (cmbn-? mrph *))
(inspect mrph)
|#

463
Kenzo-1/chcm-elementary-op.cl Normal file
View File

@ -0,0 +1,463 @@
;;; CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP
;;; CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP
;;; CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "chcm-elementary-op")
(DEFUN Z-CHCM ()
(the chain-complex
(build-chcm
:cmpr #'(lambda (gnrt1 gnrt2)
(declare (ignore gnrt1 gnrt2))
(the cmpr :equal))
:basis #'(lambda (n)
(declare (type fixnum n))
(the list
(if (zerop n)
(list :Z-gnrt)
+empty-list+)))
:bsgn :Z-gnrt
:intr-dffr #'zero-intr-dffr
:strt :cmbn
:orgn '(Z-chcm))))
(DEFUN ZERO-MRPH (chcm1 &optional (chcm2 chcm1) (degr 0))
(declare (type chain-complex chcm1 chcm2)
(type fixnum degr))
(the morphism
(build-mrph
:sorc chcm1 :trgt chcm2 :degr degr
:intr #'(lambda (cmbn)
(declare (type cmbn cmbn))
(zero-cmbn (+ (cmbn-degr cmbn) degr)))
:strt :cmbn
:orgn `(zero-mrph ,chcm1 ,chcm2 ,degr))))
#|
(cat-init)
(setf z (zero-mrph (Z-chcm) (Z-chcm) 2))
(gnrt-? z 0 :z-gnrt)
(cmbn-? z (cmbn 3))
(setf z2 (zero-mrph (Z-chcm) (Z-chcm) 2))
(eq z z2)
(setf z3 (zero-mrph (Z-chcm) (Z-chcm) 3))
(gnrt-? z3 0 :z-gnrt)
(eq z z3))
|#
(DEFUN IDNT-MRPH (chcm)
(declare (type chain-complex chcm))
(the morphism
(build-mrph
:sorc chcm :trgt chcm :degr 0
:intr #'identity
:strt :cmbn
:orgn `(idnt-mrph ,chcm))))
#|
(setf zi (idnt-mrph (Z-chcm)))
(gnrt-? zi 0 :z-gnrt)
(setf zi2 (idnt-mrph (Z-chcm)))
(eq zi zi2))
|#
(DEFUN OPPS (mrph)
(declare (type morphism mrph))
(the morphism
(with-slots (sorc trgt degr) mrph
(build-mrph
:sorc sorc :trgt trgt :degr degr
:intr #'(lambda (cmbn)
(declare (type cmbn cmbn))
(cmbn-opps (cmbn-? mrph cmbn)))
:strt :cmbn
:orgn `(opps ,mrph)))))
#|
(cat-init)
(setf -zi (opps (idnt-mrph (Z-chcm))))
(gnrt-? -zi 0 :z-gnrt)
(setf -zi2 (opps (idnt-mrph (Z-chcm))))
(eq -zi -zi2))
|#
(DEFMETHOD CMPS ((chcm1 chain-complex) (chcm2 chain-complex) &optional strt)
(declare (type (or strt null) strt))
(the morphism
(cmps (dffr chcm1) (dffr chcm2) strt)))
(DEFMETHOD CMPS ((chcm1 chain-complex) (mrph2 morphism) &optional strt)
(declare (type (or strt null) strt))
(the morphism
(cmps (dffr chcm1) mrph2 strt)))
(DEFMETHOD CMPS ((mrph1 morphism) (chcm2 chain-complex) &optional strt)
(declare (type (or strt null) strt))
(the morphism
(cmps mrph1 (dffr chcm2) strt)))
(DEFMETHOD CMPS ((mrph1 morphism) (mrph2 morphism) &optional strt)
(declare (type (or strt null) strt))
(the morphism
(with-slots ((sorc1 sorc) (trgt1 trgt) (degr1 degr) (strt1 strt)) mrph1
(declare
(type chain-complex sorc1 trgt1)
(fixnum degr1)
(type strt strt1))
(with-slots ((sorc2 sorc) (trgt2 trgt) (degr2 degr) (strt2 strt)) mrph2
(declare
(type chain-complex sorc2 trgt2)
(fixnum degr2)
(type strt strt2))
(unless (eq (grmd sorc1) (grmd trgt2))
(error "In 2MRPH-CMPS, the morphisms ~A and ~A may not be composed (cf source and target)."
mrph1 mrph2))
(unless strt
(setf strt (if (and (eq strt1 :gnrt)
(eq strt2 :gnrt))
:gnrt
:cmbn)))
(when (or (eq (first (orgn mrph1)) 'zero-mrph)
(eq (first (orgn mrph2)) 'zero-mrph))
(return-from cmps
(zero-mrph sorc2 trgt1 (+ degr1 degr2))))
(when (eq (first (orgn mrph1)) 'idnt-mrph)
(return-from cmps mrph2))
(when (eq (first (orgn mrph2)) 'idnt-mrph)
(return-from cmps mrph1))
(ecase strt
(:cmbn (build-mrph
:sorc sorc2 :trgt trgt1 :degr (+ degr1 degr2)
:intr #'(lambda (cmbn)
(declare (type cmbn cmbn))
(the cmbn
(cmbn-? mrph1 (cmbn-? mrph2 cmbn))))
:strt :cmbn :orgn `(2mrph-cmps ,mrph1 ,mrph2 ,strt)))
(:gnrt (build-mrph
:sorc sorc2 :trgt trgt1 :degr (+ degr1 degr2)
:intr #'(lambda (degr gnrt)
(declare
(type fixnum degr)
(type gnrt gnrt))
(the cmbn
(cmbn-? mrph1 (gnrt-? mrph2 degr gnrt))))
:strt :gnrt :orgn `(2mrph-cmps ,mrph1 ,mrph2 ,strt))))))))
#|
(cat-init)
(setf cc (build-chcm :cmpr #'f-cmpr
:basis :locally-effective
:bsgn 0
:intr-dffr #'(lambda (cmbn)
(cmbn (1- (cmbn-degr cmbn))))
:strt :cmbn
:orgn '(Z of Z)))
(setf *n* 5)
(defun ff (degr i)
(do ((*2n* (ash *n* 1))
(rslt +empty-list+
(cons (cons (let ((cffc (- (random *2n*) *n*)))
(if (minusp cffc) cffc (1+ cffc)))
(decf gnrt (1+ (random *n*))))
rslt))
(gnrt i)
(k 0 (1+ k)))
((= k *n*)
(make-cmbn
:degr 0
:list rslt))))
(setf mrph (build-mrph :sorc cc :trgt cc :degr 0
:intr #'ff :strt :gnrt :orgn '(test)))
(setf mrph2 (2mrph-cmps mrph mrph :gnrt))
(gnrt-? mrph2 0 0)
(dotimes (i 5)
(print (gnrt-? mrph2 0 i)))
(setf mrph (build-mrph :sorc cc :trgt cc :degr 0
:intr #'ff :strt :gnrt :orgn '(test)))
(setf mrph3 (cmps mrph mrph :cmbn))
(gnrt-? mrph3 0 0)
(dotimes (i 5)
(print (gnrt-? mrph3 0 i)))
(setf mrph33 (cmps mrph mrph :cmbn))
(eq mrph3 mrph33))
|#
(DEFUN N-MRPH-INTR (n mrph)
(declare
(fixnum n)
(type morphism mrph))
(flet ((rslt (cmbn)
(declare (type cmbn cmbn))
(n-cmbn n (cmbn-? mrph cmbn))))
(the intr-mrph #'rslt)))
(DEFUN N-MRPH (n mrph)
(declare
(fixnum n)
(type morphism mrph))
(the morphism
(with-slots (sorc trgt degr) mrph
(declare
(type chain-complex sorc trgt)
(fixnum degr))
(build-mrph
:sorc sorc :trgt trgt :degr degr
:intr (n-mrph-intr n mrph) :strt :cmbn
:orgn `(n-mrph ,n ,mrph)))))
#|
(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)
|#
(DEFMETHOD ADD ((mrph1 morphism) (mrph2 morphism) &optional strt)
(declare (type (or null strt) strt))
(the morphism
(with-slots ((sorc1 sorc) (trgt1 trgt) (degr1 degr) (strt1 strt)) mrph1
(declare
(type chain-complex sorc1 trgt1)
(fixnum degr1)
(type strt strt1))
(with-slots ((sorc2 sorc) (trgt2 trgt) (degr2 degr) (strt2 strt)) mrph2
(declare
(type chain-complex sorc2 trgt2)
(fixnum degr2)
(type strt strt2))
(unless (and (eq (grmd sorc1) (grmd sorc2))
(eq (grmd trgt1) (grmd trgt2))
(= degr1 degr2))
(error "In 2MRPH-ADD, ~A and ~A may not be added." mrph1 mrph2))
(when (eq (first (orgn mrph1)) 'zero-mrph)
(return-from add mrph2))
(when (eq (first (orgn mrph2)) 'zero-mrph)
(return-from add mrph1))
(unless strt
(setf strt
(if (and (eq strt1 :gnrt)
(eq strt2 :gnrt))
:gnrt
:cmbn)))
(when (or (eq (first (orgn mrph1)) 'idnt-mrph)
(eq (first (orgn mrph2)) 'idnt-mrph))
(setf strt :cmbn))
(let ((cmpr (cmpr trgt1)))
(declare (type cmprf cmpr))
(ecase strt
(:gnrt (build-mrph
:sorc sorc1 :trgt trgt1 :degr degr1
:intr #'(lambda (degr gnrt)
(declare (type fixnum degr) (type gnrt gnrt))
(2cmbn-add cmpr
(gnrt-? mrph1 degr gnrt)
(gnrt-? mrph2 degr gnrt)))
:strt :gnrt
:orgn `(2mrph-add ,mrph1 ,mrph2 ,strt)))
(:cmbn (build-mrph
:sorc sorc1 :trgt trgt1 :degr degr1
:intr #'(lambda (cmbn)
(declare (type cmbn cmbn))
(2cmbn-add cmpr
(cmbn-? mrph1 cmbn)
(cmbn-? mrph2 cmbn)))
:strt :cmbn
:orgn `(2mrph-add ,mrph1 ,mrph2 ,strt)))))))))
#|
(cat-init)
(setf cc (build-chcm :cmpr #'f-cmpr
:basis :locally-effective
:bsgn 0
:intr-dffr #'(lambda (cmbn)
(cmbn (1- (cmbn-degr cmbn))))
:strt :cmbn
:orgn '(Z of Z)))
(setf *n* 10)
(defun ff (degr i)
(do ((*2n* (ash *n* 1))
(rslt +empty-list+
(cons (cons (let ((cffc (- (random *2n*) *n*)))
(if (minusp cffc) cffc (1+ cffc)))
(decf gnrt (1+ (random *n*))))
rslt))
(gnrt i)
(k 0 (1+ k)))
((= k *n*)
(make-cmbn
:degr 0
:list rslt))))
(setf mrph1 (build-mrph :sorc cc :trgt cc :degr 0
:intr #'ff :strt :gnrt :orgn '(test)))
(setf mrph2 (build-mrph :sorc cc :trgt cc :degr 0
:intr #'ff :strt :gnrt :orgn '(test2)))
(setf mrph3 (add mrph1 mrph2 :gnrt))
(setf +too-much-time+ -1)
(gnrt-? mrph1 0 0)
(gnrt-? mrph2 0 0)
(gnrt-? mrph3 0 0)
(setf mrph4 (add mrph1 mrph2 :cmbn))
(gnrt-? mrph4 0 0)
(setf mrph44 (add mrph1 mrph2 :cmbn))
(eq mrph4 mrph44))
|#
(DEFMETHOD SBTR ((mrph1 morphism) (mrph2 morphism) &optional strt)
(declare (type (or null strt) strt))
(the morphism
(with-slots ((sorc1 sorc) (trgt1 trgt) (degr1 degr) (strt1 strt)) mrph1
(declare
(type chain-complex sorc1 trgt1)
(fixnum degr1)
(type strt strt1))
(with-slots ((sorc2 sorc) (trgt2 trgt) (degr2 degr) (strt2 strt)) mrph2
(declare
(type chain-complex sorc2 trgt2)
(fixnum degr2)
(type strt strt2))
(unless (and (eq (grmd sorc1) (grmd sorc2))
(eq (grmd trgt1) (grmd trgt2))
(= degr1 degr2))
(error "In 2MRPH-SBTR, ~A and ~A may not be subtracteded." mrph1 mrph2))
(when (eq (first (orgn mrph1)) 'zero-mrph)
(return-from sbtr mrph2))
(when (eq (first (orgn mrph2)) 'zero-mrph)
(return-from sbtr mrph1))
(unless strt
(setf strt
(if (and (eq strt1 :gnrt)
(eq strt2 :gnrt))
:gnrt
:cmbn)))
(when (or (eq (first (orgn mrph1)) 'idnt-mrph)
(eq (first (orgn mrph2)) 'idnt-mrph))
(setf strt :cmbn))
(let ((cmpr (cmpr trgt1)))
(declare (type cmprf cmpr))
(ecase strt
(:gnrt (build-mrph
:sorc sorc1 :trgt trgt1 :degr degr1
:intr #'(lambda (degr gnrt)
(declare (type fixnum degr) (type gnrt gnrt))
(2cmbn-sbtr cmpr
(gnrt-? mrph1 degr gnrt)
(gnrt-? mrph2 degr gnrt)))
:strt :gnrt
:orgn `(2mrph-sbtr ,mrph1 ,mrph2 ,strt)))
(:cmbn (build-mrph
:sorc sorc1 :trgt trgt1 :degr degr1
:intr #'(lambda (cmbn)
(declare (type cmbn cmbn))
(2cmbn-sbtr cmpr
(cmbn-? mrph1 cmbn)
(cmbn-? mrph2 cmbn)))
:strt :cmbn
:orgn `(2mrph-sbtr ,mrph1 ,mrph2 ,strt)))))))))
#|
()
(cat-init)
(setf cc (build-chcm :cmpr #'f-cmpr
:basis :locally-effective
:bsgn 0
:intr-dffr #'(lambda (cmbn)
(cmbn (1- (cmbn-degr cmbn))))
:strt :cmbn
:orgn '(Z of Z)))
(setf *n* 10)
(defun ff (degr i)
(do ((*2n* (ash *n* 1))
(rslt +empty-list+
(cons (cons (let ((cffc (- (random *2n*) *n*)))
(if (minusp cffc) cffc (1+ cffc)))
(decf gnrt (1+ (random *n*))))
rslt))
(gnrt i)
(k 0 (1+ k)))
((= k *n*)
(make-cmbn
:degr 0
:list rslt))))
(setf mrph1 (build-mrph :sorc cc :trgt cc :degr 0
:intr #'ff :strt :gnrt :orgn '(test)))
(setf mrph2 (build-mrph :sorc cc :trgt cc :degr 0
:intr #'ff :strt :gnrt :orgn '(test2)))
(setf mrph3 (sbtr mrph1 mrph2 :gnrt))
(setf +too-much-time+ -1)
(gnrt-? mrph1 0 0)
(gnrt-? mrph2 0 0)
(gnrt-? mrph3 0 0)
(setf mrph4 (sbtr mrph1 mrph2 :cmbn))
(gnrt-? mrph4 0 0)
(setf mrph44 (sbtr mrph1 mrph2 :cmbn))
(eq mrph4 mrph44))
|#
(DEFUN CHANGE-SORC-TRGT (mrph &key new-sorc new-trgt)
(declare
(type morphism mrph)
(type (or null chain-complex) new-sorc new-trgt))
(the morphism
(with-slots (sorc trgt degr intr strt) mrph
(build-mrph
:sorc (or new-sorc sorc)
:trgt (or new-trgt trgt)
:degr degr
:intr intr
:strt strt
:orgn `(change-sorc-trgt ,mrph ,new-sorc ,new-trgt)))))
(DEFUN DSTR-CHANGE-SORC-TRGT (mrph &key new-sorc new-trgt)
(declare
(type morphism mrph)
(type (or null chain-complex) new-sorc new-trgt))
(the morphism
(with-slots (sorc trgt) mrph
(when new-sorc
(setf sorc new-sorc))
(when new-trgt
(setf trgt new-trgt))
mrph)))
(DEFMETHOD ADD ((chcm chain-complex) (perturbation morphism) &optional strt)
(declare (type (or strt null) strt))
(the chain-complex
(with-slots (cmpr basis bsgn dffr) chcm
(declare
(type cmprf cmpr)
(type basis basis)
(type morphism dffr))
(with-slots (sorc trgt degr) perturbation
(declare
(type chain-complex sorc trgt)
(fixnum degr))
(unless (and (eq (grmd sorc) (grmd chcm))
(eq (grmd trgt) (grmd chcm))
(= degr -1))
(error "In (METHOD ADD CHAIN-COMPLEX MORPHISM), the data are not coherent."))
(let ((new-dffr (add dffr perturbation strt)))
(declare (type intr-mrph new-dffr))
(let ((new-chcm (build-chcm
:cmpr cmpr
:basis basis
:intr-dffr (intr new-dffr)
:strt (strt new-dffr)
:orgn `(add ,chcm ,perturbation))))
(declare (type chain-complex new-chcm))
(if (slot-boundp chcm 'bsgn)
(setf (slot-value new-chcm 'bsgn) bsgn)
(slot-makunbound new-chcm 'bsgn))
(setf (slot-value new-chcm 'grmd) (grmd chcm))
new-chcm))))))

875
Kenzo-1/cl-space-efhm.cl Normal file
View File

@ -0,0 +1,875 @@
;;; 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
(IN-PACKAGE "COMMON-LISP-USER")
(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)))
(declare
(type simplicial-group smgr)
(type chain-complex bar clsp-tnsr-smgr)
(type simplicial-set cl-space))
(the chain-complex
(tnsr-prdc clsp-tnsr-smgr bar)))
(DEFUN CS-HAT-RIGHT-PERTURBATION-INTR (smgr)
(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)))))))))))
(the intr-mrph #'rslt))))
(DEFUN CS-HAT-RIGHT-PERTURBATION (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))))
(DEFUN CS-HAT-U-T (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))))
#|
(cat-init)
(setf c (cs-hat-u-t (k-z-1)))
(defun random-abar (tot-degr~ max-degr)
(do ((rslt nil)
(cum-degr 0 (+ cum-degr degr 1))
(degr))
((>= cum-degr tot-degr~) (make-abar :list rslt))
(setf degr (1+ (random max-degr)))
(push (brgn (1+ degr)
(let ((list (make-list degr)))
(mapl
#'(lambda (sublist)
(setf (car sublist) (- (random 21) 10)))
list)
list))
rslt)))
(dotimes (i 5) (print (random-abar 8 4)))
(setf abar (random-abar 8 4))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
abar-degr abar))
(? c (+ 5 abar-degr) gnrt)
(? c *)
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
abar-degr abar))
(unless (>= abar-degr 10)
(print (? c (+ 5 abar-degr) gnrt))
(print (? c (? c (+ 5 abar-degr) gnrt))))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6))
abar-degr abar))
(unless (>= abar-degr 9)
(print (? c (+ 6 abar-degr) gnrt))
(print (? c (? c (+ 6 abar-degr) gnrt))))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6))
abar-degr abar))
(unless (>= abar-degr 10)
(print (? c (+ 5 abar-degr) gnrt))
(print (? c (? c (+ 5 abar-degr) gnrt))))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
abar-degr abar))
(unless (>= abar-degr 11)
(print (? c (+ 4 abar-degr) gnrt))
(print (? c (? c (+ 4 abar-degr) gnrt))))))
|#
(DEFUN CS-HAT-LEFT-PERTURBATION (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))))
(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)))
(declare
(type simplicial-group smgr)
(type chain-complex bar twisted-tnsr-prdc hat-u-u)
(type fibration fibration)
(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)))
#|
(cat-init)
(setf c (cs-hat-t-u (k-z-1)))
(defun random-abar (tot-degr~ max-degr)
(do ((rslt nil)
(cum-degr 0 (+ cum-degr degr 1))
(degr))
((>= cum-degr tot-degr~) (make-abar :list rslt))
(setf degr (1+ (random max-degr)))
(push (brgn (1+ degr)
(let ((list (make-list degr)))
(mapl
#'(lambda (sublist)
(setf (car sublist) (- (random 21) 10)))
list)
list))
rslt)))
(dotimes (i 5) (print (random-abar 8 4)))
(setf abar (random-abar 8 4))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
abar-degr abar))
(? c (+ 5 abar-degr) gnrt)
(? c *)
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
abar-degr abar))
(unless (>= abar-degr 10)
(print (? c (+ 5 abar-degr) gnrt))
(print (? c (? c (+ 5 abar-degr) gnrt))))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6))
abar-degr abar))
(unless (>= abar-degr 9)
(print (? c (+ 6 abar-degr) gnrt))
(print (? c (? c (+ 6 abar-degr) gnrt))))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6))
abar-degr abar))
(unless (>= abar-degr 10)
(print (? c (+ 5 abar-degr) gnrt))
(print (? c (? c (+ 5 abar-degr) gnrt))))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
abar-degr abar))
(unless (>= abar-degr 11)
(print (? c (+ 4 abar-degr) gnrt))
(print (? c (? c (+ 4 abar-degr) gnrt))))))
|#
(DEFUN CS-LEFT-HMEQ-HAT (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)
(type morphism hat-right-perturbation))
(the chain-complex
(add hat-t-u hat-right-perturbation)))
#|
(cat-init)
(setf c (cs-left-hmeq-hat (k-z-1)))
(defun random-abar (tot-degr~ max-degr)
(do ((rslt nil)
(cum-degr 0 (+ cum-degr degr 1))
(degr))
((>= cum-degr tot-degr~) (make-abar :list rslt))
(setf degr (1+ (random max-degr)))
(push (brgn (1+ degr)
(let ((list (make-list degr)))
(mapl
#'(lambda (sublist)
(setf (car sublist) (- (random 21) 10)))
list)
list))
rslt)))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
abar-degr abar))
(unless (>= abar-degr 10)
(print (? c (+ 5 abar-degr) gnrt))
(print (? c (? c (+ 5 abar-degr) gnrt))))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6))
abar-degr abar))
(unless (>= abar-degr 9)
(print (? c (+ 6 abar-degr) gnrt))
(print (? c (? c (+ 6 abar-degr) gnrt))))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6))
abar-degr abar))
(unless (>= abar-degr 10)
(print (? c (+ 5 abar-degr) gnrt))
(print (? c (? c (+ 5 abar-degr) gnrt))))))
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
abar-degr abar))
(unless (>= abar-degr 11)
(print (? c (+ 4 abar-degr) gnrt))
(print (? c (? c (+ 4 abar-degr) gnrt))))))
|#
(DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-INTR-F (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 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))))))
#|
(cs-pre-left-hmeq-left-reduction-intr-f
(cmbn 6 100 (tnpr 4 (tnpr 2 'a 2 'b) 2 'c)
10 (tnpr 6 (tnpr 2 'a 4 'b) 0 'c)
50 (tnpr 6 (tnpr 6 'a 0 'b) 0 'c)
1 (tnpr 6 (tnpr 6 'aa 0 'b) 0 'c)))
|#
(DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-F (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))))
(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))))))
(the intr-mrph #'rslt)))
#|
(setf g (cs-pre-left-hmeq-left-reduction-intr-g '()))
(funcall g (cmbn 3 14 (gbar 3 0 'a 1 'b 0 '())))
|#
(DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-G (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))))
(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)))))))))))
(the intr-mrph #'rslt)))
(DEFUN CS-PRE-LEFT-HMEQ-LEFT-REDUCTION-H (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))))
(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))))
#|
(cat-init)
(defun random-abar (tot-degr~ max-degr)
(do ((rslt nil)
(cum-degr 0 (+ cum-degr degr 1))
(degr))
((>= cum-degr tot-degr~) (make-abar :list rslt))
(setf degr (1+ (random max-degr)))
(push (brgn (1+ degr)
(let ((list (make-list degr)))
(mapl
#'(lambda (sublist)
(setf (car sublist) (- (random 21) 10)))
list)
list))
rslt)))
(setf rdct (cs-pre-left-hmeq-left-reduction (k-z-1)))
(pre-check-rdct rdct)
(setf *tc* (cmbn 0 1 (tnpr 0 (tnpr 0 +null-gbar+ 0 '()) 0 +null-abar+))
*bc* (cmbn 0 1 +null-gbar+))
(check-rdct)
(setf *tc* (cmbn 1 1 (tnpr 1 (tnpr 0 +null-gbar+ 1 '(13)) 0 +null-abar+)))
(check-rdct)
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
abar-degr abar))
(setf gbar (gbar 2 0 '(1) 0 '()))
(unless (>= abar-degr 9)
(setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt)
*bc* (cmbn 2 1 gbar))
(check-rdct))))
(dotimes (i 10)
(let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6))
abar-degr abar))
(setf gbar (gbar 3 0 '(1 2) 1 '() 0 '()))
(unless (>= abar-degr 8)
(setf *tc* (cmbn (+ 6 abar-degr) 1 gnrt)
*bc* (cmbn 3 1 gbar))
(check-rdct))))
(dotimes (i 10)
(let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6))
abar-degr abar))
(setf gbar (gbar 4 0 '(1 2 3) 0 '(4 5) 0 '(6) 0 '()))
(unless (>= abar-degr 9)
(setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt))
(setf *bc* (cmbn 4 1 gbar))
(check-rdct))))
(dotimes (i 10)
(let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
abar-degr abar))
(setf gbar (gbar 5 8 '(1 2 3) 0 '(4 5 6) 0 '(7 8) 0 '(9) 0 '()))
(unless (>= abar-degr 10)
(setf *tc* (cmbn (+ 4 abar-degr) 1 gnrt))
(setf *bc* (cmbn 5 1 gbar))
(check-rdct))))
|#
(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)))
(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))))
#|
(cat-init)
(defun random-abar (tot-degr~ max-degr)
(do ((rslt nil)
(cum-degr 0 (+ cum-degr degr 1))
(degr))
((>= cum-degr tot-degr~) (make-abar :list rslt))
(setf degr (1+ (random max-degr)))
(push (brgn (1+ degr)
(let ((list (make-list degr)))
(mapl
#'(lambda (sublist)
(setf (car sublist) (- (random 21) 10)))
list)
list))
rslt)))
(setf rdct (cs-left-hmeq-left-reduction (k-z-1)))
(pre-check-rdct rdct)
(setf *tc* (cmbn 0 1 (tnpr 0 (tnpr 0 +null-gbar+ 0 '()) 0 +null-abar+))
*bc* (cmbn 0 1 +null-gbar+))
(check-rdct)
(setf *tc* (cmbn 1 1 (tnpr 1 (tnpr 0 +null-gbar+ 1 '(13)) 0 +null-abar+)))
(check-rdct)
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
abar-degr abar))
(setf gbar (gbar 2 0 '(1) 0 '()))
(unless (>= abar-degr 9)
(setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt)
*bc* (cmbn 2 1 gbar))
(check-rdct))))
(dotimes (i 10)
(let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6))
abar-degr abar))
(setf gbar (gbar 3 0 '(1 2) 1 '() 0 '()))
(unless (>= abar-degr 8)
(setf *tc* (cmbn (+ 6 abar-degr) 1 gnrt)
*bc* (cmbn 3 1 gbar))
(check-rdct))))
(dotimes (i 10)
(let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6))
abar-degr abar))
(setf gbar (gbar 4 0 '(1 2 3) 0 '(4 5) 0 '(6) 0 '()))
(unless (>= abar-degr 9)
(setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt))
(setf *bc* (cmbn 4 1 gbar))
(check-rdct))))
(dotimes (i 10)
(let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
abar-degr abar))
(setf gbar (gbar 5 8 '(1 2 3) 0 '(4 5 6) 0 '(7 8) 0 '(9) 0 '()))
(unless (>= abar-degr 10)
(setf *tc* (cmbn (+ 4 abar-degr) 1 gnrt))
(setf *bc* (cmbn 5 1 gbar))
(check-rdct))))
|#
(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))))))
#|
(cs-pre-left-hmeq-right-reduction-intr-f
(cmbn 4 2 (tnpr 0 (tnpr 0 +null-gbar+ 0 'i)
4 (abar 2 'a 2 'b))
3 (tnpr 0 (tnpr 0 +null-gbar+ 0 'i)
4 (abar 2 'a 2 'c))
5 (tnpr 1 (tnpr 0 +null-gbar+ 1 'a)
3 (abar 1 'a 2 'b))))
|#
(DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-F (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))))
(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)))))))
(the intr-mrph #'rslt)))
#|
(setf g (cs-pre-left-hmeq-right-reduction-intr-g 'i))
(funcall g (cmbn 3 2 (abar 1 'a 2 'b)))
|#
(DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-G (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))))
(DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-H (smgr
&aux (bar (bar smgr))
(tnpr-contraction
(smgr-tnpr-contraction smgr)))
(declare
(type simplicial-group smgr)
(type chain-complex bar)
(type morphism tnpr-contraction))
(the morphism
(tnsr-prdc tnpr-contraction (idnt-mrph bar))))
(DEFUN CS-PRE-LEFT-HMEQ-RIGHT-REDUCTION (smgr)
(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))))
#|
(cat-init)
(defun random-abar (tot-degr~ max-degr)
(do ((rslt nil)
(cum-degr 0 (+ cum-degr degr 1))
(degr))
((>= cum-degr tot-degr~) (make-abar :list rslt))
(setf degr (1+ (random max-degr)))
(push (brgn (1+ degr)
(let ((list (make-list degr)))
(mapl
#'(lambda (sublist)
(setf (car sublist) (- (random 21) 10)))
list)
list))
rslt)))
(setf rdct (cs-pre-left-hmeq-right-reduction (k-z-1)))
(pre-check-rdct rdct)
(setf *tc* (cmbn 0 1 (tnpr 0 (tnpr 0 +null-gbar+ 0 '()) 0 +null-abar+))
*bc* (cmbn 0 1 +null-abar+))
(check-rdct)
(setf *tc* (cmbn 1 1 (tnpr 1 (tnpr 0 +null-gbar+ 1 '(13)) 0 +null-abar+)))
(check-rdct)
(dotimes (i 10)
(let ((abar (random-abar 8 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 2 '(4 5))
abar-degr abar))
(unless (>= abar-degr 9)
(setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt)
*bc* (cmbn abar-degr 1 abar))
(check-rdct))))
(dotimes (i 10)
(let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 6 (tnpr 3 (gbar 3 0 '(1 2) 0 '(3) 0 '()) 3 '(4 5 6))
abar-degr abar))
(unless (>= abar-degr 8)
(setf *tc* (cmbn (+ 6 abar-degr) 1 gnrt)
*bc* (cmbn abar-degr 1 abar))
(check-rdct))))
(dotimes (i 10)
(let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 2 (gbar 2 0 '(3) 0 '()) 3 '(4 5 6))
abar-degr abar))
(unless (>= abar-degr 9)
(setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt))
(setf *bc* (cmbn abar-degr 1 abar))
(check-rdct))))
(dotimes (i 10)
(let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
abar-degr abar))
(unless (>= abar-degr 10)
(setf *tc* (cmbn (+ 4 abar-degr) 1 gnrt))
(setf *bc* (cmbn abar-degr 1 abar))
(check-rdct))))
|#
(DEFUN CS-LEFT-HMEQ-RIGHT-REDUCTION (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))))
#|
(cat-init)
(defun random-abar (tot-degr~ max-degr)
(do ((rslt nil)
(cum-degr 0 (+ cum-degr degr 1))
(degr))
((>= cum-degr tot-degr~) (make-abar :list rslt))
(setf degr (1+ (random max-degr)))
(push (brgn (1+ degr)
(let ((list (make-list degr)))
(mapl
#'(lambda (sublist)
(setf (car sublist) (- (random 21) 10)))
list)
list))
rslt)))
(setf rdct (cs-left-hmeq-right-reduction (k-z-1)))
(pre-check-rdct rdct)
(setf *tc* (cmbn 0 1 (tnpr 0 (tnpr 0 +null-gbar+ 0 '()) 0 +null-abar+))
*bc* (cmbn 0 1 +null-abar+))
(check-rdct)
(setf *tc* (cmbn 1 1 (tnpr 1 (tnpr 0 +null-gbar+ 1 '(13)) 0 +null-abar+)))
(check-rdct)
(dotimes (i 10)
(let ((abar (random-abar 4 2)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 3 (tnpr 2 (gbar 2 0 '(3) 0 '()) 1 '(4))
abar-degr abar))
(unless (>= abar-degr 9)
(setf *tc* (cmbn (+ 3 abar-degr) 1 gnrt)
*bc* (cmbn abar-degr 1 abar))
(check-rdct))))
(dotimes (i 10)
(let ((abar (random-abar 3 1)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(5 6))
abar-degr abar))
(unless (>= abar-degr 8)
(setf *tc* (cmbn (+ 4 abar-degr) 1 gnrt)
*bc* (cmbn abar-degr 1 abar))
(check-rdct))))
(dotimes (i 10)
(let ((abar (random-abar 3 1)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 5 (tnpr 3 (gbar 3 0 '(1 2) 1 '() 0 '()) 2 '(5 6))
abar-degr abar))
(unless (>= abar-degr 9)
(setf *tc* (cmbn (+ 5 abar-degr) 1 gnrt))
(setf *bc* (cmbn abar-degr 1 abar))
(check-rdct))))
(dotimes (i 10)
(let ((abar (random-abar 6 4)))
(setf abar-degr (apply #'+ (mapcar #'car (abar-list abar))))
(setf gnrt (tnpr 4 (tnpr 2 (gbar 2 0 '(3) 0 '()) 2 '(4 5))
abar-degr abar))
(unless (>= abar-degr 10)
(setf *tc* (cmbn (+ 4 abar-degr) 1 gnrt))
(setf *bc* (cmbn abar-degr 1 abar))
(check-rdct))))
|#
(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))))
#|
(cat-init)
(setf h (cs-left-hmeq (k-z-1)))
(setf abar (abar 2 '(2) 3 '(3 4)))
(rg h 5 abar)
(lf h *)
(lg h *)
(rf h *)
|#
(DEFUN CLASSIFYING-SPACE-EFHM (smgr)
(declare (type simplicial-group smgr))
(let ((left-hmeq (cs-left-hmeq smgr))
(right-hmeq (bar (efhm smgr))))
(declare (type homotopy-equivalence left-hmeq right-hmeq))
(cmps left-hmeq right-hmeq)))
(DEFMETHOD SEARCH-EFHM (classifying-space (orgn (eql 'classifying-space)))
(declare (type simplicial-set classifying-space))
(classifying-space-efhm (second (orgn classifying-space))))
#|
(cat-init)
(setf k (k-z-1))
(homology k 0 10)
(setf bk (classifying-space k))
(homology bk 0 10)
(setf obk (loop-space bk))
(homology obk 0 6)
|#

514
Kenzo-1/classes.cl Normal file
View File

@ -0,0 +1,514 @@
;;; CLASSES CLASSES CLASSES CLASSES CLASSES CLASSES CLASSES
;;; CLASSES CLASSES CLASSES CLASSES CLASSES CLASSES CLASSES
;;; CLASSES CLASSES CLASSES CLASSES CLASSES CLASSES CLASSES
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "classes")
;;;
;;; VARIOUS
;;;
(DEFTYPE ANY () t)
;;;
;;; COMBINATIONS
;;;
(DEFSTRUCT (CMBN (:print-function cmbn-print))
(degr #+allegro :type #+allegro fixnum)
(list #+allegro :type #+allegro list))
;; CFFC = CoeFFiCient
(DEFUN CFFC-P (object)
(declare (type any object))
(the boolean
(and (typep object 'fixnum)
(/= 0 object))))
(DEFTYPE CFFC () '(satisfies cffc-p))
;; GNRT = GeNeRaTor
(DEFTYPE GNRT () 'any)
;; CMPR = CoMPaRison
(DEFTYPE CMPR () '(member :less :equal :greater))
;; CMPRF = CoMPaRison Function
(DEFTYPE CMPRF () 'function)
;; (function (gnrt gnrt) cmpr)
(DEFUN TERM-P (object)
(declare (type any object))
(the boolean
(and (consp object)
(typep (car object) 'cffc)
(typep (cdr object) 'gnrt))))
(DEFTYPE TERM () '(satisfies term-p))
;; ICMBN = Internal-CoMBiNation
(DEFUN ICMBN-P (object)
;; ICMBN = Internal CoMBiNation,
;; without the keyword and the degree
(declare (type any object))
(the boolean
(and (listp object)
(every #'term-p object))))
(DEFTYPE ICMBN () '(satisfies icmbn-p))
#|
;; CMBN = CoMBiNation
(DEFUN CMBN-P (object)
(declare (type any object))
(the boolean
(and (consp object)
(eql (car object) :cmbn)
(consp (cdr object))
(typep (second object) 'fixnum)
(typep (cddr object) 'icmbn))))
(DEFTYPE CMBN () '(satisfies cmbn-p))
|#
(DEFTYPE BASIS () '(or function (eql :locally-effective)))
;; (function (degr) (list gnrt))
;; INTR-MRPH = INTeRnal-MoRPHism
(DEFTYPE INTR-MRPH () 'function)
;; (or (function (degr gnrt) cmbn) ;; if :gnrt strategy
;; (function (cmbn) (cmbn)) ;; if :cmbn strategy
;;;
;;; CHAIN-COMPLEXES
;;;
#+allegro
(DEFVAR REDEFINITION-WARNINGS-SAVED)
#+allegro
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf redefinition-warnings-saved
excl::*redefinition-warnings*
*redefinition-warnings* nil))
(DEFCLASS CHAIN-COMPLEX () ()) ;; will be redefined later.
(DEFCLASS MORPHISM () ()) ;; will be redefined later.
(DEFCLASS HOMOTOPY-EQUIVALENCE () ()) ;; will be redefined later
;; IDNM = IDentification NuMber
(DEFVAR *IDNM-COUNTER*)
(SETF *IDNM-COUNTER* 0)
(DEFCLASS CHAIN-COMPLEX ()
((cmpr :type cmprf :initarg :cmpr :reader cmpr1)
(basis :type basis :initarg :basis :reader basis1)
;; BaSe GeNerator
(bsgn :type gnrt :initarg :bsgn :reader bsgn)
;; DiFFeRential
(dffr :type morphism :initarg :dffr :reader dffr1)
;; GRound MoDule
(grmd :type chain-complex :initarg :grmd :reader grmd)
;; EFfective HoMology
(efhm :type homotopy-equivalence :initarg :efhm :accessor efhm)
;; IDentification NuMber
(idnm :type fixnum :initform (incf *idnm-counter*) :reader idnm)
;; ORiGiN
(orgn :type list :initarg :orgn :reader orgn)))
;; STRT = STRaTegy
(DEFTYPE STRT () '(member :gnrt :cmbn))
(DEFCLASS MORPHISM ()
;; SOuRCe
((sorc :type chain-complex :initarg :sorc :reader sorc)
;; TaRGeT
(trgt :type chain-complex :initarg :trgt :reader trgt)
;; DEGRee
(degr :type fixnum :initarg :degr :reader degr)
;; INTeRnal
(intr :type intr-mrph :initarg :intr :reader intr)
;; STRaTegy
(strt :type strt :initarg :strt :reader strt)
;; ;; WoRk-TiMe
;; (wrtm :type integer :initform 0 :accessor wrtm)
;; CaLl NuMber
(???-clnm :type fixnum :initform 0 :accessor ???-clnm)
(?-clnm :type fixnum :initform 0 :accessor ?-clnm)
;; ReSuLTS
(rslts :type simple-vector
;; (vector (vector result))
:reader rslts)
;; IDentification NuMber
(idnm :type fixnum :initform (incf *idnm-counter*) :reader idnm)
;; ORiGiN
(orgn :type list :initarg :orgn :reader orgn)))
(DEFSTRUCT (RESULT (:print-function result-print))
(gnrt #+allegro :type #+allegro gnrt)
(value #+allegro :type #+allegro cmbn)
(clnm #+allegro :type #+allegro fixnum)
(rntm #+allegro :type #+allegro single-float))
;;;
;;; EFFECTIVE HOMOLOGY
;;;
(DEFCLASS REDUCTION ()
;; Top Chain Complex
((tcc :type chain-complex :initarg :tcc :reader tcc1)
;; Bottom Chain Complex
(bcc :type chain-complex :initarg :bcc :reader bcc1)
(f :type morphism :initarg :f :reader f1)
(g :type morphism :initarg :g :reader g1)
(h :type morphism :initarg :h :reader h1)
;; IDentification NuMber
(idnm :type fixnum :initform (incf *idnm-counter*) :reader idnm)
;; ORiGiN
(orgn :type list :initarg :orgn :reader orgn)))
(DEFCLASS HOMOTOPY-EQUIVALENCE ()
;; Left Bottom Chain Complex
((lbcc :type chain-complex :initarg :lbcc :reader lbcc1)
;; Top Chain Complex
(tcc :type chain-complex :initarg :tcc :reader tcc1)
;; Bottom Right Chain Complex
(rbcc :type chain-complex :initarg :rbcc :reader rbcc1)
;; Left f
(lf :type morphism :initarg :lf :reader lf1)
;; Left g
(lg :type morphism :initarg :lg :reader lg1)
;; Left h
(lh :type morphism :initarg :lh :reader lh1)
;; Right f
(rf :type morphism :initarg :rf :reader rf1)
;; Right g
(rg :type morphism :initarg :rg :reader rg1)
;; Right h
(rh :type morphism :initarg :rh :reader rh1)
;; Left ReDuCTion
(lrdct :type reduction :initarg :lrdct :reader lrdct)
;; Right ReDuCTion
(rrdct :type reduction :initarg :rrdct :reader rrdct)
;; IDentification NuMber
(idnm :type fixnum :initform (incf *idnm-counter*) :reader idnm)
;; ORiGiN
(orgn :type list :initarg :orgn :reader orgn)))
#+allegro
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf excl::*redefinition-warnings*
redefinition-warnings-saved))
;;;
;;; HOMOLOGY-GROUPS
;;;
(DEFSTRUCT (matrice (:conc-name nil))
leftcol uplig)
(DEFSTRUCT (t-mat (:conc-name nil))
val ilig icol left up)
;;;
;;; CONES
;;;
(DEFSTRUCT (CONE (:conc-name nil) (:print-function cone-print))
(conx #+allegro :type #+allegro (member 0 1))
(icon #+allegro :type #+allegro gnrt))
(DEFSTRUCT (BICN (:conc-name nil) (:print-function bicn-print))
(bcnx #+allegro :type #+allegro (member :bcnb :bcnc :bcnd))
(ibicn #+allegro :type #+allegro gnrt))
;;;
;;; TENSOR-PRODUCTS
;;;
(DEFSTRUCT (TNPR (:conc-name nil) (:print-function tnpr-print))
degr1 gnrt1 degr2 gnrt2)
;;;
;;; COALGEBRAS
;;;
(DEFCLASS COALGEBRA (chain-complex)
((cprd :type morphism :initarg :cprd :reader cprd1))) ;; coproduct
;;;
;;; COBAR
;;;
;; CBGN CoBar-GeNerator
(DEFUN CBGN-P (object)
;; CBGN = CoBar GeNerator
(declare (type any object))
(the boolean
(and (consp object)
(typep (car object) 'fixnum) ;; degree *in* the cobar
(typep (cdr object) 'gnrt))))
(DEFTYPE CBGN () '(satisfies cbgn-p))
;; IALLP = Internal-ALgebraic LooP
(DEFUN IALLP-P (object)
(declare (type any object))
(the boolean
(and (listp object)
(every #'cbgn-p object))))
(DEFTYPE IALLP () '(satisfies iallp-p))
(DEFSTRUCT (ALLP (:print-function allp-print))
(list #+allegro :type #+allegro iallp))
;;;
;;; ALGEBRAS
;;;
(DEFCLASS ALGEBRA (chain-complex)
((aprd :type morphism :initarg :aprd :reader aprd1))) ;; product
(DEFCLASS HOPF-ALGEBRA (coalgebra algebra)
())
;;;
;;; BAR
;;;
;; BRGN BaR-GeNerator
(DEFUN BRGN-P (object)
;; BRGN = BaR GeNerator
(declare (type any object))
(the boolean
(and (consp object)
(typep (car object) 'fixnum) ;; degree *in* the bar
(typep (cdr object) 'gnrt))))
(DEFTYPE BRGN () '(satisfies brgn-p))
;; IABAR = Internal-ALgebraic LooP
(DEFUN IABAR-P (object)
(declare (type any object))
(the boolean
(and (listp object)
(every #'brgn-p object))))
(DEFTYPE IABAR () '(satisfies iabar-p))
;; ABAR = ALgebraic BAR
#|
(DEFUN ABAR-P (object)
(declare (type any object))
(the boolean
(and (consp object)
(eq :abar (car object))
(typep (cdr object) 'iabar))))
(DEFTYPE ABAR () '(satisfies abar-p))
|#
(DEFSTRUCT (ABAR (:print-function abar-print))
(list #+allegro :type #+allegro list))
;;;
;;; SIMPLICIAL SETS
;;;
;; DGOP = DeGeneray OPerator
(DEFTYPE DGOP () `(integer 0 ,most-positive-fixnum))
;; GMSM = GeoMetric SiMplex
(DEFTYPE GMSM () 'gnrt)
;; DLOP = DeL OPerator
(DEFTYPE DLOP () 'dgop)
#|
;; IABSM = Internal ABstract SiMplex
(DEFUN IABSM-P (object)
(declare (type any object))
(the boolean
(and (consp object)
(typep (car object) 'dgop)
(typep (cdr object) 'gmsm))))
(DEFTYPE IABSM () '(satisfies iabsm-p))
|#
(DEFSTRUCT (ABSM (:conc-name nil) (:print-function absm-print))
(dgop #+allegro :type #+allegro dgop)
(gmsm #+allegro :type #+allegro gmsm))
#|
()
(absm-p 1)
(absm-p '(1))
(absm-p '(:absm nil)) ;; printer-error
(absm-p '(:absm 5 . a))
(absm-p '(:absm -5 . a)) ;; printer-error
|#
(DEFTYPE FACE () 'function)
;; (function (indx dmns gmsm) absm)
(DEFTYPE FACE* () 'function)
;; (function (indx dmns gmsm) (or gmsm (eql :degenerate)))
(DEFCLASS SIMPLICIAL-SET (coalgebra)
((face :type face :initarg :face :reader face1)))
;;;
;;; SIMPLICIAL-MRPHS
;;;
(DEFTYPE SINTR () 'function)
;; (function (dmns gmsm) absm)
(DEFCLASS SIMPLICIAL-MRPH (morphism)
((sintr :type sintr :initarg :sintr :reader sintr)))
;;;
;;; SPECIAL-SMSTS
;;;
;; DLOP = DeL OPerator
(DEFUN SOFT-DLOP-P (object)
(declare (type any object))
(the boolean
(and (consp object)
(eq :delt (car object))
(typep (cdr object) 'dgop))))
(DEFTYPE SOFT-DLOP () '(satisfies soft-dlop-p))
;;;
;;; CARTESIAN PRODUCTS
;;;
(DEFSTRUCT (CRPR (:print-function crpr-print) (:conc-name nil))
(dgop1 #+allegro :type #+allegro dgop)
(gmsm1 #+allegro :type #+allegro gmsm)
(dgop2 #+allegro :type #+allegro dgop)
(gmsm2 #+allegro :type #+allegro gmsm))
;;;;
;;;; KAN
;;;;
(DEFTYPE KFLL () 'function)
;; (function (indx dmns (list absm)) absm)
(DEFCLASS KAN (simplicial-set)
((kfll :type kfll :initarg :kfll :reader kfll1)))
;;;
;;; FIBRATIONS
;;;
(DEFUN FIBRATION-P (object)
(declare (type any object))
(the boolean
(and (typep object 'simplicial-mrph)
(= -1 (degr object)))))
(DEFTYPE FIBRATION ()
'(satisfies fibration-p))
(DEFCLASS SIMPLICIAL-GROUP (kan hopf-algebra)
((grml :type simplicial-mrph :initarg :grml :reader grml1)
(grin :type simplicial-mrph :initarg :grin :reader grin1)))
(DEFCLASS AB-SIMPLICIAL-GROUP (simplicial-group) ())
;;;
;;; LOOP SPACES
;;;
;; EXPN = EXPoNent
(DEFUN EXPN-P (object)
(declare (type any object))
(the boolean
(typep object '(and fixnum
(not (eql 0))))))
(DEFTYPE EXPN () '(satisfies expn-p))
;; POWR = POWeR
(DEFUN POWR-P (object)
(declare (type any object))
(the boolean
(and (consp object)
(typep (car object) 'gmsm)
(typep (cdr object) 'expn))))
(DEFTYPE POWR () '(satisfies powr-p))
;; APOWR = Abstract POWeR
(DEFUN APOWR-P (object)
(declare (type any object))
(the boolean
(and (consp object)
(typep (car object) 'dgop)
(typep (cdr object) 'powr))))
(DEFTYPE APOWR () '(satisfies apowr-p))
;; ILOOP = Internal LOOP
(DEFUN ILOOP-P (object)
(declare (type any object))
(the boolean
(and (listp object)
(every #'apowr-p object))))
(DEFTYPE ILOOP () '(satisfies iloop-p))
#+allegro
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf excl:*enable-package-locked-errors* nil))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :common-lisp) nil))
(DEFSTRUCT (LOOP (:print-function loop-print))
(list #+allegro :type #+allegro iloop))
#+allegro
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf excl:*enable-package-locked-errors* t))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :common-lisp) t))
;;;
;;; CLASSIFYING-SPACES
;;;
;; GBAR Geometrical BAR
;; (:gbar dmns absm_(m-1) ... absm_1)
(DEFSTRUCT (GBAR (:print-function gbar-print))
(dmns #+allegro :type #+allegro fixnum)
(list #+allegro :type #+allegro list))

392
Kenzo-1/classifying-spaces.cl Normal file
View File

@ -0,0 +1,392 @@
;;; CLASSIFYING-SPACES CLASSIFYING-SPACES CLASSIFYING-SPACES
;;; CLASSIFYING-SPACES CLASSIFYING-SPACES CLASSIFYING-SPACES
;;; CLASSIFYING-SPACES CLASSIFYING-SPACES CLASSIFYING-SPACES
(IN-PACKAGE "COMMON-LISP-USER")
(provide "classifying-spaces")
(DEFCONSTANT +NULL-GBAR+ (make-gbar :dmns 0 :list +empty-list+))
(DEFUN GBAR-PRINT (gbar stream depth)
(declare
(type gbar gbar) (stream stream)
(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)))
;;; NIGBAR = non-normalized igbar (with dimension)
(DEFUN NORMALIZE-GBAR (nigbar)
(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))))))))
#|
()
(normalize-gbar (list 0))
(normalize-gbar (list 1 (absm 0 'i)))
(normalize-gbar (list 2 (absm 1 'i) (absm 0 'i)))
(normalize-gbar (list 2 (absm 0 'a) (absm 0 'i)))
(normalize-gbar (list 4 (absm 0 'a) (absm 0 'b) (absm 0 'c) (absm 0 'i)))
(normalize-gbar (list 4 (absm 7 'i) (absm 3 'i) (absm 1 'i) (absm 0 'i)))
(normalize-gbar (list 4 (absm 0 'a) (absm 3 'i) (absm 0 'c) (absm 0 'i)))
(normalize-gbar (list 4 (absm 1 'a) (absm 3 'i) (absm 0 'c) (absm 0 'i)))
(normalize-gbar (list 4 (absm 2 'a) (absm 3 'i) (absm 0 'c) (absm 0 'i)))
(normalize-gbar (list 4 (absm 4 'a) (absm 3 'i) (absm 0 'c) (absm 0 'i)))
(normalize-gbar (list 4 (absm 3 'a) (absm 3 'i) (absm 0 'c) (absm 0 'i)))
(normalize-gbar (list 4 (absm 5 'a) (absm 3 'i) (absm 0 'c) (absm 0 'i)))
(normalize-gbar (list 4 (absm 6 'a) (absm 3 'i) (absm 0 'c) (absm 0 'i)))
(normalize-gbar (list 4 (absm 1 'a) (absm 3 'i) (absm 1 'i) (absm 0 'i)))
|#
(DEFUN UNNORMALIZE-GBAR (absm idnt)
(declare
(type absm absm)
(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)))))))
#|
()
(unnormalize-gbar (absm 1 +null-gbar+) 'i)
(unnormalize-gbar (absm 15 +null-gbar+) 'i)
(normalize-gbar (unnormalize-gbar (absm 15 +null-gbar+) 'i))
(unnormalize-gbar
(absm 0 (make-gbar :dmns 4
:list (list (absm 0 'a) (absm 0 'b)
(absm 0 'c) (absm 0 'i)))) 'i)
(normalize-gbar
(unnormalize-gbar
(absm 0 (make-gbar :dmns 4
:list (list (absm 0 'a) (absm 0 'b)
(absm 0 'c) (absm 0 'i)))) 'i))
(unnormalize-gbar
(absm 5 (make-gbar :dmns 4
:list (list (absm 0 'a) (absm 0 'b)
(absm 0 'c) (absm 0 'i)))) 'i)
(normalize-gbar
(unnormalize-gbar
(absm 5 (make-gbar :dmns 4
:list (list (absm 0 'a) (absm 0 'b)
(absm 0 'c) (absm 0 'i)))) 'i))
(unnormalize-gbar
(absm 9 (make-gbar :dmns 4
:list (list (absm 0 'a) (absm 0 'b)
(absm 0 'c) (absm 0 'i)))) 'i)
(normalize-gbar
(unnormalize-gbar
(absm 9 (make-gbar :dmns 4
:list (list (absm 0 'a) (absm 0 'b)
(absm 0 'c) (absm 0 'i)))) 'i))
|#
(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)))))))
#|
()
(gbar 0)
(gbar 1)
(gbar 2 1 'a 2 'b)
|#
(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))))
(the cmprf #'rslt)))
#|
(setf cmpr (classifying-space-cmpr 's-cmpr))
(funcall cmpr (gbar 2 0 'a 0 'a) (gbar 2 1 'a 0 'a))
(funcall cmpr (gbar 2 0 'a 0 'a) (gbar 2 0 'b 0 'a))
(funcall cmpr (gbar 2 0 'a 0 'a) (gbar 2 0 'a 0 'a))
|#
(DEFUN CLASSIFYING-SPACE-BASIS (basis)
(declare (type basis basis))
(when (eq basis :locally-effective)
(return-from classifying-space-basis :locally-effective))
(let ((crts-basis :locally-effective) ;; to be redefined
(idnt (first (funcall basis 0))))
(declare
(type basis crts-basis)
(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))))))
;;; :key #'caadr))))))
(setf crts-basis (crts-prdc-basis basis #'rslt))
(the basis #'rslt))))
#|
()
(cat-init)
(setf k (k-z2-1))
(setf b (classifying-space-basis (basis k)))
(funcall b 0)
(funcall b 1)
(dotimes (i 5) (print (funcall b i)))
|#
(DEFUN CLASSIFYING-SPACE-FACE (face sintr-grml)
(declare
(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))))))))))
(the face #'rslt)))
#|
(setf om (loop-space (moore 2 2)))
(setf face (classifying-space-face (face om) (sintr (grml om))))
(setf gbar (gbar 4 0 (loop3 3 'm2 1 4 'n3 1)
0 (loop3 0 'n3 1)
0 (loop3 0 'm2 1)
0 +null-loop+))
(dotimes (i 5)
(print (funcall face i 4 gbar)))
|#
(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))))
#|
(cat-init)
(setf c (classifying-space (k-z2-1)))
(orgn c)
(first (basis c 4))
(? c 4 (first (basis c 4)))
(? c *)
(cprd c 4 ***)
(dotimes (i 5)
(print (face c i 4 (first (basis c 4)))))
|#
(DEFUN CLASSIFYING-SPACE-GRML-SINTR (idnt sintr-grml)
(declare
(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)))))))
(the sintr #'rslt)))
#|
(setf grml (classifying-space-grml-sintr '() (sintr (grml (k-z-1)))))
(funcall grml 3 (crpr 0 (gbar 3 0 '(1 2) 0 '(3) 0 '())
0 (gbar 3 0 '(-1 -2) 0 '(-3) 0 '())))
(funcall grml 3 (crpr 0 (gbar 3 0 '(1 2) 0 '(3) 0 '())
4 (gbar 2 0 '(-3) 0 '())))
(funcall grml 3 (crpr 0 (gbar 3 0 '(1 2) 0 '(3) 0 '())
1 (gbar 2 0 '(-3) 0 '())))
|#
(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))))))
(the sintr #'rslt)))
#|
(setf grin (classifying-space-grin-sintr (sintr (grin (k-z-1)))))
(funcall grin 3 (gbar 3 0 '(1 2) 1 '() 0 '()))
|#
(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)))
#|
(setf k-z-1 (k-z-1))
(setf k-z-2 (classifying-space k-z-1))
(setf k-z-3 (classifying-space k-z-2))
(homology k-z-3 0 10)
(setf k-z2-1 (k-z2-1))
(setf k-z2-2 (classifying-space k-z2-1))
(setf k-z2-3 (classifying-space k-z2-2))
(setf k-z2-4 (classifying-space k-z2-3))
(setf k-z2-5 (classifying-space k-z2-4))
(homology k-z2-5 0 7)
|#

76
Kenzo-1/coalgebras.cl Normal file
View File

@ -0,0 +1,76 @@
;;; COALGEBRAS COALGEBRAS COALGEBRAS COALGEBRAS COALGEBRAS COALGEBRAS
;;; COALGEBRAS COALGEBRAS COALGEBRAS COALGEBRAS COALGEBRAS COALGEBRAS
;;; COALGEBRAS COALGEBRAS COALGEBRAS COALGEBRAS COALGEBRAS COALGEBRAS
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "coalgebras")
(DEFVAR *CLGB-LIST*)
(SETF *CLGB-LIST* +empty-list+)
(PUSHNEW '*CLGB-LIST* *list-list*)
#+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)))
#+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)))
(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
(let ((already (find orgn *clgb-list* :key #'orgn :test #'equal)))
(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))))
(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
(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)))
(setf (slot-value chcm 'cprd) (build-mrph
:sorc chcm :trgt (tnsr-prdc chcm chcm)
:degr 0
:intr intr-cprd :strt cprd-strt
:orgn orgn))
(push chcm *clgb-list*)
chcm)))

708
Kenzo-1/cobar.cl Normal file
View File

@ -0,0 +1,708 @@
;;; 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
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "cobar")
(DEFUN ALLP (&rest list)
(when (= 1 (length list))
(setf list (first list)))
(unless (evenp (length list))
(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)))))
#|
()
(allp )
(allp '(2 a 3 b))
(allp 2 'a 3 'b)
(allp 2 'a 3)) ;; error
|#
(DEFCONSTANT +NULL-ALLP+ (make-allp :list +empty-list+))
(DEFUN ALLP-PRINT (allp stream depth)
(declare
(type allp allp) (stream stream)
(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)))
(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))))))
(the cmprf #'rslt)))
#|
(setf r (cobar-cmpr #'s-cmpr))
(funcall r (allp) (allp))
(funcall r (allp 3 'a) (allp))
(funcall r (allp 3 'a) (allp 2 'a 1 'b))
(funcall r (allp 3 'a) (allp 3 'b))
(funcall r (allp 3 'a) (allp 3 'a)))
|#
(DEFUN COBAR-BASIS-LENGTH (basis degr length)
(declare
(type basis basis)
(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)))))
#|
(setf basis #'(lambda (degr)
(list degr)))
(cobar-basis-length basis 1 1)
(cobar-basis-length basis 2 1)
(cobar-basis-length basis 2 2)
(cobar-basis-length basis 3 1)
(cobar-basis-length basis 3 2)
(cobar-basis-length basis 3 3)
|#
(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))))
#| The following version of the COBAR-BASIS function is
not correctly compiled with ACL-Unix, probably
because the too complicated (but natural and correct)
structure of closures. This version works on ACL-PC.
(DEFUN COBAR-BASIS (basis)
(declare
(type basis basis))
;; if the coalgebra is effective, it is assumed simply-connected :
;; (length (funcall basis 0)) ==> 1
;; (length (funcall basis 1)) ==> 0
(the basis
(progn
(when (eq :locally-effective basis)
(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))))))))
|#
#|
(setf basis #'(lambda (degr)
(list degr)))
(setf r (cobar-basis basis))
(funcall r 0)
(funcall r 1)
(funcall r 2)
(dotimes (i 7)
(print (funcall r i)))
(cobar-basis :locally-effective)
|#
(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
(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)))))))))
(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))))))))
#|
(setf d (soft-delta-infinity))
(setf r (cobar-intr-vrtc-dffr (dffr d)))
(funcall r 0 (allp))
(funcall r 3 (allp 3 (d 15)))
(funcall r 5 (allp 3 (d (mask 5)) 2 (d (mask 4))))
(funcall r 5 (allp 2 (d (mask 4)) 3 (d (mask 5)))))
|#
(DEFMETHOD VRTC-COBAR ((chcm chain-complex))
(the chain-complex
(with-slots (cmpr basis dffr) chcm
(declare
(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)))))
#|
(cat-init)
(setf v (vrtc-cobar (soft-delta-infinity)))
(defun random-allp (length)
(let ((rslt nil))
(dotimes (i length)
(let* ((gmsm (random (mask 9)))
(dmns (1- (logcount gmsm))))
(when (plusp dmns)
(push (cbgn (1- dmns) (d gmsm)) rslt))))
(make-allp :list rslt)))
(dotimes (i 10) (print (random-allp 5)))
(dotimes (i 10)
(let ((allp (random-allp 3)))
(print allp)
(print (? v (apply #'+ (mapcar #'car (allp-list allp))) allp))
(print (? v (? v (apply #'+ (mapcar #'car (allp-list allp))) allp)))))
|#
(DEFUN COBAR-INTR-HRZN-DFFR (cprd)
(declare (type morphism cprd))
(labels ((rslt (degr iallp)
(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))
(setf cprd-gnrt1 (rest (butlast cprd-gnrt1))) ;;; because \bar{A}
(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)))))))))
#|
(setf d (soft-delta-infinity))
(setf r (cobar-intr-hrzn-dffr (cprd d)))
(funcall r 0 (allp))
(funcall r 3 (allp 3 (d (mask 5))))
(funcall r 5 (allp 3 (d (mask 5)) 2 (d (mask 4))))
(funcall r 5 (allp 2 (d (mask 4)) 3 (d (mask 5))))
|#
(DEFUN COBAR-HRZN-DFFR (clgb)
(declare (type coalgebra clgb))
(the morphism
(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)))))
#|
(cat-init)
(setf h (cobar-hrzn-dffr (soft-delta-infinity)))
(defun random-allp (length)
(let ((rslt nil))
(dotimes (i length)
(let* ((gmsm (random (mask 9)))
(dmns (1- (logcount gmsm))))
(when (plusp dmns)
(push (cbgn (1- dmns) (d gmsm)) rslt))))
(make-allp :list rslt)))
(dotimes (i 10) (print (random-allp 5)))
(setf allp (random-allp 4))
(? h (apply #'+ (mapcar #'car (allp-list allp))) allp)
(? h (? h (apply #'+ (mapcar #'car (allp-list allp))) allp))
(dotimes (i 10)
(let ((allp (random-allp 3)))
(print allp)
(print (? h (apply #'+ (mapcar #'car (allp-list allp))) allp))
(print (? h (? h (apply #'+ (mapcar #'car (allp-list allp))) allp)))))
|#
(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 bug, when the
;;; first result is stored in memory...
(cmbn-list (gnrt-? vrtc-dffr degr allp))
(cmbn-list (gnrt-? hrzn-dffr degr allp))))))
(the intr-mrph #'rslt)))
(DEFMETHOD COBAR ((coalgebra coalgebra))
(let ((vrtc-cobar (vrtc-cobar coalgebra))
(cobar-hrzn-dffr (cobar-hrzn-dffr coalgebra)))
(declare (type chain-complex vrtc-cobar)
(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))))
#|
(cat-init)
(setf c (cobar (deltab)))
(defun random-allp (length)
(let ((rslt nil))
(dotimes (i length)
(let* ((gmsm (random (mask 9)))
(dmns (1- (logcount gmsm))))
(when (plusp dmns)
(push (cbgn (1- dmns) gmsm) rslt))))
(make-allp :list rslt)))
(dotimes (i 10) (print (random-allp 5)))
(setf allp (random-allp 4))
(? c (apply #'+ (mapcar #'car (allp-list allp))) allp)
(? c (? c (apply #'+ (mapcar #'car (allp-list allp))) allp))
(dotimes (i 10)
(let ((allp (random-allp 3)))
(print allp)
(print (? c (apply #'+ (mapcar #'car (allp-list allp))) allp))
(print (? c (? c (apply #'+ (mapcar #'car (allp-list allp))) allp)))))
|#
(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))))))
(DEFUN NCMBN-COBAR (cmbn-list)
(declare (list cmbn-list))
(the cmbn
(progn
(unless cmbn-list
(return-from ncmbn-cobar (cmbn 0 1 +null-allp+)))
(cmbn-allp-cmbn-tnpr
(first cmbn-list)
(ncmbn-cobar (rest cmbn-list))))))
#|
(ncmbn-cobar nil)
(ncmbn-cobar (list (cmbn 3 2 'a 3 'b)))
(ncmbn-cobar (list (cmbn 1 2 'a 3 'b) (cmbn 2 4 'c 5 'd)))
(ncmbn-cobar (list (cmbn 1 2 'a 3 'b) (cmbn 1 4 'c 5 'd) (cmbn 1 6 'e 7 'f)))
|#
(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))))))
(the intr-mrph #'rslt)))
#|
(setf cc (build-chcm :cmpr #'f-cmpr :strt :cmbn))
(setf m (build-mrph :sorc cc :trgt cc :degr 0 :intr
#'(lambda (degr gnrt) (cmbn degr 2 gnrt 3 (1+ gnrt)))
:strt :gnrt :orgn '(test)))
(setf r (mrph-vrtc-cobar-intr m))
(funcall r 4 (allp 2 3 2 4))
|#
(DEFMETHOD VRTC-COBAR ((mrph morphism))
(the morphism
(if (eq (first (orgn mrph)) 'idnt-mrph)
(idnt-mrph (vrtc-cobar (sorc mrph)))
(build-mrph
:sorc (vrtc-cobar (sorc mrph))
:trgt (vrtc-cobar (trgt mrph))
:degr 0
:intr (mrph-vrtc-cobar-intr mrph)
:strt :gnrt
:orgn `(vrtc-cobar ,mrph)))))
#|
(cat-init)
(setf f (aw (soft-delta-infinity) (soft-delta-infinity)))
(setf cf (vrtc-cobar f))
(? cf 2 (allp 1 (crpr 0 (d 7) 0 (d 7)) 1 (crpr 0 (d 56) 0 (d 56))))
|#
(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)
(fixnum 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 cmbn 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)))
#|
(require "special-smsts")
(require "eilenberg-zilber")
(cat-init)
(setf ez (ez (delta-infinity) (delta-infinity)))
(setf h (h ez) gf (cmps (g ez) (f ez)))
(setf r (hmtp-vrtc-cobar-intr h gf))
(funcall r 3 (allp 1 (crpr 0 7 0 7) 1 (crpr 0 14 0 14) 1 (crpr 0 14 0 14)))
|#
(DEFUN HMTP-VRTC-COBAR (h gf)
(declare (type morphism h gf))
(unless (and (= +1 (degr h))
(= +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)))
(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
:sorc (vrtc-cobar (sorc h)) :trgt (vrtc-cobar (sorc h)) :degr +1
:intr (hmtp-vrtc-cobar-intr h gf)
:strt :gnrt
:orgn `(hmtp-vrtc-cobar ,h ,gf)))))
(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))))))
#|
(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)))
(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)))
(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)))
(setf g (build-mrph :sorc bcc :trgt tcc :degr 0
: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)))
(setf rdct (build-rdct :f f :g g :h h :orgn '(rdct)))
(tcc rdct 3 'a)
(g rdct (f rdct 3 'a))
(h rdct 3 'a)
(setf cobar (vrtc-cobar rdct))
(pre-check-rdct cobar)
(defun aleat-tc ()
(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)))
(rslt nil (cons (cbgn degr gnrt) rslt)))
((> tdegr 10) (setf *tc* (cmbn tdegr 1 (make-allp :list rslt))))))
(aleat-tc)
(defun aleat-bc ()
(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)))
(rslt nil (cons (cbgn degr gnrt) rslt)))
((> tdegr 10) (setf *bc* (cmbn tdegr 1 (make-allp :list rslt))))))
(aleat-bc)
(defun c ()
(aleat-tc)
(aleat-bc)
(check-rdct))
(loop (c)) ;; degrees >= 15 is possible => error.
|#
(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))))))
(DEFMETHOD COBAR ((hmeq homotopy-equivalence))
(unless (typep (lbcc hmeq) 'coalgebra)
(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))))))
#|
(cat-init)
(setf h (left-hmeq (sphere 3)))
(setf c (cobar h))
(inspect c)
|#

674
Kenzo-1/combinations.cl Normal file
View File

@ -0,0 +1,674 @@
;;; COMBINATIONS COMBINATIONS COMBINATIONS COMBINATIONS COMBINATIONS
;;; COMBINATIONS COMBINATIONS COMBINATIONS COMBINATIONS COMBINATIONS
;;; COMBINATIONS COMBINATIONS COMBINATIONS COMBINATIONS COMBINATIONS
(IN-PACKAGE "COMMON-LISP-USER")
(provide "combinations")
;;;;
;;;; COMPARISONS.
;;;;
(DEFUN CMBN-PRINT (cmbn stream depth)
(declare
(type cmbn cmbn) (stream stream)
(ignore depth))
(the cmbn
(with-cmbn (degr list) cmbn
(format stream "~%~70@{-~}{CMBN ~D}" degr)
(do ((mark list (cdr mark))
(nth 0 (1+ nth)))
((endp mark))
(declare
(list mark)
(fixnum nth))
(when (and *print-length* (= nth *print-length*))
(format stream "~%... ...")
(return))
(format stream "~%<~D * ~A>" (-cffc mark) (-gnrt mark)))
(format stream "~%~78@{-~}~%" t)
cmbn)))
(DEFUN MAPLEXICO (cmpr list1 list2)
(declare
(type cmprf cmpr)
(list list1 list2))
(the boolean
(do ((mark1 list1 (cdr mark1))
(mark2 list2 (cdr mark2)))
(nil)
(declare (list mark1 mark2))
(unless mark1
(return-from maplexico
(if mark2 :less :equal)))
(unless mark2
(return-from maplexico :greater))
(case (funcall cmpr (car mark1) (car mark2))
(:less (return-from maplexico :less))
(:greater (return-from maplexico :greater))))))
#|
(maplexico #'f-cmpr '(1 2 3) '(1 3))
(maplexico #'f-cmpr '(1 2 3) '(1 1))
(maplexico #'f-cmpr '(1 1) '(1 1 0))
(maplexico #'f-cmpr '(1 1 0) '(1 1))
(maplexico #'f-cmpr '(1 1) '(1 1))
(maplexico #'f-cmpr nil nil)
|#
(DEFUN S-CMPR (symbol1 symbol2)
(declare (symbol symbol1 symbol2))
(the cmpr
(if (#+aclpc acl:whole-string<
#-aclpc string< symbol1 symbol2)
:less
(if (#+aclpc acl:whole-string=
#-aclpc string= symbol1 symbol2)
:equal
:greater))))
(DEFUN F-CMPR (n1 n2)
(declare (fixnum n1 n2))
(the cmpr
(if (< n1 n2)
:less
(if (= n1 n2)
:equal
:greater))))
(DEFUN L-CMPR (list1 list2)
(declare (list list1 list2))
(unless list1
(return-from l-cmpr (if list2 :less :equal)))
(unless list2
(return-from l-cmpr :greater))
(if (symbolp (first list1))
(if (symbolp (first list2))
(lexico
(s-cmpr (first list1) (first list2))
(l-cmpr (rest list1) (rest list2)))
:greater)
(if (symbolp (first list2))
:less
(lexico
(f-cmpr (first list1) (first list2))
(l-cmpr (rest list1) (rest list2))))))
#|
(s-cmpr 'a 'b)
(s-cmpr 'b 'b)
(s-cmpr 'c 'b)
(f-cmpr 1 2)
(f-cmpr 2 2)
(f-cmpr 3 2)
(l-cmpr nil nil)
(l-cmpr nil '(1))
(l-cmpr '(1) nil)
(l-cmpr '(a) '(a))
(l-cmpr '(a) '(1))
(l-cmpr '(1) '(a))
(l-cmpr '(1) '(1))
(l-cmpr '(1 a) '(1 1))
(l-cmpr '(1 a) '(1 a b)))
|#
;;;;
;;;; COMBINATIONS
;;;;
#|
(DEFUN CMBN (degr &rest rest)
(declare (fixnum degr))
(the cmbn
(let ((rslt (list degr :cmbn)))
(do ((mark rest (cddr mark)))
((endp mark) (nreverse rslt))
(declare (list mark))
(push (term (car mark) (cadr mark)) rslt)))))
|#
(DEFUN CMBN (degr &rest rest)
(declare (fixnum degr))
(the cmbn
(make-cmbn :degr degr
:list (do ((rslt +empty-list+
(cons (term (car mark) (cadr mark)) rslt))
(mark rest (cddr mark)))
((endp mark) (nreverse rslt))
(declare (list rslt mark))))))
#|
(cmbn 2)
(cmbn 2 2 'a)
(cmbn 2 'a)
(cmbn 2 2 'a -3 'b))
(term-cmbn 3 -5 'a)
|#
#+allegro
(setf *print-pretty* nil)
(DEFUN CHECK-CMBN (chcm cmbn)
(declare
(type chain-complex chcm)
(type cmbn cmbn))
(the boolean
(do ((cmpr (cmpr chcm))
(mark2 (cmbn-list cmbn) mark1)
(mark1 (rest (cmbn-list cmbn)) (cdr mark1)))
((endp mark1) t)
(declare
(type cmprf cmpr)
(list mark1 mark2))
(unless (eq :less (funcall cmpr (-gnrt mark2) (-gnrt mark1)))
(error "In CHECK-CMBN, bad order; the generator:~@
~A~@
is not less than the generator:~@
~A."
(-gnrt mark2) (-gnrt mark1))))))
(DEFUN ZERO-CMBN (degr)
(declare (fixnum degr))
(the cmbn
(make-cmbn
:degr degr
:list +empty-list+)))
#|
(zero-cmbn 3))
|#
(DEFUN ZERO-INTR-DFFR (cmbn)
(declare (type cmbn cmbn))
(the cmbn (zero-cmbn (1- (cmbn-degr cmbn)))))
#|
(zero-intr-dffr (cmbn 2))
|#
(DEFCONSTANT +ZERO-NEGATIVE-CMBN+
(make-cmbn :degr -1 :list +empty-list+))
#|
(cmbn-non-zero-p (cmbn 0))
(cmbn-non-zero-p (cmbn 0 1 'a)))
(cmbn-zero-p (cmbn 0))
(cmbn-zero-p (cmbn 0 1 'a)))
|#
(DEFUN CMBN-OPPS (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 gnrt) term
(term (- cffc) gnrt)))
list)))))
#|
(setf c (cmbn 0 1 'a -2 'b))
(cmbn-opps c)
(symbol-value 'c))
|#
(DEFUN N-CMBN (n cmbn)
;; n is assumed non-zero
(declare
(fixnum n)
(type cmbn cmbn))
(the cmbn
(if (= n 1)
cmbn
(with-cmbn (degr list) cmbn
(make-cmbn
:degr degr
:list (mapcar #'(lambda (term)
(declare (type term term))
(with-term (cffc gnrt) term
(term (* n cffc) gnrt)))
list))))))
#|
(setf c (cmbn 2 3 'a))
(setf c2 (n-cmbn 1 c))
(eq c c2)
(n-cmbn -1 c)
(n-cmbn -3 c))
|#
(DEFUN 2CMBN-ADD (cmpr cmbn1 cmbn2)
(declare
(type cmprf cmpr)
(type cmbn cmbn1 cmbn2))
(the cmbn
(with-cmbn (degr1 list1) cmbn1
(with-cmbn (degr2 list2) cmbn2
(unless (= degr1 degr2)
(error "In ADD, the combination arguments have different degrees ~D and ~D."
degr1 degr2))
(unless list1
(return-from 2cmbn-add cmbn2))
(unless list2
(return-from 2cmbn-add cmbn1))
(let ((pre-rslt +empty-list+)
(mark1 list1)
(mark2 list2))
(declare (list pre-rslt mark1 mark2))
(with--term (cffc1 gnrt1) mark1
(with--term (cffc2 gnrt2) mark2
(tagbody
:begin
(ecase (funcall cmpr gnrt1 gnrt2)
(:equal
(let ((cffc (+ cffc1 cffc2)))
(declare (fixnum cffc))
(unless (zerop cffc)
(push (term cffc gnrt1) pre-rslt))
(setf mark1 (cdr mark1)
mark2 (cdr mark2))
(unless mark1 (go :cmbn1-is-finished))
(unless mark2 (go :cmbn2-is-finished))
(setf cffc1 (-cffc mark1)
gnrt1 (-gnrt mark1)
cffc2 (-cffc mark2)
gnrt2 (-gnrt mark2))
(go :begin)))
(:less
(push (-term mark1) pre-rslt)
(setf mark1 (cdr mark1))
(unless mark1 (go :cmbn1-is-finished))
(setf cffc1 (-cffc mark1)
gnrt1 (-gnrt mark1))
(go :begin))
(:greater
(push (-term mark2) pre-rslt)
(setf mark2 (cdr mark2))
(unless mark2 (go :cmbn2-is-finished))
(setf cffc2 (-cffc mark2)
gnrt2 (-gnrt mark2))
(go :begin)))
:cmbn1-is-finished
(setf pre-rslt (nreconc pre-rslt mark2))
(go :exit)
:cmbn2-is-finished
(setf pre-rslt (nreconc pre-rslt mark1))
:exit))
(make-cmbn :degr degr1 :list pre-rslt)))))))
#|
(2cmbn-add #'s-cmpr (cmbn 0) (cmbn 1))
(2cmbn-add #'s-cmpr (cmbn 0) (cmbn 0))
(2cmbn-add #'s-cmpr (cmbn 0 1 'a) (cmbn 0))
(2cmbn-add #'s-cmpr (cmbn 0 1 'a) (cmbn 0 2 'a))
(2cmbn-add #'s-cmpr (cmbn 0 1 'a) (cmbn 0 -1 'a))
(2cmbn-add #'s-cmpr (cmbn 0 1 'a) (cmbn 0 2 'b))
(2cmbn-add #'s-cmpr (cmbn 0 2 'b) (cmbn 0 1 'a))
(2cmbn-add #'s-cmpr (cmbn 0 1 'a -2 'b) (cmbn 0 2 'b))
(2cmbn-add #'s-cmpr (cmbn 0 2 'b) (cmbn 0 1 'a 3 'c)))
|#
(DEFUN 2CMBN-SBTR (cmpr cmbn1 cmbn2)
(declare
(type cmprf cmpr)
(type cmbn cmbn1 cmbn2))
(the cmbn
(with-cmbn (degr1 list1) cmbn1
(with-cmbn (degr2 list2) cmbn2
(unless (= degr1 degr2)
(error "In SBTR, the combination arguments have different degrees ~D and ~D."
degr1 degr2))
(unless list1
(return-from 2cmbn-sbtr (cmbn-opps cmbn2)))
(unless list2
(return-from 2cmbn-sbtr cmbn1))
(let ((pre-rslt +empty-list+)
(mark1 list1)
(mark2 list2))
(declare (list pre-rslt mark1 mark2))
(with--term (cffc1 gnrt1) mark1
(with--term (cffc2 gnrt2) mark2
(tagbody
:begin
(ecase (funcall cmpr gnrt1 gnrt2)
(:equal
(let ((cffc (- cffc1 cffc2)))
(declare (fixnum cffc))
(unless (zerop cffc)
(push (term cffc gnrt1) pre-rslt))
(unless mark1 (go :cmbn1-is-finished))
(setf mark1 (cdr mark1)
mark2 (cdr mark2))
(unless mark1 (go :cmbn1-is-finished))
(unless mark2 (go :cmbn2-is-finished))
(setf cffc1 (-cffc mark1)
gnrt1 (-gnrt mark1)
cffc2 (-cffc mark2)
gnrt2 (-gnrt mark2))
(go :begin)))
(:less
(push (-term mark1) pre-rslt)
(setf mark1 (cdr mark1))
(unless mark1 (go :cmbn1-is-finished))
(setf cffc1 (-cffc mark1)
gnrt1 (-gnrt mark1))
(go :begin))
(:greater
(push (term (- cffc2) gnrt2) pre-rslt)
(setf mark2 (cdr mark2))
(unless mark2 (go :cmbn2-is-finished))
(setf cffc2 (-cffc mark2)
gnrt2 (-gnrt mark2))
(go :begin)))
:cmbn1-is-finished
(setf pre-rslt
(nreconc pre-rslt
(mapcar #'(lambda (term)
(declare (cons term))
(with-term (cffc gnrt) term
(term (- cffc) gnrt)))
mark2)))
(go :exit)
:cmbn2-is-finished
(setf pre-rslt (nreconc pre-rslt mark1))
:exit))
(make-cmbn
:degr degr1
:list pre-rslt)))))))
#|
(2cmbn-sbtr #'s-cmpr (cmbn 0) (cmbn 1))
(2cmbn-sbtr #'s-cmpr (cmbn 0) (cmbn 0))
(2cmbn-sbtr #'s-cmpr (cmbn 0) (cmbn 0 1 'a))
(2cmbn-sbtr #'s-cmpr (cmbn 0 2 'b) (cmbn 0))
(2cmbn-sbtr #'s-cmpr (cmbn 0 3 'b) (cmbn 0 3 'b))
(2cmbn-sbtr #'s-cmpr (cmbn 0 3 'b) (cmbn 0 4 'b))
(2cmbn-sbtr #'s-cmpr
(cmbn 0 1 'a 2 'c 2 'd 3 'g)
(cmbn 0 1 'c -2 'd 4 'f -3 'g 4 'h))
(2cmbn-sbtr #'s-cmpr
(cmbn 0 1 'c -2 'd 4 'f -3 'g 4 'h)
(cmbn 0 1 'a 2 'c 2 'd 3 'g))
(2cmbn-sbtr #'s-cmpr
(cmbn 0 1 'c -2 'd 4 'f -3 'g)
(cmbn 0 1 'a 2 'c 2 'd 3 'g))
(2cmbn-sbtr #'s-cmpr
(cmbn 0 1 'b 2 'a)
(cmbn 0 1 'a 1 'b))) ;;; !!!
(2cmbn-sbtr #'s-cmpr
(cmbn 0 1 'b 2 'c)
(cmbn 0 1 'a 1 'b)))
|#
(DEFUN 2N-2CMBN (cmpr n1 cmbn1 n2 cmbn2)
;; n1 * cmbn1 + n2 * cmbn2
;; combinations may be null but not n1 and n2
(declare
(type cmprf cmpr)
(fixnum n1 n2)
(type cmbn cmbn1 cmbn2))
(the cmbn
(with-cmbn (degr1 list1) cmbn1
(with-cmbn (degr2 list2) cmbn2
(unless (= degr1 degr2)
(error "In 2N-2CMBN, the combination arguments have different degrees ~D and ~D."
degr1 degr2))
(unless list1
(return-from 2n-2cmbn (n-cmbn n2 cmbn2)))
(unless list2
(return-from 2n-2cmbn (n-cmbn n1 cmbn1)))
(let ((pre-rslt +empty-list+)
(mark1 list1)
(mark2 list2))
(declare (list pre-rslt mark1 mark2))
(with--term (cffc1 gnrt1) mark1
(with--term (cffc2 gnrt2) mark2
(setf cffc1 (* n1 cffc1)
cffc2 (* n2 cffc2))
(tagbody
:begin
(ecase (funcall cmpr gnrt1 gnrt2)
(:equal
(let ((cffc (+ cffc1 cffc2)))
(declare (fixnum cffc))
(unless (zerop cffc)
(push (term cffc gnrt1) pre-rslt))
(setf mark1 (cdr mark1)
mark2 (cdr mark2))
(unless mark1 (go :cmbn1-is-finished))
(unless mark2 (go :cmbn2-is-finished))
(setf cffc1 (* n1 (-cffc mark1))
gnrt1 (-gnrt mark1)
cffc2 (* n2 (-cffc mark2))
gnrt2 (-gnrt mark2))
(go :begin)))
(:less
(push (term cffc1 gnrt1) pre-rslt)
(setf mark1 (cdr mark1))
(unless mark1 (go :cmbn1-is-finished))
(setf cffc1 (* n1 (-cffc mark1))
gnrt1 (-gnrt mark1))
(go :begin))
(:greater
(push (term cffc2 gnrt2) pre-rslt)
(setf mark2 (cdr mark2))
(unless mark2 (go :cmbn2-is-finished))
(setf cffc2 (* n2 (-cffc mark2))
gnrt2 (-gnrt mark2))
(go :begin)))
:cmbn1-is-finished
(setf pre-rslt
(nreconc pre-rslt
(if (= 1 n2)
mark2
(mapcar #'(lambda (term)
(declare (cons term))
(with-term (cffc gnrt) term
(term (* n2 cffc) gnrt)))
mark2))))
(go :exit)
:cmbn2-is-finished
(setf pre-rslt
(nreconc pre-rslt
(if (= 1 n1)
mark1
(mapcar #'(lambda (term)
(declare (cons term))
(with-term (cffc gnrt) term
(term (* n1 cffc) gnrt)))
mark1))))
:exit))
(make-cmbn
:degr degr1
:list pre-rslt)))))))
#|
(2n-2cmbn #'s-cmpr 3 (cmbn 0) 4 (cmbn 1))
(2n-2cmbn #'s-cmpr 3 (cmbn 0) 4 (cmbn 0))
(2n-2cmbn #'s-cmpr 3 (cmbn 0 1 'a) 4 (cmbn 0))
(2n-2cmbn #'s-cmpr 3 (cmbn 0 1 'a 2 'b 3 'c )
1 (cmbn 0 -3 'a 2 'b 4 'd))
(2n-2cmbn #'s-cmpr 3 (cmbn 0 -3 'a 2 'b 4 'd)
1 (cmbn 0 1 'a 2 'b 3 'c ))
(2n-2cmbn #'s-cmpr 1 (cmbn 0 1 'a 2 'b 3 'c )
1 (cmbn 0 -3 'a 2 'b 4 'd))
(2n-2cmbn #'s-cmpr 1 (cmbn 0 -3 'a 2 'b 4 'd)
1 (cmbn 0 1 'a 2 'b 3 'c ))
(2n-2cmbn #'s-cmpr 1 (cmbn 0 -3 'a 2 'b 4 'd)
3 (cmbn 0 1 'a 2 'b 3 'c )))
|#
(DEFUN CMBN-CMBN (cmpr n-cmbn-list)
;; n-cmbn-list = list of (cons n cmbn)
;; non-empty-list
;; every n is non-null
(declare
(type cmprf cmpr)
(list n-cmbn-list))
(unless (rest n-cmbn-list)
(return-from cmbn-cmbn
(n-cmbn (caar n-cmbn-list) (cdar n-cmbn-list))))
(unless (cddr n-cmbn-list)
(return-from cmbn-cmbn
(2n-2cmbn cmpr
(caar n-cmbn-list) (cdar n-cmbn-list)
(caadr n-cmbn-list) (cdadr n-cmbn-list))))
(the cmbn
(let ((new-rslt +empty-list+))
(declare (list new-rslt))
(do ((mark1 (rest n-cmbn-list) (cddr mark1))
(mark2 n-cmbn-list (cdr mark1)))
((endp mark2))
(declare (list mark1 mark2))
(when (endp mark1)
(push (n-cmbn (caar mark2) (cdar mark2)) new-rslt)
(return))
(push (2n-2cmbn cmpr
(caar mark2) (cdar mark2)
(caar mark1) (cdar mark1))
new-rslt))
(let ((old-rslt +empty-list+))
(declare (list old-rslt))
(loop
(unless (rest new-rslt)
(return-from cmbn-cmbn (first new-rslt)))
(setf old-rslt new-rslt
new-rslt +empty-list+)
(do ((mark1 (rest old-rslt) (cddr mark1))
(mark2 old-rslt (cdr mark1)))
((endp mark2))
(declare (list mark1 mark2))
(when (endp mark1)
(push (car mark2) new-rslt)
(return))
(push (2cmbn-add cmpr (car mark2) (car mark1))
new-rslt)))))))
#|
(setf cons (cons 3 (cmbn 0 4 'a)))
(cmbn-cmbn #'s-cmpr (make-list 5 :initial-element cons))
(dotimes (i 10)
(print
(cffc (first (cmbn-list
(cmbn-cmbn #'s-cmpr (make-list (1+ i) :initial-element cons))))))))
|#
(DEFUN NTERM-ADD (cmpr degr &rest rest)
(declare
(type cmprf cmpr)
(fixnum degr)
(list rest))
;; (list term)
(unless rest
(return-from nterm-add (zero-cmbn degr)))
(the cmbn
(let ((rslt (list (first rest))))
(declare (list rslt))
(dolist (term (rest rest))
(declare (type term term))
(with-term (cffc gnrt) term
(do ((mark1 rslt (cdr mark1))
(mark2 nil mark1))
((endp mark1) (setf (cdr mark2) (list term)))
(ecase (funcall cmpr gnrt (-gnrt mark1))
(:less
(if mark2
(push term (cdr mark2))
(push term rslt))
(return))
(:equal
(incf (-cffc mark1) cffc)
(return))
(:greater )))))
(make-cmbn
:degr degr
:list (delete 0 rslt :key #'car)))))
#|
(nterm-add #'s-cmpr 11)
(nterm-add #'s-cmpr 11 (term 1 'a))
(nterm-add #'s-cmpr 11 (term 1 'a) (term 2 'b))
(nterm-add #'s-cmpr 11 (term 1 'b) (term 2 'a) (term 3 'aa)
(term -2 'aa) (term -2 'a) (term 4 'aab)
(term 5 'c))
|#
(DEFUN NCMBN-ADD (cmpr cmbn &rest rest)
(declare
(type cmprf cmpr)
(type cmbn cmbn))
(the cmbn
(cmbn-cmbn cmpr (mapcar #'(lambda (cmbn)
(declare (type cmbn cmbn))
(cons 1 cmbn))
(cons cmbn rest)))))
#|
(setf c (cmbn 3 4 'a))
(ncmbn-add #'s-cmpr c c c c c)
|#
(DEFUN DSTR-ADD-TERM-TO-CMBN (cmpr cffc gnrt cmbn)
(declare
(type cmprf cmpr)
(fixnum cffc) ;; non-zero
(type gnrt gnrt)
(type cmbn cmbn))
(the cmbn
(let ((list (cmbn-list cmbn)))
(declare (list list))
(unless list
(push (term cffc gnrt) (cmbn-list cmbn))
(return-from dstr-add-term-to-cmbn cmbn))
(do ((mark2 nil mark1)
(mark1 list (cdr mark1)))
((endp mark1) (setf (cdr mark2) (list (term cffc gnrt))))
(declare (list mark1 mark2))
(ecase (funcall cmpr gnrt (-gnrt mark1))
(:less
(if mark2
(push (term cffc gnrt) (cdr mark2))
(push (term cffc gnrt) (cmbn-list cmbn)))
(return))
(:equal
(let ((new-cffc (+ cffc (-cffc mark1))))
(declare (fixnum new-cffc))
(if (zerop new-cffc)
(if mark2
(pop (cdr mark2))
(pop (cmbn-list cmbn)))
(setf (-cffc mark1) new-cffc))
(return)))
(:greater)))
cmbn)))
#|
()
(setf c (zero-cmbn 10))
(dstr-add-term-to-cmbn #'s-cmpr 3 'f c)
(eq * c)
(dstr-add-term-to-cmbn #'s-cmpr 3 'g c)
(eq * c)
(dstr-add-term-to-cmbn #'s-cmpr 3 'a c)
(eq * c)
(dstr-add-term-to-cmbn #'s-cmpr 3 'd c)
(eq * c)
(dstr-add-term-to-cmbn #'s-cmpr -3 'd c)
(eq * c)
(dstr-add-term-to-cmbn #'s-cmpr -2 'a c)
(dstr-add-term-to-cmbn #'s-cmpr -1 'a c)
(eq * c)
(dstr-add-term-to-cmbn #'s-cmpr -3 'g c)
(eq * c)
(dstr-add-term-to-cmbn #'s-cmpr -3 'f c)
(eq * c))
|#

368
Kenzo-1/cones.cl Normal file
View File

@ -0,0 +1,368 @@
;;; 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
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "cones")
(DEFUN CONE-PRINT (cone stream depth)
(declare
(type cone cone)
(stream stream)
(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)))
#|
()
(con0 'a)
(con1 'a)
(con0 (con0 'a))
(con0 (con1 'a))
(con1 (con0 'a))
(con1 (con1 'a))
(con0 (con1 (con0 (con1 'a))))
|#
(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)))
#|
()
(setf cmpr (cone-cmpr #'s-cmpr #'f-cmpr))
(funcall cmpr (con0 'a) (con0 'b))
(funcall cmpr (con0 'b) (con0 'b))
(funcall cmpr (con0 'b) (con0 'a))
(funcall cmpr (con0 'b) (con1 '2))
(funcall cmpr (con1 '2) (con0 'b))
(funcall cmpr (con1 '1) (con1 '2))
(funcall cmpr (con1 '2) (con1 '2))
(funcall cmpr (con1 '2) (con1 '1))
|#
(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))))
#|
()
(setf basis (cone-basis
#'(lambda (n) (list n))
#'(lambda (n) (list n))))
(funcall basis 4)
|#
(DEFUN TERM-CON0 (term)
(declare (type term term))
(the term
(term (cffc term)
(con0 (gnrt term)))))
(DEFUN TERM-CON1 (term)
(declare (type term term))
(the term
(term (cffc term)
(con1 (gnrt term)))))
(DEFUN TERM-UNCON (term)
(declare (type term term))
(the term
(term (cffc term) (icon (gnrt term)))))
#|
()
(term-con0 (term 2 'a))
(term-con1 (term 2 'a))
(term-uncon (term 2 (con0 'a)))
|#
(DEFUN CMBN-CON0 (cmbn)
(declare (type cmbn cmbn))
(the cmbn
(make-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)))))
#|
()
(cmbn-con0 (cmbn 3 1 'a 2 'b))
(cmbn-con1 (cmbn 3 1 'a 2 'b))
|#
(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))))))
#|
()
(cone-cmbn-split
(cmbn 3 4 (con0 'a) 5 (con1 'b)))
(cone-cmbn-split (cmbn 3 4 (con0 'a)))
(cone-cmbn-split (cmbn 3 4 (con1 'a)))
|#
(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))))))
#|
()
(cone-2cmbn-append (cmbn 3 4 'a) (cmbn 2 5 'b))
|#
(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)))
#|
()
(setf mrph (dffr (delta 4)))
(setf rslt (cone-2mrph-diag-impl mrph mrph))
(funcall rslt (cmbn 3 4 (con0 15) 5 (con1 7)))
|#
(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)))
#|
()
(setf rslt (cone-3mrph-triangle-impl #'f-cmpr
(dffr (delta 4))
(dffr (delta 4))
(idnt-mrph (delta 4))))
(funcall rslt 4 (con0 '31))
(funcall rslt 5 (con1 '31))
(funcall rslt 4 (con1 '15))
; (funcall rslt (cmbn 4 1 (con0 '31) 1 (con1 '15)))
|#
(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)))))
#|
()
(cat-init)
(setf k (k-z 1))
(setf u (idnt-mrph k))
(setf c (cone u))
(setf *tc* (cmbn 4 1 (con0 '(1 2 3 4))))
(? c 4 (con0 '(1 2 3 4)))
(? c *tc*)
|#
#|
()
(setf cone (cone (idnt-mrph (delta 4))))
(? cone (cmbn 4 1 (con0 '31) -1 (con1 '15)))
(? cone *)
|#
(DEFUN CONE-2MRPH-DIAG (sorc-cone trgt-cone mrph0 mrph1)
(declare
(type chain-complex sorc-cone trgt-cone)
(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)))))
#|
()
(setf idnt (idnt-mrph (delta 4)))
(setf cone (cone idnt))
(setf ff (cone-2mrph-diag cone cone idnt idnt))
(? ff (cmbn 4 1 (con0 '31) 10 (con1 '15)))
|#
(DEFUN CONE-3MRPH-TRIANGLE (sorc-cone trgt-cone mrph0 mrph1 phi)
(declare
(type chain-complex sorc-cone trgt-cone)
(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)))))
#|
()
(cat-init)
(setf d (delta 4))
(setf df (dffr (delta 4)))
(setf n (idnt-mrph d))
(setf c (cone n))
(setf z (sbtr (dffr c)
(cone-3mrph-triangle c c df (n-mrph -1 df) n)))
(? z 0 (con0 '1))
(? z 1 (con1 '1))
(? z 1 (con0 '3))
(? z 2 (con1 '3))
(? z 4 (con0 '31))
(? z 5 (con1 '31))
|#
(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)))))
(DEFMETHOD SEARCH-EFHM (chcm (orgn (eql 'cone)))
(declare (type chain-complex chcm))
(the homotopy-equivalence
(cone-efhm chcm)))

146
Kenzo-1/cs-twisted-products.cl Normal file
View File

@ -0,0 +1,146 @@
;;; 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
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "cs-twisted-products")
(DEFUN SMGR-FIBRATION-SINTR (dmns gbar)
(declare
(ignore dmns)
(type gbar gbar))
(the absm
(first (gbar-list gbar))))
(DEFUN SMGR-FIBRATION (smgr)
(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))))
#|
(setf k1 (k-z-1))
(setf tw (smgr-fibration k1))
(setf k2 (sorc tw))
(setf tt (fibration-total tw))
(setf gmsm (crpr 0 (gbar 4 0 '(10 11 12) 0 '(20 21) 0 '(30) 0 '())
0 '(2 4 6 8)))
(dotimes (i 5)
(print (face tt i 4 gmsm)))
(setf br (brown-reduction tw))
(setf tw-pr (bcc br))
(? tw-pr 4 (tnpr 4 (gbar 4 0 '(1 10 100) 0 '(1000 10000)
0 '(100000) 0 '())
0 '()))
|#
(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)))))))
(the intr-mrph #'rslt)))
(DEFUN SMGR-CRTS-CONTRACTION (smgr)
(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))))
#|
(cat-init)
(setf chi (smgr-crts-contraction (k-z-1)))
(setf rdct (build-rdct :f (zero-mrph (sorc chi) (z-chcm))
:g (zero-mrph (z-chcm) (sorc chi))
:h chi))
(pre-check-rdct rdct)
(setf *tc* (cmbn 0 1 (crpr 0 +null-gbar+ 0 '())))
(setf *bc* (cmbn 0 1 :z-gnrt))
(check-rdct)
(setf *tc* (cmbn 1 1 (crpr 1 +null-gbar+ 0 '(1))))
(check-rdct)
(setf *tc* (cmbn 4 1 (crpr 0 (gbar 4 0 '(10 11 12) 0 '(20 21) 0 '(30) 0 '())
0 '(2 4 6 8))))
(check-rdct)
(setf *tc* (cmbn 3 1 (crpr 0 (gbar 3 0 '(10 11) 0 '(20) 0 '())
0 '(2 4 6))))
(check-rdct)
|#
(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)))
(declare
(type simplicial-group smgr)
(type fibration fibration)
(type reduction brown)
(type morphism f g chi))
(the morphism
(i-cmps f chi g)))
#|
(cat-init)
(setf chi (smgr-tnpr-contraction (k-z-1)))
(setf rdct (build-rdct :f (zero-mrph (sorc chi) (z-chcm))
:g (zero-mrph (z-chcm) (sorc chi))
:h chi))
(pre-check-rdct rdct)
(setf *tc* (cmbn 0 1 (tnpr 0 +null-gbar+ 0 '())))
(setf *bc* (cmbn 0 1 :z-gnrt))
(check-rdct)
(setf *tc* (cmbn 1 1 (tnpr 0 +null-gbar+ 1 '(1))))
(check-rdct)
(setf *tc* (cmbn 3 1 (tnpr 0 +null-gbar+ 3 '(1 10 100))))
(? chi *tc*)
(check-rdct)
(setf *tc* (cmbn 3 1 (tnpr 2 (gbar 2 0 '(1) 0 '()) 1 '(10))))
(? chi *tc*)
(check-rdct)
(setf *tc* (cmbn 3 1 (tnpr 3 (gbar 3 0 '(1 10) 0 '(100) 0 '()) 0 '())))
(? chi *tc*)
(check-rdct)
(setf *tc* (cmbn 4 1 (tnpr 0 +null-gbar+ 4 '(1 10 100 1000))))
(? chi *tc*)
(check-rdct)
(setf *tc* (cmbn 4 1 (tnpr 2 (gbar 2 0 '(1) 0 '()) 2 '(10 100))))
(? chi *tc*)
(check-rdct)
(setf *tc* (cmbn 4 1 (tnpr 3 (gbar 3 0 '(1 10) 0 '(100) 0 '())
1 '(1000))))
(? chi *tc*)
(check-rdct)
(setf *tc* (cmbn 4 1 (tnpr 4 (gbar 4 0 '(1 10 100)
0 '(1000 10000)
0 '(100000)
0 '())
0 '())))
(? chi *tc*)
(check-rdct)
|#

417
Kenzo-1/delta.cl Normal file
View File

@ -0,0 +1,417 @@
;;; 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
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "delta")
(DEFMETHOD PRINT-KEYCONS ((car (eql :delt)) cdr stream)
(format stream "~A" (hyphenize-list (dlop-int-ext cdr)))
(cons car cdr))
(DEFUN SOFT-DELTA-CMPR (gmsm1 gmsm2)
(f-cmpr (cdr gmsm1) (cdr gmsm2)))
#|
()
(soft-delta-cmpr (d 12) (d 23))
|#
(DEFUN DELTA-FACE (indx dmns gmsm)
(declare
(fixnum indx gmsm)
(ignore dmns))
(the absm
(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 delta-face (absm 0 (logxor gmsm pmark))))))))
(DEFUN SOFT-DELTA-FACE (indx dmns gmsm)
(declare
(fixnum indx dmns)
(type soft-dlop gmsm))
(absm 0 (d (gmsm (delta-face indx dmns (cdr gmsm))))))
#|
()
(dotimes (i 4)
(print (dlop-int-ext (gmsm (delta-face i 3 (dlop-ext-int '(0 1 2 3)))))))
(dotimes (i 4)
(print (dlop-int-ext (gmsm (delta-face i 3 (dlop-ext-int '(0 2 4 6))))))))
(dotimes (i 4)
(print (soft-delta-face i 3 (d (mask 4)))))
(dotimes (i 4)
(print (soft-delta-face i 3 (d (dlop-ext-int '(0 2 4 6))))))
|#
(DEFUN DELTA-BNDR (dmns gmsm)
(declare (fixnum dmns gmsm))
(the cmbn
(if (zerop dmns)
+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)
(declare
(list rslt)
(fixnum gmsm2 pmark sign))
(when (oddp gmsm2)
(push (term sign (logxor gmsm pmark)) rslt)
(setf sign (- sign))))))))
(DEFUN SOFT-DELTA-BNDR (dmns gmsm)
(declare
(fixnum dmns)
(type soft-dlop gmsm))
(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))))))
#|
()
(delta-bndr 0 4)
(delta-bndr 1 3)
(delta-bndr 1 5)
(delta-bndr 1 10)
(delta-bndr 5 63)
(soft-delta-bndr 5 (d (mask 6)))
|#
(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))))
rslt)
(when (minusp (decf ldegr))
(return rslt)))))))
(DEFUN SOFT-DELTA-DGNL (dmns gmsm)
(declare
(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))))))
#|
()
(delta-dgnl 3 15)
(delta-dgnl 3 170)
(soft-delta-dgnl 3 (d (dlop-ext-int '(1 3 5 7))))
(delta-dgnl 0 64)
|#
(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 (delta-infinity) 2 4)
(cmpr (delta-infinity) 4 4)
(cmpr (delta-infinity) 8 4)
(basis (delta-infinity) 1) ;;; => error
(face (delta-infinity) 1 2 21)
(cprd (delta-infinity) 3 15)
(dgnl (delta-infinity) 3 15)
(? (delta-infinity) 2 21)
|#
(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))))
#|
()
(cat-init)
(cmpr (soft-delta-infinity) (d 2) (d 4))
(face (soft-delta-infinity) 1 2 (d (dlop-ext-int '(1 3 5))))
(cprd (soft-delta-infinity) 3 (d 15))
(dgnl (soft-delta-infinity) 3 (d 15))
(? (soft-delta-infinity) 2 (d (dlop-ext-int '(0 2 4))))
|#
(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)))))
(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)))))
(the basis #'rslt)))
#|
()
(setf basis (delta-n-basis 3))
(setf soft-basis (soft-delta-n-basis 3))
(dotimes (i 5)
(print (funcall basis i)))
(dotimes (i 5)
(print (funcall soft-basis i)))
|#
(DEFUN DELTA (dmns)
(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))))
#|
()
(cat-init)
(setf d3 (delta 3))
(cmpr d3 2 4)
(cmpr d3 4 4)
(cmpr d3 8 4)
(basis d3 1)
(dgnl d3 3 15)
(face d3 1 2 21)
(? d3 2 13)
(setf d (delta-infinity))
(basis d)
(setf d (delta-infinity)))
|#
(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))))
#|
()
(cat-init)
(setf d3 (soft-delta 3))
(cmpr d3 (d 2) (d 4))
(basis d3 1)
(dgnl d3 3 (d 15))
(face d3 1 2 (d 21))
(? d3 2 (d 13))
|#
#| For comparison with EAT.
In
(setf delta (delta-infinity))
(setf d (bndr delta))
(setf s14 (mask 15))
(cmbn-? d (gnrt-? d 14 s14))
(defun t1 (n)
(time (dotimes (i n) (cmbn-? d (gnrt-? d 14 s14)))))
(compile 't1)
(t1 500)
(setf +too-much-time+ -1)
(t1 500)
|#
#|
In EAT:
(setf delta *delta*)
(setf d (cc-d (ss-cc delta)))
(setf s14 (<a-b> 0 14))
(??? d (? d 14 s14))
(defun t1 (n)
(time (dotimes (i n) (??? d (? d 14 s14)))))
(compile 't1)
(t1 500)
|#
(DEFUN DELTAB-CMPR (gmsm1 gmsm2)
(declare (fixnum gmsm1 gmsm2))
(if (= 1 (logcount gmsm1))
:equal
(f-cmpr gmsm1 gmsm2)))
(DEFUN DELTAB-BNDR (dmns gmsm)
(declare (fixnum dmns gmsm))
(the cmbn
(if (< dmns 2)
(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)
(declare
(list rslt)
(fixnum gmsm2 pmark sign))
(when (oddp gmsm2)
(push (term sign (logxor gmsm pmark)) rslt)
(setf sign (- sign))))))))
(DEFUN DELTAB2-FACE (indx dmns gmsm)
(declare
(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)))))))))
(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 #'caaddr))
(setf (gnrt1 (gnrt (first rslt)))
(setf (gnrt2 (gnrt (car (last rslt))))
1))
(return (delete 1 rslt :key #'cadddr)))))))))
#|
()
(dotimes (i 7)
(print (deltab2-dgnl i (mask (1+ i)))))
|#
(DEFUN DELTAB2-BNDR (dmns gmsm)
(declare (fixnum dmns gmsm))
(the cmbn
(if (< dmns 3)
(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)
(declare
(list rslt)
(fixnum gmsm2 pmark sign))
(when (oddp gmsm2)
(push (term sign (logxor gmsm pmark)) rslt)
(setf sign (- sign))))))))
#|
(deltab-bndr 1 5)
(deltab-bndr 3 15)
|#
(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))))
(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))))

396
Kenzo-1/disk-pasting.cl Normal file
View File

@ -0,0 +1,396 @@
;;; DISK-PASTING DISK-PASTING DISK-PASTING DISK-PASTING
;;; DISK-PASTING DISK-PASTING DISK-PASTING DISK-PASTING
;;; DISK-PASTING DISK-PASTING DISK-PASTING DISK-PASTING
(IN-PACKAGE "COMMON-LISP-USER")
(provide "disk-pasting")
(DEFUN DISK-PASTING-CMPR (cmpr new)
(declare
(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)))))
(the cmprf #'rslt)))
#|
(setf c (delta 3))
(setf cmpr (disk-pasting-cmpr (cmpr c) 'new))
(funcall cmpr 'new 'new)
(funcall cmpr 'new 5)
(funcall cmpr 5 'new)
(funcall cmpr 5 5)
(funcall cmpr 5 6)
(funcall cmpr 6 5)
|#
(DEFUN DISK-PASTING-BASIS (basis dmns new)
(declare
(type basis basis)
(fixnum dmns)
(symbol new))
(flet ((rslt (degr)
(declare (fixnum degr))
(if (= degr dmns)
(cons new (funcall basis dmns))
(funcall basis degr))))
(the basis #'rslt)))
#|
(setf c (delta 3))
(setf basis (disk-pasting-basis (basis c) 3 'new))
(funcall basis 3)
(funcall basis 2)
|#
(DEFUN DISK-PASTING-INTR-DFFR (old-dffr degr new bndr)
(declare
(type morphism old-dffr)
(fixnum degr)
(symbol new)
(type cmbn bndr))
(when (cmbn-non-zero-p (cmbn-? old-dffr bndr))
(error "In CHCM-DISK-PASTING, the given boundary has a non-null boundary."))
(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)))))))
(the intr-mrph #'rslt))))
#|
(cat-init)
(setf c (delta 3))
(setf intr (disk-pasting-intr-dffr (dffr c) 3 'new (cmbn 2 1 7)))
(setf intr (disk-pasting-intr-dffr (dffr c) 3 'new (? c 3 15)))
(funcall intr (cmbn 2 1 7))
(funcall intr (cmbn 3))
(funcall intr (cmbn 3 1 15))
(funcall intr (cmbn 3 1 'new 1 15))
(funcall intr (cmbn 3 1 'new -1 15))
(funcall intr (cmbn 3 -1 'new 1 15))
(funcall intr (cmbn 3 -1 'new -1 15))
|#
(DEFUN CHCM-DISK-PASTING (chcm dmns new bndr)
(declare
(type chain-complex chcm)
(fixnum dmns)
(symbol new)
(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))))
#|
(setf c (delta 3))
(setf s3 (chcm-disk-pasting c 3 'new (? c 3 15)))
(homology s3 0 5))
|#
(DEFUN DISK-PASTING-FACE (cmpr face dmns new faces)
(declare
(type cmprf cmpr)
(type face face)
(fixnum dmns)
(symbol new)
(list faces))
(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)
(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))))
(unless (check-faces cmpr #'rslt dmns new)
(error "The new simplicial-set is not constructed."))
(the face #'rslt)))
#|
(cat-init)
(setf c (delta 3))
(setf face (disk-pasting-face (cmpr c) (face c)
3 'new (list 14 (absm 0 13) 11 7)))
(funcall face 0 2 7)
(funcall face 0 3 15)
(dotimes (i 4) (print (funcall face i 3 'new)))
|#
(DEFUN DISK-PASTING (smst dmns new faces)
(declare
(type simplicial-set smst)
(fixnum dmns)
(symbol new)
(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))))))
#|
(setf d2 (delta 2))
(setf s2 (disk-pasting d2 2 'new '(6 5 3)))
(homology s2 0 4)
(setf s2xs2 (crts-prdc s2 s2))
(homology s2xs2 0 6)
|#
(DEFUN MRPH-DISK-PASTING-INTR (mrph trgt-cmpr dmns new new-im)
(declare
(type morphism mrph)
(type cmprf trgt-cmpr)
(fixnum dmns)
(symbol new)
(type cmbn new-im))
(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)))))))
(the intr-mrph #'rslt))))
#|
(setf m (idnt-mrph (delta 3)))
(setf intr
(mrph-disk-pasting-intr m (cmpr (delta 3))
3 'new (cmbn 3 -1 15)))
(funcall intr (cmbn 2 3 7))
(funcall intr (cmbn 3))
(funcall intr (cmbn 3 4 15))
(funcall intr (cmbn 3 1 'new 1 15))
(funcall intr (cmbn 3 -1 'new 1 15))
|#
(DEFUN MRPH-DISK-PASTING (mrph new-sorc new-trgt dmns new new-im)
(declare
(type morphism mrph)
(type chain-complex new-sorc new-trgt)
(fixnum dmns)
(symbol new)
(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))))
#|
(setf d (delta 3))
(setf m (idnt-mrph d))
(setf sorc (chcm-disk-pasting d 3 'new (? d 3 15)))
(setf nm (mrph-disk-pasting m sorc sorc 3 'new (cmbn 3 1 'new)))
(? nm (cmbn 3 2 'new 3 15))
|#
(DEFUN HMEQ-DISK-PASTING (hmeq dmns new bndr &key new-lbcc)
(declare
(type homotopy-equivalence hmeq)
(fixnum dmns)
(symbol new)
(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)))
(declare
(type morphism lg rf rh)
(type cmbn t-bndr rb-bndr)
(type chain-complex new-lbcc new-tcc new-rbcc)
(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)))
: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)))
:orgn `(hmeq-disk-pasting ,hmeq ,dmns ,new ,bndr))))
#|
(cat-init)
(setf tcc
(build-chcm
:cmpr #'s-cmpr
:basis #'(lambda (degr)
(case degr
(0 (list 'a))
(1 (list 'b))
(otherwise nil)))
:intr-dffr #'(lambda (degr gnrt)
(if (= 1 degr)
(cmbn 0 1 'a)
(zero-cmbn (1- degr))))
:strt :gnrt
:orgn '(z-z)))
(setf bcc
(build-chcm
:cmpr #'s-cmpr
:basis #'(lambda (degr) nil)
:intr-dffr #'(lambda (degr gnrt) (error "Impossible."))
:strt :gnrt
:orgn '(zero)))
(setf rh (build-mrph
:sorc tcc :trgt tcc :degr +1
:intr #'(lambda (degr gnrt)
(if (zerop degr)
(cmbn 1 1 'b)
(zero-cmbn 2)))
:strt :gnrt
:orgn '(rh)))
(setf hmeq (build-hmeq
:lrdct (trivial-rdct tcc)
:rrdct (build-rdct
:f (zero-mrph tcc bcc 0)
:g (zero-mrph bcc tcc 0)
:h rh
:orgn '(rrdct))))
(setf nhmeq (hmeq-disk-pasting hmeq 1 'new (cmbn 0 1 'a)))
(pre-check-rdct (lrdct nhmeq))
(setf *tc* (cmbn 0 1 'a))
(setf *bc* *tc*)
(check-rdct)
(setf *tc* (cmbn 1 1 'new 10 'b))
(setf *bc* *tc*)
(check-rdct)
(pre-check-rdct (rrdct nhmeq))
(setf *bc* (zero-cmbn 0))
(check-rdct)
(setf *tc* (cmbn 0 1 'a))
(check-rdct)
|#
(DEFMETHOD SEARCH-EFHM (smst (orgn (eql 'disk-pasting)))
(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))))
#|
(cat-init)
(setf d (delta 2))
(setf s2 (disk-pasting d 2 'new '(6 5
3)))
(homology s2 0 4)
|#

576
Kenzo-1/effective-homology.cl Normal file
View File

@ -0,0 +1,576 @@
;;; EFFECTIVE-HOMOLOGY EFFECTIVE-HOMOLOGY EFFECTIVE-HOMOLOGY
;;; EFFECTIVE-HOMOLOGY EFFECTIVE-HOMOLOGY EFFECTIVE-HOMOLOGY
;;; EFFECTIVE-HOMOLOGY EFFECTIVE-HOMOLOGY EFFECTIVE-HOMOLOGY
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "effective-homology")
;;;
;;; REDUCTIONS
;;;
(DEFVAR *RDCT-LIST*)
(SETF *RDCT-LIST* +empty-list+)
(PUSHNEW '*RDCT-LIST* *list-list*)
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) nil))
(DEFMETHOD PRINT-OBJECT ((rdct reduction) (stream stream))
(the reduction
(progn
(format stream "[K~D Reduction K~D => K~D]"
(idnm rdct) (idnm (tcc rdct)) (idnm (bcc rdct)))
rdct)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t))
(DEFUN RDCT (n)
(declare (fixnum n))
(the (or null reduction)
(find n *rdct-list* :key #'idnm)))
(DEFUN BUILD-RDCT (&key f g h orgn)
(declare
(type morphism f g h)
(list orgn))
(the reduction
(progn
(unless orgn
(setf orgn `(build-rdct ,f ,g ,h)))
(let ((already (find orgn *rdct-list* :test #'equal :key #'orgn)))
(declare (type (or reduction null) already))
(when already
(return-from build-rdct already)))
(with-slots ((fsorc sorc) (ftrgt trgt) (fdegr degr)) f
(declare
(type chain-complex fsorc ftrgt)
(fixnum fdegr))
(with-slots ((gsorc sorc) (gtrgt trgt) (gdegr degr)) g
(declare
(type chain-complex gsorc gtrgt)
(fixnum gdegr))
(with-slots ((hsorc sorc) (htrgt trgt) (hdegr degr)) h
(declare
(type chain-complex hsorc htrgt)
(fixnum hdegr))
(unless (and (eq gsorc ftrgt)
(eq fsorc gtrgt)
(eq hsorc fsorc)
(eq htrgt fsorc)
(zerop fdegr)
(zerop gdegr)
(= +1 hdegr))
(error "In BUILD-RDCT, the data are non coherent."))
(let ((rdct (make-instance 'reduction
:tcc fsorc :bcc ftrgt
:f f :g g :h h
:orgn orgn)))
(declare (type reduction rdct))
(push rdct *rdct-list*)
rdct)))))))
(DEFUN TRIVIAL-RDCT (chcm)
(declare (type chain-complex chcm))
(build-rdct
:f (idnt-mrph chcm)
:g (idnt-mrph chcm)
:h (zero-mrph chcm chcm +1)
:orgn `(trivial-rdct ,chcm)))
;;;
;;; HOMOTOPY-EQUIVALENCES
;;;
(DEFVAR *HMEQ-LIST*)
(SETF *HMEQ-LIST* +empty-list+)
(PUSHNEW '*HMEQ-LIST* *list-list*)
(DEFMETHOD BUILD-HMEQ ((keyword1 (eql :lrdct)) lrdct &key rrdct orgn)
(declare
(type reduction lrdct rrdct)
(list orgn))
(the homotopy-equivalence
(progn
(with-slots ((lf f) (lg g) (lh h) (ltcc tcc) (lbcc bcc)) lrdct
(declare
(type morphism lf lg lh)
(type chain-complex ltcc lbcc))
(with-slots ((rf f) (rg g) (rh h) (rtcc tcc) (rbcc bcc)) rrdct
(declare
(type morphism rf rg rh)
(type chain-complex rtcc rbcc))
(unless (eq ltcc rtcc)
(error "In BUILD-HMEQ (version from rdct), the tcc's are not the same."))
(unless orgn
(setf orgn `(build-hmeq ,lrdct ,rrdct)))
(let ((already (find orgn *hmeq-list* :test #'equal :key #'orgn)))
(declare (type (or homotopy-equivalence null) already))
(when already
(return-from build-hmeq already)))
(let ((hmeq (make-instance 'homotopy-equivalence
:lbcc lbcc :tcc ltcc :rbcc rbcc
:lf lf :lg lg :lh lh
:rf rf :rg rg :rh rh
:lrdct lrdct :rrdct rrdct
:orgn orgn)))
(declare (type homotopy-equivalence hmeq))
(push hmeq *hmeq-list*)
hmeq))))))
#|
(cat-init)
(progn ;;;; reused in another test
(defun cdelta (dmns)
(build-chcm
:cmpr #'l-cmpr
:basis :locally-effective
:bsgn '(0)
:intr-dffr #'(lambda (degr gmsm)
(make-cmbn
:degr (1- degr)
:list (do ((rslt +empty-list+
(cons (cons sign (append
(subseq gmsm 0 nark)
(subseq gmsm (1+ nark))))
rslt))
(sign 1 (- sign))
(nark 0 (1+ nark)))
((> nark degr) rslt))))
:strt :gnrt
:orgn `(locally effective version of C_* delta ,dmns)))
(defun make-f (tdmns bdmns)
(build-mrph
:sorc (cdelta tdmns) :trgt (cdelta bdmns) :degr 0
:intr #'(lambda (degr gmsm)
(let ((pos (position-if #'(lambda (vertex) (>= vertex bdmns)) gmsm)))
(if pos
(if (< pos degr)
(zero-cmbn degr)
(cmbn degr 1 (nconc (butlast gmsm) (list bdmns))))
(cmbn degr 1 gmsm))))
:strt :gnrt
:orgn `(projection delta ,tdmns => delta ,bdmns)))
(defun make-g (tdmns bdmns)
(build-mrph
:sorc (cdelta bdmns) :trgt (cdelta tdmns) :degr 0
:intr #'identity
:strt :cmbn
:orgn `(injection delta ,bdmns => delta ,tdmns)))
(defun make-h (tdmns bdmns)
(build-mrph
:sorc (cdelta tdmns) :trgt (cdelta tdmns) :degr +1
:intr #'(lambda (degr gmsm)
(let ((pos (position-if #'(lambda (vertex) (>= vertex bdmns)) gmsm)))
(if pos
(if (member bdmns gmsm)
(zero-cmbn (1+ degr))
(cmbn (1+ degr) (-1-expt-n pos)
(append (subseq gmsm 0 pos) (list bdmns) (subseq gmsm pos))))
(zero-cmbn (1+ degr)))))
:strt :gnrt
:orgn `(homotopy for delta ,tdmns => ,bdmns)))
(defun make-rdct (tdmns bdmns)
(setf rdct (build-rdct
:f (make-f tdmns bdmns)
:g (make-g tdmns bdmns)
:h (make-h tdmns bdmns)
:orgn `(reduction delta ,tdmns ,bdmns)))))
(setf rdct (make-rdct 6 3))
(setf f (f rdct) g (g rdct) h (h rdct)
tcc (tcc rdct) bcc (bcc rdct))
(setf dh (cmps (dffr tcc) h))
(setf hd (cmps h (dffr tcc)))
(setf gf (cmps g f))
(setf id-gf-dh-hd (i-sbtr (idnt-mrph tcc) gf dh hd))
(setf c (cmbn 2 1 '(0 1 2) 10 '(1 2 3) 100 '(1 2 4) 1000 '(2 3 4)))
(cmbn-? id-gf-dh-hd c)
|#
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) nil))
(DEFMETHOD PRINT-OBJECT ((hmeq homotopy-equivalence) (stream stream))
(the homotopy-equivalence
(progn
(format stream "[K~D Homotopy-Equivalence K~D <= K~D => K~D]"
(idnm hmeq)
(idnm (lbcc hmeq)) (idnm (tcc hmeq)) (idnm (rbcc hmeq)))
hmeq)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t))
(DEFMETHOD HMEQ ((n integer))
(declare (fixnum n))
(the (or homotopy-equivalence null)
(find n *hmeq-list* :key #'idnm)))
(DEFMETHOD BUILD-HMEQ ((keyword1 (eql :lf)) lf &key lg lh rf rg rh orgn)
(declare
(type morphism lf lg lh rf rg rh)
(list orgn))
(the homotopy-equivalence
(progn
(unless orgn
(setf orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh)))
(let ((already (find orgn *hmeq-list* :test #'equal :key #'orgn)))
(declare (type (or null homotopy-equivalence) already))
(when already
(return-from build-hmeq already)))
(build-hmeq
:lrdct (build-rdct :f lf :g lg :h lh :orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh lrdct))
:rrdct (build-rdct :f rf :g rg :h rh :orgn `(build-hmeq ,lf ,lg ,lh ,rf ,rg ,rh rrdct))
:orgn orgn))))
(DEFUN TRIVIAL-HMEQ (chcm)
(declare (type chain-complex chcm))
(build-hmeq
:lrdct (trivial-rdct chcm)
:rrdct (trivial-rdct chcm)
:orgn `(trivial-hmeq ,chcm)))
#|
(cat-init)
(setf cc (cdelta 5))
(setf hmeq (trivial-hmeq cc))
|#
;; Functions.
(DEFVAR *TDD*)
(DEFVAR *BDD*)
(DEFVAR *ID-FG*)
(DEFVAR *ID-GF-DH-HD*)
(DEFVAR *HH*)
(DEFVAR *FH*)
(DEFVAR *HG*)
(DEFVAR *DF-FD*)
(DEFVAR *DG-GD*)
(DEFUN PRE-CHECK-RDCT (rdct)
(declare (type reduction rdct))
(with-slots (bcc tcc f g h) rdct
(declare
(type chain-complex bcc tcc)
(type morphism f g h))
(setf *tdd* (cmps tcc tcc)
*bdd* (cmps bcc bcc)
*df-fd* (sbtr
(cmps bcc f)
(cmps f tcc))
*dg-gd* (sbtr
(cmps tcc g)
(cmps g bcc))
*id-fg* (sbtr (idnt-mrph bcc) (cmps f g))
*id-gf-dh-hd* (i-sbtr (idnt-mrph tcc)
(cmps g f)
(cmps tcc h)
(cmps h tcc))
*hh* (cmps h h)
*fh* (cmps f h)
*hg* (cmps h g)))
(done))
(DEFVAR *TC*)
(DEFVAR *BC*)
(DEFUN CHECK-RDCT ()
(dolist (cmbn '(*tc* *bc*))
(declare (type symbol cmbn))
(format t "~%~A => ~A" cmbn (eval cmbn)))
(dolist (phi '(*tdd* *bdd* *df-fd* *dg-gd* *id-fg* *id-gf-dh-hd*
*hh* *fh* *hg*))
(declare (type symbol phi))
(format t "~%Checking ~A = 0" phi)
(format t "~%Result: ")
(princ (cmbn-? (eval phi)
(if (member phi '(*bdd* *dg-gd* *id-fg* *dg-gd* *hg*))
*bc* *tc*)))
(read-line))
(done))
#|
(setf rdct (make-rdct 6 3)) ;;; defined in a previous test
(pre-check-rdct rdct)
(setf *tc* (cmbn 2 1 '(0 1 2) 10 '(1 2 3) 100 '(1 2 4) 1000 '(2 3 4)))
(setf *bc* (cmbn 3 4 '(0 1 2 3)))
(check-rdct))
|#
(DEFMETHOD CMPS ((brdct reduction) (trdct reduction) &optional dummy)
(declare (ignore dummy))
(when (eq (first (orgn brdct)) 'trivial-rdct)
(return-from cmps trdct))
(when (eq (first (orgn trdct)) 'trivial-rdct)
(return-from cmps brdct))
(with-slots ((tf f) (tg g) (th h)) trdct
(declare (type morphism tf tg th))
(with-slots ((bf f) (bg g) (bh h)) brdct
(declare (type morphism bf bg bh))
(build-rdct
:f (cmps bf tf)
:g (cmps tg bg)
:h (add th (i-cmps tg bh tf))
:orgn `(cmps ,brdct ,trdct)))))
#|
(setf trdct (make-rdct 6 4))
(setf brdct (make-rdct 4 3))
(setf rdct (cmps brdct trdct))
(pre-check-rdct rdct)
(setf *tcc* (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))
*bcc* (cmbn 2 1 '(0 1 3)))
(check-rdct))
|#
;
; BASIC PERTURBATION LEMMA.
;
(DEFMETHOD ADD ((rdct reduction) (perturbation morphism) &optional dummy)
(declare (type null dummy))
(when dummy
(error "Why a third argument in (ADD REDUCTION MORPHISM)?"))
(when (eq (grmd (tcc rdct)) (grmd (sorc perturbation)))
(return-from add
(basic-perturbation-lemma rdct perturbation)))
(when (eq (grmd (bcc rdct)) (grmd (sorc perturbation)))
(return-from add
(easy-perturbation-lemma rdct perturbation)))
(error "In (METHOD ADD REDUCTION MORPHISM),~@
the data do not sound like coherent."))
(DEFUN BASIC-PERTURBATION-LEMMA (reduction top-perturbation)
(declare
(type reduction reduction)
(type morphism top-perturbation))
(the (values reduction morphism)
(with-slots ((old-tcc tcc) (old-bcc bcc)
(old-f f) (old-g g) (old-h h)) reduction
(declare
(type chain-complex old-tcc old-bcc)
(type morphism old-f old-g old-h))
(when (eq (first (orgn top-perturbation)) 'zero-mrph)
(return-from basic-perturbation-lemma
(values reduction (zero-mrph old-bcc))))
(when (eq (first (orgn (h reduction))) 'zero-mrph)
(return-from basic-perturbation-lemma
(values
(trivial-rdct (add old-tcc top-perturbation))
(i-cmps old-f top-perturbation old-g))))
(let* ((sigma (bpl-*-sigma old-h top-perturbation))
(new-f (cmps old-f
(sbtr (idnt-mrph old-tcc)
(i-cmps
top-perturbation
sigma
old-h))))
(new-g (cmps sigma old-g))
(new-h (cmps sigma old-h))
(bottom-perturbation (i-cmps
old-f
top-perturbation
new-g))
(new-tcc (add old-tcc top-perturbation))
(new-bcc (add old-bcc bottom-perturbation)))
(declare
(type chain-complex new-tcc new-bcc)
(type morphism sigma new-f new-g new-h bottom-perturbation))
(setf new-f (dstr-change-sorc-trgt new-f :new-sorc new-tcc :new-trgt new-bcc)
new-g (dstr-change-sorc-trgt new-g :new-sorc new-bcc :new-trgt new-tcc)
new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc :new-trgt new-tcc))
(values
(build-rdct :f new-f :g new-g :h new-h
:orgn `(basic-perturbation-lemma ,reduction ,top-perturbation))
bottom-perturbation)))))
(DEFUN EASY-PERTURBATION-LEMMA (reduction bottom-perturbation)
(declare
(type reduction reduction)
(type morphism bottom-perturbation))
(the (values reduction morphism)
(with-slots ((old-tcc tcc) (old-bcc bcc)
(old-f f) (old-g g) (old-h h)) reduction
(declare
(type chain-complex old-tcc old-bcc)
(type morphism old-f old-g old-h))
(when (eq 'zero-mrph (first (orgn bottom-perturbation)))
(return-from easy-perturbation-lemma
(values reduction (zero-mrph old-tcc))))
(when (eq 'trivial-rdct (first (orgn reduction)))
(return-from easy-perturbation-lemma
(trivial-rdct (add (bcc reduction) bottom-perturbation))))
(let ((top-perturbation (i-cmps old-g bottom-perturbation old-f)))
(declare (type morphism top-perturbation))
(let ((new-bcc (add old-bcc bottom-perturbation))
(new-tcc (add old-tcc top-perturbation)))
(declare (type chain-complex new-bcc new-tcc))
(values
(build-rdct
:f (dstr-change-sorc-trgt old-f :new-sorc new-tcc :new-trgt new-bcc)
:g (dstr-change-sorc-trgt old-g :new-sorc new-bcc :new-trgt new-tcc)
:h (dstr-change-sorc-trgt old-h :new-sorc new-tcc :new-trgt new-tcc)
:orgn `(easy-perturbation-lemma ,reduction ,bottom-perturbation))
top-perturbation))))))
(DEFUN SPECIAL-BPL (reduction top-perturbation)
(declare
(type reduction reduction)
(type morphism top-perturbation))
(when (eq (first (orgn top-perturbation)) 'zero-mrph)
(return-from special-bpl reduction))
(the reduction
(with-slots ((old-tcc tcc) (old-bcc bcc)
(old-f f) (old-g g) (old-h h)) reduction
(declare
(type chain-complex old-tcc old-bcc)
(type morphism old-f old-g old-h))
(let* ((sigma (bpl-*-sigma old-h top-perturbation))
(new-f (cmps old-f
(sbtr (idnt-mrph old-tcc)
(i-cmps
top-perturbation
sigma
old-h))))
(new-h (cmps sigma old-h))
(new-tcc (add old-tcc top-perturbation)))
(declare
(type chain-complex new-tcc)
(type morphism sigma new-f new-h))
(setf new-f (dstr-change-sorc-trgt new-f :new-sorc new-tcc)
old-g (dstr-change-sorc-trgt old-g :new-trgt new-tcc)
new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc :new-trgt new-tcc))
(build-rdct :f new-f :g old-g :h new-h
:orgn `(special-bpl ,reduction ,top-perturbation))))))
(DEFUN SPECIAL-BPL-2 (reduction top-perturbation)
(declare
(type reduction reduction)
(type morphism top-perturbation))
(the reduction
(with-slots ((old-tcc tcc) (old-bcc bcc)
(old-f f) (old-g g) (old-h h)) reduction
(declare
(type chain-complex old-tcc old-bcc)
(type morphism old-f old-g old-h))
(when (eq (first (orgn top-perturbation)) 'zero-mrph)
(return-from special-bpl-2
(values reduction (zero-mrph old-bcc))))
(when (eq (first (orgn (h reduction))) 'zero-mrph)
(return-from special-bpl-2
(values
(trivial-rdct (add old-tcc top-perturbation))
(i-cmps old-f top-perturbation old-g))))
(let* ((sigma (bpl-*-sigma old-h top-perturbation))
(new-g (cmps sigma old-g))
(new-h (cmps sigma old-h))
(new-tcc (add old-tcc top-perturbation)))
(declare
(type chain-complex new-tcc)
(type morphism sigma new-g new-h))
(setf old-f (dstr-change-sorc-trgt old-f :new-sorc new-tcc)
new-g (dstr-change-sorc-trgt new-g :new-trgt new-tcc)
new-h (dstr-change-sorc-trgt new-h :new-sorc new-tcc :new-trgt new-tcc))
(values
(build-rdct :f old-f :g new-g :h new-h
:orgn `(special-bpl-2 ,reduction ,top-perturbation)))))))
(DEFUN BPL-*-sigma (homotopy perturbation)
(declare (type morphism homotopy perturbation))
(the morphism
(let ((cmpr (cmpr (sorc perturbation)))
(h-delta (cmps homotopy perturbation)))
(declare
(type cmprf cmpr)
(type morphism h-delta))
(flet
((sigma-* (degr gnrt)
(declare
(fixnum degr)
(type gnrt gnrt))
(do ((rslt (zero-cmbn degr) (2cmbn-add cmpr rslt iterated))
(iterated (term-cmbn degr 1 gnrt) (cmbn-opps (cmbn-? h-delta iterated))))
((cmbn-zero-p iterated) rslt)
(declare (type cmbn rslt iterated)))))
(build-mrph
:sorc (sorc homotopy) :trgt (sorc homotopy) :degr 0
:intr #'sigma-*
:strt :gnrt
:orgn `(bpl-*-sigma ,homotopy ,perturbation))))))
#|
(cat-init)
(setf rdct (make-rdct 6 3))
(setf perturb (zero-mrph (cdelta 6) (cdelta 6) -1))
(setf new-rdct (add rdct perturb))
(pre-check-rdct new-rdct)
(setf *tc* (cmbn 2 3 '(0 1 2))
*bc* (cmbn 3 4 '(0 1 2 3)))
(check-rdct))
|#
#|
(cat-init)
(setf rdct (make-rdct 6 3))
(setf perturb (opps (dffr (tcc rdct))))
(setf new-rdct (add rdct perturb))
(pre-check-rdct new-rdct)
(setf *tc* (cmbn 2 3 '(0 1 2))
*bc* (cmbn 3 4 '(0 1 2 3)))
(check-rdct))
|#
#| ;; an absurd reduction ; just to test bpl-*-sigma
(cat-init)
(setf tcc (build-chcm
:cmpr #'l-cmpr
:basis :locally-effective
:bsgn '(0)
:intr-dffr #'(lambda (degr gnrt)
(cmbn (1- degr) 1 gnrt))
:strt :gnrt
:orgn '(test1)))
(setf rdct (trivial-rdct tcc))
(setf (slot-value rdct 'h)
(build-mrph
:sorc tcc :trgt tcc :degr +1
:intr #'(lambda (degr gnrt)
(cmbn (1+ degr) 1 gnrt))
:strt :gnrt
:orgn '(test2)))
(setf perturb
(build-mrph
:sorc tcc :trgt tcc :degr -1
:intr #'(lambda (degr gnrt)
(if (zerop (first gnrt))
(zero-cmbn (1- degr))
(cmbn (1- degr) 1 (list (1- (first gnrt)) (1+ (second gnrt))))))
:strt :gnrt
:orgn '(test3)))
(setf new-rdct (add rdct perturb))
(gnrt-? (dffr (tcc new-rdct)) 3 '(3 5))
(gnrt-? (dffr (bcc new-rdct)) 3 '(3 5))
|#
(DEFMETHOD ADD ((hmeq homotopy-equivalence) (lb-perturbation morphism) &optional dummy)
(declare (ignore dummy))
(the homotopy-equivalence
(with-slots (lrdct rrdct) hmeq
(declare (type reduction lrdct rrdct))
(multiple-value-bind (new-lrdct top-perturbation)
(add lrdct lb-perturbation)
(declare
(type reduction new-lrdct)
(type morphism lb-perturbation))
(build-hmeq
:lrdct new-lrdct
:rrdct (add rrdct top-perturbation)
:orgn `(add ,hmeq ,lb-perturbation))))))
#|
(cat-init)
(setf hmeq (trivial-hmeq (cdelta 4)))
(add (lrdct hmeq) (opps (dffr (cdelta 4))))
(setf hmeq (add hmeq (opps (dffr (cdelta 4)))))
(gnrt-? (dffr (rbcc hmeq)) 3 '(0 1 2 3)))
|#

480
Kenzo-1/eilenberg-zilber.cl Normal file
View File

@ -0,0 +1,480 @@
;;; EILENBERG-ZILBER EILENBERG-ZILBER EILENBERG-ZILBER
;;; EILENBERG-ZILBER EILENBERG-ZILBER EILENBERG-ZILBER
;;; EILENBERG-ZILBER EILENBERG-ZILBER EILENBERG-ZILBER
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "eilenberg-zilber")
(DEFUN SHUFFLE-SIGN (dgop)
(declare (fixnum dgop))
(the fixnum
(do ((rslt +1)
(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))))))
#|
(dotimes (i 30)
(format t "~%~A => ~@D" (hyphenize-list (dlop-int-ext i)) (shuffle-sign i)))
|#
(DEFUN INTR-EML (cmbn)
(declare (type cmbn cmbn))
(when (cmbn-zero-p cmbn)
(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))))))
#|
(intr-eml (cmbn 3 1 (tnpr 0 'a 3 'b) 2 (tnpr 2 'a 1 'b) 3 (tnpr 2 'aa 1 'bb) 4 (tnpr 3 'a 0 'b)))
(intr-eml (cmbn 3 1 (tnpr 1 'c 2 'd) 10 (tnpr 2 'a 1 'b)))
(intr-eml (cmbn 3 10 (tnpr 1 'c 2 'd) 1 (tnpr 2 'a 1 'b) 100 (tnpr 2 'aa 1 'bb)))
(intr-eml (cmbn 3 10 (tnpr 1 'c 2 'd) 100 (tnpr 1 'cc 2 'dd) 1 (tnpr 2 'a 1 'b)))
|#
(DEFUN EML (smst1 smst2)
(build-mrph
:sorc (tnsr-prdc smst1 smst2)
:trgt (crts-prdc smst1 smst2)
:degr 0
:intr #'intr-eml
:strt :cmbn
:orgn `(eml ,smst1 ,smst2)))
#|
(cat-init)
(setf d (delta-infinity))
(setf eml (eml d d))
(? eml (cmbn 3 1 (tnpr 0 1 3 30) 10 (tnpr 1 3 2 28) 100 (tnpr 2 7 1 24) 1000 (tnpr 3 15 0 16)))
|#
(DEFUN INTR-PHI (smst1 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
(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))))))))))))
;; array-pq))) ;; in case of debugging
(intr-phi-2 array-pq cmpr)
))))
(the intr-mrph #'rslt)))
#|
()
(setf d (delta-infinity))
(setf rslt (intr-phi d d))
(funcall rslt (cmbn 3 1 (crpr 0 15 0 15)))
|#
#|
(DEFUN INTR-PHI-22 (array-pq cmpr)
(declare
(type (simple-array cmbn (* *)) array-pq)
(type cmprf cmpr))
; (format t " -22- ")
(the cmbn
(let* ((n+1 (1- (array-dimension array-pq 0)))
(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 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)))))
|#
(DEFUN INTR-PHI-2 (array-pq cmpr)
(declare
(type (simple-array cmbn (* *)) array-pq)
(type cmprf cmpr))
; (format t " -2- ")
(the cmbn
(let* ((n+1 (1- (array-dimension array-pq 0)))
(n (1- n+1))
(cmbn-list +empty-list+))
(declare
(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))))))))))))))
(if cmbn-list
(apply #'ncmbn-add cmpr cmbn-list)
(zero-cmbn n+1)))))
#|
(setf d (delta-infinity))
(setf rslt (intr-phi d d))
(funcall rslt (cmbn 3 1 (crpr 0 15 0 15)))
(funcall rslt (cmbn 2 1 (crpr 0 7 0 7)))
(funcall rslt (cmbn 1 1 (crpr 0 3 0 3)))
(funcall rslt (cmbn 0 1 (crpr 0 1 0 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))))
#|
(setf phi (phi (delta-infinity) (delta-infinity)))
(? phi 3 (crpr 0 15 0 15))
|#
#| ;; Comparison with EAT.
;; In Kenzo.
(cat-init)
(setf s (sphere 5))
(setf p (crts-prdc s s))
(setf b (basis p 8))
(setf c (make-cmbn :degr 8
:list (mapcar #'(lambda (item)
(term (1+ (random 5)) item))
b)))
(setf phi (phi s s))
(time (? phi c)))
|#
#| ;; in EAT
(setf s (sphere 5))
(setf p (cpr-2ss s s))
(setf b (sbs p 8))
(setf c (make-cmb :dgr 8
:lst (mapcar #'(lambda (item)
(mnm (1+ (random 5)) item))
b)))
(setf phi (phi s s))
(time (??? phi c))
|#
(DEFUN INTR-AW (face1 face2)
(declare (type face face1 face2))
(flet ((rslt (dmns crpr)
(declare
(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))
(declare
(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)
(push
(term 1
(tnpr 0 (gmsm face) dmns (gmsm absm2)))
rslt)))
(declare
(type absm face)
(fixnum dmns1 dmns2)
(list mark))
(unless (or (degenerate-p face)
(degenerate-p (car mark)))
(push
(term 1
(tnpr dmns1 (gmsm face) dmns2 (gmsm (car mark))))
rslt)))
(make-cmbn
:degr dmns
:list rslt)))))
(the intr-mrph #'rslt)))
#|
(setf r (intr-aw #'delta-face #'delta-face))
(funcall r 3 (crpr 0 15 0 15))
(setf s (sphere 3))
(setf f (face s))
(setf r (intr-aw f f))
(funcall r 3 (crpr 0 's3 0 's3))
|#
(DEFUN AW (smst1 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))))
#|
(setf aw (aw (delta-infinity) (delta-infinity)))
(? aw (cmbn 3 1 (crpr 0 15 0 30) -1 (crpr 0 23 0 29)))
|#
(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))))
#|
(setf ez (ez (delta-infinity) (delta-infinity)))
(setf *bc* (cmbn 3 1 (tnpr 0 1 3 30)
10 (tnpr 1 96 2 896)
100 (tnpr 2 7168 1 3)
1000 (tnpr 3 15 0 4096)))
(setf *tc* (cmbn 3 1 (crpr 0 15 0 480)
100 (crpr 0 15 5 96)
10 (crpr 6 3 0 480)
1000 (crpr 6 3 1 224)))
(pre-check-rdct ez)
(check-rdct)
|#
#|
;; Comparison EAT.
;; In Kenzo.
(cat-init)
(setf s (sphere 5))
(setf ez (ez s s))
(setf b (basis (tcc ez) 8))
(setf c (make-cmbn :degr 8
:list (mapcar #'(lambda (item)
(term (1+ (random 5)) item))
b)))
(pre-check-rdct ez)
(setf +too-much-time+ -1)
(time (? *id-gf-dh-hd* c))
(time (? *id-gf-dh-hd* c))
|#
#|
;; in EAT
(setf s (sphere 5))
(setf ez (ez s s))
(setf b (cbs (rdc-tcc ez) 8))
(setf c (make-cmb :dgr 8
:lst (mapcar #'(lambda (item)
(mnm (1+ (random 5)) item))
b)))
(verif-rdc ez)
(time (??? *id-gf-dh-hd* c))
(time (??? *id-gf-dh-hd* c))
|#
(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))))
(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)))))))
#|
(cat-init)
(setf k (k-z 2))
(setf k2 (crts-prdc k k))
(homology k2 0 10)
|#

185
Kenzo-1/fibrations.cl Normal file
View File

@ -0,0 +1,185 @@
;;; FIBRATIONS FIBRATIONS FIBRATIONS FIBRATIONS FIBRATIONS
;;; FIBRATIONS FIBRATIONS FIBRATIONS FIBRATIONS FIBRATIONS
;;; FIBRATIONS FIBRATIONS FIBRATIONS FIBRATIONS FIBRATIONS
(IN-PACKAGE "COMMON-LISP-USER")
(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)))
(declare
(type fibration fibration)
(type simplicial-mrph grml)
(type simplicial-set base totl)
(type simplicial-group fibr)
(type gmsm fbspn)
(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))))))))
(the face #'rslt)))
#|
(cat-init)
(setf h (hopf 1))
(setf sf (serre-face h))
(funcall sf 0 2 (crpr 0 's2 0 '(2 4)))
(funcall sf 1 2 (crpr 0 's2 0 '(2 4)))
(funcall sf 2 2 (crpr 0 's2 0 '(2 4)))
(funcall sf 3 3 (crpr 1 's2 2 '(2 4)))
|#
(DEFUN FIBRATION-TOTAL (fibration
&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)))
#|
(cat-init)
(setf s2 (sphere 2))
(setf k (k-z-1))
(setf tw (build-smmr
:sorc s2
:trgt k
:degr -1
:sintr #'(lambda (dmns gmsm)
(absm 0 (list 1)))
:orgn '(s2-tw-kz1)))
(setf e (fibration-total tw))
(homology e 2)
(homology e 0 8)
(cat-init)
(setf s2 (sphere 2))
(setf k (k-z2-1))
(setf tw (build-smmr
:sorc s2
:trgt k
:degr -1
:sintr #'(lambda (dmns gmsm)
(absm 0 1))
:orgn '(s2-tw-kz2)))
(setf e (fibration-total tw))
(homology e 2)
(homology e 0 8)
|#
(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))))
(declare
(type fibration twist)
(type kan base fibre)
(type gmsm fbspn)
(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))))))
(the kfll #'rslt)))
#|
(cat-init)
(load "r-proj-space")
(setf tw (kdivide-z2-twist opr opr-chml-clss))
(setf pr-4 (fibration-total tw))
(setf absm (absm 0 (crpr 0 (loop3 0 5 2) 0 4)))
(setf hat (mapcar #'(lambda (i) (face pr-4 i 4 absm))
(<a-b> 0 4)))
(dotimes (i 5)
(print (kfll pr-4 i 4 (remove (nth i hat) hat)))
(check-kan pr-4 i 4 (remove (nth i hat) hat)))
|#
#|
(cat-init)
(setf os3-fibration os3-fibration)
(setf total (fibration-total os3-fibration))
(setf absm (absm 1 (crpr 0 (loop3 1 's3 1 2 's3 -2)
0 '(-2 1 1))))
(setf hat (mapcar #'(lambda (i) (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)))
|#

673
Kenzo-1/homology-groups.cl Normal file
View File

@ -0,0 +1,673 @@
;; HOMOLOGY-GROUPS HOMOLOGY-GROUPS HOMOLOGY-GROUPS HOMOLOGY-GROUPS
;; HOMOLOGY-GROUPS HOMOLOGY-GROUPS HOMOLOGY-GROUPS HOMOLOGY-GROUPS
;; HOMOLOGY-GROUPS HOMOLOGY-GROUPS HOMOLOGY-GROUPS HOMOLOGY-GROUPS
(IN-PACKAGE "COMMON-LISP-USER")
(provide "homology-groups")
;;
;; Computing ordinary homology-groups.
;;
;; Functions.
(defun creer-matrice (n1 n2)
(let ((mat (make-matrice
: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))
(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))
(setf (basecol mat j)
(make-t-mat :ilig 0 :icol j :left (basecol mat (1- j))))
(setf (up (basecol mat j)) (basecol mat j)))
(setf (up (baselig mat 0)) (baselig mat n1))
(setf (left (basecol mat 0)) (basecol mat n2))
mat))
(defun chercher-hor (p ic)
(do ((p2 p p1)
(p1 (left p) (left p1)))
((<= (icol p1) ic) p2)))
(defun chercher-ver (p il)
(do ((p2 p p1)
(p1 (up p) (up p1)))
((<= (ilig p1) il) p2)))
(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)))
(defun supprimer-terme (pl pc)
(setf (left pl) (left (left pl))
(up pc) (up (up pc))))
(defun maj-terme (pl pc val)
(if (= val 0)
(if (eq (left pl) (up pc)) (supprimer-terme pl pc))
(if (eq (left pl) (up pc))
(setf (val (left pl)) val)
(inserer-terme pl pc val))))
(defun maj-ligne (mat il liste)
(let ((ptl (baselig mat il)))
(mapcar
#'(lambda (elem)
(maj-terme (chercher-hor ptl (first elem))
(chercher-ver (basecol mat (first elem)) il)
(second elem)))
liste)
ptl))
(defun maj-colonne (mat ic liste)
(let ((ptc (basecol mat ic)))
(mapcar
#'(lambda (elem)
(maj-terme (chercher-hor (baselig mat (first elem)) ic)
(chercher-ver ptc (first elem))
(second elem)))
liste)
ptc))
(defun maj-matrice (mat liste)
(mapcar
#'(lambda (elem) (apply #'maj-ligne mat elem))
liste)
mat)
(defun disp-p (p)
`((,(ilig p) ,(icol p) ,(val p))
(,(ilig (left p)) ,(icol (left p)) ,(val (left p)))
(,(ilig (up p)) ,(icol (up p)) ,(val (up p)))))
(defun disp-ligne (mat il)
(terpri)
(princ "L")
(princ il)
(princ "=")
(mapcar
#'(lambda (elem)
(princ "(")
(princ (first elem))
(princ ":")
(princ (second elem))
(princ ")"))
(let ((ptl (baselig mat il))
(res '()))
(do ((pl (left ptl) (left pl)))
((eq pl ptl))
(push (list (icol pl) (val pl)) res))
res))
(values ))
(defun disp-colonne (mat ic)
(terpri)
(princ "C")
(princ ic)
(princ "=")
(mapcar
#'(lambda (elem)
(princ "(")
(princ (first elem))
(princ ":")
(princ (second elem))
(princ ")"))
(let ((ptc (basecol mat ic))
(res '()))
(do ((pc (up ptc) (up pc)))
((eq pc ptc))
(push (list (ilig pc) (val pc)) res))
res))
(values ))
(defun nlig (mat) (1- (array-dimension (leftcol mat) 0)))
(defun ncol (mat) (1- (array-dimension (uplig mat) 0)))
(defun disp-matrice (mat)
(let ((nlig (nlig mat)))
(do ((i 1 (1+ i)))
((> i nlig))
(disp-ligne mat i)))
(done))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) nil))
(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"))
mtrx)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t))
(defun disp-matrice-colonnes (mat)
(let ((ncol (ncol mat)))
(do ((i 1 (1+ i)))
((> 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)))
(defun mat-aleat (n1 n2 dens x)
(let ((mat (creer-matrice n1 n2))
(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))))
(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))
(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)))
(do ((res nil (cons (chercher-ver (basecol mat (icol pl)) il)
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)))
(do ((res nil (cons (chercher-hor (baselig mat (ilig pc)) ic)
res))
(pc (up ptc) (up pc)))
((eq pc ptc) (nreverse res)))))
(defun op-lig (ptl1 ptl2 peigne lambda)
(do ((pl1 (left ptl1) (left pl1))
(pp peigne (rest pp))
(pl2 ptl2))
((endp pp) ptl2)
(setf pl2 (chercher-hor pl2 (icol pl1)))
(op-elem pl2 (first pp) (* lambda (val pl1)))))
(defun op-col (ptc1 ptc2 peigne lambda)
(do ((pc1 (up ptc1) (up pc1))
(pp peigne (rest pp))
(pc2 ptc2))
((endp pp) ptc2)
(setf pc2 (chercher-ver pc2 (ilig pc1)))
(op-elem (first pp) pc2 (* lambda (val pc1)))))
(defun op-lig-n (mat l1 l2 lambda)
(op-lig (baselig mat l1)
(baselig mat l2)
(peigne-ver mat (baselig mat l1) l2)
lambda))
(defun op-col-n (mat c1 c2 lambda)
(op-col (basecol mat c1)
(basecol mat c2)
(peigne-hor mat (basecol mat c1) c2)
lambda))
(defun n-lig (mat)
(1- (array-dimension (leftcol mat) 0)))
(defun n-col (mat)
(1- (array-dimension (uplig mat) 0)))
(defun copier-matrice (mat)
(let ((mat2 (creer-matrice (n-lig mat) (n-col mat))))
(do ((i 1 (1+ i)))
((> i (n-lig mat)) mat2)
(do ((ptl1 (baselig mat i))
(pl1 (left (baselig mat i)) (left pl1))
(pl2 (baselig mat2 i) (left pl2)))
((eq pl1 ptl1))
(inserer-terme pl2 (basecol mat2 (icol pl1)) (val pl1))))))
(defun reste (a b)
(second (multiple-value-list (round a b))))
(defun diviseur (a b)
(round a b))
(defun maj-peigne-ver (peigne il)
(do ((pp peigne (rest pp)))
((endp pp) peigne)
(setf (first pp) (chercher-ver (first pp) il))))
(defun maj-peigne-hor (peigne ic)
(do ((pp peigne (rest pp)))
((endp pp) peigne)
(setf (first pp) (chercher-hor (first pp) ic))))
(defun identite (n)
(let ((mat (creer-matrice n n)))
(do ((ptl (baselig mat n) (up ptl))
(ptc (basecol mat n) (left ptc)))
((eq ptl ptc))
(inserer-terme ptl ptc 1))
mat))
(defun init-peigne-ver (mat ptl)
(do ((res nil (cons (basecol mat (icol pl))
res))
(pl (left ptl) (left pl)))
((eq pl ptl) (nreverse res))))
(defun init-peigne-hor (mat ptc)
(do ((res nil (cons (baselig mat (ilig pc))
res))
(pc (up ptc) (up pc)))
((eq pc ptc) (nreverse res))))
(defun disp-peigne (peigne)
(mapcar #'(lambda (elem) (first (disp-p elem)))
peigne))
(defun terme-minimal-matrice (mat)
(catch '?
(do* ((fin (baselig mat 0))
(ptl (up fin) (up ptl)))
((eq ptl fin) (throw '? nil))
(if (not (eq ptl (left ptl)))
(let* ((pmin (left ptl))
(min (abs (val pmin))))
(if (= min 1) (throw '? pmin))
(do ((ptl ptl (up ptl)))
((eq ptl fin) (throw '? pmin))
(do ((pl (left ptl) (left pl)))
((eq pl ptl))
(let ((val (abs (val pl))))
(when (< val min)
(if (= val 1) (throw '? pl))
(setq pmin pl min val))))))))))
(defun tuer-ligne (mat il)
(let* ((ptl (baselig mat il))
(peigne (peigne-ver mat ptl il)))
(do ((pp peigne (rest pp)))
((endp pp))
(supprimer-terme ptl (first pp)))
(setf (up (chercher-ver (baselig mat 0) il)) (up ptl)))
mat)
(defun tuer-colonne (mat ic)
(let* ((ptc (basecol mat ic))
(peigne (peigne-hor mat ptc ic)))
(do ((pp peigne (rest pp)))
((endp pp))
(supprimer-terme (first pp) ptc))
(setf (left (chercher-hor (basecol mat 0) ic)) (left ptc)))
mat)
(defun pivot (mat p)
(let* ((div (val p))
(ptl (baselig mat (ilig p)))
(ptc (basecol mat (icol p)))
(peigne (init-peigne-ver mat ptl))
(peigne2 '*non-defini*))
(do ((pc (up ptc) (up pc)))
((eq pc ptc))
(maj-peigne-ver peigne (ilig pc))
(if (eq pc p)
(setf peigne2 (copy-list peigne))
(op-lig ptl
(baselig mat (ilig pc))
peigne
(truncate (val pc) div))))
(do ((pp peigne2 (rest pp)))
((endp pp))
(supprimer-terme ptl (first pp)))
(setf (left (chercher-hor (basecol mat 0) (icol p))) (left ptc))
(setf (up (chercher-ver (baselig mat 0) (ilig p))) (up ptl))
(list (ilig p) (icol p) (val p))))
(defun pivot-parallele (M N p)
(let* ((div (val p))
(ic (icol p))
(ptl (baselig M (ilig p)))
(ptc (basecol N ic))
(peigne (init-peigne-hor N ptc))
(peigne2 '*non-defini*))
(do ((pl (left ptl) (left pl)))
((eq pl ptl))
(maj-peigne-hor peigne (icol pl))
(if (eq pl p)
(setf peigne2 (copy-list peigne))
(op-col ptc
(basecol N (icol pl))
peigne
(truncate (val pl) div))))
(do ((pp peigne2 (rest pp)))
((endp pp))
(supprimer-terme (first pp) ptc))
(setf (left (chercher-hor (basecol N 0) ic)) (left ptc))))
(defun generateur-torsion-H* (B N p)
(let ((tab (make-array (1+ (n-lig B)) :initial-element 0))
(ptcN (basecol N (icol p))))
(do ((pcN (up ptcN) (up pcN)))
((eq pcN ptcN))
(let ((facteur (truncate (val pcN) (val p)))
(ptcB (basecol B (ilig pcN))))
(do ((pcB (up ptcB) (up pcB)))
((eq pcB ptcB))
(incf (aref tab (ilig pcB)) (* (val pcB) facteur)))))
(cons (abs (val p))
(let ((res '()))
(do ((ind (n-lig B) (1- ind)))
((zerop ind) res)
(if (/= 0 (aref tab ind))
(push (cons (aref tab ind) ind) res)))))))
(defun terminer-H* (B)
(let ((res '())
(fin (basecol B 0)))
(do ((ptc (left fin) (left ptc)))
((eq ptc fin) res)
(push (cons 0
(do ((pc (up ptc) (up pc))
(res '() (cons (cons (val pc) (ilig pc)) res)))
((eq pc ptc) res)))
res))))
(defun reste-minimal-ligne (mat p)
(block ?
(let ((div (val p))
(ptl (baselig mat (ilig p))))
(do ((pl (left ptl) (left pl)))
((eq pl ptl) (return-from ? nil))
(let ((val (reste (val pl) div)))
(if (/= 0 val)
(if (= 1 val)
(return-from ? pl)
(let ((pmin pl)
(min val))
(do ((pl (left pl) (left pl)))
((eq pl ptl) (return-from ? pmin))
(let ((val (reste (val pl) div)))
(if (and (/= 0 val) (< val min))
(if (= 1 val)
(return-from ? pl)
(setf pmin pl min val)))))))))))))
(defun reste-minimal-colonne (mat p)
(block ?
(let ((div (val p))
(ptc (basecol mat (icol p))))
(do ((pc (up ptc) (up pc)))
((eq pc ptc) (return-from ? nil))
(let ((val (reste (val pc) div)))
(if (/= 0 val)
(if (= 1 val)
(return-from ? pc)
(let ((pmin pc)
(min val))
(do ((pc (up pc) (up pc)))
((eq pc ptc) (return-from ? pmin))
(let ((val (reste (val pc) div)))
(if (and (/= 0 val) (< val min))
(if (= 1 val)
(return-from ? pc)
(setf pmin pc min val)))))))))))))
(defun homologie (M N)
(prog ((B (identite (n-col M)))
(res nil)
(p1) (p2) (div))
depart1
(setf p1 (terme-minimal-matrice M))
loop1
(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)))))
op-lig1
(op-lig-n M (ilig p1) (ilig p2) (diviseur (val p2) (val p1)))
(setf p1 p2)
(go loop1)
op-col1
(setf div (diviseur (val p2) (val p1)))
(op-col-n M (icol p1) (icol p2) div)
(op-col-n B (icol p1) (icol p2) div)
(op-lig-n N (icol p2) (icol p1) (- div))
(setf p1 p2)
(go loop1)
pivot1
(tuer-ligne N (icol p1))
(pivot-parallele M B p1)
(pivot M p1)
(go depart1)
depart2
(setf p1 (terme-minimal-matrice N))
loop2
(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)))))
op-lig2
(setf div (diviseur (val p2) (val p1)))
(op-col-n B (ilig p2) (ilig p1) (- div))
(op-lig-n N (ilig p1) (ilig p2) div)
(setf p1 p2)
(go loop2)
op-col2
(op-col-n N (icol p1) (icol p2) (diviseur (val p2) (val p1)))
(setf p1 p2)
(go loop2)
pivot2-torsion
(setf res (cons (generateur-torsion-H* B N p1) res))
pivot2
(tuer-colonne B (ilig p1))
(pivot N p1)
(go depart2)
depart3
(return (append res (terminer-H* B)))))
(DEFVAR *HOMOLOGY-VERBOSE* t)
(DEFUN CHCM-MAT (chcm n)
(declare
(type chain-complex chcm)
(fixnum n))
(when (eq (basis chcm) :locally-effective)
(error "CHCMC-MAT cannot work with a LOCALLY-EFFECTIVE chain complex."))
(let ((sorc (basis chcm n))
(trgt (basis chcm (1- n)))
(cmpr (cmpr chcm)))
(declare
(list sorc trgt)
(type cmprf cmpr))
(format t "~%Computing boundary-matrix in dimension ~D.
Rank of the source-module : ~D.~2%"
n (length sorc))
(let ((sorcl (length sorc))
(mat (creer-matrice (length trgt) (length sorc)))
(test #'(lambda (gnrt1 gnrt2)
(eq (funcall cmpr gnrt1 gnrt2) :equal))))
(declare
(fixnum sorcl)
(type matrice mat)
(function test))
(do ((i 1 (1+ i))
(mark sorc (cdr mark)))
((endp mark))
(declare
(fixnum i)
(list mark))
(when *homology-verbose*
(clock)
(format t "Computing the boundary of the generator ~D/~D (dimension ~D) :"
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)))))
(when *homology-verbose*
(format t "~%End of computing.~2%")))
mat)))
#|
()
(setf d (delta 3))
(chcm-mat d 2)
(chcm-mat d 3)
(chcm-mat d 4)
|#
(defun chcm-homology (cc n)
(declare (type chain-complex cc) (type fixnum n))
(let ((rsl (homologie (chcm-mat cc n) (chcm-mat cc (1+ n)))))
(declare (type list rsl))
(format t "~3%Homology in dimension ~D :~%" n)
(dolist (item rsl)
(declare (type list item))
(format t "~2%Component Z")
(unless (zerop (first item))
(format t "/~DZ" (first item)))))
(terpri) (terpri)
(done))
#|
()
(setf d (sphere 3))
(chcm-homology d 2)
(chcm-homology d 3)
(chcm-homology d 4)
|#
(defun chcm-homology-gen (cc n)
(declare (type chain-complex cc) (type fixnum n))
(let ((src (cons :unused (basis cc n)))
(rsl (homologie (chcm-mat cc n) (chcm-mat cc (1+ n)))))
(declare (type list src rsl))
(format t "~3%Homology in dimension ~D :~%" n)
(dolist (item rsl)
(declare (type list item))
(format t "~%Component Z")
(unless (zerop (first item))
(format t "/~DZ" (first item))))
(terpri) (terpri)
(setf rsl (mapcar #'cdr rsl))
(setf rsl (mapcar #'(lambda (item)
(declare (type list item))
(mapcar #'(lambda (term)
(declare (type term term))
(term (car term) (nth (cdr term) src)))
item))
rsl))
(setf rsl (mapcar #'(lambda (item)
(declare (type list item))
(make-cmbn :degr n :list item))
rsl))
rsl))
#|
()
(setf d (sphere 3))
(chcm-homology-gen d 2)
(chcm-homology-gen d 3)
(chcm-homology-gen d 4)
|#
(defun chcm-homology-gen-old (cc n)
(declare (type chain-complex cc) (type fixnum n))
(let ((src (cons :unused (basis cc n)))
(rsl (homologie (chcm-mat cc n) (chcm-mat cc (1+ n)))))
(declare (type list src rsl))
(format t "~3%Homology in dimension ~D :~%" n)
(dolist (item rsl)
(declare (type list item))
(format t "~2%Component Z")
(unless (zerop (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)))))
(done))
#|
()
(setf d (sphere 3))
(chcm-homology-gen-old d 2)
(chcm-homology-gen-old d 3)
(chcm-homology-gen-old d 4)
|#

1071
Kenzo-1/k-pi-n.cl Normal file
View File

File diff suppressed because it is too large Load Diff

198
Kenzo-1/kan.cl Normal file
View File

@ -0,0 +1,198 @@
;;; 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
(IN-PACKAGE "COMMON-LISP-USER")
(provide "kan")
(DEFVAR *KAN-LIST*)
(SETF *KAN-LIST* +empty-list+)
(PUSHNEW '*KAN-LIST* *list-list*)
(DEFUN KAN (idnm)
(declare (fixnum idnm))
(the (or null simplicial-group)
(find idnm *kan-list* :key #'idnm)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) nil))
(DEFMETHOD PRINT-OBJECT ((kan kan) stream)
(the kan
(progn
(format stream "[K~D Kan-Simplicial-Set]" (idnm kan))
kan)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t))
(DEFUN SMST-KAN (smst kfll)
(declare
(type simplicial-set smst)
(type kfll kfll))
(the kan
(progn
(change-class smst 'kan)
(setf (slot-value smst 'kfll) kfll)
(pushnew smst *kan-list*)
smst)))
#|
(setf d (delta-infinity))
(defun vertex-i (absm i)
(with-absm (dgop gmsm) absm
(let ((dgop (nreverse (dgop-int-ext dgop)))
(gmsm (dlop-int-ext gmsm)))
(do ((dgop-mark dgop)
(gmsm-mark gmsm)
(ii 0 (1+ ii)))
((= i ii) (car gmsm-mark))
(if (and dgop-mark
(= ii (car dgop-mark)))
(pop dgop-mark)
(pop gmsm-mark))))))
(vertex-i (absm 0 1) 0)
(vertex-i (absm 1 1) 0)
(vertex-i (absm 1 1) 1)
(vertex-i (absm 0 3) 0)
(vertex-i (absm 0 3) 1)
(vertex-i (absm 3 1) 0)
(vertex-i (absm 3 1) 1)
(vertex-i (absm 3 1) 2)
(vertex-i (absm 1 3) 0)
(vertex-i (absm 1 3) 1)
(vertex-i (absm 1 3) 2)
(vertex-i (absm 2 3) 0)
(vertex-i (absm 2 3) 1)
(vertex-i (absm 2 3) 2)
(vertex-i (absm 0 7) 0)
(vertex-i (absm 0 7) 1)
(vertex-i (absm 0 7) 2)
(defun absm-int-ext (absm)
(with-absm (dgop gmsm) absm
(do ((dgop (nreverse (dgop-int-ext dgop)))
(gmsm (rest (dlop-int-ext gmsm)))
(i 0 (1+ i))
(rslt (list (first (dlop-int-ext gmsm)))))
((and (endp dgop) (endp gmsm)) (nreverse rslt))
(if dgop
(if (= i (car dgop))
(progn
(pop dgop)
(push (first rslt) rslt))
(push (pop gmsm) rslt))
(return (nreconc rslt gmsm))))))
(defun absm-ext-int (vlist)
(do ((dgop nil)
(gmsm (list (first vlist)))
(mark (rest vlist) (cdr mark))
(idgop 0 (1+ idgop)))
((endp mark) (absm (dgop-ext-int dgop)
(dgop-ext-int gmsm)))
(if (= (first gmsm) (car mark))
(push idgop dgop)
(push (car mark) gmsm))))
(absm-ext-int '(0 0 0 1 2 3 3 3))
(absm-ext-int '(0 1 1 1 2))
(absm-int-ext (absm-ext-int '(0 0 0 1 2 3 3 3)))
(absm-int-ext (absm-ext-int '(0 1 1 1 2)))
(defun dkfll (indx dmns hat)
(cond ((= 1 dmns)
(absm 1 (gmsm (first hat))))
((= 0 indx)
(let ((del-1 (absm-int-ext (first hat)))
(del-2 (absm-int-ext (second hat))))
(absm-ext-int
(cons (first del-1)
(cons (second del-2) (rest del-1))))))
((= 1 indx)
(let ((del-0 (absm-int-ext (first hat)))
(del-2 (absm-int-ext (second hat))))
(absm-ext-int
(cons (first del-2) del-0))))
(t
(let ((del-0 (absm-int-ext (first hat)))
(del-1 (absm-int-ext (second hat))))
(absm-ext-int
(cons (first del-1) del-0))))))
(smst-kan d #'dkfll)
(kfll d 0 1 (list (absm 0 1)))
(kfll d 0 2 (list (absm 0 5) (absm 0 3)))
(kfll d 1 2 (list (absm 0 6) (absm 0 3)))
(kfll d 2 2 (list (absm 0 6) (absm 0 5)))
(kfll d 0 2 (list (absm 0 3) (absm 0 3)))
(kfll d 1 2 (list (absm 1 2) (absm 0 3)))
|#
(DEFUN CHECK-HAT (kan indx dmns hat)
(declare
(type kan kan)
(fixnum indx dmns) ;;; dmns like in (funcall kfll ...)
(list hat))
(assert (= dmns (length hat)))
(setf hat
(append (subseq hat 0 indx)
(list :hole)
(nthcdr indx hat)))
(do ((cmpr (cmpr kan))
(j 0 (1+ j)))
((> j dmns) t)
(declare
(type cmprf cmpr)
(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))))))))))
#|
(setf od (gdeltab))
(setf s (loop3 0 31 2))
(setf faces (mapcar #'(lambda (indx) (face od indx 3 s))
'(0 1 2 3)))
(delete (nth 1 faces) faces)
(check-hat od 1 3 faces)
(setf (nth 2 faces) (nth 1 faces))
(check-hat od 1 3 faces)
|#
(DEFUN CHECK-KAN (kan indx dmns hat)
(declare
(type kan kan)
(fixnum indx dmns)
(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:~@
Fill = ~A~@
Del-~D(Fill) = ~A~@
Hat-~D = ~A"
rslt i del-i-rslt i x-i)))))))
(done))))

611
Kenzo-1/loop-spaces.cl Normal file
View File

@ -0,0 +1,611 @@
;;; 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
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "loop-spaces")
(DEFCONSTANT +NULL-LOOP+ (make-loop :list +empty-list+))
;;; NILOOP = non-normalized iloop; a common dgop is possible.
(DEFUN NORMALIZE-LOOP (dmns niloop)
(declare (list niloop))
(the absm
(progn
(unless niloop
(return-from normalize-loop
(absm (mask dmns) +null-loop+)))
(let ((dgop (apply #'logand (mapcar #'car niloop))))
(declare (fixnum dgop))
(if (zerop dgop)
(absm 0 (make-loop :list niloop))
(absm dgop
(make-loop
:list (mapcar #'(lambda (apowr)
(cons
(dgop/dgop (apdgop apowr) dgop)
(cdr apowr)))
niloop))))))))
#|
(normalize-loop 4 +empty-list+)
(normalize-loop 4 '((1 a . 1)))
(normalize-loop 4 '((1 a . 1) (3 b . 1) (5 b . 1)))
|#
(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)))))
#|
(unnormalize-loop (absm 1 (loop3 2 'a 3)))
|#
(DEFUN LOOP3 (&rest list)
(when (and (= 1 (length list))
(listp (first list)))
(setf list (first list)))
(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))
(do ((rslt +empty-list+ (cons (apowr
(fixnumpp (car mark))
(cadr mark)
(fixnumpp (caddr mark)))
rslt))
(mark list (cdddr mark)))
((endp mark) (make-loop :list (nreverse rslt)))
(declare (list rslt mark)))))
#|
()
(loop3 nil)
(loop3 '(1 a 2 3 b -2))
(loop3 '(1 a 2 3 b b))
(loop3 '(1 a 2 3 b))
(loop3 1 'a 2 3 'b 4)
(loop3 1 'a 2 3 'b)
|#
(DEFUN LOOP-PRINT (loop stream depth)
(declare
(type loop loop) (stream stream)
(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)))
#|
(loop3 nil)
(loop3 '(0 a 2))
(loop3 '(1 a 2))
(loop3 '(3 a 2 5 b -1 6 c 4))
(loop3 '(7 a 1 11 b 1 13 c 1 14 d 1))
(loop3 '(7 a 1 11 b 1 13 c 1 7 d 1))
(loop3 '(0 a 1 0 b 2 0 c -1 1 d 1))
|#
(DEFUN APOWR-NILOOP (cmpr apowr niloop)
(declare
(type cmprf cmpr)
(type apowr apowr)
(type iloop niloop))
(the iloop
(progn
(unless niloop
(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))))))))
#|
(apowr-niloop #'s-cmpr '(0 a . 1) +empty-list+)
(apowr-niloop #'s-cmpr '(0 a . 1) '((1 a . 1)))
(apowr-niloop #'s-cmpr '(0 a . 1) '((0 b . 1)))
(apowr-niloop #'s-cmpr '(0 a . 1) '((0 a . 1) (0 b . 1)))
(apowr-niloop #'s-cmpr '(0 a . 1) '((0 a . -1) (0 b . 1)))
|#
(DEFUN LOOP-SPACE-CMPR (cmpr)
(declare (type cmprf cmpr))
(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)))))
(flet ((rslt (loop1 loop2)
(declare (type loop loop1 loop2))
(maplexico #'2apowr-cmpr (loop-list loop1) (loop-list loop2))))
(the cmprf #'rslt))))
#|
(setf cmpr (loop-space-cmpr #'s-cmpr))
(funcall cmpr (loop3 '(1 a 2)) (loop3 '(1 a -1)))
(funcall cmpr (loop3 '(3 b 4 1 a 2)) (loop3 '(3 b 4 1 a -1)))
|#
(DEFUN APOWR-FACE4 (face indx dmns apowr)
;; dmns = dimension in the loop-space
(declare
(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))))))
#|
(setf face (face (delta-infinity)))
(apowr-face4 face 3 4 (apowr 1 31 5))
(setf face (face (sphere 5)))
(apowr-face4 face 2 5 (apowr 1 's5 4))
(apowr-face4 face 2 5 (apowr 2 's5 4))
|#
(DEFUN APOWR-LASTFACE4 (cmpr face dmns apowr)
;; indx =dmns
(declare
(type cmprf cmpr)
(type face face)
(fixnum dmns)
(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)))))))))))))
#|
(setf cmpr #'f-cmpr face (face (delta-infinity)))
(apowr-lastface4 cmpr face 4 (apowr 0 63 1))
(apowr-lastface4 cmpr face 4 (apowr 0 63 -1))
(apowr-lastface4 cmpr face 4 (apowr 0 63 3))
(apowr-lastface4 cmpr face 4 (apowr 0 63 -3))
(apowr-lastface4 cmpr face 4 (apowr 8 31 1))
(setf face #'(lambda (indx dmns gmsm) ; dmns = 5
(case indx
(5 (absm 8 'a))
(4 (absm 8 'a)))))
(setf cmpr #'s-cmpr)
(apowr-lastface4 cmpr face 4 (apowr 0 'a 2))
(setf face #'(lambda (indx dmns gmsm) ; dmns = 5
(case indx
(5 (absm 1 'a))
(4 (absm 8 'a)))))
(apowr-lastface4 cmpr face 4 (apowr 0 'a 2))
(setf face #'(lambda (indx dmns gmsm) ; dmns = 5
(case indx
(5 (absm 1 'a))
(4 (absm 1 'a)))))
(apowr-lastface4 cmpr face 4 (apowr 0 'a 2))
|#
(DEFUN LOOP-SPACE-FACE (cmpr face)
(declare
(type cmprf cmpr)
(type face face))
(flet ((rslt (indx dmns loop)
(declare
(fixnum indx dmns)
(type loop loop))
(the absm
(let ((rslt +empty-list+))
(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)))))
(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))))))
(the face #'rslt)))
#|
(setf cmpr #'f-cmpr
face (face (delta-infinity)))
(setf rslt (loop-space-face cmpr face))
(funcall rslt 2 4 (loop3 '(0 63 3 1 31 -3)))
(funcall rslt 2 4 (loop3 '(0 63 3 0 63 -3)))
(funcall rslt 4 4 (loop3 '(0 63 3 0 63 -3)))
(funcall rslt 4 4 (loop3 '(0 63 3)))
|#
(DEFUN LOOP-SPACE-FACE* (cmpr face)
(declare
(type cmprf cmpr)
(type face face))
(flet ((rslt (indx dmns loop)
(declare
(fixnum indx dmns)
(type loop loop))
(the (or loop (eql :degenerate))
(let ((rslt +empty-list+))
(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)))))
(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)))
(make-loop :list (nreverse rslt))
:degenerate)))))
(the face* #'rslt)))
(DEFUN LOOP-SPACE-GRIN-SINTR (dmns loop)
(declare
(ignore dmns)
(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)))))))
#|
(loop-space-grin-sintr 5 (loop3 0 'a 2 3 'b -3))
|#
(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)))))))
(the sintr #'rslt)))
#|
(setf cmpr #'s-cmpr)
(setf ml (loop-space-grml-sintr cmpr))
(funcall ml 2 (crpr 3 (loop3) 0 (loop3 0 'a 2)))
(funcall ml 2 (crpr 0 (loop3 0 'a 2) 3 (loop3)))
(funcall ml 2 (crpr 0 (loop3 0 'a 2) 0 (loop3 0 'a -2)))
(funcall ml 2 (crpr 0 (loop3 0 'a 2) 0 (loop3 0 'a -3)))
(funcall ml 2 (crpr 0 (loop3 0 'a 2) 0 (loop3 0 'b -3)))
(funcall ml 2 (crpr 0 (loop3 0 'a 2 0 'b -3)
0 (loop3 0 'b +3 0 'a -2)))
|#
(DEFUN LOOP-SPACE (smst &optional (n 1))
(declare
(type simplicial-set smst)
(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)))))
(DEFUN GDELTAB ()
(loop-space (deltab)))
#|
(cat-init)
(setf g (gdeltab))
(cmpr g (loop3 0 3 2) (loop3 0 3 2))
(cmpr g (loop3 0 3 2) (loop3 0 3 3))
(cmpr g (loop3 0 3 2) (loop3 0 5 2))
(cmpr g (loop3 0 5 2) (loop3 0 3 2))
(face g 3 3 (loop3 12 7 3))
(face g 3 3 (loop3 5 7 3))
(face g 3 3 (loop3 6 7 3 5 7 3 3 7 3))
(face g 4 4 (absm 4 (loop3 6 7 3 5 7 3 3 7 3)))
(check-faces (cmpr g) (face g) 3 (loop3 6 7 -3 5 7 -3 3 7 -3))
(setf dd (cmps g g))
(? dd 3 (loop3 6 7 3 5 7 3 3 7 3))
(grml g 2 (crpr 0 (loop3 0 15 3) 0 (loop3 0 15 4)))
(grin g 2 (loop3 0 15 -2))
(setf rslt (loop3 0 31 1))
(setf hat (mapcar #'(lambda (i) (face g i 3 rslt))
(<a-b> 0 3)))
(dotimes (i 4)
(print (kfll g i 3 (remove (nth i hat) hat :test #'equal)))
(check-kan g i 3 (remove (nth i hat) hat :test #'equal)))
(setf g (loop-space (sphere 2)))
(setf rslt (loop3 3 's2 2 5 's2 -2 6 's2 2))
(setf hat (mapcar #'(lambda (i) (face g i 3 rslt))
(<a-b> 0 3)))
(dotimes (i 4)
(print (kfll g i 3 (remove (nth i hat) hat :test #'equal)))
(check-kan g i 3 (remove (nth i hat) hat :test #'equal)))
(setf g (loop-space (sphere 3) 2))
(setf x (first (basis (echcm g) 4)))
(setf efhm (efhm g))
(setf x (lf efhm (rg efhm 4 x)))
(setf rslt (gnrt (first (cmbn-list x))))
(setf hat (mapcar #'(lambda (i) (face g i 4 rslt))
(<a-b> 0 4)))
(dotimes (i 5)
(print (kfll g i 4 (remove (nth i hat) hat :test #'equal)))
(check-kan g i 4 (remove (nth i hat) hat :test #'equal)))
(setf rslt (gnrt (third (cmbn-list x))))
(setf hat (mapcar #'(lambda (i) (face g i 4 rslt))
(<a-b> 0 4)))
(dotimes (i 5)
(print (kfll g i 4 (remove (nth i hat) hat :test #'equal)))
(check-kan g i 4 (remove (nth i hat) hat :test #'equal)))
(setf g (loop-space (sphere 3) 2))
(setf efhm (efhm g))
(setf echcm (rbcc efhm))
(setf basis (basis echcm 4))
(setf cmbn (cmbn 4 1 (first basis) 10 (second basis)
100 (third basis)))
(setf cmbn2 (lf efhm (rg efhm cmbn)))
(setf loop-list (mapcar #'cdr (cmbn-list cmbn2)))
(dolist (loop loop-list)
(setf hat (mapcar #'(lambda (i) (face g i 4 loop))
(<a-b> 0 4)))
(dotimes (i 5)
(print (kfll g i 4 (remove (nth i hat) hat)))
(check-kan g i 4 (remove (nth i hat) hat))))
|#
#|
(cat-init)
(setf p (r-proj-space 3))
(setf op (loop-space p))
(defun random-apowr (dmns max-expn)
(loop
(let* ((dgop (random (2-exp (1- dmns))))
(gmsm (- dmns (logcount dgop))))
(unless (< 0 gmsm 3)
(return-from random-apowr
(apowr dgop gmsm (srandom max-expn)))))))
(dotimes (i 15) (print (random-apowr 8 3)))
(defun random-niloop (dmns max-expn length)
(mapcar #'(lambda (dummy)
(random-apowr (1+ dmns) max-expn))
(make-list length)))
(dotimes (i 20)
(print (normalize-loop 7 (random-niloop 7 3 3))))
(defun random-loop-cmbn (cmpr degr max-cffc max-expn loop-length cmbn-length)
(do ((rslt +empty-list+ (cons term rslt))
(i cmbn-length (1- i))
(term))
((zerop i)
(apply #'nterm-add cmpr degr rslt))
(setf term
(term (srandom max-cffc)
(make-loop :list (random-niloop degr max-expn loop-length))))))
(setf cmpr (cmpr op))
(setf +too-much-time+ -1)
(setf c (random-loop-cmbn cmpr 8 10 4 4 100))
(time (? op (? op c)))
(time (? op (? op c)))
|#
#| ;; in EAT.
(DEFUN PR-INFINITY-EQS (gsm1 gsm2)
(declare (fixnum gsm1 gsm2))
t)
(DEFUN PR-INFINITY-BASIS (k)
(declare (fixnum k))
(flet ((rslt (dmns)
(declare (fixnum dmns))
(if (< 0 dmns k)
empty-list
(list dmns))))
(the basis #'rslt)))
(DEFUN PR-INFINITY-GDL (k)
(declare (fixnum k))
(flet ((rslt (indx dmns gsm)
(declare (fixnum indx dmns gsm))
(if (<= dmns k)
(asm (nreverse (<a-b< 0 (1- dmns))) 0)
(if (or (zerop indx)
(= indx dmns))
(asm nil (1- dmns))
(if (= dmns (1+ k))
(asm (nreverse (<a-b< 0 (1- dmns))) 0)
(asm (list (1- indx)) (- dmns 2)))))))
(the function #'rslt)))
(DEFUN PR-INFINITY (&optional (k 1))
(declare (fixnum k))
(build-ss
:eqs #'pr-infinity-eqs
:sbs (pr-infinity-basis k)
:bsp 0
:gdl (pr-infinity-gdl k)
:org `(pr-infinity ,k)))
(setf p (pr-infinity))
(sbs p 4)
(dotimes (i 5)
(print (gdl p i 4 4)))
(setf cc (ss-cc p))
(dotimes (i 5)
(print (d-? cc i i)))
(setf dd (cmp-mrp (cc-d cc) (cc-d cc)))
(dotimes (i 6)
(print (? dd i i)))
(setf p (pr-infinity 3))
(dotimes (i 7)
(print (sbs p i)))
(dotimes (i 5)
(print (gdl p i 4 4)))
(setf d (cc-d (ss-cc p)))
(dotimes (i 7)
(print (? d i i)))
(setf dd (cmp-mrp d d))
(dotimes (i 7)
(print (? dd i i)))
(setf p (pr-infinity 3))
(setf op (loop-space p))
(defun srandom (max)
(let ((rslt (- (random (+ max max)) max)))
(if (zerop rslt)
max
rslt)))
(dotimes (i 20) (print (srandom 3)))
(DEFUN DGOP-INT-EXT (dop)
(declare (fixnum dop))
(the list
(do ((dop dop (ash dop -1))
(rslt empty-list)
(bmark 0 (1+ bmark)))
((zerop dop) rslt)
(declare
(fixnum dop bmark)
(list rslt))
(when (oddp dop)
(push bmark rslt)))))
(defun random-apowr (dmns max-expn)
(let ((dgop (dgop-int-ext (* 2 (random (2-exp (1- dmns)))))))
(pwr (asm dgop (- 8 (length dgop))) (srandom max-expn))))
(dotimes (i 5) (print (random-apowr 8 3)))
(defun random-niloop (dmns max-expn length)
(mapcar #'(lambda (dummy)
(random-apowr (1+ dmns) max-expn))
(make-list length)))
(dotimes (i 20)
(print (normalize-loop 7 (make-strloop :lst (random-niloop 7 3 3)))))
(defun random-loop-cmbn (degr max-cffc max-expn loop-length cmbn-length)
(do ((rslt empty-list (cons mnm rslt))
(i cmbn-length (1- i))
(term))
((zerop i)
(make-cmb :dgr degr :lst rslt))
(setf mnm
(mnm (srandom max-cffc)
(make-strloop :lst (random-niloop degr max-expn loop-length))))))
(setf d (cc-d (ss-cc op)))
(setf c (random-loop-cmbn 8 10 4 4 100))
(time (??? d (??? d c)))
(time (??? d (??? d c)))
|#

664
Kenzo-1/lp-space-efhm.cl Normal file
View File

@ -0,0 +1,664 @@
;;; 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
(IN-PACKAGE "COMMON-LISP-USER")
(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)))
(declare
(type simplicial-set space)
(type chain-complex cobar spac-tnsr-lpsp)
(type simplicial-group loop-space))
(the chain-complex
(tnsr-prdc cobar spac-tnsr-lpsp)))
(DEFUN LS-HAT-LEFT-PERTURBATION-INTR (space)
(declare (type simplicial-set space))
(let ((cprd (dgnl space)))
(flet ((rslt (degr tnpr)
(declare
(fixnum degr)
(type tnpr tnpr))
(with-tnpr (degr1 allp1 nil tnpr2) tnpr
(with-tnpr (degr21 gmsm21 degr22 loop22) tnpr2
(let ((cprd (cmbn-list (gnrt-? cprd degr21 gmsm21))))
(declare (list cprd))
(setf cprd (rest cprd)) ;;; because \bar{A}
(make-cmbn :degr (1- degr)
:list
(mapcar
#'(lambda (term)
(declare (type term term))
(with-term (cffc tnpr21) term
(with-tnpr (degr211 gmsm211 degr212 gmsm212) tnpr21
(decf degr211)
(term cffc
(tnpr
(+ degr1 degr211)
(make-allp
:list (append
(allp-list allp1)
(list (cbgn degr211 gmsm211))))
(+ degr212 degr22)
(tnpr degr212 gmsm212 degr22 loop22))))))
cprd)))))))
(the intr-mrph #'rslt))))
(DEFUN LS-HAT-LEFT-PERTURBATION (space)
(declare (type simplicial-set space))
(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)))))
(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)))
(declare
(type simplicial-set space)
(type chain-complex ls-hat-u-u)
(type morphism ls-hat-left-perturbation))
(the chain-complex
(progn
(setf (slot-value ls-hat-left-perturbation 'sorc) ls-hat-u-u
(slot-value ls-hat-left-perturbation 'trgt) ls-hat-u-u)
;; because maybe these slots have been modified when constructing
;; the ls-left-hmeq-right-reduction
(add ls-hat-u-u ls-hat-left-perturbation))))
#|
(cat-init)
(setf c (ls-hat-t-u (deltab)))
(defun random-allp (length)
(let ((rslt nil))
(dotimes (i length)
(let* ((gmsm (random (mask 9)))
(dmns (1- (logcount gmsm))))
(when (plusp dmns)
(push (cbgn (1- dmns) gmsm) rslt))))
(make-allp :list rslt)))
(dotimes (i 10) (print (random-allp 5)))
(setf allp (random-allp 4)) ;; the degree could be too big
;; then redo
(setf allp-degr (apply #'+ (mapcar #'car (allp-list allp))))
(setf gnrt (tnpr allp-degr allp 4 (tnpr 2 7 2 (loop3 0 15 2))))
(? c (+ 4 allp-degr) gnrt)
(? c *)
(dotimes (i 10)
(let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (allp-list allp))))
(setf gnrt (tnpr allp-degr allp 4 (tnpr 2 7 2 (loop3 0 15 2))))
(unless (>= allp-degr 11)
(print (? c (+ 4 allp-degr) gnrt))
(print (? c (? c (+ 4 allp-degr) gnrt))))))
(dotimes (i 20)
(let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (allp-list allp))))
(setf gnrt (tnpr allp-degr allp 5 (tnpr 3 15 2 (loop3 0 15 2))))
(unless (>= allp-degr 10)
(print (? c (+ 5 allp-degr) gnrt))
(print (? c (? c (+ 5 allp-degr) gnrt))))))
(dotimes (i 20)
(let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (allp-list allp))))
(setf gnrt (tnpr allp-degr allp 5 (tnpr 2 7 3 (loop3 0 31 2))))
(unless (>= allp-degr 10)
(print (? c (+ 5 allp-degr) gnrt))
(print (? c (? c (+ 5 allp-degr) gnrt))))))
|#
(DEFUN LS-HAT-RIGHT-PERTURBATION (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)
(declare
(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))))
(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)))
(declare
(type simplicial-set space)
(type chain-complex cobar twisted-tnsr-prdc ls-hat-u-u))
(the chain-complex
(let ((rslt (tnsr-prdc cobar twisted-tnsr-prdc)))
(declare (type chain-complex rslt))
(setf (slot-value rslt 'grmd) ls-hat-u-u)
rslt)))
#|
(cat-init)
(setf c (ls-hat-u-t (deltab)))
(defun random-allp (length)
(let ((rslt nil))
(dotimes (i length)
(let* ((gmsm (random (mask 9)))
(dmns (1- (logcount gmsm))))
(when (plusp dmns)
(push (cbgn (1- dmns) gmsm) rslt))))
(make-allp :list rslt)))
(dotimes (i 10) (print (random-allp 5)))
(setf allp (random-allp 3))
(setf allp-degr (apply #'+ (mapcar #'car (allp-list allp))))
(setf gnrt (tnpr allp-degr allp 4 (tnpr 2 7 2 (loop3 0 15 2))))
(? c (+ 4 allp-degr) gnrt)
(? c *)
(dotimes (i 10)
(let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (allp-list allp))))
(setf gnrt (tnpr allp-degr allp 4 (tnpr 2 7 2 (loop3 0 15 2))))
(unless (>= allp-degr 11)
(print (? c (+ 4 allp-degr) gnrt))
(print (? c (? c (+ 4 allp-degr) gnrt))))))
(dotimes (i 20)
(let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (allp-list allp))))
(setf gnrt (tnpr allp-degr allp 5 (tnpr 3 15 2 (loop3 0 15 2))))
(unless (>= allp-degr 10)
(print (? c (+ 5 allp-degr) gnrt))
(print (? c (? c (+ 5 allp-degr) gnrt))))))
(dotimes (i 20)
(let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (allp-list allp))))
(setf gnrt (tnpr allp-degr allp 5 (tnpr 2 7 3 (loop3 0 31 2))))
(unless (>= allp-degr 10)
(print (? c (+ 5 allp-degr) gnrt))
(print (? c (? c (+ 5 allp-degr) gnrt))))))
|#
(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)))
(declare
(type simplicial-set space)
(type chain-complex ls-hat-u-t)
(type morphism ls-hat-left-perturbation))
(the chain-complex
(add ls-hat-u-t ls-hat-left-perturbation)))
#|
(cat-init)
(setf c (ls-left-hmeq-hat (deltab)))
(defun random-allp (length)
(let ((rslt nil))
(dotimes (i length)
(let* ((gmsm (random (mask 9)))
(dmns (1- (logcount gmsm))))
(when (plusp dmns)
(push (cbgn (1- dmns) gmsm) rslt))))
(make-allp :list rslt)))
(dotimes (i 10) (print (random-allp 5)))
(setf allp (random-allp 3))
(setf allp-degr (apply #'+ (mapcar #'car (allp-list allp))))
(setf gnrt (tnpr allp-degr allp 4 (tnpr 2 7 2 (loop3 0 15 2))))
(? c (+ 4 allp-degr) gnrt)
(? c *)
(dotimes (i 10)
(let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (allp-list allp))))
(setf gnrt (tnpr allp-degr allp 4 (tnpr 2 7 2 (loop3 0 15 2))))
(unless (>= allp-degr 11)
(print (? c (+ 4 allp-degr) gnrt))
(print (? c (? c (+ 4 allp-degr) gnrt))))))
(dotimes (i 20)
(let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (allp-list allp))))
(setf gnrt (tnpr allp-degr allp 5 (tnpr 3 15 2 (loop3 0 15 2))))
(unless (>= allp-degr 10)
(print (? c (+ 5 allp-degr) gnrt))
(print (? c (? c (+ 5 allp-degr) gnrt))))))
(dotimes (i 20)
(let ((allp (random-allp 3)))
(setf allp-degr (apply #'+ (mapcar #'car (allp-list allp))))
(setf gnrt (tnpr allp-degr allp 5 (tnpr 2 7 3 (loop3 0 31 2))))
(unless (>= allp-degr 10)
(print (? c (+ 5 allp-degr) gnrt))
(print (? c (? c (+ 5 allp-degr) gnrt))))))
|#
(DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-INTR-F (cmbn)
(declare (type cmbn cmbn))
(the cmbn
(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)))))
(make-cmbn :degr (cmbn-degr cmbn)
:list (nreverse rslt)))))
#|
(ls-pre-left-hmeq-left-reduction-intr-f
(cmbn 6 100 (tnpr 0 'a 6 (tnpr 0 'b 6 'c))
50 (tnpr 0 'a 6 (tnpr 0 'b 6 'cc))
10 (tnpr 0 'a 6 (tnpr 2 'b 4 'c))
1 (tnpr 2 'a 4 (tnpr 2 'b 2 'cc))))
|#
(DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-F (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))))
(DEFUN LS-LEFT-HMEQ-LEFT-REDUCTION-G-INTR (bspn)
(declare (type gmsm bspn))
(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 loop) term
(term cffc
(tnpr
0 +null-allp+
degr (tnpr 0 bspn degr loop)))))
list))))))
(the intr-mrph #'rslt)))
#|
(setf r (ls-left-hmeq-left-reduction-g-intr '*))
(funcall r (cmbn 3 4 'loop))
|#
(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)))
(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))))
(DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-H-INTR
(space
&aux (ls-hat-t-u (ls-hat-t-u space))
(cmpr (cmpr ls-hat-t-u)))
(declare
(type simplicial-set space)
(type chain-complex ls-hat-t-u)
(type cmprf cmpr))
(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)))))
(the intr-mrph #'rslt)))
#|
(setf r (ls-pre-left-hmeq-left-reduction-h-intr (deltab)))
(setf *tnpr-with-degrees* t)
(funcall r (cmbn 10 1 (tnpr 3 (allp 2 'a 1 'b) 7 (tnpr 5 'c 2 'd))
1 (tnpr 7 (allp 2 'a 5 'b) 3 (tnpr 0 '* 3 'c))
10 (tnpr 8 (allp 4 'aa 4 'bb) 2 (tnpr 0 '* 2 'cc))))
(funcall r (cmbn 10 1 (tnpr 3 (allp 2 'a 1 'b) 7 (tnpr 5 'c 2 'd))
1 (tnpr 7 (allp 4 'a 3 'b) 3 (tnpr 0 '* 3 'c))
10 (tnpr 8 (allp 3 'aa 5 'bb) 2 (tnpr 0 '* 2 'cc))))
(setf *tnpr-with-degrees* nil)
|#
(DEFUN LS-PRE-LEFT-HMEQ-LEFT-REDUCTION-H (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))))
(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))))
#|
(cat-init)
(setf rdct (ls-pre-left-hmeq-left-reduction (deltab)))
(pre-check-rdct rdct)
(defun random-allp (length)
(let ((rslt nil))
(dotimes (i length)
(let* ((gmsm (random (mask 9)))
(dmns (1- (logcount gmsm))))
(when (plusp dmns)
(push (cbgn (1- dmns) gmsm) rslt))))
(make-allp :list rslt)))
(setf allp (random-allp 3))
(setf allp-degr (apply #'+ (mapcar #'car (allp-list allp))))
(setf gnrt (tnpr allp-degr allp 4 (tnpr 2 7 2 (loop3 0 15 2))))
(setf *tc* (cmbn (+ 4 allp-degr) 1 gnrt))
(setf *bc* (cmbn 2 1 (loop3 0 15 2)))
(check-rdct)
(setf gnrt (tnpr allp-degr allp 4 (tnpr 0 1 4 (loop3 0 (mask 6) 2))))
(setf *tc* (cmbn (+ 4 allp-degr) 1 gnrt))
(check-rdct)
(setf *bc* (cmbn 0 1 (bspn (bcc rdct)))
(setf *tc* (cmbn 0 1 (bsgn (tcc rdct)))
(check-rdct)
|#
(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)))
(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))
(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)))))
#|
(cat-init)
(setf rdct (ls-left-hmeq-left-reduction (deltab2)))
(pre-check-rdct rdct)
(defun a (d1 d2 d3)
(setf *tc* (cmbn (+ d1 d2 d3)
1 (tnpr d1 (allp d1 (mask (+ d1 2)))
(+ d2 d3)
(tnpr d2 (mask (1+ d2))
d3 (loop3 0 (mask (+ d3 2)) 1))))
*bc* (cmbn d3 1
(loop3 0 (mask (+ d3 2)) -1)))
(check-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)
|#
;;; -[CLISP
#|
(DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-F (cmbn)
(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))))))
|#
;;; LISP]-
;;; +[CLISP
(DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-F (cmbn)
(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))))))
;;; CLISP]+
#|
()
(ls-pre-left-hmeq-right-reduction-intr-f
(cmbn 3 12 (tnpr 2 'a 1 'b) 14 (tnpr 3 'aa 0 '*))))
|#
(DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-F (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))))
(DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-INTR-G (bspn)
(declare (type gmsm bspn))
(flet ((rslt (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)))))))
(the intr-mrph #'rslt)))
#|
(setf r (ls-pre-left-hmeq-right-reduction-intr-g '*))
(funcall r (cmbn 3 4 'a))
|#
(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)))
(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))))
(DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION-H (space
&aux (cobar (cobar space))
(tnpr-contraction (tnpr-contraction space)))
(declare
(type simplicial-set space)
(type chain-complex cobar)
(type morphism tnpr-contraction))
(the morphism
(tnsr-prdc (idnt-mrph cobar) tnpr-contraction)))
(DEFUN LS-PRE-LEFT-HMEQ-RIGHT-REDUCTION (space)
(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))))
#|
(cat-init)
(setf r (ls-pre-left-hmeq-right-reduction (deltab2)))
(pre-check-rdct r)
(setf *tc* (cmbn 0 1 (bsgn (tcc r))))
(setf *bc* (cmbn 0 1 (bsgn (bcc r))))
(check-rdct)
(setf *tc* (cmbn 3 1 (tnpr 3 (allp 3 (mask 5)) 0 (tnpr 0 1 0 +null-loop+))))
(setf *bc* (cmbn 3 1 (allp 1 7 2 15)))
(check-rdct)
(setf *tc* (cmbn 6 1 (tnpr 3 (allp 1 7 2 15) 3 (tnpr 2 7 1 (loop3 0 7 2)))))
(check-rdct)
(setf *tc* (cmbn 6 1 (tnpr 3 (allp 1 7 2 15) 3 (tnpr 0 1 3 (loop3 0 (mask 5) 2)))))
(check-rdct)
|#
(DEFUN LS-LEFT-HMEQ-RIGHT-REDUCTION (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)
(type morphism perturbation))
(the reduction
(progn
(setf (slot-value perturbation 'sorc) (tcc pre-reduction)
(slot-value perturbation 'trgt) (tcc pre-reduction))
(special-bpl pre-reduction perturbation))))
#|
(cat-init)
(setf r (ls-left-hmeq-right-reduction (deltab2)))
(pre-check-rdct r)
(setf *tc* (cmbn 0 1 (bsgn (tcc r))))
(setf *bc* (cmbn 0 1 (bsgn (bcc r))))
(check-rdct)
(setf *tc* (cmbn 3 1 (tnpr 3 (allp 3 (mask 5)) 0 (tnpr 0 1 0 +null-loop+))))
(setf *bc* (cmbn 3 1 (allp 1 7 2 15)))
(check-rdct)
(setf *tc* (cmbn 6 1 (tnpr 3 (allp 1 7 2 15) 3 (tnpr 2 7 1 (loop3 0 7 2)))))
(check-rdct)
(setf *tc* (cmbn 6 1 (tnpr 3 (allp 1 7 2 15) 3 (tnpr 0 1 3 (loop3 0 (mask 5) 2)))))
(check-rdct)
|#
(DEFUN LS-LEFT-HMEQ (space)
(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))))
#|
(cat-init)
(setf h (ls-left-hmeq (deltab2)))
(setf loop (loop3 0 (mask 5) 2))
(lg h 3 loop)
(rf h *)
(rg h *)
(lf h *)
(setf allp (allp 2 (mask 4) 3 (mask 5)))
(rg h 5 allp)
(lf h *)
(lg h *)
(rf h *) ;; = allp, but why ?
|#
(DEFUN LOOP-SPACE-EFHM (space)
(declare (type simplicial-set space))
(let ((ls-left-hmeq (ls-left-hmeq space))
(right-hmeq (cobar (efhm space))))
(declare (type homotopy-equivalence ls-left-hmeq right-hmeq))
(cmps ls-left-hmeq right-hmeq)))
(DEFMETHOD SEARCH-EFHM (loop-space (orgn (eql 'loop-space)))
(declare (type simplicial-set loop-space))
(loop-space-efhm (second (orgn loop-space))))
#|
(cat-init)
(setf l (loop-space (sphere 2)))
(homology l 6)
(setf oos3 (loop-space (loop-space (sphere 3))))
(homology oos3 3)
(setf ooos4 (loop-space (loop-space (loop-space (sphere 4)))))
(homology ooos4 2)
|#

524
Kenzo-1/ls-twisted-products.cl Normal file
View File

@ -0,0 +1,524 @@
;;; 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
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "ls-twisted-products")
;; ABSM-LOOPABSM is the "twisted" product of ABSM, a simplex of the base
;; space of dimension DMNS by LOOP-ABSM, a simplex of the corresponding
;; loop-space, of dimension (1- DMNS). The returned object is
;; a loop-absm of dimension (1- DMNS).
(DEFUN ABSM-LOOPABSM (cmpr dmns absm loop-absm)
(declare
(type cmprf cmpr)
(fixnum dmns) ;; dimension of ABSM
(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))))))))))))))
#|
()
(setf cmpr (cmpr (deltab)))
(absm-loopabsm cmpr 3 (absm 4 7) (absm 7 +null-loop+))
(absm-loopabsm cmpr 3 (absm 0 15) (absm 7 +null-loop+))
(absm-loopabsm cmpr 3 (absm 2 7) (absm 2 (loop3 0 7 4)))
(absm-loopabsm cmpr 3 (absm 2 7) (absm 2 (loop3 0 7 4 1 12 -1)))
(absm-loopabsm cmpr 3 (absm 2 7) (absm 2 (loop3 0 7 -1)))
(absm-loopabsm cmpr 3 (absm 2 7) (absm 2 (loop3 0 7 -1 1 12 -1)))
(absm-loopabsm cmpr 3 (absm 2 7) (absm 2 (loop3 0 7 4)))
(absm-loopabsm cmpr 3 (absm 2 7) (absm 0 (loop3 2 7 4 1 14 -1)))
(absm-loopabsm cmpr 3 (absm 2 7) (absm 0 (loop3 2 7 -1))) ;; in principle illegal but works
(absm-loopabsm cmpr 3 (absm 2 7) (absm 0 (loop3 2 7 -1 1 14 -1)))
(absm-loopabsm cmpr 3 (absm 2 7) (absm 0 (loop3 0 15 -1 1 14 -1)))
(absm-loopabsm cmpr 3 (absm 0 15) (absm 2 (loop3 0 7 -1 0 14 -1)))
(absm-loopabsm cmpr 3 (absm 2 7) (absm 2 (loop3 0 28 -1 0 14 -1)))
|#
(DEFUN TWISTED-CRTS-PRDC-FACE (cmpr space-face loop-space-face non-twisted-face)
(declare
(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)))))))
(the face #'rslt)))
(DEFUN TWISTED-CRTS-PRDC (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
space-cmpr space-face loop-space-face crts-prdc-face)
:orgn `(twisted-crts-prdc ,space))))
(setf (slot-value rslt 'grmd) crts-prdc)
rslt))))))
#|
(setf p (r-proj-space 3))
(setf tw (twisted-crts-prdc p))
(defun random-apowr (dmns max-expn)
(loop
(let* ((dgop (random (2-exp (1- dmns))))
(gmsm (- dmns (logcount dgop))))
(unless (< 0 gmsm 3)
(return-from random-apowr
(apowr dgop gmsm (srandom max-expn)))))))
(defun random-niloop (dmns max-expn length)
(mapcar #'(lambda (dummy)
(random-apowr (1+ dmns) max-expn))
(make-list length)))
(defun random-crpr (dmns max-expn length)
(loop
(let ((loop (normalize-loop dmns (random-niloop dmns max-expn length)))
(dgop (random (2-exp dmns))))
(let ((absm (2absm-acrpr (absm dgop (- dmns (logcount dgop))) loop)))
(when (and (zerop (dgop absm))
(not (< (gmsm1 (gmsm absm)) 3)))
(return (gmsm absm)))))))
(setf cmpr (cmpr tw))
(defun random-cmbn (degr max-cffc max-expn loop-length cmbn-length)
(apply #'nterm-add cmpr degr
(mapcar #'(lambda (dummy)
(term (srandom max-cffc) (random-crpr degr max-expn loop-length)))
(make-list cmbn-length))))
(setf c (random-cmbn 8 10 4 4 100))
(time (? tw (? tw c)))
(time (? tw (? tw c)))
|#
(DEFUN DTAU-D-INTR (crts-prdc-cmpr crts-prdc-face twisted-crts-prdc-face)
(declare
(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
(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.~@
Crpr = ~A~@
D-tau = ~A~@
D = ~A"
crpr gmsm-tau gmsm))))))))))))
(the intr-mrph #'rslt)))
#|
(setf d (deltab))
(setf p (crts-prdc d (loop-space d)))
(setf tw (twisted-crts-prdc d))
(setf crts-prdc-cmpr (cmpr p)
crts-prdc-face (face p)
twisted-crts-prdc-face (face tw))
(setf delta (dtau-d-intr crts-prdc-cmpr crts-prdc-face twisted-crts-prdc-face))
(funcall delta 3 (crpr 0 15 0 (loop3 0 (- 2048 64) 1)))
(funcall delta 5 (crpr 10 15 5 (loop3 0 (- 2048 64) 1)))
(funcall delta 5 (crpr 5 15 10 (loop3 0 (- 2048 64) 1)))
|#
(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)))
(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))))
(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)))
(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))
(values szczarba bottom-perturbation))))
#|
(cat-init)
(setf rdct (szczarba (deltab)))
(pre-check-rdct rdct)
(setf *tc* (cmbn 2 1 (crpr 0 7 0 (loop3 0 (- 512 32) 1)))
*bc* (cmbn 2 1 (tnpr 0 1 2 (loop3 0 (- 512 32) 1))
10 (tnpr 1 (- 4096 1024) 1 (loop3 0 7 1))
100 (tnpr 2 7 0 (loop3 0 (- 4096 1024) 1))))
(check-rdct)
(setf bcc (bcc rdct))
(time (? bcc 5 (tnpr 5 (mask 6) 0 +null-loop+)))
(time (? bcc 6 (tnpr 6 (mask 7) 0 +null-loop+)))
|#
(DEFUN TWISTED-TNSR-PRDC (space
&aux (szczarba (szczarba space)))
(declare
(type simplicial-set space)
(type reduction szczarba))
(the chain-complex
(bcc szczarba)))
;;;
;;; The important contraction.
;;;
(DEFUN POP-FIRST-ABSM (dmns iloop)
(declare (type iloop iloop))
(the (values (member -1 0 1) (or nil absm) absm)
(progn
(unless 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))))))))))
#|
()
(pop-first-absm 4 (cdr +null-loop+))
(pop-first-absm 4 (cdr (loop3 0 'a -2)))
(pop-first-absm 4 (cdr (loop3 0 'a +2)))
(pop-first-absm 4 (cdr (loop3 0 'a -1)))
(pop-first-absm 4 (cdr (loop3 0 'a +1)))
(pop-first-absm 4 (cdr (loop3 1 'a -2 2 'b 3)))
(pop-first-absm 4 (cdr (loop3 0 'a +2 2 'b -3)))
(pop-first-absm 4 (cdr (loop3 1 'a -1 2 'b 3)))
(pop-first-absm 4 (cdr (loop3 0 'a +1 2 'b 5)))
(pop-first-absm 4 (cdr (loop3 2 'a -1 1 'b 3)))
(pop-first-absm 4 (cdr (loop3 2 'a +1 1 'b 3)))
|#
(DEFUN CRTS-CONTRACTION-INTR (base-cmpr base-bspn base-face crts-cmpr)
(declare
(type cmprf base-cmpr crts-cmpr)
(type gmsm base-bspn)
(type face base-face))
(flet ((rslt (n crpr)
(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 absm y-n+1)
(type loop 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)))
#|
()
(cat-init)
(setf delta (deltab))
(setf tw (twisted-crts-prdc delta))
(setf d (bndr tw))
(setf base-cmpr (cmpr delta)
base-bspn (bspn delta)
base-face (face delta)
crts-cmpr (cmpr tw))
(setf r (crts-contraction-intr base-cmpr base-bspn base-face crts-cmpr))
(setf h (build-mrph :sorc tw :trgt tw :degr +1
:intr r :strt :gnrt :orgn `(crts-contraction ,delta)))
(setf z (i-sbtr (idnt-mrph tw) (cmps d h) (cmps h d)))
(? z 0 (crpr 0 1 0 +null-loop+))
(funcall r 0 (crpr 0 1 0 (loop3 0 96 1)))
(? z 0 (crpr 0 1 0 (loop3 0 96 1)))
(? z 0 (crpr 0 1 0 (loop3 0 96 1 0 (+ 256 128) 1)))
(? z 0 (crpr 0 1 0 (loop3 0 96 1 0 (+ 256 128) 1 0 (+ 512 1024) 1)))
(? z 0 (crpr 0 1 0 (loop3 0 96 2)))
(? z 1 (crpr 0 3 0 (loop3 0 (+ 32 64 128) 1)))
(? z 2 (crpr 0 7 0 (loop3 0 (+ 32 64 128 256) 1)))
(? z 3 (crpr 2 7 1 (loop3 2 (+ 32 64 128) 2 4 (+ 32 64 128) -2)))
(? z 3 (crpr 2 7 4 (loop3 2 (+ 32 64 128) 2 1 (+ 32 64 128) -2)))
(? z 3 (crpr 2 7 1 (loop3 2 (+ 32 64 128) -2 4 (+ 32 64 128) 2)))
(? z 3 (crpr 2 7 4 (loop3 2 (+ 32 64 128) -2 1 (+ 32 64 128) 2)))
(? z 3 (crpr 1 7 2 (loop3 2 (+ 32 64 128) 2 4 (+ 32 64 128) -2)))
(? z 3 (crpr 4 7 2 (loop3 2 (+ 32 64 128) 2 1 (+ 32 64 128) -2)))
(? z 3 (crpr 1 7 2 (loop3 2 (+ 32 64 128) -2 4 (+ 32 64 128) 2)))
(? z 3 (crpr 4 7 2 (loop3 2 (+ 32 64 128) -2 1 (+ 32 64 128) 2)))
|#
#|
(cat-init)
(setf p (r-proj-space 3))
(setf tw (twisted-crts-prdc p))
(setf r (crts-contraction-intr (cmpr p) (bspn p) (face p) (cmpr tw)))
(defun random-apowr (dmns max-expn)
(loop
(let* ((dgop (random (2-exp (1- dmns))))
(gmsm (- dmns (logcount dgop))))
(unless (< 0 gmsm 3)
(return-from random-apowr
(apowr dgop gmsm (srandom max-expn)))))))
(defun random-niloop (dmns max-expn length)
(mapcar #'(lambda (dummy)
(random-apowr (1+ dmns) max-expn))
(make-list length)))
(defun random-crpr (dmns max-expn length)
(loop
(let ((loop (normalize-loop dmns (random-niloop dmns max-expn length)))
(dgop (random (2-exp dmns))))
(let ((absm (2absm-acrpr (absm dgop (- dmns (logcount dgop))) loop)))
(when (and (zerop (dgop absm))
(not (< (gmsm1 (gmsm absm)) 3)))
(return (gmsm absm)))))))
(setf cmpr (cmpr tw))
(defun random-cmbn (degr max-cffc max-expn loop-length cmbn-length)
(apply #'nterm-add cmpr degr
(mapcar #'(lambda (dummy)
(term (srandom max-cffc) (random-crpr degr max-expn loop-length)))
(make-list cmbn-length))))
(setf h (build-mrph :sorc tw :trgt tw :degr +1
:intr r :strt :gnrt :orgn `(crts-contraction ,p)))
(setf d (bndr tw))
(setf z (i-sbtr (idnt-mrph tw) (cmps h d) (cmps d h)))
(setf c (random-cmbn 5 10 2 2 1))
(? z c)
(setf c (random-cmbn 6 10 3 3 3))
(? z c)
(setf c (random-cmbn 7 10 4 4 6))
(? z c)
(setf c (random-cmbn 8 10 4 4 20))
(? z c)
(? h c)
(? d *)
(length *)
|#
(DEFUN CRTS-CONTRACTION (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))))
#|
(setf h (crts-contraction (deltab)))
(setf d (bndr (twisted-crts-prdc (deltab))))
(setf z (i-sbtr (idnt-mrph (sorc d)) (cmps d h) (cmps h d)))
(? z 3 (crpr 4 7 2 (loop3 2 (+ 32 64 128) -2 1 (+ 32 64 128) 2)))
|#
(DEFUN TNPR-CONTRACTION (space
&aux
(szczarba (szczarba space))
(f (f szczarba))
(g (g szczarba))
(crts-contraction (crts-contraction space)))
(declare
(type simplicial-set space)
(type reduction szczarba)
(type morphism f g crts-contraction))
(the morphism
(i-cmps f crts-contraction g)))
#|
(cat-init)
(setf delta (deltab))
(setf sz (szczarba (deltab)))
(setf tw (bcc sz))
(setf h (tnpr-contraction delta))
(setf z (i-sbtr (idnt-mrph tw) (cmps tw h) (cmps h tw)))
(time (? z 3 (tnpr 0 1 3 (loop3 0 (mask 5) 2 0 (* 32 (mask 5)) -1))))
(? h 4 (tnpr 0 1 0 (loop3 0 (mask 6) 1)))
|#

886
Kenzo-1/macros.cl Normal file
View File

@ -0,0 +1,886 @@
;;; MACROS MACROS MACROS MACROS MACROS MACROS MACROS
;;; MACROS MACROS MACROS MACROS MACROS MACROS MACROS
;;; MACROS MACROS MACROS MACROS MACROS MACROS MACROS
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "macros")
;;;
;;; VARIOUS
;;;
(DEFMACRO -1-EXPT-N (n)
`(the fixnum (if (evenp (the fixnum ,n)) 1 -1)))
(DEFMACRO -1-EXPT-N+1 (n)
`(the fixnum (if (evenp (the fixnum ,n)) -1 1)))
(DEFMACRO -1-EXPT-N-1 (n)
`(-1-expt-n+1 ,n))
#|
()
(-1-expt-n 5)
(-1-expt-n 6)
(-1-expt-n+1 5)
(-1-expt-n+1 6)
(-1-expt-n-1 5)
(-1-expt-n-1 6)
|#
(DEFMACRO 2-EXP (n)
`(aref +2-exp+ ,n))
(DEFMACRO MASK (n)
`(aref +mask+ ,n))
(DEFMACRO BINOMIAL-P-Q (p q)
`(binomial-n-p (+ ,p ,q) ,p))
;;;
;;; COMBINATIONS
;;;
(DEFMACRO LEXICO (&rest rest)
(unless (cdr rest)
(return-from lexico (first rest)))
(let ((vrslt (gensym)))
`(let ((,vrslt ,(first rest)))
(declare (type cmpr ,vrslt))
(if (eq ,vrslt :equal)
(lexico ,@(rest rest))
,vrslt))))
#|
()
(let ((*print-level* nil))
(declare (special
#+aclpc allegro:*top-print-level*
#-aclpc *print-level*))
(pprint (macroexpand-1
'(lexico
comparison1
comparison2
comparison3
comparison4))))
|#
(DEFMACRO TERM (cffc gnrt)
`(cons ,cffc ,gnrt))
(DEFMACRO -TERM (mark)
`(car ,mark))
(DEFMACRO CFFC (term)
`(car ,term))
(DEFMACRO -CFFC (mark)
`(caar ,mark))
(DEFMACRO GNRT (term)
`(cdr ,term))
(DEFMACRO -GNRT (mark)
`(cdar ,mark))
(DEFMACRO WITH-TERM ((cffc gnrt) term . body)
`(let (,@(if cffc `((,cffc (cffc ,term))) nil)
,@(if gnrt `((,gnrt (gnrt ,term))) nil))
(declare
(fixnum ,@(if cffc `(,cffc) nil))
(type gnrt ,@(if gnrt `(,gnrt) nil)))
,@body))
#|
(macroexpand-1 '(with-term (cffc gnrt) term
(statement-1)
(statement-2)))
(macroexpand-1 '(with-term (nil gnrt) term
(statement-1)
(statement-2)))
|#
(DEFMACRO WITH--TERM ((cffc gnrt) mark . body)
`(let ((,cffc (-cffc ,mark))
(,gnrt (-gnrt ,mark)))
(declare
(fixnum ,cffc)
(type gnrt ,gnrt))
,@body))
#|
(macroexpand-1 '(with--term (cffc gnrt) mark
(statement-1)
(statement-2)))
|#
(DEFMACRO WITH-CMBN ((degr list) cmbn . body)
`(let ((,degr (cmbn-degr ,cmbn))
(,list (cmbn-list ,cmbn)))
(declare
(fixnum ,degr)
(list ,list))
,@body))
#|
(macroexpand-1 '(with-cmbn (degr list) cmbn
(statement-1)
(statement-2)))
|#
(DEFMACRO TERM-CMBN (degr cffc gnrt)
`(make-cmbn :degr ,degr
:list (list (term ,cffc ,gnrt))))
(DEFMACRO CMBN-NON-ZERO-P (cmbn)
`(cmbn-list ,cmbn))
(DEFMACRO CMBN-ZERO-P (cmbn)
`(null (cmbn-list ,cmbn)))
(DEFMACRO CONTROL (cmpr cmbn)
(if *cmbn-control*
`(do-control ,cmpr ,cmbn)
cmbn))
(DEFMACRO CONTROLN (cmpr cmbn)
(if *cmbn-control*
`(do-control ,cmpr ,cmbn)
nil))
(DEFVAR *WRONG-CMBN*)
;;;
;;; CHAIN-COMPLEXES
;;;
(DEFMACRO CMPR (&rest rest)
(ecase (length rest)
(1 `(cmpr1 ,@rest))
(3 `(cmpr3 ,@rest))))
(DEFMACRO CMPR3 (object item1 item2)
`(funcall (cmpr1 ,object) ,item1 ,item2))
#|
(macroexpand '(cmpr chcm))
(macroexpand '(cmpr chcm item1 item2))
|#
(DEFMACRO BASIS (&rest rest)
(ecase (length rest)
(1 `(basis1 ,@rest))
(2 `(basis2 ,@rest))
(3 `(basis3 ,@rest))))
(DEFMACRO BASIS3 (smst dmns keyword)
(declare (ignore keyword))
`(a-basis2 (basis ,smst) ,dmns))
(DEFMACRO DFFR (&rest rest)
(ecase (length rest)
(1 `(dffr1 ,@rest))
((2 3) `(? (dffr1 ,(first rest)) ,@(rest rest)))))
#|
(macroexpand '(dffr chcm))
(macroexpand '(dffr chcm cmbn))
(macroexpand '(dffr chcm degr gnrt))
|#
(DEFMACRO ? (&rest rest)
(ecase (length rest)
(2 `(?2 ,@rest))
(3 `(?3 ,@rest))))
;;;
;;; CHCM-ELEMENTARY-OP
;;;
(DEFMACRO I-CMPS (mrph1 &rest rest)
(if rest
`(cmps ,mrph1 (i-cmps ,@rest))
mrph1))
#|
(macroexpand '(i-cmps m1))
(macroexpand '(i-cmps m1 m2))
(macroexpand '(i-cmps m1 m2 m3))
|#
(DEFMACRO I-ADD (mrph1 &rest rest)
(if rest
`(add ,mrph1 (i-add ,@rest))
mrph1))
#|
(macroexpand '(i-add m1))
(macroexpand '(i-add m1 m2))
(macroexpand '(i-add m1 m2 m3))
|#
(DEFMACRO I-SBTR (mrph1 mrph2 &rest rest)
`(sbtr ,mrph1 (i-add ,mrph2 ,@rest)))
#|
(macroexpand '(i-sbtr m1 m2))
(macroexpand '(i-sbtr m1 m2 m3))
|#
;;;
;;; EFFECTIVE HOMOLOGY
;;;
(DEFMACRO BCC (&rest rest)
(case (length rest)
(1 `(bcc1 ,@rest))
(otherwise
`(? (bcc1 ,(first rest)) ,@(rest rest)))))
(DEFMACRO TCC (&rest rest)
(case (length rest)
(1 `(tcc1 ,@rest))
(otherwise
`(? (tcc1 ,(first rest)) ,@(rest rest)))))
(DEFMACRO F (&rest rest)
(case (length rest)
(1 `(f1 ,@rest))
(otherwise
`(? (f1 ,(first rest)) ,@(rest rest)))))
#|
(macroexpand '(f rdct))
(macroexpand '(f rdct cmbn))
(macroexpand '(f rdct degr gnrt))
|#
(DEFMACRO G (&rest rest)
(case (length rest)
(1 `(g1 ,@rest))
(otherwise
`(? (g1 ,(first rest)) ,@(rest rest)))))
(DEFMACRO H (&rest rest)
(case (length rest)
(1 `(h1 ,@rest))
(otherwise
`(? (h1 ,(first rest)) ,@(rest rest)))))
(DEFMACRO LBCC (&rest rest)
(case (length rest)
(1 `(lbcc1 ,@rest))
(otherwise
`(? (lbcc1 ,(first rest)) ,@(rest rest)))))
(DEFMACRO RBCC (&rest rest)
(case (length rest)
(1 `(rbcc1 ,@rest))
(otherwise
`(? (rbcc1 ,(first rest)) ,@(rest rest)))))
(DEFMACRO LF (&rest rest)
(case (length rest)
(1 `(lf1 ,@rest))
(otherwise
`(? (lf1 ,(first rest)) ,@(rest rest)))))
(DEFMACRO LG (&rest rest)
(case (length rest)
(1 `(lg1 ,@rest))
(otherwise
`(? (lg1 ,(first rest)) ,@(rest rest)))))
(DEFMACRO LH (&rest rest)
(case (length rest)
(1 `(lh1 ,@rest))
(otherwise
`(? (lh1 ,(first rest)) ,@(rest rest)))))
(DEFMACRO RF (&rest rest)
(case (length rest)
(1 `(rf1 ,@rest))
(otherwise
`(? (rf1 ,(first rest)) ,@(rest rest)))))
(DEFMACRO RG (&rest rest)
(case (length rest)
(1 `(rg1 ,@rest))
(otherwise
`(? (rg1 ,(first rest)) ,@(rest rest)))))
(DEFMACRO RH (&rest rest)
(case (length rest)
(1 `(rh1 ,@rest))
(otherwise
`(? (rh1 ,(first rest)) ,@(rest rest)))))
;;;
;;; HOMOLOGY-GROUPS
;;;
(DEFMACRO BASELIG (mat n)
`(aref (leftcol ,mat) ,n))
(DEFMACRO BASECOL (mat n)
`(aref (uplig ,mat) ,n))
;;;
;;; CONES
;;;
(DEFMACRO CON0 (gnrt)
`(make-cone :conx 0 :icon ,gnrt))
(DEFMACRO CON1 (gnrt)
`(make-cone :conx 1 :icon ,gnrt))
(DEFMACRO WITH-CONE ((conx icon) cone . body)
(let ((scone (gensym)))
(declare (symbol scone))
`(let ((,scone ,cone))
(declare (type cone ,scone))
(let ((,conx (conx ,scone))
(,icon (icon ,scone)))
(declare (type (member 0 1) ,conx) (type gnrt ,icon))
,@body))))
(DEFMACRO BCNB (gnrt)
`(make-bicn :bcnx :bcnb :ibicn ,gnrt))
(DEFMACRO BCNC (gnrt)
`(make-bicn :bcnx :bcnc :ibicn ,gnrt))
(DEFMACRO BCND (gnrt)
`(make-bicn :bcnx :bcnd :ibicn ,gnrt))
(DEFMACRO WITH-BICN ((bcnx ibicn) bicn . body)
`(let ((,bcnx (bcnx ,bicn))
(,ibicn (ibicn ,bicn)))
(declare
(type (member :bcnb :bcnc :bcnd) ,bcnx)
(type gnrt ,ibicn))
,@body))
;;;
;;; TENSOR PRODUCTS
;;;
#|
(DEFMACRO TNPR (degr1 gnrt1 degr2 gnrt2)
`(cons :tnpr (cons (cons ,degr1 ,gnrt1) (cons ,degr2 ,gnrt2))))
(DEFMACRO DEGR1 (tnpr)
`(caadr ,tnpr))
(DEFMACRO GNRT1 (tnpr)
`(cdadr ,tnpr))
(DEFMACRO DEGR2 (tnpr)
`(caddr ,tnpr))
(DEFMACRO GNRT2 (tnpr)
`(cdddr ,tnpr))
|#
(DEFMACRO TNPR (degr1 gnrt1 degr2 gnrt2)
`(make-tnpr :degr1 ,degr1 :gnrt1 ,gnrt1
:degr2 ,degr2 :gnrt2 ,gnrt2))
(DEFMACRO WITH-TNPR ((degr1 gnrt1 degr2 gnrt2) tnpr . body)
`(let (,@(if degr1 `((,degr1 (degr1 ,tnpr))) nil)
,@(if gnrt1 `((,gnrt1 (gnrt1 ,tnpr))) nil)
,@(if degr2 `((,degr2 (degr2 ,tnpr))) nil)
,@(if gnrt2 `((,gnrt2 (gnrt2 ,tnpr))) nil))
(declare
(fixnum ,@(if degr1 `(,degr1) nil) ,@(if degr2 `(,degr2) nil))
(type gnrt ,@(if gnrt1 `(,gnrt1) nil) ,@(if gnrt2 `(,gnrt2) nil)))
,@body))
#|
(macroexpand '(tnpr 1 a 2 b))
1 (tnpr 2 'a 4 (tnpr 2 'b 2 'c))
(macroexpand-1 '(with-tnpr (degr1 gnrt1 degr2 gnrt2) tnpr
(statement-1)
(statement-2)))
(macroexpand-1 '(with-tnpr (nil gnrt1 degr2 gnrt2) tnpr
(statement-1)
(statement-2)))
|#
;;;
;;; COALGEBRAS
;;;
(DEFMACRO CPRD (&rest rest)
(case (length rest)
(1 `(cprd1 ,@rest))
((2 3) `(? (cprd1 ,(first rest)) ,@(rest rest)))))
;;;
;;; COBAR
;;;
(DEFMACRO CBGN (degr gnrt)
`(cons ,degr ,gnrt))
(DEFMACRO CDEGR (cbgn)
`(car ,cbgn))
(DEFMACRO CGNRT (cbgn)
`(cdr ,cbgn))
(DEFMACRO -CDEGR (cbgn)
`(caar ,cbgn))
(DEFMACRO -CGNRT (cbgn)
`(cdar ,cbgn))
(DEFMACRO WITH-CBGN ((cdegr cgnrt) cbgn . body)
`(let ((,cdegr (cdegr ,cbgn))
(,cgnrt (cgnrt ,cbgn)))
(declare
(fixnum ,cdegr)
(type gnrt ,cgnrt))
,@body))
(DEFMACRO WITH--CBGN ((cdegr cgnrt) cbgn . body)
`(let ((,cdegr (-cdegr ,cbgn))
(,cgnrt (-cgnrt ,cbgn)))
(declare
(fixnum ,cdegr)
(type gnrt ,cgnrt))
,@body))
(DEFMACRO WITH-ALLP ((list) allp . body)
`(let ((,list (allp-list ,allp)))
(declare (list ,list))
,@body))
(DEFMACRO GNRT-ALLP-TNPR (degr gnrt allp)
`(make-allp :list (cons (cbgn (1- ,degr) ,gnrt) ,allp)))
;;;
;;; ALGEBRAS
;;;
(DEFMACRO APRD (&rest rest)
(case (length rest)
(1 `(aprd1 ,@rest))
((2 3) `(? (aprd1 ,(first rest)) ,@(rest rest)))))
;;;
;;; BAR
;;;
(DEFMACRO BRGN (degr gnrt)
`(cons ,degr ,gnrt))
(DEFMACRO BDEGR (brgn)
`(car ,brgn))
(DEFMACRO BGNRT (brgn)
`(cdr ,brgn))
(DEFMACRO -BDEGR (brgn)
`(caar ,brgn))
(DEFMACRO -BGNRT (brgn)
`(cdar ,brgn))
(DEFMACRO WITH-BRGN ((bdegr bgnrt) brgn . body)
`(let ((,bdegr (bdegr ,brgn))
(,bgnrt (bgnrt ,brgn)))
(declare
(fixnum ,bdegr)
(type gnrt ,bgnrt))
,@body))
(DEFMACRO WITH--BRGN ((bdegr bgnrt) brgn . body)
`(let ((,bdegr (-bdegr ,brgn))
(,bgnrt (-bgnrt ,brgn)))
(declare
(fixnum ,bdegr)
(type gnrt ,bgnrt))
,@body))
#|
(DEFMACRO MAKE-ABAR (&key list)
`(cons :abar ,list))
(DEFMACRO ABAR-LIST (abar)
`(cdr ,abar))
|#
(DEFMACRO WITH-ABAR ((list) abar . body)
`(let ((,list (abar-list ,abar)))
(declare (list ,list))
,@body))
#|
(DEFMACRO MAKE-GBAR (&key dmns list)
`(cons :gbar (cons ,dmns ,list)))
(DEFMACRO GBAR-DMNS (gbar)
`(cadr ,gbar))
(DEFMACRO GBAR-LIST (gbar)
`(cddr ,gbar))
|#
(DEFMACRO WITH-GBAR ((dmns list) gbar . body)
`(let ((,dmns (gbar-dmns ,gbar))
(,list (gbar-list ,gbar)))
(declare
(fixnum ,dmns)
(list ,list))
,@body))
#|
(DEFMACRO GNRT-GBAR-TNPR (degr gnrt gbar)
`(make-gbar :list (cons (brgn (1- ,degr) ,gnrt) ,gbar)))
|#
;;;
;;; SIMPLICIAL SETS
;;;
#|
(DEFMACRO ABSM (dgop gmsm)
`(cons :absm (cons ,dgop ,gmsm)))
(DEFMACRO DGOP (absm)
`(cadr ,absm))
(DEFMACRO GMSM (absm)
`(cddr ,absm))
|#
(DEFMACRO ABSM (dgop gmsm)
`(make-absm :dgop ,dgop :gmsm ,gmsm))
(DEFMACRO WITH-ABSM ((dgop-var gmsm-var) absm . body)
(let ((sabsm (gensym)))
`(let ((,sabsm ,absm))
(declare (type absm ,sabsm))
(let ((,dgop-var (dgop ,sabsm))
(,gmsm-var (gmsm ,sabsm)))
(declare
(fixnum ,dgop-var)
(type gmsm ,gmsm-var))
,@body))))
(DEFMACRO DEGENERATE-P (absm)
`(plusp (dgop ,absm)))
(DEFMACRO NON-DEGENERATE-P (absm)
`(zerop (dgop ,absm)))
(DEFMACRO BSPN (smst)
`(bsgn ,smst))
(DEFMACRO BNDR (&rest rest)
`(dffr ,@rest))
(DEFMACRO DGNL (&rest rest)
`(cprd ,@rest))
(DEFMACRO FACE (&rest rest)
(ecase (length rest)
(1 `(face1 ,@rest))
(4 `(face4 ,@rest))))
;;;
;;; DELTA
;;;
(DEFMACRO D (igmsm)
`(cons :delt ,igmsm))
;;;
;;; SPECIAL-SMSTS
;;;
;;; GMSM-FACES-INFO = (gmsm (simple-vector absm) . bndr)
;;; faces
(DEFMACRO MAKE-GMSM-FACES-INFO (&key gmsm faces bndr)
`(cons ,gmsm (cons ,faces ,bndr)))
(DEFMACRO INFO-GMSM (gmsm-faces-info)
`(car ,gmsm-faces-info))
(DEFMACRO INFO-FACES (gmsm-faces-info)
`(cadr ,gmsm-faces-info))
(DEFMACRO INFO-FACE-I (gmsm-faces-info i)
`(svref (cadr ,gmsm-faces-info) ,i))
(DEFMACRO INFO-BNDR (gmsm-faces-info)
`(cddr ,gmsm-faces-info))
;;;
;;; CARTESIAN PRODUCTS
;;;
#|
(DEFMACRO CRPR (&rest rest)
(ecase (length rest)
(2 `(cons :crpr (cons (cdr ,(first rest)) (cdr ,(second rest)))))
(4 `(cons :crpr (cons
(cons ,(first rest) ,(second rest))
(cons ,(third rest) ,(fourth rest)))))))
|#
(DEFMACRO CRPR (&rest rest)
(ecase (length rest)
(2 `(crpr2 ,@rest))
(4 `(crpr4 ,@rest))))
(DEFMACRO CRPR2 (absm1 absm2)
`(crpr4 (dgop ,absm1) (gmsm ,absm1) (dgop ,absm2) (gmsm ,absm2)))
(DEFMACRO CRPR4 (dgop1 gmsm1 dgop2 gmsm2)
`(make-crpr :dgop1 ,dgop1 :gmsm1 ,gmsm1
:dgop2 ,dgop2 :gmsm2 ,gmsm2))
#|
()
(crpr (absm 3 'a) (absm 4 'b))
(crpr 3 'a 4 'b)
|#
#|
()
(macroexpand '(crpr absm1 absm2))
(macroexpand '(crpr dgop1 gmsm1 dgop2 gmsm2))
|#
#|
(DEFMACRO DGOP1 (crpr)
`(caadr ,crpr))
(DEFMACRO GMSM1 (crpr)
`(cdadr ,crpr))
(DEFMACRO DGOP2 (crpr)
`(caddr ,crpr))
(DEFMACRO GMSM2 (crpr)
`(cdddr ,crpr))
(DEFMACRO ABSM1 (crpr)
`(cons :absm (cadr ,crpr)))
(DEFMACRO ABSM2 (crpr)
`(cons :absm (cddr ,crpr)))
|#
(DEFMACRO ABSM1 (crpr)
`(absm (dgop1 ,crpr) (gmsm1 ,crpr)))
(DEFMACRO ABSM2 (crpr)
`(absm (dgop2 ,crpr) (gmsm2 ,crpr)))
#|
()
(setf c (crpr 1 'a 2 'b))
(dgop1 c)
(gmsm1 c)
(dgop2 c)
(gmsm2 c)
(absm1 c)
(absm2 c)
|#
(DEFMACRO WITH-CRPR (&rest rest)
(ecase (length (first rest))
(2 `(with-crpr-2 ,@rest))
(4 `(with-crpr-4 ,@rest))))
#|
(DEFMACRO WITH-CRPR-2 ((absm1 absm2) crpr . body)
`(let ((,absm1 (cons :absm (cadr ,crpr)))
(,absm2 (cons :absm (cddr ,crpr))))
(declare (type absm ,absm1 ,absm2))
,@body))
|#
(DEFMACRO WITH-CRPR-2 ((absm1 absm2) crpr . body)
`(let ((,absm1 (absm (dgop1 ,crpr) (gmsm1 ,crpr)))
(,absm2 (absm (dgop2 ,crpr) (gmsm2 ,crpr))))
(declare (type absm ,absm1 ,absm2))
,@body))
#|
()
(with-crpr (absm1 absm2) (crpr 3 'a 4 'b) (list absm1 absm2))
|#
(DEFMACRO WITH-CRPR-4 ((dgop1 gmsm1 dgop2 gmsm2) crpr . body)
`(let ((,dgop1 (dgop1 ,crpr))
(,gmsm1 (gmsm1 ,crpr))
(,dgop2 (dgop2 ,crpr))
(,gmsm2 (gmsm2 ,crpr)))
(declare
(fixnum ,dgop1 ,dgop2)
(type gmsm ,gmsm1 ,gmsm2))
,@body))
#|
()
(macroexpand-1
(macroexpand-1 '(with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr
(statement-1)
(statement-2))))
(macroexpand-1
(macroexpand-1 '(with-crpr (absm1 absm2) crpr
(statement-1)
(statement-2))))
|#
;;;
;;; EILENBERG-ZILBER
;;;
(DEFMACRO EILENBERG-ZILBER (&rest rest)
`(ez ,@rest))
;;;
;;; KAN
;;;
(DEFMACRO KFLL (&rest rest)
(ecase (length rest)
(1 `(kfll1 ,@rest))
(4 `(kfll4 ,@rest))))
(DEFMACRO KFLL4 (kan indx dmns hat)
`(funcall (kfll1 ,kan) ,indx ,dmns ,hat))
;;;
;;; SIMPLICIAL-GROUP
;;;
(DEFMACRO GRML (smgr &rest rest)
(ecase (length rest)
(0 `(grml1 ,smgr))
((1 2) `(? (grml1 ,smgr) ,@rest))))
(DEFMACRO GRIN (smgr &rest rest)
(case (length rest)
(0 `(grin1 ,smgr))
(otherwise `(? (grin1 ,smgr) ,@rest))))
(DEFMACRO BUILD-AB-SMGR (&rest rest)
`(change-class (build-smgr ,@rest) 'ab-simplicial-group))
;;;
;;; LOOP SPACES
;;;
(DEFMACRO POWR (gmsm expn)
`(cons ,gmsm ,expn))
(DEFMACRO PGMSM (powr)
`(car ,powr))
(DEFMACRO EXPN (powr)
`(cdr ,powr))
(DEFMACRO WITH-POWR ((gmsm expn) powr . body)
`(let ((,gmsm (car ,powr))
(,expn (cdr ,powr)))
(declare
(type gmsm ,gmsm)
(fixnum expn))
,@body))
(DEFMACRO WITH-APOWR ((dgop gmsm expn) apowr . body)
`(let ((,dgop (apdgop ,apowr))
(,gmsm (cadr ,apowr))
(,expn (cddr ,apowr)))
(declare
(fixnum ,dgop ,expn)
(type gmsm ,gmsm))
,@body))
(DEFMACRO APOWR (dgop gmsm expn)
`(cons ,dgop (cons ,gmsm ,expn)))
(DEFMACRO APDGOP (apowr)
`(car ,apowr))
(DEFMACRO APGMSM (apowr)
`(cadr ,apowr))
(DEFMACRO APEXPN (apowr)
`(cddr ,apowr))
;;;
;;; SMITH
;;;
(DEFMACRO LINE-NUMBER (mtrx)
`(first (array-dimensions ,mtrx)))
(DEFMACRO COLUMN-NUMBER (mtrx)
`(second (array-dimensions ,mtrx)))
(DEFMACRO LINE-OP-5 (mtrx-list begin lambda line1 line2)
(let ((slambda (gensym)))
`(let ((,slambda ,lambda))
(column-op (first ,mtrx-list) 0 (- ,slambda) ,line2 ,line1)
(line-op (second ,mtrx-list) 0 ,slambda ,line1 ,line2)
(line-op (third ,mtrx-list) ,begin ,slambda ,line1 ,line2))))
(DEFMACRO COLUMN-OP-5 (mtrx-list begin lambda column1 column2)
(let ((slambda (gensym)))
`(let ((,slambda ,lambda))
(column-op (third ,mtrx-list) ,begin ,slambda ,column1 ,column2)
(column-op (fourth ,mtrx-list) 0 ,slambda ,column1 ,column2)
(line-op (fifth ,mtrx-list) 0 (- ,slambda) ,column2 ,column1))))
(DEFMACRO LINE-SWAP-5 (mtrx-list begin line1 line2)
`(progn
(column-swap (first ,mtrx-list) 0 ,line1 ,line2)
(line-swap (second ,mtrx-list) 0 ,line1 ,line2)
(line-swap (third ,mtrx-list) ,begin ,line1 ,line2)))
(DEFMACRO COLUMN-SWAP-5 (mtrx-list begin column1 column2)
`(progn
(column-swap (third ,mtrx-list) ,begin ,column1 ,column2)
(column-swap (fourth ,mtrx-list) 0 ,column1 ,column2)
(line-swap (fifth ,mtrx-list) 0 ,column1 ,column2)))
(DEFMACRO LINE-MINUS-5 (mtrx-list begin line)
`(progn
(column-minus (first ,mtrx-list) 0 ,line)
(line-minus (second ,mtrx-list) 0 ,line)
(line-minus (third ,mtrx-list) ,begin ,line)))
(DEFMACRO COLUMN-MINUS-5 (mtrx-list begin column)
`(progn
(column-minus (third ,mtrx-list) ,begin ,column)
(column-minus (fourth ,mtrx-list) 0 ,column)
(line-minus (fifth ,mtrx-list) 0 ,column)))
(DEFMACRO GNRT-NAME (i)
`(intern (format nil "GN-~D" ,i) +gnrts-pckg+))

42
Kenzo-1/searching-homology.cl Normal file
View File

@ -0,0 +1,42 @@
;;; SEARCHING-HOMOLOGY SEARCHING-HOMOLOGY SEARCHING-HOMOLOGY
;;; SEARCHING-HOMOLOGY SEARCHING-HOMOLOGY SEARCHING-HOMOLOGY
;;; SEARCHING-HOMOLOGY SEARCHING-HOMOLOGY SEARCHING-HOMOLOGY
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "searching-homology")
(DEFUN ECHCM (chcm)
(rbcc (efhm chcm)))
(DEFMETHOD HOMOLOGY ((chcm chain-complex) degr1 &optional (degr2 (1+ degr1)))
(declare (fixnum degr1 degr2))
(do ((degr degr1 (1+ degr)))
((>= degr degr2))
(declare (fixnum degr))
(chcm-homology (echcm chcm) degr)
(terpri) (clock) (terpri)))
(DEFGENERIC SEARCH-EFHM (chcm orgn))
(DEFMETHOD SEARCH-EFHM (chcm orgn)
(declare (ignore chcm orgn))
nil)
(DEFMETHOD SLOT-UNBOUND (class (chcm chain-complex) (slot-name (eql 'efhm)))
(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 ~
the effective homology of:~@
~A (Origin: ~A)." chcm (orgn chcm)))))))
#|
(cat-init)
(setf d (delta 3))
(homology d 0)
|#

286
Kenzo-1/serre.cl Normal file
View File

@ -0,0 +1,286 @@
;;; 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
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "serre")
(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)))
(declare
(type fibration fibration)
(type simplicial-set base total)
(type face bface fface)
(type simplicial-group fibre)
(type gmsm fbspn)
(type sintr sintr-grml sintr-twist)
(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)))))))))))
(the intr-mrph #'rslt)))
#|
(cat-init)
(setf s2 (sphere 2))
(setf k (k-z2-1))
(setf tw (build-smmr
:sorc s2
:trgt k
:degr -1
:sintr #'(lambda (dmns gmsm)
(absm 0 1))
:orgn '(s2-tw-kz2)))
(setf dt-d (fibration-dtau-d-intr tw))
(funcall dt-d 0 (crpr 0 '* 0 0))
(funcall dt-d 3 (crpr 4 's2 0 3))
(funcall dt-d 3 (crpr 2 's2 0 3))
(funcall dt-d 3 (crpr 2 's2 5 1))
(funcall dt-d 2 (crpr 0 's2 0 2))
(cat-init)
(setf s2 (sphere 2))
(setf k (k-z-1))
(setf tw (build-smmr
:sorc s2
:trgt k
:degr -1
:sintr #'(lambda (dmns gmsm)
(absm 0 (list 1)))
:orgn '(s2-tw-kz)))
(setf dt-d (fibration-dtau-d-intr tw))
(funcall dt-d 0 (crpr 0 '* 0 nil))
(funcall dt-d 3 (crpr 4 's2 0 '(2 3 4)))
(funcall dt-d 3 (crpr 2 's2 0 '(2 3 4)))
(funcall dt-d 3 (crpr 2 's2 5 '(5)))
(funcall dt-d 2 (crpr 0 's2 0 '(3 -2)))
|#
(DEFUN FIBRATION-DTAU-D (fibration
&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))))
#|
(cat-init)
(setf s2 (sphere 2))
(setf k (k-z-1))
(setf tw (build-smmr
:sorc s2
:trgt k
:degr -1
:sintr #'(lambda (dmns gmsm)
(absm 0 (list 1)))
:orgn '(s2-tw-kz)))
(setf dt-d (fibration-dtau-d tw))
(? dt-d 0 (crpr 0 '* 0 nil))
(? dt-d 3 (crpr 4 's2 0 '(2 3 4)))
(? dt-d 3 (crpr 2 's2 0 '(2 3 4)))
(? dt-d 3 (crpr 2 's2 5 '(5)))
(? dt-d 2 (crpr 0 's2 0 '(3 -2)))
|#
(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)))
(declare
(type fibration fibration)
(type simplicial-set base fibre total)
(type reduction ez)
(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)))))
#|
(cat-init)
(setf s2 (sphere 2))
(setf k (k-z2-1))
(setf tw (build-smmr
:sorc s2
:trgt k
:degr -1
:sintr #'(lambda (dmns gmsm)
(absm 0 1))
:orgn '(s2-tw-kz2)))
(setf brown (brown-reduction tw))
(setf tcc (tcc brown) bcc (bcc brown))
(homology bcc 3)
(homology tcc 1 8)
(homology bcc 1 8)
(cat-init)
(setf s2 (sphere 2))
(setf k (k-z-1))
(setf tw (build-smmr
:sorc s2
:trgt k
:degr -1
:sintr #'(lambda (dmns gmsm)
(absm 0 (list 1)))
:orgn '(s2-tw-kz1)))
(setf brown (brown-reduction tw))
(homology (tcc brown) 1 5)
(homology (bcc brown) 1 5)
|#
(DEFUN LEFT-SERRE-EFHM (fibration)
(declare (type fibration fibration))
(the homotopy-equivalence
(build-hmeq
:lrdct (trivial-rdct (fibration-total 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)))
(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))))
#|
(cat-init)
(setf s2 (sphere 2))
(setf k (k-z-1))
(setf tw (build-smmr
:sorc s2
:trgt k
:degr -1
:sintr #'(lambda (dmns gmsm)
(absm 0 (list 1)))
:orgn '(s2-tw-kz1)))
(setf rh (right-serre-efhm tw))
(setf rbcc (rbcc rh))
(homology rbcc 0 5)
|#
(DEFUN FIBRATION-TOTAL-EFHM (fibration)
(declare (type fibration fibration))
(the homotopy-equivalence
(cmps (left-serre-efhm fibration)
(right-serre-efhm fibration))))
(DEFMETHOD SEARCH-EFHM (smst (orgn (eql 'fibration-total)))
(declare
(type simplicial-set smst))
(the homotopy-equivalence
(fibration-total-efhm (second (orgn smst)))))
#|
(cat-init)
(setf s2 (sphere 2))
(setf k (k-z-1))
(setf tw (build-smmr
:sorc s2
:trgt k
:degr -1
:sintr #'(lambda (dmns gmsm)
(absm 0 (list 2)))
:orgn '(s2-tw-kz1)))
(setf p3r (fibration-total tw))
(homology p3r 1 )
|#

198
Kenzo-1/simplicial-groups.cl Normal file
View File

@ -0,0 +1,198 @@
;;; SIMPLICIAL-GROUPS SIMPLICIAL-GROUPS SIMPLICIAL-GROUPS
;;; SIMPLICIAL-GROUPS SIMPLICIAL-GROUPS SIMPLICIAL-GROUPS
;;; SIMPLICIAL-GROUPS SIMPLICIAL-GROUPS SIMPLICIAL-GROUPS
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "simplicial-groups")
(DEFVAR *SMGR-LIST*)
(SETF *SMGR-LIST* +empty-list+)
(PUSHNEW '*SMGR-LIST* *list-list*)
(DEFUN SMGR (idnm)
(declare (fixnum idnm))
(the (or null simplicial-group)
(find idnm *smgr-list* :key #'idnm)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) nil))
(DEFMETHOD PRINT-OBJECT ((smgr simplicial-group) stream)
(the simplicial-group
(progn
(format stream "[K~D Simplicial-Group]" (idnm smgr))
smgr)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) nil))
(DEFMETHOD PRINT-OBJECT ((smgr ab-simplicial-group) stream)
(the simplicial-group
(progn
(format stream "[K~D Abelian-Simplicial-Group]" (idnm smgr))
smgr)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t))
(DEFUN BUILD-SMGR
(&key cmpr basis bspn
face face* intr-bndr bndr-strt
intr-dgnl dgnl-strt
sintr-grml sintr-grin
orgn)
(declare
(type cmprf cmpr)
(type basis basis)
(type gmsm bspn)
(type face face)
(type (or null face*) face*)
(type (or intr-mrph null) intr-bndr intr-dgnl)
(type (or strt null) bndr-strt dgnl-strt)
(type sintr sintr-grml sintr-grin)
(list orgn))
(let ((already (find orgn *smgr-list* :test #'equal :key #'orgn)))
(declare (type (or simplicial-group null) already))
(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)))
(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)))
(push rslt *smgr-list*)
rslt))
(DEFUN A-GRML4 (sintr-grml dmns absm1 absm2)
(declare
(fixnum dmns)
(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))))))
(DEFUN A-GRIN4 (sintr-grin dmns absm)
(declare
(type sintr sintr-grin)
(fixnum dmns)
(type absm absm))
(the absm
(with-absm (dgop gmsm) absm
(absm dgop
(gmsm
(funcall sintr-grin (- dmns (logcount dgop)) gmsm))))))
(DEFMETHOD SLOT-UNBOUND (class (smgr simplicial-group)
(name (eql 'kfll)))
(declare (ignore class))
(the kfll
(progn
(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))))
(the kfll #'rslt)))
(DEFUN SMGR-KFLL (smgr)
(declare (type simplicial-group smgr))
(with-slots (face grml grin) smgr
(declare
(type face face)
(type simplicial-mrph grml grin))
(smgr-kfll-intr face (sintr grml) (sintr grin))))
#|
(cat-init)
(setf k (k-z-1))
(setf rslt '(1 10 100))
(setf hat (mapcar #'(lambda (i) (face k i 3 rslt)) (<a-b> 0 3)))
(dotimes (i 4)
(check-kan k i 3 (remove (nth i hat) hat :test #'equal)))
|#
(DEFMETHOD SLOT-UNBOUND (class (smgr simplicial-group)
(name (eql 'aprd)))
(declare (ignore class))
(the morphism
(progn
(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))))

162
Kenzo-1/simplicial-mrphs.cl Normal file
View File

@ -0,0 +1,162 @@
;;; SIMPLICIAL-MRPHS SIMPLICIAL-MRPHS SIMPLICIAL-MRPHS
;;; SIMPLICIAL-MRPHS SIMPLICIAL-MRPHS SIMPLICIAL-MRPHS
;;; SIMPLICIAL-MRPHS SIMPLICIAL-MRPHS SIMPLICIAL-MRPHS
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "simplicial-mrphs")
(DEFVAR *SMMR-LIST*)
(SETF *SMMR-LIST* +empty-list+)
(PUSHNEW '*SMMR-LIST* *LIST-LIST*)
(DEFMETHOD ?3 ((smmr simplicial-mrph) dmns absm-or-gmsm)
(declare
(fixnum dmns)
(type (or absm gmsm) absm-or-gmsm))
(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))))
(otherwise
(funcall (sintr smmr) dmns absm-or-gmsm))))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) nil))
(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)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t))
(DEFUN SMMR (idnm)
(declare (fixnum idnm))
(the (or null simplicial-mrph)
(find idnm *smmr-list* :key #'idnm)))
(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))))))
(the intr-mrph #'rslt)))
(DEFUN BUILD-SMMR (&key sorc trgt degr sintr intr strt orgn)
(declare
(type simplicial-set sorc trgt)
(fixnum degr)
(type sintr sintr)
(type (or intr-mrph null) intr)
(type (or strt null) strt)
(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))))
#|
(setf d (delta 3))
(setf m (build-smmr
:sorc d :trgt d :degr 0
:sintr #'(lambda (dmns gmsm)
(absm 0 gmsm))
:orgn '(identity delta-3)))
(setf m2 (build-smmr
:sorc d :trgt d :degr 0
:sintr #'(lambda (dmns gmsm)
(absm (mask dmns) 1))
:orgn '(null delta-3)))
(? m2 2 7)
;; (s? m2 2 7)
|#
#| ????
(DEFUN IA-SINTR3 (sintr dmns iabsm)
(declare
(type sintr sintr)
(fixnum dmns)
(type iabsm iabsm))
(the absm
(with-iabsm (dgop gmsm) iabsm
(ndgnr dgop (funcall sintr (- dmns (logcount dgop)) gmsm)))))
(DEFUN A-SINTR3 (sintr dmns absm)
(declare
(type sintr sintr)
(fixnum dmns)
(type absm absm))
(the absm
(with-absm (dgop gmsm) absm
(ndgnr dgop (funcall sintr (- dmns (logcount dgop)) gmsm)))))
|# ;;; ????
(DEFUN TW-A-SINTR3 (sintr dmns absm bspn)
(declare
(type sintr sintr)
(fixnum dmns)
(type absm absm)
(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)))))))
#|
(DEFUN TW-IA-SINTR3 (sintr dmns iabsm bspn)
(declare
(type sintr sintr)
(fixnum dmns)
(type iabsm iabsm)
(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)))))))
|#

659
Kenzo-1/simplicial-sets.cl Normal file
View File

@ -0,0 +1,659 @@
;;; SIMPLICIAL-SETS SIMPLICIAL-SETS SIMPLICIAL-SETS
;;; SIMPLICIAL-SETS SIMPLICIAL-SETS SIMPLICIAL-SETS
;;; SIMPLICIAL-SETS SIMPLICIAL-SETS SIMPLICIAL-SETS
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "simplicial-sets")
(DEFVAR *SMST-LIST*)
(SETF *SMST-LIST* +empty-list+)
(PUSHNEW '*SMST-LIST* *list-list*)
(DEFUN DGOP-EXT-INT (ext-dgop)
(declare (list ext-dgop))
;; (list fixnum)
(when ext-dgop
(unless (apply #'> ext-dgop)
(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))))
#|
(dgop-ext-int '())
(dgop-ext-int '(2 2))
(dgop-ext-int '(4 0))
|#
(DEFUN DGOP-INT-EXT (dgop)
(declare (fixnum dgop))
(unless (typep dgop 'dgop)
(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)
(declare
(fixnum dgop bmark)
(list rslt))
(when (oddp dgop)
(push bmark rslt)))))
#|
(dgop-int-ext 0)
(dgop-int-ext 4)
(dgop-int-ext 63)
(dotimes (i 33)
(print (dgop-ext-int (dgop-int-ext i)))))
|#
(DEFUN HYPHENIZE-LIST (list)
(declare (list list))
(if list
(format nil "~D~{-~D~}" (first list) (rest list))
(format nil "-")))
#|
(hyphenize-list '())
(hyphenize-list '(3))
(hyphenize-list '(5 3 1)))
|#
(DEFUN ABSM-PRINT (absm stream depth)
(declare
(type absm absm)
(type stream stream)
(ignore depth))
(format stream
"<AbSm ~A ~A>"
(hyphenize-list (dgop-int-ext (dgop absm)))
(gmsm absm))
absm)
(DEFUN FACE4 (smst indx dmns gmsm-or-absm)
(if (typep gmsm-or-absm 'absm)
(a-face4 (face1 smst) indx dmns gmsm-or-absm)
(funcall (face1 smst) indx dmns gmsm-or-absm)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) nil))
(DEFMETHOD PRINT-OBJECT ((smst simplicial-set) stream)
(the simplicial-set
(progn
(format stream "[K~D Simplicial-Set]" (idnm smst))
smst)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t))
(DEFUN SMST (n)
(declare (fixnum n))
(the (or simplicial-set null)
(find n *smst-list* :key #'idnm)))
(DEFUN BUILD-SMST
(&key cmpr basis bspn face face* intr-bndr bndr-strt
intr-dgnl dgnl-strt orgn)
(declare
(type cmprf cmpr)
(type basis basis)
(type gmsm bspn)
(type face face)
(type (or null face*) face*)
(type (or intr-mrph null) intr-bndr intr-dgnl)
(type (or strt null) bndr-strt dgnl-strt)
(list orgn))
(let ((already (find orgn *smst-list* :test #'equal :key #'orgn)))
(declare (type (or simplicial-set null) already))
(when already
(return-from build-smst already)))
(if intr-bndr
(unless bndr-strt
(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*)))
(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."))
(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)))
(change-chcm-to-clgb rslt
:intr-cprd intr-dgnl :cprd-strt dgnl-strt)
(setf (slot-value (dgnl rslt) 'orgn)
`(diagonal ,rslt))
(change-class rslt 'simplicial-set)
(setf (slot-value rslt 'face) face)
(push rslt *smst-list*)
rslt)))
(DEFUN A-BASIS2 (basis dmns)
(declare
(type basis basis)
(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)))))
#|
(setf m (moore 2 2))
(dotimes (i 4)
(print (basis m i :dgnr)))
|#
(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)))))
(the intr-mrph #'rslt)))
#|
()
(setf cmpr #'f-cmpr
face #'delta-face)
(setf diag (intr-diagonal face))
(funcall diag 4 (mask 5))
(funcall diag 0 4)
(setf cmpr #'s-cmpr
face (sphere-face 4))
(setf diag (intr-diagonal face))
(funcall diag 4 's4)
(funcall diag 0 '*)
(setf s4 (sphere 4))
(dgnl s4 4 's4)
|#
(DEFUN FACE-BNDR (cmpr face)
(declare
(type cmprf cmpr)
(type face face))
(flet ((rslt (dmns gmsm)
(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))))))
(the intr-mrph #'rslt)))
#|
(setf face #'(lambda (indx dmns gmsm)
(absm 0 (append
(subseq gmsm 0 indx)
(subseq gmsm (1+ indx))))))
(setf bndr (face-bndr #'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)
(absm (dgop-ext-int (nreverse (<a-b< 0 (1- dmns)))) 'a)))
(setf bndr (face-bndr #'s-cmpr face))
(funcall bndr 1 '(a b))
(funcall bndr 2 '(a b c)))
|#
(DEFUN FACE*-BNDR (cmpr face*)
(declare
(type cmprf cmpr)
(type face* face*))
(flet ((rslt (dmns gmsm)
(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))))))
(the intr-mrph #'rslt)))
#|
(setf face*
#'(lambda (indx dmns gmsm)
(if (and (= dmns 3) (evenp indx))
'm2
:degenerate)))
(setf bndr (face*-bndr #'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 (face*-bndr #'s-cmpr face*))
(funcall bndr 3 'm3)
(funcall bndr 2 'm2)
(funcall bndr 0 '*))
|#
(DEFUN A-CMPR3 (cmpr absm1 absm2)
(declare
(type cmprf cmpr)
(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))))))
#|
(a-cmpr3 #'s-cmpr (absm 0 'a) (absm 1 'b))
(a-cmpr3 #'s-cmpr (absm 2 'a) (absm 1 'b))
(a-cmpr3 #'s-cmpr (absm 1 'a) (absm 1 'b))
(a-cmpr3 #'s-cmpr (absm 1 'c) (absm 1 'b))
(a-cmpr3 #'s-cmpr (absm 1 'a) (absm 1 'a))
|#
(DEFUN BSPN-P (cmpr bspn dmns absm)
;; this function makes sense only in the simplicial context
;; so that the basg (= base-generator) is called bspn (= base-point)
(declare
(type gmsm bspn)
(fixnum dmns)
(type absm absm))
(the boolean
(with-absm (dgop gmsm) absm
(and (= dgop (mask dmns))
(eq :equal (funcall cmpr bspn gmsm))))))
#|
(setf d (delta-infinity))
(setf cmpr (cmpr d))
(bspn-p cmpr 1 5 (absm (mask 5) 1))
(bspn-p cmpr 1 5 (absm (mask 5) 2))
(bspn-p cmpr 1 5 (absm (mask 4) 3))
|#
(DEFUN DLOP-EXT-INT (ext-dlop)
(declare (list ext-dlop))
;; (list fixnum)
(when ext-dlop
(unless (apply #'< ext-dlop)
(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))))
#|
(dlop-ext-int '())
(dlop-ext-int '(2 2))
(dlop-ext-int '(0 4)))
|#
(DEFUN DLOP-INT-EXT (dlop)
(declare (fixnum dlop))
(the list
(nreverse (dgop-int-ext dlop))))
#|
(dlop-int-ext 0)
(dlop-int-ext 4)
(dlop-int-ext 63)
(dotimes (i 33)
(print (dlop-ext-int (dlop-int-ext i)))))
|#
(DEFUN 1DGOP*DGOP (1dgop dgop)
(declare (fixnum 1dgop dgop))
;; 1dgop is an ordinary integer
;; dgop is a bit string
(the fixnum
(let ((share (ash -1 1dgop)))
(declare (fixnum share))
(logxor
(ash (logand share dgop) 1)
(2-exp 1dgop)
(logandc1 share dgop)))))
#|
(dotimes (i 20)
(dotimes (j 5)
(format t "~% (~D) o ~A = ~A"
j (dgop-int-ext i) (dgop-int-ext (1dgop*dgop j i))))))
|#
(DEFUN DGOP*DGOP (dgop1 dgop2)
(declare (type fixnum dgop1 dgop2))
(let ((dgop 0)
(bmark 0))
(declare (fixnum dgop bmark))
(loop
(when (zerop dgop1)
(return-from dgop*dgop
(logxor dgop (ash dgop2 bmark))))
(when (zerop dgop2)
(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))))
(setf dgop1 (ash dgop1 -1))
(incf bmark))))
#|
(dotimes (i 10)
(dotimes (j 10)
(format t "~%~A o ~A = ~A"
(dgop-int-ext i) (dgop-int-ext j)
(dgop-int-ext (dgop*dgop i j))))))
|#
(DEFUN REMOVE-BIT (n indx)
(declare (fixnum n indx))
(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)))))
#|
(remove-bit 107 3) ;; 51
|#
(DEFUN DGOP/DGOP (dgop1 dgop2)
(declare (fixnum dgop1 dgop2))
(the fixnum
(do ((indx (1- (integer-length dgop2)) (1- indx)))
((minusp indx) dgop1)
(declare (fixnum indx))
(when (logbitp indx dgop2)
(setf dgop1 (remove-bit dgop1 indx))))))
#|
(dgop/dgop 67 0)
(dgop/dgop 68 4)
(dgop/dgop 31 5)
|#
(DEFUN 1DLOP-DGOP (1dlop dgop)
(declare (fixnum 1dlop dgop))
;; 1dlop is an ordinary fixnum
;; dgop is a bit string
(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))))
(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))
(let ((right (logandc1 share dgop)))
(declare (fixnum right))
(values
(logxor right (logand share (ash dgop -1)))
(- 1dlop (logcount right))))))))
#|
(dotimes (i 5)
(dotimes (j 17)
(multiple-value-bind (dgop 1dlop) (1dlop-dgop i j)
(format t "~% del-~D o ~A = ~A o del-~A"
i (dgop-int-ext j) (dgop-int-ext dgop) 1dlop)))))
|#
(DEFUN A-FACE4 (face indx dmns absm)
(declare
(type face face)
(fixnum indx dmns)
(type absm absm))
(the absm
(with-absm (dgop gmsm) absm
(multiple-value-bind (dgop2 1dlop) (1dlop-dgop indx dgop)
(declare (fixnum dgop2)
#-lispworks (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))))))))
#|
()
(require "special-smsts")
(let ((simp (dlop-ext-int '(0 1 2 3 4 5 6))))
(dotimes (i 5)
(dotimes (j 17)
(let ((face (a-face4 (face (delta-infinity))
i (+ 6 (logcount j)) (absm j simp))))
(format t "~%del-~D o ~A (0 1 2 3 4 5 6) = ~A ~A"
i (dgop-int-ext j)
(dgop-int-ext (dgop face))
(dlop-int-ext (gmsm face)))))))
|#
(DEFUN 1DGNR (indx absm)
(declare
(fixnum indx)
(type absm absm))
(the absm
(with-absm (dgop gmsm) absm
(absm (1dgop*dgop indx dgop) gmsm))))
#|
(1dgnr 2 (absm 17 'a))
|#
(DEFUN NDGNR (dgop absm)
(declare
(fixnum dgop)
(type absm absm))
(the absm
(with-absm (dgop2 gmsm) absm
(absm (dgop*dgop dgop dgop2) gmsm))))
#|
(ndgnr 2 (absm 17 'a))
|#
(DEFUN NFACE (face dlop dmns gmsm)
(declare
(type face face)
(type dlop dlop)
(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))))
((zerop dlop) (absm dgop gmsm))
(declare
(type gmsm gmsm)
(fixnum dgop dlop bark))
(multiple-value-bind (dgop2 indx) (1dlop-dgop bark dgop)
(declare
(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)))))
#|
(setf f (face (delta-infinity)))
(dotimes (dlop 31)
(print (dlop-int-ext (gmsm (nface f dlop 4 31)))))
(setf p (r-proj-space))
(setf f (face p))
(dotimes (dlop 31)
(format t "~%~A ~A"
(hyphenize-list (dlop-int-ext dlop))
(nface f dlop 4 4)))
|#
(DEFUN CHECK-FACES (cmpr face dmns gmsm)
(declare
(type cmprf cmpr)
(type face face)
(fixnum dmns)
(type gmsm gmsm))
(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 :~@
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)))))))
t)))
#|
(setf d (delta-infinity))
(check-faces #'f-cmpr (face d) 4 31)
|#
(DEFUN CHECK-SMST (smst dmns1 &optional (dmns2 (1+ dmns1)))
(declare
(type simplicial-set smst)
(fixnum dmns1 dmns2))
(with-slots (cmpr basis face) smst
(declare
(type cmprf cmpr)
(type face face))
(when (eq basis :locally-effective)
(error "In CHECK-SMST, the locally-effective simplicial-set ~A~@
cannot be checked." smst))
(do ((rslt t)
(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))))))
#|
(check-smst (delta-infinity) 5)
(check-smst (delta 3) 2)
(check-smst (delta 3) 2 4)
|#

1106
Kenzo-1/smith.cl Normal file
View File

File diff suppressed because it is too large Load Diff

688
Kenzo-1/special-smsts.cl Normal file
View File

@ -0,0 +1,688 @@
;;; 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
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "special-smsts")
;;; GMSM-FACES-INFO = (gmsm (simple-vector absm) . bndr)
;;; faces
(DEFUN FINITE-SS-PRE-TABLE (list)
(declare (list list))
(the list
(let ((pre-rslt +empty-list+)
(dmns-mark nil)
(gmsm-mark nil))
(declare (list pre-rslt dmns-mark gmsm-mark))
(dolist (item list)
(declare (type (or fixnum symbol list) item))
(cond ((typep item 'fixnum)
(let ((found (assoc item pre-rslt)))
(declare (list found))
(setf dmns-mark
(or found
(car (push (list item) pre-rslt)))
gmsm-mark nil)))
((symbolp item)
(when (assoc item (cdr dmns-mark))
(error "In BUILD-FINITE-SS, the symbol ~A is present two times."
item))
(setf gmsm-mark (car (push (list item) (cdr dmns-mark)))))
((listp item)
(unless gmsm-mark
(error "In BUILD-FINITE-SS, the face list ~A~@
is not after a symbol." item))
(nconc gmsm-mark item)
(setf gmsm-mark nil))
(t
(error "In BUILD-FINITE-SS, the argument ~A does not make sense." item))))
(do ((mark1 pre-rslt (cdr mark1)))
((endp mark1))
(declare (list mark1))
(do ((mark2 (rest mark1) (cdr mark2)))
((endp mark2))
(declare (list mark2))
(let ((inter (intersection (cdar mark1) (cdar mark2) :key #'first)))
(declare (list inter))
(when inter
(error "In BUILD-FINITE-SS, the symbol ~A is present two times."
(caar inter))))))
pre-rslt)))
#|
(setf p (finite-ss-pre-table '(0 v0 v1 v2)))
(finite-ss-pre-table '(0 v0 v0 v2))
(setf p (finite-ss-pre-table '(0 v0 v1 1 e0 e1 e2)))
(finite-ss-pre-table '(0 v0 v1 1 e0 e1 v1))
(setf p (finite-ss-pre-table '(0 v0 (v0 v0))))
(setf p (finite-ss-pre-table '(0 v0 v1 v2 0 v3)))
(finite-ss-pre-table '(0 v0 (v0 v0) (v1 v1)))
(finite-ss-pre-table '(0 (v0 v0) (v1 v1)))
(finite-ss-pre-table '(0 v0 (v0 v0) #(1 2))))
|#
(DEFUN FINITE-SS-PRE-TABLE-TABLE (pre-table)
(declare (list pre-table))
(let* ((maxdim (1+ (apply #'max (mapcar #'first pre-table))))
(table (make-array maxdim :initial-element +empty-list+)))
(declare
(fixnum maxdim)
(simple-vector table))
(dolist (item pre-table)
(declare (list item))
(setf (svref table (first item))
(sort (rest item) #'string< :key #'first)))
table))
#|
(setf p (finite-ss-pre-table-table
(finite-ss-pre-table '(2 v0 (e1 e2) v1 1 e0 e1 e2)))))
|#
(DEFUN FINITE-SS-FIND-GMSM (table gmsm dmns &optional (max-dmns (1+ dmns)))
(declare
(type gmsm gmsm)
(fixnum dmns max-dmns))
(do ((dmns dmns (1+ dmns)))
((>= dmns max-dmns) nil)
(declare (fixnum dmns))
(let ((found (find gmsm (svref table dmns) :test #'eq :key #'car)))
(declare (type (or cons null) found))
(when found
(return-from finite-ss-find-gmsm dmns)))))
(DEFUN FINITE-SS-FINISH-TABLE (table bspn)
(declare (simple-vector table))
(dotimes (dmns (length table))
(declare (fixnum dmns))
(finite-ss-finish-line table dmns bspn))
table)
(DEFUN FINITE-SS-FINISH-LINE (table dmns bspn)
(declare
(simple-vector table)
(fixnum dmns))
(setf (svref table dmns)
(mapcar
#'(lambda (entry)
(finite-ss-finish-entry table entry dmns bspn))
(svref table dmns))))
(DEFUN FINITE-SS-FINISH-ENTRY (table entry dmns bspn)
(declare
(simple-vector table)
(list entry)
(fixnum dmns)
(symbol bspn))
(let ((simplex (first entry))
(faces (rest entry)))
(declare
(symbol simplex)
(list faces))
(when (zerop dmns)
(return-from finite-ss-finish-entry
(make-gmsm-faces-info
:gmsm simplex :faces +s-empty-vector+
:bndr +zero-negative-cmbn+)))
(setf faces (nconc faces (make-list (1+ (- dmns (length faces)))
:initial-element bspn)))
(let ((rslt (make-gmsm-faces-info :gmsm simplex)))
(declare (cons rslt))
(flet ((process-face (face)
(declare (type (or symbol list) face))
(when (symbolp face)
(setf face (list face)))
(let* ((gmsm2 (car (last face)))
(dgop-ext (nbutlast face))
(dmns2 (finite-ss-find-gmsm table gmsm2 0 dmns)))
(declare
(symbol gmsm2)
(list dgop-ext)
(type (or fixnum null) dmns2))
(unless dmns2
(error "In BUILD-FINITE-SS, the face ~A is absent." gmsm2))
(when (zerop (length dgop-ext))
(setf dgop-ext (nreverse (<a-b< dmns2 (1- dmns)))))
(unless (= (+ (length dgop-ext) dmns2 1) dmns)
(error "In BUILD-FINITE-SS, the face ~A has a wrong dimension."
(append dgop-ext (list gmsm2))))
(absm (dgop-ext-int dgop-ext) gmsm2))))
(setf (info-faces rslt)
(map 'simple-vector #'process-face faces))
(setf (info-bndr rslt)
(apply #'nterm-add #'s-cmpr (1- dmns)
(do ((rslt +empty-list+)
(faces (info-faces rslt))
(indx dmns (1- indx)))
((minusp indx) rslt)
(declare
(list rslt)
(simple-vector faces)
(fixnum indx))
(let ((face (svref faces indx)))
(declare (type absm face))
(unless (degenerate-p face)
(push (term (-1-expt-n indx) (gmsm face))
rslt))))))
rslt))))
(DEFUN FINITE-SS-TABLE (list)
(declare (list list))
(setf list (cons 0 list))
(let* ((bspn (second list))
(pre-table (finite-ss-pre-table list))
(table (finite-ss-pre-table-table pre-table)))
(declare
(symbol bspn)
(list pre-table)
(simple-vector table))
;; (vector (vector gmsm-faces-info))
(finite-ss-finish-table table bspn)))
#|
(finite-ss-table '(*))
(finite-ss-table '(a b))
(finite-ss-table '(a b 1 c (b a)))
(finite-ss-table '(* 2 s2 3 s3))
(finite-ss-table '(s0 s1 s2 1 s01 (s1 s0) s02 (s2 s0) s12 (s2 s1) 2 s012 (s12 s02 s01)))
(finite-ss-table '(* 4 s4 ((2 1 0 *))))
(finite-ss-table '(* 4 s4 ((1 1 0 *))))
(finite-ss-table '(* 1 s (t)))
(finite-ss-table '(* 4 s4 ((1 0 *)))))
|#
(DEFUN FINITE-SS-BASIS (table)
(declare (simple-vector table))
(flet ((rslt (dmns)
(declare (fixnum dmns))
(the list
(if (< -1 dmns (length table))
(mapcar #'car (svref table dmns))
+empty-list+))))
#'rslt))
(DEFUN FINITE-SS-FACE (ind-smst table)
(declare
(symbol ind-smst)
(simple-vector table))
(flet ((rslt (indx dmns gmsm)
(declare
(fixnum indx dmns)
(symbol gmsm))
(let ((found (find gmsm (svref table dmns) :key #'car)))
(unless found
(error "In the finite simplicial set ~A,~@
the simplex ~A is absent in dimension ~D." (eval ind-smst) gmsm dmns))
(svref (info-faces found) indx))))
#'rslt))
(DEFUN FINITE-SS-INTR-BNDR (ind-smst table)
(declare
(symbol ind-smst)
(simple-vector table))
(flet ((rslt (dmns gmsm)
(declare
(fixnum dmns)
(symbol gmsm))
(let ((found (find gmsm (svref table dmns) :key #'car)))
(unless found
(error "In the finite simplicial set ~A,~@
the simplex ~A is absent in dimension ~D." (eval ind-smst) gmsm dmns))
(info-bndr found))))
#'rslt))
(DEFUN BUILD-FINITE-SS (list)
(declare (list list))
(let ((bspn (first list))
(table (finite-ss-table list))
(ind-smst (gensym)))
(declare
(symbol bspn ind-smst)
(simple-vector table))
;; (vector (vector gmsm-faces-info))
(let ((rslt (build-smst
:cmpr #'s-cmpr
:basis (finite-ss-basis table)
:bspn bspn
:face (finite-ss-face ind-smst table)
:intr-bndr (finite-ss-intr-bndr ind-smst table)
:bndr-strt :gnrt
:orgn `(build-finite-ss ,list))))
(setf (symbol-value ind-smst) rslt)
(unless (check-smst rslt 0 (length table))
(pop *smst-list*)
(pop *chcm-list*)
(pop *mrph-list*)
(return-from build-finite-ss nil))
rslt)))
#|
()
(cat-init)
(setf tr (build-finite-ss '(s0 s1 s2
1 s01 (s1 s0) s02 (s2 s0) s12 (s2 s1)
2 s012 (s12 s02 s01))))
(cmpr tr 's01 's02)
(basis tr 2)
(bspn tr)
(face tr 1 2 's012)
(? tr 2 's012)
(? tr *)
(inspect tr)
(mapcar #'(lambda (s) (length (eval s))) *list-list*)
(setf tr (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))) *list-list*))
|#
(DEFUN SPHERE-CMPR (gmsm1 gmsm2)
(declare (ignore gmsm1 gmsm2))
(the cmpr :equal))
(DEFUN SPHERE-BASIS (dmns)
(declare (fixnum dmns))
(let ((fund-gmsm (intern (format nil "S~D" dmns))))
(declare (symbol fund-gmsm))
(flet ((rslt (dmns2)
(declare (fixnum dmns2))
(cond ((zerop dmns2)
(list '*))
((= dmns2 dmns)
(list fund-gmsm))
(t
+empty-list+))))
(the basis #'rslt))))
(DEFUN SPHERE-FACE (dmns)
(declare (fixnum dmns))
(let ((face (absm (mask (1- dmns)) '*)))
(declare (type absm face))
(flet ((rslt (indx dmns2 gmsm)
(declare (ignore indx dmns2 gmsm))
(the absm face)))
#'rslt)))
(DEFUN SPHERE (dmns)
(declare (fixnum dmns))
(unless (plusp dmns)
(error "In SPHERE, the dimension ~D should be positive." dmns))
(unless (< dmns +maximal-dimension+)
(error "In SPHERE, the dimension ~D should be < ~D."
dmns +maximal-dimension+))
(the simplicial-set
(let ((rslt (build-smst
:cmpr #'sphere-cmpr
:basis (sphere-basis dmns)
:bspn '*
:face (sphere-face dmns)
:intr-bndr #'zero-intr-dffr
:bndr-strt :cmbn
:orgn `(sphere ,dmns))))
(declare (type simplicial-set rslt))
(setf (slot-value (bndr rslt) 'orgn)
`(zero-mrph ,rslt ,rslt -1))
rslt)))
#|
(cat-init)
(setf s3 (sphere 3))
(funcall (cmpr s3) 's3 's3)
(dotimes (i 5)
(print (funcall (basis s3) i)))
(mapcar #'(lambda (i) (funcall (face s3) i 3 's3)) (<a-b> 0 3))
(? s3 3 's3)
(smst (idnm s3))
(chcm (idnm s3))
(setf d (bndr s3))
(add d d))
|#
(DEFUN SPHERE-WEDGE-BASIS (dmns-list)
(declare (list dmns-list))
(flet ((rslt (dmns)
(declare (fixnum dmns))
(when (zerop dmns)
(return-from rslt '(*)))
(do ((i (count dmns dmns-list) (1- i))
(basis +empty-list+
(cons (intern (format nil "S~D-~D" dmns i))
basis)))
((zerop i) basis)
(declare
(fixnum i)
(list basis)))))
(the basis #'rslt)))
(DEFUN SPHERE-WEDGE-FACE (indx dmns gmsm)
(declare
(ignore indx gmsm)
(fixnum dmns))
(the absm
(absm (mask (1- dmns)) '*)))
(DEFUN SPHERE-WEDGE (&rest dmns-list)
(declare (list dmns-list))
(the simplicial-set
(let ((rslt (build-smst
:cmpr #'s-cmpr
:basis (sphere-wedge-basis dmns-list)
:face #'sphere-wedge-face
:intr-bndr #'zero-intr-dffr
:bndr-strt :cmbn
:orgn `(sphere-wedge ,@dmns-list))))
(declare (type simplicial-set rslt))
(setf (slot-value (bndr rslt) 'orgn)
`(zero-mrph ,rslt ,rslt -1))
rslt)))
#|
(cat-init)
(setf w (sphere-wedge 3 2 3))
(funcall (cmpr w) 's3-1 's3-2)
(dotimes (i 5) (print (funcall (basis w) i)))
(funcall (face w) 2 3 's3-1)
(gnrt-? (bndr w) 3 's3-2))
|#
(DEFUN MOORE-CMPR (gmsm1 gmsm2)
(declare (ignore gmsm1 gmsm2))
(the cmpr :equal))
(DEFUN MOORE-BASIS (dmns)
(declare (fixnum dmns))
(let ((lgmsm1 (list (intern (format nil "M~D" dmns))))
(lgmsm2 (list (intern (format nil "N~D" (1+ dmns))))))
(declare (list lgmsm1 lgmsm2))
(flet ((rslt (dmns2)
(declare (fixnum dmns2))
(cond ((zerop dmns2) '(*))
((= dmns dmns2) lgmsm1)
((= (1+ dmns) dmns2) lgmsm2)
(t +empty-list+))))
(the basis #'rslt))))
(DEFUN MOORE-FACE (pii dmns)
(declare (fixnum pii dmns))
(let ((face (absm 0 (intern (format nil "M~D" dmns))))
(bspn1 (absm (mask (1- dmns)) '*))
(bspn2 (absm (mask dmns) '*))
(2pii (ash pii 1)))
(declare
(type absm face)
(type absm bspn1 bspn2)
(fixnum 2pii))
(flet ((rslt (indx dmns2 gmsm)
(declare
(fixnum indx dmns2)
(ignore gmsm))
(the absm
(if (= dmns dmns2)
bspn1
(if (oddp indx)
bspn2
(if (< indx 2pii)
face
bspn2))))))
(the face #'rslt))))
(DEFUN MOORE-INTR-BNDR (pii dmns)
(declare (fixnum pii dmns))
(let ((1+dmns (1+ dmns))
(gmsm1 (intern (format nil "M~D" dmns))))
(declare
(fixnum 1+dmns)
(type symbol gmsm1))
(flet ((rslt (cmbn)
(declare
(type cmbn cmbn))
(with-cmbn (degr list) cmbn
(unless list
(return-from rslt (zero-cmbn (1- (cmbn-degr cmbn)))))
(if (= degr 1+dmns)
(term-cmbn dmns (* (cffc (first list)) pii) gmsm1)
(zero-cmbn (1- (cmbn-degr cmbn)))))))
(the intr-mrph #'rslt))))
(DEFUN MOORE (pii dmns)
(declare (fixnum pii dmns))
(the simplicial-set
(build-smst
:cmpr #'moore-cmpr
:basis (moore-basis dmns)
:face (moore-face pii dmns)
:intr-bndr (moore-intr-bndr pii dmns)
:bndr-strt :cmbn
:orgn `(moore ,pii ,dmns))))
#|
(cat-init)
(setf m4 (moore 2 4))
(cmpr m4 'n5 'n5)
(dotimes (i 7)
(print (basis m4 i)))
(mapcar #'(lambda (i) (face m4 i 5 'n5)) (<a-b> 0 5))
(? m4 4 'm4)
(? m4 5 'n5))
|#
(DEFUN R-PROJ-SPACE-CMPR (gmsm1 gmsm2)
(declare (ignore gmsm1 gmsm2))
(the cmpr :equal))
(DEFUN R-PROJ-SPACE-BASIS (k l)
(declare (fixnum k) (type (or (eql :infinity) fixnum) l))
(the basis
(progn
(when (eq l :infinity)
(setf l most-positive-fixnum))
(flet
((rslt (dmns)
(declare (fixnum dmns))
(the list
(if (or (minusp dmns)
(< 0 dmns k)
(>= dmns l))
+empty-list+
(list dmns)))))
(the basis #'rslt)))))
#|
()
(setf b (r-proj-space-basis 1 :infinity))
(dotimes (i 5) (print (funcall b i)))
(setf b (r-proj-space-basis 1 5))
(dotimes (i 8) (print (funcall b i)))
(setf b (r-proj-space-basis 3 :infinity))
(dotimes (i 5) (print (funcall b i)))
(setf b (r-proj-space-basis 3 6))
(dotimes (i 10) (print (funcall b i)))
|#
(DEFUN R-PROJ-SPACE-FACE (k)
(declare (fixnum k))
(flet ((rslt (indx dmns gmsm)
(declare
(fixnum indx dmns)
(ignore gmsm))
(if (<= dmns k)
(absm (mask (1- dmns)) 0)
(if (or (zerop indx)
(= indx dmns))
(absm 0 (1- dmns))
(if (= dmns (1+ k))
(absm (mask (1- dmns)) 0)
(absm (2-exp (1- indx)) (- dmns 2)))))))
(the face #'rslt)))
(DEFUN R-PROJ-SPACE-INTR-BNDR (k)
(declare (fixnum k))
(flet ((rslt (cmbn)
(declare (type cmbn cmbn))
(with-cmbn (degr list) cmbn
(unless list
(return-from rslt (zero-cmbn (1- degr))))
(if (<= degr k)
(zero-cmbn (1- degr))
(if (evenp degr)
(make-cmbn
:degr (1- degr)
:list (list (term (* 2 (-cffc list)) (1- degr))))
(zero-cmbn (1- degr)))))))
(the intr-mrph #'rslt)))
(DEFUN R-PROJ-SPACE (&optional (l :infinity) (k 1))
(declare (fixnum k) (type (or fixnum (eql :infinity))))
(assert
(and (typep k 'fixnum)
(plusp k)
(or (eq l :infinity)
(and (typep l 'fixnum)
(<= k l)))))
(the simplicial-set
(build-smst
:cmpr #'R-proj-space-cmpr
:basis (R-proj-space-basis k l)
:bspn 0
:face (R-proj-space-face k)
:intr-bndr (R-proj-space-intr-bndr k)
:bndr-strt :cmbn
:orgn `(R-proj-space ,k ,l))))
#|
()
(cat-init)
(setf p (R-proj-space))
(basis p 4)
(dotimes (i 5)
(print (face p i 4 4)))
(dotimes (i 5)
(print (? p i i)))
(setf dd (cmps p p))
(dotimes (i 6)
(print (? dd i i)))
(setf p (R-proj-space 3))
(dotimes (i 7)
(print (basis p i)))
(dotimes (i 5)
(print (face p i 4 4)))
(dotimes (i 7)
(print (? p i i)))
(setf dd (cmps p p))
(dotimes (i 7)
(print (? dd i i)))
|#
;;; Constructing a small simplicial subset
;;; from a combination of simplices.
(DEFUN CMBN-GMSMS (cmbn)
(declare (type cmbn cmbn))
(the list
;; Returns a list made of:
;; the degree of the combination;
;; the list of simplex generators of the combinations.
(cons (cmbn-degr cmbn) (mapcar #'cdr (cmbn-list cmbn)))))
#|
()
|#
(DEFUN GMSMS-SUBSMST (smst gmsms
&aux
(dmns (typecase gmsms
(cmbn (cmbn-degr gmsms))
(otherwise (first gmsms))))
(cmpr= #'(lambda (gmsm1 gmsm2)
(declare (type gmsm gmsm1 gmsm2))
(the boolean
(eq (cmpr smst gmsm1 gmsm2) :equal)))))
(declare
(type simplicial-set smst)
(type (or cmbn list) gmsms)
(fixnum dmns)
(type (function (gmsm gmsm) boolean) cmpr=))
(when (typep gmsms 'cmbn)
(setf gmsms (cmbn-gmsms gmsms)))
(the (values simplicial-set morphism)
(let ((prslt (make-array (1+ dmns) :initial-element +empty-list+)))
(declare (type simple-vector prslt))
(setf (svref prslt dmns) (rest gmsms))
(do ((d dmns (1- d)))
((zerop d))
(declare (fixnum d))
(dolist (gmsm (svref prslt d))
(declare (type gmsm gmsm))
(dotimes (iface (1+ d))
(declare (fixnum iface))
(with-absm (dgop gmsm) (face smst iface d gmsm)
(declare (fixnum dgop) (type gmsm gmsm))
(pushnew gmsm (svref prslt (- d 1 (logcount dgop)))
:test cmpr=)))))
(let ((rslt-basis #'(lambda (k)
(declare (fixnum dmns))
(the list
(if (<= 0 k dmns)
(aref prslt k)
+empty-list+)))))
(declare (type (function (fixnum) list) rslt-basis))
(let ((subsmst (build-smst
:cmpr (cmpr smst)
:basis rslt-basis
:bspn (let ((bspn (bspn smst)))
(declare (type gmsm bspn))
(pushnew bspn (svref prslt 0) :test cmpr=)
bspn)
:face (face smst)
:orgn `(gmsms-subsmst ,gmsms))))
(declare (type simplicial-set subsmst))
(values subsmst
(build-mrph :sorc subsmst
:trgt smst
:degr 0
:intr #'(lambda (cmbn)
(declare (type cmbn cmbn))
(the cmbn cmbn))
:strt :cmbn
:orgn `(gmsms-subsmst-incl ,gmsms))))))))
#|
()
(cat-init)
(setf k (k-z 2))
(setf efhm (efhm k))
(setf *homology-verbose* nil)
(chcm-homology-gen (rbcc efhm) 4)
(setf g (first *))
(setf cmbn (lf efhm (rg efhm g)))
(multiple-value-setq (kf incl) (gmsms-subsmst k cmbn))
(setf cone (cone incl))
(efhm cone)
(homology kf 0 5)
(homology (cone incl) 0 6)
(chcm-homology-gen (rbcc efhm) 8)
(setf g (first *))
(setf cmbn (lf efhm (rg efhm g)))
(multiple-value-setq (kf incl) (gmsms-subsmst k cmbn))
(setf cone (cone incl))
(efhm cone)
(homology kf 0 9)
(homology (cone incl) 0 10)
(dotimes (i 9) (print (length (basis kf i))))
()
(setf s2 (sphere 2))
(setf cl2 (chml-clss s2 2))
(setf f2 (z-whitehead s2 cl2))
(setf s3 (fibration-total f2))
(setf efhm (efhm s3))
(basis (rbcc efhm) 3)
(setf cmbn (lf efhm (rg efhm 3 (first (basis (rbcc efhm) 3)))))
(setf kf (gmsms-subsmst s3 cmbn))
(homology kf 0 4)
|#

321
Kenzo-1/suspensions.cl Normal file
View File

@ -0,0 +1,321 @@
;;; SUSPENSIONS SUSPENSIONS SUSPENSIONS SUSPENSIONS
;;; SUSPENSIONS SUSPENSIONS SUSPENSIONS SUSPENSIONS
;;; SUSPENSIONS SUSPENSIONS SUSPENSIONS SUSPENSIONS
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "suspensions")
(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))))
(the cmprf #'rslt)))
#|
(setf cc (deltab))
(setf cmpr (suspension-cmpr (cmpr cc)))
(funcall cmpr :s-bsgn :s-bsgn)
(funcall cmpr 6 5)
|#
(DEFUN SUSPENSION-BASIS (basis)
(declare (type basis basis))
(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))))))
(the basis #'rslt)))
#|
(setf cc (sphere 2))
(setf basis (suspension-basis (basis cc)))
(dotimes (i 6)
(print (funcall basis i)))
(suspension-basis :locally-effective)
|#
(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))))))))
(the intr-mrph #'rslt)))
#|
(setf cc (deltab))
(setf intr (suspension-intr-dffr (dffr cc)))
(funcall intr (cmbn 0 3 :s-bsgn))
(funcall intr (cmbn 3 66 7))
|#
(DEFUN SUSPENSION (obj &optional (n 1))
(declare (type (or chain-complex morphism reduction
homotopy-equivalence) obj)
(fixnum n))
(if (= n 0)
obj
(suspension-1 (suspension obj (1- n)))))
(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)))))
#|
(cat-init)
(setf cc (deltab))
(setf scc (suspension cc))
(cmpr scc 7 11)
(basis scc 3) ;; error
(bsgn scc)
(? scc 3 11)
(setf scc (suspension cc 2))
(? scc 4 11)
|#
(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))))))))
#|
(suspension-intr-cprd (cmbn 0))
(suspension-intr-cprd (cmbn 0 5 :s-bsgn))
(suspension-intr-cprd (cmbn 3 4 7 5 11))
|#
(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)))
#|
(cat-init)
(setf coal (deltab))
(setf scoal (suspension coal))
(setf scoal (suspension coal))
(? scoal 3 7)
(cprd scoal 3 7)
|#
(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)))))
(the face #'rslt)))
#|
(setf ss (deltab))
(setf face (suspension-face (face ss)))
(funcall face 4 4 15)
(funcall face 0 4 15)
(check-faces #'f-cmpr face 4 15)
(check-faces #'f-cmpr face 3 7)
(check-faces #'f-cmpr face 2 3)
(setf m (moore 2 3))
(setf face (suspension-face (face m)))
(dotimes (i 5) (print (funcall face i 4 'm3)))
(dotimes (i 6) (print (funcall face i 5 'mm4)))
(check-faces #'s-cmpr face 4 'm3)
(check-faces #'s-cmpr face 5 'mm4)
|#
(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)))
#|
(cat-init)
(setf d (deltab))
(setf sd (suspension d))
(setf sd (suspension d))
(inspect sd)
(? sd 3 7)
(cprd sd 3 7)
(face sd 3 3 7)
(face sd 2 3 7)
(setf m (moore 2 1))
(setf sm (suspension m))
(homology sm 0 5)
(setf ssm (suspension sm))
(homology ssm 0 6)
|#
(DEFUN SUSPENSION-INTR (mrph)
(declare (type morphism mrph))
(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)))))))
(the intr-mrph #'rslt))))
#|
(setf f (idnt-mrph (deltab)))
(setf sf (suspension-intr f))
(funcall sf (cmbn 0 3 :s-bsgn))
(funcall sf (cmbn 2 4 3))
(setf d (dffr (deltab)))
(setf sd (suspension-intr d))
(funcall sd (cmbn 0 3 :s-bsgn))
(funcall sd (cmbn 2 4 3))
(funcall sd (cmbn 3 4 7))
|#
(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)))))
#|
(setf f (idnt-mrph (deltab)))
(setf sf (suspension f))
(? sf (cmbn 0 3 :s-bsgn))
(? sf (cmbn 2 4 3))
(setf d (dffr (deltab)))
(setf sd (suspension d))
(? sd (cmbn 0 3 :s-bsgn))
(? sd (cmbn 2 4 3))
(? sd (cmbn 3 4 7))
|#
(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)))))
#|
(setf rdct (ez (deltab) (deltab)))
(setf srdct (suspension rdct))
(pre-check-rdct srdct)
(setf *tc* (cmbn 4 1 (crpr 0 15 0 15)))
(setf *bc* (cmbn 4 1 (tnpr 0 1 3 15)
5 (tnpr 1 3 2 7)
10 (tnpr 2 7 1 3)
100 (tnpr 3 15 0 1)))
(check-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)))))
(DEFMETHOD SEARCH-EFHM (suspension (orgn (eql 'suspension)))
(declare (type chain-complex suspension))
(suspension (efhm (second (orgn suspension)))))
#|
(setf sk (suspension (k-z 2)))
(homology sk 0 10)
|#

369
Kenzo-1/tensor-products.cl Normal file
View File

@ -0,0 +1,369 @@
;;; 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
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "tensor-products")
(DEFVAR *TNPR-WITH-DEGREES* nil)
(DEFUN TNPR-PRINT (tnpr stream depth)
(declare
(type tnpr tnpr) (stream stream)
(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)))
#|
(tnpr 2 'a 3 'b)
(setf *tnpr-with-degrees* t)
(tnpr 2 'a 3 'b)
(setf *tnpr-with-degrees* nil)
|#
(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))))))
#|
(setf *tnpr-with-degrees* t)
(2cmbn-tnpr (cmbn 2 3 'a 4 'b -5 'c) (cmbn 3 4 'x -3 'y 2 'z)))
|#
#|
(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))))))
(the cmprf #'rslt)))
|#
(DEFUN TNSR-PRDC-CMPR (cmpr1 cmpr2)
(declare (type cmprf cmpr1 cmpr2))
(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))))))
(the cmprf #'rslt)))
#|
(setf cmpr (tnsr-prdc-cmpr #'s-cmpr #'s-cmpr))
(funcall cmpr (tnpr 2 'a 3 'b) (tnpr 3 'a 2 'b))
(funcall cmpr (tnpr 3 'a 2 'b) (tnpr 2 'a 3 'b))
(funcall cmpr (tnpr 2 'a 3 'b) (tnpr 2 'b 3 'b))
(funcall cmpr (tnpr 2 'b 3 'b) (tnpr 2 'a 3 'b))
(funcall cmpr (tnpr 2 'a 3 'a) (tnpr 2 'a 3 'b))
(funcall cmpr (tnpr 2 'a 3 'c) (tnpr 2 'a 3 'b))
(funcall cmpr (tnpr 2 'a 3 'b) (tnpr 2 'a 3 'b)))
|#
(DEFUN TNSR-PRDC-BASIS (basis1 basis2)
(declare (type basis basis1 basis2))
(when (or (eq basis1 :locally-effective)
(eq basis2 :locally-effective))
(return-from tnsr-prdc-basis :locally-effective))
(flet ((rslt (degr)
(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))))))
(the basis #'rslt)))
#|
(defun bas (degr)
(case degr
(0 '(a b c))
(1 '(d))
(2 nil)
(3 '(x y))))
(setf bas (tnsr-prdc-basis #'bas #'bas))
(dotimes (i 8)
(print (funcall bas i))))
|#
(DEFUN TNSR-PRDC-INTR-DFFR (dffr1 dffr2)
(declare (type morphism dffr1 dffr2))
(flet ((rslt (degr tnpr)
(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 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)))
#|
(cat-init)
(setf chcm (build-chcm :cmpr #'s-cmpr :strt :gnrt :orgn '(test-1)))
(setf dffr (build-mrph :sorc chcm :trgt chcm :degr -1
:intr #'(lambda (degr gnrt)
(ecase gnrt
(a (cmbn (1- degr) 2 'd1a -3 'd2a))
(b (cmbn (1- degr) 3 'd1b -4 'd2b))))
:strt :gnrt :orgn '(test-2)))
(setf rslt (tnsr-prdc-intr-dffr dffr dffr))
(funcall rslt 4 (tnpr 2 'a 2 'b))
(funcall rslt 5 (tnpr 3 'a 2 'b))
(funcall rslt 5 (tnpr 2 'a 3 'b))
(funcall rslt 6 (tnpr 3 'a 3 'b)))
|#
(DEFMETHOD TNSR-PRDC ((chcm1 chain-complex) (chcm2 chain-complex))
(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 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)))))
#|
(setf dd (tnsr-prdc (delta 2) (delta 3)))
(cmpr dd (tnpr 2 7 2 11) (tnpr 2 7 2 14))
(basis dd 3)
(? dd 4 (tnpr 2 7 2 14))
(? dd 3 (tnpr 1 6 2 14))
(? dd (? dd 4 (tnpr 2 7 2 14)))
(? dd (? dd 3 (tnpr 1 6 2 14))))
|#
(DEFUN TNSR-PRDC-INTR (mrph1 mrph2)
(declare
(type morphism mrph1 mrph2))
(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))))
(the intr-mrph #'rslt))))
#|
(cat-init)
(setf chcm (build-chcm :cmpr #'s-cmpr :strt :gnrt :orgn '(test-1)))
(setf mrph (build-mrph :sorc chcm :trgt chcm :degr 0
:intr #'(lambda (degr gnrt)
(ecase gnrt
(a (cmbn degr 2 'd1a -3 'd2a))
(b (cmbn degr 3 'd1b -4 'd2b))))
:strt :gnrt :orgn '(test-2)))
(setf rslt (tnsr-prdc-intr mrph mrph))
(funcall rslt 6 (tnpr 2 'a 4 'b))
(funcall rslt 5 (tnpr 3 'a 2 'b))
(setf mrph (build-mrph :sorc chcm :trgt chcm :degr 1
:intr #'(lambda (degr gnrt)
(ecase gnrt
(a (cmbn (1+ degr) 2 'd1a -3 'd2a))
(b (cmbn (1+ degr) 3 'd1b -4 'd2b))))
:strt :gnrt :orgn '(test-3)))
(setf rslt (tnsr-prdc-intr mrph mrph))
(funcall rslt 6 (tnpr 2 'a 4 'b))
(funcall rslt 5 (tnpr 3 'a 2 'b)))
|#
(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))))))))
#|
(cat-init)
(setf d (dffr (delta-infinity)))
(setf dd (tnsr-prdc d d))
(eq (sorc dd) (tnsr-prdc (delta-infinity) (delta-infinity)))
(? dd 5 (tnpr 2 7 3 15))
(? dd 5 (tnpr 3 15 2 7))
(? dd (? dd 5 (tnpr 2 7 3 15)))
(? dd (? dd 5 (tnpr 3 15 2 7)))
(setf ddd (cmps dd dd))
(? ddd 5 (tnpr 2 7 3 15))
(? ddd 5 (tnpr 3 15 2 7))
|#
(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)))))))
#|
(cat-init)
(setf r (ez (delta-infinity) (delta-infinity)))
(setf r2 (tnsr-prdc r r))
(setf *bc* (cmbn 4 1 (tnpr 2 (tnpr 1 3 1 3) 2 (tnpr 1 3 1 3)))
*tc* (cmbn 2 1 (tnpr 1 (crpr 0 3 0 3) 1 (crpr 0 3 0 3))))
(pre-check-rdct r2)
(check-rdct)
|#
(DEFMETHOD TNSR-PRDC ((hmeq1 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))))
(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))))))
#|
(cat-init)
(setf k (k-z 2))
(setf k2 (tnsr-prdc k k))
(homology k2 0 10)
|#

144
Kenzo-1/various.cl Normal file
View File

@ -0,0 +1,144 @@
;;; VARIOUS VARIOUS VARIOUS VARIOUS VARIOUS VARIOUS
;;; VARIOUS VARIOUS VARIOUS VARIOUS VARIOUS VARIOUS
;;; VARIOUS VARIOUS VARIOUS VARIOUS VARIOUS VARIOUS
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "various")
(DEFCONSTANT +EMPTY-LIST+ '())
(DEFCONSTANT +F-EMPTY-VECTOR+
(make-array 0 :element-type 'fixnum))
(DEFCONSTANT +S-EMPTY-VECTOR+
#())
(DEFCONSTANT +TRUE+ t)
(DEFCONSTANT +FALSE+ nil)
(DEFCONSTANT +2-EXP+
(let ((rslt (make-array (integer-length most-positive-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))))))
(DEFCONSTANT +MASK+
(let ((rslt (make-array (integer-length most-positive-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)))))))
(DEFUN BINOMIAL-N-P (n p)
(declare (fixnum n p))
(when (> (2-exp p) n)
(setf p (- n p)))
(the fixnum
(do ((nn n (1- nn))
(pp 1 (1+ pp))
(rslt 1 (/ (* rslt nn) pp)))
((> pp p) rslt)
(declare (fixnum nn pp rslt)))))
#|
(dotimes (i 6)
(print (binomial-n-p 5 i)))
(dotimes (i 6)
(print (binomial-p-q (- 5 i) i))))
|#
(SETF *PRINT-LEVEL* 5
*PRINT-LENGTH* 10)
(DEFUN <A-B< (a b)
(declare (fixnum a b))
(the list
(do ((i (1- b) (1- i))
(rslt +empty-list+ (cons i rslt)))
((< i a) rslt)
(declare (fixnum i) (list rslt)))))
(DEFUN <A-B> (a b)
(declare (fixnum a b))
(the list
(do ((i b (1- i))
(rslt +empty-list+ (cons i rslt)))
((< i a) rslt)
(declare (fixnum i) (list rslt)))))
(DEFUN >A-B< (a b)
(declare (fixnum a b))
(the list
(do ((i (1- b) (1- i))
(rslt +empty-list+ (cons i rslt)))
((= i a) rslt)
(declare (fixnum i) (list rslt)))))
(DEFUN >A-B> (a b)
(declare (fixnum a b))
(the list
(do ((i b (1- i))
(rslt +empty-list+ (cons i rslt)))
((= i a) rslt)
(declare (fixnum i) (list rslt)))))
#|
(<a-b< 0 5)
(<a-b> 0 5)
(>a-b< 0 5)
(>a-b> 0 5))
|#
(DEFUN V<A-B> (a b)
(declare (fixnum a b))
(the (vector fixnum)
(let ((rslt (make-array (1+ (- b a)) :element-type 'fixnum)))
(declare (type (vector fixnum) rslt))
(do ((i a (1+ i))
(mark 0 (1+ mark)))
((> i b))
(declare (fixnum i mark))
(setf (aref rslt mark) i))
rslt)))
#|
(v<a-b> -5 5))
|#
(DEFUN SRANDOM (max)
(declare (fixnum max))
(the fixnum
(let ((rslt (- (random (+ max max)) max)))
(declare (fixnum rslt))
(if (zerop rslt)
max
rslt))))
#|
(dotimes (i 20) (print (srandom 3))))
|#
(DEFUN CLOCK ()
(multiple-value-bind (sec min hour day month year)
(get-decoded-time)
(format t "~%;; Clock -> ~4D-~2,'0D-~2,'0D, ~Dh ~Dm ~Ds.~%"
year month day hour min sec))
(values))
#|
(clock))
|#
(DEFUN DONE ()
(format t "~%---done---")
(values))
#|
(done))
|#

338
Kenzo-1/whitehead.cl Normal file
View File

@ -0,0 +1,338 @@
;;; WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD
;;; WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD
;;; WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD WHITEHEAD
(IN-PACKAGE "COMMON-LISP-USER")
(provide "whitehead")
;;;
;;; Z
;;;
(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)))
(declare
(type simplicial-set smst)
(fixnum n)
(type morphism chml-clss)
(type face face)
(type ab-simplicial-group k-z-n)
(type gmsm idnt)
(type homotopy-equivalence efhm))
(setf chml-clss
(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)))))
(the sintr #'rslt)))
#|
(cat-init)
(setf k (k-z 2))
(setf ecc (echcm k))
(setf chml-clss
(build-mrph
:sorc ecc :trgt (z-chcm) :degr 2
:intr #'(lambda (degr gnrt)
(if (= degr 2)
(term-cmbn 0 1 :z-gnrt)
(zero-cmbn (- degr 2))))
:strt :gnrt :orgn '(fundamental-class k-z-2)))
(setf tw (z-wwhitehead-sintr k 2 chml-clss))
(a-sintr3 tw 1 (absm 1 +null-gbar+)) ;;; cf old-macro cancelled
(a-sintr3 tw 2 (absm 3 +null-gbar+)) ;;; in macros.cl
(funcall tw 2 (gbar 2 0 '(55) 0 '()))
(funcall tw 3 (gbar 3 0 '(12 23)
0 '(34)
0 '()))
(funcall tw 4 (gbar 4 0 '(12 23 34)
2 '(45)
0 '(56)
0 '()))
(setf k (k-z 3))
(setf ecc (echcm k))
(setf chml-clss
(build-mrph
:sorc ecc :trgt (z-chcm) :degr 3
:intr #'(lambda (degr gnrt)
(if (= degr 3)
(term-cmbn 0 -1 :z-gnrt)
(zero-cmbn (- degr 3))))
:strt :gnrt :orgn '(fundamental-class k-z-3)))
(setf tw (z-wwhitehead-sintr k 3 chml-clss))
(a-sintr3 tw 1 (absm 1 +null-gbar+))
(a-sintr3 tw 2 (absm 3 +null-gbar+))
(a-sintr3 tw 3 (absm 7 +null-gbar+))
(funcall tw 3 (z-fundamental-gmsm 3 55))
(equal (funcall tw 3 (z-fundamental-gmsm 3 55))
(absm 0 (z-fundamental-gmsm 3 55)))
(funcall tw 4 (gbar 4 0 (gbar 3 0 '(12 23) 0 '(34) 0 '())
0 (gbar 2 0 '(45) 0 '())
1 (gbar 0)
0 (gbar 0)))
|#
(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)))
(declare
(type simplicial-set smst)
(fixnum n)
(type morphism chml-clss)
(type face face)
(type ab-simplicial-group k-z-n-1)
(type gmsm idnt)
(type homotopy-equivalence efhm))
(setf chml-clss
(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)))))
(the sintr #'rslt)))
#|
(cat-init)
(setf k (k-z 2))
(setf ecc (echcm k))
(setf chml-clss
(build-mrph
:sorc ecc :trgt (z-chcm) :degr 2
:intr #'(lambda (degr gnrt)
(if (= degr 2)
(term-cmbn 0 1 :z-gnrt)
(zero-cmbn (- degr 2))))
:strt :gnrt :orgn '(fundamental-class k-z-2)))
(setf tw (z-whitehead-sintr k 2 chml-clss))
(tw-a-sintr3 tw 1 (absm 1 +null-gbar+) '())
(tw-a-sintr3 tw 2 (absm 3 +null-gbar+) '())
(funcall tw 2 (gbar 2 0 '(55) 0 '()))
(funcall tw 3 (gbar 3 0 '(12 23)
0 '(34)
0 '()))
(funcall tw 4 (gbar 4 0 '(12 23 34)
2 '(45)
0 '(56)
0 '()))
(setf k (k-z 3))
(setf ecc (echcm k))
(setf chml-clss
(build-mrph
:sorc ecc :trgt (z-chcm) :degr 3
:intr #'(lambda (degr gnrt)
(if (= degr 3)
(term-cmbn 0 -1 :z-gnrt)
(zero-cmbn (- degr 3))))
:strt :gnrt :orgn '(fundamental-class k-z-3)))
(setf tw (z-whitehead-sintr k 3 chml-clss))
(tw-a-sintr3 tw 1 (absm 1 +null-gbar+) +null-gbar+)
(tw-a-sintr3 tw 2 (absm 3 +null-gbar+) +null-gbar+)
(tw-a-sintr3 tw 3 (absm 7 +null-gbar+) +null-gbar+)
(funcall tw 3 (z-fundamental-gmsm 3 55))
(equal (funcall tw 3 (z-fundamental-gmsm 3 55))
(absm 0 (z-fundamental-gmsm 2 55)))
(funcall tw 4 (gbar 4 0 (gbar 3 0 '(12 23) 0 '(34) 0 '())
0 (gbar 2 0 '(45) 0 '())
1 (gbar 0)
0 (gbar 0)))
|#
(DEFUN Z-WHITEHEAD (smst chml-clss &aux (n (- (degr chml-clss))))
(declare
(type simplicial-set smst)
(fixnum n)
(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))))
;;;
;;; 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)))
(declare
(type simplicial-set smst)
(fixnum n)
(type morphism chml-clss)
(type face face)
(type ab-simplicial-group k-z2-n)
(type gmsm idnt)
(type homotopy-equivalence efhm))
(setf chml-clss
(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)))))
(the sintr #'rslt)))
#|
(cat-init)
(setf k (k-z2 2))
(setf ecc (echcm k))
(setf chml-clss
(build-mrph
:sorc ecc :trgt (z-chcm) :degr 2
:intr #'(lambda (degr gnrt)
(if (= degr 2)
(term-cmbn 0 1 :z-gnrt)
(zero-cmbn (- degr 2))))
:strt :gnrt :orgn '(fundamental-class k-z-2)))
(setf tw (Z2-wwhitehead-sintr k 2 chml-clss))
(a-sintr3 tw 1 (absm 1 +null-gbar+))
(a-sintr3 tw 2 (absm 3 +null-gbar+))
(funcall tw 2 (gbar 2 0 1 0 0))
(funcall tw 3 (gbar 3 0 2
0 1
0 0))
(funcall tw 4 (gbar 4 0 3
2 1
0 1
0 0))
(setf k (k-z2 3))
(setf ecc (echcm k))
(setf chml-clss
(build-mrph
:sorc ecc :trgt (z-chcm) :degr 3
:intr #'(lambda (degr gnrt)
(if (= degr 3)
(term-cmbn 0 -1 :z-gnrt)
(zero-cmbn (- degr 3))))
:strt :gnrt :orgn '(fundamental-class k-z-3)))
(setf tw (Z2-wwhitehead-sintr k 3 chml-clss))
(a-sintr3 tw 1 (absm 1 +null-gbar+))
(a-sintr3 tw 2 (absm 3 +null-gbar+))
(a-sintr3 tw 3 (absm 7 +null-gbar+))
(funcall tw 3 (Z2-fundamental-gmsm 3 1))
(equal (funcall tw 3 (Z2-fundamental-gmsm 3 1))
(absm 0 (Z2-fundamental-gmsm 3 1)))
(funcall tw 4 (gbar 4 0 (gbar 3 0 2 0 1 0 0)
0 (gbar 2 0 1 0 0)
1 (gbar 0)
0 (gbar 0)))
|#
(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)))
(declare
(type simplicial-set smst)
(fixnum n)
(type morphism chml-clss)
(type face face)
(type ab-simplicial-group k-z2-n-1)
(type gmsm idnt)
(type homotopy-equivalence efhm))
(setf chml-clss
(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)))))
(the sintr #'rslt)))
#|
(cat-init)
(setf k (k-z2 2))
(setf ecc (echcm k))
(setf chml-clss
(build-mrph
:sorc ecc :trgt (z-chcm) :degr 2
:intr #'(lambda (degr gnrt)
(if (= degr 2)
(term-cmbn 0 1 :z-gnrt)
(zero-cmbn (- degr 2))))
:strt :gnrt :orgn '(fundamental-class k-z-2)))
(setf tw (Z2-whitehead-sintr k 2 chml-clss))
(tw-a-sintr3 tw 1 (absm 1 +null-gbar+) 0)
(tw-a-sintr3 tw 2 (absm 3 +null-gbar+) 0)
(funcall tw 2 (gbar 2 0 1 0 '()))
(funcall tw 3 (gbar 3 0 2
0 1
0 0))
(funcall tw 4 (gbar 4 0 3
2 1
0 1
0 0))
(setf k (k-z2 3))
(setf ecc (echcm k))
(setf chml-clss
(build-mrph
:sorc ecc :trgt (z-chcm) :degr 3
:intr #'(lambda (degr gnrt)
(if (= degr 3)
(term-cmbn 0 -1 :z-gnrt)
(zero-cmbn (- degr 3))))
:strt :gnrt :orgn '(fundamental-class k-z-3)))
(setf tw (Z2-whitehead-sintr k 3 chml-clss))
(tw-a-sintr3 tw 1 (absm 1 +null-gbar+) 0)
(tw-a-sintr3 tw 2 (absm 3 +null-gbar+) 0)
(tw-a-sintr3 tw 3 (absm 7 +null-gbar+) 0)
(funcall tw 3 (Z2-fundamental-gmsm 3 1))
(equal (funcall tw 3 (Z2-fundamental-gmsm 3 1))
(absm 0 (Z2-fundamental-gmsm 2 1)))
(funcall tw 4 (gbar 4 0 (gbar 3 0 2 0 1 0 0)
0 (gbar 2 0 1 0 0)
1 (gbar 0)
0 (gbar 0)))
|#
(DEFUN Z2-WHITEHEAD (smst chml-clss &aux (n (- (degr chml-clss))))
(declare
(type simplicial-set smst)
(fixnum n)
(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))))
#|
(setf m (moore 2 4))
(setf chml-clss
(build-mrph
:sorc m :trgt (z-chcm) :degr -4
:intr #'(lambda (dmns gmsm)
(if (= 4 dmns)
(cmbn 0 1 :z-gnrt)
(zero-cmbn (- dmns 4))))
:strt :gnrt
:orgn '(chml-clss moore 2 4)))
(setf mf (z2-whitehead m 4 chml-clss))
(setf mt (fibration-total mf))
(homology mt 0 10)
|#