;;;  CLASSES  CLASSES  CLASSES  CLASSES  CLASSES  CLASSES  CLASSES
;;;  CLASSES  CLASSES  CLASSES  CLASSES  CLASSES  CLASSES  CLASSES
;;;  CLASSES  CLASSES  CLASSES  CLASSES  CLASSES  CLASSES  CLASSES

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

(PROVIDE "classes")

;;;
;;; VARIOUS
;;;

(DEFTYPE ANY () t)

;;;
;;;  COMBINATIONS
;;;

;; CFFC = CoeFFiCient
(DEFUN CFFC-P (object)
   (declare (type any object))
   (the boolean
      (and (typep object 'fixnum)
           (/= 0 object))))

(DEFTYPE CFFC () '(satisfies cffc-p))

;; GNRT = GeNeRaTor
(DEFTYPE GNRT () 'any)

;; CMPR = CoMPaRison
(DEFTYPE CMPR () '(member :less :equal :greater))

;; CMPRF = CoMPaRison Function
(DEFTYPE CMPRF () 'function)
               ;; (function (gnrt gnrt) cmpr)

(DEFUN TERM-P (object)
   (declare (type any object))
   (the boolean
      (and (consp object)
           (typep (car object) 'cffc)
           (typep (cdr object) 'gnrt))))

(DEFTYPE TERM () '(satisfies term-p))

;; ICMBN = Internal-CoMBiNation
(DEFUN ICMBN-P (object)
   ;; ICMBN = Internal CoMBiNation,
   ;;   without the keyword and the degree
   (declare (type any object))
   (the boolean
      (and (listp object)
           (every #'term-p object))))

(DEFTYPE ICMBN () '(satisfies icmbn-p))

;; CMBN = CoMBiNation
(DEFUN CMBN-P (object)
   (declare (type any object))
   (the boolean
      (and (consp object)
           (eql (car object) :cmbn)
           (consp (cdr object))
           (typep (second object) 'fixnum)
           (typep (cddr object) 'icmbn))))

(DEFTYPE CMBN () '(satisfies cmbn-p))

(DEFTYPE BASIS () '(or function (eql :locally-effective)))
                   ;; (function (degr) (list gnrt))

;; INTR-MRPH = INTeRnal-MoRPHism
(DEFTYPE INTR-MRPH () 'function)
               ;; (or (function (degr gnrt) cmbn)  ;; if :gnrt strategy
               ;;     (function (cmbn) (cmbn))     ;; if :cmbn strategy

(DEFCLASS CHAIN-COMPLEX () ())  ;; will be redefined later.

(DEFCLASS MORPHISM () ())  ;; will be redefined later.

(DEFCLASS HOMOTOPY-EQUIVALENCE () ())  ;;  will be redefined later

;;  IDNM = IDentification NuMber
(DEFVAR *IDNM-COUNTER*)
(SETF *IDNM-COUNTER* 0)

(DEFCLASS CHAIN-COMPLEX ()
    ((cmpr :type cmprf :initarg :cmpr :reader cmpr1)
     (basis :type basis :initarg :basis :reader basis1)
     ;; BaSe GeNerator
     (bsgn :type gnrt :initarg :bsgn :reader bsgn)
     ;; DiFFeRential
     (dffr :type morphism :initarg :dffr :reader dffr1)
     ;; GRound MoDule
     (grmd :type chain-complex :initarg :grmd :reader grmd)
     ;; EFfective HoMology
     (efhm :type homotopy-equivalence :initarg :efhm :reader efhm)
     ;; IDentification NuMber
     (idnm :type fixnum :initform (incf *idnm-counter*) :reader idnm)
     ;; ORiGiN
     (orgn :type list :initarg :orgn :reader orgn)))

;; STRT = STRaTegy
(DEFTYPE STRT () '(member :gnrt :cmbn))

(DEFCLASS MORPHISM ()
     ;; SOuRCe
    ((sorc :type chain-complex :initarg :sorc :reader sorc)
     ;; TaRGeT
     (trgt :type chain-complex :initarg :trgt :reader trgt)
     ;; DEGRee
     (degr :type fixnum :initarg :degr :reader degr)
     ;; INTeRnal
     (intr :type intr-mrph :initarg :intr :reader intr)
     ;; STRaTegy
     (strt :type strt :initarg :strt :reader strt)
;;     ;; WoRk-TiMe
;;     (wrtm :type integer :initform 0 :accessor wrtm)
     ;; CaLl NuMber
     (???-clnm :type fixnum :initform 0 :accessor ???-clnm)
     (?-clnm :type fixnum :initform 0 :accessor ?-clnm)
     ;; ReSuLTS
     (rslts :type simple-vector
        ;; (vector (vector result))
        :reader rslts)
     ;; IDentification NuMber
     (idnm :type fixnum :initform (incf *idnm-counter*) :reader idnm)
     ;; ORiGiN
     (orgn :type list :initarg :orgn :reader orgn)))

;;;
;;;  EFFECTIVE HOMOLOGY
;;;

(DEFCLASS REDUCTION ()
     ;; Top Chain Complex
    ((tcc :type chain-complex :initarg :tcc :reader tcc1)
     ;; Bottom Chain Complex
     (bcc :type chain-complex :initarg :bcc :reader bcc1)
     (f :type morphism :initarg :f :reader f1)
     (g :type morphism :initarg :g :reader g1)
     (h :type morphism :initarg :h :reader h1)
     ;; IDentification NuMber
     (idnm :type fixnum :initform (incf *idnm-counter*) :reader idnm)
     ;; ORiGiN
     (orgn :type list :initarg :orgn :reader orgn)))

(DEFCLASS HOMOTOPY-EQUIVALENCE ()
     ;; Left Bottom Chain Complex
    ((lbcc :type chain-complex :initarg :lbcc :reader lbcc1)
     ;; Top Chain Complex
     (tcc  :type chain-complex :initarg :tcc  :reader tcc1)
     ;; Bottom Right Chain Complex
     (rbcc :type chain-complex :initarg :rbcc :reader rbcc1)
     ;; Left f
     (lf   :type morphism      :initarg :lf   :reader lf1)
     ;; Left g
     (lg   :type morphism      :initarg :lg   :reader lg1)
     ;; Left h
     (lh   :type morphism      :initarg :lh   :reader lh1)
     ;; Right f
     (rf   :type morphism      :initarg :rf   :reader rf1)
     ;; Right g
     (rg   :type morphism      :initarg :rg   :reader rg1)
     ;; Right h
     (rh   :type morphism      :initarg :rh   :reader rh1)
     ;; Left ReDuCTion
     (lrdct :type reduction    :initarg :lrdct :reader lrdct)
     ;; Right ReDuCTion
     (rrdct :type reduction    :initarg :rrdct :reader rrdct)
     ;; IDentification NuMber
     (idnm :type fixnum :initform (incf *idnm-counter*) :reader idnm)
     ;; ORiGiN
     (orgn :type list          :initarg :orgn :reader orgn)))

;;;
;;;  CONES
;;;

;; BICN = bicone
(DEFUN BICN-P (object)
   (declare (type any object))
   (the boolean
      (and (consp object)
           (typep (car object) '(member :bcnb :bcnc :bcnd))
           (typep (cdr object) 'gnrt))))

(DEFTYPE BICN () '(satisfies bicn-p))

;;;
;;;  TENSOR PRODUCTS
;;;

(DEFUN TNPR-P (object)
   (declare (type any object))
   (the boolean
      (and (consp object)
           (eql :tnpr (car object))
           (consp (cdr object))
           (consp (cadr object))
           (consp (cddr object))
           (typep (caadr object) 'fixnum)
           (typep (caddr object) 'fixnum))))

(DEFTYPE TNPR () '(satisfies tnpr-p))

;;;
;;;  COALGEBRAS
;;;

(DEFCLASS COALGEBRA (chain-complex)
    ((cprd :type morphism :initarg :cprd :reader cprd1)))   ;; coproduct

;;;
;;;  COBAR
;;;

;; CBGN CoBar-GeNerator
(DEFUN CBGN-P (object)
   ;; CBGN = CoBar GeNerator
   (declare (type any object))
   (the boolean
      (and (consp object)
           (typep (car object) 'fixnum)      ;; degree *in* the cobar
           (typep (cdr object) 'gnrt))))

(DEFTYPE CBGN () '(satisfies cbgn-p))

;; IALLP = Internal-ALgebraic LooP
(DEFUN IALLP-P (object)
   (declare (type any object))
   (the boolean
      (and (listp object)
           (every #'cbgn-p object))))

(DEFTYPE IALLP () '(satisfies iallp-p))

;; ALLP = ALgebraic LooP
(DEFUN ALLP-P (object)
   ;; ALLP = ALgebraic LooP
   (declare (type any object))
   (the boolean
      (and (consp object)
           (eq :allp (car object))
           (typep (cdr object) 'iallp))))

(DEFTYPE ALLP () '(satisfies allp-p))

;;;
;;;  ALGEBRAS
;;;

(DEFCLASS ALGEBRA (chain-complex)
    ((aprd :type morphism :initarg :aprd :reader aprd1)))   ;; product


;;;
;;;  HOPH-ALGEBRAS
;;;

(DEFCLASS HOPF-ALGEBRA (coalgebra algebra)
  ())

;;;
;;;  BAR
;;;

;; BRGN BaR-GeNerator
(DEFUN BRGN-P (object)
   ;; BRGN = BaR GeNerator
   (declare (type any object))
   (the boolean
      (and (consp object)
           (typep (car object) 'fixnum)      ;; degree *in* the cobar
           (typep (cdr object) 'gnrt))))

(DEFTYPE BRGN () '(satisfies brgn-p))

;; IABAR = Internal-ALgebraic LooP
(DEFUN IABAR-P (object)
   (declare (type any object))
   (the boolean
      (and (listp object)
           (every #'brgn-p object))))

(DEFTYPE IABAR () '(satisfies iabar-p))

;; ABAR = ALgebraic BAR
(DEFUN ABAR-P (object)
   (declare (type any object))
   (the boolean
      (and (consp object)
           (eq :abar (car object))
           (typep (cdr object) 'iabar))))

(DEFTYPE ABAR () '(satisfies abar-p))

;;;
;;;  SIMPLICIAL SETS
;;;

;;  DGOP = DeGeneray OPerator
(DEFTYPE DGOP () `(integer 0 ,most-positive-fixnum))

;; GMSM = GeoMetric SiMplex
(DEFTYPE GMSM () 'gnrt)

;;  DLOP = DeL OPerator
(DEFTYPE DLOP () 'dgop)

;; IABSM = Internal ABstract SiMplex
(DEFUN IABSM-P (object)
  (declare (type any object))
  (the boolean
     (and (consp object)
      (typep (car object) 'dgop)
      (typep (cdr object) 'gmsm))))

(DEFTYPE IABSM () '(satisfies iabsm-p))

;; ABSM = ABstract SiMplex
(DEFUN ABSM-P (object)
   (declare (type any object))
   (the boolean
      (and (consp object)
           (eq :absm (car object))
           (typep (cdr object) 'iabsm))))


(DEFTYPE ABSM () '(satisfies absm-p))

(DEFTYPE FACE () 'function)
            ;;   (function (indx dmns gmsm) absm)

(DEFTYPE FACE* () 'function)
            ;;    (function (indx dmns gmsm) (or gmsm (eql :degenerate)))

(DEFCLASS SIMPLICIAL-SET (coalgebra)
    ((face :type face :initarg :face :reader face1)))

;;;
;;;  SPECIAL SMSTS
;;;

;;  DLOP = DeL OPerator
(DEFUN SOFT-DLOP-P (object)
   (declare (type any object))
   (the boolean
      (and (consp object)
           (eq :delt (car object))
           (typep (cdr object) 'dgop))))

(DEFTYPE SOFT-DLOP () '(satisfies soft-dlop-p))

;;;
;;;  CARTESIAN PRODUCTS
;;;

;;  CRPR = CaRtesian PRoduct
(DEFUN CRPR-P (object)
   (declare (type any object))
   (the boolean
      (and (consp object)
           (eq (car object) :crpr)
           (consp (cdr object))
           (consp (cadr object))
           (consp (cddr object))
           (typep (caadr object) 'dgop)
           (typep (cdadr object) 'gmsm)
           (typep (caddr object) 'dgop)
           (typep (cdddr object) 'gmsm))))

(DEFTYPE CRPR () '(satisfies crpr-p))

;;;
;;;  LOOP SPACES
;;;

;;  EXPN = EXPoNent
(DEFUN EXPN-P (object)
   (declare (type any object))
   (the boolean
      (typep object '(and fixnum
                          (not (eql 0))))))

(DEFTYPE EXPN () '(satisfies expn-p))

;;  POWR = POWeR
(DEFUN POWR-P (object)
   (declare (type any object))
   (the boolean
      (and (consp object)
           (typep (car object) 'gmsm)
           (typep (cdr object) 'expn))))

(DEFTYPE POWR () '(satisfies powr-p))

;;  APOWR = Abstract POWeR
(DEFUN APOWR-P (object)
   (declare (type any object))
   (the boolean
      (and (consp object)
           (typep (car object) 'dgop)
           (typep (cdr object) 'powr))))

(DEFTYPE APOWR () '(satisfies apowr-p))

;;  ILOOP = Internal LOOP
(DEFUN ILOOP-P (object)
   (declare (type any object))
   (the boolean
      (and (listp object)
           (every #'apowr-p object))))

(DEFTYPE ILOOP () '(satisfies iloop-p))

(DEFUN LOOP-P (object)
   (declare (type any object))
   (the boolean
      (and (consp object)
           (eq :loop (car object))
           (iloop-p (cdr object)))))

#+(and allegro unix)
  (eval-when (:compile-toplevel :load-toplevel :execute)
     (setf excl:*enable-package-locked-errors* nil))

(DEFTYPE LOOP () '(satisfies loop-p))

#+(and allegro unix)
  (eval-when (:compile-toplevel :load-toplevel :execute)
     (setf excl:*enable-package-locked-errors* t))

;;;;
;;;;
;;;;

(DEFTYPE KFLL () 'function)
              ;; (function (indx dmns (list absm)) absm)

(DEFCLASS KAN (simplicial-set)
  ((kfll :type kfll :initarg :kfll :reader kfll1)))

(DEFTYPE SINTR () 'function)
               ;; (function (dmns gmsm) absm)

(DEFCLASS SIMPLICIAL-MRPH (morphism)
  ((sintr :type sintr :initarg :sintr :reader sintr)))

(DEFUN FIBRATION-P (object)
  (declare (type any object))
  (the boolean
     (and (typep object 'simplicial-mrph)
      (= -1 (degr object)))))

(DEFTYPE FIBRATION ()
  '(satisfies fibration-p))

(DEFCLASS SIMPLICIAL-GROUP (kan hopf-algebra)
   ((grml :type simplicial-mrph :initarg :grml :reader grml1)
    (grin :type simplicial-mrph :initarg :grin :reader grin1)))

(DEFCLASS AB-SIMPLICIAL-GROUP (simplicial-group) ())

(DEFMACRO GRML (smgr &rest rest)
   (ecase (length rest)
      (0 `(grml1 ,smgr))
      ((1 2) `(? (grml1 ,smgr) ,@rest))))

(DEFMACRO GRIN (smgr &rest rest)
   (case (length rest)
      (0 `(grin1 ,smgr))
      (otherwise `(? (grin1 ,smgr) ,@rest))))

;;;
;;;  GBAR
;;;

;;  IGBAR Internal Geometrical BAR
;;  (dmns absm_(m-1) ... absm_1 absm_0)
(DEFUN IGBAR-P (object)
   (declare (type any object))
   (the boolean
      (and (listp object)
       (typep (first object) '(integer 0 *))
       (= (length object) (1+ (first object)))
       (every #'absm-p (rest object)))))

(DEFTYPE IGBAR () '(satisfies igbar-p))

;;  GBAR Geometrical BAR
;;  (:gbar dmns absm_(m-1) ... absm_1)
(DEFUN GBAR-P (object)
   (declare (type any object))
   (the boolean
      (and (consp object)
           (eq :gbar (car object))
           (igbar-p (cdr object)))))

(DEFTYPE GBAR () '(satisfies gbar-p))






Home page.