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)))))))
(the intr-mrph #'rslt)))
(DEFUN R-PROJ-SPACE (&optional (l :infinity) (k 1))
(declare (fixnum k) (type (or fixnum (eql :infinity))))
(assert
(and (typep k 'fixnum)
(plusp k)
(or (eq l :infinity)
(and (typep l 'fixnum)
(<= k l)))))
(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))))
(DEFUN R-PROJ-SPACE (&rest args)
(labels ((infinityp (x)
(and (symbolp x)
(eql x :infinity)))
(dimp (x)
(or (infinityp x)
(and (integerp x)
(< x most-positive-fixnum)
(plusp x)))))
(let ((l :infinity)
(k 1))
;; accept zero, one or two arguments
;; must be positive FIXNUM or :INFINITY
;; if one is FIXNUM, assign K
;; if both are FIXNUM, sort and assign such that (<= 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