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

Extracted cobar tests.

Browse Source
This commit is contained in:
Gerd Heber 2015-07-22 20:11:54 -05:00
parent 3c0bf751c4
commit c6666fbe3d
6 changed files with 462 additions and 630 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
kenzo-test.asd
View File

@ -19,6 +19,7 @@
(:file "circle") (:file "circle")
(:file "cl-space-efhm-test") (:file "cl-space-efhm-test")
(:file "classifying-spaces-test") (:file "classifying-spaces-test")
(:file "cobar-test")
(:file "combinations-test") (:file "combinations-test")
(:file "cones-test") (:file "cones-test")
(:file "delta-test") (:file "delta-test")

19
package.lisp
View File

@ -113,8 +113,10 @@
ABSM ABSM
AB-SIMPLICIAL-GROUP AB-SIMPLICIAL-GROUP
ALLP-LIST
BCC BCC
BRGN BRGN
CBGN
CHAIN-COMPLEX CHAIN-COMPLEX
CMBN-CMBN CMBN-CMBN
CMBN-DEGR CMBN-DEGR
@ -134,6 +136,7 @@
KAN KAN
LRDCT LRDCT
MAKE-ABAR MAKE-ABAR
MAKE-ALLP
MAKE-CMBN MAKE-CMBN
MAKE-RESULT MAKE-RESULT
MORPHISM MORPHISM
@ -159,6 +162,21 @@
NORMALIZE-GBAR NORMALIZE-GBAR
UNNORMALIZE-GBAR UNNORMALIZE-GBAR
;; cobar.lisp
ALLP
COBAR
COBAR-BASIS
COBAR-BASIS-LENGTH
COBAR-CMPR
COBAR-HRZN-DFFR
COBAR-INTR-HRZN-DFFR
COBAR-INTR-VRTC-DFFR
HMTP-VRTC-COBAR-INTR
MRPH-VRTC-COBAR-INTR
NCMBN-COBAR
VRTC-COBAR
;; combinations.lisp ;; combinations.lisp
2CMBN-ADD 2CMBN-ADD
@ -205,6 +223,7 @@
DELTA-FACE DELTA-FACE
DELTA-INFINITY DELTA-INFINITY
DELTA-N-BASIS DELTA-N-BASIS
DELTAB
DELTAB2-BNDR DELTAB2-BNDR
DELTAB2-DGNL DELTAB2-DGNL
SOFT-DELTA SOFT-DELTA

291
src/cobar.lisp
View File

