Fixed error in SOFT-DELTA-CMPR
Must be L-CMPR instead of F-CMPR, since CDR returns a list.
This commit is contained in:
gheber
parent
911a74de68
commit
b82a5e6884
483
src/delta.lisp
483
src/delta.lisp
@ -7,36 +7,33 @@
|
|||||||
(PROVIDE "delta")
|
(PROVIDE "delta")
|
||||||
|
|
||||||
(DEFMETHOD PRINT-KEYCONS ((car (eql :delt)) cdr stream)
|
(DEFMETHOD PRINT-KEYCONS ((car (eql :delt)) cdr stream)
|
||||||
(format stream "~A" (hyphenize-list (dlop-int-ext cdr)))
|
(format stream "~A" (hyphenize-list (dlop-int-ext cdr)))
|
||||||
(cons car cdr))
|
(cons car cdr))
|
||||||
|
|
||||||
|
|
||||||
(DEFUN SOFT-DELTA-CMPR (gmsm1 gmsm2)
|
(DEFUN SOFT-DELTA-CMPR (gmsm1 gmsm2)
|
||||||
(f-cmpr (cdr gmsm1) (cdr gmsm2)))
|
(l-cmpr (cdr gmsm1) (cdr gmsm2)))
|
||||||
|
|
||||||
|
|
||||||
#|
|
|
||||||
()
|
|
||||||
(soft-delta-cmpr (d 12) (d 23))
|
|
||||||
|#
|
|
||||||
|
|
||||||
(DEFUN DELTA-FACE (indx dmns gmsm)
|
(DEFUN DELTA-FACE (indx dmns gmsm)
|
||||||
(declare
|
(declare
|
||||||
(fixnum indx gmsm)
|
(fixnum indx gmsm)
|
||||||
(ignore dmns))
|
(ignore dmns))
|
||||||
(the absm
|
(the absm
|
||||||
(do ((pmark 1 (ash pmark 1))
|
(do ((pmark 1 (ash pmark 1))
|
||||||
(bmark indx)
|
(bmark indx)
|
||||||
(gmsm2 gmsm (ash gmsm2 -1)))
|
(gmsm2 gmsm (ash gmsm2 -1)))
|
||||||
(nil)
|
(nil)
|
||||||
(declare (fixnum pmark bmark gmsm2))
|
(declare (fixnum pmark bmark gmsm2))
|
||||||
(when (oddp gmsm2)
|
(when (oddp gmsm2)
|
||||||
(when (minusp (decf bmark))
|
(when (minusp (decf bmark))
|
||||||
(return-from delta-face (absm 0 (logxor gmsm pmark))))))))
|
(return-from delta-face (absm 0 (logxor gmsm pmark))))))))
|
||||||
|
|
||||||
(DEFUN SOFT-DELTA-FACE (indx dmns gmsm)
|
(DEFUN SOFT-DELTA-FACE (indx dmns gmsm)
|
||||||
(declare
|
(declare
|
||||||
(fixnum indx dmns)
|
(fixnum indx dmns)
|
||||||
(type soft-dlop gmsm))
|
(type soft-dlop gmsm))
|
||||||
(absm 0 (d (gmsm (delta-face indx dmns (cdr gmsm))))))
|
(absm 0 (d (gmsm (delta-face indx dmns (cdr gmsm))))))
|
||||||
|
|
||||||
#|
|
#|
|
||||||
()
|
()
|
||||||
@ -51,34 +48,34 @@
|
|||||||
|#
|
|#
|
||||||
|
|
||||||
(DEFUN DELTA-BNDR (dmns gmsm)
|
(DEFUN DELTA-BNDR (dmns gmsm)
|
||||||
(declare (fixnum dmns gmsm))
|
(declare (fixnum dmns gmsm))
|
||||||
(the cmbn
|
(the cmbn
|
||||||
(if (zerop dmns)
|
(if (zerop dmns)
|
||||||
+zero-negative-cmbn+
|
+zero-negative-cmbn+
|
||||||
(make-cmbn
|
(make-cmbn
|
||||||
:degr (1- dmns)
|
:degr (1- dmns)
|
||||||
:list (do ((rslt +empty-list+)
|
:list (do ((rslt +empty-list+)
|
||||||
(gmsm2 gmsm (ash gmsm2 -1))
|
(gmsm2 gmsm (ash gmsm2 -1))
|
||||||
(pmark 1 (ash pmark +1))
|
(pmark 1 (ash pmark +1))
|
||||||
(sign 1))
|
(sign 1))
|
||||||
((zerop gmsm2) rslt)
|
((zerop gmsm2) rslt)
|
||||||
(declare
|
(declare
|
||||||
(list rslt)
|
(list rslt)
|
||||||
(fixnum gmsm2 pmark sign))
|
(fixnum gmsm2 pmark sign))
|
||||||
(when (oddp gmsm2)
|
(when (oddp gmsm2)
|
||||||
(push (term sign (logxor gmsm pmark)) rslt)
|
(push (term sign (logxor gmsm pmark)) rslt)
|
||||||
(setf sign (- sign))))))))
|
(setf sign (- sign))))))))
|
||||||
|
|
||||||
(DEFUN SOFT-DELTA-BNDR (dmns gmsm)
|
(DEFUN SOFT-DELTA-BNDR (dmns gmsm)
|
||||||
(declare
|
(declare
|
||||||
(fixnum dmns)
|
(fixnum dmns)
|
||||||
(type soft-dlop gmsm))
|
(type soft-dlop gmsm))
|
||||||
(make-cmbn
|
(make-cmbn
|
||||||
:degr (1- dmns)
|
:degr (1- dmns)
|
||||||
:list (mapcar #'(lambda (term)
|
:list (mapcar #'(lambda (term)
|
||||||
(with-term (cffc gmsm) term
|
(with-term (cffc gmsm) term
|
||||||
(term cffc (d gmsm))))
|
(term cffc (d gmsm))))
|
||||||
(cmbn-list (delta-bndr dmns (cdr gmsm))))))
|
(cmbn-list (delta-bndr dmns (cdr gmsm))))))
|
||||||
|
|
||||||
#|
|
#|
|
||||||
()
|
()
|
||||||
@ -92,37 +89,38 @@
|
|||||||
|
|
||||||
|
|
||||||
(DEFUN DELTA-DGNL (dmns gmsm)
|
(DEFUN DELTA-DGNL (dmns gmsm)
|
||||||
(declare (fixnum dmns gmsm))
|
(declare (fixnum dmns gmsm))
|
||||||
(the cmbn
|
(the cmbn
|
||||||
(make-cmbn
|
(make-cmbn
|
||||||
:degr dmns
|
:degr dmns
|
||||||
:list (do ((rslt +empty-list+)
|
:list (do ((rslt +empty-list+)
|
||||||
(ldegr dmns)
|
(ldegr dmns)
|
||||||
(indx (1- (integer-length gmsm)) (1- indx)))
|
(indx (1- (integer-length gmsm)) (1- indx)))
|
||||||
((minusp indx))
|
((minusp indx))
|
||||||
(declare
|
(declare
|
||||||
(list rslt)
|
(list rslt)
|
||||||
(fixnum indx))
|
(fixnum indx))
|
||||||
(when (logbitp indx gmsm)
|
(when (logbitp indx gmsm)
|
||||||
(push (term 1 (tnpr
|
(push (term 1 (tnpr
|
||||||
ldegr (logand gmsm (mask (1+ indx)))
|
ldegr (logand gmsm (mask (1+ indx)))
|
||||||
(- dmns ldegr) (logandc2 gmsm (mask indx))))
|
(- dmns ldegr) (logandc2 gmsm (mask indx))))
|
||||||
rslt)
|
rslt)
|
||||||
(when (minusp (decf ldegr))
|
(when (minusp (decf ldegr))
|
||||||
(return rslt)))))))
|
(return rslt)))))))
|
||||||
|
|
||||||
(DEFUN SOFT-DELTA-DGNL (dmns gmsm)
|
(DEFUN SOFT-DELTA-DGNL (dmns gmsm)
|
||||||
(declare
|
(declare
|
||||||
(fixnum dmns)
|
(fixnum dmns)
|
||||||
(type soft-dlop gmsm))
|
(type soft-dlop gmsm))
|
||||||
(make-cmbn :degr dmns
|
(make-cmbn :degr dmns
|
||||||
:list (mapcar
|
:list (mapcar
|
||||||
#'(lambda (term)
|
#'(lambda (term)
|
||||||
(with-term (cffc tnpr) term
|
(with-term (cffc tnpr) term
|
||||||
(with-tnpr (degr1 gmsm1 degr2 gmsm2) tnpr
|
(with-tnpr (degr1 gmsm1 degr2 gmsm2) tnpr
|
||||||
(term cffc
|
(term cffc
|
||||||
(tnpr degr1 (d gmsm1) degr2 (d gmsm2))))))
|
(tnpr degr1 (d gmsm1)
|
||||||
(cmbn-list (delta-dgnl dmns (cdr gmsm))))))
|
degr2 (d gmsm2))))))
|
||||||
|
(cmbn-list (delta-dgnl dmns (cdr gmsm))))))
|
||||||
|
|
||||||
#|
|
#|
|
||||||
()
|
()
|
||||||
@ -133,17 +131,17 @@
|
|||||||
|#
|
|#
|
||||||
|
|
||||||
(DEFUN DELTA-INFINITY ()
|
(DEFUN DELTA-INFINITY ()
|
||||||
(the simplicial-set
|
(the simplicial-set
|
||||||
(build-smst
|
(build-smst
|
||||||
:cmpr #'f-cmpr
|
:cmpr #'f-cmpr
|
||||||
:basis :locally-effective
|
:basis :locally-effective
|
||||||
:bspn 1
|
:bspn 1
|
||||||
:face #'delta-face
|
:face #'delta-face
|
||||||
:intr-dgnl #'delta-dgnl
|
:intr-dgnl #'delta-dgnl
|
||||||
:dgnl-strt :gnrt
|
:dgnl-strt :gnrt
|
||||||
:intr-bndr #'delta-bndr
|
:intr-bndr #'delta-bndr
|
||||||
:bndr-strt :gnrt
|
:bndr-strt :gnrt
|
||||||
:orgn '(delta-infinity))))
|
:orgn '(delta-infinity))))
|
||||||
|
|
||||||
#|
|
#|
|
||||||
()
|
()
|
||||||
@ -158,15 +156,15 @@
|
|||||||
|#
|
|#
|
||||||
|
|
||||||
(DEFUN SOFT-DELTA-INFINITY ()
|
(DEFUN SOFT-DELTA-INFINITY ()
|
||||||
(the simplicial-set
|
(the simplicial-set
|
||||||
(build-smst
|
(build-smst
|
||||||
:cmpr #'soft-delta-cmpr
|
:cmpr #'soft-delta-cmpr
|
||||||
:basis :locally-effective
|
:basis :locally-effective
|
||||||
:bspn (d 1)
|
:bspn (d 1)
|
||||||
:face #'soft-delta-face
|
:face #'soft-delta-face
|
||||||
:intr-dgnl #'soft-delta-dgnl :dgnl-strt :gnrt
|
:intr-dgnl #'soft-delta-dgnl :dgnl-strt :gnrt
|
||||||
:intr-bndr #'soft-delta-bndr :bndr-strt :gnrt
|
:intr-bndr #'soft-delta-bndr :bndr-strt :gnrt
|
||||||
:orgn '(soft-delta-infinity))))
|
:orgn '(soft-delta-infinity))))
|
||||||
|
|
||||||
#|
|
#|
|
||||||
()
|
()
|
||||||
@ -179,36 +177,36 @@
|
|||||||
|#
|
|#
|
||||||
|
|
||||||
(DEFUN DELTA-N-BASIS (n)
|
(DEFUN DELTA-N-BASIS (n)
|
||||||
(declare (fixnum n))
|
(declare (fixnum n))
|
||||||
(flet ((rslt (dmns)
|
(flet ((rslt (dmns)
|
||||||
(declare (fixnum dmns))
|
(declare (fixnum dmns))
|
||||||
(when (> dmns n)
|
(when (> dmns n)
|
||||||
(return-from rslt +empty-list+))
|
(return-from rslt +empty-list+))
|
||||||
(setf dmns (1+ dmns))
|
(setf dmns (1+ dmns))
|
||||||
(do ((rslt +empty-list+)
|
(do ((rslt +empty-list+)
|
||||||
(count (binomial-n-p (1+ n) dmns))
|
(count (binomial-n-p (1+ n) dmns))
|
||||||
(gmsm (mask (1+ n)) (1- gmsm)))
|
(gmsm (mask (1+ n)) (1- gmsm)))
|
||||||
((zerop count) rslt)
|
((zerop count) rslt)
|
||||||
(when (= (logcount gmsm) dmns)
|
(when (= (logcount gmsm) dmns)
|
||||||
(push gmsm rslt)
|
(push gmsm rslt)
|
||||||
(decf count)))))
|
(decf count)))))
|
||||||
(the basis #'rslt)))
|
(the basis #'rslt)))
|
||||||
|
|
||||||
(DEFUN SOFT-DELTA-N-BASIS (n)
|
(DEFUN SOFT-DELTA-N-BASIS (n)
|
||||||
(declare (fixnum n))
|
(declare (fixnum n))
|
||||||
(flet ((rslt (dmns)
|
(flet ((rslt (dmns)
|
||||||
(when (> dmns n)
|
(when (> dmns n)
|
||||||
(return-from rslt +empty-list+))
|
(return-from rslt +empty-list+))
|
||||||
(setf dmns (1+ dmns))
|
(setf dmns (1+ dmns))
|
||||||
(do ((rslt +empty-list+)
|
(do ((rslt +empty-list+)
|
||||||
(count (binomial-n-p (1+ n) dmns))
|
(count (binomial-n-p (1+ n) dmns))
|
||||||
(gmsm (mask (1+ n)) (1- gmsm)))
|
(gmsm (mask (1+ n)) (1- gmsm)))
|
||||||
((zerop count) rslt)
|
((zerop count) rslt)
|
||||||
(when (= (logcount gmsm) dmns)
|
(when (= (logcount gmsm) dmns)
|
||||||
(push (d gmsm) rslt)
|
(push (d gmsm) rslt)
|
||||||
(decf count)))))
|
(decf count)))))
|
||||||
(the basis #'rslt)))
|
(the basis #'rslt)))
|
||||||
|
|
||||||
|
|
||||||
#|
|
#|
|
||||||
()
|
()
|
||||||
@ -221,18 +219,18 @@
|
|||||||
|#
|
|#
|
||||||
|
|
||||||
(DEFUN DELTA (dmns)
|
(DEFUN DELTA (dmns)
|
||||||
(declare (fixnum dmns))
|
(declare (fixnum dmns))
|
||||||
(the simplicial-set
|
(the simplicial-set
|
||||||
(build-smst
|
(build-smst
|
||||||
:cmpr #'f-cmpr
|
:cmpr #'f-cmpr
|
||||||
:basis (delta-n-basis dmns)
|
:basis (delta-n-basis dmns)
|
||||||
:bspn 1
|
:bspn 1
|
||||||
:face #'delta-face
|
:face #'delta-face
|
||||||
:intr-dgnl #'delta-dgnl
|
:intr-dgnl #'delta-dgnl
|
||||||
:dgnl-strt :gnrt
|
:dgnl-strt :gnrt
|
||||||
:intr-bndr #'delta-bndr
|
:intr-bndr #'delta-bndr
|
||||||
:bndr-strt :gnrt
|
:bndr-strt :gnrt
|
||||||
:orgn `(delta ,dmns))))
|
:orgn `(delta ,dmns))))
|
||||||
|
|
||||||
#|
|
#|
|
||||||
()
|
()
|
||||||
@ -251,17 +249,17 @@
|
|||||||
|#
|
|#
|
||||||
|
|
||||||
(DEFUN SOFT-DELTA (dmns)
|
(DEFUN SOFT-DELTA (dmns)
|
||||||
(declare (fixnum dmns))
|
(declare (fixnum dmns))
|
||||||
(the simplicial-set
|
(the simplicial-set
|
||||||
(build-smst
|
(build-smst
|
||||||
:cmpr #'soft-delta-cmpr
|
:cmpr #'soft-delta-cmpr
|
||||||
:basis (soft-delta-n-basis dmns)
|
:basis (soft-delta-n-basis dmns)
|
||||||
:bspn (d 1)
|
:bspn (d 1)
|
||||||
:face #'soft-delta-face
|
:face #'soft-delta-face
|
||||||
:intr-dgnl #'soft-delta-dgnl :dgnl-strt :gnrt
|
:intr-dgnl #'soft-delta-dgnl :dgnl-strt :gnrt
|
||||||
:intr-bndr #'soft-delta-bndr :bndr-strt :gnrt
|
:intr-bndr #'soft-delta-bndr :bndr-strt :gnrt
|
||||||
:orgn `(soft-delta ,dmns))))
|
:orgn `(soft-delta ,dmns))))
|
||||||
|
|
||||||
#|
|
#|
|
||||||
()
|
()
|
||||||
(cat-init)
|
(cat-init)
|
||||||
@ -274,144 +272,145 @@
|
|||||||
|#
|
|#
|
||||||
|
|
||||||
#| For comparison with EAT.
|
#| For comparison with EAT.
|
||||||
In
|
In
|
||||||
(setf delta (delta-infinity))
|
(setf delta (delta-infinity))
|
||||||
(setf d (bndr delta))
|
(setf d (bndr delta))
|
||||||
(setf s14 (mask 15))
|
(setf s14 (mask 15))
|
||||||
(cmbn-? d (gnrt-? d 14 s14))
|
(cmbn-? d (gnrt-? d 14 s14))
|
||||||
(defun t1 (n)
|
(defun t1 (n)
|
||||||
(time (dotimes (i n) (cmbn-? d (gnrt-? d 14 s14)))))
|
(time (dotimes (i n) (cmbn-? d (gnrt-? d 14 s14)))))
|
||||||
(compile 't1)
|
(compile 't1)
|
||||||
(t1 500)
|
(t1 500)
|
||||||
(setf +too-much-time+ -1)
|
(setf +too-much-time+ -1)
|
||||||
(t1 500)
|
(t1 500)
|
||||||
|#
|
|#
|
||||||
#|
|
#|
|
||||||
In EAT:
|
In EAT:
|
||||||
(setf delta *delta*)
|
(setf delta *delta*)
|
||||||
(setf d (cc-d (ss-cc delta)))
|
(setf d (cc-d (ss-cc delta)))
|
||||||
(setf s14 (<a-b> 0 14))
|
(setf s14 (<a-b> 0 14))
|
||||||
(??? d (? d 14 s14))
|
(??? d (? d 14 s14))
|
||||||
(defun t1 (n)
|
(defun t1 (n)
|
||||||
(time (dotimes (i n) (??? d (? d 14 s14)))))
|
(time (dotimes (i n) (??? d (? d 14 s14)))))
|
||||||
(compile 't1)
|
(compile 't1)
|
||||||
(t1 500)
|
(t1 500)
|
||||||
|#
|
|#
|
||||||
|
|
||||||
(DEFUN DELTAB-CMPR (gmsm1 gmsm2)
|
(DEFUN DELTAB-CMPR (gmsm1 gmsm2)
|
||||||
(declare (fixnum gmsm1 gmsm2))
|
(declare (fixnum gmsm1 gmsm2))
|
||||||
(if (= 1 (logcount gmsm1))
|
(if (= 1 (logcount gmsm1))
|
||||||
:equal
|
:equal
|
||||||
(f-cmpr gmsm1 gmsm2)))
|
(f-cmpr gmsm1 gmsm2)))
|
||||||
|
|
||||||
(DEFUN DELTAB-BNDR (dmns gmsm)
|
(DEFUN DELTAB-BNDR (dmns gmsm)
|
||||||
(declare (fixnum dmns gmsm))
|
(declare (fixnum dmns gmsm))
|
||||||
(the cmbn
|
(the cmbn
|
||||||
(if (< dmns 2)
|
(if (< dmns 2)
|
||||||
(zero-cmbn (1- dmns))
|
(zero-cmbn (1- dmns))
|
||||||
(make-cmbn
|
(make-cmbn
|
||||||
:degr (1- dmns)
|
:degr (1- dmns)
|
||||||
:list (do ((rslt +empty-list+)
|
:list (do ((rslt +empty-list+)
|
||||||
(gmsm2 gmsm (ash gmsm2 -1))
|
(gmsm2 gmsm (ash gmsm2 -1))
|
||||||
(pmark 1 (ash pmark +1))
|
(pmark 1 (ash pmark +1))
|
||||||
(sign 1))
|
(sign 1))
|
||||||
((zerop gmsm2) rslt)
|
((zerop gmsm2) rslt)
|
||||||
(declare
|
(declare
|
||||||
(list rslt)
|
(list rslt)
|
||||||
(fixnum gmsm2 pmark sign))
|
(fixnum gmsm2 pmark sign))
|
||||||
(when (oddp gmsm2)
|
(when (oddp gmsm2)
|
||||||
(push (term sign (logxor gmsm pmark)) rslt)
|
(push (term sign (logxor gmsm pmark)) rslt)
|
||||||
(setf sign (- sign))))))))
|
(setf sign (- sign))))))))
|
||||||
|
|
||||||
(DEFUN DELTAB2-FACE (indx dmns gmsm)
|
(DEFUN DELTAB2-FACE (indx dmns gmsm)
|
||||||
(declare
|
(declare
|
||||||
(fixnum indx dmns gmsm))
|
(fixnum indx dmns gmsm))
|
||||||
(the absm
|
(the absm
|
||||||
(progn
|
(progn
|
||||||
(when (= 2 dmns)
|
(when (= 2 dmns)
|
||||||
(return-from deltab2-face (absm 1 1)))
|
(return-from deltab2-face (absm 1 1)))
|
||||||
(do ((pmark 1 (ash pmark 1))
|
(do ((pmark 1 (ash pmark 1))
|
||||||
(bmark indx)
|
(bmark indx)
|
||||||
(gmsm2 gmsm (ash gmsm2 -1)))
|
(gmsm2 gmsm (ash gmsm2 -1)))
|
||||||
(nil)
|
(nil)
|
||||||
(declare (fixnum pmark bmark gmsm2))
|
(declare (fixnum pmark bmark gmsm2))
|
||||||
(when (oddp gmsm2)
|
(when (oddp gmsm2)
|
||||||
(when (minusp (decf bmark))
|
(when (minusp (decf bmark))
|
||||||
(return-from deltab2-face (absm 0 (logxor gmsm pmark)))))))))
|
(return-from deltab2-face (absm 0 (logxor gmsm pmark)))))))))
|
||||||
|
|
||||||
(DEFUN DELTAB2-DGNL (dmns gmsm)
|
(DEFUN DELTAB2-DGNL (dmns gmsm)
|
||||||
(declare (fixnum dmns gmsm))
|
(declare (fixnum dmns gmsm))
|
||||||
(the cmbn
|
(the cmbn
|
||||||
(make-cmbn
|
(make-cmbn
|
||||||
:degr dmns
|
:degr dmns
|
||||||
:list (if (zerop dmns)
|
:list (if (zerop dmns)
|
||||||
(list (term 1 (tnpr 0 gmsm 0 gmsm)))
|
(list (term 1 (tnpr 0 gmsm 0 gmsm)))
|
||||||
(do ((rslt +empty-list+)
|
(do ((rslt +empty-list+)
|
||||||
(ldegr dmns)
|
(ldegr dmns)
|
||||||
(indx (1- (integer-length gmsm)) (1- indx)))
|
(indx (1- (integer-length gmsm)) (1- indx)))
|
||||||
((minusp indx))
|
((minusp indx))
|
||||||
(declare (list rslt) (fixnum indx))
|
(declare (list rslt) (fixnum indx))
|
||||||
(when (logbitp indx gmsm)
|
(when (logbitp indx gmsm)
|
||||||
(push (term 1 (tnpr
|
(push (term 1 (tnpr
|
||||||
ldegr (logand gmsm (mask (1+ indx)))
|
ldegr (logand gmsm (mask (1+ indx)))
|
||||||
(- dmns ldegr) (logandc2 gmsm (mask indx))))
|
(- dmns ldegr)
|
||||||
rslt)
|
(logandc2 gmsm (mask indx))))
|
||||||
(when (minusp (decf ldegr))
|
rslt)
|
||||||
(setf rslt (delete 1 rslt :key #'caaddr))
|
(when (minusp (decf ldegr))
|
||||||
(setf (gnrt1 (gnrt (first rslt)))
|
(setf rslt (delete 1 rslt :key #'caaddr))
|
||||||
(setf (gnrt2 (gnrt (car (last rslt))))
|
(setf (gnrt1 (gnrt (first rslt)))
|
||||||
1))
|
(setf (gnrt2 (gnrt (car (last rslt))))
|
||||||
(return (delete 1 rslt :key #'cadddr)))))))))
|
1))
|
||||||
|
(return (delete 1 rslt :key #'cadddr)))))))))
|
||||||
|
|
||||||
#|
|
#|
|
||||||
()
|
()
|
||||||
(dotimes (i 7)
|
(dotimes (i 7)
|
||||||
(print (deltab2-dgnl i (mask (1+ i)))))
|
(print (deltab2-dgnl i (mask (1+ i)))))
|
||||||
|#
|
|#
|
||||||
|
|
||||||
|
|
||||||
(DEFUN DELTAB2-BNDR (dmns gmsm)
|
(DEFUN DELTAB2-BNDR (dmns gmsm)
|
||||||
(declare (fixnum dmns gmsm))
|
(declare (fixnum dmns gmsm))
|
||||||
(the cmbn
|
(the cmbn
|
||||||
(if (< dmns 3)
|
(if (< dmns 3)
|
||||||
(zero-cmbn (1- dmns))
|
(zero-cmbn (1- dmns))
|
||||||
(make-cmbn
|
(make-cmbn
|
||||||
:degr (1- dmns)
|
:degr (1- dmns)
|
||||||
:list (do ((rslt +empty-list+)
|
:list (do ((rslt +empty-list+)
|
||||||
(gmsm2 gmsm (ash gmsm2 -1))
|
(gmsm2 gmsm (ash gmsm2 -1))
|
||||||
(pmark 1 (ash pmark +1))
|
(pmark 1 (ash pmark +1))
|
||||||
(sign 1))
|
(sign 1))
|
||||||
((zerop gmsm2) rslt)
|
((zerop gmsm2) rslt)
|
||||||
(declare
|
(declare
|
||||||
(list rslt)
|
(list rslt)
|
||||||
(fixnum gmsm2 pmark sign))
|
(fixnum gmsm2 pmark sign))
|
||||||
(when (oddp gmsm2)
|
(when (oddp gmsm2)
|
||||||
(push (term sign (logxor gmsm pmark)) rslt)
|
(push (term sign (logxor gmsm pmark)) rslt)
|
||||||
(setf sign (- sign))))))))
|
(setf sign (- sign))))))))
|
||||||
|
|
||||||
#|
|
#|
|
||||||
(deltab-bndr 1 5)
|
(deltab-bndr 1 5)
|
||||||
(deltab-bndr 3 15)
|
(deltab-bndr 3 15)
|
||||||
|#
|
|#
|
||||||
|
|
||||||
(DEFUN DELTAB ()
|
(DEFUN DELTAB ()
|
||||||
(the simplicial-set
|
(the simplicial-set
|
||||||
(build-smst
|
(build-smst
|
||||||
:cmpr #'deltab-cmpr
|
:cmpr #'deltab-cmpr
|
||||||
:basis :locally-effective
|
:basis :locally-effective
|
||||||
:bspn 1
|
:bspn 1
|
||||||
:face #'delta-face
|
:face #'delta-face
|
||||||
:intr-dgnl #'delta-dgnl
|
:intr-dgnl #'delta-dgnl
|
||||||
:dgnl-strt :gnrt
|
:dgnl-strt :gnrt
|
||||||
:orgn '(deltab))))
|
:orgn '(deltab))))
|
||||||
|
|
||||||
(DEFUN DELTAB2 ()
|
(DEFUN DELTAB2 ()
|
||||||
(the simplicial-set
|
(the simplicial-set
|
||||||
(build-smst
|
(build-smst
|
||||||
:cmpr #'f-cmpr
|
:cmpr #'f-cmpr
|
||||||
:basis :locally-effective
|
:basis :locally-effective
|
||||||
:bspn 1
|
:bspn 1
|
||||||
:face #'deltab2-face
|
:face #'deltab2-face
|
||||||
:intr-dgnl #'deltab2-dgnl
|
:intr-dgnl #'deltab2-dgnl
|
||||||
:dgnl-strt :gnrt
|
:dgnl-strt :gnrt
|
||||||
:orgn '(deltab2))))
|
:orgn '(deltab2))))
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user