« back to all changes in this revision
Viewing changes to base/class.scm
- browse files at revision 1
- compare with another revision
- download diff
- download tarball
- view history from revision 1
- Committer: Bazaar Package Importer
- Author(s): Josselin Mouette
- Date: 2002-04-17 10:36:45 UTC
- Revision ID: james.westby@ubuntu.com-20020417103645-29vomjspk4yf4olw
Tags: upstream-2.1
Import upstream version 2.1
- files added:
- autom4te.cache
- base
- doc
- examples
- utils
added
removed
base/class.scm
1
; libctl: flexible Guile-based control files for scientific software
2
; Copyright (C) 1998, 1999, 2000, 2001, 2002, Steven G. Johnson
3
;
4
; This library is free software; you can redistribute it and/or
5
; modify it under the terms of the GNU Lesser General Public
6
; License as published by the Free Software Foundation; either
7
; version 2 of the License, or (at your option) any later version.
8
;
9
; This library is distributed in the hope that it will be useful,
10
; but WITHOUT ANY WARRANTY; without even the implied warranty of
11
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12
; Lesser General Public License for more details.
13
;
14
; You should have received a copy of the GNU Lesser General Public
15
; License along with this library; if not, write to the
16
; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
17
; Boston, MA 02111-1307, USA.
18
;
19
; Steven G. Johnson can be contacted at stevenj@alum.mit.edu.
20
21
; ****************************************************************
22
; Functions for creating and manipulating classes, objects, types,
23
; and properties.
24
25
(define class-list '())
26
27
(define (make-property-value-pair name value)
28
(cons name value))
29
30
(define (make-object type-names property-values)
31
(cons type-names property-values))
32
(define (object-type-names object) (car object))
33
(define (object-property-values object) (cdr object))
34
(define (object-member? type-name object)
35
(and (pair? object) (member type-name (object-type-names object))))
36
(define (object-property-value object property-name)
37
(assoc-ref (object-property-values object) property-name))
38
(define (object-memberp type-name)
39
(lambda (object) (object-member? type-name object)))
40
; (I wish Scheme had implicit currying like ML.)
41
(define (extend-object object type-name property-values)
42
(make-object (cons type-name (object-type-names object))
43
(combine-alists property-values
44
(object-property-values object))))
45
(define (modify-object object . property-values)
46
(make-object (object-type-names object)
47
(combine-alists property-values
48
(object-property-values object))))
49
(define null-object (make-object '() '()))
50
51
(define no-default '(no-default))
52
(define (has-default? default) (not (eq? default no-default)))
53
54
(define (make-derived derive-func)
55
(cons true derive-func))
56
(define not-derived (cons false '()))
57
(define (derived? derived) (car derived))
58
(define (derive-func derived) (cdr derived))
59
60
(define (make-property name type-name default derived . constraints)
61
(list name type-name default constraints derived))
62
63
(define no-constraints '())
64
(define (property-name property) (first property))
65
(define (property-type-name property) (second property))
66
(define (property-default property) (third property))
67
(define (property-constraints property) (fourth property))
68
(define (property-derived property) (fifth property))
69
(define (property-has-default? property)
70
(has-default? (property-default property)))
71
(define (property-default-value property) (property-default property))
72
(define (property-derived? property)
73
(derived? (property-derived property)))
74
(define (derive-property property object)
75
(make-property-value-pair
76
(property-name property)
77
((derive-func (property-derived property)) object)))
78
79
(define (check-constraints constraints value)
80
(for-all? constraints (lambda (c) (c value))))
81
82
(define (make-list-type el-type-name)
83
(cons 'list el-type-name))
84
(define (list-type-name? type-name)
85
(and (pair? type-name) (eq? (car type-name) 'list)))
86
(define (list-el-type-name type-name) (cdr type-name))
87
88
(define (make-type-descriptor kind name name-str predicate)
89
(list kind name name-str predicate))
90
(define type-descriptor-kind first)
91
(define type-descriptor-name second)
92
(define type-descriptor-name-str third)
93
(define type-descriptor-predicate fourth)
94
(define (make-simple-type-descriptor name predicate)
95
(make-type-descriptor 'simple name (symbol->string name) predicate))
96
(define (make-object-type-descriptor name)
97
(make-type-descriptor 'object name (symbol->string name)
98
(object-memberp name)))
99
(define (make-list-type-descriptor name)
100
(make-type-descriptor 'uniform-list name "list" list?))
101
(define (get-type-descriptor type-name)
102
(cond
103
((eq? type-name 'number) (make-simple-type-descriptor 'number real?))
104
((eq? type-name 'cnumber) (make-simple-type-descriptor 'cnumber complex?))
105
((eq? type-name 'integer) (make-simple-type-descriptor 'integer integer?))
106
((eq? type-name 'boolean) (make-simple-type-descriptor 'boolean boolean?))
107
((eq? type-name 'string) (make-simple-type-descriptor 'string string?))
108
((eq? type-name 'SCM)
109
(make-simple-type-descriptor 'SCM (lambda (x) true)))
110
((eq? type-name 'function)
111
(make-simple-type-descriptor 'function procedure?))
112
((eq? type-name 'vector3)
113
(make-simple-type-descriptor 'vector3 real-vector3?))
114
((eq? type-name 'cvector3) (make-simple-type-descriptor 'cvector3 vector3?))
115
((eq? type-name 'matrix3x3)
116
(make-simple-type-descriptor 'matrix3x3 real-matrix3x3?))
117
((eq? type-name 'cmatrix3x3)
118
(make-simple-type-descriptor 'cmatrix3x3 matrix3x3?))
119
((eq? type-name 'list) (make-simple-type-descriptor 'list list?))
120
((symbol? type-name) (make-object-type-descriptor type-name))
121
((list-type-name? type-name) (make-list-type-descriptor type-name))
122
(else (error "unknown type" type-name))))
123
124
(define (type-string type-name)
125
(let ((desc (get-type-descriptor type-name)))
126
(cond
127
((or (eq? (type-descriptor-kind desc) 'simple)
128
(eq? (type-descriptor-kind desc) 'object))
129
(type-descriptor-name-str desc))
130
((eq? (type-descriptor-kind desc) 'uniform-list)
131
(string-append (type-string (list-el-type-name type-name)) " list"))
132
(else (error "unknown type" type-name)))))
133
(define (type-predicate type-name)
134
(let ((desc (get-type-descriptor type-name)))
135
(cond
136
((or (eq? (type-descriptor-kind desc) 'simple)
137
(eq? (type-descriptor-kind desc) 'object))
138
(type-descriptor-predicate desc))
139
((eq? (type-descriptor-kind desc) 'uniform-list)
140
(lambda (val)
141
(and ((type-descriptor-predicate desc) val)
142
(for-all? val (type-predicate (list-el-type-name type-name))))))
143
(else (error "unknown type" type-name)))))
144
(define (check-type type-name value)
145
((type-predicate type-name) value))
146
147
(define (get-property-value property property-values)
148
(let ((val (assoc (property-name property)
149
property-values)))
150
(let ((newval (if (pair? val) val
151
(if (property-has-default? property)
152
(make-property-value-pair
153
(property-name property)
154
(property-default-value property))
155
(error "no value for property"
156
(property-name property))))))
157
(if (check-constraints (property-constraints property) (cdr newval))
158
(if (check-type (property-type-name property) (cdr newval))
159
newval
160
(error "wrong type for property" (property-name property) 'type
161
(property-type-name property)))
162
(error "invalid value for property" (property-name property))))))
163
164
(define (make-class type-name parent . properties)
165
(let ((new-class (list type-name parent properties)))
166
(set! class-list (cons new-class class-list))
167
new-class))
168
(define (class-type-name class) (first class))
169
(define (class-parent class) (second class))
170
(define (class-properties class) (third class))
171
(define (class-member? type-name class)
172
(if (list? class)
173
(or (eq? type-name (class-type-name class))
174
(class-member? type-name (class-parent class)))
175
false))
176
177
(defmacro-public define-class (class-name parent . properties)
178
`(define ,class-name (make-class (quote ,class-name)
179
,parent
180
,@properties)))
181
182
(define no-parent false)
183
184
(define (make class . property-values)
185
(if (list? class)
186
(let ((o
187
(extend-object
188
(apply make (cons (class-parent class) property-values))
189
(class-type-name class)
190
(map (lambda (property)
191
(get-property-value property property-values))
192
(list-transform-negative
193
(class-properties class) property-derived?)))))
194
(fold-left (lambda (o p)
195
(modify-object o (derive-property p o)))
196
o
197
(list-transform-positive
198
(class-properties class) property-derived?)))
199
null-object))
200
201
; ****************************************************************
202
; Defining property values.
203
204
(define (property-value-constructor name)
205
(lambda (x) (make-property-value-pair name x)))
206
207
(define (vector3-property-value-constructor name)
208
(lambda x (make-property-value-pair name (if (and (= (length x) 1)
209
(vector3? (car x)))
210
(car x)
211
(apply vector3 x)))))
212
213
(define (list-property-value-constructor name)
214
(lambda x (make-property-value-pair name x)))
215
216
(define (type-property-value-constructor type-name name)
217
(cond
218
((eq? type-name 'vector3)
219
(vector3-property-value-constructor name))
220
((list-type-name? type-name)
221
(list-property-value-constructor name))
222
(else (property-value-constructor name))))
223
224
(define (post-processing-constructor post-process-func constructor)
225
(lambda x
226
(let ((value-pair (apply constructor x)))
227
(make-property-value-pair (car value-pair)
228
(post-process-func (cdr value-pair))))))
229
230
(defmacro-public define-property (name default type-name . constraints)
231
`(begin
232
(define ,name
233
(type-property-value-constructor ,type-name (quote ,name)))
234
(make-property (quote ,name) ,type-name ,default
235
not-derived ,@constraints)))
236
237
(defmacro-public define-post-processed-property
238
(name default type-name post-process-func . constraints)
239
`(begin
240
(define ,name (post-processing-constructor
241
,post-process-func
242
(type-property-value-constructor ,type-name
243
(quote ,name))))
244
(make-property (quote ,name) ,type-name ,default
245
not-derived ,@constraints)))
246
247
(defmacro-public define-derived-property (name type-name derive-func)
248
`(make-property (quote ,name) ,type-name no-default
249
(make-derived ,derive-func)))
250
251
; ****************************************************************
Loggerhead is a web-based interface for Breezy
Version: 2.0.1