;;;  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 crpr1 crpr2))
              (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 )
|#





Home page.