;;; BAR BAR BAR BAR BAR BAR BAR BAR BAR
;;; BAR BAR BAR BAR BAR BAR BAR BAR BAR
;;; BAR BAR BAR BAR BAR BAR BAR BAR BAR
;;;
;;; MAC-LANE signs (p. 306)
;;;
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "bar")
(DEFUN ABAR (&rest list)
(when (= 1 (length list))
(setf list (first list)))
(unless (evenp (length list))
(error "In ABAR, the length list should be even."))
(the abar
(let ((rslt (list :abar)))
(declare (list rslt))
(do ((mark list (cddr mark)))
((endp mark))
(declare (list mark))
(push (brgn (car mark) (cadr mark)) rslt))
(nreverse rslt))))
#|
(abar )
(abar '(2 a 3 b))
(abar 2 'a 3 'b)
(abar 2 'a 3)) ;; error
|#
(DEFCONSTANT +NULL-ABAR+ (make-abar :list +empty-list+))
(DEFMETHOD PRINT-KEYCONS ((car (eql :abar)) cdr stream)
(declare
(list cdr)
(stream stream))
(the abar
(progn
(format stream "<>")
(cons car cdr))))
(DEFUN BAR-CMPR (cmpr)
(declare (type cmprf cmpr))
(flet ((rslt (abar1 abar2)
(declare (type abar abar1 abar2))
(the cmpr
(lexico
(f-cmpr (length abar1) (length abar2))
(maplexico
#'(lambda (brgn1 brgn2)
(lexico
(f-cmpr (bdegr brgn1) (bdegr brgn2))
(funcall cmpr (bgnrt brgn1) (bgnrt brgn2))))
(abar-list abar1)
(abar-list abar2))))))
(the cmprf #'rslt)))
#|
(setf r (bar-cmpr #'s-cmpr))
(funcall r (abar) (abar))
(funcall r (abar 3 'a) (abar))
(funcall r (abar 3 'a) (abar 2 'a 1 'b))
(funcall r (abar 3 'a) (abar 3 'b))
(funcall r (abar 3 'a) (abar 3 'a)))
|#
(DEFUN BAR-BASIS-LENGTH (basis degr length)
(declare
(type basis basis)
(fixnum degr length))
(the list
(progn
(when (= 1 length)
(return-from bar-basis-length
(mapcar
#'(lambda (item)
(declare (type gnrt item))
(list (brgn degr item)))
(funcall basis (1- degr)))))
(when (< degr 4)
(return-from bar-basis-length +empty-list+))
(mapcan
#'(lambda (degr1)
(declare (fixnum degr1))
(let ((list1 (funcall basis (1- degr1)))
(list2 (bar-basis-length
basis (- degr degr1) (1- length))))
(declare (list list1 lis2))
(mapcan
#'(lambda (item1)
(declare (type gnrt item1))
(mapcar
#'(lambda (item2)
(declare (type iabar item2))
(cons (brgn degr1 item1) item2))
list2))
list1)))
(>a-b< 1 (1- degr))))))
#|
(setf basis #'(lambda (degr)
(list degr)))
(bar-basis-length basis 2 1)
(bar-basis-length basis 2 2)
(bar-basis-length basis 3 1)
(bar-basis-length basis 3 2)
(bar-basis-length basis 4 1)
(bar-basis-length basis 4 2)
(bar-basis-length basis 4 3)
(bar-basis-length basis 4 4)
(bar-basis-length basis 8 1)
(bar-basis-length basis 8 2)
(bar-basis-length basis 8 3)
(bar-basis-length basis 8 4)
(bar-basis-length basis 8 5)
(bar-basis-length basis 8 6)
(bar-basis-length basis 8 11))
|#
(DEFUN BAR-BASIS (basis)
(declare (type basis basis))
(the basis
(progn
(when (eq :locally-effective basis)
(return-from bar-basis :locally-effective))
(flet ((rslt (degr)
(declare (fixnum degr))
(cond ((zerop degr) (list +null-abar+))
((< degr 2) +empty-list+)
(t
(mapcan
#'(lambda (length)
(declare (fixnum length))
(mapcar
#'(lambda (iabar)
(declare (type iabar iabar))
(make-abar :list iabar))
(bar-basis-length basis degr length)))
(>a-b> 0 (floor degr 2)))))))
#'rslt))))
#|
(setf basis #'(lambda (degr)
(list degr)))
(setf r (bar-basis basis))
(funcall r 0)
(funcall r 1)
(funcall r 2)
(dotimes (i 7)
(print (funcall r i)))
(bar-basis :locally-effective))
|#
(DEFUN BAR-INTR-VRTC-DFFR (dffr)
(declare (type morphism dffr))
(labels ((rslt (degr iabar)
;; the argument iabar is an internal algebraic bar,
;; without the keyword :abar
;; rslt returns an internal combination
;; without the keyword :cmbn, without degree
(declare
(fixnum degr)
(type iabar iabar))
(progn
(unless iabar
(return-from rslt +empty-list+))
(let ((brgn1 (first iabar))
(rest2 (rest iabar)))
(declare
(type brgn brgn1)
(type iabar rest2))
(with-brgn (degr1 gnrt1) brgn1
(let ((d-gnrt1 (cmbn-list (gnrt-? dffr (1- degr1) gnrt1)))
(d-rest2 (rslt (- degr degr1) rest2))
(degr1-1 (1- degr1))
(rest-sign (-1-expt-n degr1)))
(declare
(type icmbn d-gnrt1 d-rest2)
(fixnum degr1-1 rest-sign))
(nconc
(mapcar
#'(lambda (term)
(declare (type term term))
(with-term (cffc gnrt) term
(term (- cffc)
(cons (brgn degr1-1 gnrt) rest2))))
d-gnrt1)
(mapcar
#'(lambda (term)
(with-term (cffc gnrt) term
(term (* rest-sign cffc)
(cons brgn1 gnrt))))
d-rest2))))))))
(the intr-mrph
#'(lambda (degr abar)
(declare
(fixnum degr)
(type abar abar))
(make-cmbn
:degr (1- degr)
:list (mapcar
#'(lambda (term)
(with-term (cffc iabar) term
(term cffc (make-abar :list iabar))))
(rslt degr (abar-list abar))))))))
#|
(setf d (soft-delta-infinity))
(setf r (bar-intr-vrtc-dffr (dffr d)))
(funcall r 0 (abar))
(funcall r 3 (abar 3 (d 7)))
(funcall r 5 (abar 3 (d 7) 2 (d 3)))
(funcall r 5 (abar 2 (d 3) 3 (d 7))))
|#
(DEFMETHOD VRTC-BAR ((chcm chain-complex))
(the chain-complex
(with-slots (cmpr basis dffr) chcm
(declare
(type cmprf cmpr)
(type basis basis)
(type morphism dffr))
(build-chcm
:cmpr (bar-cmpr cmpr)
:basis (bar-basis basis)
:bsgn +null-abar+
:intr-dffr (bar-intr-vrtc-dffr dffr)
:strt :gnrt
:orgn `(vrtc-bar ,chcm)))))
#|
(cat-init)
(setf v (vrtc-bar (soft-delta-infinity)))
(defun random-abar (length)
(let ((rslt nil))
(dotimes (i length)
(let* ((gmsm (random (mask 7)))
(dmns (1- (logcount gmsm))))
(when (plusp dmns)
(push (brgn (1+ dmns) (d gmsm)) rslt))))
(make-abar :list rslt)))
(dotimes (i 10) (print (random-abar 5)))
(dotimes (i 10)
(let ((abar (random-abar 3)))
(print abar)
(print (? v (apply #'+ (mapcar #'car (abar-list abar))) abar))
(print (? v (? v (apply #'+ (mapcar #'car (abar-list abar))) abar)))))
|#
(DEFUN BAR-INTR-HRZN-DFFR (aprd)
(declare (type morphism aprd))
(labels ((rslt (degr iabar)
(declare
(fixnum degr)
(type iabar iabar))
(the icmbn
(progn
(unless (cdr iabar)
(return-from rslt +empty-list+))
(let ((brgn1 (first iabar))
(brgn2 (second iabar))
(rest1 (rest iabar))
(rest2 (cddr iabar)))
(declare
(type brgn brgn1 brgn2)
(type iabar rest1 rest2))
(with-brgn (degr1 gnrt1) brgn1
(with-brgn (degr2 gnrt2) brgn2
(let ((sign (-1-expt-n degr1))
(aprd-brgn1-brgn2 (gnrt-? aprd (+ degr1 degr2 -2)
(tnpr (1- degr1) gnrt1
(1- degr2) gnrt2)))
(aprd-rest1 (rslt (- degr degr1) rest1)))
(declare
(type icmbn aprd-brgn1-brgn2 aprd-rest1))
(with-cmbn (degr12 icmbn12) aprd-brgn1-brgn2
(incf degr12)
(nconc
(mapcar
#'(lambda (term2)
(declare (type term term2))
(with-term (cffc2 iabar2) term2
(term (* sign cffc2) (cons brgn1 iabar2))))
aprd-rest1)
(mapcar
#'(lambda (term1)
(declare (type term term1))
(with-term (cffc1 gnrt12) term1
(term (* sign cffc1) (cons (brgn degr12 gnrt12) rest2))))
icmbn12)))))))))))
(the intr-mrph
#'(lambda (degr abar)
(declare
(fixnum degr)
(type abar abar))
(the cmbn
(make-cmbn :degr (1- degr)
:list (mapcar #'(lambda (term)
(declare (type term term))
(with-term (cffc iabar) term
(term cffc (make-abar :list iabar))))
(rslt degr (abar-list abar)))))))))
#|
(setf k (k-z-1))
(setf r (bar-intr-hrzn-dffr (aprd k)))
(funcall r 0 (abar ))
(funcall r 3 (abar 3 '(2 3)))
(funcall r 6 (abar 3 '(2 3) 3 '(-2 -3)))
(funcall r 9 (abar 3 '(2 3) 3 '(-2 -3) 3 '(2 3)))
(funcall r 11 (abar 3 '(2 3) 3 '(-2 -3) 2 '(-2) 3 '(-2 -3))))
|#
(DEFUN BAR-HRZN-DFFR (algb)
(declare (type algebra algb))
(the morphism
(with-slots (aprd) algb
(declare (type morphism aprd))
(build-mrph
:sorc (vrtc-bar algb) :trgt (vrtc-bar algb) :degr -1
: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))
(flet ((rslt (degr abar)
(declare
(fixnum degr)
(type abar abar))
(make-cmbn :degr (1- degr)
:list (append ;;; and not nconc, otherwise a terrible bug, when the
;;; first result is stored in memory...
(cmbn-list (gnrt-? hrzn-dffr degr abar))
(cmbn-list (gnrt-? vrtc-dffr degr abar))))))
(the intr-mrph #'rslt)))
(DEFMETHOD BAR ((algebra algebra))
(let ((vrtc-bar (vrtc-bar algebra))
(bar-hrzn-dffr (bar-hrzn-dffr algebra)))
(declare (type chain-complex vrtc-bar hrzn-bar))
(the chain-complex
(let ((rslt (build-chcm
:cmpr (cmpr vrtc-bar)
:basis (basis vrtc-bar)
:bsgn +null-abar+
:intr-dffr (bar-intr-dffr (dffr vrtc-bar) bar-hrzn-dffr)
:strt :gnrt
:orgn `(add ,vrtc-bar ,bar-hrzn-dffr))))
(declare (type chain-complex rslt))
(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))
(the cmbn
(with-cmbn (degr1 list1) cmbn
(incf degr1) ;; because abar organization
(with-cmbn (degrr listr) abar-cmbn
(make-cmbn
:degr (+ degr1 degrr)
:list
(mapcan
#'(lambda (term1)
(declare (type term term1))
(with-term (cffc1 gnrt1) term1
(let ((brgn1 (brgn degr1 gnrt1)))
(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))))))
listr))))
list1))))))
(DEFUN NCMBN-BAR (cmbn-list)
(declare (list cmbn-list))
(the cmbn
(progn
(unless cmbn-list
(return-from ncmbn-bar (cmbn 0 1 +null-abar+)))
(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))
(flet ((rslt (degr abar)
(declare
(ignore degr)
(type abar abar))
(the cmbn
(ncmbn-bar
(mapcar #'(lambda (brgn)
(declare (type brgn brgn))
(with-brgn (degr gnrt) brgn
(gnrt-? mrph (1- degr) gnrt)))
(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
(if (eq (first (orgn mrph)) 'idnt-mrph)
(idnt-mrph (vrtc-bar (sorc mrph)))
(build-mrph
:sorc (vrtc-bar (sorc mrph))
:trgt (vrtc-bar (trgt mrph))
:degr 0
:intr (mrph-vrtc-bar-intr mrph)
: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))
(labels ((rslt (degr iabar)
(declare
(fixnum degr)
(type iabar iabar))
(unless iabar
(return-from rslt +empty-list+))
(let ((brgn1 (first iabar))
(rest2 (rest iabar)))
(declare
(type brgn brgn1)
(list rest2))
(with-brgn (degr1 gnrt1) brgn1
(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))))
(declare
(fixnum degr1+1 rest-sign)
(type icmbn h-gnrt1 h-rest2 gf-gnrt1))
(nconc
(mapcan
#'(lambda (term1)
(declare (type term term1))
(with-term (cffc1 gnrt11) term1
(mapcar
#'(lambda (term2)
(declare (type term term2))
(with-term (cffc2 iabar2) term2
(term (* rest-sign cffc1 cffc2)
(cons (brgn degr1 gnrt11) iabar2))))
h-rest2)))
gf-gnrt1)
(mapcar
#'(lambda (term1)
(declare (type term term1))
(with-term (cffc1 gnrt11) term1
(term (- cffc1)
(cons (brgn degr1+1 gnrt11) rest2))))
h-gnrt1)))))))
(the intr-mrph
#'(lambda (degr abar)
(declare
(fixnum degr)
(type abar abar))
(make-cmbn
:degr (1+ degr)
:list (mapcar
#'(lambda (term)
(declare (type term term))
(with-term (cffc iabar) term
(declare
(fixnum cffc)
(type iabar iabar))
(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))
(unless (and (= +1 (degr h))
(= +0 (degr gf)))
(error "In HMTP-VRTC-BAR, the morphism degrees are not the right ones."))
(unless (and (eq (sorc h) (trgt h))
(eq (trgt h) (sorc gf))
(eq (sorc gf) (trgt gf)))
(error "In HMTP-VRTC-BAR, fg-h sources and targets are not the same."))
(the morphism
(if (eq (first (orgn h)) 'zero-mrph)
(zero-mrph (vrtc-bar (sorc h)))
(build-mrph
:sorc (vrtc-bar (sorc h)) :trgt (vrtc-bar (sorc h)) :degr +1
:intr (hmtp-vrtc-bar-intr h gf)
:strt :gnrt
:orgn `(hmtp-vrtc-bar ,h ,gf)))))
(DEFMETHOD VRTC-BAR ((rdct reduction))
(the reduction
(if (eq (first (orgn rdct)) 'trivial-rdct)
(trivial-rdct (vrtc-bar (bcc rdct)))
(with-slots (f g h) rdct
(build-rdct
:f (vrtc-bar f)
:g (vrtc-bar g)
: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
(if (eq (first (orgn hmeq)) 'trivial-hmeq)
(trivial-hmeq (vrtc-bar (lbcc hmeq)))
(with-slots (lrdct rrdct) hmeq
(build-hmeq
:lrdct (vrtc-bar lrdct)
:rrdct (vrtc-bar rrdct)
:orgn `(vrtc-bar ,hmeq))))))
(DEFMETHOD BAR ((hmeq homotopy-equivalence))
(unless (typep (lbcc hmeq) 'algebra)
(error "In (BAR HMEQ), the LBCC should be a algebra."))
(the homotopy-equivalence
(if (eq (first (orgn hmeq)) 'trivial-hmeq)
(trivial-hmeq (bar (lbcc hmeq)))
(add (vrtc-bar hmeq) (bar-hrzn-dffr (lbcc hmeq))))))
#|
(cat-init)
(setf h (efhm (k-z-1)))
(setf b (bar h))
(inspect b)
(homology (rbcc b) 0 11)
|#