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

Updated formattting

Browse Source
This commit is contained in:
gheber 2015-01-02 07:44:28 -06:00
parent fe0f5a3e96
commit baaec230bb
6 changed files with 1412 additions and 1394 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

548
src/chain-complexes.lisp
View File

@ -12,27 +12,27 @@
(map nil #'(lambda (listname) (map nil #'(lambda (listname)
(declare (symbol listname)) (declare (symbol listname))
(setf (symbol-value listname) +empty-list+)) (setf (symbol-value listname) +empty-list+))
*list-list*) *list-list*)
(done)) (done))
(DEFUN HOW-MANY-OBJECTS () (DEFUN HOW-MANY-OBJECTS ()
(mapc #'(lambda (symbol) (mapc #'(lambda (symbol)
(declare (type (or string symbol) symbol)) (declare (type (or string symbol) symbol))
(let ((length (length (eval symbol)))) (let ((length (length (eval symbol))))
(declare (fixnum length)) (declare (fixnum length))
(setf symbol (symbol-name symbol)) (setf symbol (symbol-name symbol))
(setf symbol (subseq symbol 1 (- (length symbol) 6))) (setf symbol (subseq symbol 1 (- (length symbol) 6)))
(format t "~%~6D ~As" length symbol))) (format t "~%~6D ~As" length symbol)))
*list-list*) *list-list*)
(done)) (done))
(DEFUN ALL-OBJECTS () (DEFUN ALL-OBJECTS ()
(let ((object-list (let ((object-list
(sort (delete-duplicates (sort (delete-duplicates
(mapcan #'(lambda (symbol) (mapcan #'(lambda (symbol)
(copy-list (eval symbol))) (copy-list (eval symbol)))
*list-list*) *list-list*)
:test #'eq) :test #'eq)
#'< :key #'idnm))) #'< :key #'idnm)))
(declare (list object-list)) (declare (list object-list))
(dolist (item object-list) (dolist (item object-list)
@ -66,10 +66,10 @@
((zerop idnm)) ((zerop idnm))
(declare (fixnum idnm)) (declare (fixnum idnm))
(let ((found (find-if (let ((found (find-if
#'(lambda (item) #'(lambda (item)
(declare (type (or chain-complex morphism) item)) (declare (type (or chain-complex morphism) item))
(member (k idnm) (orgn item))) (member (k idnm) (orgn item)))
k-list))) k-list)))
(declare (type (or null chain-complex morphism) found)) (declare (type (or null chain-complex morphism) found))
(when found (when found
(push (k idnm) k-list)))) (push (k idnm) k-list))))
@ -79,217 +79,217 @@
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) nil)) (setf (ext:package-lock :clos) nil))
(DEFMETHOD PRINT-OBJECT ((chcm chain-complex) stream) (DEFMETHOD PRINT-OBJECT ((chcm chain-complex) stream)
(the chain-complex (the chain-complex
(progn (progn
(format stream "[K~D Chain-Complex]" (idnm chcm)) (format stream "[K~D Chain-Complex]" (idnm chcm))
chcm))) chcm)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t)) (setf (ext:package-lock :clos) t))
(DEFUN CHCM (idnm) (DEFUN CHCM (idnm)
(declare (fixnum idnm)) (declare (fixnum idnm))
(the (or chain-complex null) (the (or chain-complex null)
(find idnm *chcm-list* :key #'idnm))) (find idnm *chcm-list* :key #'idnm)))
(DEFUN RESULT-PRINT (result stream depth) (DEFUN RESULT-PRINT (result stream depth)
(declare (declare
(type result result) (stream stream) (type result result) (stream stream)
(ignore depth)) (ignore depth))
(format stream "~%<Rslt> (format stream "~%<Rslt>
~4TGNRT-> ~A ~4TGNRT-> ~A
~3TVALUE-> ~A ~3TVALUE-> ~A
~4TCLNM-> ~6D ~4TCLNM-> ~6D
~4TRNTM-> ~11,3F" ~4TRNTM-> ~11,3F"
(result-gnrt result) (result-value result) (result-gnrt result) (result-value result)
(result-clnm result) (result-rntm result)) (result-clnm result) (result-rntm result))
result) result)
(DEFMETHOD ?2 ((mrph morphism) cmbn) (DEFMETHOD ?2 ((mrph morphism) cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(cmbn-? mrph cmbn))) (cmbn-? mrph cmbn)))
(DEFMETHOD ?2 ((chcm chain-complex) cmbn) (DEFMETHOD ?2 ((chcm chain-complex) cmbn)
(declare (declare
(type cmbn cmbn)) (type cmbn cmbn))
(the cmbn (the cmbn
(cmbn-? (dffr1 chcm) cmbn))) (cmbn-? (dffr1 chcm) cmbn)))
(DEFMETHOD ?3 ((mrph morphism) degr gnrt) (DEFMETHOD ?3 ((mrph morphism) degr gnrt)
(declare (declare
(fixnum degr) (fixnum degr)
(type gnrt gnrt)) (type gnrt gnrt))
(the cmbn (the cmbn
(gnrt-? mrph degr gnrt))) (gnrt-? mrph degr gnrt)))
(DEFMETHOD ?3 ((chcm chain-complex) degr gnrt) (DEFMETHOD ?3 ((chcm chain-complex) degr gnrt)
(declare (declare
(fixnum degr) (fixnum degr)
(type gnrt gnrt)) (type gnrt gnrt))
(gnrt-? (dffr1 chcm) degr gnrt)) (gnrt-? (dffr1 chcm) degr gnrt))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) nil)) (setf (ext:package-lock :clos) nil))
(DEFMETHOD PRINT-OBJECT ((mrph morphism) stream) (DEFMETHOD PRINT-OBJECT ((mrph morphism) stream)
(the morphism (the morphism
(progn (progn
(if (eq (first (orgn (trgt mrph))) 'z-chcm) (if (eq (first (orgn (trgt mrph))) 'z-chcm)
(format stream "[K~D Cohomology-Class on K~D of degree ~D]" (format stream "[K~D Cohomology-Class on K~D of degree ~D]"
(idnm mrph) (idnm (sorc mrph)) (- (degr mrph))) (idnm mrph) (idnm (sorc mrph)) (- (degr mrph)))
(format stream "[K~D Morphism (degree ~D): K~D -> K~D]" (format stream "[K~D Morphism (degree ~D): K~D -> K~D]"
(idnm mrph) (degr mrph) (idnm mrph) (degr mrph)
(idnm (sorc mrph)) (idnm (trgt mrph)))) (idnm (sorc mrph)) (idnm (trgt mrph))))
mrph))) mrph)))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :clos) t)) (setf (ext:package-lock :clos) t))
(DEFUN MRPH (n) (DEFUN MRPH (n)
(declare (fixnum n)) (declare (fixnum n))
(the (or morphism null) (the (or morphism null)
(find n *mrph-list* :key #'idnm))) (find n *mrph-list* :key #'idnm)))
(DEFUN BUILD-CHCM (&key cmpr basis bsgn intr-dffr strt orgn) (DEFUN BUILD-CHCM (&key cmpr basis bsgn intr-dffr strt orgn)
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(type basis basis) (type basis basis)
(type gnrt bsgn) (type gnrt bsgn)
(type intr-mrph intr-dffr) (type intr-mrph intr-dffr)
(type strt strt) (type strt strt)
(type list orgn)) (type list orgn))
(the chain-complex (the chain-complex
(progn (progn
(let ((already (find orgn *chcm-list* :test #'equal :key #'orgn))) (let ((already (find orgn *chcm-list* :test #'equal :key #'orgn)))
(declare (type (or chain-complex null) already)) (declare (type (or chain-complex null) already))
(when already (when already
(return-from build-chcm already))) (return-from build-chcm already)))
(unless basis (unless basis
(setf basis :locally-effective)) (setf basis :locally-effective))
(let ((chcm (make-instance 'chain-complex (let ((chcm (make-instance 'chain-complex
:cmpr cmpr :cmpr cmpr
:basis basis :basis basis
:bsgn bsgn :bsgn bsgn
:orgn orgn))) :orgn orgn)))
(declare (type chain-complex chcm)) (declare (type chain-complex chcm))
(setf (slot-value chcm 'dffr) (setf (slot-value chcm 'dffr)
(build-mrph (build-mrph
:sorc chcm :trgt chcm :degr -1 :sorc chcm :trgt chcm :degr -1
:intr intr-dffr :strt strt :intr intr-dffr :strt strt
:orgn `(dffr ,chcm))) :orgn `(dffr ,chcm)))
(setf (slot-value chcm 'grmd) chcm) (setf (slot-value chcm 'grmd) chcm)
(push chcm *chcm-list*) (push chcm *chcm-list*)
chcm)))) chcm))))
(DEFUN BASIS2 (object n) ;;; (DEFUN BASIS2 (object n) ;;;
(declare (declare
(type t object) (type t object)
(fixnum n)) (fixnum n))
(the list (the list
(with-slots (basis) object (with-slots (basis) object
(declare (type basis basis)) (declare (type basis basis))
(when (eq :locally-effective basis) (when (eq :locally-effective basis)
(error "The object ~A is locally-effective." object)) (error "The object ~A is locally-effective." object))
(funcall basis n)))) (funcall basis n))))
(DEFUN BUILD-MRPH (&key sorc trgt degr intr strt orgn) (DEFUN BUILD-MRPH (&key sorc trgt degr intr strt orgn)
(declare (declare
(type chain-complex sorc trgt) (type chain-complex sorc trgt)
(fixnum degr) (fixnum degr)
(type intr-mrph intr) (type intr-mrph intr)
(type strt strt) (type strt strt)
(list orgn)) (list orgn))
(the morphism (the morphism
(progn (progn
(let ((already (find orgn *mrph-list* :test #'equal :key #'orgn))) (let ((already (find orgn *mrph-list* :test #'equal :key #'orgn)))
(declare (type (or morphism null) already)) (declare (type (or morphism null) already))
(when already (when already
(return-from build-mrph already))) (return-from build-mrph already)))
(let ((mrph (make-instance 'morphism (let ((mrph (make-instance 'morphism
:sorc sorc :trgt trgt :degr degr :sorc sorc :trgt trgt :degr degr
:intr intr :strt strt :intr intr :strt strt
:orgn orgn))) :orgn orgn)))
(declare (type morphism mrph)) (declare (type morphism mrph))
(setf (slot-value mrph 'rslts) (setf (slot-value mrph 'rslts)
(ecase strt (ecase strt
(:gnrt (map 'simple-vector (:gnrt (map 'simple-vector
;; (vector (vector result)) ;; (vector (vector result))
#'(lambda (dummy) #'(lambda (dummy)
(declare (ignore dummy)) (declare (ignore dummy))
(make-array 0 (make-array 0
:adjustable t :adjustable t
:fill-pointer 0)) :fill-pointer 0))
(make-list +maximal-dimension+))) (make-list +maximal-dimension+)))
(:cmbn nil))) (:cmbn nil)))
(push mrph *mrph-list*) (push mrph *mrph-list*)
mrph)))) mrph))))
;;; FUNCTIONS ;;; FUNCTIONS
(DEFUN NRESULTS () (DEFUN NRESULTS ()
(the fixnum (the fixnum
(let ((nrslts 0)) (let ((nrslts 0))
(declare (fixnum nrslts)) (declare (fixnum nrslts))
(dolist (item *mrph-list*) (dolist (item *mrph-list*)
(declare (type morphism item)) (declare (type morphism item))
(when (eq :gnrt (strt item)) (when (eq :gnrt (strt item))
(map nil (map nil
#'(lambda (drslt) #'(lambda (drslt)
(declare (vector drslt)) (declare (vector drslt))
(incf nrslts (length drslt))) (incf nrslts (length drslt)))
(rslts item)))) (rslts item))))
nrslts))) nrslts)))
(DEFUN TIME-LIST () (DEFUN TIME-LIST ()
(the list (the list
(let ((time-list +empty-list+)) (let ((time-list +empty-list+))
(declare (list time-list)) (declare (list time-list))
(dolist (item *mrph-list*) (dolist (item *mrph-list*)
(declare (type morphism item)) (declare (type morphism item))
(when (eq :gnrt (strt item)) (when (eq :gnrt (strt item))
(map nil #'(lambda (drslt) (map nil #'(lambda (drslt)
(declare (vector drslt)) (declare (vector drslt))
(map nil #'(lambda (rslt) (map nil #'(lambda (rslt)
(declare (type result rslt)) (declare (type result rslt))
(let ((rntm (result-rntm rslt))) (let ((rntm (result-rntm rslt)))
(declare (integer rntm)) (declare (integer rntm))
(when (plusp rntm) (when (plusp rntm)
(push rntm time-list)))) (push rntm time-list))))
drslt)) drslt))
(rslts item)))) (rslts item))))
(sort time-list #'>)))) (sort time-list #'>))))
(DEFUN CLEAN-RESULTS (&optional (results-coef *results-coef*)) (DEFUN CLEAN-RESULTS (&optional (results-coef *results-coef*))
(declare (declare
(single-float results-coef) (single-float results-coef)
(special *results-coef* *results-cmlt-tm* *results-n* *results-verbose*)) (special *results-coef* *results-cmlt-tm* *results-n* *results-verbose*))
(the (values ) (the (values )
(let ((cut (* results-coef (/ *results-cmlt-tm* *results-n*)))) (let ((cut (* results-coef (/ *results-cmlt-tm* *results-n*))))
(declare (single-float cut)) (declare (single-float cut))
(setf *results-n* 0 *results-cmlt-tm* 0.0) (setf *results-n* 0 *results-cmlt-tm* 0.0)
(dolist (item *mrph-list*) (dolist (item *mrph-list*)
(declare (type morphism item)) (declare (type morphism item))
(when (eq :gnrt (strt item)) (when (eq :gnrt (strt item))
(let ((rslts (rslts item))) (let ((rslts (rslts item)))
(declare (vector rslts)) (declare (vector rslts))
(dotimes (i +maximal-dimension+) (dotimes (i +maximal-dimension+)
(declare (fixnum i)) (declare (fixnum i))
(let ((rslts-i (aref rslts i)) (let ((rslts-i (aref rslts i))
(output (make-array 0 :adjustable t :fill-pointer 0))) (output (make-array 0 :adjustable t :fill-pointer 0)))
(declare (vector rslts-i output)) (declare (vector rslts-i output))
(map nil (map nil
#'(lambda (rslt) #'(lambda (rslt)
(declare (type result rslt)) (declare (type result rslt))
(let ((rntm (result-rntm rslt))) (let ((rntm (result-rntm rslt)))
(declare (single-float rntm)) (declare (single-float rntm))
(when (> rntm cut) (when (> rntm cut)
(incf *results-n*) (incf *results-n*)
(incf *results-cmlt-tm* rntm) (incf *results-cmlt-tm* rntm)
(vector-push-extend rslt output)))) (vector-push-extend rslt output))))
rslts-i) rslts-i)
(setf (aref rslts i) output)))))) (setf (aref rslts i) output))))))
(when *results-verbose* (when *results-verbose*
(format t "~%*CR* -- Cut = ~A -- N = ~A" cut *results-n*))))) (format t "~%*CR* -- Cut = ~A -- N = ~A" cut *results-n*)))))
@ -355,42 +355,43 @@
(DEFUN MRPH-CMBN (scmpr2 tcmpr2 intr cmbn memory) (DEFUN MRPH-CMBN (scmpr2 tcmpr2 intr cmbn memory)
(declare (declare
(type intr-mrph intr) (type intr-mrph intr)
;; (function (fixnum gnrt) cmbn) ;; (function (fixnum gnrt) cmbn)
(type cmprf scmpr2 tcmpr2) (type cmprf scmpr2 tcmpr2)
(type cmbn cmbn) ;;; cmbn is a non-zero one (type cmbn cmbn) ;;; cmbn is a non-zero one
(vector memory)) (vector memory))
;; (vector result) ;; (vector result)
(the cmbn (the cmbn
(with-cmbn (degr list) cmbn (with-cmbn (degr list) cmbn
(let ((n-cmbn-list +empty-list+)) (let ((n-cmbn-list +empty-list+))
(declare (list n-cmbn-list)) (declare (list n-cmbn-list))
(do ((mark list (cdr mark)) (do ((mark list (cdr mark))
(left -1)) (left -1))
((endp mark)) ((endp mark))
(declare (list mark)) (declare (list mark))
(multiple-value-bind (rslt new-left) (multiple-value-bind (rslt new-left)
(mrph-gnrt scmpr2 intr degr (-gnrt mark) memory left) (mrph-gnrt scmpr2 intr degr (-gnrt mark) memory left)
(setf left new-left) (setf left new-left)
(push (cons (-cffc mark) rslt) n-cmbn-list))) (push (cons (-cffc mark) rslt) n-cmbn-list)))
(cmbn-cmbn tcmpr2 n-cmbn-list))))) (cmbn-cmbn tcmpr2 n-cmbn-list)))))
(DEFUN DO-CONTROL (cmpr cmbn) (DEFUN DO-CONTROL (cmpr cmbn)
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(type cmbn cmbn)) (type cmbn cmbn))
(let ((list (cmbn-list cmbn))) (let ((list (cmbn-list cmbn)))
(declare (list list)) (declare (list list))
(do ((mark1 (rest list) (cdr mark1)) (do ((mark1 (rest list) (cdr mark1))
(mark2 list mark1)) (mark2 list mark1))
((endp mark1)) ((endp mark1))
(declare (list mark1 mark2)) (declare (list mark1 mark2))
(unless (eq :less (funcall cmpr (-gnrt mark2) (-gnrt mark1))) (unless (eq :less (funcall cmpr (-gnrt mark2) (-gnrt mark1)))
(setf *wrong-cmbn* cmbn) (setf *wrong-cmbn* cmbn)
(error "In the combination located by *WRONG-CMBN*, the generators:~@ (error "In the combination located by *WRONG-CMBN*, the generators:~@
~A and ~A are in a wrong order." (cdar mark2) (cdar mark1))))) ~A and ~A are in a wrong order." (cdar mark2)
cmbn) (cdar mark1)))))
cmbn)
#| #|
@ -398,98 +399,99 @@
(SETF *PROFILER-STACK* +empty-list+) (SETF *PROFILER-STACK* +empty-list+)
(DEFUN PROFILER-INIT () (DEFUN PROFILER-INIT ()
(mapc #'(lambda (mrph) (mapc #'(lambda (mrph)
(declare (type morphism mrph)) (declare (type morphism mrph))
(setf (wrtm mrph) 0)) (setf (wrtm mrph) 0))
*mrph-list*)) *mrph-list*))
(DEFUN PROFILER-ON () (DEFUN PROFILER-ON ()
(push (get-internal-run-time) *profiler-stack*)) (push (get-internal-run-time) *profiler-stack*))
(DEFUN PROFILER-OFF (mrph) (DEFUN PROFILER-OFF (mrph)
(declare (type morphism mrph)) (declare (type morphism mrph))
(let ((time-spent (let ((time-spent
(- (get-internal-run-time) (pop *profiler-stack*)))) (- (get-internal-run-time) (pop *profiler-stack*))))
(declare (integer time-spent)) (declare (integer time-spent))
(mapl #'(lambda (mark) (mapl #'(lambda (mark)
(declare (cons mark)) (declare (cons mark))
(incf (car mark) time-spent)) (incf (car mark) time-spent))
*profiler-stack*) *profiler-stack*)
(incf (wrtm mrph) time-spent))) (incf (wrtm mrph) time-spent)))
|# |#
(DEFUN GNRT-? (mrph degr gnrt) (DEFUN GNRT-? (mrph degr gnrt)
(declare (declare
(type morphism mrph) (type morphism mrph)
(fixnum degr) (fixnum degr)
(type gnrt gnrt)) (type gnrt gnrt))
(the cmbn (the cmbn
(progn (progn
;; (profiler-on) ;; (profiler-on)
(when (and *future-display* (when (and *future-display*
(> (get-internal-run-time) *future-display*)) (> (get-internal-run-time) *future-display*))
(format t "~%GNRT-? (format t "~%GNRT-?
~3T~A ORGN = ~A ~3T~A ORGN = ~A
~3TDEGR = ~D ~3TDEGR = ~D
~3TGNRT = ~A" ~3TGNRT = ~A"
mrph (orgn mrph) degr gnrt) mrph (orgn mrph) degr gnrt)
(setf *future-display* (+ (get-internal-run-time) *time-interval*))) (setf *future-display* (+ (get-internal-run-time) *time-interval*)))
(with-slots (sorc (mdegr degr) intr strt ?-clnm) mrph (with-slots (sorc (mdegr degr) intr strt ?-clnm) mrph
(declare (declare
(type chain-complex sorc) (type chain-complex sorc)
(fixnum mdegr ?-clnm) (fixnum mdegr ?-clnm)
(type intr-mrph intr) (type intr-mrph intr)
(type strt strt)) (type strt strt))
(with-slots ((scmpr cmpr)) sorc (with-slots ((scmpr cmpr)) sorc
(declare (type cmprf scmpr)) (declare (type cmprf scmpr))
(control (slot-value (slot-value mrph 'trgt) 'cmpr) (control (slot-value (slot-value mrph 'trgt) 'cmpr)
(progn (progn
(incf ?-clnm) (incf ?-clnm)
(prog1 (prog1
(ecase strt (ecase strt
(:gnrt (:gnrt
(mrph-gnrt scmpr intr (mrph-gnrt scmpr intr
degr gnrt (svref (rslts mrph) degr))) degr gnrt (svref (rslts mrph) degr)))
(:cmbn (:cmbn
(funcall intr (term-cmbn degr 1 gnrt)))) (funcall intr (term-cmbn degr 1 gnrt))))
;; (profiler-off mrph) ;; (profiler-off mrph)
)))))))) ))))))))
(DEFUN CMBN-? (mrph cmbn) (DEFUN CMBN-? (mrph cmbn)
(declare (declare
(type morphism mrph) (type morphism mrph)
(type cmbn cmbn)) (type cmbn cmbn))
(the cmbn (the cmbn
(progn (progn
;; (profiler-on) ;; (profiler-on)
(when (and *future-display* (when (and *future-display*
(> (get-internal-run-time) *future-display*)) (> (get-internal-run-time) *future-display*))
(format t "~%CMBN-? (format t "~%CMBN-?
~3T~A ORGN = ~A ~3T~A ORGN = ~A
~3TCMBN = ~A" ~3TCMBN = ~A"
mrph (orgn mrph) cmbn) mrph (orgn mrph) cmbn)
(setf *future-display* (+ (get-internal-run-time) *time-interval*))) (setf *future-display* (+ (get-internal-run-time) *time-interval*)))
(with-slots (sorc trgt degr intr strt ???-clnm) mrph (with-slots (sorc trgt degr intr strt ???-clnm) mrph
(declare (declare
(type chain-complex sorc trgt) (type chain-complex sorc trgt)
(fixnum degr ???-clnm) (fixnum degr ???-clnm)
(type intr-mrph intr) (type intr-mrph intr)
(type strt strt)) (type strt strt))
(with-slots ((scmpr cmpr)) sorc (with-slots ((scmpr cmpr)) sorc
(declare (type cmprf scmpr)) (declare (type cmprf scmpr))
(with-slots ((tcmpr cmpr)) trgt (with-slots ((tcmpr cmpr)) trgt
(declare (type cmprf tcmpr)) (declare (type cmprf tcmpr))
(control tcmpr (control tcmpr
(progn (progn
(controln scmpr cmbn) (controln scmpr cmbn)
(incf ???-clnm) (incf ???-clnm)
(when (eq strt :cmbn) (when (eq strt :cmbn)
(return-from cmbn-? (funcall intr cmbn))) (return-from cmbn-? (funcall intr cmbn)))
(prog1 (prog1
(if (cmbn-zero-p cmbn) (if (cmbn-zero-p cmbn)
(zero-cmbn (+ (cmbn-degr cmbn) degr)) (zero-cmbn (+ (cmbn-degr cmbn) degr))
(mrph-cmbn scmpr tcmpr intr (mrph-cmbn scmpr tcmpr intr
cmbn (svref (rslts mrph) (cmbn-degr cmbn)))) cmbn (svref (rslts mrph)
;; (profiler-off mrph) (cmbn-degr cmbn))))
))))))))) ;; (profiler-off mrph)
)))))))))

