;;; classe principale (defclass polygon () ()) (defgeneric number-of-sides (p) (:documentation "returns the number of sides of a polygon")) (defgeneric perimeter (p) (:documentation "returns the perimeter of a polygon")) (defgeneric area (p) (:documentation "returns the area of a polygon")) (defgeneric compute-area (p) (:documentation "computes the area of a polygon")) (defgeneric sides-lengths (p) (:documentation "returns the list of sides of a polygon")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod perimeter ((p polygon)) (reduce #'+ (sides-lengths p))) ;;; Exercice 1 ;;; Une sous-classe possible spécialisée (mais pas encore ;;; utilisable, car les côtés ne sont toujours pas disponibles). ;;; 1.1 (defclass triangle (polygon) ((number-of-sides :initform 3))) ;;; 1.2 (defclass triangle (polygon) ((number-of-sides :initform 3 :reader number-of-sides))) (number-of-sides (make-instance 'triangle)) ;;; 1.3 (defclass triangle (polygon) ((number-of-sides :initform 3 :allocation :class :reader number-of-sides))) ;;; 1.4 (defun area-of-triangle (a b c) (let ((p (/ (+ a b c) 2))) (sqrt (* p (- p a) (- p b) (- p c))))) (defmethod area ((triangle triangle)) (apply #'area-of-triangle (sides-lengths triangle))) ;;; Exercice 2 ;;; Sous-classes concrètes: les triangles quelconques ;;; 2.1 (defclass plain-triangle (triangle) ((side-a :initarg :side-a) (side-b :initarg :side-b) (side-c :initarg :side-c))) ;;; 2.2 (defun triangular-inequality (a b c) (and (< a (+ b c)) (> a (abs (- b c))))) (defun correct-sides-lengths (a b c) (and (plusp a) (plusp b) (plusp c) (triangular-inequality a b c))) ;;; 2.3 (defun make-plain-triangle (a b c) (assert (correct-sides-lengths a b c)) (make-instance 'plain-triangle :side-a a :side-b b :side-c c)) (defparameter *s1* (make-plain-triangle 3 4 5)) ;;; 2.4 (defmethod sides-lengths ((triangle plain-triangle)) (with-slots (side-a side-b side-c) triangle (list side-a side-b side-c))) (sides-lengths *s1*) (perimeter *s1*) (area *s1*) ;;; 2.5 (defmethod resize-a ((triangle plain-triangle) new-a) (with-slots (side-a side-b side-c) triangle (assert (correct-sides-lengths new-a side-b side-c)) (setf side-a new-a) triangle)) (defmethod resize-b ((triangle plain-triangle) new-b) (with-slots (side-a side-b side-c) triangle (assert (correct-sides-lengths side-a new-b side-c)) (setf side-b new-b) triangle)) (defmethod resize-c ((triangle plain-triangle) new-c) (with-slots (side-a side-b side-c) triangle (assert (correct-sides-lengths side-a side-b new-c)) (setf side-c new-c) triangle)) ;;; triangles isoceles ;;; 3.1 (defclass isocele (triangle) ((long-side :initarg :long-side) (base-side :initarg :base-side))) (defun make-isocele (cote base) (assert (and (plusp cote) (plusp base) (triangular-inequality cote cote base))) (make-instance 'isocele :long-side cote :base-side base)) (defmethod sides-lengths ((i isocele)) (with-slots (long-side base-side) i (list long-side long-side base-side))) ;;; 3.2 ;;; triangles equilateraux (defclass equilateral (triangle) ((side :initarg :side))) (defun make-equilateral (side) (assert (plusp side)) (make-instance 'equilateral :side side)) (defmethod sides-lengths ((e equilateral)) (with-slots (side) e (make-list 3 :initial-element side))) ;;; 3.3 (defmethod perimeter ((e equilateral)) (with-slots (side) e (* 3 side))) (defconstant +rac3/4+ (/ (sqrt 3.0) 4)) (defmethod area ((e equilateral)) (with-slots (side) e (* side side +rac3/4+))) ;;;; triangles rectangles (defclass triangle-rectangle (triangle) ((side-b :initarg :side-b) (side-c :initarg :side-c) (hypo :initarg :hypo))) (defmethod sides-lengths ((tr triangle-rectangle)) (with-slots (side-b side-c hypo) tr (list side-b side-c hypo))) (defun make-triangle-rectangle (b c) (assert (and (plusp b) (plusp c))) (let ((h (sqrt (+ (* b b) (* c c))))) (make-instance 'triangle-rectangle :side-b b :side-c c :hypo h))) (defmethod resize-b ((triangle triangle-rectangle) new-b) (with-slots (side-b side-c hypo) triangle (assert (plusp new-b)) (let ((new-h (sqrt (+ (* new-b new-b) (expt side-c 2))))) (setf hypo new-h) (setf side-b new-b) triangle))) (defmethod area ((triangle triangle-rectangle)) (with-slots (side-b side-c) triangle (* .5 side-b side-c)))