463 lines
16 KiB
Common Lisp
463 lines
16 KiB
Common Lisp
;;; 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))
|
|
(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)))))) |