;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*

;;;  CLASSIFYING-SPACES  CLASSIFYING-SPACES  CLASSIFYING-SPACES
;;;  CLASSIFYING-SPACES  CLASSIFYING-SPACES  CLASSIFYING-SPACES
;;;  CLASSIFYING-SPACES  CLASSIFYING-SPACES  CLASSIFYING-SPACES

(IN-PACKAGE #:cat)

(provide "classifying-spaces")

#-sbcl (DEFINE-CONSTANT +NULL-GBAR+ (make-gbar :dmns 0 :list +empty-list+))
#+sbcl (DEFPARAMETER +NULL-GBAR+ (make-gbar :dmns 0 :list +empty-list+))

(DEFUN GBAR-PRINT (gbar stream depth)
  (declare
   (type gbar gbar) (stream stream)
   (ignore depth))
  (the gbar
       (progn
         (princ "<<GBar" stream)
         (dolist (absm (gbar-list gbar))
           (declare (type absm absm))
           (with-absm (dgop gmsm) absm
                      (format stream "<~A ~A>"
                              (hyphenize-list (dgop-int-ext dgop))
                              gmsm)))
         (princ ">>" stream)
         gbar)))

;;; NIGBAR = non-normalized igbar (with dimension)

(DEFUN NORMALIZE-GBAR (nigbar)
  (declare (list nigbar))
  (the absm
       (let ((dmns (first nigbar))
             (igbar (rest nigbar)))
         (declare
          (fixnum dmns)
          (list igbar))
         (when (zerop dmns)
           (return-from normalize-gbar (absm 0 +null-gbar+)))
         (do ((mark igbar (cdr mark))
              (indx (1- dmns) (1- indx))
              (2-indx (2-exp (1- dmns)) (ash 2-indx -1))
              (mask (mask (1- dmns)) (ash mask -1))
              (and-dgops -1 (logand and-dgops (dgop (car mark))))
              ;; r = result
              (r-dgop 0)
              (r-absm-list +empty-list+))
             ((endp mark)
              (absm r-dgop
                    (make-gbar
                     :dmns (- dmns (logcount r-dgop))
                     :list (nreverse r-absm-list))))
           (declare
            (list mark r-absm-list)
            (fixnum indx 2-indx mask and-dgops r-dgop))
           (when (zerop and-dgops)
             (return-from normalize-gbar
               (absm r-dgop
                     (make-gbar
                      :dmns (- dmns (logcount r-dgop))
                      :list (nreconc r-absm-list mark)))))
           (let ((absm (car mark)))
             (with-absm
                 (dgop gmsm) absm
                 (declare (ignore gmsm))
                 (if (and (= dgop mask)
                          (logbitp indx and-dgops))
                     (progn
                       (incf r-dgop 2-indx)
                       (mapl
                        #'(lambda (sublist)
                            (declare (list sublist))
                            (setf (car sublist)
                                  (let ((absm (car sublist)))
                                    (declare (type absm absm))
                                    (with-absm
                                        (dgop gmsm) absm
                                        (absm (multiple-value-bind (q r)
                                                  (floor dgop 2-indx)
                                                (declare (fixnum q r))
                                                (+ (ash (1- q) (1- indx)) r))
                                              gmsm)))))
                        r-absm-list))
                     (push absm r-absm-list))))))))


(DEFUN UNNORMALIZE-GBAR (absm idnt)
  (declare
   (type absm absm)
   (type gmsm idnt))
  (the list ;; igbar
       (with-absm (dgop gbar) absm
                  (with-gbar (dmns list) gbar
                             (setf list (reverse list))
                             (do ((dgop2 dgop (ash dgop2 -1))
                                  (indx 0 (1+ indx))
                                  (2-indx 1 (ash 2-indx 1))
                                  (dgop3 0)
                                  (rslt +empty-list+))
                                 ((zerop dgop2)
                                  (cons (+ dmns (logcount dgop))
                                        (nreconc
                                         (mapcar
                                          #'(lambda (absm)
                                              (declare (type absm absm))
                                              (ndgnr dgop3 absm))
                                          list)
                                         rslt)))
                               (declare
                                (list rslt)
                                (fixnum dgop2 2-indx dgop3))
                               (if (oddp dgop2)
                                   (progn
                                     (push (absm (mask indx) idnt) rslt)
                                     (incf dgop3 2-indx))
                                   (push (ndgnr dgop3 (pop list)) rslt)))))))


(DEFUN GBAR (dmns &rest rest)
  (the gbar
       (progn
         (unless (= (+ dmns dmns) (length rest))
           (error "In GBAR, the argument list has a wrong length."))
         (make-gbar :dmns dmns
                    :list (do ((mark rest (cddr mark))
                               (rslt +empty-list+
                                     (cons (absm (car mark) (cadr mark))
                                           rslt)))
                              ((endp mark) (nreverse rslt))
                            (declare (list mark rslt)))))))


