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

Extracted simplicial set tests.

Browse Source
This commit is contained in:
Gerd Heber 2015-07-12 19:35:13 -05:00
parent e31bbd56f7
commit c177ef36f4
5 changed files with 571 additions and 507 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
kenzo-test.asd
View File

@ -9,6 +9,7 @@
:pathname #P"test/" :pathname #P"test/"
:components ((:file "package") :components ((:file "package")
(:file "common") (:file "common")
#|
(:file "combinations-test") (:file "combinations-test")
(:file "various-test") (:file "various-test")
(:file "chain-complexes-test") (:file "chain-complexes-test")
@ -27,4 +28,6 @@
;;(:file "cl-space-efhm-test") ;;(:file "cl-space-efhm-test")
(:file "tensor-products-test") (:file "tensor-products-test")
(:file "k-pi-n-test") (:file "k-pi-n-test")
|#
(:file "simplicial-sets-test")
)) ))

24
package.lisp
View File

@ -107,6 +107,7 @@
CMBN-DEGR CMBN-DEGR
CMBN-LIST CMBN-LIST
DEGR DEGR
DGOP
DFFR1 DFFR1
EFHM EFHM
F F
@ -272,9 +273,27 @@
;; simplicial-sets.lisp ;; simplicial-sets.lisp
1DGNR
1DGOP*DGOP
1DLOP-DGOP
A-CMPR3
A-FACE4
BSPN-P
CHECK-FACES
CHECK-SMST
DGOP*DGOP DGOP*DGOP
DGOP/DGOP
DGOP-EXT-INT
DGOP-INT-EXT
DLOP-EXT-INT DLOP-EXT-INT
DLOP-INT-EXT DLOP-INT-EXT
FACE-BNDR
FACE*-BNDR
HYPHENIZE-LIST
INTR-DIAGONAL
NDGNR
NFACE
REMOVE-BIT
;; smith.lisp ;; smith.lisp
@ -282,8 +301,11 @@
;; special-smsts.lisp ;; special-smsts.lisp
SPHERE
BUILD-FINITE-SS BUILD-FINITE-SS
MOORE
R-PROJ-SPACE
SPHERE
SPHERE-FACE
;; tensor-products.lisp ;; tensor-products.lisp

1
src/abbreviations.lisp
View File

@ -17,6 +17,7 @@
:BNDR "BouNDaRy" :BNDR "BouNDaRy"
:BRGN "BaR-GeNerator" :BRGN "BaR-GeNerator"
:BSGN "BaSe GeNerator" :BSGN "BaSe GeNerator"
:BSPN "BaSe-PoiNt"
;; C ;; C
:CBGN "CoBar-GeNerator" :CBGN "CoBar-GeNerator"

846
src/simplicial-sets.lisp
View File

