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

"Auto-correct" the argument order of R-PROJ-SPACE.

Browse Source
This commit is contained in:
Gerd Heber 2016-04-02 04:50:02 -04:00
parent 0dd09f23c2
commit 841b904e7e
1 changed files with 42 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
src/special-smsts.lisp
View File

@ -468,23 +468,48 @@
(zero-cmbn (1- degr))))))) (zero-cmbn (1- degr)))))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
(DEFUN R-PROJ-SPACE (&optional (l :infinity) (k 1))
(declare (fixnum k) (type (or fixnum (eql :infinity)))) (DEFUN R-PROJ-SPACE (&rest args)
(assert (labels ((infinityp (x)
(and (typep k 'fixnum) (and (symbolp x)
(plusp k) (eql x :infinity)))
(or (eq l :infinity) (dimp (x)
(and (typep l 'fixnum) (or (infinityp x)
(<= k l))))) (and (integerp x)
(the simplicial-set (< x most-positive-fixnum)
(build-smst (plusp x)))))
:cmpr #'R-proj-space-cmpr (let ((l :infinity)
:basis (R-proj-space-basis k l) (k 1))
:bspn 0 ;; accept zero, one or two arguments
:face (R-proj-space-face k) ;; must be positive FIXNUM or :INFINITY
:intr-bndr (R-proj-space-intr-bndr k) ;; if one is FIXNUM, assign K
:bndr-strt :cmbn ;; if both are FIXNUM, sort and assign such that (<= k l)
:orgn `(R-proj-space ,k ,l)))) (ecase (length args)
(0 t)
(1 (let ((a (first args)))
(when (dimp a)
(unless (infinityp a)
(setq k a)))))
(2 (let ((a (first args))
(b (first (last args))))
(when (and (and (dimp a)
(dimp b))
(or (not (infinityp a))
(not (infinityp b))))
(cond
((infinityp a) (setq k b))
((infinityp b) (setq k a))
((<= a b) (setq l b k a))
(t (setq l a k b)))))))
(the simplicial-set
(build-smst
:cmpr #'R-proj-space-cmpr
:basis (R-proj-space-basis k l)
:bspn 0
:face (R-proj-space-face k)
:intr-bndr (R-proj-space-intr-bndr k)
:bndr-strt :cmbn
:orgn `(R-proj-space ,k ,l))))))
;;; Constructing a small simplicial subset ;;; Constructing a small simplicial subset