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

Moved ABSM-EXT-INT, ABSM-INT_EXT, and VERTEX-I to special-smsts.lisp.

Browse Source
This commit is contained in:
Gerd Heber 2016-03-08 19:23:58 -05:00
parent 5c23300e73
commit 54893a7b0b
3 changed files with 348 additions and 345 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
package.lisp
View File

@ -533,6 +533,8 @@
;; special-smsts.lisp ;; special-smsts.lisp
#:ABSM-EXT-INT
#:ABSM-INT-EXT
#:BUILD-FINITE-SS #:BUILD-FINITE-SS
#:BUILD-SMST #:BUILD-SMST
#:FINITE-SS-PRE-TABLE #:FINITE-SS-PRE-TABLE
@ -545,6 +547,7 @@
#:SPHERE #:SPHERE
#:SPHERE-FACE #:SPHERE-FACE
#:SPHERE-WEDGE #:SPHERE-WEDGE
#:VERTEX-I
;; suspensions.lisp ;; suspensions.lisp

550
src/special-smsts.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
;;; SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS ;;; SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS
;;; SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS ;;; SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS
;;; SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS ;;; SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS
@ -13,42 +14,42 @@
(declare (list list)) (declare (list list))
(the list (the list
(let ((pre-rslt +empty-list+) (let ((pre-rslt +empty-list+)
(dmns-mark nil) (dmns-mark nil)
(gmsm-mark nil)) (gmsm-mark nil))
(declare (list pre-rslt dmns-mark gmsm-mark)) (declare (list pre-rslt dmns-mark gmsm-mark))
(dolist (item list) (dolist (item list)
(declare (type (or fixnum symbol list) item)) (declare (type (or fixnum symbol list) item))
(cond ((typep item 'fixnum) (cond ((typep item 'fixnum)
(let ((found (assoc item pre-rslt))) (let ((found (assoc item pre-rslt)))
(declare (list found)) (declare (list found))
(setf dmns-mark (setf dmns-mark
(or found (or found
(car (push (list item) pre-rslt))) (car (push (list item) pre-rslt)))
gmsm-mark nil))) gmsm-mark nil)))
((symbolp item) ((symbolp item)
(when (assoc item (cdr dmns-mark)) (when (assoc item (cdr dmns-mark))
(error "In BUILD-FINITE-SS, the symbol ~A is present two times." (error "In BUILD-FINITE-SS, the symbol ~A is present two times."
item)) item))
(setf gmsm-mark (car (push (list item) (cdr dmns-mark))))) (setf gmsm-mark (car (push (list item) (cdr dmns-mark)))))
((listp item) ((listp item)
(unless gmsm-mark (unless gmsm-mark
(error "In BUILD-FINITE-SS, the face list ~A~@ (error "In BUILD-FINITE-SS, the face list ~A~@
is not after a symbol." item)) is not after a symbol." item))
(nconc gmsm-mark item) (nconc gmsm-mark item)
(setf gmsm-mark nil)) (setf gmsm-mark nil))
(t (t
(error "In BUILD-FINITE-SS, the argument ~A does not make sense." item)))) (error "In BUILD-FINITE-SS, the argument ~A does not make sense." item))))
(do ((mark1 pre-rslt (cdr mark1))) (do ((mark1 pre-rslt (cdr mark1)))
((endp mark1)) ((endp mark1))
(declare (list mark1)) (declare (list mark1))
(do ((mark2 (rest mark1) (cdr mark2))) (do ((mark2 (rest mark1) (cdr mark2)))
((endp mark2)) ((endp mark2))
(declare (list mark2)) (declare (list mark2))
(let ((inter (intersection (cdar mark1) (cdar mark2) (let ((inter (intersection (cdar mark1) (cdar mark2)
:key #'first))) :key #'first)))
(declare (list inter)) (declare (list inter))
(when inter (when inter
(error "In BUILD-FINITE-SS, the symbol ~A is present two times." (error "In BUILD-FINITE-SS, the symbol ~A is present two times."
(caar inter)))))) (caar inter))))))
pre-rslt))) pre-rslt)))
@ -56,14 +57,14 @@
(DEFUN FINITE-SS-PRE-TABLE-TABLE (pre-table) (DEFUN FINITE-SS-PRE-TABLE-TABLE (pre-table)
(declare (list pre-table)) (declare (list pre-table))
(let* ((maxdim (1+ (apply #'max (mapcar #'first pre-table)))) (let* ((maxdim (1+ (apply #'max (mapcar #'first pre-table))))
(table (make-array maxdim :initial-element +empty-list+))) (table (make-array maxdim :initial-element +empty-list+)))
(declare (declare
(fixnum maxdim) (fixnum maxdim)
(simple-vector table)) (simple-vector table))
(dolist (item pre-table) (dolist (item pre-table)
(declare (list item)) (declare (list item))
(setf (svref table (first item)) (setf (svref table (first item))
(sort (rest item) #'string< :key #'first))) (sort (rest item) #'string< :key #'first)))
table)) table))
@ -77,7 +78,7 @@
(let ((found (find gmsm (svref table dmns) :test #'eq :key #'car))) (let ((found (find gmsm (svref table dmns) :test #'eq :key #'car)))
(declare (type (or cons null) found)) (declare (type (or cons null) found))
(when found (when found
(return-from finite-ss-find-gmsm dmns))))) (return-from finite-ss-find-gmsm dmns)))))
(DEFUN FINITE-SS-FINISH-TABLE (table bspn) (DEFUN FINITE-SS-FINISH-TABLE (table bspn)
@ -93,10 +94,10 @@
(simple-vector table) (simple-vector table)
(fixnum dmns)) (fixnum dmns))
(setf (svref table dmns) (setf (svref table dmns)
(mapcar (mapcar
#'(lambda (entry) #'(lambda (entry)
(finite-ss-finish-entry table entry dmns bspn)) (finite-ss-finish-entry table entry dmns bspn))
(svref table dmns)))) (svref table dmns))))
(DEFUN FINITE-SS-FINISH-ENTRY (table entry dmns bspn) (DEFUN FINITE-SS-FINISH-ENTRY (table entry dmns bspn)
@ -106,64 +107,64 @@
(fixnum dmns) (fixnum dmns)
(symbol bspn)) (symbol bspn))
(let ((simplex (first entry)) (let ((simplex (first entry))
(faces (rest entry))) (faces (rest entry)))
(declare (declare
(symbol simplex) (symbol simplex)
(list faces)) (list faces))
(when (zerop dmns) (when (zerop dmns)
(return-from finite-ss-finish-entry (return-from finite-ss-finish-entry
(make-gmsm-faces-info (make-gmsm-faces-info
:gmsm simplex :faces +s-empty-vector+ :gmsm simplex :faces +s-empty-vector+
:bndr +zero-negative-cmbn+))) :bndr +zero-negative-cmbn+)))
(setf faces (nconc faces (make-list (1+ (- dmns (length faces))) (setf faces (nconc faces (make-list (1+ (- dmns (length faces)))
:initial-element bspn))) :initial-element bspn)))
(let ((rslt (make-gmsm-faces-info :gmsm simplex))) (let ((rslt (make-gmsm-faces-info :gmsm simplex)))
(declare (cons rslt)) (declare (cons rslt))
(flet ((process-face (face) (flet ((process-face (face)
(declare (type (or symbol list) face)) (declare (type (or symbol list) face))
(when (symbolp face) (when (symbolp face)
(setf face (list face))) (setf face (list face)))
(let* ((gmsm2 (car (last face))) (let* ((gmsm2 (car (last face)))
(dgop-ext (nbutlast face)) (dgop-ext (nbutlast face))
(dmns2 (finite-ss-find-gmsm table gmsm2 0 dmns))) (dmns2 (finite-ss-find-gmsm table gmsm2 0 dmns)))
(declare (declare
(symbol gmsm2) (symbol gmsm2)
(list dgop-ext) (list dgop-ext)
(type (or fixnum null) dmns2)) (type (or fixnum null) dmns2))
(unless dmns2 (unless dmns2
(error "In BUILD-FINITE-SS, the face ~A is absent." gmsm2)) (error "In BUILD-FINITE-SS, the face ~A is absent." gmsm2))
(when (zerop (length dgop-ext)) (when (zerop (length dgop-ext))
(setf dgop-ext (nreverse (<a-b< dmns2 (1- dmns))))) (setf dgop-ext (nreverse (<a-b< dmns2 (1- dmns)))))
(unless (= (+ (length dgop-ext) dmns2 1) dmns) (unless (= (+ (length dgop-ext) dmns2 1) dmns)
(error "In BUILD-FINITE-SS, the face ~A has a wrong dimension." (error "In BUILD-FINITE-SS, the face ~A has a wrong dimension."
(append dgop-ext (list gmsm2)))) (append dgop-ext (list gmsm2))))
(absm (dgop-ext-int dgop-ext) gmsm2)))) (absm (dgop-ext-int dgop-ext) gmsm2))))
(setf (info-faces rslt) (setf (info-faces rslt)
(map 'simple-vector #'process-face faces)) (map 'simple-vector #'process-face faces))
(setf (info-bndr rslt) (setf (info-bndr rslt)
(apply #'nterm-add #'s-cmpr (1- dmns) (apply #'nterm-add #'s-cmpr (1- dmns)
(do ((rslt +empty-list+) (do ((rslt +empty-list+)
(faces (info-faces rslt)) (faces (info-faces rslt))
(indx dmns (1- indx))) (indx dmns (1- indx)))
((minusp indx) rslt) ((minusp indx) rslt)
(declare (declare
(list rslt) (list rslt)
(simple-vector faces) (simple-vector faces)
(fixnum indx)) (fixnum indx))
(let ((face (svref faces indx))) (let ((face (svref faces indx)))
(declare (type absm face)) (declare (type absm face))
(unless (degenerate-p face) (unless (degenerate-p face)
(push (term (-1-expt-n indx) (gmsm face)) (push (term (-1-expt-n indx) (gmsm face))
rslt)))))) rslt))))))
rslt)))) rslt))))
(DEFUN FINITE-SS-TABLE (list) (DEFUN FINITE-SS-TABLE (list)
(declare (list list)) (declare (list list))
(setf list (cons 0 list)) (setf list (cons 0 list))
(let* ((bspn (second list)) (let* ((bspn (second list))
(pre-table (finite-ss-pre-table list)) (pre-table (finite-ss-pre-table list))
(table (finite-ss-pre-table-table pre-table))) (table (finite-ss-pre-table-table pre-table)))
(declare (declare
(symbol bspn) (symbol bspn)
(list pre-table) (list pre-table)
@ -175,11 +176,11 @@
(DEFUN FINITE-SS-BASIS (table) (DEFUN FINITE-SS-BASIS (table)
(declare (simple-vector table)) (declare (simple-vector table))
(flet ((rslt (dmns) (flet ((rslt (dmns)
(declare (fixnum dmns)) (declare (fixnum dmns))
(the list (the list
(if (< -1 dmns (length table)) (if (< -1 dmns (length table))
(mapcar #'car (svref table dmns)) (mapcar #'car (svref table dmns))
+empty-list+)))) +empty-list+))))
#'rslt)) #'rslt))
@ -189,14 +190,14 @@
(simple-vector table)) (simple-vector table))
(flet ((rslt (indx dmns gmsm) (flet ((rslt (indx dmns gmsm)
(declare (declare
(fixnum indx dmns) (fixnum indx dmns)
(symbol gmsm)) (symbol gmsm))
(let ((found (find gmsm (svref table dmns) :key #'car))) (let ((found (find gmsm (svref table dmns) :key #'car)))
(unless found (unless found
(error "In the finite simplicial set ~A,~@ (error "In the finite simplicial set ~A,~@
the simplex ~A is absent in dimension ~D." the simplex ~A is absent in dimension ~D."
(eval ind-smst) gmsm dmns)) (eval ind-smst) gmsm dmns))
(svref (info-faces found) indx)))) (svref (info-faces found) indx))))
#'rslt)) #'rslt))
@ -206,40 +207,40 @@
(simple-vector table)) (simple-vector table))
(flet ((rslt (dmns gmsm) (flet ((rslt (dmns gmsm)
(declare (declare
(fixnum dmns) (fixnum dmns)
(symbol gmsm)) (symbol gmsm))
(let ((found (find gmsm (svref table dmns) :key #'car))) (let ((found (find gmsm (svref table dmns) :key #'car)))
(unless found (unless found
(error "In the finite simplicial set ~A,~@ (error "In the finite simplicial set ~A,~@
the simplex ~A is absent in dimension ~D." (eval ind-smst) gmsm dmns)) the simplex ~A is absent in dimension ~D." (eval ind-smst) gmsm dmns))
(info-bndr found)))) (info-bndr found))))
#'rslt)) #'rslt))
(DEFUN BUILD-FINITE-SS (list) (DEFUN BUILD-FINITE-SS (list)
(declare (list list)) (declare (list list))
(let ((bspn (first list)) (let ((bspn (first list))
(table (finite-ss-table list)) (table (finite-ss-table list))
(ind-smst (gensym))) (ind-smst (gensym)))
(declare (declare
(symbol bspn ind-smst) (symbol bspn ind-smst)
(simple-vector table)) (simple-vector table))
;; (vector (vector gmsm-faces-info)) ;; (vector (vector gmsm-faces-info))
(let ((rslt (build-smst (let ((rslt (build-smst
:cmpr #'s-cmpr :cmpr #'s-cmpr
:basis (finite-ss-basis table) :basis (finite-ss-basis table)
:bspn bspn :bspn bspn
:face (finite-ss-face ind-smst table) :face (finite-ss-face ind-smst table)
:intr-bndr (finite-ss-intr-bndr ind-smst table) :intr-bndr (finite-ss-intr-bndr ind-smst table)
:bndr-strt :gnrt :bndr-strt :gnrt
:orgn `(build-finite-ss ,list)))) :orgn `(build-finite-ss ,list))))
(setf (symbol-value ind-smst) rslt) (setf (symbol-value ind-smst) rslt)
(inspect rslt) (inspect rslt)
(unless (check-smst rslt 0 (length table)) (unless (check-smst rslt 0 (length table))
(pop *smst-list*) (pop *smst-list*)
(pop *chcm-list*) (pop *chcm-list*)
(pop *mrph-list*) (pop *mrph-list*)
(return-from build-finite-ss nil)) (return-from build-finite-ss nil))
rslt))) rslt)))
@ -253,13 +254,13 @@
(let ((fund-gmsm (intern (format nil "S~D" dmns)))) (let ((fund-gmsm (intern (format nil "S~D" dmns))))
(declare (symbol fund-gmsm)) (declare (symbol fund-gmsm))
(flet ((rslt (dmns2) (flet ((rslt (dmns2)
(declare (fixnum dmns2)) (declare (fixnum dmns2))
(cond ((zerop dmns2) (cond ((zerop dmns2)
(list '*)) (list '*))
((= dmns2 dmns) ((= dmns2 dmns)
(list fund-gmsm)) (list fund-gmsm))
(t (t
+empty-list+)))) +empty-list+))))
(the basis #'rslt)))) (the basis #'rslt))))
@ -268,8 +269,8 @@
(let ((face (absm (mask (1- dmns)) '*))) (let ((face (absm (mask (1- dmns)) '*)))
(declare (type absm face)) (declare (type absm face))
(flet ((rslt (indx dmns2 gmsm) (flet ((rslt (indx dmns2 gmsm)
(declare (ignore indx dmns2 gmsm)) (declare (ignore indx dmns2 gmsm))
(the absm face))) (the absm face)))
#'rslt))) #'rslt)))
@ -279,16 +280,16 @@
(error "In SPHERE, the dimension ~D should be positive." dmns)) (error "In SPHERE, the dimension ~D should be positive." dmns))
(unless (< dmns +maximal-dimension+) (unless (< dmns +maximal-dimension+)
(error "In SPHERE, the dimension ~D should be < ~D." (error "In SPHERE, the dimension ~D should be < ~D."
dmns +maximal-dimension+)) dmns +maximal-dimension+))
(the simplicial-set (the simplicial-set
(let ((rslt (build-smst (let ((rslt (build-smst
:cmpr #'sphere-cmpr :cmpr #'sphere-cmpr
:basis (sphere-basis dmns) :basis (sphere-basis dmns)
:bspn '* :bspn '*
:face (sphere-face dmns) :face (sphere-face dmns)
:intr-bndr #'zero-intr-dffr :intr-bndr #'zero-intr-dffr
:bndr-strt :cmbn :bndr-strt :cmbn
:orgn `(sphere ,dmns)))) :orgn `(sphere ,dmns))))
(declare (type simplicial-set rslt)) (declare (type simplicial-set rslt))
(setf (slot-value (bndr rslt) 'orgn) (setf (slot-value (bndr rslt) 'orgn)
`(zero-mrph ,rslt ,rslt -1)) `(zero-mrph ,rslt ,rslt -1))
@ -298,17 +299,17 @@
(DEFUN SPHERE-WEDGE-BASIS (dmns-list) (DEFUN SPHERE-WEDGE-BASIS (dmns-list)
(declare (list dmns-list)) (declare (list dmns-list))
(flet ((rslt (dmns) (flet ((rslt (dmns)
(declare (fixnum dmns)) (declare (fixnum dmns))
(when (zerop dmns) (when (zerop dmns)
(return-from rslt '(*))) (return-from rslt '(*)))
(do ((i (count dmns dmns-list) (1- i)) (do ((i (count dmns dmns-list) (1- i))
(basis +empty-list+ (basis +empty-list+
(cons (intern (format nil "S~D-~D" dmns i)) (cons (intern (format nil "S~D-~D" dmns i))
basis))) basis)))
((zerop i) basis) ((zerop i) basis)
(declare (declare
(fixnum i) (fixnum i)
(list basis))))) (list basis)))))
(the basis #'rslt))) (the basis #'rslt)))
@ -323,12 +324,12 @@
(declare (list dmns-list)) (declare (list dmns-list))
(the simplicial-set (the simplicial-set
(let ((rslt (build-smst (let ((rslt (build-smst
:cmpr #'s-cmpr :cmpr #'s-cmpr
:basis (sphere-wedge-basis dmns-list) :basis (sphere-wedge-basis dmns-list)
:face #'sphere-wedge-face :face #'sphere-wedge-face
:intr-bndr #'zero-intr-dffr :intr-bndr #'zero-intr-dffr
:bndr-strt :cmbn :bndr-strt :cmbn
:orgn `(sphere-wedge ,@dmns-list)))) :orgn `(sphere-wedge ,@dmns-list))))
(declare (type simplicial-set rslt)) (declare (type simplicial-set rslt))
(setf (slot-value (bndr rslt) 'orgn) (setf (slot-value (bndr rslt) 'orgn)
`(zero-mrph ,rslt ,rslt -1)) `(zero-mrph ,rslt ,rslt -1))
@ -343,58 +344,58 @@
(DEFUN MOORE-BASIS (dmns) (DEFUN MOORE-BASIS (dmns)
(declare (fixnum dmns)) (declare (fixnum dmns))
(let ((lgmsm1 (list (intern (format nil "M~D" dmns)))) (let ((lgmsm1 (list (intern (format nil "M~D" dmns))))
(lgmsm2 (list (intern (format nil "N~D" (1+ dmns)))))) (lgmsm2 (list (intern (format nil "N~D" (1+ dmns))))))
(declare (list lgmsm1 lgmsm2)) (declare (list lgmsm1 lgmsm2))
(flet ((rslt (dmns2) (flet ((rslt (dmns2)
(declare (fixnum dmns2)) (declare (fixnum dmns2))
(cond ((zerop dmns2) '(*)) (cond ((zerop dmns2) '(*))
((= dmns dmns2) lgmsm1) ((= dmns dmns2) lgmsm1)
((= (1+ dmns) dmns2) lgmsm2) ((= (1+ dmns) dmns2) lgmsm2)
(t +empty-list+)))) (t +empty-list+))))
(the basis #'rslt)))) (the basis #'rslt))))
(DEFUN MOORE-FACE (pii dmns) (DEFUN MOORE-FACE (pii dmns)
(declare (fixnum pii dmns)) (declare (fixnum pii dmns))
(let ((face (absm 0 (intern (format nil "M~D" dmns)))) (let ((face (absm 0 (intern (format nil "M~D" dmns))))
(bspn1 (absm (mask (1- dmns)) '*)) (bspn1 (absm (mask (1- dmns)) '*))
(bspn2 (absm (mask dmns) '*)) (bspn2 (absm (mask dmns) '*))
(2pii (ash pii 1))) (2pii (ash pii 1)))
(declare (declare
(type absm face) (type absm face)
(type absm bspn1 bspn2) (type absm bspn1 bspn2)
(fixnum 2pii)) (fixnum 2pii))
(flet ((rslt (indx dmns2 gmsm) (flet ((rslt (indx dmns2 gmsm)
(declare (declare
(fixnum indx dmns2) (fixnum indx dmns2)
(ignore gmsm)) (ignore gmsm))
(the absm (the absm
(if (= dmns dmns2) (if (= dmns dmns2)
bspn1 bspn1
(if (oddp indx) (if (oddp indx)
bspn2 bspn2
(if (< indx 2pii) (if (< indx 2pii)
face face
bspn2)))))) bspn2))))))
(the face #'rslt)))) (the face #'rslt))))
(DEFUN MOORE-INTR-BNDR (pii dmns) (DEFUN MOORE-INTR-BNDR (pii dmns)
(declare (fixnum pii dmns)) (declare (fixnum pii dmns))
(let ((1+dmns (1+ dmns)) (let ((1+dmns (1+ dmns))
(gmsm1 (intern (format nil "M~D" dmns)))) (gmsm1 (intern (format nil "M~D" dmns))))
(declare (declare
(fixnum 1+dmns) (fixnum 1+dmns)
(type symbol gmsm1)) (type symbol gmsm1))
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (declare
(type cmbn cmbn)) (type cmbn cmbn))
(with-cmbn (degr list) cmbn (with-cmbn (degr list) cmbn
(unless list (unless list
(return-from rslt (zero-cmbn (1- (cmbn-degr cmbn))))) (return-from rslt (zero-cmbn (1- (cmbn-degr cmbn)))))
(if (= degr 1+dmns) (if (= degr 1+dmns)
(term-cmbn dmns (* (cffc (first list)) pii) gmsm1) (term-cmbn dmns (* (cffc (first list)) pii) gmsm1)
(zero-cmbn (1- (cmbn-degr cmbn))))))) (zero-cmbn (1- (cmbn-degr cmbn)))))))
(the intr-mrph #'rslt)))) (the intr-mrph #'rslt))))
@ -402,12 +403,12 @@
(declare (fixnum pii dmns)) (declare (fixnum pii dmns))
(the simplicial-set (the simplicial-set
(build-smst (build-smst
:cmpr #'moore-cmpr :cmpr #'moore-cmpr
:basis (moore-basis dmns) :basis (moore-basis dmns)
:face (moore-face pii dmns) :face (moore-face pii dmns)
:intr-bndr (moore-intr-bndr pii dmns) :intr-bndr (moore-intr-bndr pii dmns)
:bndr-strt :cmbn :bndr-strt :cmbn
:orgn `(moore ,pii ,dmns)))) :orgn `(moore ,pii ,dmns))))
(DEFUN R-PROJ-SPACE-CMPR (gmsm1 gmsm2) (DEFUN R-PROJ-SPACE-CMPR (gmsm1 gmsm2)
@ -419,34 +420,34 @@
(declare (fixnum k) (type (or (eql :infinity) fixnum) l)) (declare (fixnum k) (type (or (eql :infinity) fixnum) l))
(the basis (the basis
(progn (progn
(when (eq l :infinity) (when (eq l :infinity)
(setf l most-positive-fixnum)) (setf l most-positive-fixnum))
(flet (flet
((rslt (dmns) ((rslt (dmns)
(declare (fixnum dmns)) (declare (fixnum dmns))
(the list (the list
(if (or (minusp dmns) (if (or (minusp dmns)
(< 0 dmns k) (< 0 dmns k)
(>= dmns l)) (>= dmns l))
+empty-list+ +empty-list+
(list dmns))))) (list dmns)))))
(the basis #'rslt))))) (the basis #'rslt)))))
(DEFUN R-PROJ-SPACE-FACE (k) (DEFUN R-PROJ-SPACE-FACE (k)
(declare (fixnum k)) (declare (fixnum k))
(flet ((rslt (indx dmns gmsm) (flet ((rslt (indx dmns gmsm)
(declare (declare
(fixnum indx dmns) (fixnum indx dmns)
(ignore gmsm)) (ignore gmsm))
(if (<= dmns k) (if (<= dmns k)
(absm (mask (1- dmns)) 0) (absm (mask (1- dmns)) 0)
(if (or (zerop indx) (if (or (zerop indx)
(= indx dmns)) (= indx dmns))
(absm 0 (1- dmns)) (absm 0 (1- dmns))
(if (= dmns (1+ k)) (if (= dmns (1+ k))
(absm (mask (1- dmns)) 0) (absm (mask (1- dmns)) 0)
(absm (2-exp (1- indx)) (- dmns 2))))))) (absm (2-exp (1- indx)) (- dmns 2)))))))
(the face #'rslt))) (the face #'rslt)))
@ -455,15 +456,15 @@
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(with-cmbn (degr list) cmbn (with-cmbn (degr list) cmbn
(unless list (unless list
(return-from rslt (zero-cmbn (1- degr)))) (return-from rslt (zero-cmbn (1- degr))))
(if (<= degr k) (if (<= degr k)
(zero-cmbn (1- degr)) (zero-cmbn (1- degr))
(if (evenp degr) (if (evenp degr)
(make-cmbn (make-cmbn
:degr (1- degr) :degr (1- degr)
:list (list (term (* 2 (-cffc list)) (1- degr)))) :list (list (term (* 2 (-cffc list)) (1- degr))))
(zero-cmbn (1- degr))))))) (zero-cmbn (1- degr)))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
(DEFUN R-PROJ-SPACE (&optional (l :infinity) (k 1)) (DEFUN R-PROJ-SPACE (&optional (l :infinity) (k 1))
@ -476,13 +477,13 @@
(<= k l))))) (<= k l)))))
(the simplicial-set (the simplicial-set
(build-smst (build-smst
:cmpr #'R-proj-space-cmpr :cmpr #'R-proj-space-cmpr
:basis (R-proj-space-basis k l) :basis (R-proj-space-basis k l)
:bspn 0 :bspn 0
:face (R-proj-space-face k) :face (R-proj-space-face k)
:intr-bndr (R-proj-space-intr-bndr k) :intr-bndr (R-proj-space-intr-bndr k)
:bndr-strt :cmbn :bndr-strt :cmbn
:orgn `(R-proj-space ,k ,l)))) :orgn `(R-proj-space ,k ,l))))
;;; Constructing a small simplicial subset ;;; Constructing a small simplicial subset
@ -498,13 +499,13 @@
(DEFUN GMSMS-SUBSMST (smst gmsms (DEFUN GMSMS-SUBSMST (smst gmsms
&aux &aux
(dmns (typecase gmsms (dmns (typecase gmsms
(cmbn (cmbn-degr gmsms)) (cmbn (cmbn-degr gmsms))
(otherwise (first gmsms)))) (otherwise (first gmsms))))
(cmpr= #'(lambda (gmsm1 gmsm2) (cmpr= #'(lambda (gmsm1 gmsm2)
(declare (type gmsm gmsm1 gmsm2)) (declare (type gmsm gmsm1 gmsm2))
(the boolean (the boolean
(eq (cmpr smst gmsm1 gmsm2) :equal))))) (eq (cmpr smst gmsm1 gmsm2) :equal)))))
(declare (declare
(type simplicial-set smst) (type simplicial-set smst)
@ -515,42 +516,85 @@
(setf gmsms (cmbn-gmsms gmsms))) (setf gmsms (cmbn-gmsms gmsms)))
(the (values simplicial-set morphism) (the (values simplicial-set morphism)
(let ((prslt (make-array (1+ dmns) :initial-element +empty-list+))) (let ((prslt (make-array (1+ dmns) :initial-element +empty-list+)))
(declare (type simple-vector prslt)) (declare (type simple-vector prslt))
(setf (svref prslt dmns) (rest gmsms)) (setf (svref prslt dmns) (rest gmsms))
(do ((d dmns (1- d))) (do ((d dmns (1- d)))
((zerop d)) ((zerop d))
(declare (fixnum d)) (declare (fixnum d))
(dolist (gmsm (svref prslt d)) (dolist (gmsm (svref prslt d))
(declare (type gmsm gmsm)) (declare (type gmsm gmsm))
(dotimes (iface (1+ d)) (dotimes (iface (1+ d))
(declare (fixnum iface)) (declare (fixnum iface))
(with-absm (dgop gmsm) (face smst iface d gmsm) (with-absm (dgop gmsm) (face smst iface d gmsm)
(declare (fixnum dgop) (type gmsm gmsm)) (declare (fixnum dgop) (type gmsm gmsm))
(pushnew gmsm (svref prslt (- d 1 (logcount dgop))) (pushnew gmsm (svref prslt (- d 1 (logcount dgop)))
:test cmpr=))))) :test cmpr=)))))
(let ((rslt-basis #'(lambda (k) (let ((rslt-basis #'(lambda (k)
(declare (fixnum dmns)) (declare (fixnum dmns))
(the list (the list
(if (<= 0 k dmns) (if (<= 0 k dmns)
(aref prslt k) (aref prslt k)
+empty-list+))))) +empty-list+)))))
(declare (type (function (fixnum) list) rslt-basis)) (declare (type (function (fixnum) list) rslt-basis))
(let ((subsmst (build-smst (let ((subsmst (build-smst
:cmpr (cmpr smst) :cmpr (cmpr smst)
:basis rslt-basis :basis rslt-basis
:bspn (let ((bspn (bspn smst))) :bspn (let ((bspn (bspn smst)))
(declare (type gmsm bspn)) (declare (type gmsm bspn))
(pushnew bspn (svref prslt 0) :test cmpr=) (pushnew bspn (svref prslt 0) :test cmpr=)
bspn) bspn)
:face (face smst) :face (face smst)
:orgn `(gmsms-subsmst ,gmsms)))) :orgn `(gmsms-subsmst ,gmsms))))
(declare (type simplicial-set subsmst)) (declare (type simplicial-set subsmst))
(values subsmst (values subsmst
(build-mrph :sorc subsmst (build-mrph :sorc subsmst
:trgt smst :trgt smst
:degr 0 :degr 0
:intr #'(lambda (cmbn) :intr #'(lambda (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn cmbn)) (the cmbn cmbn))
:strt :cmbn :strt :cmbn
:orgn `(gmsms-subsmst-incl ,gmsms)))))))) :orgn `(gmsms-subsmst-incl ,gmsms))))))))
(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))))
(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 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))))))

140
test/kan-test.lisp
View File

@ -1,99 +1,55 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test) (in-package :kenzo-test)
(in-suite :kenzo) (in-suite :kenzo)
(defun vertex-i (absm i)
(cat:with-absm
(dgop gmsm) absm
(let ((dgop (nreverse (cat:dgop-int-ext dgop)))
(gmsm (cat: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))))))
(test vertex-i (test vertex-i
(let ((d (cat:delta-infinity))) (let ((d (cat:delta-infinity)))
(vertex-i (cat:absm 0 1) 0) (cat:vertex-i (cat:absm 0 1) 0)
(vertex-i (cat:absm 1 1) 0) (cat:vertex-i (cat:absm 1 1) 0)
(vertex-i (cat:absm 1 1) 1) (cat:vertex-i (cat:absm 1 1) 1)
(vertex-i (cat:absm 0 3) 0) (cat:vertex-i (cat:absm 0 3) 0)
(vertex-i (cat:absm 0 3) 1) (cat:vertex-i (cat:absm 0 3) 1)
(vertex-i (cat:absm 3 1) 0) (cat:vertex-i (cat:absm 3 1) 0)
(vertex-i (cat:absm 3 1) 1) (cat:vertex-i (cat:absm 3 1) 1)
(vertex-i (cat:absm 3 1) 2) (cat:vertex-i (cat:absm 3 1) 2)
(vertex-i (cat:absm 1 3) 0) (cat:vertex-i (cat:absm 1 3) 0)
(vertex-i (cat:absm 1 3) 1) (cat:vertex-i (cat:absm 1 3) 1)
(vertex-i (cat:absm 1 3) 2) (cat:vertex-i (cat:absm 1 3) 2)
(vertex-i (cat:absm 2 3) 0) (cat:vertex-i (cat:absm 2 3) 0)
(vertex-i (cat:absm 2 3) 1) (cat:vertex-i (cat:absm 2 3) 1)
(vertex-i (cat:absm 2 3) 2) (cat:vertex-i (cat:absm 2 3) 2)
(vertex-i (cat:absm 0 7) 0) (cat:vertex-i (cat:absm 0 7) 0)
(vertex-i (cat:absm 0 7) 1) (cat:vertex-i (cat:absm 0 7) 1)
(vertex-i (cat:absm 0 7) 2))) (cat:vertex-i (cat:absm 0 7) 2)))
(defun absm-int-ext (absm)
(cat:with-absm
(dgop gmsm) absm
(do ((dgop (nreverse (cat:dgop-int-ext dgop)))
(gmsm (rest (cat:dlop-int-ext gmsm)))
(i 0 (1+ i))
(rslt (list (first (cat: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) (cat:absm (cat:dgop-ext-int dgop)
(cat:dgop-ext-int gmsm)))
(if (= (first gmsm) (car mark))
(push idgop dgop)
(push (car mark) gmsm))))
(test absm-int-ext (test absm-int-ext
(absm-ext-int '(0 0 0 1 2 3 3 3)) (cat:absm-ext-int '(0 0 0 1 2 3 3 3))
(absm-ext-int '(0 1 1 1 2)) (cat:absm-ext-int '(0 1 1 1 2))
(absm-int-ext (absm-ext-int '(0 0 0 1 2 3 3 3))) (cat:absm-int-ext (cat:absm-ext-int '(0 0 0 1 2 3 3 3)))
(absm-int-ext (absm-ext-int '(0 1 1 1 2)))) (cat:absm-int-ext (cat:absm-ext-int '(0 1 1 1 2))))
(defun dkfll (indx dmns hat) (defun dkfll (indx dmns hat)
(cond ((= 1 dmns) (cond ((= 1 dmns)
(cat:absm 1 (cat:gmsm (first hat)))) (cat:absm 1 (cat:gmsm (first hat))))
((= 0 indx) ((= 0 indx)
(let ((del-1 (absm-int-ext (first hat))) (let ((del-1 (cat:absm-int-ext (first hat)))
(del-2 (absm-int-ext (second hat)))) (del-2 (cat:absm-int-ext (second hat))))
(absm-ext-int (cat:absm-ext-int
(cons (first del-1) (cons (first del-1)
(cons (second del-2) (rest del-1)))))) (cons (second del-2) (rest del-1))))))
((= 1 indx) ((= 1 indx)
(let ((del-0 (absm-int-ext (first hat))) (let ((del-0 (cat:absm-int-ext (first hat)))
(del-2 (absm-int-ext (second hat)))) (del-2 (cat:absm-int-ext (second hat))))
(absm-ext-int (cat:absm-ext-int
(cons (first del-2) del-0)))) (cons (first del-2) del-0))))
(t (t
(let ((del-0 (absm-int-ext (first hat))) (let ((del-0 (cat:absm-int-ext (first hat)))
(del-1 (absm-int-ext (second hat)))) (del-1 (cat:absm-int-ext (second hat))))
(absm-ext-int (cat:absm-ext-int
(cons (first del-1) del-0)))))) (cons (first del-1) del-0))))))
(let ((d (cat:delta-infinity))) (let ((d (cat:delta-infinity)))
@ -108,12 +64,12 @@
(test check-hat (test check-hat
(let* ((od (cat:gdeltab)) (let* ((od (cat:gdeltab))
(s (cat:loop3 0 31 2)) (s (cat:loop3 0 31 2))
(faces (mapcar #'(lambda (indx) (cat:face od indx 3 s)) (faces (mapcar #'(lambda (indx) (cat:face od indx 3 s))
'(0 1 2 3)))) '(0 1 2 3))))
(delete (nth 1 faces) faces) (delete (nth 1 faces) faces)
(cat:check-hat od 1 3 faces) (cat:check-hat od 1 3 faces)
(setf (nth 2 faces) (nth 1 faces)) (setf (nth 2 faces) (nth 1 faces))
(signals #-ecl simple-error (signals #-ecl simple-error
#+ecl simple-type-error #+ecl simple-type-error
(cat:check-hat od 1 3 faces)))) (cat:check-hat od 1 3 faces))))