(DEFUN CLASSIFYING-SPACE-CMPR (cmpr)
  (declare (type cmprf cmpr))
  (flet ((rslt (gbar1 gbar2)
           (declare (type gbar gbar1 gbar2))
           (maplexico
            #'(lambda (absm1 absm2)
                (declare (type absm absm1 absm2))
                (a-cmpr3 cmpr absm1 absm2))
            (gbar-list gbar1) (gbar-list gbar2))))
    (the cmprf #'rslt)))


(DEFUN CLASSIFYING-SPACE-BASIS (basis)
  (declare (type basis basis))
  (when (eq basis :locally-effective)
    (return-from classifying-space-basis :locally-effective))
  (let ((crts-basis :locally-effective)  ;; to be redefined
        (idnt (first (funcall basis 0))))
    (declare
     (type basis crts-basis)
     (type gmsm idnt))
    (labels
        ((rslt (dmns)
           (declare (fixnum dmns))
           (when (minusp dmns)
             (return-from rslt +empty-list+))
           (when (zerop dmns)
             (return-from rslt (list +null-gbar+)))
           (let ((basis-1 (funcall crts-basis (1- dmns))))
             (declare (list basis-1))
             (nreverse
              (mapcar  ;; xxx bug
               #'(lambda (crpr)
                   (declare (type crpr crpr))
                   (with-crpr
                       (absm1 absm2) crpr
                       (make-gbar
                        :dmns dmns
                        :list (cons absm1
                                    (rest (unnormalize-gbar absm2 idnt))))))
               (member-if  ;; xxx bug
                #'(lambda (dgop)
                    (declare (fixnum dgop))
                    (< dgop (mask (1- dmns))))
                (reverse basis-1)
                :key #'dgop1))))))
;;;                  :key #'caadr))))))
      (setf crts-basis (crts-prdc-basis basis #'rslt))
      (the basis #'rslt))))


(DEFUN CLASSIFYING-SPACE-FACE (face sintr-grml)
  (declare
   (type face face)
   (type sintr sintr-grml))
  (flet ((rslt (indx dmns gbar)
           (declare
            (fixnum indx dmns)
            (type gbar gbar))
           (when (= indx dmns)
             (return-from rslt
               (normalize-gbar (cons (1- dmns) (rest (gbar-list gbar))))))
           (do ((mark (gbar-list gbar) (cdr mark))
                (dmns2 (1- dmns) (1- dmns2))
                (rslt +empty-list+
                      (cons (a-face4 face indx dmns2 (car mark))
                            rslt)))
               ((= dmns2 indx)
                (if (zerop indx)
                    (normalize-gbar (cons (1- dmns) (nreverse rslt)))
                    (normalize-gbar
                     (cons (1- dmns)
                           (nreconc
                            rslt
                            (cons (a-grml4 sintr-grml (1- indx)
                                           (second mark)
                                           (a-face4 face indx indx
                                                    (first mark)))
                                  (nthcdr 2 mark))))))))))
    (the face #'rslt)))


(DEFGENERIC CLASSIFYING-SPACE (smgr))

(DEFMETHOD CLASSIFYING-SPACE ((smgr simplicial-group))
  (the simplicial-set
       (build-smst :cmpr (classifying-space-cmpr (cmpr smgr))
                   :basis (classifying-space-basis (basis smgr))
                   :bspn +null-gbar+
                   :face (classifying-space-face (face smgr) (sintr (grml smgr)))
                   :orgn `(classifying-space ,smgr))))


(DEFUN CLASSIFYING-SPACE-GRML-SINTR (idnt sintr-grml)
  (declare
   (type gmsm idnt)
   (type sintr sintr-grml))
  (flet ((rslt (dmns crpr)
           (declare
            (fixnum dmns)
            (type crpr crpr))
           (with-crpr (absm1 absm2) crpr
                      (let ((absm-list-1 (rest (unnormalize-gbar absm1 idnt)))
                            (absm-list-2 (rest (unnormalize-gbar absm2 idnt))))
                        (declare (list absm-list-1 absm-list-2))
                        (normalize-gbar
                         (cons dmns
                               (mapcar
                                #'(lambda (absm1 absm2)
                                    (declare (type absm absm1 absm2))
                                    (decf dmns) ;; !!
                                    (a-grml4 sintr-grml dmns absm1 absm2))
                                absm-list-1 absm-list-2)))))))
    (the sintr #'rslt)))


(DEFUN CLASSIFYING-SPACE-GRIN-SINTR (sintr-grin)
  (declare (type sintr sintr-grin))
  (flet ((rslt (dmns gbar)
           (declare
            (fixnum dmns)
            (type gbar gbar))
           (absm 0
                 (make-gbar
                  :dmns dmns
                  :list (mapcar
                         #'(lambda (absm)
                             (declare (type absm absm))
                             (a-grin4 sintr-grin dmns absm))
                         (gbar-list gbar))))))
    (the sintr #'rslt)))


(DEFMETHOD CLASSIFYING-SPACE ((smgr ab-simplicial-group))
  (the ab-simplicial-group
       (change-class
        (build-smgr :cmpr (classifying-space-cmpr (cmpr smgr))
                    :basis (classifying-space-basis (basis smgr))
                    :bspn +null-gbar+
                    :face (classifying-space-face (face smgr)
                                                  (sintr (grml smgr)))
                    :sintr-grml (classifying-space-grml-sintr
                                 (bspn smgr)
                                 (sintr (grml smgr)))
                    :sintr-grin (classifying-space-grin-sintr
                                 (sintr (grin smgr)))
                    :orgn `(classifying-space ,smgr))
        'ab-simplicial-group)))