Extracted loop spaces tests.
This commit is contained in:
Gerd Heber
parent
1ea365ec1e
commit
5528954480
@ -32,6 +32,7 @@
|
|||||||
(:file "homology-groups-test")
|
(:file "homology-groups-test")
|
||||||
(:file "k-pi-n-test")
|
(:file "k-pi-n-test")
|
||||||
(:file "kan-test")
|
(:file "kan-test")
|
||||||
|
(:file "loop-spaces-test")
|
||||||
(:file "searching-homology-test")
|
(:file "searching-homology-test")
|
||||||
(:file "simplicial-groups-test")
|
(:file "simplicial-groups-test")
|
||||||
(:file "simplicial-mrphs-test")
|
(:file "simplicial-mrphs-test")
|
||||||
|
|||||||
14
package.lisp
14
package.lisp
@ -118,6 +118,7 @@
|
|||||||
ABSM
|
ABSM
|
||||||
AB-SIMPLICIAL-GROUP
|
AB-SIMPLICIAL-GROUP
|
||||||
ALLP-LIST
|
ALLP-LIST
|
||||||
|
APOWR
|
||||||
BCC
|
BCC
|
||||||
BRGN
|
BRGN
|
||||||
CBGN
|
CBGN
|
||||||
@ -142,6 +143,7 @@
|
|||||||
MAKE-ABAR
|
MAKE-ABAR
|
||||||
MAKE-ALLP
|
MAKE-ALLP
|
||||||
MAKE-CMBN
|
MAKE-CMBN
|
||||||
|
MAKE-LOOP
|
||||||
MAKE-RESULT
|
MAKE-RESULT
|
||||||
MORPHISM
|
MORPHISM
|
||||||
ORGN
|
ORGN
|
||||||
@ -324,14 +326,25 @@
|
|||||||
;; loop-spaces.lisp
|
;; loop-spaces.lisp
|
||||||
|
|
||||||
+NULL-LOOP+
|
+NULL-LOOP+
|
||||||
|
APOWR-FACE4
|
||||||
|
APOWR-LASTFACE4
|
||||||
|
APOWR-NILOOP
|
||||||
GDELTAB
|
GDELTAB
|
||||||
LOOP3
|
LOOP3
|
||||||
|
LOOP-PRINT
|
||||||
LOOP-SPACE
|
LOOP-SPACE
|
||||||
|
LOOP-SPACE-CMPR
|
||||||
|
LOOP-SPACE-FACE
|
||||||
|
LOOP-SPACE-GRIN-SINTR
|
||||||
|
LOOP-SPACE-GRML-SINTR
|
||||||
|
NORMALIZE-LOOP
|
||||||
|
UNNORMALIZE-LOOP
|
||||||
|
|
||||||
;; macros.lisp
|
;; macros.lisp
|
||||||
|
|
||||||
-1-EXPT-N
|
-1-EXPT-N
|
||||||
?
|
?
|
||||||
|
2-EXP
|
||||||
ABAR-LIST
|
ABAR-LIST
|
||||||
APRD
|
APRD
|
||||||
BASIS
|
BASIS
|
||||||
@ -372,6 +385,7 @@
|
|||||||
|
|
||||||
;; searching-homology.lisp
|
;; searching-homology.lisp
|
||||||
|
|
||||||
|
ECHCM
|
||||||
HOMOLOGY
|
HOMOLOGY
|
||||||
|
|
||||||
;; serre.lisp
|
;; serre.lisp
|
||||||
|
|||||||
@ -758,13 +758,3 @@
|
|||||||
(zero-cmbn (- dmns n))))
|
(zero-cmbn (- dmns n))))
|
||||||
:strt :gnrt
|
:strt :gnrt
|
||||||
:orgn `(k-z2-fundamental-class ,n))))
|
:orgn `(k-z2-fundamental-class ,n))))
|
||||||
|
|
||||||
#|
|
|
||||||
(cat-init)
|
|
||||||
(setf c1 (k-z2-fundamental-class 1))
|
|
||||||
(? c1 1 1)
|
|
||||||
(? c1 2 2)
|
|
||||||
(setf c3 (k-z2-fundamental-class 3))
|
|
||||||
(? c3 3 (z2-fundamental-gmsm 3 1))
|
|
||||||
|#
|
|
||||||
|
|
||||||
|
|||||||
@ -12,43 +12,35 @@
|
|||||||
;;; NILOOP = non-normalized iloop; a common dgop is possible.
|
;;; NILOOP = non-normalized iloop; a common dgop is possible.
|
||||||
|
|
||||||
(DEFUN NORMALIZE-LOOP (dmns niloop)
|
(DEFUN NORMALIZE-LOOP (dmns niloop)
|
||||||
(declare (list niloop))
|
(declare (list niloop))
|
||||||
(the absm
|
(the absm
|
||||||
(progn
|
(progn
|
||||||
(unless niloop
|
(unless niloop
|
||||||
(return-from normalize-loop
|
(return-from normalize-loop
|
||||||
(absm (mask dmns) +null-loop+)))
|
(absm (mask dmns) +null-loop+)))
|
||||||
(let ((dgop (apply #'logand (mapcar #'car niloop))))
|
(let ((dgop (apply #'logand (mapcar #'car niloop))))
|
||||||
(declare (fixnum dgop))
|
(declare (fixnum dgop))
|
||||||
(if (zerop dgop)
|
(if (zerop dgop)
|
||||||
(absm 0 (make-loop :list niloop))
|
(absm 0 (make-loop :list niloop))
|
||||||
(absm dgop
|
(absm dgop
|
||||||
(make-loop
|
(make-loop
|
||||||
:list (mapcar #'(lambda (apowr)
|
:list (mapcar #'(lambda (apowr)
|
||||||
(cons
|
(cons
|
||||||
(dgop/dgop (apdgop apowr) dgop)
|
(dgop/dgop (apdgop apowr) dgop)
|
||||||
(cdr apowr)))
|
(cdr apowr)))
|
||||||
niloop))))))))
|
niloop))))))))
|
||||||
|
|
||||||
#|
|
|
||||||
(normalize-loop 4 +empty-list+)
|
|
||||||
(normalize-loop 4 '((1 a . 1)))
|
|
||||||
(normalize-loop 4 '((1 a . 1) (3 b . 1) (5 b . 1)))
|
|
||||||
|#
|
|
||||||
|
|
||||||
(DEFUN UNNORMALIZE-LOOP (absm)
|
(DEFUN UNNORMALIZE-LOOP (absm)
|
||||||
(declare (type absm absm))
|
(declare (type absm absm))
|
||||||
(the iloop
|
(the iloop
|
||||||
(with-absm (dgop loop) absm
|
(with-absm (dgop loop) absm
|
||||||
(mapcar #'(lambda (apowr)
|
(mapcar #'(lambda (apowr)
|
||||||
(declare (type apowr apowr))
|
(declare (type apowr apowr))
|
||||||
(cons (dgop*dgop dgop (car apowr))
|
(cons (dgop*dgop dgop (car apowr))
|
||||||
(cdr apowr)))
|
(cdr apowr)))
|
||||||
(loop-list loop)))))
|
(loop-list loop)))))
|
||||||
|
|
||||||
#|
|
|
||||||
(unnormalize-loop (absm 1 (loop3 2 'a 3)))
|
|
||||||
|#
|
|
||||||
|
|
||||||
(DEFUN LOOP3 (&rest list)
|
(DEFUN LOOP3 (&rest list)
|
||||||
(when (and (= 1 (length list))
|
(when (and (= 1 (length list))
|
||||||
@ -57,9 +49,9 @@
|
|||||||
(unless (zerop (mod (length list) 3))
|
(unless (zerop (mod (length list) 3))
|
||||||
(error "In LOOP3, 3 should divide the list length."))
|
(error "In LOOP3, 3 should divide the list length."))
|
||||||
(flet ((fixnumpp (object)
|
(flet ((fixnumpp (object)
|
||||||
(unless (typep object 'fixnum)
|
(unless (typep object 'fixnum)
|
||||||
(error "In LOOP3, ~A should be a fixnum." object))
|
(error "In LOOP3, ~A should be a fixnum." object))
|
||||||
object))
|
object))
|
||||||
(do ((rslt +empty-list+ (cons (apowr
|
(do ((rslt +empty-list+ (cons (apowr
|
||||||
(fixnumpp (car mark))
|
(fixnumpp (car mark))
|
||||||
(cadr mark)
|
(cadr mark)
|
||||||
@ -69,544 +61,275 @@
|
|||||||
((endp mark) (make-loop :list (nreverse rslt)))
|
((endp mark) (make-loop :list (nreverse rslt)))
|
||||||
(declare (list rslt mark)))))
|
(declare (list rslt mark)))))
|
||||||
|
|
||||||
#|
|
|
||||||
()
|
|
||||||
(loop3 nil)
|
|
||||||
(loop3 '(1 a 2 3 b -2))
|
|
||||||
(loop3 '(1 a 2 3 b b))
|
|
||||||
(loop3 '(1 a 2 3 b))
|
|
||||||
(loop3 1 'a 2 3 'b 4)
|
|
||||||
(loop3 1 'a 2 3 'b)
|
|
||||||
|#
|
|
||||||
|
|
||||||
(DEFUN LOOP-PRINT (loop stream depth)
|
(DEFUN LOOP-PRINT (loop stream depth)
|
||||||
(declare
|
(declare
|
||||||
(type loop loop) (stream stream)
|
(type loop loop) (stream stream)
|
||||||
(ignore depth))
|
(ignore depth))
|
||||||
(the loop
|
(the loop
|
||||||
(progn
|
(progn
|
||||||
(format stream "<<Loop")
|
(format stream "<<Loop")
|
||||||
(dolist (apowr (loop-list loop))
|
(dolist (apowr (loop-list loop))
|
||||||
(declare (type apowr apowr))
|
(declare (type apowr apowr))
|
||||||
(with-apowr (dgop gmsm expn) apowr
|
(with-apowr (dgop gmsm expn) apowr
|
||||||
(format stream "[")
|
(format stream "[")
|
||||||
(unless (zerop dgop)
|
(unless (zerop dgop)
|
||||||
(format stream "~A " (hyphenize-list (dgop-int-ext dgop))))
|
(format stream "~A " (hyphenize-list (dgop-int-ext dgop))))
|
||||||
(format stream "~A" gmsm)
|
(format stream "~A" gmsm)
|
||||||
(unless (= 1 expn)
|
(unless (= 1 expn)
|
||||||
(format stream "\\~D" expn))
|
(format stream "\\~D" expn))
|
||||||
(format stream "]")))
|
(format stream "]")))
|
||||||
(format stream ">>")
|
(format stream ">>")
|
||||||
loop)))
|
loop)))
|
||||||
|
|
||||||
#|
|
|
||||||
(loop3 nil)
|
|
||||||
(loop3 '(0 a 2))
|
|
||||||
(loop3 '(1 a 2))
|
|
||||||
(loop3 '(3 a 2 5 b -1 6 c 4))
|
|
||||||
(loop3 '(7 a 1 11 b 1 13 c 1 14 d 1))
|
|
||||||
(loop3 '(7 a 1 11 b 1 13 c 1 7 d 1))
|
|
||||||
(loop3 '(0 a 1 0 b 2 0 c -1 1 d 1))
|
|
||||||
|#
|
|
||||||
|
|
||||||
(DEFUN APOWR-NILOOP (cmpr apowr niloop)
|
(DEFUN APOWR-NILOOP (cmpr apowr niloop)
|
||||||
(declare
|
(declare
|
||||||
(type cmprf cmpr)
|
(type cmprf cmpr)
|
||||||
(type apowr apowr)
|
(type apowr apowr)
|
||||||
(type iloop niloop))
|
(type iloop niloop))
|
||||||
(the iloop
|
(the iloop
|
||||||
(progn
|
(progn
|
||||||
(unless niloop
|
(unless niloop
|
||||||
(return-from apowr-niloop
|
(return-from apowr-niloop
|
||||||
(list apowr)))
|
(list apowr)))
|
||||||
(let ((apowr2 (first niloop)))
|
(let ((apowr2 (first niloop)))
|
||||||
(declare (type apowr apowr2))
|
(declare (type apowr apowr2))
|
||||||
(with-apowr (dgop2 gmsm2 expn2) apowr2
|
(with-apowr (dgop2 gmsm2 expn2) apowr2
|
||||||
(unless (and (= (apdgop apowr) dgop2)
|
(unless (and (= (apdgop apowr) dgop2)
|
||||||
(eq :equal (funcall cmpr (apgmsm apowr) gmsm2)))
|
(eq :equal (funcall cmpr (apgmsm apowr)
|
||||||
(return-from apowr-niloop
|
gmsm2)))
|
||||||
(cons apowr niloop)))
|
(return-from apowr-niloop
|
||||||
(incf expn2 (apexpn apowr))
|
(cons apowr niloop)))
|
||||||
(if (zerop expn2)
|
(incf expn2 (apexpn apowr))
|
||||||
(rest niloop)
|
(if (zerop expn2)
|
||||||
(cons (apowr dgop2 gmsm2 expn2) (rest niloop))))))))
|
(rest niloop)
|
||||||
|
(cons (apowr dgop2 gmsm2 expn2) (rest niloop))))))))
|
||||||
|
|
||||||
#|
|
|
||||||
(apowr-niloop #'s-cmpr '(0 a . 1) +empty-list+)
|
|
||||||
(apowr-niloop #'s-cmpr '(0 a . 1) '((1 a . 1)))
|
|
||||||
(apowr-niloop #'s-cmpr '(0 a . 1) '((0 b . 1)))
|
|
||||||
(apowr-niloop #'s-cmpr '(0 a . 1) '((0 a . 1) (0 b . 1)))
|
|
||||||
(apowr-niloop #'s-cmpr '(0 a . 1) '((0 a . -1) (0 b . 1)))
|
|
||||||
|#
|
|
||||||
|
|
||||||
(DEFUN LOOP-SPACE-CMPR (cmpr)
|
(DEFUN LOOP-SPACE-CMPR (cmpr)
|
||||||
(declare (type cmprf cmpr))
|
(declare (type cmprf cmpr))
|
||||||
(flet ((2apowr-cmpr (apowr1 apowr2)
|
(flet ((2apowr-cmpr (apowr1 apowr2)
|
||||||
(declare (type apowr apowr1 apowr2))
|
(declare (type apowr apowr1 apowr2))
|
||||||
(lexico
|
(lexico
|
||||||
(f-cmpr (apdgop apowr1) (apdgop apowr2))
|
(f-cmpr (apdgop apowr1) (apdgop apowr2))
|
||||||
(funcall cmpr (apgmsm apowr1) (apgmsm apowr2))
|
(funcall cmpr (apgmsm apowr1) (apgmsm apowr2))
|
||||||
(f-cmpr (apexpn apowr1) (apexpn apowr2)))))
|
(f-cmpr (apexpn apowr1) (apexpn apowr2)))))
|
||||||
(flet ((rslt (loop1 loop2)
|
(flet ((rslt (loop1 loop2)
|
||||||
(declare (type loop loop1 loop2))
|
(declare (type loop loop1 loop2))
|
||||||
(maplexico #'2apowr-cmpr (loop-list loop1) (loop-list loop2))))
|
(maplexico #'2apowr-cmpr (loop-list loop1) (loop-list loop2))))
|
||||||
(the cmprf #'rslt))))
|
(the cmprf #'rslt))))
|
||||||
|
|
||||||
#|
|
|
||||||
(setf cmpr (loop-space-cmpr #'s-cmpr))
|
|
||||||
(funcall cmpr (loop3 '(1 a 2)) (loop3 '(1 a -1)))
|
|
||||||
(funcall cmpr (loop3 '(3 b 4 1 a 2)) (loop3 '(3 b 4 1 a -1)))
|
|
||||||
|#
|
|
||||||
|
|
||||||
(DEFUN APOWR-FACE4 (face indx dmns apowr)
|
(DEFUN APOWR-FACE4 (face indx dmns apowr)
|
||||||
;; dmns = dimension in the loop-space
|
;; dmns = dimension in the loop-space
|
||||||
(declare
|
(declare
|
||||||
(type face face)
|
(type face face)
|
||||||
(type apowr apowr))
|
(type apowr apowr))
|
||||||
(with-apowr (dgop gmsm expn) apowr
|
(with-apowr (dgop gmsm expn) apowr
|
||||||
(let ((face (a-face4 face indx (1+ dmns) (absm dgop gmsm))))
|
(let ((face (a-face4 face indx (1+ dmns) (absm dgop gmsm))))
|
||||||
(declare (type absm face))
|
(declare (type absm face))
|
||||||
(with-absm (dgop gmsm) face
|
(with-absm (dgop gmsm) face
|
||||||
(if (logbitp (1- dmns) dgop)
|
(if (logbitp (1- dmns) dgop)
|
||||||
nil
|
nil
|
||||||
(apowr dgop gmsm expn))))))
|
(apowr dgop gmsm expn))))))
|
||||||
|
|
||||||
#|
|
|
||||||
(setf face (face (delta-infinity)))
|
|
||||||
(apowr-face4 face 3 4 (apowr 1 31 5))
|
|
||||||
(setf face (face (sphere 5)))
|
|
||||||
(apowr-face4 face 2 5 (apowr 1 's5 4))
|
|
||||||
(apowr-face4 face 2 5 (apowr 2 's5 4))
|
|
||||||
|#
|
|
||||||
|
|
||||||
(DEFUN APOWR-LASTFACE4 (cmpr face dmns apowr)
|
(DEFUN APOWR-LASTFACE4 (cmpr face dmns apowr)
|
||||||
;; indx =dmns
|
;; indx =dmns
|
||||||
(declare
|
(declare
|
||||||
(type cmprf cmpr)
|
(type cmprf cmpr)
|
||||||
(type face face)
|
(type face face)
|
||||||
(fixnum dmns)
|
(fixnum dmns)
|
||||||
(type apowr apowr))
|
(type apowr apowr))
|
||||||
(the list
|
(the list
|
||||||
(with-apowr (dgop gmsm expn) apowr
|
(with-apowr
|
||||||
(let ((absm (absm dgop gmsm)))
|
(dgop gmsm expn) apowr
|
||||||
(declare (type absm absm))
|
(let ((absm (absm dgop gmsm)))
|
||||||
(let ((face-n (a-face4 face dmns (1+ dmns) absm))
|
(declare (type absm absm))
|
||||||
(face-n+1 (a-face4 face (1+ dmns) (1+ dmns) absm)))
|
(let ((face-n (a-face4 face dmns (1+ dmns) absm))
|
||||||
(declare (type absm face-n face-n+1))
|
(face-n+1 (a-face4 face (1+ dmns) (1+ dmns) absm)))
|
||||||
(with-absm (dgop1 gmsm1) face-n
|
(declare (type absm face-n face-n+1))
|
||||||
(with-absm (dgop2 gmsm2) face-n+1
|
(with-absm
|
||||||
(if (logbitp (1- dmns) dgop1)
|
(dgop1 gmsm1) face-n
|
||||||
(if (logbitp (1- dmns) dgop2)
|
(with-absm
|
||||||
(return-from apowr-lastface4 +empty-list+)
|
(dgop2 gmsm2) face-n+1
|
||||||
(return-from apowr-lastface4
|
(if (logbitp (1- dmns) dgop1)
|
||||||
(list (apowr dgop2 gmsm2 (- expn)))))
|
(if (logbitp (1- dmns) dgop2)
|
||||||
(when (logbitp (1- dmns) dgop2)
|
(return-from apowr-lastface4 +empty-list+)
|
||||||
(return-from apowr-lastface4
|
(return-from apowr-lastface4
|
||||||
(list (apowr dgop1 gmsm1 expn)))))
|
(list (apowr dgop2 gmsm2 (- expn)))))
|
||||||
(when (and (= dgop1 dgop2)
|
(when (logbitp (1- dmns) dgop2)
|
||||||
(eq :equal (funcall cmpr gmsm1 gmsm2)))
|
(return-from apowr-lastface4
|
||||||
(return-from apowr-lastface4 +empty-list+))
|
(list (apowr dgop1 gmsm1 expn)))))
|
||||||
(case expn
|
(when (and (= dgop1 dgop2)
|
||||||
(+1 (list (apowr dgop2 gmsm2 -1) (apowr dgop1 gmsm1 +1)))
|
(eq :equal (funcall cmpr gmsm1 gmsm2)))
|
||||||
(-1 (list (apowr dgop1 gmsm1 -1) (apowr dgop2 gmsm2 +1)))
|
(return-from apowr-lastface4 +empty-list+))
|
||||||
(otherwise
|
(case expn
|
||||||
(if (plusp expn)
|
(+1 (list (apowr dgop2 gmsm2 -1) (apowr dgop1 gmsm1
|
||||||
(do ((rslt +empty-list+ (cons apowr2 (cons apowr1 rslt)))
|
+1)))
|
||||||
(apowr1 (apowr dgop1 gmsm1 +1))
|
(-1 (list (apowr dgop1 gmsm1 -1) (apowr dgop2 gmsm2
|
||||||
(apowr2 (apowr dgop2 gmsm2 -1))
|
+1)))
|
||||||
(nark expn (1- nark)))
|
(otherwise
|
||||||
((zerop nark) rslt)
|
(if (plusp expn)
|
||||||
(declare
|
(do ((rslt +empty-list+ (cons apowr2
|
||||||
(list rslt)
|
(cons apowr1
|
||||||
(type apowr apowr1 apowr2)))
|
rslt)))
|
||||||
(do ((rslt +empty-list+ (cons apowr1 (cons apowr2 rslt)))
|
(apowr1 (apowr dgop1 gmsm1 +1))
|
||||||
(apowr1 (apowr dgop1 gmsm1 -1))
|
(apowr2 (apowr dgop2 gmsm2 -1))
|
||||||
(apowr2 (apowr dgop2 gmsm2 +1))
|
(nark expn (1- nark)))
|
||||||
(nark expn (1+ nark)))
|
((zerop nark) rslt)
|
||||||
((zerop nark) rslt)
|
(declare
|
||||||
(declare
|
(list rslt)
|
||||||
(list rslt)
|
(type apowr apowr1 apowr2)))
|
||||||
(type apowr apowr1 apowr2)))))))))))))
|
(do ((rslt +empty-list+ (cons apowr1
|
||||||
|
(cons apowr2
|
||||||
|
rslt)))
|
||||||
|
(apowr1 (apowr dgop1 gmsm1 -1))
|
||||||
|
(apowr2 (apowr dgop2 gmsm2 +1))
|
||||||
|
(nark expn (1+ nark)))
|
||||||
|
((zerop nark) rslt)
|
||||||
|
(declare
|
||||||
|
(list rslt)
|
||||||
|
(type apowr apowr1 apowr2)))))))))))))
|
||||||
|
|
||||||
#|
|
|
||||||
(setf cmpr #'f-cmpr face (face (delta-infinity)))
|
|
||||||
(apowr-lastface4 cmpr face 4 (apowr 0 63 1))
|
|
||||||
(apowr-lastface4 cmpr face 4 (apowr 0 63 -1))
|
|
||||||
(apowr-lastface4 cmpr face 4 (apowr 0 63 3))
|
|
||||||
(apowr-lastface4 cmpr face 4 (apowr 0 63 -3))
|
|
||||||
(apowr-lastface4 cmpr face 4 (apowr 8 31 1))
|
|
||||||
(setf face #'(lambda (indx dmns gmsm) ; dmns = 5
|
|
||||||
(case indx
|
|
||||||
(5 (absm 8 'a))
|
|
||||||
(4 (absm 8 'a)))))
|
|
||||||
(setf cmpr #'s-cmpr)
|
|
||||||
(apowr-lastface4 cmpr face 4 (apowr 0 'a 2))
|
|
||||||
(setf face #'(lambda (indx dmns gmsm) ; dmns = 5
|
|
||||||
(case indx
|
|
||||||
(5 (absm 1 'a))
|
|
||||||
(4 (absm 8 'a)))))
|
|
||||||
(apowr-lastface4 cmpr face 4 (apowr 0 'a 2))
|
|
||||||
(setf face #'(lambda (indx dmns gmsm) ; dmns = 5
|
|
||||||
(case indx
|
|
||||||
(5 (absm 1 'a))
|
|
||||||
(4 (absm 1 'a)))))
|
|
||||||
(apowr-lastface4 cmpr face 4 (apowr 0 'a 2))
|
|
||||||
|#
|
|
||||||
|
|
||||||
(DEFUN LOOP-SPACE-FACE (cmpr face)
|
(DEFUN LOOP-SPACE-FACE (cmpr face)
|
||||||
(declare
|
(declare
|
||||||
(type cmprf cmpr)
|
(type cmprf cmpr)
|
||||||
(type face face))
|
(type face face))
|
||||||
(flet ((rslt (indx dmns loop)
|
(flet ((rslt (indx dmns loop)
|
||||||
(declare
|
(declare
|
||||||
(fixnum indx dmns)
|
(fixnum indx dmns)
|
||||||
(type loop loop))
|
(type loop loop))
|
||||||
(the absm
|
(the absm
|
||||||
(let ((rslt +empty-list+))
|
(let ((rslt +empty-list+))
|
||||||
(declare (type iloop rslt))
|
(declare (type iloop rslt))
|
||||||
(if (< indx dmns)
|
(if (< indx dmns)
|
||||||
(dolist (apowr (loop-list loop))
|
(dolist (apowr (loop-list loop))
|
||||||
(declare (type apowr apowr))
|
(declare (type apowr apowr))
|
||||||
(let ((lface (apowr-face4 face indx dmns apowr)))
|
(let ((lface (apowr-face4 face indx dmns apowr)))
|
||||||
(declare (type (or null apowr) lface))
|
(declare (type (or null apowr) lface))
|
||||||
(when lface (setf rslt (apowr-niloop cmpr lface rslt)))))
|
(when lface (setf rslt (apowr-niloop cmpr lface
|
||||||
|
rslt)))))
|
||||||
(dolist (apowr (loop-list loop))
|
(dolist (apowr (loop-list loop))
|
||||||
(declare (type apowr apowr))
|
(declare (type apowr apowr))
|
||||||
(let ((lface (apowr-lastface4 cmpr face dmns apowr)))
|
(let ((lface (apowr-lastface4 cmpr face dmns apowr)))
|
||||||
(declare (list lface))
|
(declare (list lface))
|
||||||
(dolist (apowr lface)
|
(dolist (apowr lface)
|
||||||
(declare (type apowr apowr))
|
(declare (type apowr apowr))
|
||||||
(setf rslt (apowr-niloop cmpr apowr rslt))))))
|
(setf rslt (apowr-niloop cmpr apowr rslt))))))
|
||||||
(normalize-loop (1- dmns) (nreverse rslt))))))
|
(normalize-loop (1- dmns) (nreverse rslt))))))
|
||||||
(the face #'rslt)))
|
(the face #'rslt)))
|
||||||
|
|
||||||
#|
|
|
||||||
(setf cmpr #'f-cmpr
|
|
||||||
face (face (delta-infinity)))
|
|
||||||
(setf rslt (loop-space-face cmpr face))
|
|
||||||
(funcall rslt 2 4 (loop3 '(0 63 3 1 31 -3)))
|
|
||||||
(funcall rslt 2 4 (loop3 '(0 63 3 0 63 -3)))
|
|
||||||
(funcall rslt 4 4 (loop3 '(0 63 3 0 63 -3)))
|
|
||||||
(funcall rslt 4 4 (loop3 '(0 63 3)))
|
|
||||||
|#
|
|
||||||
|
|
||||||
(DEFUN LOOP-SPACE-FACE* (cmpr face)
|
(DEFUN LOOP-SPACE-FACE* (cmpr face)
|
||||||
(declare
|
(declare
|
||||||
(type cmprf cmpr)
|
(type cmprf cmpr)
|
||||||
(type face face))
|
(type face face))
|
||||||
(flet ((rslt (indx dmns loop)
|
(flet ((rslt (indx dmns loop)
|
||||||
(declare
|
(declare
|
||||||
(fixnum indx dmns)
|
(fixnum indx dmns)
|
||||||
(type loop loop))
|
(type loop loop))
|
||||||
(the (or loop (eql :degenerate))
|
(the (or loop (eql :degenerate))
|
||||||
(let ((rslt +empty-list+))
|
(let ((rslt +empty-list+))
|
||||||
(declare (type iloop rslt))
|
(declare (type iloop rslt))
|
||||||
(if (< indx dmns)
|
(if (< indx dmns)
|
||||||
(dolist (apowr (loop-list loop))
|
(dolist (apowr (loop-list loop))
|
||||||
(declare (type apowr apowr))
|
(declare (type apowr apowr))
|
||||||
(let ((lface (apowr-face4 face indx dmns apowr)))
|
(let ((lface (apowr-face4 face indx dmns apowr)))
|
||||||
(declare (type (or null apowr) lface))
|
(declare (type (or null apowr) lface))
|
||||||
(when lface (setf rslt (apowr-niloop cmpr lface rslt)))))
|
(when lface (setf rslt (apowr-niloop cmpr lface
|
||||||
|
rslt)))))
|
||||||
(dolist (apowr (loop-list loop))
|
(dolist (apowr (loop-list loop))
|
||||||
(declare (type apowr apowr))
|
(declare (type apowr apowr))
|
||||||
(let ((lface (apowr-lastface4 cmpr face dmns apowr)))
|
(let ((lface (apowr-lastface4 cmpr face dmns apowr)))
|
||||||
(declare (list lface))
|
(declare (list lface))
|
||||||
(dolist (apowr lface)
|
(dolist (apowr lface)
|
||||||
(declare (type apowr apowr))
|
(declare (type apowr apowr))
|
||||||
(setf rslt (apowr-niloop cmpr apowr rslt))))))
|
(setf rslt (apowr-niloop cmpr apowr rslt))))))
|
||||||
(if (zerop (apply #'logand (mapcar #'car rslt)))
|
(if (zerop (apply #'logand (mapcar #'car rslt)))
|
||||||
(make-loop :list (nreverse rslt))
|
(make-loop :list (nreverse rslt))
|
||||||
:degenerate)))))
|
:degenerate)))))
|
||||||
(the face* #'rslt)))
|
(the face* #'rslt)))
|
||||||
|
|
||||||
|
|
||||||
(DEFUN LOOP-SPACE-GRIN-SINTR (dmns loop)
|
(DEFUN LOOP-SPACE-GRIN-SINTR (dmns loop)
|
||||||
(declare
|
(declare
|
||||||
(ignore dmns)
|
(ignore dmns)
|
||||||
(type loop loop))
|
(type loop loop))
|
||||||
(the absm
|
(the absm
|
||||||
(absm 0 (make-loop
|
(absm 0 (make-loop
|
||||||
:list (mapcar #'(lambda (apowr)
|
:list (mapcar #'(lambda (apowr)
|
||||||
(declare (type apowr apowr))
|
(declare (type apowr apowr))
|
||||||
(with-apowr (dgop gmsm expn) apowr
|
(with-apowr (dgop gmsm expn) apowr
|
||||||
(apowr dgop gmsm (- expn))))
|
(apowr dgop gmsm (- expn))))
|
||||||
(reverse (loop-list loop)))))))
|
(reverse (loop-list loop)))))))
|
||||||
|
|
||||||
#|
|
|
||||||
(loop-space-grin-sintr 5 (loop3 0 'a 2 3 'b -3))
|
|
||||||
|#
|
|
||||||
|
|
||||||
(DEFUN LOOP-SPACE-GRML-SINTR (cmpr)
|
(DEFUN LOOP-SPACE-GRML-SINTR (cmpr)
|
||||||
(declare (type cmprf cmpr))
|
(declare (type cmprf cmpr))
|
||||||
(flet ((rslt (dmns crpr)
|
(flet ((rslt (dmns crpr)
|
||||||
(declare
|
(declare
|
||||||
(fixnum dmns)
|
(fixnum dmns)
|
||||||
(type crpr crpr))
|
(type crpr crpr))
|
||||||
(the absm
|
(the absm
|
||||||
(with-crpr (absm1 absm2) crpr
|
(with-crpr
|
||||||
(let ((niloop1 (nreverse (unnormalize-loop absm1)))
|
(absm1 absm2) crpr
|
||||||
(niloop2 (unnormalize-loop absm2)))
|
(let ((niloop1 (nreverse (unnormalize-loop absm1)))
|
||||||
(declare (type iloop niloop1 niloop2))
|
(niloop2 (unnormalize-loop absm2)))
|
||||||
(loop
|
(declare (type iloop niloop1 niloop2))
|
||||||
(unless niloop1 (return))
|
(loop
|
||||||
(unless niloop2 (return))
|
(unless niloop1 (return))
|
||||||
(let ((apowr1 (first niloop1))
|
(unless niloop2 (return))
|
||||||
(apowr2 (first niloop2)))
|
(let ((apowr1 (first niloop1))
|
||||||
(declare (type apowr apowr1 apowr2))
|
(apowr2 (first niloop2)))
|
||||||
(with-apowr (dgop1 gmsm1 expn1) apowr1
|
(declare (type apowr apowr1 apowr2))
|
||||||
(with-apowr (dgop2 gmsm2 expn2) apowr2
|
(with-apowr
|
||||||
(unless (and (= dgop1 dgop2)
|
(dgop1 gmsm1 expn1) apowr1
|
||||||
(eq :equal (funcall cmpr gmsm1 gmsm2)))
|
(with-apowr
|
||||||
(return))
|
(dgop2 gmsm2 expn2) apowr2
|
||||||
(incf expn1 expn2)
|
(unless (and (= dgop1 dgop2)
|
||||||
(cond ((zerop expn1)
|
(eq :equal (funcall cmpr
|
||||||
(pop niloop1)
|
gmsm1
|
||||||
(pop niloop2))
|
gmsm2)))
|
||||||
(t
|
(return))
|
||||||
(pop niloop1)
|
(incf expn1 expn2)
|
||||||
(setf niloop2
|
(cond ((zerop expn1)
|
||||||
(cons (apowr dgop2 gmsm2 expn1)
|
(pop niloop1)
|
||||||
(rest niloop2)))
|
(pop niloop2))
|
||||||
(return)))))))
|
(t
|
||||||
(normalize-loop dmns
|
(pop niloop1)
|
||||||
(nreconc niloop1 niloop2)))))))
|
(setf niloop2
|
||||||
(the sintr #'rslt)))
|
(cons (apowr dgop2 gmsm2 expn1)
|
||||||
|
(rest niloop2)))
|
||||||
|
(return)))))))
|
||||||
|
(normalize-loop dmns
|
||||||
|
(nreconc niloop1 niloop2)))))))
|
||||||
|
(the sintr #'rslt)))
|
||||||
|
|
||||||
#|
|
|
||||||
(setf cmpr #'s-cmpr)
|
|
||||||
(setf ml (loop-space-grml-sintr cmpr))
|
|
||||||
(funcall ml 2 (crpr 3 (loop3) 0 (loop3 0 'a 2)))
|
|
||||||
(funcall ml 2 (crpr 0 (loop3 0 'a 2) 3 (loop3)))
|
|
||||||
(funcall ml 2 (crpr 0 (loop3 0 'a 2) 0 (loop3 0 'a -2)))
|
|
||||||
(funcall ml 2 (crpr 0 (loop3 0 'a 2) 0 (loop3 0 'a -3)))
|
|
||||||
(funcall ml 2 (crpr 0 (loop3 0 'a 2) 0 (loop3 0 'b -3)))
|
|
||||||
(funcall ml 2 (crpr 0 (loop3 0 'a 2 0 'b -3)
|
|
||||||
0 (loop3 0 'b +3 0 'a -2)))
|
|
||||||
|#
|
|
||||||
|
|
||||||
(DEFUN LOOP-SPACE (smst &optional (n 1))
|
(DEFUN LOOP-SPACE (smst &optional (n 1))
|
||||||
(declare
|
(declare
|
||||||
(type simplicial-set smst)
|
(type simplicial-set smst)
|
||||||
(fixnum n))
|
(fixnum n))
|
||||||
(the simplicial-group
|
(the simplicial-group
|
||||||
(if (= n 1)
|
(if (= n 1)
|
||||||
(with-slots (cmpr face) smst
|
(with-slots (cmpr face) smst
|
||||||
(declare
|
(declare
|
||||||
(type cmprf cmpr)
|
(type cmprf cmpr)
|
||||||
(type face face))
|
(type face face))
|
||||||
(build-smgr
|
(build-smgr
|
||||||
:cmpr (loop-space-cmpr cmpr)
|
:cmpr (loop-space-cmpr cmpr)
|
||||||
:basis :locally-effective
|
:basis :locally-effective
|
||||||
:bspn +null-loop+
|
:bspn +null-loop+
|
||||||
:face (loop-space-face cmpr face)
|
:face (loop-space-face cmpr face)
|
||||||
:face* (loop-space-face* cmpr face)
|
:face* (loop-space-face* cmpr face)
|
||||||
:sintr-grml (loop-space-grml-sintr cmpr)
|
:sintr-grml (loop-space-grml-sintr cmpr)
|
||||||
:sintr-grin #'loop-space-grin-sintr
|
:sintr-grin #'loop-space-grin-sintr
|
||||||
:orgn `(loop-space ,smst)))
|
:orgn `(loop-space ,smst)))
|
||||||
(loop-space (loop-space smst) (1- n)))))
|
(loop-space (loop-space smst) (1- n)))))
|
||||||
|
|
||||||
|
|
||||||
(DEFUN GDELTAB ()
|
(DEFUN GDELTAB ()
|
||||||
(loop-space (deltab)))
|
(loop-space (deltab)))
|
||||||
|
|
||||||
#|
|
|
||||||
(cat-init)
|
|
||||||
(setf g (gdeltab))
|
|
||||||
(cmpr g (loop3 0 3 2) (loop3 0 3 2))
|
|
||||||
(cmpr g (loop3 0 3 2) (loop3 0 3 3))
|
|
||||||
(cmpr g (loop3 0 3 2) (loop3 0 5 2))
|
|
||||||
(cmpr g (loop3 0 5 2) (loop3 0 3 2))
|
|
||||||
(face g 3 3 (loop3 12 7 3))
|
|
||||||
(face g 3 3 (loop3 5 7 3))
|
|
||||||
(face g 3 3 (loop3 6 7 3 5 7 3 3 7 3))
|
|
||||||
(face g 4 4 (absm 4 (loop3 6 7 3 5 7 3 3 7 3)))
|
|
||||||
(check-faces (cmpr g) (face g) 3 (loop3 6 7 -3 5 7 -3 3 7 -3))
|
|
||||||
(setf dd (cmps g g))
|
|
||||||
(? dd 3 (loop3 6 7 3 5 7 3 3 7 3))
|
|
||||||
(grml g 2 (crpr 0 (loop3 0 15 3) 0 (loop3 0 15 4)))
|
|
||||||
(grin g 2 (loop3 0 15 -2))
|
|
||||||
(setf rslt (loop3 0 31 1))
|
|
||||||
(setf hat (mapcar #'(lambda (i) (face g i 3 rslt))
|
|
||||||
(<a-b> 0 3)))
|
|
||||||
(dotimes (i 4)
|
|
||||||
(print (kfll g i 3 (remove (nth i hat) hat :test #'equal)))
|
|
||||||
(check-kan g i 3 (remove (nth i hat) hat :test #'equal)))
|
|
||||||
|
|
||||||
(setf g (loop-space (sphere 2)))
|
|
||||||
(setf rslt (loop3 3 's2 2 5 's2 -2 6 's2 2))
|
|
||||||
(setf hat (mapcar #'(lambda (i) (face g i 3 rslt))
|
|
||||||
(<a-b> 0 3)))
|
|
||||||
(dotimes (i 4)
|
|
||||||
(print (kfll g i 3 (remove (nth i hat) hat :test #'equal)))
|
|
||||||
(check-kan g i 3 (remove (nth i hat) hat :test #'equal)))
|
|
||||||
|
|
||||||
(setf g (loop-space (sphere 3) 2))
|
|
||||||
(setf x (first (basis (echcm g) 4)))
|
|
||||||
(setf efhm (efhm g))
|
|
||||||
(setf x (lf efhm (rg efhm 4 x)))
|
|
||||||
(setf rslt (gnrt (first (cmbn-list x))))
|
|
||||||
(setf hat (mapcar #'(lambda (i) (face g i 4 rslt))
|
|
||||||
(<a-b> 0 4)))
|
|
||||||
(dotimes (i 5)
|
|
||||||
(print (kfll g i 4 (remove (nth i hat) hat :test #'equal)))
|
|
||||||
(check-kan g i 4 (remove (nth i hat) hat :test #'equal)))
|
|
||||||
|
|
||||||
(setf rslt (gnrt (third (cmbn-list x))))
|
|
||||||
(setf hat (mapcar #'(lambda (i) (face g i 4 rslt))
|
|
||||||
(<a-b> 0 4)))
|
|
||||||
(dotimes (i 5)
|
|
||||||
(print (kfll g i 4 (remove (nth i hat) hat :test #'equal)))
|
|
||||||
(check-kan g i 4 (remove (nth i hat) hat :test #'equal)))
|
|
||||||
|
|
||||||
(setf g (loop-space (sphere 3) 2))
|
|
||||||
(setf efhm (efhm g))
|
|
||||||
(setf echcm (rbcc efhm))
|
|
||||||
(setf basis (basis echcm 4))
|
|
||||||
(setf cmbn (cmbn 4 1 (first basis) 10 (second basis)
|
|
||||||
100 (third basis)))
|
|
||||||
(setf cmbn2 (lf efhm (rg efhm cmbn)))
|
|
||||||
(setf loop-list (mapcar #'cdr (cmbn-list cmbn2)))
|
|
||||||
(dolist (loop loop-list)
|
|
||||||
(setf hat (mapcar #'(lambda (i) (face g i 4 loop))
|
|
||||||
(<a-b> 0 4)))
|
|
||||||
(dotimes (i 5)
|
|
||||||
(print (kfll g i 4 (remove (nth i hat) hat)))
|
|
||||||
(check-kan g i 4 (remove (nth i hat) hat))))
|
|
||||||
|#
|
|
||||||
|
|
||||||
#|
|
|
||||||
(cat-init)
|
|
||||||
(setf p (r-proj-space 3))
|
|
||||||
(setf op (loop-space p))
|
|
||||||
(defun random-apowr (dmns max-expn)
|
|
||||||
(loop
|
|
||||||
(let* ((dgop (random (2-exp (1- dmns))))
|
|
||||||
(gmsm (- dmns (logcount dgop))))
|
|
||||||
(unless (< 0 gmsm 3)
|
|
||||||
(return-from random-apowr
|
|
||||||
(apowr dgop gmsm (srandom max-expn)))))))
|
|
||||||
(dotimes (i 15) (print (random-apowr 8 3)))
|
|
||||||
(defun random-niloop (dmns max-expn length)
|
|
||||||
(mapcar #'(lambda (dummy)
|
|
||||||
(random-apowr (1+ dmns) max-expn))
|
|
||||||
(make-list length)))
|
|
||||||
(dotimes (i 20)
|
|
||||||
(print (normalize-loop 7 (random-niloop 7 3 3))))
|
|
||||||
(defun random-loop-cmbn (cmpr degr max-cffc max-expn loop-length cmbn-length)
|
|
||||||
(do ((rslt +empty-list+ (cons term rslt))
|
|
||||||
(i cmbn-length (1- i))
|
|
||||||
(term))
|
|
||||||
((zerop i)
|
|
||||||
(apply #'nterm-add cmpr degr rslt))
|
|
||||||
(setf term
|
|
||||||
(term (srandom max-cffc)
|
|
||||||
(make-loop :list (random-niloop degr max-expn loop-length))))))
|
|
||||||
(setf cmpr (cmpr op))
|
|
||||||
(setf +too-much-time+ -1)
|
|
||||||
(setf c (random-loop-cmbn cmpr 8 10 4 4 100))
|
|
||||||
(time (? op (? op c)))
|
|
||||||
(time (? op (? op c)))
|
|
||||||
|#
|
|
||||||
|
|
||||||
#| ;; in EAT.
|
|
||||||
(DEFUN PR-INFINITY-EQS (gsm1 gsm2)
|
|
||||||
(declare (fixnum gsm1 gsm2))
|
|
||||||
t)
|
|
||||||
|
|
||||||
(DEFUN PR-INFINITY-BASIS (k)
|
|
||||||
(declare (fixnum k))
|
|
||||||
(flet ((rslt (dmns)
|
|
||||||
(declare (fixnum dmns))
|
|
||||||
(if (< 0 dmns k)
|
|
||||||
empty-list
|
|
||||||
(list dmns))))
|
|
||||||
(the basis #'rslt)))
|
|
||||||
|
|
||||||
(DEFUN PR-INFINITY-GDL (k)
|
|
||||||
(declare (fixnum k))
|
|
||||||
(flet ((rslt (indx dmns gsm)
|
|
||||||
(declare (fixnum indx dmns gsm))
|
|
||||||
(if (<= dmns k)
|
|
||||||
(asm (nreverse (<a-b< 0 (1- dmns))) 0)
|
|
||||||
(if (or (zerop indx)
|
|
||||||
(= indx dmns))
|
|
||||||
(asm nil (1- dmns))
|
|
||||||
(if (= dmns (1+ k))
|
|
||||||
(asm (nreverse (<a-b< 0 (1- dmns))) 0)
|
|
||||||
(asm (list (1- indx)) (- dmns 2)))))))
|
|
||||||
(the function #'rslt)))
|
|
||||||
|
|
||||||
(DEFUN PR-INFINITY (&optional (k 1))
|
|
||||||
(declare (fixnum k))
|
|
||||||
(build-ss
|
|
||||||
:eqs #'pr-infinity-eqs
|
|
||||||
:sbs (pr-infinity-basis k)
|
|
||||||
:bsp 0
|
|
||||||
:gdl (pr-infinity-gdl k)
|
|
||||||
:org `(pr-infinity ,k)))
|
|
||||||
|
|
||||||
(setf p (pr-infinity))
|
|
||||||
(sbs p 4)
|
|
||||||
(dotimes (i 5)
|
|
||||||
(print (gdl p i 4 4)))
|
|
||||||
(setf cc (ss-cc p))
|
|
||||||
(dotimes (i 5)
|
|
||||||
(print (d-? cc i i)))
|
|
||||||
(setf dd (cmp-mrp (cc-d cc) (cc-d cc)))
|
|
||||||
(dotimes (i 6)
|
|
||||||
(print (? dd i i)))
|
|
||||||
(setf p (pr-infinity 3))
|
|
||||||
(dotimes (i 7)
|
|
||||||
(print (sbs p i)))
|
|
||||||
(dotimes (i 5)
|
|
||||||
(print (gdl p i 4 4)))
|
|
||||||
(setf d (cc-d (ss-cc p)))
|
|
||||||
(dotimes (i 7)
|
|
||||||
(print (? d i i)))
|
|
||||||
(setf dd (cmp-mrp d d))
|
|
||||||
(dotimes (i 7)
|
|
||||||
(print (? dd i i)))
|
|
||||||
|
|
||||||
(setf p (pr-infinity 3))
|
|
||||||
(setf op (loop-space p))
|
|
||||||
(defun srandom (max)
|
|
||||||
(let ((rslt (- (random (+ max max)) max)))
|
|
||||||
(if (zerop rslt)
|
|
||||||
max
|
|
||||||
rslt)))
|
|
||||||
(dotimes (i 20) (print (srandom 3)))
|
|
||||||
(DEFUN DGOP-INT-EXT (dop)
|
|
||||||
(declare (fixnum dop))
|
|
||||||
(the list
|
|
||||||
(do ((dop dop (ash dop -1))
|
|
||||||
(rslt empty-list)
|
|
||||||
(bmark 0 (1+ bmark)))
|
|
||||||
((zerop dop) rslt)
|
|
||||||
(declare
|
|
||||||
(fixnum dop bmark)
|
|
||||||
(list rslt))
|
|
||||||
(when (oddp dop)
|
|
||||||
(push bmark rslt)))))
|
|
||||||
(defun random-apowr (dmns max-expn)
|
|
||||||
(let ((dgop (dgop-int-ext (* 2 (random (2-exp (1- dmns)))))))
|
|
||||||
(pwr (asm dgop (- 8 (length dgop))) (srandom max-expn))))
|
|
||||||
(dotimes (i 5) (print (random-apowr 8 3)))
|
|
||||||
(defun random-niloop (dmns max-expn length)
|
|
||||||
(mapcar #'(lambda (dummy)
|
|
||||||
(random-apowr (1+ dmns) max-expn))
|
|
||||||
(make-list length)))
|
|
||||||
(dotimes (i 20)
|
|
||||||
(print (normalize-loop 7 (make-strloop :lst (random-niloop 7 3 3)))))
|
|
||||||
(defun random-loop-cmbn (degr max-cffc max-expn loop-length cmbn-length)
|
|
||||||
(do ((rslt empty-list (cons mnm rslt))
|
|
||||||
(i cmbn-length (1- i))
|
|
||||||
(term))
|
|
||||||
((zerop i)
|
|
||||||
(make-cmb :dgr degr :lst rslt))
|
|
||||||
(setf mnm
|
|
||||||
(mnm (srandom max-cffc)
|
|
||||||
(make-strloop :lst (random-niloop degr max-expn loop-length))))))
|
|
||||||
(setf d (cc-d (ss-cc op)))
|
|
||||||
(setf c (random-loop-cmbn 8 10 4 4 100))
|
|
||||||
(time (??? d (??? d c)))
|
|
||||||
(time (??? d (??? d c)))
|
|
||||||
|#
|
|
||||||
|
|
||||||
|
|||||||
@ -84,6 +84,7 @@
|
|||||||
3 (cat:d (cat:mask 5))))))
|
3 (cat:d (cat:mask 5))))))
|
||||||
|
|
||||||
|
|
||||||
|
#|
|
||||||
(test cobar-hrzn-dffr
|
(test cobar-hrzn-dffr
|
||||||
(cat:cat-init)
|
(cat:cat-init)
|
||||||
(let ((h (cat:cobar-hrzn-dffr (cat:soft-delta-infinity)))
|
(let ((h (cat:cobar-hrzn-dffr (cat:soft-delta-infinity)))
|
||||||
@ -100,7 +101,7 @@
|
|||||||
(print (cat:? h (cat:? h (apply #'+ (mapcar #'car
|
(print (cat:? h (cat:? h (apply #'+ (mapcar #'car
|
||||||
(cat:allp-list allp)))
|
(cat:allp-list allp)))
|
||||||
allp)))))))
|
allp)))))))
|
||||||
|
|#
|
||||||
|
|
||||||
(defun random-allp1 (length)
|
(defun random-allp1 (length)
|
||||||
(let ((rslt nil))
|
(let ((rslt nil))
|
||||||
|
|||||||
222
test/loop-spaces-test.lisp
Normal file
222
test/loop-spaces-test.lisp
Normal file
@ -0,0 +1,222 @@
|
|||||||
|
|
||||||
|
(in-package :kenzo-test)
|
||||||
|
|
||||||
|
(in-suite :kenzo)
|
||||||
|
|
||||||
|
|
||||||
|
(test normalize-loop
|
||||||
|
(cat:normalize-loop 4 cat:+empty-list+)
|
||||||
|
(cat:normalize-loop 4 '((1 a . 1)))
|
||||||
|
(cat:normalize-loop 4 '((1 a . 1) (3 b . 1) (5 b . 1))))
|
||||||
|
|
||||||
|
|
||||||
|
(test unnormalize-loop
|
||||||
|
(cat:unnormalize-loop (cat:absm 1 (cat:loop3 2 'a 3))))
|
||||||
|
|
||||||
|
|
||||||
|
(test loop3
|
||||||
|
(cat:loop3 nil)
|
||||||
|
(cat:loop3 '(1 a 2 3 b -2))
|
||||||
|
(signals simple-error (cat:loop3 '(1 a 2 3 b b)))
|
||||||
|
(signals simple-error (cat:loop3 '(1 a 2 3 b)))
|
||||||
|
(cat:loop3 1 'a 2 3 'b 4)
|
||||||
|
(signals simple-error (cat:loop3 1 'a 2 3 'b)))
|
||||||
|
|
||||||
|
|
||||||
|
(test loop-print
|
||||||
|
(print (cat:loop3 nil))
|
||||||
|
(print (cat:loop3 '(0 a 2)))
|
||||||
|
(print (cat:loop3 '(1 a 2)))
|
||||||
|
(print (cat:loop3 '(3 a 2 5 b -1 6 c 4)))
|
||||||
|
(print (cat:loop3 '(7 a 1 11 b 1 13 c 1 14 d 1)))
|
||||||
|
(print (cat:loop3 '(7 a 1 11 b 1 13 c 1 7 d 1)))
|
||||||
|
(print (cat:loop3 '(0 a 1 0 b 2 0 c -1 1 d 1))))
|
||||||
|
|
||||||
|
|
||||||
|
(test apowr-niloop
|
||||||
|
(cat:apowr-niloop #'cat:s-cmpr '(0 a . 1) cat:+empty-list+)
|
||||||
|
(cat:apowr-niloop #'cat:s-cmpr '(0 a . 1) '((1 a . 1)))
|
||||||
|
(cat:apowr-niloop #'cat:s-cmpr '(0 a . 1) '((0 b . 1)))
|
||||||
|
(cat:apowr-niloop #'cat:s-cmpr '(0 a . 1) '((0 a . 1) (0 b . 1)))
|
||||||
|
(cat:apowr-niloop #'cat:s-cmpr '(0 a . 1) '((0 a . -1) (0 b . 1))))
|
||||||
|
|
||||||
|
|
||||||
|
(test loop-space-cmpr
|
||||||
|
(let ((cmpr (cat:loop-space-cmpr #'cat:s-cmpr)))
|
||||||
|
(is (equal :greater (funcall cmpr (cat:loop3 '(1 a 2))
|
||||||
|
(cat:loop3 '(1 a -1)))))
|
||||||
|
(is (equal :greater (funcall cmpr (cat:loop3 '(3 b 4 1 a 2))
|
||||||
|
(cat:loop3 '(3 b 4 1 a -1)))))))
|
||||||
|
|
||||||
|
|
||||||
|
(test apowr-face4
|
||||||
|
(cat:cat-init)
|
||||||
|
(let ((face (cat:face (cat:delta-infinity))))
|
||||||
|
(cat:apowr-face4 face 3 4 (cat:apowr 1 31 5))
|
||||||
|
(setf face (cat:face (cat:sphere 5)))
|
||||||
|
(cat:apowr-face4 face 2 5 (cat:apowr 1 's5 4))
|
||||||
|
(cat:apowr-face4 face 2 5 (cat:apowr 2 's5 4))))
|
||||||
|
|
||||||
|
|
||||||
|
(test apowr-lastface4
|
||||||
|
(cat:cat-init)
|
||||||
|
(let ((cmpr #'cat:f-cmpr)
|
||||||
|
(face (cat:face (cat:delta-infinity))))
|
||||||
|
(cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 63 1))
|
||||||
|
(cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 63 -1))
|
||||||
|
(cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 63 3))
|
||||||
|
(cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 63 -3))
|
||||||
|
(cat:apowr-lastface4 cmpr face 4 (cat:apowr 8 31 1))
|
||||||
|
(setf face #'(lambda (indx dmns gmsm) ; dmns = 5
|
||||||
|
(case indx
|
||||||
|
(5 (cat:absm 8 'a))
|
||||||
|
(4 (cat:absm 8 'a)))))
|
||||||
|
(setf cmpr #'cat:s-cmpr)
|
||||||
|
(cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 'a 2))
|
||||||
|
(setf face #'(lambda (indx dmns gmsm) ; dmns = 5
|
||||||
|
(case indx
|
||||||
|
(5 (cat:absm 1 'a))
|
||||||
|
(4 (cat:absm 8 'a)))))
|
||||||
|
(cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 'a 2))
|
||||||
|
(setf face #'(lambda (indx dmns gmsm) ; dmns = 5
|
||||||
|
(case indx
|
||||||
|
(5 (cat:absm 1 'a))
|
||||||
|
(4 (cat:absm 1 'a)))))
|
||||||
|
(cat:apowr-lastface4 cmpr face 4 (cat:apowr 0 'a 2))))
|
||||||
|
|
||||||
|
|
||||||
|
(test loop-space-face
|
||||||
|
(cat:cat-init)
|
||||||
|
(let* ((cmpr #'cat:f-cmpr)
|
||||||
|
(face (cat:face (cat:delta-infinity)))
|
||||||
|
(rslt (cat:loop-space-face cmpr face)))
|
||||||
|
(funcall rslt 2 4 (cat:loop3 '(0 63 3 1 31 -3)))
|
||||||
|
(funcall rslt 2 4 (cat:loop3 '(0 63 3 0 63 -3)))
|
||||||
|
(funcall rslt 4 4 (cat:loop3 '(0 63 3 0 63 -3)))
|
||||||
|
(funcall rslt 4 4 (cat:loop3 '(0 63 3)))))
|
||||||
|
|
||||||
|
|
||||||
|
(test loop-space-grin-sintr
|
||||||
|
(cat:loop-space-grin-sintr 5 (cat:loop3 0 'a 2 3 'b -3)))
|
||||||
|
|
||||||
|
|
||||||
|
(test loop-space-grml-sintr
|
||||||
|
(let* ((cmpr #'cat:s-cmpr)
|
||||||
|
(ml (cat:loop-space-grml-sintr cmpr)))
|
||||||
|
(funcall ml 2 (cat:crpr 3 (cat:loop3) 0 (cat:loop3 0 'a 2)))
|
||||||
|
(funcall ml 2 (cat:crpr 0 (cat:loop3 0 'a 2) 3 (cat:loop3)))
|
||||||
|
(funcall ml 2 (cat:crpr 0 (cat:loop3 0 'a 2) 0 (cat:loop3 0 'a -2)))
|
||||||
|
(funcall ml 2 (cat:crpr 0 (cat:loop3 0 'a 2) 0 (cat:loop3 0 'a -3)))
|
||||||
|
(funcall ml 2 (cat:crpr 0 (cat:loop3 0 'a 2) 0 (cat:loop3 0 'b -3)))
|
||||||
|
(funcall ml 2 (cat:crpr 0 (cat:loop3 0 'a 2 0 'b -3)
|
||||||
|
0 (cat:loop3 0 'b +3 0 'a -2)))))
|
||||||
|
|
||||||
|
|
||||||
|
(test loop-space
|
||||||
|
(cat:cat-init)
|
||||||
|
(let ((g (cat:gdeltab))
|
||||||
|
basis cmbn cmbn2 dd echcm efhm hat loop-list rslt x)
|
||||||
|
(is (equal :equal (cat:cmpr g (cat:loop3 0 3 2) (cat:loop3 0 3 2))))
|
||||||
|
(is (equal :less (cat:cmpr g (cat:loop3 0 3 2) (cat:loop3 0 3 3))))
|
||||||
|
(is (equal :less (cat:cmpr g (cat:loop3 0 3 2) (cat:loop3 0 5 2))))
|
||||||
|
(is (equal :greater (cat:cmpr g (cat:loop3 0 5 2) (cat:loop3 0 3 2))))
|
||||||
|
(cat:face g 3 3 (cat:loop3 12 7 3))
|
||||||
|
(cat:face g 3 3 (cat:loop3 5 7 3))
|
||||||
|
(cat:face g 3 3 (cat:loop3 6 7 3 5 7 3 3 7 3))
|
||||||
|
(cat:face g 4 4 (cat:absm 4 (cat:loop3 6 7 3 5 7 3 3 7 3)))
|
||||||
|
(cat:check-faces (cat:cmpr g) (cat:face g) 3
|
||||||
|
(cat:loop3 6 7 -3 5 7 -3 3 7 -3))
|
||||||
|
(setf dd (cat:cmps g g))
|
||||||
|
(cat:? dd 3 (cat:loop3 6 7 3 5 7 3 3 7 3))
|
||||||
|
(cat:grml g 2 (cat:crpr 0 (cat:loop3 0 15 3) 0 (cat:loop3 0 15 4)))
|
||||||
|
(cat:grin g 2 (cat:loop3 0 15 -2))
|
||||||
|
(setf rslt (cat:loop3 0 31 1))
|
||||||
|
(setf hat (mapcar #'(lambda (i) (cat:face g i 3 rslt))
|
||||||
|
(cat:<a-b> 0 3)))
|
||||||
|
(dotimes (i 4)
|
||||||
|
(print (cat:kfll g i 3 (remove (nth i hat) hat :test #'equal)))
|
||||||
|
(cat:check-kan g i 3 (remove (nth i hat) hat :test #'equal)))
|
||||||
|
|
||||||
|
(setf g (cat:loop-space (cat:sphere 2)))
|
||||||
|
(setf rslt (cat:loop3 3 's2 2 5 's2 -2 6 's2 2))
|
||||||
|
(setf hat (mapcar #'(lambda (i) (cat:face g i 3 rslt))
|
||||||
|
(cat:<a-b> 0 3)))
|
||||||
|
(dotimes (i 4)
|
||||||
|
(print (cat:kfll g i 3 (remove (nth i hat) hat :test #'equal)))
|
||||||
|
(cat:check-kan g i 3 (remove (nth i hat) hat :test #'equal)))
|
||||||
|
|
||||||
|
(setf g (cat:loop-space (cat:sphere 3) 2))
|
||||||
|
(setf x (first (cat:basis (cat:echcm g) 4)))
|
||||||
|
(setf efhm (cat:efhm g))
|
||||||
|
(setf x (cat:lf efhm (cat:rg efhm 4 x)))
|
||||||
|
(setf rslt (cat:gnrt (first (cat:cmbn-list x))))
|
||||||
|
(setf hat (mapcar #'(lambda (i) (cat:face g i 4 rslt))
|
||||||
|
(cat:<a-b> 0 4)))
|
||||||
|
(dotimes (i 5)
|
||||||
|
(print (cat:kfll g i 4 (remove (nth i hat) hat :test #'equal)))
|
||||||
|
(cat:check-kan g i 4 (remove (nth i hat) hat :test #'equal)))
|
||||||
|
|
||||||
|
(setf rslt (cat:gnrt (third (cat:cmbn-list x))))
|
||||||
|
(setf hat (mapcar #'(lambda (i) (cat:face g i 4 rslt))
|
||||||
|
(cat:<a-b> 0 4)))
|
||||||
|
(dotimes (i 5)
|
||||||
|
(print (cat:kfll g i 4 (remove (nth i hat) hat :test #'equal)))
|
||||||
|
(cat:check-kan g i 4 (remove (nth i hat) hat :test #'equal)))
|
||||||
|
|
||||||
|
(setf g (cat:loop-space (cat:sphere 3) 2))
|
||||||
|
(setf efhm (cat:efhm g))
|
||||||
|
(setf echcm (cat:rbcc efhm))
|
||||||
|
(setf basis (cat:basis echcm 4))
|
||||||
|
(setf cmbn (cat:cmbn 4 1 (first basis) 10 (second basis)
|
||||||
|
100 (third basis)))
|
||||||
|
(setf cmbn2 (cat:lf efhm (cat:rg efhm cmbn)))
|
||||||
|
(setf loop-list (mapcar #'cdr (cat:cmbn-list cmbn2)))
|
||||||
|
(dolist (loop loop-list)
|
||||||
|
(setf hat (mapcar #'(lambda (i) (cat:face g i 4 loop))
|
||||||
|
(cat:<a-b> 0 4)))
|
||||||
|
(dotimes (i 5)
|
||||||
|
(print (cat:kfll g i 4 (remove (nth i hat) hat)))
|
||||||
|
(cat:check-kan g i 4 (remove (nth i hat) hat))))))
|
||||||
|
|
||||||
|
|
||||||
|
(defun random-apowr (dmns max-expn)
|
||||||
|
(loop
|
||||||
|
(let* ((dgop (random (cat:2-exp (1- dmns))))
|
||||||
|
(gmsm (- dmns (logcount dgop))))
|
||||||
|
(unless (< 0 gmsm 3)
|
||||||
|
(return-from random-apowr
|
||||||
|
(cat:apowr dgop gmsm (cat:srandom max-expn)))))))
|
||||||
|
|
||||||
|
|
||||||
|
(defun random-niloop (dmns max-expn length)
|
||||||
|
(mapcar #'(lambda (dummy)
|
||||||
|
(random-apowr (1+ dmns) max-expn))
|
||||||
|
(make-list length)))
|
||||||
|
|
||||||
|
|
||||||
|
(defun random-loop-cmbn (cmpr degr max-cffc max-expn loop-length cmbn-length)
|
||||||
|
(do ((rslt cat:+empty-list+ (cons term rslt))
|
||||||
|
(i cmbn-length (1- i))
|
||||||
|
(term))
|
||||||
|
((zerop i)
|
||||||
|
(apply #'cat:nterm-add cmpr degr rslt))
|
||||||
|
(setf term
|
||||||
|
(cat:term (cat:srandom max-cffc)
|
||||||
|
(cat:make-loop :list (random-niloop degr max-expn
|
||||||
|
loop-length))))))
|
||||||
|
|
||||||
|
|
||||||
|
(test loop-space2
|
||||||
|
(cat:cat-init)
|
||||||
|
(let* ((p (cat:r-proj-space 3))
|
||||||
|
(op (cat:loop-space p))
|
||||||
|
cmpr c)
|
||||||
|
(dotimes (i 15) (print (random-apowr 8 3)))
|
||||||
|
(dotimes (i 20)
|
||||||
|
(print (cat:normalize-loop 7 (random-niloop 7 3 3))))
|
||||||
|
|
||||||
|
(setf cmpr (cat:cmpr op))
|
||||||
|
(setf cat:+too-much-time+ -1)
|
||||||
|
(setf c (random-loop-cmbn cmpr 8 10 4 4 100))
|
||||||
|
(time (cat:? op (cat:? op c)))
|
||||||
|
(time (cat:? op (cat:? op c)))))
|
||||||
Loading…
Reference in New Issue
Block a user