diff --git a/package.lisp b/package.lisp index 54dd620..4c39369 100644 --- a/package.lisp +++ b/package.lisp @@ -4,6 +4,10 @@ (:use #:cl) (:export KENZO-VERSION + ;; UFO + + EFHM + ;; kenzo.lisp *BC* @@ -23,11 +27,16 @@ ;; bar.lisp ABAR + BAR BAR-BASIS-LENGTH BAR-BASIS BAR-CMPR + BAR-HRZN-DFFR BAR-INTR-HRZN-DFFR BAR-INTR-VRTC-DFFR + HMTP-VRTC-BAR-INTR + MRPH-VRTC-BAR-INTR + NCMBN-BAR VRTC-BAR ;; bicones.lisp @@ -145,6 +154,11 @@ TRIVIAL-HMEQ TRIVIAL-RDCT + ;; eilenberg-zilber.lisp + + AW + EZ + ;; fibrations.lisp FIBRATION-TOTAL @@ -178,7 +192,9 @@ CMBN-ZERO-P CMPR CPRD + CRPR D + F DFFR DGNL GNRT diff --git a/src/bar.lisp b/src/bar.lisp index 60804a9..7b4002c 100644 --- a/src/bar.lisp +++ b/src/bar.lisp @@ -299,33 +299,6 @@ :intr (bar-intr-hrzn-dffr aprd) :strt :gnrt :orgn `(bar-hrzn-dffr ,algb))))) -#| -(cat-init) -(setf h (bar-hrzn-dffr (k-z-1))) -(defun random-abar (tot-degr~ max-degr) - (do ((rslt nil) - (cum-degr 0 (+ cum-degr degr 1)) - (degr)) - ((>= cum-degr tot-degr~) (make-abar :list rslt)) - (setf degr (1+ (random max-degr))) - (push (brgn (1+ degr) - (let ((list (make-list degr))) - (mapl - #'(lambda (sublist) - (setf (car sublist) (- (random 21) 10))) - list) - list)) - rslt))) -(dotimes (i 10) (print (random-abar 10 5))) -(setf abar (random-abar 10 5)) -(? h (apply #'+ (mapcar #'car (abar-list abar))) abar) -(? h (? h (apply #'+ (mapcar #'car (abar-list abar))) abar)) -(dotimes (i 10) - (let ((abar (random-abar 10 3))) - (print abar) - (print (? h (apply #'+ (mapcar #'car (abar-list abar))) abar)) - (print (? h (? h (apply #'+ (mapcar #'car (abar-list abar))) abar))))) -|# (DEFUN BAR-INTR-DFFR (vrtc-dffr hrzn-dffr) (declare (type morphism vrtc-dffr hrzn-dffr)) @@ -340,8 +313,10 @@ (cmbn-list (gnrt-? vrtc-dffr degr abar)))))) (the intr-mrph #'rslt))) + (DEFGENERIC BAR (algebra-or-hmeq)) + (DEFMETHOD BAR ((algebra algebra)) (let ((vrtc-bar (vrtc-bar algebra)) (bar-hrzn-dffr (bar-hrzn-dffr algebra))) @@ -359,32 +334,6 @@ (setf (slot-value rslt 'grmd) (grmd vrtc-bar)) rslt)))) -#| -(cat-init) -(setf b (bar (k-z-1))) -(defun random-abar (tot-degr~ max-degr) - (do ((rslt nil) - (cum-degr 0 (+ cum-degr degr 1)) - (degr)) - ((>= cum-degr tot-degr~) (make-abar :list rslt)) - (setf degr (1+ (random max-degr))) - (push (brgn (1+ degr) - (let ((list (make-list degr))) - (mapl - #'(lambda (sublist) - (setf (car sublist) (- (random 21) 10))) - list) - list)) - rslt))) -(setf abar (random-abar 10 3)) -(? b (apply #'+ (mapcar #'car (abar-list abar))) abar) -(? b (? b (apply #'+ (mapcar #'car (abar-list abar))) abar)) -(dotimes (i 10) - (let ((abar (random-abar 10 3))) - (print abar) - (print (? b (apply #'+ (mapcar #'car (abar-list abar))) abar)) - (print (? b (? b (apply #'+ (mapcar #'car (abar-list abar))) abar))))) -|# (DEFUN CMBN-ABAR-CMBN-TNPR (cmbn abar-cmbn) (declare (type cmbn cmbn abar-cmbn)) @@ -403,14 +352,21 @@ (declare (type brgn brgn1)) (mapcar #'(lambda (termr) - (declare (type term termr)) - (with-term (cffcr abarr) termr - (term (* cffc1 cffcr) - (make-abar - :list (cons brgn1 (abar-list abarr)))))) + (declare (type term + termr)) + (with-term (cffcr abarr) + termr + (term + (* cffc1 cffcr) + (make-abar + :list (cons + brgn1 + (abar-list + abarr)))))) listr)))) list1)))))) + (DEFUN NCMBN-BAR (cmbn-list) (declare (list cmbn-list)) (the cmbn @@ -420,12 +376,7 @@ (cmbn-abar-cmbn-tnpr (first cmbn-list) (ncmbn-bar (rest cmbn-list)))))) -#| -(ncmbn-bar nil) -(ncmbn-bar (list (cmbn 3 2 'a 3 'b))) -(ncmbn-bar (list (cmbn 1 2 'a 3 'b) (cmbn 2 4 'c 5 'd))) -(ncmbn-bar (list (cmbn 1 2 'a 3 'b) (cmbn 1 4 'c 5 'd) (cmbn 1 6 'e 7 'f)))) -|# + (DEFUN MRPH-VRTC-BAR-INTR (mrph) (declare (type morphism mrph)) @@ -442,14 +393,6 @@ (abar-list abar)))))) (the intr-mrph #'rslt))) -#| -(setf cc (build-chcm :cmpr #'f-cmpr :strt :cmbn)) -(setf m (build-mrph :sorc cc :trgt cc :degr 0 :intr - #'(lambda (degr gnrt) (cmbn degr 2 gnrt 3 (1+ gnrt))) - :strt :gnrt :orgn '(test))) -(setf r (mrph-vrtc-bar-intr m)) -(funcall r 4 (abar 2 3 2 4)) -|# (DEFMETHOD VRTC-BAR ((mrph morphism)) (the morphism @@ -463,12 +406,6 @@ :strt :gnrt :orgn `(vrtc-bar ,mrph))))) -#| -(cat-init) -(setf f (aw (soft-delta-infinity) (soft-delta-infinity))) -(setf cf (vrtc-bar f)) -(? cf 6 (abar 3 (crpr 0 (d 7) 0 (d 7)) 3 (crpr 0 (d 56) 0 (d 56)))) -|# (DEFUN HMTP-VRTC-BAR-INTR (h gf) (declare (type morphism h gf)) @@ -484,11 +421,13 @@ (type brgn brgn1) (list rest2)) (with-brgn (degr1 gnrt1) brgn1 - (let ((h-gnrt1 (cmbn-list (gnrt-? h (1- degr1) gnrt1))) + (let ((h-gnrt1 (cmbn-list (gnrt-? h (1- degr1) + gnrt1))) (h-rest2 (rslt (- degr degr1) rest2)) (degr1+1 (1+ degr1)) (rest-sign (-1-expt-n degr1)) - (gf-gnrt1 (cmbn-list (gnrt-? gf (1- degr1) gnrt1)))) + (gf-gnrt1 (cmbn-list (gnrt-? gf (1- degr1) + gnrt1)))) (declare (fixnum degr1+1 rest-sign) (type icmbn h-gnrt1 h-rest2 gf-gnrt1)) @@ -500,9 +439,13 @@ (mapcar #'(lambda (term2) (declare (type term term2)) - (with-term (cffc2 iabar2) term2 - (term (* rest-sign cffc1 cffc2) - (cons (brgn degr1 gnrt11) iabar2)))) + (with-term (cffc2 iabar2) + term2 + (term (* rest-sign cffc1 + cffc2) + (cons + (brgn degr1 gnrt11) + iabar2)))) h-rest2))) gf-gnrt1) (mapcar @@ -510,7 +453,9 @@ (declare (type term term1)) (with-term (cffc1 gnrt11) term1 (term (- cffc1) - (cons (brgn degr1+1 gnrt11) rest2)))) + (cons + (brgn degr1+1 gnrt11) + rest2)))) h-gnrt1))))))) (the intr-mrph #'(lambda (degr abar) @@ -529,14 +474,6 @@ (term cffc (make-abar :list iabar)))) (rslt degr (abar-list abar)))))))) -#| -(cat-init) -(setf ez (ez (delta-infinity) (delta-infinity))) -(setf h (h ez) gf (cmps (g ez) (f ez))) -(setf r (hmtp-vrtc-bar-intr h gf)) -(funcall r 3 (abar 3 (crpr 0 7 0 7))) -(funcall r 9 (abar 3 (crpr 0 7 0 7) 3 (crpr 0 14 0 14) 3 (crpr 0 14 0 14))) -|# (DEFUN HMTP-VRTC-BAR (h gf) (declare (type morphism h gf)) @@ -567,72 +504,6 @@ :h (hmtp-vrtc-bar h (cmps g f)) :orgn `(vrtc-bar ,rdct)))))) -#| -(cat-init) -(setf tcc (build-chcm - :cmpr #'s-cmpr - :basis #'(lambda (degr) '(a b c d)) - :bsgn 'd - :intr-dffr #'(lambda (degr gnrt) - (ecase gnrt - (a (cmbn (1- degr) 1 'b 1 'd)) - ((b d) (cmbn (1- degr))) - (c (cmbn (1- degr) 1 'd)))) - :strt :gnrt - :orgn '(tcc))) -(setf bcc (build-chcm - :cmpr #'s-cmpr - :basis #'(lambda (degr) '(c d)) - :bsgn 'd - :intr-dffr #'(lambda (degr gnrt) - (ecase gnrt - (d (cmbn (1- degr))) - (c (cmbn (1- degr) 1 'd)))) - :strt :gnrt - :orgn '(bcc))) -(setf f (build-mrph :sorc tcc :trgt bcc :degr 0 - :intr #'(lambda (degr gnrt) - (ecase gnrt - (a (cmbn degr 1 'c 1 'd)) - (b (cmbn degr)) - ((c d) (cmbn degr 1 gnrt)))) - :strt :gnrt :orgn '(f))) -(setf g (build-mrph :sorc bcc :trgt tcc :degr 0 - :intr #'identity :strt :cmbn :orgn '(g))) -(setf h (build-mrph :sorc tcc :trgt tcc :degr +1 - :intr #'(lambda (degr gnrt) - (ecase gnrt - ((a b) (cmbn (1+ degr) 1 'a -1 'b -1 'c -1 'd)) - ((c d) (cmbn (1+ degr))))) - :strt :gnrt :orgn '(h))) -(setf rdct (build-rdct :f f :g g :h h :orgn '(rdct))) -(tcc rdct 3 'a) -(g rdct (f rdct 3 'a)) -(h rdct 3 'a) -(setf bar (vrtc-bar rdct)) -(pre-check-rdct bar) -(defun aleat-tc () - (do ((tdegr 0 (+ tdegr degr)) - (degr (+ 2 (random 3)) (+ 2 (random 3))) - (gnrt (intern (coerce (vector (code-char (+ 65 (random 4)))) 'string)) - (intern (coerce (vector (code-char (+ 65 (random 4)))) 'string))) - (rslt nil (cons (brgn degr gnrt) rslt))) - ((> tdegr 10) (setf *tc* (cmbn tdegr 1 (make-abar :list rslt)))))) -(aleat-tc) -(defun aleat-bc () - (do ((tdegr 0 (+ tdegr degr)) - (degr (+ 2 (random 3)) (+ 2 (random 3))) - (gnrt (intern (coerce (vector (code-char (+ 67 (random 2)))) 'string)) - (intern (coerce (vector (code-char (+ 67 (random 2)))) 'string))) - (rslt nil (cons (brgn degr gnrt) rslt))) - ((> tdegr 10) (setf *bc* (cmbn tdegr 1 (make-abar :list rslt)))))) -(aleat-bc) -(defun c () - (aleat-tc) - (aleat-bc) - (check-rdct)) -(loop (c)) ;; degrees >= 15 is possible => error. -|# (DEFMETHOD VRTC-BAR ((hmeq homotopy-equivalence)) (the homotopy-equivalence diff --git a/test/bar-test.lisp b/test/bar-test.lisp index bbe1881..98bbf1d 100644 --- a/test/bar-test.lisp +++ b/test/bar-test.lisp @@ -81,6 +81,23 @@ (cat:abar-list abar))) abar)))))))) + +(defun random-abar1 (tot-degr~ max-degr) + (do ((rslt nil) + (cum-degr 0 (+ cum-degr degr 1)) + (degr)) + ((>= cum-degr tot-degr~) (cat:make-abar :list rslt)) + (setf degr (1+ (random max-degr))) + (push (cat:brgn (1+ degr) + (let ((list (make-list degr))) + (mapl + #'(lambda (sublist) + (setf (car sublist) (- (random 21) 10))) + list) + list)) + rslt))) + + #| (test bar-intr-hrzn-dffr (let* ((k (cat:k-z-1)) @@ -90,4 +107,174 @@ (funcall r 6 (cat:abar 3 '(2 3) 3 '(-2 -3))) (funcall r 9 (cat:abar 3 '(2 3) 3 '(-2 -3) 3 '(2 3))) (funcall r 11 (cat:abar 3 '(2 3) 3 '(-2 -3) 2 '(-2) 3 '(-2 -3))))) + + +(test bar-hrzn-dffr + (progn + (cat:cat-init) + (let ((h (cat:bar-hrzn-dffr (cat:k-z-1))) + (abar)) + (dotimes (i 10) + (print (random-abar1 10 5))) + (setf abar (random-abar1 10 5)) + (cat:? h (apply #'+ (mapcar #'car (cat:abar-list abar))) abar) + (cat:? h (cat:? h (apply #'+ (mapcar #'car + (cat:abar-list abar))) abar)) + (dotimes (i 10) + (setf abar (random-abar1 10 3)) + (print abar) + (print (cat:? h (apply #'+ (mapcar #'car (cat:abar-list abar))) + abar)) + (print (cat:? h (cat:? h (apply #'+ (mapcar #'car + (cat:abar-list abar))) + abar))))))) + + +(test bar + (progn + (cat:cat-init) + (let ((b (cat:bar (cat:k-z-1))) + (abar (random-abar1 10 3))) + (cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar))) abar) + (cat:? b (cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar))) + abar)) + (dotimes (i 10) + (let ((abar (random-abar1 10 3))) + (print abar) + (print (cat:? b (apply #'+ (mapcar #'car (cat:abar-list abar))) + abar)) + (print (cat:? b + (cat:? b + (apply #'+ (mapcar #'car + (cat:abar-list abar))) + abar)))))))) + +|# + +(test ncmbn-bar + (cat:ncmbn-bar nil) + (cat:ncmbn-bar (list (cat:cmbn 3 2 'a 3 'b))) + (cat:ncmbn-bar (list (cat:cmbn 1 2 'a 3 'b) (cat:cmbn 2 4 'c 5 'd))) + (cat:ncmbn-bar (list (cat:cmbn 1 2 'a 3 'b) (cat:cmbn 1 4 'c 5 'd) + (cat:cmbn 1 6 'e 7 'f)))) + +#| +(test mrph-vrtc-bar-intr + (let* ((cc (cat:build-chcm :cmpr #'cat:f-cmpr :strt :cmbn)) + (m (cat:build-mrph :sorc cc :trgt cc :degr 0 :intr + #'(lambda (degr gnrt) + (cat:cmbn degr 2 gnrt 3 (1+ gnrt))) + :strt :gnrt :orgn '(test))) + (r (cat:mrph-vrtc-bar-intr m))) + (funcall r 4 (cat:abar 2 3 2 4)))) +|# + +(test vrtc-bar + (progn + (cat:cat-init) + (let* ((f (cat:aw (cat:soft-delta-infinity) + (cat:soft-delta-infinity))) + (cf (cat:vrtc-bar f))) + (cat:? cf 6 (cat:abar 3 (cat:crpr 0 (cat:d 7) 0 (cat:d 7)) 3 + (cat:crpr 0 (cat:d 56) 0 (cat:d 56))))))) + +(test hmtp-vrtc-bar-intr + (progn + (cat:cat-init) + (let* ((ez (cat:ez (cat:delta-infinity) (cat:delta-infinity))) + (h (cat:h ez)) + (gf (cat:cmps (cat:g ez) (cat:f ez))) + (r (cat:hmtp-vrtc-bar-intr h gf))) + (funcall r 3 (cat:abar 3 (cat:crpr 0 7 0 7))) + (funcall r 9 (cat:abar 3 (cat:crpr 0 7 0 7) 3 (cat:crpr 0 14 0 14) + 3 (cat:crpr 0 14 0 14)))))) + + +(defun aleat-tc () + (do ((tdegr 0 (+ tdegr degr)) + (degr (+ 2 (random 3)) (+ 2 (random 3))) + (gnrt (intern (coerce (vector (code-char (+ 65 (random 4)))) 'string)) + (intern (coerce (vector (code-char (+ 65 (random 4)))) 'string))) + (rslt nil (cons (cat:brgn degr gnrt) rslt))) + ((> tdegr 10) (setf cat:*tc* (cat:cmbn tdegr 1 (cat:make-abar + :list rslt)))))) + + +(defun aleat-bc () + (do ((tdegr 0 (+ tdegr degr)) + (degr (+ 2 (random 3)) (+ 2 (random 3))) + (gnrt (intern (coerce (vector (code-char (+ 67 (random 2)))) 'string)) + (intern (coerce (vector (code-char (+ 67 (random 2)))) 'string))) + (rslt nil (cons (cat:brgn degr gnrt) rslt))) + ((> tdegr 10) (setf cat:*bc* (cat:cmbn tdegr 1 (cat:make-abar + :list rslt)))))) + + +(defun c () + (aleat-tc) + (aleat-bc) + (check-rdct)) + +#| + +(test vrtc-bar + (progn + (cat:cat-init) + + (let* ((tcc (cat:build-chcm + :cmpr #'cat:s-cmpr + :basis #'(lambda (degr) '(a b c d)) + :bsgn 'd + :intr-dffr #'(lambda (degr gnrt) + (ecase gnrt + (a (cat:cmbn (1- degr) 1 'b 1 'd)) + ((b d) (cat:cmbn (1- degr))) + (c (cat:cmbn (1- degr) 1 'd)))) + :strt :gnrt + :orgn '(tcc))) + (bcc (cat:build-chcm + :cmpr #'cat:s-cmpr + :basis #'(lambda (degr) '(c d)) + :bsgn 'd + :intr-dffr #'(lambda (degr gnrt) + (ecase gnrt + (d (cat:cmbn (1- degr))) + (c (cat:cmbn (1- degr) 1 'd)))) + :strt :gnrt + :orgn '(bcc))) + (f (cat:build-mrph :sorc tcc :trgt bcc :degr 0 + :intr #'(lambda (degr gnrt) + (ecase gnrt + (a (cat:cmbn degr 1 'c 1 'd)) + (b (cat:cmbn degr)) + ((c d) (cat:cmbn degr 1 gnrt)))) + :strt :gnrt :orgn '(f))) + (g (cat:build-mrph :sorc bcc :trgt tcc :degr 0 + :intr #'identity :strt :cmbn :orgn '(g))) + (h (cat:build-mrph :sorc tcc :trgt tcc :degr +1 + :intr #'(lambda (degr gnrt) + (ecase gnrt + ((a b) (cat:cmbn + (1+ degr) + 1 'a -1 'b -1 'c -1 'd)) + ((c d) (cat:cmbn (1+ degr))))) + :strt :gnrt :orgn '(h))) + (rdct (cat:build-rdct :f f :g g :h h :orgn '(rdct))) + (bar)) + (cat:tcc rdct 3 'a) + (cat:g rdct (cat:f rdct 3 'a)) + (cat:h rdct 3 'a) + (setf bar (cat:vrtc-bar rdct)) + (cat:pre-check-rdct bar) + (aleat-tc) + (aleat-bc) + (loop (c))))) ;; degrees >= 15 is possible => error. + +(test bar + (progn + (cat:cat-init) + (let* ((h (cat:efhm (cat:k-z-1))) + (b (cat:bar h))) + ;;(inspect b) + (cat:homology (cat:rbcc b) 0 11)))) |#