mmarco/kenzo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Added missing NREVERSE in return from ABAR.

Browse Source
This commit is contained in:
Gerd Heber 2016-02-29 19:16:38 -05:00
parent ddee5978cc
commit fa9eb0fc70
1 changed files with 336 additions and 334 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

670
src/bar.lisp
View File

@ -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 ;;; 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.")) (error "In ABAR, the length list should be even."))
(the abar (the abar
(let ((rslt +empty-list+)) (let ((rslt +empty-list+))
(declare (list rslt)) (declare (list rslt))
(do ((mark list (cddr mark))) (do ((mark list (cddr mark)))
((endp mark)) ((endp mark))
(declare (list mark)) (declare (list mark))
(push (brgn (car mark) (cadr mark)) rslt)) (push (brgn (car mark) (cadr mark)) rslt))
(make-abar :list rslt)))) (make-abar :list (nreverse rslt)))))
#-sbcl (DEFINE-CONSTANT +NULL-ABAR+ (make-abar :list +empty-list+)) #-sbcl (DEFINE-CONSTANT +NULL-ABAR+ (make-abar :list +empty-list+))
@ -38,9 +40,9 @@
(progn (progn
(format stream "<<Abar") (format stream "<<Abar")
(dolist (brgn cdr) (dolist (brgn cdr)
(declare (type brgn brgn)) (declare (type brgn brgn))
(with-brgn (degr gnrt) brgn (with-brgn (degr gnrt) brgn
(format stream "[~D ~A]" degr gnrt))) (format stream "[~D ~A]" degr gnrt)))
(format stream ">>") (format stream ">>")
(cons car cdr)))) (cons car cdr))))
|# |#
@ -52,32 +54,32 @@
(ignore depth)) (ignore depth))
(the abar (the abar
(progn (progn
(format stream "<<Abar") (format stream "<<Abar")
(dolist (brgn (abar-list abar)) (dolist (brgn (abar-list abar))
(declare (type brgn brgn)) (declare (type brgn brgn))
(with-brgn (degr gnrt) brgn (with-brgn (degr gnrt) brgn
(format stream "[~D ~A]" degr gnrt))) (format stream "[~D ~A]" degr gnrt)))
(format stream ">>") (format stream ">>")
abar))) abar)))
;;; CLISP]+ ;;; CLISP]+
(DEFUN BAR-CMPR (cmpr) (DEFUN BAR-CMPR (cmpr)
(declare (type cmprf cmpr)) (declare (type cmprf cmpr))
(flet ((rslt (abar1 abar2) (flet ((rslt (abar1 abar2)
(declare (type abar abar1 abar2)) (declare (type abar abar1 abar2))
(the cmpr (the cmpr
(let ((list1 (abar-list abar1)) (let ((list1 (abar-list abar1))
(list2 (abar-list abar2))) (list2 (abar-list abar2)))
(declare (list list1 list2)) (declare (list list1 list2))
(lexico (lexico
(f-cmpr (length list1) (length list2)) (f-cmpr (length list1) (length list2))
(maplexico (maplexico
#'(lambda (brgn1 brgn2) #'(lambda (brgn1 brgn2)
(lexico (lexico
(f-cmpr (bdegr brgn1) (bdegr brgn2)) (f-cmpr (bdegr brgn1) (bdegr brgn2))
(funcall cmpr (bgnrt brgn1) (bgnrt brgn2)))) (funcall cmpr (bgnrt brgn1) (bgnrt brgn2))))
list1 list2)))))) list1 list2))))))
(the cmprf #'rslt))) (the cmprf #'rslt)))
@ -87,16 +89,16 @@
(fixnum degr length)) (fixnum degr length))
(the list (the list
(progn (progn
(when (= 1 length) (when (= 1 length)
(return-from bar-basis-length (return-from bar-basis-length
(mapcar (mapcar
#'(lambda (item) #'(lambda (item)
(declare (type gnrt item)) (declare (type gnrt item))
(list (brgn degr item))) (list (brgn degr item)))
(funcall basis (1- degr))))) (funcall basis (1- degr)))))
(when (< degr 4) (when (< degr 4)
(return-from bar-basis-length +empty-list+)) (return-from bar-basis-length +empty-list+))
(mapcan (mapcan
#'(lambda (degr1) #'(lambda (degr1)
(declare (fixnum degr1)) (declare (fixnum degr1))
(let ((list1 (funcall basis (1- degr1))) (let ((list1 (funcall basis (1- degr1)))
@ -104,95 +106,95 @@
basis (- degr degr1) (1- length)))) basis (- degr degr1) (1- length))))
(declare (list list1 list2)) (declare (list list1 list2))
(mapcan (mapcan
#'(lambda (item1) #'(lambda (item1)
(declare (type gnrt item1)) (declare (type gnrt item1))
(mapcar (mapcar
#'(lambda (item2) #'(lambda (item2)
(declare (type iabar item2)) (declare (type iabar item2))
(cons (brgn degr1 item1) item2)) (cons (brgn degr1 item1) item2))
list2)) list2))
list1))) list1)))
(>a-b< 1 (1- degr)))))) (>a-b< 1 (1- degr))))))
(DEFUN BAR-BASIS (basis) (DEFUN BAR-BASIS (basis)
(declare (type basis basis)) (declare (type basis basis))
(the basis (the basis
(progn (progn
(when (eq :locally-effective basis) (when (eq :locally-effective basis)
(return-from bar-basis :locally-effective)) (return-from bar-basis :locally-effective))
(flet (flet
((rslt (degr) ((rslt (degr)
(declare (fixnum degr)) (declare (fixnum degr))
(cond ((zerop degr) (list +null-abar+)) (cond ((zerop degr) (list +null-abar+))
((< degr 2) +empty-list+) ((< degr 2) +empty-list+)
(t (t
(mapcan (mapcan
#'(lambda (length) #'(lambda (length)
(declare (fixnum length)) (declare (fixnum length))
(mapcar (mapcar
#'(lambda (iabar) #'(lambda (iabar)
(declare (type iabar iabar)) (declare (type iabar iabar))
(make-abar :list iabar)) (make-abar :list iabar))
(bar-basis-length basis degr length))) (bar-basis-length basis degr length)))
(>a-b> 0 (floor degr 2))))))) (>a-b> 0 (floor degr 2)))))))
#'rslt)))) #'rslt))))
(DEFUN BAR-INTR-VRTC-DFFR (dffr) (DEFUN BAR-INTR-VRTC-DFFR (dffr)
(declare (type morphism dffr)) (declare (type morphism dffr))
(labels ((rslt (degr iabar) (labels ((rslt (degr iabar)
;; the argument iabar is an internal algebraic bar, ;; the argument iabar is an internal algebraic bar,
;; without the keyword :abar ;; without the keyword :abar
;; rslt returns an internal combination ;; rslt returns an internal combination
;; without the keyword :cmbn, without degree ;; without the keyword :cmbn, without degree
(declare (declare
(fixnum degr) (fixnum degr)
(type iabar iabar)) (type iabar iabar))
(progn (progn
(unless iabar (unless iabar
(return-from rslt +empty-list+)) (return-from rslt +empty-list+))
(let ((brgn1 (first iabar)) (let ((brgn1 (first iabar))
(rest2 (rest iabar))) (rest2 (rest iabar)))
(declare (declare
(type brgn brgn1) (type brgn brgn1)
(type iabar rest2)) (type iabar rest2))
(with-brgn (degr1 gnrt1) brgn1 (with-brgn (degr1 gnrt1) brgn1
(let ((d-gnrt1 (cmbn-list (gnrt-? dffr (1- degr1) (let ((d-gnrt1 (cmbn-list (gnrt-? dffr (1- degr1)
gnrt1))) gnrt1)))
(d-rest2 (rslt (- degr degr1) rest2)) (d-rest2 (rslt (- degr degr1) rest2))
(degr1-1 (1- degr1)) (degr1-1 (1- degr1))
(rest-sign (-1-expt-n degr1))) (rest-sign (-1-expt-n degr1)))
(declare (declare
(type icmbn d-gnrt1 d-rest2) (type icmbn d-gnrt1 d-rest2)
(fixnum degr1-1 rest-sign)) (fixnum degr1-1 rest-sign))
(nconc (nconc
(mapcar (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (cffc gnrt) term (with-term (cffc gnrt) term
(term (- cffc) (term (- cffc)
(cons (brgn degr1-1 gnrt) (cons (brgn degr1-1 gnrt)
rest2)))) rest2))))
d-gnrt1) d-gnrt1)
(mapcar (mapcar
#'(lambda (term) #'(lambda (term)
(with-term (cffc gnrt) term (with-term (cffc gnrt) term
(term (* rest-sign cffc) (term (* rest-sign cffc)
(cons brgn1 gnrt)))) (cons brgn1 gnrt))))
d-rest2)))))))) d-rest2))))))))
(the intr-mrph (the intr-mrph
#'(lambda (degr abar) #'(lambda (degr abar)
(declare (declare
(fixnum degr) (fixnum degr)
(type abar abar)) (type abar abar))
(make-cmbn (make-cmbn
:degr (1- degr) :degr (1- degr)
:list (mapcar :list (mapcar
#'(lambda (term) #'(lambda (term)
(with-term (cffc iabar) term (with-term (cffc iabar) term
(term cffc (make-abar :list iabar)))) (term cffc (make-abar :list iabar))))
(rslt degr (abar-list abar)))))))) (rslt degr (abar-list abar))))))))
(DEFGENERIC VRTC-BAR (chcm-hmeq-mrph)) (DEFGENERIC VRTC-BAR (chcm-hmeq-mrph))
@ -202,91 +204,91 @@
(the chain-complex (the chain-complex
(with-slots (cmpr basis dffr) chcm (with-slots (cmpr basis dffr) chcm
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(type basis basis) (type basis basis)
(type morphism dffr)) (type morphism dffr))
(build-chcm (build-chcm
:cmpr (bar-cmpr cmpr) :cmpr (bar-cmpr cmpr)
:basis (bar-basis basis) :basis (bar-basis basis)
:bsgn +null-abar+ :bsgn +null-abar+
:intr-dffr (bar-intr-vrtc-dffr dffr) :intr-dffr (bar-intr-vrtc-dffr dffr)
:strt :gnrt :strt :gnrt
:orgn `(vrtc-bar ,chcm))))) :orgn `(vrtc-bar ,chcm)))))
(DEFUN BAR-INTR-HRZN-DFFR (aprd) (DEFUN BAR-INTR-HRZN-DFFR (aprd)
(declare (type morphism aprd)) (declare (type morphism aprd))
(labels ((rslt (degr iabar) (labels ((rslt (degr iabar)
(declare (declare
(fixnum degr) (fixnum degr)
(type iabar iabar)) (type iabar iabar))
(the icmbn (the icmbn
(progn (progn
(unless (cdr iabar) (unless (cdr iabar)
(return-from rslt +empty-list+)) (return-from rslt +empty-list+))
(let ((brgn1 (first iabar)) (let ((brgn1 (first iabar))
(brgn2 (second iabar)) (brgn2 (second iabar))
(rest1 (rest iabar)) (rest1 (rest iabar))
(rest2 (cddr iabar))) (rest2 (cddr iabar)))
(declare (declare
(type brgn brgn1 brgn2) (type brgn brgn1 brgn2)
(type iabar rest1 rest2)) (type iabar rest1 rest2))
(with-brgn (degr1 gnrt1) brgn1 (with-brgn (degr1 gnrt1) brgn1
(with-brgn (degr2 gnrt2) brgn2 (with-brgn (degr2 gnrt2) brgn2
(let ((sign (-1-expt-n degr1)) (let ((sign (-1-expt-n degr1))
(aprd-brgn1-brgn2 (aprd-brgn1-brgn2
(gnrt-? aprd (gnrt-? aprd
(+ degr1 degr2 -2) (+ degr1 degr2 -2)
(tnpr (1- degr1) (tnpr (1- degr1)
gnrt1 gnrt1
(1- degr2) (1- degr2)
gnrt2))) gnrt2)))
(aprd-rest1 (rslt (aprd-rest1 (rslt
(- degr degr1) (- degr degr1)
rest1))) rest1)))
(declare (declare
(type cmbn aprd-brgn1-brgn2) (type cmbn aprd-brgn1-brgn2)
(type icmbn aprd-rest1)) (type icmbn aprd-rest1))
(with-cmbn (degr12 icmbn12) (with-cmbn (degr12 icmbn12)
aprd-brgn1-brgn2 aprd-brgn1-brgn2
(incf degr12) (incf degr12)
(nconc (nconc
(mapcar (mapcar
#'(lambda (term2) #'(lambda (term2)
(declare (type term (declare (type term
term2)) term2))
(with-term (cffc2 iabar2) (with-term (cffc2 iabar2)
term2 term2
(term (* sign cffc2) (term (* sign cffc2)
(cons brgn1 (cons brgn1
iabar2)))) iabar2))))
aprd-rest1) aprd-rest1)
(mapcar (mapcar
#'(lambda (term1) #'(lambda (term1)
(declare (type term (declare (type term
term1)) term1))
(with-term (cffc1 gnrt12) (with-term (cffc1 gnrt12)
term1 term1
(term (* sign cffc1) (term (* sign cffc1)
(cons (brgn (cons (brgn
degr12 degr12
gnrt12) gnrt12)
rest2)))) rest2))))
icmbn12))))))))))) icmbn12)))))))))))
(the intr-mrph (the intr-mrph
#'(lambda (degr abar) #'(lambda (degr abar)
(declare (declare
(fixnum degr) (fixnum degr)
(type abar abar)) (type abar abar))
(the cmbn (the cmbn
(make-cmbn :degr (1- degr) (make-cmbn :degr (1- degr)
:list (mapcar #'(lambda (term) :list (mapcar #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (cffc iabar) term (with-term (cffc iabar) term
(term cffc (term cffc
(make-abar (make-abar
:list iabar)))) :list iabar))))
(rslt degr (abar-list abar))))))))) (rslt degr (abar-list abar)))))))))
(DEFUN BAR-HRZN-DFFR (algb) (DEFUN BAR-HRZN-DFFR (algb)
@ -295,22 +297,22 @@
(with-slots (aprd) algb (with-slots (aprd) algb
(declare (type morphism aprd)) (declare (type morphism aprd))
(build-mrph (build-mrph
:sorc (vrtc-bar algb) :trgt (vrtc-bar algb) :degr -1 :sorc (vrtc-bar algb) :trgt (vrtc-bar algb) :degr -1
:intr (bar-intr-hrzn-dffr aprd) :strt :gnrt :intr (bar-intr-hrzn-dffr aprd) :strt :gnrt
:orgn `(bar-hrzn-dffr ,algb))))) :orgn `(bar-hrzn-dffr ,algb)))))
(DEFUN BAR-INTR-DFFR (vrtc-dffr hrzn-dffr) (DEFUN BAR-INTR-DFFR (vrtc-dffr hrzn-dffr)
(declare (type morphism vrtc-dffr hrzn-dffr)) (declare (type morphism vrtc-dffr hrzn-dffr))
(flet ((rslt (degr abar) (flet ((rslt (degr abar)
(declare (declare
(fixnum degr) (fixnum degr)
(type abar abar)) (type abar abar))
(make-cmbn :degr (1- degr) (make-cmbn :degr (1- degr)
:list (append ;;; and not nconc, otherwise a terrible bug, :list (append ;;; and not nconc, otherwise a terrible bug,
;;; when the first result is stored in memory ;;; when the first result is stored in memory
(cmbn-list (gnrt-? hrzn-dffr degr abar)) (cmbn-list (gnrt-? hrzn-dffr degr abar))
(cmbn-list (gnrt-? vrtc-dffr degr abar)))))) (cmbn-list (gnrt-? vrtc-dffr degr abar))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
@ -319,52 +321,52 @@
(DEFMETHOD BAR ((algebra algebra)) (DEFMETHOD BAR ((algebra algebra))
(let ((vrtc-bar (vrtc-bar 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) (declare (type chain-complex vrtc-bar)
(type morphism bar-hrzn-dffr)) (type morphism bar-hrzn-dffr))
(the chain-complex (the chain-complex
(let ((rslt (build-chcm (let ((rslt (build-chcm
:cmpr (cmpr vrtc-bar) :cmpr (cmpr vrtc-bar)
:basis (basis vrtc-bar) :basis (basis vrtc-bar)
:bsgn +null-abar+ :bsgn +null-abar+
:intr-dffr (bar-intr-dffr (dffr vrtc-bar) bar-hrzn-dffr) :intr-dffr (bar-intr-dffr (dffr vrtc-bar) bar-hrzn-dffr)
:strt :gnrt :strt :gnrt
:orgn `(add ,vrtc-bar ,bar-hrzn-dffr)))) :orgn `(add ,vrtc-bar ,bar-hrzn-dffr))))
(declare (type chain-complex rslt)) (declare (type chain-complex rslt))
(setf (slot-value rslt 'grmd) (grmd vrtc-bar)) (setf (slot-value rslt 'grmd) (grmd vrtc-bar))
rslt)))) rslt))))
(DEFUN CMBN-ABAR-CMBN-TNPR (cmbn abar-cmbn) (DEFUN CMBN-ABAR-CMBN-TNPR (cmbn abar-cmbn)
(declare (type cmbn cmbn abar-cmbn)) (declare (type cmbn cmbn abar-cmbn))
(the cmbn (the cmbn
(with-cmbn (degr1 list1) cmbn (with-cmbn (degr1 list1) cmbn
(incf degr1) ;; because abar organization (incf degr1) ;; because abar organization
(with-cmbn (degrr listr) abar-cmbn (with-cmbn (degrr listr) abar-cmbn
(make-cmbn (make-cmbn
:degr (+ degr1 degrr) :degr (+ degr1 degrr)
:list :list
(mapcan (mapcan
#'(lambda (term1) #'(lambda (term1)
(declare (type term term1)) (declare (type term term1))
(with-term (cffc1 gnrt1) term1 (with-term (cffc1 gnrt1) term1
(let ((brgn1 (brgn degr1 gnrt1))) (let ((brgn1 (brgn degr1 gnrt1)))
(declare (type brgn brgn1)) (declare (type brgn brgn1))
(mapcar (mapcar
#'(lambda (termr) #'(lambda (termr)
(declare (type term (declare (type term
termr)) termr))
(with-term (cffcr abarr) (with-term (cffcr abarr)
termr termr
(term (term
(* cffc1 cffcr) (* cffc1 cffcr)
(make-abar (make-abar
:list (cons :list (cons
brgn1 brgn1
(abar-list (abar-list
abarr)))))) abarr))))))
listr)))) listr))))
list1)))))) list1))))))
(DEFUN NCMBN-BAR (cmbn-list) (DEFUN NCMBN-BAR (cmbn-list)
@ -372,33 +374,33 @@
(the cmbn (the cmbn
(progn (progn
(unless cmbn-list (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 (cmbn-abar-cmbn-tnpr
(first cmbn-list) (first cmbn-list)
(ncmbn-bar (rest cmbn-list)))))) (ncmbn-bar (rest cmbn-list))))))
(DEFUN MRPH-VRTC-BAR-INTR (mrph) (DEFUN MRPH-VRTC-BAR-INTR (mrph)
(declare (type morphism mrph)) (declare (type morphism mrph))
(flet ((rslt (degr abar) (flet ((rslt (degr abar)
(declare (declare
(ignore degr) (ignore degr)
(type abar abar)) (type abar abar))
(the cmbn (the cmbn
(ncmbn-bar (ncmbn-bar
(mapcar #'(lambda (brgn) (mapcar #'(lambda (brgn)
(declare (type brgn brgn)) (declare (type brgn brgn))
(with-brgn (degr gnrt) brgn (with-brgn (degr gnrt) brgn
(gnrt-? mrph (1- degr) gnrt))) (gnrt-? mrph (1- degr) gnrt)))
(abar-list abar)))))) (abar-list abar))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
(DEFMETHOD VRTC-BAR ((mrph morphism)) (DEFMETHOD VRTC-BAR ((mrph morphism))
(the morphism (the morphism
(if (eq (first (orgn mrph)) 'idnt-mrph) (if (eq (first (orgn mrph)) 'idnt-mrph)
(idnt-mrph (vrtc-bar (sorc mrph))) (idnt-mrph (vrtc-bar (sorc mrph)))
(build-mrph (build-mrph
:sorc (vrtc-bar (sorc mrph)) :sorc (vrtc-bar (sorc mrph))
:trgt (vrtc-bar (trgt mrph)) :trgt (vrtc-bar (trgt mrph))
:degr 0 :degr 0
@ -410,84 +412,84 @@
(DEFUN HMTP-VRTC-BAR-INTR (h gf) (DEFUN HMTP-VRTC-BAR-INTR (h gf)
(declare (type morphism h gf)) (declare (type morphism h gf))
(labels ((rslt (degr iabar) (labels ((rslt (degr iabar)
(declare (declare
(fixnum degr) (fixnum degr)
(type iabar iabar)) (type iabar iabar))
(unless iabar (unless iabar
(return-from rslt +empty-list+)) (return-from rslt +empty-list+))
(let ((brgn1 (first iabar)) (let ((brgn1 (first iabar))
(rest2 (rest iabar))) (rest2 (rest iabar)))
(declare (declare
(type brgn brgn1) (type brgn brgn1)
(list rest2)) (list rest2))
(with-brgn (degr1 gnrt1) brgn1 (with-brgn (degr1 gnrt1) brgn1
(let ((h-gnrt1 (cmbn-list (gnrt-? h (1- degr1) (let ((h-gnrt1 (cmbn-list (gnrt-? h (1- degr1)
gnrt1))) gnrt1)))
(h-rest2 (rslt (- degr degr1) rest2)) (h-rest2 (rslt (- degr degr1) rest2))
(degr1+1 (1+ degr1)) (degr1+1 (1+ degr1))
(rest-sign (-1-expt-n degr1)) (rest-sign (-1-expt-n degr1))
(gf-gnrt1 (cmbn-list (gnrt-? gf (1- degr1) (gf-gnrt1 (cmbn-list (gnrt-? gf (1- degr1)
gnrt1)))) gnrt1))))
(declare (declare
(fixnum degr1+1 rest-sign) (fixnum degr1+1 rest-sign)
(type icmbn h-gnrt1 h-rest2 gf-gnrt1)) (type icmbn h-gnrt1 h-rest2 gf-gnrt1))
(nconc (nconc
(mapcan (mapcan
#'(lambda (term1) #'(lambda (term1)
(declare (type term term1)) (declare (type term term1))
(with-term (cffc1 gnrt11) term1 (with-term (cffc1 gnrt11) term1
(mapcar (mapcar
#'(lambda (term2) #'(lambda (term2)
(declare (type term term2)) (declare (type term term2))
(with-term (cffc2 iabar2) (with-term (cffc2 iabar2)
term2 term2
(term (* rest-sign cffc1 (term (* rest-sign cffc1
cffc2) cffc2)
(cons (cons
(brgn degr1 gnrt11) (brgn degr1 gnrt11)
iabar2)))) iabar2))))
h-rest2))) h-rest2)))
gf-gnrt1) gf-gnrt1)
(mapcar (mapcar
#'(lambda (term1) #'(lambda (term1)
(declare (type term term1)) (declare (type term term1))
(with-term (cffc1 gnrt11) term1 (with-term (cffc1 gnrt11) term1
(term (- cffc1) (term (- cffc1)
(cons (cons
(brgn degr1+1 gnrt11) (brgn degr1+1 gnrt11)
rest2)))) rest2))))
h-gnrt1))))))) h-gnrt1)))))))
(the intr-mrph (the intr-mrph
#'(lambda (degr abar) #'(lambda (degr abar)
(declare (declare
(fixnum degr) (fixnum degr)
(type abar abar)) (type abar abar))
(make-cmbn (make-cmbn
:degr (1+ degr) :degr (1+ degr)
:list (mapcar :list (mapcar
#'(lambda (term) #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (cffc iabar) term (with-term (cffc iabar) term
(declare (declare
(fixnum cffc) (fixnum cffc)
(type iabar iabar)) (type iabar iabar))
(term cffc (make-abar :list iabar)))) (term cffc (make-abar :list iabar))))
(rslt degr (abar-list abar)))))))) (rslt degr (abar-list abar))))))))
(DEFUN HMTP-VRTC-BAR (h gf) (DEFUN HMTP-VRTC-BAR (h gf)
(declare (type morphism h gf)) (declare (type morphism h gf))
(unless (and (= +1 (degr h)) (unless (and (= +1 (degr h))
(= +0 (degr gf))) (= +0 (degr gf)))
(error "In HMTP-VRTC-BAR, the morphism degrees are not the right ones.")) (error "In HMTP-VRTC-BAR, the morphism degrees are not the right ones."))
(unless (and (eq (sorc h) (trgt h)) (unless (and (eq (sorc h) (trgt h))
(eq (trgt h) (sorc gf)) (eq (trgt h) (sorc gf))
(eq (sorc gf) (trgt gf))) (eq (sorc gf) (trgt gf)))
(error "In HMTP-VRTC-BAR, fg-h sources and targets are not the same.")) (error "In HMTP-VRTC-BAR, fg-h sources and targets are not the same."))
(the morphism (the morphism
(if (eq (first (orgn h)) 'zero-mrph) (if (eq (first (orgn h)) 'zero-mrph)
(zero-mrph (vrtc-bar (sorc h))) (zero-mrph (vrtc-bar (sorc h)))
(build-mrph (build-mrph
:sorc (vrtc-bar (sorc h)) :trgt (vrtc-bar (sorc h)) :degr +1 :sorc (vrtc-bar (sorc h)) :trgt (vrtc-bar (sorc h)) :degr +1
:intr (hmtp-vrtc-bar-intr h gf) :intr (hmtp-vrtc-bar-intr h gf)
:strt :gnrt :strt :gnrt
@ -496,24 +498,24 @@
(DEFMETHOD VRTC-BAR ((rdct reduction)) (DEFMETHOD VRTC-BAR ((rdct reduction))
(the reduction (the reduction
(if (eq (first (orgn rdct)) 'trivial-rdct) (if (eq (first (orgn rdct)) 'trivial-rdct)
(trivial-rdct (vrtc-bar (bcc rdct))) (trivial-rdct (vrtc-bar (bcc rdct)))
(with-slots (f g h) rdct (with-slots (f g h) rdct
(build-rdct (build-rdct
:f (vrtc-bar f) :f (vrtc-bar f)
:g (vrtc-bar g) :g (vrtc-bar g)
:h (hmtp-vrtc-bar h (cmps g f)) :h (hmtp-vrtc-bar h (cmps g f))
:orgn `(vrtc-bar ,rdct)))))) :orgn `(vrtc-bar ,rdct))))))
(DEFMETHOD VRTC-BAR ((hmeq homotopy-equivalence)) (DEFMETHOD VRTC-BAR ((hmeq homotopy-equivalence))
(the homotopy-equivalence (the homotopy-equivalence
(if (eq (first (orgn hmeq)) 'trivial-hmeq) (if (eq (first (orgn hmeq)) 'trivial-hmeq)
(trivial-hmeq (vrtc-bar (lbcc hmeq))) (trivial-hmeq (vrtc-bar (lbcc hmeq)))
(with-slots (lrdct rrdct) hmeq (with-slots (lrdct rrdct) hmeq
(build-hmeq (build-hmeq
:lrdct (vrtc-bar lrdct) :lrdct (vrtc-bar lrdct)
:rrdct (vrtc-bar rrdct) :rrdct (vrtc-bar rrdct)
:orgn `(vrtc-bar ,hmeq)))))) :orgn `(vrtc-bar ,hmeq))))))
(DEFMETHOD BAR ((hmeq homotopy-equivalence)) (DEFMETHOD BAR ((hmeq homotopy-equivalence))
@ -521,5 +523,5 @@
(error "In (BAR HMEQ), the LBCC should be a algebra.")) (error "In (BAR HMEQ), the LBCC should be a algebra."))
(the homotopy-equivalence (the homotopy-equivalence
(if (eq (first (orgn hmeq)) 'trivial-hmeq) (if (eq (first (orgn hmeq)) 'trivial-hmeq)
(trivial-hmeq (bar (lbcc hmeq))) (trivial-hmeq (bar (lbcc hmeq)))
(add (vrtc-bar hmeq) (bar-hrzn-dffr (lbcc hmeq)))))) (add (vrtc-bar hmeq) (bar-hrzn-dffr (lbcc hmeq))))))