; ----- evaluateur partiel [hw]
;      adapte du  pretty-print de [pg]
;	 24.3.02 (hw)

 (setq --x-- careful careful nil)

(de symeval (exp)
  (setq activity 'symb)
  (let ((x exp) (y (interprete exp)))
	(if (equal x y) x (self y (interprete y) ))))

(de interprete (l ;; al xx)
   (initializeInterprete)
   (cond ((null l) (casNil))
	 ((atom l) (casAtom))
 	 ((and (eq (car l) quote) (null (cddr l)))
 		 (casQuote))
	 ((and (listp (car l)) (eq (caar l) lambda))
	     (casLambda))
	 (t (initGeneralCase) (let ((x
	    (let ((f (and (litatom (car l))(get (car l) activity))))
		(if f (apply f nil)
		    (defaultCase)))))
	    (exitGeneralCase x)))))

  (de casNil () ())
  (defmacro casAtom () `(let (val (assoc l al)) (if val (cadr val) l)))
  (defmacro casQuote () '(cadr l))	
  (defmacro casLambda () '(progn
	     (setq l ['let (let ((v (cadar l)) (a (cdr l)))
			(if (null v) nil
				(cons [(nextl v)(nextl a)] (self v a))))
			. (cddar l)])
	     (interprete l)))
  (de initGeneralCase () ())
  (de initializeInterprete () ())
  (de exitGeneralCase (x) x)
  (defmacro defaultCase () '(cond
     ((or (null (get (car l) 'body))(listp (car l)))
      (cons (interprete (nextl l) al) 
		(mapcar l '(lambda (x) (interprete x al)))))
    (t (let (largs (mapcar (cdr l) '(lambda (x) (interprete x al))))
          (let   (al1 (redpair (car l) (get (car l) 'vars) largs))
	       (if (eq al1 'no) (cons (car l) largs)
		 (interprete (get (car l) 'body) (nconc al1 al))))))))

(put 'cdr 'symb '(lambda () (let ((x (interprete (cadr l) al))) (cond
  ((null x) nil)
  ((equal (car x) 'cons)(caddr x))
  (t (list 'cdr x))))))
(put '1+ 'symb '(lambda () (let ((x (interprete (cadr l) al))) (cond
	((numbp x) (1+ x))
	((atom x) ['1+ x])
	((eq (car x) '1-) (cadr x))
	(t ['1+ x])))))
(put '1- 'symb '(lambda () (let ((x (interprete (cadr l) al))) (cond
	((numbp x) (1- x))
	((atom x) ['1- x])
	((eq (car x) '1+) (cadr x))
	(t ['1+ x])))))
(put 'zerop 'symb '(lambda () (let ((x (interprete (cadr l) al))) (cond
	((numbp x) (if (zerop x) t nil))
	((atom x) [zerop x])
	((eq (car x) '1+) nil)
	(t ['zerop x])))))
(put 'car 'symb '(lambda () (let ((x (interprete (cadr l) al)))(cond
  ((null x) nil)
  ((equal (car x) 'cons)(cadr x))
  (t (list 'car x))))))
(put 'null 'symb '(lambda () (let ((x (interprete (cadr l) al))) (cond
  ((null x) t)
  ((and (listp x) (eq (car x) 'cons)) nil)
  (t (list 'null x))))))
(put 'if 'symb '(lambda () (let ((x (interprete (cadr l) al) )) (cond
  ((or (eq x t) (and (listp x) (eq (car x) 'cons)))
	(interprete (caddr l) al))
  ((null x) (interprete (cadr (cddr l)) al))
  (t (cons 'null (cons x (cddr l))))))))
(put 'de 'symb '(lambda () (eval l) (analyse (cadr l)) (cadr l)))



(de analyse (f ;; x vars body decvars)
  (setq x (fval f) vars (car x) body (cadr x))
  (let (e body)(cond
	((atom e))
	((member (car e) '(car cdr 1-))
		(if (atom (cadr e))
		    (and (member (cadr e) vars)
			 (or (member (cadr e) decvars)(newl decvars (cadr e))))
		    (self (cadr e))))
	(t (self (nextl e)) (self e))))
  (put f 'vars vars)
  (put f 'body body)
  (put f 'decvars decvars))

; ---------- controleur de deploiement -----------

(de redpair (fun vars largs ;; decvars res v l)
  (setq decvars (get fun 'decvars))
  (while vars
    (setq v (nextl vars) l (nextl largs))
    (if (member v decvars)
        (and l (neq l 0)
               (neq (car l) 'cons) (neq (car l) '1+)
               (exit 'no)))
    (newl res [v l]))
  res)

(de app (x y) (if (null x) y (cons (car x) (app (cdr x) y))))
(analyse 'app)

(de rev (x) (if (null x) nil (app (rev (cdr x)) (cons (car x) nil))))
(analyse 'rev)

(de len (l) (if (null l) 0 (1+ (len (cdr l)))))
(analyse 'len)

(de p (x y) (if (zerop x) y (1+ (p (1- x) y))))
(analyse 'p)

(de m (x y) (if (zerop x) 0 (p y (1- x) y))))
(analyse 'm)
 
(de loop () (print "eval sym :") 
(let (x  (read))(if (null x) 'ok
(print (symeval x))  (print "eval sym :") 
(self (read)))))

(setq careful --x--)