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

[[tags: egg]]

== yasos

[[toc:]]

=== Description

"Yet another Scheme Object System"

A 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.

=== Scheming with  Objects

There is a saying--attributed to Norman Adams--that "Objects are a
poor man's closures." In this article we discuss what closures are and
how objects and closures are related, show code samples to make these
abstract ideas concrete, and implement a Scheme Object System which
solves the problems we uncover along the way. 

==== The Classical Object Model

Before discussing object oriented programming in Scheme, it pays to
take a look at the classical model so that we have something to
compare with and in order to clarify some of the terminology.  One of
the problems that the OO movement created for itself was the use of
new terms to get away from older concepts and the confusion this has
caused.  So before going further I would like to give some of my own
definitions and a simple operational model.  The model is not strictly
correct as most compiled systems use numerous short cuts and special
optimization tricks, but it is close enough for most practical
purposes and has been used to implement OO programming in imperative
languages. 

An object "instance" consists of local (encapsulated) state and a
reference to shared code which operates on its state.  The easy way to
think of this is as a C struct or Pascal record which has one field
reserved for a pointer to its shared code environment and other slots
for its instance variables.  Each procedure in this shared environment
is called a "method." A "class" is code which is can generate
instances (new records) by initializing their fields, including a
pointer to the instance's shared method environment.  The environment
just maps method names to their values (their code).  Each method is a
procedure which takes the record it is operating on as its first,
sometimes hidden, argument.  The first argument is called the
"reciever" and typically aliased to the name "self" within the
procedure's code. 

