#|=head1 GOLD (Version 4)

These pages describes more  details behing Graham's GOLD
system. Those pages (chp 17 of Graham) should be read first.

=head2 Conventions

A function named C<x%> or
C<x%%> is a preliminary version of a function that will be refined,
later.

Anything starting with C<$> is a UNIX shell command; e.g.

 $ ls
 abcd.lisp       counts.lisp     dist.lisp       macros.lisp     nb.lisp
 bounded.lisp    data.lisp       gold.lisp       make.lisp       random.lisp
 class.lisp      deftest.lisp    knn.lisp        misc.lisp       rbst.lisp

Anything starting with C<E<gt>> is a LISP REPL command; e.g.

 > (+ 1 1)
 2

=head1 Load Code

|#

 (defun make ()
   (handler-bind ((style-warning #'muffle-warning))
     (format t "% ~a~%" "gold4.lisp")
     (load "gold4.lisp")))

#|

=head1 Gold (v4)

GOLD is two sets of functions:

=over 8

=item *

Graham's code with some bug fixes.

=item *

Some timm tricks to make working with GOLD,
a little easier.

=back

=head1 Graham's OO Code

=head2 Some Set-Up

To stop a certain debugging error, make sure that we do not do infinite
prints of recursive structures.

|#

(setf *print-array* nil)
(declaim (inline lookup (setf lookup)))
(declaim (inline run-methods))

#|

=head2 Properties

In this program, as in the earlier version, there is no hard
distinction between slots and methods. A "method" is just a field with
a function in it. But, this nuance will soon be hidden by a more
convenient front-end.

=head2 Speeding Thing Up

=head3 Class and Instances

So far we have not distinguished between classes and instances. We
have used a single term, I<object>, to cover both. 

While it is elegant and
flexible to treat all objects the same, but grossly inefficient. In
most object-oriented applications the inheritance graph will be
bottom-heavy. In a simulation of traffic, for example, we might have
less than ten objects representing classes of vehicles, and hundreds
of objects representing particular vehicles. Since the latter will all
share a few precedence lists, it is a waste of time to create them,
and a waste of space to store them.  

So we'll distinguish with C<classes> and C<instances>.  Instances are
like other objects (which now may as well be called classes), but have
only one parent and do not maintain precedence lists.

And since some objects will no longer have precedence lists, the
functions C<rget> and C<get-next> are now redefined to look at the
parents of such objects instead.  

=head3 Vectors, not Hashtables

So far we have been representing all objects as hash tables. This
gives us more flexibility than we need, at greater cost than we
want. Here, we will rewrite our program to represent objects
as simple vectors.

Vectors are one-dimensional arrays. We can generate them from lists
as follows:

 (coerce all 'simple-vector)

Their slots can be accessed using:

 (svref vector index)

and updated with

 (setf (svref vector index) newThing)

This change will mean giving up the possibility of defining new
properties on the fly. So far we can define a property of any object
simply by referring to it. Now when a class is created, we will have
to give a list of the new properties it has, and when instances are
created, they will have exactly the properties they inherit.

Classes and instances are represented as vectors. The first three
elements of each will contain information used by the program itself,
as modeled bu the following macros:

|#

(defmacro parents  (v) `(svref ,v 0))
(defmacro layout   (v) `(the simple-vector (svref ,v 1)))
(defmacro preclist (v) `(svref ,v 2))

#|

=over 8

=item *

The parents field takes the place of the C<:parents> hash table entry in
the old implementation. In a class it will contain a list of parent
classes. In an instance it will contain a single parent class.

=item *

The C<layout> field will contain a vector of property names, indicating
the layout of the class or instance from the fourth element on.

=item *

The C<preclist> field takes the place of the :preclist hashtable entry in
the old implementation. It will contain the precedence list of a
class, or nil in an instance.

=back

Because these operators are macros, they can all be used in the first
argument to C<setf> (see below).

=head2 DefProp


The macro C<defprop> is essentially unchanged; now it just calls
C<lookup> instead of C<gethash>.

If the optional second argument to C<defprop> is true, it expands into a
call to C<run-methods>, which is also almost unchanged.

|#

(defmacro defprop (name &optional meth?)
  `(progn
     ,(if meth?
	  `(defun ,name (obj &rest args)
	     (run-methods obj ',name args))
	  `(defun ,name (obj &rest args)
	     (declare (ignore args)) ;tjm: we ignore args for non-methods
	     (rget ',name obj nil)))
     (defun (setf ,name) (val obj)
       (setf (lookup ',name obj) val))))
 
#|

Here's a slightly different C<run-methods>. This one uses the keyword
C<:nil> to represent no method. Later on (see the C<inst> method),
the default value of all properties will be set to C<:nil>.

|#

(defun run-methods (obj name args)
  (let ((meth (rget name obj nil)))
    (if (not (eq meth :nil))
        (apply meth obj args)
        (error "No ~A method for ~A." name obj))))

#|

Rget is nearly the same as before.
It is
so similar to C<get-next> that we can implement both in one function
by adding an extra argument. If this extra argument is true, C<rget>
takes the place of C<get-next>.

|#
 (defun rget (prop obj next?)
  (let ((prec (preclist obj)))
    (if prec
        (dolist (c (if next? (cdr prec) prec) :nil)
          (let ((val (lookup prop c)))
            (unless (eq val :nil) (return val))))
        (let ((val (lookup prop obj)))
          (if (eq val :nil)
              (rget prop (parents obj) nil)
              val)))))
 
 (defun lookup (prop obj)
  (let ((off (position prop (layout obj) :test #'eq)))
    (if off (svref obj (+ off 3)) :nil)))
 
 (defun (setf lookup) (val prop obj)
  (let ((off (position prop (layout obj) :test #'eq)))
    (if off
        (setf (svref obj (+ off 3)) val)
        (error "Can't set ~A of ~A." val obj))))

#|

=head2 Defining Classes

There is a name class with calling something C<class> or C<slot> in
COMMON LISP. So we will call them C<klass> or C<zlot>.

The macro C<class> is for creating classes. It takes an optional list
of superclasses, followed by zero or more property names
(properties are I<either> methods or data slots). 
It returns
an object representing a class.

To define a class (klass), need to run C<defprop> across all the
properties.

|#

(defmacro klass (&optional parents &rest props)
  `(prog1 
       (klass-fn (list ,@parents) ',props)
     ,@(mapcar ; tjm everything is a property
	#'(lambda (x) `(defprop ,x)) props))) 

#|

C<klass-fn> runs over all the parents and finds the set of all
their properties.  This will get converted to a simple vector,
for space reasons.

It then creates an object with enough space for all those properties
and three more spaces used by the above macros.

|#

 (defun klass-fn (parents props)
   (let* ((all (union (inherit-props parents) props))
	  (obj (make-array (+ (length all) 3)
			   :initial-element :nil)))
     (setf (parents obj)  parents
	   (layout obj)   (coerce all 'simple-vector)
	   (preclist obj) (precedence obj))
     obj))
 
 ; similar to make-precedence, but uses the 
 ; "layout" of the classes
 (defun inherit-props (klasses)
   (delete-duplicates
    (mapcan #'(lambda (c)
		(nconc (coerce (layout c) 'list)
		       (inherit-props (parents c))))
	    klasses)))
  
 ; not you again
 (defun precedence (obj)
  (labels ((traverse (x)
             (cons x
                   (mapcan #'traverse (parents x)))))
    (delete-duplicates (traverse obj))))

#|

=head2 defmeth

Finally,  the function C<defmeth> provides a convenient way to define
meth- ods. There are three things new about this version: it does an
implicit C<defprop>, it calls C<lookup> instead of C<gethash>, and it
calls C<rget> instead of C<get-next> to get the next method.

|#
(defmacro defmeth (name obj parms &rest body)
  (let ((gobj (gensym))
	(inst (gensym)))
    `(let ((,gobj ,obj))
       (defprop ,name t)
       (setf (lookup ',name ,gobj)
             (labels ((next (,inst) ;tjm simple way to call "next"
			(funcall (rget ',name ,gobj  t) ,inst)))
               #'(lambda ,parms ,@body))))))
#|

=head2 Creating Instances

This nearly the same as what we saw before- but note that the
default value of all properties is C<:nil>.

|#
(defun inst0 (parent)
  (let ((obj (copy-seq parent)))
    (setf (parents obj)  parent 
          (preclist obj) nil)
    (fill obj :nil :start 3)
    obj))
#|

=head1 Timm's Extensions

I've made the default C<inst> call the lower-level C<inst0>,
the send the C<init> method to each.

|#
 (defun inst (parent)
   (let ((obj (inst0 parent)))
     (init  obj) 
     obj))
#|

This only works isf all objects respond to C<init>. So
in my extension to GOLD, everything inherits from a master
C<*object*> that contains some useful general utilities. 
|#
 (defparameter *object* (klass nil ; no parents
			       init with-zlots zlots with-vars))  
 (defmeth init *object* (u)
	  "default initialization method: do nothing"
	  (declare (ignore u)) 
	  t)
 (defmeth zlots *object* (self)
	  "return all the properties"
	  (coerce (layout (parents self)) 'list))
 (defmeth with-zlots *object* (self fn)
	  "iterate over all slots"
	 (dolist (zlot (zlots self))
	   (funcall fn zlot (lookup zlot self))))
 (defmeth with-vars *object* (self fn)
	  "iterate over all slots that are 'dollars'"
	 (with-zlots self
	     #'(lambda (prop value)
		 (if (dollarp prop)
		     (funcall fn prop value))))) 
#|
Note that my code names non-method properties with a $dollar
sign. This  is optional.
|#
 (defun dollarp (x)
  "does some property name start with $dollar?"
   (and (symbolp x) (equal (elt (symbol-name x) 0) #\$)))
#|

=head1 Example

|#
 (defparameter *body* (klass (*object*) area $height volume))
 (defparameter *tube* (klass (*body*) $radius))
 
 (defmeth init *body* (u)    (setf ($height u) 1))
 (defmeth area *tube* (u)    (* pi (expt ($radius u) 2)))
 (defmeth volume *body* (u)  (* ($height u) (area u)))
 
 (defmeth init *tube* (u)
	  (next u)
	  (setf ($radius u) 10))
  
 (defun !tube ()
   (let ((tub (inst *tube*)))
     (format t "~a~%" (volume tub))
     (with-zlots tub 
       #'(lambda (prop value) 
	   (if (dollarp prop)
	       (format t "~a = ~a~%" prop value))))
     (with-vars tub
       #'(lambda (prop value)
	   (format t "~a = ~a~%" prop value)))))
#|

=head1 Installation

=head2 Download

Source code: 

 $ wget http://unbox.org/wisp/var/timm/11/310/lisp/lib/gold4.lisp

This doco:

 $ wget http://unbox.org/wisp/var/timm/11/310/lisp/gold4.html

=head2 Execute

First load into LISP:

 > (load "gold4.lisp") ; ignore warning messages

Reloads:

 > (make)

|#