Extracted cobar tests.
This commit is contained in:
Gerd Heber
parent
3c0bf751c4
commit
c6666fbe3d
@ -19,6 +19,7 @@
|
||||
(:file "circle")
|
||||
(:file "cl-space-efhm-test")
|
||||
(:file "classifying-spaces-test")
|
||||
(:file "cobar-test")
|
||||
(:file "combinations-test")
|
||||
(:file "cones-test")
|
||||
(:file "delta-test")
|
||||
|
||||
19
package.lisp
19
package.lisp
@ -113,8 +113,10 @@
|
||||
|
||||
ABSM
|
||||
AB-SIMPLICIAL-GROUP
|
||||
ALLP-LIST
|
||||
BCC
|
||||
BRGN
|
||||
CBGN
|
||||
CHAIN-COMPLEX
|
||||
CMBN-CMBN
|
||||
CMBN-DEGR
|
||||
@ -134,6 +136,7 @@
|
||||
KAN
|
||||
LRDCT
|
||||
MAKE-ABAR
|
||||
MAKE-ALLP
|
||||
MAKE-CMBN
|
||||
MAKE-RESULT
|
||||
MORPHISM
|
||||
@ -159,6 +162,21 @@
|
||||
NORMALIZE-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
|
||||
|
||||
2CMBN-ADD
|
||||
@ -205,6 +223,7 @@
|
||||
DELTA-FACE
|
||||
DELTA-INFINITY
|
||||
DELTA-N-BASIS
|
||||
DELTAB
|
||||
DELTAB2-BNDR
|
||||
DELTAB2-DGNL
|
||||
SOFT-DELTA
|
||||
|
||||
291
src/cobar.lisp
291
src/cobar.lisp
@ -20,13 +20,6 @@
|
||||
(push (cbgn (car mark) (cadr mark)) 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 (DEFPARAMETER +NULL-ALLP+ (make-allp :list +empty-list+))
|
||||
@ -65,14 +58,6 @@
|
||||
list1 list2))))))
|
||||
(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)
|
||||
(declare
|
||||
@ -105,16 +90,6 @@
|
||||
list1)))
|
||||
(>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)
|
||||
(declare (type basis basis))
|
||||
@ -139,9 +114,9 @@
|
||||
#'rslt))))
|
||||
|
||||
#| The following version of the COBAR-BASIS function is
|
||||
not correctly compiled with ACL-Unix, probably
|
||||
because the too complicated (but natural and correct)
|
||||
structure of closures. This version works on ACL-PC.
|
||||
not correctly compiled with ACL-Unix, probably
|
||||
because the too complicated (but natural and correct)
|
||||
structure of closures. This version works on ACL-PC.
|
||||
(DEFUN COBAR-BASIS (basis)
|
||||
(declare
|
||||
(type basis basis))
|
||||
@ -192,17 +167,6 @@
|
||||
(>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)
|
||||
(declare (type morphism dffr))
|
||||
@ -223,8 +187,10 @@
|
||||
(declare
|
||||
(type cbgn cbgn1)
|
||||
(type iallp rest))
|
||||
(with-cbgn (degr1 gnrt1) cbgn1
|
||||
(let ((d-gnrt1 (cmbn-list (gnrt-? dffr (1+ degr1) gnrt1)))
|
||||
(with-cbgn
|
||||
(degr1 gnrt1) cbgn1
|
||||
(let ((d-gnrt1 (cmbn-list (gnrt-? dffr (1+ degr1)
|
||||
gnrt1)))
|
||||
(d-rest (rslt (- degr degr1) rest))
|
||||
(degr1-1 (1- degr1))
|
||||
(first-sign (-1-expt-n-1 (length rest)))
|
||||
@ -235,13 +201,15 @@
|
||||
(nconc
|
||||
(mapcar
|
||||
#'(lambda (term)
|
||||
(with-term (cffc gnrt) term
|
||||
(with-term
|
||||
(cffc gnrt) term
|
||||
(term (* first-sign cffc)
|
||||
(cons (cbgn degr1-1 gnrt) rest))))
|
||||
d-gnrt1)
|
||||
(mapcar
|
||||
#'(lambda (term)
|
||||
(with-term (cffc gnrt) term
|
||||
(with-term
|
||||
(cffc gnrt) term
|
||||
(term (* rest-sign cffc)
|
||||
(cons cbgn1 gnrt))))
|
||||
d-rest)))))))))
|
||||
@ -256,17 +224,9 @@
|
||||
(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))
|
||||
|
||||
|
||||
(DEFMETHOD VRTC-COBAR ((chcm chain-complex))
|
||||
(the chain-complex
|
||||
(with-slots (cmpr basis dffr) chcm
|
||||
@ -282,24 +242,6 @@
|
||||
:strt :gnrt
|
||||
: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)
|
||||
(declare (type morphism cprd))
|
||||
@ -316,20 +258,24 @@
|
||||
(declare
|
||||
(type cbgn cbgn1)
|
||||
(type iallp rest))
|
||||
(with-cbgn (degr1 gnrt1) cbgn1
|
||||
(with-cbgn
|
||||
(degr1 gnrt1) cbgn1
|
||||
(let ((cprd-gnrt1 (cmbn-list (gnrt-? cprd (1+ degr1) gnrt1)))
|
||||
(cprd-rest (rslt (- degr degr1) rest))
|
||||
(sign (-1-expt-n-1 (length rest))))
|
||||
(declare
|
||||
(type icmbn cprd-gnrt1 cprd-rest)
|
||||
(fixnum sign))
|
||||
(setf cprd-gnrt1 (rest (butlast cprd-gnrt1))) ;;; because \bar{A}
|
||||
;;; because \bar{A}
|
||||
(setf cprd-gnrt1 (rest (butlast cprd-gnrt1)))
|
||||
(nconc
|
||||
(mapcar
|
||||
#'(lambda (term1)
|
||||
(declare (type term term1))
|
||||
(with-term (nil tnpr) term1 ;;; cffc is in fact 1
|
||||
(with-tnpr (degr1 gnrt1 degr2 gnrt2) tnpr
|
||||
(with-term
|
||||
(nil tnpr) term1 ;;; cffc is in fact 1
|
||||
(with-tnpr
|
||||
(degr1 gnrt1 degr2 gnrt2) tnpr
|
||||
(term sign ;;; (* cffc sign)
|
||||
(cons (cbgn (1- degr1) gnrt1)
|
||||
(cons (cbgn (1- degr2) gnrt2)
|
||||
@ -351,18 +297,12 @@
|
||||
(make-cmbn :degr (1- degr)
|
||||
:list (mapcar #'(lambda (term)
|
||||
(declare (type term term))
|
||||
(with-term (cffc iallp) term
|
||||
(term cffc (make-allp :list iallp))))
|
||||
(with-term
|
||||
(cffc iallp) term
|
||||
(term cffc (make-allp
|
||||
:list iallp))))
|
||||
(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)
|
||||
(declare (type coalgebra clgb))
|
||||
@ -374,27 +314,6 @@
|
||||
:intr (cobar-intr-hrzn-dffr cprd) :strt :gnrt
|
||||
: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)
|
||||
(declare (type morphism vrtc-dffr hrzn-dffr))
|
||||
@ -403,14 +322,17 @@
|
||||
(fixnum degr)
|
||||
(type allp allp))
|
||||
(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...
|
||||
(cmbn-list (gnrt-? vrtc-dffr degr allp))
|
||||
(cmbn-list (gnrt-? hrzn-dffr degr allp))))))
|
||||
(the intr-mrph #'rslt)))
|
||||
|
||||
|
||||
(DEFGENERIC COBAR (clgbr-or-hmeq))
|
||||
|
||||
|
||||
(DEFMETHOD COBAR ((coalgebra coalgebra))
|
||||
(let ((vrtc-cobar (vrtc-cobar coalgebra))
|
||||
(cobar-hrzn-dffr (cobar-hrzn-dffr coalgebra)))
|
||||
@ -421,60 +343,46 @@
|
||||
:cmpr (cmpr vrtc-cobar)
|
||||
:basis (basis vrtc-cobar)
|
||||
: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
|
||||
:orgn `(add ,vrtc-cobar ,cobar-hrzn-dffr))))
|
||||
(declare (type chain-complex rslt))
|
||||
(setf (slot-value rslt 'grmd) (grmd vrtc-cobar))
|
||||
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)
|
||||
(declare (type cmbn cmbn allp-cmbn))
|
||||
(the cmbn
|
||||
(with-cmbn (degr1 list1) cmbn
|
||||
(with-cmbn
|
||||
(degr1 list1) cmbn
|
||||
(decf degr1) ;; because allp organization
|
||||
(with-cmbn (degrr listr) allp-cmbn
|
||||
(with-cmbn
|
||||
(degrr listr) allp-cmbn
|
||||
(make-cmbn
|
||||
:degr (+ degr1 degrr)
|
||||
:list
|
||||
(mapcan
|
||||
#'(lambda (term1)
|
||||
(declare (type term term1))
|
||||
(with-term (cffc1 gnrt1) term1
|
||||
(with-term
|
||||
(cffc1 gnrt1) term1
|
||||
(let ((cbgn1 (cbgn degr1 gnrt1)))
|
||||
(declare (type cbgn cbgn1))
|
||||
(mapcar
|
||||
#'(lambda (termr)
|
||||
(declare (type term termr))
|
||||
(with-term (cffcr allpr) termr
|
||||
(with-term
|
||||
(cffcr allpr) termr
|
||||
(term (* cffc1 cffcr)
|
||||
(make-allp
|
||||
:list (cons cbgn1 (allp-list allpr))))))
|
||||
:list (cons cbgn1
|
||||
(allp-list allpr))))))
|
||||
listr))))
|
||||
list1))))))
|
||||
|
||||
|
||||
(DEFUN NCMBN-COBAR (cmbn-list)
|
||||
(declare (list cmbn-list))
|
||||
(the cmbn
|
||||
@ -484,12 +392,7 @@
|
||||
(cmbn-allp-cmbn-tnpr
|
||||
(first 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)
|
||||
(declare (type morphism mrph))
|
||||
@ -506,14 +409,6 @@
|
||||
(allp-list allp))))))
|
||||
(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))
|
||||
(the morphism
|
||||
@ -527,13 +422,6 @@
|
||||
:strt :gnrt
|
||||
: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)
|
||||
(declare (type morphism h gf))
|
||||
@ -543,7 +431,8 @@
|
||||
(type allp allp))
|
||||
(let* ((cbgn-list (reverse (allp-list allp)))
|
||||
(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+)))
|
||||
(declare
|
||||
(list cbgn-list rslt)
|
||||
@ -554,13 +443,16 @@
|
||||
(loop
|
||||
(let ((cbgn (car cbgn-list)))
|
||||
(declare (type cbgn cbgn))
|
||||
(with-cbgn (degr gnrt) cbgn
|
||||
(with-cbgn
|
||||
(degr gnrt) cbgn
|
||||
(when (evenp degr)
|
||||
(setf sign (not sign)))
|
||||
(incf degr)
|
||||
(let ((h-gnrt (gnrt-? h degr 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))
|
||||
(when sign
|
||||
(mapc #'(lambda (term)
|
||||
@ -585,16 +477,6 @@
|
||||
(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)
|
||||
(declare (type morphism h gf))
|
||||
(unless (and (= +1 (degr h))
|
||||
@ -613,6 +495,7 @@
|
||||
:strt :gnrt
|
||||
:orgn `(hmtp-vrtc-cobar ,h ,gf)))))
|
||||
|
||||
|
||||
(DEFMETHOD VRTC-COBAR ((rdct reduction))
|
||||
(the reduction
|
||||
(if (eq (first (orgn rdct)) 'trivial-rdct)
|
||||
@ -624,72 +507,6 @@
|
||||
:h (hmtp-vrtc-cobar h (cmps g f))
|
||||
: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))
|
||||
(the homotopy-equivalence
|
||||
@ -701,6 +518,7 @@
|
||||
:rrdct (vrtc-cobar rrdct)
|
||||
:orgn `(vrtc-cobar ,hmeq))))))
|
||||
|
||||
|
||||
(DEFMETHOD COBAR ((hmeq homotopy-equivalence))
|
||||
(unless (typep (lbcc hmeq) 'coalgebra)
|
||||
(error "In (COBAR HMEQ), the LBCC should be a coalgebra."))
|
||||
@ -708,10 +526,3 @@
|
||||
(if (eq (first (orgn hmeq)) 'trivial-hmeq)
|
||||
(trivial-hmeq (cobar (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)
|
||||
|#
|
||||
|
||||
@ -176,32 +176,6 @@
|
||||
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
|
||||
(progn
|
||||
|
||||
@ -237,6 +237,7 @@
|
||||
(check-rdct))))))
|
||||
|#
|
||||
|
||||
#|
|
||||
(test cs-left-hmeq-left-reduction
|
||||
(cat:cat-init)
|
||||
(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:*bc* (cat:cmbn 5 1 gbar))
|
||||
(check-rdct))))))
|
||||
|
||||
|#
|
||||
|
||||
(test cs-pre-left-hmeq-right-reduction-intr-f
|
||||
(cat:cs-pre-left-hmeq-right-reduction-intr-f
|
||||
|
||||
@ -184,3 +184,29 @@
|
||||
list)
|
||||
list))
|
||||
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))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user