146 lines
5.0 KiB
Common Lisp
146 lines
5.0 KiB
Common Lisp
;; 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)))))
|