;;;  CHCM-ELEMENTARY-OP  CHCM-ELEMENTARY-OP  CHCM-ELEMENTARY-OP  CHCM-ELEMENTARY-OP
;;;  CHCM-ELEMENTARY-OP  CHCM-ELEMENTARY-OP  CHCM-ELEMENTARY-OP  CHCM-ELEMENTARY-OP
;;;  CHCM-ELEMENTARY-OP  CHCM-ELEMENTARY-OP  CHCM-ELEMENTARY-OP  CHCM-ELEMENTARY-OP

(IN-PACKAGE "COMMON-LISP-USER")

(PROVIDE "chcm-elementary-op")

(DEFUN Z-CHCM ()
   (the chain-complex
      (build-chcm
         :cmpr #'(lambda (gnrt1 gnrt2)
                    (declare (ignore gnrt1 gnrt2))
                    (the cmpr :equal))
         :basis #'(lambda (n)
                     (declare (type fixnum n))
                     (the list
                        (if (zerop n)
                           (list :Z-gnrt)
                           +empty-list+)))
         :bsgn :Z-gnrt
         :intr-dffr #'zero-intr-dffr
         :strt :cmbn
         :orgn '(Z-chcm))))

(DEFUN ZERO-MRPH (chcm1 &optional (chcm2 chcm1) (degr 0))
   (declare (type chain-complex chcm1 chcm2)
            (type fixnum degr))
   (the morphism
      (build-mrph
         :sorc chcm1 :trgt chcm2 :degr degr
         :intr #'(lambda (cmbn)
                    (declare (type cmbn cmbn))
                    (zero-cmbn (+ (cmbn-degr cmbn) degr)))
         :strt :cmbn
         :orgn `(zero-mrph ,chcm1 ,chcm2 ,degr))))

#|
  (cat-init)
  (setf z (zero-mrph (Z-chcm) (Z-chcm) 2))
  (gnrt-? z 0 :z-gnrt)
  (cmbn-? z (cmbn 3))
  (setf z2 (zero-mrph (Z-chcm) (Z-chcm) 2))
  (eq z z2)
  (setf z3 (zero-mrph (Z-chcm) (Z-chcm) 3))
  (gnrt-? z3 0 :z-gnrt)
  (eq z z3))
|#



(DEFUN IDNT-MRPH (chcm)
   (declare (type chain-complex chcm))
   (the morphism
      (build-mrph
         :sorc chcm :trgt chcm :degr 0
         :intr #'identity
         :strt :cmbn
         :orgn `(idnt-mrph ,chcm))))

#|
  (setf zi (idnt-mrph (Z-chcm)))
  (gnrt-? zi 0 :z-gnrt)
  (setf zi2 (idnt-mrph (Z-chcm)))
  (eq zi zi2))
|#

