source: trunk/example.lisp @ 3

Revision 3, 7.5 KB checked in by gz, 9 years ago (diff)

Recovered version 0.961 from Sheldon Ball <s.ball@…>

  • Property svn:eol-style set to native
Line 
1;;;-*- Mode: Lisp; Package: cl-user
2;;;
3;;; example.lisp
4;;;
5;; Copyright © 1996 Digitool, Inc.
6;; Copyright © 1992-1995 Apple Computer, Inc.
7;; All rights reserved.
8;; Permission is given to use, copy, and modify this software provided
9;; that Digitool is given credit in all derivative works.
10;; This software is provided "as is". Digitool makes no warranty or
11;; representation, either express or implied, with respect to this software,
12;; its quality, accuracy, merchantability, or fitness for a particular
13;; purpose.
14
15;;; Example file showing one way to save person records in a persistent heap.
16;;; If your "Wood" directory is not accessible as "ccl:wood;", you
17;;; will need to change the pathname in the (require "WOOD" ...) form below.
18
19;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
20;;;
21;;; Modification history
22;;;
23;;; ------------- 0.96
24;;; ------------- 0.95
25;;; ------------- 0.94
26;;; ------------- 0.93
27;;; ------------- 0.9
28;;; ------------- 0.8
29;;; ------------- 0.6
30;;; 12/09/92 bill "wood:" package prefix in commented out code.
31;;; 09/14/92 bill move to CL-USER package. (require "WOOD" ...)
32;;; 07/31/92 bill Matthew Cornell's typo fixes in the commented out code.
33;;; ------------- 0.5
34;;;
35
36(in-package "CL-USER")
37
38(eval-when (:compile-toplevel :execute :load-toplevel)
39  (require "WOOD" "ccl:wood;wood"))
40
41;; define the PERSON class
42(defclass person ()
43  ((first-name
44    :initarg :first-name
45    :accessor person-first-name)
46   (last-name
47    :initarg :last-name
48    :accessor person-last-name)
49   (age
50    :initarg :age
51    :accessor person-age)
52   (sex
53    :initarg :sex
54    :accessor person-sex)
55   (occupation
56    :initarg :occupation
57    :accessor person-occupation)
58   (ss#
59    :initarg :ss#
60    :accessor person-ss#)))
61
62(defmethod person-name ((self person))
63  (concatenate 'string (person-first-name self) " " (person-last-name self)))
64
65(defmethod print-object ((object person) stream)
66  (print-unreadable-object (object stream :type t :identity t)
67    (format stream "~a ~a, ~a"
68            (person-first-name object)
69            (person-last-name object)
70            (person-occupation object))))
71
72;; Create a persistent heap for storing indexed PERSON instances.
73;; The root object is a three element list.
74;; The first element identifies the file.
75;; The second element is a btree mapping social security number to person.
76;; The third element is a btree mapping last name to a list of people.
77(defun create-person-file (&key (filename "People.wood")
78                                (if-exists :error))
79  (let ((pheap (wood:open-pheap filename
80                                :if-exists if-exists
81                                :if-does-not-exist :create)))
82    (setf (wood:root-object pheap)
83          (wood:p-list
84           pheap
85           "People"                     ; Identify this file
86           (wood:p-make-btree pheap)    ; ss# -> person
87           (wood:p-make-btree pheap)    ; last-name -> (person ...)
88           ))
89    pheap))
90
91; I wouldn't really look up the root for every access in a production system.
92(defun person-pheap-tables (pheap)
93  (let ((root (wood:p-load (wood:root-object pheap))))
94    (unless (and (listp root)
95               (eql 3 (length root))
96               (equal "People" (first root))
97               (wood:p-btree-p (second root))
98               (wood:p-btree-p (third root)))
99      (error "~s does not appear to be a person file" pheap))
100    (values (second root) (third root))))
101
102(defun store-person (pheap person)
103  (setq person (require-type person 'person))
104  (multiple-value-bind (ss#->person last-name->person-list)
105                       (person-pheap-tables pheap)
106    (let ((ss# (person-ss# person))
107          (last-name (string-upcase (person-last-name person))))
108      (unless (wood:p-btree-lookup ss#->person ss#)
109        (setf (wood:p-btree-lookup ss#->person (person-ss# person)) person
110              (wood:p-btree-lookup last-name->person-list last-name)
111              (cons person
112                    (wood:p-load
113                     (wood:p-btree-lookup last-name->person-list last-name)))))))
114  person)
115
116(defun find-person-with-ss# (pheap ss#)
117  (let ((ss#->person (person-pheap-tables pheap)))
118    (wood:p-load (wood:p-btree-lookup ss#->person ss#))))
119
120(defun find-people-with-last-name (pheap last-name)
121  (multiple-value-bind (ss#->person last-name->person-list)
122                       (person-pheap-tables pheap)
123    (declare (ignore ss#->person))
124    (wood:p-load
125     (wood:p-btree-lookup last-name->person-list (string-upcase last-name)))))
126
127(defun print-people-by-ss# (pheap)
128  (let ((ss#->person (person-pheap-tables pheap)))
129    (wood:p-map-btree ss#->person
130                      #'(lambda (ss# person)
131                          (format t "~&~a ~s~%" ss# (wood:p-load person))))))
132
133(defun print-people-by-last-name (pheap)
134  (multiple-value-bind (ss#->person last-name->person-list)
135                       (person-pheap-tables pheap)
136    (declare (ignore ss#->person))
137    (wood:p-map-btree last-name->person-list
138                      #'(lambda (last-name person-list)
139                          (declare (ignore last-name))
140                          (setq person-list
141                                (sort (mapcar 'wood:p-load
142                                              (wood:p-load person-list))
143                                      #'string<
144                                      :key 'person-first-name))
145                          (dolist (person person-list)
146                            (format t "~&~s~%" person))))))
147
148;; Code for creating random PERSON instances.
149(defparameter *first-names*
150  '(("Alan" . M)
151    ("Abraham" . M)
152    ("Andrew" . M)
153    ("Alice" . F)
154    ("Susan" . F)
155    ("Bob" . M)
156    ("Hillary" . F)
157    ("Joe" . M)
158    ("Bill" . M)
159    ("Matthew" . M)
160    ("Gail" . F)
161    ("Gary" . M)
162    ("Doug" . M)
163    ("Christie" . F)
164    ("Steve" . M)
165    ("Elizabeth" . F)
166    ("Melissa" . F)
167    ("Karla" . F)
168    ("Dan" . M)
169    ("Irving" . M)))
170
171(defparameter *last-names*
172  '("Smith" "Jones" "Peterson" "Williams" "Kennedy" "Johnson"
173    "Riley" "Sylversteen" "Wilson" "Cranshaw" "Ryan" "O'Neil"
174    "McAllister"))
175
176(defparameter *occupations*
177  '("Butcher" "Baker" "Candlestick Maker"
178    "Engineer" "Hacker" "Tailor" "Cop" "Lawyer" "Doctor"
179    "Dentist" "Politician" "Cashier" "Insurance Sales"
180    "Advertising"))
181
182(defun random-person ()
183  (multiple-value-bind (first-name last-name sex) (random-name)
184    (make-instance 'person
185      :first-name first-name
186      :last-name last-name
187      :sex sex
188      :age (random 100)
189      :occupation (random-element *occupations*)
190      :ss# (random-ss#))))
191
192(defun random-element (sequence)
193  (elt sequence (random (length sequence))))
194   
195(defun random-name ()
196  (let ((first.sex (random-element *first-names*))
197        (last (random-element *last-names*)))
198    (values
199     (car first.sex)
200     last
201     (cdr first.sex))))
202
203(defvar *ss#s* (make-hash-table :test 'equal))
204
205(defun random-ss# ()
206  (with-standard-io-syntax
207    (loop
208      (let ((ss# (write-to-string
209                  (+ (expt 10 8) (random (- (expt 10 9) (expt 10 8)))))))
210        (unless (gethash ss# *ss#s*)
211          (return
212           (setf (gethash ss# *ss#s*) ss#)))))))
213
214(defun store-n-random-people (pheap n)
215  (dotimes (i n)
216    (store-person pheap (random-person))))
217
218#|
219(defparameter *p* (create-person-file :if-exists :supersede))
220; or
221(defparameter *p* (wood:open-pheap "People.wood"))
222
223(store-n-random-people *p* 100)
224
225(print-people-by-ss# *p*)
226
227(print-people-by-last-name *p*)
228
229(wood:close-pheap *p*)
230|#
231;;;    1   3/10/94  bill         1.8d247
232;;;    2   3/23/95  bill         1.11d010
Note: See TracBrowser for help on using the repository browser.