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

337
src/classes.lisp
View File

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

767
src/combinations.lisp
View File

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

580
src/macros.lisp
View File

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

103
src/various.lisp
View File

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