-
Notifications
You must be signed in to change notification settings - Fork 702
/
clos.lisp
92 lines (73 loc) · 3.01 KB
/
clos.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*-
;;; Code from Paradigms of Artificial Intelligence Programming
;;; Copyright (c) 1991 Peter Norvig
;;;; File clos.lisp: Object-oriented programming examples
(defstruct account
(name "") (balance 0.00) (interest-rate .06))
(defun account-withdraw (account amt)
"Make a withdrawal from this account."
(if (<= amt (account-balance account))
(decf (account-balance account) amt)
'insufficient-funds))
(defun account-deposit (account amt)
"Make a deposit to this account."
(incf (account-balance account) amt))
(defun account-interest (account)
"Accumulate interest in this account."
(incf (account-balance account)
(* (account-interest-rate account)
(account-balance account))))
;;; ==============================
(defun new-account (name &optional (balance 0.00)
(interest-rate .06))
"Create a new account that knows the following messages:"
#'(lambda (message)
(case message
(withdraw #'(lambda (amt)
(if (<= amt balance)
(decf balance amt)
'insufficient-funds)))
(deposit #'(lambda (amt) (incf balance amt)))
(balance #'(lambda () balance))
(name #'(lambda () name))
(interest #'(lambda ()
(incf balance
(* interest-rate balance)))))))
;;; ==============================
(defun get-method (object message)
"Return the method that implements message for this object."
(funcall object message))
(defun send (object message &rest args)
"Get the function to implement the message,
and apply the function to the args."
(apply (get-method object message) args))
;;; ==============================
(defun withdraw (object &rest args)
"Define withdraw as a generic function on objects."
(apply (get-method object 'withdraw) args))
;;; ==============================
(defmacro define-class (class inst-vars class-vars &body methods)
"Define a class for object-oriented programming."
;; Define constructor and generic functions for methods
`(let ,class-vars
(mapcar #'ensure-generic-fn ',(mapcar #'first methods))
(defun ,class ,inst-vars
#'(lambda (message)
(case message
,@(mapcar #'make-clause methods))))))
(defun make-clause (clause)
"Translate a message from define-class into a case clause."
`(,(first clause) #'(lambda ,(second clause) .,(rest2 clause))))
(defun ensure-generic-fn (message)
"Define an object-oriented dispatch function for a message,
unless it has already been defined as one."
(unless (generic-fn-p message)
(let ((fn #'(lambda (object &rest args)
(apply (get-method object message) args))))
(setf (symbol-function message) fn)
(setf (get message 'generic-fn) fn))))
(defun generic-fn-p (fn-name)
"Is this a generic function?"
(and (fboundp fn-name)
(eq (get fn-name 'generic-fn) (symbol-function fn-name))))
;;; ==============================