;;;
;;; Corrigé partiel de l'examen de programmation fonctionnelle proposé
;;;  par Myriam de Sainte-Catherine au semestre I2, le 8 juin 2005.
;;;   Paul Y Gloess, http://www.enseirb.fr/~gloess
;;;
(in-package :common-lisp-user)

;;; Exercice 1:

(defparameter a 0)

(let ((b 0))
  (defun f (m)
    (+ a b m)))

;;; Exercice 2:

(defmacro increment (x)
  (incf x))

;;; Exercice 3:

(block int
  (defparameter *count* 0)
  (defun int ()
    (declare (special *count*))
    (incf *count*)))

;;; Autre solution, avec environnement lexical:
(let ((count 0))
  (defun int ()
    (incf count)))

(defmacro generator (fname vname init-form &body forms)
  "Expands into code for initializing global variable VNAME
    to INIT-FORM, and a function named FNAME, whose body is 
    FORMS."
  `(block ,fname
      (defparameter ,vname ,init-form)
      (defun ,fname ()
	(declare (special ,vname))
	. ,forms)))

;;; Autre solution, conception lexicale:
(defmacro generator (fname vname init-form &body forms)
  "Expands into code for setting up a lexical environment
    with variable VNAME bound to INIT-FORM, and defining
    a function name FNAME with body FORMS."
  `(let ((,vname ,init-form))
      (defun ,fname ()
	. ,forms)))

;;; (generator int i 0 (print i) (setf i (1+ i)))

;;; Exercice 4:

(defun e1 (l)
  (when l
    (let ((word (car l)))
      (cond ((or (= word 1) (= word 2))
	     (e2 (cdr l)))
	    ((= word 3)
	     (e3 (cdr l)))
	    (t nil)))))

(defun e2 (l)
  (when l
    (let ((word (car l)))
      (cond ((= word 1)
	     (e1 (cdr l)))
	    ((or (= word 2) (= word 3))
	     (e3 (cdr l)))
	    (t nil)))))

(defun e3 (l)                        ; we assume E3 is the only final state.
  (or (null l)
      (let ((word (car l)))
	(cond ((= word 1)
	       (e1 (cdr l)))
	      ((or (= word 2) (= word 3))
	       (e2 (cdr l)))
	      (t nil)))))

(defun reconnu (l i)
  (funcall i l))

;;; (reconnu '(1 1 2 2) #'e1)

;;; (reconnu '(1 3) #'e1)

;;; (reconnu '(1 4) #'e1)

;;; (reconnu '(1 1 2) #'e1)

;;; Exercice 4 avec les remplacements suggérés (1 -> a, 2 -> b, 3 -> c):

(defun qa (l)
  (when l
    (case (car l)
       ((a b)
	(qb (cdr l)))
       (c (qc (cdr l)))
       (t nil))))

(defun qb (l)
  (when l
    (case (car l)
      (a (qa (cdr l)))
      ((b c) (qc (cdr l)))
      (t nil))))

(defun qc (l)     ; we assume QC is the only final state.
  (or (null l)
      (case (car l)
	(a (qa (cdr l)))
	((b c) (qb (cdr l)))
	(t nil))))

(defun reconnu (l i)
  (funcall i l))

;;; (reconnu '(a a b b) #'qa)

;;; (reconnu '(a c) #'qa)

;;; (reconnu '(a d) #'qa)

;;; (reconnu '(a a b) #'qa)


;;; Exercice 5:

(defun make-polynome (coefficients degrees)
  "Makes up a polynome from a list of COEFFICIENTS and a list of
    corresponding DEGREES."
  (mapcar #'make-monome coefficients degrees))

(defun monome-degree (monome)
  "Returns MONOME's degree."
  (cdr monome))

(defun monome-coefficient (monome)
  "Returns MONOME's coefficient."
  (car monome))

(defun make-monome (coefficient degree)
  "Makes up a monome from its COEFFICIENT and DEGREE."
  (cons coefficient degree))

(defun normalize (polynome)
  "Assuming POLYNOME is a list of MONOMEs (see make-monome),
   with no two monomes with same degree,
   returns an equivalent polynome in normal form:
   - monomes are ordered by strictly decreasing degree,
   - there are no leading zero coefficients (first monome has non zero
      coefficient)."
  (remove-leading-zeros (sort (copy-list polynome) #'> :key #'monome-degree)))

(defun ndegree (normal-polynome)
  "Assuming NORMAL-POLYNOME is a polynome in normal form,
    returns its degree."
  (if normal-polynome
      (monome-degree (car normal-polynome))
    -1))

(defun degree (polynome)
  "Returns the degree of POLYNOME."
  (ndegree (normalize polynome)))

(defun +polynome (polynome1 polynome2)
  "Returns the sum of POLYNOME1 and POLYNOME2."
  (+normal-polynome (normalize polynome1) (normalize polynome2)))

(defun remove-leading-zeros (monomes)
  (when monomes
    (let ((monome (car monomes)))
      (if (zerop (monome-coefficient monome))
	  (remove-leading-zeros (cdr monomes))
	monomes))))

(defun +normal-polynome (normal-polynome1 normal-polynome2)
  "Returns the sum of NORMAL-POLYNOME1 and NORMAL-POLYNOME2,
    assumed to be in normal form. The resulting polynome
    is ordered but may have leading zeros."
  (let ((degree1 (ndegree normal-polynome1))
	(degree2 (ndegree normal-polynome2)))
    (cond ((and (>= degree1 0)(= degree1 degree2))
	   (cons (+same-degree-monome (car normal-polynome1) (car normal-polynome2))
		 (+normal-polynome (remove-leading-zeros (cdr normal-polynome1))
				   (remove-leading-zeros (cdr normal-polynome2)))))
	  ((and (< degree1 0) (< degree2 0))
	   ())
	  ((> degree1 degree2)
	   (cons (car normal-polynome1)
		 (+normal-polynome (remove-leading-zeros (cdr normal-polynome1))
				   normal-polynome2)))
	  (t (+normal-polynome normal-polynome2 normal-polynome1)))))

(defun +same-degree-monome (monome1 monome2)
  "Assuming MONOME1 and MONOME2 are monomes of equal degrees,
    returns their sum as a monome."
  (make-monome (+ (monome-coefficient monome1) (monome-coefficient monome2))
	       (monome-degree monome1)))

(defparameter p1 (make-polynome '(1 2 3) '(1 3 4)))
(defparameter p2 (make-polynome '(3 1 2) '(0 1 4)))

;;; (+polynome p1 p2)