; -------------------------------------------------------
;
; 	Implementation d'une couche objets en Lisp
;
;	F. Balmas				17/11/97
;
; -------------------------------------------------------

; un objet racine avec methode de creation d'instance
; + les methodes standard pour les instances
(de init-objet ()
	(put 'objet 'nom 'objet)
	(put 'objet 'herite-de nil)
	(put 'objet 'sous-classes (list '*>))
	(put 'objet 'instances nil)
	(put 'objet 'methodes '(
		; creation d'instance
		(newI (lambda (Obj i)
			(or i (setq i (gensym))) 	; Obj)))
			(put i 'nom i)
			(put i 'inst-de Obj)
			(nconc (get Obj 'instances) (list i))
			(put i 'methodes (get Obj 'methodI))
			(put i 'variables (mapcar (get Obj 'varI) 
				(lambda (v) (list v nil)) ))
			(-> i 'init)
			i
			))
		; affichage par defaut d'une classe
		(print (lambda (Obj)
			(print Obj)
			(prin1 "sous-classe de ")(print (get Obj 'herite-de))
			(print 'varI) (pretty (get Obj 'varI)) (terpri)
			(print 'methodC) (pretty (get Obj 'methodes)) (terpri)
			(print 'methodI) (pretty (get Obj 'methodI)) (terpri)
			))
		))
	(put 'objet 'methodI '(
		; acces en lecture a une variable
		(getvar (lambda (Obj v)
				(cadr (assq v (get Obj 'variables)))
			))
		; acces en ecriture a une variable
		(putvar (lambda (Obj var val)
				(rplaca (cdr (assq var (get Obj 'variables))) val)
			))
		; methode par defaut d'initialisation d'instance
		(init (lambda (Obj) t))
		; affichage par defaut d'une instance
		(print (lambda (Obj)
			(print Obj)
			(prin1 "instance-de ")(print (get Obj 'inst-de)) 
			(print 'variables) (pretty (get Obj 'variables)) (terpri)
			(print 'methodes)(pretty (get Obj 'methodes)) (terpri)
			))
		))
	'objet
	)

; creation/definition de classes
(de defclasse (nom herit varI varC meth)
	(put nom 'nom nom)
	(put nom 'herite-de herit)
	(nconc (get herit 'sous-classes) (list nom))
	(put nom 'instances (list '*>))
	(put nom 'sous-classes (list '*>))
	(put nom 'methodI (nconc meth (get herit 'methodI)))
	(put nom 'methodes (get 'objet 'methodes))
	(put nom 'varI (nconc varI (get herit 'varI))) 
; 	(put nom 'varC varC)
	nom
)	

; l'envoi de message
(de -> (Obj mess . args)
	(let ((meth (assq mess (get Obj 'methodes)) ))
		(if meth
			(apply (cadr meth) (cons Obj args))
			(erreur mess Obj args)
		)
	)
)

; provoque une erreur Lisp
(de erreur (m o a)
	(%ubf 'error-methode (list 'methode m) a nil (list 'objet o)) )

; un macro-caractere pour simplifier le code ...
(dmc \: () (list '-> 'Obj ''getvar (list 'quote (read))))

; et pour demarrer, initialisation de la hierarchie
(init-objet)

; --------------------------------------------------------------
; en guise de documentation
; -------------------------

; un objet est un atome, ses champs sont enregistres dans la p-liste

; champs des classes
'(	(nom <classe c>)
	(herite-de <super-classe>)
	(sous-classes <liste des sous-classes>)
	(instances <liste des instances>)
	(methodI <a-liste des methodes d'instance>)
	(methodes <a-liste des methodes de classe>)
	(varI <liste des variables d'instances>)
; 	(varC <a-liste des variables de classe>)
; ceci n'est pas implemente dans cette version
)

; champs des instances
'(	(nom <instance i>)
	(inst-de <classe>)
	(methodes <a-liste de methodes>)
	(variables <a-liste des variables d'instances>)
)

; ---------------------------------------------------
; et pour continuer ...
; ---------------------

; gerer des variables de classe
; permettre la definition de nouvelles methodes de classe

; questions ouvertes :
; 	pb de la quotation des arguments
; 	version "fonctionnelle" des objets, pour eviter l'envoi
;		de message explicite ?


; ---------------------------------------------------