338 lines
13 KiB
Common Lisp
338 lines
13 KiB
Common Lisp
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
|
|
|
|
;;; LOOP-SPACES LOOP-SPACES LOOP-SPACES LOOP-SPACES LOOP-SPACES LOOP-SPACES
|
|
;;; LOOP-SPACES LOOP-SPACES LOOP-SPACES LOOP-SPACES LOOP-SPACES LOOP-SPACES
|
|
;;; LOOP-SPACES LOOP-SPACES LOOP-SPACES LOOP-SPACES LOOP-SPACES LOOP-SPACES
|
|
|
|
(IN-PACKAGE #:cat)
|
|
|
|
(PROVIDE "loop-spaces")
|
|
|
|
#-sbcl (DEFINE-CONSTANT +NULL-LOOP+ (make-loop :list +empty-list+))
|
|
#+sbcl (DEFPARAMETER +NULL-LOOP+ (make-loop :list +empty-list+))
|
|
|
|
;;; NILOOP = non-normalized iloop; a common dgop is possible.
|
|
|
|
(DEFUN NORMALIZE-LOOP (dmns niloop)
|
|
(declare (list niloop))
|
|
(the absm
|
|
(progn
|
|
(unless niloop
|
|
(return-from normalize-loop
|
|
(absm (mask dmns) +null-loop+)))
|
|
(let ((dgop (apply #'logand (mapcar #'car niloop))))
|
|
(declare (fixnum dgop))
|
|
(if (zerop dgop)
|
|
(absm 0 (make-loop :list niloop))
|
|
(absm dgop
|
|
(make-loop
|
|
:list (mapcar #'(lambda (apowr)
|
|
(cons
|
|
(dgop/dgop (apdgop apowr) dgop)
|
|
(cdr apowr)))
|
|
niloop))))))))
|
|
|
|
|
|
(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)))))
|
|
|
|
|
|
(DEFUN LOOP3 (&rest list)
|
|
(when (and (= 1 (length list))
|
|
(listp (first list)))
|
|
(setf list (first list)))
|
|
(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))
|
|
(do ((rslt +empty-list+ (cons (apowr
|
|
(fixnumpp (car mark))
|
|
(cadr mark)
|
|
(fixnumpp (caddr mark)))
|
|
rslt))
|
|
(mark list (cdddr mark)))
|
|
((endp mark) (make-loop :list (nreverse rslt)))
|
|
(declare (list rslt mark)))))
|
|
|
|
|
|
(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)))
|
|
|
|
|
|
(DEFUN APOWR-NILOOP (cmpr apowr niloop)
|
|
(declare
|
|
(type cmprf cmpr)
|
|
(type apowr apowr)
|
|
(type iloop niloop))
|
|
(the iloop
|
|
(progn
|
|
(unless niloop
|
|
(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))))))))
|
|
|
|
|
|
(DEFUN LOOP-SPACE-CMPR (cmpr)
|
|
(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))))
|
|
|
|
|
|
(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))))))
|
|
|
|
|
|
(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)))))))))))))
|
|
|
|
|
|
(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
|
|
(let ((rslt +empty-list+))
|
|
(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)))))
|
|
(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)))
|
|
|
|
|
|
(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))
|
|
(let ((rslt +empty-list+))
|
|
(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)))))
|
|
(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)))
|
|
(make-loop :list (nreverse rslt))
|
|
:degenerate)))))
|
|
(the face* #'rslt)))
|
|
|
|
|
|
(DEFUN LOOP-SPACE-GRIN-SINTR (dmns loop)
|
|
(declare
|
|
(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)))))))
|
|
|
|
|
|
(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)))
|
|
|
|
|
|
(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)))))
|
|
|
|
|
|
(DEFUN GDELTAB ()
|
|
(loop-space (deltab)))
|