Data directed programming chapter.

sec-2-4-3-data-directed.lisp

@@ -0,0 +1,145 @@
+;; in this chapter we do data directed programming
+;; to solve what is, essentially, the expression problem
+;; or a variation of it anyway.
+;; in common lisp, we do have hash tables, so we'll just use that.
+
+
+;; exercise 2.73
+;; these aren't optimised, and they don't eliminate unnecessary elements.
+;; mainly because we already did that. I'm just focusing on the data-driven
+;; approach here.
+(defparameter *deriv* (make-hash-table))
+(defun make-sum (a b)
+  (cond
+    ((and (numberp a) (numberp b)) (+ a b))
+    ((and (numberp a) (= a 0)) b)
+    ((and (numberp b) (= b 0)) a)
+    (t (list '+ a b))))
+(defun sum-deriv (operands var)
+  (reduce #'make-sum
+	  (mapcar (lambda (x) (deriv x var))
+		  operands)))
+(setf (gethash '+ *deriv*) #'sum-deriv)
+
+;; the important thing to notice, here, is that we can easily
+;; add another operation that we want to derive without ever modifying
+;; derive or any of the other methods, by simply adding new entries to
+;; the table.
+;; this ease of extension is what is valuable here.
+;; if I were the user of a library such as this, I could easily modify
+;; this without ever touching the source.
+
+(defun make-product (a b)
+  (cond
+    ((and (numberp a) (numberp b)) (* a b))
+    ((and (numberp a) (= a 1)) b)
+    ((and (numberp b) (= b 1)) a)
+    ((or (zerop a) (zerop b)) 0)
+    (t (list '* a b))))
+(defun prod-deriv (operands var)
+  (make-sum
+   (make-product (first operands)
+		 (deriv (second operands) var))
+   (make-product (deriv (first operands) var)
+		 (second operands))))
+(setf (gethash '* *deriv*) #'prod-deriv)
+
+
+(defun operator (e)
+  (car e))
+(defun operands (e)
+  (cdr e))
+(defun deriv ( exp var)
+  (cond ((numberp exp) 0)
+	((symbolp exp) (if (eql exp var) 1 0))
+	(t (funcall (gethash (operator exp) *deriv*)
+		       (operands exp)
+		       var))))
+
+
+;; exercise 2.74
+;; I'm going to make some assumptions here.
+;; First off, I'm going to make up a data representation for each
+;; division, and I'm going to make up some divisions, and employees for each division.
+;;
+
+(defparameter *salary-getters* (make-hash-table))
+(defparameter *employee-getters* (make-hash-table))
+
+(defun file-type (f)
+  (car f))
+(defun file-contents (f)
+  (cadr f))
+(defun employee-type (e)
+  (car e))
+(defun employee-contents (e)
+  (cadr e))
+
+;; get-employee returns a list containing the division as a symbol as the
+;; first element, and the actual data returned by the division-specific
+;; function as the second element.
+;; get-salary takes that list, strips the type, and calls the division
+;; specific function to get the salary
+(defun get-salary (rec)
+  (funcall (gethash (employee-type rec) *salary-getters*)
+	   (employee-contents rec)))
+(defun get-employee (name file)
+  (list (file-type file) ;; add the division at the front.
+	(funcall (gethash (file-type file) *employee-getters*) name)))
+
+(defparameter *div-a* (list 'A
+			    `(("John" . ,(make-div-a-employee "John" 15 150))
+			      ("Jane" . ,(make-div-a-employee "Jane" 20 200))))
+  "Division A has opted to use an alist for their employee file.
+   Further, each employee is represented as a plist, containing their name,
+   age, and salary.")
+(defun make-div-a-employee (name age salary)
+  (list :name name
+	:age age
+	:salary salary))
+(defun div-a-get-salary (rec)
+  (getf rec :salary))
+(setf (gethash 'A *salary-getters*) #'div-a-get-salary)
+(defun div-a-get-employee (name)
+  (cdr (assoc name (file-contents *div-a*) :test #'string=)))
+(setf (gethash 'A *employee-getters*) #'div-a-get-employee)
+
+
+(defstruct div-b-employee name age salary)
+(defparameter *div-b* (list 'B (make-hash-table :test #'equalp)))
+(setf (gethash "Mark" (cadr *div-b*))
+      (make-div-b-employee :name "Mark" :age 190 :salary 1000))
+(setf (gethash 'B *employee-getters*) (lambda (name) (gethash name (cadr *div-b*))))
+(setf (gethash 'B *salary-getters*) #'div-b-employee-salary)
+
+
+(get-salary (get-employee "John" *div-a*))
+;=> 150
+(get-salary (get-employee "Mark" *div-b*))
+;=> 1000
+
+(defparameter *all-divisions* (list *div-a* *div-b*))
+
+;; When a new company is taken over, you simply need to make sure the new
+;; company's file is a list starting with the type tag, and whatever else
+;; as the rest. Then you can just add the functions for each operation
+;; into the *employee-getters* and *salary-getters* tables.
+;; It's a little annoying that each file must be a cons cell with
+;; the car being the symbol, but it does achieve the goal here.
+;; presumably, in common lisp, I would be using the CLOS and methods
+;; for this.
+
+;; okay 22/01/2025, cleaned up the functions a little bit,
+;; now the division-specific salary function just gets their own
+;; data structures without having to manage the type tag themselves.
+;; we could potentially get rid of the type tag in the division
+;; file as well, through another table that associates type tags
+;; to the files... but I'm not sure if that's very robust.
+;; also forces each company to be aware of the main table...
+;; look, this is good enough.
+
+(defun find-employee (name divisions)
+  (loop for i in divisions do
+	(let ((rec (get-employee name i)))
+	  (if (employee-contents rec)
+	      (return rec)))))