From fa9eb0fc70dd6a00199478d811f10cbb556b96f4 Mon Sep 17 00:00:00 2001 From: Gerd Heber Date: Mon, 29 Feb 2016 19:16:38 -0500 Subject: [PATCH] Added missing NREVERSE in return from ABAR. --- src/bar.lisp | 670 ++++++++++++++++++++++++++------------------------- 1 file changed, 336 insertions(+), 334 deletions(-) diff --git a/src/bar.lisp b/src/bar.lisp index b8a6b9d..1530da7 100644 --- a/src/bar.lisp +++ b/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 "<>") (cons car cdr)))) |# @@ -52,32 +54,32 @@ (ignore depth)) (the abar (progn - (format stream "<>") - abar))) + (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))))))