120 lines
3.1 KiB
Common Lisp
120 lines
3.1 KiB
Common Lisp
|
|
(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))))
|
|
|
|
|
|
(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))))
|
|
|
|
|
|
(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
|
|
(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
|
|
(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
|
|
(cons (first del-1) del-0))))))
|
|
|
|
|
|
(let ((d (cat:delta-infinity)))
|
|
(cat:smst-kan d #'dkfll)
|
|
(cat:kfll d 0 1 (list (cat:absm 0 1)))
|
|
(cat:kfll d 0 2 (list (cat:absm 0 5) (cat:absm 0 3)))
|
|
(cat:kfll d 1 2 (list (cat:absm 0 6) (cat:absm 0 3)))
|
|
(cat:kfll d 2 2 (list (cat:absm 0 6) (cat:absm 0 5)))
|
|
(cat:kfll d 0 2 (list (cat:absm 0 3) (cat:absm 0 3)))
|
|
(cat:kfll d 1 2 (list (cat:absm 1 2) (cat:absm 0 3))))
|
|
|
|
|
|
(test check-hat
|
|
(let* ((od (cat:gdeltab))
|
|
(s (cat:loop3 0 31 2))
|
|
(faces (mapcar #'(lambda (indx) (cat:face od indx 3 s))
|
|
'(0 1 2 3))))
|
|
(delete (nth 1 faces) faces)
|
|
(cat:check-hat od 1 3 faces)
|
|
(setf (nth 2 faces) (nth 1 faces))
|
|
(signals #-ecl simple-error
|
|
#+ecl simple-type-error
|
|
(cat:check-hat od 1 3 faces))))
|