606 lines
20 KiB
Common Lisp
606 lines
20 KiB
Common Lisp
;;; CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES
|
|
;;; CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES
|
|
;;; CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES CHAIN-COMPLEXES
|
|
|
|
(IN-PACKAGE "COMMON-LISP-USER")
|
|
|
|
(PROVIDE "chain-complexes")
|
|
|
|
(DEFVAR *LIST-LIST* +empty-list+)
|
|
|
|
(DEFUN CAT-INIT ()
|
|
(declare (special *idnm-counter* *results-n* *results-cmlt-tm*))
|
|
(setf *idnm-counter* 0 *results-n* 0 *results-cmlt-tm* 0.0)
|
|
(map nil #'(lambda (listname)
|
|
(declare (symbol listname))
|
|
(setf (symbol-value listname) +empty-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))
|
|
|
|
(DEFUN ALL-OBJECTS ()
|
|
(let ((object-list
|
|
(sort (delete-duplicates
|
|
(mapcan #'(lambda (symbol)
|
|
(copy-list (eval symbol)))
|
|
*list-list*)
|
|
:test #'eq)
|
|
#'< :key #'idnm)))
|
|
(declare (list object-list))
|
|
(dolist (item object-list)
|
|
(format t "~%~A = ~A" item (orgn item))))
|
|
(done))
|
|
|
|
(DEFUN KD (idnm)
|
|
(declare (fixnum idnm))
|
|
(dolist (list *list-list*)
|
|
(let ((found (find idnm (eval list) :key #'idnm)))
|
|
(when found
|
|
(format t "~%Object: ~A
|
|
~3TOrigin: ~A~2%" found (orgn found))
|
|
(return-from kd (values))))))
|
|
|
|
(DEFUN K (idnm)
|
|
(declare (fixnum idnm))
|
|
(dolist (list *list-list*)
|
|
(let ((found (find idnm (eval list) :key #'idnm)))
|
|
(when found
|
|
(return-from k found)))))
|
|
|
|
(DEFUN KD2 (idnm)
|
|
(declare (fixnum idnm))
|
|
(let ((k-list (k idnm)))
|
|
(declare (list k-list))
|
|
(unless k-list
|
|
(return-from kd2 nil))
|
|
(setf k-list (list k-list))
|
|
(do ((idnm (1- idnm) (1- idnm)))
|
|
((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)))
|
|
(declare (type (or null chain-complex morphism) found))
|
|
(when found
|
|
(push (k idnm) k-list))))
|
|
(mapc #'kd (nreverse (mapcar #'idnm k-list)))))
|
|
|
|
|
|
(DEFVAR *CHCM-LIST*)
|
|
(SETF *CHCM-LIST* +empty-list+)
|
|
(PUSHNEW '*CHCM-LIST* *list-list*)
|
|
|
|
#+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)))
|
|
#+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)))
|
|
|
|
(DEFUN RESULT-PRINT (result stream depth)
|
|
(declare
|
|
(type result result) (stream stream)
|
|
(ignore depth))
|
|
(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)
|
|
|
|
|
|
#|
|
|
()
|
|
(make-result :gnrt 'a :value '(a a) :clnm 23 :rntm 2.345)
|
|
|#
|
|
|
|
(DEFPARAMETER +MAXIMAL-DIMENSION+ 15)
|
|
|
|
(DEFVAR *MRPH-LIST*)
|
|
(SETF *MRPH-LIST* +empty-list+)
|
|
(PUSHNEW '*MRPH-LIST* *list-list*)
|
|
|
|
(DEFMETHOD ?2 ((mrph morphism) 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)))
|
|
|
|
(DEFMETHOD ?3 ((mrph morphism) 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))
|
|
|
|
#+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))))
|
|
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)))
|
|
|
|
(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
|
|
(let ((already (find orgn *chcm-list* :test #'equal :key #'orgn)))
|
|
(declare (type (or chain-complex null) already))
|
|
(when already
|
|
(return-from build-chcm already)))
|
|
(unless basis
|
|
(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))))
|
|
|
|
(DEFUN BASIS2 (object n) ;;;
|
|
(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))
|
|
(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
|
|
(let ((already (find orgn *mrph-list* :test #'equal :key #'orgn)))
|
|
(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
|
|
;; (vector (vector result))
|
|
#'(lambda (dummy)
|
|
(declare (ignore dummy))
|
|
(make-array 0
|
|
:adjustable t
|
|
:fill-pointer 0))
|
|
(make-list +maximal-dimension+)))
|
|
(:cmbn nil)))
|
|
(push mrph *mrph-list*)
|
|
mrph))))
|
|
|
|
;;; FUNCTIONS
|
|
|
|
(DEFVAR *START-STACK* +empty-list+)
|
|
|
|
(DEFPARAMETER +TOO-MUCH-TIME+ -1)
|
|
|
|
(DEFVAR *RESULTS-MAX* (expt 10 5))
|
|
|
|
(DEFVAR *RESULTS-COEF* 3.0)
|
|
(DEFVAR *RESULTS-CMLT-TM* 0.0)
|
|
(DEFVAR *RESULTS-N* 0)
|
|
|
|
(DEFVAR *RESULTS-VERBOSE* t)
|
|
|
|
(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)))
|
|
|
|
(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 #'>))))
|
|
|
|
(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*)))))
|
|
|
|
|
|
|
|
|
|
(DEFUN MRPH-GNRT (cmpr2 intr degr gnrt memory &optional (left -1) (right (fill-pointer memory)))
|
|
(declare
|
|
(type intr-mrph intr)
|
|
;; (function (fixnum gnrt) cmbn)
|
|
(type cmprf cmpr2)
|
|
(fixnum degr left right)
|
|
(type gnrt gnrt)
|
|
(vector memory)
|
|
(special *results-n*)
|
|
(fixnum *results-n*))
|
|
;; (vector result)
|
|
(the (values cmbn fixnum)
|
|
;;; cmbn = image of the generator
|
|
;;; fixnum = index "exact" or just "lower" of the maybe stored result
|
|
(loop
|
|
(when (= right (1+ left)) ;; the result for gnrt is not available
|
|
(push (get-internal-run-time) *start-stack*)
|
|
(let ((value (funcall intr degr gnrt))
|
|
(runtime (- (get-internal-run-time) (pop *start-stack*))))
|
|
(declare
|
|
(type cmbn value)
|
|
(integer runtime))
|
|
(if (> runtime +too-much-time+)
|
|
;;; the condition deciding whether
|
|
;;; storing must happen
|
|
(let ((old-length (vector-push-extend nil memory)))
|
|
(declare (fixnum old-length))
|
|
(replace memory memory
|
|
:start1 (1+ right) :end1 (1+ old-length)
|
|
:start2 right :end2 old-length)
|
|
(setf (aref memory right)
|
|
(make-result
|
|
:gnrt gnrt :value value
|
|
:clnm 1
|
|
:rntm (let ((rntm
|
|
(float
|
|
(/ runtime internal-time-units-per-second))))
|
|
(declare (single-float rntm))
|
|
(incf *results-cmlt-tm* rntm)
|
|
rntm)))
|
|
(mapl #'(lambda (mark)
|
|
(declare (cons mark))
|
|
(incf (car mark) runtime))
|
|
*start-stack*)
|
|
(when (> (incf *results-n*) *results-max*)
|
|
(clean-results))
|
|
(return (values value right)))
|
|
(return (values value left)))))
|
|
(let ((middle (truncate (+ right left) 2)))
|
|
(declare (fixnum middle))
|
|
(ecase (funcall cmpr2 gnrt (result-gnrt (aref memory middle)))
|
|
(:equal (let ((rslt (aref memory middle)))
|
|
(declare (type cons rslt))
|
|
(incf (result-clnm rslt))
|
|
(return (values (result-value rslt) middle))))
|
|
(:less (setf right middle))
|
|
(:greater (setf left middle)))))))
|
|
|
|
|
|
(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)))))
|
|
|
|
(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)
|
|
|
|
#|
|
|
(do-control #'s-cmpr (cmbn 0 1 'a 1 'b -1 'c))
|
|
(do-control #'s-cmpr (cmbn 0 1 'b 1 'b -1 'c))
|
|
(do-control #'s-cmpr (cmbn 0 1 'a 1 'b -1 'b))
|
|
(setf *cmbn-control* nil)
|
|
(control #'s-cmpr (cmbn 0 1 'a 1 'b -1 'b))
|
|
(setf *cmbn-control* t)
|
|
(control #'s-cmpr (cmbn 0 1 'a 1 'b -1 'b))
|
|
|#
|
|
|
|
#|
|
|
(DEFVAR *PROFILER-STACK*)
|
|
(SETF *PROFILER-STACK* +empty-list+)
|
|
|
|
(DEFUN PROFILER-INIT ()
|
|
(mapc #'(lambda (mrph)
|
|
(declare (type morphism mrph))
|
|
(setf (wrtm mrph) 0))
|
|
*mrph-list*))
|
|
|
|
(DEFUN PROFILER-ON ()
|
|
(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)))
|
|
|#
|
|
|
|
(DEFVAR *FUTURE-DISPLAY* nil)
|
|
|
|
(DEFVAR *TIME-INTERVAL* 60000)
|
|
|
|
(DEFUN GNRT-? (mrph degr gnrt)
|
|
(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-?
|
|
~3T~A ORGN = ~A
|
|
~3TDEGR = ~D
|
|
~3TGNRT = ~A"
|
|
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)
|
|
))))))))
|
|
|
|
#|
|
|
()
|
|
(cat-init)
|
|
(setf cc (build-chcm :cmpr #'f-cmpr
|
|
:basis :locally-effective
|
|
:bsgn 0
|
|
:intr-dffr #'(lambda (cmbn)
|
|
(cmbn (1- (cmbn-degr cmbn))))
|
|
:strt :cmbn
|
|
:orgn '(Z of Z)))
|
|
(setf cc (build-chcm :cmpr #'f-cmpr
|
|
:basis :locally-effective
|
|
:bsgn 0
|
|
:intr-dffr #'(lambda (cmbn)
|
|
(cmbn (1- (cmbn-degr cmbn))))
|
|
:strt :cmbn
|
|
:orgn '(Z of Z)))
|
|
(setf ff (build-mrph :sorc cc :trgt cc :degr 0
|
|
:intr #'(lambda (degr n) (cmbn degr 1 n))
|
|
:strt :gnrt :orgn '(test)))
|
|
(setf ff (build-mrph :sorc cc :trgt cc :degr 0
|
|
:intr #'(lambda (degr n) (cmbn degr 1 n))
|
|
:strt :gnrt :orgn '(test)))
|
|
(dotimes (i 20)
|
|
(let ((n (- (random 50) 50)))
|
|
(format t "~%~D ~D" n (gnrt-? ff 0 n))))
|
|
(setf +too-much-time+ -1)
|
|
(dotimes (i 20)
|
|
(let ((n (- (random 50) 50)))
|
|
(format t "~%~D ~D" n (gnrt-? ff 0 n))))
|
|
(setf +too-much-time+ 50)
|
|
|#
|
|
|
|
(DEFUN CMBN-? (mrph cmbn)
|
|
(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-?
|
|
~3T~A ORGN = ~A
|
|
~3TCMBN = ~A"
|
|
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)
|
|
)))))))))
|
|
|
|
#|
|
|
()
|
|
(cat-init)
|
|
(setf cc (build-chcm :cmpr #'f-cmpr
|
|
:basis :locally-effective
|
|
:bsgn 0
|
|
:intr-dffr #'(lambda (cmbn)
|
|
(cmbn (1- (cmbn-degr cmbn))))
|
|
:strt :cmbn
|
|
:orgn '(Z of Z)))
|
|
(setf *n* 10)
|
|
(defun ff (degr i)
|
|
(do ((*2n* (ash *n* 1))
|
|
(rslt +empty-list+
|
|
(cons (cons (let ((cffc (- (random *2n*) *n*)))
|
|
(if (minusp cffc) cffc (1+ cffc)))
|
|
(decf gnrt (1+ (random *n*))))
|
|
rslt))
|
|
(gnrt i)
|
|
(k 0 (1+ k)))
|
|
((= k *n*)
|
|
(make-cmbn
|
|
:degr 0
|
|
:list rslt))))
|
|
(ff 0 20)
|
|
(compile 'ff)
|
|
(setf mrph (build-mrph :sorc cc :trgt cc :degr 0
|
|
:intr #'ff :strt :gnrt :orgn '(test)))
|
|
(cmbn-? mrph (cmbn 0 1 100))
|
|
(cmbn-? mrph *)
|
|
(cmbn-? mrph *)
|
|
(cmbn-? mrph *)
|
|
(cmbn-? mrph *)
|
|
(cmbn-? mrph *)
|
|
(time (cmbn-? mrph *))
|
|
(inspect mrph)
|
|
|#
|