; =>man/asl.sdoc

; Experimental version, spring 2011.
; I have delete many of the non-mutating primitives, such as add-member and delete-member.

;;;; .title       Abstraction Step Language - ASL 2.1
;;;; .author      Kurt Nørmark
;;;; .affiliation Aalborg University, Denmark
;;;; .laml-resource                 false
;;;; .css-prestylesheet             compact
;;;; .css-stylesheet                original
;;;; .css-stylesheet-copying        true
;;;; .scheme-source-linking         true 
;;;; .source-destination-delta      
;;;; .schemedoc-dependencies 
;;;; This is SchemeDoc documentation of the constituents of the ASL2 experimental programming language, version 2.1.
;;;; The ASL2 programming language is embedded in R5RS Scheme.
;;;; ASL2 is created to explore an extreme variant of object-oriented programming, which starts with concrete objects (created to solve a particular problem) and ends with a traditional class hierarchy.
;;;; Throughout the development process the programmer carries out a sequence of  Abstraction Steps.
;;;; Version 2 of ASL - ASL2 - accompanies a paper titled 'Object-oriented Programming with Gradual Abstraction'.
;;;; In version 2.1 a few renamings have been done to allow for more smooth execution in some R5RS Scheme systems.
;;;; Specifically, new is renamed to new-object, this is renamed to this-object, Object is renamed to root-object, and Class is renamed to class-object. 
; (require (lib "errortrace.ss" "errortrace"))

