702 lines
22 KiB
Common Lisp
702 lines
22 KiB
Common Lisp
;;; 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 "CAT")
|
|
|
|
(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 "<<Abar")
|
|
(dolist (brgn cdr)
|
|
(declare (type brgn brgn))
|
|
(with-brgn (degr gnrt) brgn
|
|
(format stream "[~D ~A]" degr gnrt)))
|
|
(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 list2))
|
|
(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
|
|
#'(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
|
|
(let ((dfnt `(vrtc-bar ,chcm)))
|
|
(declare (type list dfnt))
|
|
(already vrtc-bar dfnt)
|
|
(with-slots (cmpr basis dffr) chcm
|
|
(declare
|
|
(type cmprf cmpr)
|
|
(type basis basis)
|
|
(type morphism dffr))
|
|
(chain-complex
|
|
:cmpr (bar-cmpr cmpr)
|
|
:basis (bar-basis basis)
|
|
:bsgn +null-abar+
|
|
:dffr-intr (bar-intr-vrtc-dffr dffr)
|
|
:dffr-strt :gnrt
|
|
:dfnt dfnt)))))
|
|
|
|
#|
|
|
(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
|
|
#'(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))
|
|
(morphism
|
|
:sorc (vrtc-bar algb) :trgt (vrtc-bar algb) :degr -1
|
|
:intr (bar-intr-hrzn-dffr aprd) :strt :gnrt
|
|
:dfnt `(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 #'rslt)))
|
|
|
|
(DEFMETHOD BAR ((algebra algebra))
|
|
(the chain-complex
|
|
(let ((vrtc-bar (vrtc-bar algebra))
|
|
(bar-hrzn-dffr (bar-hrzn-dffr algebra)))
|
|
(declare (type chain-complex vrtc-bar hrzn-bar))
|
|
(let ((rslt (chain-complex
|
|
:cmpr (cmpr vrtc-bar)
|
|
:basis (basis vrtc-bar)
|
|
:bsgn +null-abar+
|
|
:dffr-intr (bar-intr-dffr (dffr vrtc-bar) bar-hrzn-dffr)
|
|
:dffr-strt :gnrt
|
|
:dfnt `(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 #'rslt)))
|
|
|
|
#|
|
|
(setf cc (chain-complex :cmpr #'f-cmpr :dffr-strt :cmbn))
|
|
(setf m (morphism :sorc cc :trgt cc :degr 0 :intr
|
|
#'(lambda (degr gnrt) (cmbn degr 2 gnrt 3 (1+ gnrt)))
|
|
:strt :gnrt :dfnt '(test)))
|
|
(setf r (mrph-vrtc-bar-intr m))
|
|
(funcall r 4 (abar 2 3 2 4))
|
|
|#
|
|
|
|
(DEFMETHOD VRTC-BAR ((mrph morphism))
|
|
(the morphism
|
|
(let ((dfnt `(vrtc-bar ,mrph)))
|
|
(declare (type list dfnt))
|
|
(if (eq (first (dfnt mrph)) 'idnt-mrph)
|
|
(idnt-mrph (vrtc-bar (sorc mrph)))
|
|
(morphism
|
|
:sorc (vrtc-bar (sorc mrph))
|
|
:trgt (vrtc-bar (trgt mrph))
|
|
:degr 0
|
|
:intr (mrph-vrtc-bar-intr mrph)
|
|
:strt :gnrt
|
|
:dfnt dfnt)))))
|
|
|
|
#|
|
|
(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
|
|
#'(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 (dfnt h)) 'zero-mrph)
|
|
(zero-mrph (vrtc-bar (sorc h)))
|
|
(morphism
|
|
:sorc (vrtc-bar (sorc h)) :trgt (vrtc-bar (sorc h)) :degr +1
|
|
:intr (hmtp-vrtc-bar-intr h gf)
|
|
:strt :gnrt
|
|
:dfnt `(hmtp-vrtc-bar ,h ,gf)))))
|
|
|
|
(DEFMETHOD VRTC-BAR ((rdct reduction))
|
|
(the reduction
|
|
(let ((dfnt `(vrtc-bar ,rdct)))
|
|
(declare (type list dfnt))
|
|
(if (eq (first (dfnt rdct)) 'trivial-rdct)
|
|
(trivial-rdct (vrtc-bar (bcc rdct)))
|
|
(with-slots (f g h) rdct
|
|
(reduction
|
|
:f (vrtc-bar f)
|
|
:g (vrtc-bar g)
|
|
:h (hmtp-vrtc-bar h (cmps g f))
|
|
:dfnt dfnt))))))
|
|
|
|
#|
|
|
(cat-init)
|
|
(setf tcc (chain-complex
|
|
:cmpr #'s-cmpr
|
|
:basis #'(lambda (degr) '(a b c d))
|
|
:bsgn 'd
|
|
:dffr-intr #'(lambda (degr gnrt)
|
|
(ecase gnrt
|
|
(a (cmbn (1- degr) 1 'b 1 'd))
|
|
((b d) (cmbn (1- degr)))
|
|
(c (cmbn (1- degr) 1 'd))))
|
|
:dffr-strt :gnrt
|
|
:dfnt '(tcc)))
|
|
(setf bcc (chain-complex
|
|
:cmpr #'s-cmpr
|
|
:basis #'(lambda (degr) '(c d))
|
|
:bsgn 'd
|
|
:dffr-intr #'(lambda (degr gnrt)
|
|
(ecase gnrt
|
|
(d (cmbn (1- degr)))
|
|
(c (cmbn (1- degr) 1 'd))))
|
|
:dffr-strt :gnrt
|
|
:dfnt '(bcc)))
|
|
(setf f (morphism :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 :dfnt '(f)))
|
|
(setf g (morphism :sorc bcc :trgt tcc :degr 0
|
|
:intr #'identity :strt :cmbn :dfnt '(g)))
|
|
(setf h (morphism :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 :dfnt '(h)))
|
|
(setf rdct (reduction :f f :g g :h h :dfnt '(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 ((eqvl equivalence))
|
|
(the equivalence
|
|
(let ((dfnt `(vrtc-bar ,eqvl)))
|
|
(declare (type list dfnt))
|
|
(already vrtc-bar dfnt)
|
|
(if (eq (first (dfnt eqvl)) 'trivial-eqvl)
|
|
(trivial-eqvl (vrtc-bar (lbcc eqvl)))
|
|
(with-slots (lrdct rrdct) eqvl
|
|
(equivalence
|
|
:lrdct (vrtc-bar lrdct)
|
|
:rrdct (vrtc-bar rrdct)
|
|
:dfnt dfnt))))))
|
|
|
|
(DEFMETHOD BAR ((eqvl equivalence))
|
|
(unless (typep (lbcc eqvl) 'algebra)
|
|
(error "In (BAR eqvl), the LBCC should be a algebra."))
|
|
(the equivalence
|
|
(if (eq (first (dfnt eqvl)) 'trivial-eqvl)
|
|
(trivial-eqvl (bar (lbcc eqvl)))
|
|
(add (vrtc-bar eqvl) (bar-hrzn-dffr (lbcc eqvl))))))
|
|
|
|
#|
|
|
(cat-init)
|
|
(setf h (efhm (k-z-1)))
|
|
(setf b (bar h))
|
|
(inspect b)
|
|
(homology (rbcc b) 0 11)
|
|
|#
|
|
|
|
|
|
|