;;;  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 ()
   (setf *idnm-counter* 0)
   (mapc #'(lambda (listname)
              (declare (symbol listname))
              (set listname +empty-list+))
      *list-list*))

(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))

(DEFVAR *CHCM-LIST*)
(SETF *CHCM-LIST* +empty-list+)
(PUSHNEW '*CHCM-LIST* *list-list*)

(DEFMETHOD PRINT-OBJECT ((chcm chain-complex) stream)
 (the chain-complex
   (progn
      (format stream "[K~D Chain-Complex]" (idnm chcm))
      chcm)))

(DEFUN CHCM (idnm)
   (declare (fixnum idnm))
   (the (or chain-complex null)
      (find idnm *chcm-list* :key #'idnm)))

;;; Result = (:rslt gnrt value clnm rntm . prpr)

(DEFMETHOD PRINT-KEYCONS ((key (eql :rslt)) cdr stream)
   (the list
      (progn
         (setf cdr (cons key cdr))
         (format stream "~%~@
                     ~4TGNRT-> ~A~@
                         ~3TVALUE-> ~A~@
                         ~4TCLNM-> ~6D~@
                         ~4TRNTM-> ~11,3F"
            (rslt-gnrt cdr) (rslt-value cdr)
            (rslt-clnm cdr) (rslt-rntm cdr))
         cdr)))

#|
  (make-rslt :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))

(DEFMETHOD PRINT-OBJECT ((mrph morphism) stream)
   (the morphism
      (progn
    (if (eq (first (orgn (trgt mrph))) 'z-chcm)
        (format stream "[K~D Cohomology-Class (degree ~D)]"
            (idnm mrph) (- (degr mrph)))
      (format stream "[K~D Morphism (degree ~D)]"
          (idnm mrph) (degr mrph)))
         mrph)))

(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 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)

(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))
   ;; (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-rslt
                              :gnrt gnrt :value value
                              :clnm 1
                              :rntm (float (/ runtime internal-time-units-per-second))))
                     (mapl #'(lambda (mark)
                                (declare (cons mark))
                                (incf (car mark) runtime))
                        *start-stack*)
                     (return (values value right)))
                  (return (values value left)))))
         (let ((middle (truncate (+ right left) 2)))
            (declare (fixnum middle))
            (ecase (funcall cmpr2 gnrt (rslt-gnrt (aref memory middle)))
               (:equal (let ((rslt (aref memory middle)))
              (declare (type cons rslt))
              (incf (rslt-clnm rslt))
              (return (values (rslt-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 scmpr))
            (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))
|#


Home page.