diff options
| author | elioat <elioat@tilde.institute> | 2023-08-23 07:52:19 -0400 |
|---|---|---|
| committer | elioat <elioat@tilde.institute> | 2023-08-23 07:52:19 -0400 |
| commit | 562a9a52d599d9a05f871404050968a5fd282640 (patch) | |
| tree | 7d3305c1252c043bfe246ccc7deff0056aa6b5ab /js/games/nluqo.github.io/~bh/61a-pages/Volume1 | |
| parent | 5d012c6c011a9dedf7d0a098e456206244eb5a0f (diff) | |
| download | tour-562a9a52d599d9a05f871404050968a5fd282640.tar.gz | |
*
Diffstat (limited to 'js/games/nluqo.github.io/~bh/61a-pages/Volume1')
10 files changed, 2076 insertions, 0 deletions
diff --git a/js/games/nluqo.github.io/~bh/61a-pages/Volume1/CS 61A Course Reader, Volume 1.html b/js/games/nluqo.github.io/~bh/61a-pages/Volume1/CS 61A Course Reader, Volume 1.html new file mode 100644 index 0000000..0990f1a --- /dev/null +++ b/js/games/nluqo.github.io/~bh/61a-pages/Volume1/CS 61A Course Reader, Volume 1.html @@ -0,0 +1,79 @@ +<html><head> +<meta http-equiv="content-type" content="text/html; charset=UTF-8"><title>CS 61A Course Reader, Volume 1</title><style type="text/css">@namespace url(http://www.w3.org/1999/xhtml); +@font-face { + font-family: 'EasyRead2'; + font-style: normal; + font-weight: 400; + src: local('EasyRead2'), url(https://cdn.rawgit.com/PullJosh/files/gh-pages/Arial-LargePeriod2.woff) format('woff'); +}input[type="text"], input[type="textarea"], textarea { + font-family: "EasyRead2" !important; + }</style></head> +<body> + +<center> +<h1> CS61A: Structure and Interpretation of Computer Programs </h1> +<h3> Course Reader, Volume 1: Semester Assignments </h3> +</center> + +<table frame="box" pixels="6"><tbody><tr><td> +<h2><b>Berkeley students: Do not print or use these pages! They do not have +the dates for the current semester, so they won't help you. They are here +for non-Berkeley people. ESPECIALLY DON'T LOOK HERE FOR THE PROGRAMMING +PROJECTS, WHICH ARE DIFFERENT HERE FROM THE CURRENT ONES!</b></h2> +</td></tr></tbody></table> + +<p>For many years I resisted the trend to putting course materials online, +but I've been convinced because of the increasing numbers of people who +aren't at Berkeley but use the +<a href="http://wla.berkeley.edu/main.php?course=cs61a">online lectures</a> +to study SICP. Welcome, visitors! Our course reader is divided into two +volumes, this small one with semester-varying material, and +<a href="https://inst.eecs.berkeley.edu/%7Ecs61a/reader/vol2.html">Volume 2</a>, with unchanging reference material, +so that our students can buy used copies of Volume 2, and only need new +copies of Volume 1. What's online has the dates removed. <b>Also, the +projects vary somewhat from semester to semester, so what you see here is +only approximately what's current -- I don't update the online version.</b> + +</p><ul> +<li><a href="hw.pdf"> +Homework assignments</a> +</li><li>Programming Projects: +<ul> +<li><a href="https://people.eecs.berkeley.edu/~bh/61a-pages/Volume1/Project1/nodate-21.pdf">Project 1: Twenty-one +</a><ul><li><a href="Project1/twenty-one.scm">twenty-one.scm</a></li></ul> +</li><li><b>Project 2 is in the textbook!</b> +<a href="https://mitpress.mit.edu/sites/default/files/sicp/full-text/book/book-Z-H-15.html#%_sec_2.2.4"> +(Section 2.2.4)</a><br /> +You can't actually draw anything until you +finish the project!<br /><br />To begin, copy the file +<a href="../Lib/picture.scm">picture.scm</a> to your directory.<br /><br />To +draw pictures, once you've completed the exercises:<br /><br /> +> (cs)<br /> +> (ht)<br /> +> (===your-painter=== full-frame)<br /><br /> +For example:<br /><br /> +> (wave full-frame)<br /> +> ((square-limit wave 3) full-frame)<br /> +</li><li><a href="Project3/adv.txt">Project 3: Adventure Game +</a><ul><li><a href="https://people.eecs.berkeley.edu/~bh/61a-pages/Volume1/Project3/adv.scm">adv.scm</a></li></ul> +<ul><li><a href="Project3/adv-world.scm">adv-world.scm</a></li></ul> +<ul><li><a href="Project3/small-world.scm">small-world.scm</a></li></ul> +<ul><li><a href="https://people.eecs.berkeley.edu/~bh/61a-pages/Volume1/Project3/labyrinth.scm">labyrinth.scm</a></li></ul> +<ul><li><a href="Project3/obj.scm">obj.scm</a></li></ul> +</li><li><a href="https://people.eecs.berkeley.edu/~bh/61a-pages/Volume1/Project4/logo.txt">Project 4: Logo Interpreter +</a><ul><li><a href="Project4/logo.scm">logo.scm</a></li></ul> +<ul><li><a href="Project4/logo-meta.scm">logo-meta.scm</a></li></ul> +<ul><li><a href="https://people.eecs.berkeley.edu/~bh/61a-pages/Volume1/Project4/tables.scm">tables.scm</a></li></ul> +<ul><li><a href="Project4/obj.scm">obj.scm</a></li></ul> +</li></ul> +</li><li><a href="https://people.eecs.berkeley.edu/~bh/61a-pages/Volume1/labs.pdf"> +Lab assignments</a> +</li></ul> +<p> +</p><p> +</p><p> +</p><p><a href="../Volume2/CS 61A Course Reader, Volume 2.html">Volume 2</a> +</p><p><a href="../../61a-pages">Back to class web page</a> + + +</p></body></html> diff --git a/js/games/nluqo.github.io/~bh/61a-pages/Volume1/Project1/twenty-one.scm b/js/games/nluqo.github.io/~bh/61a-pages/Volume1/Project1/twenty-one.scm new file mode 100644 index 0000000..1c1c6bb --- /dev/null +++ b/js/games/nluqo.github.io/~bh/61a-pages/Volume1/Project1/twenty-one.scm @@ -0,0 +1,60 @@ + + +(define (twenty-one strategy) + (define (play-dealer customer-hand dealer-hand-so-far rest-of-deck) + (cond ((> (best-total dealer-hand-so-far) 21) 1) + ((< (best-total dealer-hand-so-far) 17) + (play-dealer customer-hand + (se dealer-hand-so-far (first rest-of-deck)) + (bf rest-of-deck))) + ((< (best-total customer-hand) (best-total dealer-hand-so-far)) -1) + ((= (best-total customer-hand) (best-total dealer-hand-so-far)) 0) + (else 1))) + + (define (play-customer customer-hand-so-far dealer-up-card rest-of-deck) + (cond ((> (best-total customer-hand-so-far) 21) -1) + ((strategy customer-hand-so-far dealer-up-card) + (play-customer (se customer-hand-so-far (first rest-of-deck)) + dealer-up-card + (bf rest-of-deck))) + (else + (play-dealer customer-hand-so-far + (se dealer-up-card (first rest-of-deck)) + (bf rest-of-deck))))) + + (let ((deck (make-deck))) + (play-customer (se (first deck) (first (bf deck))) + (first (bf (bf deck))) + (bf (bf (bf deck))))) ) + +(define (make-ordered-deck) + (define (make-suit s) + (every (lambda (rank) (word rank s)) '(A 2 3 4 5 6 7 8 9 10 J Q K)) ) + (se (make-suit 'H) (make-suit 'S) (make-suit 'D) (make-suit 'C)) ) + +(define (make-deck) + (define (shuffle deck size) + (define (move-card in out which) + (if (= which 0) + (se (first in) (shuffle (se (bf in) out) (- size 1))) + (move-card (bf in) (se (first in) out) (- which 1)) )) + (if (= size 0) + deck + (move-card deck '() (random size)) )) + (shuffle (make-ordered-deck) 52) ) + + + + + + + + + + + + + + + +; 32 diff --git a/js/games/nluqo.github.io/~bh/61a-pages/Volume1/Project3/adv-world.scm b/js/games/nluqo.github.io/~bh/61a-pages/Volume1/Project3/adv-world.scm new file mode 100644 index 0000000..bc4eb8c --- /dev/null +++ b/js/games/nluqo.github.io/~bh/61a-pages/Volume1/Project3/adv-world.scm @@ -0,0 +1,83 @@ +;;; Data for adventure game. This file is adv-world.scm + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; setting up the world +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define Soda (instantiate place 'Soda)) +(define BH-Office (instantiate place 'BH-Office)) +(define MJC-Office (instantiate place 'MJC-Office)) +(define art-gallery (instantiate place 'art-gallery)) +(define Pimentel (instantiate place 'Pimentel)) +(define 61A-Lab (instantiate place '61A-Lab)) +(define Sproul-Plaza (instantiate place 'Sproul-Plaza)) +(define Telegraph-Ave (instantiate place 'Telegraph-Ave)) +(define Noahs (instantiate place 'Noahs)) +(define Intermezzo (instantiate place 'Intermezzo)) +(define s-h (instantiate place 'sproul-hall)) + + +(can-go Soda 'up art-gallery) +(can-go art-gallery 'down Soda) +(can-go art-gallery 'west BH-Office) +(can-go BH-Office 'east art-gallery) +(can-go art-gallery 'east MJC-Office) +(can-go MJC-office 'west art-gallery) +(can-go Soda 'south Pimentel) +(can-go Pimentel 'north Soda) +(can-go Pimentel 'south 61A-Lab) +(can-go 61A-Lab 'north Pimentel) +(can-go 61A-Lab 'west s-h) +(can-go s-h 'east 61A-Lab) +(can-go Sproul-Plaza 'east s-h) +(can-go s-h 'west Sproul-Plaza) +(can-go Sproul-Plaza 'north Pimentel) +(can-go Sproul-Plaza 'south Telegraph-Ave) +(can-go Telegraph-Ave 'north Sproul-Plaza) +(can-go Telegraph-Ave 'south Noahs) +(can-go Noahs 'north Telegraph-Ave) +(can-go Noahs 'south Intermezzo) +(can-go Intermezzo 'north Noahs) + +;; Some people. +; MOVED above the add-entry-procedure stuff, to avoid the "The computers +; seem to be down" message that would occur when hacker enters 61a-lab +; -- Ryan Stejskal + +(define Brian (instantiate person 'Brian BH-Office)) +(define hacker (instantiate person 'hacker 61A-lab)) +(define nasty (instantiate thief 'nasty sproul-plaza)) + +(define (sproul-hall-exit) + (error "You can check out any time you'd like, but you can never leave")) + +(define (bh-office-exit) + (print "What's your favorite programming language?") + (let ((answer (read))) + (if (eq? answer 'scheme) + (print "Good answer, but my favorite is Logo!") + (begin (newline) (bh-office-exit))))) + + +(ask s-h 'add-entry-procedure + (lambda () (print "Miles and miles of students are waiting in line..."))) +(ask s-h 'add-exit-procedure sproul-hall-exit) +(ask BH-Office 'add-exit-procedure bh-office-exit) +(ask Noahs 'add-entry-procedure + (lambda () (print "Would you like lox with it?"))) +(ask Noahs 'add-exit-procedure + (lambda () (print "How about a cinnamon raisin bagel for dessert?"))) +(ask Telegraph-Ave 'add-entry-procedure + (lambda () (print "There are tie-dyed shirts as far as you can see..."))) +(ask 61A-Lab 'add-entry-procedure + (lambda () (print "The computers seem to be down"))) +(ask 61A-Lab 'add-exit-procedure + (lambda () (print "The workstations come back to life just in time."))) + +;; Some things. + +(define bagel (instantiate thing 'bagel)) +(ask Noahs 'appear bagel) + +(define coffee (instantiate thing 'coffee)) +(ask Intermezzo 'appear coffee) diff --git a/js/games/nluqo.github.io/~bh/61a-pages/Volume1/Project3/adv.txt b/js/games/nluqo.github.io/~bh/61a-pages/Volume1/Project3/adv.txt new file mode 100644 index 0000000..755f2ed --- /dev/null +++ b/js/games/nluqo.github.io/~bh/61a-pages/Volume1/Project3/adv.txt @@ -0,0 +1,718 @@ +Project: Write an adventure game. We'll provide most of the program. You +will mostly make modification and some additions. + +This project is designed to be done by two people working in parallel, then +combining your results into one finished product. (Hereafter the two partners +are called Person A and Person B.) But you will combine your work to hand in +a single report for your group. + +The project begins with two exercises that everyone should do; these +exercises do not require new programming, but rather familiarize you +with the overall structure of the program as we've provided it. After +that, each person has separate exercises. There is one final exercise +for everyone that requires the two partners' work to be combined. +(Therefore, you should probably keep notes about all of the procedures +that you've modified during the project, so you can notice the ones that +both partners modified independently.) + +This is a two-week project. Each week, your group should +hand in one paper (not one per person) including a listing of your modified +adv.scm program with the modifications highlighted, and a transcript of the +testing of your work. Indicate on the paper which of you is person A and +which is person B. + +Scoring: Each person works on nine problems. Three of these (numbers +1, 2, and 9) are common to the two partners; the others are separate. +You hand in a single solution to each problem. Both partners get +the points awarded to the group for problems 1, 2, and 9; each +person gets the points for his or her own problems 3 through 8. This means +that your score for the project is mostly based on your individual work but +also relies partly on the other member of your group. For the first two +problems, you could get away with letting your partner do the +work, but you shouldn't because those problems are necessary to help you +understand the structure of the entire project. Problem 9 requires that both +partners have already done their separate work, and meet together to +understand each other's solutions, so probably nobody will get credit for it +unless both have done their jobs. + +(Acknowledgement: This assignment is loosely based on an MIT homework +assignment in their version of this course. But since this is Berkeley we've +changed it to be politically correct; instead of killing each other, the +characters go around eating gourmet food all the time. N.B.: Unless you +are a diehard yuppie you may feel that eating gourmet food does not express +appropriate sensitivity to the plight of the homeless. But it's a start.) + +In this laboratory assignment, we will be exploring two key ideas: the +simulation of a world in which objects are characterized by a set of state +variables, and the use of message passing as a programming technique for +modularizing worlds in which objects interact. + +OBJECT-ORIENTED PROGRAMMING is becoming an extremely popular methodology for +any application that involves interactions among computational entities. +Examples: + + -- operating systems (processes as objects) + -- window systems (windows as objects) + -- games (asteroids, spaceships, gorillas as objects) + -- drawing programs (shapes as objects) + + +GETTING STARTED +To start, copy the following five files into your directory: + ~cs61a/lib/obj.scm The object-oriented system + ~cs61a/lib/adv.scm The adventure game program + ~cs61a/lib/tables.scm An ADT you'll need for parts A5 and B4 + ~cs61a/lib/adv-world.scm The specific people, places, and things + ~cs61a/lib/small-world.scm A smaller world you can use for debugging + +To work on this project, you must load these files into Scheme in the +correct order: obj.scm first, then adv.scm and tables.scm when you're using +that, and finally the particular world you're using, either adv-world.scm or +small-world.scm. The work you are asked to do refers to adv-world.scm; +small-world.scm is provided in case you'd prefer to debug some of your +procedures in a smaller world that may be less complicated to remember and +also faster to load. + +The reason the adventure game is divided into adv.scm (containing the +definitions of the object classes) and adv-world.scm (containing the +specific instances of those objects in Berkeley) is that when you change +something in adv.scm you may need to reload the entire world in order for +your changed version to take effect. Having two files means that you don't +also have to reload the first batch of procedures. + + +In this program there are three classes: THING, PLACE, and PERSON. + +Here are some examples selected from adv-world.scm: + +;;; construct the places in the world +(define Soda (instantiate place 'Soda)) +(define BH-Office (instantiate place 'BH-Office)) +(define art-gallery (instantiate place 'art-gallery)) +(define Pimentel (instantiate place 'Pimentel)) +(define 61A-Lab (instantiate place '61A-Lab)) +(define Sproul-Plaza (instantiate place 'Sproul-Plaza)) +(define Telegraph-Ave (instantiate place 'Telegraph-Ave)) +(define Noahs (instantiate place 'Noahs)) +(define Intermezzo (instantiate place 'Intermezzo)) +(define s-h (instantiate place 'sproul-hall)) + +;;; make some things and put them at places +(define bagel (instantiate thing 'bagel)) +(ask Noahs 'appear bagel) + +(define coffee (instantiate thing 'coffee)) +(ask Intermezzo 'appear coffee) + +;;; make some people +(define Brian (instantiate person 'Brian BH-Office)) +(define hacker (instantiate person 'hacker Pimentel)) + +;;; connect places in the world + +(can-go Soda 'up art-gallery) +(can-go art-gallery 'west BH-Office) +(can-go Soda 'south Pimentel) + +Having constructed this world, we can now interact with it by sending +messages to objects. Here is a short example. + +; We start with the hacker in Pimentel. + +> (ask Pimentel 'exits) +(NORTH SOUTH) +> (ask hacker 'go 'north) +HACKER moved from PIMENTEL to SODA + + +We can put objects in the different places, and the people can then take the +objects: + +> (define Jolt (instantiate thing 'Jolt)) +JOLT +> (ask Soda 'appear Jolt) +APPEARED +> (ask hacker 'take Jolt) +HACKER took JOLT +TAKEN + +You can take objects away from other people, but the management is not +responsible for the consequences... (Too bad this is a fantasy game, and +there aren't really vending machines in Soda that stock Jolt.) + +PART I: + +The first two exercises in this part should be done by everyone -- that is, +everyone should actually sit in front of a terminal and do it! It's okay to +work in pairs as long as you all really know what's going on by the time +you're finished. (Nevertheless, you should only hand in one solution, that +both agree about.) The remaining exercises have numbers like "A3" +which means exercise 3 for Person A. + +After you've done the work separately, you should meet together +to make sure that you each understands what the other person did, because +the second week's work depends on all of the first week's work. You can +do the explaining while you're merging the two sets of modifications into +one adv.scm file to hand in. + +1. Create a new person to represent yourself. Put yourself in a new place +called Dormitory (or wherever you live) and connect it to campus so that you +can get there from here. Create a place called Kirin, north of Soda. +(It's actually on Solano Avenue.) Put a thing called Potstickers there. +Then give the necessary commands to move your character to Kirin, take +the Potstickers, then move yourself to where Brian is, put down the +Potstickers, and have Brian take them. Then go back to the lab and get back +to work. (There is no truth to the rumor that you'll get an A in the course +for doing this in real life!) All this is just to ensure that you know how +to speak the language of the adventure program. + +LIST ALL THE MESSAGES THAT ARE SENT DURING THIS EPISODE. It's a good idea +to see if you can work this out in your head, at least for some of the +actions that take place, but you can also trace the ASK procedure to get +a complete list. You don't have to hand in this listing of messages. (Do +hand in a transcript of the episode without the tracing.) The point is that +you should have a good sense of the ways in which the different objects send +messages back and forth as they do their work. + +[Tip: we have provided a MOVE-LOOP procedure that you may find useful as +an aid in debugging your work. You can use it to move a person repeatedly.] + + +2. It is very important that you think about and understand the kinds of +objects involved in the adventure game. Please answer the following questions: + +2A. What kind of thing is the value of variable BRIAN? + +Hint: What is returned by scheme in the following situation: + You type: > BRIAN + + +2B. List all the messages that a PLACE understands. (You might want to +maintain such a list for your own use, for every type of object, to help +in the debugging effort.) + + +2C. We have been defining a variable to hold each object in our world. +For example, we defined bagel by saying: + + (define bagel (instantiate thing 'bagel)) + +This is just for convenience. Every object does not have to have a +top-level definition. Every object DOES have to be constructed and +connected to the world. For instance, suppose we did this: + +> (can-go Telegraph-Ave 'east (instantiate place 'Peoples-Park)) + +;;; assume BRIAN is at Telegraph +> (ask Brian 'go 'east) + +What is returned by the following expressions and WHY? + +> (ask Brian 'place) + +> (let ((where (ask Brian 'place))) + (ask where 'name)) + +> (ask Peoples-park 'appear bagel) + + + +2D. The implication of all this is that there can be multiple names for +objects. One name is the value of the object's internal NAME variable. In +addition, we can define a variable at the top-level to refer to an object. +Moreover, one object can have a private name for another object. For +example, BRIAN has a variable PLACE which is currently bound to the object +that represents People's Park. Some examples to think about: + + > (eq? (ask Telegraph-Ave 'look-in 'east) (ask Brian 'place)) + + > (eq? (ask Brian 'place) 'Peoples-Park) + + > (eq? (ask (ask Brian 'place) 'name) 'Peoples-Park) + + +OK. Suppose we type the following into scheme: + +> (define computer (instantiate thing 'Durer)) + + +Which of the following is correct? Why? + +(ask 61a-lab 'appear computer) + +or + +(ask 61a-lab 'appear Durer) + +or + +(ask 61a-lab 'appear 'Durer) + +What is returned by (computer 'name)? Why? + + +2E. We have provided a definition of the THING class that does not use +the object-oriented programming syntax described in the handout. Translate +it into the new notation. + +2F. Sometimes it's inconvenient to debug an object interactively because +its methods return objects and we want to see the names of the objects. You +can create auxiliary procedures for interactive use (as opposed to use +inside object methods) that provide the desired information in printable +form. For example: + +(define (name obj) (ask obj 'name)) +(define (inventory obj) + (if (person? obj) + (map name (ask obj 'possessions)) + (map name (ask obj 'things)))) + +Write a procedure WHEREIS that takes a person as its argument and returns +the name of the place where that person is. + +Write a procedure OWNER that takes a thing as its argument and returns the +name of the person who owns it. (Make sure it works for things that aren't +owned by anyone.) + +Procedures like this can be very helpful in debugging the later parts of the +project, so feel free to write more of them for your own use. + + +Now it's time for you to make your first modifications to the adventure +game. This is where you split the work individually. + +PART I -- PERSON A: + +A3. You will notice that whenever a person goes to a new place, the place +gets an 'ENTER message. In addition, the place the person previously +inhabited gets an 'EXIT message. When the place gets the message, it calls +each procedure on its list of ENTRY-PROCEDURES or EXIT-PROCEDURES as +appropriate. Places have the following methods defined for manipulating +these lists of procedures: ADD-ENTRY-PROCEDURE, ADD-EXIT-PROCEDURE, +REMOVE-ENTRY-PROCEDURE, +REMOVE-EXIT-PROCEDURE, CLEAR-ALL-PROCS. You can read their definitions in the +code. + +Sproul Hall has a particularly obnoxious exit procedure attached to it. Fix +SPROUL-HALL-EXIT so that it counts how many times it gets called, and stops +being obnoxious after the third time. + +Remember that the EXIT-PROCS list contains procedures, not names of +procedures! It's not good enough to redefine SPROUL-HALL-EXIT, since Sproul +Hall's list of exit procedures still contains the old procedure. The best +thing to do is just to load adv-world.scm again, which will define a new +sproul hall and add the new exit procedure. + + + +A4a. We've provided people with the ability to say something using the +messages 'TALK and 'SET-TALK. As you may have noticed, some people around +this campus start talking whenever anyone walks by. We want to simulate this +behavior. In any such interaction there are two people involved: the one +who was already at the place (hereafter called the TALKER) and the one who +is just entering the place (the LISTENER). We have already provided a +mechanism so that the listener sends an ENTER message to the place when +entering. Also, each person is ready to accept a NOTICE message, meaning +that the person should notice that someone new has come. The talker should +get a NOTICE message, and will then talk, because we've made a person's +NOTICE method send itself a TALK message. (Later we'll see that some special +kinds of people have different NOTICE methods.) + +Your job is to modify the ENTER method for places, so that in addition to +what that method already does, it sends a NOTICE message to each person in +that place other than the person who is entering. The NOTICE message should +have the newly-entered person as an argument. (You won't do anything with +that argument now, but you'll need it later.) + +Test your implementation with the following: + +(define singer (instantiate person 'rick sproul-plaza)) + +(ask singer 'set-talk "My funny valentine, sweet comic valentine") + +(define preacher (instantiate person 'preacher sproul-plaza)) + +(ask preacher 'set-talk "Praise the Lord") + +(define street-person (instantiate person 'harry telegraph-ave)) + +(ask street-person 'set-talk "Brother, can you spare a buck") + +YOU MUST INCLUDE A TRANSCRIPT IN WHICH YOUR CHARACTER WALKS AROUND AND +TRIGGERS THESE MESSAGES. + + +A4b. So far the program assumes that anyone can go anywhere they want. +In real life, many places have locked doors. + +Invent a MAY-ENTER? message for places that takes a person as an argument and +always returns #T. Then invent a LOCKED-PLACE class in which the MAY-ENTER? +method returns #T if the place is unlocked, or #F if it's locked. (It should +initially be locked.) The LOCKED-PLACE class must also have an UNLOCK +message. For simplicity, write this method with no arguments and have it +always succeed. In a real game, we would also invent keys, and a mechanism +requiring that the person have the correct key in order to unlock the door. +(That's why MAY-ENTER? takes the person as an argument.) + +Modify the person class so that it checks for permission to enter before +moving from one place to another. Then create a locked place and test +it out. + + +A5. Walking around is great, but some people commute from far away, so +they need to park their cars in garages. A car is just a THING, but you'll +have to invent a special kind of place called a GARAGE. Garages have two +methods (besides the ones all places have): PARK and UNPARK. You'll also +need a special kind of THING called a TICKET; what's special about it is +that it has a NUMBER as an instantiation variable. + +The PARK method takes a car (a THING) as its argument. First check to be sure +that the car is actually in the garage. (The person who possesses the car +will enter the garage, then ask to park it, so the car should have entered the +garage along with the person before the PARK message is sent.) Then generate +a TICKET with a unique serial number. (The counter for serial numbers should +be shared among all garages, so that we don't get in trouble later trying to +UNPARK a car from one garage that was parked in a different garage.) Every +ticket should have the name TICKET. + +You'll associate the ticket number with the car in a key-value table like the +one that we used with GET and PUT in 2.3.3. However, GET and PUT refer to a +single, fixed table for all operations; in this situation we need a separate +table for every garage. The file tables.scm contains an implementation of the +table Abstract Data Type: + +constructor: (make-table) returns a new, empty table. + +mutator: (insert! key value table) adds a new key-value pair to a table. + +selector: (lookup key table) returns the corresponding value, or #F if + the key is not in the table. + +You'll learn how tables are implemented in 3.3.3 (pp. 266-268). +For now, just take them as primitive. + +Make a table entry with the ticket number as the key, and the car as the +value. Then ask the car's owner to lose the car and take the ticket. + +The UNPARK method takes a ticket as argument. First make sure the object +you got is actually a ticket (by checking the name). Then look up the +ticket number in the garage's table. If you find a car, ask the ticket's +owner to lose the ticket and take the car. Also, insert #F in the table for +that ticket number, so that people can't unpark the car twice. + +A real-life garage would have a limited capacity, and would charge money +for parking, but to simplify the project you don't have to simulate those +aspects of garages. + + +--- End of Part I for Person A + + +PART I, PERSON B: + + +B3. Define a method TAKE-ALL for people. If given that message, a person +should TAKE all the things at the current location that are not already +owned by someone. + + +B4a. It's unrealistic that anyone can take anything from anyone. We want to +give our characters a STRENGTH, and then one person can take something from +another only if the first has greater STRENGTH than the second. + +However, we aren't going to clutter up the person class by adding a local +STRENGTH variable. That's because we can anticipate wanting to add lots +more attributes as we develop the program further. People can have CHARISMA +or WISDOM; things can be FOOD or not; places can be INDOORS or not. +Therefore, you will create a class called BASIC-OBJECT that keeps a local +variable called PROPERTIES containing an attribute-value table like the +one that we used with GET and PUT in 2.3.3. However, GET and PUT refer to +a single, fixed table for all operations; in this situation we need a +separate table for every object. The file tables.scm contains an +implementation of the table Abstract Data Type: + +constructor: (make-table) returns a new, empty table. + +mutator: (insert! key value table) adds a new key-value pair to a table. + +selector: (lookup key table) returns the corresponding value, or #F if + the key is not in the table. + +You'll learn how tables are implemented in 3.3.3 (pp. 266-268). +For now, just take them as primitive. + +You'll modify the person, place and thing classes so that they will inherit +from basic-object. This object will accept a message PUT so that + > (ask Brian 'put 'strength 100) +does the right thing. Also, the basic-object should treat any message not +otherwise recognized as a request for the attribute of that name, so + > (ask Brian 'strength) + 100 +should work WITHOUT having to write an explicit STRENGTH method in the +class definition. + +Don't forget that the property list mechanism in 3.3.3 returns #F if you ask +for a property that isn't in the list. This means that + > (ask Brian 'charisma) +should never give an error message, even if we haven't PUT that property in +that object. This is important for true-or-false properties, which will +automatically be #F (but not an error) unless we explicitly PUT a #T +value for them. + +Give people some reasonable (same for everyone) initial strength. Next +week they'll be able to get stronger by eating. + +B4b. You'll notice that the type predicate PERSON? checks to see if the type +of the argument is a member of the list '(person police thief). This means +that the PERSON? procedure has to keep a list of all the classes that +inherit from PERSON, which is a pain if we make a new subclass. + +We'll take advantage of the property list to implement a better system for +type checking. If we add a method named PERSON? to the person class, and +have it always return #T, then any object that's a type of person will +automatically inherit this method. Objects that don't inherit from person +won't find a PERSON? method and won't find an entry for person? in their +property table, so they'll return #F. + +Similarly, places should have a PLACE? method, and things a THING? method. + +Add these type methods and change the implementation of the type predicate +procedures to this new implementation. + + +B5. In the modern era, many places allow you to get connected to the net. +Define a HOTSPOT as a kind of place that allows network connectivity. Each +hotspot should have a PASSWORD (an instantiation variable) that you must know +to connect. (Note: We're envisioning a per-network password, not a per-person +password as you use with AirBears.) The hotspot has a CONNECT method with two +arguments, a LAPTOP (a kind of thing, to be invented in a moment) and a +password. If the password is correct, and the laptop is in the hotspot, add +it to a list of connected laptops. When the laptop leaves the hotspot, remove +it from the list. + +Hotspots also have a SURF method with two arguments, a laptop and a text +string, such as + + "http://www.cs.berkeley.edu" + +If the laptop is connected to the network, then the surf method should + + (system (string-append "lynx " url)) + +where URL is the text string argument. + +Now invent laptops. A laptop is a thing that has two extra methods: CONNECT, +with a password as argument, sends a CONNECT message to the place where the +laptop is. SURF, with a URL text string as argument, sends a SURF message to +the place where it is. Thus, whenever a laptop enters a new hotspot, the user +must ask to CONNECT to that hotspot's network; when the laptop leaves the +hotspot, it must automatically be disconnected from the network. (If it's in +a place other than a hotspot, the SURF message won't be understood; if it's in +a hotspot but not connected, the hotspot won't do anything.) + + +--- End of Part I, PERSON B. + + +PART II: + +This part of the project includes three exercises for each person, but YOU +HAVE TO READ EACH OTHER'S CODE midweek, because one partner's exercises 7 and +8 build on the other partner's exercise 6. Finally, exercise 9 requires the +two partners' work to be combined. You will have to create a version of +adv.scm that has both partners' changes. This may take some thinking! If +both parners modify the same method in the same object class, you'll have to +write a version of the method that incorporates both modifications. + + +PART II, PERSON A: + +Adv.scm includes a definition of the class THIEF, a subclass of person. +A thief is a character who tries to steal food from other people. Of +course, Berkeley can not tolerate this behavior for long. Your job is to +define a POLICE class; police objects catch thieves and send them directly +to jail. To do this you will need to understand how theives work. + +Since a thief is a kind of person, whenever another person enters the place +where the thief is, the thief gets a NOTICE message from the place. When +the thief notices a new person, he does one of two things, depending on the +state of his internal BEHAVIOR variable. If this variable is set to STEAL, +the thief looks around to see if there is any food at the place. If there +is food, the thief takes the food from its current possessor and sets his +behavior to RUN. When the thief's behavior is RUN, he moves to a new random +place whenever he NOTICEs someone entering his current location. The RUN +behavior makes it hard to catch a thief. + +Notice that a thief object delegates many messages to its person object. + + +A6a. To help the police do their work, you will need to create a place called +jail. Jail has no exits. Moreover, you will need to create a method for +persons and thieves called GO-DIRECTLY-TO. Go-directly-to does not require +that the new-place be adjacent to the current-place. So by calling (ASK +THIEF 'GO-DIRECTLY-TO JAIL) the police can send the thief to jail no matter +where the thief currently is located, assuming the variable thief is bound +to the thief being apprehended. + + +A6b. Thieves sometimes try to leave their place in a randomly chosen +direction. This, it turns out, won't work if there are no exits from +that place -- for example, the jail. Modify the THIEF class so that +a thief won't try to leave a place with no exits. + +** Now get your partner to explain problem B6 and its solution. ** + +A7a. We are now going to invent restaurant objects. People will interact +with the restaurants by buying food there. First we have to make it possible +for people to buy stuff. Give PERSON objects a MONEY property, which is a +number, saying how many dollars they have. Note that money is not an +object. We implement it as a number because, unlike the case of objects +such as chairs and potstickers, a person needs to be able to spend SOME +money without giving up all of it. In principle we could have objects like +QUARTER and DOLLAR-BILL, but this would make the change-making process +complicated for no good reason. + +To make life simple, we'll have every PERSON start out with $100. (We should +really start people with no money, and invent banks and jobs and so on, but +we won't.) Create two methods for people, GET-MONEY and PAY-MONEY, each of +which takes a number as argument and updates the person's money value +appropriately. PAY-MONEY must return true or false depending on whether +the person had enough money. + + +A7b. Another problem with the adventure game is that Noah's only has one +bagel. Once someone has taken that bagel, they're out of business. + +To fix this, we're going to invent a new kind of place, called a RESTAURANT. +(That is, RESTAURANT is a subclass of PLACE.) Each restaurant serves only +one kind of food. (This is a simplification, of course, and it's easy to see +how we might extend the project to allow lists of kinds of food.) When a +restaurant is instantiated, it should have two extra arguments, besides the +ones that all places have: the class of food objects that this restaurant +sells, and the price of one item of this type: + + > (define-class (bagel) (parent (food ...)) ...) + + > (define Noahs (instantiate restaurant 'Noahs bagel 0.50)) + +Notice that the argument to the restaurant is a CLASS, not a particular +bagel (instance). + +Restaurants should have two methods. The MENU method returns a list +containing the name and price of the food that the restaurant sells. +The SELL method takes two arguments, the person who wants to buy something +and the name of the food that the person wants. The SELL method must first +check that the restaurant actually sells the right kind of food. If so, +it should ASK the buyer to PAY-MONEY in the appropriate amount. If that +succeeds, the method should instantiate the food class and return the new +food object. The method should return #F if the person can't buy the food. + + +A8. Now we need a BUY method for people. It should take as argument the +name of the food we want to buy: (ask Brian 'buy 'bagel). The method must +send a SELL message to the restaurant. If this succeeds (that is, if the +value returned from the SELL method is an object rather than #F) the new food +should be added to the person's possessions. + +--- Person A skip to question 9 below. + +PART II, PERSON B: + +B6. The way we're having people take food from restaurants is unrealistic +in several ways. Our overall goal this week is to fix that. As a first +step, you are going to create a FOOD class. +We will give things that are food two properties, an EDIBLE? property +and a CALORIES property. EDIBLE? will have the value #T if the object is a +food. If a PERSON eats some food, the food's CALORIES are added to the +person's STRENGTH. + +(Remember that the EDIBLE? property will automatically be false for objects +other than food, because of the way properties were implemented in question B4. +You don't have to go around telling all the other stuff not to be edible +explicitly.) + +Write a definition of the FOOD class that uses THING as the parent class. +It should return #T when you send it an EDBILE? message, and it should +correctly respond to a CALORIES message. + +Replace the procedure named EDIBLE? in the original adv.scm with a new +version that takes advantage of the mechanism you've created, instead of +relying on a built-in list of types of food. + +Now that you have the FOOD class, invent some child classes for particular +kinds of food. For example, make a bagel class that inherits from FOOD. +Give the bagel class a class-variable called NAME whose value is the word +bagel. (We'll need this later when we invent RESTAURANT objects.) + +Make an EAT method for people. Your EAT method should look at your +possessions and filter for all the ones that are edible. It should then add +the calorie value of the foods to your strength. Then it should make the +foods disappear (no longer be your possessions and no longer be at your +location). + +** Now get your partner to explain problem A6 and its solution. ** + +B7. Your job is to define the police class. A policeperson is to have the +following behavior: + +The police stays at one location. When the police notices a new person +entering the location, the police checks to see if that person is a thief. +If the person is a thief the police says "Crime Does Not Pay," then takes +away all the thief's possessions and sends the thief directly to jail. + +Give thieves and police default strengths. Thieves should start out stronger +than persons, but police should be stronger than thieves. Of course, if you +eat lots you should be able to build up enough STRENGTH (mass?) to take food +away from a thief. (Only a character with a lot of CHUTZPAH would take food +away from the police. :-) + +Please test your code and turn in a transcript that shows the thief stealing +your food, you chasing the thief and the police catching the thief. In case +you haven't noticed, we've put a thief in Sproul Plaza. + + +B8. Now we want to reorganize TAKE so that it looks to see who previously +possesses the desired object. If its possessor is 'NO-ONE, go ahead and +take it as always. Otherwise, invoke + (ask thing 'MAY-TAKE? receiver) +The MAY-TAKE? method for a thing that belongs to someone should compare +the strength of its owner with the strength of the requesting person to +decide whether or not it can be taken. The method should return #F +if the person may not take the thing, or the thing itself if the person may +take it. This is a little more complicated than necessary right now, but +we are planning ahead for a situation in which, for example, an object +might want to make a clone of itself for a person to take. + +Note the flurry of message-passing going on here. We send a message to the +taker. It sends a message to the thing, which sends messages to two people +to find out their strengths. + +--- End of Part II, Person B (but both partners do question 8 below). + +9. Combine the two partners' work. For example, both partners have +created new methods for the PERSON class. Both partners have done work +involving strengths of kinds of people; make sure they work together. + +Now make it so that when a POLICE person asks to BUY some food the +restaurant doesn't charge him or her any money. (This makes the game +more realistic...) + +******** OPTIONAL ********** +As you can imagine, this is a truly open-ended project. If you have the +time and inclination, you can populate your world with new kinds of people +(e.g., punk-rockers), places (Gilman-St), and especially things (magic +wands, beer, gold pieces, cars looking for parking places...). + +For your enjoyment we have developed a procedure that creates a labyrinth (a +maze) that you can explore. To do so, load the file ~cs61a/lib/labyrinth.scm. +[Note: labyrinth.scm may need some modification to work with the procedures +you developed in part two of the project.] + +Legend has it that there is a vast series of rooms underneath Sproul Plaza. +These rooms are littered with food of bygone days and quite a few theives. +You can find the secret passage down in Sproul Plaza. + +You may want to modify FANCY-MOVE-LOOP so that you can look around in nearby +rooms before entering so that you can avoid thieves. You might also want +your character to maintain a list of rooms visited on its property list so +you can find your way back to the earth's surface. 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") diff --git a/js/games/nluqo.github.io/~bh/61a-pages/Volume1/Project3/small-world.scm b/js/games/nluqo.github.io/~bh/61a-pages/Volume1/Project3/small-world.scm new file mode 100644 index 0000000..dcd6bd1 --- /dev/null +++ b/js/games/nluqo.github.io/~bh/61a-pages/Volume1/Project3/small-world.scm @@ -0,0 +1,28 @@ +;;; small-world.scm +;;; Miniature game world for debugging the CS61A adventure game project. +;;; You can load this instead of adv-world.scm, and reload it quickly +;;; whenever you change a class. + +;;; How to use this file: +;;; If, for example, your person class doesn't work, and you do something +;;; like (define Matt (instantiate person 'Matt)), and then fix your +;;; person class definition, Matt is still bound to the faulty person +;;; object from before. However, reloading this file whenever you +;;; change something should redefine everything in your world with the +;;; currently loaded (i.e. most recent) versions of your classes. + +(define 61A-Lab (instantiate place '61A-Lab)) +(define Lounge (instantiate place 'Lounge)) +(can-go 61A-Lab 'up Lounge) +(can-go Lounge 'down 61A-Lab) +;;; Hopefully you'll see more of the world than this in real life +;;; while you're doing the project! + +(define homework-box (instantiate thing 'homework-box)) +(ask 61A-Lab 'appear homework-box) + +(define Coke (instantiate thing 'Coke)) +(ask Lounge 'appear Coke) + +(define laba (instantiate person 'Lab-assistant 61A-Lab)) + diff --git a/js/games/nluqo.github.io/~bh/61a-pages/Volume1/Project4/logo-meta.scm b/js/games/nluqo.github.io/~bh/61a-pages/Volume1/Project4/logo-meta.scm new file mode 100644 index 0000000..f66afdc --- /dev/null +++ b/js/games/nluqo.github.io/~bh/61a-pages/Volume1/Project4/logo-meta.scm @@ -0,0 +1,371 @@ +;;; logo-meta.scm Part of programming project #4 + +;;; Differences between the book and this version: Eval and apply have +;;; been changed to logo-eval and logo-apply so as not to overwrite the Scheme +;;; versions of these routines. An extra procedure initialize-logo has been +;;; added. This routine resets the global environment and then executes the +;;; driver loop. This procedure should be invoked to start the Logo +;;; evaluator executing. Note: It will reset your global environment and all +;;; definitions to the Logo interpreter will be lost. To restart the Logo +;;; interpreter without resetting the global environment, just invoke +;;; driver-loop. Don't forget that typing control-C will get you out of +;;; the Logo evaluator back into Scheme. + +;;; Problems A1, A2, and B2 are entirely in logo.scm +;;; Problems 3, 7, and up require you to find and change existing procedures. + +;;; Procedures that you must write from scratch: + +;;; Problem B1 eval-line + +(define (eval-line line-obj env) + (error "eval-line not written yet!")) + + +;;; Problem 4 variables (other procedures must be modified, too) +;;; data abstraction procedures + +(define (variable? exp) + #f) ;; not written yet but we fake it for now + +(define (variable-name exp) + (error "variable-name not written yet!")) + + +;;; Problem A5 handle-infix + +(define (de-infix token) + (cdr (assoc token '((+ . sum) + (- . difference) + (* . product) + (/ . quotient) + (= . equalp) + (< . lessp) + (> . greaterp))))) + +(define (handle-infix value line-obj env) + value) ;; This doesn't give an error message, so other stuff works. + + +;;; Problem B5 eval-definition + +(define (eval-definition line-obj) + (error "eval-definition not written yet!")) + + +;;; Problem 6 eval-sequence + +(define (eval-sequence exps env) + (error "eval-sequence not written yet!")) + + + + +;;; SETTING UP THE ENVIRONMENT + +(define the-primitive-procedures '()) + +(define (add-prim name count proc) + (set! the-primitive-procedures + (cons (list name 'primitive count proc) + the-primitive-procedures))) + +(add-prim 'first 1 first) +(add-prim 'butfirst 1 bf) +(add-prim 'bf 1 bf) +(add-prim 'last 1 last) +(add-prim 'butlast 1 bl) +(add-prim 'bl 1 bl) +(add-prim 'word 2 word) +(add-prim 'sentence 2 se) +(add-prim 'se 2 se) +(add-prim 'list 2 list) +(add-prim 'fput 2 cons) + +(add-prim 'sum 2 (make-logo-arith +)) +(add-prim 'difference 2 (make-logo-arith -)) +(add-prim '=unary-minus= 1 (make-logo-arith -)) +(add-prim '- 1 (make-logo-arith -)) +(add-prim 'product 2 (make-logo-arith *)) +(add-prim 'quotient 2 (make-logo-arith /)) +(add-prim 'remainder 2 (make-logo-arith remainder)) + +(add-prim 'print 1 logo-print) +(add-prim 'pr 1 logo-print) +(add-prim 'show 1 logo-show) +(add-prim 'type 1 logo-type) +(add-prim 'make '(2) make) + +(add-prim 'run '(1) run) +(add-prim 'if '(2) logo-if) +(add-prim 'ifelse '(3) ifelse) +(add-prim 'equalp 2 (logo-pred (make-logo-arith equalp))) +(add-prim 'lessp 2 (logo-pred (make-logo-arith <))) +(add-prim 'greaterp 2 (logo-pred (make-logo-arith >))) +(add-prim 'emptyp 1 (logo-pred empty?)) +(add-prim 'numberp 1 (logo-pred (make-logo-arith number?))) +(add-prim 'listp 1 (logo-pred list?)) +(add-prim 'wordp 1 (logo-pred (lambda (x) (not (list? x))))) + +(add-prim 'stop 0 (lambda () '=stop=)) +(add-prim 'output 1 (lambda (x) (cons '=output= x))) +(add-prim 'op 1 (lambda (x) (cons '=output= x))) + +(define (pcmd proc) (lambda args (apply proc args) '=no-value=)) +(add-prim 'cs 0 (pcmd cs)) +(add-prim 'clearscreen 0 (pcmd cs)) +(add-prim 'fd 1 (pcmd fd)) +(add-prim 'forward 1 (pcmd fd)) +(add-prim 'bk 1 (pcmd bk)) +(add-prim 'back 1 (pcmd bk)) +(add-prim 'lt 1 (pcmd lt)) +(add-prim 'left 1 (pcmd lt)) +(add-prim 'rt 1 (pcmd rt)) +(add-prim 'right 1 (pcmd rt)) +(add-prim 'setxy 2 (pcmd setxy)) +(add-prim 'setx 1 (lambda (x) (setxy x (ycor)) '=no-value=)) +(add-prim 'sety 1 (lambda (y) (setxy (xcor) y) '=no-value=)) +(add-prim 'xcor 0 xcor) +(add-prim 'ycor 0 ycor) +(add-prim 'pos 0 pos) +(add-prim 'seth 1 (pcmd setheading)) +(add-prim 'setheading 1 (pcmd setheading)) +(add-prim 'heading 0 heading) +(add-prim 'st 0 (pcmd st)) +(add-prim 'showturtle 0 (pcmd st)) +(add-prim 'ht 0 (pcmd ht)) +(add-prim 'hideturtle 0 (pcmd ht)) +(add-prim 'shown? 0 shown?) +(add-prim 'pd 0 (pcmd pendown)) +(add-prim 'pendown 0 (pcmd pendown)) +(add-prim 'pu 0 (pcmd penup)) +(add-prim 'penup 0 (pcmd penup)) +(add-prim 'pe 0 (pcmd penerase)) +(add-prim 'penerase 0 (pcmd penerase)) +(add-prim 'home 0 (pcmd home)) +(add-prim 'setpc 1 (pcmd setpc)) +(add-prim 'setpencolor 1 (pcmd setpc)) +(add-prim 'pc 0 pc) +(add-prim 'pencolor 0 pc) +(add-prim 'setbg 1 (pcmd setbg)) +(add-prim 'setbackground 1 (pcmd setbg)) + +(add-prim 'load 1 meta-load) + +(define the-global-environment '()) +(define the-procedures the-primitive-procedures) + +;;; INITIALIZATION AND DRIVER LOOP + +;;; The following code initializes the machine and starts the Logo +;;; system. You should not call it very often, because it will clobber +;;; the global environment, and you will lose any definitions you have +;;; accumulated. + +(define (initialize-logo) + (set! the-global-environment (extend-environment '() '() '())) + (set! the-procedures the-primitive-procedures) + (driver-loop)) + +(define (driver-loop) + (define (helper) + (prompt "? ") + (let ((line (logo-read))) + (if (not (null? line)) + (let ((result (eval-line (make-line-obj line) + the-global-environment))) + (if (not (eq? result '=no-value=)) + (logo-print (list "You don't say what to do with" result)))))) + (helper)) + (logo-read) + (helper)) + +;;; APPLYING PRIMITIVE PROCEDURES + +;;; To apply a primitive procedure, we ask the underlying Scheme system +;;; to perform the application. (Of course, an implementation on a +;;; low-level machine would perform the application in some other way.) + +(define (apply-primitive-procedure p args) + (apply (text p) args)) + + +;;; Now for the code that's based on the book!!! + + +;;; Section 4.1.1 + +;; Given an expression like (proc :a :b :c)+5 +;; logo-eval calls eval-prefix for the part in parentheses, and then +;; handle-infix to check for and process the infix arithmetic. +;; Eval-prefix is comparable to Scheme's eval. + +(define (logo-eval line-obj env) + (handle-infix (eval-prefix line-obj env) line-obj env)) + +(define (eval-prefix line-obj env) + (define (eval-helper paren-flag) + (let ((token (ask line-obj 'next))) + (cond ((self-evaluating? token) token) + ((variable? token) + (lookup-variable-value (variable-name token) env)) + ((quoted? token) (text-of-quotation token)) + ((definition? token) (eval-definition line-obj)) + ((left-paren? token) + (let ((result (handle-infix (eval-helper #t) + line-obj + env))) + (let ((token (ask line-obj 'next))) + (if (right-paren? token) + result + (error "Too much inside parens"))))) + ((right-paren? token) + (error "Unexpected ')'")) + (else + (let ((proc (lookup-procedure token))) + (if (not proc) (error "I don't know how to " token)) + (logo-apply proc + (collect-n-args (arg-count proc) + line-obj + env) ))) ))) + (eval-helper #f)) + +(define (logo-apply procedure arguments) + (cond ((primitive-procedure? procedure) + (apply-primitive-procedure procedure arguments)) + ((compound-procedure? procedure) + (error "Compound procedures not implemented yet.")) + (else + (error "Unknown procedure type -- LOGO-APPLY " procedure)))) + +(define (collect-n-args n line-obj env) + (cond ((= n 0) '()) + ((and (< n 0) (not (ask line-obj 'empty?))) + (let ((token (ask line-obj 'next))) + (ask line-obj 'put-back token) + (if (right-paren? token) + '() + (let ((next (logo-eval line-obj env))) + (cons next + (collect-n-args (- n 1) line-obj env)) )))) + (else + (let ((next (logo-eval line-obj env))) + (cons next + (collect-n-args (- n 1) line-obj env)) )))) + +;;; Section 4.1.2 -- Representing expressions + +;;; numbers + +(define (self-evaluating? exp) (number? exp)) + +;;; quote + +(define (quoted? exp) + (or (list? exp) + (eq? (string-ref (word->string (first exp)) 0) #\"))) + +(define (text-of-quotation exp) + (if (list? exp) + exp + (bf exp))) + +;;; parens + +(define (left-paren? exp) (eq? exp left-paren-symbol)) + +(define (right-paren? exp) (eq? exp right-paren-symbol)) + +;;; definitions + +(define (definition? exp) + (eq? exp 'to)) + +;;; procedures + +(define (lookup-procedure name) + (assoc name the-procedures)) + +(define (primitive-procedure? p) + (eq? (cadr p) 'primitive)) + +(define (compound-procedure? p) + (eq? (cadr p) 'compound)) + +(define (arg-count proc) + (caddr proc)) + +(define (text proc) + (cadddr proc)) + +(define (parameters proc) (car (text proc))) + +(define (procedure-body proc) (cdr (text proc))) + +;;; Section 4.1.3 + +;;; Operations on environments + +(define (enclosing-environment env) (cdr env)) + +(define (first-frame env) (car env)) + +(define the-empty-environment '()) + +(define (make-frame variables values) + (cons variables values)) + +(define (frame-variables frame) (car frame)) +(define (frame-values frame) (cdr frame)) + +(define (add-binding-to-frame! var val frame) + (set-car! frame (cons var (car frame))) + (set-cdr! frame (cons val (cdr frame)))) + +(define (extend-environment vars vals base-env) + (if (= (length vars) (length vals)) + (cons (make-frame vars vals) base-env) + (if (< (length vars) (length vals)) + (error "Too many arguments supplied " vars vals) + (error "Too few arguments supplied " vars vals)))) + +(define (lookup-variable-value var env) + (define (env-loop env) + (define (scan vars vals) + (cond ((null? vars) + (env-loop (enclosing-environment env))) + ((equal? var (car vars)) + (car vals)) + (else (scan (cdr vars) (cdr vals))))) + (if (eq? env the-empty-environment) + (error "Unbound variable " var) + (let ((frame (first-frame env))) + (scan (frame-variables frame) + (frame-values frame))))) + (env-loop env)) + +(define (set-variable-value! var val env) + (define (env-loop env) + (define (scan vars vals) + (cond ((null? vars) + (env-loop (enclosing-environment env))) + ((equal? var (car vars)) + (set-car! vals val)) + (else (scan (cdr vars) (cdr vals))))) + (if (eq? env the-empty-environment) + (error "Unbound variable -- SET! " var) + (let ((frame (first-frame env))) + (scan (frame-variables frame) + (frame-values frame))))) + (env-loop env)) + +(define (define-variable! var val env) + (let ((frame (first-frame env))) + (define (scan vars vals) + (cond ((null? vars) + (add-binding-to-frame! var val frame)) + ((equal? var (car vars)) + (set-car! vals val)) + (else (scan (cdr vars) (cdr vals))))) + (scan (frame-variables frame) + (frame-values frame)))) diff --git a/js/games/nluqo.github.io/~bh/61a-pages/Volume1/Project4/logo.scm b/js/games/nluqo.github.io/~bh/61a-pages/Volume1/Project4/logo.scm new file mode 100644 index 0000000..d957e7f --- /dev/null +++ b/js/games/nluqo.github.io/~bh/61a-pages/Volume1/Project4/logo.scm @@ -0,0 +1,179 @@ +;;; logo.scm part of programming project #4 + + +;;; Problem A1 make-line-obj + +(define (make-line-obj text) + (error "make-line-obj not written yet!")) + + +;;; Problem A2 logo-type + +(define (logo-type val) + (error "logo-type not written yet!")) + +(define (logo-print val) + (logo-type val) + (newline) + '=no-value=) + +(define (logo-show val) + (logo-print (list val))) + + + +;;; Problem 4 variables (logo-meta.scm is also affected) + +(define (make env var val) + (error "make not written yet!") + '=no-value=) + + +;;; Here are the primitives RUN, IF, and IFELSE. Problem B2 provides +;;; support for these, but you don't have to modify them. + +(define (run env exp) + (eval-line (make-line-obj exp) env)) + +(define (logo-if env t/f exp) + (cond ((eq? t/f 'true) (eval-line (make-line-obj exp) env)) + ((eq? t/f 'false) '=no-value=) + (else (error "Input to IF not true or false " t/f)))) + +(define (ifelse env t/f exp1 exp2) + (cond ((eq? t/f 'true) (eval-line (make-line-obj exp1) env)) + ((eq? t/f 'false) (eval-line (make-line-obj exp2) env)) + (else (error "Input to IFELSE not true or false " t/f)))) + + +;;; Problem B2 logo-pred + +(define (logo-pred pred) + pred) ;; This isn't written yet but we fake it for now. + + +;;; Here is an example of a Scheme predicate that will be turned into +;;; a Logo predicate by logo-pred: + +(define (equalp a b) + (if (and (number? a) (number? b)) + (= a b) + (equal? a b))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Stuff below here is needed for the interpreter to work but you ;;; +;;; don't have to modify anything or understand how they work. ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;; The Logo reader + +(define left-paren-symbol (string->symbol (make-string 1 #\( ))) +(define right-paren-symbol (string->symbol (make-string 1 #\) ))) +(define quote-symbol (string->symbol (make-string 1 #\" ))) + +(define (logo-read) + (define lookahead #f) + (define (logo-read-help depth) + (define (get-char) + (if lookahead + (let ((char lookahead)) + (set! lookahead #f) + char) + (let ((char (read-char))) + (if (eq? char #\\) + (list (read-char)) + char)))) + (define (quoted char) + (if (pair? char) + char + (list char))) + (define (get-symbol char) + (define (iter sofar char) + (cond ((pair? char) (iter (cons (car char) sofar) (get-char))) + ((memq char + '(#\space #\newline #\+ #\- #\* #\/ + #\= #\< #\> #\( #\) #\[ #\] )) + (set! lookahead char) + sofar) + (else (iter (cons char sofar) (get-char))) )) + (string->word (list->string (reverse (iter '() char)))) ) + (define (get-token space-flag) + (let ((char (get-char))) + (cond ((eq? char #\space) (get-token #t)) + ((memq char '(#\+ #\* #\/ #\= #\< #\> #\( #\) )) + (string->symbol (make-string 1 char))) + ((eq? char #\-) + (if space-flag + (let ((char (get-char))) + (let ((result (if (eq? char #\space) + '- + '=unary-minus=))) + (set! lookahead char) + result)) + '-)) + ((eq? char #\[) (logo-read-help (+ depth 1))) + ((pair? char) (get-symbol char)) + ((eq? char #\") + (let ((char (get-char))) + (if (memq char '(#\[ #\] #\newline)) + (begin (set! lookahead char) quote-symbol) + (string->symbol (word quote-symbol + (get-symbol (quoted char))))))) + (else (get-symbol char)) ))) + + (define (after-space) + (let ((char (get-char))) + (if (eq? char #\space) + (after-space) + char))) + (let ((char (get-char))) + (cond ((eq? char #\newline) + (if (> depth 0) (set! lookahead char)) + '()) + ((eq? char #\space) + (let ((char (after-space))) + (cond ((eq? char #\newline) + (begin (if (> depth 0) (set! lookahead char)) + '())) + ((eq? char #\]) + (if (> depth 0) '() (error "Unexpected ]"))) + (else (set! lookahead char) + (let ((token (get-token #t))) + (cons token (logo-read-help depth))))))) + ((eq? char #\]) + (if (> depth 0) '() (error "Unexpected ]"))) + ((eof-object? char) char) + (else (set! lookahead char) + (let ((token (get-token #f))) + (cons token (logo-read-help depth)) ))))) + (logo-read-help 0)) + + +;;; Assorted stuff + +(define (make-logo-arith op) + (lambda args (apply op (map maybe-num args)))) + +(define (maybe-num val) + (if (word? val) + (string->word (word->string val)) + val)) + +(define tty-port (current-input-port)) + +(define (prompt string) + (if (eq? (current-input-port) tty-port) + (begin (display string) (flush)))) + +(define (meta-load fn) + (define (loader) + (let ((exp (logo-read))) + (if (eof-object? exp) + '() + (begin (eval-line (make-line-obj exp) + the-global-environment) + (loader))))) + (with-input-from-file (symbol->string fn) loader) + '=no-value=) diff --git a/js/games/nluqo.github.io/~bh/61a-pages/Volume1/Project4/obj.scm b/js/games/nluqo.github.io/~bh/61a-pages/Volume1/Project4/obj.scm new file mode 100644 index 0000000..d4a9d7a --- /dev/null +++ b/js/games/nluqo.github.io/~bh/61a-pages/Volume1/Project4/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") diff --git a/js/games/nluqo.github.io/~bh/61a-pages/Volume1/hw.pdf b/js/games/nluqo.github.io/~bh/61a-pages/Volume1/hw.pdf new file mode 100644 index 0000000..4bf9a8c --- /dev/null +++ b/js/games/nluqo.github.io/~bh/61a-pages/Volume1/hw.pdf Binary files differ |