@ -20,13 +20,6 @@
(push (cbgn (car mark) (cadr mark)) rslt)) (push (cbgn (car mark) (cadr mark)) rslt))
(make-allp :list (nreverse rslt))))) (make-allp :list (nreverse rslt)))))
#|
()
(allp )
(allp '(2 a 3 b))
(allp 2 'a 3 'b)
(allp 2 'a 3)) ;; error
|#
#-sbcl (DEFINE-CONSTANT +NULL-ALLP+ (make-allp :list +empty-list+)) #-sbcl (DEFINE-CONSTANT +NULL-ALLP+ (make-allp :list +empty-list+))
#+sbcl (DEFPARAMETER +NULL-ALLP+ (make-allp :list +empty-list+)) #+sbcl (DEFPARAMETER +NULL-ALLP+ (make-allp :list +empty-list+))
@ -65,14 +58,6 @@
list1 list2)))))) list1 list2))))))
(the cmprf #'rslt))) (the cmprf #'rslt)))
#|
(setf r (cobar-cmpr #'s-cmpr))
(funcall r (allp) (allp))
(funcall r (allp 3 'a) (allp))
(funcall r (allp 3 'a) (allp 2 'a 1 'b))
(funcall r (allp 3 'a) (allp 3 'b))
(funcall r (allp 3 'a) (allp 3 'a)))
|#
(DEFUN COBAR-BASIS-LENGTH (basis degr length) (DEFUN COBAR-BASIS-LENGTH (basis degr length)
(declare (declare
@ -105,16 +90,6 @@
list1))) list1)))
(>a-b< 0 degr))))) (>a-b< 0 degr)))))
#|
(setf basis #'(lambda (degr)
(list degr)))
(cobar-basis-length basis 1 1)
(cobar-basis-length basis 2 1)
(cobar-basis-length basis 2 2)
(cobar-basis-length basis 3 1)
(cobar-basis-length basis 3 2)
(cobar-basis-length basis 3 3)
|#
(DEFUN COBAR-BASIS (basis) (DEFUN COBAR-BASIS (basis)
(declare (type basis basis)) (declare (type basis basis))
@ -139,9 +114,9 @@
#'rslt)))) #'rslt))))
#| The following version of the COBAR-BASIS function is #| The following version of the COBAR-BASIS function is
not correctly compiled with ACL-Unix, probably not correctly compiled with ACL-Unix, probably
because the too complicated (but natural and correct) because the too complicated (but natural and correct)
structure of closures. This version works on ACL-PC. structure of closures. This version works on ACL-PC.
(DEFUN COBAR-BASIS (basis) (DEFUN COBAR-BASIS (basis)
(declare (declare
(type basis basis)) (type basis basis))
@ -192,17 +167,6 @@
(>a-b> 0 degr)))))))) (>a-b> 0 degr))))))))
|# |#
#|
(setf basis #'(lambda (degr)
(list degr)))
(setf r (cobar-basis basis))
(funcall r 0)
(funcall r 1)
(funcall r 2)
(dotimes (i 7)
(print (funcall r i)))
(cobar-basis :locally-effective)
|#
(DEFUN COBAR-INTR-VRTC-DFFR (dffr) (DEFUN COBAR-INTR-VRTC-DFFR (dffr)
(declare (type morphism dffr)) (declare (type morphism dffr))
@ -223,8 +187,10 @@
(declare (declare
(type cbgn cbgn1) (type cbgn cbgn1)
(type iallp rest)) (type iallp rest))
(with-cbgn (degr1 gnrt1) cbgn1 (with-cbgn
(let ((d-gnrt1 (cmbn-list (gnrt-? dffr (1+ degr1) gnrt1))) (degr1 gnrt1) cbgn1
(let ((d-gnrt1 (cmbn-list (gnrt-? dffr (1+ degr1)
gnrt1)))
(d-rest (rslt (- degr degr1) rest)) (d-rest (rslt (- degr degr1) rest))
(degr1-1 (1- degr1)) (degr1-1 (1- degr1))
(first-sign (-1-expt-n-1 (length rest))) (first-sign (-1-expt-n-1 (length rest)))
@ -235,13 +201,15 @@
(nconc (nconc
(mapcar (mapcar
#'(lambda (term) #'(lambda (term)
(with-term (cffc gnrt) term (with-term
(cffc gnrt) term
(term (* first-sign cffc) (term (* first-sign cffc)
(cons (cbgn degr1-1 gnrt) rest)))) (cons (cbgn degr1-1 gnrt) rest))))
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 cbgn1 gnrt)))) (cons cbgn1 gnrt))))
d-rest))))))))) d-rest)))))))))
@ -256,17 +224,9 @@
(rslt degr (allp-list allp)))))))) (rslt degr (allp-list allp))))))))
#|
(setf d (soft-delta-infinity))
(setf r (cobar-intr-vrtc-dffr (dffr d)))
(funcall r 0 (allp))
(funcall r 3 (allp 3 (d 15)))
(funcall r 5 (allp 3 (d (mask 5)) 2 (d (mask 4))))
(funcall r 5 (allp 2 (d (mask 4)) 3 (d (mask 5)))))
|#
(DEFGENERIC VRTC-COBAR (chcm-or-hmeq-or-rdct)) (DEFGENERIC VRTC-COBAR (chcm-or-hmeq-or-rdct))
(DEFMETHOD VRTC-COBAR ((chcm chain-complex)) (DEFMETHOD VRTC-COBAR ((chcm chain-complex))
(the chain-complex (the chain-complex
(with-slots (cmpr basis dffr) chcm (with-slots (cmpr basis dffr) chcm
@ -282,24 +242,6 @@
:strt :gnrt :strt :gnrt
:orgn `(vrtc-cobar ,chcm))))) :orgn `(vrtc-cobar ,chcm)))))
#|
(cat-init)
(setf v (vrtc-cobar (soft-delta-infinity)))
(defun random-allp (length)
(let ((rslt nil))
(dotimes (i length)
(let* ((gmsm (random (mask 9)))
(dmns (1- (logcount gmsm))))
(when (plusp dmns)
(push (cbgn (1- dmns) (d gmsm)) rslt))))
(make-allp :list rslt)))
(dotimes (i 10) (print (random-allp 5)))
(dotimes (i 10)
(let ((allp (random-allp 3)))
(print allp)
(print (? v (apply #'+ (mapcar #'car (allp-list allp))) allp))
(print (? v (? v (apply #'+ (mapcar #'car (allp-list allp))) allp)))))
|#
(DEFUN COBAR-INTR-HRZN-DFFR (cprd) (DEFUN COBAR-INTR-HRZN-DFFR (cprd)
(declare (type morphism cprd)) (declare (type morphism cprd))
@ -316,20 +258,24 @@
(declare (declare
(type cbgn cbgn1) (type cbgn cbgn1)
(type iallp rest)) (type iallp rest))
(with-cbgn (degr1 gnrt1) cbgn1 (with-cbgn
(degr1 gnrt1) cbgn1
(let ((cprd-gnrt1 (cmbn-list (gnrt-? cprd (1+ degr1) gnrt1))) (let ((cprd-gnrt1 (cmbn-list (gnrt-? cprd (1+ degr1) gnrt1)))
(cprd-rest (rslt (- degr degr1) rest)) (cprd-rest (rslt (- degr degr1) rest))
(sign (-1-expt-n-1 (length rest)))) (sign (-1-expt-n-1 (length rest))))
(declare (declare
(type icmbn cprd-gnrt1 cprd-rest) (type icmbn cprd-gnrt1 cprd-rest)
(fixnum sign)) (fixnum sign))
(setf cprd-gnrt1 (rest (butlast cprd-gnrt1))) ;;; because \bar{A} ;;; because \bar{A}
(setf cprd-gnrt1 (rest (butlast cprd-gnrt1)))
(nconc (nconc
(mapcar (mapcar
#'(lambda (term1) #'(lambda (term1)
(declare (type term term1)) (declare (type term term1))
(with-term (nil tnpr) term1 ;;; cffc is in fact 1 (with-term
(with-tnpr (degr1 gnrt1 degr2 gnrt2) tnpr (nil tnpr) term1 ;;; cffc is in fact 1
(with-tnpr
(degr1 gnrt1 degr2 gnrt2) tnpr
(term sign ;;; (* cffc sign) (term sign ;;; (* cffc sign)
(cons (cbgn (1- degr1) gnrt1) (cons (cbgn (1- degr1) gnrt1)
(cons (cbgn (1- degr2) gnrt2) (cons (cbgn (1- degr2) gnrt2)
@ -351,18 +297,12 @@
(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 iallp) term (with-term
(term cffc (make-allp :list iallp)))) (cffc iallp) term
(term cffc (make-allp
:list iallp))))
(rslt degr (allp-list allp))))))))) (rslt degr (allp-list allp)))))))))
#|
(setf d (soft-delta-infinity))
(setf r (cobar-intr-hrzn-dffr (cprd d)))
(funcall r 0 (allp))
(funcall r 3 (allp 3 (d (mask 5))))
(funcall r 5 (allp 3 (d (mask 5)) 2 (d (mask 4))))
(funcall r 5 (allp 2 (d (mask 4)) 3 (d (mask 5))))
|#
(DEFUN COBAR-HRZN-DFFR (clgb) (DEFUN COBAR-HRZN-DFFR (clgb)
(declare (type coalgebra clgb)) (declare (type coalgebra clgb))
@ -374,27 +314,6 @@
:intr (cobar-intr-hrzn-dffr cprd) :strt :gnrt :intr (cobar-intr-hrzn-dffr cprd) :strt :gnrt
:orgn `(cobar-hrzn-dffr ,clgb))))) :orgn `(cobar-hrzn-dffr ,clgb)))))
#|
(cat-init)
(setf h (cobar-hrzn-dffr (soft-delta-infinity)))
(defun random-allp (length)
(let ((rslt nil))
(dotimes (i length)
(let* ((gmsm (random (mask 9)))
(dmns (1- (logcount gmsm))))
(when (plusp dmns)
(push (cbgn (1- dmns) (d gmsm)) rslt))))
(make-allp :list rslt)))
(dotimes (i 10) (print (random-allp 5)))
(setf allp (random-allp 4))
(? h (apply #'+ (mapcar #'car (allp-list allp))) allp)
(? h (? h (apply #'+ (mapcar #'car (allp-list allp))) allp))
(dotimes (i 10)
(let ((allp (random-allp 3)))
(print allp)
(print (? h (apply #'+ (mapcar #'car (allp-list allp))) allp))
(print (? h (? h (apply #'+ (mapcar #'car (allp-list allp))) allp)))))
|#
(DEFUN COBAR-INTR-DFFR (vrtc-dffr hrzn-dffr) (DEFUN COBAR-INTR-DFFR (vrtc-dffr hrzn-dffr)
(declare (type morphism vrtc-dffr hrzn-dffr)) (declare (type morphism vrtc-dffr hrzn-dffr))
@ -403,14 +322,17 @@
(fixnum degr) (fixnum degr)
(type allp allp)) (type allp allp))
(make-cmbn :degr (1- degr) (make-cmbn :degr (1- degr)
:list (append ;;; and not nconc, otherwise a terrible bug, when the :list (append ;;; and not nconc, otherwise a terrible
;;; bug, when the
;;; first result is stored in memory... ;;; first result is stored in memory...
(cmbn-list (gnrt-? vrtc-dffr degr allp)) (cmbn-list (gnrt-? vrtc-dffr degr allp))
(cmbn-list (gnrt-? hrzn-dffr degr allp)))))) (cmbn-list (gnrt-? hrzn-dffr degr allp))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
(DEFGENERIC COBAR (clgbr-or-hmeq)) (DEFGENERIC COBAR (clgbr-or-hmeq))
(DEFMETHOD COBAR ((coalgebra coalgebra)) (DEFMETHOD COBAR ((coalgebra coalgebra))
(let ((vrtc-cobar (vrtc-cobar coalgebra)) (let ((vrtc-cobar (vrtc-cobar coalgebra))
(cobar-hrzn-dffr (cobar-hrzn-dffr coalgebra))) (cobar-hrzn-dffr (cobar-hrzn-dffr coalgebra)))
@ -421,60 +343,46 @@
:cmpr (cmpr vrtc-cobar) :cmpr (cmpr vrtc-cobar)
:basis (basis vrtc-cobar) :basis (basis vrtc-cobar)
:bsgn +null-allp+ :bsgn +null-allp+
:intr-dffr (cobar-intr-dffr (dffr vrtc-cobar) cobar-hrzn-dffr) :intr-dffr (cobar-intr-dffr (dffr vrtc-cobar)
cobar-hrzn-dffr)
:strt :gnrt :strt :gnrt
:orgn `(add ,vrtc-cobar ,cobar-hrzn-dffr)))) :orgn `(add ,vrtc-cobar ,cobar-hrzn-dffr))))
(declare (type chain-complex rslt)) (declare (type chain-complex rslt))
(setf (slot-value rslt 'grmd) (grmd vrtc-cobar)) (setf (slot-value rslt 'grmd) (grmd vrtc-cobar))
rslt)))) rslt))))
#|
(cat-init)
(setf c (cobar (deltab)))
(defun random-allp (length)
(let ((rslt nil))
(dotimes (i length)
(let* ((gmsm (random (mask 9)))
(dmns (1- (logcount gmsm))))
(when (plusp dmns)
(push (cbgn (1- dmns) gmsm) rslt))))
(make-allp :list rslt)))
(dotimes (i 10) (print (random-allp 5)))
(setf allp (random-allp 4))
(? c (apply #'+ (mapcar #'car (allp-list allp))) allp)
(? c (? c (apply #'+ (mapcar #'car (allp-list allp))) allp))
(dotimes (i 10)
(let ((allp (random-allp 3)))
(print allp)
(print (? c (apply #'+ (mapcar #'car (allp-list allp))) allp))
(print (? c (? c (apply #'+ (mapcar #'car (allp-list allp))) allp)))))
|#
(DEFUN CMBN-ALLP-CMBN-TNPR (cmbn allp-cmbn) (DEFUN CMBN-ALLP-CMBN-TNPR (cmbn allp-cmbn)
(declare (type cmbn cmbn allp-cmbn)) (declare (type cmbn cmbn allp-cmbn))
(the cmbn (the cmbn
(with-cmbn (degr1 list1) cmbn (with-cmbn
(degr1 list1) cmbn
(decf degr1) ;; because allp organization (decf degr1) ;; because allp organization
(with-cmbn (degrr listr) allp-cmbn (with-cmbn
(degrr listr) allp-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 ((cbgn1 (cbgn degr1 gnrt1))) (let ((cbgn1 (cbgn degr1 gnrt1)))
(declare (type cbgn cbgn1)) (declare (type cbgn cbgn1))
(mapcar (mapcar
#'(lambda (termr) #'(lambda (termr)
(declare (type term termr)) (declare (type term termr))
(with-term (cffcr allpr) termr (with-term
(cffcr allpr) termr
(term (* cffc1 cffcr) (term (* cffc1 cffcr)
(make-allp (make-allp
:list (cons cbgn1 (allp-list allpr)))))) :list (cons cbgn1
(allp-list allpr))))))
listr)))) listr))))
list1)))))) list1))))))
(DEFUN NCMBN-COBAR (cmbn-list) (DEFUN NCMBN-COBAR (cmbn-list)
(declare (list cmbn-list)) (declare (list cmbn-list))
(the cmbn (the cmbn
@ -484,12 +392,7 @@
(cmbn-allp-cmbn-tnpr (cmbn-allp-cmbn-tnpr
(first cmbn-list) (first cmbn-list)
(ncmbn-cobar (rest cmbn-list)))))) (ncmbn-cobar (rest cmbn-list))))))
#|
(ncmbn-cobar nil)
(ncmbn-cobar (list (cmbn 3 2 'a 3 'b)))
(ncmbn-cobar (list (cmbn 1 2 'a 3 'b) (cmbn 2 4 'c 5 'd)))
(ncmbn-cobar (list (cmbn 1 2 'a 3 'b) (cmbn 1 4 'c 5 'd) (cmbn 1 6 'e 7 'f)))
|#
(DEFUN MRPH-VRTC-COBAR-INTR (mrph) (DEFUN MRPH-VRTC-COBAR-INTR (mrph)
(declare (type morphism mrph)) (declare (type morphism mrph))
@ -506,14 +409,6 @@
(allp-list allp)))))) (allp-list allp))))))
(the intr-mrph #'rslt))) (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-cobar-intr m))
(funcall r 4 (allp 2 3 2 4))
|#
(DEFMETHOD VRTC-COBAR ((mrph morphism)) (DEFMETHOD VRTC-COBAR ((mrph morphism))
(the morphism (the morphism
@ -527,13 +422,6 @@
:strt :gnrt :strt :gnrt
:orgn `(vrtc-cobar ,mrph))))) :orgn `(vrtc-cobar ,mrph)))))
#|
(cat-init)
(setf f (aw (soft-delta-infinity) (soft-delta-infinity)))
(setf cf (vrtc-cobar f))
(? cf 2 (allp 1 (crpr 0 (d 7) 0 (d 7)) 1 (crpr 0 (d 56) 0 (d 56))))
|#
(DEFUN HMTP-VRTC-COBAR-INTR (h gf) (DEFUN HMTP-VRTC-COBAR-INTR (h gf)
(declare (type morphism h gf)) (declare (type morphism h gf))
@ -543,7 +431,8 @@
(type allp allp)) (type allp allp))
(let* ((cbgn-list (reverse (allp-list allp))) (let* ((cbgn-list (reverse (allp-list allp)))
(rslt (list nil)) (rslt (list nil))
(sign (oddp (apply #'+ (mapcar #'car cbgn-list)))) ;; nil = -1 ;; t = +1 (sign (oddp (apply #'+ (mapcar #'car cbgn-list))))
;; nil = -1 ;; t = +1
(gfgf-tail (term-cmbn 0 1 +null-allp+))) (gfgf-tail (term-cmbn 0 1 +null-allp+)))
(declare (declare
(list cbgn-list rslt) (list cbgn-list rslt)
@ -554,13 +443,16 @@
(loop (loop
(let ((cbgn (car cbgn-list))) (let ((cbgn (car cbgn-list)))
(declare (type cbgn cbgn)) (declare (type cbgn cbgn))
(with-cbgn (degr gnrt) cbgn (with-cbgn
(degr gnrt) cbgn
(when (evenp degr) (when (evenp degr)
(setf sign (not sign))) (setf sign (not sign)))
(incf degr) (incf degr)
(let ((h-gnrt (gnrt-? h degr gnrt))) (let ((h-gnrt (gnrt-? h degr gnrt)))
(declare (type cmbn h-gnrt)) (declare (type cmbn h-gnrt))
(let ((hgfgf (cmbn-list (cmbn-allp-cmbn-tnpr h-gnrt gfgf-tail)))) (let ((hgfgf (cmbn-list (cmbn-allp-cmbn-tnpr
h-gnrt
gfgf-tail))))
(declare (type list hgfgf)) (declare (type list hgfgf))
(when sign (when sign
(mapc #'(lambda (term) (mapc #'(lambda (term)
@ -585,16 +477,6 @@
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
#|
(require "special-smsts")
(require "eilenberg-zilber")
(cat-init)
(setf ez (ez (delta-infinity) (delta-infinity)))
(setf h (h ez) gf (cmps (g ez) (f ez)))
(setf r (hmtp-vrtc-cobar-intr h gf))
(funcall r 3 (allp 1 (crpr 0 7 0 7) 1 (crpr 0 14 0 14) 1 (crpr 0 14 0 14)))
|#
(DEFUN HMTP-VRTC-COBAR (h gf) (DEFUN HMTP-VRTC-COBAR (h gf)
(declare (type morphism h gf)) (declare (type morphism h gf))
(unless (and (= +1 (degr h)) (unless (and (= +1 (degr h))
@ -613,6 +495,7 @@
:strt :gnrt :strt :gnrt
:orgn `(hmtp-vrtc-cobar ,h ,gf))))) :orgn `(hmtp-vrtc-cobar ,h ,gf)))))
(DEFMETHOD VRTC-COBAR ((rdct reduction)) (DEFMETHOD VRTC-COBAR ((rdct reduction))
(the reduction (the reduction
(if (eq (first (orgn rdct)) 'trivial-rdct) (if (eq (first (orgn rdct)) 'trivial-rdct)
@ -624,72 +507,6 @@
:h (hmtp-vrtc-cobar h (cmps g f)) :h (hmtp-vrtc-cobar h (cmps g f))
:orgn `(vrtc-cobar ,rdct)))))) :orgn `(vrtc-cobar ,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 cobar (vrtc-cobar rdct))
(pre-check-rdct cobar)
(defun aleat-tc ()
(do ((tdegr 0 (+ tdegr degr))
(degr (1+ (random 4)) (1+ (random 4)))
(gnrt (intern (coerce (vector (+ 65 (random 4))) 'string))
(intern (coerce (vector (+ 65 (random 4))) 'string)))
(rslt nil (cons (cbgn degr gnrt) rslt)))
((> tdegr 10) (setf *tc* (cmbn tdegr 1 (make-allp :list rslt))))))
(aleat-tc)
(defun aleat-bc ()
(do ((tdegr 0 (+ tdegr degr))
(degr (1+ (random 4)) (1+ (random 4)))
(gnrt (intern (coerce (vector (+ 67 (random 2))) 'string))
(intern (coerce (vector (+ 67 (random 2))) 'string)))
(rslt nil (cons (cbgn degr gnrt) rslt)))
((> tdegr 10) (setf *bc* (cmbn tdegr 1 (make-allp :list rslt))))))
(aleat-bc)
(defun c ()
(aleat-tc)
(aleat-bc)
(check-rdct))
(loop (c)) ;; degrees >= 15 is possible => error.
|#
(DEFMETHOD VRTC-COBAR ((hmeq homotopy-equivalence)) (DEFMETHOD VRTC-COBAR ((hmeq homotopy-equivalence))
(the homotopy-equivalence (the homotopy-equivalence
@ -701,6 +518,7 @@
:rrdct (vrtc-cobar rrdct) :rrdct (vrtc-cobar rrdct)
:orgn `(vrtc-cobar ,hmeq)))))) :orgn `(vrtc-cobar ,hmeq))))))
(DEFMETHOD COBAR ((hmeq homotopy-equivalence)) (DEFMETHOD COBAR ((hmeq homotopy-equivalence))
(unless (typep (lbcc hmeq) 'coalgebra) (unless (typep (lbcc hmeq) 'coalgebra)
(error "In (COBAR HMEQ), the LBCC should be a coalgebra.")) (error "In (COBAR HMEQ), the LBCC should be a coalgebra."))
@ -708,10 +526,3 @@
(if (eq (first (orgn hmeq)) 'trivial-hmeq) (if (eq (first (orgn hmeq)) 'trivial-hmeq)
(trivial-hmeq (cobar (lbcc hmeq))) (trivial-hmeq (cobar (lbcc hmeq)))
(add (vrtc-cobar hmeq) (cobar-hrzn-dffr (lbcc hmeq)))))) (add (vrtc-cobar hmeq) (cobar-hrzn-dffr (lbcc hmeq))))))
#|
(cat-init)
(setf h (left-hmeq (sphere 3)))
(setf c (cobar h))
(inspect c)
|#

26
test/bar-test.lisp
View File

@ -176,32 +176,6 @@
3 (cat:crpr 0 14 0 14)))))) 3 (cat:crpr 0 14 0 14))))))
(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 (cat:brgn degr gnrt) rslt)))
((> tdegr 10) (setf cat:*tc* (cat:cmbn tdegr 1 (cat:make-abar
:list rslt))))))
(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 (cat:brgn degr gnrt) rslt)))
((> tdegr 10) (setf cat:*bc* (cat:cmbn tdegr 1 (cat:make-abar
:list rslt))))))
(defun c ()
(aleat-tc)
(aleat-bc)
(check-rdct))
#| #|
(test vrtc-bar1 (test vrtc-bar1
(progn (progn

3
test/cl-space-efhm-test.lisp
View File

@ -237,6 +237,7 @@
(check-rdct)))))) (check-rdct))))))
|# |#
#|
(test cs-left-hmeq-left-reduction (test cs-left-hmeq-left-reduction
(cat:cat-init) (cat:cat-init)
(let ((rdct (cat:cs-left-hmeq-left-reduction (cat:k-z-1))) (let ((rdct (cat:cs-left-hmeq-left-reduction (cat:k-z-1)))
@ -298,7 +299,7 @@
(setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt)) (setf cat:*tc* (cat:cmbn (+ 4 abar-degr) 1 gnrt))
(setf cat:*bc* (cat:cmbn 5 1 gbar)) (setf cat:*bc* (cat:cmbn 5 1 gbar))
(check-rdct)))))) (check-rdct))))))
|#
(test cs-pre-left-hmeq-right-reduction-intr-f (test cs-pre-left-hmeq-right-reduction-intr-f
(cat:cs-pre-left-hmeq-right-reduction-intr-f (cat:cs-pre-left-hmeq-right-reduction-intr-f

26
test/common.lisp
View File

@ -184,3 +184,29 @@
list) list)
list)) list))
rslt))) rslt)))
(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 (cat:brgn degr gnrt) rslt)))
((> tdegr 10) (setf cat:*tc* (cat:cmbn tdegr 1 (cat:make-abar
:list rslt))))))
(defun aleat-bc ()
(do ((tdegr 0 (+ tdegr degr))
(degr (1+ (random 4)) (1+ (random 4)))
(gnrt (intern (coerce (vector (code-char (+ 67 (random 2)))) 'string))
(intern (coerce (vector (code-char (+ 67 (random 2)))) 'string)))
(rslt nil (cons (cat:brgn degr gnrt) rslt)))
((> tdegr 10) (setf cat:*bc* (cat:cmbn tdegr 1 (cat:make-abar
:list rslt))))))
(defun c ()
(aleat-tc)
(aleat-bc)
(check-rdct))