First batch of classifying spaces tests.
This commit is contained in:
Gerd Heber
parent
a75a2ee3d5
commit
23dd20c419
@ -149,6 +149,11 @@
|
|||||||
|
|
||||||
+NULL-GBAR+
|
+NULL-GBAR+
|
||||||
CLASSIFYING-SPACE
|
CLASSIFYING-SPACE
|
||||||
|
CLASSIFYING-SPACE-BASIS
|
||||||
|
CLASSIFYING-SPACE-CMPR
|
||||||
|
GBAR
|
||||||
|
NORMALIZE-GBAR
|
||||||
|
UNNORMALIZE-GBAR
|
||||||
|
|
||||||
;; combinations.lisp
|
;; combinations.lisp
|
||||||
|
|
||||||
@ -302,6 +307,7 @@
|
|||||||
LF
|
LF
|
||||||
LG
|
LG
|
||||||
MASK
|
MASK
|
||||||
|
MAKE-GBAR
|
||||||
RBCC
|
RBCC
|
||||||
RF
|
RF
|
||||||
RG
|
RG
|
||||||
|
|||||||
@ -14,175 +14,121 @@
|
|||||||
(type gbar gbar) (stream stream)
|
(type gbar gbar) (stream stream)
|
||||||
(ignore depth))
|
(ignore depth))
|
||||||
(the gbar
|
(the gbar
|
||||||
(progn
|
(progn
|
||||||
(princ "<<GBar" stream)
|
(princ "<<GBar" stream)
|
||||||
(dolist (absm (gbar-list gbar))
|
(dolist (absm (gbar-list gbar))
|
||||||
(declare (type absm absm))
|
(declare (type absm absm))
|
||||||
(with-absm (dgop gmsm) absm
|
(with-absm (dgop gmsm) absm
|
||||||
(format stream "<~A ~A>"
|
(format stream "<~A ~A>"
|
||||||
(hyphenize-list (dgop-int-ext dgop))
|
(hyphenize-list (dgop-int-ext dgop))
|
||||||
gmsm)))
|
gmsm)))
|
||||||
(princ ">>" stream)
|
(princ ">>" stream)
|
||||||
gbar)))
|
gbar)))
|
||||||
|
|
||||||
;;; NIGBAR = non-normalized igbar (with dimension)
|
;;; NIGBAR = non-normalized igbar (with dimension)
|
||||||
|
|
||||||
(DEFUN NORMALIZE-GBAR (nigbar)
|
(DEFUN NORMALIZE-GBAR (nigbar)
|
||||||
(declare (list nigbar))
|
(declare (list nigbar))
|
||||||
(the absm
|
(the absm
|
||||||
(let ((dmns (first nigbar))
|
(let ((dmns (first nigbar))
|
||||||
(igbar (rest nigbar)))
|
(igbar (rest nigbar)))
|
||||||
(declare
|
(declare
|
||||||
(fixnum dmns)
|
(fixnum dmns)
|
||||||
(list igbar))
|
(list igbar))
|
||||||
(when (zerop dmns)
|
(when (zerop dmns)
|
||||||
(return-from normalize-gbar (absm 0 +null-gbar+)))
|
(return-from normalize-gbar (absm 0 +null-gbar+)))
|
||||||
(do ((mark igbar (cdr mark))
|
(do ((mark igbar (cdr mark))
|
||||||
(indx (1- dmns) (1- indx))
|
(indx (1- dmns) (1- indx))
|
||||||
(2-indx (2-exp (1- dmns)) (ash 2-indx -1))
|
(2-indx (2-exp (1- dmns)) (ash 2-indx -1))
|
||||||
(mask (mask (1- dmns)) (ash mask -1))
|
(mask (mask (1- dmns)) (ash mask -1))
|
||||||
(and-dgops -1 (logand and-dgops (dgop (car mark))))
|
(and-dgops -1 (logand and-dgops (dgop (car mark))))
|
||||||
;; r = result
|
;; r = result
|
||||||
(r-dgop 0)
|
(r-dgop 0)
|
||||||
(r-absm-list +empty-list+))
|
(r-absm-list +empty-list+))
|
||||||
((endp mark)
|
((endp mark)
|
||||||
(absm r-dgop
|
|
||||||
(make-gbar
|
|
||||||
:dmns (- dmns (logcount r-dgop))
|
|
||||||
:list (nreverse r-absm-list))))
|
|
||||||
(declare
|
|
||||||
(list mark r-absm-list)
|
|
||||||
(fixnum indx 2-indx mask and-dgops r-dgop))
|
|
||||||
(when (zerop and-dgops)
|
|
||||||
(return-from normalize-gbar
|
|
||||||
(absm r-dgop
|
(absm r-dgop
|
||||||
(make-gbar
|
(make-gbar
|
||||||
:dmns (- dmns (logcount r-dgop))
|
:dmns (- dmns (logcount r-dgop))
|
||||||
:list (nreconc r-absm-list mark)))))
|
:list (nreverse r-absm-list))))
|
||||||
(let ((absm (car mark)))
|
(declare
|
||||||
(with-absm (dgop gmsm) absm
|
(list mark r-absm-list)
|
||||||
(declare (ignore gmsm))
|
(fixnum indx 2-indx mask and-dgops r-dgop))
|
||||||
(if (and (= dgop mask)
|
(when (zerop and-dgops)
|
||||||
(logbitp indx and-dgops))
|
(return-from normalize-gbar
|
||||||
(progn
|
(absm r-dgop
|
||||||
(incf r-dgop 2-indx)
|
(make-gbar
|
||||||
(mapl
|
:dmns (- dmns (logcount r-dgop))
|
||||||
#'(lambda (sublist)
|
:list (nreconc r-absm-list mark)))))
|
||||||
(declare (list sublist))
|
(let ((absm (car mark)))
|
||||||
(setf (car sublist)
|
(with-absm
|
||||||
(let ((absm (car sublist)))
|
(dgop gmsm) absm
|
||||||
(declare (type absm absm))
|
(declare (ignore gmsm))
|
||||||
(with-absm (dgop gmsm) absm
|
(if (and (= dgop mask)
|
||||||
(absm (multiple-value-bind (q r)
|
(logbitp indx and-dgops))
|
||||||
(floor dgop 2-indx)
|
(progn
|
||||||
(declare (fixnum q r))
|
(incf r-dgop 2-indx)
|
||||||
(+ (ash (1- q) (1- indx)) r))
|
(mapl
|
||||||
gmsm)))))
|
#'(lambda (sublist)
|
||||||
r-absm-list))
|
(declare (list sublist))
|
||||||
(push absm r-absm-list))))))))
|
(setf (car sublist)
|
||||||
|
(let ((absm (car sublist)))
|
||||||
|
(declare (type absm absm))
|
||||||
|
(with-absm
|
||||||
|
(dgop gmsm) absm
|
||||||
|
(absm (multiple-value-bind (q r)
|
||||||
|
(floor dgop 2-indx)
|
||||||
|
(declare (fixnum q r))
|
||||||
|
(+ (ash (1- q) (1- indx)) r))
|
||||||
|
gmsm)))))
|
||||||
|
r-absm-list))
|
||||||
|
(push absm r-absm-list))))))))
|
||||||
|
|
||||||
#|
|
|
||||||
()
|
|
||||||
(normalize-gbar (list 0))
|
|
||||||
(normalize-gbar (list 1 (absm 0 'i)))
|
|
||||||
(normalize-gbar (list 2 (absm 1 'i) (absm 0 'i)))
|
|
||||||
(normalize-gbar (list 2 (absm 0 'a) (absm 0 'i)))
|
|
||||||
(normalize-gbar (list 4 (absm 0 'a) (absm 0 'b) (absm 0 'c) (absm 0 'i)))
|
|
||||||
(normalize-gbar (list 4 (absm 7 'i) (absm 3 'i) (absm 1 'i) (absm 0 'i)))
|
|
||||||
(normalize-gbar (list 4 (absm 0 'a) (absm 3 'i) (absm 0 'c) (absm 0 'i)))
|
|
||||||
(normalize-gbar (list 4 (absm 1 'a) (absm 3 'i) (absm 0 'c) (absm 0 'i)))
|
|
||||||
(normalize-gbar (list 4 (absm 2 'a) (absm 3 'i) (absm 0 'c) (absm 0 'i)))
|
|
||||||
(normalize-gbar (list 4 (absm 4 'a) (absm 3 'i) (absm 0 'c) (absm 0 'i)))
|
|
||||||
(normalize-gbar (list 4 (absm 3 'a) (absm 3 'i) (absm 0 'c) (absm 0 'i)))
|
|
||||||
(normalize-gbar (list 4 (absm 5 'a) (absm 3 'i) (absm 0 'c) (absm 0 'i)))
|
|
||||||
(normalize-gbar (list 4 (absm 6 'a) (absm 3 'i) (absm 0 'c) (absm 0 'i)))
|
|
||||||
(normalize-gbar (list 4 (absm 1 'a) (absm 3 'i) (absm 1 'i) (absm 0 'i)))
|
|
||||||
|#
|
|
||||||
|
|
||||||
(DEFUN UNNORMALIZE-GBAR (absm idnt)
|
(DEFUN UNNORMALIZE-GBAR (absm idnt)
|
||||||
(declare
|
(declare
|
||||||
(type absm absm)
|
(type absm absm)
|
||||||
(type gmsm idnt))
|
(type gmsm idnt))
|
||||||
(the list ;; igbar
|
(the list ;; igbar
|
||||||
(with-absm (dgop gbar) absm
|
(with-absm (dgop gbar) absm
|
||||||
(with-gbar (dmns list) gbar
|
(with-gbar (dmns list) gbar
|
||||||
(setf list (reverse list))
|
(setf list (reverse list))
|
||||||
(do ((dgop2 dgop (ash dgop2 -1))
|
(do ((dgop2 dgop (ash dgop2 -1))
|
||||||
(indx 0 (1+ indx))
|
(indx 0 (1+ indx))
|
||||||
(2-indx 1 (ash 2-indx 1))
|
(2-indx 1 (ash 2-indx 1))
|
||||||
(dgop3 0)
|
(dgop3 0)
|
||||||
(rslt +empty-list+))
|
(rslt +empty-list+))
|
||||||
((zerop dgop2)
|
((zerop dgop2)
|
||||||
(cons (+ dmns (logcount dgop))
|
(cons (+ dmns (logcount dgop))
|
||||||
(nreconc
|
(nreconc
|
||||||
(mapcar
|
(mapcar
|
||||||
#'(lambda (absm)
|
#'(lambda (absm)
|
||||||
(declare (type absm absm))
|
(declare (type absm absm))
|
||||||
(ndgnr dgop3 absm))
|
(ndgnr dgop3 absm))
|
||||||
list)
|
list)
|
||||||
rslt)))
|
rslt)))
|
||||||
(declare
|
(declare
|
||||||
(list rslt)
|
(list rslt)
|
||||||
(fixnum dgop2 2-indx dgop3))
|
(fixnum dgop2 2-indx dgop3))
|
||||||
(if (oddp dgop2)
|
(if (oddp dgop2)
|
||||||
(progn
|
(progn
|
||||||
(push (absm (mask indx) idnt) rslt)
|
(push (absm (mask indx) idnt) rslt)
|
||||||
(incf dgop3 2-indx))
|
(incf dgop3 2-indx))
|
||||||
(push (ndgnr dgop3 (pop list)) rslt)))))))
|
(push (ndgnr dgop3 (pop list)) rslt)))))))
|
||||||
|
|
||||||
#|
|
|
||||||
()
|
|
||||||
(unnormalize-gbar (absm 1 +null-gbar+) 'i)
|
|
||||||
(unnormalize-gbar (absm 15 +null-gbar+) 'i)
|
|
||||||
(normalize-gbar (unnormalize-gbar (absm 15 +null-gbar+) 'i))
|
|
||||||
(unnormalize-gbar
|
|
||||||
(absm 0 (make-gbar :dmns 4
|
|
||||||
:list (list (absm 0 'a) (absm 0 'b)
|
|
||||||
(absm 0 'c) (absm 0 'i)))) 'i)
|
|
||||||
(normalize-gbar
|
|
||||||
(unnormalize-gbar
|
|
||||||
(absm 0 (make-gbar :dmns 4
|
|
||||||
:list (list (absm 0 'a) (absm 0 'b)
|
|
||||||
(absm 0 'c) (absm 0 'i)))) 'i))
|
|
||||||
(unnormalize-gbar
|
|
||||||
(absm 5 (make-gbar :dmns 4
|
|
||||||
:list (list (absm 0 'a) (absm 0 'b)
|
|
||||||
(absm 0 'c) (absm 0 'i)))) 'i)
|
|
||||||
(normalize-gbar
|
|
||||||
(unnormalize-gbar
|
|
||||||
(absm 5 (make-gbar :dmns 4
|
|
||||||
:list (list (absm 0 'a) (absm 0 'b)
|
|
||||||
(absm 0 'c) (absm 0 'i)))) 'i))
|
|
||||||
(unnormalize-gbar
|
|
||||||
(absm 9 (make-gbar :dmns 4
|
|
||||||
:list (list (absm 0 'a) (absm 0 'b)
|
|
||||||
(absm 0 'c) (absm 0 'i)))) 'i)
|
|
||||||
(normalize-gbar
|
|
||||||
(unnormalize-gbar
|
|
||||||
(absm 9 (make-gbar :dmns 4
|
|
||||||
:list (list (absm 0 'a) (absm 0 'b)
|
|
||||||
(absm 0 'c) (absm 0 'i)))) 'i))
|
|
||||||
|#
|
|
||||||
|
|
||||||
(DEFUN GBAR (dmns &rest rest)
|
(DEFUN GBAR (dmns &rest rest)
|
||||||
(the gbar
|
(the gbar
|
||||||
(progn
|
(progn
|
||||||
(unless (= (+ dmns dmns) (length rest))
|
(unless (= (+ dmns dmns) (length rest))
|
||||||
(error "In GBAR, the argument list has a wrong length."))
|
(error "In GBAR, the argument list has a wrong length."))
|
||||||
(make-gbar :dmns dmns
|
(make-gbar :dmns dmns
|
||||||
:list (do ((mark rest (cddr mark))
|
:list (do ((mark rest (cddr mark))
|
||||||
(rslt +empty-list+
|
(rslt +empty-list+
|
||||||
(cons (absm (car mark) (cadr mark))
|
(cons (absm (car mark) (cadr mark))
|
||||||
rslt)))
|
rslt)))
|
||||||
((endp mark) (nreverse rslt))
|
((endp mark) (nreverse rslt))
|
||||||
(declare (list mark rslt)))))))
|
(declare (list mark rslt)))))))
|
||||||
|
|
||||||
#|
|
|
||||||
()
|
|
||||||
(gbar 0)
|
|
||||||
(gbar 1)
|
|
||||||
(gbar 2 1 'a 2 'b)
|
|
||||||
|#
|
|
||||||
|
|
||||||
(DEFUN CLASSIFYING-SPACE-CMPR (cmpr)
|
(DEFUN CLASSIFYING-SPACE-CMPR (cmpr)
|
||||||
(declare (type cmprf cmpr))
|
(declare (type cmprf cmpr))
|
||||||
@ -193,14 +139,8 @@
|
|||||||
(declare (type absm absm1 absm2))
|
(declare (type absm absm1 absm2))
|
||||||
(a-cmpr3 cmpr absm1 absm2))
|
(a-cmpr3 cmpr absm1 absm2))
|
||||||
(gbar-list gbar1) (gbar-list gbar2))))
|
(gbar-list gbar1) (gbar-list gbar2))))
|
||||||
(the cmprf #'rslt)))
|
(the cmprf #'rslt)))
|
||||||
|
|
||||||
#|
|
|
||||||
(setf cmpr (classifying-space-cmpr 's-cmpr))
|
|
||||||
(funcall cmpr (gbar 2 0 'a 0 'a) (gbar 2 1 'a 0 'a))
|
|
||||||
(funcall cmpr (gbar 2 0 'a 0 'a) (gbar 2 0 'b 0 'a))
|
|
||||||
(funcall cmpr (gbar 2 0 'a 0 'a) (gbar 2 0 'a 0 'a))
|
|
||||||
|#
|
|
||||||
|
|
||||||
(DEFUN CLASSIFYING-SPACE-BASIS (basis)
|
(DEFUN CLASSIFYING-SPACE-BASIS (basis)
|
||||||
(declare (type basis basis))
|
(declare (type basis basis))
|
||||||
@ -213,51 +153,42 @@
|
|||||||
(type gmsm idnt))
|
(type gmsm idnt))
|
||||||
(labels
|
(labels
|
||||||
((rslt (dmns)
|
((rslt (dmns)
|
||||||
(declare (fixnum dmns))
|
(declare (fixnum dmns))
|
||||||
(when (minusp dmns)
|
(when (minusp dmns)
|
||||||
(return-from rslt +empty-list+))
|
(return-from rslt +empty-list+))
|
||||||
(when (zerop dmns)
|
(when (zerop dmns)
|
||||||
(return-from rslt (list +null-gbar+)))
|
(return-from rslt (list +null-gbar+)))
|
||||||
(let ((basis-1 (funcall crts-basis (1- dmns))))
|
(let ((basis-1 (funcall crts-basis (1- dmns))))
|
||||||
(declare (list basis-1))
|
(declare (list basis-1))
|
||||||
(nreverse
|
(nreverse
|
||||||
(mapcar ;; xxx bug
|
(mapcar ;; xxx bug
|
||||||
#'(lambda (crpr)
|
#'(lambda (crpr)
|
||||||
(declare (type crpr crpr))
|
(declare (type crpr crpr))
|
||||||
(with-crpr
|
(with-crpr
|
||||||
(absm1 absm2) crpr
|
(absm1 absm2) crpr
|
||||||
(make-gbar
|
(make-gbar
|
||||||
:dmns dmns
|
:dmns dmns
|
||||||
:list (cons absm1
|
:list (cons absm1
|
||||||
(rest (unnormalize-gbar absm2 idnt))))))
|
(rest (unnormalize-gbar absm2 idnt))))))
|
||||||
(member-if ;; xxx bug
|
(member-if ;; xxx bug
|
||||||
#'(lambda (dgop)
|
#'(lambda (dgop)
|
||||||
(declare (fixnum dgop))
|
(declare (fixnum dgop))
|
||||||
(< dgop (mask (1- dmns))))
|
(< dgop (mask (1- dmns))))
|
||||||
(reverse basis-1)
|
(reverse basis-1)
|
||||||
:key #'dgop1))))))
|
:key #'dgop1))))))
|
||||||
;;; :key #'caadr))))))
|
;;; :key #'caadr))))))
|
||||||
(setf crts-basis (crts-prdc-basis basis #'rslt))
|
(setf crts-basis (crts-prdc-basis basis #'rslt))
|
||||||
(the basis #'rslt))))
|
(the basis #'rslt))))
|
||||||
|
|
||||||
#|
|
|
||||||
()
|
|
||||||
(cat-init)
|
|
||||||
(setf k (k-z2-1))
|
|
||||||
(setf b (classifying-space-basis (basis k)))
|
|
||||||
(funcall b 0)
|
|
||||||
(funcall b 1)
|
|
||||||
(dotimes (i 5) (print (funcall b i)))
|
|
||||||
|#
|
|
||||||
|
|
||||||
(DEFUN CLASSIFYING-SPACE-FACE (face sintr-grml)
|
(DEFUN CLASSIFYING-SPACE-FACE (face sintr-grml)
|
||||||
(declare
|
(declare
|
||||||
(type face face)
|
(type face face)
|
||||||
(type sintr sintr-grml))
|
(type sintr sintr-grml))
|
||||||
(flet ((rslt (indx dmns gbar)
|
(flet ((rslt (indx dmns gbar)
|
||||||
(declare
|
(declare
|
||||||
(fixnum indx dmns)
|
(fixnum indx dmns)
|
||||||
(type gbar gbar))
|
(type gbar gbar))
|
||||||
(when (= indx dmns)
|
(when (= indx dmns)
|
||||||
(return-from rslt
|
(return-from rslt
|
||||||
(normalize-gbar (cons (1- dmns) (rest (gbar-list gbar))))))
|
(normalize-gbar (cons (1- dmns) (rest (gbar-list gbar))))))
|
||||||
@ -268,80 +199,80 @@
|
|||||||
rslt)))
|
rslt)))
|
||||||
((= dmns2 indx)
|
((= dmns2 indx)
|
||||||
(if (zerop indx)
|
(if (zerop indx)
|
||||||
(normalize-gbar (cons (1- dmns) (nreverse rslt)))
|
(normalize-gbar (cons (1- dmns) (nreverse rslt)))
|
||||||
(normalize-gbar
|
(normalize-gbar
|
||||||
(cons (1- dmns)
|
(cons (1- dmns)
|
||||||
(nreconc
|
(nreconc
|
||||||
rslt
|
rslt
|
||||||
(cons (a-grml4 sintr-grml (1- indx)
|
(cons (a-grml4 sintr-grml (1- indx)
|
||||||
(second mark)
|
(second mark)
|
||||||
(a-face4 face indx indx (first mark)))
|
(a-face4 face indx indx (first mark)))
|
||||||
(nthcdr 2 mark))))))))))
|
(nthcdr 2 mark))))))))))
|
||||||
(the face #'rslt)))
|
(the face #'rslt)))
|
||||||
|
|
||||||
#|
|
#|
|
||||||
(setf om (loop-space (moore 2 2)))
|
(setf om (loop-space (moore 2 2)))
|
||||||
(setf face (classifying-space-face (face om) (sintr (grml om))))
|
(setf face (classifying-space-face (face om) (sintr (grml om))))
|
||||||
(setf gbar (gbar 4 0 (loop3 3 'm2 1 4 'n3 1)
|
(setf gbar (gbar 4 0 (loop3 3 'm2 1 4 'n3 1)
|
||||||
0 (loop3 0 'n3 1)
|
0 (loop3 0 'n3 1)
|
||||||
0 (loop3 0 'm2 1)
|
0 (loop3 0 'm2 1)
|
||||||
0 +null-loop+))
|
0 +null-loop+))
|
||||||
(dotimes (i 5)
|
(dotimes (i 5)
|
||||||
(print (funcall face i 4 gbar)))
|
(print (funcall face i 4 gbar)))
|
||||||
|#
|
|#
|
||||||
|
|
||||||
(DEFGENERIC CLASSIFYING-SPACE (smgr))
|
(DEFGENERIC CLASSIFYING-SPACE (smgr))
|
||||||
|
|
||||||
(DEFMETHOD CLASSIFYING-SPACE ((smgr simplicial-group))
|
(DEFMETHOD CLASSIFYING-SPACE ((smgr simplicial-group))
|
||||||
(the simplicial-set
|
(the simplicial-set
|
||||||
(build-smst :cmpr (classifying-space-cmpr (cmpr smgr))
|
(build-smst :cmpr (classifying-space-cmpr (cmpr smgr))
|
||||||
:basis (classifying-space-basis (basis smgr))
|
:basis (classifying-space-basis (basis smgr))
|
||||||
:bspn +null-gbar+
|
:bspn +null-gbar+
|
||||||
:face (classifying-space-face (face smgr) (sintr (grml smgr)))
|
:face (classifying-space-face (face smgr) (sintr (grml smgr)))
|
||||||
:orgn `(classifying-space ,smgr))))
|
:orgn `(classifying-space ,smgr))))
|
||||||
|
|
||||||
#|
|
#|
|
||||||
(cat-init)
|
(cat-init)
|
||||||
(setf c (classifying-space (k-z2-1)))
|
(setf c (classifying-space (k-z2-1)))
|
||||||
(orgn c)
|
(orgn c)
|
||||||
(first (basis c 4))
|
(first (basis c 4))
|
||||||
(? c 4 (first (basis c 4)))
|
(? c 4 (first (basis c 4)))
|
||||||
(? c *)
|
(? c *)
|
||||||
(cprd c 4 ***)
|
(cprd c 4 ***)
|
||||||
(dotimes (i 5)
|
(dotimes (i 5)
|
||||||
(print (face c i 4 (first (basis c 4)))))
|
(print (face c i 4 (first (basis c 4)))))
|
||||||
|#
|
|#
|
||||||
|
|
||||||
(DEFUN CLASSIFYING-SPACE-GRML-SINTR (idnt sintr-grml)
|
(DEFUN CLASSIFYING-SPACE-GRML-SINTR (idnt sintr-grml)
|
||||||
(declare
|
(declare
|
||||||
(type gmsm idnt)
|
(type gmsm idnt)
|
||||||
(type sintr sintr-grml))
|
(type sintr sintr-grml))
|
||||||
(flet ((rslt (dmns crpr)
|
(flet ((rslt (dmns crpr)
|
||||||
(declare
|
(declare
|
||||||
(fixnum dmns)
|
(fixnum dmns)
|
||||||
(type crpr crpr))
|
(type crpr crpr))
|
||||||
(with-crpr (absm1 absm2) crpr
|
(with-crpr (absm1 absm2) crpr
|
||||||
(let ((absm-list-1 (rest (unnormalize-gbar absm1 idnt)))
|
(let ((absm-list-1 (rest (unnormalize-gbar absm1 idnt)))
|
||||||
(absm-list-2 (rest (unnormalize-gbar absm2 idnt))))
|
(absm-list-2 (rest (unnormalize-gbar absm2 idnt))))
|
||||||
(declare (list absm-list-1 absm-list-2))
|
(declare (list absm-list-1 absm-list-2))
|
||||||
(normalize-gbar
|
(normalize-gbar
|
||||||
(cons dmns
|
(cons dmns
|
||||||
(mapcar
|
(mapcar
|
||||||
#'(lambda (absm1 absm2)
|
#'(lambda (absm1 absm2)
|
||||||
(declare (type absm absm1 absm2))
|
(declare (type absm absm1 absm2))
|
||||||
(decf dmns) ;; !!
|
(decf dmns) ;; !!
|
||||||
(a-grml4 sintr-grml dmns absm1 absm2))
|
(a-grml4 sintr-grml dmns absm1 absm2))
|
||||||
absm-list-1 absm-list-2)))))))
|
absm-list-1 absm-list-2)))))))
|
||||||
(the sintr #'rslt)))
|
(the sintr #'rslt)))
|
||||||
|
|
||||||
#|
|
#|
|
||||||
(setf grml (classifying-space-grml-sintr '() (sintr (grml (k-z-1)))))
|
(setf grml (classifying-space-grml-sintr '() (sintr (grml (k-z-1)))))
|
||||||
(funcall grml 3 (crpr 0 (gbar 3 0 '(1 2) 0 '(3) 0 '())
|
(funcall grml 3 (crpr 0 (gbar 3 0 '(1 2) 0 '(3) 0 '())
|
||||||
0 (gbar 3 0 '(-1 -2) 0 '(-3) 0 '())))
|
0 (gbar 3 0 '(-1 -2) 0 '(-3) 0 '())))
|
||||||
(funcall grml 3 (crpr 0 (gbar 3 0 '(1 2) 0 '(3) 0 '())
|
(funcall grml 3 (crpr 0 (gbar 3 0 '(1 2) 0 '(3) 0 '())
|
||||||
4 (gbar 2 0 '(-3) 0 '())))
|
4 (gbar 2 0 '(-3) 0 '())))
|
||||||
(funcall grml 3 (crpr 0 (gbar 3 0 '(1 2) 0 '(3) 0 '())
|
(funcall grml 3 (crpr 0 (gbar 3 0 '(1 2) 0 '(3) 0 '())
|
||||||
1 (gbar 2 0 '(-3) 0 '())))
|
1 (gbar 2 0 '(-3) 0 '())))
|
||||||
|#
|
|#
|
||||||
|
|
||||||
|
|
||||||
@ -349,48 +280,48 @@
|
|||||||
(declare (type sintr sintr-grin))
|
(declare (type sintr sintr-grin))
|
||||||
(flet ((rslt (dmns gbar)
|
(flet ((rslt (dmns gbar)
|
||||||
(declare
|
(declare
|
||||||
(fixnum dmns)
|
(fixnum dmns)
|
||||||
(type gbar gbar))
|
(type gbar gbar))
|
||||||
(absm 0
|
(absm 0
|
||||||
(make-gbar
|
(make-gbar
|
||||||
:dmns dmns
|
:dmns dmns
|
||||||
:list (mapcar
|
:list (mapcar
|
||||||
#'(lambda (absm)
|
#'(lambda (absm)
|
||||||
(declare (type absm absm))
|
(declare (type absm absm))
|
||||||
(a-grin4 sintr-grin dmns absm))
|
(a-grin4 sintr-grin dmns absm))
|
||||||
(gbar-list gbar))))))
|
(gbar-list gbar))))))
|
||||||
(the sintr #'rslt)))
|
(the sintr #'rslt)))
|
||||||
|
|
||||||
#|
|
#|
|
||||||
(setf grin (classifying-space-grin-sintr (sintr (grin (k-z-1)))))
|
(setf grin (classifying-space-grin-sintr (sintr (grin (k-z-1)))))
|
||||||
(funcall grin 3 (gbar 3 0 '(1 2) 1 '() 0 '()))
|
(funcall grin 3 (gbar 3 0 '(1 2) 1 '() 0 '()))
|
||||||
|#
|
|#
|
||||||
|
|
||||||
|
|
||||||
(DEFMETHOD CLASSIFYING-SPACE ((smgr ab-simplicial-group))
|
(DEFMETHOD CLASSIFYING-SPACE ((smgr ab-simplicial-group))
|
||||||
(the ab-simplicial-group
|
(the ab-simplicial-group
|
||||||
(change-class
|
(change-class
|
||||||
(build-smgr :cmpr (classifying-space-cmpr (cmpr smgr))
|
(build-smgr :cmpr (classifying-space-cmpr (cmpr smgr))
|
||||||
:basis (classifying-space-basis (basis smgr))
|
:basis (classifying-space-basis (basis smgr))
|
||||||
:bspn +null-gbar+
|
:bspn +null-gbar+
|
||||||
:face (classifying-space-face (face smgr) (sintr (grml smgr)))
|
:face (classifying-space-face (face smgr) (sintr (grml smgr)))
|
||||||
:sintr-grml (classifying-space-grml-sintr
|
:sintr-grml (classifying-space-grml-sintr
|
||||||
(bspn smgr)
|
(bspn smgr)
|
||||||
(sintr (grml smgr)))
|
(sintr (grml smgr)))
|
||||||
:sintr-grin (classifying-space-grin-sintr
|
:sintr-grin (classifying-space-grin-sintr
|
||||||
(sintr (grin smgr)))
|
(sintr (grin smgr)))
|
||||||
:orgn `(classifying-space ,smgr))
|
:orgn `(classifying-space ,smgr))
|
||||||
'ab-simplicial-group)))
|
'ab-simplicial-group)))
|
||||||
|
|
||||||
#|
|
#|
|
||||||
(setf k-z-1 (k-z-1))
|
(setf k-z-1 (k-z-1))
|
||||||
(setf k-z-2 (classifying-space k-z-1))
|
(setf k-z-2 (classifying-space k-z-1))
|
||||||
(setf k-z-3 (classifying-space k-z-2))
|
(setf k-z-3 (classifying-space k-z-2))
|
||||||
(homology k-z-3 0 10)
|
(homology k-z-3 0 10)
|
||||||
(setf k-z2-1 (k-z2-1))
|
(setf k-z2-1 (k-z2-1))
|
||||||
(setf k-z2-2 (classifying-space k-z2-1))
|
(setf k-z2-2 (classifying-space k-z2-1))
|
||||||
(setf k-z2-3 (classifying-space k-z2-2))
|
(setf k-z2-3 (classifying-space k-z2-2))
|
||||||
(setf k-z2-4 (classifying-space k-z2-3))
|
(setf k-z2-4 (classifying-space k-z2-3))
|
||||||
(setf k-z2-5 (classifying-space k-z2-4))
|
(setf k-z2-5 (classifying-space k-z2-4))
|
||||||
(homology k-z2-5 0 7)
|
(homology k-z2-5 0 7)
|
||||||
|#
|
|#
|
||||||
|
|||||||
103
test/classifying-spaces-test.lisp
Normal file
103
test/classifying-spaces-test.lisp
Normal file
@ -0,0 +1,103 @@
|
|||||||
|
|
||||||
|
(in-package :kenzo-test)
|
||||||
|
|
||||||
|
(in-suite :kenzo)
|
||||||
|
|
||||||
|
|
||||||
|
(test normalize-gbar
|
||||||
|
(cat:normalize-gbar (list 0))
|
||||||
|
(cat:normalize-gbar (list 1 (cat:absm 0 'i)))
|
||||||
|
(cat:normalize-gbar (list 2 (cat:absm 1 'i) (cat:absm 0 'i)))
|
||||||
|
(cat:normalize-gbar (list 2 (cat:absm 0 'a) (cat:absm 0 'i)))
|
||||||
|
(cat:normalize-gbar (list 4 (cat:absm 0 'a) (cat:absm 0 'b)
|
||||||
|
(cat:absm 0 'c) (cat:absm 0 'i)))
|
||||||
|
(cat:normalize-gbar (list 4 (cat:absm 7 'i) (cat:absm 3 'i)
|
||||||
|
(cat:absm 1 'i) (cat:absm 0 'i)))
|
||||||
|
(cat:normalize-gbar (list 4 (cat:absm 0 'a) (cat:absm 3 'i)
|
||||||
|
(cat:absm 0 'c) (cat:absm 0 'i)))
|
||||||
|
(cat:normalize-gbar (list 4 (cat:absm 1 'a) (cat:absm 3 'i)
|
||||||
|
(cat:absm 0 'c) (cat:absm 0 'i)))
|
||||||
|
(cat:normalize-gbar (list 4 (cat:absm 2 'a) (cat:absm 3 'i)
|
||||||
|
(cat:absm 0 'c) (cat:absm 0 'i)))
|
||||||
|
(cat:normalize-gbar (list 4 (cat:absm 4 'a) (cat:absm 3 'i)
|
||||||
|
(cat:absm 0 'c) (cat:absm 0 'i)))
|
||||||
|
(cat:normalize-gbar (list 4 (cat:absm 3 'a) (cat:absm 3 'i)
|
||||||
|
(cat:absm 0 'c) (cat:absm 0 'i)))
|
||||||
|
(cat:normalize-gbar (list 4 (cat:absm 5 'a) (cat:absm 3 'i)
|
||||||
|
(cat:absm 0 'c) (cat:absm 0 'i)))
|
||||||
|
(cat:normalize-gbar (list 4 (cat:absm 6 'a) (cat:absm 3 'i)
|
||||||
|
(cat:absm 0 'c) (cat:absm 0 'i)))
|
||||||
|
(cat:normalize-gbar (list 4 (cat:absm 1 'a) (cat:absm 3 'i)
|
||||||
|
(cat:absm 1 'i) (cat:absm 0 'i))))
|
||||||
|
|
||||||
|
|
||||||
|
(test unnormalize-gbar
|
||||||
|
(cat:unnormalize-gbar (cat:absm 1 cat:+null-gbar+) 'i)
|
||||||
|
(cat:unnormalize-gbar (cat:absm 15 cat:+null-gbar+) 'i)
|
||||||
|
(cat:normalize-gbar (cat:unnormalize-gbar
|
||||||
|
(cat:absm 15 cat:+null-gbar+) 'i))
|
||||||
|
(cat:unnormalize-gbar
|
||||||
|
(cat:absm 0 (cat:make-gbar :dmns 4
|
||||||
|
:list (list (cat:absm 0 'a) (cat:absm 0 'b)
|
||||||
|
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i)
|
||||||
|
(cat:normalize-gbar
|
||||||
|
(cat:unnormalize-gbar
|
||||||
|
(cat:absm 0 (cat:make-gbar :dmns 4
|
||||||
|
:list (list (cat:absm 0 'a) (cat:absm 0 'b)
|
||||||
|
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i))
|
||||||
|
(cat:unnormalize-gbar
|
||||||
|
(cat:absm 5 (cat:make-gbar :dmns 4
|
||||||
|
:list (list (cat:absm 0 'a) (cat:absm 0 'b)
|
||||||
|
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i)
|
||||||
|
(cat:normalize-gbar
|
||||||
|
(cat:unnormalize-gbar
|
||||||
|
(cat:absm 5 (cat:make-gbar :dmns 4
|
||||||
|
:list (list (cat:absm 0 'a) (cat:absm 0 'b)
|
||||||
|
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i))
|
||||||
|
(cat:unnormalize-gbar
|
||||||
|
(cat:absm 9 (cat:make-gbar :dmns 4
|
||||||
|
:list (list (cat:absm 0 'a) (cat:absm 0 'b)
|
||||||
|
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i)
|
||||||
|
(cat:normalize-gbar
|
||||||
|
(cat:unnormalize-gbar
|
||||||
|
(cat:absm 9 (cat:make-gbar :dmns 4
|
||||||
|
:list (list (cat:absm 0 'a) (cat:absm 0 'b)
|
||||||
|
(cat:absm 0 'c) (cat:absm 0 'i)))) 'i)))
|
||||||
|
|
||||||
|
|
||||||
|
(test gbar
|
||||||
|
(cat:gbar 0)
|
||||||
|
(signals #-ecl simple-error
|
||||||
|
#+ecl simple-type-error (cat:gbar 1))
|
||||||
|
(cat:gbar 2 1 'a 2 'b))
|
||||||
|
|
||||||
|
|
||||||
|
(test classifying-space-cmpr
|
||||||
|
(let ((cmpr (cat:classifying-space-cmpr 'cat:s-cmpr)))
|
||||||
|
(is (equal :less (funcall cmpr
|
||||||
|
(cat:gbar 2 0 'a 0 'a)
|
||||||
|
(cat:gbar 2 1 'a 0 'a))))
|
||||||
|
(is (equal :less (funcall cmpr
|
||||||
|
(cat:gbar 2 0 'a 0 'a)
|
||||||
|
(cat:gbar 2 0 'b 0 'a))))
|
||||||
|
(is (equal :equal (funcall cmpr
|
||||||
|
(cat:gbar 2 0 'a 0 'a)
|
||||||
|
(cat:gbar 2 0 'a 0 'a))))))
|
||||||
|
|
||||||
|
|
||||||
|
(test classifying-space-basis
|
||||||
|
(cat:cat-init)
|
||||||
|
(let* ((k (cat:k-z2-1))
|
||||||
|
(b (cat:classifying-space-basis (cat:basis k))))
|
||||||
|
(funcall b 0)
|
||||||
|
(funcall b 1)
|
||||||
|
(dotimes (i 5) (print (funcall b i)))))
|
||||||
|
#|
|
||||||
|
()
|
||||||
|
(cat-init)
|
||||||
|
(setf k (k-z2-1))
|
||||||
|
(setf b (classifying-space-basis (basis k)))
|
||||||
|
(funcall b 0)
|
||||||
|
(funcall b 1)
|
||||||
|
(dotimes (i 5) (print (funcall b i)))
|
||||||
|
|#
|
||||||
Loading…
Reference in New Issue
Block a user