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

Moved ABSM-EXT-INT, ABSM-INT_EXT, and VERTEX-I to special-smsts.lisp.

Browse Source
This commit is contained in:
Gerd Heber 2016-03-08 19:23:58 -05:00
parent 5c23300e73
commit 54893a7b0b
3 changed files with 348 additions and 345 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
package.lisp
View File

@ -533,6 +533,8 @@
;; special-smsts.lisp
#:ABSM-EXT-INT
#:ABSM-INT-EXT
#:BUILD-FINITE-SS
#:BUILD-SMST
#:FINITE-SS-PRE-TABLE
@ -545,6 +547,7 @@
#:SPHERE
#:SPHERE-FACE
#:SPHERE-WEDGE
#:VERTEX-I
;; suspensions.lisp

44
src/special-smsts.lisp
View File

@ -1,3 +1,4 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
;;; SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS
;;; SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS
;;; SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS SPECIAL-SMSTS
@ -554,3 +555,46 @@
(the cmbn cmbn))
:strt :cmbn
:orgn `(gmsms-subsmst-incl ,gmsms))))))))
(defun absm-ext-int (vlist)
(do ((dgop nil)
(gmsm (list (first vlist)))
(mark (rest vlist) (cdr mark))
(idgop 0 (1+ idgop)))
((endp mark) (absm (dgop-ext-int dgop)
(dgop-ext-int gmsm)))
(if (= (first gmsm) (car mark))
(push idgop dgop)
(push (car mark) gmsm))))
(defun absm-int-ext (absm)
(with-absm
(dgop gmsm) absm
(do ((dgop (nreverse (dgop-int-ext dgop)))
(gmsm (rest (dlop-int-ext gmsm)))
(i 0 (1+ i))
(rslt (list (first (dlop-int-ext gmsm)))))
((and (endp dgop) (endp gmsm)) (nreverse rslt))
(if dgop
(if (= i (car dgop))
(progn
(pop dgop)
(push (first rslt) rslt))
(push (pop gmsm) rslt))
(return (nreconc rslt gmsm))))))
(defun vertex-i (absm i)
(with-absm
(dgop gmsm) absm
(let ((dgop (nreverse (dgop-int-ext dgop)))
(gmsm (dlop-int-ext gmsm)))
(do ((dgop-mark dgop)
(gmsm-mark gmsm)
(ii 0 (1+ ii)))
((= i ii) (car gmsm-mark))
(if (and dgop-mark
(= ii (car dgop-mark)))
(pop dgop-mark)
(pop gmsm-mark))))))

106
test/kan-test.lisp
View File

@ -1,98 +1,54 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*
(in-package :kenzo-test)
(in-suite :kenzo)
(defun vertex-i (absm i)
(cat:with-absm
(dgop gmsm) absm
(let ((dgop (nreverse (cat:dgop-int-ext dgop)))
(gmsm (cat:dlop-int-ext gmsm)))
(do ((dgop-mark dgop)
(gmsm-mark gmsm)
(ii 0 (1+ ii)))
((= i ii) (car gmsm-mark))
(if (and dgop-mark
(= ii (car dgop-mark)))
(pop dgop-mark)
(pop gmsm-mark))))))
(test vertex-i
(let ((d (cat:delta-infinity)))
(vertex-i (cat:absm 0 1) 0)
(vertex-i (cat:absm 1 1) 0)
(vertex-i (cat:absm 1 1) 1)
(vertex-i (cat:absm 0 3) 0)
(vertex-i (cat:absm 0 3) 1)
(vertex-i (cat:absm 3 1) 0)
(vertex-i (cat:absm 3 1) 1)
(vertex-i (cat:absm 3 1) 2)
(vertex-i (cat:absm 1 3) 0)
(vertex-i (cat:absm 1 3) 1)
(vertex-i (cat:absm 1 3) 2)
(vertex-i (cat:absm 2 3) 0)
(vertex-i (cat:absm 2 3) 1)
(vertex-i (cat:absm 2 3) 2)
(vertex-i (cat:absm 0 7) 0)
(vertex-i (cat:absm 0 7) 1)
(vertex-i (cat:absm 0 7) 2)))
(defun absm-int-ext (absm)
(cat:with-absm
(dgop gmsm) absm
(do ((dgop (nreverse (cat:dgop-int-ext dgop)))
(gmsm (rest (cat:dlop-int-ext gmsm)))
(i 0 (1+ i))
(rslt (list (first (cat:dlop-int-ext gmsm)))))
((and (endp dgop) (endp gmsm)) (nreverse rslt))
(if dgop
(if (= i (car dgop))
(progn
(pop dgop)
(push (first rslt) rslt))
(push (pop gmsm) rslt))
(return (nreconc rslt gmsm))))))
(defun absm-ext-int (vlist)
(do ((dgop nil)
(gmsm (list (first vlist)))
(mark (rest vlist) (cdr mark))
(idgop 0 (1+ idgop)))
((endp mark) (cat:absm (cat:dgop-ext-int dgop)
(cat:dgop-ext-int gmsm)))
(if (= (first gmsm) (car mark))
(push idgop dgop)
(push (car mark) gmsm))))
(cat:vertex-i (cat:absm 0 1) 0)
(cat:vertex-i (cat:absm 1 1) 0)
(cat:vertex-i (cat:absm 1 1) 1)
(cat:vertex-i (cat:absm 0 3) 0)
(cat:vertex-i (cat:absm 0 3) 1)
(cat:vertex-i (cat:absm 3 1) 0)
(cat:vertex-i (cat:absm 3 1) 1)
(cat:vertex-i (cat:absm 3 1) 2)
(cat:vertex-i (cat:absm 1 3) 0)
(cat:vertex-i (cat:absm 1 3) 1)
(cat:vertex-i (cat:absm 1 3) 2)
(cat:vertex-i (cat:absm 2 3) 0)
(cat:vertex-i (cat:absm 2 3) 1)
(cat:vertex-i (cat:absm 2 3) 2)
(cat:vertex-i (cat:absm 0 7) 0)
(cat:vertex-i (cat:absm 0 7) 1)
(cat:vertex-i (cat:absm 0 7) 2)))
(test absm-int-ext
(absm-ext-int '(0 0 0 1 2 3 3 3))
(absm-ext-int '(0 1 1 1 2))
(absm-int-ext (absm-ext-int '(0 0 0 1 2 3 3 3)))
(absm-int-ext (absm-ext-int '(0 1 1 1 2))))
(cat:absm-ext-int '(0 0 0 1 2 3 3 3))
(cat:absm-ext-int '(0 1 1 1 2))
(cat:absm-int-ext (cat:absm-ext-int '(0 0 0 1 2 3 3 3)))
(cat:absm-int-ext (cat:absm-ext-int '(0 1 1 1 2))))
(defun dkfll (indx dmns hat)
(cond ((= 1 dmns)
(cat:absm 1 (cat:gmsm (first hat))))
((= 0 indx)
(let ((del-1 (absm-int-ext (first hat)))
(del-2 (absm-int-ext (second hat))))
(absm-ext-int
(let ((del-1 (cat:absm-int-ext (first hat)))
(del-2 (cat:absm-int-ext (second hat))))
(cat:absm-ext-int
(cons (first del-1)
(cons (second del-2) (rest del-1))))))
((= 1 indx)
(let ((del-0 (absm-int-ext (first hat)))
(del-2 (absm-int-ext (second hat))))
(absm-ext-int
(let ((del-0 (cat:absm-int-ext (first hat)))
(del-2 (cat:absm-int-ext (second hat))))
(cat:absm-ext-int
(cons (first del-2) del-0))))
(t
(let ((del-0 (absm-int-ext (first hat)))
(del-1 (absm-int-ext (second hat))))
(absm-ext-int
(let ((del-0 (cat:absm-int-ext (first hat)))
(del-1 (cat:absm-int-ext (second hat))))
(cat:absm-ext-int
(cons (first del-1) del-0))))))