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

Last change on this file since 32518 was 32518, checked in by juergen, 5 years ago

juergen-lorenz and records-and-oop updated

File size: 30.2 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 special-forms unit. 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.
50rect-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 special-forms unit, 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 library unit 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 records egg.  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
11110.
112
113Henceforth, record-type descriptors will be written all uppercase, and
114the corresponding constructor starting uppercase.
115
116=== srfi-99
117
118Chicken'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,
127Chicken'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
210define-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 childs. 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 error define-reader-ctor)
347          (only extras 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 error define-reader-ctor)
464          (only extras 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
518RECT 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 inpectors, 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 error)
617          (only data-structures constantly)
618          (only srfi-99
619                define-record-property
620                make-rtd
621                rtd-predicate
622                record?
623                record-rtd
624                rtd-name
625                rtd-parent
626                define-variant-type
627                variant-case))
628 
629(define-record-property handle) ; the only property
630
631;; message constructors
632(define-variant-type OBJECT-MESSAGE object-message?
633  (invariant)
634  (messages))
635
636(define OBJECT
637  (make-rtd 'object '#()
638            #:property handle
639            (lambda (obj)
640              (lambda (msg)
641                (if (object-message? msg)
642                  (variant-case OBJECT-MESSAGE msg
643                    ((invariant) #t)
644                    ((messages) '((#:OBJECT (invariant) (messages)))))
645                  ;do nothing (enabling broadcasts)
646                  )))))
647
648(define object? (rtd-predicate OBJECT))
649
650) ; objects
651</enscript>
652
653Note, how the messages are defined and set apart. Besides the message
654type and predicate two parameterless constructors, invariant and
655messages, are defined and exported by the module. The exported handle
656property then inspects -- using variant-case -- the message constructors
657in sequence and invokes the code of the first matching one, after having
658checked, that msg is indeed of tye OBJECT-MESSAGE, invoking the else
659clause otherwise. Here, the else clause does nothing on purpose: Message
660handling can be used for broadcasting. Hence, if a message is not
661understood, nothing happens.
662
663Here, these constructors are parameterless, but as we'll see in the
664sequel, variant-case not only serves as a discriminator, but also as an
665accessor to the constructors' arguments, without need to define accessor
666procedures.
667
668Here's the new version of the rects module:
669
670<enscript highlight=scheme>
671(module rects (RECT Rect rect? RECT-MESSAGE rect-message? x x! y y! w w!
672               h h! move! scale! area)
673  (import scheme objects
674          (only chicken error void define-reader-ctor)
675          (only data-structures constantly)
676          (only extras fprintf)
677          (only srfi-99 define-record-printer define-record-property
678                define-variant-type variant-case
679                make-rtd rtd-constructor rtd-predicate rtd-accessor))
680  (reexport objects)
681
682;; new messages
683(define-variant-type RECT-MESSAGE rect-message?
684  (x)
685  (x! arg)
686  (y)
687  (y! arg)
688  (w)
689  (w! arg)
690  (h)
691  (h! arg)
692  (move! dx dy)
693  (scale! s)
694  (area))
695
696;;; message-handler
697(define (rect-handler obj)
698  (lambda (msg)
699    (cond
700      ((rect-message? msg)
701       (variant-case RECT-MESSAGE msg
702         ((x) (%x obj))
703         ((x! arg) (set! (%x obj) arg))
704         ((y) (%y obj))
705         ((y! arg) (set! (%y obj) arg))
706         ((w) (%w obj))
707         ((w! arg) (set! (%w obj) arg))
708         ((h) (%h obj))
709         ((h! arg) (set! (%h obj) arg))
710         ((move! dx dy)
711          (set! (%x obj) (+ (%x obj) dx))
712          (set! (%y obj) (+ (%y obj) dy)))
713         ((scale! s)
714          (set! (%w obj) (* (%w obj) s))
715          (set! (%h obj) (* (%h obj) s)))
716         ((area) (* (%w obj) (%h obj)))))
717      ((object-message? msg)
718       (variant-case OBJECT-MESSAGE msg
719        ((invariant)
720         (if (and (number? (%x obj)) (number? (%y obj))
721                  (number? (%w obj)) (number? (%h obj))
722                  (>= (%w obj) 0) (>= (%h obj) 0))
723           '(and (number? (%x obj)) (number? (%y obj))
724                 (number? (%w obj)) (number? (%h obj))
725                 (>= (%w obj) 0) (>= (%h obj) 0))
726           #f))
727         ((messages)
728          (cons '(#:RECT (x) (x! arg) (y) (y! arg) (w) (w! arg)
729                         (h) (h!  arg) (move! dx dy) (scale! s) (area))
730                ((handle obj OBJECT) (messages))))))
731      (else
732        ((handle obj OBJECT) msg)))))
733
734;;; rtd, denoted all upper case
735(define RECT
736  (make-rtd 'rect '#((mutable x) (mutable y) (mutable w) (mutable h))
737            #:parent OBJECT
738            #:property handle rect-handler
739            ))
740
741;; constructor, denoted with leading upper case
742(define (Rect a b c d)
743  (let ((result ((rtd-constructor RECT) a b c d)))
744    (if ((handle result) (invariant))
745      result
746      (error 'Rect "invariant broken"))))
747
748;; predicate
749(define (rect? arg)
750  (and ((rtd-predicate RECT) arg)
751       ((handle arg) (invariant))))
752
753;; printer
754(define-record-printer (RECT rt out)
755  (fprintf out "#,(rect ~s ~s ~s ~s)"
756                ((handle rt) (x)) ((handle rt) (y))
757                ((handle rt) (w)) ((handle rt) (h))))
758
759;; reader
760(define-reader-ctor 'rect Rect)
761
762;;hidden
763(define %x (rtd-accessor RECT 'x))
764(define %y (rtd-accessor RECT 'y))
765(define %w (rtd-accessor RECT 'w))
766(define %h (rtd-accessor RECT 'h))
767
768) ; rects
769</enscript>
770
771The interesting thing here is, that of course, the handler can be
772defined outside of the record RECT and only be referenced inside.
773The variant-record RECT-MESSAGE does only define the new messages,
774whereas RECT's handler accepts messages of OBJECT-MESSAGE as well,
775they are imported with rects.
776
777Now the message-sending-version of the squares module.
778
779<enscript highlight=scheme>
780(module squares (SQUARE SQUARE-MESSAGE Square square? square-message? l l!)
781  (import scheme rects ;objects
782          (only chicken error define-reader-ctor)
783          (only data-structures constantly)
784          (only extras fprintf)
785          (only srfi-99 define-record-printer define-record-property
786                define-variant-type variant-case
787                make-rtd rtd-constructor rtd-predicate rtd-accessor))
788  (reexport rects)
789
790;; new messages
791(define-variant-type SQUARE-MESSAGE square-message?
792  (l)
793  (l! arg))
794
795(define (square-handler obj)
796  (lambda (msg)
797    (cond
798      ((square-message? msg)
799       (variant-case SQUARE-MESSAGE msg
800         ((l) ((handle obj) (w)))
801         ((l! arg)
802          ((handle obj) (w! arg))
803          ((handle obj) (h! arg)))))
804      ((object-message? msg)
805       (variant-case OBJECT-MESSAGE msg
806        ((invariant)
807         (if (and ((handle obj RECT) (invariant))
808                  (= ((handle obj) (w)) ((handle obj) (h))))
809           '(and ((handle obj RECT) (invariant))
810                 (= ((handle obj) (w)) ((handle obj) (h))))
811           #f))
812        ((messages)
813         (cons '(#:SQUARE (l) (l! arg))
814                 ((handle obj RECT) (messages))))))
815      (else
816       ((handle obj RECT) msg)))))
817
818;;;; type extension, aka inheritance
819(define SQUARE
820  (make-rtd 'square '#()
821            #:parent RECT
822            #:property handle square-handler))
823
824(define (Square x y l)
825  (let ((result ((rtd-constructor SQUARE) x y l l)))
826    (if ((handle result) (invariant))
827      result
828      (error 'Square "invariant broken"))))
829
830(define (square? arg)
831  (and ((rtd-predicate SQUARE) arg)
832       ((handle arg) (invariant))))
833
834;; printer
835(define-record-printer (SQUARE rt out)
836  (fprintf out "#,(square ~s ~s ~s)" ((handle rt) (x))
837                                     ((handle rt) (y))
838                                     ((handle rt) (l))))
839
840;; reader
841(define-reader-ctor 'square Square)
842
843) ; squares
844</enscript>
845
846To show the usage of this oop message-sending pattern compared to the
847above method-property pattern, simply do the following
848
849<enscript highlight=scheme>
850(define sq (Square 0 0 1))
851(define rt (Rect 0 0 10 20)
852(for-each (lambda (x) ((handle x) (l! 5))) (list sq rt))
853</enscript>
854
855No error occurs! Instead , only sq has changed, but rt is untouched:
856RECT can't handle the (l! 5) message and hence ignores it.  This is
857exactly the behaviour you want when broadcasing a message. There is no
858easy way to do the same with methods.
859
860==== The datatype egg
861
862Above, messages are defined with define-variant-type and processed with
863variant-case from the srfi-99 library. That's not the only possibility.
864You can use define-datatype and cases from the datatype egg instead, an
865implementation of the equally named routines from the classic
866Friedman, Wand, Haynes, Essentials of programming languages.
867We will not rewrite our modules objects, rects and squares in this
868terminology, but simply note the differences in syntax and semantics.
869
870Whereas the constructors in define-variant-type are written as normal
871Scheme procedures, e.g. (move! dx dy), define-datatype constructors
872specify argument type predicates, or, more general, preconditions:
873(move! (dx number?) (dy number?)). In other words, type tests are done
874automatically. This saves a lot of work. Moreover, by redefining a
875constructor in a module, the preconditions can be intensified by
876additional predicates, which is in accordance with the "is a"
877relationship of inheritance.
878
879The cases construct of the datatype egg differs from variant-case above
880insofar, as they are not written as procedure calls. Instead of
881((move! dx dy) ...) one writes (move! (dx dy) ...). This underlines the
882fact, that the variants play different roles. They serve not only as
883constructors, but as discriminators and accessors as well ...
884
885=== Epilogue
886
887We've seen, that srfi-99 records provide all the means to implement OOP,
888especially in Thomas Chust's implementation. We've also described two
889patterns to do that, methods and messages. Which pattern you prefer, is
890on your own. Both have advantages and drawbacks. Methods are more
891tightly coupled with records, messages are more flexible, in particular,
892they allow broadcasts. In connection with define-datatype, they provide
893automatic precondition tests, where preconditions can even be
894intensified.
895
896It should be noted, that Chicken Scheme supplies a lot of eggs with
897other implementations of OOP. One, based on datatype and message passing
898as described above, is supplied in the datatypes egg (note the plural).
899The most complete one, however, is coops, which is similar to Common
900Lisp's CLOS.
901This diversity demonstrates the power of the simple minimalist Scheme language ...
902
903== Last update
904
905Jun 25, 2015
906
907== Author
908
909[[/users/juergen-lorenz|Juergen Lorenz]]
910
Note: See TracBrowser for help on using the repository browser.