; ------ pretty-print, par [pg]
;	transformation en evaluateur 24.3.02 (hw)

 (setq --x-- careful careful nil)

(df pretty (l)(goPretty)
  (setq activity 'prettyFtn)
  (mapc l (lambda (f) (terpri) (pprint f)))
  )

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

(de pprint (f ;; x)
  (status print 3)      ; bit 0 : '"' , bit 1 : pas d'espace.
  (setq lmargin 0)
  (setq x (cdr (assoc (ftyp f) '((7 . de) (8 . df) (9 . macro)))))
  (and x (interprete [x f .(fval f)]))
  (terpri)
  (status print 0)
  f)

(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 goSymEval ()
 ; pour initialiser l'ensemble des fonctionalites
 ; pour l'interprete symbolique
  (de casNil () ())
  (de casAtom () (let (val (assoc l al)) (if val (cadr val) l)))
  (de casQuote () l)	
  (de casLambda ()
	     (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)
  (de 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 '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 goPretty ()
 ; pour initialiser l'ensemble des fonctionalites
 ; pour le pretty-print
(de initializeInterprete ()
   (status print 3) ; pour les appels externes ; )

(de casNil () (princh "()"))	
(de casAtom () (prin1 l))
(de casQuote () (princh "'")(interprete (cadr l)))
(de casLambda ()
	     (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 ()  (setq xx (outpos))(princh "("))
(de exitGeneralCase (x)
	    (and l (princh " . ") (princh l))
	    (princh ")"))


(de defaultCase ()
    (t+3) (interprete (nextl l))(while (listp l) (p-p1)) (t-3))
	    
(defmacro p-p1 () '(progn (princh " ") (interprete (nextl l))))

(defmacro t+3 () '(setq lmargin (+ lmargin 3)))
(defmacro t-3 () '(setq lmargin (- lmargin 3)))

(defmacro  p-progn (?)
  `(if (and (null (cdr l)) (null ,?))
      (p-p1)    ; un seul argument
      (t+3)     ; plusieurs
      (while (listp l)
             (if (> lmargin (outpos)) (outpos lmargin)
                 (terpri))
             (interprete (nextl l)))
      (t-3)))

(defmacro p-cond ()'(progn
  (t+3)
  (while (listp l)
    (terpri)
    (princh "(")
    (let (l (nextl l))
      (interprete (nextl l)) (if l (p-progn)))
    (princh ")"))
  (t-3)))

(mapc '(progn           ; type progn
  prog1 and exit or) (lambda (x) 
	(put x 'prettyFtn '(lambda () (interprete (nextl l)) (p-progn)))))

(mapc '(lambda          ; type while
  escape if ifn let mapc mapcar while until) (lambda (x) 
	 (put x 'prettyFtn '(lambda () 
		(interprete (nextl l)) (p-p1)(p-progn t)))))

(mapc '(de              ; type def
  df dm dmc) (lambda (x) (put x 'prettyFtn 
	'(lambda () (interprete (nextl l))
		   (p-p1)(p-p1) (p-progn t)))))

(mapc '(cond            ; type cond
  ) (lambda (x) (put x 'prettyFtn '(lambda ()
	(interprete (nextl l))
	(p-cond)))))

(mapc '(selectq         ; type selectq
  ) (lambda (x) (put x 'prettyFtn '(lambda ()
	(interprete (nextl l))
	(p-p1) (p-cond))))))

(setq careful --x--)