;;;  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)
|#




Home page.