;;;  DISK-PASTING  DISK-PASTING  DISK-PASTING  DISK-PASTING
;;;  DISK-PASTING  DISK-PASTING  DISK-PASTING  DISK-PASTING
;;;  DISK-PASTING  DISK-PASTING  DISK-PASTING  DISK-PASTING

(IN-PACKAGE "COMMON-LISP-USER")

(provide "disk-pasting")

(DEFUN DISK-PASTING-CMPR (cmpr new)
  (declare
    (type cmprf cmpr)
    (symbol new))
  (flet ((rslt (gnrt1 gnrt2)
	   (declare (type gnrt gnrt1 gnrt2))
	   (if (eq gnrt1 new)
	       (if (eq gnrt2 new)
		   :equal
		 :less)
	     (if (eq gnrt2 new)
		 :greater
	       (funcall cmpr gnrt1 gnrt2)))))
    (the cmprf #'rslt)))

#|
  (setf c (delta 3))
  (setf cmpr (disk-pasting-cmpr (cmpr c) 'new))
  (funcall cmpr 'new 'new)
  (funcall cmpr 'new 5)
  (funcall cmpr 5 'new)
  (funcall cmpr 5 5)
  (funcall cmpr 5 6)
  (funcall cmpr 6 5)
|#

(DEFUN DISK-PASTING-BASIS (basis dmns new)
  (declare
    (type basis basis)
    (fixnum dmns)
    (symbol new))
  (flet ((rslt (degr)
	   (declare (fixnum degr))
	   (if (= degr dmns)
	       (cons new (funcall basis dmns))
	     (funcall basis degr))))
    (the basis #'rslt)))

#|
  (setf c (delta 3))
  (setf basis (disk-pasting-basis (basis c) 3 'new))
  (funcall basis 3)
  (funcall basis 2)
|#

(DEFUN DISK-PASTING-INTR-DFFR (old-dffr degr new bndr)
  (declare
    (type morphism old-dffr)
    (fixnum degr)
    (symbol new)
    (type cmbn bndr))
  (when (cmbn-non-zero-p (cmbn-? old-dffr bndr))
    (error "In CHCM-DISK-PASTING, the given boundary has a non-null boundary."))
  (let ((cmpr (cmpr (trgt old-dffr))))
    (declare (type cmprf cmpr))
    (flet ((rslt (cmbn)
	     (declare (type cmbn cmbn))
	     (with-cmbn (degr2 list) cmbn
	       (unless (= degr degr2)
		 (return-from rslt
		   (cmbn-? old-dffr cmbn)))
	       (unless list
		 (return-from rslt
		   (zero-cmbn (1- degr))))
	       (unless (eq (-gnrt list) new)
		 (return-from rslt
		   (cmbn-? old-dffr cmbn)))
	       (2cmbn-add cmpr
		 (n-cmbn (-cffc list) bndr)
		 (cmbn-? old-dffr
			 (make-cmbn :degr degr
				    :list (rest list)))))))
      (the intr-mrph #'rslt))))

#|
  (cat-init)
  (setf c (delta 3))
  (setf intr (disk-pasting-intr-dffr (dffr c) 3 'new (cmbn 2 1 7)))
  (setf intr (disk-pasting-intr-dffr (dffr c) 3 'new (? c 3 15)))
  (funcall intr (cmbn 2 1 7))
  (funcall intr (cmbn 3))
  (funcall intr (cmbn 3 1 15))
  (funcall intr (cmbn 3 1 'new 1 15))
  (funcall intr (cmbn 3 1 'new -1 15))
  (funcall intr (cmbn 3 -1 'new 1 15))
  (funcall intr (cmbn 3 -1 'new -1 15))
|#
 
(DEFUN CHCM-DISK-PASTING (chcm dmns new bndr)
  (declare
    (type chain-complex chcm)
    (fixnum dmns)
    (symbol new)
    (type cmbn bndr))
  (the chain-complex
    (with-slots (cmpr basis dffr) chcm
      (declare
       (type cmprf cmpr)
       (type basis basis)
       (type morphism dffr))
      (let ((rslt (build-chcm
		   :cmpr (disk-pasting-cmpr cmpr new)
		   :basis (disk-pasting-basis basis dmns new)
		   :intr-dffr (disk-pasting-intr-dffr dffr dmns new bndr)
		   :strt :cmbn
		   :orgn `(chcm-disk-pasting ,chcm ,dmns ,new ,bndr))))
	(declare (type chain-complex rslt))
	(when (slot-boundp chcm 'bsgn)
	  (setf (slot-value rslt 'bsgn) (slot-value chcm 'bsgn)))
	rslt))))

#|
  (setf c (delta 3))
  (setf s3 (chcm-disk-pasting c 3 'new (? c 3 15)))
  (homology s3 0 5))
|#

(DEFUN DISK-PASTING-FACE (cmpr face dmns new faces)
  (declare
    (type cmprf cmpr)
    (type face face)
    (fixnum dmns)
    (symbol new)
    (list faces))
  (unless (= (1+ dmns) (length faces))
    (error "In DISK-PASTING, non-coherent arguments."))
  (mapl #'(lambda (mark)
	    (declare (list mark))
	    (unless (typep (car mark) 'absm)
	      (setf (car mark) (absm 0 (car mark)))))
	faces)
  (flet ((rslt (indx dmns2 gmsm)
	   (declare
	     (fixnum indx dmns2)
	     (type gmsm gmsm))
	   (unless (= dmns dmns2)
	     (return-from rslt
	       (funcall face indx dmns2 gmsm)))
	   (if (eq gmsm new)
	       (nth indx faces)
	     (funcall face indx dmns gmsm))))
    (unless (check-faces cmpr #'rslt dmns new)
      (error "The new simplicial-set is not constructed."))
    (the face #'rslt)))

#|
  (cat-init)
  (setf c (delta 3))
  (setf face (disk-pasting-face (cmpr c) (face c)
                3 'new (list 14 (absm 0 13) 11 7)))
  (funcall face 0 2 7)
  (funcall face 0 3 15)
  (dotimes (i 4) (print (funcall face i 3 'new)))
|#

(DEFUN DISK-PASTING (smst dmns new faces)
  (declare
    (type simplicial-set smst)
    (fixnum dmns)
    (symbol new)
    (list faces))
  (the simplicial-set
    (with-slots (cmpr basis bsgn face dffr) smst
      (declare
       (type cmprf cmpr)
       (type basis basis)
       (type gmsm bsgn)
       (type face face)
       (type morphism dffr))
      (let ((new-face (disk-pasting-face (cmpr smst) face
					 dmns new faces))
	    (new-bndr (zero-cmbn (1- dmns))))
	(declare
	  (type face new-face)
	  (type cmbn new-bndr))
	(do ((mark faces (cdr mark))
	     (sign 1 (- sign)))
	    ((endp mark))
	    (declare
	      (list mark)
	      (fixnum sign))
	  (let ((absm (car mark)))
	    (declare (type absm absm))
	    (with-absm (dgop gmsm) absm
	      (unless (plusp dgop)
		(dstr-add-term-to-cmbn cmpr sign gmsm new-bndr)))))
	(build-smst
	 :cmpr (disk-pasting-cmpr cmpr new)
	 :basis (disk-pasting-basis basis dmns new)
	 :bspn bsgn
	 :face new-face
	 :intr-bndr (disk-pasting-intr-dffr dffr dmns new new-bndr)
	 :bndr-strt :cmbn
	 :orgn `(disk-pasting ,smst ,dmns ,new ,faces))))))

#|
  (setf d2 (delta 2))
  (setf s2 (disk-pasting d2 2 'new '(6 5 3)))
  (homology s2 0 4)
  (setf s2xs2 (crts-prdc s2 s2))
  (homology s2xs2 0 6)
|#

(DEFUN MRPH-DISK-PASTING-INTR (mrph trgt-cmpr dmns new new-im)
  (declare
    (type morphism mrph)
    (type cmprf trgt-cmpr)
    (fixnum dmns)
    (symbol new)
    (type cmbn new-im))
  (let ((mrph-degr (degr mrph)))
    (declare (fixnum mrph-degr))
    (flet ((rslt (cmbn)
	     (declare (type cmbn cmbn))
	     (with-cmbn (degr list) cmbn
	       (unless (= degr dmns)
		 (return-from rslt
		   (cmbn-? mrph cmbn)))
	       (unless list
		 (return-from rslt
		   (zero-cmbn (+ degr mrph-degr))))
	       (unless (eq new (-gnrt list))
		 (return-from rslt
		   (cmbn-? mrph cmbn)))
	       (2cmbn-add trgt-cmpr
		 (n-cmbn (-cffc list) new-im)
		 (cmbn-? mrph
			 (make-cmbn :degr degr
				    :list (rest list)))))))
      (the intr-mrph #'rslt))))

#|
  (setf m (idnt-mrph (delta 3)))
  (setf intr
        (mrph-disk-pasting-intr m (cmpr (delta 3))
                                3 'new (cmbn 3 -1 15)))
  (funcall intr (cmbn 2 3 7))
  (funcall intr (cmbn 3))
  (funcall intr (cmbn 3 4 15))
  (funcall intr (cmbn 3 1 'new 1 15))
  (funcall intr (cmbn 3 -1 'new 1 15))
|#

(DEFUN MRPH-DISK-PASTING (mrph new-sorc new-trgt dmns new new-im)
  (declare
    (type morphism mrph)
    (type chain-complex new-sorc new-trgt)
    (fixnum dmns)
    (symbol new)
    (type cmbn new-im))
  (the morphism
    (build-mrph
      :sorc new-sorc :trgt new-trgt :degr (degr mrph)
      :intr (mrph-disk-pasting-intr mrph (cmpr new-trgt)
				    dmns new new-im)
      :strt :cmbn
      :orgn `(mrph-disk-pasting ,mrph ,new-sorc ,new-trgt
				,dmns ,new ,new-im))))

#|
  (setf d (delta 3))
  (setf m (idnt-mrph d))
  (setf sorc (chcm-disk-pasting d 3 'new (? d 3 15)))
  (setf nm (mrph-disk-pasting m sorc sorc 3 'new (cmbn 3 1 'new)))
  (? nm (cmbn 3 2 'new 3 15))
|#

(DEFUN HMEQ-DISK-PASTING (hmeq dmns new bndr &key new-lbcc)
  (declare
    (type homotopy-equivalence hmeq)
    (fixnum dmns)
    (symbol new)
    (type cmbn bndr)
    (type (or null chain-complex) new-lbcc))
  (let* ((lg (lg hmeq))
	 (rf (rf hmeq))
	 (rh (rh hmeq))
	 (t-bndr (cmbn-? lg bndr))
	 (rb-bndr (cmbn-? rf t-bndr))
	 (new-lbcc (or new-lbcc
		       (chcm-disk-pasting (lbcc hmeq)
					  dmns new bndr)))
	 (new-tcc (chcm-disk-pasting (tcc hmeq)
				      dmns new t-bndr))
	 (new-rbcc (chcm-disk-pasting (rbcc hmeq)
				      dmns new rb-bndr))
	 (1+dmns (1+ dmns)))
    (declare
      (type morphism lg rf rh)
      (type cmbn t-bndr rb-bndr)
      (type chain-complex new-lbcc new-tcc new-rbcc)
      (fixnum 1+dmns))
    (build-hmeq
      :lrdct (build-rdct
	       :f (mrph-disk-pasting (lf hmeq) new-tcc new-lbcc
				     dmns new (cmbn dmns 1 new))
	       :g (mrph-disk-pasting lg new-lbcc new-tcc
				     dmns new (cmbn dmns 1 new))
	       :h (mrph-disk-pasting (lh hmeq) new-tcc new-tcc
				     dmns new (zero-cmbn 1+dmns)))
      :rrdct (build-rdct
	       :f (mrph-disk-pasting rf new-tcc new-rbcc
				     dmns new (cmbn dmns 1 new))
	       :g (mrph-disk-pasting (rg hmeq) new-rbcc new-tcc
				     dmns new
				     (make-cmbn
				      :degr dmns
				      :list (cons (term 1 new)
						  (cmbn-list
						   (cmbn-opps
						    (cmbn-? rh t-bndr))))))
	       :h (mrph-disk-pasting rh new-tcc new-tcc
				     dmns new (zero-cmbn 1+dmns)))
      :orgn `(hmeq-disk-pasting ,hmeq ,dmns ,new ,bndr))))
				     
#|
(cat-init)
(setf tcc
      (build-chcm
       :cmpr #'s-cmpr
       :basis #'(lambda (degr)
		  (case degr
			(0 (list 'a))
			(1 (list 'b))
			(otherwise nil)))
       :intr-dffr #'(lambda (degr gnrt)
		      (if (= 1 degr)
			  (cmbn 0 1 'a)
			(zero-cmbn (1- degr))))
       :strt :gnrt
       :orgn '(z-z)))
(setf bcc
      (build-chcm
       :cmpr #'s-cmpr
       :basis #'(lambda (degr) nil)
       :intr-dffr #'(lambda (degr gnrt) (error "Impossible."))
       :strt :gnrt
       :orgn '(zero)))
(setf rh (build-mrph
	  :sorc tcc :trgt tcc :degr +1
	  :intr #'(lambda (degr gnrt)
		    (if (zerop degr)
			(cmbn 1 1 'b)
		      (zero-cmbn 2)))
	  :strt :gnrt
	  :orgn '(rh)))
(setf hmeq (build-hmeq
	    :lrdct (trivial-rdct tcc)
	    :rrdct (build-rdct
		    :f (zero-mrph tcc bcc 0)
		    :g (zero-mrph bcc tcc 0)
		    :h rh
		    :orgn '(rrdct))))
(setf nhmeq (hmeq-disk-pasting hmeq 1 'new (cmbn 0 1 'a)))
(pre-check-rdct (lrdct nhmeq))
(setf *tc* (cmbn 0 1 'a))
(setf *bc* *tc*)
(check-rdct)
(setf *tc* (cmbn 1 1 'new 10 'b))
(setf *bc* *tc*)
(check-rdct)
(pre-check-rdct (rrdct nhmeq))
(setf *bc* (zero-cmbn 0))
(check-rdct)
(setf *tc* (cmbn 0 1 'a))
(check-rdct)
|#

(DEFMETHOD SEARCH-EFHM (smst (orgn (eql 'disk-pasting)))
  (declare (type simplicial-set smst))
  (the homotopy-equivalence
    (destructuring-bind (old-smst dmns new faces) (rest (orgn smst))
			(declare
			  (type simplicial-set old-smst)
			  (fixnum dmns)
			  (symbol new)
			  (ignore faces))
      (hmeq-disk-pasting (efhm old-smst)
			 dmns new (? smst dmns new)
			 :new-lbcc smst))))

#|
(cat-init)
(setf d (delta 2))
(setf s2 (disk-pasting d 2 'new '(6 5
  3)))
(homology s2 0 4)
|#