source: project/wiki/records-and-oop @ 40244

Last change on this file since 40244 was 40244, checked in by Mario Domenech Goulart, 3 months ago

records-and-oop: update to CHICKEN 5, add some markup

File size: 30.7 KB
Line 
1[[toc:]]
2
3== Records and Object Orientation
4
5Records are the feature most painfully missed in R5RS. Consequently
6Chicken supplied define-record in the special-forms unit. It is easy to
7use, but personally I don't like it because it does too much behind the
8scene. For example, the following call
9
10<enscript highlight=scheme>
11(define-record rect x y w h)
12</enscript>
13
14creates automatically ten procedures
15
16* a constructor, {{make-rect}}
17* a predicate, {{rect?}}
18
19for each slot, {{x}}, {{y}}, {{w}}, {{h}}
20
21* an accessor {{rect-x}}, {{rect-y}}, {{rect-w}}, {{rect-h}}
22* and a mutator {{rect-x-set!}}, {{rect-y-set!}}, {{rect-w-set!}}, {{rect-h-set!}}
23
24This is convenient, but since these procedures are never defined
25explicitly, you might have problems understanding code, where their use
26is far away from the call to {{define-record}}. Moreover, you are missing
27the flexibility to choose your own names for these procedures, and --
28which is more important -- you can't make individual slots read-only.
29
30=== define-record-type
31
32All these problems are avoided using srfi-9's {{define-record-type}}, also
33supplied by CHICKEN in the {{chicken.base}} module. The following call will
34do exactly the same as the {{define-record}} call above, but now all names
35are explicit, hence can be chosen by yourself and the modifiers can be
36omitted at all, thus providing read-only slots.
37
38<enscript highlight=scheme>
39(define-record-type rect
40  (make-rect x y w h)
41  rect?
42  (x rect-x rect-x-set!)
43  (y rect-y rect-y-set!)
44  (w rect-w rect-w-set!)
45  (h rect-h rect-h-set!)
46)
47</enscript>
48
49You can also save some procedure identifiers by replacing e.g.
50{{rect-x-set!}} with {{(setter rect-x)}}. Then you can mutate the {{x}} slot in the
51srfi-17 way by {{(set! (rect-x rt) new-slot)}}.
52
53=== define-record-printer
54
55Both {{define-record}} and {{define-record-type}} can be used in combination
56with {{define-record-printer}} from the {{chicken.base}} module, thus allowing
57records to be printed in a readable form. Without it, a {{rect}} instance
58is simply printed {{#<rect>}}, which is not very descriptive. But having
59written
60
61<enscript highlight=scheme>
62(define-record-printer (rect rt out)
63  (fprintf out "#,(rect ~s ~s ~s ~s)"
64  (rect-x rt) (rect-y rt) (rect-w rt) (rect-h rt)))
65</enscript>
66
67{{(make-rect 0 0 1 2)}} will print {{#,(rect 0 0 1 2)}} instead of {{#<rect>}}.
68
69=== define-reader-ctor
70
71Now you can turn things around and read a {{rect}} instance written in the
72form printed above via
73
74  (define rt '#,(rect 0 0 1 2))
75
76provided you have used srfi-10's {{define-reader-ctor}}, supplied by
77CHICKEN's {{chicken.read-syntax}} module via
78
79  (define-reader-ctor 'rect make-rect)
80
81=== The records egg
82
83Up to now, you have used a syntactic interface to {{rects}}. There is a
84procedural one as well, provided by the [[/eggref/5/records egg|records]].  Now I can reduce
85the number of identifiers by packaging accessors and modifiers with
86srfi-17's {{getter-with-setter}}, so that {{set!}} can work on accessor
87expressions.  But note that {{define-record-printer}} is used a bit
88different then above, because you must use the name of the record-type,
89not the record-type-descriptor.
90
91<enscript highlight=scheme>
92(use records)
93(define RECT (make-record-type 'rect '(x y w h)))
94(define Rect (record-constructor RECT))
95(define rect? (record-predicate RECT))
96(define rect-x (getter-with-setter (record-accessor RECT 'x)
97                                   (record-mutator RECT 'x)))
98(define rect-y (getter-with-setter (record-accessor RECT 'y)
99                                   (record-mutator RECT 'y)))
100(define rect-w (getter-with-setter (record-accessor RECT 'w)
101                                   (record-mutator RECT 'w)))
102(define rect-h (getter-with-setter (record-accessor RECT 'h)
103                                   (record-mutator RECT 'h)))
104(define-record-printer ('rect rt out) ; note 'rect, not RECT
105  (fprintf out "#,(rect ~s ~s ~s ~s)"
106    (rect-x rt) (rect-y rt) (rect-w rt) (rect-h rt)))
107</enscript>
108
109Now with {{(define rt (Rect 0 0 1 2))}}, {{rt}} will print {{#,(rect 0 0 1 2)}},
110{{(rect-x rt)}} will print {{0}} and after {{(set! (rect-x rt) 10)}} it will print
111{{10}}.
112
113Henceforth, record-type descriptors will be written all uppercase, and
114the corresponding constructor starting uppercase.
115
116=== srfi-99
117
118CHICKENS's implementation of srfi-99, written by Thomas Chust, combines
119both interfaces, the syntactic and the procedural one, so that they can
120be used interchangeably, and it provides its own version of
121define-record-printer.
122
123This one module comprises srfi-99-variants and srfi-99-records, the
124latter in turn comprising submodules srfi-99-records-procedural,
125srfi-99-records-inspection and srfi-99-records-syntactic, the former
126being an extension to the srfi-99 document. As that document postulates,
127CHICKENS's srfi-99 records not only implement type extension in the form
128of single inheritance, but also all optional extensions, the srfi-document
129mentions: opaque, sealed and non-generative records.
130
131And that's not all. Thomas' implementation includes record-properties,
132which can be attached to record-type-descriptors -- henceforth
133abbreviated rtd's -- and which can be used to implement single
134inheritance object orientation.
135
136
137==== Type extension
138
139From now on, we assume srfi-99 is used.
140
141Let's start with specializing a rectangle to a square in
142the procedural interface. First rects.
143
144<enscript highlight=scheme>
145(define RECT (make-rtd 'rect
146               '#((mutable x) (mutable y) (mutable w) (mutable h))))
147(define Rect (rtd-constructor RECT))
148(define rect? (rtd-predicate RECT))
149(define rect-x (rtd-accessor RECT 'x))
150(define rect-y (rtd-accessor RECT 'y))
151(define rect-w (rtd-accessor RECT 'w))
152(define rect-h (rtd-accessor RECT 'h))
153</enscript>
154
155Apart from name-changes, you'll notice, that the fields are now
156referenced in a vector instead of a list and they are tagged as mutable.
157Alternatively, you could have tagged them with immutable. Short forms of,
158e.g. {{(mutable x)}} or {{(immutable y)}} are accepted as well, namely {{(x)}} or {{y}}
159respectively, but I strongly recommend, not to use them: It's all to
160easy to write {{x}} when you mean {{(x)}} and later wonder, why a setter doesn't
161work, although you have explicitly supplied a correct one.
162Another change is, that explicit mutators via {{getter-with-setter}} are
163missing; they are automatically provided by the srfi-99 library, so
164something like {{(set!  (rect-x rt) 10)}} would work as expected, provided
165the field x is tagged as mutable.
166The name-changes of srfi-99 with the rtd abbreviations, untypical for
167Scheme, are caused not to conflict with R6RS-records.
168
169But the fun begins now, specializing rects to squares.
170
171<enscript highlight=scheme>
172(define SQUARE (make-rtd 'square '#() #:parent RECT))
173(define (Square x y l)
174  ((rtd-constructor SQUARE) x y l l))
175(define (square? rt)
176  (and ((rtd-predicate SQUARE) rt) (= (rect-w rt) (rect-h rt))))
177</enscript>
178
179Note, that the slot vector is empty. There are no new slots. But the
180constructor and the predicate need to be corrected to reflect the
181spezialization. A raw {{rtd-constructor}} of a child rtd accepts the
182parent's and the child's slots in this order as arguments.
183
184Now, every square is a rectangle, but not every rectangle a square!
185Note, that albeit the rtd SQUARE doesn't provide any accessors, they are
186inherited from rtd RECT. But the names {{rect-x}} etc. are a bit foreign to
187a square. That's where dynamic binding and object orientation comes into
188the play ...
189
190==== Record properties and object orientation
191
192The above is fine, but there is a serious drawback: The accessors are
193statically bound. So we had to prefix the slot-names with the {{rtd-name}}
194to avoid name clashes, forcing the user of these records to remember in
195which hierarchy-level the accessors were defined; a real problem, if the
196hierarchy is deep.  We would prefer to have them dynamically bound and
197given them names like {{x}}, {{y}}, {{w}} and {{h}}, the actual routine being looked up
198by the system.  That's exactly what record-properties provide.
199
200First we have to define, for each method to be implemented, in
201particular for the slots, record-properties, e.g.
202{{(define-record-property x)}}/
203
204This defines procedures of at least one argument, which will eventually
205be applied to records, which have corresponding procedures bound to its
206record-type-descriptor. Before this happens, these properties will
207allways return the default value {{#f}} independently of its argument; try
208this by issuing {{(x #t)}} or {{(x #t #t #t)}}. If you want another value to be
209returned, you must supply it as a second argument to
210{{define-record-property}}. This second argument is returned via CHICKEN's
211constantly procedure.  But you should be aware, that symbols as second
212argument to {{record-properties}} are treated specially: inside rtd's they
213refer to accessors of equally named fields.
214
215To bind properties to record-type-descriptors, you'll use the {{#:property}}
216clause of {{make-rtd}}. Note, that after their implementation in the rtd,
217the properties will be more or less dynamically bound versions of the
218statically bound accessors like {{rect-x}} and the corresponding mutators.
219The accessors are simply referenced by their names as a symbol, while
220the mutators must be curried.
221
222<enscript highlight=scheme>
223(define-record-property x)
224(define-record-property y)
225(define-record-property w)
226(define-record-property h)
227(define-record-property x!)
228(define-record-property y!)
229(define-record-property w!)
230(define-record-property h!)
231
232(define RECT
233  (make-rtd 'rect '#((mutable x) (mutable y) (mutable w) (mutable h))
234            #:property x 'x
235            #:property x!
236            (lambda (rt)
237              (lambda (a)
238                (set! (x rt) a)))
239            #:property y 'y
240            #:property y!
241            (lambda (rt)
242              (lambda (b)
243                (set! (y rt) b)))
244            #:property w 'w
245            #:property w!
246            (lambda (rt)
247              (lambda (b)
248                (set! (w rt) b)))
249            #:property h 'h
250            #:property h!
251            (lambda (rt)
252              (lambda (b)
253                (set! (h rt) b)))
254            ))
255(define Rect (rtd-constructor RECT))
256(define rect? (rtd-predicate RECT))
257
258;; now squares as speciealized rects
259(define-record-property l)
260(define-record-property l!)
261
262(define SQUARE
263  (make-rtd 'square '#()
264            #:parent RECT
265            #:property l w
266            #:property l!
267            (lambda (rt)
268               (lambda (c)
269                (set! (w rt) c)
270                (set! (h rt) c)))
271            ))
272
273(define (Square x y l)
274  ((rtd-constructor SQUARE) x y l l))
275
276(define (square? rt)
277  (and ((rtd-predicate SQUARE) rt) (= (rect-w rt) (rect-h rt))))
278</enscript>
279
280Now {{x}}, {{x!}} and friends are dynamically bound. They are called like {{(x rt)}}
281and {{((x! rt) a)}}. If there where other records with properties {{x}} and {{x!}}
282bound to its type, always the right accessor or mutator would be chosen.
283To see this, let's enhance the example, so that it's more realistic. In
284doing this, we'll package the types in modules.
285
286==== Rects revisited
287
288Realistic rects should always have numeric fields, and they should be
289movable and scalable. An area method would be nice as well.  Moreover,
290they should always be in a valid state. In other words, we would like to
291have an invariant property, which checks the validity of an object's
292state, automatic documentation and properties {{move!}}, {{scale!}} and {{area}}.
293
294Since invariant and automatic documentation should be available
295everywhere, we package corresponding properties in an abstract base
296type, OBJECT, to be overridden in any of its children. Abstract types
297don't have constructors.
298
299<enscript highlight=scheme>
300(module objects *
301  (import scheme
302          (only data-structures sort)
303          (only srfi-99
304                define-record-property
305                make-rtd
306                rtd-predicate
307                record?))
308
309(define-record-property invariant)
310(define-record-property property-names)
311
312(define OBJECT
313        (make-rtd 'object '#()
314          #:property invariant #t
315          #:property property-names
316          (lambda (obj)
317            (sort-symbols
318              '(invariant property-names)))
319          ))
320(define object? (rtd-predicate OBJECT))
321
322(define (sort-symbols symlist)
323  (sort symlist (lambda (x y)
324                  (string-ci<=? (symbol->string x)
325                                (symbol->string y)))))
326) ; objects
327</enscript>
328
329To test, that invariant works indeed everywhere, we'll use a fake
330module using the syntactic interface:
331
332<enscript highlight=scheme>
333(module foos (FOO Foo foo? invariant)
334  (import scheme objects
335          (only srfi-99 define-record-type define-record-property))
336;;; a different inheritance branch
337(define-record-type (FOO #:parent OBJECT #:property invariant "foo") (Foo) foo?)
338) ; foos
339</enscript>
340
341Now the implementation of rectangles ...
342
343<enscript highlight=scheme>
344(module rects (RECT Rect rect? x x! y y! w w! h h! move! scale! area)
345  (import scheme objects
346          (only (chicken base) error define-reader-ctor)
347          (only (chicken format) fprintf)
348          (only srfi-99 define-record-printer define-record-property
349                make-rtd rtd-constructor rtd-predicate))
350  (reexport objects)
351
352;; new properties
353(define-record-property x)
354(define-record-property x!)
355(define-record-property y)
356(define-record-property y!)
357(define-record-property w)
358(define-record-property w!)
359(define-record-property h)
360(define-record-property h!)
361(define-record-property area)
362(define-record-property move!)
363(define-record-property scale!)
364
365;;; rtd, denoted all upper case
366(define RECT
367  (make-rtd 'rect '#((mutable x) (mutable y) (mutable w) (mutable h))
368            #:parent OBJECT
369            #:property invariant
370            (lambda (rt)
371              (if (and (number? (x rt))
372                       (number? (y rt))
373                       (number? (w rt))
374                       (number? (h rt))
375                       (>= (w rt) 0)
376                       (>= (h rt) 0))
377                '(and (number? (x rt))
378                      (number? (y rt))
379                      (number? (w rt))
380                      (number? (h rt))
381                      (>= (w rt) 0)
382                      (>= (h rt) 0))
383                #f))
384            #:property property-names
385            (lambda (rt)
386              (sort-symbols
387                (append '(area scale! move! x x! y y! w w! h h!)
388                        (property-names rt OBJECT))))
389            #:property area
390            (lambda (rt) (* (w rt) (h rt)))
391            #:property move!
392            (lambda (rt)
393              (lambda (dx dy)
394                ((x! rt) (+ (x rt) dx))
395                ((y! rt) (+ (y rt) dy))))
396            #:property scale!
397            (lambda (rt)
398              (lambda (s)
399                (cond
400                  ((and (number? s) (>= s 0))
401                   ((w! rt) (* s (w rt)))
402                   ((h! rt) (* s (h rt))))
403                  (else
404                    (error 'scale! "positive number expected" s)))))
405            #:property x 'x
406            #:property x!
407            (lambda (rt)
408              (lambda (a)
409                (if (number? a)
410                  (set! (x rt) a)
411                  (error 'x! "number expected" a))))
412            #:property y 'y
413            #:property y!
414            (lambda (rt)
415              (lambda (b)
416                (if (number? b)
417                  (set! (y rt) b)
418                  (error 'y! "number eypected" b))))
419            #:property w 'w
420            #:property w!
421            (lambda (rt)
422              (lambda (a)
423                (if (number? a)
424                  (set! (w rt) a)
425                  (error 'w! "number expected" a))))
426            #:property h 'h
427            #:property h!
428            (lambda (rt)
429              (lambda (a)
430                (if (number? a)
431                  (set! (h rt) a)
432                  (error 'h! "number expected" a))))
433            ))
434
435;; constructor, denoted with leading upper case
436(define (Rect a b c d)
437  (let ((result ((rtd-constructor RECT) a b c d)))
438    (if (invariant result)
439      result
440      (error 'Rect "invariant broken"))))
441;; predicate
442(define (rect? arg)
443  (and ((rtd-predicate RECT) arg)
444       (if (invariant arg) #t #f)))
445
446;; printer
447(define-record-printer (RECT rt out)
448  (fprintf out "#,(rect ~s ~s ~s ~s)"
449               (x rt) (y rt) (w rt) (h rt)))
450
451;; reader
452(define-reader-ctor 'rect Rect)
453
454) ; rects
455</enscript>
456
457... and of squares:
458
459<enscript highlight=scheme>
460(module squares (SQUARE Square square? l l!)
461  (import scheme
462          rects
463          (only (chicken base) error define-reader-ctor)
464          (only (chicken format) fprintf)
465          (only srfi-99 define-record-printer define-record-property
466                make-rtd rtd-constructor rtd-predicate))
467  (reexport rects)
468
469(define-record-property l)
470(define-record-property l!)
471
472;;; type extension, aka inheritance
473(define SQUARE
474  (make-rtd 'square '#()
475            #:parent RECT
476            #:property invariant
477            (lambda (rt)
478              (if (and (invariant rt RECT)
479                       (= (w rt) (h rt)))
480                '(and (invariant rt RECT)
481                      (= (w rt) (h rt)))
482                #f))
483            #:property property-names
484            (lambda (rt)
485              (sort-symbols
486                (append '(l l!)
487                        (property-names rt RECT))))
488            #:property l w
489            #:property l!
490            (lambda (rt)
491              (lambda (c)
492                (set! (w rt) c)
493                (set! (h rt) c)))
494            ))
495
496;; constructor, denoted with leading upper case
497(define (Square x y l)
498  (let ((result ((rtd-constructor SQUARE) x y l l)))
499    (if (invariant result)
500      result
501      (error 'Square "invariant broken"))))
502;; predicate
503(define (square? arg)
504  (and ((rtd-predicate SQUARE) arg)
505       (invariant arg)))
506;; printer
507(define-record-printer (SQUARE rt out)
508  (fprintf out "#,(square ~s ~s ~s)" (x rt) (y rt) (l rt)))
509
510;; reader
511(define-reader-ctor 'square Square)
512
513) ; squares
514</enscript>
515
516Interesting is, how invariant and property-names are overridden in the
517subtpye {{SQUARE}}. To access the parent versions, simply add the supertype
518{{RECT}} as a second argument to the property.
519Another interesting point is the constructor {{Square}}. You can't simply
520call {{(Rect x y l l)}}. This would create a {{RECT}}, not a {{SQUARE}}. But the
521latter has four slots, not three. So you must call
522{{((rtd-constructor SQUARE) x y l l)}} and check the invariant. Note in
523passing that child constructors always expect the parent slots before the
524child slots. The latter don't exist in the present case.
525Note also, that property {{l}} is simply equivalent to property {{w}}, but {{l!}}
526isn't equivalent to {{w!}}.
527And last, but not least, properties {{move!}}, {{scale!}} and area needn't be
528redefined in {{SQUARE}}, the parent versions do the job.
529
530Now you can test your objects as well as some inspectors, issuing e.g.
531
532<enscript highlight=scheme>
533(import foos squares
534        (only srfi-99 rtd? record? rtd-name rtd-uid rtd-parent
535              rtd-field-names rtd-all-field-names))
536(rtd? SQUARE)
537(rtd-name (rtd-parent SQUARE))
538(rtd-field-names SQUARE)
539(rtd-all-field-names SQUARE)
540(rtd-uid RECT)
541(rtd-field-names RECT)
542(define sq (Square 1 2 3))
543(define rt (Rect 0 0 1 2))
544(object? sq)
545(record? rt)
546(invariant sq)
547(invariant rt)
548(type-name rt)
549(parent-type-name sq)
550(define foo (Foo))
551(rect? foo)
552(foo? foo)
553(invariant foo)
554(square? sq)
555(rect? sq)
556(square? rt)
557(x sq)
558(y sq)
559(l sq)
560(x rt)
561(y rt)
562(w rt)
563(h rt)
564((move! sq) 10 20)
565(invariant sq)
566(x sq)
567(y sq)
568(l sq)
569((x! sq) 0)
570((y! sq) 0)
571((l! sq) 5)
572(invariant sq)
573rt
574sq
575</enscript>
576
577==== Variant records and object orientation
578
579Above, we've implemented methods as record-properties, Thomas Chust's
580extension to srfi-99 records. This way, the record alone encapsulates
581data and properties. But there is another pattern to implement object
582orientation with srfi-99 records, taking the message-sending metaphor
583literally. In this pattern, the record has only one record-property, a
584message handler, which accepts messages as arguments and discriminates
585between them according to their type. And messages can conveniently be
586implemented as variant records, another of Thomas' extensions to srfi-99
587records.
588
589In this pattern, instead of calling the property move! as above,
590
591{{((move! sq) 10 20)}},
592
593a {{move!}} message is send to {{sq}}'s only property, its handler, as follows
594
595{{((handle sq) (move! 10 20))}}
596
597Whereas in the method-properties pattern, encapsulation is achieved by
598the record, in the message-sending pattern, the module does the
599encapsulation job. This means, equally named methods are discriminated
600by the record instance, equally named messages need to be renamed or
601prefixed.
602
603In essence, variant records supply two macros,
604
605* {{define-variant-type}}
606* {{variant-case}}
607
608the former defining a series of constructors, the latter discriminating
609between them in a case like fashion. Our old friends, objects, rects
610and squares can now be implemented as follows.
611
612<enscript highlight=scheme>
613;; abstract root object
614(module objects (OBJECT handle OBJECT-MESSAGE object-message? invariant messages)
615  (import scheme
616          (only (chicken base) constantly error)
617          (only srfi-99
618                define-record-property
619                make-rtd
620                rtd-predicate
621                record?
622                record-rtd
623                rtd-name
624                rtd-parent
625                define-variant-type
626                variant-case))
627 
628(define-record-property handle) ; the only property
629
630;; message constructors
631(define-variant-type OBJECT-MESSAGE object-message?
632  (invariant)
633  (messages))
634
635(define OBJECT
636  (make-rtd 'object '#()
637            #:property handle
638            (lambda (obj)
639              (lambda (msg)
640                (if (object-message? msg)
641                  (variant-case OBJECT-MESSAGE msg
642                    ((invariant) #t)
643                    ((messages) '((#:OBJECT (invariant) (messages)))))
644                  ;do nothing (enabling broadcasts)
645                  )))))
646
647(define object? (rtd-predicate OBJECT))
648
649) ; objects
650</enscript>
651
652Note, how the messages are defined and set apart. Besides the message
653type and predicate two parameterless constructors, invariant and
654messages, are defined and exported by the module. The exported handle
655property then inspects -- using variant-case -- the message constructors
656in sequence and invokes the code of the first matching one, after having
657checked, that {{msg}} is indeed of type {{OBJECT-MESSAGE}}, invoking the else
658clause otherwise. Here, the else clause does nothing on purpose: Message
659handling can be used for broadcasting. Hence, if a message is not
660understood, nothing happens.
661
662Here, these constructors are parameterless, but as we'll see in the
663sequel, variant-case not only serves as a discriminator, but also as an
664accessor to the constructors' arguments, without need to define accessor
665procedures.
666
667Here's the new version of the {{rects}} module:
668
669<enscript highlight=scheme>
670(module rects (RECT Rect rect? RECT-MESSAGE rect-message? x x! y y! w w!
671               h h! move! scale! area)
672  (import scheme objects
673          (only (chicken base) constantly error void define-reader-ctor)
674          (only (chicken format) fprintf)
675          (only srfi-99 define-record-printer define-record-property
676                define-variant-type variant-case
677                make-rtd rtd-constructor rtd-predicate rtd-accessor))
678  (reexport objects)
679
680;; new messages
681(define-variant-type RECT-MESSAGE rect-message?
682  (x)
683  (x! arg)
684  (y)
685  (y! arg)
686  (w)
687  (w! arg)
688  (h)
689  (h! arg)
690  (move! dx dy)
691  (scale! s)
692  (area))
693
694;;; message-handler
695(define (rect-handler obj)
696  (lambda (msg)
697    (cond
698      ((rect-message? msg)
699       (variant-case RECT-MESSAGE msg
700         ((x) (%x obj))
701         ((x! arg) (set! (%x obj) arg))
702         ((y) (%y obj))
703         ((y! arg) (set! (%y obj) arg))
704         ((w) (%w obj))
705         ((w! arg) (set! (%w obj) arg))
706         ((h) (%h obj))
707         ((h! arg) (set! (%h obj) arg))
708         ((move! dx dy)
709          (set! (%x obj) (+ (%x obj) dx))
710          (set! (%y obj) (+ (%y obj) dy)))
711         ((scale! s)
712          (set! (%w obj) (* (%w obj) s))
713          (set! (%h obj) (* (%h obj) s)))
714         ((area) (* (%w obj) (%h obj)))))
715      ((object-message? msg)
716       (variant-case OBJECT-MESSAGE msg
717        ((invariant)
718         (if (and (number? (%x obj)) (number? (%y obj))
719                  (number? (%w obj)) (number? (%h obj))
720                  (>= (%w obj) 0) (>= (%h obj) 0))
721           '(and (number? (%x obj)) (number? (%y obj))
722                 (number? (%w obj)) (number? (%h obj))
723                 (>= (%w obj) 0) (>= (%h obj) 0))
724           #f))
725         ((messages)
726          (cons '(#:RECT (x) (x! arg) (y) (y! arg) (w) (w! arg)
727                         (h) (h!  arg) (move! dx dy) (scale! s) (area))
728                ((handle obj OBJECT) (messages))))))
729      (else
730        ((handle obj OBJECT) msg)))))
731
732;;; rtd, denoted all upper case
733(define RECT
734  (make-rtd 'rect '#((mutable x) (mutable y) (mutable w) (mutable h))
735            #:parent OBJECT
736            #:property handle rect-handler
737            ))
738
739;; constructor, denoted with leading upper case
740(define (Rect a b c d)
741  (let ((result ((rtd-constructor RECT) a b c d)))
742    (if ((handle result) (invariant))
743      result
744      (error 'Rect "invariant broken"))))
745
746;; predicate
747(define (rect? arg)
748  (and ((rtd-predicate RECT) arg)
749       ((handle arg) (invariant))))
750
751;; printer
752(define-record-printer (RECT rt out)
753  (fprintf out "#,(rect ~s ~s ~s ~s)"
754                ((handle rt) (x)) ((handle rt) (y))
755                ((handle rt) (w)) ((handle rt) (h))))
756
757;; reader
758(define-reader-ctor 'rect Rect)
759
760;;hidden
761(define %x (rtd-accessor RECT 'x))
762(define %y (rtd-accessor RECT 'y))
763(define %w (rtd-accessor RECT 'w))
764(define %h (rtd-accessor RECT 'h))
765
766) ; rects
767</enscript>
768
769The interesting thing here is, that of course, the handler can be
770defined outside of the record {{RECT}} and only be referenced inside.
771The variant-record {{RECT-MESSAGE}} does only define the new messages,
772whereas {{RECT}}'s handler accepts messages of {{OBJECT-MESSAGE}} as well,
773they are imported with rects.
774
775Now the message-sending-version of the squares module.
776
777<enscript highlight=scheme>
778(module squares (SQUARE SQUARE-MESSAGE Square square? square-message? l l!)
779  (import scheme rects ;objects
780          (only (chicken base) constantly error define-reader-ctor)
781          (only (chicken format) fprintf)
782          (only srfi-99 define-record-printer define-record-property
783                define-variant-type variant-case
784                make-rtd rtd-constructor rtd-predicate rtd-accessor))
785  (reexport rects)
786
787;; new messages
788(define-variant-type SQUARE-MESSAGE square-message?
789  (l)
790  (l! arg))
791
792(define (square-handler obj)
793  (lambda (msg)
794    (cond
795      ((square-message? msg)
796       (variant-case SQUARE-MESSAGE msg
797         ((l) ((handle obj) (w)))
798         ((l! arg)
799          ((handle obj) (w! arg))
800          ((handle obj) (h! arg)))))
801      ((object-message? msg)
802       (variant-case OBJECT-MESSAGE msg
803        ((invariant)
804         (if (and ((handle obj RECT) (invariant))
805                  (= ((handle obj) (w)) ((handle obj) (h))))
806           '(and ((handle obj RECT) (invariant))
807                 (= ((handle obj) (w)) ((handle obj) (h))))
808           #f))
809        ((messages)
810         (cons '(#:SQUARE (l) (l! arg))
811                 ((handle obj RECT) (messages))))))
812      (else
813       ((handle obj RECT) msg)))))
814
815;;;; type extension, aka inheritance
816(define SQUARE
817  (make-rtd 'square '#()
818            #:parent RECT
819            #:property handle square-handler))
820
821(define (Square x y l)
822  (let ((result ((rtd-constructor SQUARE) x y l l)))
823    (if ((handle result) (invariant))
824      result
825      (error 'Square "invariant broken"))))
826
827(define (square? arg)
828  (and ((rtd-predicate SQUARE) arg)
829       ((handle arg) (invariant))))
830
831;; printer
832(define-record-printer (SQUARE rt out)
833  (fprintf out "#,(square ~s ~s ~s)" ((handle rt) (x))
834                                     ((handle rt) (y))
835                                     ((handle rt) (l))))
836
837;; reader
838(define-reader-ctor 'square Square)
839
840) ; squares
841</enscript>
842
843To show the usage of this oop message-sending pattern compared to the
844above method-property pattern, simply do the following
845
846<enscript highlight=scheme>
847(define sq (Square 0 0 1))
848(define rt (Rect 0 0 10 20)
849(for-each (lambda (x) ((handle x) (l! 5))) (list sq rt))
850</enscript>
851
852No error occurs! Instead, only {{sq}} has changed, but {{rt}} is untouched:
853{{RECT}} can't handle the {{(l! 5)}} message and hence ignores it.  This is
854exactly the behaviour you want when broadcasting a message. There is no
855easy way to do the same with methods.
856
857==== The datatype egg
858
859Above, messages are defined with {{define-variant-type}} and processed with
860variant-case from the srfi-99 library. That's not the only possibility.
861You can use {{define-datatype}} and cases from the datatype egg instead, an
862implementation of the equally named routines from the classic
863Friedman, Wand, Haynes, Essentials of programming languages.
864We will not rewrite our modules objects, rects and squares in this
865terminology, but simply note the differences in syntax and semantics.
866
867Whereas the constructors in {{define-variant-type}} are written as normal
868Scheme procedures, e.g. {{(move! dx dy)}}, define-datatype constructors
869specify argument type predicates, or, more general, preconditions:
870{{(move! (dx number?) (dy number?))}}. In other words, type tests are done
871automatically. This saves a lot of work. Moreover, by redefining a
872constructor in a module, the preconditions can be intensified by
873additional predicates, which is in accordance with the "is a"
874relationship of inheritance.
875
876The cases construct of the datatype egg differs from variant-case above
877insofar, as they are not written as procedure calls. Instead of
878{{((move! dx dy) ...)}} one writes {{(move! (dx dy) ...)}}. This underlines the
879fact, that the variants play different roles. They serve not only as
880constructors, but as discriminators and accessors as well ...
881
882=== Epilogue
883
884We've seen, that srfi-99 records provide all the means to implement OOP,
885especially in Thomas Chust's implementation. We've also described two
886patterns to do that, methods and messages. Which pattern you prefer, is
887on your own. Both have advantages and drawbacks. Methods are more
888tightly coupled with records, messages are more flexible, in particular,
889they allow broadcasts. In connection with define-datatype, they provide
890automatic precondition tests, where preconditions can even be
891intensified.
892
893It should be noted, that Chicken Scheme supplies a lot of eggs with
894other implementations of OOP. One, based on datatype and message passing
895as described above, is supplied in the datatypes egg (note the plural).
896The most complete one, however, is coops, which is similar to Common
897Lisp's CLOS.
898This diversity demonstrates the power of the simple minimalist Scheme language ...
899
900== Last update
901
902Jun 25, 2015
903
904== Author
905
906[[/users/juergen-lorenz|Juergen Lorenz]]
Note: See TracBrowser for help on using the repository browser.