;;;; Corrige du TD 2 de LISP ;;;; Macros, powers and Horner ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; builds the code of a powering function (defun make-power-code (name exponent) (let ((body (cons '* (make-list exponent :initial-element 'x)))) (list 'defun name (list 'x) body))) ;;;; defines a powering function (defmacro defpower (name exponent) (make-power-code name exponent)) ;;; another version, with backquotes and all this stuff (defmacro defpower (name exponent) `(defun ,name (x) (* ,@(make-list exponent :initial-element 'x)))) ;;;; Horner's algorithm viewed as a macro ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defstruct monome coeff degree) ;;; computes a lisp expression from a sorted polynom (decreasing wrt degrees) (defun generate-horner (pol variable) (do ((p (cdr pol) (cdr p)) (highest-degree (monome-degree (car pol)) (monome-degree (car p))) (horner-exp (monome-coeff (car pol)) `(+ ,(monome-coeff (car p)) (* ,@(make-list (- highest-degree (monome-degree (car p))) :initial-element variable) ,horner-exp)))) ((endp p) (if (zerop highest-degree) horner-exp `(* ,@(make-list highest-degree :initial-element variable) ,horner-exp))))) ;;; checks wether a list of monomes is well formed (defun correct-polynom-p (p) (and (listp p) (consp p) (every #'monome-p p) (equal p (remove-duplicates p :test #'= :key #'monome-degree)))) ;;; generates Horner's code from a polynom (list of monomes) (defun make-horner-defun (pol name &key (variable 'x)) (let ((p (sort pol #'> :key #'monome-degree))) (if (correct-polynom-p p) (list 'defun name (list variable) (generate-horner p variable)) (error "your polynom has duplicate degrees :~s" (mapcar #'monome-degree p))))) ;;; The macro (defmacro defhorner (name variable &rest coeffs ) (let ((polynome (mapcar #'(lambda (m) (make-monome :coeff (first m) :degree (second m))) coeffs))) (make-horner-defun polynome name :variable variable))) ;;; example : polynom 3 x^6 + 2 x^8 -5 (make-horner-defun (list (make-monome :coeff 3 :degree 6) (make-monome :coeff 2 :degree 8) (make-monome :coeff -5 :degree 0)) 'P :variable 'z) (macroexpand-1 '(defhorner P x (3 6) (2 8) (-5 0))) ; (DEFUN P (X) (+ -5 (* X X X X X X (+ 3 (* X X 2))))) (defhorner Q z (1 2) (1 0) (-2 1)) ; z^2 + 1 - 2z ; Q (Q 1/3) ; 4/9 ;;;; mapcan and side effects ;; (mapcan-problem l) creates a circular list based on l (defun mapcan-problem (l) (mapcan #'(lambda (l) l) (list l l))) ;; (setf *l1* '(a b)) ;; ;; loops ! : (mapcan-problem (list *l1* *l1*)) ;;;; a mapcan for unary functions ;;;; (defun non-destructive-mapcan (f l) (if (endp l) () (append (funcall f (car l)) (non-destructive-mapcan f (cdr l))))) ;;;; generalized cartesian product (defun cartesian (l1 l2 &key (operator #'list)) (mapcan #'(lambda (x) (mapcar #'(lambda (y) (funcall operator x y)) l2)) l1)) ;;; examples (cartesian '(1 2 3) '(a b c d)) (cartesian '(1 2 3) '(10 2 ) :operator #'max) ;;;; version of cartesian for a symmetric operator (defun half-cartesian (l &key (operator #'list)) (let ((acc (list))) (do ((l1 l (cdr l1))) ((endp l1) acc) (dolist (x l1) (push (funcall operator (first l1) x) acc))) (reverse acc))) ;;; examples (half-cartesian '(1 2 3 4 5) :operator #'(lambda (x y) (list x y (* x y)))) ;;;; Euclidean points (defstruct point (x 0.0 :type float) (y 0.0 :type float)) (defun point-distance (p1 p2) (let ((dx (- (point-x p1) (point-x p2))) (dy (- (point-y p1) (point-y p2)))) (sqrt (+ (* dx dx) (* dy dy))))) ;;;; cities (defstruct (city (:include point)) name) (defmacro defcity (name &key (x 0.0) ( y 0.0)) `(defconstant ,name (make-city :name ,(string-downcase (symbol-name name)) :x ,x :y ,y))) (defcity paris ) (defcity bordeaux :x 580.0 :y -123.0) (defcity toulouse :x 720.0 :y 56.0) (defcity begles :x 587.0 :y -126.0) (defcity rocamadour :x 578.0) (defun all-distances (cities) (half-cartesian cities :operator #'(lambda (c1 c2) (list (city-name c1) (city-name c2) (point-distance c1 c2))))) ;;; exemple : (all-distances (list paris bordeaux begles toulouse)) ;;; exemple (all-distances (list paris bordeaux begles rocamadour toulouse))