;;; DELTA DELTA DELTA DELTA DELTA DELTA DELTA DELTA DELTA
;;; DELTA DELTA DELTA DELTA DELTA DELTA DELTA DELTA DELTA
;;; DELTA DELTA DELTA DELTA DELTA DELTA DELTA DELTA DELTA
(IN-PACKAGE "COMMON-LISP-USER")
(PROVIDE "delta")
(DEFMETHOD PRINT-KEYCONS ((car (eql :delt)) cdr stream)
(format stream "~A" (hyphenize-list (dlop-int-ext cdr)))
(cons car cdr))
(DEFUN SOFT-DELTA-CMPR (gmsm1 gmsm2)
(f-cmpr (cdr gmsm1) (cdr gmsm2)))
#|
(soft-delta-cmpr (d 12) (d 23))
|#
(DEFUN DELTA-FACE (indx dmns gmsm)
(declare
(fixnum indx gmsm)
(ignore dmns))
(the absm
(do ((pmark 1 (ash pmark 1))
(bmark indx)
(gmsm2 gmsm (ash gmsm2 -1)))
(nil)
(declare (fixnum pmark bmark gmsm2))
(when (oddp gmsm2)
(when (minusp (decf bmark))
(return-from delta-face (absm 0 (logxor gmsm pmark))))))))
(DEFUN SOFT-DELTA-FACE (indx dmns gmsm)
(declare
(fixnum indx dmns)
(type soft-dlop gmsm))
(absm 0 (d (gmsm (delta-face indx dmns (cdr gmsm))))))
#|
(dotimes (i 4)
(print (dlop-int-ext (gmsm (delta-face i 3 (dlop-ext-int '(0 1 2 3)))))))
(dotimes (i 4)
(print (dlop-int-ext (gmsm (delta-face i 3 (dlop-ext-int '(0 2 4 6))))))))
(dotimes (i 4)
(print (soft-delta-face i 3 (d (mask 4)))))
(dotimes (i 4)
(print (soft-delta-face i 3 (d (dlop-ext-int '(0 2 4 6))))))
|#
(DEFUN DELTA-BNDR (dmns gmsm)
(declare (fixnum dmns gmsm))
(the cmbn
(if (zerop dmns)
+zero-negative-cmbn+
(make-cmbn
:degr (1- dmns)
:list (do ((rslt +empty-list+)
(gmsm2 gmsm (ash gmsm2 -1))
(pmark 1 (ash pmark +1))
(sign 1))
((zerop gmsm2) rslt)
(declare
(list rslt)
(fixnum gmsm2 pmark sign))
(when (oddp gmsm2)
(push (term sign (logxor gmsm pmark)) rslt)
(setf sign (- sign))))))))
(DEFUN SOFT-DELTA-BNDR (dmns gmsm)
(declare
(fixnum dmns)
(type soft-dlop gmsm))
(make-cmbn
:degr (1- dmns)
:list (mapcar #'(lambda (term)
(with-term (cffc gmsm) term
(term cffc (d gmsm))))
(cmbn-list (delta-bndr dmns (cdr gmsm))))))
#|
(delta-bndr 0 4)
(delta-bndr 1 3)
(delta-bndr 1 5)
(delta-bndr 1 10)
(delta-bndr 5 63)
(soft-delta-bndr 5 (d (mask 6)))
|#
(DEFUN DELTA-DGNL (dmns gmsm)
(declare (fixnum dmns gmsm))
(the cmbn
(make-cmbn
:degr dmns
:list (do ((rslt +empty-list+)
(ldegr dmns)
(indx (1- (integer-length gmsm)) (1- indx)))
((minusp indx))
(declare
(list rslt)
(fixnum indx))
(when (logbitp indx gmsm)
(push (term 1 (tnpr
ldegr (logand gmsm (mask (1+ indx)))
(- dmns ldegr) (logandc2 gmsm (mask indx))))
rslt)
(when (minusp (decf ldegr))
(return rslt)))))))
(DEFUN SOFT-DELTA-DGNL (dmns gmsm)
(declare
(fixnum dmns)
(type soft-dlop gmsm))
(make-cmbn :degr dmns
:list (mapcar
#'(lambda (term)
(with-term (cffc tnpr) term
(with-tnpr (degr1 gmsm1 degr2 gmsm2) tnpr
(term cffc
(tnpr degr1 (d gmsm1) degr2 (d gmsm2))))))
(cmbn-list (delta-dgnl dmns (cdr gmsm))))))
#|
(delta-dgnl 3 15)
(delta-dgnl 3 170)
(soft-delta-dgnl 3 (d (dlop-ext-int '(1 3 5 7))))
(delta-dgnl 0 64)
|#
(DEFUN DELTA-INFINITY ()
(the simplicial-set
(build-smst
:cmpr #'f-cmpr
:basis :locally-effective
:bspn 1
:face #'delta-face
:intr-dgnl #'delta-dgnl
:dgnl-strt :gnrt
:intr-bndr #'delta-bndr
:bndr-strt :gnrt
:orgn '(delta-infinity))))
#|
(cmpr (delta-infinity) 2 4)
(cmpr (delta-infinity) 4 4)
(cmpr (delta-infinity) 8 4)
(basis (delta-infinity) 1) ;;; => error
(face (delta-infinity) 1 2 21)
(cprd (delta-infinity) 3 15)
(dgnl (delta-infinity) 3 15)
(? (delta-infinity) 2 21))
|#
(DEFUN SOFT-DELTA-INFINITY ()
(the simplicial-set
(build-smst
:cmpr #'soft-delta-cmpr
:basis :locally-effective
:bspn (d 1)
:face #'soft-delta-face
:intr-dgnl #'soft-delta-dgnl :dgnl-strt :gnrt
:intr-bndr #'soft-delta-bndr :bndr-strt :gnrt
:orgn '(soft-delta-infinity))))
#|
(cat-init)
(cmpr (soft-delta-infinity) (d 2) (d 4))
(face (soft-delta-infinity) 1 2 (d (dlop-ext-int '(1 3 5))))
(cprd (soft-delta-infinity) 3 (d 15))
(dgnl (soft-delta-infinity) 3 (d 15))
(? (soft-delta-infinity) 2 (d (dlop-ext-int '(0 2 4))))
|#
(DEFUN DELTA-N-BASIS (n)
(declare (fixnum n dmns))
(flet ((rslt (dmns)
(when (> dmns n)
(return-from rslt +empty-list+))
(setf dmns (1+ dmns))
(do ((rslt +empty-list+)
(count (binomial-n-p (1+ n) dmns))
(gmsm (mask (1+ n)) (1- gmsm)))
((zerop count) rslt)
(when (= (logcount gmsm) dmns)
(push gmsm rslt)
(decf count)))))
(the basis #'rslt)))
(DEFUN SOFT-DELTA-N-BASIS (n)
(declare (fixnum n))
(flet ((rslt (dmns)
(when (> dmns n)
(return-from rslt +empty-list+))
(setf dmns (1+ dmns))
(do ((rslt +empty-list+)
(count (binomial-n-p (1+ n) dmns))
(gmsm (mask (1+ n)) (1- gmsm)))
((zerop count) rslt)
(when (= (logcount gmsm) dmns)
(push (d gmsm) rslt)
(decf count)))))
(the basis #'rslt)))
#|
(setf basis (delta-n-basis 3))
(setf soft-basis (soft-delta-n-basis 3))
(dotimes (i 5)
(print (funcall basis i)))
(dotimes (i 5)
(print (funcall soft-basis i)))))
|#
(DEFUN DELTA (dmns)
(declare (fixnum dmns))
(the simplicial-set
(build-smst
:cmpr #'f-cmpr
:basis (delta-n-basis dmns)
:bspn 1
:face #'delta-face
:intr-dgnl #'delta-dgnl
:dgnl-strt :gnrt
:intr-bndr #'delta-bndr
:bndr-strt :gnrt
:orgn `(delta ,dmns))))
#|
(cat-init)
(setf d3 (delta 3))
(cmpr d3 2 4)
(cmpr d3 4 4)
(cmpr d3 8 4)
(basis d3 1)
(dgnl d3 3 15)
(face d3 1 2 21)
(? d3 2 13)
(setf d (delta-infinity))
(basis d)
(setf d (delta-infinity)))
|#
(DEFUN SOFT-DELTA (dmns)
(declare (fixnum dmns))
(the simplicial-set
(build-smst
:cmpr #'soft-delta-cmpr
:basis (soft-delta-n-basis dmns)
:bspn (d 1)
:face #'soft-delta-face
:intr-dgnl #'soft-delta-dgnl :dgnl-strt :gnrt
:intr-bndr #'soft-delta-bndr :bndr-strt :gnrt
:orgn `(soft-delta ,dmns))))
#|
(cat-init)
(setf d3 (soft-delta 3))
(cmpr d3 (d 2) (d 4))
(basis d3 1)
(dgnl d3 3 (d 15))
(face d3 1 2 (d 21))
(? d3 2 (d 13))
|#
#| For comparison with EAT.
In
(setf delta (delta-infinity))
(setf d (bndr delta))
(setf s14 (mask 15))
(cmbn-? d (gnrt-? d 14 s14))
(defun t1 (n)
(time (dotimes (i n) (cmbn-? d (gnrt-? d 14 s14)))))
(compile 't1)
(t1 500)
(setf +too-much-time+ -1)
(t1 500)
|#
#|
In EAT:
(setf delta *delta*)
(setf d (cc-d (ss-cc delta)))
(setf s14 ( 0 14))
(??? d (? d 14 s14))
(defun t1 (n)
(time (dotimes (i n) (??? d (? d 14 s14)))))
(compile 't1)
(t1 500)
|#
(DEFUN DELTAB-CMPR (gmsm1 gmsm2)
(declare (fixnum gmsm1 gmsm2))
(if (= 1 (logcount gmsm1))
:equal
(f-cmpr gmsm1 gmsm2)))
(DEFUN DELTAB-BNDR (dmns gmsm)
(declare (fixnum dmns gmsm))
(the cmbn
(if (< dmns 2)
(zero-cmbn (1- dmns))
(make-cmbn
:degr (1- dmns)
:list (do ((rslt +empty-list+)
(gmsm2 gmsm (ash gmsm2 -1))
(pmark 1 (ash pmark +1))
(sign 1))
((zerop gmsm2) rslt)
(declare
(list rslt)
(fixnum gmsm2 pmark sign))
(when (oddp gmsm2)
(push (term sign (logxor gmsm pmark)) rslt)
(setf sign (- sign))))))))
(DEFUN DELTAB2-FACE (indx dmns gmsm)
(declare
(fixnum indx dmns gmsm))
(the absm
(progn
(when (= 2 dmns)
(return-from deltab2-face (absm 1 1)))
(do ((pmark 1 (ash pmark 1))
(bmark indx)
(gmsm2 gmsm (ash gmsm2 -1)))
(nil)
(declare (fixnum pmark bmark gmsm2))
(when (oddp gmsm2)
(when (minusp (decf bmark))
(return-from deltab2-face (absm 0 (logxor gmsm pmark)))))))))
(DEFUN DELTAB2-DGNL (dmns gmsm)
(declare (fixnum dmns gmsm))
(the cmbn
(make-cmbn
:degr dmns
:list (if (zerop dmns)
(list (term 1 (tnpr 0 gmsm 0 gmsm)))
(do ((rslt +empty-list+)
(ldegr dmns)
(indx (1- (integer-length gmsm)) (1- indx)))
((minusp indx))
(declare
(list rslt)
(fixnum indx))
(when (logbitp indx gmsm)
(push (term 1 (tnpr
ldegr (logand gmsm (mask (1+ indx)))
(- dmns ldegr) (logandc2 gmsm (mask indx))))
rslt)
(when (minusp (decf ldegr))
(setf rslt (delete 1 rslt :key #'caaddr))
(setf (gnrt1 (gnrt (first rslt)))
(setf (gnrt2 (gnrt (car (last rslt))))
1))
(return (delete 1 rslt :key #'cadddr)))))))))
#|
(dotimes (i 7)
(print (deltab2-dgnl i (mask (1+ i)))))
|#
(DEFUN DELTAB2-BNDR (dmns gmsm)
(declare (fixnum dmns gmsm))
(the cmbn
(if (< dmns 3)
(zero-cmbn (1- dmns))
(make-cmbn
:degr (1- dmns)
:list (do ((rslt +empty-list+)
(gmsm2 gmsm (ash gmsm2 -1))
(pmark 1 (ash pmark +1))
(sign 1))
((zerop gmsm2) rslt)
(declare
(list rslt)
(fixnum gmsm2 pmark sign))
(when (oddp gmsm2)
(push (term sign (logxor gmsm pmark)) rslt)
(setf sign (- sign))))))))
#|
(deltab-bndr 1 5)
(deltab-bndr 3 15)
|#
(DEFUN DELTAB ()
(the simplicial-set
(build-smst
:cmpr #'deltab-cmpr
:basis :locally-effective
:bspn 1
:face #'delta-face
:intr-dgnl #'delta-dgnl
:dgnl-strt :gnrt
:orgn '(deltab))))
(DEFUN DELTAB2 ()
(the simplicial-set
(build-smst
:cmpr #'f-cmpr
:basis :locally-effective
:bspn 1
:face #'deltab2-face
:intr-dgnl #'deltab2-dgnl
:dgnl-strt :gnrt
:orgn '(deltab2))))