From 562a9a52d599d9a05f871404050968a5fd282640 Mon Sep 17 00:00:00 2001 From: elioat Date: Wed, 23 Aug 2023 07:52:19 -0400 Subject: * --- .../~bh/61a-pages/Volume1/Project3/obj.scm | 279 +++++++++++++++++++++ 1 file changed, 279 insertions(+) create mode 100644 js/games/nluqo.github.io/~bh/61a-pages/Volume1/Project3/obj.scm (limited to 'js/games/nluqo.github.io/~bh/61a-pages/Volume1/Project3/obj.scm') diff --git a/js/games/nluqo.github.io/~bh/61a-pages/Volume1/Project3/obj.scm b/js/games/nluqo.github.io/~bh/61a-pages/Volume1/Project3/obj.scm new file mode 100644 index 0000000..d4a9d7a --- /dev/null +++ b/js/games/nluqo.github.io/~bh/61a-pages/Volume1/Project3/obj.scm @@ -0,0 +1,279 @@ +;;; obj.scm version 4.0 5/18/2000 +;;; -- implementation of the object-oriented syntax +;; By Matt Wright, based on a handout from MIT +;; Revised for STk by Brian Gaeke - removed scm and procedure->macro + +;;; Utilities + +;; MAKNAM: create a new symbol whose name is the concatenation of the +;; names of those in the symbol list SYMBOLS. +(define (maknam . symbols) + (string->symbol (apply string-append (map symbol->string symbols)))) + +;; ASK: send a message to an object + +; The dot in the first line of the definition of ASK, below, makes it +; take a variable number of arguments. The first argument is associated +; with the formal parameter OBJECT; the second with MESSAGE; any extra +; actual arguments are put in a list, and that list is associated with +; the formal parameter ARGS. (If there are only two actual args, then +; ARGS will be the empty list.) + +; APPLY takes two arguments, a procedure and a list, and applies the +; procedure to the things in the list, which are used as actual +; argument values. + +(define (ask object message . args) + (let ((method (object message))) + (if (method? method) + (apply method args) + (error "No method " message " in class " (cadr method))))) + +(define (no-method name) + (list 'no-method name)) + +(define (no-method? x) + (if (pair? x) + (eq? (car x) 'no-method) + #f)) + +(define (method? x) + (not (no-method? x))) + + +;; INSTANTIATE and INSTANTIATE-PARENT: Create an instance of a class + +; The difference is that only INSTANTIATE initializes the new object + +(define (instantiate class . arguments) + (let ((new-instance (apply (class 'instantiate) arguments))) + (ask new-instance 'initialize new-instance) + new-instance)) + +(define (instantiate-parent class . arguments) + (apply (class 'instantiate) arguments)) + +;; GET-METHOD: Send a message to several objects and return the first +;; method found (for multiple inheritance) + +(define (get-method give-up-name message . objects) + (if (null? objects) + (no-method give-up-name) + (let ((method ((car objects) message))) + (if (method? method) + method + (apply get-method (cons give-up-name + (cons message (cdr objects)) )))))) + + + +;; USUAL: Invoke a parent's method +;; Note: The 'send-usual-to-parent method is put in automatically by +;; define-class. + +(define-macro (usual . args) + `(ask dispatch 'send-usual-to-parent . ,args)) + + +;; DEFINE-CLASS: Create a new class. + +; DEFINE-CLASS is a special form. When you type (define-class body...) +; it's as if you typed (make-definitions (quote body...)). In other +; words, the argument to DEFINE-CLASS isn't evaluated. This makes sense +; because the argument isn't Scheme syntax, but rather is the special +; object-oriented programming language we're defining. +; Make-definitions transforms the OOP notation into a standard Scheme +; expression, then uses EVAL to evaluate the result. (You'll see EVAL +; again in chapter 4 with the metacircular evaluator.) + +; When you define a class named THING, for example, two global Scheme +; variables are created. The variable THING has as its value the +; procedure that represents the class. This procedure is invoked by +; INSTANTIATE to create instances of the class. A second variable, +; THING-DEFINITION, has as its value the text of the Scheme expression +; that defines THING. This text is used only by SHOW-CLASS, the +; procedure that lets you examine the result of the OOP-to-Scheme +; translation process. + +(define-macro (define-class . body) (make-definitions body)) + +(define (make-definitions form) + (let ((definition (translate form))) + (eval `(define ,(maknam (class-name form) '-definition) ',definition)) + (eval definition) + (list 'quote (class-name form)))) + +(define (show-class name) + (eval (maknam name '-definition)) ) + +; TRANSLATE does all the work of DEFINE-CLASS. +; The backquote operator (`) works just like regular quote (') except +; that expressions proceeded by a comma are evaluated. Also, expressions +; proceeded by ",@" evaluate to lists; the lists are inserted into the +; text without the outermost level of parentheses. + +(define (translate form) + (cond ((null? form) (error "Define-class: empty body")) + ((not (null? (obj-filter form (lambda (x) (not (pair? x)))))) + (error "Each argument to define-class must be a list")) + ((not (null? (extra-clauses form))) + (error "Unrecognized clause in define-class:" (extra-clauses form))) + (else + `(define ,(class-name form) + (let ,(class-var-bindings form) + (lambda (class-message) + (cond + ,@(class-variable-methods form) + ((eq? class-message 'instantiate) + (lambda ,(instantiation-vars form) + (let ((self '()) + ,@(parent-let-list form) + ,@(instance-vars-let-list form)) + (define (dispatch message) + (cond + ,(init-clause form) + ,(usual-clause form) + ,@(method-clauses form) + ,@(local-variable-methods form) + ,(else-clause form) )) + dispatch ))) + (else (error "Bad message to class" class-message)) ))))))) + +(define *legal-clauses* + '(instance-vars class-vars method default-method parent initialize)) + +(define (extra-clauses form) + (obj-filter (cdr form) + (lambda (x) (null? (member (car x) *legal-clauses*))))) + +(define class-name caar) + +(define (class-var-bindings form) + (let ((classvar-clause (find-a-clause 'class-vars form))) + (if (null? classvar-clause) + '() + (cdr classvar-clause) ))) + +(define instantiation-vars cdar) + +(define (parent-let-list form) + (let ((parent-clause (find-a-clause 'parent form))) + (if (null? parent-clause) + '() + (map (lambda (parent-and-args) + (list (maknam 'my- (car parent-and-args)) + (cons 'instantiate-parent parent-and-args))) + (cdr parent-clause))))) + +(define (instance-vars-let-list form) + (let ((instance-vars-clause (find-a-clause 'instance-vars form))) + (if (null? instance-vars-clause) + '() + (cdr instance-vars-clause)))) + +(define (init-clause form) + (define (parent-initialization form) + (let ((parent-clause (find-a-clause 'parent form))) + (if (null? parent-clause) + '() + (map + (lambda (parent-and-args) + `(ask ,(maknam 'my- (car parent-and-args)) 'initialize self) ) + (cdr parent-clause) )))) + (define (my-initialization form) + (let ((init-clause (find-a-clause 'initialize form))) + (if (null? init-clause) '() + (cdr init-clause)))) + (define (init-body form) + (append (parent-initialization form) + (my-initialization form) )) + + `((eq? message 'initialize) + (lambda (value-for-self) + (set! self value-for-self) + ,@(init-body form) ))) + +(define (variable-list var-type form) + (let ((clause (find-a-clause var-type form))) + (if (null? clause) + '() + (map car (cdr clause)) ))) + +(define (class-variable-methods form) + (cons `((eq? class-message 'class-name) (lambda () ',(class-name form))) + (map (lambda (variable) + `((eq? class-message ',variable) (lambda () ,variable))) + (variable-list 'class-vars form)))) + +(define (local-variable-methods form) + (cons `((eq? message 'class-name) (lambda () ',(class-name form))) + (map (lambda (variable) + `((eq? message ',variable) (lambda () ,variable))) + (append (cdr (car form)) + (variable-list 'instance-vars form) + (variable-list 'class-vars form))))) + +(define (method-clauses form) + (map + (lambda (method-defn) + (let ((this-message (car (cadr method-defn))) + (args (cdr (cadr method-defn))) + (body (cddr method-defn))) + `((eq? message ',this-message) + (lambda ,args ,@body)))) + (obj-filter (cdr form) (lambda (x) (eq? (car x) 'method))) )) + +(define (parent-list form) + (let ((parent-clause (find-a-clause 'parent form))) + (if (null? parent-clause) + '() + (map (lambda (class) (maknam 'my- class)) + (map car (cdr parent-clause)))))) + +(define (usual-clause form) + (let ((parent-clause (find-a-clause 'parent form))) + (if (null? parent-clause) + `((eq? message 'send-usual-to-parent) + (error "Can't use USUAL without a parent." ',(class-name form))) + `((eq? message 'send-usual-to-parent) + (lambda (message . args) + (let ((method (get-method ',(class-name form) + message + ,@(parent-list form)))) + (if (method? method) + (apply method args) + (error "No USUAL method" message ',(class-name form)) ))))))) + +(define (else-clause form) + (let ((parent-clause (find-a-clause 'parent form)) + (default-method (find-a-clause 'default-method form))) + (cond + ((and (null? parent-clause) (null? default-method)) + `(else (no-method ',(class-name form)))) + ((null? parent-clause) + `(else (lambda args ,@(cdr default-method)))) + ((null? default-method) + `(else (get-method ',(class-name form) message ,@(parent-list form))) ) + (else + `(else (let ((method (get-method ',(class-name form) + message + ,@(parent-list form)))) + (if (method? method) + method + (lambda args ,@(cdr default-method)) ))))))) + +(define (find-a-clause clause-name form) + (let ((clauses (obj-filter (cdr form) + (lambda (x) (eq? (car x) clause-name))))) + (cond ((null? clauses) '()) + ((null? (cdr clauses)) (car clauses)) + (else (error "Error in define-class: too many " + clause-name "clauses.")) ))) + +(define (obj-filter l pred) + (cond ((null? l) '()) + ((pred (car l)) + (cons (car l) (obj-filter (cdr l) pred))) + (else (obj-filter (cdr l) pred)))) + +(provide "obj") -- cgit 1.4.1-2-gfad0