; -------------------------------------------------------
;
; 	Implementation d'une couche de frames en Lisp
;
;	F. Balmas				13/1/98
;
; -------------------------------------------------------

; un frame racine 
(de init-frame ()
	(put 'frame 'nom 'frame)
	(put 'frame 'herite-de nil)
	(put 'frame 'sous-frames (list '*>))
	(put 'frame 'instances nil)
	(put 'frame 'slots '((nom)))
	'frame
	)

; creation/definition de frames
(de newF (nom herit slots)
	(put nom 'nom nom)
	(put nom 'herite-de herit)
	(nconc (get herit 'sous-frames) (list nom))
	(put nom 'instances (list '*>))
	(put nom 'sous-frames (list '*>))
	(put nom 'slots (nconc slots (get herit 'slots))) 
	nom
)	

; creation d'instances de frames
(de newI (f i)
   (if (null i)
       'ERREUR_il_faut_un_nom
       (progn
;	(or i (setq i (gensym)))
	(put i 'inst-de f)
	(nconc (get f 'instances) (list i))
	(put i 'slots (mapcar (get f 'slots) '(lambda (a)
		(if (null (cdr a))
		    (cons (car a) (list '-))
		    (cons (car a) (cons (cadr a) (cddr a))) )
		)))
	(putS i 'nom i)
	i))
)

; ecriture de valeurs dans les slots
; + execution des demons concernes
(de putS (i slot val s)
   	(setq s (assq slot (get i 'slots)))
   	(if (null s) 
	    'undefined-slot
	    (progn 
	    	(rplaca (cdr s) val) 
	    	(if (assq '+ (cddr s))
	      		(eval (cadr (assq '+ (cddr s)))) 
			t)
	    	val))
)

; lecture de valeurs de slots
; + execution des demons concernes
(de getS (i slot s val) 
   (if (not (assq slot (get i 'slots)))
	nil
	(progn 
	  (setq s (assq slot (get i 'slots)))
	  (setq val (cadr (assq slot (get i 'slots))))
	  (cond 
	      ((= val '-) 
		 (if (assq '- (cddr s))
		     (progn 
			(putS i slot (eval (cadr (assq '- (cddr s)))))
			(getS i slot) )
		     (if (assq '? (cddr s))
			 (progn (eval (cadr (assq '? (cddr s))))
			 	val)
			 val) ) )
	      ((= val '?)
		(prin1 'Valeur_pour_le_slot slot)
		(prin1 'de) 
		(prin1 i)
		(prin1 '>) 
		(putS i slot (read))
		(getS i slot) ) 
	      ((assq '? (cddr s))
		(eval (cadr (assq '? (cddr s))))
		val) 
	      (t val) ) 
	  ))
)


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

; --------------------------------------------------------------------------
; documentation
; -------------------------

; definition de slots
; -------------------
; demons 
;	+   whenFill		execute a l'ecriture de valeur dans un slot
;	?   whenRead		execute a la lecture d'un slot		
;	-   whenNeed		execute a la lecture d'un slot s'il est vide 
;				(pseudo-valeur  -)

; valeurs particulieres
;	-	absence de valeur
;	?	valeur a demander a l'utilisateur
;	<val>	valeur par defaut	


; structure des definitions de slots
; ----------------------------------

;  attribut ::=
;	(<nom du slot>)
;	| (<nom du slot> <valeur particuliere>)
;	| (<nom du slot> <valeur particuliere> . <liste de demons>)

;  demons ::=
;	(<symbolde de demon> <1 expression Lisp a evaluer>)

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