mmarco/kenzo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fixed error in SOFT-DELTA-CMPR

Browse Source 
Must be L-CMPR instead of F-CMPR, since CDR returns a list.
This commit is contained in:
gheber 2015-07-08 06:42:31 -05:00
parent 911a74de68
commit b82a5e6884
1 changed files with 241 additions and 242 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

475
src/delta.lisp
View File

@ -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,35 +177,35 @@
|# |#
(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,16 +249,16 @@
|# |#
(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))))
#| #|
() ()
@ -274,94 +272,95 @@
|# |#
#| 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)))))))))
#| #|
() ()
@ -371,47 +370,47 @@
(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))))