;;; Exercice 1 (defun flatten-ops (assoc-ops expr) (if (atom expr) expr (let ((op (car expr)) (args (mapcar (lambda (arg) (flatten-ops assoc-ops arg)) (cdr expr)))) (cons op (if (member op assoc-ops) (let ((newargs '())) (dolist (arg args (nreverse new)) (if (or (atom arg) (not (eq (car arg) op))) (push arg new) (dolist (e (cdr arg)) (push e new))))) args))))) ;; ou plus simple mais moins efficace ;; recursif (defun flatten-ops (assoc-ops expr) (if (endp assoc-ops) expr (flatten-ops2 (cdr assoc-ops) (flatten-op (car assoc-ops) expr)))) ;; iteratif (defun flatten-ops (assoc-ops expr) (dolist (op assoc-ops expr) (setf expr (flatten-op op expr)))) ;;; Exercice 2 ;; 2.1 (defclass word () ((word-letters :initform '() :initarg :word-letters :reader word-letters))) ;; 2.2 (defmethod make-word ((letters list)) (make-instance 'word :word-letters letters)) ;; 2.3 (defmethod word= ((word1 word) (word2 word)) (every #'letter= (word-letters word1) (word-letters word2))) ;; 2.4 (defmethod alphabet ((word word)) (make-alphabet (word-letters word))) ;; 2.5 (defmethod make-word :before ((letters list)) (assert (every #'letterp letters))) ;;; Exercice 3 ;; 3.1 (LET ((G N)) (COND ((PLUSP G) E1) ((ZEROP G) E2) (T E3))) T ;; 3.2 capture de la variable g ;; 3.3 (defmacro numerical-if (expr pos zero neg) (let ((g (gensym))) `(let ((,g ,expr)) (cond ((plusp ,g) ,pos) ((zerop ,g) ,zero) (t ,neg))))) ;;; Exercice 4 ;; 4.1 (defmacro condv (v defaut &rest lexpr) (let ((clauses (do ((i 0 (1+ i)) (l lexpr (cdr l)) (clauses '() (cons (list (list '= v i) (car l)) clauses))) ((endp l) (nreverse clauses))))) `(cond ,@clauses (t ,defaut)))) ;; 4.2 CL-USER> (setf *x* 1) 1 CL-USER> (condv *x* 'defaut (+ *x* 1) 12 'a) 12 CL-USER> (setf *x* 4) 4 CL-USER> (condv *x* 'defaut (+ *x* 1) 12 'a) DEFAUT