;;;  DELTA  DELTA  DELTA  DELTA  DELTA  DELTA  DELTA  DELTA  DELTA
;;;  DELTA  DELTA  DELTA  DELTA  DELTA  DELTA  DELTA  DELTA  DELTA
;;;  DELTA  DELTA  DELTA  DELTA  DELTA  DELTA  DELTA  DELTA  DELTA

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

(PROVIDE "delta")

(DEFMETHOD PRINT-KEYCONS ((car (eql :delt)) cdr stream)
   (format stream "~A" (hyphenize-list (dlop-int-ext cdr)))
   (cons car cdr))

(DEFUN SOFT-DELTA-CMPR (gmsm1 gmsm2)
   (f-cmpr (cdr gmsm1) (cdr gmsm2)))

#|
()
(soft-delta-cmpr (d 12) (d 23))
|#
   
(DEFUN DELTA-FACE (indx dmns gmsm)
   (declare
      (fixnum indx gmsm)
      (ignore dmns))
   (the absm
      (do ((pmark 1 (ash pmark 1))
           (bmark indx)
           (gmsm2 gmsm (ash gmsm2 -1)))
          (nil)
         (declare (fixnum pmark bmark gmsm2))
         (when (oddp gmsm2)
            (when (minusp (decf bmark))
               (return-from delta-face (absm 0 (logxor gmsm pmark))))))))

(DEFUN SOFT-DELTA-FACE (indx dmns gmsm)
   (declare
      (fixnum indx dmns)
      (type soft-dlop gmsm))
   (absm 0 (d (gmsm (delta-face indx dmns (cdr gmsm))))))

