312 lines
11 KiB
Common Lisp
312 lines
11 KiB
Common Lisp
;;; CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS
|
|
;;; CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS
|
|
;;; CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS CARTESIAN-PRODUCTS
|
|
|
|
(IN-PACKAGE "CAT")
|
|
|
|
(PROVIDE "cartesian-products")
|
|
|
|
(DEFMETHOD PRINT-KEYCONS ((car (eql :crpr)) cdr stream)
|
|
(declare
|
|
(cons cdr)
|
|
(stream stream))
|
|
(the (eql t)
|
|
(progn
|
|
(setf cdr (cons car cdr))
|
|
(with-crpr (dgop1 gmsm1 dgop2 gmsm2) cdr
|
|
(format stream
|
|
"<CrPr ~A ~A ~A ~A>"
|
|
(hyphenize-list (dgop-int-ext dgop1)) gmsm1
|
|
(hyphenize-list (dgop-int-ext dgop2)) gmsm2)
|
|
cdr)
|
|
t)))
|
|
|
|
(DEFUN EXTRACT-COMMON-DGOP (dgop1 dgop2)
|
|
(declare (fixnum dgop1 dgop2))
|
|
(let ((dgop (logand dgop1 dgop2)))
|
|
(declare (fixnum dgop))
|
|
(do ((indx (1- (integer-length dgop)) (1- indx)))
|
|
((minusp indx))
|
|
(declare (fixnum indx))
|
|
(when (logbitp indx dgop)
|
|
(setf dgop1 (remove-bit dgop1 indx)
|
|
dgop2 (remove-bit dgop2 indx))))
|
|
(values dgop dgop1 dgop2)))
|
|
|
|
#|
|
|
(dotimes (i 100)
|
|
(dotimes (j 100)
|
|
(multiple-value-bind (dgop dgop1 dgop2) (extract-common-dgop i j)
|
|
(unless (and (= i (dgop*dgop dgop dgop1))
|
|
(= j (dgop*dgop dgop dgop2)))
|
|
(error "i = ~D, j = ~D, dgop = ~D, dgop1 = ~D, dgop2 = ~D"
|
|
i j dgop dgop1 dgop2)))))
|
|
|#
|
|
|
|
(DEFUN 2ABSM-ACRPR (absm1 absm2)
|
|
(declare (type absm absm1 absm2))
|
|
(the absm
|
|
(with-absm (dgop1 gmsm1) absm1
|
|
(with-absm (dgop2 gmsm2) absm2
|
|
(multiple-value-bind (dgop dgop11 dgop22) (extract-common-dgop dgop1 dgop2)
|
|
(declare (fixnum dgop dgop11 dgop22))
|
|
(absm dgop
|
|
(crpr dgop11 gmsm1 dgop22 gmsm2)))))))
|
|
|
|
#|
|
|
(2absm-acrpr (absm 5 'a) (absm 3 'b))
|
|
|#
|
|
|
|
(DEFUN CRTS-PRDC-CMPR (cmpr1 cmpr2)
|
|
(declare (type cmprf cmpr1 cmpr2))
|
|
(flet ((rslt (crpr1 crpr2)
|
|
(declare (type crpr crpr1 crpr2))
|
|
(the cmpr
|
|
(let ((left-cons-1 (cadr crpr1))
|
|
(left-cons-2 (cadr crpr2)))
|
|
(declare (cons left-cons-1 left-cons-2))
|
|
(lexico
|
|
(f-cmpr (car left-cons-1) (car left-cons-2))
|
|
(let ((right-cons-1 (cddr crpr1))
|
|
(right-cons-2 (cddr crpr2)))
|
|
(declare (cons right-cons-1 right-cons-2))
|
|
(lexico
|
|
(f-cmpr (car right-cons-1) (car right-cons-2))
|
|
(funcall cmpr1 (cdr left-cons-1) (cdr left-cons-2))
|
|
(funcall cmpr2 (cdr right-cons-1) (cdr right-cons-2)))))))))
|
|
(the cmprf #'rslt)))
|
|
|
|
#|
|
|
(setf c (cmpr (delta-infinity)))
|
|
(setf rslt (crts-prdc-cmpr c c))
|
|
(funcall rslt (crpr 0 3 0 3) (crpr 1 1 0 3))
|
|
(funcall rslt (crpr 4 3 0 7) (crpr 3 1 0 7))
|
|
(funcall rslt (crpr 0 3 0 3) (crpr 0 3 1 1))
|
|
(funcall rslt (crpr 0 3 0 3) (crpr 0 5 0 3))
|
|
(funcall rslt (crpr 0 3 0 3) (crpr 0 3 0 5))
|
|
(funcall rslt (crpr 0 3 0 3) (crpr 0 3 0 3)))
|
|
|#
|
|
|
|
(DEFUN CRTS-PRDC-BASIS (basis1 basis2)
|
|
(declare (type basis basis1 basis2))
|
|
(when (or (eq basis1 :locally-effective)
|
|
(eq basis2 :locally-effective))
|
|
(return-from crts-prdc-basis :locally-effective))
|
|
(flet ((rslt (dmns)
|
|
(declare (fixnum dmns))
|
|
(the list
|
|
(progn
|
|
(when (minusp dmns)
|
|
(return-from rslt +empty-list+))
|
|
(let ((array1 (make-array (1+ dmns)))
|
|
(array2 (make-array (1+ dmns)))
|
|
(rslt +empty-list+)
|
|
(mask (mask dmns)))
|
|
(declare
|
|
(simple-vector array1 array2)
|
|
(list rslt)
|
|
(fixnum mask))
|
|
(dotimes (i (1+ dmns))
|
|
(setf (svref array1 i) (funcall basis1 i)
|
|
(svref array2 i) (funcall basis2 i)))
|
|
(do ((dgop1 mask (1- dgop1)))
|
|
((minusp dgop1))
|
|
(declare (fixnum dgop1))
|
|
(let ((dmns1 (- dmns (logcount dgop1))))
|
|
(declare (fixnum dmns1))
|
|
(do ((dgop2 mask (1- dgop2)))
|
|
((minusp dgop2))
|
|
(declare (fixnum dgop2))
|
|
(unless (plusp (logand dgop1 dgop2))
|
|
(setf rslt
|
|
(nconc
|
|
(mapcan
|
|
#'(lambda (item1)
|
|
(declare (type gmsm item1))
|
|
(mapcar
|
|
#'(lambda (item2)
|
|
(declare (type gmsm item2))
|
|
(crpr dgop1 item1 dgop2 item2))
|
|
(svref array2 (- dmns (logcount dgop2)))))
|
|
(svref array1 dmns1))
|
|
rslt))))))
|
|
rslt)))))
|
|
(the basis #'rslt)))
|
|
|
|
#|
|
|
(setf b (basis (delta 1)))
|
|
(setf r (crts-prdc-basis b b))
|
|
(funcall r 0)
|
|
(funcall r 1)
|
|
(funcall r 2)
|
|
(funcall r 3)
|
|
(setf d3 (basis (delta 3)))
|
|
(setf r (crts-prdc-basis d3 d3))
|
|
(time (dotimes (i 7)
|
|
(print (length (funcall r i)))))
|
|
(setf s3 (basis (sphere 3)))
|
|
(setf p (crts-prdc-basis s3 s3))
|
|
(dotimes (i 8)
|
|
(print (funcall p i)))
|
|
|#
|
|
|
|
(DEFUN CRTS-PRDC-FACE (face1 face2)
|
|
(declare (type face face1 face2))
|
|
(flet ((rslt (indx dmns crpr)
|
|
(declare
|
|
(fixnum indx dmns)
|
|
(type crpr crpr))
|
|
(with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr
|
|
(multiple-value-bind (dgop1 del1) (1dlop-dgop indx dgop1)
|
|
(declare
|
|
(fixnum dgop1)
|
|
(type (or null fixnum) del1))
|
|
(multiple-value-bind (dgop2 del2) (1dlop-dgop indx dgop2)
|
|
(declare
|
|
(fixnum dgop2)
|
|
(type (or null fixnum) del2))
|
|
(when del1
|
|
(let ((absm1 (funcall face1 del1 (- dmns (logcount dgop1)) gmsm1)))
|
|
(declare (type absm absm1))
|
|
(setf dgop1 (dgop*dgop dgop1 (dgop absm1))
|
|
gmsm1 (gmsm absm1))))
|
|
(when del2
|
|
(let ((absm2 (funcall face2 del2 (- dmns (logcount dgop2)) gmsm2)))
|
|
(declare (type absm absm2))
|
|
(setf dgop2 (dgop*dgop dgop2 (dgop absm2))
|
|
gmsm2 (gmsm absm2))))
|
|
(multiple-value-bind (dgop dgop1 dgop2) (extract-common-dgop dgop1 dgop2)
|
|
(declare (fixnum dgop dgop1 dgop2))
|
|
(absm dgop (crpr dgop1 gmsm1 dgop2 gmsm2))))))))
|
|
(the face #'rslt)))
|
|
|
|
#|
|
|
(setf d2 (delta 2))
|
|
(setf b2 (basis d2))
|
|
(setf f2 (face d2))
|
|
(setf b (crts-prdc-basis b2 b2))
|
|
(setf r (crts-prdc-face f2 f2))
|
|
(dotimes (i 5)
|
|
(unless (zerop i)
|
|
(dolist (item (funcall b i))
|
|
(dotimes (j (1+ i))
|
|
(format t "~%del-~D ~A = ~A"
|
|
j item (funcall r j i item))))))
|
|
|#
|
|
|
|
(DEFUN CRTS-PRDC-FACE* (face1 face2)
|
|
(declare (type face face1 face2))
|
|
(flet ((rslt (indx dmns crpr)
|
|
(declare
|
|
(fixnum indx dmns)
|
|
(type crpr crpr))
|
|
(with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr
|
|
(multiple-value-bind (dgop1 del1) (1dlop-dgop indx dgop1)
|
|
(declare
|
|
(fixnum dgop1)
|
|
(type (or null fixnum) del1))
|
|
(multiple-value-bind (dgop2 del2) (1dlop-dgop indx dgop2)
|
|
(declare
|
|
(fixnum dgop2)
|
|
(type (or null fixnum) del2))
|
|
(when del1
|
|
(let ((absm1 (funcall face1 del1 (- dmns (logcount dgop1)) gmsm1)))
|
|
(declare (type absm absm1))
|
|
(setf dgop1 (dgop*dgop dgop1 (dgop absm1))
|
|
gmsm1 (gmsm absm1))))
|
|
(when del2
|
|
(let ((absm2 (funcall face2 del2 (- dmns (logcount dgop2)) gmsm2)))
|
|
(declare (type absm absm2))
|
|
(setf dgop2 (dgop*dgop dgop2 (dgop absm2))
|
|
gmsm2 (gmsm absm2))))
|
|
(if (plusp (logand dgop1 dgop2))
|
|
:degenerate
|
|
(crpr dgop1 gmsm1 dgop2 gmsm2)))))))
|
|
(the intr #'rslt)))
|
|
|
|
#|
|
|
(setf d2 (delta 2))
|
|
(setf b2 (basis d2))
|
|
(setf f2 (face d2))
|
|
(setf b (crts-prdc-basis b2 b2))
|
|
(setf r (crts-prdc-face* f2 f2))
|
|
(dotimes (i 5)
|
|
(unless (zerop i)
|
|
(dolist (item (coerce (funcall b i) 'list))
|
|
(dotimes (j (1+ i))
|
|
(format t "~%del-~D ~A = ~A"
|
|
j item (funcall r j i item))))))
|
|
(setf s3 (sphere 3))
|
|
(setf b3 (basis s3))
|
|
(setf f3 (face s3))
|
|
(setf b (crts-prdc-basis b3 b3))
|
|
(setf r (crts-prdc-face* f3 f3))
|
|
(dotimes (i 7)
|
|
(unless (zerop i)
|
|
(dolist (item (coerce (funcall b i) 'list))
|
|
(dotimes (j (1+ i))
|
|
(format t "~%del-~D ~A = ~A"
|
|
j item (funcall r j i item))))))
|
|
|#
|
|
|
|
(DEFUN CRTS-PRDC (smst1 smst2)
|
|
(declare (type simplicial-set smst1 smst2))
|
|
(the simplicial-set
|
|
(with-slots ((cmpr1 cmpr) (basis1 basis) (face1 face) (bsgn1 bsgn)) smst1
|
|
(declare
|
|
(type cmprf cmpr1)
|
|
(type basis basis1)
|
|
(type face face1))
|
|
(with-slots ((cmpr2 cmpr) (basis2 basis) (face2 face) (bsgn2 bsgn)) smst2
|
|
(declare
|
|
(type cmprf cmpr2)
|
|
(type basis basis2)
|
|
(type face face2))
|
|
(simplicial-set
|
|
:cmpr (crts-prdc-cmpr cmpr1 cmpr2)
|
|
:basis (crts-prdc-basis basis1 basis2)
|
|
:bsgn (crpr 0 bsgn1 0 bsgn2)
|
|
:face (crts-prdc-face face1 face2)
|
|
:face* (crts-prdc-face* face1 face2)
|
|
:dfnt `(crts-prdc ,smst1 ,smst2))))))
|
|
|
|
#|
|
|
(setf p (crts-prdc (delta 3) (delta 3)))
|
|
(? p 0 (crpr 0 1 0 2))
|
|
(? p 1 (crpr 0 3 0 3))
|
|
(? p 2 (crpr 0 7 0 7))
|
|
(? p 3 (crpr 0 15 0 15))
|
|
(? p 4 (crpr 1 15 2 15))
|
|
|#
|
|
|
|
#|
|
|
;; For comparison with EAT.
|
|
;; In CAT.
|
|
(setf s5 (sphere 5))
|
|
(setf p (crts-prdc s5 s5))
|
|
(setf b (basis p))
|
|
(setf d (dffr p))
|
|
(setf basis (funcall b 10))
|
|
(length basis)
|
|
(setf c (make-cmbn :degr 10 :list (mapcar #'(lambda (item)
|
|
(term (1+ (random 5)) item))
|
|
basis)))
|
|
(setf +too-much-time+ -1)
|
|
(cmbn-? d (cmbn-? d c))
|
|
(time (dotimes (i 5) (cmbn-? d (cmbn-? d c))))
|
|
|#
|
|
|
|
#|
|
|
;; In EAT.
|
|
(setf s5 (sphere 5))
|
|
(setf p (cpr-2ss s5 s5))
|
|
(setf d (cc-d (ss-cc p)))
|
|
(setf basis (sbs p 10))
|
|
(length basis)
|
|
(setf c (make-cmb :dgr 10 :lst (mapcar #'(lambda (item)
|
|
(mnm (1+ (random 5)) item))
|
|
basis)))
|
|
(??? d (??? d c))
|
|
(time (dotimes (i 5) (??? d (??? d c))))
|
|
|#
|