; Copied from the LAML compatibility library. ASL does not require LAML, as such. It relies, however, on several functions from the LAML general library.
; (define (bound? symbol)
;   (if (memq symbol (namespace-mapped-symbols)) #t #f))

;;; ASL object and class Primitives.
;;; This section contains the most important object and class related primitives in ASL2. 
;;; Among these, ASL operations that create objects and classes.

 
(define (new-object class-object . initializer-fields)
  (if (kappa? class-object)
      (let* ((initializer-field-alist-from-class (class-fields-alist class-object))
             (obj (apply make-object (alist-to-propertylist (cons (cons '$instance-of class-object) (filter (negate function-field?) initializer-field-alist-from-class)))))
            )

        ; Mutate fields according to initializer-fields.
        (for-each
           (lambda (field-key-val-pair)
              (set-field! obj (car field-key-val-pair) (cdr field-key-val-pair) ))
           (propertylist-to-alist initializer-fields))

        obj
      )
      (error "Cannot instantiate non-class objects")))



 
(define (make-object . parameters)
  (if (null? parameters) 
      (cons 'object (cons"" '()))
      (let ((first-par (car parameters)))
        (if (string? first-par)           ; making an object with a role
            (let* ((role-name first-par)
                   (fields (cdr parameters))
                   (role-class-rel (assoc role-name role-class-mapping)))
               (if role-class-rel   ; the role role-name has been mapped to a class - instantiate this class
                   (apply new-object (cons (cdr role-class-rel) fields))                
                   (let ((obj (cons 'object (cons role-name (propertylist-to-alist fields)))))    ; make an object with a role
                     (insert-object-with-role! obj role-name)
                     obj)
               )
            )
            (let ((fields parameters))  ; make an object without a role
              (cons 'object (cons "" (propertylist-to-alist fields))))))))


; The fields of an object represented as an association list.
; Includes internal (dollar) fields.
; This is not a copy, but a direct reference to the internal representation of the object.
; Only fields of object - independent of relations to other objects.
; Relies on the particular ASL object representation. 
(define (object-fields-alist object)
  (if (asl-object? object)
      (cdr (cdr object))
      (error "The first parameter must be an object")))

; Return an association list of the data fields of object.
(define (object-data-fields-alist object)
  (filter (lambda (field-pair) (and  (not (internal-field? field-pair)) (not (function-field? field-pair))))
          (object-fields-alist object)))

; Return an association list of the method fields of object.
(define (object-method-fields-alist object)
  (filter (lambda (field-pair) (and  (not (internal-field? field-pair)) (function-field? field-pair)))
          (object-fields-alist object)))

; Renew the fields a-list of object to be new-field-alist.
; Relies on the particular ASL object representation. 
(define (set-fields-of-objects-low-level! object new-field-alist)
  (set-cdr! (cdr object) new-field-alist)
)


; Refurnish an associative array to an object.
; If ass-array already is an object, just return it.
; .parameter ass-array An associative array, represented as a Lisp association list.
(define (as-object ass-array)
  (if (asl-object? ass-array)
      ass-array
      (apply make-object (alist-to-propertylist ass-array))
  )
)

 
(define (make-class . parameters)
  (cond ((null? parameters)
            (apply make-object (cons '$kind (cons 'class '()))))   ; implicitly with root-object as superclass 
        ((kappa? (first parameters))
            (apply make-object  (cons '$kind (cons 'class (cons '$superclass (cons (first parameters) (cdr parameters)))))))
        (else 
            (apply make-object  (cons '$kind (cons 'class parameters))))))

; Not used any more - multi-kappa used in all cases.
(define (single-kappa object)
  (if (kappa? object)
      (laml-error "It is illegal to apply kappa on a class object")
      (apply make-class (object-property-list object)))
)

         


; Used in check-sufficient-fields-in!
(define problem-object #f)

; Assert that all object have at least the data fields enumerated in field-name-list.
(define (check-sufficient-fields-in! objects field-name-list)
  (set! problem-object #f)
  (for-each
    (lambda (object)
      (let ((object-data-fields (object-data-fields-alist object)))
        (if (not (subset-of-by-predicate field-name-list object-data-fields (lambda (name pair) (eq? name (car pair)))))
            (begin 
               (set! problem-object object)
               (laml-error "Insuffient data fields in object. Inspect the problem object with (inspect problem-object)")))))
  objects))



 
(define (kappa . objects)
  (multi-kappa objects))

(define (multi-kappa objects)
  (if (null? objects) (laml-error "At least one object must be supplied to multi-kappa"))
  
  ; This limitation has now been removed, such that it now is possible to create meta classes with kappa. 
; (if (not (null? (filter kappa? objects))) (laml-error "All objects passed to kappa must be non-class objects"))

  (cond ((equal? (map kappa? objects) (make-list (length objects) #t))  ; ALL objects are class objects - make a meta class

         ; THIS CASE - META CLASSES - IS NOT YET DONE. IT CAUSES A NUMBER OF PROBLEMS THAT MUST BE DEALT CAREFUL WITH.

           (let ((class (apply make-class '())))

             ; All objects become instances of the derived class
             (for-each (lambda (object) (as-instance-of-class! object class)) objects)

             ; Return the class
             class)
        )

        ((equal? (map kappa? objects) (make-list (length objects) #f))  ; NONE of the objects are class objects.

           ; Check that all objects conform to the data fields in the first object
           (check-sufficient-fields-in! objects (map car (object-data-fields-alist (first objects)))) 

           (let ((class (apply make-class
                               (alist-to-propertylist
                                (append 
                                 ; The data fields of the first object
                                 (object-data-fields-alist (car objects))

                                 ; The union of the methods of all objects
                                 (remove-duplicates-by-predicate
                                  (flatten
                                   (map object-method-fields-alist objects))
                                  (lambda (m1 m2)
                                    (eq? (car m1) (car m2))) 
                                  )
                                 )))))

             ; All objects become instances of the derived class
             (for-each (lambda (object) (as-instance-of-class! object class)) objects)

             ; If only a single object role is represented among objects, map this role to class
             (let ((roles (remove-duplicates (filter (negate empty-string?) (map object-role objects)))))
               (if (= (length roles) 1)
                   (map-role-to-class! (car roles) class)))

             ; Return the class
             class)
        )

        (else 
             (error "It is not possible to derive a class from a mixed set of non-class and class objects"))))


; Add a new member (data or function) to an object by mutation.
; If field-name already exists in object the old field is removed before the new field is added.
; add-member! has no return value.
; .parameter object An object to which we will add a new member
; .parameter field-name The name of the new member. A symbol.
; .parameter field-value The value of the new member.
; .misc This is a mutating procedure. object is mutated to contain a new field.
(define (add-member-old! object field-name field-value)
  (let ((field-value-1 (if (function? field-value) 
                           field-value                    ; earlier: (refurnish-function field-value '())   ; supply the actual environment when the method is called.
                           field-value)))
    (if (asl-object? object)
        (begin
          (if (member field-name (map car (object-fields-alist object)))
              (delete-member! object field-name))
          (let ((last-pair (last-cons-cell (object-fields-alist object))))
            (set-cdr! last-pair
                      (cons
                       (cons field-name field-value-1)
                       '()))
            ))
        (error "The first parameter must be an object"))))

; ASL 2.0
 
(define (add-member! object field-name field-value)
  (cond ((object-with-class? object)
           (let ((class (class-of object)))
             (if (function? field-value)
                 (if (or (and (field-exists? class field-name) (function? (get-field class field-name)) 
                              (= (length (formal-parameters-of-function field-value)) (length (formal-parameters-of-function (get-field class field-name)))))

                         ; It is possible to add a getter/setter if the field exists in the class
                         (and (getter-name? field-name) (field-exists? class (field-name-of-getter field-name)))
                         (and (setter-name? field-name) (field-exists? class (field-name-of-setter field-name)))

                     )
                     (begin  ; Add the method to the object
                       (if (member field-name (map car (object-fields-alist object)))
                           (delete-member! object field-name))
                       (let ((last-pair (last-cons-cell (object-fields-alist object))))
                         (set-cdr! last-pair
                                   (cons
                                    (cons field-name field-value)
                                    '()))
                         ))
                     (error "It is only possible to add a method to an instance of a class if the method is compatible with a method in the class (both methods have the same number of parameters)"))
                 (error "It is not possible to add a data member to an instance of class. Consider adding the member to the class as such."))))
           
        ((object-without-class? object)
          (begin
            (if (member field-name (map car (object-fields-alist object)))
                (delete-member! object field-name))
            (let ((last-pair (last-cons-cell (object-fields-alist object))))
              (set-cdr! last-pair
                        (cons
                         (cons field-name field-value)
                         '()))
              )))
  
        (else (error "The first parameter must be an object"))))


; Delete an existing member (data or method) from an object, by mutation of object.
; .parameter object An object from which to delete a member.
; .parameter field-name The name of the member to delete. A symbol.
; .misc This is a mutating procedure which modifies the state of object.
; .internal-references "non mutating counterpart" "delete-member"
(define (delete-member-old! object field-name)
    (if (asl-object? object)
        (if (field-exists? object field-name)
            (begin
              (set-fields-of-objects-low-level! object
                        (filter (lambda (pair) (not (eq? field-name (car pair)))) (object-fields-alist object))))
            (error "Trying to delete non-existing field:" field-name))
        (error "The first parameter must be an object")))

; ASL 2.0
 
(define (delete-member! object field-name)
  (if (asl-object? object)
      (cond ; Only delete the field if it exists in the class. In that case the class's field becomes the default of the instance field - lazyness.
            ((object-with-class? object)
             (let ((class (class-of object)))
               (if (field-exists-in-class? class field-name)
                   (if (field-exists? object field-name)
                       (begin
                         (set-fields-of-objects-low-level! object
                                   (filter (lambda (pair) (not (eq? field-name (car pair)))) (object-fields-alist object))))
                       (error "Trying to delete non-existing field from an instance of class:" field-name))
                   (error "You cannot delete a field from an instance of a class C, where C does not contain the field."))))

            ; Delete the field if it exists.
            ((object-without-class? object)
             (if (field-exists? object field-name)
                 (begin
                   (set-fields-of-objects-low-level! object
                             (filter (lambda (pair) (not (eq? field-name (car pair)))) (object-fields-alist object))))
                 (error "Trying to delete non-existing field:" field-name)))
            (else (error "Should not happen")))
     (error "The first parameter must be an object")))


; ASL 2.0
 
(define (get-field object field-name)
  (cond ((object-with-class? object)                                               ; object with class
            (let ((class (class-of object)))
              (if (field-exists-in-class? class field-name)
                  (if (field-exists? object field-name)
                      (if (field-exists-raw? object field-name)                   ; get the field from the object or root-object
                          (get field-name (object-fields-alist object))
                          (if (field-exists-raw? root-object field-name) ; an object has access to the members of root-object
                              (get field-name (object-fields-alist root-object))
                              (error (string-append "Attempting to get the value of a non-existing field: " (as-string field-name)))))
                      (get-field class field-name)                               ; take it from the class
                  )
                  (error (string-append "Attempting to get a field  " (as-string field-name) "  from an instance of class, where the class does not prescribe the field: "))))
        )
            
        ((object-without-class? object)
          (if (field-exists-raw? object field-name)
              (get field-name (object-fields-alist object))
              (if (field-exists-raw? root-object field-name)                            ; an object has access to the members of root-object
                  (get field-name (object-fields-alist root-object))
                  (error (string-append "Attempting to get the value of a non-existing field: " (as-string field-name))))))

        ((kappa? object)                                                           ; never reached
           (get-field-in-class object field-name))

        ; If object is #f - which is the case if the pseudo variable this is used in a function outside of an object context - lookup the field name in the current interaction environment
        ((and (boolean? object) (not object))  ; boolean false.
          (eval-expr field-name '()))

        (else (error "get-field should be activated on an object"))))



; ASL 2.0
 
(define (set-field! object field-name field-value)
  (cond ((object-with-class? object)
           (let ((class (class-of object)))
             (if (field-exists-in-class? class field-name)
                 (if (field-exists? object field-name)
                     (a-set! (object-fields-alist object) field-name field-value)        ; Set the value of the field
                     (forced-add-member-low-level object field-name field-value)
                 )
                 (error "It is not possible to set the value of field, which is not prescribed in the class of the object")
            )
          )
        )
        ((object-without-class? object)
           (if (field-exists? object field-name)
               (begin 
                 (a-set! (object-fields-alist object) field-name field-value)
                )
               (error "Cannot set the value of a non-existing field.")))
        (else (error "set-field!  must be activated on an object"))))





; A boolean symbolic constant that affects the behavior of send. If true (#t) a missing method in an independent object may be borrowed from an object of the same role (if unambiguous).
; The value of this variable is normally true (#t in Scheme).
(define borrow-methods-from-objects-of-same-role? #t)

; this-object (used now instead of this) and the this-object-stack used now instead of fluid-let
(define this-object #f)         ; the backing definition behind this, which is fluidly bound by send.   Earlier: this
(define this-object-stack '())  ; instead of using fluid-let


 
(define (send object selector . actual-parameters)

  (dynamic-wind

    (lambda ()
      (if (asl-object? this-object) 
          (set! this-object-stack (cons this-object this-object-stack)))
      (set! this-object object))

    (lambda ()
      (cond ((and (asl-object? object) (not (kappa? object)))  ; an object which is not a class
           (let* ((obj-method (if (field-exists-in-object-non-class? object selector) (get-field-in-object-non-class object selector) #f))
                  (class-of-object (if (field-exists-raw? object '$instance-of) (get-field-raw object '$instance-of) #f))
                  (class-method (if class-of-object (if (field-exists-in-class? class-of-object selector) (get-field-in-class class-of-object selector) #f) #f))
                 )
             (cond 
                   ; A function is selected in the object or in root-object. Call it
                   ((and obj-method (function? obj-method))
                      ; Call method taken from the object, or root-object
                      (call-method obj-method actual-parameters))

                   ; No method in object nor root-object: If this object is an instance of a class, lookup the method in the superclass chain of the class (ending with Class).    Call it if found. 
                   ((and class-of-object class-method (function? class-method))
                         (call-method class-method actual-parameters))

                   ; Attempt borrowing the method from another object with the same role
                   ((and borrow-methods-from-objects-of-same-role? (not (empty-string? (object-role object))))
                       (let ((borrowed-method (borrow-method-from-objects-of-same-role (object-role object) selector))) 
                           (if (and borrowed-method (function? borrowed-method))
                               (call-method borrowed-method actual-parameters)
                               (attempt-getting-or-setting object selector actual-parameters))))

                   ; Handle automatically generated getters and setters - modified august 19, 2011. And agian November 30, 2011
                   ((or (and (getter-name? selector) (or (data-field? object (field-name-of-getter selector)) (data-field? class-of-object (field-name-of-getter selector))))
                        (and (setter-name? selector) (or (data-field? object (field-name-of-setter selector)) (data-field? class-of-object (field-name-of-getter selector)))))
                      (attempt-getting-or-setting object selector actual-parameters))

                   ; Give up - error
                   (else
                      (error (string-append "No appropriate method with selector " (as-string selector))))
              )))


        ((kappa? object)  ; A class object
           (let ((class-obj-method (if (field-exists-in-object-class? object selector)        ; looking in object (a class object),  Class, and root-object.     Does also look in superclasses of the class object.
                                       (get-field-in-class object selector)
                                       #f))
                 (class-of-object (if (field-exists-raw? object '$instance-of) (get-field-raw object '$instance-of) #f))  ; meta class object
                )


             (cond  

                   ; Call a method taken from object, Class, or root-object
                   ((and class-obj-method (function? class-obj-method))   
                     (call-method class-obj-method actual-parameters))

                   ; If the class-object is an instance of (meta)class, lookup the method in superclass chain of the (meta)class. Call it if found. Else: Error.
                   (class-of-object
                       (let ((class-method (if (field-exists-in-class? class-of-object selector) (get-field-in-class class-of-object selector) #f)))
                         (if class-method
                             (call-method class-method actual-parameters)
                             (error (string-append "No appropriate method with selector " (as-string selector)))))    
                       (error (string-append "No appropriate method with selector " (as-string selector))))

                   ; Handle automatically generated getters and setters
                   ((or (and (getter-name? selector) (data-field? object (field-name-of-getter selector)))
                        (and (setter-name? selector) (data-field? object (field-name-of-setter selector))))
                      (attempt-getting-or-setting object selector actual-parameters))

                   (else 
                      (error (string-append "No appropriate method with selector " (as-string selector))))

             )
           )
        )))

    (lambda ()
      (if (not (null? this-object-stack))
        (begin
          (set! this-object (car this-object-stack))
          (set! this-object-stack (cdr this-object-stack)))
        (set! this-object #f)))

  )
)
 

(define (attempt-getting-or-setting object selector actual-parameters)
   (cond 

;        ((and (field-exists-in-general? object selector) (data-field? object selector))
;           (get-field object selector))

         ((and (getter-name? selector) (data-field? object (field-name-of-getter selector)) (= (length actual-parameters) 0))                                            ; getter of object
            (get-field object (field-name-of-getter selector)))

         ((and (getter-name? selector) (object-with-class? object) (data-field? (class-of object) (field-name-of-getter selector)) (= (length actual-parameters) 0))     ; getter of object with class  
            (get-field object (field-name-of-getter selector)))


         ((and (setter-name? selector) (data-field? object (field-name-of-setter selector)) (= (length actual-parameters) 1))                                            ; setter of object
            (set-field! object (field-name-of-setter selector) (car actual-parameters)))                                                                                 

         ((and (setter-name? selector) (object-with-class? object) (data-field? (class-of object) (field-name-of-setter selector)) (= (length actual-parameters) 1))     ; setter of object with class. 
            (set-field! object (field-name-of-setter selector) (car actual-parameters)))


         ((and (setter-name? selector) (not (= (length actual-parameters) 1)))
            (error "A setter method must have exactly one actual parameter."))

         (else (error (string-append "No appropriate method with selector " (as-string selector) )))))

(define (setter-name? selector-symbol)
  (let ((selector-string (as-string selector-symbol)))
    (if (> (string-length selector-string) 4)               ; a least one char after 'set-' prefix
        (equal? (substring selector-string 0 4) "set-")
        #f)))

(define (getter-name? selector-symbol)
  (let ((selector-string (as-string selector-symbol)))
    (if (> (string-length selector-string) 4)               ; a least one char after 'get-' prefix
        (equal? (substring selector-string 0 4) "get-")
        #f)))

(define (getter-name field-name)
  (as-symbol (string-append "get" "-" (as-string field-name))))

(define (setter-name field-name)
  (as-symbol (string-append "set" "-" (as-string field-name)))) 

(define (field-name-of-setter selector)
  (let ((selector-string (as-string selector)))
    (as-symbol (substring selector-string 4))))

(define (field-name-of-getter selector)
  (let ((selector-string (as-string selector)))
    (as-symbol (substring selector-string 4))))

(define (call-method method actual-parameters)
  (if (not (function? method)) (error "The selected field exists, but it is not a function"))

  ; Error handling is integrated in apply function, more specifically in the function pair-up-parameters-in-function-application
;  (if (not (= (length actual-parameters) (length (formal-parameters-of-function method))))
;      (error (string-append "The method has " (as-string (length (formal-parameters-of-function method)))
;                            " formal parameters, but is called with "  (as-string (length actual-parameters)) " actual parameter(s).")))
 
  (apply-function method actual-parameters))

 
(define (send-super object selector . actual-parameters)

  (dynamic-wind

    (lambda ()
      (if (asl-object? this-object) 
          (set! this-object-stack (cons this-object this-object-stack)))
      (set! this-object object))

    (lambda ()
     (cond ((and (asl-object? object) (not (kappa? object)))
            (let ((obj-method (if (field-exists-raw? root-object selector) (get-field-raw root-object selector) #f))) ; Look in root-object rather than the receiver
              (if obj-method
                  (call-method obj-method actual-parameters)

                                        ; step 2
                  (let* ((class-of-object (if (field-exists-raw? object '$instance-of) (get-field-raw object '$instance-of) #f))
                         (superclass-of-object (superclass-of class-of-object))) ; Look in superclass
                    (if class-of-object
                        (let ((class-method (if (field-exists-in-class? superclass-of-object selector) (get-field-in-class superclass-of-object selector) #f)))
                          (if class-method
                              (call-method class-method actual-parameters)
                              (error (string-append "No appropriate method with selector " (as-string selector)))))    
                        (error (string-append "No appropriate method with selector " (as-string selector)))))

                  )))
           ((kappa? object)
            (let ((class-obj-method (if (field-exists-in-object-class? class-object selector) (get-field-in-object-class class-object selector) #f))) ; Look in Class rather than the receiver
              (if class-obj-method
                  (call-method class-obj-method actual-parameters)

                                        ; step 2
                  (let* ((class-of-object (if (field-exists-raw? object '$instance-of) (get-field-raw object '$instance-of) #f))
                         (superclass-of-object (superclass-of class-of-object))) ; Look in superclass
                    (if class-of-object ; a meta class
                        (let ((class-method (if (field-exists-in-class? superclass-of-object selector) (get-field-in-class superclass-of-object selector) #f)))
                          (if class-method
                              (call-method class-method actual-parameters)
                              (error (string-append "No appropriate method with selector " (as-string selector)))))    
                        (error (string-append "No appropriate method with selector " (as-string selector)))))
                  )))))

     (lambda ()
       (if (not (null? this-object-stack))
           (begin
             (set! this-object (car this-object-stack))
             (set! this-object-stack (cdr this-object-stack)))
           (set! this-object #f)))
  )
)


 
(define (clone-object obj . initializer-fields)
  (if (asl-object? obj)
      (let ((new-object (as-object (object-fields-alist obj)))  ; the shallow cloning is actually done by make-object, called by as-object
           )

         ; Mutate fields according to initializer-fields.
         (for-each
           (lambda (field-key-val-pair)
             (set-field! new-object (car field-key-val-pair) (cdr field-key-val-pair) ))
           (propertylist-to-alist initializer-fields))
         
         new-object)
       (error "Cannot clone a non-object")))

; ASL 2.0
 
(define (as-instance-of-class! object class)
  (if (kappa? object)
      (error "The first parameter is not supposed to be a class"))
  (if (not (kappa? class))
      (error "The second parameter must be a class"))

  (cond ; object is already an instance of class
        ((eq? class (class-of object))   
            object)

        ; all data fields of object exist in class
        ((subset-of-by-predicate (member-names-of object) (map car (class-fields-alist class)) eq?)                                      ; could in addition consider conformance of method signatures (number of parameters).

            ; Ad an internal instance-of field
            (forced-add-member-low-level object '$instance-of class)

            ; Delete the methods from object. 
            (let ((method-names-in-object
                     (map name-of-field (filter (lambda (f) (function? (value-of-field f))) (object-fields-alist object)))))
              (for-each (lambda (method-name)
                           (if (field-exists? object method-name)
                               (delete-member! object method-name)))
                        method-names-in-object))
        )  
        (else (error "The object does not conform with the class. One or more members of the object is not present in the class.")))
)

 
(define (as-independent-object! object)
  (if (object-with-class? object)
      (let ((class (class-of object)))

         ; Transfer missing data fields from class to object - due to lazy updating.
         (for-each 
           (lambda (data-field)
              (if (not (field-exists-raw? object (name-of-field data-field)))
                  (forced-add-member-low-level object (name-of-field data-field) (value-of-field data-field))))
           (filter (negate function-field?) (class-fields-alist class))
         )

         ; Transfer missing methods from class (below Class) to object
         (for-each
           (lambda (method-field)
              (if (not (field-exists-raw? object (name-of-field method-field)))
                  (forced-add-member-low-level object (name-of-field method-field) (value-of-field method-field))))
           (filter function-field? (class-fields-alist class #t))
         )

         ; Remove the internal instance-of field from object
         (forced-delete-member-low-level object '$instance-of)
       )
      object))


(define (as-instance-of-class-old! object class)   ; not used
  (if (kappa? object)
      (error "The first parameter is not supposed to be a class"))
  (if (not (kappa? class))
      (error "The second parameter must be a class"))

  (cond ; object is already an instance of class
        ((eq? class (class-of object))   
            object)

        ; all data fields of class exist in object
        ((subset-of-by-predicate (data-field-names-of class) (data-field-names-of object) eq?)
            (add-member! object '$instance-of class)

            ; delete methods from object which already are members in the class. Methods are identified by name.
            (let ((method-names-in-class
                     (map name-of-field (filter (lambda (f) (function? (value-of-field f))) (class-fields-alist class)))))
              (for-each (lambda (method-name)
                           (if (field-exists? object method-name)
                               (delete-member! object method-name)))
                        method-names-in-class))
        )  
        (else (error "Some data fields in the class are not present in the object.")))
)



 
(define (generalize class-list member-names)
  (generalize-multiple-classes-from-list! class-list member-names)
)

; Legacy. Do not use.
; Return a new class which generalizes class. Like generalize! but with a list of member-names as the second parameter.
(define (generalize-from-list! class member-names)
  (laml-error "Use generalize!")
  (generalize-multiple-classes-from-list! (list class) member-names))

; Return a new class which generalizes all classes in class-list. This is an abstraction step.
; In this version of the function, the member names are rest arguments of generalize-multiple-classes!
; Apart from this calling convention, this function is exactly identical to (and implemented in terms of) generalize-multiple-classes-from-list!
; .internal-references "Underlying function" "generalize-multiple-classes-from-list!"
; .parameter class-list A non-empty list of classes.
; .parameter member-names A list of members (a list of symbols).
(define (generalize-multiple-classes! class-list . member-names)
  (laml-error "Use generalize!")
  (generalize-multiple-classes-from-list! class-list member-names))

; Return a new class which generalizes all classes in class-list. This is an abstraction step.
; In this parameter profile of this function, the member must be collected in a list and passed to generalize-multiple-classes-from-list!
; Mutate the existing classes to have the new class as their superclass.
; Take the default values of non-function fields from the first class in the list.
; Transfer all methods from all classes in the list.
; It is not necessary that all members enumerated in member-name are members of all classes in class-list.
; With this semantics, multiple generalization may lead to definition of new members in some of the subclasses.
; Methods that belong to more than one subclass are assumed to be equal to each other. (This is not - and cannot - be tested).
; .parameter class-list A list of classes.
; .parameter member-names A list of members (a list of symbols).
(define (generalize-multiple-classes-from-list! class-list member-names)
  (if (all-true (lambda (class) (kappa? class)) class-list)                                                         ; are all elements in class-list classes?
      (if (not (all-true (lambda (class) (field-exists? class '$superclass)) class-list))                           ; are all classes without a superclass?
          (let ((first-class (if (not (null? class-list)) (first class-list) #f))
                (new-superclass (apply make-class '())))
            (for-each (lambda (class)                                                                               ; for each class in class-list...
                            (add-member! class '$superclass new-superclass)                                         ; let new-superclass be the superclass of class
                            (let ((class-member-pairs (object-fields-alist class)))   ; (member-name . member-value)   
                              (add-member! class '$superclass new-superclass)
                              (for-each (lambda (m)                                                                 ; for each member in a class ...
                                          (let ((member-name (car m))
                                                (member-value (cdr m)))
                                           (if (member member-name member-names)                                    ; if member belongs to the member-names parameter of this function ...
                                               (begin
                                                  (delete-member! class member-name)

                                                  ; Add member to new super class - data members are only added from the first class in class-list
                                                  (if (not (function-value? member-value))     ; a data member  
                                                      (if (eq? class first-class)              ; .. is added if it commes from the first class
                                                          (begin
                                                             (add-member! new-superclass member-name member-value)))
                                                      (begin                                   ; function members are added from any class (and may overwrite each other...).
                                                         (add-member! new-superclass member-name member-value)))
                                               )
                                           )
                                         )
                                        ) 
                                        class-member-pairs) 
                              ))
                           class-list)
            new-superclass
          )
          (error "Cannot generalize a class which already has a superclass field"))
      (error "Can only generalize class objects")))  

; Binary and as a function - not a macro
(define (and-fn x y)
  (and x y))

; Does the predicate p hold on all elements in the list lst.
(define (all-true p lst)
  (accumulate-right and-fn #t (map p lst)))

 
(define (specialize class . fields)
  (if (kappa? class)
      (apply make-class (cons class fields)) 
      (error "Can only specialize class objects")))
  

; Returns a class object without an explicit superclass.
; The returned class joins all the fields in class and its superclass.
; .parameter class A class object.
(define (flatten-class class)
  (apply make-class (alist-to-propertylist (class-fields-alist class))))

 
(define (class-of obj)
  (let* ((fields (object-fields-alist obj))
         (internal-instance-of-field (assq '$instance-of fields)))
    (if internal-instance-of-field 
        (cdr internal-instance-of-field)
        #f)))

 
(define (superclass-of class-obj)
  (let* ((fields (object-fields-alist class-obj))
         (superclass-pair (assq '$superclass fields)))
    (if superclass-pair 
        (cdr superclass-pair)
        class-object)))

 
(define (object-role object)
  (if (asl-object? object)
      (cadr object)
      (error "The first parameter must be an object")))

;;; ASL Predicates.
;;; A number of predicates which identifies ASL objects and classes relative to other Scheme objects.
; Relies on the particular ASL object representation. 
 
(define (asl-object? x)
  (and (list? x)
       (>= (length x) 1)
       (eq? (car x) 'object))) 

 
(define (object-without-class? x)
  (and (asl-object? x)
       (not (field-exists-raw? x '$instance-of))))

 
(define (object-with-class? x)
  (and (asl-object? x)
       (field-exists-raw? x '$instance-of)))

 
(define (kappa? x)
  (and (asl-object? x)
       (field-exists-raw? x '$kind)
       (eq? 'class (get-field-raw x '$kind))))

 
(define (instance-of? object class)
  (let ((obj-fields (map car (object-fields-alist object)))
        (class-fields (map car (object-fields-alist class))))
    (subset-of-by-predicate obj-fields class-fields eq?)
  )
)


   
; Lower level primitives.
; If you just interested in ASL2 at an overall and general level you can ignore the function

; Get the field with field-name in class.
; Looks for the field in the intire superclass chain in class.
(define (get-field-in-class class field-name)
  (cond ((kappa? class)
          (if (field-exists-in-class? class field-name)
              (get field-name (class-fields-alist class))
              (error (string-append "Attempting to get the value of a non-existing field of a class: " (as-string field-name)))))
        (else (error "get-field should be activated on a class object"))))

; Access the field named filed-name in the the object, which is assumed to be a class object.
; field-name is an existing field in a class object.
; Se also the function get-field-in-class
(define (get-field-in-object-class object field-name)
  (if (field-exists-raw? object field-name)
      (get field-name (object-fields-alist object))
      (if (field-exists-raw? class-object field-name)           ; an object has access to the members of Class
          (get field-name (object-fields-alist class-object))
          (if (field-exists-raw? root-object field-name) ; an object has access to the members of Class
              (get field-name (object-fields-alist root-object))
              (error (string-append "Attempting to get the value of a non-existing field: " (as-string field-name)))))))

; Lookup field-name in the fields directly in object. If field-name is not there, look it up in root-object.
; Assume that field-name is an existing field in a non-class object.
(define (get-field-in-object-non-class object field-name)
  (if (field-exists-raw? object field-name)
      (get field-name (object-fields-alist object))
      (if (field-exists-raw? root-object field-name)          ; an object has access to the members of root-object
          (get field-name (object-fields-alist root-object))
          (error (string-append "Attempting to get the value of a non-existing field: " (as-string field-name))))))


; Is field-name a data field in object?
; Works via get-field.
; .internal-references "See also" "get-field"
(define (data-field? object field-name)
 (if (internal-field-name? field-name)
     #f
     (if (field-exists? object field-name)
         (let ((val (get-field object field-name)))
           (not (function? val)))
         #f)))

; Does field exist in object. 
; Looks in object (the parameter of this function) and in root-object (the common objet shared by all objects in the system).
; This version of the function is not controlled by the class for objects with classes.
(define (field-exists? object field)
  (cond ((asl-object? object)
           (let ((exists-in-object?  (field-exists-raw? object field)))
             (if exists-in-object?
                 exists-in-object?
                 (field-exists-raw? root-object field))))
        (error "The first parameter must be an object")))

; Does field exits in object. 
; For objects with classes, this version of the function is entirely controlled by existence in the class.

(define (field-exists-in-general? object field-name)
  (cond ((object-with-class? object)                                               ; object with class
            (let ((class (class-of object)))
              (field-exists-in-class? class field-name))
        )
            
        ((object-without-class? object)                                            ; object without class
          (if (field-exists-raw? object field-name)
              #t
              (field-exists-raw? root-object field-name)))

        ((kappa? object)                                                           ; never reached?
           (field-exists-in-class? object field-name))

        (else (error "get-field should be activated on an object"))))

; Assume as a precondition that object is an object, but not a class object.
; Does field exists in the object itself or in the object root-object?
(define (field-exists-in-object-non-class? object field)
  (let ((exists-in-object?  (field-exists-raw? object field)))
    (if exists-in-object?
        exists-in-object?
        (field-exists-raw? root-object field))))

; Is field an existing field in a class object. 
; Looks in the entire superclass chain of the class.
; .parameter class A class object.
; .parameter field The name of a field in object. Cannot be an internal dollar field.
(define (field-exists-in-class? class field)
  (if (kappa? class)
      (turn-into-boolean (find-in-list (lambda (pair) (eq? (car pair) field)) (class-fields-alist class)))
      (error "The first parameter must be a class object")))

; Assumes that object is a class object.
; Does field exists in the object itself, in the object Class, or in the object root-object?
; See also field-exists-in-class? which probably overlaps with this function
(define (field-exists-in-object-class? object field)
 (let ((exists-in-object?  (field-exists-raw? object field)))
    (if exists-in-object?
        exists-in-object?
        (if (field-exists-in-explicit-superclasses-of object field)
            #t
            (let ((exists-in-class? (field-exists-raw? class-object field)))
              (if exists-in-class?
                  exists-in-class?
                  (field-exists-raw? root-object field)))))))

; Look for field in explicit superclasses of class-object. Do not look in Class and root-object.
(define (field-exists-in-explicit-superclasses-of class-object field)
   (if (assq '$superclass (object-fields-alist class-object))
       (let ((super-class-object (superclass-of class-object)))
          (if (field-exists-raw? super-class-object field)
              #t
              (field-exists-in-explicit-superclasses-of super-class-object field)  ; recurses
          )
       )
       #f))



; Force adding a field to object.
; Only this object is considered, and the additn is always done.
(define (forced-add-member-low-level object field-name field-value)
  (let ((last-pair (last-cons-cell (object-fields-alist object))))
    (set-cdr! last-pair
              (cons
               (cons field-name field-value)
               '()))))

; Force deleting a field in object.
; Only this object is considered, and the additn is always done.
(define (forced-delete-member-low-level object field-name)
  (let ((a-list (object-fields-alist object)))
    (set-fields-of-objects-low-level! object 
                                      (remove-associations (list field-name) a-list))))


; f is a pair of the form (name . value).
; Is f of the form (name function par-list body env)?
(define (function-field? f)
  (and (pair? f)    ; should always be true
       (function-value? (cdr f))))

; Is x a function value?
(define (function-value? x)
  (and (pair? x)    ; should always be true
       (list? x)    ; proper list?
       (= (length x) 4)
       (eq? (car x) 'function)))


;;; Object inspection.
;;; Functions that can be used to inspect (pretty print) an ASL object.
(define (inspect-old object)
 (if (function? object)
     (display-message (as-string object))
     (let* ((class? (kappa? object))
            (fields (remove-internal-fields (object-fields-alist object)))                ; does not remove a possible $instance-of field. Only $superclass and $kind are removed.
            (has-superclass? (if class? (field-exists-raw? object '$superclass) #f)))
       (display-message (if class? 
                            (if has-superclass? (string-append "A class with superclass: " (short-class-inspect-string (flatten-class (get-field-raw object '$superclass)))) "A class without a given superclass")
                            "An non-class object"))
       (for-each (lambda (pair)
                   (display-message
                    " "
                    (as-string (car pair)) ": " 

                    (cond ((kappa? (cdr pair)) (short-class-inspect-string (flatten-class (cdr pair))))
                          ((asl-object? (cdr pair)) "<Object>")
                          ((function? (cdr pair)) (string-append "Function" (as-string (formal-parameters-of-function (cdr pair))) "..."))
                          (else (as-string (cdr pair))))
                    )
                   )
                 fields))))

(define (inspect-member-of-object in-object member-pair . optional-parameters)
  (let ((indentation (optional-parameter 1 optional-parameters 0))
        (show-automatic-getters-setters (optional-parameter 2 optional-parameters #t))

        (member-name (car member-pair))
        (member-value (cdr member-pair))
       )
    (display-message
     (string-append
        (make-string indentation #\space) (as-string member-name) ": " 

        (cond ((kappa? member-value) (short-class-inspect-string (flatten-class member-value)))
              ((asl-object? member-value)
                  (let* ((object member-value)
                         (obj-role (object-role object))
                        )
                     (if (empty-string? obj-role)
                         "<Object>"
                         (string-append "<" obj-role " " "Object>"))))
              ((function? member-value) (string-append "Function" (as-string (formal-parameters-of-function member-value)) "..."))
              (else (as-string member-value)))))

    ; Display automatic getters and setters
    (if (and show-automatic-getters-setters (not (function? member-value)))
        (let ((getter-name (getter-name member-name))
              (setter-name (setter-name member-name))
             )
          (if (not (field-exists? in-object getter-name))
              (display-message
               (string-append
                (make-string indentation #\space) (as-string getter-name) ": "  "Automatic getter")))

          (if (not (field-exists? in-object setter-name))
              (display-message
               (string-append
                (make-string indentation #\space) (as-string setter-name) ": "  "Automatic setter")))))))


 
(define (inspect object . optional-parameters)
 (let ((variation (optional-parameter 1 optional-parameters 'short)))
  (cond ((function? object) (display-message (as-string object)))

        ; an (non-class) object without a class
        ((and (object-without-class? object) (not (kappa? object)))
           (let ((role (object-role object)))
             (if (empty-string? role)
                 (display-message "An object without a class:")
                 (display-message "An object of role" role "without a class:")))
           (for-each (lambda (member-pair)
                        (inspect-member-of-object object member-pair 2))
                     (append (remove-internal-fields (object-fields-alist object))
                              (if (eq? variation 'full) (remove-internal-fields (object-fields-alist root-object)) '()))))

        ; an (non-class) object with a class
        ((and (asl-object? object) (not (kappa? object))) 
           (display-message "An instance of a class")

           (display-message "  Instance members:")
           (for-each (lambda (member-pair)
                        (inspect-member-of-object object member-pair 4 #f))
                     (remove-internal-fields (append (object-fields-alist object) 
                                                     (if (eq? variation 'full) (object-fields-alist root-object) '())) 
                                             (list '$superclass '$kind '$instance-of)))
           (display-message "  Class members:")
           (for-each (lambda (member-pair)
                        (inspect-member-of-object object member-pair 4))
                     (remove-internal-fields (class-fields-alist (class-of object)
                                                                 (if (eq? variation 'full) 'class #f)))))


        ; a class object
        ((and (asl-object? object) (kappa? object)) 
           (display-message "A class object")
           (for-each (lambda (member-pair)
                        (inspect-member-of-object object member-pair 4))
                        (remove-internal-fields (object-fields-alist object) 
                                                (list '$superclass '$kind '$instance-of)))

           (if (assq '$superclass (object-fields-alist object))
               (let ((super-class (superclass-of object)))
                 (display-message "From superclass:")

                 (for-each (lambda (member-pair)
                        (inspect-member-of-object object member-pair 4))
                     (remove-internal-fields (class-fields-alist super-class (if (eq? variation 'full) 'object #t))))))
        )

        ; a class object - NOT USED.
        ((and (asl-object? object) (kappa? object)) 
           (display-message "A class object")

           (for-each (lambda (member-pair)
                        (inspect-member-of-object object member-pair 4))
                     (remove-internal-fields (class-fields-alist object (if (eq? variation 'full) 'object #t)))))

        (else object))))


(define (short-class-inspect-string class-obj)
  (let* ((fields (object-fields-alist class-obj))
         (non-internal-fields (filter (negate internal-field?) fields)))
     (string-append
        "A class with the fields: " (string-append CR "          ")
        (list-to-string
          (map-bites 
           (bite-of-length 5)
           (lambda (bite)
             (list (list-to-string bite ", ")))
           (map (compose as-string car) non-internal-fields)
          )
         (string-append CR "          ")
        )
     )
  )
)

; Does the field, the (name . value) pair, represent an internal field?
(define (internal-field? pair)
  (let ((name (as-string (car pair))))
    (internal-field-name? name)))

(define (internal-field-name? name)
  (let ((name-str (as-string name)))
    (if (>= (string-length name-str) 1)
        (eqv? #\$ (string-ref name-str 0))
        #f)))
  

;;; Function objects.
;;; Function objects form the basis for methods.
;;; When a function object is added to an object or a class, it becomes a method in the object.
; OLD version
; (define-syntax function
;  (syntax-rules ()
;     ((function formal-parameters body)
;      (make-function (quote formal-parameters) (quote body) '()))))


 
(define-syntax function
  (syntax-rules ()
     ((function formal-parameters body-form ...)
      (make-function (quote formal-parameters) (quote (begin body-form ...)) '()))))

; The parameter formal-parameter-list may be a proper list, such as (x y y) an improper list, such as (x y . z), or a name, such as z.
; Relative to the examples, z is a rest parameter which in a function call is bound to the list of the rest of the actual parameters
(define (make-function formal-parameter-list expression environment)
  (list 'function formal-parameter-list expression environment)
)


 
(define (function? x)
  (and (list? x)
       (= (length x) 4)
       (eq? (car x) 'function)))

 
(define (expression-of-function function) (third function))

 
(define (formal-parameters-of-function function) (second function))

 
(define (environment-of-function function) (fourth function))

; Refurnish the function to another environment env.
; That is, return a function which has env as its environment part.
; Not used.
; .parameter function-object A function object, as created by make-function.
; .parameter env An association list of name/value pairs.
(define (refurnish-function function-object env)
  (make-function 
    (formal-parameters-of-function function-object)
    (expression-of-function function-object)
    env))


 
(define (apply-function function-object actual-parameter-list)
  (if (function? function-object)
      (eval-expr (expression-of-function function-object) 
                 (append (pair-up-parameters-in-function-application (formal-parameters-of-function function-object) actual-parameter-list) (environment-of-function function-object)))
      (error "Apply-function needs a function object as the first parameter")))

(define (pair-up-parameters-in-function-application formal-parameters actual-parameter-list)
  (cond ((symbol? formal-parameters) (list (cons formal-parameters actual-parameter-list)))
        ((and (null? formal-parameters) (null? actual-parameter-list)) '()) 
        ((and (pair? formal-parameters) (pair? actual-parameter-list) (symbol? (car formal-parameters)))
            (cons
              (cons (car formal-parameters) (car actual-parameter-list))
              (pair-up-parameters-in-function-application (cdr formal-parameters) (cdr actual-parameter-list))))
        ((and (pair? formal-parameters) (null? actual-parameter-list))
            (error "Insufficient number of actual parameters"))
        ((and (null? formal-parameters))
            (error "Insufficient number of formal parameters"))
        (else (error "Malformed formal or actual parameter list"))))


;;; Expressions.
;;; Expressions are encapsluated in functions, which in turn form the basis of methods.
;;; The method eval-expr is the main function of a simple, meta circular Scheme interpreter.
;;; It has been adapted from the book 'The Scheme Programming Language' by R. Kent Dybvig.
 
(define eval-expr #f)

(let ()
    (define primitive-environment
    `((+ . ,+) (- . ,-) (* . ,*) (/ . ,/) (= . ,=) (>= . ,>=) (<= . ,<=) (> . ,>) (< . ,<)
      (string-append . ,string-append)
      (apply . ,apply) (assq . ,assq) (call/cc . ,call-with-current-continuation)
      (car . ,car) (cadr . ,cadr) (caddr . ,caddr)
      (cadddr . ,cadddr) (cddr . ,cddr) (cdr . ,cdr)
      (cons . ,cons) (eq? . ,eq?) (list . ,list)
      (map . ,map) (memv . ,memv) (null? . ,null?)
      (pair? . ,pair?) (read . ,read) (set-car! . ,set-car!)
      (set-cdr! . ,set-cdr!) (symbol? . ,symbol?)
      (clone-object . ,clone-object)
      (sqrt . ,sqrt) (square . ,(lambda (x) (* x x)))

      (get-field . ,get-field) (set-field! . ,set-field!)  ; setter and getters in the implementation of ASL.
      (new . ,new-object)
      (add-member! ,add-member!) (delete-member! ,delete-member!)
      (kappa . ,kappa) (kappa? . ,kappa?)
      (as-instance-of-class! . ,as-instance-of-class!)
      (generalize-multiple-classes! . ,generalize-multiple-classes!)
;      (error . ,error)
     )
  )

    (define new-env
    (lambda (formals actuals env)
      (cond
        ((null? formals) env)
        ((symbol? formals) (cons (cons formals actuals) env))
        (else
         (cons (cons (car formals) (car actuals))
               (new-env (cdr formals) (cdr actuals) env))))))

    (define lookup-orig
    (lambda (var env)
      (let ((res (assq var env)))
        (if res 
            (cdr res)
            (if (bound? var)
                (eval var (interaction-environment))  ; earlier:  (error (string-append "Lookup error: Cannot find " (as-string var)))))))
                (error (string-append "The variable " (as-string var) " is unbound in the local environment, the environment of the hosting object, the primitives environment, and in the implementation's interaction environment."))
            )
        ))))

    (define lookup
    (lambda (var env)
      (let ((res (assq var env))
            (current-object (eval 'this-object (interaction-environment)))
           )
        (cond (res (cdr res))
              ((and (asl-object? current-object) (field-exists? current-object var)) (get-field current-object var))
              ((bound? var) (eval var (interaction-environment)))
              (else (error (string-append "The variable " (as-string var) " is unbound in the given environment, the primitives environment, and in the implementation's interaction environment.")))))))


    (define assign
    (lambda (var val env)
      (set-cdr! (assq var env) val)))

    (define exec
    (lambda (exp env)
      (cond
        ((symbol? exp) (lookup exp env))
        ((pair? exp)
         (case (car exp)
           ((quote) (cadr exp))
           ((lambda)
            (lambda vals
              (let ((env (new-env (cadr exp) vals env)))
                (let loop ((exps (cddr exp)))
                   (if (null? (cdr exps))
                       (exec (car exps) env)
                       (begin
                          (exec (car exps) env)
                          (loop (cdr exps))))))))
           ((if)
            (if (exec (cadr exp) env)
                (exec (caddr exp) env)
                (exec (cadddr exp) env)))

           ((function)   ; new and experimental Oct 10, 2011.
              (let ((formal-parameters (cadr exp))
                    (body-forms (cddr exp)))
                (make-function formal-parameters (cons 'begin body-forms) env)
              )
           )


           ((set!)  ; modified june 14, 2011 - Now (set! var ...) provides lexical access to names in left hand side contexts.
              (let ((lhs (cadr exp))
                    (rhs (caddr exp))
                    (current-object (eval 'this-object (interaction-environment)))
                   )
                (cond ((assq lhs env)                          ; the lhs variable is in the environment
                         (assign lhs (exec rhs env) env)       ; assign to a variable in the environment
                      )
                      ((field-exists? current-object lhs)
                         (set-field! current-object lhs (exec rhs env)))
                      (else (error (string-append "Cannot assign: The variable " (as-string lhs) " is not a local variable, nor a field in the current object.")))
                )
              )
           )

           ((begin)   ; modified june 10, 2011 - Now the value of (begin ...) is the value of the last expression in the begin form.
              (let ((imperatives (cdr exp)))
                 (if (not (null? imperatives))
                     (let ((prefix-imperatives (butlast imperatives))
                           (last-imperative (last imperatives)))
                       (for-each 
                         (lambda (imperative) (exec imperative env))
                         prefix-imperatives)
                       (exec last-imperative env))))
           )

           ((let)
              (let* ((name-bindings (cadr exp))
                     (names  (map car name-bindings))
                     (values (map cadr name-bindings))
                     (body-forms (cddr exp)))
                (exec `((lambda ,names ,@body-forms) ,@values) env)
              )
           )

           ((dot)
             (let ((object (exec (cadr exp) env))
                   (field-name (caddr exp)))
               (if (not (= (length (cdr exp)) 2))
                   (error (string-append "Illegal dot form: " (as-string exp) " .   " "Must be of the form: (dot object field-name)"))) 
               (get-field object field-name))
           )

           (else
            (apply (exec (car exp) env)
                   (map (lambda (x) (exec x env))
                        (cdr exp))))
         )
        )
        (else exp))))

  (define interpret
     (lambda (expr env)
       (exec expr (append env primitive-environment))))

    (set! eval-expr interpret))


; Low level object stuff.


; The fields of an object represented as a property list.
; Includes internal (dollar) fields.
(define (object-property-list object)
  (if (asl-object? object)
      (alist-to-propertylist (object-fields-alist object))
      (error "The first parameter must be an object")))

; Does field exist in the object's immediate fields (disregarding that the object may be a class object).
(define (field-exists-raw? object field)
  (turn-into-boolean (find-in-list (lambda (pair) (eq? (car pair) field)) (object-fields-alist object))))

; Assume as a precondition that field-name exists
(define (get-field-raw object field-name)
  (get field-name (object-fields-alist object)))

; Return those fields names of object which represent data fields.
; Does not return any internal $-prefixed field names.
; Only names of object - independent of relations to other objects.
(define (data-field-names-of object)
  (map car (filter (negate (disjunction internal-field? function-field?)) (object-fields-alist object))))

; Return the member names of object (data as well as methods).
; Does not return any internal $-prefixed field names.
; Only names of object - independent of relations to other objects.
(define (member-names-of object)
  (map car (filter (negate internal-field?) (object-fields-alist object))))



; Return an alist of the fields of class.
; Appends information from the superclass chain, up to either Class, root-object or the last class before Class (in case last-class if #t).
; Ordered such that fields from specialized classes come before fields from general classes.
; Does not return any internal fields (dollar fields).
; .form (class-fields-alist class [last-class])
; .parameter last-class Either class, object (a symbol) or #t.
; .returns An alist of field names and field default values.
(define (class-fields-alist class . optional-parameters)
 (let ((last-class (optional-parameter 1 optional-parameters 'object)))
  (if (kappa? class)
      (if (eq? class class-object)
          (cond ((eq? last-class 'object)
                   (append (remove-internal-fields (object-fields-alist class-object)) (remove-internal-fields (object-fields-alist root-object))))
                ((eq? last-class 'class)
                   (remove-internal-fields (object-fields-alist class-object)))
                (else '()))
          (let* ((class-fields (object-fields-alist class))
                 (superclass-object (if (field-exists-raw? class '$superclass)   ;  field-exists -> field-exists-raw? aug 17, 2010
                                        (get-field-raw class '$superclass)
                                        class-object))   ; several interpretations are possible - see cond of outer if.
                )
            (append 
               (remove-internal-fields class-fields)                       ; Order of these have been reversed june 10, 2011. This corrects an error.
               (class-fields-alist superclass-object last-class)           ; Recurses
            )
          )
      )
      (error "Cannot extract class fields of a non-kappa object")) ))

; Remove per default the internal fields $superclass and $kind, or the internal fields enumerated in the optional parameter. 
(define (remove-internal-fields fields-alist . optional-parameters)
 (let ((internal-fields (optional-parameter 1 optional-parameters (list '$superclass '$kind))))  ; internal fields to remove
  (filter
    (lambda (pair)
       (not (memq (car pair) internal-fields)))
    fields-alist)))

; Mutate the pair (key . -) in a-list to be (key . val).
; Identifies key with eq?
(define (a-set! a-list key val)
  (let ((pair (find-in-list (lambda (p) (eq? key (car p))) a-list)))
    (if pair (set-cdr! pair val))))

; Mutate the pair (key . -) in a-list to be (key . val).
; Identifies key with equal.
(define (a-set-equal! a-list key val)
  (let ((pair (find-in-list (lambda (p) (equal? key (car p))) a-list)))
    (if pair (set-cdr! pair val))))



(define (last-cons-cell lst)
  (cond ((and (pair? lst) (null? (cdr lst))) lst)
        ((pair? lst) (last-cons-cell (cdr lst)))
        (else (error "last-cons-cell applied on non-list"))))
  
; just suggar
(define name-of-field car)
(define value-of-field cdr)

;;; General ASL2 Standard Objects. 
 
(define root-object 
  (let ((class-obj (make-object '$kind 'class)))
     (add-member! class-obj 'AddMember (function (memberName memberValue) (add-member! this-object memberName memberValue))) 
     (add-member! class-obj 'DeleteMember (function (memberName) (delete-member! this-object memberName))) 
     (add-member! class-obj 'Kappa (function () (kappa this-object)))    ; A left over from old days
     (add-member! class-obj 'Kappa? (function () (kappa? this-object))) 
     (add-member! class-obj 'AsInstanceOfClass (function (class) (as-instance-of-class! this-object class))) 
     (add-member! class-obj 'GetField (function (field-name) (get-field this-object field-name)))
     (add-member! class-obj 'SetField (function (field-name field-value) (set-field! this-object field-name field-value)))
     (add-member! class-obj 'Clone (function () (clone-object this-object)))

     class-obj))

 
(define class-object
  (let ((class-obj (make-object '$kind 'class)))
     (add-member! class-obj '$superclass root-object)
     (add-member! class-obj 'New (function fields-and-values (apply new-object (cons this-object fields-and-values))))
;     (add-member! class-obj 'GeneralizeMultipleClasses (function (class) (generalize-multiple-classes! this class)))   
     class-obj))



; ---------------------------------------------------------------------------------------------------------------
; Object role administration.
; Object can be created with a certain role, which serves as a loose classification (and documentation) of the object.
; At a later point in time, objects that share a certain role may be converted to a class, with use of the primitive map-role-to-class!

; An association list that relates a role name (a string) to the list of all objects with this particular role.
(define *objects-by-role* '())

; Insert object with the given role-name in the rolled object adminstration system.
(define (insert-object-with-role! object role-name)
  (let ((role-collection (assoc role-name *objects-by-role*)))
    (if role-collection
        (let ((existing-role-objects (cdr role-collection)))
          (a-set-equal! *objects-by-role* role-name (cons object existing-role-objects)))
        (set! *objects-by-role* (extend-a-list-raw role-name (list object) *objects-by-role*)))))

(define (extend-a-list-raw key value a-list)
 (cons (cons key value) a-list))

; Return the list of objects with the role role-string.
(define (objects-with-role role-string)
  (let ((lookup-res (assoc role-string *objects-by-role*)))
    (if lookup-res (cdr lookup-res) '())))

; Remove all objects from role-string. In other words, reset the role represented by role-string.
(define (reset-objects-with-role! role-string)
  (a-set-equal! *objects-by-role* role-string '()))

; Return a method with selector among from the pool of objects with role.
; If no such method exists, or if such a method is ambiguous, return #f.
(define (borrow-method-from-objects-of-same-role role selector)
  (let ((candicate-objects (objects-with-role role)))
    (if (not (null? candicate-objects))
        (let ((objects-with-method (filter (lambda (obj) (field-exists-raw? obj selector)) candicate-objects)))
           (cond ((= (length objects-with-method) 0) #f)
                 ((= (length objects-with-method) 1) (get-field (car objects-with-method) selector))
                 (else (let* ((methods (map (lambda (obj) (get-field obj selector)) objects-with-method))
                              (methods-equals? (accumulate-right
                                                (lambda (meth1 meth2) (methods-syntactical-equal? meth1 meth2))
                                                #t
                                                methods)))
                         (if methods-equals?
                             (car methods)
                             #f)))))
        #f)))

(define (methods-syntactical-equal? m1 m2)
  (equal? m1 m2))

; An association list that maps role (strings) to a class object.
(define role-class-mapping '())

; Ensures that objects with the role represented by role-string in the future is handled as instances of the class represented by class-object.
; This affects the behavior of (make-object role-string ...), which will instantiate the class instead of making an independent object. 
(define (map-role-to-class! role-string class-object)
  (for-each (lambda (obj) (as-instance-of-class! obj class-object)) (objects-with-role role-string)) 
  (reset-objects-with-role! role-string)                                                 ; detach existing objects from the role. 
  (set! role-class-mapping (cons (cons role-string class-object) role-class-mapping))
)

; ---------------------------------------------------------------------------------------------------------------
; Traditional class syntax - syntatic abstraction

(define-syntax class
  (syntax-rules ()
     ((class class-name (superclass-name ...) member ...)
      (define class-name (make-full-class (quote (superclass-name ...)) (quote (member ...)))))))

(define (make-full-class superclass-list member-list)
  (let* ((superclass-object 
           (cond ((and (list? superclass-list) (= (length superclass-list) 1))
                    (let ((superclass-name (car superclass-list)))
                      (if (bound? superclass-name) (eval superclass-name) (laml-error "Name of superclass is unbound"))))
                 ((and (list? superclass-list) (= (length superclass-list) 0))
                     #f)
                 (else (laml-error "At most one superclass can be supplied"))))
         (class-object (if superclass-object (make-class superclass-object) (make-class))))

    ; Add members to class-object
    (for-each (lambda (member)
                (let ((member-name (car member))
                      (member-value (if (= (length member) 2) 
                                        (eval (cadr member))
                                        'undefined))
                     )
                  (add-member! class-object member-name member-value)))
              member-list)
    
    class-object))

; ---------------------------------------------------------------------------------------------------------------
;;; Generation of class forms.
;;; The primitive that turns an ASL2 class object into a class description in a source file.
 
(define (class-source class-object class-name superclass-name file-path . optional-parameters)
  (let ((class-role (optional-parameter 1 optional-parameters #f))
        )
    (if (kappa? class-object)
        (let* ((superclass-object-0 (superclass-of class-object))
               (superclass-object (if (eq? superclass-object-0 class-object) #f superclass-object-0))  ; the given superclass - not Class
               (field-list (object-data-fields-alist class-object))
               (method-list (object-method-fields-alist class-object))
               (indent (lambda (n) (lambda (str) (string-append (make-string n #\space) str))))
              )

;  Test eliminated july 11, 2012:
;          (if (and superclass-object (not superclass-name))
;              (laml-error "You must supply a superclass name (an optional third parameter)"))
              
          (let ((class-string
                  (string-append
                     "(" "class" " " class-name " "        "(" (if superclass-object (as-string superclass-name) "") ")" CR
                         (list-to-string (map (indent 2) (map field-source field-list)) CR) CR
                         (list-to-string (map (indent 2) (map method-source method-list)) CR) CR
                     ")"
                  ))
                (mapping-entry 
                  (if class-role
                      (string-append
                         "(" "map-role-to-class!" " " (as-quoted-string class-role) " " class-name ")")
                      ""))
              ) 

             (write-text-file (string-append class-string CR CR mapping-entry) file-path)

             (lib-load "scheme-pretty-printing.scm")
             (if (file-exists? file-path)
                 (begin 
                    (pretty-print-lisp-file file-path)
                    'DONE-AND-PRETTY-PRINTED)
                 'DONE)
        ))
        (laml-error "The first parameter must be a class"))))

(define (field-source member)
  (let ((member-name (car member))
        (member-value (cdr member)))
    (if (asl-object? member-value)
        (string-append "(" (as-quoted-string member-name) ")")
        (string-append "(" (as-string member-name) " "
                       (as-quoted-string member-value) ; ?
                   ")"))))

(define (method-source member)
  (let ((member-name (car member))
        (member-value (cdr member)))
    (string-append "(" (as-string member-name) " "
                       (function-source member-value)
                   ")"))) 


(define (function-source function-object)
  (if (function? function-object)
       (let* ((par-list (cadr function-object))
              (body (caddr function-object))
              (body-forms (if (and (list? body) (>= (length body) 1) (eq? (car body) 'begin))
                              (cdr body)
                              #f))
             )
        (string-append
            "("
               "function" " "
               "(" (list-to-string (map as-string par-list) " ") ")" " "
               (if body-forms
                   (list-to-string (map as-quoted-string body-forms) " ")
                   (as-quoted-string body) 
               )

            ")"))
      (laml-error "Malformed function object")))


; ---------------------------------------------------------------------------------------------------------------
; DEMO definitions

(define END-DEMO 'OK)

(define (END-SECTION txt)
  'OK)

; Add Borrow to root-object
(send root-object 'AddMember 'Borrow
       (function (member-name from-obj)
          (send this-object 'AddMember member-name
                (send from-obj 'GetField member-name))))

(send root-object 'AddMember 'PrivateField
  (function (field-name)
    (send this-object 'AddMember (getter-name field-name) (function () (error (string-append "ERROR: The field" " " (as-string field-name) " " "is private - you cannot read it from outside the object."))))
    (send this-object 'AddMember (setter-name field-name) (function (value) (error (string-append "ERROR: The field" " " (as-string field-name) " " "is private - you cannot write to it from outside the object."))))
))

(define (other-corner-1 corner)
 (cond ((eq? corner 'c1) 'c2)
       ((eq? corner 'c2) 'c3)
       ((eq? corner 'c3) 'c1)
       (else (error "Illegal corner given til other-corner-1"))))

(define (other-corner-2 corner)
 (cond ((eq? corner 'c1) 'c3)
       ((eq? corner 'c2) 'c1)
       ((eq? corner 'c3) 'c2)
       (else (error "Illegal corner given til other-corner-1"))))

(define PI 3.1415962)

(define (radian-to-degree r)
  (/ (* r 360) (* 2 PI)))

(define (degree-to-radians d)
  (/ (* d 2 PI) 360)) 

(define (getter-of symbol)
  (as-symbol (string-append "get" "-" (as-string symbol))))