From: LeonardoBizzoni <leo2002714@gmail.com>
Date: Fri, 12 Jan 2024 07:50:47 +0000 (+0100)
Subject: Esempio epico coi numeri complessi e ultimi fix a lisp
X-Git-Url: http://git.leonardobizzoni.com/?a=commitdiff_plain;h=2fe6d258985718d53cf125f604ce7dc43bf28693;p=ObjectOriented-Prolog-Lisp

Esempio epico coi numeri complessi e ultimi fix a lisp

Se `field-helper` arriva alla fine della lista di fields non
restituisce `nil` ma genera un errore perchè il field richiesto non è presente.

A quanto pare era possibile invertire l'ordine in cui dare `fields` e
`methods` nella definizione della classe.
---

diff --git a/Lisp/README.org b/Lisp/README.org
index 63f9405..8a77f39 100644
--- a/Lisp/README.org
+++ b/Lisp/README.org
@@ -78,6 +78,38 @@ tra il nome della classe e la lista ottenuta.
   '(methods
     (foo ()
      (format "Favourite number is ~D~%" field(this 'bar)))))
+
+(def-class 'p-complex nil
+	   '(fields
+	     (:phi 0.0 real)
+	     (:rho 1.0 real))
+	   '(methods
+	     (sum (pcn)
+	      (let ((r1 (field this :rho))
+		    (phi1 (field this :phi))
+		    (r2 (field pcn :rho))
+		    (phi2 (field pcn :phi)))
+		(make 'p-complex :rho (+ r1 r2)
+		      :phi (+ phi1 phi2))))
+	     (mult (pcn)
+	      (let ((r1 (field this :rho))
+		    (phi1 (field this :phi))
+		    (r2 (field pcn :rho))
+		    (phi2 (field pcn :phi)))
+		(make 'p-complex
+		      :rho (- (* r1 r2) (* phi1 phi2))
+		      :phi (+ (* r1 phi2) (* r2 phi1)))))
+	     (div (pcn)
+	      (let ((r1 (field this :rho))
+		    (phi1 (field this :phi))
+		    (r2 (field pcn :rho))
+		    (phi2 (field pcn :phi))
+		    (denominator (+ (* r2 r2) (* phi2 phi2))))
+		(make 'p-complex
+		      :rho (/ (+ (* r1 r2) (* phi1 phi2)) denominator)
+		      :phi (/ (- (* r1 phi2) (* r2 phi1)) denominator))))
+	     (as-complex ()
+	      (complex (field this :rho) (field this :phi)))))
 #+end_src
 
 ** make
@@ -127,7 +159,7 @@ sono a loro volta liste /(name value type)/.
   (field-helper (getf instance :fields) field-name))
 
 (defun field-helper (fields field-name)
-  (cond ((null fields) nil)
+  (cond ((null fields) (error "'~A' non è un field valido" field-name))
 	;; Se sono uguali il primo elemento della prima lista di `fields`
 	;; ed il nome del field restituisci il secondo
 	;; elemento della prima lista di `fields`
@@ -204,25 +236,32 @@ ereditati dalle classi genitore.
 
 #+begin_src lisp :tangle ool.lisp
 (defun make-class (classname parents fields methods)
-  (unless (null fields)
-    (unless (equal (car fields) 'fields)
-      (error "Il primo argomento della lista di fields ~S"
-	     "deve essere il simbolo 'fields'")))
-
-  (unless (null methods)
-    (unless (equal (car methods) 'methods)
-      (error "Il primo argomento della lista di methods ~S"
-             "deve essere il simbolo 'methods'")))
-
-  (define-methods (cdr methods))
-  (validate-fields-type (cdr fields))
-  (inherit
-   (list :classname classname
-	 :type 'class
-	 :parents parents
-	 :fields (cdr fields)
-	 :methods (cdr methods))
-   parents))
+  (cond ((and (null fields) (null methods))
+	 (inherit
+	  (list :classname classname
+		:type 'class
+		:parents parents
+		:fields nil
+		:methods nil)
+	  parents))
+	((and (null methods)
+	      (eq 'methods (car fields)))
+	 (make-class classname parents nil fields))
+	((and (eq 'methods (car fields))
+	      (eq 'fields (car methods)))
+	 (make-class classname parents methods fields))
+	((and (or (null fields) (eq 'fields (car fields)))
+	      (or (null methods) (eq 'methods (car methods))))
+	 (define-methods (cdr methods))
+	 (validate-fields-type (cdr fields))
+	 (inherit
+	  (list :classname classname
+		:type 'class
+		:parents parents
+		:fields (cdr fields)
+		:methods (cdr methods))
+	  parents))
+	(t (error "Definizione di fields o methods invalida"))))
 #+end_src
 
 *** Ereditarietà dei genitori
diff --git a/Lisp/ool.lisp b/Lisp/ool.lisp
index f57e793..fc3f553 100644
--- a/Lisp/ool.lisp
+++ b/Lisp/ool.lisp
@@ -36,7 +36,7 @@
   (field-helper (getf instance :fields) field-name))
 
 (defun field-helper (fields field-name)
-  (cond ((null fields) nil)
+  (cond ((null fields) (error "'~A' non è un field valido" field-name))
 	;; Se sono uguali il primo elemento della prima lista di `fields`
 	;; ed il nome del field restituisci il secondo
 	;; elemento della prima lista di `fields`
@@ -62,25 +62,32 @@
   (gethash name *classes-specs*))
 
 (defun make-class (classname parents fields methods)
-  (unless (null fields)
-    (unless (equal (car fields) 'fields)
-      (error "Il primo argomento della lista di fields ~S"
-	     "deve essere il simbolo 'fields'")))
-
-  (unless (null methods)
-    (unless (equal (car methods) 'methods)
-      (error "Il primo argomento della lista di methods ~S"
-             "deve essere il simbolo 'methods'")))
-
-  (define-methods (cdr methods))
-  (validate-fields-type (cdr fields))
-  (inherit
-   (list :classname classname
-	 :type 'class
-	 :parents parents
-	 :fields (cdr fields)
-	 :methods (cdr methods))
-   parents))
+  (cond ((and (null fields) (null methods))
+	 (inherit
+	  (list :classname classname
+		:type 'class
+		:parents parents
+		:fields nil
+		:methods nil)
+	  parents))
+	((and (null methods)
+	      (eq 'methods (car fields)))
+	 (make-class classname parents nil fields))
+	((and (eq 'methods (car fields))
+	      (eq 'fields (car methods)))
+	 (make-class classname parents methods fields))
+	((and (or (null fields) (eq 'fields (car fields)))
+	      (or (null methods) (eq 'methods (car methods))))
+	 (define-methods (cdr methods))
+	 (validate-fields-type (cdr fields))
+	 (inherit
+	  (list :classname classname
+		:type 'class
+		:parents parents
+		:fields (cdr fields)
+		:methods (cdr methods))
+	  parents))
+	(t (error "Definizione di fields o methods invalida"))))
 
 (defun inherit (class parents)
   (if (null parents)