;;;;;;;;;; Exercice 6.1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; derivation formelle extra light ;;;; (sans data-driven, le + et le * binaires, sans simplifications) (defun derivee-simple (var expr) (cond ((eq var expr) 1) ((atom expr) 0) ((eq (first expr) '+) (list '+ (derivee-simple var (second expr)) (derivee-simple var (third expr)))) ((eq (first expr) '*) (list '+ (list '* (second expr) (derivee-simple var (third expr))) (list '* (third expr) (derivee-simple var (second expr))))))) ;(derivee-simple 'x '(+ x 3)) ;(+ 1 0) ;(derivee-simple 'x '(+ x (+ x 3))) ;(+ 1 (+ 1 0)) ;(derivee-simple 'x '(+ (* 3 x) 56)) ;(+ (+ (* 3 1) (* X 0)) 0) ;;;;;;;;;;Exercice 6.2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; derivation formelle light (le + et le * binaires, sans simplifications) (defvar *derivateurs* (make-hash-table :test #'eq) "fonctions de derivation formelle") (defun enregistrer-fonction (symbole deriv-fun) (setf (gethash symbole *derivateurs* ) deriv-fun) symbole) (defun derivee-simple (var expr) (cond ((eq var expr) 1) ((atom expr) 0) (t (funcall (gethash (first expr) *derivateurs*) var expr)))) (enregistrer-fonction '+ (lambda (var expr) (list '+ (derivee-simple var (second expr)) (derivee-simple var (third expr))))) (enregistrer-fonction '* (lambda (var expr) (list '+ (list '* (second expr) (derivee-simple var (third expr))) (list '* (third expr) (derivee-simple var (second expr)))))) ;(derivee-simple 'x '(+ x 3)) ;(+ 1 0) ;(derivee-simple 'x '(+ x (+ x 3))) ;(+ 1 (+ 1 0)) ;(derivee-simple 'x '(+ (* 3 x) 56)) ;(+ (+ (* 3 1) (* X 0)) 0) ;;;; améliorations vers le light plus ;;;; (le + n-aire, la derivée n-ième) (enregistrer-fonction 'exp (lambda (var expr) (list '* (derivee-simple var (second expr)) expr))) ; (derivee-simple 'x '(exp (+ (* 3 x) 56))) ; (* (+ (+ (* 3 1) (* X 0)) 0) (EXP (+ (* 3 X) 56))) (enregistrer-fonction '+ (lambda (var expr) (cons '+ (mapcar (lambda (e) (derivee-simple var e)) (cdr expr))))) ;(derivee-simple 'x '(+ x x 3 x 56)) ;(+ 1 1 0 1 0) (defun derivee (var expr &key (ordre 1)) (if (zerop ordre) expr (derivee var (derivee-simple var expr) :ordre (1- ordre)))) ;(derivee 'x '(+ x x 3 x 56) :ordre 2) ;(+ 0 0 0 0 0) ;;;;;;;;;; VERSIONS SUPPLEMENTAIRES ;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;; 1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; dérivation formelle moins light (avec simplifications) (defvar *derivateurs* (make-hash-table :test #'eq) "fonctions de derivation formelle") (defvar *fonction-lisp* (make-hash-table :test #'eq) "fonction lisp associée à un symbole") (defvar *simplificateurs* (make-hash-table :test #'eq) "fonctions de simplification") (defun enregistrer-fonction (symbole lisp-fun deriv-fun &key simp-fun) (setf (gethash symbole *fonction-lisp*) lisp-fun) (setf (gethash symbole *derivateurs* ) deriv-fun) (setf (gethash symbole *simplificateurs*) simp-fun) symbole) (defun derivee-simple (var expr) (cond ((eq var expr) 1) ((atom expr) 0) (t (simplifier (funcall (gethash (car expr) *derivateurs*) var expr))))) (defun derivee (var expr &key (ordre 1)) (if (zerop ordre) expr (derivee var (derivee-simple var expr) :ordre (1- ordre)))) (defun simplifier (expression) (if (atom expression) expression (appliquer (car expression) (mapcar #'simplifier (cdr expression))))) (defun simplifier-application (symbole args) (let ((simplificateur (gethash symbole *simplificateurs*))) (if simplificateur (apply simplificateur args) (cons symbole args)))) ;;; "apply" d'une opération à une liste d'expressions symboliques (defun appliquer (operation args) (let ((fun (gethash operation *fonction-lisp*))) (if (and fun (every #'numberp args)) (apply fun args) (simplifier-application operation args)))) ;;; "funcall" correspondant (defun appeler (operation &rest args) (appliquer operation args)) (enregistrer-fonction '+ #'+ (lambda (var expr) (appliquer '+ (mapcar (lambda (e) (derivee var e)) (cdr expr)))) :simp-fun (lambda (var us) (let ((vs (remove 0 (us :test #'equal))) (cond ((null vs) 0) ((null (cdr vs)) (car vs)) (t (cons '+ vs))))))) (enregistrer-fonction '* #'* (lambda (var expr) (appeler '+ (appeler '* (second expr) (derivee-simple var (third expr))) (appeler '* (third expr) (derivee-simple var (second expr))))) :simp-fun (lambda (u v) (cond ((or (eql u 0) (eql v 0)) 0) ((eql u 1) v) ((eql v 1) u) (t (list '* u v))))) ;(derivee 'x '(+ x 3)) ;1 ;(derivee 'x '(+ x (+ u x) x)) ;3 ;(derivee 'x '(+ (* 3 x) 56)) ;3 ;;;;;;;;;; 2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; dérivation formelle pas très light ;;;; (avec simplifications, fonctions n-aires et encore plus d'opérateurs) (defvar *derivateurs* (make-hash-table :test #'eq) "fonctions de derivation formelle") (defvar *fonction-lisp* (make-hash-table :test #'eq) "fonction lisp associée à un symbole") (defvar *simplificateurs* (make-hash-table :test #'eq) "fonctions de simplification") (defvar *standard-fun* (make-hash-table :test #'eq) "fonction lisp pour traiter les associativités") (defun enregistrer-fonction (symbole lisp-fun deriv-fun &key simp-fun standard-fun) (setf (gethash symbole *fonction-lisp*) lisp-fun) (setf (gethash symbole *derivateurs* ) deriv-fun) (setf (gethash symbole *simplificateurs*) simp-fun) (setf (gethash symbole *standard-fun*) standard-fun) symbole) ;;; rend certaines opérations binaires (notamment *, / et - ) (defun standardiser (expr) (if (atom expr) expr (let* ((op (car expr)) (standard-fun (gethash op *standard-fun*))) (if standard-fun (apply standard-fun (mapcar #'standardiser (cdr expr))) (cons op (mapcar #'standardiser (cdr expr))))))) ;;; exprime opération comme opérateur associatif à gauche (defun associativite-gauche (operation args) (do ((reste (cddr args) (cdr reste)) (result (list operation (first args) (second args)) (list operation result (car reste)))) ((endp reste) result))) ;;; exprime opération comme opérateur associatif à droite (defun associativite-droite (operation args) (if (endp (cddr args)) (cons operation args) (list operation (first args) (associativite-droite operation (cdr args))))) (defun simplifier-application (symbole args) (let ((simplificateur (gethash symbole *simplificateurs*))) (if simplificateur (apply simplificateur args) (cons symbole args)))) ;;; application d'une opération à une liste d'expressions symboliques (defun appliquer (operation args) (let ((fun (gethash operation *fonction-lisp*))) (if (and fun (every #'numberp args)) (apply fun args) (simplifier-application operation args)))) (defun appeler (operation &rest args) (appliquer operation args)) (defun simplifier (expression) (if (atom expression) expression (appliquer (car expression) (mapcar #'simplifier (cdr expression))))) (defun derivee-simple (var expr) (cond ((eq var expr) 1) ((atom expr) 0) (t (simplifier (apply (gethash (car expr) *derivateurs*) (cons var (cdr expr))))))) (defun derivee (var expr &key (ordre 1)) (if (zerop ordre) expr (derivee var (derivee-simple var expr) :ordre (1- ordre)))) (enregistrer-fonction '+ #'+ (lambda (var &rest us) (appliquer '+ (mapcar (lambda (u) (derivee var u)) us))) :simp-fun (lambda (&rest us) (let ((vs (remove 0 us :test #'equal))) (cond ((null vs) 0) ((null (cdr vs)) (car vs)) (t (cons '+ vs)))))) (enregistrer-fonction '- #'- (lambda (var u v) (appeler '- (derivee var u) (derivee var v))) :simp-fun (lambda (u v) (if (eql v 0) u (list '- u v))) :standard-fun (lambda (&rest args) (cond ((null args) (error "soustraction vide")) ((null (cdr args)) (list '- 0 (car args))) (t (associativite-droite '- args))))) (enregistrer-fonction '* ;; restriction à la multiplication binaire #'* (lambda (var u v) (appeler '+ (appeler '* (derivee var u) v) (appeler '* u (derivee var v)))) :simp-fun (lambda (u v) (cond ((or (eql u 0) (eql v 0)) 0) ((eql u 1) v) ((eql v 1) u) (t (list '* u v)))) :standard-fun (lambda (&rest args) (cond ((null args) 1) ((null (cdr args)) (car args)) (t (associativite-gauche '* args))))) (enregistrer-fonction '/ #'/ (lambda (var u v) (appeler '/ (appeler '- (appeler '* (derivee var u) v) (appeler '* u (derivee var v))) (appeler '* v v))) :simp-fun (lambda (u v) (if (eql u 0) 0 (list '/ u v))) :standard-fun (lambda (&rest args) (cond ((null args) (error "division vide")) ((null (cdr args)) (list '/ 1 (car args))) ((null (cddr args)) (associativite-droite '/ args))))) (enregistrer-fonction 'exp #'exp (lambda (var u) (appeler '* (derivee var u) (appeler 'exp u)))) (enregistrer-fonction 'log #'log (lambda (var u) (appeler '/ (derivee var u) u))) (derivee 'x '(exp (+ (* 3 x) 56))) (derivee 'x '(exp (+ (* 3 x) 56)) :ordre 2) (derivee 'x '(log (+ (* 3 x) y))) (derivee 'x '(log (+ (* 3 x) y)) :ordre 2) (derivee 'x (standardiser '(log (/ x))) :ordre 2) (derivee 'x (standardiser '(log (* x x x)))) (derivee 'x (standardiser '(log (* x x x))) :ordre 3) (derivee 'x (standardiser '(* x x x x)) :ordre 3) (derivee 'x (standardiser '(* x x x x)) :ordre 4) (derivee 'x (standardiser '(* x x x x)) :ordre 5)