In order to make code management easy, object oriented systems such as
Actor or Smalltalk wish to deal with code as objects and the way this
is done is by making each class an object instance as well.  In order
to manipulate the class's code, however a "meta-class" is typically
defined and in some cases a meta-meta...  Well, you get the idea.
Many people have spent a great deal of time in theories of how to
"ground" such systems without infinite recursion.  To confuse things
further, many object systems have an object named "object" and a class
object named "class"--so that the class of the "class" object is
`class'. 

By making every data object an instance of the OO system, uniformity
demands that numbers are added, e.g. 1 + 2 by "sending the message" +
to the object 1 with the argument 2.  This has the advantage that + is
polymorphic--it can be applied to any data object.  Unfortunately,
polymorphism also makes optimization hard in that the compiler can no
longer make assumptions about + and may not be able to do constant
folding or inlining. 

The set of methods an object responds to is called a "protocol".
Another way of saying this is that the functions or operations that
are invokeable on an object make up its interface.  More than one
class of object may respond to the same protocol--i.e. many different
types of objects have the same operation names available. 


==== Object Based Message Passing


So how can this "message passing" be implemented with lexical
closures?  And what are these closure things anyway? 

References within a function to variables outside of the local
scope--free references--are resolved by looking them up in the
environment in which the function finds itself.  When a language is
lexically scoped, you see the shape of the environment when you
read--lex--the code.  In Scheme, when a function is created it
remembers the environment in which it was created.  Free names are
looked up in that environment, so the environment is said to be
"closed over" when the function is created.  Hence the term "closure."


An example may help here:

<enscript highlight=scheme>
(define (curried-add x) (lambda (y) (+ x y))

(define add8 (curried-add 8))

(add8 3)        ;-> 11
</enscript>


When add8 is applied to its argument, we are doing ((lambda (y) (+ x y)) 3)

The function add8 remembers that X has the value 8.  It gets the value
Y when it is applied to 3.  It finds that + is the addition function.
So (add8 3) evaluates to 11. 

(define ADD5 (curried-add 5)) makes a new function which shares the
curried-add code (lambda (y) (+ x y)), but remembers that in its
closed over environment, X has the value 5. 

Now that we have a way to create data objects, closures, which share
code but have different data, we just need a "dispatching function" to
which we can pass the symbols we will use for messages:


<enscript highlight=scheme>
(define (MAKE-POINT the-x the-y)
  (lambda (message)
     (case message
  ((x)  (lambda () the-x)) ;; return a function which returns the answer
  ((y)  (lambda () the-y))
  ((set-x!) 
       (lambda (new-value)
               (set! the-x new-value)  ;; do the assignment
                the-x))                ;; return the new value
  ((set-y!) 
       (lambda (new-value)
               (set! the-y new-value)
                the-y))
 (else (error "POINT: Unknown message ->" message)))))

(define p1 (MAKE-POINT 132 75))

(define p2 (MAKE-POINT 132 57))

((p1 'x))       ;-> 132

((p1 'set-x!) 5)        ;-> 5
</enscript>


We can even change the message passign style to function calling style:

<enscript highlight=scheme>
(define (x obj) (obj 'x))

(define (set-x! obj new-val) ((obj 'set-x!) new-val))


(set-x! p1 12)  ;-> 12 

(x p1)          ;-> 12

(x p2)          ;-> 132 ;; p1 and p2 share code but have different local data
</enscript>

Using Scheme's lexical scoping, we can also define make-point as:

<enscript highlight=scheme>
(define (MAKE-POINT the-x the-y)

  (define (get-x) the-x)        ;; a "method"

  (define (get-y) the-y)

  (define (set-x! new-x) 
     (set! the-x new-x)
     the-x)

  (define (set-y! new-y) 
     (set! the-y new-y)
     the-y)

  (define (self message)
     (case message
  ((x)            get-x) ;; return the local function
  ((y)            get-y)
  ((set-x!) set-x!)
  ((set-y!) set-y!)
  (else (error "POINT: Unknown message ->" message))))

  self)  ;; the return value of make-point is the dispatch function
</enscript>


==== Adding Inheritance


"Inheritance" means that one object may be specialized by adding to
and/or shadowing another's behavior.  It is said that "object based"
programming together with inheritance is "object oriented" programming.
How can we add inheritance to the above picture?  By delegating to
another object! 


<enscript highlight=scheme>
(define (MAKE-POINT-3D a b the-z)
  (let ((point (MAKE-POINT a b)))

   (define (get-z) the-z)

   (define (set-z! new-value)
(set! the-z new-value)
the-z)

   (define (self message)
     (case message
   ((z)                 get-z)
   ((set-z!)    set-z!)
   (else (point message))))

  self)

(define p3 (MAKE-POINT-3D 12 34 217))

(x p3)          ;-> 12

(z p3)          ;-> 217

(set-x! p3 12)  ;-> 12

(set-x! p2 12)  ;-> 12

(set-z! p3 14)  ;-> 14
</enscript>

Note that in this style, we are not required to have a single distinguished
base object, "object"--although we may do so if we wish.


==== What Is Wrong With The Above Picture ?


While the direct strategy above is perfectly adequate for OO
programming, there are a couple of rough spots.  For example, how can
we tell which functions are points and which are not?  We can define a
POINT?  predicate, but not all Scheme data objects will take a 'point?
message.  Most will generate error messages, but some will just "do
the wrong thing."

<enscript highlight=scheme>
(define (POINT? obj) (and (procedure? obj) (obj 'point?)))

(POINT? list)         -> (POINT?)  ;; a list with the symbol 'point?
</enscript>

We want a system in which all objects participate and in which we can
mix styles.  Building dispatch functions is repetitive and can
certainly be automated--and let's throw in multiple inheritance while
we are at it.  Also, it is generally a good design principle to
separate interface from implementation, so we will. 


==== One Set Of Solutions

The following is one of a large number of possible implementations.
Most Scheme programmers I know have written at least one object system
and some have written several.  Let's first look at the interface, then
how it is used, then how it was implemented.

In order to know what data objects are "instances", we have a
predicate, INSTANCE?, which takes a single argument and answers #t or
#f.  

For each kind of object is also useful to have a predicate, so we
define a predicate maker: (DEFINE-PREDICATE <opname?>) which by default
answers #f.  

To define operations which operate on any data, we need a default
behavior for data objects which don't handle the operation:
(define-operation (opname self arg ...) default-body).
If we don't supply a default-behavior, the default default-behavior
is to generate an error.

We certainly need to return values which are instances of our object
system: (object operation... ), where an operation has the form:
((opname self arg ...) body).  There is also a let-like form for
multiple inheritance:

   (object-with-ancestors ((ancestor1 init1) ...) operation ...).

In the case of multiple inherited operations with the same identity,
the operation used is the one found in the first ancestor in the
ancestor list.

And finally, there is the "send to super" problem, where we want to
operate as an ancestor, but maintain our own self identity:

  (operate-as component operation composite arg ...),

or, in curried form

  ((operate-as component operation) composite arg ...).

Note that in this system, code which creates instances is just code, so
there there is no need to define "classes" and no meta-<anything>!

=== Usage

(require-extension yasos)

=== Module yasos

==== yasos

<procedure>(yasos)</procedure>
<procedure>(yasos sym)</procedure>

documentation procedure: Lists the exported symbols, if run as a thunk,
or the documentation of the exported sym.

==== protocol

<procedure>(protocol obj)</procedure>
<procedure>(protocol obj sym)</procedure>

if run as thunk, returns the list of operations, obj accepts,
otherwise the signature of sym.

This operation is available for each yasos object without intervention
of the client.

==== show

<procedure>(show obj)</procedure>
<procedure>(show obj arg)</procedure>

prints obj with format to stdout, if no optional arg is given, or to the
first format argument. To be updated in operations.

==== size

<procedure>(size obj)</procedure>

returns the size of an object. To be updated in operations.

==== define-predicate

<macro>(define-predicate name)</macro>

defines a predicate.

==== define-operation

<macro>(define-operation (name obj . args) . default-body)</macro>

defines an operation, obj should accept, with arguments args and
default-body in case, no name is defined within operations.

==== operations

<macro>(operations ((ancestor init) ...) ((name self . args) . body) ...)</macro> 

defines the list of operations, the object self will accept, possibly
inheriting ancestor ...

==== operate-as

<macro>(operate-as super operation)</macro>
<macro>(operate-as super operation self . args)</macro>

operation is send to super. The first is a curried version of the
second.

The following two macros are deprecated but still exported. They are
superseded by operations.

==== object

<macro>(object ((name self . args) . body) ...)</macro>

same as (operations () ((name self . args) . body) ...)

==== object-with-ancestors

<macro>(object-with-ancestors ((ancestor init) ...) ((name self . args) . body) ...)</macro> 

same as operations.

==== Example

===== person interface

<enscript highlight=scheme>
(define-predicate person?)
(define-operation (name obj))
(define-operation (age obj))
(define-operation (set-age! obj new-age))
(define-operation (ssn obj password)) ;; Social Security # is protected
(define-operation (new-password obj old-passwd new-passwd))
(define-operation (bad-password obj bogus-passwd)
  ;; assume internal (design) error
  (error (format #f "Bad Password: ~s given to ~a~%"
          bogus-passwd
          (show obj #f))))
</enscript>

===== person implementation

<enscript highlight=scheme>
(define (make-person a-name an-age a-ssn the-password)
  (object
    ((person? self) #t)
    ((name self) a-name)
    ((age self) an-age)
    ((set-age! self val) (set! an-age val) an-age)
    ((ssn self password)
      (if (equal? password the-password)
        a-ssn
        (bad-password self password)))
    ((new-password self old-passwd new-passwd)
      (cond
        ((equal? old-passwd the-password) (set! the-password new-passwd) self)
        (else (bad-password self old-passwd))))
    ((bad-password self bogus-passwd)
      (format #t "Bad password: ~s~%" bogus-passwd)) ;; let user recover
    ((show self port)
      (format port "#<Person: ~a age: ~a>~%" (name self) (age self)))))
</enscript>

===== account-history and bank-account interfaces

<enscript highlight=scheme>
(define-predicate bank-account?)
(define-operation (current-balance obj pin))
(define-operation (add obj amount))
(define-operation (withdraw obj amount pin))
(define-operation (get-pin obj master-password))
(define-operation (get-account-history obj master-password))
</enscript>

===== account-history implementation

<enscript highlight=scheme>
;; put access to bank database and report generation here
(define (make-account-history initial-balance a-pin master-password)
  ;; history is a simple list of balances -- no transaction times
  (letrec 
    ((history (list initial-balance))
     (balance (lambda () (car history))) ; balance is a function
     (remember
       (lambda (datum) (set! history (cons datum history)))))
    (object
      ((bank-account? self) #t)
      ((add self amount) ;; bank will accept money without a password
        (remember (+ amount (balance)))
        ;; print new balance
        (format #t "New balance: $~a~%" (balance)))
      ((withdraw self amount pin)
        (cond
          ((not (equal? pin a-pin)) (bad-password self pin))
          ((< (- (balance) amount) 0)
            (format 
              #t
              "No overdraft~% Can't withdraw more than you have: $~a~%"
              (balance)))
          (else
            (remember (- (balance) amount))
            (format #t "New balance: $~a~%" (balance)))))
      ((current-balance self password)
        (if (or (eq? password master-password) (equal? password a-pin))
          (format #t "Your Balance is $~a~%" (balance))
          (bad-password self password)))
      ;; only bank has access to account history
      ((get-account-history self password)
        (if (eq? password master-password)
          history
          (bad-password self password))))))
</enscript>

===== bank-account implementation

<enscript highlight=scheme>
(define (make-account a-name an-age a-ssn a-pin initial-balance master-password)
  (object-with-ancestors
    ((customer (make-person a-name an-age a-ssn a-pin))
     (account (make-account-history initial-balance a-pin master-password)))
    ((get-pin self password)
      (if (eq? password master-password)
        a-pin
        (bad-password self password)))
    ((get-account-history self password)
      ((operate-as account get-account-history) self password))
    ;; our bank is very conservative...
    ((bad-password self bogus-passwd)
      (format #t "~%CALL THE POLICE!!~%"))
    ;; protect the customer as well
    ((ssn self password)
      ((operate-as customer ssn) self password))
    ((show self port)
      (format port "#<Bank-Customer ~a>~%" (name self)))))
</enscript>

===== Running the bank-account example

<enscript highlight=scheme>
(require-extension yasos)

(define main
  (lambda ()
    (let (
      (fred  (make-person  "Fred"  19 "573-19-4279" 'FadeCafe))
      (sally (make-account "Sally" 26 "629-26-9742" 'FeedBabe 263 'bank-password))
      )
      (show 'mist)
      (show fred)
      (printf "Fred's ssn: ~a~%" (ssn fred 'FadeCafe))
      (printf "Fred: person? ~a bank-account? ~a~%" (person? fred) (bank-account? fred))
      (show sally)
      (printf "Sally's  ssn: ~a~%" (ssn sally 'FeedBabe))
      (printf "Sally: person? ~a bank-account? ~a~%" (person? sally) (bank-account? sally))
      (current-balance sally 'FeedBabe)
      (add sally 200)
      (add sally 300)
      (withdraw sally 400 'FeedBabe)
      (printf "Account history of Sally: ~a~%" (get-account-history sally 'bank-password))
      (withdraw sally 150 (get-pin sally 'bank-password))
      (printf "Account history of Sally: ~a~%" (get-account-history sally 'bank-password))
      (printf "Bad password for Fred:~%")
      (ssn fred 'bogus)
      (printf "Bad password for Sally:")
      (ssn sally 'bogus)
      (void))))   
(main)
</enscript>

=== Module stacks

an implementation of random-acces stacks

==== make-stack

<procedure>(make-stack)</procedure>

creates an empty stack.

==== make-ra-stack

<procedure>(make-ra-stack)</procedure>

creates an empty random access stack.

==== stack?

<procedure>(stack? xpr)</procedure>

stack predicate.

==== ra-stack?

<procedure>(ra-stack? xpr)</procedure>

random access stack predicate.

==== push!

<procedure>(push! obj val)</procedure>

pushes val onto the stack.

==== top

<procedure>(top obj)</procedure>

returns the top of the stack.

==== down

<procedure>(down obj k)</procedure>

returns the result of stepping down the ra-stack k times.

==== pop!

<procedure>(pop! obj)</procedure>

pops the stack.

==== empty?

<procedure>(empty? obj)</procedure>

is stack empty?

==== clear!

<procedure>(clear! obj)</procedure>

empties the stack.

=== Module queues

an implementation of queues with amortized constant time access.

==== make-queue

<procedure>(make-queue)</procedure>

creates an empty queue.

==== queue?

<procedure>(queue? xpr)</procedure>

queue predicate.

==== enq!

<procedure>(enq! obj val)</procedure>

enqueues val onto the tail of the queue.

==== front

<procedure>(front obj)</procedure>

returns the first item of the queue.

==== deq!

<procedure>(deq! obj)</procedure>

dequeues the the first item from the queue.

==== empty?

<procedure>(empty? obj)</procedure>

is queue empty?
q
==== clear!

<procedure>(clear! obj)</procedure>

empties the queue.

=== Module points

an implementation of flat points.

==== make-point-cartesian

<procedure>(make-point-cartesian x y)</procedure>

creates a point from cartesian coordinates.

==== make-point-polar

<procedure>(make-point-polar rho theta)</procedure>

creates a point from polar coordinates.

==== point?

<procedure>(point? xpr)</procedure>

type predicate.

==== distance

<procedure>(distance obj other)</procedure>

computes the distance between the two points obj and otern.

The following four procedures return the respective coordinates:

==== x

<procedure>(x obj)</procedure>

==== y

<procedure>(y obj)</procedure>

==== rho

<procedure>(rho obj)</procedure>

==== theta

<procedure>(theta obj)</procedure>

The following three commands do what their names suggest:

==== scale!

<procedure>(scale! obj factor)</procedure>

==== rotate!

<procedure>(rotate! obj angle)</procedure>

==== translate!

<procedure>(translate! obj dx dy)</procedure>

=== Author

Kenneth Dickey
Ken(dot)Dickey(at)Whidbey(dot)Com

ported to CHICKEN and enhanced by Juergen Lorenz

=== Maintainer

[[/users/juergen-lorenz|Juergen Lorenz]]

=== License

COPYRIGHT (c) 1992,2008 by Kenneth A Dickey, All rights reserved.
COPYRIGHT (c) 2013-2014 by Juergen Lorenz, All rights reserved.

Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation files (the
"Software"), to deal in the Software without restriction, including
without limitation the rights to use, copy, modify, merge, publish,
distribute, sublicense, and/or sell copies of the Software, and to
permit persons to whom the Software is furnished to do so, subject to
the following conditions:

The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,WHETHER IN AN ACTION
OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

=== Changelog

; 1.5 : ported to CHICKEN 5
; 1.4 : tests with define-test instead of simple-test
; 1.3 : operations and protocol added, define-operation with arbitrary lambda-lists, examples stacks, queues and points added
; 1.2 : fixes in the setup script and simplification of the set of files
; 1.1
; 1.0 : initial import