source: project/wiki/eggref/5/yasos @ 36329

Last change on this file since 36329 was 36329, checked in by Ivan Raikov, 2 years ago

yasos doc for C5

File size: 20.8 KB
Line 
1[[tags: egg]]
2
3== yasos
4
5[[toc:]]
6
7=== Description
8
9"Yet another Scheme Object System"
10
11A very simple OOP system with multiple inheritance, that allows mixing of styles and separates interface from implementation. There are no classes, no meta-anything, simply closures.
12
13=== Scheming with  Objects
14
15There is a saying--attributed to Norman Adams--that "Objects are a
16poor man's closures." In this article we discuss what closures are and
17how objects and closures are related, show code samples to make these
18abstract ideas concrete, and implement a Scheme Object System which
19solves the problems we uncover along the way.
20
21==== The Classical Object Model
22
23Before discussing object oriented programming in Scheme, it pays to
24take a look at the classical model so that we have something to
25compare with and in order to clarify some of the terminology.  One of
26the problems that the OO movement created for itself was the use of
27new terms to get away from older concepts and the confusion this has
28caused.  So before going further I would like to give some of my own
29definitions and a simple operational model.  The model is not strictly
30correct as most compiled systems use numerous short cuts and special
31optimization tricks, but it is close enough for most practical
32purposes and has been used to implement OO programming in imperative
33languages.
34
35An object "instance" consists of local (encapsulated) state and a
36reference to shared code which operates on its state.  The easy way to
37think of this is as a C struct or Pascal record which has one field
38reserved for a pointer to its shared code environment and other slots
39for its instance variables.  Each procedure in this shared environment
40is called a "method." A "class" is code which is can generate
41instances (new records) by initializing their fields, including a
42pointer to the instance's shared method environment.  The environment
43just maps method names to their values (their code).  Each method is a
44procedure which takes the record it is operating on as its first,
45sometimes hidden, argument.  The first argument is called the
46"reciever" and typically aliased to the name "self" within the
47procedure's code.
48
49In order to make code management easy, object oriented systems such as
50Actor or Smalltalk wish to deal with code as objects and the way this
51is done is by making each class an object instance as well.  In order
52to manipulate the class's code, however a "meta-class" is typically
53defined and in some cases a meta-meta...  Well, you get the idea.
54Many people have spent a great deal of time in theories of how to
55"ground" such systems without infinite recursion.  To confuse things
56further, many object systems have an object named "object" and a class
57object named "class"--so that the class of the "class" object is
58`class'.
59
60By making every data object an instance of the OO system, uniformity
61demands that numbers are added, e.g. 1 + 2 by "sending the message" +
62to the object 1 with the argument 2.  This has the advantage that + is
63polymorphic--it can be applied to any data object.  Unfortunately,
64polymorphism also makes optimization hard in that the compiler can no
65longer make assumptions about + and may not be able to do constant
66folding or inlining.
67
68The set of methods an object responds to is called a "protocol".
69Another way of saying this is that the functions or operations that
70are invokeable on an object make up its interface.  More than one
71class of object may respond to the same protocol--i.e. many different
72types of objects have the same operation names available.
73
74
75==== Object Based Message Passing
76
77
78So how can this "message passing" be implemented with lexical
79closures?  And what are these closure things anyway?
80
81References within a function to variables outside of the local
82scope--free references--are resolved by looking them up in the
83environment in which the function finds itself.  When a language is
84lexically scoped, you see the shape of the environment when you
85read--lex--the code.  In Scheme, when a function is created it
86remembers the environment in which it was created.  Free names are
87looked up in that environment, so the environment is said to be
88"closed over" when the function is created.  Hence the term "closure."
89
90
91An example may help here:
92
93<enscript highlight=scheme>
94(define (curried-add x) (lambda (y) (+ x y))
95
96(define add8 (curried-add 8))
97
98(add8 3)        ;-> 11
99</enscript>
100
101
102When add8 is applied to its argument, we are doing ((lambda (y) (+ x y)) 3)
103
104The function add8 remembers that X has the value 8.  It gets the value
105Y when it is applied to 3.  It finds that + is the addition function.
106So (add8 3) evaluates to 11.
107
108(define ADD5 (curried-add 5)) makes a new function which shares the
109curried-add code (lambda (y) (+ x y)), but remembers that in its
110closed over environment, X has the value 5.
111
112Now that we have a way to create data objects, closures, which share
113code but have different data, we just need a "dispatching function" to
114which we can pass the symbols we will use for messages:
115
116
117<enscript highlight=scheme>
118(define (MAKE-POINT the-x the-y)
119  (lambda (message)
120     (case message
121  ((x)  (lambda () the-x)) ;; return a function which returns the answer
122  ((y)  (lambda () the-y))
123  ((set-x!)
124       (lambda (new-value)
125               (set! the-x new-value)  ;; do the assignment
126                the-x))                ;; return the new value
127  ((set-y!)
128       (lambda (new-value)
129               (set! the-y new-value)
130                the-y))
131 (else (error "POINT: Unknown message ->" message)))))
132
133(define p1 (MAKE-POINT 132 75))
134
135(define p2 (MAKE-POINT 132 57))
136
137((p1 'x))       ;-> 132
138
139((p1 'set-x!) 5)        ;-> 5
140</enscript>
141
142
143We can even change the message passign style to function calling style:
144
145<enscript highlight=scheme>
146(define (x obj) (obj 'x))
147
148(define (set-x! obj new-val) ((obj 'set-x!) new-val))
149
150
151(set-x! p1 12)  ;-> 12
152
153(x p1)          ;-> 12
154
155(x p2)          ;-> 132 ;; p1 and p2 share code but have different local data
156</enscript>
157
158Using Scheme's lexical scoping, we can also define make-point as:
159
160<enscript highlight=scheme>
161(define (MAKE-POINT the-x the-y)
162
163  (define (get-x) the-x)        ;; a "method"
164
165  (define (get-y) the-y)
166
167  (define (set-x! new-x)
168     (set! the-x new-x)
169     the-x)
170
171  (define (set-y! new-y)
172     (set! the-y new-y)
173     the-y)
174
175  (define (self message)
176     (case message
177  ((x)            get-x) ;; return the local function
178  ((y)            get-y)
179  ((set-x!) set-x!)
180  ((set-y!) set-y!)
181  (else (error "POINT: Unknown message ->" message))))
182
183  self)  ;; the return value of make-point is the dispatch function
184</enscript>
185
186
187==== Adding Inheritance
188
189
190"Inheritance" means that one object may be specialized by adding to
191and/or shadowing another's behavior.  It is said that "object based"
192programming together with inheritance is "object oriented" programming.
193How can we add inheritance to the above picture?  By delegating to
194another object!
195
196
197<enscript highlight=scheme>
198(define (MAKE-POINT-3D a b the-z)
199  (let ((point (MAKE-POINT a b)))
200
201   (define (get-z) the-z)
202
203   (define (set-z! new-value)
204(set! the-z new-value)
205the-z)
206
207   (define (self message)
208     (case message
209   ((z)                 get-z)
210   ((set-z!)    set-z!)
211   (else (point message))))
212
213  self)
214
215(define p3 (MAKE-POINT-3D 12 34 217))
216
217(x p3)          ;-> 12
218
219(z p3)          ;-> 217
220
221(set-x! p3 12)  ;-> 12
222
223(set-x! p2 12)  ;-> 12
224
225(set-z! p3 14)  ;-> 14
226</enscript>
227
228Note that in this style, we are not required to have a single distinguished
229base object, "object"--although we may do so if we wish.
230
231
232==== What Is Wrong With The Above Picture ?
233
234
235While the direct strategy above is perfectly adequate for OO
236programming, there are a couple of rough spots.  For example, how can
237we tell which functions are points and which are not?  We can define a
238POINT?  predicate, but not all Scheme data objects will take a 'point?
239message.  Most will generate error messages, but some will just "do
240the wrong thing."
241
242<enscript highlight=scheme>
243(define (POINT? obj) (and (procedure? obj) (obj 'point?)))
244
245(POINT? list)         -> (POINT?)  ;; a list with the symbol 'point?
246</enscript>
247
248We want a system in which all objects participate and in which we can
249mix styles.  Building dispatch functions is repetitive and can
250certainly be automated--and let's throw in multiple inheritance while
251we are at it.  Also, it is generally a good design principle to
252separate interface from implementation, so we will.
253
254
255==== One Set Of Solutions
256
257The following is one of a large number of possible implementations.
258Most Scheme programmers I know have written at least one object system
259and some have written several.  Let's first look at the interface, then
260how it is used, then how it was implemented.
261
262In order to know what data objects are "instances", we have a
263predicate, INSTANCE?, which takes a single argument and answers #t or
264#f. 
265
266For each kind of object is also useful to have a predicate, so we
267define a predicate maker: (DEFINE-PREDICATE <opname?>) which by default
268answers #f. 
269
270To define operations which operate on any data, we need a default
271behavior for data objects which don't handle the operation:
272(define-operation (opname self arg ...) default-body).
273If we don't supply a default-behavior, the default default-behavior
274is to generate an error.
275
276We certainly need to return values which are instances of our object
277system: (object operation... ), where an operation has the form:
278((opname self arg ...) body).  There is also a let-like form for
279multiple inheritance:
280
281   (object-with-ancestors ((ancestor1 init1) ...) operation ...).
282
283In the case of multiple inherited operations with the same identity,
284the operation used is the one found in the first ancestor in the
285ancestor list.
286
287And finally, there is the "send to super" problem, where we want to
288operate as an ancestor, but maintain our own self identity:
289
290  (operate-as component operation composite arg ...),
291
292or, in curried form
293
294  ((operate-as component operation) composite arg ...).
295
296Note that in this system, code which creates instances is just code, so
297there there is no need to define "classes" and no meta-<anything>!
298
299=== Usage
300
301(require-extension yasos)
302
303=== Module yasos
304
305==== yasos
306
307<procedure>(yasos)</procedure>
308<procedure>(yasos sym)</procedure>
309
310documentation procedure: Lists the exported symbols, if run as a thunk,
311or the documentation of the exported sym.
312
313==== protocol
314
315<procedure>(protocol obj)</procedure>
316<procedure>(protocol obj sym)</procedure>
317
318if run as thunk, returns the list of operations, obj accepts,
319otherwise the signature of sym.
320
321This operation is available for each yasos object without intervention
322of the client.
323
324==== show
325
326<procedure>(show obj)</procedure>
327<procedure>(show obj arg)</procedure>
328
329prints obj with format to stdout, if no optional arg is given, or to the
330first format argument. To be updated in operations.
331
332==== size
333
334<procedure>(size obj)</procedure>
335
336returns the size of an object. To be updated in operations.
337
338==== define-predicate
339
340<macro>(define-predicate name)</macro>
341
342defines a predicate.
343
344==== define-operation
345
346<macro>(define-operation (name obj . args) . default-body)</macro>
347
348defines an operation, obj should accept, with arguments args and
349default-body in case, no name is defined within operations.
350
351==== operations
352
353<macro>(operations ((ancestor init) ...) ((name self . args) . body) ...)</macro> 
354
355defines the list of operations, the object self will accept, possibly
356inheriting ancestor ...
357
358==== operate-as
359
360<macro>(operate-as super operation)</macro>
361<macro>(operate-as super operation self . args)</macro>
362
363operation is send to super. The first is a curried version of the
364second.
365
366The following two macros are deprecated but still exported. They are
367superseded by operations.
368
369==== object
370
371<macro>(object ((name self . args) . body) ...)</macro>
372
373same as (operations () ((name self . args) . body) ...)
374
375==== object-with-ancestors
376
377<macro>(object-with-ancestors ((ancestor init) ...) ((name self . args) . body) ...)</macro> 
378
379same as operations.
380
381==== Example
382
383===== person interface
384
385<enscript highlight=scheme>
386(define-predicate person?)
387(define-operation (name obj))
388(define-operation (age obj))
389(define-operation (set-age! obj new-age))
390(define-operation (ssn obj password)) ;; Social Security # is protected
391(define-operation (new-password obj old-passwd new-passwd))
392(define-operation (bad-password obj bogus-passwd)
393  ;; assume internal (design) error
394  (error (format #f "Bad Password: ~s given to ~a~%"
395          bogus-passwd
396          (show obj #f))))
397</enscript>
398
399===== person implementation
400
401<enscript highlight=scheme>
402(define (make-person a-name an-age a-ssn the-password)
403  (object
404    ((person? self) #t)
405    ((name self) a-name)
406    ((age self) an-age)
407    ((set-age! self val) (set! an-age val) an-age)
408    ((ssn self password)
409      (if (equal? password the-password)
410        a-ssn
411        (bad-password self password)))
412    ((new-password self old-passwd new-passwd)
413      (cond
414        ((equal? old-passwd the-password) (set! the-password new-passwd) self)
415        (else (bad-password self old-passwd))))
416    ((bad-password self bogus-passwd)
417      (format #t "Bad password: ~s~%" bogus-passwd)) ;; let user recover
418    ((show self port)
419      (format port "#<Person: ~a age: ~a>~%" (name self) (age self)))))
420</enscript>
421
422===== account-history and bank-account interfaces
423
424<enscript highlight=scheme>
425(define-predicate bank-account?)
426(define-operation (current-balance obj pin))
427(define-operation (add obj amount))
428(define-operation (withdraw obj amount pin))
429(define-operation (get-pin obj master-password))
430(define-operation (get-account-history obj master-password))
431</enscript>
432
433===== account-history implementation
434
435<enscript highlight=scheme>
436;; put access to bank database and report generation here
437(define (make-account-history initial-balance a-pin master-password)
438  ;; history is a simple list of balances -- no transaction times
439  (letrec
440    ((history (list initial-balance))
441     (balance (lambda () (car history))) ; balance is a function
442     (remember
443       (lambda (datum) (set! history (cons datum history)))))
444    (object
445      ((bank-account? self) #t)
446      ((add self amount) ;; bank will accept money without a password
447        (remember (+ amount (balance)))
448        ;; print new balance
449        (format #t "New balance: $~a~%" (balance)))
450      ((withdraw self amount pin)
451        (cond
452          ((not (equal? pin a-pin)) (bad-password self pin))
453          ((< (- (balance) amount) 0)
454            (format
455              #t
456              "No overdraft~% Can't withdraw more than you have: $~a~%"
457              (balance)))
458          (else
459            (remember (- (balance) amount))
460            (format #t "New balance: $~a~%" (balance)))))
461      ((current-balance self password)
462        (if (or (eq? password master-password) (equal? password a-pin))
463          (format #t "Your Balance is $~a~%" (balance))
464          (bad-password self password)))
465      ;; only bank has access to account history
466      ((get-account-history self password)
467        (if (eq? password master-password)
468          history
469          (bad-password self password))))))
470</enscript>
471
472===== bank-account implementation
473
474<enscript highlight=scheme>
475(define (make-account a-name an-age a-ssn a-pin initial-balance master-password)
476  (object-with-ancestors
477    ((customer (make-person a-name an-age a-ssn a-pin))
478     (account (make-account-history initial-balance a-pin master-password)))
479    ((get-pin self password)
480      (if (eq? password master-password)
481        a-pin
482        (bad-password self password)))
483    ((get-account-history self password)
484      ((operate-as account get-account-history) self password))
485    ;; our bank is very conservative...
486    ((bad-password self bogus-passwd)
487      (format #t "~%CALL THE POLICE!!~%"))
488    ;; protect the customer as well
489    ((ssn self password)
490      ((operate-as customer ssn) self password))
491    ((show self port)
492      (format port "#<Bank-Customer ~a>~%" (name self)))))
493</enscript>
494
495===== Running the bank-account example
496
497<enscript highlight=scheme>
498(require-extension yasos)
499
500(define main
501  (lambda ()
502    (let (
503      (fred  (make-person  "Fred"  19 "573-19-4279" 'FadeCafe))
504      (sally (make-account "Sally" 26 "629-26-9742" 'FeedBabe 263 'bank-password))
505      )
506      (show 'mist)
507      (show fred)
508      (printf "Fred's ssn: ~a~%" (ssn fred 'FadeCafe))
509      (printf "Fred: person? ~a bank-account? ~a~%" (person? fred) (bank-account? fred))
510      (show sally)
511      (printf "Sally's  ssn: ~a~%" (ssn sally 'FeedBabe))
512      (printf "Sally: person? ~a bank-account? ~a~%" (person? sally) (bank-account? sally))
513      (current-balance sally 'FeedBabe)
514      (add sally 200)
515      (add sally 300)
516      (withdraw sally 400 'FeedBabe)
517      (printf "Account history of Sally: ~a~%" (get-account-history sally 'bank-password))
518      (withdraw sally 150 (get-pin sally 'bank-password))
519      (printf "Account history of Sally: ~a~%" (get-account-history sally 'bank-password))
520      (printf "Bad password for Fred:~%")
521      (ssn fred 'bogus)
522      (printf "Bad password for Sally:")
523      (ssn sally 'bogus)
524      (void))))   
525(main)
526</enscript>
527
528=== Module stacks
529
530an implementation of random-acces stacks
531
532==== make-stack
533
534<procedure>(make-stack)</procedure>
535
536creates an empty stack.
537
538==== make-ra-stack
539
540<procedure>(make-ra-stack)</procedure>
541
542creates an empty random access stack.
543
544==== stack?
545
546<procedure>(stack? xpr)</procedure>
547
548stack predicate.
549
550==== ra-stack?
551
552<procedure>(ra-stack? xpr)</procedure>
553
554random access stack predicate.
555
556==== push!
557
558<procedure>(push! obj val)</procedure>
559
560pushes val onto the stack.
561
562==== top
563
564<procedure>(top obj)</procedure>
565
566returns the top of the stack.
567
568==== down
569
570<procedure>(down obj k)</procedure>
571
572returns the result of stepping down the ra-stack k times.
573
574==== pop!
575
576<procedure>(pop! obj)</procedure>
577
578pops the stack.
579
580==== empty?
581
582<procedure>(empty? obj)</procedure>
583
584is stack empty?
585
586==== clear!
587
588<procedure>(clear! obj)</procedure>
589
590empties the stack.
591
592=== Module queues
593
594an implementation of queues with amortized constant time access.
595
596==== make-queue
597
598<procedure>(make-queue)</procedure>
599
600creates an empty queue.
601
602==== queue?
603
604<procedure>(queue? xpr)</procedure>
605
606queue predicate.
607
608==== enq!
609
610<procedure>(enq! obj val)</procedure>
611
612enqueues val onto the tail of the queue.
613
614==== front
615
616<procedure>(front obj)</procedure>
617
618returns the first item of the queue.
619
620==== deq!
621
622<procedure>(deq! obj)</procedure>
623
624dequeues the the first item from the queue.
625
626==== empty?
627
628<procedure>(empty? obj)</procedure>
629
630is queue empty?
631q
632==== clear!
633
634<procedure>(clear! obj)</procedure>
635
636empties the queue.
637
638=== Module points
639
640an implementation of flat points.
641
642==== make-point-cartesian
643
644<procedure>(make-point-cartesian x y)</procedure>
645
646creates a point from cartesian coordinates.
647
648==== make-point-polar
649
650<procedure>(make-point-polar rho theta)</procedure>
651
652creates a point from polar coordinates.
653
654==== point?
655
656<procedure>(point? xpr)</procedure>
657
658type predicate.
659
660==== distance
661
662<procedure>(distance obj other)</procedure>
663
664computes the distance between the two points obj and otern.
665
666The following four procedures return the respective coordinates:
667
668==== x
669
670<procedure>(x obj)</procedure>
671
672==== y
673
674<procedure>(y obj)</procedure>
675
676==== rho
677
678<procedure>(rho obj)</procedure>
679
680==== theta
681
682<procedure>(theta obj)</procedure>
683
684The following three commands do what their names suggest:
685
686==== scale!
687
688<procedure>(scale! obj factor)</procedure>
689
690==== rotate!
691
692<procedure>(rotate! obj angle)</procedure>
693
694==== translate!
695
696<procedure>(translate! obj dx dy)</procedure>
697
698=== Author
699
700Kenneth Dickey
701Ken(dot)Dickey(at)Whidbey(dot)Com
702
703ported to CHICKEN and enhanced by Juergen Lorenz
704
705=== Maintainer
706
707[[/users/juergen-lorenz|Juergen Lorenz]]
708
709=== License
710
711COPYRIGHT (c) 1992,2008 by Kenneth A Dickey, All rights reserved.
712COPYRIGHT (c) 2013-2014 by Juergen Lorenz, All rights reserved.
713
714Permission is hereby granted, free of charge, to any person obtaining
715a copy of this software and associated documentation files (the
716"Software"), to deal in the Software without restriction, including
717without limitation the rights to use, copy, modify, merge, publish,
718distribute, sublicense, and/or sell copies of the Software, and to
719permit persons to whom the Software is furnished to do so, subject to
720the following conditions:
721
722The above copyright notice and this permission notice shall be
723included in all copies or substantial portions of the Software.
724
725THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
726EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
727MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
728NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
729LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,WHETHER IN AN ACTION
730OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
731WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
732
733=== Changelog
734
735; 1.5 : ported to CHICKEN 5
736; 1.4 : tests with define-test instead of simple-test
737; 1.3 : operations and protocol added, define-operation with arbitrary lambda-lists, examples stacks, queues and points added
738; 1.2 : fixes in the setup script and simplification of the set of files
739; 1.1
740; 1.0 : initial import
741
Note: See TracBrowser for help on using the repository browser.