(DEFUN OPPS (mrph)
   (declare (type morphism mrph))
   (the morphism
      (with-slots (sorc trgt degr) mrph
         (build-mrph
            :sorc sorc :trgt trgt :degr degr
            :intr #'(lambda (cmbn)
                       (declare (type cmbn cmbn))
                       (cmbn-opps (cmbn-? mrph cmbn)))
            :strt :cmbn
            :orgn `(opps ,mrph)))))

#|
  (cat-init)
  (setf -zi (opps (idnt-mrph (Z-chcm))))
  (gnrt-? -zi 0 :z-gnrt)
  (setf -zi2 (opps (idnt-mrph (Z-chcm))))
  (eq -zi -zi2))
|#

(DEFMETHOD CMPS ((chcm1 chain-complex) (chcm2 chain-complex) &optional strt)
   (declare (type (or strt null) strt))
   (the morphism
      (cmps (dffr chcm1) (dffr chcm2) strt)))

(DEFMETHOD CMPS ((chcm1 chain-complex) (mrph2 morphism) &optional strt)
   (declare (type (or strt null) strt))
   (the morphism
      (cmps (dffr chcm1) mrph2 strt)))

(DEFMETHOD CMPS ((mrph1 morphism) (chcm2 chain-complex) &optional strt)
   (declare (type (or strt null) strt))
   (the morphism
      (cmps mrph1 (dffr chcm2) strt)))

(DEFMETHOD CMPS ((mrph1 morphism) (mrph2 morphism) &optional strt)
   (declare (type (or strt null) strt))
   (the morphism
      (with-slots ((sorc1 sorc) (trgt1 trgt) (degr1 degr) (strt1 strt)) mrph1
         (declare
            (type chain-complex sorc1 trgt1)
            (fixnum degr1)
            (type strt strt1))
      (with-slots ((sorc2 sorc) (trgt2 trgt) (degr2 degr) (strt2 strt)) mrph2
         (declare
            (type chain-complex sorc2 trgt2)
            (fixnum degr2)
            (type strt strt2))
         (unless (eq (grmd sorc1) (grmd trgt2))
            (error "In 2MRPH-CMPS, the morphisms ~A and ~A may not be composed (cf source and target)."
               mrph1 mrph2))
         (unless strt
            (setf strt (if (and (eq strt1 :gnrt)
                                (eq strt2 :gnrt))
                          :gnrt
                          :cmbn)))
         (when (or (eq (first (orgn mrph1)) 'zero-mrph)
                   (eq (first (orgn mrph2)) 'zero-mrph))
            (return-from cmps
               (zero-mrph sorc2 trgt1 (+ degr1 degr2))))
         (when (eq (first (orgn mrph1)) 'idnt-mrph)
            (return-from cmps mrph2))
         (when (eq (first (orgn mrph2)) 'idnt-mrph)
            (return-from cmps mrph1))
         (ecase strt
            (:cmbn (build-mrph
                      :sorc sorc2 :trgt trgt1 :degr (+ degr1 degr2)
                      :intr #'(lambda (cmbn)
                                 (declare (type cmbn cmbn))
                                 (the cmbn
                                    (cmbn-? mrph1 (cmbn-? mrph2 cmbn))))
                      :strt :cmbn :orgn `(2mrph-cmps ,mrph1 ,mrph2 ,strt)))
            (:gnrt (build-mrph
                      :sorc sorc2 :trgt trgt1 :degr (+ degr1 degr2)
                      :intr #'(lambda (degr gnrt)
                                 (declare
                                    (type fixnum degr)
                                    (type gnrt gnrt))
                                 (the cmbn
                                    (cmbn-? mrph1 (gnrt-? mrph2 degr gnrt))))
                      :strt :gnrt :orgn `(2mrph-cmps ,mrph1 ,mrph2 ,strt))))))))

#|
  (cat-init)
  (setf cc (build-chcm :cmpr #'f-cmpr
                       :basis :locally-effective
                       :bsgn 0
                       :intr-dffr #'(lambda (cmbn)
                                       (cmbn (1- (cmbn-degr cmbn))))
                       :strt :cmbn
                       :orgn '(Z of Z)))
  (setf *n* 5)
  (defun ff (degr i)
     (do ((*2n* (ash *n* 1))
          (rslt +empty-list+
                (cons (cons (let ((cffc (- (random *2n*) *n*)))
                               (if (minusp cffc) cffc (1+ cffc)))
                            (decf gnrt (1+ (random *n*))))
                      rslt))
          (gnrt i)
          (k 0 (1+ k)))
         ((= k *n*)
          (make-cmbn
             :degr 0
             :list rslt))))
  (setf mrph (build-mrph :sorc cc :trgt cc :degr 0
             :intr #'ff :strt :gnrt :orgn '(test)))
  (setf mrph2 (2mrph-cmps mrph mrph :gnrt))
  (gnrt-? mrph2 0 0)
  (dotimes (i 5)
     (print (gnrt-? mrph2 0 i)))
  (setf mrph (build-mrph :sorc cc :trgt cc :degr 0
             :intr #'ff :strt :gnrt :orgn '(test)))
  (setf mrph3 (cmps mrph mrph :cmbn))
  (gnrt-? mrph3 0 0)
  (dotimes (i 5)
     (print (gnrt-? mrph3 0 i)))
  (setf mrph33 (cmps mrph mrph :cmbn))
  (eq mrph3 mrph33))
|#

(DEFUN N-MRPH-INTR (n mrph)
  (declare
    (fixnum n)
    (type morphism mrph))
  (flet ((rslt (cmbn)
       (declare (type cmbn cmbn))
       (n-cmbn n (cmbn-? mrph cmbn))))
     (the intr-mrph #'rslt)))

(DEFUN N-MRPH (n mrph)
  (declare
    (fixnum n)
    (type morphism mrph))
  (the morphism
    (with-slots (sorc trgt degr) mrph
      (declare
        (type chain-complex sorc trgt)
    (fixnum degr))
      (build-mrph
        :sorc sorc :trgt trgt :degr degr
    :intr (n-mrph-intr n mrph) :strt :cmbn
    :orgn `(n-mrph ,n ,mrph)))))

