;; VERSION 3 DES POLYGONES EN CLOS ;; C'est une variation de la version 2 en ceci: ;; l'aire n'est calculee et stockee qu'a la demande, i.e. ;; il n'y a pas de calcul a la construction. ;; Cette version pourrait donc etre qualifiee de "paresseuse". ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; 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" ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; 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) (ar :initarg :ar ;; NOUVEL ATTRIBUT POUR L'AIRE :accessor ar :initform nil))) ;; INITIALIS'e A NIL (defgeneric compute-area ((tr triangle))) ;; permet la genericit'e du calcul (defmethod compute-area ((tr triangle)) (apply #' area-of-triangle (get-sides tr))) (defmethod area ((tr triangle)) ;; implementation par defaut (or (ar tr) ;; CALCUL OU APPEL A L'ATTRIBUT... (setf (ar tr) (compute-area tr)))) ;;;; 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)) (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) (setf (slot-value s 'ar) nil) ;; A RECALCULER 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) (setf (slot-value s 'ar) nil) ;; A RECALCULER 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) ;;constructeur avec controle (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))) (defmethod compute-area ((i triangle-isocele)) ;; DEFINITION DU CALCUL D'AIRE (let ((eq (eq-side i)) (ba (base-side i))) (area-of-triangle eq eq ba))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; 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) ;;constructeur avec controle (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 (defmethod compute-area ((e triangle-equilateral));; DEFINITION DU CALCUL D'AIRE (let ((s (side e))) (* s s (/ (sqrt 3) 4)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; 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) ;;constructeur avec controle (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 compute-area ((tr triangle-rectangle)) ;;DEFINITION DU CALCUL D'AIRE (* (side-b tr) (side-c tr) .5)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Test: une liste heterogene d'instances de triangles ;;;; 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))) (mapcar #'area *l*) ;; (0.0 4.472136 6.0 314.1592653589793d0) (mapcar #'perimeter *l*) ;; (10 10 12.0 62.83185307179586d0)