;*******************************************************************************
;                                   UNITES.LSP                      "22/11/2000"
; Definition de la classe UNITE permettant d'acceder aux objets par leur nom
;*******************************************************************************

; Package pour utiliser CLOS
(use-package "CLOS")

; Definition de la classe Unite

(defclass unite ()
   ((nom :accessor nom :initarg :nom :type symbol))
   (:documentation "les unites sont des objets accessibles par leur nom"))


; Encapsulation d'une variable nommee "les-unites" stockant toutes les 
; instances des classes heritant de Unite
; La valeur de la variable les-unites est formee de couple "nom-instance"
; Sa structure est celle d'une table de hashage qui permet d'acceder rapidement
; a une instance (ou objet) a partir de son nom
; Sont egalement definies les fonctions ayant droit d'acces a cette variable

(let ((les-unites (make-hash-table)))
  
  (defun reset-unites (&rest l)
    "supprime toutes les unites ou celles des classes indiquees"
    (if l
        (maphash #'(lambda (key val)
                           (if (loop for domaine in l 
                                     thereis (typep val domaine))
                               (remhash key les-unites)))
                   les-unites)
        (setf les-unites (make-hash-table))))
     
  (defun une-unite (nom objet)
    "associe un nom et un objet dans la table des unites"
    (setf (gethash nom les-unites) objet))

  (defmethod suicide ((oself unite))
    "enleve un objet de la table des unites"
    (remhash (nom oself) les-unites))

  (defmethod suicide ((oself symbol))
    "enleve un objet de la table des unites"
    (remhash oself les-unites))
     
  (defun l-objet (nom) 
    "retourne l'objet associe a un nom dans la table des unites"
    (gethash nom les-unites))
   
  (defun lister (&optional (domaine t))
     "permet de lister toutes les unites de la table qui sont dans un domaine 
       de types"
     (maphash #'(lambda (key val)
                        (declare (ignore key))
                        (if (typep val domaine) (print val)))
                les-unites))
   
  (defun les-noms (&optional (domaine t))
     "retourne la liste des noms des unites de la table qui sont dans un 
      domaine de types"
     (let ((liste ()))
          (maphash #'(lambda (key val)
                             (if (typep val domaine) (push key liste)))
                     les-unites)
          liste))
)


; Definition d'un reflexe declenche lors de la creation d'une instance
; Les instances n'ayant pas de noms fournis dans les parametres sont
; nommees automatiquement. Ce nom sera obtenu en concatenant le nom de la
; classe de l'instance et un numero genere par le systeme a l'aide de la 
; fonction gentemp 

(defmethod initialize-instance :after ((oself unite) &rest initargs)
   (declare (ignore initargs))
   (unless (slot-boundp oself 'nom)
           (setf (nom oself)
                 (gentemp (format nil "~s" (type-of oself)))))
   (une-unite (nom oself) oself))


;******************************************************************************

; Quelques exemples de methodes definies pour la classe unite

; Affichage specifique

(defmethod print-object :before ((x unite) flot)
   (format flot "#<~a : ~a" (type-of x) (nom x)))

(defmethod print-object ((x unite) flot)
   (declare (ignore flot)))

(defmethod print-object :after ((x unite) flot)
   (format flot ">"))


; Test d'egalite d'instances (meme nom)

(defgeneric meme (oself autre)
  (:documentation "une fonction qui prolonge l'egalite")
  (:method (oself autre) (equal oself autre)))

(defmethod meme ((oself unite) (autre unite))
  (equal (nom oself) (nom autre)))

;******************************************************************************

; Definition d'un macro-caractere simplifiant l'utilisation de la classe Unite

; ! pour l-objet
; exemple d'utilisation : !cube1 (cube1 est une instance de la classe cube)

(defun point-d-exclamation (flot char)
  (declare (ignore char))
  `(l-objet ',(read flot t nil t)))
    
(set-macro-character #\! #'point-d-exclamation)
    
;******************************************************************************

; Definition d'une methode permettant d'interfacer la fonction Describe 
; quelque soit le type de l'argument

(defun |??| (oself &optional (stream t))
   (cond ((l-objet oself) (describe (l-objet oself) stream))
         ((and (symbolp oself) (find-class oself))
          (print-object (find-class oself) stream))
         ((clos::class-p oself)
          (print-object oself stream))
         (t (describe oself stream))))

; definition du macro-caratere ? remplacant l'appel de la fonction ??
; exemples d'utilisation : ?unite ou ?"chaine"
(defun point-d-interrogation (flot char)
  (declare (ignore char))
  `(|??| ',(read flot t nil t)))
    
(set-macro-character #\? #'point-d-interrogation)
                                                  
;**************************************************************************