Extracted loop spaces tests.
This commit is contained in:
Gerd Heber
parent
1ea365ec1e
commit
5528954480
@ -32,6 +32,7 @@
|
||||
(:file "homology-groups-test")
|
||||
(:file "k-pi-n-test")
|
||||
(:file "kan-test")
|
||||
(:file "loop-spaces-test")
|
||||
(:file "searching-homology-test")
|
||||
(:file "simplicial-groups-test")
|
||||
(:file "simplicial-mrphs-test")
|
||||
|
||||
14
package.lisp
14
package.lisp
@ -118,6 +118,7 @@
|
||||
ABSM
|
||||
AB-SIMPLICIAL-GROUP
|
||||
ALLP-LIST
|
||||
APOWR
|
||||
BCC
|
||||
BRGN
|
||||
CBGN
|
||||
@ -142,6 +143,7 @@
|
||||
MAKE-ABAR
|
||||
MAKE-ALLP
|
||||
MAKE-CMBN
|
||||
MAKE-LOOP
|
||||
MAKE-RESULT
|
||||
MORPHISM
|
||||
ORGN
|
||||
@ -324,14 +326,25 @@
|
||||
;; loop-spaces.lisp
|
||||
|
||||
+NULL-LOOP+
|
||||
APOWR-FACE4
|
||||
APOWR-LASTFACE4
|
||||
APOWR-NILOOP
|
||||
GDELTAB
|
||||
LOOP3
|
||||
LOOP-PRINT
|
||||
LOOP-SPACE
|
||||
LOOP-SPACE-CMPR
|
||||
LOOP-SPACE-FACE
|
||||
LOOP-SPACE-GRIN-SINTR
|
||||
LOOP-SPACE-GRML-SINTR
|
||||
NORMALIZE-LOOP
|
||||
UNNORMALIZE-LOOP
|
||||
|
||||
;; macros.lisp
|
||||
|
||||
-1-EXPT-N
|
||||
?
|
||||
2-EXP
|
||||
ABAR-LIST
|
||||
APRD
|
||||
BASIS
|
||||
@ -372,6 +385,7 @@
|
||||
|
||||
;; searching-homology.lisp
|
||||
|
||||
ECHCM
|
||||
HOMOLOGY
|
||||
|
||||
;; serre.lisp
|
||||
|
||||
@ -758,13 +758,3 @@
|
||||
(zero-cmbn (- dmns n))))
|
||||
:strt :gnrt
|
||||
: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.
|
||||
|
||||
(DEFUN NORMALIZE-LOOP (dmns niloop)
|
||||
(declare (list niloop))
|
||||
(the absm
|
||||
(progn
|
||||
(declare (list niloop))
|
||||
(the absm
|
||||
(progn
|
||||
(unless niloop
|
||||
(return-from normalize-loop
|
||||
(absm (mask dmns) +null-loop+)))
|
||||
(return-from normalize-loop
|
||||
(absm (mask dmns) +null-loop+)))
|
||||
(let ((dgop (apply #'logand (mapcar #'car niloop))))
|
||||
(declare (fixnum dgop))
|
||||
(if (zerop dgop)
|
||||
(declare (fixnum dgop))
|
||||
(if (zerop dgop)
|
||||
(absm 0 (make-loop :list niloop))
|
||||
(absm dgop
|
||||
(make-loop
|
||||
:list (mapcar #'(lambda (apowr)
|
||||
(make-loop
|
||||
:list (mapcar #'(lambda (apowr)
|
||||
(cons
|
||||
(dgop/dgop (apdgop apowr) dgop)
|
||||
(cdr apowr)))
|
||||
niloop))))))))
|
||||
(dgop/dgop (apdgop apowr) dgop)
|
||||
(cdr apowr)))
|
||||
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)
|
||||
(declare (type absm absm))
|
||||
(the iloop
|
||||
(with-absm (dgop loop) absm
|
||||
(mapcar #'(lambda (apowr)
|
||||
(declare (type apowr apowr))
|
||||
(cons (dgop*dgop dgop (car apowr))
|
||||
(cdr apowr)))
|
||||
(loop-list loop)))))
|
||||
(with-absm (dgop loop) absm
|
||||
(mapcar #'(lambda (apowr)
|
||||
(declare (type apowr apowr))
|
||||
(cons (dgop*dgop dgop (car apowr))
|
||||
(cdr apowr)))
|
||||
(loop-list loop)))))
|
||||
|
||||
#|
|
||||
(unnormalize-loop (absm 1 (loop3 2 'a 3)))
|
||||
|#
|
||||
|
||||
(DEFUN LOOP3 (&rest list)
|
||||
(when (and (= 1 (length list))
|
||||
@ -57,9 +49,9 @@
|
||||
(unless (zerop (mod (length list) 3))
|
||||
(error "In LOOP3, 3 should divide the list length."))
|
||||
(flet ((fixnumpp (object)
|
||||
(unless (typep object 'fixnum)
|
||||
(error "In LOOP3, ~A should be a fixnum." object))
|
||||
object))
|
||||
(unless (typep object 'fixnum)
|
||||
(error "In LOOP3, ~A should be a fixnum." object))
|
||||
object))
|
||||
(do ((rslt +empty-list+ (cons (apowr
|
||||
(fixnumpp (car mark))
|
||||
(cadr mark)
|
||||
@ -69,544 +61,275 @@
|
||||
((endp mark) (make-loop :list (nreverse rslt)))
|
||||
(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)
|
||||
(declare
|
||||
(type loop loop) (stream stream)
|
||||
(ignore depth))
|
||||
(the loop
|
||||
(progn
|
||||
(format stream "<<Loop")
|
||||
(dolist (apowr (loop-list loop))
|
||||
(declare (type apowr apowr))
|
||||
(with-apowr (dgop gmsm expn) apowr
|
||||
(format stream "[")
|
||||
(unless (zerop dgop)
|
||||
(format stream "~A " (hyphenize-list (dgop-int-ext dgop))))
|
||||
(format stream "~A" gmsm)
|
||||
(unless (= 1 expn)
|
||||
(format stream "\\~D" expn))
|
||||
(format stream "]")))
|
||||
(format stream ">>")
|
||||
loop)))
|
||||
(progn
|
||||
(format stream "<<Loop")
|
||||
(dolist (apowr (loop-list loop))
|
||||
(declare (type apowr apowr))
|
||||
(with-apowr (dgop gmsm expn) apowr
|
||||
(format stream "[")
|
||||
(unless (zerop dgop)
|
||||
(format stream "~A " (hyphenize-list (dgop-int-ext dgop))))
|
||||
(format stream "~A" gmsm)
|
||||
(unless (= 1 expn)
|
||||
(format stream "\\~D" expn))
|
||||
(format stream "]")))
|
||||
(format stream ">>")
|
||||
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)
|
||||
(declare
|
||||
(type cmprf cmpr)
|
||||
(type apowr apowr)
|
||||
(type iloop niloop))
|
||||
(the iloop
|
||||
(progn
|
||||
(declare
|
||||
(type cmprf cmpr)
|
||||
(type apowr apowr)
|
||||
(type iloop niloop))
|
||||
(the iloop
|
||||
(progn
|
||||
(unless niloop
|
||||
(return-from apowr-niloop
|
||||
(list apowr)))
|
||||
(return-from apowr-niloop
|
||||
(list apowr)))
|
||||
(let ((apowr2 (first niloop)))
|
||||
(declare (type apowr apowr2))
|
||||
(with-apowr (dgop2 gmsm2 expn2) apowr2
|
||||
(unless (and (= (apdgop apowr) dgop2)
|
||||
(eq :equal (funcall cmpr (apgmsm apowr) gmsm2)))
|
||||
(return-from apowr-niloop
|
||||
(cons apowr niloop)))
|
||||
(incf expn2 (apexpn apowr))
|
||||
(if (zerop expn2)
|
||||
(rest niloop)
|
||||
(cons (apowr dgop2 gmsm2 expn2) (rest niloop))))))))
|
||||
(declare (type apowr apowr2))
|
||||
(with-apowr (dgop2 gmsm2 expn2) apowr2
|
||||
(unless (and (= (apdgop apowr) dgop2)
|
||||
(eq :equal (funcall cmpr (apgmsm apowr)
|
||||
gmsm2)))
|
||||
(return-from apowr-niloop
|
||||
(cons apowr niloop)))
|
||||
(incf expn2 (apexpn apowr))
|
||||
(if (zerop expn2)
|
||||
(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)
|
||||
(declare (type cmprf cmpr))
|
||||
(flet ((2apowr-cmpr (apowr1 apowr2)
|
||||
(declare (type cmprf cmpr))
|
||||
(flet ((2apowr-cmpr (apowr1 apowr2)
|
||||
(declare (type apowr apowr1 apowr2))
|
||||
(lexico
|
||||
(f-cmpr (apdgop apowr1) (apdgop apowr2))
|
||||
(funcall cmpr (apgmsm apowr1) (apgmsm apowr2))
|
||||
(f-cmpr (apexpn apowr1) (apexpn apowr2)))))
|
||||
(flet ((rslt (loop1 loop2)
|
||||
(declare (type loop loop1 loop2))
|
||||
(maplexico #'2apowr-cmpr (loop-list loop1) (loop-list loop2))))
|
||||
(the cmprf #'rslt))))
|
||||
(f-cmpr (apdgop apowr1) (apdgop apowr2))
|
||||
(funcall cmpr (apgmsm apowr1) (apgmsm apowr2))
|
||||
(f-cmpr (apexpn apowr1) (apexpn apowr2)))))
|
||||
(flet ((rslt (loop1 loop2)
|
||||
(declare (type loop loop1 loop2))
|
||||
(maplexico #'2apowr-cmpr (loop-list loop1) (loop-list loop2))))
|
||||
(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)
|
||||
;; dmns = dimension in the loop-space
|
||||
(declare
|
||||
(type face face)
|
||||
(type apowr apowr))
|
||||
(with-apowr (dgop gmsm expn) apowr
|
||||
(let ((face (a-face4 face indx (1+ dmns) (absm dgop gmsm))))
|
||||
(declare (type absm face))
|
||||
(with-absm (dgop gmsm) face
|
||||
(if (logbitp (1- dmns) dgop)
|
||||
nil
|
||||
(apowr dgop gmsm expn))))))
|
||||
;; dmns = dimension in the loop-space
|
||||
(declare
|
||||
(type face face)
|
||||
(type apowr apowr))
|
||||
(with-apowr (dgop gmsm expn) apowr
|
||||
(let ((face (a-face4 face indx (1+ dmns) (absm dgop gmsm))))
|
||||
(declare (type absm face))
|
||||
(with-absm (dgop gmsm) face
|
||||
(if (logbitp (1- dmns) dgop)
|
||||
nil
|
||||
(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)
|
||||
;; indx =dmns
|
||||
(declare
|
||||
(type cmprf cmpr)
|
||||
(type face face)
|
||||
(fixnum dmns)
|
||||
(type apowr apowr))
|
||||
(the list
|
||||
(with-apowr (dgop gmsm expn) apowr
|
||||
(let ((absm (absm dgop gmsm)))
|
||||
(declare (type absm absm))
|
||||
(let ((face-n (a-face4 face dmns (1+ dmns) absm))
|
||||
(face-n+1 (a-face4 face (1+ dmns) (1+ dmns) absm)))
|
||||
(declare (type absm face-n face-n+1))
|
||||
(with-absm (dgop1 gmsm1) face-n
|
||||
(with-absm (dgop2 gmsm2) face-n+1
|
||||
(if (logbitp (1- dmns) dgop1)
|
||||
(if (logbitp (1- dmns) dgop2)
|
||||
(return-from apowr-lastface4 +empty-list+)
|
||||
(return-from apowr-lastface4
|
||||
(list (apowr dgop2 gmsm2 (- expn)))))
|
||||
(when (logbitp (1- dmns) dgop2)
|
||||
(return-from apowr-lastface4
|
||||
(list (apowr dgop1 gmsm1 expn)))))
|
||||
(when (and (= dgop1 dgop2)
|
||||
(eq :equal (funcall cmpr gmsm1 gmsm2)))
|
||||
(return-from apowr-lastface4 +empty-list+))
|
||||
(case expn
|
||||
(+1 (list (apowr dgop2 gmsm2 -1) (apowr dgop1 gmsm1 +1)))
|
||||
(-1 (list (apowr dgop1 gmsm1 -1) (apowr dgop2 gmsm2 +1)))
|
||||
(otherwise
|
||||
(if (plusp expn)
|
||||
(do ((rslt +empty-list+ (cons apowr2 (cons apowr1 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)))
|
||||
(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)))))))))))))
|
||||
;; indx =dmns
|
||||
(declare
|
||||
(type cmprf cmpr)
|
||||
(type face face)
|
||||
(fixnum dmns)
|
||||
(type apowr apowr))
|
||||
(the list
|
||||
(with-apowr
|
||||
(dgop gmsm expn) apowr
|
||||
(let ((absm (absm dgop gmsm)))
|
||||
(declare (type absm absm))
|
||||
(let ((face-n (a-face4 face dmns (1+ dmns) absm))
|
||||
(face-n+1 (a-face4 face (1+ dmns) (1+ dmns) absm)))
|
||||
(declare (type absm face-n face-n+1))
|
||||
(with-absm
|
||||
(dgop1 gmsm1) face-n
|
||||
(with-absm
|
||||
(dgop2 gmsm2) face-n+1
|
||||
(if (logbitp (1- dmns) dgop1)
|
||||
(if (logbitp (1- dmns) dgop2)
|
||||
(return-from apowr-lastface4 +empty-list+)
|
||||
(return-from apowr-lastface4
|
||||
(list (apowr dgop2 gmsm2 (- expn)))))
|
||||
(when (logbitp (1- dmns) dgop2)
|
||||
(return-from apowr-lastface4
|
||||
(list (apowr dgop1 gmsm1 expn)))))
|
||||
(when (and (= dgop1 dgop2)
|
||||
(eq :equal (funcall cmpr gmsm1 gmsm2)))
|
||||
(return-from apowr-lastface4 +empty-list+))
|
||||
(case expn
|
||||
(+1 (list (apowr dgop2 gmsm2 -1) (apowr dgop1 gmsm1
|
||||
+1)))
|
||||
(-1 (list (apowr dgop1 gmsm1 -1) (apowr dgop2 gmsm2
|
||||
+1)))
|
||||
(otherwise
|
||||
(if (plusp expn)
|
||||
(do ((rslt +empty-list+ (cons apowr2
|
||||
(cons apowr1
|
||||
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)))
|
||||
(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)
|
||||
(declare
|
||||
(type cmprf cmpr)
|
||||
(type face face))
|
||||
(flet ((rslt (indx dmns loop)
|
||||
(declare
|
||||
(fixnum indx dmns)
|
||||
(type loop loop))
|
||||
(the absm
|
||||
(declare
|
||||
(type cmprf cmpr)
|
||||
(type face face))
|
||||
(flet ((rslt (indx dmns loop)
|
||||
(declare
|
||||
(fixnum indx dmns)
|
||||
(type loop loop))
|
||||
(the absm
|
||||
(let ((rslt +empty-list+))
|
||||
(declare (type iloop rslt))
|
||||
(if (< indx dmns)
|
||||
(declare (type iloop rslt))
|
||||
(if (< indx dmns)
|
||||
(dolist (apowr (loop-list loop))
|
||||
(declare (type apowr apowr))
|
||||
(let ((lface (apowr-face4 face indx dmns apowr)))
|
||||
(declare (type (or null apowr) lface))
|
||||
(when lface (setf rslt (apowr-niloop cmpr lface rslt)))))
|
||||
(declare (type apowr apowr))
|
||||
(let ((lface (apowr-face4 face indx dmns apowr)))
|
||||
(declare (type (or null apowr) lface))
|
||||
(when lface (setf rslt (apowr-niloop cmpr lface
|
||||
rslt)))))
|
||||
(dolist (apowr (loop-list loop))
|
||||
(declare (type apowr apowr))
|
||||
(let ((lface (apowr-lastface4 cmpr face dmns apowr)))
|
||||
(declare (list lface))
|
||||
(dolist (apowr lface)
|
||||
(declare (type apowr apowr))
|
||||
(setf rslt (apowr-niloop cmpr apowr rslt))))))
|
||||
(normalize-loop (1- dmns) (nreverse rslt))))))
|
||||
(the face #'rslt)))
|
||||
(declare (type apowr apowr))
|
||||
(let ((lface (apowr-lastface4 cmpr face dmns apowr)))
|
||||
(declare (list lface))
|
||||
(dolist (apowr lface)
|
||||
(declare (type apowr apowr))
|
||||
(setf rslt (apowr-niloop cmpr apowr rslt))))))
|
||||
(normalize-loop (1- dmns) (nreverse 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)
|
||||
(declare
|
||||
(type cmprf cmpr)
|
||||
(type face face))
|
||||
(flet ((rslt (indx dmns loop)
|
||||
(declare
|
||||
(fixnum indx dmns)
|
||||
(type loop loop))
|
||||
(the (or loop (eql :degenerate))
|
||||
(declare
|
||||
(type cmprf cmpr)
|
||||
(type face face))
|
||||
(flet ((rslt (indx dmns loop)
|
||||
(declare
|
||||
(fixnum indx dmns)
|
||||
(type loop loop))
|
||||
(the (or loop (eql :degenerate))
|
||||
(let ((rslt +empty-list+))
|
||||
(declare (type iloop rslt))
|
||||
(if (< indx dmns)
|
||||
(declare (type iloop rslt))
|
||||
(if (< indx dmns)
|
||||
(dolist (apowr (loop-list loop))
|
||||
(declare (type apowr apowr))
|
||||
(let ((lface (apowr-face4 face indx dmns apowr)))
|
||||
(declare (type (or null apowr) lface))
|
||||
(when lface (setf rslt (apowr-niloop cmpr lface rslt)))))
|
||||
(declare (type apowr apowr))
|
||||
(let ((lface (apowr-face4 face indx dmns apowr)))
|
||||
(declare (type (or null apowr) lface))
|
||||
(when lface (setf rslt (apowr-niloop cmpr lface
|
||||
rslt)))))
|
||||
(dolist (apowr (loop-list loop))
|
||||
(declare (type apowr apowr))
|
||||
(let ((lface (apowr-lastface4 cmpr face dmns apowr)))
|
||||
(declare (list lface))
|
||||
(dolist (apowr lface)
|
||||
(declare (type apowr apowr))
|
||||
(setf rslt (apowr-niloop cmpr apowr rslt))))))
|
||||
(if (zerop (apply #'logand (mapcar #'car rslt)))
|
||||
(declare (type apowr apowr))
|
||||
(let ((lface (apowr-lastface4 cmpr face dmns apowr)))
|
||||
(declare (list lface))
|
||||
(dolist (apowr lface)
|
||||
(declare (type apowr apowr))
|
||||
(setf rslt (apowr-niloop cmpr apowr rslt))))))
|
||||
(if (zerop (apply #'logand (mapcar #'car rslt)))
|
||||
(make-loop :list (nreverse rslt))
|
||||
:degenerate)))))
|
||||
(the face* #'rslt)))
|
||||
(the face* #'rslt)))
|
||||
|
||||
|
||||
(DEFUN LOOP-SPACE-GRIN-SINTR (dmns loop)
|
||||
(declare
|
||||
(ignore dmns)
|
||||
(type loop loop))
|
||||
(ignore dmns)
|
||||
(type loop loop))
|
||||
(the absm
|
||||
(absm 0 (make-loop
|
||||
:list (mapcar #'(lambda (apowr)
|
||||
(declare (type apowr apowr))
|
||||
(with-apowr (dgop gmsm expn) apowr
|
||||
(apowr dgop gmsm (- expn))))
|
||||
(reverse (loop-list loop)))))))
|
||||
(absm 0 (make-loop
|
||||
:list (mapcar #'(lambda (apowr)
|
||||
(declare (type apowr apowr))
|
||||
(with-apowr (dgop gmsm expn) apowr
|
||||
(apowr dgop gmsm (- expn))))
|
||||
(reverse (loop-list loop)))))))
|
||||
|
||||
#|
|
||||
(loop-space-grin-sintr 5 (loop3 0 'a 2 3 'b -3))
|
||||
|#
|
||||
|
||||
(DEFUN LOOP-SPACE-GRML-SINTR (cmpr)
|
||||
(declare (type cmprf cmpr))
|
||||
(flet ((rslt (dmns crpr)
|
||||
(declare
|
||||
(fixnum dmns)
|
||||
(type crpr crpr))
|
||||
(the absm
|
||||
(with-crpr (absm1 absm2) crpr
|
||||
(let ((niloop1 (nreverse (unnormalize-loop absm1)))
|
||||
(niloop2 (unnormalize-loop absm2)))
|
||||
(declare (type iloop niloop1 niloop2))
|
||||
(loop
|
||||
(unless niloop1 (return))
|
||||
(unless niloop2 (return))
|
||||
(let ((apowr1 (first niloop1))
|
||||
(apowr2 (first niloop2)))
|
||||
(declare (type apowr apowr1 apowr2))
|
||||
(with-apowr (dgop1 gmsm1 expn1) apowr1
|
||||
(with-apowr (dgop2 gmsm2 expn2) apowr2
|
||||
(unless (and (= dgop1 dgop2)
|
||||
(eq :equal (funcall cmpr gmsm1 gmsm2)))
|
||||
(return))
|
||||
(incf expn1 expn2)
|
||||
(cond ((zerop expn1)
|
||||
(pop niloop1)
|
||||
(pop niloop2))
|
||||
(t
|
||||
(pop niloop1)
|
||||
(setf niloop2
|
||||
(cons (apowr dgop2 gmsm2 expn1)
|
||||
(rest niloop2)))
|
||||
(return)))))))
|
||||
(normalize-loop dmns
|
||||
(nreconc niloop1 niloop2)))))))
|
||||
(the sintr #'rslt)))
|
||||
(declare
|
||||
(fixnum dmns)
|
||||
(type crpr crpr))
|
||||
(the absm
|
||||
(with-crpr
|
||||
(absm1 absm2) crpr
|
||||
(let ((niloop1 (nreverse (unnormalize-loop absm1)))
|
||||
(niloop2 (unnormalize-loop absm2)))
|
||||
(declare (type iloop niloop1 niloop2))
|
||||
(loop
|
||||
(unless niloop1 (return))
|
||||
(unless niloop2 (return))
|
||||
(let ((apowr1 (first niloop1))
|
||||
(apowr2 (first niloop2)))
|
||||
(declare (type apowr apowr1 apowr2))
|
||||
(with-apowr
|
||||
(dgop1 gmsm1 expn1) apowr1
|
||||
(with-apowr
|
||||
(dgop2 gmsm2 expn2) apowr2
|
||||
(unless (and (= dgop1 dgop2)
|
||||
(eq :equal (funcall cmpr
|
||||
gmsm1
|
||||
gmsm2)))
|
||||
(return))
|
||||
(incf expn1 expn2)
|
||||
(cond ((zerop expn1)
|
||||
(pop niloop1)
|
||||
(pop niloop2))
|
||||
(t
|
||||
(pop niloop1)
|
||||
(setf niloop2
|
||||
(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))
|
||||
(declare
|
||||
(type simplicial-set smst)
|
||||
(fixnum n))
|
||||
(the simplicial-group
|
||||
(if (= n 1)
|
||||
(with-slots (cmpr face) smst
|
||||
(declare
|
||||
(type cmprf cmpr)
|
||||
(type face face))
|
||||
(build-smgr
|
||||
:cmpr (loop-space-cmpr cmpr)
|
||||
:basis :locally-effective
|
||||
:bspn +null-loop+
|
||||
:face (loop-space-face cmpr face)
|
||||
:face* (loop-space-face* cmpr face)
|
||||
:sintr-grml (loop-space-grml-sintr cmpr)
|
||||
:sintr-grin #'loop-space-grin-sintr
|
||||
:orgn `(loop-space ,smst)))
|
||||
(loop-space (loop-space smst) (1- n)))))
|
||||
(declare
|
||||
(type simplicial-set smst)
|
||||
(fixnum n))
|
||||
(the simplicial-group
|
||||
(if (= n 1)
|
||||
(with-slots (cmpr face) smst
|
||||
(declare
|
||||
(type cmprf cmpr)
|
||||
(type face face))
|
||||
(build-smgr
|
||||
:cmpr (loop-space-cmpr cmpr)
|
||||
:basis :locally-effective
|
||||
:bspn +null-loop+
|
||||
:face (loop-space-face cmpr face)
|
||||
:face* (loop-space-face* cmpr face)
|
||||
:sintr-grml (loop-space-grml-sintr cmpr)
|
||||
:sintr-grin #'loop-space-grin-sintr
|
||||
:orgn `(loop-space ,smst)))
|
||||
(loop-space (loop-space smst) (1- n)))))
|
||||
|
||||
|
||||
(DEFUN GDELTAB ()
|
||||
(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)))
|
||||
|#
|
||||
|
||||
(loop-space (deltab)))
|
||||
|
||||
@ -84,6 +84,7 @@
|
||||
3 (cat:d (cat:mask 5))))))
|
||||
|
||||
|
||||
#|
|
||||
(test cobar-hrzn-dffr
|
||||
(cat:cat-init)
|
||||
(let ((h (cat:cobar-hrzn-dffr (cat:soft-delta-infinity)))
|
||||
@ -100,7 +101,7 @@
|
||||
(print (cat:? h (cat:? h (apply #'+ (mapcar #'car
|
||||
(cat:allp-list allp)))
|
||||
allp)))))))
|
||||
|
||||
|#
|
||||
|
||||
(defun random-allp1 (length)
|
||||
(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