;; VERSION 1 DES POLYGONES EN CLOS ;; Celle-ci a la particularit'e de ne fixer que le plus tard possible ;; l'implementation de la notion de "cot'e". ;; Ceci est rendu possible par l'accesseurs virtuel "get-sides" ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; polygones (classe abstraite) (defclass polygon () ()) ;; une simple racine du DAG d'heritage (defgeneric get-sides ((f polygon)) ;; accesseur virtuel (:documentation "returns the list of sides of a polygon")) (defgeneric perimeter ((f polygon))) ;; methode virtuelle de base (defmethod perimeter ((f polygon)) ;; implementation par defaut (reduce #'+ (get-sides f))) ;; generique par "get-sides" ;; reduce #'fn '(a b c) = fn(fn(a b) c) ;;Remarque: une classe abstraite en CLOS est instanciable meme ;; si elle est inutilisable... ;; (setf p (make-instance 'polygon)) => ok ;; (perimeter p) => erreur puisque get-sides n'est pas implementee ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; triangles: une sous-classe (egalement abstraite) de polygone qui ;;;; represente le minimum de ce qu'on peut dire sur un triangle. (defclass triangle (polygon) ((number-of-sides :initform 3 :allocation :class))) (defgeneric area ((tr triangle))) ;; methode virtuelle de base (defmethod area ((tri triangle)) ;; implementation par defaut (apply #'area-of-triangle (get-sides tri))) ;; generique par "get-sides" ;;;; quelques fonctions auxiliaires generales de calcul pour les triangles: (defun three-sides-to-angle (a b c) (acos (/ (- (+ (expt b 2) (expt c 2)) (expt a 2)) (* 2 b c)))) (defun area-of-triangle (a b c) (let ((angle-C (three-sides-to-angle c a b))) (* a b (sin angle-C) .5))) ;;;; quelques fonctions auxiliaires de controle de validit'e ;;;; lors de la construction et des acces en ecriture: (defun triangular-inequality (a b c) (and (<= a (+ b c)) (>= a (abs (- b c))))) (defun correct-sides (a b c) (and (> a 0) (> b 0) (> c 0) (triangular-inequality a b c))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; triangles quelconques, i.e. scalenes : une sous-classe ;;;; (concrete cette fois) de triangle (defclass triangle-scalene (triangle) ((side-a :initarg :side-a :reader side-a) (side-b :initarg :side-b :reader side-b) (side-c :initarg :side-c :reader side-c))) (defun make-triangle-scalene (a b c) ;; constructeur avec controle (assert (correct-sides a b c)) ;; Remarque: defini par "defun" (make-instance 'triangle-scalene :side-a a :side-b b :side-c c)) (defmethod get-sides ((s triangle-scalene)) ;;concretis. de l'access. aux cot'es (list (side-a s) (side-b s) (side-c s))) ;;;; accesseurs en ecriture avec controle: (defmethod resize-a ((s triangle-scalene) new-a) (let ((b (side-b s)) (c (side-c s))) (assert (correct-sides new-a b c)) (setf (slot-value s 'side-a) new-a) s)) (defmethod resize-b ((s triangle-scalene) new-b) (let ((a (side-a s)) (c (side-c s))) (assert (correct-sides a new-b c)) (setf (slot-value s 'side-b) new-b) s)) (defmethod resize-c ((s triangle-scalene) new-c) ;;idem ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; triangles isoceles : une autre sous-classe ;;;; concrete de triangle. Ici, seuls deux slots sont ;;;; necessaires pour stocker les cot'es. (defclass triangle-isocele (triangle) ((eq-side :initarg :eq-side :reader eq-side) (base-side :initarg :base-side :reader base-side))) (defun make-triangle-isocele (eq base) (assert (correct-sides eq eq base)) (make-instance 'triangle-isocele :eq-side eq :base-side base)) (defmethod get-sides ((i triangle-isocele)) (list (eq-side i) (eq-side i) (base-side i))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; triangles equilateres: une autre sous-classe ;;;; concrete de triangle. Ici, seul un slot est ;;;; necessaire pour stocker les cot'es. (defclass triangle-equilateral (triangle) ((side :initarg :side :reader side))) (defun make-triangle-equilateral (side) (assert (> side 0)) (make-instance 'triangle-equilateral :side side)) (defmethod get-sides ((e triangle-equilateral)) (make-list 3 :initial-element (side e))) (defmethod perimeter ((e triangle-equilateral));; redef. du calcul du perimetre (* 3 (side e))) ;; i.e. une optimisation (defconstant rac3/4 (/ (sqrt 3.0) 4)) (defmethod area ((e triangle-equilateral)) ;; redef. du calcul d'aire: (* (side e) (side e) rac3/4)) ;; i.e. une optimisation ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; triangles rectangles: une autre sous-classe ;;;; concrete de triangle. Ici, trois slots sont utilis'es, ;;;; mais le constructeur n'en necessite que deux. En fait, ;;;; l'hypothenuse est un attribut calcul'e (sans etre necessaire) (defclass triangle-rectangle (triangle) ((side-b :initarg :side-b :reader side-b) (side-c :initarg :side-c :reader side-c) (hypo :initarg :hypo :reader hypo))) (defun make-triangle-rectangle (b c) (assert (and (> b 0) (> c 0))) (let ((h (sqrt (+ (* b b) (* c c))))) (make-instance 'triangle-rectangle :side-b b :side-c c :hypo h))) (defmethod get-sides ((tr triangle-rectangle)) (list (side-b tr) (side-c tr) (hypo tr))) (defmethod resize-b ((tr triangle-rectangle) new-b) (assert (> new-b 0)) (let ((new-h (sqrt (+ (* new-b new-b) (expt (side-c tr) 2))))) (setf (slot-value tr 'hypo) new-h) (setf (slot-value tr 'side-b) new-b) tr)) (defmethod area ((tr triangle-rectangle)) (* .5 (side-b tr) (side-c tr))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ronds : une classe qui n'a a priori rien a voir avec les polygones... (defstruct color (r 0) (g 0) (b 0)) (defclass rond () ((rayon :initarg :rayon :reader rayon) (couleur :initarg :couleur :reader couleur))) (defun make-rond (r &key (couleur (make-color :r 255 :g 0 :b 0))) (make-instance 'rond :rayon r :couleur couleur)) ;; d'efinitions sur les calculs d'aire et perimetre ;; (nb: aucun probleme pour surcharger les methodes existantes sur les polygones. ;; en particulier, le "defgeneric" avec arguments typ'es ne contraint en ;; rien les definitions suivantes: (defmethod area ((c rond)) (* pi (expt (rayon c) 2))) (defmethod perimeter ((c rond)) (* 2 pi (rayon c))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Test: une liste heterogene d'instances de triangles et de ronds ;;;; est construite sur laquelle sont appliqu'ees les fonctions ;;;; de calcul de permimetre et d'aire: le polymorphisme marche. (defvar *l* (list (make-triangle-scalene 3 5 2) (make-triangle-isocele 3 4) (make-triangle-rectangle 3 4) (make-rond 10 :couleur (make-color)))) (mapcar #'area *l*) ;; (0.0 4.472136 6.0 314.1592653589793d0) (mapcar #'perimeter *l*) ;; (10 10 12.0 62.83185307179586d0)