From f1ab0d41e892a372238bb32268123ae9cedf4b0b Mon Sep 17 00:00:00 2001 From: Gerd Heber Date: Sun, 26 Jul 2015 04:04:35 -0500 Subject: [PATCH] Extracted suspensions tests. --- kenzo-test.asd | 1 + package.lisp | 11 ++ src/suspensions.lisp | 352 +++++++++++++------------------------ test/common.lisp | 2 + test/suspensions-test.lisp | 133 ++++++++++++++ 5 files changed, 270 insertions(+), 229 deletions(-) create mode 100644 test/suspensions-test.lisp diff --git a/kenzo-test.asd b/kenzo-test.asd index 902fc51..2574e8f 100644 --- a/kenzo-test.asd +++ b/kenzo-test.asd @@ -38,6 +38,7 @@ (:file "simplicial-groups-test") (:file "simplicial-mrphs-test") (:file "simplicial-sets-test") + (:file "suspensions-test") (:file "tensor-products-test") (:file "various-test") )) diff --git a/package.lisp b/package.lisp index ad894be..d649942 100644 --- a/package.lisp +++ b/package.lisp @@ -121,6 +121,7 @@ APOWR BCC BRGN + BSGN BSPN CBGN CHAIN-COMPLEX @@ -446,6 +447,16 @@ SPHERE SPHERE-FACE + ;; suspensions.lisp + + SUSPENSION + SUSPENSION-BASIS + SUSPENSION-CMPR + SUSPENSION-FACE + SUSPENSION-INTR + SUSPENSION-INTR-CPRD + SUSPENSION-INTR-DFFR + ;; tensor-products.lisp 2CMBN-TNPR diff --git a/src/suspensions.lisp b/src/suspensions.lisp index 49f401f..31f1b7c 100644 --- a/src/suspensions.lisp +++ b/src/suspensions.lisp @@ -12,15 +12,9 @@ (declare (type gnrt gnrt1 gnrt2)) (if (eq gnrt1 :s-bsgn) :equal - (funcall cmpr gnrt1 gnrt2)))) + (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)) @@ -34,35 +28,23 @@ (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)))))))) + (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 @@ -70,153 +52,101 @@ (fixnum n)) (if (= n 0) obj - (suspension-1 (suspension obj (1- n))))) + (suspension-1 (suspension obj (1- n))))) (DEFGENERIC SUSPENSION-1 (x)) + (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))))) + (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)))))))) + (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))) + (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)) + (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))) + (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))) + (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)) @@ -224,101 +154,65 @@ (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)))) + (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))))) + (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))))) + (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))))) + (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) -|# - diff --git a/test/common.lisp b/test/common.lisp index e309b02..4415f2d 100644 --- a/test/common.lisp +++ b/test/common.lisp @@ -224,6 +224,7 @@ (defun random-cmbn (cmpr degr max-cffc max-expn loop-length cmbn-length) (apply #'cat:nterm-add cmpr degr (mapcar #'(lambda (dummy) + (declare (ignore dummy)) (cat:term (cat:srandom max-cffc) (random-crpr degr max-expn loop-length))) (make-list cmbn-length)))) @@ -255,5 +256,6 @@ (defun random-niloop (dmns max-expn length) (mapcar #'(lambda (dummy) + (declare (ignore dummy)) (random-apowr (1+ dmns) max-expn)) (make-list length))) diff --git a/test/suspensions-test.lisp b/test/suspensions-test.lisp new file mode 100644 index 0000000..9794895 --- /dev/null +++ b/test/suspensions-test.lisp @@ -0,0 +1,133 @@ + +(in-package :kenzo-test) + +(in-suite :kenzo) + +(test suspension-cmpr + (cat:cat-init) + (let* ((cc (cat:deltab)) + (cmpr (cat:suspension-cmpr (cat:cmpr cc)))) + (is (equal :equal (funcall cmpr :s-bsgn :s-bsgn))) + (is (equal :greater (funcall cmpr 6 5))))) + + +(test suspension-basis + (cat:cat-init) + (let* ((cc (cat:sphere 2)) + (basis (cat:suspension-basis (cat:basis cc)))) + (dotimes (i 6) + (print (funcall basis i))) + (cat:suspension-basis :locally-effective))) + + +(test suspension-intr-dffr + (cat:cat-init) + (let* ((cc (cat:deltab)) + (intr (cat:suspension-intr-dffr (cat:dffr cc)))) + (funcall intr (cat:cmbn 0 3 :s-bsgn)) + (funcall intr (cat:cmbn 3 66 7)))) + + +(test suspension + (cat:cat-init) + (let* ((cc (cat:deltab)) + (scc (cat:suspension cc))) + (cat:cmpr scc 7 11) + (signals simple-error (cat:basis scc 3)) + (cat:bsgn scc) + (cat:? scc 3 11) + (setf scc (cat:suspension cc 2)) + (cat:? scc 4 11))) + + +(test suspension-intr-cprd + (cat:suspension-intr-cprd (cat:cmbn 0)) + (cat:suspension-intr-cprd (cat:cmbn 0 5 :s-bsgn)) + (cat:suspension-intr-cprd (cat:cmbn 3 4 7 5 11))) + + +(test coal + (cat:cat-init) + (let* ((coal (cat:deltab)) + (scoal (cat:suspension coal))) + (setf scoal (cat:suspension coal)) + (cat:? scoal 3 7) + (cat:cprd scoal 3 7))) + + +(test suspension-face + (cat:cat-init) + (let* ((ss (cat:deltab)) + (face (cat:suspension-face (cat:face ss))) + (m (cat:moore 2 3))) + (funcall face 4 4 15) + (funcall face 0 4 15) + (cat:check-faces #'cat:f-cmpr face 4 15) + (cat:check-faces #'cat:f-cmpr face 3 7) + (cat:check-faces #'cat:f-cmpr face 2 3) + (setf face (cat:suspension-face (cat:face m))) + (dotimes (i 5) (print (funcall face i 4 'm3))) + (dotimes (i 6) (print (funcall face i 5 'mm4))) + (cat:check-faces #'cat:s-cmpr face 4 'm3) + (cat:check-faces #'cat:s-cmpr face 5 'mm4))) + + +(test suspension1 + (cat:cat-init) + (let* ((d (cat:deltab)) + (sd (cat:suspension d)) + (m (cat:moore 2 1)) + (sm (cat:suspension m))) + (setf sd (cat:suspension d)) + (cat:? sd 3 7) + (cat:cprd sd 3 7) + (cat:face sd 3 3 7) + (cat:face sd 2 3 7) + (cat:homology sm 0 5) + (setf ssm (cat:suspension sm)) + (cat:homology ssm 0 6))) + + +(test suspension-intr + (cat:cat-init) + (let* ((f (cat:idnt-mrph (cat:deltab))) + (sf (cat:suspension-intr f)) + (d (cat:dffr (cat:deltab))) + (sd (cat:suspension-intr d))) + (funcall sf (cat:cmbn 0 3 :s-bsgn)) + (funcall sf (cat:cmbn 2 4 3)) + (funcall sd (cat:cmbn 0 3 :s-bsgn)) + (funcall sd (cat:cmbn 2 4 3)) + (funcall sd (cat:cmbn 3 4 7)))) + + +(test suspension2 + (cat:cat-init) + (let* ((f (cat:idnt-mrph (cat:deltab))) + (sf (cat:suspension f)) + (d (cat:dffr (cat:deltab))) + (sd (cat:suspension d))) + (cat:? sf (cat:cmbn 0 3 :s-bsgn)) + (cat:? sf (cat:cmbn 2 4 3)) + (cat:? sd (cat:cmbn 0 3 :s-bsgn)) + (cat:? sd (cat:cmbn 2 4 3)) + (cat:? sd (cat:cmbn 3 4 7)))) + + +(test suspension3 + (cat:cat-init) + (let* ((rdct (cat:ez (cat:deltab) (cat:deltab))) + (srdct (cat:suspension rdct))) + (cat:pre-check-rdct srdct) + (setf cat:*tc* (cat:cmbn 4 1 (cat:crpr 0 15 0 15))) + (setf cat:*bc* (cat:cmbn 4 1 (cat:tnpr 0 1 3 15) + 5 (cat:tnpr 1 3 2 7) + 10 (cat:tnpr 2 7 1 3) + 100 (cat:tnpr 3 15 0 1))) + (check-rdct))) + + +(test suspension4 + (cat:cat-init) + (let ((sk (cat:suspension (cat:k-z 2)))) + (cat:homology sk 0 10)))