@ -8,58 +8,41 @@
(DEFUN DGOP-EXT-INT (ext-dgop) (DEFUN DGOP-EXT-INT (ext-dgop)
(declare (list ext-dgop)) (declare (list ext-dgop))
;; (list fixnum) ;; (list fixnum)
(when ext-dgop (when ext-dgop
(unless (apply #'> ext-dgop) (unless (apply #'> ext-dgop)
(error "In DGOP-EXT-INT, the external dgop ~A is not decreasing." ext-dgop))) (error "In DGOP-EXT-INT, the external dgop ~A is not decreasing." ext-dgop)))
(the fixnum (the fixnum
(apply #'logxor (mapcar (apply #'logxor (mapcar
#'(lambda (item) #'(lambda (item)
(declare (fixnum item)) (declare (fixnum item))
(the fixnum (2-exp item))) (the fixnum (2-exp item)))
ext-dgop)))) ext-dgop))))
#|
(dgop-ext-int '())
(dgop-ext-int '(2 2))
(dgop-ext-int '(4 0))
|#
(DEFUN DGOP-INT-EXT (dgop) (DEFUN DGOP-INT-EXT (dgop)
(declare (fixnum dgop)) (declare (fixnum dgop))
(unless (typep dgop 'dgop) (unless (typep dgop 'dgop)
(error "In DXOP-INT-EXT, ~A is not a dxop." dgop)) (error "In DXOP-INT-EXT, ~A is not a dxop." dgop))
(the list (the list
(do ((dgop dgop (ash dgop -1)) (do ((dgop dgop (ash dgop -1))
(rslt +empty-list+) (rslt +empty-list+)
(bmark 0 (1+ bmark))) (bmark 0 (1+ bmark)))
((zerop dgop) rslt) ((zerop dgop) rslt)
(declare (declare
(fixnum dgop bmark) (fixnum dgop bmark)
(list rslt)) (list rslt))
(when (oddp dgop) (when (oddp dgop)
(push bmark rslt))))) (push bmark rslt)))))
#|
(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) (DEFUN HYPHENIZE-LIST (list)
(declare (list list)) (declare (list list))
(if list (if list
(format nil "~D~{-~D~}" (first list) (rest list)) (format nil "~D~{-~D~}" (first list) (rest list))
(format nil "-"))) (format nil "-")))
#|
(hyphenize-list '())
(hyphenize-list '(3))
(hyphenize-list '(5 3 1)))
|#
(DEFUN ABSM-PRINT (absm stream depth) (DEFUN ABSM-PRINT (absm stream depth)
(declare (declare
@ -67,68 +50,71 @@
(type stream stream) (type stream stream)
(ignore depth)) (ignore depth))
(format stream (format stream
"<AbSm ~A ~A>" "<AbSm ~A ~A>"
(hyphenize-list (dgop-int-ext (dgop absm))) (hyphenize-list (dgop-int-ext (dgop absm)))
(gmsm absm)) (gmsm absm))
absm) absm)
(DEFUN FACE4 (smst indx dmns gmsm-or-absm) (DEFUN FACE4 (smst indx dmns gmsm-or-absm)
(if (typep gmsm-or-absm 'absm) (if (typep gmsm-or-absm 'absm)
(a-face4 (face1 smst) indx dmns gmsm-or-absm) (a-face4 (face1 smst) indx dmns gmsm-or-absm)
(funcall (face1 smst) indx dmns gmsm-or-absm))) (funcall (face1 smst) indx dmns gmsm-or-absm)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) nil)) (setf (ext:package-lock :clos) nil))
(DEFMETHOD PRINT-OBJECT ((smst simplicial-set) stream) (DEFMETHOD PRINT-OBJECT ((smst simplicial-set) stream)
(the simplicial-set (the simplicial-set
(progn (progn
(format stream "[K~D Simplicial-Set]" (idnm smst)) (format stream "[K~D Simplicial-Set]" (idnm smst))
smst))) smst)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t)) (setf (ext:package-lock :clos) t))
(DEFUN SMST (n) (DEFUN SMST (n)
(declare (fixnum n)) (declare (fixnum n))
(the (or simplicial-set null) (the (or simplicial-set null)
(find n *smst-list* :key #'idnm))) (find n *smst-list* :key #'idnm)))
(DEFUN BUILD-SMST (DEFUN BUILD-SMST
(&key cmpr basis bspn face face* intr-bndr bndr-strt (&key cmpr basis bspn face face* intr-bndr bndr-strt
intr-dgnl dgnl-strt orgn) intr-dgnl dgnl-strt orgn)
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(type basis basis) (type basis basis)
(type gmsm bspn) (type gmsm bspn)
(type face face) (type face face)
(type (or null face*) face*) (type (or null face*) face*)
(type (or intr-mrph null) intr-bndr intr-dgnl) (type (or intr-mrph null) intr-bndr intr-dgnl)
(type (or strt null) bndr-strt dgnl-strt) (type (or strt null) bndr-strt dgnl-strt)
(list orgn)) (list orgn))
(let ((already (find orgn *smst-list* :test #'equal :key #'orgn))) (let ((already (find orgn *smst-list* :test #'equal :key #'orgn)))
(declare (type (or simplicial-set null) already)) (declare (type (or simplicial-set null) already))
(when already (when already
(return-from build-smst already))) (return-from build-smst already)))
(if intr-bndr (if intr-bndr
(unless bndr-strt (unless bndr-strt
(error "In BUILD-SMST, an intr-bndr is given but not its strategy.")) (error "In BUILD-SMST, an intr-bndr is given but not its strategy."))
(cond (face* (cond (face*
(setf bndr-strt :gnrt (setf bndr-strt :gnrt
intr-bndr (face*-bndr cmpr face*))) intr-bndr (face*-bndr cmpr face*)))
(face (face
(setf bndr-strt :gnrt (setf bndr-strt :gnrt
intr-bndr (face-bndr cmpr face))))) intr-bndr (face-bndr cmpr face)))))
(if intr-dgnl (if intr-dgnl
(unless dgnl-strt (unless dgnl-strt
(error "In BUILD-SMST, an intr-dgnl is given but not its strategy.")) (error "In BUILD-SMST, an intr-dgnl is given but not its strategy."))
(setf dgnl-strt :gnrt (setf dgnl-strt :gnrt
intr-dgnl (intr-diagonal face))) intr-dgnl (intr-diagonal face)))
(the simplicial-set (the simplicial-set
(let ((rslt (build-chcm :cmpr cmpr :basis basis :bsgn bspn (let ((rslt (build-chcm :cmpr cmpr :basis basis :bsgn bspn
:intr-dffr intr-bndr :intr-dffr intr-bndr
:strt bndr-strt :orgn orgn))) :strt bndr-strt :orgn orgn)))
(change-chcm-to-clgb rslt (change-chcm-to-clgb rslt
:intr-cprd intr-dgnl :cprd-strt dgnl-strt) :intr-cprd intr-dgnl :cprd-strt dgnl-strt)
(setf (slot-value (dgnl rslt) 'orgn) (setf (slot-value (dgnl rslt) 'orgn)
`(diagonal ,rslt)) `(diagonal ,rslt))
(change-class rslt 'simplicial-set) (change-class rslt 'simplicial-set)
@ -136,359 +122,246 @@
(push rslt *smst-list*) (push rslt *smst-list*)
rslt))) rslt)))
(DEFUN A-BASIS2 (basis dmns) (DEFUN A-BASIS2 (basis dmns)
(declare (declare
(type basis basis) (type basis basis)
(fixnum dmns)) (fixnum dmns))
(the list (the list
(let ((basis-array (make-array (1+ dmns) :element-type 'list))) (let ((basis-array (make-array (1+ dmns) :element-type 'list)))
(declare (type (vector list) basis-array)) (declare (type (vector list) basis-array))
(dotimes (i (1+ dmns)) (dotimes (i (1+ dmns))
(declare (fixnum i)) (declare (fixnum i))
(setf (aref basis-array i) (funcall basis i))) (setf (aref basis-array i) (funcall basis i)))
(do ((dgop (mask dmns) (1- dgop)) (do ((dgop (mask dmns) (1- dgop))
(rslt +empty-list+ (rslt +empty-list+
(nconc (mapcar (nconc (mapcar
#'(lambda (gmsm) #'(lambda (gmsm)
(declare (type gmsm gmsm)) (declare (type gmsm gmsm))
(absm dgop gmsm)) (absm dgop gmsm))
(aref basis-array (- dmns (logcount dgop)))) (aref basis-array (- dmns (logcount dgop))))
rslt))) rslt)))
((minusp dgop) rslt))))) ((minusp dgop) rslt)))))
#|
(setf m (moore 2 2))
(dotimes (i 4)
(print (basis m i :dgnr)))
|#
(DEFUN INTR-DIAGONAL (face) (DEFUN INTR-DIAGONAL (face)
(declare (type face face)) (declare (type face face))
(flet ((rslt (dmns gmsm) (flet ((rslt (dmns gmsm)
(declare (declare
(fixnum dmns) (fixnum dmns)
(type gmsm gmsm)) (type gmsm gmsm))
(the cmbn (the cmbn
(let ((del-0-s +empty-list+) (let ((del-0-s +empty-list+)
(rslt +empty-list+)) (rslt +empty-list+))
(declare (list del-0-s rslt)) (declare (list del-0-s rslt))
(do ((dmns dmns (1- dmns)) (do ((dmns dmns (1- dmns))
(absm (absm 0 gmsm) (a-face4 face 0 dmns absm))) (absm (absm 0 gmsm) (a-face4 face 0 dmns absm)))
((zerop dmns) (push absm del-0-s)) ((zerop dmns) (push absm del-0-s))
(declare (fixnum dmns) (type absm absm)) (declare (fixnum dmns) (type absm absm))
(push absm del-0-s)) (push absm del-0-s))
(do ((ldmns dmns (1- ldmns)) (do ((ldmns dmns (1- ldmns))
(rdmns 0 (1+ rdmns)) (rdmns 0 (1+ rdmns))
(absm (absm 0 gmsm) (a-face4 face ldmns ldmns absm)) (absm (absm 0 gmsm) (a-face4 face ldmns ldmns absm))
(mark-del-0 del-0-s (cdr mark-del-0))) (mark-del-0 del-0-s (cdr mark-del-0)))
((zerop ldmns) ((zerop ldmns)
(push (term 1 (tnpr 0 (gmsm absm) dmns gmsm)) (push (term 1 (tnpr 0 (gmsm absm) dmns gmsm))
rslt)) rslt))
(declare (declare
(fixnum ldmns rdmns) (fixnum ldmns rdmns)
(type gmsm gmsm) (type gmsm gmsm)
(list mark-del-0)) (list mark-del-0))
(unless (or (plusp (dgop absm)) (unless (or (plusp (dgop absm))
(plusp (dgop (car mark-del-0)))) (plusp (dgop (car mark-del-0))))
(push (term 1 (tnpr ldmns (gmsm absm) (push (term 1 (tnpr ldmns (gmsm absm)
rdmns (gmsm (car mark-del-0)))) rdmns (gmsm (car mark-del-0))))
rslt))) rslt)))
(make-cmbn :degr dmns :list rslt))))) (make-cmbn :degr dmns :list rslt)))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
#|
()
(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) (DEFUN FACE-BNDR (cmpr face)
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(type face face)) (type face face))
(flet ((rslt (dmns gmsm) (flet ((rslt (dmns gmsm)
(declare (declare
(fixnum dmns) (fixnum dmns)
(type gmsm gmsm)) (type gmsm gmsm))
(the cmbn (the cmbn
(progn (progn
(when (zerop dmns) (when (zerop dmns)
(return-from rslt +zero-negative-cmbn+)) (return-from rslt +zero-negative-cmbn+))
(let ((pre-rslt +empty-list+)) (let ((pre-rslt +empty-list+))
(declare (list pre-rslt)) (declare (list pre-rslt))
;; (list (cons cffc face)) ;; (list (cons cffc face))
(dotimes (indx (1+ dmns)) (dotimes (indx (1+ dmns))
(declare (fixnum indx)) (declare (fixnum indx))
(let ((face (funcall face indx dmns gmsm))) (let ((face (funcall face indx dmns gmsm)))
(declare (type absm face)) (declare (type absm face))
(unless (degenerate-p face) (unless (degenerate-p face)
(push (term (-1-expt-n indx) (gmsm face)) (push (term (-1-expt-n indx) (gmsm face))
pre-rslt)))) pre-rslt))))
(apply #'nterm-add cmpr (1- dmns) pre-rslt)))))) (apply #'nterm-add cmpr (1- dmns) pre-rslt))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
#|
(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*) (DEFUN FACE*-BNDR (cmpr face*)
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(type face* face*)) (type face* face*))
(flet ((rslt (dmns gmsm) (flet ((rslt (dmns gmsm)
(declare (declare
(fixnum dmns) (fixnum dmns)
(type gmsm gmsm)) (type gmsm gmsm))
(the cmbn (the cmbn
(progn (progn
(when (zerop dmns) (when (zerop dmns)
(return-from rslt +zero-negative-cmbn+)) (return-from rslt +zero-negative-cmbn+))
(let ((pre-rslt +empty-list+)) (let ((pre-rslt +empty-list+))
(declare (list pre-rslt)) (declare (list pre-rslt))
;; (list (list gmsm fixnum)) ;; (list (list gmsm fixnum))
(dotimes (indx (1+ dmns)) (dotimes (indx (1+ dmns))
(declare (fixnum indx)) (declare (fixnum indx))
(let ((face (funcall face* indx dmns gmsm))) (let ((face (funcall face* indx dmns gmsm)))
(declare (type (or gmsm (eql :degenerate)) face)) (declare (type (or gmsm (eql :degenerate)) face))
(unless (eq face :degenerate) (unless (eq face :degenerate)
(push (term (-1-expt-n indx) face) pre-rslt)))) (push (term (-1-expt-n indx) face) pre-rslt))))
(apply #'nterm-add cmpr (1- dmns) pre-rslt)))))) (apply #'nterm-add cmpr (1- dmns) pre-rslt))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
#|
(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) (DEFUN A-CMPR3 (cmpr absm1 absm2)
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(type absm absm1 absm2)) (type absm absm1 absm2))
(the cmpr (the cmpr
(with-absm (dgop1 gmsm1) absm1 (with-absm (dgop1 gmsm1) absm1
(with-absm (dgop2 gmsm2) absm2 (with-absm (dgop2 gmsm2) absm2
(lexico (lexico
(f-cmpr dgop1 dgop2) (f-cmpr dgop1 dgop2)
(funcall cmpr gmsm1 gmsm2)))))) (funcall cmpr gmsm1 gmsm2))))))
#|
(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) (DEFUN BSPN-P (cmpr bspn dmns absm)
;; this function makes sense only in the simplicial context ;; this function makes sense only in the simplicial context
;; so that the basg (= base-generator) is called bspn (= base-point) ;; so that the basg (= base-generator) is called bspn (= base-point)
(declare (declare
(type gmsm bspn) (type gmsm bspn)
(fixnum dmns) (fixnum dmns)
(type absm absm)) (type absm absm))
(the boolean (the boolean
(with-absm (dgop gmsm) absm (with-absm (dgop gmsm) absm
(and (= dgop (mask dmns)) (and (= dgop (mask dmns))
(eq :equal (funcall cmpr bspn gmsm)))))) (eq :equal (funcall cmpr bspn gmsm))))))
#|
(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) (DEFUN DLOP-EXT-INT (ext-dlop)
(declare (list ext-dlop)) (declare (list ext-dlop))
;; (list fixnum) ;; (list fixnum)
(when ext-dlop (when ext-dlop
(unless (apply #'< ext-dlop) (unless (apply #'< ext-dlop)
(error "In DLOP-EXT-INT, the external dlop ~A is not increasing." ext-dlop))) (error "In DLOP-EXT-INT, the external dlop ~A is not increasing." ext-dlop)))
(the fixnum (the fixnum
(apply #'logxor (apply #'logxor
(mapcar #'(lambda (item) (mapcar #'(lambda (item)
(declare (fixnum item)) (declare (fixnum item))
(the fixnum (2-exp item))) (the fixnum (2-exp item)))
ext-dlop)))) ext-dlop))))
#|
(dlop-ext-int '())
(dlop-ext-int '(2 2))
(dlop-ext-int '(0 4)))
|#
(DEFUN DLOP-INT-EXT (dlop) (DEFUN DLOP-INT-EXT (dlop)
(declare (fixnum dlop)) (declare (fixnum dlop))
(the list (the list
(nreverse (dgop-int-ext dlop)))) (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) (DEFUN 1DGOP*DGOP (1dgop dgop)
(declare (fixnum 1dgop dgop)) (declare (fixnum 1dgop dgop))
;; 1dgop is an ordinary integer ;; 1dgop is an ordinary integer
;; dgop is a bit string ;; dgop is a bit string
(the fixnum (the fixnum
(let ((share (ash -1 1dgop))) (let ((share (ash -1 1dgop)))
(declare (fixnum share)) (declare (fixnum share))
(logxor (logxor
(ash (logand share dgop) 1) (ash (logand share dgop) 1)
(2-exp 1dgop) (2-exp 1dgop)
(logandc1 share dgop))))) (logandc1 share dgop)))))
#|
(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) (DEFUN DGOP*DGOP (dgop1 dgop2)
(declare (type fixnum dgop1 dgop2)) (declare (type fixnum dgop1 dgop2))
(let ((dgop 0) (let ((dgop 0)
(bmark 0)) (bmark 0))
(declare (fixnum dgop bmark)) (declare (fixnum dgop bmark))
(loop (loop
(when (zerop dgop1) (when (zerop dgop1)
(return-from dgop*dgop (return-from dgop*dgop
(logxor dgop (ash dgop2 bmark)))) (logxor dgop (ash dgop2 bmark))))
(when (zerop dgop2) (when (zerop dgop2)
(return-from dgop*dgop (return-from dgop*dgop
(logxor dgop (ash dgop1 bmark)))) (logxor dgop (ash dgop1 bmark))))
(cond ((evenp dgop1) (cond ((evenp dgop1)
(when (oddp dgop2) (when (oddp dgop2)
(incf dgop (2-exp bmark))) (incf dgop (2-exp bmark)))
(setf dgop2 (ash dgop2 -1))) (setf dgop2 (ash dgop2 -1)))
(t (t
(incf dgop (2-exp bmark)))) (incf dgop (2-exp bmark))))
(setf dgop1 (ash dgop1 -1)) (setf dgop1 (ash dgop1 -1))
(incf bmark)))) (incf bmark))))
#|
(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) (DEFUN REMOVE-BIT (n indx)
(declare (fixnum n indx)) (declare (fixnum n indx))
(the fixnum (the fixnum
(let ((cut (2-exp indx))) (let ((cut (2-exp indx)))
(multiple-value-bind (quotient remainder) (truncate n cut) (multiple-value-bind (quotient remainder) (truncate n cut)
(declare (fixnum quotient remainder)) (declare (fixnum quotient remainder))
(+ (ash (ash quotient -1) indx) remainder))))) (+ (ash (ash quotient -1) indx) remainder)))))
#|
(remove-bit 107 3) ;; 51
|#
(DEFUN DGOP/DGOP (dgop1 dgop2) (DEFUN DGOP/DGOP (dgop1 dgop2)
(declare (fixnum dgop1 dgop2)) (declare (fixnum dgop1 dgop2))
(the fixnum (the fixnum
(do ((indx (1- (integer-length dgop2)) (1- indx))) (do ((indx (1- (integer-length dgop2)) (1- indx)))
((minusp indx) dgop1) ((minusp indx) dgop1)
(declare (fixnum indx)) (declare (fixnum indx))
(when (logbitp indx dgop2) (when (logbitp indx dgop2)
(setf dgop1 (remove-bit dgop1 indx)))))) (setf dgop1 (remove-bit dgop1 indx))))))
#|
(dgop/dgop 67 0)
(dgop/dgop 68 4)
(dgop/dgop 31 5)
|#
(DEFUN 1DLOP-DGOP (1dlop dgop) (DEFUN 1DLOP-DGOP (1dlop dgop)
(declare (fixnum 1dlop dgop)) (declare (fixnum 1dlop dgop))
;; 1dlop is an ordinary fixnum ;; 1dlop is an ordinary fixnum
;; dgop is a bit string ;; dgop is a bit string
(the (values fixnum (or fixnum null)) (the (values fixnum (or fixnum null))
(progn (progn
(when (logbitp 1dlop dgop) (when (logbitp 1dlop dgop)
(let ((share (ash -1 1dlop))) (let ((share (ash -1 1dlop)))
(declare (fixnum share)) (declare (fixnum share))
(return-from 1dlop-dgop (return-from 1dlop-dgop
(values (values
(logxor (logxor
(logand share (ash dgop -1)) (logand share (ash dgop -1))
(logandc1 share dgop)) (logandc1 share dgop))
nil)))) nil))))
(when (and (plusp 1dlop) (when (and (plusp 1dlop)
(logbitp (1- 1dlop) dgop)) (logbitp (1- 1dlop) dgop))
(let ((share (ash -1 1dlop))) ;;; (let ((share (ash -1 1dlop))) ;;;
(declare (fixnum share)) (declare (fixnum share))
(setf share (ash share -1)) ;;; because of the compiler bug (setf share (ash share -1)) ;;; because of the compiler bug
(return-from 1dlop-dgop (return-from 1dlop-dgop
(values (values
(logxor (logxor
(logand share (ash dgop -1)) (logand share (ash dgop -1))
(logandc1 share dgop)) (logandc1 share dgop))
nil)))) nil))))
(let ((share (ash -1 1dlop))) (let ((share (ash -1 1dlop)))
(declare (fixnum share)) (declare (fixnum share))
(let ((right (logandc1 share dgop))) (let ((right (logandc1 share dgop)))
(declare (fixnum right)) (declare (fixnum right))
(values (values
(logxor right (logand share (ash dgop -1))) (logxor right (logand share (ash dgop -1)))
(- 1dlop (logcount right)))))))) (- 1dlop (logcount right))))))))
#|
(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) (DEFUN A-FACE4 (face indx dmns absm)
@ -497,63 +370,44 @@
(fixnum indx dmns) (fixnum indx dmns)
(type absm absm)) (type absm absm))
(the absm (the absm
(with-absm (dgop gmsm) absm (with-absm (dgop gmsm) absm
(multiple-value-bind (dgop2 1dlop) (1dlop-dgop indx dgop) (multiple-value-bind (dgop2 1dlop) (1dlop-dgop indx dgop)
(declare (fixnum dgop2) (declare (fixnum dgop2)
#-lispworks (type (or fixnum nil) 1dlop)) #-lispworks (type (or fixnum nil) 1dlop))
;; Bug LispWorks if this or-type defined ;; Bug LispWorks if this or-type defined
(unless 1dlop (unless 1dlop
(return-from a-face4 (absm dgop2 gmsm))) (return-from a-face4 (absm dgop2 gmsm)))
(locally (declare (fixnum 1dlop)) (locally (declare (fixnum 1dlop))
(let ((gmsm-face (funcall face 1dlop (- dmns (logcount dgop)) gmsm))) (let ((gmsm-face (funcall face 1dlop (- dmns (logcount dgop)) gmsm)))
(declare (type absm gmsm-face)) (declare (type absm gmsm-face))
(with-absm (dgop3 gmsm3) gmsm-face (with-absm (dgop3 gmsm3) gmsm-face
(absm (dgop*dgop dgop2 dgop3) gmsm3)))))))) (absm (dgop*dgop dgop2 dgop3) gmsm3))))))))
#|
()
(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) (DEFUN 1DGNR (indx absm)
(declare (declare
(fixnum indx) (fixnum indx)
(type absm absm)) (type absm absm))
(the absm (the absm
(with-absm (dgop gmsm) absm (with-absm (dgop gmsm) absm
(absm (1dgop*dgop indx dgop) gmsm)))) (absm (1dgop*dgop indx dgop) gmsm))))
#|
(1dgnr 2 (absm 17 'a))
|#
(DEFUN NDGNR (dgop absm) (DEFUN NDGNR (dgop absm)
(declare (declare
(fixnum dgop) (fixnum dgop)
(type absm absm)) (type absm absm))
(the absm (the absm
(with-absm (dgop2 gmsm) absm (with-absm (dgop2 gmsm) absm
(absm (dgop*dgop dgop dgop2) gmsm)))) (absm (dgop*dgop dgop dgop2) gmsm))))
#|
(ndgnr 2 (absm 17 'a))
|#
(DEFUN NFACE (face dlop dmns gmsm) (DEFUN NFACE (face dlop dmns gmsm)
(declare (declare
(type face face) (type face face)
(type dlop dlop) (type dlop dlop)
(fixnum dmns) (fixnum dmns)
(type gmsm gmsm)) (type gmsm gmsm))
(do* ((gmsm gmsm) (do* ((gmsm gmsm)
(dmns dmns) (dmns dmns)
(dgop 0) (dgop 0)
@ -561,95 +415,75 @@
(bark (1- (integer-length dlop)) (bark (1- (integer-length dlop))
(1- (integer-length dlop)))) (1- (integer-length dlop))))
((zerop dlop) (absm dgop gmsm)) ((zerop dlop) (absm dgop gmsm))
(declare
(type gmsm gmsm)
(fixnum dgop dlop bark))
(multiple-value-bind (dgop2 indx) (1dlop-dgop bark dgop)
(declare (declare
(type gmsm gmsm) (fixnum dgop2)
(fixnum dgop dlop bark)) (type (or null fixnum) indx))
(multiple-value-bind (dgop2 indx) (1dlop-dgop bark dgop) (if indx
(declare (locally (declare (fixnum indx))
(fixnum dgop2) (let ((new-absm (funcall face indx dmns gmsm)))
(type (or null fixnum) indx)) (declare (type absm new-absm))
(if indx (with-absm (dgop3 gmsm2) new-absm
(locally (declare (fixnum indx)) (setf gmsm gmsm2
(let ((new-absm (funcall face indx dmns gmsm))) dmns (- dmns 1
(declare (type absm new-absm)) (logcount dgop3))
(with-absm (dgop3 gmsm2) new-absm dgop (dgop*dgop dgop2 dgop3)))))
(setf gmsm gmsm2 (setf dgop dgop2)))))
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) (DEFUN CHECK-FACES (cmpr face dmns gmsm)
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(type face face) (type face face)
(fixnum dmns) (fixnum dmns)
(type gmsm gmsm)) (type gmsm gmsm))
(the boolean (the boolean
(progn (progn
(when (> dmns 1) (when (> dmns 1)
(let ((dmns-1 (1- dmns))) (let ((dmns-1 (1- dmns)))
(declare (fixnum dmns-1)) (declare (fixnum dmns-1))
(dotimes (i dmns) (dotimes (i dmns)
(declare (fixnum i)) (declare (fixnum i))
(dotimes (j (1+ i)) (dotimes (j (1+ i))
(declare (fixnum j)) (declare (fixnum j))
(let ((rslt1 (a-face4 face i dmns-1 (funcall face j dmns gmsm))) (let ((rslt1 (a-face4 face i dmns-1
(rslt2 (a-face4 face j dmns-1 (funcall face (1+ i) dmns gmsm)))) (funcall face j dmns gmsm)))
(declare (type absm rslt1 rslt2)) (rslt2 (a-face4 face j dmns-1
(unless (eq (a-cmpr3 cmpr rslt1 rslt2) :equal) (funcall face (1+ i) dmns gmsm))))
(cerror "CHECK-FACES will return NIL." (declare (type absm rslt1 rslt2))
"Noncoherent boundary operators detected by CHECK-FACES :~@ (unless (eq (a-cmpr3 cmpr rslt1 rslt2) :equal)
(cerror "CHECK-FACES will return NIL."
"Noncoherent boundary operators detected by CHECK-FACES :~@
Simplex => ~A~@ Simplex => ~A~@
del_~D o del_~D => ~A~@ del_~D o del_~D => ~A~@
del_~D o del_~D => ~A" del_~D o del_~D => ~A"
gmsm i j rslt1 j (1+ i) rslt2) gmsm i j rslt1 j (1+ i) rslt2)
(return-from check-faces nil))))))) (return-from check-faces nil)))))))
t))) t)))
#|
(setf d (delta-infinity))
(check-faces #'f-cmpr (face d) 4 31)
|#
(DEFUN CHECK-SMST (smst dmns1 &optional (dmns2 (1+ dmns1))) (DEFUN CHECK-SMST (smst dmns1 &optional (dmns2 (1+ dmns1)))
(declare (declare
(type simplicial-set smst) (type simplicial-set smst)
(fixnum dmns1 dmns2)) (fixnum dmns1 dmns2))
(with-slots (cmpr basis face) smst (with-slots (cmpr basis face) smst
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(type face face)) (type face face))
(when (eq basis :locally-effective) (when (eq basis :locally-effective)
(error "In CHECK-SMST, the locally-effective simplicial-set ~A~@ (error "In CHECK-SMST, the locally-effective simplicial-set ~A~@
cannot be checked." smst)) cannot be checked." smst))
(do ((rslt t) (do ((rslt t)
(dmns dmns1 (1+ dmns))) (dmns dmns1 (1+ dmns)))
((>= dmns dmns2) rslt) ((>= dmns dmns2) rslt)
(declare (declare
(type boolean rslt) (type boolean rslt)
(fixnum dmns)) (fixnum dmns))
(format t "~%Checking the ~D-simplices..." dmns) (format t "~%Checking the ~D-simplices..." dmns)
(dolist (gmsm (funcall basis dmns)) (dolist (gmsm (funcall basis dmns))
(declare (type gmsm gmsm)) (declare (type gmsm gmsm))
(unless (check-faces cmpr face dmns gmsm) (unless (check-faces cmpr face dmns gmsm)
(setf rslt nil)))))) (setf rslt nil))))))
#|
(check-smst (delta-infinity) 5)
(check-smst (delta 3) 2)
(check-smst (delta 3) 2 4)
|#

204
test/simplicial-sets-test.lisp Normal file
View File

@ -0,0 +1,204 @@
(in-package :kenzo-test)
(in-suite :kenzo)
(test dgop-ext-int
(is (= 0 (cat:dgop-ext-int '())))
(signals simple-error (cat:dgop-ext-int '(2 2)))
(is (= 17 (cat:dgop-ext-int '(4 0)))))
(test dgop-int-ext
(is (null (cat:dgop-int-ext 0)))
(is (equal '(2) (cat:dgop-int-ext 4)))
(is (equal '(5 4 3 2 1 0) (cat:dgop-int-ext 63)))
(dotimes (i 33)
(is (= i (cat:dgop-ext-int (cat:dgop-int-ext i))))))
(test hyphenize-list
(is (string= "-" (cat:hyphenize-list '())))
(is (string= "3" (cat:hyphenize-list '(3))))
(is (string= "5-3-1" (cat:hyphenize-list '(5 3 1)))))
(test moore
(let ((m (cat:moore 2 2)))
(dotimes (i 4)
(print (cat:basis m i :dgnr)))))
#|
(test intr-diagonal
(let* ((cmpr #'cat:f-cmpr)
(face #'cat:delta-face)
(diag (cat:intr-diagonal face)))
(funcall diag 4 (cat:mask 5))
(funcall diag 0 4)
(setf cmpr #'cat:s-cmpr face (cat:sphere-face 4))
(setf diag (cat:intr-diagonal face))
(funcall diag 4 's4)
(funcall diag 0 '*)
(setf s4 (cat:sphere 4))
(cat:dgnl s4 4 's4)))
|#
(test face-bndr
(let* ((face #'(lambda (indx dmns gmsm)
(cat:absm 0 (append
(subseq gmsm 0 indx)
(subseq gmsm (1+ indx))))))
(bndr (cat:face-bndr #'cat:l-cmpr face)))
(funcall bndr 0 '(a))
(funcall bndr 1 '(a b))
(funcall bndr 2 '(a b c))
(funcall bndr 3 '(a b c d))
(funcall bndr 3 '(d c b a))
(funcall bndr 1 '(a a))
(funcall bndr 2 '(a a a))
(funcall bndr 3 '(a a a a))
(setf face #'(lambda (index dmns gmsm)
(cat:absm (cat:dgop-ext-int
(nreverse (cat:<a-b< 0 (1- dmns)))) 'a)))
(setf bndr (cat:face-bndr #'cat:s-cmpr face))
(funcall bndr 1 '(a b))
(funcall bndr 2 '(a b c))))
(test face*-bndr
(let* ((face* #'(lambda (indx dmns gmsm)
(if (and (= dmns 3) (evenp indx))
'm2
:degenerate)))
(bndr (cat:face*-bndr #'cat:s-cmpr face*)))
(funcall bndr 3 'm3)
(funcall bndr 2 'm2)
(funcall bndr 0 '*)
(setf face* #'(lambda (indx dmns gmsm)
(if (and (= dmns 3) (< indx 2))
'm2
:degenerate)))
(setf bndr (cat:face*-bndr #'cat:s-cmpr face*))
(funcall bndr 3 'm3)
(funcall bndr 2 'm2)
(funcall bndr 0 '*)))
(test a-cmpr3
(is (equal :less (cat:a-cmpr3 #'cat:s-cmpr
(cat:absm 0 'a)
(cat:absm 1 'b))))
(is (equal :greater (cat:a-cmpr3 #'cat:s-cmpr
(cat:absm 2 'a)
(cat:absm 1 'b))))
(is (equal :less (cat:a-cmpr3 #'cat:s-cmpr
(cat:absm 1 'a)
(cat:absm 1 'b))))
(is (equal :greater (cat:a-cmpr3 #'cat:s-cmpr
(cat:absm 1 'c)
(cat:absm 1 'b))))
(is (equal :equal (cat:a-cmpr3 #'cat:s-cmpr
(cat:absm 1 'a)
(cat:absm 1 'a)))))
(test bspn-p
(let* ((d (cat:delta-infinity))
(cmpr (cat:cmpr d)))
(is (cat:bspn-p cmpr 1 5 (cat:absm (cat:mask 5) 1)))
(is (not (cat:bspn-p cmpr 1 5 (cat:absm (cat:mask 5) 2))))
(is (not (cat:bspn-p cmpr 1 5 (cat:absm (cat:mask 4) 3))))))
(test dlop-ext-int
(is (= 0 (cat:dlop-ext-int '())))
(signals simple-error (cat:dlop-ext-int '(2 2)))
(is (= 17 (cat:dlop-ext-int '(0 4)))))
(test dlop-ext-int
(is (null (cat:dlop-int-ext 0)))
(is (equal '(2) (cat:dlop-int-ext 4)))
(is (equal '(0 1 2 3 4 5) (cat:dlop-int-ext 63)))
(dotimes (i 33)
(is (= i (cat:dlop-ext-int (cat:dlop-int-ext i))))))
(test 1dgop*dgop
(dotimes (i 20)
(dotimes (j 5)
(format t "~% (~D) o ~A = ~A"
j (cat:dgop-int-ext i)
(cat:dgop-int-ext (cat:1dgop*dgop j i))))))
(test dgop*dgop
(dotimes (i 10)
(dotimes (j 10)
(format t "~%~A o ~A = ~A"
(cat:dgop-int-ext i) (cat:dgop-int-ext j)
(cat:dgop-int-ext (cat:dgop*dgop i j))))))
(test remove-bit
(is (= 51 (cat:remove-bit 107 3))))
(test dgop/dgop
(is (= 67 (cat:dgop/dgop 67 0)))
(is (= 32 (cat:dgop/dgop 68 4)))
(is (= 7 (cat:dgop/dgop 31 5))))
(test 1dlop-dgop
(dotimes (i 5)
(dotimes (j 17)
(multiple-value-bind (dgop 1dlop) (cat:1dlop-dgop i j)
(format t "~% del-~D o ~A = ~A o del-~A"
i (cat:dgop-int-ext j) (cat:dgop-int-ext dgop) 1dlop)))))
#|
(test a-face4
(let ((simp (cat:dlop-ext-int '(0 1 2 3 4 5 6))))
(dotimes (i 5)
(dotimes (j 17)
(let ((face (cat:a-face4 (cat:face (cat:delta-infinity))
i (+ 6 (logcount j))
(cat:absm j simp))))
(format t "~%del-~D o ~A (0 1 2 3 4 5 6) = ~A ~A"
i (cat:dgop-int-ext j)
(cat:dgop-int-ext (cat:dgop face))
(cat:dlop-int-ext (cat:gmsm face))))))))
|#
(test 1dgnr
(print (cat:1dgnr 2 (cat:absm 17 'a))))
(test ndgnr
(print (cat:ndgnr 2 (cat:absm 17 'a))))
(test nface
(let ((f (cat:face (cat:delta-infinity)))
p)
(dotimes (dlop 31)
(print (cat:dlop-int-ext (cat:gmsm (cat:nface f dlop 4 31)))))
(setf p (cat:r-proj-space))
(setf f (cat:face p))
(dotimes (dlop 31)
(format t "~%~A ~A"
(cat:hyphenize-list (cat:dlop-int-ext dlop))
(cat:nface f dlop 4 4)))))
(test check-faces
(let ((d (cat:delta-infinity)))
(is (cat:check-faces #'cat:f-cmpr (cat:face d) 4 31))))
(test check-smst
(signals simple-error (cat:check-smst (cat:delta-infinity) 5))
(is (cat:check-smst (cat:delta 3) 2))
(is (cat:check-smst (cat:delta 3) 2 4)))