471
src/chcm-elementary-op.lisp
View File

@ -1,310 +1,311 @@
;;; CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP ;;; CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP
;;; CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP ;;; CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP
;;; CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP ;;; CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP CHCM-ELEMENTARY-OP
(IN-PACKAGE #:cat) (IN-PACKAGE #:cat)
(PROVIDE "chcm-elementary-op") (PROVIDE "chcm-elementary-op")
(DEFUN Z-CHCM () (DEFUN Z-CHCM ()
(the chain-complex (the chain-complex
(build-chcm (build-chcm
:cmpr #'(lambda (gnrt1 gnrt2) :cmpr #'(lambda (gnrt1 gnrt2)
(declare (ignore gnrt1 gnrt2)) (declare (ignore gnrt1 gnrt2))
(the cmpr :equal)) (the cmpr :equal))
:basis #'(lambda (n) :basis #'(lambda (n)
(declare (type fixnum n)) (declare (type fixnum n))
(the list (the list
(if (zerop n) (if (zerop n)
(list :Z-gnrt) (list :Z-gnrt)
+empty-list+))) +empty-list+)))
:bsgn :Z-gnrt :bsgn :Z-gnrt
:intr-dffr #'zero-intr-dffr :intr-dffr #'zero-intr-dffr
:strt :cmbn :strt :cmbn
:orgn '(Z-chcm)))) :orgn '(Z-chcm))))
(DEFUN ZERO-MRPH (chcm1 &optional (chcm2 chcm1) (degr 0)) (DEFUN ZERO-MRPH (chcm1 &optional (chcm2 chcm1) (degr 0))
(declare (type chain-complex chcm1 chcm2) (declare (type chain-complex chcm1 chcm2)
(type fixnum degr)) (type fixnum degr))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc chcm1 :trgt chcm2 :degr degr :sorc chcm1 :trgt chcm2 :degr degr
:intr #'(lambda (cmbn) :intr #'(lambda (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(zero-cmbn (+ (cmbn-degr cmbn) degr))) (zero-cmbn (+ (cmbn-degr cmbn) degr)))
:strt :cmbn :strt :cmbn
:orgn `(zero-mrph ,chcm1 ,chcm2 ,degr)))) :orgn `(zero-mrph ,chcm1 ,chcm2 ,degr))))
(DEFUN IDNT-MRPH (chcm) (DEFUN IDNT-MRPH (chcm)
(declare (type chain-complex chcm)) (declare (type chain-complex chcm))
(the morphism (the morphism
(build-mrph (build-mrph
:sorc chcm :trgt chcm :degr 0 :sorc chcm :trgt chcm :degr 0
:intr #'identity :intr #'identity
:strt :cmbn :strt :cmbn
:orgn `(idnt-mrph ,chcm)))) :orgn `(idnt-mrph ,chcm))))
(DEFUN OPPS (mrph) (DEFUN OPPS (mrph)
(declare (type morphism mrph)) (declare (type morphism mrph))
(the morphism (the morphism
(with-slots (sorc trgt degr) mrph (with-slots (sorc trgt degr) mrph
(build-mrph (build-mrph
:sorc sorc :trgt trgt :degr degr :sorc sorc :trgt trgt :degr degr
:intr #'(lambda (cmbn) :intr #'(lambda (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(cmbn-opps (cmbn-? mrph cmbn))) (cmbn-opps (cmbn-? mrph cmbn)))
:strt :cmbn :strt :cmbn
:orgn `(opps ,mrph))))) :orgn `(opps ,mrph)))))
(DEFMETHOD CMPS ((chcm1 chain-complex) (chcm2 chain-complex) &optional strt) (DEFMETHOD CMPS ((chcm1 chain-complex) (chcm2 chain-complex) &optional strt)
(declare (type (or strt null) strt)) (declare (type (or strt null) strt))
(the morphism (the morphism
(cmps (dffr chcm1) (dffr chcm2) strt))) (cmps (dffr chcm1) (dffr chcm2) strt)))
(DEFMETHOD CMPS ((chcm1 chain-complex) (mrph2 morphism) &optional strt) (DEFMETHOD CMPS ((chcm1 chain-complex) (mrph2 morphism) &optional strt)
(declare (type (or strt null) strt)) (declare (type (or strt null) strt))
(the morphism (the morphism
(cmps (dffr chcm1) mrph2 strt))) (cmps (dffr chcm1) mrph2 strt)))
(DEFMETHOD CMPS ((mrph1 morphism) (chcm2 chain-complex) &optional strt) (DEFMETHOD CMPS ((mrph1 morphism) (chcm2 chain-complex) &optional strt)
(declare (type (or strt null) strt)) (declare (type (or strt null) strt))
(the morphism (the morphism
(cmps mrph1 (dffr chcm2) strt))) (cmps mrph1 (dffr chcm2) strt)))
(DEFMETHOD CMPS ((mrph1 morphism) (mrph2 morphism) &optional strt) (DEFMETHOD CMPS ((mrph1 morphism) (mrph2 morphism) &optional strt)
(declare (type (or strt null) strt)) (declare (type (or strt null) strt))
(the morphism (the morphism
(with-slots ((sorc1 sorc) (trgt1 trgt) (degr1 degr) (strt1 strt)) mrph1 (with-slots ((sorc1 sorc) (trgt1 trgt) (degr1 degr) (strt1 strt)) mrph1
(declare
(type chain-complex sorc1 trgt1)
(fixnum degr1)
(type strt strt1))
(with-slots ((sorc2 sorc) (trgt2 trgt) (degr2 degr) (strt2 strt)) mrph2
(declare (declare
(type chain-complex sorc1 trgt1)
(fixnum degr1)
(type strt strt1))
(with-slots ((sorc2 sorc) (trgt2 trgt) (degr2 degr) (strt2 strt)) mrph2
(declare
(type chain-complex sorc2 trgt2) (type chain-complex sorc2 trgt2)
(fixnum degr2) (fixnum degr2)
(type strt strt2)) (type strt strt2))
(unless (eq (grmd sorc1) (grmd trgt2)) (unless (eq (grmd sorc1) (grmd trgt2))
(error "In 2MRPH-CMPS, the morphisms ~A and ~A may not be composed (cf source and target)." (error "In 2MRPH-CMPS, the morphisms ~A and ~A may not be composed (cf source and target)."
mrph1 mrph2)) mrph1 mrph2))
(unless strt (unless strt
(setf strt (if (and (eq strt1 :gnrt) (setf strt (if (and (eq strt1 :gnrt)
(eq strt2 :gnrt)) (eq strt2 :gnrt))
:gnrt :gnrt
:cmbn))) :cmbn)))
(when (or (eq (first (orgn mrph1)) 'zero-mrph) (when (or (eq (first (orgn mrph1)) 'zero-mrph)
(eq (first (orgn mrph2)) 'zero-mrph)) (eq (first (orgn mrph2)) 'zero-mrph))
(return-from cmps (return-from cmps
(zero-mrph sorc2 trgt1 (+ degr1 degr2)))) (zero-mrph sorc2 trgt1 (+ degr1 degr2))))
(when (eq (first (orgn mrph1)) 'idnt-mrph) (when (eq (first (orgn mrph1)) 'idnt-mrph)
(return-from cmps mrph2)) (return-from cmps mrph2))
(when (eq (first (orgn mrph2)) 'idnt-mrph) (when (eq (first (orgn mrph2)) 'idnt-mrph)
(return-from cmps mrph1)) (return-from cmps mrph1))
(ecase strt (ecase strt
(:cmbn (build-mrph (:cmbn (build-mrph
:sorc sorc2 :trgt trgt1 :degr (+ degr1 degr2) :sorc sorc2 :trgt trgt1 :degr (+ degr1 degr2)
:intr #'(lambda (cmbn) :intr #'(lambda (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(cmbn-? mrph1 (cmbn-? mrph2 cmbn)))) (cmbn-? mrph1 (cmbn-? mrph2 cmbn))))
:strt :cmbn :orgn `(2mrph-cmps ,mrph1 ,mrph2 ,strt))) :strt :cmbn :orgn `(2mrph-cmps ,mrph1 ,mrph2 ,strt)))
(:gnrt (build-mrph (:gnrt (build-mrph
:sorc sorc2 :trgt trgt1 :degr (+ degr1 degr2) :sorc sorc2 :trgt trgt1 :degr (+ degr1 degr2)
:intr #'(lambda (degr gnrt) :intr #'(lambda (degr gnrt)
(declare (declare
(type fixnum degr) (type fixnum degr)
(type gnrt gnrt)) (type gnrt gnrt))
(the cmbn (the cmbn
(cmbn-? mrph1 (gnrt-? mrph2 degr gnrt)))) (cmbn-? mrph1 (gnrt-? mrph2 degr gnrt))))
:strt :gnrt :orgn `(2mrph-cmps ,mrph1 ,mrph2 ,strt)))))))) :strt :gnrt :orgn `(2mrph-cmps ,mrph1 ,mrph2 ,strt))))))))
(DEFUN N-MRPH-INTR (n mrph) (DEFUN N-MRPH-INTR (n mrph)
(declare (declare
(fixnum n) (fixnum n)
(type morphism mrph)) (type morphism mrph))
(flet ((rslt (cmbn) (flet ((rslt (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(n-cmbn n (cmbn-? mrph cmbn)))) (n-cmbn n (cmbn-? mrph cmbn))))
(the intr-mrph #'rslt))) (the intr-mrph #'rslt)))
(DEFUN N-MRPH (n mrph) (DEFUN N-MRPH (n mrph)
(declare (declare
(fixnum n) (fixnum n)
(type morphism mrph)) (type morphism mrph))
(the morphism (the morphism
(with-slots (sorc trgt degr) mrph (with-slots (sorc trgt degr) mrph
(declare (declare
(type chain-complex sorc trgt) (type chain-complex sorc trgt)
(fixnum degr)) (fixnum degr))
(build-mrph (build-mrph
:sorc sorc :trgt trgt :degr degr :sorc sorc :trgt trgt :degr degr
:intr (n-mrph-intr n mrph) :strt :cmbn :intr (n-mrph-intr n mrph) :strt :cmbn
:orgn `(n-mrph ,n ,mrph))))) :orgn `(n-mrph ,n ,mrph)))))
(DEFMETHOD ADD ((mrph1 morphism) (mrph2 morphism) &optional strt) (DEFMETHOD ADD ((mrph1 morphism) (mrph2 morphism) &optional strt)
(declare (type (or null strt) strt)) (declare (type (or null strt) strt))
(the morphism (the morphism
(with-slots ((sorc1 sorc) (trgt1 trgt) (degr1 degr) (strt1 strt)) mrph1 (with-slots ((sorc1 sorc) (trgt1 trgt) (degr1 degr) (strt1 strt)) mrph1
(declare
(type chain-complex sorc1 trgt1)
(fixnum degr1)
(type strt strt1))
(with-slots ((sorc2 sorc) (trgt2 trgt) (degr2 degr) (strt2 strt)) mrph2
(declare (declare
(type chain-complex sorc1 trgt1)
(fixnum degr1)
(type strt strt1))
(with-slots ((sorc2 sorc) (trgt2 trgt) (degr2 degr) (strt2 strt)) mrph2
(declare
(type chain-complex sorc2 trgt2) (type chain-complex sorc2 trgt2)
(fixnum degr2) (fixnum degr2)
(type strt strt2)) (type strt strt2))
(unless (and (eq (grmd sorc1) (grmd sorc2)) (unless (and (eq (grmd sorc1) (grmd sorc2))
(eq (grmd trgt1) (grmd trgt2)) (eq (grmd trgt1) (grmd trgt2))
(= degr1 degr2)) (= degr1 degr2))
(error "In 2MRPH-ADD, ~A and ~A may not be added." mrph1 mrph2)) (error "In 2MRPH-ADD, ~A and ~A may not be added." mrph1 mrph2))
(when (eq (first (orgn mrph1)) 'zero-mrph) (when (eq (first (orgn mrph1)) 'zero-mrph)
(return-from add mrph2)) (return-from add mrph2))
(when (eq (first (orgn mrph2)) 'zero-mrph) (when (eq (first (orgn mrph2)) 'zero-mrph)
(return-from add mrph1)) (return-from add mrph1))
(unless strt (unless strt
(setf strt (setf strt
(if (and (eq strt1 :gnrt) (if (and (eq strt1 :gnrt)
(eq strt2 :gnrt)) (eq strt2 :gnrt))
:gnrt :gnrt
:cmbn))) :cmbn)))
(when (or (eq (first (orgn mrph1)) 'idnt-mrph) (when (or (eq (first (orgn mrph1)) 'idnt-mrph)
(eq (first (orgn mrph2)) 'idnt-mrph)) (eq (first (orgn mrph2)) 'idnt-mrph))
(setf strt :cmbn)) (setf strt :cmbn))
(let ((cmpr (cmpr trgt1))) (let ((cmpr (cmpr trgt1)))
(declare (type cmprf cmpr)) (declare (type cmprf cmpr))
(ecase strt (ecase strt
(:gnrt (build-mrph (:gnrt (build-mrph
:sorc sorc1 :trgt trgt1 :degr degr1 :sorc sorc1 :trgt trgt1 :degr degr1
:intr #'(lambda (degr gnrt) :intr #'(lambda (degr gnrt)
(declare (type fixnum degr) (type gnrt gnrt)) (declare (type fixnum degr) (type gnrt gnrt))
(2cmbn-add cmpr (2cmbn-add cmpr
(gnrt-? mrph1 degr gnrt) (gnrt-? mrph1 degr gnrt)
(gnrt-? mrph2 degr gnrt))) (gnrt-? mrph2 degr gnrt)))
:strt :gnrt :strt :gnrt
:orgn `(2mrph-add ,mrph1 ,mrph2 ,strt))) :orgn `(2mrph-add ,mrph1 ,mrph2 ,strt)))
(:cmbn (build-mrph (:cmbn (build-mrph
:sorc sorc1 :trgt trgt1 :degr degr1 :sorc sorc1 :trgt trgt1 :degr degr1
:intr #'(lambda (cmbn) :intr #'(lambda (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(2cmbn-add cmpr (2cmbn-add cmpr
(cmbn-? mrph1 cmbn) (cmbn-? mrph1 cmbn)
(cmbn-? mrph2 cmbn))) (cmbn-? mrph2 cmbn)))
:strt :cmbn :strt :cmbn
:orgn `(2mrph-add ,mrph1 ,mrph2 ,strt))))))))) :orgn `(2mrph-add ,mrph1 ,mrph2 ,strt)))))))))
(DEFMETHOD SBTR ((mrph1 morphism) (mrph2 morphism) &optional strt) (DEFMETHOD SBTR ((mrph1 morphism) (mrph2 morphism) &optional strt)
(declare (type (or null strt) strt)) (declare (type (or null strt) strt))
(the morphism (the morphism
(with-slots ((sorc1 sorc) (trgt1 trgt) (degr1 degr) (strt1 strt)) mrph1 (with-slots ((sorc1 sorc) (trgt1 trgt) (degr1 degr) (strt1 strt)) mrph1
(declare
(type chain-complex sorc1 trgt1)
(fixnum degr1)
(type strt strt1))
(with-slots ((sorc2 sorc) (trgt2 trgt) (degr2 degr) (strt2 strt)) mrph2
(declare (declare
(type chain-complex sorc1 trgt1)
(fixnum degr1)
(type strt strt1))
(with-slots ((sorc2 sorc) (trgt2 trgt) (degr2 degr) (strt2 strt)) mrph2
(declare
(type chain-complex sorc2 trgt2) (type chain-complex sorc2 trgt2)
(fixnum degr2) (fixnum degr2)
(type strt strt2)) (type strt strt2))
(unless (and (eq (grmd sorc1) (grmd sorc2)) (unless (and (eq (grmd sorc1) (grmd sorc2))
(eq (grmd trgt1) (grmd trgt2)) (eq (grmd trgt1) (grmd trgt2))
(= degr1 degr2)) (= degr1 degr2))
(error "In 2MRPH-SBTR, ~A and ~A may not be subtracteded." mrph1 mrph2)) (error "In 2MRPH-SBTR, ~A and ~A may not be subtracteded."
(when (eq (first (orgn mrph1)) 'zero-mrph) mrph1 mrph2))
(return-from sbtr mrph2)) (when (eq (first (orgn mrph1)) 'zero-mrph)
(when (eq (first (orgn mrph2)) 'zero-mrph) (return-from sbtr mrph2))
(return-from sbtr mrph1)) (when (eq (first (orgn mrph2)) 'zero-mrph)
(unless strt (return-from sbtr mrph1))
(setf strt (unless strt
(if (and (eq strt1 :gnrt) (setf strt
(eq strt2 :gnrt)) (if (and (eq strt1 :gnrt)
:gnrt (eq strt2 :gnrt))
:cmbn))) :gnrt
(when (or (eq (first (orgn mrph1)) 'idnt-mrph) :cmbn)))
(eq (first (orgn mrph2)) 'idnt-mrph)) (when (or (eq (first (orgn mrph1)) 'idnt-mrph)
(setf strt :cmbn)) (eq (first (orgn mrph2)) 'idnt-mrph))
(let ((cmpr (cmpr trgt1))) (setf strt :cmbn))
(declare (type cmprf cmpr)) (let ((cmpr (cmpr trgt1)))
(ecase strt (declare (type cmprf cmpr))
(ecase strt
(:gnrt (build-mrph (:gnrt (build-mrph
:sorc sorc1 :trgt trgt1 :degr degr1 :sorc sorc1 :trgt trgt1 :degr degr1
:intr #'(lambda (degr gnrt) :intr #'(lambda (degr gnrt)
(declare (type fixnum degr) (type gnrt gnrt)) (declare (type fixnum degr) (type gnrt gnrt))
(2cmbn-sbtr cmpr (2cmbn-sbtr cmpr
(gnrt-? mrph1 degr gnrt) (gnrt-? mrph1 degr gnrt)
(gnrt-? mrph2 degr gnrt))) (gnrt-? mrph2 degr gnrt)))
:strt :gnrt :strt :gnrt
:orgn `(2mrph-sbtr ,mrph1 ,mrph2 ,strt))) :orgn `(2mrph-sbtr ,mrph1 ,mrph2 ,strt)))
(:cmbn (build-mrph (:cmbn (build-mrph
:sorc sorc1 :trgt trgt1 :degr degr1 :sorc sorc1 :trgt trgt1 :degr degr1
:intr #'(lambda (cmbn) :intr #'(lambda (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(2cmbn-sbtr cmpr (2cmbn-sbtr cmpr
(cmbn-? mrph1 cmbn) (cmbn-? mrph1 cmbn)
(cmbn-? mrph2 cmbn))) (cmbn-? mrph2 cmbn)))
:strt :cmbn :strt :cmbn
:orgn `(2mrph-sbtr ,mrph1 ,mrph2 ,strt))))))))) :orgn `(2mrph-sbtr ,mrph1 ,mrph2 ,strt)))))))))
(DEFUN CHANGE-SORC-TRGT (mrph &key new-sorc new-trgt) (DEFUN CHANGE-SORC-TRGT (mrph &key new-sorc new-trgt)
(declare (declare
(type morphism mrph) (type morphism mrph)
(type (or null chain-complex) new-sorc new-trgt)) (type (or null chain-complex) new-sorc new-trgt))
(the morphism (the morphism
(with-slots (sorc trgt degr intr strt) mrph (with-slots (sorc trgt degr intr strt) mrph
(build-mrph (build-mrph
:sorc (or new-sorc sorc) :sorc (or new-sorc sorc)
:trgt (or new-trgt trgt) :trgt (or new-trgt trgt)
:degr degr :degr degr
:intr intr :intr intr
:strt strt :strt strt
:orgn `(change-sorc-trgt ,mrph ,new-sorc ,new-trgt))))) :orgn `(change-sorc-trgt ,mrph ,new-sorc ,new-trgt)))))
(DEFUN DSTR-CHANGE-SORC-TRGT (mrph &key new-sorc new-trgt) (DEFUN DSTR-CHANGE-SORC-TRGT (mrph &key new-sorc new-trgt)
(declare (declare
(type morphism mrph) (type morphism mrph)
(type (or null chain-complex) new-sorc new-trgt)) (type (or null chain-complex) new-sorc new-trgt))
(the morphism (the morphism
(with-slots (sorc trgt) mrph (with-slots (sorc trgt) mrph
(when new-sorc (when new-sorc
(setf sorc new-sorc)) (setf sorc new-sorc))
(when new-trgt (when new-trgt
(setf trgt new-trgt)) (setf trgt new-trgt))
mrph))) mrph)))
(DEFMETHOD ADD ((chcm chain-complex) (perturbation morphism) &optional strt) (DEFMETHOD ADD ((chcm chain-complex) (perturbation morphism) &optional strt)
(declare (type (or strt null) strt)) (declare (type (or strt null) strt))
(the chain-complex (the chain-complex
(with-slots (cmpr basis bsgn dffr) chcm (with-slots (cmpr basis bsgn dffr) chcm
(declare
(type cmprf cmpr)
(type basis basis)
(type morphism dffr))
(with-slots (sorc trgt degr) perturbation
(declare (declare
(type cmprf cmpr)
(type basis basis)
(type morphism dffr))
(with-slots (sorc trgt degr) perturbation
(declare
(type chain-complex sorc trgt) (type chain-complex sorc trgt)
(fixnum degr)) (fixnum degr))
(unless (and (eq (grmd sorc) (grmd chcm)) (unless (and (eq (grmd sorc) (grmd chcm))
(eq (grmd trgt) (grmd chcm)) (eq (grmd trgt) (grmd chcm))
(= degr -1)) (= degr -1))
(error "In (METHOD ADD CHAIN-COMPLEX MORPHISM), the data are not coherent.")) (error "In (METHOD ADD CHAIN-COMPLEX MORPHISM), the data are not coherent."))
(let ((new-dffr (add dffr perturbation strt))) (let ((new-dffr (add dffr perturbation strt)))
(declare (type intr-mrph new-dffr)) (declare (type intr-mrph new-dffr))
(let ((new-chcm (build-chcm (let ((new-chcm (build-chcm
:cmpr cmpr :cmpr cmpr
:basis basis :basis basis
:intr-dffr (intr new-dffr) :intr-dffr (intr new-dffr)
:strt (strt new-dffr) :strt (strt new-dffr)
:orgn `(add ,chcm ,perturbation)))) :orgn `(add ,chcm ,perturbation))))
(declare (type chain-complex new-chcm)) (declare (type chain-complex new-chcm))
(if (slot-boundp chcm 'bsgn) (if (slot-boundp chcm 'bsgn)
(setf (slot-value new-chcm 'bsgn) bsgn) (setf (slot-value new-chcm 'bsgn) bsgn)
(slot-makunbound new-chcm 'bsgn)) (slot-makunbound new-chcm 'bsgn))
(setf (slot-value new-chcm 'grmd) (grmd chcm)) (setf (slot-value new-chcm 'grmd) (grmd chcm))
new-chcm)))))) new-chcm))))))

337
src/classes.lisp
View File

@ -22,10 +22,10 @@
;; CFFC = CoeFFiCient ;; CFFC = CoeFFiCient
(DEFUN CFFC-P (object) (DEFUN CFFC-P (object)
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (typep object 'fixnum) (and (typep object 'fixnum)
(/= 0 object)))) (/= 0 object))))
(DEFTYPE CFFC () '(satisfies cffc-p)) (DEFTYPE CFFC () '(satisfies cffc-p))
@ -37,49 +37,49 @@
;; CMPRF = CoMPaRison Function ;; CMPRF = CoMPaRison Function
(DEFTYPE CMPRF () 'function) (DEFTYPE CMPRF () 'function)
;; (function (gnrt gnrt) cmpr) ;; (function (gnrt gnrt) cmpr)
(DEFUN TERM-P (object) (DEFUN TERM-P (object)
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (consp object) (and (consp object)
(typep (car object) 'cffc) (typep (car object) 'cffc)
(typep (cdr object) 'gnrt)))) (typep (cdr object) 'gnrt))))
(DEFTYPE TERM () '(satisfies term-p)) (DEFTYPE TERM () '(satisfies term-p))
;; ICMBN = Internal-CoMBiNation ;; ICMBN = Internal-CoMBiNation
(DEFUN ICMBN-P (object) (DEFUN ICMBN-P (object)
;; ICMBN = Internal CoMBiNation, ;; ICMBN = Internal CoMBiNation,
;; without the keyword and the degree ;; without the keyword and the degree
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (listp object) (and (listp object)
(every #'term-p object)))) (every #'term-p object))))
(DEFTYPE ICMBN () '(satisfies icmbn-p)) (DEFTYPE ICMBN () '(satisfies icmbn-p))
#| #|
;; CMBN = CoMBiNation ;; CMBN = CoMBiNation
(DEFUN CMBN-P (object) (DEFUN CMBN-P (object)
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (consp object) (and (consp object)
(eql (car object) :cmbn) (eql (car object) :cmbn)
(consp (cdr object)) (consp (cdr object))
(typep (second object) 'fixnum) (typep (second object) 'fixnum)
(typep (cddr object) 'icmbn)))) (typep (cddr object) 'icmbn))))
(DEFTYPE CMBN () '(satisfies cmbn-p)) (DEFTYPE CMBN () '(satisfies cmbn-p))
|# |#
(DEFTYPE BASIS () '(or function (eql :locally-effective))) (DEFTYPE BASIS () '(or function (eql :locally-effective)))
;; (function (degr) (list gnrt)) ;; (function (degr) (list gnrt))
;; INTR-MRPH = INTeRnal-MoRPHism ;; INTR-MRPH = INTeRnal-MoRPHism
(DEFTYPE INTR-MRPH () 'function) (DEFTYPE INTR-MRPH () 'function)
;; (or (function (degr gnrt) cmbn) ;; if :gnrt strategy ;; (or (function (degr gnrt) cmbn) ;; if :gnrt strategy
;; (function (cmbn) (cmbn)) ;; if :cmbn strategy ;; (function (cmbn) (cmbn)) ;; if :cmbn strategy
;;; ;;;
;;; CHAIN-COMPLEXES ;;; CHAIN-COMPLEXES
@ -91,8 +91,8 @@
#+allegro #+allegro
(eval-when (:compile-toplevel :load-toplevel :execute) (eval-when (:compile-toplevel :load-toplevel :execute)
(setf redefinition-warnings-saved (setf redefinition-warnings-saved
excl::*redefinition-warnings* excl::*redefinition-warnings*
*redefinition-warnings* nil)) *redefinition-warnings* nil))
(DEFCLASS CHAIN-COMPLEX () ()) ;; will be redefined later. (DEFCLASS CHAIN-COMPLEX () ()) ;; will be redefined later.
@ -105,49 +105,49 @@
(SETF *IDNM-COUNTER* 0) (SETF *IDNM-COUNTER* 0)
(DEFCLASS CHAIN-COMPLEX () (DEFCLASS CHAIN-COMPLEX ()
((cmpr :type cmprf :initarg :cmpr :reader cmpr1) ((cmpr :type cmprf :initarg :cmpr :reader cmpr1)
(basis :type basis :initarg :basis :reader basis1) (basis :type basis :initarg :basis :reader basis1)
;; BaSe GeNerator ;; BaSe GeNerator
(bsgn :type gnrt :initarg :bsgn :reader bsgn) (bsgn :type gnrt :initarg :bsgn :reader bsgn)
;; DiFFeRential ;; DiFFeRential
(dffr :type morphism :initarg :dffr :reader dffr1) (dffr :type morphism :initarg :dffr :reader dffr1)
;; GRound MoDule ;; GRound MoDule
(grmd :type chain-complex :initarg :grmd :reader grmd) (grmd :type chain-complex :initarg :grmd :reader grmd)
;; EFfective HoMology ;; EFfective HoMology
(efhm :type homotopy-equivalence :initarg :efhm :accessor efhm) (efhm :type homotopy-equivalence :initarg :efhm :accessor efhm)
;; IDentification NuMber ;; IDentification NuMber
(idnm :type fixnum :initform (incf *idnm-counter*) :reader idnm) (idnm :type fixnum :initform (incf *idnm-counter*) :reader idnm)
;; ORiGiN ;; ORiGiN
(orgn :type list :initarg :orgn :reader orgn))) (orgn :type list :initarg :orgn :reader orgn)))
;; STRT = STRaTegy ;; STRT = STRaTegy
(DEFTYPE STRT () '(member :gnrt :cmbn)) (DEFTYPE STRT () '(member :gnrt :cmbn))
(DEFCLASS MORPHISM () (DEFCLASS MORPHISM ()
;; SOuRCe ;; SOuRCe
((sorc :type chain-complex :initarg :sorc :reader sorc) ((sorc :type chain-complex :initarg :sorc :reader sorc)
;; TaRGeT ;; TaRGeT
(trgt :type chain-complex :initarg :trgt :reader trgt) (trgt :type chain-complex :initarg :trgt :reader trgt)
;; DEGRee ;; DEGRee
(degr :type fixnum :initarg :degr :reader degr) (degr :type fixnum :initarg :degr :reader degr)
;; INTeRnal ;; INTeRnal
(intr :type intr-mrph :initarg :intr :reader intr) (intr :type intr-mrph :initarg :intr :reader intr)
;; STRaTegy ;; STRaTegy
(strt :type strt :initarg :strt :reader strt) (strt :type strt :initarg :strt :reader strt)
;; ;; WoRk-TiMe ;; ;; WoRk-TiMe
;; (wrtm :type integer :initform 0 :accessor wrtm) ;; (wrtm :type integer :initform 0 :accessor wrtm)
;; CaLl NuMber ;; CaLl NuMber
(???-clnm :type fixnum :initform 0 :accessor ???-clnm) (???-clnm :type fixnum :initform 0 :accessor ???-clnm)
(?-clnm :type fixnum :initform 0 :accessor ?-clnm) (?-clnm :type fixnum :initform 0 :accessor ?-clnm)
;; ReSuLTS ;; ReSuLTS
(rslts :type simple-vector (rslts :type simple-vector
;; (vector (vector result)) ;; (vector (vector result))
:reader rslts) :reader rslts)
;; IDentification NuMber ;; IDentification NuMber
(idnm :type fixnum :initform (incf *idnm-counter*) :reader idnm) (idnm :type fixnum :initform (incf *idnm-counter*) :reader idnm)
;; ORiGiN ;; ORiGiN
(orgn :type list :initarg :orgn :reader orgn))) (orgn :type list :initarg :orgn :reader orgn)))
(DEFSTRUCT (RESULT (:print-function result-print)) (DEFSTRUCT (RESULT (:print-function result-print))
(gnrt nil :type gnrt) (gnrt nil :type gnrt)
@ -160,50 +160,50 @@
;;; ;;;
(DEFCLASS REDUCTION () (DEFCLASS REDUCTION ()
;; Top Chain Complex ;; Top Chain Complex
((tcc :type chain-complex :initarg :tcc :reader tcc1) ((tcc :type chain-complex :initarg :tcc :reader tcc1)
;; Bottom Chain Complex ;; Bottom Chain Complex
(bcc :type chain-complex :initarg :bcc :reader bcc1) (bcc :type chain-complex :initarg :bcc :reader bcc1)
(f :type morphism :initarg :f :reader f1) (f :type morphism :initarg :f :reader f1)
(g :type morphism :initarg :g :reader g1) (g :type morphism :initarg :g :reader g1)
(h :type morphism :initarg :h :reader h1) (h :type morphism :initarg :h :reader h1)
;; IDentification NuMber ;; IDentification NuMber
(idnm :type fixnum :initform (incf *idnm-counter*) :reader idnm) (idnm :type fixnum :initform (incf *idnm-counter*) :reader idnm)
;; ORiGiN ;; ORiGiN
(orgn :type list :initarg :orgn :reader orgn))) (orgn :type list :initarg :orgn :reader orgn)))
(DEFCLASS HOMOTOPY-EQUIVALENCE () (DEFCLASS HOMOTOPY-EQUIVALENCE ()
;; Left Bottom Chain Complex ;; Left Bottom Chain Complex
((lbcc :type chain-complex :initarg :lbcc :reader lbcc1) ((lbcc :type chain-complex :initarg :lbcc :reader lbcc1)
;; Top Chain Complex ;; Top Chain Complex
(tcc :type chain-complex :initarg :tcc :reader tcc1) (tcc :type chain-complex :initarg :tcc :reader tcc1)
;; Bottom Right Chain Complex ;; Bottom Right Chain Complex
(rbcc :type chain-complex :initarg :rbcc :reader rbcc1) (rbcc :type chain-complex :initarg :rbcc :reader rbcc1)
;; Left f ;; Left f
(lf :type morphism :initarg :lf :reader lf1) (lf :type morphism :initarg :lf :reader lf1)
;; Left g ;; Left g
(lg :type morphism :initarg :lg :reader lg1) (lg :type morphism :initarg :lg :reader lg1)
;; Left h ;; Left h
(lh :type morphism :initarg :lh :reader lh1) (lh :type morphism :initarg :lh :reader lh1)
;; Right f ;; Right f
(rf :type morphism :initarg :rf :reader rf1) (rf :type morphism :initarg :rf :reader rf1)
;; Right g ;; Right g
(rg :type morphism :initarg :rg :reader rg1) (rg :type morphism :initarg :rg :reader rg1)
;; Right h ;; Right h
(rh :type morphism :initarg :rh :reader rh1) (rh :type morphism :initarg :rh :reader rh1)
;; Left ReDuCTion ;; Left ReDuCTion
(lrdct :type reduction :initarg :lrdct :reader lrdct) (lrdct :type reduction :initarg :lrdct :reader lrdct)
;; Right ReDuCTion ;; Right ReDuCTion
(rrdct :type reduction :initarg :rrdct :reader rrdct) (rrdct :type reduction :initarg :rrdct :reader rrdct)
;; IDentification NuMber ;; IDentification NuMber
(idnm :type fixnum :initform (incf *idnm-counter*) :reader idnm) (idnm :type fixnum :initform (incf *idnm-counter*) :reader idnm)
;; ORiGiN ;; ORiGiN
(orgn :type list :initarg :orgn :reader orgn))) (orgn :type list :initarg :orgn :reader orgn)))
#+allegro #+allegro
(eval-when (:compile-toplevel :load-toplevel :execute) (eval-when (:compile-toplevel :load-toplevel :execute)
(setf excl::*redefinition-warnings* (setf excl::*redefinition-warnings*
redefinition-warnings-saved)) redefinition-warnings-saved))
;;; ;;;
;;; HOMOLOGY-GROUPS ;;; HOMOLOGY-GROUPS
@ -245,7 +245,7 @@
;;; ;;;
(DEFCLASS COALGEBRA (chain-complex) (DEFCLASS COALGEBRA (chain-complex)
((cprd :type morphism :initarg :cprd :reader cprd1))) ;; coproduct ((cprd :type morphism :initarg :cprd :reader cprd1))) ;; coproduct
;;; ;;;
;;; COBAR ;;; COBAR
@ -253,21 +253,21 @@
;; CBGN CoBar-GeNerator ;; CBGN CoBar-GeNerator
(DEFUN CBGN-P (object) (DEFUN CBGN-P (object)
;; CBGN = CoBar GeNerator ;; CBGN = CoBar GeNerator
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (consp object) (and (consp object)
(typep (car object) 'fixnum) ;; degree *in* the cobar (typep (car object) 'fixnum) ;; degree *in* the cobar
(typep (cdr object) 'gnrt)))) (typep (cdr object) 'gnrt))))
(DEFTYPE CBGN () '(satisfies cbgn-p)) (DEFTYPE CBGN () '(satisfies cbgn-p))
;; IALLP = Internal-ALgebraic LooP ;; IALLP = Internal-ALgebraic LooP
(DEFUN IALLP-P (object) (DEFUN IALLP-P (object)
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (listp object) (and (listp object)
(every #'cbgn-p object)))) (every #'cbgn-p object))))
(DEFTYPE IALLP () '(satisfies iallp-p)) (DEFTYPE IALLP () '(satisfies iallp-p))
@ -279,7 +279,7 @@
;;; ;;;
(DEFCLASS ALGEBRA (chain-complex) (DEFCLASS ALGEBRA (chain-complex)
((aprd :type morphism :initarg :aprd :reader aprd1))) ;; product ((aprd :type morphism :initarg :aprd :reader aprd1))) ;; product
(DEFCLASS HOPF-ALGEBRA (coalgebra algebra) (DEFCLASS HOPF-ALGEBRA (coalgebra algebra)
()) ())
@ -290,21 +290,21 @@
;; BRGN BaR-GeNerator ;; BRGN BaR-GeNerator
(DEFUN BRGN-P (object) (DEFUN BRGN-P (object)
;; BRGN = BaR GeNerator ;; BRGN = BaR GeNerator
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (consp object) (and (consp object)
(typep (car object) 'fixnum) ;; degree *in* the bar (typep (car object) 'fixnum) ;; degree *in* the bar
(typep (cdr object) 'gnrt)))) (typep (cdr object) 'gnrt))))
(DEFTYPE BRGN () '(satisfies brgn-p)) (DEFTYPE BRGN () '(satisfies brgn-p))
;; IABAR = Internal-ALgebraic LooP ;; IABAR = Internal-ALgebraic LooP
(DEFUN IABAR-P (object) (DEFUN IABAR-P (object)
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (listp object) (and (listp object)
(every #'brgn-p object)))) (every #'brgn-p object))))
(DEFTYPE IABAR () '(satisfies iabar-p)) (DEFTYPE IABAR () '(satisfies iabar-p))
@ -313,11 +313,11 @@
#| #|
(DEFUN ABAR-P (object) (DEFUN ABAR-P (object)
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (consp object) (and (consp object)
(eq :abar (car object)) (eq :abar (car object))
(typep (cdr object) 'iabar)))) (typep (cdr object) 'iabar))))
(DEFTYPE ABAR () '(satisfies abar-p)) (DEFTYPE ABAR () '(satisfies abar-p))
|# |#
@ -343,9 +343,9 @@
(DEFUN IABSM-P (object) (DEFUN IABSM-P (object)
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (consp object) (and (consp object)
(typep (car object) 'dgop) (typep (car object) 'dgop)
(typep (cdr object) 'gmsm)))) (typep (cdr object) 'gmsm))))
(DEFTYPE IABSM () '(satisfies iabsm-p)) (DEFTYPE IABSM () '(satisfies iabsm-p))
|# |#
@ -366,13 +366,13 @@
(DEFTYPE FACE () 'function) (DEFTYPE FACE () 'function)
;; (function (indx dmns gmsm) absm) ;; (function (indx dmns gmsm) absm)
(DEFTYPE FACE* () 'function) (DEFTYPE FACE* () 'function)
;; (function (indx dmns gmsm) (or gmsm (eql :degenerate))) ;; (function (indx dmns gmsm) (or gmsm (eql :degenerate)))
(DEFCLASS SIMPLICIAL-SET (coalgebra) (DEFCLASS SIMPLICIAL-SET (coalgebra)
((face :type face :initarg :face :reader face1))) ((face :type face :initarg :face :reader face1)))
;;; ;;;
@ -380,7 +380,7 @@
;;; ;;;
(DEFTYPE SINTR () 'function) (DEFTYPE SINTR () 'function)
;; (function (dmns gmsm) absm) ;; (function (dmns gmsm) absm)
(DEFCLASS SIMPLICIAL-MRPH (morphism) (DEFCLASS SIMPLICIAL-MRPH (morphism)
((sintr :type sintr :initarg :sintr :reader sintr))) ((sintr :type sintr :initarg :sintr :reader sintr)))
@ -392,11 +392,11 @@
;; DLOP = DeL OPerator ;; DLOP = DeL OPerator
(DEFUN SOFT-DLOP-P (object) (DEFUN SOFT-DLOP-P (object)
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (consp object) (and (consp object)
(eq :delt (car object)) (eq :delt (car object))
(typep (cdr object) 'dgop)))) (typep (cdr object) 'dgop))))
(DEFTYPE SOFT-DLOP () '(satisfies soft-dlop-p)) (DEFTYPE SOFT-DLOP () '(satisfies soft-dlop-p))
@ -416,7 +416,7 @@
;;;; ;;;;
(DEFTYPE KFLL () 'function) (DEFTYPE KFLL () 'function)
;; (function (indx dmns (list absm)) absm) ;; (function (indx dmns (list absm)) absm)
(DEFCLASS KAN (simplicial-set) (DEFCLASS KAN (simplicial-set)
((kfll :type kfll :initarg :kfll :reader kfll1))) ((kfll :type kfll :initarg :kfll :reader kfll1)))
@ -428,15 +428,15 @@
(DEFUN FIBRATION-P (object) (DEFUN FIBRATION-P (object)
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (typep object 'simplicial-mrph) (and (typep object 'simplicial-mrph)
(= -1 (degr object))))) (= -1 (degr object)))))
(DEFTYPE FIBRATION () (DEFTYPE FIBRATION ()
'(satisfies fibration-p)) '(satisfies fibration-p))
(DEFCLASS SIMPLICIAL-GROUP (kan hopf-algebra) (DEFCLASS SIMPLICIAL-GROUP (kan hopf-algebra)
((grml :type simplicial-mrph :initarg :grml :reader grml1) ((grml :type simplicial-mrph :initarg :grml :reader grml1)
(grin :type simplicial-mrph :initarg :grin :reader grin1))) (grin :type simplicial-mrph :initarg :grin :reader grin1)))
(DEFCLASS AB-SIMPLICIAL-GROUP (simplicial-group) ()) (DEFCLASS AB-SIMPLICIAL-GROUP (simplicial-group) ())
@ -447,46 +447,46 @@
;; EXPN = EXPoNent ;; EXPN = EXPoNent
(DEFUN EXPN-P (object) (DEFUN EXPN-P (object)
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(typep object '(and fixnum (typep object '(and fixnum
(not (eql 0)))))) (not (eql 0))))))
(DEFTYPE EXPN () '(satisfies expn-p)) (DEFTYPE EXPN () '(satisfies expn-p))
;; POWR = POWeR ;; POWR = POWeR
(DEFUN POWR-P (object) (DEFUN POWR-P (object)
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (consp object) (and (consp object)
(typep (car object) 'gmsm) (typep (car object) 'gmsm)
(typep (cdr object) 'expn)))) (typep (cdr object) 'expn))))
(DEFTYPE POWR () '(satisfies powr-p)) (DEFTYPE POWR () '(satisfies powr-p))
;; APOWR = Abstract POWeR ;; APOWR = Abstract POWeR
(DEFUN APOWR-P (object) (DEFUN APOWR-P (object)
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (consp object) (and (consp object)
(typep (car object) 'dgop) (typep (car object) 'dgop)
(typep (cdr object) 'powr)))) (typep (cdr object) 'powr))))
(DEFTYPE APOWR () '(satisfies apowr-p)) (DEFTYPE APOWR () '(satisfies apowr-p))
;; ILOOP = Internal LOOP ;; ILOOP = Internal LOOP
(DEFUN ILOOP-P (object) (DEFUN ILOOP-P (object)
(declare (type any object)) (declare (type any object))
(the boolean (the boolean
(and (listp object) (and (listp object)
(every #'apowr-p object)))) (every #'apowr-p object))))
(DEFTYPE ILOOP () '(satisfies iloop-p)) (DEFTYPE ILOOP () '(satisfies iloop-p))
#+allegro #+allegro
(eval-when (:compile-toplevel :load-toplevel :execute) (eval-when (:compile-toplevel :load-toplevel :execute)
(setf excl:*enable-package-locked-errors* nil)) (setf excl:*enable-package-locked-errors* nil))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :common-lisp) nil)) (setf (ext:package-lock :common-lisp) nil))
#+sbcl(eval-when (:compile-toplevel :load-toplevel :execute) #+sbcl(eval-when (:compile-toplevel :load-toplevel :execute)
@ -497,11 +497,11 @@
#+allegro #+allegro
(eval-when (:compile-toplevel :load-toplevel :execute) (eval-when (:compile-toplevel :load-toplevel :execute)
(setf excl:*enable-package-locked-errors* t)) (setf excl:*enable-package-locked-errors* t))
#+clisp(eval-when (:compile-toplevel :load-toplevel :execute) #+clisp(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (ext:package-lock :common-lisp) t)) (setf (ext:package-lock :common-lisp) t))
#+sbcl(eval-when (:compile-toplevel :load-toplevel :execute) #+sbcl(eval-when (:compile-toplevel :load-toplevel :execute)
(sb-ext:lock-package :common-lisp)) (sb-ext:lock-package :common-lisp))
;;; ;;;
@ -514,4 +514,3 @@
(DEFSTRUCT (GBAR (:print-function gbar-print)) (DEFSTRUCT (GBAR (:print-function gbar-print))
(dmns -1 :type fixnum) (dmns -1 :type fixnum)
(list () :type list)) (list () :type list))

767
src/combinations.lisp
View File

@ -16,39 +16,39 @@
(type cmbn cmbn) (stream stream) (type cmbn cmbn) (stream stream)
(ignore depth)) (ignore depth))
(the cmbn (the cmbn
(with-cmbn (degr list) cmbn (with-cmbn (degr list) cmbn
(format stream "~%~70@{-~}{CMBN ~D}" degr) (format stream "~%~70@{-~}{CMBN ~D}" degr)
(do ((mark list (cdr mark)) (do ((mark list (cdr mark))
(nth 0 (1+ nth))) (nth 0 (1+ nth)))
((endp mark)) ((endp mark))
(declare (declare
(list mark) (list mark)
(fixnum nth)) (fixnum nth))
(when (and *print-length* (= nth *print-length*)) (when (and *print-length* (= nth *print-length*))
(format stream "~%... ...") (format stream "~%... ...")
(return)) (return))
(format stream "~%<~D * ~A>" (-cffc mark) (-gnrt mark))) (format stream "~%<~D * ~A>" (-cffc mark) (-gnrt mark)))
(format stream "~%~78@{-~}~%" t) (format stream "~%~78@{-~}~%" t)
cmbn))) cmbn)))
(DEFUN MAPLEXICO (cmpr list1 list2) (DEFUN MAPLEXICO (cmpr list1 list2)
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(list list1 list2)) (list list1 list2))
(the boolean (the boolean
(do ((mark1 list1 (cdr mark1)) (do ((mark1 list1 (cdr mark1))
(mark2 list2 (cdr mark2))) (mark2 list2 (cdr mark2)))
(nil) (nil)
(declare (list mark1 mark2)) (declare (list mark1 mark2))
(unless mark1 (unless mark1
(return-from maplexico (return-from maplexico
(if mark2 :less :equal))) (if mark2 :less :equal)))
(unless mark2 (unless mark2
(return-from maplexico :greater)) (return-from maplexico :greater))
(case (funcall cmpr (car mark1) (car mark2)) (case (funcall cmpr (car mark1) (car mark2))
(:less (return-from maplexico :less)) (:less (return-from maplexico :less))
(:greater (return-from maplexico :greater)))))) (:greater (return-from maplexico :greater))))))
(DEFUN S-CMPR (symbol1 symbol2) (DEFUN S-CMPR (symbol1 symbol2)
@ -99,24 +99,24 @@
#| #|
(DEFUN CMBN (degr &rest rest) (DEFUN CMBN (degr &rest rest)
(declare (fixnum degr)) (declare (fixnum degr))
(the cmbn (the cmbn
(let ((rslt (list degr :cmbn))) (let ((rslt (list degr :cmbn)))
(do ((mark rest (cddr mark))) (do ((mark rest (cddr mark)))
((endp mark) (nreverse rslt)) ((endp mark) (nreverse rslt))
(declare (list mark)) (declare (list mark))
(push (term (car mark) (cadr mark)) rslt))))) (push (term (car mark) (cadr mark)) rslt)))))
|# |#
(DEFUN CMBN (degr &rest rest) (DEFUN CMBN (degr &rest rest)
(declare (fixnum degr)) (declare (fixnum degr))
(the cmbn (the cmbn
(make-cmbn :degr degr (make-cmbn :degr degr
:list (do ((rslt +empty-list+ :list (do ((rslt +empty-list+
(cons (term (car mark) (cadr mark)) rslt)) (cons (term (car mark) (cadr mark)) rslt))
(mark rest (cddr mark))) (mark rest (cddr mark)))
((endp mark) (nreverse rslt)) ((endp mark) (nreverse rslt))
(declare (list rslt mark)))))) (declare (list rslt mark))))))
#+allegro #+allegro
@ -125,281 +125,300 @@
(DEFUN CHECK-CMBN (chcm cmbn) (DEFUN CHECK-CMBN (chcm cmbn)
(declare (declare
(type chain-complex chcm) (type chain-complex chcm)
(type cmbn cmbn)) (type cmbn cmbn))
(the boolean (the boolean
(do ((cmpr (cmpr chcm)) (do ((cmpr (cmpr chcm))
(mark2 (cmbn-list cmbn) mark1) (mark2 (cmbn-list cmbn) mark1)
(mark1 (rest (cmbn-list cmbn)) (cdr mark1))) (mark1 (rest (cmbn-list cmbn)) (cdr mark1)))
((endp mark1) t) ((endp mark1) t)
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(list mark1 mark2)) (list mark1 mark2))
(unless (eq :less (funcall cmpr (-gnrt mark2) (-gnrt mark1))) (unless (eq :less (funcall cmpr (-gnrt mark2) (-gnrt mark1)))
(error "In CHECK-CMBN, bad order; the generator:~@ (error "In CHECK-CMBN, bad order; the generator:~@
~A~@ ~A~@
is not less than the generator:~@ is not less than the generator:~@
~A." ~A."
(-gnrt mark2) (-gnrt mark1)))))) (-gnrt mark2) (-gnrt mark1))))))
(DEFUN ZERO-CMBN (degr) (DEFUN ZERO-CMBN (degr)
(declare (fixnum degr)) (declare (fixnum degr))
(the cmbn (the cmbn
(make-cmbn (make-cmbn
:degr degr :degr degr
:list +empty-list+))) :list +empty-list+)))
(DEFUN ZERO-INTR-DFFR (cmbn) (DEFUN ZERO-INTR-DFFR (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (zero-cmbn (1- (cmbn-degr cmbn))))) (the cmbn (zero-cmbn (1- (cmbn-degr cmbn)))))
(DEFINE-CONSTANT +ZERO-NEGATIVE-CMBN+ (DEFINE-CONSTANT +ZERO-NEGATIVE-CMBN+
(make-cmbn :degr -1 :list +empty-list+)) (make-cmbn :degr -1 :list +empty-list+))
(DEFUN CMBN-OPPS (cmbn) (DEFUN CMBN-OPPS (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(the cmbn (the cmbn
(with-cmbn (degr list) cmbn (with-cmbn (degr list) cmbn
(make-cmbn (make-cmbn
:degr degr :degr degr
:list (mapcar #'(lambda (term) :list (mapcar #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (cffc gnrt) term (with-term
(term (- cffc) gnrt))) (cffc gnrt) term
list))))) (term (- cffc) gnrt)))
list)))))
(DEFUN N-CMBN (n cmbn) (DEFUN N-CMBN (n cmbn)
;; n is assumed non-zero ;; n is assumed non-zero
(declare (declare
(fixnum n) (fixnum n)
(type cmbn cmbn)) (type cmbn cmbn))
(the cmbn (the cmbn
(if (= n 1) (if (= n 1)
cmbn cmbn
(with-cmbn (degr list) cmbn (with-cmbn (degr list) cmbn
(make-cmbn (make-cmbn
:degr degr :degr degr
:list (mapcar #'(lambda (term) :list (mapcar #'(lambda (term)
(declare (type term term)) (declare (type term term))
(with-term (cffc gnrt) term (with-term
(term (* n cffc) gnrt))) (cffc gnrt) term
list)))))) (term (* n cffc) gnrt)))
list))))))
(DEFUN 2CMBN-ADD (cmpr cmbn1 cmbn2) (DEFUN 2CMBN-ADD (cmpr cmbn1 cmbn2)
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(type cmbn cmbn1 cmbn2)) (type cmbn cmbn1 cmbn2))
(the cmbn (the cmbn
(with-cmbn (degr1 list1) cmbn1 (with-cmbn
(with-cmbn (degr2 list2) cmbn2 (degr1 list1) cmbn1
(unless (= degr1 degr2) (with-cmbn
(error "In ADD, the combination arguments have different degrees ~D and ~D." (degr2 list2) cmbn2
degr1 degr2)) (unless (= degr1 degr2)
(unless list1 (error "In ADD, the combination arguments have different degrees ~D and ~D."
(return-from 2cmbn-add cmbn2)) degr1 degr2))
(unless list2 (unless list1
(return-from 2cmbn-add cmbn1)) (return-from 2cmbn-add cmbn2))
(let ((pre-rslt +empty-list+) (unless list2
(mark1 list1) (return-from 2cmbn-add cmbn1))
(mark2 list2)) (let ((pre-rslt +empty-list+)
(declare (list pre-rslt mark1 mark2)) (mark1 list1)
(with--term (cffc1 gnrt1) mark1 (mark2 list2))
(with--term (cffc2 gnrt2) mark2 (declare (list pre-rslt mark1 mark2))
(tagbody (with--term
:begin (cffc1 gnrt1) mark1
(ecase (funcall cmpr gnrt1 gnrt2) (with--term
(:equal (cffc2 gnrt2) mark2
(let ((cffc (+ cffc1 cffc2))) (tagbody
(declare (fixnum cffc)) :begin
(unless (zerop cffc) (ecase (funcall cmpr gnrt1 gnrt2)
(push (term cffc gnrt1) pre-rslt)) (:equal
(setf mark1 (cdr mark1) (let ((cffc (+ cffc1 cffc2)))
mark2 (cdr mark2)) (declare (fixnum cffc))
(unless mark1 (go :cmbn1-is-finished)) (unless (zerop cffc)
(unless mark2 (go :cmbn2-is-finished)) (push (term cffc gnrt1) pre-rslt))
(setf cffc1 (-cffc mark1) (setf mark1 (cdr mark1)
gnrt1 (-gnrt mark1) mark2 (cdr mark2))
cffc2 (-cffc mark2) (unless mark1 (go :cmbn1-is-finished))
gnrt2 (-gnrt mark2)) (unless mark2 (go :cmbn2-is-finished))
(go :begin))) (setf cffc1 (-cffc mark1)
(:less gnrt1 (-gnrt mark1)
(push (-term mark1) pre-rslt) cffc2 (-cffc mark2)
(setf mark1 (cdr mark1)) gnrt2 (-gnrt mark2))
(unless mark1 (go :cmbn1-is-finished)) (go :begin)))
(setf cffc1 (-cffc mark1) (:less
gnrt1 (-gnrt mark1)) (push (-term mark1) pre-rslt)
(go :begin)) (setf mark1 (cdr mark1))
(:greater (unless mark1 (go :cmbn1-is-finished))
(push (-term mark2) pre-rslt) (setf cffc1 (-cffc mark1)
(setf mark2 (cdr mark2)) gnrt1 (-gnrt mark1))
(unless mark2 (go :cmbn2-is-finished)) (go :begin))
(setf cffc2 (-cffc mark2) (:greater
gnrt2 (-gnrt mark2)) (push (-term mark2) pre-rslt)
(go :begin))) (setf mark2 (cdr mark2))
:cmbn1-is-finished (unless mark2 (go :cmbn2-is-finished))
(setf pre-rslt (nreconc pre-rslt mark2)) (setf cffc2 (-cffc mark2)
(go :exit) gnrt2 (-gnrt mark2))
:cmbn2-is-finished (go :begin)))
(setf pre-rslt (nreconc pre-rslt mark1)) :cmbn1-is-finished
:exit)) (setf pre-rslt (nreconc pre-rslt mark2))
(make-cmbn :degr degr1 :list pre-rslt))))))) (go :exit)
:cmbn2-is-finished
(setf pre-rslt (nreconc pre-rslt mark1))
:exit))
(make-cmbn :degr degr1 :list pre-rslt)))))))
(DEFUN 2CMBN-SBTR (cmpr cmbn1 cmbn2) (DEFUN 2CMBN-SBTR (cmpr cmbn1 cmbn2)
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(type cmbn cmbn1 cmbn2)) (type cmbn cmbn1 cmbn2))
(the cmbn (the cmbn
(with-cmbn (degr1 list1) cmbn1 (with-cmbn
(with-cmbn (degr2 list2) cmbn2 (degr1 list1) cmbn1
(unless (= degr1 degr2) (with-cmbn
(error "In SBTR, the combination arguments have different degrees ~D and ~D." (degr2 list2) cmbn2
degr1 degr2)) (unless (= degr1 degr2)
(unless list1 (error "In SBTR, the combination arguments have different degrees ~D and ~D."
(return-from 2cmbn-sbtr (cmbn-opps cmbn2))) degr1 degr2))
(unless list2 (unless list1
(return-from 2cmbn-sbtr cmbn1)) (return-from 2cmbn-sbtr (cmbn-opps cmbn2)))
(let ((pre-rslt +empty-list+) (unless list2
(mark1 list1) (return-from 2cmbn-sbtr cmbn1))
(mark2 list2)) (let ((pre-rslt +empty-list+)
(declare (list pre-rslt mark1 mark2)) (mark1 list1)
(with--term (cffc1 gnrt1) mark1 (mark2 list2))
(with--term (cffc2 gnrt2) mark2 (declare (list pre-rslt mark1 mark2))
(tagbody (with--term
:begin (cffc1 gnrt1) mark1
(ecase (funcall cmpr gnrt1 gnrt2) (with--term
(:equal (cffc2 gnrt2) mark2
(let ((cffc (- cffc1 cffc2))) (tagbody
(declare (fixnum cffc)) :begin
(unless (zerop cffc) (ecase (funcall cmpr gnrt1 gnrt2)
(push (term cffc gnrt1) pre-rslt)) (:equal
(unless mark1 (go :cmbn1-is-finished)) (let ((cffc (- cffc1 cffc2)))
(setf mark1 (cdr mark1) (declare (fixnum cffc))
mark2 (cdr mark2)) (unless (zerop cffc)
(unless mark1 (go :cmbn1-is-finished)) (push (term cffc gnrt1) pre-rslt))
(unless mark2 (go :cmbn2-is-finished)) (unless mark1 (go :cmbn1-is-finished))
(setf cffc1 (-cffc mark1) (setf mark1 (cdr mark1)
gnrt1 (-gnrt mark1) mark2 (cdr mark2))
cffc2 (-cffc mark2) (unless mark1 (go :cmbn1-is-finished))
gnrt2 (-gnrt mark2)) (unless mark2 (go :cmbn2-is-finished))
(go :begin))) (setf cffc1 (-cffc mark1)
(:less gnrt1 (-gnrt mark1)
(push (-term mark1) pre-rslt) cffc2 (-cffc mark2)
(setf mark1 (cdr mark1)) gnrt2 (-gnrt mark2))
(unless mark1 (go :cmbn1-is-finished)) (go :begin)))
(setf cffc1 (-cffc mark1) (:less
gnrt1 (-gnrt mark1)) (push (-term mark1) pre-rslt)
(go :begin)) (setf mark1 (cdr mark1))
(:greater (unless mark1 (go :cmbn1-is-finished))
(push (term (- cffc2) gnrt2) pre-rslt) (setf cffc1 (-cffc mark1)
(setf mark2 (cdr mark2)) gnrt1 (-gnrt mark1))
(unless mark2 (go :cmbn2-is-finished)) (go :begin))
(setf cffc2 (-cffc mark2) (:greater
gnrt2 (-gnrt mark2)) (push (term (- cffc2) gnrt2) pre-rslt)
(go :begin))) (setf mark2 (cdr mark2))
:cmbn1-is-finished (unless mark2 (go :cmbn2-is-finished))
(setf pre-rslt (setf cffc2 (-cffc mark2)
(nreconc pre-rslt gnrt2 (-gnrt mark2))
(mapcar #'(lambda (term) (go :begin)))
(declare (cons term)) :cmbn1-is-finished
(with-term (cffc gnrt) term (setf pre-rslt
(term (- cffc) gnrt))) (nreconc pre-rslt
mark2))) (mapcar #'(lambda (term)
(go :exit) (declare (cons term))
:cmbn2-is-finished (with-term
(setf pre-rslt (nreconc pre-rslt mark1)) (cffc gnrt) term
:exit)) (term (- cffc) gnrt)))
(make-cmbn mark2)))
:degr degr1 (go :exit)
:list pre-rslt))))))) :cmbn2-is-finished
(setf pre-rslt (nreconc pre-rslt mark1))
:exit))
(make-cmbn
:degr degr1
:list pre-rslt)))))))
(DEFUN 2N-2CMBN (cmpr n1 cmbn1 n2 cmbn2) (DEFUN 2N-2CMBN (cmpr n1 cmbn1 n2 cmbn2)
;; n1 * cmbn1 + n2 * cmbn2 ;; n1 * cmbn1 + n2 * cmbn2
;; combinations may be null but not n1 and n2 ;; combinations may be null but not n1 and n2
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(fixnum n1 n2) (fixnum n1 n2)
(type cmbn cmbn1 cmbn2)) (type cmbn cmbn1 cmbn2))
(the cmbn (the cmbn
(with-cmbn (degr1 list1) cmbn1 (with-cmbn
(with-cmbn (degr2 list2) cmbn2 (degr1 list1) cmbn1
(unless (= degr1 degr2) (with-cmbn
(error "In 2N-2CMBN, the combination arguments have different degrees ~D and ~D." (degr2 list2) cmbn2
degr1 degr2)) (unless (= degr1 degr2)
(unless list1 (error "In 2N-2CMBN, the combination arguments have different degrees ~D and ~D."
(return-from 2n-2cmbn (n-cmbn n2 cmbn2))) degr1 degr2))
(unless list2 (unless list1
(return-from 2n-2cmbn (n-cmbn n1 cmbn1))) (return-from 2n-2cmbn (n-cmbn n2 cmbn2)))
(let ((pre-rslt +empty-list+) (unless list2
(mark1 list1) (return-from 2n-2cmbn (n-cmbn n1 cmbn1)))
(mark2 list2)) (let ((pre-rslt +empty-list+)
(declare (list pre-rslt mark1 mark2)) (mark1 list1)
(with--term (cffc1 gnrt1) mark1 (mark2 list2))
(with--term (cffc2 gnrt2) mark2 (declare (list pre-rslt mark1 mark2))
(setf cffc1 (* n1 cffc1) (with--term
cffc2 (* n2 cffc2)) (cffc1 gnrt1) mark1
(tagbody (with--term
:begin (cffc2 gnrt2) mark2
(ecase (funcall cmpr gnrt1 gnrt2) (setf cffc1 (* n1 cffc1)
(:equal cffc2 (* n2 cffc2))
(let ((cffc (+ cffc1 cffc2))) (tagbody
(declare (fixnum cffc)) :begin
(unless (zerop cffc) (ecase (funcall cmpr gnrt1 gnrt2)
(push (term cffc gnrt1) pre-rslt)) (:equal
(setf mark1 (cdr mark1) (let ((cffc (+ cffc1 cffc2)))
mark2 (cdr mark2)) (declare (fixnum cffc))
(unless mark1 (go :cmbn1-is-finished)) (unless (zerop cffc)
(unless mark2 (go :cmbn2-is-finished)) (push (term cffc gnrt1) pre-rslt))
(setf cffc1 (* n1 (-cffc mark1)) (setf mark1 (cdr mark1)
gnrt1 (-gnrt mark1) mark2 (cdr mark2))
cffc2 (* n2 (-cffc mark2)) (unless mark1 (go :cmbn1-is-finished))
gnrt2 (-gnrt mark2)) (unless mark2 (go :cmbn2-is-finished))
(go :begin))) (setf cffc1 (* n1 (-cffc mark1))
(:less gnrt1 (-gnrt mark1)
(push (term cffc1 gnrt1) pre-rslt) cffc2 (* n2 (-cffc mark2))
(setf mark1 (cdr mark1)) gnrt2 (-gnrt mark2))
(unless mark1 (go :cmbn1-is-finished)) (go :begin)))
(setf cffc1 (* n1 (-cffc mark1)) (:less
gnrt1 (-gnrt mark1)) (push (term cffc1 gnrt1) pre-rslt)
(go :begin)) (setf mark1 (cdr mark1))
(:greater (unless mark1 (go :cmbn1-is-finished))
(push (term cffc2 gnrt2) pre-rslt) (setf cffc1 (* n1 (-cffc mark1))
(setf mark2 (cdr mark2)) gnrt1 (-gnrt mark1))
(unless mark2 (go :cmbn2-is-finished)) (go :begin))
(setf cffc2 (* n2 (-cffc mark2)) (:greater
gnrt2 (-gnrt mark2)) (push (term cffc2 gnrt2) pre-rslt)
(go :begin))) (setf mark2 (cdr mark2))
:cmbn1-is-finished (unless mark2 (go :cmbn2-is-finished))
(setf pre-rslt (setf cffc2 (* n2 (-cffc mark2))
(nreconc pre-rslt gnrt2 (-gnrt mark2))
(if (= 1 n2) (go :begin)))
mark2 :cmbn1-is-finished
(mapcar #'(lambda (term) (setf pre-rslt
(declare (cons term)) (nreconc pre-rslt
(with-term (cffc gnrt) term (if (= 1 n2)
(term (* n2 cffc) gnrt))) mark2
mark2)))) (mapcar #'(lambda (term)
(go :exit) (declare (cons term))
:cmbn2-is-finished (with-term
(setf pre-rslt (cffc gnrt) term
(nreconc pre-rslt (term (* n2 cffc)
(if (= 1 n1) gnrt)))
mark1 mark2))))
(mapcar #'(lambda (term) (go :exit)
(declare (cons term)) :cmbn2-is-finished
(with-term (cffc gnrt) term (setf pre-rslt
(term (* n1 cffc) gnrt))) (nreconc pre-rslt
mark1)))) (if (= 1 n1)
:exit)) mark1
(make-cmbn (mapcar #'(lambda (term)
:degr degr1 (declare (cons term))
:list pre-rslt))))))) (with-term
(cffc gnrt) term
(term (* n1 cffc)
gnrt)))
mark1))))
:exit))
(make-cmbn
:degr degr1
:list pre-rslt)))))))
(DEFUN CMBN-CMBN (cmpr n-cmbn-list) (DEFUN CMBN-CMBN (cmpr n-cmbn-list)
@ -407,121 +426,121 @@
;; non-empty-list ;; non-empty-list
;; every n is non-null ;; every n is non-null
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(list n-cmbn-list)) (list n-cmbn-list))
(unless (rest n-cmbn-list) (unless (rest n-cmbn-list)
(return-from cmbn-cmbn (return-from cmbn-cmbn
(n-cmbn (caar n-cmbn-list) (cdar n-cmbn-list)))) (n-cmbn (caar n-cmbn-list) (cdar n-cmbn-list))))
(unless (cddr n-cmbn-list) (unless (cddr n-cmbn-list)
(return-from cmbn-cmbn (return-from cmbn-cmbn
(2n-2cmbn cmpr (2n-2cmbn cmpr
(caar n-cmbn-list) (cdar n-cmbn-list) (caar n-cmbn-list) (cdar n-cmbn-list)
(caadr n-cmbn-list) (cdadr n-cmbn-list)))) (caadr n-cmbn-list) (cdadr n-cmbn-list))))
(the cmbn (the cmbn
(let ((new-rslt +empty-list+)) (let ((new-rslt +empty-list+))
(declare (list new-rslt)) (declare (list new-rslt))
(do ((mark1 (rest n-cmbn-list) (cddr mark1)) (do ((mark1 (rest n-cmbn-list) (cddr mark1))
(mark2 n-cmbn-list (cdr mark1))) (mark2 n-cmbn-list (cdr mark1)))
((endp mark2)) ((endp mark2))
(declare (list mark1 mark2)) (declare (list mark1 mark2))
(when (endp mark1) (when (endp mark1)
(push (n-cmbn (caar mark2) (cdar mark2)) new-rslt) (push (n-cmbn (caar mark2) (cdar mark2)) new-rslt)
(return)) (return))
(push (2n-2cmbn cmpr (push (2n-2cmbn cmpr
(caar mark2) (cdar mark2) (caar mark2) (cdar mark2)
(caar mark1) (cdar mark1)) (caar mark1) (cdar mark1))
new-rslt)) new-rslt))
(let ((old-rslt +empty-list+)) (let ((old-rslt +empty-list+))
(declare (list old-rslt)) (declare (list old-rslt))
(loop (loop
(unless (rest new-rslt) (unless (rest new-rslt)
(return-from cmbn-cmbn (first new-rslt))) (return-from cmbn-cmbn (first new-rslt)))
(setf old-rslt new-rslt (setf old-rslt new-rslt
new-rslt +empty-list+) new-rslt +empty-list+)
(do ((mark1 (rest old-rslt) (cddr mark1)) (do ((mark1 (rest old-rslt) (cddr mark1))
(mark2 old-rslt (cdr mark1))) (mark2 old-rslt (cdr mark1)))
((endp mark2)) ((endp mark2))
(declare (list mark1 mark2)) (declare (list mark1 mark2))
(when (endp mark1) (when (endp mark1)
(push (car mark2) new-rslt) (push (car mark2) new-rslt)
(return)) (return))
(push (2cmbn-add cmpr (car mark2) (car mark1)) (push (2cmbn-add cmpr (car mark2) (car mark1))
new-rslt))))))) new-rslt)))))))
(DEFUN NTERM-ADD (cmpr degr &rest rest) (DEFUN NTERM-ADD (cmpr degr &rest rest)
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(fixnum degr) (fixnum degr)
(list rest)) (list rest))
;; (list term) ;; (list term)
(unless rest (unless rest
(return-from nterm-add (zero-cmbn degr))) (return-from nterm-add (zero-cmbn degr)))
(the cmbn (the cmbn
(let ((rslt (list (first rest)))) (let ((rslt (list (first rest))))
(declare (list rslt)) (declare (list rslt))
(dolist (term (rest rest)) (dolist (term (rest rest))
(declare (type term term)) (declare (type term term))
(with-term (cffc gnrt) term (with-term (cffc gnrt) term
(do ((mark1 rslt (cdr mark1)) (do ((mark1 rslt (cdr mark1))
(mark2 nil mark1)) (mark2 nil mark1))
((endp mark1) (setf (cdr mark2) (list term))) ((endp mark1) (setf (cdr mark2) (list term)))
(ecase (funcall cmpr gnrt (-gnrt mark1)) (ecase (funcall cmpr gnrt (-gnrt mark1))
(:less (:less
(if mark2 (if mark2
(push term (cdr mark2)) (push term (cdr mark2))
(push term rslt)) (push term rslt))
(return)) (return))
(:equal (:equal
(incf (-cffc mark1) cffc) (incf (-cffc mark1) cffc)
(return)) (return))
(:greater ))))) (:greater )))))
(make-cmbn (make-cmbn
:degr degr :degr degr
:list (delete 0 rslt :key #'car))))) :list (delete 0 rslt :key #'car)))))
(DEFUN NCMBN-ADD (cmpr cmbn &rest rest) (DEFUN NCMBN-ADD (cmpr cmbn &rest rest)
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(type cmbn cmbn)) (type cmbn cmbn))
(the cmbn (the cmbn
(cmbn-cmbn cmpr (mapcar #'(lambda (cmbn) (cmbn-cmbn cmpr (mapcar #'(lambda (cmbn)
(declare (type cmbn cmbn)) (declare (type cmbn cmbn))
(cons 1 cmbn)) (cons 1 cmbn))
(cons cmbn rest))))) (cons cmbn rest)))))
(DEFUN DSTR-ADD-TERM-TO-CMBN (cmpr cffc gnrt cmbn) (DEFUN DSTR-ADD-TERM-TO-CMBN (cmpr cffc gnrt cmbn)
(declare (declare
(type cmprf cmpr) (type cmprf cmpr)
(fixnum cffc) ;; non-zero (fixnum cffc) ;; non-zero
(type gnrt gnrt) (type gnrt gnrt)
(type cmbn cmbn)) (type cmbn cmbn))
(the cmbn (the cmbn
(let ((list (cmbn-list cmbn))) (let ((list (cmbn-list cmbn)))
(declare (list list)) (declare (list list))
(unless list (unless list
(push (term cffc gnrt) (cmbn-list cmbn)) (push (term cffc gnrt) (cmbn-list cmbn))
(return-from dstr-add-term-to-cmbn cmbn)) (return-from dstr-add-term-to-cmbn cmbn))
(do ((mark2 nil mark1) (do ((mark2 nil mark1)
(mark1 list (cdr mark1))) (mark1 list (cdr mark1)))
((endp mark1) (setf (cdr mark2) (list (term cffc gnrt)))) ((endp mark1) (setf (cdr mark2) (list (term cffc gnrt))))
(declare (list mark1 mark2)) (declare (list mark1 mark2))
(ecase (funcall cmpr gnrt (-gnrt mark1)) (ecase (funcall cmpr gnrt (-gnrt mark1))
(:less (:less
(if mark2 (if mark2
(push (term cffc gnrt) (cdr mark2)) (push (term cffc gnrt) (cdr mark2))
(push (term cffc gnrt) (cmbn-list cmbn))) (push (term cffc gnrt) (cmbn-list cmbn)))
(return)) (return))
(:equal (:equal
(let ((new-cffc (+ cffc (-cffc mark1)))) (let ((new-cffc (+ cffc (-cffc mark1))))
(declare (fixnum new-cffc)) (declare (fixnum new-cffc))
(if (zerop new-cffc) (if (zerop new-cffc)
(if mark2 (if mark2
(pop (cdr mark2)) (pop (cdr mark2))
(pop (cmbn-list cmbn))) (pop (cmbn-list cmbn)))
(setf (-cffc mark1) new-cffc)) (setf (-cffc mark1) new-cffc))
(return))) (return)))
(:greater))) (:greater)))
cmbn))) cmbn)))

580
src/macros.lisp
View File

@ -30,10 +30,10 @@
|# |#
(DEFMACRO 2-EXP (n) (DEFMACRO 2-EXP (n)
`(aref +2-exp+ ,n)) `(aref +2-exp+ ,n))
(DEFMACRO MASK (n) (DEFMACRO MASK (n)
`(aref +mask+ ,n)) `(aref +mask+ ,n))
(DEFMACRO BINOMIAL-P-Q (p q) (DEFMACRO BINOMIAL-P-Q (p q)
`(binomial-n-p (+ ,p ,q) ,p)) `(binomial-n-p (+ ,p ,q) ,p))
@ -43,14 +43,14 @@
;;; ;;;
(DEFMACRO LEXICO (&rest rest) (DEFMACRO LEXICO (&rest rest)
(unless (cdr rest) (unless (cdr rest)
(return-from lexico (first rest))) (return-from lexico (first rest)))
(let ((vrslt (gensym))) (let ((vrslt (gensym)))
`(let ((,vrslt ,(first rest))) `(let ((,vrslt ,(first rest)))
(declare (type cmpr ,vrslt)) (declare (type cmpr ,vrslt))
(if (eq ,vrslt :equal) (if (eq ,vrslt :equal)
(lexico ,@(rest rest)) (lexico ,@(rest rest))
,vrslt)))) ,vrslt))))
#| #|
() ()
@ -70,64 +70,64 @@
`(cons ,cffc ,gnrt)) `(cons ,cffc ,gnrt))
(DEFMACRO -TERM (mark) (DEFMACRO -TERM (mark)
`(car ,mark)) `(car ,mark))
(DEFMACRO CFFC (term) (DEFMACRO CFFC (term)
`(car ,term)) `(car ,term))
(DEFMACRO -CFFC (mark) (DEFMACRO -CFFC (mark)
`(caar ,mark)) `(caar ,mark))
(DEFMACRO GNRT (term) (DEFMACRO GNRT (term)
`(cdr ,term)) `(cdr ,term))
(DEFMACRO -GNRT (mark) (DEFMACRO -GNRT (mark)
`(cdar ,mark)) `(cdar ,mark))
(DEFMACRO WITH-TERM ((cffc gnrt) term . body) (DEFMACRO WITH-TERM ((cffc gnrt) term . body)
`(let (,@(if cffc `((,cffc (cffc ,term))) nil) `(let (,@(if cffc `((,cffc (cffc ,term))) nil)
,@(if gnrt `((,gnrt (gnrt ,term))) nil)) ,@(if gnrt `((,gnrt (gnrt ,term))) nil))
(declare (declare
(fixnum ,@(if cffc `(,cffc) nil)) (fixnum ,@(if cffc `(,cffc) nil))
(type gnrt ,@(if gnrt `(,gnrt) nil))) (type gnrt ,@(if gnrt `(,gnrt) nil)))
,@body)) ,@body))
#| #|
(macroexpand-1 '(with-term (cffc gnrt) term (macroexpand-1 '(with-term (cffc gnrt) term
(statement-1) (statement-1)
(statement-2))) (statement-2)))
(macroexpand-1 '(with-term (nil gnrt) term (macroexpand-1 '(with-term (nil gnrt) term
(statement-1) (statement-1)
(statement-2))) (statement-2)))
|# |#
(DEFMACRO WITH--TERM ((cffc gnrt) mark . body) (DEFMACRO WITH--TERM ((cffc gnrt) mark . body)
`(let ((,cffc (-cffc ,mark)) `(let ((,cffc (-cffc ,mark))
(,gnrt (-gnrt ,mark))) (,gnrt (-gnrt ,mark)))
(declare (declare
(fixnum ,cffc) (fixnum ,cffc)
(type gnrt ,gnrt)) (type gnrt ,gnrt))
,@body)) ,@body))
#| #|
(macroexpand-1 '(with--term (cffc gnrt) mark (macroexpand-1 '(with--term (cffc gnrt) mark
(statement-1) (statement-1)
(statement-2))) (statement-2)))
|# |#
(DEFMACRO WITH-CMBN ((degr list) cmbn . body) (DEFMACRO WITH-CMBN ((degr list) cmbn . body)
`(let ((,degr (cmbn-degr ,cmbn)) `(let ((,degr (cmbn-degr ,cmbn))
(,list (cmbn-list ,cmbn))) (,list (cmbn-list ,cmbn)))
(declare (declare
(fixnum ,degr) (fixnum ,degr)
(list ,list)) (list ,list))
,@body)) ,@body))
#| #|
(macroexpand-1 '(with-cmbn (degr list) cmbn (macroexpand-1 '(with-cmbn (degr list) cmbn
(statement-1) (statement-1)
(statement-2))) (statement-2)))
|# |#
@ -137,18 +137,18 @@
(DEFMACRO CMBN-NON-ZERO-P (cmbn) (DEFMACRO CMBN-NON-ZERO-P (cmbn)
`(cmbn-list ,cmbn)) `(cmbn-list ,cmbn))
(DEFMACRO CMBN-ZERO-P (cmbn) (DEFMACRO CMBN-ZERO-P (cmbn)
`(null (cmbn-list ,cmbn))) `(null (cmbn-list ,cmbn)))
(DEFMACRO CONTROL (cmpr cmbn) (DEFMACRO CONTROL (cmpr cmbn)
(if *cmbn-control* (if *cmbn-control*
`(do-control ,cmpr ,cmbn) `(do-control ,cmpr ,cmbn)
cmbn)) cmbn))
(DEFMACRO CONTROLN (cmpr cmbn) (DEFMACRO CONTROLN (cmpr cmbn)
(if *cmbn-control* (if *cmbn-control*
`(do-control ,cmpr ,cmbn) `(do-control ,cmpr ,cmbn)
nil)) nil))
@ -160,76 +160,76 @@
;;; ;;;
(DEFMACRO CMPR (&rest rest) (DEFMACRO CMPR (&rest rest)
(ecase (length rest) (ecase (length rest)
(1 `(cmpr1 ,@rest)) (1 `(cmpr1 ,@rest))
(3 `(cmpr3 ,@rest)))) (3 `(cmpr3 ,@rest))))
(DEFMACRO CMPR3 (object item1 item2) (DEFMACRO CMPR3 (object item1 item2)
`(funcall (cmpr1 ,object) ,item1 ,item2)) `(funcall (cmpr1 ,object) ,item1 ,item2))
#| #|
(macroexpand '(cmpr chcm)) (macroexpand '(cmpr chcm))
(macroexpand '(cmpr chcm item1 item2)) (macroexpand '(cmpr chcm item1 item2))
|# |#
(DEFMACRO BASIS (&rest rest) (DEFMACRO BASIS (&rest rest)
(ecase (length rest) (ecase (length rest)
(1 `(basis1 ,@rest)) (1 `(basis1 ,@rest))
(2 `(basis2 ,@rest)) (2 `(basis2 ,@rest))
(3 `(basis3 ,@rest)))) (3 `(basis3 ,@rest))))
(DEFMACRO BASIS3 (smst dmns keyword) (DEFMACRO BASIS3 (smst dmns keyword)
(declare (ignore keyword)) (declare (ignore keyword))
`(a-basis2 (basis ,smst) ,dmns)) `(a-basis2 (basis ,smst) ,dmns))
(DEFMACRO DFFR (&rest rest) (DEFMACRO DFFR (&rest rest)
(ecase (length rest) (ecase (length rest)
(1 `(dffr1 ,@rest)) (1 `(dffr1 ,@rest))
((2 3) `(? (dffr1 ,(first rest)) ,@(rest rest))))) ((2 3) `(? (dffr1 ,(first rest)) ,@(rest rest)))))
#| #|
(macroexpand '(dffr chcm)) (macroexpand '(dffr chcm))
(macroexpand '(dffr chcm cmbn)) (macroexpand '(dffr chcm cmbn))
(macroexpand '(dffr chcm degr gnrt)) (macroexpand '(dffr chcm degr gnrt))
|# |#
(DEFMACRO ? (&rest rest) (DEFMACRO ? (&rest rest)
(ecase (length rest) (ecase (length rest)
(2 `(?2 ,@rest)) (2 `(?2 ,@rest))
(3 `(?3 ,@rest)))) (3 `(?3 ,@rest))))
;;; ;;;
;;; CHCM-ELEMENTARY-OP ;;; CHCM-ELEMENTARY-OP
;;; ;;;
(DEFMACRO I-CMPS (mrph1 &rest rest) (DEFMACRO I-CMPS (mrph1 &rest rest)
(if rest (if rest
`(cmps ,mrph1 (i-cmps ,@rest)) `(cmps ,mrph1 (i-cmps ,@rest))
mrph1)) mrph1))
#| #|
(macroexpand '(i-cmps m1)) (macroexpand '(i-cmps m1))
(macroexpand '(i-cmps m1 m2)) (macroexpand '(i-cmps m1 m2))
(macroexpand '(i-cmps m1 m2 m3)) (macroexpand '(i-cmps m1 m2 m3))
|# |#
(DEFMACRO I-ADD (mrph1 &rest rest) (DEFMACRO I-ADD (mrph1 &rest rest)
(if rest (if rest
`(add ,mrph1 (i-add ,@rest)) `(add ,mrph1 (i-add ,@rest))
mrph1)) mrph1))
#| #|
(macroexpand '(i-add m1)) (macroexpand '(i-add m1))
(macroexpand '(i-add m1 m2)) (macroexpand '(i-add m1 m2))
(macroexpand '(i-add m1 m2 m3)) (macroexpand '(i-add m1 m2 m3))
|# |#
(DEFMACRO I-SBTR (mrph1 mrph2 &rest rest) (DEFMACRO I-SBTR (mrph1 mrph2 &rest rest)
`(sbtr ,mrph1 (i-add ,mrph2 ,@rest))) `(sbtr ,mrph1 (i-add ,mrph2 ,@rest)))
#| #|
(macroexpand '(i-sbtr m1 m2)) (macroexpand '(i-sbtr m1 m2))
(macroexpand '(i-sbtr m1 m2 m3)) (macroexpand '(i-sbtr m1 m2 m3))
|# |#
;;; ;;;
@ -237,88 +237,88 @@
;;; ;;;
(DEFMACRO BCC (&rest rest) (DEFMACRO BCC (&rest rest)
(case (length rest) (case (length rest)
(1 `(bcc1 ,@rest)) (1 `(bcc1 ,@rest))
(otherwise (otherwise
`(? (bcc1 ,(first rest)) ,@(rest rest))))) `(? (bcc1 ,(first rest)) ,@(rest rest)))))
(DEFMACRO TCC (&rest rest) (DEFMACRO TCC (&rest rest)
(case (length rest) (case (length rest)
(1 `(tcc1 ,@rest)) (1 `(tcc1 ,@rest))
(otherwise (otherwise
`(? (tcc1 ,(first rest)) ,@(rest rest))))) `(? (tcc1 ,(first rest)) ,@(rest rest)))))
(DEFMACRO F (&rest rest) (DEFMACRO F (&rest rest)
(case (length rest) (case (length rest)
(1 `(f1 ,@rest)) (1 `(f1 ,@rest))
(otherwise (otherwise
`(? (f1 ,(first rest)) ,@(rest rest))))) `(? (f1 ,(first rest)) ,@(rest rest)))))
#| #|
(macroexpand '(f rdct)) (macroexpand '(f rdct))
(macroexpand '(f rdct cmbn)) (macroexpand '(f rdct cmbn))
(macroexpand '(f rdct degr gnrt)) (macroexpand '(f rdct degr gnrt))
|# |#
(DEFMACRO G (&rest rest) (DEFMACRO G (&rest rest)
(case (length rest) (case (length rest)
(1 `(g1 ,@rest)) (1 `(g1 ,@rest))
(otherwise (otherwise
`(? (g1 ,(first rest)) ,@(rest rest))))) `(? (g1 ,(first rest)) ,@(rest rest)))))
(DEFMACRO H (&rest rest) (DEFMACRO H (&rest rest)
(case (length rest) (case (length rest)
(1 `(h1 ,@rest)) (1 `(h1 ,@rest))
(otherwise (otherwise
`(? (h1 ,(first rest)) ,@(rest rest))))) `(? (h1 ,(first rest)) ,@(rest rest)))))
(DEFMACRO LBCC (&rest rest) (DEFMACRO LBCC (&rest rest)
(case (length rest) (case (length rest)
(1 `(lbcc1 ,@rest)) (1 `(lbcc1 ,@rest))
(otherwise (otherwise
`(? (lbcc1 ,(first rest)) ,@(rest rest))))) `(? (lbcc1 ,(first rest)) ,@(rest rest)))))
(DEFMACRO RBCC (&rest rest) (DEFMACRO RBCC (&rest rest)
(case (length rest) (case (length rest)
(1 `(rbcc1 ,@rest)) (1 `(rbcc1 ,@rest))
(otherwise (otherwise
`(? (rbcc1 ,(first rest)) ,@(rest rest))))) `(? (rbcc1 ,(first rest)) ,@(rest rest)))))
(DEFMACRO LF (&rest rest) (DEFMACRO LF (&rest rest)
(case (length rest) (case (length rest)
(1 `(lf1 ,@rest)) (1 `(lf1 ,@rest))
(otherwise (otherwise
`(? (lf1 ,(first rest)) ,@(rest rest))))) `(? (lf1 ,(first rest)) ,@(rest rest)))))
(DEFMACRO LG (&rest rest) (DEFMACRO LG (&rest rest)
(case (length rest) (case (length rest)
(1 `(lg1 ,@rest)) (1 `(lg1 ,@rest))
(otherwise (otherwise
`(? (lg1 ,(first rest)) ,@(rest rest))))) `(? (lg1 ,(first rest)) ,@(rest rest)))))
(DEFMACRO LH (&rest rest) (DEFMACRO LH (&rest rest)
(case (length rest) (case (length rest)
(1 `(lh1 ,@rest)) (1 `(lh1 ,@rest))
(otherwise (otherwise
`(? (lh1 ,(first rest)) ,@(rest rest))))) `(? (lh1 ,(first rest)) ,@(rest rest)))))
(DEFMACRO RF (&rest rest) (DEFMACRO RF (&rest rest)
(case (length rest) (case (length rest)
(1 `(rf1 ,@rest)) (1 `(rf1 ,@rest))
(otherwise (otherwise
`(? (rf1 ,(first rest)) ,@(rest rest))))) `(? (rf1 ,(first rest)) ,@(rest rest)))))
(DEFMACRO RG (&rest rest) (DEFMACRO RG (&rest rest)
(case (length rest) (case (length rest)
(1 `(rg1 ,@rest)) (1 `(rg1 ,@rest))
(otherwise (otherwise
`(? (rg1 ,(first rest)) ,@(rest rest))))) `(? (rg1 ,(first rest)) ,@(rest rest)))))
(DEFMACRO RH (&rest rest) (DEFMACRO RH (&rest rest)
(case (length rest) (case (length rest)
(1 `(rh1 ,@rest)) (1 `(rh1 ,@rest))
(otherwise (otherwise
`(? (rh1 ,(first rest)) ,@(rest rest))))) `(? (rh1 ,(first rest)) ,@(rest rest)))))
;;; ;;;
@ -361,12 +361,12 @@
`(make-bicn :bcnx :bcnd :ibicn ,gnrt)) `(make-bicn :bcnx :bcnd :ibicn ,gnrt))
(DEFMACRO WITH-BICN ((bcnx ibicn) bicn . body) (DEFMACRO WITH-BICN ((bcnx ibicn) bicn . body)
`(let ((,bcnx (bcnx ,bicn)) `(let ((,bcnx (bcnx ,bicn))
(,ibicn (ibicn ,bicn))) (,ibicn (ibicn ,bicn)))
(declare (declare
(type (member :bcnb :bcnc :bcnd) ,bcnx) (type (member :bcnb :bcnc :bcnd) ,bcnx)
(type gnrt ,ibicn)) (type gnrt ,ibicn))
,@body)) ,@body))
;;; ;;;
@ -375,19 +375,19 @@
#| #|
(DEFMACRO TNPR (degr1 gnrt1 degr2 gnrt2) (DEFMACRO TNPR (degr1 gnrt1 degr2 gnrt2)
`(cons :tnpr (cons (cons ,degr1 ,gnrt1) (cons ,degr2 ,gnrt2)))) `(cons :tnpr (cons (cons ,degr1 ,gnrt1) (cons ,degr2 ,gnrt2))))
(DEFMACRO DEGR1 (tnpr) (DEFMACRO DEGR1 (tnpr)
`(caadr ,tnpr)) `(caadr ,tnpr))
(DEFMACRO GNRT1 (tnpr) (DEFMACRO GNRT1 (tnpr)
`(cdadr ,tnpr)) `(cdadr ,tnpr))
(DEFMACRO DEGR2 (tnpr) (DEFMACRO DEGR2 (tnpr)
`(caddr ,tnpr)) `(caddr ,tnpr))
(DEFMACRO GNRT2 (tnpr) (DEFMACRO GNRT2 (tnpr)
`(cdddr ,tnpr)) `(cdddr ,tnpr))
|# |#
(DEFMACRO TNPR (degr1 gnrt1 degr2 gnrt2) (DEFMACRO TNPR (degr1 gnrt1 degr2 gnrt2)
`(make-tnpr :degr1 ,degr1 :gnrt1 ,gnrt1 `(make-tnpr :degr1 ,degr1 :gnrt1 ,gnrt1
@ -395,24 +395,24 @@
(DEFMACRO WITH-TNPR ((degr1 gnrt1 degr2 gnrt2) tnpr . body) (DEFMACRO WITH-TNPR ((degr1 gnrt1 degr2 gnrt2) tnpr . body)
`(let (,@(if degr1 `((,degr1 (degr1 ,tnpr))) nil) `(let (,@(if degr1 `((,degr1 (degr1 ,tnpr))) nil)
,@(if gnrt1 `((,gnrt1 (gnrt1 ,tnpr))) nil) ,@(if gnrt1 `((,gnrt1 (gnrt1 ,tnpr))) nil)
,@(if degr2 `((,degr2 (degr2 ,tnpr))) nil) ,@(if degr2 `((,degr2 (degr2 ,tnpr))) nil)
,@(if gnrt2 `((,gnrt2 (gnrt2 ,tnpr))) nil)) ,@(if gnrt2 `((,gnrt2 (gnrt2 ,tnpr))) nil))
(declare (declare
(fixnum ,@(if degr1 `(,degr1) nil) ,@(if degr2 `(,degr2) nil)) (fixnum ,@(if degr1 `(,degr1) nil) ,@(if degr2 `(,degr2) nil))
(type gnrt ,@(if gnrt1 `(,gnrt1) nil) ,@(if gnrt2 `(,gnrt2) nil))) (type gnrt ,@(if gnrt1 `(,gnrt1) nil) ,@(if gnrt2 `(,gnrt2) nil)))
,@body)) ,@body))
#| #|
(macroexpand '(tnpr 1 a 2 b)) (macroexpand '(tnpr 1 a 2 b))
1 (tnpr 2 'a 4 (tnpr 2 'b 2 'c)) 1 (tnpr 2 'a 4 (tnpr 2 'b 2 'c))
(macroexpand-1 '(with-tnpr (degr1 gnrt1 degr2 gnrt2) tnpr (macroexpand-1 '(with-tnpr (degr1 gnrt1 degr2 gnrt2) tnpr
(statement-1) (statement-1)
(statement-2))) (statement-2)))
(macroexpand-1 '(with-tnpr (nil gnrt1 degr2 gnrt2) tnpr (macroexpand-1 '(with-tnpr (nil gnrt1 degr2 gnrt2) tnpr
(statement-1) (statement-1)
(statement-2))) (statement-2)))
|# |#
;;; ;;;
@ -420,52 +420,52 @@
;;; ;;;
(DEFMACRO CPRD (&rest rest) (DEFMACRO CPRD (&rest rest)
(case (length rest) (case (length rest)
(1 `(cprd1 ,@rest)) (1 `(cprd1 ,@rest))
((2 3) `(? (cprd1 ,(first rest)) ,@(rest rest))))) ((2 3) `(? (cprd1 ,(first rest)) ,@(rest rest)))))
;;; ;;;
;;; COBAR ;;; COBAR
;;; ;;;
(DEFMACRO CBGN (degr gnrt) (DEFMACRO CBGN (degr gnrt)
`(cons ,degr ,gnrt)) `(cons ,degr ,gnrt))
(DEFMACRO CDEGR (cbgn) (DEFMACRO CDEGR (cbgn)
`(car ,cbgn)) `(car ,cbgn))
(DEFMACRO CGNRT (cbgn) (DEFMACRO CGNRT (cbgn)
`(cdr ,cbgn)) `(cdr ,cbgn))
(DEFMACRO -CDEGR (cbgn) (DEFMACRO -CDEGR (cbgn)
`(caar ,cbgn)) `(caar ,cbgn))
(DEFMACRO -CGNRT (cbgn) (DEFMACRO -CGNRT (cbgn)
`(cdar ,cbgn)) `(cdar ,cbgn))
(DEFMACRO WITH-CBGN ((cdegr cgnrt) cbgn . body) (DEFMACRO WITH-CBGN ((cdegr cgnrt) cbgn . body)
`(let ((,cdegr (cdegr ,cbgn)) `(let ((,cdegr (cdegr ,cbgn))
(,cgnrt (cgnrt ,cbgn))) (,cgnrt (cgnrt ,cbgn)))
(declare (declare
(fixnum ,cdegr) (fixnum ,cdegr)
(type gnrt ,cgnrt)) (type gnrt ,cgnrt))
,@body)) ,@body))
(DEFMACRO WITH--CBGN ((cdegr cgnrt) cbgn . body) (DEFMACRO WITH--CBGN ((cdegr cgnrt) cbgn . body)
`(let ((,cdegr (-cdegr ,cbgn)) `(let ((,cdegr (-cdegr ,cbgn))
(,cgnrt (-cgnrt ,cbgn))) (,cgnrt (-cgnrt ,cbgn)))
(declare (declare
(fixnum ,cdegr) (fixnum ,cdegr)
(type gnrt ,cgnrt)) (type gnrt ,cgnrt))
,@body)) ,@body))
(DEFMACRO WITH-ALLP ((list) allp . body) (DEFMACRO WITH-ALLP ((list) allp . body)
`(let ((,list (allp-list ,allp))) `(let ((,list (allp-list ,allp)))
(declare (list ,list)) (declare (list ,list))
,@body)) ,@body))
(DEFMACRO GNRT-ALLP-TNPR (degr gnrt allp) (DEFMACRO GNRT-ALLP-TNPR (degr gnrt allp)
`(make-allp :list (cons (cbgn (1- ,degr) ,gnrt) ,allp))) `(make-allp :list (cons (cbgn (1- ,degr) ,gnrt) ,allp)))
;;; ;;;
@ -473,69 +473,69 @@
;;; ;;;
(DEFMACRO APRD (&rest rest) (DEFMACRO APRD (&rest rest)
(case (length rest) (case (length rest)
(1 `(aprd1 ,@rest)) (1 `(aprd1 ,@rest))
((2 3) `(? (aprd1 ,(first rest)) ,@(rest rest))))) ((2 3) `(? (aprd1 ,(first rest)) ,@(rest rest)))))
;;; ;;;
;;; BAR ;;; BAR
;;; ;;;
(DEFMACRO BRGN (degr gnrt) (DEFMACRO BRGN (degr gnrt)
`(cons ,degr ,gnrt)) `(cons ,degr ,gnrt))
(DEFMACRO BDEGR (brgn) (DEFMACRO BDEGR (brgn)
`(car ,brgn)) `(car ,brgn))
(DEFMACRO BGNRT (brgn) (DEFMACRO BGNRT (brgn)
`(cdr ,brgn)) `(cdr ,brgn))
(DEFMACRO -BDEGR (brgn) (DEFMACRO -BDEGR (brgn)
`(caar ,brgn)) `(caar ,brgn))
(DEFMACRO -BGNRT (brgn) (DEFMACRO -BGNRT (brgn)
`(cdar ,brgn)) `(cdar ,brgn))
(DEFMACRO WITH-BRGN ((bdegr bgnrt) brgn . body) (DEFMACRO WITH-BRGN ((bdegr bgnrt) brgn . body)
`(let ((,bdegr (bdegr ,brgn)) `(let ((,bdegr (bdegr ,brgn))
(,bgnrt (bgnrt ,brgn))) (,bgnrt (bgnrt ,brgn)))
(declare (declare
(fixnum ,bdegr) (fixnum ,bdegr)
(type gnrt ,bgnrt)) (type gnrt ,bgnrt))
,@body)) ,@body))
(DEFMACRO WITH--BRGN ((bdegr bgnrt) brgn . body) (DEFMACRO WITH--BRGN ((bdegr bgnrt) brgn . body)
`(let ((,bdegr (-bdegr ,brgn)) `(let ((,bdegr (-bdegr ,brgn))
(,bgnrt (-bgnrt ,brgn))) (,bgnrt (-bgnrt ,brgn)))
(declare (declare
(fixnum ,bdegr) (fixnum ,bdegr)
(type gnrt ,bgnrt)) (type gnrt ,bgnrt))
,@body)) ,@body))
#| #|
(DEFMACRO MAKE-ABAR (&key list) (DEFMACRO MAKE-ABAR (&key list)
`(cons :abar ,list)) `(cons :abar ,list))
(DEFMACRO ABAR-LIST (abar) (DEFMACRO ABAR-LIST (abar)
`(cdr ,abar)) `(cdr ,abar))
|# |#
(DEFMACRO WITH-ABAR ((list) abar . body) (DEFMACRO WITH-ABAR ((list) abar . body)
`(let ((,list (abar-list ,abar))) `(let ((,list (abar-list ,abar)))
(declare (list ,list)) (declare (list ,list))
,@body)) ,@body))
#| #|
(DEFMACRO MAKE-GBAR (&key dmns list) (DEFMACRO MAKE-GBAR (&key dmns list)
`(cons :gbar (cons ,dmns ,list))) `(cons :gbar (cons ,dmns ,list)))
(DEFMACRO GBAR-DMNS (gbar) (DEFMACRO GBAR-DMNS (gbar)
`(cadr ,gbar)) `(cadr ,gbar))
(DEFMACRO GBAR-LIST (gbar) (DEFMACRO GBAR-LIST (gbar)
`(cddr ,gbar)) `(cddr ,gbar))
|# |#
@ -549,7 +549,7 @@
#| #|
(DEFMACRO GNRT-GBAR-TNPR (degr gnrt gbar) (DEFMACRO GNRT-GBAR-TNPR (degr gnrt gbar)
`(make-gbar :list (cons (brgn (1- ,degr) ,gnrt) ,gbar))) `(make-gbar :list (cons (brgn (1- ,degr) ,gnrt) ,gbar)))
|# |#
@ -560,10 +560,10 @@
#| #|
(DEFMACRO ABSM (dgop gmsm) (DEFMACRO ABSM (dgop gmsm)
`(cons :absm (cons ,dgop ,gmsm))) `(cons :absm (cons ,dgop ,gmsm)))
(DEFMACRO DGOP (absm) (DEFMACRO DGOP (absm)
`(cadr ,absm)) `(cadr ,absm))
(DEFMACRO GMSM (absm) (DEFMACRO GMSM (absm)
`(cddr ,absm)) `(cddr ,absm))
@ -582,34 +582,34 @@
(declare (declare
(fixnum ,dgop-var) (fixnum ,dgop-var)
(type gmsm ,gmsm-var)) (type gmsm ,gmsm-var))
,@body)))) ,@body))))
(DEFMACRO DEGENERATE-P (absm) (DEFMACRO DEGENERATE-P (absm)
`(plusp (dgop ,absm))) `(plusp (dgop ,absm)))
(DEFMACRO NON-DEGENERATE-P (absm) (DEFMACRO NON-DEGENERATE-P (absm)
`(zerop (dgop ,absm))) `(zerop (dgop ,absm)))
(DEFMACRO BSPN (smst) (DEFMACRO BSPN (smst)
`(bsgn ,smst)) `(bsgn ,smst))
(DEFMACRO BNDR (&rest rest) (DEFMACRO BNDR (&rest rest)
`(dffr ,@rest)) `(dffr ,@rest))
(DEFMACRO DGNL (&rest rest) (DEFMACRO DGNL (&rest rest)
`(cprd ,@rest)) `(cprd ,@rest))
(DEFMACRO FACE (&rest rest) (DEFMACRO FACE (&rest rest)
(ecase (length rest) (ecase (length rest)
(1 `(face1 ,@rest)) (1 `(face1 ,@rest))
(4 `(face4 ,@rest)))) (4 `(face4 ,@rest))))
;;; ;;;
;;; DELTA ;;; DELTA
;;; ;;;
(DEFMACRO D (igmsm) (DEFMACRO D (igmsm)
`(cons :delt ,igmsm)) `(cons :delt ,igmsm))
;;; ;;;
;;; SPECIAL-SMSTS ;;; SPECIAL-SMSTS
@ -619,19 +619,19 @@
;;; faces ;;; faces
(DEFMACRO MAKE-GMSM-FACES-INFO (&key gmsm faces bndr) (DEFMACRO MAKE-GMSM-FACES-INFO (&key gmsm faces bndr)
`(cons ,gmsm (cons ,faces ,bndr))) `(cons ,gmsm (cons ,faces ,bndr)))
(DEFMACRO INFO-GMSM (gmsm-faces-info) (DEFMACRO INFO-GMSM (gmsm-faces-info)
`(car ,gmsm-faces-info)) `(car ,gmsm-faces-info))
(DEFMACRO INFO-FACES (gmsm-faces-info) (DEFMACRO INFO-FACES (gmsm-faces-info)
`(cadr ,gmsm-faces-info)) `(cadr ,gmsm-faces-info))
(DEFMACRO INFO-FACE-I (gmsm-faces-info i) (DEFMACRO INFO-FACE-I (gmsm-faces-info i)
`(svref (cadr ,gmsm-faces-info) ,i)) `(svref (cadr ,gmsm-faces-info) ,i))
(DEFMACRO INFO-BNDR (gmsm-faces-info) (DEFMACRO INFO-BNDR (gmsm-faces-info)
`(cddr ,gmsm-faces-info)) `(cddr ,gmsm-faces-info))
;;; ;;;
;;; CARTESIAN PRODUCTS ;;; CARTESIAN PRODUCTS
@ -639,11 +639,11 @@
#| #|
(DEFMACRO CRPR (&rest rest) (DEFMACRO CRPR (&rest rest)
(ecase (length rest) (ecase (length rest)
(2 `(cons :crpr (cons (cdr ,(first rest)) (cdr ,(second rest))))) (2 `(cons :crpr (cons (cdr ,(first rest)) (cdr ,(second rest)))))
(4 `(cons :crpr (cons (4 `(cons :crpr (cons
(cons ,(first rest) ,(second rest)) (cons ,(first rest) ,(second rest))
(cons ,(third rest) ,(fourth rest))))))) (cons ,(third rest) ,(fourth rest)))))))
|# |#
(DEFMACRO CRPR (&rest rest) (DEFMACRO CRPR (&rest rest)
(ecase (length rest) (ecase (length rest)
@ -671,22 +671,22 @@
#| #|
(DEFMACRO DGOP1 (crpr) (DEFMACRO DGOP1 (crpr)
`(caadr ,crpr)) `(caadr ,crpr))
(DEFMACRO GMSM1 (crpr) (DEFMACRO GMSM1 (crpr)
`(cdadr ,crpr)) `(cdadr ,crpr))
(DEFMACRO DGOP2 (crpr) (DEFMACRO DGOP2 (crpr)
`(caddr ,crpr)) `(caddr ,crpr))
(DEFMACRO GMSM2 (crpr) (DEFMACRO GMSM2 (crpr)
`(cdddr ,crpr)) `(cdddr ,crpr))
(DEFMACRO ABSM1 (crpr) (DEFMACRO ABSM1 (crpr)
`(cons :absm (cadr ,crpr))) `(cons :absm (cadr ,crpr)))
(DEFMACRO ABSM2 (crpr) (DEFMACRO ABSM2 (crpr)
`(cons :absm (cddr ,crpr))) `(cons :absm (cddr ,crpr)))
|# |#
(DEFMACRO ABSM1 (crpr) (DEFMACRO ABSM1 (crpr)
`(absm (dgop1 ,crpr) (gmsm1 ,crpr))) `(absm (dgop1 ,crpr) (gmsm1 ,crpr)))
@ -708,17 +708,17 @@
|# |#
(DEFMACRO WITH-CRPR (&rest rest) (DEFMACRO WITH-CRPR (&rest rest)
(ecase (length (first rest)) (ecase (length (first rest))
(2 `(with-crpr-2 ,@rest)) (2 `(with-crpr-2 ,@rest))
(4 `(with-crpr-4 ,@rest)))) (4 `(with-crpr-4 ,@rest))))
#| #|
(DEFMACRO WITH-CRPR-2 ((absm1 absm2) crpr . body) (DEFMACRO WITH-CRPR-2 ((absm1 absm2) crpr . body)
`(let ((,absm1 (cons :absm (cadr ,crpr))) `(let ((,absm1 (cons :absm (cadr ,crpr)))
(,absm2 (cons :absm (cddr ,crpr)))) (,absm2 (cons :absm (cddr ,crpr))))
(declare (type absm ,absm1 ,absm2)) (declare (type absm ,absm1 ,absm2))
,@body)) ,@body))
|# |#
(DEFMACRO WITH-CRPR-2 ((absm1 absm2) crpr . body) (DEFMACRO WITH-CRPR-2 ((absm1 absm2) crpr . body)
@ -733,25 +733,25 @@
|# |#
(DEFMACRO WITH-CRPR-4 ((dgop1 gmsm1 dgop2 gmsm2) crpr . body) (DEFMACRO WITH-CRPR-4 ((dgop1 gmsm1 dgop2 gmsm2) crpr . body)
`(let ((,dgop1 (dgop1 ,crpr)) `(let ((,dgop1 (dgop1 ,crpr))
(,gmsm1 (gmsm1 ,crpr)) (,gmsm1 (gmsm1 ,crpr))
(,dgop2 (dgop2 ,crpr)) (,dgop2 (dgop2 ,crpr))
(,gmsm2 (gmsm2 ,crpr))) (,gmsm2 (gmsm2 ,crpr)))
(declare (declare
(fixnum ,dgop1 ,dgop2) (fixnum ,dgop1 ,dgop2)
(type gmsm ,gmsm1 ,gmsm2)) (type gmsm ,gmsm1 ,gmsm2))
,@body)) ,@body))
#| #|
() ()
(macroexpand-1 (macroexpand-1
(macroexpand-1 '(with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr (macroexpand-1 '(with-crpr (dgop1 gmsm1 dgop2 gmsm2) crpr
(statement-1) (statement-1)
(statement-2)))) (statement-2))))
(macroexpand-1 (macroexpand-1
(macroexpand-1 '(with-crpr (absm1 absm2) crpr (macroexpand-1 '(with-crpr (absm1 absm2) crpr
(statement-1) (statement-1)
(statement-2)))) (statement-2))))
|# |#
;;; ;;;
@ -759,7 +759,7 @@
;;; ;;;
(DEFMACRO EILENBERG-ZILBER (&rest rest) (DEFMACRO EILENBERG-ZILBER (&rest rest)
`(ez ,@rest)) `(ez ,@rest))
;;; ;;;
;;; KAN ;;; KAN
@ -767,8 +767,8 @@
(DEFMACRO KFLL (&rest rest) (DEFMACRO KFLL (&rest rest)
(ecase (length rest) (ecase (length rest)
(1 `(kfll1 ,@rest)) (1 `(kfll1 ,@rest))
(4 `(kfll4 ,@rest)))) (4 `(kfll4 ,@rest))))
(DEFMACRO KFLL4 (kan indx dmns hat) (DEFMACRO KFLL4 (kan indx dmns hat)
`(funcall (kfll1 ,kan) ,indx ,dmns ,hat)) `(funcall (kfll1 ,kan) ,indx ,dmns ,hat))
@ -779,14 +779,14 @@
;;; ;;;
(DEFMACRO GRML (smgr &rest rest) (DEFMACRO GRML (smgr &rest rest)
(ecase (length rest) (ecase (length rest)
(0 `(grml1 ,smgr)) (0 `(grml1 ,smgr))
((1 2) `(? (grml1 ,smgr) ,@rest)))) ((1 2) `(? (grml1 ,smgr) ,@rest))))
(DEFMACRO GRIN (smgr &rest rest) (DEFMACRO GRIN (smgr &rest rest)
(case (length rest) (case (length rest)
(0 `(grin1 ,smgr)) (0 `(grin1 ,smgr))
(otherwise `(? (grin1 ,smgr) ,@rest)))) (otherwise `(? (grin1 ,smgr) ,@rest))))
(DEFMACRO BUILD-AB-SMGR (&rest rest) (DEFMACRO BUILD-AB-SMGR (&rest rest)
`(change-class (build-smgr ,@rest) 'ab-simplicial-group)) `(change-class (build-smgr ,@rest) 'ab-simplicial-group))
@ -796,43 +796,43 @@
;;; ;;;
(DEFMACRO POWR (gmsm expn) (DEFMACRO POWR (gmsm expn)
`(cons ,gmsm ,expn)) `(cons ,gmsm ,expn))
(DEFMACRO PGMSM (powr) (DEFMACRO PGMSM (powr)
`(car ,powr)) `(car ,powr))
(DEFMACRO EXPN (powr) (DEFMACRO EXPN (powr)
`(cdr ,powr)) `(cdr ,powr))
(DEFMACRO WITH-POWR ((gmsm expn) powr . body) (DEFMACRO WITH-POWR ((gmsm expn) powr . body)
`(let ((,gmsm (car ,powr)) `(let ((,gmsm (car ,powr))
(,expn (cdr ,powr))) (,expn (cdr ,powr)))
(declare (declare
(type gmsm ,gmsm) (type gmsm ,gmsm)
(fixnum expn)) (fixnum expn))
,@body)) ,@body))
(DEFMACRO WITH-APOWR ((dgop gmsm expn) apowr . body) (DEFMACRO WITH-APOWR ((dgop gmsm expn) apowr . body)
`(let ((,dgop (apdgop ,apowr)) `(let ((,dgop (apdgop ,apowr))
(,gmsm (cadr ,apowr)) (,gmsm (cadr ,apowr))
(,expn (cddr ,apowr))) (,expn (cddr ,apowr)))
(declare (declare
(fixnum ,dgop ,expn) (fixnum ,dgop ,expn)
(type gmsm ,gmsm)) (type gmsm ,gmsm))
,@body)) ,@body))
(DEFMACRO APOWR (dgop gmsm expn) (DEFMACRO APOWR (dgop gmsm expn)
`(cons ,dgop (cons ,gmsm ,expn))) `(cons ,dgop (cons ,gmsm ,expn)))
(DEFMACRO APDGOP (apowr) (DEFMACRO APDGOP (apowr)
`(car ,apowr)) `(car ,apowr))
(DEFMACRO APGMSM (apowr) (DEFMACRO APGMSM (apowr)
`(cadr ,apowr)) `(cadr ,apowr))
(DEFMACRO APEXPN (apowr) (DEFMACRO APEXPN (apowr)
`(cddr ,apowr)) `(cddr ,apowr))
;;; ;;;
;;; SMITH ;;; SMITH

103
src/various.lisp
View File

@ -10,92 +10,89 @@
(DEFUN BINOMIAL-N-P (n p) (DEFUN BINOMIAL-N-P (n p)
(declare (fixnum n p)) (declare (fixnum n p))
(when (> (2-exp p) n) (when (> (2-exp p) n)
(setf p (- n p))) (setf p (- n p)))
(the fixnum (the fixnum
(do ((nn n (1- nn)) (do ((nn n (1- nn))
(pp 1 (1+ pp)) (pp 1 (1+ pp))
(rslt 1 (/ (* rslt nn) pp))) (rslt 1 (/ (* rslt nn) pp)))
((> pp p) rslt) ((> pp p) rslt)
(declare (fixnum nn pp rslt))))) (declare (fixnum nn pp rslt)))))
(SETF *PRINT-LEVEL* 5 (SETF *PRINT-LEVEL* 5
*PRINT-LENGTH* 10) *PRINT-LENGTH* 10)
(DEFUN <A-B< (a b) (DEFUN <A-B< (a b)
(declare (fixnum a b)) (declare (fixnum a b))
(the list (the list
(do ((i (1- b) (1- i)) (do ((i (1- b) (1- i))
(rslt +empty-list+ (cons i rslt))) (rslt +empty-list+ (cons i rslt)))
((< i a) rslt) ((< i a) rslt)
(declare (fixnum i) (list rslt))))) (declare (fixnum i) (list rslt)))))
(DEFUN <A-B> (a b) (DEFUN <A-B> (a b)
(declare (fixnum a b)) (declare (fixnum a b))
(the list (the list
(do ((i b (1- i)) (do ((i b (1- i))
(rslt +empty-list+ (cons i rslt))) (rslt +empty-list+ (cons i rslt)))
((< i a) rslt) ((< i a) rslt)
(declare (fixnum i) (list rslt))))) (declare (fixnum i) (list rslt)))))
(DEFUN >A-B< (a b) (DEFUN >A-B< (a b)
(declare (fixnum a b)) (declare (fixnum a b))
(the list (the list
(do ((i (1- b) (1- i)) (do ((i (1- b) (1- i))
(rslt +empty-list+ (cons i rslt))) (rslt +empty-list+ (cons i rslt)))
((= i a) rslt) ((= i a) rslt)
(declare (fixnum i) (list rslt))))) (declare (fixnum i) (list rslt)))))
(DEFUN >A-B> (a b) (DEFUN >A-B> (a b)
(declare (fixnum a b)) (declare (fixnum a b))
(the list (the list
(do ((i b (1- i)) (do ((i b (1- i))
(rslt +empty-list+ (cons i rslt))) (rslt +empty-list+ (cons i rslt)))
((= i a) rslt) ((= i a) rslt)
(declare (fixnum i) (list rslt))))) (declare (fixnum i) (list rslt)))))
(DEFUN V<A-B> (a b) (DEFUN V<A-B> (a b)
(declare (fixnum a b)) (declare (fixnum a b))
(the (vector fixnum) (the (vector fixnum)
(let ((rslt (make-array (1+ (- b a)) :element-type 'fixnum))) (let ((rslt (make-array (1+ (- b a)) :element-type 'fixnum)))
(declare (type (vector fixnum) rslt)) (declare (type (vector fixnum) rslt))
(do ((i a (1+ i)) (do ((i a (1+ i))
(mark 0 (1+ mark))) (mark 0 (1+ mark)))
((> i b)) ((> i b))
(declare (fixnum i mark)) (declare (fixnum i mark))
(setf (aref rslt mark) i)) (setf (aref rslt mark) i))
rslt))) rslt)))
(DEFUN SRANDOM (max) (DEFUN SRANDOM (max)
(declare (fixnum max)) (declare (fixnum max))
(the fixnum (the fixnum
(let ((rslt (- (random (+ max max)) max))) (let ((rslt (- (random (+ max max)) max)))
(declare (fixnum rslt)) (declare (fixnum rslt))
(if (zerop rslt) (if (zerop rslt)
max max
rslt)))) rslt))))
(DEFUN CLOCK () (DEFUN CLOCK ()
(multiple-value-bind (sec min hour day month year) (multiple-value-bind (sec min hour day month year)
(get-decoded-time) (get-decoded-time)
(format t "~%;; Clock -> ~4D-~2,'0D-~2,'0D, ~Dh ~Dm ~Ds.~%" (format t "~%;; Clock -> ~4D-~2,'0D-~2,'0D, ~Dh ~Dm ~Ds.~%"
year month day hour min sec)) year month day hour min sec))
(values)) (values))
#| #|
(clock)) (clock))
|# |#
(DEFUN DONE () (DEFUN DONE ()
(format t "~%---done---") (format t "~%---done---")
(values)) (values))
#| #|
(done)) (done))
|# |#