#|
  (setf s3 (sphere 3))
  (setf ch3 (chml-clss s3 3))
  (setf 2ch3 (n-mrph 2 ch3))
  (setf f3 (z-whitehead s3 2ch3))
  (setf x (fibration-total f3))
  (homology x 0 10)
  (setf k (k-z 3))
  (setf ch3 (chml-clss k 3))
  (setf 2ch3 (n-mrph 2 ch3))
  (setf f3 (z-whitehead k 2ch3))
  (setf x (fibration-total f3))
  (homology x 0 10)
|#

(DEFMETHOD ADD ((mrph1 morphism) (mrph2 morphism) &optional strt)
   (declare (type (or null strt) strt))
   (the morphism
      (with-slots ((sorc1 sorc) (trgt1 trgt) (degr1 degr) (strt1 strt)) mrph1
         (declare
            (type chain-complex sorc1 trgt1)
            (fixnum degr1)
            (type strt strt1))
      (with-slots ((sorc2 sorc) (trgt2 trgt) (degr2 degr) (strt2 strt)) mrph2
         (declare
            (type chain-complex sorc2 trgt2)
            (fixnum degr2)
            (type strt strt2))
         (unless (and (eq (grmd sorc1) (grmd sorc2))
                      (eq (grmd trgt1) (grmd trgt2))
                      (= degr1 degr2))
            (error "In 2MRPH-ADD, ~A and ~A may not be added." mrph1 mrph2))
         (when (eq (first (orgn mrph1)) 'zero-mrph)
            (return-from add mrph2))
         (when (eq (first (orgn mrph2)) 'zero-mrph)
            (return-from add mrph1))
         (unless strt
            (setf strt
                  (if (and (eq strt1 :gnrt)
                           (eq strt2 :gnrt))
                     :gnrt
                     :cmbn)))
         (when (or (eq (first (orgn mrph1)) 'idnt-mrph)
                   (eq (first (orgn mrph2)) 'idnt-mrph))
            (setf strt :cmbn))
         (let ((cmpr (cmpr trgt1)))
            (declare (type cmprf cmpr))
            (ecase strt
               (:gnrt (build-mrph
                         :sorc sorc1 :trgt trgt1 :degr degr1
                         :intr #'(lambda (degr gnrt)
                                    (declare (type fixnum degr) (type gnrt gnrt))
                                    (2cmbn-add cmpr
                                       (gnrt-? mrph1 degr gnrt)
                                       (gnrt-? mrph2 degr gnrt)))
                         :strt :gnrt
                         :orgn `(2mrph-add ,mrph1 ,mrph2 ,strt)))
               (:cmbn (build-mrph
                         :sorc sorc1 :trgt trgt1 :degr degr1
                         :intr #'(lambda (cmbn)
                                    (declare (type cmbn cmbn))
                                    (2cmbn-add cmpr
                                       (cmbn-? mrph1 cmbn)
                                       (cmbn-? mrph2 cmbn)))
                         :strt :cmbn
                         :orgn `(2mrph-add ,mrph1 ,mrph2 ,strt)))))))))

#|
  (cat-init)
  (setf cc (build-chcm :cmpr #'f-cmpr
                       :basis :locally-effective
                       :bsgn 0
                       :intr-dffr #'(lambda (cmbn)
                                       (cmbn (1- (cmbn-degr cmbn))))
                       :strt :cmbn
                       :orgn '(Z of Z)))
  (setf *n* 10)
  (defun ff (degr i)
     (do ((*2n* (ash *n* 1))
          (rslt +empty-list+
                (cons (cons (let ((cffc (- (random *2n*) *n*)))
                               (if (minusp cffc) cffc (1+ cffc)))
                            (decf gnrt (1+ (random *n*))))
                      rslt))
          (gnrt i)
          (k 0 (1+ k)))
         ((= k *n*)
          (make-cmbn
             :degr 0
             :list rslt))))
  (setf mrph1 (build-mrph :sorc cc :trgt cc :degr 0
                          :intr #'ff :strt :gnrt :orgn '(test)))
  (setf mrph2 (build-mrph :sorc cc :trgt cc :degr 0
                          :intr #'ff :strt :gnrt :orgn '(test2)))
  (setf mrph3 (add mrph1 mrph2 :gnrt))
  (setf +too-much-time+ -1)
  (gnrt-? mrph1 0 0)
  (gnrt-? mrph2 0 0)
  (gnrt-? mrph3 0 0)
  (setf mrph4 (add mrph1 mrph2 :cmbn))
  (gnrt-? mrph4 0 0)
  (setf mrph44 (add mrph1 mrph2 :cmbn))
  (eq mrph4 mrph44))
|#

(DEFMETHOD SBTR ((mrph1 morphism) (mrph2 morphism) &optional strt)
   (declare (type (or null strt) strt))
   (the morphism
      (with-slots ((sorc1 sorc) (trgt1 trgt) (degr1 degr) (strt1 strt)) mrph1
         (declare
            (type chain-complex sorc1 trgt1)
            (fixnum degr1)
            (type strt strt1))
      (with-slots ((sorc2 sorc) (trgt2 trgt) (degr2 degr) (strt2 strt)) mrph2
         (declare
            (type chain-complex sorc2 trgt2)
            (fixnum degr2)
            (type strt strt2))
         (unless (and (eq (grmd sorc1) (grmd sorc2))
                      (eq (grmd trgt1) (grmd trgt2))
                      (= degr1 degr2))
            (error "In 2MRPH-SBTR, ~A and ~A may not be subtracteded." mrph1 mrph2))
         (when (eq (first (orgn mrph1)) 'zero-mrph)
            (return-from sbtr mrph2))
         (when (eq (first (orgn mrph2)) 'zero-mrph)
            (return-from sbtr mrph1))
         (unless strt
            (setf strt
                  (if (and (eq strt1 :gnrt)
                           (eq strt2 :gnrt))
                     :gnrt
                     :cmbn)))
         (when (or (eq (first (orgn mrph1)) 'idnt-mrph)
                   (eq (first (orgn mrph2)) 'idnt-mrph))
            (setf strt :cmbn))
         (let ((cmpr (cmpr trgt1)))
            (declare (type cmprf cmpr))
            (ecase strt
               (:gnrt (build-mrph
                         :sorc sorc1 :trgt trgt1 :degr degr1
                         :intr #'(lambda (degr gnrt)
                                    (declare (type fixnum degr) (type gnrt gnrt))
                                    (2cmbn-sbtr cmpr
                                       (gnrt-? mrph1 degr gnrt)
                                       (gnrt-? mrph2 degr gnrt)))
                         :strt :gnrt
                         :orgn `(2mrph-sbtr ,mrph1 ,mrph2 ,strt)))
               (:cmbn (build-mrph
                         :sorc sorc1 :trgt trgt1 :degr degr1
                         :intr #'(lambda (cmbn)
                                    (declare (type cmbn cmbn))
                                    (2cmbn-sbtr cmpr
                                       (cmbn-? mrph1 cmbn)
                                       (cmbn-? mrph2 cmbn)))
                         :strt :cmbn
                         :orgn `(2mrph-sbtr ,mrph1 ,mrph2 ,strt)))))))))

#|
  (cat-init)
  (setf cc (build-chcm :cmpr #'f-cmpr
                       :basis :locally-effective
                       :bsgn 0
                       :intr-dffr #'(lambda (cmbn)
                                       (cmbn (1- (cmbn-degr cmbn))))
                       :strt :cmbn
                       :orgn '(Z of Z)))
  (setf *n* 10)
  (defun ff (degr i)
     (do ((*2n* (ash *n* 1))
          (rslt +empty-list+
                (cons (cons (let ((cffc (- (random *2n*) *n*)))
                               (if (minusp cffc) cffc (1+ cffc)))
                            (decf gnrt (1+ (random *n*))))
                      rslt))
          (gnrt i)
          (k 0 (1+ k)))
         ((= k *n*)
          (make-cmbn
             :degr 0
             :list rslt))))
  (setf mrph1 (build-mrph :sorc cc :trgt cc :degr 0
                          :intr #'ff :strt :gnrt :orgn '(test)))
  (setf mrph2 (build-mrph :sorc cc :trgt cc :degr 0
                          :intr #'ff :strt :gnrt :orgn '(test2)))
  (setf mrph3 (sbtr mrph1 mrph2 :gnrt))
  (setf +too-much-time+ -1)
  (gnrt-? mrph1 0 0)
  (gnrt-? mrph2 0 0)
  (gnrt-? mrph3 0 0)
  (setf mrph4 (sbtr mrph1 mrph2 :cmbn))
  (gnrt-? mrph4 0 0)
  (setf mrph44 (sbtr mrph1 mrph2 :cmbn))
  (eq mrph4 mrph44))
|#

(DEFUN CHANGE-SORC-TRGT (mrph &key new-sorc new-trgt)
   (declare
      (type morphism mrph)
      (type (or null chain-complex) new-sorc new-trgt))
   (the morphism
      (with-slots (sorc trgt degr intr strt) mrph
         (build-mrph
            :sorc (or new-sorc sorc)
            :trgt (or new-trgt trgt)
            :degr degr
            :intr intr
            :strt strt
            :orgn `(change-sorc-trgt ,mrph ,new-sorc ,new-trgt)))))

(DEFUN DSTR-CHANGE-SORC-TRGT (mrph &key new-sorc new-trgt)
   (declare
      (type morphism mrph)
      (type (or null chain-complex) new-sorc new-trgt)
      (list new-orgn))
   (the morphism
      (with-slots (sorc trgt) mrph
         (when new-sorc
            (setf sorc new-sorc))
         (when new-trgt
            (setf trgt new-trgt))
         mrph)))

(DEFMETHOD ADD ((chcm chain-complex) (perturbation morphism) &optional strt)
   (declare (type (or strt null) strt))
   (the chain-complex
      (with-slots (cmpr basis bsgn dffr) chcm
         (declare
            (type cmprf cmpr)
            (type basis basis)
            (type morphism dffr))
      (with-slots (sorc trgt degr) perturbation
         (declare
            (type chain-complex sorc trgt)
            (fixnum degr))
         (unless (and (eq (grmd sorc) (grmd chcm))
                      (eq (grmd trgt) (grmd chcm))
                      (= degr -1))
            (error "In (METHOD ADD CHAIN-COMPLEX MORPHISM), the data are not coherent."))
         (let ((new-dffr (add dffr perturbation strt)))
            (declare (type intr-mrph new-dffr))
            (let ((new-chcm (build-chcm
                               :cmpr cmpr
                               :basis basis
                               :intr-dffr (intr new-dffr)
                               :strt (strt new-dffr)
                               :orgn  `(add ,chcm ,perturbation))))
          (declare (type chain-complex new-chcm))
          (if (slot-boundp chcm 'bsgn)
         (setf (slot-value new-chcm 'bsgn) bsgn)
         (slot-makunbound new-chcm 'bsgn))
          (setf (slot-value new-chcm 'grmd) (grmd chcm))
          new-chcm))))))



Home page.