#|
()
(dotimes (i 4)
  (print (dlop-int-ext (gmsm (delta-face i 3 (dlop-ext-int '(0 1 2 3)))))))
(dotimes (i 4)
  (print (dlop-int-ext (gmsm (delta-face i 3 (dlop-ext-int '(0 2 4 6))))))))
(dotimes (i 4)
  (print (soft-delta-face i 3 (d (mask 4)))))
(dotimes (i 4)
  (print (soft-delta-face i 3 (d (dlop-ext-int '(0 2 4 6))))))
|#

(DEFUN DELTA-BNDR (dmns gmsm)
   (declare (fixnum dmns gmsm))
   (the cmbn
      (if (zerop dmns)
         +zero-negative-cmbn+
         (make-cmbn
            :degr (1- dmns)
            :list (do ((rslt +empty-list+)
                      (gmsm2 gmsm (ash gmsm2 -1))
                      (pmark 1 (ash pmark +1))
                      (sign 1))
                     ((zerop gmsm2) rslt)
                    (declare
                       (list rslt)
                       (fixnum gmsm2 pmark sign))
                    (when (oddp gmsm2)
                       (push (term sign (logxor gmsm pmark)) rslt)
                       (setf sign (- sign))))))))

(DEFUN SOFT-DELTA-BNDR (dmns gmsm)
   (declare
      (fixnum dmns)
      (type soft-dlop gmsm))
   (make-cmbn
      :degr (1- dmns)
      :list (mapcar #'(lambda (term)
                         (with-term (cffc gmsm) term
                            (term cffc (d gmsm))))
               (cmbn-list (delta-bndr dmns (cdr gmsm))))))

#|
()
(delta-bndr 0 4)
(delta-bndr 1 3)
(delta-bndr 1 5)
(delta-bndr 1 10)
(delta-bndr 5 63)
(soft-delta-bndr 5 (d (mask 6)))
|#


(DEFUN DELTA-DGNL (dmns gmsm)
   (declare (fixnum dmns gmsm))
   (the cmbn
      (make-cmbn
         :degr dmns
         :list (do ((rslt +empty-list+)
                    (ldegr dmns)
                    (indx (1- (integer-length gmsm)) (1- indx)))
                   ((minusp indx))
                  (declare
                     (list rslt)
                     (fixnum indx))
                  (when (logbitp indx gmsm)
                     (push (term 1 (tnpr
                                    ldegr (logand gmsm (mask (1+ indx)))
                                    (- dmns ldegr) (logandc2 gmsm (mask indx))))
                        rslt)
                     (when (minusp (decf ldegr))
                        (return rslt)))))))

(DEFUN SOFT-DELTA-DGNL (dmns gmsm)
   (declare
      (fixnum dmns)
      (type soft-dlop gmsm))
   (make-cmbn :degr dmns
      :list (mapcar
               #'(lambda (term)
                    (with-term (cffc tnpr) term
                       (with-tnpr (degr1 gmsm1 degr2 gmsm2) tnpr
                          (term cffc
                             (tnpr degr1 (d gmsm1) degr2 (d gmsm2))))))
               (cmbn-list (delta-dgnl dmns (cdr gmsm))))))

#|
()
(delta-dgnl 3 15)
(delta-dgnl 3 170)
(soft-delta-dgnl 3 (d (dlop-ext-int '(1 3 5 7))))
(delta-dgnl 0 64)
|#
                                        
(DEFUN DELTA-INFINITY ()
   (the simplicial-set
      (build-smst
         :cmpr #'f-cmpr
         :basis :locally-effective
         :bspn 1
         :face #'delta-face
         :intr-dgnl #'delta-dgnl
         :dgnl-strt :gnrt
         :intr-bndr #'delta-bndr
         :bndr-strt :gnrt
         :orgn '(delta-infinity))))

#|
()
(cmpr (delta-infinity) 2 4)
(cmpr (delta-infinity) 4 4)
(cmpr (delta-infinity) 8 4)
(basis (delta-infinity) 1)   ;;; => error
(face (delta-infinity) 1 2 21)
(cprd (delta-infinity) 3 15)
(dgnl (delta-infinity) 3 15)
(? (delta-infinity) 2 21)
|#

(DEFUN SOFT-DELTA-INFINITY ()
   (the simplicial-set
      (build-smst
         :cmpr #'soft-delta-cmpr
         :basis :locally-effective
         :bspn (d 1)
         :face #'soft-delta-face
         :intr-dgnl #'soft-delta-dgnl :dgnl-strt :gnrt
         :intr-bndr #'soft-delta-bndr :bndr-strt :gnrt
         :orgn '(soft-delta-infinity))))

#|
()
(cat-init)
(cmpr (soft-delta-infinity) (d 2) (d 4))
(face (soft-delta-infinity) 1 2 (d (dlop-ext-int '(1 3 5))))
(cprd (soft-delta-infinity) 3 (d 15))
(dgnl (soft-delta-infinity) 3 (d 15))
(? (soft-delta-infinity) 2 (d (dlop-ext-int '(0 2 4))))
|#

(DEFUN DELTA-N-BASIS (n)
   (declare (fixnum n))
  (flet ((rslt (dmns)
               (declare (fixnum dmns))
             (when (> dmns n)
                (return-from rslt +empty-list+))
             (setf dmns (1+ dmns))
             (do ((rslt +empty-list+)
                  (count (binomial-n-p (1+ n) dmns))
                  (gmsm (mask (1+ n)) (1- gmsm)))
                 ((zerop count) rslt)
                (when (= (logcount gmsm) dmns)
                   (push gmsm rslt)
                   (decf count)))))
      (the basis #'rslt)))

(DEFUN SOFT-DELTA-N-BASIS (n)
   (declare (fixnum n))
   (flet ((rslt (dmns)
             (when (> dmns n)
                (return-from rslt +empty-list+))
             (setf dmns (1+ dmns))
             (do ((rslt +empty-list+)
                  (count (binomial-n-p (1+ n) dmns))
                  (gmsm (mask (1+ n)) (1- gmsm)))
                 ((zerop count) rslt)
                (when (= (logcount gmsm) dmns)
                   (push (d gmsm) rslt)
                   (decf count)))))
      (the basis #'rslt)))
      

#|
()
(setf basis (delta-n-basis 3))
(setf soft-basis (soft-delta-n-basis 3))
(dotimes (i 5)
  (print (funcall basis i)))
(dotimes (i 5)
  (print (funcall soft-basis i)))
|#   

(DEFUN DELTA (dmns)
   (declare (fixnum dmns))
   (the simplicial-set
      (build-smst
         :cmpr #'f-cmpr
         :basis (delta-n-basis dmns)
         :bspn 1
         :face #'delta-face
         :intr-dgnl #'delta-dgnl
         :dgnl-strt :gnrt
         :intr-bndr #'delta-bndr
         :bndr-strt :gnrt
         :orgn `(delta ,dmns))))

#|
()
(cat-init)
(setf d3 (delta 3))
(cmpr d3 2 4)
(cmpr d3 4 4)
(cmpr d3 8 4)
(basis d3 1)
(dgnl d3 3 15)
(face d3 1 2 21)
(? d3 2 13)
(setf d (delta-infinity))
(basis d)
(setf d (delta-infinity)))
|#

(DEFUN SOFT-DELTA (dmns)
   (declare (fixnum dmns))
   (the simplicial-set
      (build-smst
         :cmpr #'soft-delta-cmpr
         :basis (soft-delta-n-basis dmns)
         :bspn (d 1)
         :face #'soft-delta-face
         :intr-dgnl #'soft-delta-dgnl :dgnl-strt :gnrt
         :intr-bndr #'soft-delta-bndr :bndr-strt :gnrt
         :orgn `(soft-delta ,dmns))))
      
#|
()
(cat-init)
(setf d3 (soft-delta 3))
(cmpr d3 (d 2) (d 4))
(basis d3 1)
(dgnl d3 3 (d 15))
(face d3 1 2 (d 21))
(? d3 2 (d 13))
|#

#| For comparison with EAT.
   In 
  (setf delta (delta-infinity))
  (setf d (bndr delta))
  (setf s14 (mask 15))
  (cmbn-? d (gnrt-? d 14 s14))
  (defun t1 (n)
     (time (dotimes (i n) (cmbn-? d (gnrt-? d 14 s14)))))
  (compile 't1)
  (t1 500)
  (setf +too-much-time+ -1)
  (t1 500)
|#
#|
  In EAT:
  (setf delta *delta*)
  (setf d (cc-d (ss-cc delta)))
  (setf s14 (<a-b> 0 14))
  (??? d (? d 14 s14))
  (defun t1 (n)
     (time (dotimes (i n) (??? d (? d 14 s14)))))
  (compile 't1)
  (t1 500)
|#

(DEFUN DELTAB-CMPR (gmsm1 gmsm2)
   (declare (fixnum gmsm1 gmsm2))
   (if (= 1 (logcount gmsm1))
      :equal
      (f-cmpr gmsm1 gmsm2)))

(DEFUN DELTAB-BNDR (dmns gmsm)
   (declare (fixnum dmns gmsm))
   (the cmbn
      (if (< dmns 2)
         (zero-cmbn (1- dmns))
         (make-cmbn
            :degr (1- dmns)
            :list (do ((rslt +empty-list+)
                      (gmsm2 gmsm (ash gmsm2 -1))
                      (pmark 1 (ash pmark +1))
                      (sign 1))
                     ((zerop gmsm2) rslt)
                    (declare
                       (list rslt)
                       (fixnum gmsm2 pmark sign))
                    (when (oddp gmsm2)
                       (push (term sign (logxor gmsm pmark)) rslt)
                       (setf sign (- sign))))))))

(DEFUN DELTAB2-FACE (indx dmns gmsm)
   (declare
      (fixnum indx dmns gmsm))
   (the absm
      (progn
	(when (= 2 dmns)
	   (return-from deltab2-face (absm 1 1)))
	(do ((pmark 1 (ash pmark 1))
	     (bmark indx)
	     (gmsm2 gmsm (ash gmsm2 -1)))
	    (nil)
	    (declare (fixnum pmark bmark gmsm2))
	    (when (oddp gmsm2)
		  (when (minusp (decf bmark))
			(return-from deltab2-face (absm 0 (logxor gmsm pmark)))))))))

(DEFUN DELTAB2-DGNL (dmns gmsm)
  (declare (fixnum dmns gmsm))
  (the cmbn
    (make-cmbn
     :degr dmns
     :list (if (zerop dmns)
               (list (term 1 (tnpr 0 gmsm 0 gmsm)))
             (do ((rslt +empty-list+)
                  (ldegr dmns)
                  (indx (1- (integer-length gmsm)) (1- indx)))
                 ((minusp indx))
               (declare (list rslt) (fixnum indx))
               (when (logbitp indx gmsm)
                 (push (term 1 (tnpr
                                ldegr (logand gmsm (mask (1+ indx)))
                                (- dmns ldegr) (logandc2 gmsm (mask indx))))
                       rslt)
                 (when (minusp (decf ldegr))
                   (setf rslt (delete 1 rslt :key #'caaddr))
                   (setf (gnrt1 (gnrt (first rslt)))
                     (setf (gnrt2 (gnrt (car (last rslt))))
                       1))				    
                   (return (delete 1 rslt :key #'cadddr)))))))))

#|
()
(dotimes (i 7)
  (print (deltab2-dgnl i (mask (1+ i)))))
|#
  

(DEFUN DELTAB2-BNDR (dmns gmsm)
   (declare (fixnum dmns gmsm))
   (the cmbn
      (if (< dmns 3)
         (zero-cmbn (1- dmns))
         (make-cmbn
            :degr (1- dmns)
            :list (do ((rslt +empty-list+)
                      (gmsm2 gmsm (ash gmsm2 -1))
                      (pmark 1 (ash pmark +1))
                      (sign 1))
                     ((zerop gmsm2) rslt)
                    (declare
                       (list rslt)
                       (fixnum gmsm2 pmark sign))
                    (when (oddp gmsm2)
                       (push (term sign (logxor gmsm pmark)) rslt)
                       (setf sign (- sign))))))))

#|
  (deltab-bndr 1 5)
  (deltab-bndr 3 15)
|#

(DEFUN DELTAB ()
  (the simplicial-set
   (build-smst
      :cmpr #'deltab-cmpr
      :basis :locally-effective
      :bspn 1
      :face #'delta-face
      :intr-dgnl #'delta-dgnl
      :dgnl-strt :gnrt
      :orgn '(deltab))))

(DEFUN DELTAB2 ()
  (the simplicial-set
     (build-smst
      :cmpr #'f-cmpr
      :basis :locally-effective
      :bspn 1
      :face #'deltab2-face
      :intr-dgnl #'deltab2-dgnl
      :dgnl-strt :gnrt
      :orgn '(deltab2))))