Added missing NREVERSE in return from ABAR.
This commit is contained in:
Gerd Heber
parent
ddee5978cc
commit
fa9eb0fc70
670
src/bar.lisp
670
src/bar.lisp
@ -1,3 +1,5 @@
|
||||
;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
|
||||
;;;
|
||||
;;; 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
|
||||
@ -17,12 +19,12 @@
|
||||
(error "In ABAR, the length list should be even."))
|
||||
(the abar
|
||||
(let ((rslt +empty-list+))
|
||||
(declare (list rslt))
|
||||
(do ((mark list (cddr mark)))
|
||||
((endp mark))
|
||||
(declare (list mark))
|
||||
(push (brgn (car mark) (cadr mark)) rslt))
|
||||
(make-abar :list rslt))))
|
||||
(declare (list rslt))
|
||||
(do ((mark list (cddr mark)))
|
||||
((endp mark))
|
||||
(declare (list mark))
|
||||
(push (brgn (car mark) (cadr mark)) rslt))
|
||||
(make-abar :list (nreverse rslt)))))
|
||||
|
||||
|
||||
#-sbcl (DEFINE-CONSTANT +NULL-ABAR+ (make-abar :list +empty-list+))
|
||||
@ -38,9 +40,9 @@
|
||||
(progn
|
||||
(format stream "<<Abar")
|
||||
(dolist (brgn cdr)
|
||||
(declare (type brgn brgn))
|
||||
(with-brgn (degr gnrt) brgn
|
||||
(format stream "[~D ~A]" degr gnrt)))
|
||||
(declare (type brgn brgn))
|
||||
(with-brgn (degr gnrt) brgn
|
||||
(format stream "[~D ~A]" degr gnrt)))
|
||||
(format stream ">>")
|
||||
(cons car cdr))))
|
||||
|#
|
||||
@ -52,32 +54,32 @@
|
||||
(ignore depth))
|
||||
(the abar
|
||||
(progn
|
||||
(format stream "<<Abar")
|
||||
(dolist (brgn (abar-list abar))
|
||||
(declare (type brgn brgn))
|
||||
(with-brgn (degr gnrt) brgn
|
||||
(format stream "[~D ~A]" degr gnrt)))
|
||||
(format stream ">>")
|
||||
abar)))
|
||||
(format stream "<<Abar")
|
||||
(dolist (brgn (abar-list abar))
|
||||
(declare (type brgn brgn))
|
||||
(with-brgn (degr gnrt) brgn
|
||||
(format stream "[~D ~A]" degr gnrt)))
|
||||
(format stream ">>")
|
||||
abar)))
|
||||
;;; CLISP]+
|
||||
|
||||
|
||||
(DEFUN BAR-CMPR (cmpr)
|
||||
(declare (type cmprf cmpr))
|
||||
(flet ((rslt (abar1 abar2)
|
||||
(declare (type abar abar1 abar2))
|
||||
(the cmpr
|
||||
(let ((list1 (abar-list abar1))
|
||||
(list2 (abar-list abar2)))
|
||||
(declare (list list1 list2))
|
||||
(lexico
|
||||
(f-cmpr (length list1) (length list2))
|
||||
(maplexico
|
||||
#'(lambda (brgn1 brgn2)
|
||||
(lexico
|
||||
(f-cmpr (bdegr brgn1) (bdegr brgn2))
|
||||
(funcall cmpr (bgnrt brgn1) (bgnrt brgn2))))
|
||||
list1 list2))))))
|
||||
(declare (type abar abar1 abar2))
|
||||
(the cmpr
|
||||
(let ((list1 (abar-list abar1))
|
||||
(list2 (abar-list abar2)))
|
||||
(declare (list list1 list2))
|
||||
(lexico
|
||||
(f-cmpr (length list1) (length list2))
|
||||
(maplexico
|
||||
#'(lambda (brgn1 brgn2)
|
||||
(lexico
|
||||
(f-cmpr (bdegr brgn1) (bdegr brgn2))
|
||||
(funcall cmpr (bgnrt brgn1) (bgnrt brgn2))))
|
||||
list1 list2))))))
|
||||
(the cmprf #'rslt)))
|
||||
|
||||
|
||||
@ -87,16 +89,16 @@
|
||||
(fixnum degr length))
|
||||
(the list
|
||||
(progn
|
||||
(when (= 1 length)
|
||||
(return-from bar-basis-length
|
||||
(mapcar
|
||||
(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
|
||||
(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)))
|
||||
@ -104,95 +106,95 @@
|
||||
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))))))
|
||||
#'(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))))))
|
||||
|
||||
|
||||
(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))))
|
||||
(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))))
|
||||
|
||||
|
||||
(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 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))))))))
|
||||
#'(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))))))))
|
||||
|
||||
|
||||
(DEFGENERIC VRTC-BAR (chcm-hmeq-mrph))
|
||||
@ -202,91 +204,91 @@
|
||||
(the chain-complex
|
||||
(with-slots (cmpr basis dffr) chcm
|
||||
(declare
|
||||
(type cmprf cmpr)
|
||||
(type basis basis)
|
||||
(type morphism dffr))
|
||||
(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)))))
|
||||
:cmpr (bar-cmpr cmpr)
|
||||
:basis (bar-basis basis)
|
||||
:bsgn +null-abar+
|
||||
:intr-dffr (bar-intr-vrtc-dffr dffr)
|
||||
:strt :gnrt
|
||||
:orgn `(vrtc-bar ,chcm)))))
|
||||
|
||||
|
||||
(DEFUN BAR-INTR-HRZN-DFFR (aprd)
|
||||
(declare (type morphism aprd))
|
||||
(labels ((rslt (degr iabar)
|
||||
(declare
|
||||
(fixnum degr)
|
||||
(type iabar iabar))
|
||||
(the icmbn
|
||||
(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 cmbn aprd-brgn1-brgn2)
|
||||
(type icmbn 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)))))))))))
|
||||
(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 cmbn aprd-brgn1-brgn2)
|
||||
(type icmbn 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)))))))))
|
||||
(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)))))))))
|
||||
|
||||
|
||||
(DEFUN BAR-HRZN-DFFR (algb)
|
||||
@ -295,22 +297,22 @@
|
||||
(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)))))
|
||||
:sorc (vrtc-bar algb) :trgt (vrtc-bar algb) :degr -1
|
||||
:intr (bar-intr-hrzn-dffr aprd) :strt :gnrt
|
||||
:orgn `(bar-hrzn-dffr ,algb)))))
|
||||
|
||||
|
||||
(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))))))
|
||||
(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)))
|
||||
|
||||
|
||||
@ -319,52 +321,52 @@
|
||||
|
||||
(DEFMETHOD BAR ((algebra algebra))
|
||||
(let ((vrtc-bar (vrtc-bar algebra))
|
||||
(bar-hrzn-dffr (bar-hrzn-dffr algebra)))
|
||||
(bar-hrzn-dffr (bar-hrzn-dffr algebra)))
|
||||
(declare (type chain-complex vrtc-bar)
|
||||
(type morphism bar-hrzn-dffr))
|
||||
(type morphism bar-hrzn-dffr))
|
||||
(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))))
|
||||
(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))))
|
||||
|
||||
|
||||
(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))))))
|
||||
(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)
|
||||
@ -372,33 +374,33 @@
|
||||
(the cmbn
|
||||
(progn
|
||||
(unless cmbn-list
|
||||
(return-from ncmbn-bar (cmbn 0 1 +null-abar+)))
|
||||
(return-from ncmbn-bar (cmbn 0 1 +null-abar+)))
|
||||
(cmbn-abar-cmbn-tnpr
|
||||
(first cmbn-list)
|
||||
(ncmbn-bar (rest cmbn-list))))))
|
||||
(first cmbn-list)
|
||||
(ncmbn-bar (rest cmbn-list))))))
|
||||
|
||||
|
||||
(DEFUN MRPH-VRTC-BAR-INTR (mrph)
|
||||
(declare (type morphism mrph))
|
||||
(flet ((rslt (degr abar)
|
||||
(declare
|
||||
(ignore degr)
|
||||
(type abar abar))
|
||||
(the cmbn
|
||||
(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))))))
|
||||
(mapcar #'(lambda (brgn)
|
||||
(declare (type brgn brgn))
|
||||
(with-brgn (degr gnrt) brgn
|
||||
(gnrt-? mrph (1- degr) gnrt)))
|
||||
(abar-list abar))))))
|
||||
(the intr-mrph #'rslt)))
|
||||
|
||||
|
||||
(DEFMETHOD VRTC-BAR ((mrph morphism))
|
||||
(the morphism
|
||||
(if (eq (first (orgn mrph)) 'idnt-mrph)
|
||||
(idnt-mrph (vrtc-bar (sorc mrph)))
|
||||
(build-mrph
|
||||
(idnt-mrph (vrtc-bar (sorc mrph)))
|
||||
(build-mrph
|
||||
:sorc (vrtc-bar (sorc mrph))
|
||||
:trgt (vrtc-bar (trgt mrph))
|
||||
:degr 0
|
||||
@ -410,84 +412,84 @@
|
||||
(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)))))))
|
||||
(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))))))))
|
||||
#'(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))))))))
|
||||
|
||||
|
||||
(DEFUN HMTP-VRTC-BAR (h gf)
|
||||
(declare (type morphism h gf))
|
||||
(unless (and (= +1 (degr h))
|
||||
(= +0 (degr gf)))
|
||||
(= +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)))
|
||||
(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
|
||||
(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
|
||||
@ -496,24 +498,24 @@
|
||||
(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))))))
|
||||
(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))))))
|
||||
|
||||
|
||||
(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))))))
|
||||
(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))
|
||||
@ -521,5 +523,5 @@
|
||||
(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))))))
|
||||
(trivial-hmeq (bar (lbcc hmeq)))
|
||||
(add (vrtc-bar hmeq) (bar-hrzn-dffr (lbcc hmeq))))))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user