From: LeonardoBizzoni Date: Sat, 30 Dec 2023 16:58:58 +0000 (+0100) Subject: `inherit` fatta X-Git-Url: http://git.leonardobizzoni.com/?a=commitdiff_plain;h=6afc77d20e6cf41959e0f8dda2fde270147be2d0;p=ObjectOriented-Prolog-Lisp `inherit` fatta --- diff --git a/Lisp/README.org b/Lisp/README.org index 5aa1b1a..b05a4f1 100644 --- a/Lisp/README.org +++ b/Lisp/README.org @@ -15,19 +15,17 @@ ;;;; (defun def-class (classname parents &optional (fields nil) (methods nil)) - (defun make-class (parents fields methods) - (let ((class (list :parents parents - :fields (cdr fields) - :methods (cdr methods)))) - (if (null parents) class (inherit class parents)))) - (cond ((not (listp parents)) (error "`parents` non è una lista")) ((not (listp fields)) (error "`fields` non è una lista")) ((not (listp methods)) (error "`methods` non è una lista")) ((or (null classname) (not (symbolp classname))) (error "`classname` non è un simbolo"))) + + ;; Aggiunge la coppia `classname` e classe in forma di lista + ;; all'hash-table (add-class-spec classname (setf (symbol-value classname) (make-class parents fields methods))) + ;; e restituisce il nome della classe classname) #+end_src @@ -76,3 +74,62 @@ (defun class-spec (name) (gethash name *classes-specs*)) #+end_src + +** Creazione della classe in formato lista +#+begin_src lisp :tangle ool.lisp +(defun make-class (parents fields methods) + (inherit (list :parents parents + :fields (cdr fields) + :methods (cdr methods)) parents)) +#+end_src + +*** Ereditazione dai genitori +#+begin_src lisp :tangle ool.lisp +(defun inherit (class parents) + (if (null parents) + class + (inherit (merge-class class (class-spec (car parents))) + (cdr parents)))) + +(defun merge-class (child super) + (list :parents (merge-parents (getf super :parents) + (getf child :parents)) + :fields (merge-parts (getf super :fields) + (getf child :fields)) + :methods (merge-parts (getf super :methods) + (getf child :methods)))) +#+end_src + +**** Merge dei genitori delle superclassi con quelli della classe figlio +#+begin_src lisp :tangle ool.lisp +(defun merge-parents (super-parents child-parent) + (if (null super-parents) + child-parent + + ;; Se il genitore di `super` corrente NON è un membro + ;; della lista dei genitore del figlio + (if (not (member (car super-parents) child-parent)) + ;; fai una chiamata ricorsiva aggiungendolo ai genitori del figlio + (merge-parents (cdr super-parents) (cons (car super-parents) child-parent)) + ;; altrimenti vai al prossimo senza aggiungerlo + (merge-parents (cdr super-parents) child-parent)))) +#+end_src + +**** Merge field/method dei genitori con quelli della classe figlio +#+begin_src lisp :tangle ool.lisp +(defun merge-parts (parent-fields class-fields) + (if (null parent-fields) + class-fields + (if (not (field-name-exists (first (car parent-fields)) class-fields)) + (merge-parts (cdr parent-fields) (cons (car parent-fields) class-fields)) + (merge-parts (cdr parent-fields) class-fields)))) + +;; È necessaria questa funzione in quanto i field sono a loro volta +;; liste (name value &optional type) ma è di fatto lo stesso +;; comportamento di `member` +(defun field-name-exists (name fields) + (if (null fields) + nil + (or (equal name (first (first fields))) + (field-name-exists name (rest fields))))) +#+end_src diff --git a/Lisp/ool.lisp b/Lisp/ool.lisp index a5ce162..44a05e2 100644 --- a/Lisp/ool.lisp +++ b/Lisp/ool.lisp @@ -2,19 +2,17 @@ ;;;; (defun def-class (classname parents &optional (fields nil) (methods nil)) - (defun make-class (parents fields methods) - (let ((class (list :parents parents - :fields (cdr fields) - :methods (cdr methods)))) - (if (null parents) class (inherit class parents)))) - (cond ((not (listp parents)) (error "`parents` non è una lista")) ((not (listp fields)) (error "`fields` non è una lista")) ((not (listp methods)) (error "`methods` non è una lista")) ((or (null classname) (not (symbolp classname))) (error "`classname` non è un simbolo"))) + + ;; Aggiunge la coppia `classname` e classe in forma di lista + ;; all'hash-table (add-class-spec classname (setf (symbol-value classname) (make-class parents fields methods))) + ;; e restituisce il nome della classe classname) @@ -30,3 +28,50 @@ (defun class-spec (name) (gethash name *classes-specs*)) + +(defun make-class (parents fields methods) + (inherit (list :parents parents + :fields (cdr fields) + :methods (cdr methods)) parents)) + +(defun inherit (class parents) + (if (null parents) + class + (inherit (merge-class class (class-spec (car parents))) + (cdr parents)))) + +(defun merge-class (child super) + (list :parents (merge-parents (getf super :parents) + (getf child :parents)) + :fields (merge-parts (getf super :fields) + (getf child :fields)) + :methods (merge-parts (getf super :methods) + (getf child :methods)))) + +(defun merge-parents (super-parents child-parent) + (if (null super-parents) + child-parent + + ;; Se il genitore di `super` corrente NON è un membro + ;; della lista dei genitore del figlio + (if (not (member (car super-parents) child-parent)) + ;; fai una chiamata ricorsiva aggiungendolo ai genitori del figlio + (merge-parents (cdr super-parents) (cons (car super-parents) child-parent)) + ;; altrimenti vai al prossimo senza aggiungerlo + (merge-parents (cdr super-parents) child-parent)))) + +(defun merge-parts (parent-fields class-fields) + (if (null parent-fields) + class-fields + (if (not (field-name-exists (first (car parent-fields)) class-fields)) + (merge-parts (cdr parent-fields) (cons (car parent-fields) class-fields)) + (merge-parts (cdr parent-fields) class-fields)))) + +;; È necessaria questa funzione in quanto i field sono a loro volta +;; liste (name value &optional type) ma è di fatto lo stesso +;; comportamento di `member` +(defun field-name-exists (name fields) + (if (null fields) + nil + (or (equal name (first (first fields))) + (field-name-exists name (rest fields)))))