From 60666f73e031df64c910e0ca07dfca923360632a Mon Sep 17 00:00:00 2001 From: Marcus Kammer Date: Thu, 12 Jan 2023 17:23:13 +0100 Subject: [PATCH] Add solutions to exercises --- CL-gentle-intro/README.md | 19 + CL-gentle-intro/applicative-programming.lisp | 398 +++++++++ CL-gentle-intro/array-hash-tables-plists.lisp | 264 ++++++ CL-gentle-intro/assignment.lisp | 325 ++++++++ CL-gentle-intro/conditionals.lisp | 177 ++++ CL-gentle-intro/eval.lisp | 49 ++ CL-gentle-intro/functions-data.lisp | 20 + CL-gentle-intro/input-output.lisp | 236 ++++++ .../iteration-and-block-structure.lisp | 385 +++++++++ CL-gentle-intro/list-data-structures.lisp | 271 +++++++ CL-gentle-intro/lists.lisp | 84 ++ CL-gentle-intro/macros-and-compilation.lisp | 250 ++++++ CL-gentle-intro/recursion.lisp | 755 ++++++++++++++++++ CL-gentle-intro/structures-type-system.lisp | 137 ++++ CL-gentle-intro/variables-side-effects.lisp | 96 +++ 15 files changed, 3466 insertions(+) create mode 100644 CL-gentle-intro/README.md create mode 100644 CL-gentle-intro/applicative-programming.lisp create mode 100644 CL-gentle-intro/array-hash-tables-plists.lisp create mode 100644 CL-gentle-intro/assignment.lisp create mode 100644 CL-gentle-intro/conditionals.lisp create mode 100644 CL-gentle-intro/eval.lisp create mode 100644 CL-gentle-intro/functions-data.lisp create mode 100644 CL-gentle-intro/input-output.lisp create mode 100644 CL-gentle-intro/iteration-and-block-structure.lisp create mode 100644 CL-gentle-intro/list-data-structures.lisp create mode 100644 CL-gentle-intro/lists.lisp create mode 100644 CL-gentle-intro/macros-and-compilation.lisp create mode 100644 CL-gentle-intro/recursion.lisp create mode 100644 CL-gentle-intro/structures-type-system.lisp create mode 100644 CL-gentle-intro/variables-side-effects.lisp diff --git a/CL-gentle-intro/README.md b/CL-gentle-intro/README.md new file mode 100644 index 00000000..10d5a165 --- /dev/null +++ b/CL-gentle-intro/README.md @@ -0,0 +1,19 @@ +# Common Lisp: A Gentle Introduction to Symbolic Computation + +## My solutions for the exercices included in the book, you can get the book from the following link: [Common Lisp: GISC](https://www.cs.cmu.edu/~dst/LispBook/) + +* Chapter 1 - **Functions and Data** +* Chapter 2 - **Lists** +* Chapter 3 - **EVAL Notation** +* Chapter 4 - **Conditionals** +* Chapter 5 - **Variables and Side Effects** +* Chapter 6 - **List Data Structures** +* Chapter 7 - **Applicative Programming** +* Chapter 8 - **Recursion** +* Chapter 9 - **Input/Output** +* Chapter 10 - **Assignment** +* Chapter 11 - **Iteration and Block Structure** +* Chapter 12 - **Structures and The Type System** +* Chapter 13 - **Arrays, Hash Tables, And Property Lists** +* Chapter 14 - **Macros and Compilation** + diff --git a/CL-gentle-intro/applicative-programming.lisp b/CL-gentle-intro/applicative-programming.lisp new file mode 100644 index 00000000..1608ed9d --- /dev/null +++ b/CL-gentle-intro/applicative-programming.lisp @@ -0,0 +1,398 @@ +;;; Chapter 7 - Applicative Programming +;;; Exercises + +;;; Ex 7.1 +;;; Write an ADD1 function that adds one to its input. Then write an expression to add one to each of the list (1 3 5 7 9) +(defun add1 (n) + (+ n 1)) + +(mapcar #'add1 '(1 3 5 7 9)) + +;;; Ex 7.2 +;;; let the global variable DAILY-PLANET contain the following table: +((olsen jimmy 123-76-4535 cub-reporter) + (kent clark 089-52-6787 reporter) + (lane lois 951-26-1438 reporter) + (white perry 355-16-7439 editor)) +;;; Each table entry consist of a last name, a first name, a social security number, and a job title. use MAPCAR on this table to extract a list of social numbers. +(setf daily-planet + '((olsen jimmy 123-76-4535 cub-reporter) + (kent clark 089-52-6787 reporter) + (lane lois 951-26-1438 reporter) + (white perry 355-16-7439 editor))) + +(mapcar #'third daily-planet) + +;;; Write an expression to apply the ZEROP predicate to each element of the list (2 0 3 4 0 -5 -6). +;;; The answer you get should be a list of Ts and NILs. +(mapcar #'zerop '(2 0 3 4 0 -5 -6)) + +;;; Suppose we want to solve a problem similar to the preceding one, but instead of testing wheter an element is zero, we want to test whether it is greater than five. +;;; We can't use > directly for this because > is a function of two inputs; MAPCAR will only give it one input. +;;; Show how first writing a one-input function called GREATER-THAN-FIVE-P would help. +(defun greater-than-five-p (n) + (> n 5)) + +(mapcar #'greater-than-five-p '(2 0 3 4 0 -5 -6)) + +;;; Ex 7.5 +;;; Write a lambda expression to subtract seven from a number +#'(lambda (n) (- n 7)) + +;;; Ex 7.6 +;;; Write a lambda expression that returns T if its input is T or NIL, but NIL for any other input. +#'(lambda (i) (cond (or (eq t i) (eq nil i)) t)) + +;;; Ex 7.7 +;;; Write a function that takes a list such as (UP DOWN UP UP) and "flips" each element, returning (DOWN UP DOWN DOWN). +;;; Your function should include a lambda expression that knows how to flip an individual element, plus an applicative operator to do this to every element of the list. +(defun flip (l) + (mapcar #'(lambda (e) + (if (eq e 'up) + 'down + 'up)) l)) + +;;; Ex 7.8 +;;; Write a function that takes two inputs, X and K, and returns the first number in the list X that is roughly equal to K. +;;; Let's say that "roughly equal" means no less than K-10 and no more than K+10. +(defun ex-7.8 (x k) + (find-if #'(lambda (e) + (and (>= e (- k 10)) (<= 2 (+ k 10)))) + x)) + +;;; Ex 7.9 +;;; Write a function FIND-NESTED that returns the first element of a list that is itself a non-NIL list. +(defun find-nested (l) + (find-if #'(lambda (e) + (and (listp e) (> (length e) 0))) + l)) + +(defun find-nested (l) + (find-if #'consp l)) + +;;; Ex 7.10 +;;; In this exercise we will write a program to transpose a song from one key to another. In order to manipulate notes more efficiently, we will translate them into numbers. +;;; Here is the correspondence between notes and numbers for a non-octave scale: +C = 1 F-SHARP = 7 +C-SHARP = 2 G = 8 +D = 3 G-SHARP = 9 +D-SHARP = 4 A = 10 +E = 5 A-SHARP = 11 +F = 6 B = 12 +;;; a. +;;; Write a table to represent this information. Store it in a global variable called NOTE-TABLE. +(setf note-table + '((c 1) (c-sharp 2) (d 3) (d-sharp 4) (e 5) (f 6) + (f-sharp 7) (g 8) (g-sharp 9) (a 10) (a-sharp 11) + (b 12))) + +;;; b. +;;; Write a function called NUMBERS that takes a list of notes as input and returns the corresponding list of numbers. (NUMBERS '(E D C D E E E)) should return (5 3 1 3 5 5 5). +;;; This list represents the first seven notes of "Mary Had a Little Lamb." +(defun numbers (l) + (mapcar #'(lambda (x) + (cadr (assoc x note-table))) + l)) + +;;; c. +;;; Write a function called NOTES that takes a list of numbers as input and returns the corresponding list of notes. (NOTES '(5 3 1 3 5 5 5)) should return (E D C D E E E). Hint: Since NOTE-TABLE is keyed by note, ASSOC can't look up numbers in it; +;;; neither can RASSOC, since the elements are lists, not dotted pairs. Write you own table-searching function to search NOTE-TABLE by number instead of by note. +(defun table-searching (x) + (find-if #'(lambda (e) + (eq (car (reverse e)) x)) + note-table)) + +(defun notes (l) + (mapcar #'(lambda (x) + (car x)) + (mapcar #'table-searching l))) + +;;; e. +;;; To transpose a piece of music up by n half steps, we begin by adding the value n to each note in the piece. Write a function called RAISE that takes a number n and a list of numbers as input and raises each number in the list by the value n. +;;; (RAISE 5 '(5 3 1 3 5 5 5)) should return (10 8 6 8 10 10 10), whis is "Mary had a little lamb" transposed five half steps from the key of C to the key of F. +(defun raise (n l) + (mapcar #'(lambda (x) + (+ x n)) + l)) + +;;; f. +;;; Sometimes when we raise the value of a note, we may raise it right into the next octave. For instance, if we raise the triad C-E-G represented by the list (1 5 8) into the key of F by adding five to each note, we get (6 10 13), or F-A-C. +;;; Here the C note, represented by the number 13, is an octave above the regular C, represented by 1. Write a function called NORMALIZE that takes a list of numbers as input and "normalizes" them to make them be between 1 and 12. +;;; A number greater than 12 should have 12 subtracted from it; a number less than 1 should have 12 added to it. (NORMALIZE '(6 10 13)) should return (6 10 1). +(defun normalize (l) + (mapcar #'(lambda (x) + (cond ((> x 12) (- x 12)) + ((< x 1) (+ x 12)) + (t x))) + l)) + +;;; g. +;;; Write a function TRANSPOSE that takes a number n and a song as input, and returns the song transposed by n half steps. +;;; (TRANSPOSES 5 '(E D C D E E E)) should return (A G F G A A A). Your solution should assume the availability of the NUMBERS, NOTES, RAISE and NORMALIZE functions. Try transposing "Mary Had a Little Lamb" up by 11 half steps. What happens if you transpose it by 12 half steps? How about -1 half steps? +(defun transpose (n l) + (notes + (normalize + (raise n (numbers l))))) + +;;; Ex 7.11 +;;; Write a function to pick out those numbers in a list that are greater than one and less than five. +(defun ex-711 (l) + (remove-if-not #'(lambda (x) + (and (> x 1) (< x 5))) + l)) + +;;; Ex 7.12 +;;; Write a function that counts how many times the word "the" appears in a sentence. +(defun ex-712 (l) + (length (remove-if-not #'(lambda (x) + (eq x 'the)) + l))) + +;;; Ex 7.13 +;;; Write a function that picks from a list of lists those of exactly length two. +(defun ex-713 (l) + (remove-if-not #'(lambda (x) + (eq (length x) 2)) + l)) + +;;; Ex 7.14 +;;; Here is a version of SET-DIFFERENCE written with REMOVE-IF: +(defun my-setdiff (x y) + (remove-if #'(lambda (e) + (member e y)) + x)) +;;; Show how the INTERSECTION and UNION functions can be written using REMOVE-IF or REMOVE-IF-NOT. +(defun my-intersection (x y) + (remove-if-not #'(lambda (e) + (member e y)) + x)) + +(defun my-union (x y) + (append y + (remove-if #'(lambda (e) + (and (member e x) (member e y))) + x))) + +;;; Ex 7.15 +;;; In this exercise we will manipulate cards with applicative operators. A card will be represented by a list of form (rank suit), for example, (ACE SPADES) or (2 CLUBS). A hand will be represented by a list of cards. + +;;; a. +;;; Write the functions RANK and SUIT that return the rank and suit of a card, respectively. (RANK '(2 CLUBS)) should return 2, and (SUIT '(2 CLUBS)) should return CLUBS. +(defun rank (l) + (car l)) + +(defun suite (l) + (cadr l)) + +;;; b. +;;; Set the global variable MY-HAND to the following hand of cards: +((3 hearts) (5 clubs) (2 diamonds) (4 diamonds) (ace spades)) +;;; Now write a function COUNT-SUIT that takes two inputs, a suit and a hand of cards, and returns the number of cards belonging to that suit. (COUNT-SUIT 'DIAMONDS MY-HAND) should return 2. +(setf my-hand '((3 hearts) (5 clubs) (2 diamonds) (4 diamonds) (ace spades))) + +(defun count-suit (s h) + (length (remove-if-not #'(lambda (x) + (eq (suite x) s)) + h))) + +;;; c. +;;; Set the global variable COLORS to the following table: +((clubs black) (diamonds red) (hearts red) (spades black)) +;;; Now write a function COLOR-OF that uses the table COLORS to retrieve the color of a card. (COLOR-OF '(2 CLUBS)) should return BLACK. (COLOR-OF '(6 HEARTS)) should return RED. +(setf colors '((clubs black) (diamonds red) (hearts red) (spades black))) + +;;; Now write a function COLOR-OF that uses the table COLORS to retrieve the color of a card. (COLOR-OF '(2 CLUBS)) should return BLACK. +(defun color-of (c) + (cadr (assoc (suite c) colors))) + +;;; d. +;;; Write a function FIRST-RED that returns the first card of a hand that is of a red suit, or NIL if none are. +(defun first-red (h) + (find-if #'(lambda (c) + (eq (color-of c) 'red)) + h)) + +;;; e. +;;; Write a function BLACK-CARDS that returns a list of all the black cards in a hand. +(defun black-cards (h) + (remove-if-not #'(lambda (c) + (eq (color-of c) 'black)) + h)) + +;;; f. +;;; Write a function WHAT-RANKS that takes two inputs, a suit and a hand, and return the ranks of all cards belonging to that suit. +;;; (WHAT-RANKS 'DIAMONDS MY-HAND) should return the list (2 4). +;;; (WHAT-RANKS 'SPADES MY-HAND) should return the list (ACE). +;;; Hint: First extract all the cards of the specified suit, then use another operator to get the ranks of those cards. +(defun what-ranks (s h) + (mapcar #'(lambda (c) (rank c)) + (remove-if-not #'(lambda (c) (eq (suite c) s)) + h))) + +;;; g. +;;; Set the global variable ALL-RANKS to the list +(2 3 4 5 6 7 8 9 10 jack queen king ace) +;;; Then write a predicate HIGHER-RANK-P that takes two cards as input and returns true if the first card has a higher rank than the second. +;;; Hint: look at the BEFOREP predicate on page 171 of Chapter 6. +(setf all-ranks '(2 3 4 5 6 7 8 9 10 jack queen king ace)) + +(defun beforep (x y l) + "Returns true if X appears before Y in L" + (member y (member x l))) + +(defun bang (e) + "Retuns boolean value of e" + (not (not e))) + +(defun higher-rank-p (c1 c2) + (bang + (beforep (rank c2) (rank c1) all-ranks))) + +;;; h. +;;; Write a function HIGH-CARD that returns the highest ranked card in a hand. +;;; Hint: One way to solve this is to use FIND-IF to search a list of ranks (ordered from high to low) to find the highest rank that appears in the hand. +;;; Then use ASSOC on the hand to pick the card with that rank. Another solution would be to use REDUCE (defined in the next section) to repeatedly pick the highest card of each pair. + +(defun high-card (h) + (reduce #'(lambda (x y) + (if (higher-rank-p x y) + x + y)) + h)) + +;;; 7.16 +;;; Suppose we had a list of sets ((A B C) (C D A) (F B D) (G)) that we wanted to collapse into one big set. If we use APPEND for our reducing function, the result won't be a true set, because some elements will appear more than once. +;;; What reducing function should be used instead? +(reduce #'union '((A B C) (C D A) (F B D) (G))) + +;;; 7.17 +;;; Write a function that, given a list of lists, returns the total length of all the lists. This problem can be solved two different ways. +(defun my-length (l) + (reduce #'+ (mapcar #'(lambda (x) + (length x)) + l))) + +;;; 7.19 +;;; Write a function ALL-ODD that returns T if every element of a list of numbers is odd. +(defun all-odd (l) + (every #'oddp l)) + +;;; 7.20 +;;; Write a function NONE-ODD that returns T if every element of a list of numbers is not odd. +(defun none-odd (l) + (every #'evenp l)) + +;;; 7.21 +;;; Write a function NOT-ALL-ODD that returns T if not every element of a list of numbers is odd. +(defun not-all-odd (l) + (if (all-odd l) + nil + t)) + +(defun not-all-odd (l) + (find-if #'evenp l)) + +;;; 7.22 +;;; Write a function NOT-NONE-ODD that returns T if it is not the case that a list of numbers contains no odd elements. +(defun not-none-odd (l) + (if (none-odd l) + nil + t)) + +(defun not-none-odd (l) + (find-if #'oddp l)) + +;;; Ex 7.29 +;;; Create a global variable DATABASE +(setf database + '((b1 shape brick) (b1 color green) (b1 size small) (b1 supported-by b2) (b1 supported-by b3) + (b2 shape brick) (b2 color red) (b2 size small) (b2 supports b1) (b2 left-of b3) + (b3 shape brick) (b3 color red) (b3 size small) (b3 supports b1) (b1 right-of b2) + (b4 shape pyramid) (b4 color blue) (b4 size large) (b4 supported-by b5) + (b5 shape cube) (b5 color green) (b5 size large) (b5 supports b4) + (b6 shape brick) (b6 color purple) (b6 size large))) + +;;; a. +;;; Write a function MATCH-ELEMENT that takes two symbols as input. If the two are equal, or if the second is a question mark, MATCH-ELEMENT should return T. +;;; Thus (MATCH-ELEMENT 'RED 'RED) and (MATCH-ELEMENT 'RED '?) should return T, but (MATCH-ELEMENT 'RED 'BLUE) should return NIL. Make sure your function works correctly before proceeding further. +(defun match-element (s1 s2) + (or (eq s1 s2) (eq s2 '?))) + +;;; b. +;;; Write a function MATCH-TRIPLE that takes an assertion and a pattern as input, and returns T if the assertion matches the pattern. +;;; Both inputs will be three-element lists. (MATCH-TRIPlE '(B2 COLOR RED) '(B2 COLOR ?)) should return T. (MATCH-TRIPlE '(B2 COLOR RED) '(B2 COLOR GREEN)) should return NIL. +(defun match-triple (a p) + (match-element (third a) (third p))) + +;;; c. +;;; Write the function FETCH that takes a pattern as input and returns all assertions in the database that match the pattern. Remember that DATABASE is a global variable. +;;; (FETCH '(B2 COLOR ?)) should return ((B2 COLOR RED)), and (FETCH '(? SUPPORTS B1)) should return ((B2 SUPPORTS B1) (B3 SUPPORTS B1)). +(defun fetch (p) + (remove-if-not #'(lambda (x) + (subsetp (remove '? p) x)) + database)) + +;;; d. +;;; Use FETCH with patterns you construct yourself to answer the following questions. What shape is block B4? Which blocks are bricks? What relation is block B2 to block B3? List the color of every block. What facts are known about block B4? +(fetch '(b4 shape ?)) +(fetch '(? shape brick)) +(fetch '(b2 ? b3)) +(fetch '(? color ?)) +(fetch '(b4 ? ?)) + +;;; e. +;;; Write a function that takes a block name as input and returns a pattern asking the color of the block. For example, given the input B3, your function should return the list (B3 COLOR ?). +(defun ask-color (b) + (cons b '(color ?))) + +;;; f. +;;; Write a funtion SUPPORTERS that takes one input, a block, and returns a list of the blocks that support it. (SUPPORTERS 'B1) should return the list (B2 B3). +;;; The function should work by constructing a pattern containing the block's name, using that pattern as input to FETCH, and then extracting the block names from the resulting list of assertions. +(defun supporters (b) + (mapcar #'(lambda (x) + (car x)) + (fetch (append '(? supports) (list b))))) + + +;;; g. +;;; Write a predicate SUPP-CUBE that takes a block as input and returns true if that block is supported by a cube. (SUPP-CUBE 'B4) should return a true value; +;;; (SUPP-CUBE 'B1) should not because B1 is supported by bricks but not cubes. +(defun supp-cube (b) + (eq (third + (car + (fetch (cons (car (supporters b)) '( shape ?))))) + 'cube)) + +;;; h. +;;; We are going to write a DESCRIPTION function that returns the description of a block. (DESCRIPTION 'B2) will return (SHAPE BRICK COLOR RED SIZE SMALL SUPPORTS B1 LEFT-OF B3). +;;; We will do this in steps. First, write a function DESC1 that takes a block as input and returns all assertions dealing with that block. +;;; (DESC1 'B6) should return ((B6 SHAPE BRICK) (B6 COLOR PURPLE) (B6 SIZE LARGE)). +(defun desc1 (b) + (fetch (list b '? '?))) + +;;; i. +;;; Write a function DESC2 of one input that calls DESC1 and strips the block name off each element of the result. +;;; (DESC2 'B6) should return the list ((SHAPE BRICK) (COLOR PURPLE) (SIZE LARGE)). +(defun desc2 (l) + (mapcar #'(lambda (x) + (rest x)) + l)) + +;;; j. +;;; Write the DESCRIPTION function. It should take one input, call DESC2, and merge the resulting list of lists into a single list. +;;; (DESCRIPTION 'B6) should return (SHAPE BRICK COLOR PURPLE SIZE LARGE). +(defun description (b) + (reduce #'(lambda (x y) + (append x y)) + (desc2 (desc1 b)))) + +;;; 7.30 +;;; Recall the English-French dictionary we stored in the global variable WORDS earlier in the chapter. Given this dictionary plus the list or corresponding Spanish words (UNO DOS TRES QUATRO CINCO). +;;; Write an expression to return a trilingual dictionary. The first entry of the dictionary should be (ONE UN UNO). +(setf words + '((one un) (two deux) (three trois) (four quatre) (five cinq))) + +(mapcar #'(lambda (x y) (append x (list y))) + words '(uno dos tres quatro cinco)) + + diff --git a/CL-gentle-intro/array-hash-tables-plists.lisp b/CL-gentle-intro/array-hash-tables-plists.lisp new file mode 100644 index 00000000..d52c2526 --- /dev/null +++ b/CL-gentle-intro/array-hash-tables-plists.lisp @@ -0,0 +1,264 @@ +;;; Chapter 13 - Arrays, Hash Tables, And Property Lists + +;;; Exercises + +;;; Ex 13.1 +;;; Write a function called SUBPROP that deletes an element from a set stored under a property name. +;;; For example, if the symbol ALPHA has the list (A B C D E) as the value of its FOOPROP property, doing (SUBPROP 'ALPHA 'D 'FOOPROP) should leave (A B C E) as the value of ALPHA's FOOPROP property. +(setf (get 'alpha 'fooprop) '(a b c d e)) + +(defun subprop (name element prop) + (setf (get name prop) + (remove element + (get name prop)))) + +;;; Ex 13.2 +;;; Write a function called FORGET-MEETING that forgets that two particular persons have ever met each other. +;;; Use SUBPROP in your solution. +(defun addprop (sym elem prop) + (pushnew elem (get sym prop))) + +(defun record-meeting (x y) + (addprop x y 'has-met) + (addprop y x 'has-met) + t) + +(symbol-plist 'john) + +(defun forget-meeting (x y) + (remprop x 'has-met) + (remprop y 'has-met) + t) + +;;; Alternative solution +(defun forget-meeting (person1 person2) + (subprop person1 person2 'has-met) + (subprop person2 person1 'has-met) + 'forgotten) + +;;; Ex 13.3 +;;; Using SYMBOL-PLIST, write your own version of the GET function. +(defun my-get (symbol property) + (do ((p (symbol-plist symbol) (cddr p))) + ((null p) nil) + (if (equal property (first p)) + (return (second p))))) + + +;;; Ex 13.4 +;;; Write a predicate HASPROP that returns T or NIL to indicate whether a symbol has a particular property, independent of the value of that property. +;;; Note: If symbol A has a property FOO with value NIL, (HASPROP 'A 'FOO) should still return T. +(defun hasprop (symbol property) + (do ((p (symbol-plist symbol) (cddr p))) + ((null p) nil) + (if (equal property (first p)) + (return t)))) + +;;; Ex 13.8 +;;; Follow the steps below to create a histogram-drawing program. Your functions should not assume that the histogram will have exactly eleven bins. +;;; In other words, don't use eleven as a constant in you program; use (LENGTH *HIST-ARRAY*) instead. +;;; That way your program will be able to generate histograms of any size. + +;;; a. +;;; Write expressions to set up a global variable *HIST-ARRAY* that holds the array of counts, and a global variable *TOTAL-POINTS* that holds the number of points recorded so far. +(setf *hist-array* nil) + +(setf *total-points* 0) + +;;; b. +;;; Write a function NEW-HISTOGRAM to initialize these variables appropriately. +;;; It should take one input: the number of bins the histogram is to have. +(defun new-histogram (n) + (setf *total-points* 0) + (setf *hist-array* + (make-array n + :initial-element 0)) + t) + +;;; c. +;;; Write the function RECORD-VALUE that takes a number as input. +;;; If the number is between zero and ten, it should increment the appropriate element of the array, and also update *TOTAL-POINTS*. +;;; If the input is out of range, RECORD-VALUE should issue an appropriate error message. +(defun record-value (n) + (cond ((or (< n 0) (> n 10)) + (format t "~&Number ~A is out of range." n)) + (t (setf (aref *hist-array* n) + (+ (aref *hist-array* n) 1)) + (dotimes (i 11 *total-points*) + (setf *total-points* + (+ *total-points* + (aref *hist-array* i))))))) + +;;; Better alternative +(defun record-value (v) + (incf *total-points*) + (if (and (>= v 0) + (< v (length *hist-array*))) + (incf (aref *hist-array* v)) + (error "Value ~S out of bounds." v))) + +;;; d. +;;; Write a function PRINT-HIST-LINE that takes a value from zero to ten as input, looks up that value in the array, and prints the corresponding line of the histogram. +;;; To get the numbers to line up in columns properly, you will need to use the format directives ~2S to display the value and ~3S to display the count. +;;; You can use a DOTIMES to print the asterisks. +(defun print-hist-line (n) + (let ((cnt (aref *hist-array* n))) + (format t "~&~2D [~3D] " n cnt) + (dotimes (i cnt) + (format t "*")))) + +;;; e. +;;; Write the function PRINT-HISTOGRAM. +(defun print-histogram (iterations) + (new-histogram 11) + (dotimes (i iterations) + (record-value (random 11))) + (dotimes (i 11) + (print-hist-line i)) + (format t "~& ~3D total" *total-points*)) + +;;; Ex 13.9 +;;; Set up the global variable CRYPTO-TEXT as shown. Then build the cryptogram-solv§ing tool by following these instruction: + +;;; a. +;;; Each letter in the alphabet has a corresponding letter to which it deciphers, for example, P deciphers to A. +;;; As we solve the cryptogram we will store this information in two hash tables called *ENCIPHER-TABLE* and *DECIPHER-TABLE*. +;;; We will use *DECIPHER-TABLE* to print out the deciphered cryptogram. +;;; We need *ENCIPHER-TABLE* to check for two letters being deciphered to the same thing, for example, if P is deciphered to A and then we tried to decipher K to A, a look at *ENCIPHER-TABLE* would reveal that A had already been assigned to P. +;;; Similarly, if P is deciphered to A and then we tried deciphering P to E, a look at *DECIPHER-TABLE* would tell us that P had already been deciphered to A. +;;; Write expressions to initialize these global variables. +(setf *decipher-table* (make-hash-table)) + +(setf *encipher-table* (make-hash-table)) + +(setf crypto-text + '("zj ze kljjls jf slapzi ezvlij pib kl jufwxuj p hffv jupi jf" + "enlpo pib slafml pvv bfwkj")) + +;;; b. +;;; Write a function MAKE-SUBSTITUTION that takes two character objects as input and stores the appropriate entries in *DECIPHER-TABLE* and *ENCIPHER-TABLE* so that the first letter deciphers to the second and the second letter enciphers to the first. +;;; This function does not need to check if either letter already has an entry in these hash tables. +(defun make-substitution (a b) + (setf (gethash a *decipher-table*) b) + (setf (gethash b *encipher-table*) a)) + +;;; c. +;;; Write a function UNDO-SUBSTITUTION that takes one letter as input. +;;; It should set the *DECIPHER-TABLE* entry of that letter, and the *ENCIPHER-TABLE* entry of the letter it deciphered to, to NIL. +(defun undo-substitution (a b) + (setf (gethash a *decipher-table*) nil) + (setf (gethash b *encipher-table*) nil)) + +;;; d. +;;; Look up the documentation for the CLRHASH function, and write a function CLEAR that clears the two hash tables used in this problem. +(defun clear () + (clrhash *decipher-table*) + (clrhash *encipher-table*) + 'clear-ok) + +;;; e. +;;; Write a function DECIPHER-STRING that takes a single encoded string as input and return a new, partially decoded string. It should begin by making a new string the same length as the input, containing all spaces. +;;; Here is how to do that, assuming the variable LEN holds the length: (make-string len :initial-element #\Space). +;;; Next the function should iterate through the elements of the input string, which are character objects. For each character that deciphers to something non-NIL, that value should be inserted into the corresponding position in the new string. +;;; Finally, the function should return the new string. +;;; When testing this function, make sure its inputs are all lowercase. +(defun decipher-string (str) + (do* ((len (length str)) + (new-str (make-string len + :initial-element #\Space)) + (i 0 (1+ i))) + ((equal i len) new-str) + (let* ((char (aref str i)) + (new-char + (gethash char *decipher-table*))) + (when new-char + (setf (aref new-str i) new-char))))) + +;;; f. +;;; Write a function SHOW-LINE that displays one line of cryptogram text, with the deciphered text displayed beneath it. +(defun show-line (line) + (format t "~&~A" line) + (format t "~&~A" + (decipher-string line))) + +;;; g. +;;; Write a function SHOW-TEXT that takes a cryptogram (list of strings) as input and displays the lines as in the examples at the beginning of this exercise. +(defun show-text (cryptogram) + (format t "~&-------------------------------------") + (dolist (element cryptogram) + (format t "~&~A" element) + (format t "~&~A" (decipher-string element))) + (format t "~&-------------------------------------")) + +;;; h. +;;; Type in the definition of GET-FIRST-CHAR, which returns the first character in the lowercase printed of an object. +(defun get-first-char (x) + (char-downcase + (char (format nil "~A" x) 0))) + +;;; i. +;;; Write a function READ-LETTER that reads an object from the keyboard. If the object is the symbol END or UNDO, it should be returned as the value of READ-LETTER. +;;; Otherwise READ-LETTER should use GET-FIRST-CHAR on the object to extract the first character of its printed representation; it should return that character as its result. +(defun read-letter () + (do ((answer nil)) + (nil) + (setf answer (read)) + (if (or (equal answer 'end) + (equal answer 'undo)) + (return answer) + (return (get-first-char answer))))) + +;;; j. +;;; Write a function SUB-LETTER that takes a character object as input. If that character has been deciphered already, SUB-LETTER should print an error message that tells to what the letter has been deciphered. +;;; Otherwise SUB-LETTER should ask "What does (letter) decipher to?" and read a letter. +;;; If the result is a character and it has not yet been enciphered, SUB-LETTER should call MAKE-SUBSTITION to record the substitution. +;;; Otherwise an appropriate error message should be printed. +(defun sub-letter (c) + (let ((deciphered (gethash c *decipher-table*))) + (cond ((not (null deciphered)) (format t + "~&´~A´ has already been deciphered as ´~A´" + c deciphered)) + (t (format t "~&What does ´~A´ decipher to? " c) + (setf answer (read)) + (setf answer (get-first-char answer)) + (setf deciphered (gethash answer *decipher-table*)) + (if deciphered + (format t "~&´~A´ has already been deciphered as ´~A´" + answer deciphered) + (make-substitution c answer)))))) + +;;; k. +;;; Write a function UNDO-LETTER that asks "Undo which letter?" and reads in a character. +;;; If that character has been deciphered UNDO-LETTER should call UNDO-SUBSTITUTION on the letter. +;;; Otherwise an appropriate error message should be printed. +(defun undo-letter () + (format t "~&Undo which letter? ") + (let* ((l (read)) + (l (get-first-char l)) + (d (gethash l *decipher-table*))) + (if d + (undo-substitution l d) + (format t "~&´~A´ cannot be undone." l)))) + +;;; Write the main function SOLVE that takes a cryptogram as input. SOLVE should perform the following loop. +;;; First it should display the cryptogram. +;;; Then it should ask "Substitute which letter?" and call READ-LETTER. +;;; If the result is a character, SOLVE should call SUB-LETTER; if the result is the symbol UNDO, it should call UNDO-LETTER; +;;; If the result is the symbol END, it should return T; +;;; otherwise it should issue an error message. +;;; Then it should go back to the beginning of the loop, unless the value returned by READ-LETTER was END. +(defun solve (cryptogram) + (clear) + (show-text cryptogram) + (do ((answer nil)) + (nil) + (format t "~&Substitute which letter? ") + (setf answer (read-letter)) + (cond ((equal answer 'undo) + (undo-letter) + (show-text cryptogram)) + ((equal answer 'end) (return t)) + (t (sub-letter answer) + (show-text cryptogram))))) + + diff --git a/CL-gentle-intro/assignment.lisp b/CL-gentle-intro/assignment.lisp new file mode 100644 index 00000000..a671ac01 --- /dev/null +++ b/CL-gentle-intro/assignment.lisp @@ -0,0 +1,325 @@ +;;; Chapter 10 - Assignment +;;; Exercises + +;;; Assign global variable *total-glasses* to zero. +(setf *total-glasses* 0) + +(defun sell (n) + "Ye Olde Lemonade Stand: Sales by the Glass." + (setf *total-glasses* (+ *total-glasses* n)) + (format t + "~&That makes ~S glasses so far today." + *total-glasses*)) + +;;; Ex 10.2 +;;; Rewrite the lemonade stand SELL function to use INCF instead of SETF. +(defun sell (n) + "Ye Olde Lemonade Stand: Sales by the Glass." + (incf *total-glasses* n) + (format t + "~&That makes ~S glasses so far today." + *total-glasses*)) + +;;; Ex 10.3 +;;; Modify the MEET function to keep a count of how many people have been met more than once. Store this count in a global variable. + +(setf *friends* nil) + +(defun meet (person) + (cond ((equal person (first *friends*)) + 'we-just-met) + ((member person *friends*) + 'we-know-each-other) + (t (push person *friends*) + 'please-to-meet-you))) + +(setf *meet-cnt* 0) + +(defun meet (person) + (cond ((equal person (first *friends*)) + 'we-just-met) + ((member person *friends*) + (+ *meet-cnt* 1) + 'we-know-each-other) + (t (push person *friends*) + 'please-to-meet-you))) + +;;; Ex 10.4 +;;; Write a function FORGET that removes a person from the *FRIENDS* list. +;;; If the person wasn't on the list in the first place, the function should complain. +(defun forget (person) + (cond ((member person *friends*) (remove person *friends*)) + (t (format t "~&You haven't met ~S yet!" person)))) + +;;; CASE STUDY: a tic-tac-toe player +(defun make-board () + (list 'board 0 0 0 0 0 0 0 0 0)) + +(defun convert-to-letter (v) + (cond ((equal v 1) "O") + ((equal v 10) "X") + (t " "))) + +(defun print-row (x y z) + (format t "~& ~A | ~A | ~A" + (convert-to-letter x) + (convert-to-letter y) + (convert-to-letter z))) + +(defun print-board (board) + (format t "~%") + (print-row + (nth 1 board) (nth 2 board) (nth 3 board)) + (format t "~& -----------") + (print-row + (nth 4 board) (nth 5 board) (nth 6 board)) + (format t "~& -----------") + (print-row + (nth 7 board) (nth 8 board) (nth 9 board)) + (format t "~%~%")) + +(setf b (make-board)) + +(defun make-move (player pos board) + (setf (nth pos board) player) + board) + +(setf *computer* 10) + +(setf *opponent* 1) + +(setf *triplets* + '((1 2 3) (4 5 6) (7 8 9) + (1 4 7) (2 5 8) (3 6 9) + (1 5 9) (3 5 7))) + +(defun sum-triplet (board triplet) + (+ (nth (first triplet) board) + (nth (second triplet) board) + (nth (third triplet) board))) + +(defun compute-sums (board) + (mapcar #'(lambda (triplet) + (sum-triplet board triplet)) + *triplets*)) + +(defun winner-p (board) + (let ((sums (compute-sums board))) + (or (member (* 3 *computer*) sums) + (member (* 3 *opponent*) sums)))) + +(defun play-one-game () + (if (y-or-n-p "Would you like to go first? ") + (opponent-move (make-board)) + (computer-move (make-board)))) + +(defun opponent-move (board) + (let* ((pos (read-a-legal-move board)) + (new-board (make-move + *opponent* + pos + board))) + (print-board new-board) + (cond ((winner-p new-board) + (format t "~& You win!")) + ((board-full-p new-board) + (format t "~&Tie game.")) + (t (computer-move new-board))))) + +(defun read-a-legal-move (board) + (format t "~&Your move: ") + (let ((pos (read))) + (cond ((not (and (integerp pos) + (<= 1 pos 9))) + (format t "~&Invalid input.") + (read-a-legal-move board)) + ((not (zerop (nth pos board))) + (format t + "~&That space is already occupied.") + (read-a-legal-move board)) + (t pos)))) + +(defun board-full-p (board) + (not (member 0 board))) + +(defun computer-move (board) + (let* ((best-move (choose-best-move board)) + (pos (first best-move)) + (strategy (second best-move)) + (new-board (make-move + *computer* pos board))) + (format t "~&My move: ~S" pos) + (format t "~&My strategy: ~A~%" strategy) + (print-board new-board) + (cond ((winner-p new-board) + (format t "~&I win!")) + ((board-full-p new-board) + (format t "~&Tie game.")) + (t (opponent-move new-board))))) + +(defun choose-best-move (board) + "First version" + (or (make-three-in-a-row board) + (block-opponent-win board) + (random-move-strategy board))) + +(defun random-move-strategy (board) + (list (pick-random-empty-position board) + "random move")) + +(defun pick-random-empty-position (board) + (let ((pos (+ 1 (random 9)))) + (if (zerop (nth pos board)) + pos + (pick-random-empty-position board)))) + +(defun make-three-in-a-row (board) + (let ((pos (win-or-block board + (* 2 *computer*)))) + (and pos (list pos "make three in a row")))) +(defun block-opponent-win (board) + (let ((pos (win-or-block board + (* 2 *opponent*)))) + (and pos (list pos "block opponent")))) + +(defun win-or-block (board target-sum) + (let ((triplet (find-if + #'(lambda (trip) + (equal (sum-triplet board + trip) + target-sum)) + *triplets*))) + (when triplet + (find-empty-position board triplet)))) + +(defun find-empty-position (board squares) + (find-if #'(lambda (pos) + (zerop (nth pos board))) + squares)) + +;;; Ex 10.8 +;;; a. +;;; Set up a global variable named *CORNERS* to hold a list of the four corner positions. Set up a global variable named *SIDES* to hold a list of the four side squares. +;;; Note that (FIND-EMPTY-POSITION BOARD *SIDES*) will return an empty side square, if there are any. +(setf *corners* '(1 3 7 9)) + +(setf *sides* '(2 4 6 8)) + +(setf *diagonals* '((1 5 9) (3 5 7))) + +;;; b. +;;; Write a function BLOCK-SQUEEZE-PLAY that checks the diagonals for an O-X-O pattern and defends by suggesting a side square as the best move. +;;; Your function should return NIL if there is no squeeze play in progress. +;;; Otherwise, it should return a list containing a move number and a string explaining the strategy behind the move. +;;; Test the function by calling it on a sample board. +(defun block-squeeze-play (board) + (let ((pos (block-squeeze-suggest-play board + (+ (* 2 *opponent*) *computer*)))) + pos)) + +(defun block-squeeze-suggest-play (board target-sum) + (let ((corner (find-if + #'(lambda (diagonal) + (equal (sum-diagonal board diagonal) + target-sum)) + *diagonals*))) + (when corner + (let ((pos (find-empty-side board))) + (and pos (list pos "block squeeze play")))))) + +(defun find-empty-side (board) + (find-if #'(lambda (pos) + (zerop (nth pos board))) + *sides*)) + +;;; c. +;;; Write a function BLOCK-TWO-ON-ONE that checks the diagonals for an O-O-X or X-O-O pattern and defends by suggesting a corner as the best move. +;;; Your function should return NIL if there is no two-on-one threat to which to respond. Otherwise, it should return a list containing a move and a strategy description. +(defun block-two-on-one (board) + (let ((pos (block-two-on-one-play board + (+ (* 2 *opponent*) *computer*)))) + pos)) + +(defun block-two-on-one-play (board target-sum) + (let ((diagonal (find-if + #'(lambda (diagonal) + (equal (sum-diagonal board diagonal) + target-sum)) + *diagonals*))) + (when (diagonal + (let ((pos (find-empty-corner board))) + (and pos (list pos "block two on one play"))))))) + +(defun sum-diagonal (board diagonal) + (+ (nth (first diagonal) board) + (nth (second diagonal) board) + (nth (third diagonal) board))) + +(defun find-empty-corner (board) + (find-if #'(lambda (pos) + (zerop (nth pos board))) + *corners*)) + +;;; Alternative solution for block-squeeze-play and block-two-on-one. +(defun block-squeeze-play (board) + (sq-and-2 board *computer* *sides* 12 + "block squeeze play")) + +(defun sq-and-2 (board player pool v strategy) + (when (equal (nth 5 board) player) + (or (sq-helper board 1 9 v strategy pool) + (sq-helper board 3 7 v strategy pool)))) + +(defun sq-helper (board c1 c2 val strategy pool) + (when (equal val (sum-triplet + board + (list c1 5 c2))) + (let ((pos (find-empty-position + board + (or pool (list c1 c2))))) + (and pos (list pos strategy))))) + +(defun block-two-on-one (board) + (sq-and-2 board *opponent* *corners* 12 + "block two-on-one")) + +;;; d. +;;; Modify the CHOOSE-BEST-MOVE function so that it tries these two defensive strategies before choosing a move at random. +(defun choose-best-move (board) + "First version" + (or (make-three-in-a-row board) + (block-opponent-win board) + (block-squeeze-play board) + (block-two-on-one board) + (random-move-strategy board))) + +;;; e. +;;; If the computer goes first, then after the opponent's first move there may be an opportunity for the computer to set up a squeeze play or two-on-one situation to trap the opponent. +;;; Write functions to check the diagonals and suggest an appropriate attack if the opportunity exists. Modify the CHOOSE-BEST-MOVE function to include these offensive strategies in its list of things to try. +(defun try-squeeze-play (board) + (sq-and-2 board *opponent* nil 11 + "set up a squeeze play")) + +(defun try-two-on-one (board) + (sq-and-2 board *computer* nil 11 + "set up a two-on-one")) + +;;; Ex 10.9 +;;; Write a destructive function CHOP that shortens any non-NIL list to a list of one element. +;;; (CHOP '(FEE FIE FOE FUM)) should return (FEE). +(defun chop (l) + (if (consp l) (setf (cdr l) nil)) + l) + +;;; Ex 10.10 +;;; Write a function NTACK that destructively tacks a symbol onto a list. +;;; (NTACK '(FEE FIE FOE) 'FUM) should return (FEE FIE FOE FUM). +(defun ntack (a b) + (cond ((null a) b) + (t (setf (cdr (last a)) (list b))))) + +;;; Alternative solution: +(defun ntack (a b) + (nconc a (list b))) + + diff --git a/CL-gentle-intro/conditionals.lisp b/CL-gentle-intro/conditionals.lisp new file mode 100644 index 00000000..25944a05 --- /dev/null +++ b/CL-gentle-intro/conditionals.lisp @@ -0,0 +1,177 @@ +;;; Chapter 4 - Conditionals +;; Exercises + +;; Ex 4.1 +; Write a function MAKE-EVEN that makes an odd number even by adding one to it. +; If the input to MAKE-EVEN is already even, it should be returned unchanged. +(defun make-even (n) + (if (evenp n) + n + (1+ n))) + +;; Ex 4.2 +; Write a function FURTHER that makes a positive number larger by adding one to it, and a negative number smaller by subtracting one from it. +; What does the function do if given the number 0. +(defun further (n) + (if (> n 0) + (1+ n) + (1- n))) + +;; Ex 4.3 +; Recall the primitive function NOT: It returns NIL for a true input and T for a false one. Suppose Lisp didn't have a NOT primitive. +; Show how to write NOT using just IF and constants (no other functions). Call the function MY-NOT +(defun my-not (in) + (if (and in t) + t + nil)) + +;; Ex 4.4 +; Write a function ORDERED that takes two numbers as input and makes a list of them in ascending order. +; (ORDERED 4 3) should also return (3 4), in other words, the first and second inputs should appear in reverse order when the first is greater than the second. +(defun ordered (a b) + (if (> a b) + (list b a) + (list a b))) + +;; Ex 4.6 +; Write a version of the absolute value function MY-ABS using COND instead of IF. +(defun my-abs (n) + (cond ((< n 0) (* n -1)) + (t n))) + +;; Ex 4.8 +; Write EMPHASIZE3, which is like EMPHASIZE2 but adds the symbol VERY onto the list if it doesn't know how to emphasize it. +; For example, EMPHASIZE3 of (LONG DAY) should produce (VERY LONG DAY). +; What does EMPHASIZE3 of (VERY LONG DAY) produce? +(defun emphasize2 (x) + (cond ((equal (first x) 'good) (cons 'great (rest x))) + ((equal (first x) 'bad (cons 'awful (rest x)))) + (t x))) + +(defun emphasize3 (x) + (cond ((equal (first x) 'good) (cons 'great (rest x))) + ((equal (first x) 'bad) (cons 'awful (rest x))) + (t (cons 'very x)))) + +;; Ex 4.9 +; What is wrong with this function? Try out the function on the numbers 3, 4 and -2. +; Rewrite it so it works correctly. +(defun make-odd-w (x) + (cond (t x) + ((not (oddp x)) (+ x 1)))) + +(defun make-odd-c (x) + (cond ((oddp x) (+ x 1)) + (t x))) + + +;; Ex 4.10 +; Write a function CONSTRAIN that takes three inputs called X, MAX, and MIN. If X is less than MIN, it should return MIN; if X is greater than MAX, it should return MAX. +; Otherwise, since X is between MIN and MAX, it should return X. (CONSTRAIN 3 -50 50) should return 3. (CONSTRAIN 92 -50 50) should return 50. +; Write one version using COND and another using nested IFs. +(defun constrain-v1 (x max min) + (cond ((> max x) max) + ((< min x) min) + (t x))) + +(defun constrain-v2 (x max min) + (if (> max x) + max) + (if (< min x) + min) + x) + +;; Ex 4.11 +; Write a function FIRSTZERO that takes a list of three numbers as input and returns a word (one of "first," "second," "third," or "none") indicating where the first zero appears in the list. +; Example: (FIRSTZERO '(3 0 4)) should return SECOND. What happens if you try to call FIRSTZERO with three separate numbers instead of a list of three numbers, as in (FIRSTZERO 3 0 4)? +(defun firstzero (l) + (cond ((equal (first l) 0) 'first) + ((equal (second l) 0) 'second) + ((equal (third l) 0) 'third) + (t 'none))) + +;; Ex 4.12 +; Write a function CYCLE that cyclically counts from 1 to 99 . CYCLE called with an input of 1 should return 2, with an input of 2 should return 3, and so on. +; With an input of 99, CYCLE should return 1. That's the cyclical part. Do not try to solve this with 99 COND clauses! +(defun cycle (n) + (cond ((>= n 99) 1) + (t (1+ n)))) + +;; Ex 4.13 +; Write a function HOWCOMPUTE that is the inverse of the COMPUTE function described previously. +; HOWCOMPUTE takes three numbers as inputs and figures out what operation would produce the third from the first two. +; (HOWCOMPUTE 3 4 7) should return SUM-OF. +; (HOWCOMPUTE 3 4 12) should return PRODUCT-OF. +; HOWCOMPUTE should return the list BEATS-ME if it can't find a relationship between the firs two inputs and the third. +(defun howcompute (a b c) + (cond ((eq (+ a b) c) 'sum-of) + ((eq (* a b) c) 'product-of) + (t '(beats me)))) + +;; Ex 4.15 +; Write a predicate called GEQ that returns T if its first input is greater than or equal to its second input. +(defun geq (a b) + (cond ((>= a b) t))) + +;; Ex 4.16 +; Write a function that squares a number if it is odd and positive, doubles it if it is odd and negative, and otherwise divides the number by 2. +(defun fn (n) + (cond ((and (> n 0) (oddp n)) (* n n)) + ((and (< n 0) (oddp n)) (* n 2)) + (t (/ n 2)))) + +;; Ex 4.17 +; Write a predicate that returns T if the first input is either BOY or GIRL and the second input is CHILD, or the first input is either MAN or WOMAN and the second input is ADULT. +(defun fn (a b) + (cond ((and (eq a 'boy) (eq b 'child)) t) + ((and (eq a 'girl) (eq b 'child)) t) + ((and (eq a 'man) (eq b 'adult)) t) + ((and (eq a 'woman) (eq b 'adult)) t))) + +;; Ex 4.18 +; Write a function to act as referee in the Rock-Scissors-Paper game. In this game, each player picks one of Rock, Scissors, or Paper, and then both players tell what they picked. +; Rock "breaks" Scissors, so if the first player picks Rock and the second picks Scissors, the first player wins. +; Scissors "cuts" Paper, and Paper "covers" Rock. If both players pick the same thing, it's a tie. +; The function PLAY should take two inputs, each of which is either ROCK, SCISSORS, or PAPER, and return one of the symbols FIRST-WINS, SECOND-WINS, or TIE. +; Examples: (PLAY 'ROCK 'SCISSORS) should return FIRST-WINS. +; (PLAY 'PAPER 'SCISSORS) should return SECOND-WINS. +(defun play (a b) + (cond ((or (and (eq a 'paper) (eq b 'rock)) + (and (eq a 'rock) (eq b 'scissors)) + (and (eq a 'scissors) (eq b 'paper))) 'first-wins) + ((or (and (eq a 'scissors) (eq b 'rock)) + (and (eq a 'paper) (eq b 'scissors)) + (and (eq a 'rock) (eq b 'paper))) 'second-wins) + ((eq a b) 'tie))) + +;; Ex 4.22 +; Use COND to write a predicate BOILINGP that takes two inputs, TEMP and SCALE, and returns T if the temperature is above the boiling point of water on the specified scale. +; If the scale is FAHRENHEIT, the boiling point is 212 degrees; if CELSIUS, the boiling point is 100 degrees. Also write versions using IF and AND/OR instead of COND. +(defun boilingp (temp scale) + (cond ((or (and (eq scale 'fahrenheit) (> temp 212)) + (and (eq scale 'celsius) (> temp 100))) t))) + +(defun boilingp (temp scale) + (if (or (and (eq scale 'fahrenheit) (> temp 212)) + (and (eq scale 'celsius) (> temp 100))) + t)) + +;; Ex 4.29 +; Write versions of LOGICAL-AND using IF and COND instead of AND. +(defun logical-and (x y) + (and x y t)) + +(defun logical-and (x y) + (cond ((not x) nil) + ((not y) nil) + (t t))) + +(defun logical-and (x y) + (if (not x) nil + (if (not y) nil + t))) + +;; Ex 4.30 +; Write LOGICAL-OR. Make sure it returns only T or NIL for its result. +(defun logical-or (x y) + (not (not (or x y)))) diff --git a/CL-gentle-intro/eval.lisp b/CL-gentle-intro/eval.lisp new file mode 100644 index 00000000..0cbddd17 --- /dev/null +++ b/CL-gentle-intro/eval.lisp @@ -0,0 +1,49 @@ +;;; Chapter 3 - EVAL Notation +;; Exercises + +;; Ex 3.6 +; Define a function PYTHAG that takes two input, x and y, and return the square root of x^2+y^2. +; (PYTHAG 3 4) should return 5.0. +(defun pythag (x y) + (sqrt (+ (* x x) (* y y)))) + +;; Ex 3.11 +; Define a predicate called LONGER-THAN that takes two lists as input and returns T if the first list is longer than the second. +(defun longer-than (a b) + (> (length a) (length b))) + +;; Ex 3.12 +; Write a function ADDLENGTH that takes a list as input and returns a new list with the length of the input added onto the front of it. If the input is (MOO GOO GAI PAN), +; the output should be (4 MOO GOO GAI PAN). +(defun addlength (my-list) + (cons (length my-list) my-list)) + +;; Ex 3.22 d +; Write a predicate FIRSTP that returns T if its first argument (a symbol) is equal to the first element of its second argument (a list). +; That is, (FIRSTP 'FOO '(FOO BAR BAZ)) should return T. +; (FIRSTP 'BOING '(FOO BAR BAZ)) should return NIL. +(defun firstp (s my-list) + (equal s (car my-list))) + +;; Ex 3.22 e +; Write a function MID-ADD1 that adds 1 to the middle element of a three element list. For example, (MID-ADD1 '(TAKE 2 COOKIES)) should return the list (TAKE 3 COOKIES). +; Note: You are not allowed to make MID-ADD1 a function of three inputs. It has to take a single input that is a list of three elements. +(defun mid-add1 (my-list) + (list (first my-list) (+ (second my-list) 1) (third my-list))) + +;; Ex 3.22 f +; Write a function F-TO-C that converts a temperature from Fahrenheit to Celsius. The formula for doing the conversion is: Celsius temperature = [5X(Fahrenheit temperature - 32)]/9. +; To go in the opposite direction, the formula is: Fahrenheit temperature = (9/5X Celsius temperature) + 32. +(defun f-to-c (temp) + (/ (* (- temp 32) 5) 9)) + +;; Ex 3.23 +; Write each of the following functions in Church's lambda notation: DOUBLE, SQUARE, ONEMOREREP +(defun my-double (n) + (* n 2)) + +(defun my-square (n) + (* n n)) + +(defun onemorerep (n) + (1+ n)) diff --git a/CL-gentle-intro/functions-data.lisp b/CL-gentle-intro/functions-data.lisp new file mode 100644 index 00000000..37e1cca5 --- /dev/null +++ b/CL-gentle-intro/functions-data.lisp @@ -0,0 +1,20 @@ +;;;; Ex 1.15 +;;; Write a predicate NOT-ONEP that return T if its input is anything other than one +(defun not-onep (n) + (not (equal n 1))) + + +;;;; Ex 1.16 +;;; Write the predicate NOT-PLUSP that returns T if its input is not greater than zero +(defun not-plusp (n) + (not (> n 0))) + +;;;; Ex 1.17 +;;; Some earlier Lisp dialects did not have the EVENP primitive; they only had ODDP. Show how to define EVENP in terms of ODDP. +(defun my-evenp (n) + (not (oddp n))) + +;;;; Ex 1.20 +;;; Write XOR, the exclusive-or truth function. +(defun xor (n m) + (not (eq (not n) (not m)))) diff --git a/CL-gentle-intro/input-output.lisp b/CL-gentle-intro/input-output.lisp new file mode 100644 index 00000000..3e05b684 --- /dev/null +++ b/CL-gentle-intro/input-output.lisp @@ -0,0 +1,236 @@ +;;; Chapter 9 - Input/Output +;;; Exercises. + +;;; Ex 9.1 +;;; Write a function to print the following saying on the display: "There are old pilots, and there are bold pilots, but there are no old bold pilots." +;;; The function should break up the quotation into several lines. +(defun print-test () + (format t "There are old pilots,~&and there are bold pilots,~&but there are no old bold pilots.~& ")) + +;;; Ex 9.2 +;;; Write a recursive function DRAW-LINE that draws a line of a specified length by doing (FORMAT T "*") the correct number of times. +;;; (DRAW-LINE 10) should produce ********** +(defun draw-line (n) + (labels ((dl-helper (x result) + (cond ((>= x n) (mapcar #'(lambda (x) (format t x)) result)) + (t (dl-helper (+ x 1) (cons "*" result)))))) + (dl-helper 0 nil))) + +(defun draw-line (n) + (cond ((zerop n) (format t "~%")) + (t (format t "*") + (draw-line (- n 1))))) + +;;; Ex 9.3 +;;; Write a recursive function DRAW-BOX that calls DRAW-LINE repeatedly to draw a box of specified dimensions. +;;; (DRAW-BOX 10 4) should produce: + + ********** + ********** + ********** + ********** +(defun draw-box (x y) + (cond ((zerop y) (format t "~%")) + (t (draw-line x) + (format t "~%") + (draw-box x (- y 1))))) + +;;; Ex 9.4 +;;; Write a recursive function NINETY-NINE-BOTTLES that sings the well-known song "Ninety-nine Bottles of Beer on the Wall." The first verse of this song is: +;;; 99 bottles of beer on the wall, +;;; 99 bottles of beer! +;;; Take one down, +;;; Pass it around, +;;; 98 bottles of beer on the wall. +;;; NINETY-NINE-BOTTLES should take a number N as input and start counting from N down to zero. (This is so you can run it on three bottles instead of all ninety nine.) +;;; Your function should also leave a blank line between each verse, and say something appropriate when it runs out of beer. +(defun ninety-nine-bottles (n) + (cond ((zerop n) (format t "~%~S bottles of beer on the wall." n)) + (t (format t "~&~S bottles of beer on the wall," n) + (format t "~&~S bottles of beer!" n) + (format t "~&Take one down,") + (format t "~&Pass it around,") + (ninety-nine-bottles (- n 1))))) + +;;; Ex 9.5 +;;; Part of any tic-tac-toe playing program is a function to display the board. Write a function PRINT-BOARD that takes a list of nine element as input. Each element will be an X, an O, or NIL. PRINT-BOARD should display the corresponding board. +;;; (PRINT-BOARD '(X O O NIL X NIL O NIL X)) should print: + X | O | O + ----------- + | X | + ----------- + O | | X + +(defun repl (a b c) + (cond ((eq a b) c) + (t a))) + +(defun print-board (l) + (cond ((null l) (format t "~%")) + (t (format t "~& ~A | ~A | ~A" + (repl (first l) nil " ") + (repl (second l) nil " ") + (repl (third l) nil " ")) + (if (cdddr l) + (format t "~&-----------")) + (print-board (cdddr l))))) + +(defun print-board (b) + (let ((b2 (sublis '((x . "X") + (o . "O") + (nil . " ")) + b))) + (format t "~&") + (print-line b2) + (format t "-----------~%") + (print-line (nthcdr 3 b2)) + (format t "-----------~%") + (print-line (nthcdr 6 b2)))) + +(defun print-line (line) + (format t " ~A | ~A | ~A~%" + (first line) + (second line) + (third line))) + +;;; Ex 9.6 +;;; Write a function to compute an hourly worker's gross pay given an hourly wage in dollars and the number of hours he or she worked. +;;; Your function should prompt for each input it needs by printing a message in English. It should display its answers in English as well. +(defun gross-pay () + (format t "~&Please enter your hourly wage: ") + (let ((h (read))) + (format t "~&Please enter the working hours: ") + (let ((w (read))) + (format t "~&The gross pay is ~S €." (* h w))))) + +;;; Ex 9.7 +;;; The COOKIE-MONSTER function keeps reading data from the terminal until it reads the symbol COOKIE. +;;; Write COOKIE-MONSTER. Here is a sample interaction: +> (cookie-monster) +Give me cookie!!! +Cookie? rock +No want ROCK... + +Give me cookie!!! +Cookie? cookie +Thank you!...Munch munch munch...BURP +NIL + +(defun cookie-monster () + (format t "~&Give me cookie!!!") + (format t "~&Cookie? ") + (let ((cookie (read))) + (cond ((string-equal cookie "cookie") + (format t "~&Thank you!...Munch munch munch...BURP")) + (t (format t "~&No want ~A..." cookie) + (cookie-monster))))) + +;;; Ex 9.10 +;;; As you write each of the following functions, test it by calling it from top level with appropriate inputs before proceeding on to the next function. +;;; a. +;;; Write a recursive function SPACE-OVER that takes a number N as input and moves the cursor to the right by printing N spaces, one at a time. +;;; SPACE should print "Error!" if N is negative. +;;; Test it by using the function TEST. Try (TEST 5) and (TEST -5). +(defun test (n) + (format t "~%>>>") + (space-over n) + (format t "<<<")) + +(defun space-over (n) + (cond ((zerop n) nil) + ((< n 0) (format t "Error!")) + (t (format t " ") + (space-over (- n 1))))) + +;;; b. +;;; Write a function PLOT-ONE-POINT that takes two inputs PLOTTING-STRING and Y-VAL, prints PLOTTING-STRING (without the quotes) in column Y-VAL, and then moves to a new line. +;;; The leftmost column is numbered zero. +(defun plot-one-point () + (format t "~&Enter plotting string: ") + (let ((plotting-string (read))) + (format t "~&Enter y-val: ") + (let ((y-val (read))) + (space-over y-val) + (format t "~A" plotting-string)))) + +(defun plot-one-point (plotting-string y-val) + (space-over y-val) + (format t "~A~%" plotting-string)) + +;;; c. +;;; Write a function PLOT-POINTS that takes a string and a list of y values as input and plot them. (PLOT-POINTS "<>" '(4 6 8 10 8 6 4)) should print + <> + <> + <> + <> + <> + <> + <> + +(defun plot-points (str l) + (mapcar #'(lambda (x) (plot-one-point str x)) l)) + +;;; d. +;;; Write a function GENERATE that takes two numbers M and N as input and returns a list of the integers from M to N. +;;; (GENERATE -3 3) should return (-3 -2 -1 0 1 2 3). +(defun generate (m n) + (generate-helper m n nil)) + +(defun generate-helper (m n result) + (cond ((> m n) result) + (t (generate-helper (+ m 1) n (append result (list m)))))) + +;;; e. +;;; Write the MAKE-GRAPH function. MAKE-GRAPH should prompt for the values of FUNC, StART, END, and PLOTTING-STRING, and then graph the function. +;;; Note: You can pass FUNC as an input to MAPCAR to generate the list of y values for the function. +(defun make-graph () + (format t "~&Function to graph? ") + (let ((func (read))) + (format t "~&Starting x value? ") + (let ((start (read))) + (format t "~&Ending x value? ") + (let ((end (read))) + (format t "~&Plotting string? ") + (let ((plotting-string (read))) + (plot-points plotting-string + (mapcar #'(lambda (x) (funcall func x)) (generate start end)))))))) + +;;; f. +;;; Define the SQUARE function and graph it over the range -7 to 7. +(defun square (x) + (* x x)) + +;;; Ex 9.11 +;;; Write a function DOT-PRIN1 that takes a list as input and prints it in dot notation. DOT-PRIN1 will print parentheses by (FORMAT T "(") and (FORMAT T ")"), and dots by (FORMAT T " . "), and will call itself recursively to print lists within lists. +;;; DOT-PRIN1 should return NIL as its result. +;;; Try (DOT-PRIN1 '(A (B) C)) and see if your output matches the result in the table above. +;;; Then try (DOT-PRIN1 '((((A))))). +(defun dot-prin1 (l) + (cond ((atom l) (format t "~S" l)) + (t (format t "(") + (dot-prin1 (car l)) + (format t " . ") + (dot-prin1 (cdr l)) + (format t ")")))) + +;;; Ex 9.12 +;;; Write HYBRID-PRIN1. Here is how the function should decide whether to print a dot or not. If the cdr part of the cons cell is a list, HYBRID-PRIN1 continues to print in list notation. +;;; If the cdr part is NIL, HYBRID-PRIN1 should print a right parenthesis. +;;; If the cdr part is something else, such as a symbol, HYBRID-PRIN1 should print a dot, the symbol, and a right parenthesis. +;;; It will be useful to define a subfunction to print cdrs of lists, as these always begin with a space, whereas the cars always begin with a left parenthesis. +(defun hybrid-prin1 (l) + (cond ((atom l) (format t "~S" l)) + (t (hp-car (car l)) + (hp-cdr (cdr l))))) + +(defun hp-car (l) + (format t "(") + (hybrid-prin1 l)) + +(defun hp-cdr (l) + (cond ((null l) (format t ")")) + ((atom l) (format t " . ~S)" l)) + (t (format t " ") + (hybrid-prin1 (car l)) + (hp-cdr (cdr l))))) + diff --git a/CL-gentle-intro/iteration-and-block-structure.lisp b/CL-gentle-intro/iteration-and-block-structure.lisp new file mode 100644 index 00000000..474f7454 --- /dev/null +++ b/CL-gentle-intro/iteration-and-block-structure.lisp @@ -0,0 +1,385 @@ +;;; Chapter 11 - Iteration and Block Structure +;;; Exercises + +;;; Ex 11.1 +;;; Write an iterative version of the MEMBER function, called IT-MEMBER. It should return T if its first input appears in its second input; +;;; It needs not return a sublist of its second input. +(defun it-member (item b) + (dolist (e b) + (when (equal item e) + (return t)))) + +;;; Ex 11.2 +;;; Write an iterative version of ASSOC, called IT-ASSOC. +(defun it-assoc (item x) + (dolist (e x) + (when (equal (car e) item) + (return e)))) + +;;; Ex 11.3 +;;; Write a recursive version of CHECK-ALL-ODD. It should produce the same message and the same result as the preceding iterative version. +;;; Iterative version +(defun check-all-odd (list-of-numbers) + (dolist (e list-of-numbers t) + (format t "~&Checking ~S..." e) + (if (not (oddp e)) (return nil)))) + +;;; Recursive version +(defun check-all-odd (x) + (cond ((null x) t) + ((not (oddp (car x))) nil) + (t (format t "~&Checking ~S..." (car x)) + (check-all-odd (rest x))))) + +;;; Recursive version with unless +(defun check-all-odd (x) + (cond ((null x) t) + (t (format t "~&Checking ~S..." + (first x)) + (unless (evenp (first x)) + (check-all-odd (rest x)))))) + +;;; Ex 11.4 +;;; Write an iterative version of LENGTH, called IT-LENGTH. +(defun it-length (x) + (let ((c 0)) + (dolist (element x c) + (incf c)))) + +;;; Ex 11.5 +;;; Write an iterative version of NTH, called IT-NTH. +(defun it-nth (i x) + (let ((c 0)) + (dolist (element x c) + (if (or (< i 0) (>= i (length x))) (return nil)) + (if (equal c i) + (return element)) + (incf c)))) + +;;; alternative solution +(defun it-nth (n x) + (dotimes (i n (first x)) + (pop x))) + +;;; Ex 11.6 +;;; Write an iterative version of UNION, called IT-UNION. Your function need not return its result in the same order as the built-in UNION function. +(defun it-union (a b) + (let ((l b)) + (dolist (element a) + (if (not (member element l)) + (push element l))) + l)) + +;;; alternative solution +(defun it-union (x y) + (dolist (e x y) + (unless (member e y) + (push e y)))) + +;;; Ex 11.8 +;;; Write an iterative version of REVERSE, called IT-REVERSE. +(defun it-reverse (x) + (let ((l '())) + (dolist (element x l) + (push element l)))) + +;;; Ex 11.9 +;;; Show how to write CHECK-ALL-ODD using DO. +(defun check-all-odd (x) + (do ((my-x x (rest my-x))) + ((null my-x) (return t)) + (if (not (oddp (first my-x))) (return nil)) + (format t "~&Checking ~S..." (first my-x)))) + +;;; Ex 11.10 +;;; Show how to write LAUNCH using DOTIMES. +(defun launch (n) + (dotimes (i n (format t "Blast off!")) + (format t "~S..." (- n i)))) + +;;; 11.11 +;;; Rewrite the following function to use DO* instead of DOLIST. +(defun find-largest (list-of-numbers) + (let ((largest (first list-of-numbers))) + (dolist (element (rest list-of-numbers) largest) + (when (> element largest) + (setf largest element))))) + +(defun find-largest (list-of-numbers) + (do* ((x list-of-numbers (rest x)) + (y (first x) (first x)) + (largest y)) + ((null x) largest) + (when (> y largest) + (setf largest y)))) + +;;; 11.12 +;;; Rewrite the following function to use DO instead of DOTIMES. +(defun power-of-2 (n) + (let ((result 1)) + (dotimes (i n result) + (incf result result)))) + +(defun power-of-2 (n) + (do ((x 0 (+ x 1)) + (result 1)) + ((equal x n) result) + (setf result (incf result result)))) + +;;; alternative solution +(defun power-of-2 (n) + (do ((result 1 (+ result result)) + (i 0 (+ i 1))) + ((equal i n) result))) + +;;; Ex 11.13 +;;; Rewrite the following function using DOLIST instead of DO*. +(defun first-non-integer (x) + "Return the first non-integer element of X." + (do* ((z x (rest z)) + (z1 (first z) (first z))) + ((null z) 'none) + (unless (integerp z1) + (return z1)))) + +(defun first-non-integer (x) + (dolist (e x 'none) + (unless (integerp e) + (return e)))) + +;;; alternative version +(defun first-non-integer (x) + (dolist (e x 'none) + (when (not (integerp e)) + (return e)))) + +;;; Ex 11.15 +;;; corrected version +(defun ffo-with-do (x) + (do* ((z x (rest z)) + (e (first z) (first z))) + ((null z) nil) + (if (oddp e) (return e)))) + +;;; Ex 11.18 +;;; Rewrite the DOTIMES expression using DO. +(defun f () + (dotimes (i 5 i) + (format t "~&I = ~S" i))) + +(defun f () + (do ((i 0 (+ i 1))) + ((equal i 5) i) + (format t "~&I = ~S" i))) + +;;; Ex 11.21 +;;; One way to compute Fib(5) is to start with Fib(0) and Fib(1), which we know to be one, and add them together, giving Fib(2). +;;; Then add Fib(1) and Fib(2) to get Fib(3). Add Fib(2) and Fib(3) to get Fib(4). +;;; Add Fib(3) and Fib(4) to get Fib(5). +;;; This is an iterative method involving no recursion; we merely have to keep around the last two values of Fib to compute the next one. +;;; Write an iterative version of FIB using this technique. +(defun fib (n) + (cond ((or (zerop n) (equal n 1)) 1) + (t (+ (fib (- n 1)) (fib (- n 2)))))) + +(defun fib (n) + (do* ((i n (- i 1)) + (a 0 b) + (b 1 c) + (c 1 (+ a b))) + ((zerop i) a))) + +;;; Ex 11.22 +;;; a. +;;; Write a function COMPLEMENT-BASE that takes a base as input and returns the matching complementary base. +;;; (COMPLEMENT-BASE 'A) should return T; (COMPLEMENT-BASE 'T) should return A; and so on. +(defun complement-base (b) + (cond ((equal b 'a) 't) + ((equal b 'g) 'c) + ((equal b 't) 'a) + ((equal b 'c) 'g))) + +;;; alternative solution +(defun complement-base (base) + (second + (assoc base '((a t) (t a) (g c) (c g))))) + +;;; b. +;;; Write a function COMPLEMENT-STRAND that returns the complementary strand of a sequence of single-stranded DNA. +;;; (COMPLEMENT-STRAND '(A G G T)) should return (T C C A). +(defun complement-strand (s) + (mapcar #'complement-base s)) + +;;; iterative solution +(defun complement-strand (s) + (do ((result nil) + (l s (rest l))) + ((null l) (reverse result)) + (push (complement-base (first l)) result))) + +;;; c. +;;; Write a function MAKE-DOUBLE that takes a single strand of DNA as input and returns a double-stranded version. +;;; We will represent double-stranded DNA by making a list of each base and its complement. +;;; (MAKE-DOUBLE '(G G A C T)) should return ((G C) (G C) (A T) (C G) (T A)). +(defun make-double (strand) + (do ((result nil) + (l strand (rest l))) + ((null l) (reverse result)) + (push (list (first l) + (complement-base (first l))) + result))) + +;;; d. +;;; One of the important clues to DNA's double-stranded nature was the observation that in naturally occuring DNA, whether from people, animals, or plants, the observed percentage of adenine is always very close to that of thymine, while the observed percentage of guanine is very close to that of cytosine. +;;; Write a function COUNT-BASES that counts the number of bases of each type in a DNA strand, and returns the result as a table. +;;; Your function should work for both single- and double-stranded DNA. +;;; Example: (COUNT-BASES '((G C) (A T) (T A) (T A) (C G))) should return ((A 3) (T 3) (G 2) (C 2)), +;;; whereas (COUNT-BASES '(A G T A C T C T)) should return ((A 2) (T 3) (G 1) (C 2)). +;;; In the latter case the percentages are not equal because we are working with only a single strand. +;;; What answer do you get if you apply COUNT-BASES to the corresponding double-stranded sequence? +(defun flatten (x) + (cond ((null x) nil) + ((atom x) (list x)) + (t (append (flatten (first x)) (flatten (rest x)))))) + +(defun count-bases (strand) + (let ((a 0) + (c 0) + (g 0) + (tt 0) + (l (if (listp (first strand)) + (flatten strand) + strand))) + (mapcar #'(lambda (x) + (cond ((equal x 'a) (setf a (+ a 1))) + ((equal x 'c) (setf c (+ c 1))) + ((equal x 'g) (setf g (+ g 1))) + ((equal x 't) (setf tt (+ tt 1))))) + l) + (list + (list 'a a) + (list 'c c) + (list 'g g) + (list 't tt)))) + +;;; Alternative solution +(defun count-bases (dna) + (let ((acnt 0) (tcnt 0) (gcnt 0) (ccnt 0)) + (labels ((count-one-base (base) + (cond ((equal base 'a) (incf acnt)) + ((equal base 't) (incf tcnt)) + ((equal base 'g) (incf gcnt)) + ((equal base 'c) (incf ccnt))))) + (dolist (element dna) + (cond ((atom element) (count-one-base element)) + (t (count-one-base (first element)) + (count-one-base (second element))))) + (list (list 'a acnt) + (list 't tcnt) + (list 'g gcnt) + (list 'c ccnt))))) + +;;; e. +;;; Write a predicate PREFIXP that returns T if one strand of DNA is a prefix of another. +;;; To be a prefix, the elements of the first strand must exactly match the corresponding elements of the second, which may be longer. Example: (G T C) is a prefix of (G T C A T), but not of (A G G T C). +(defun prefixp (s1 s2) + (do ((c1 s1 (rest c1)) + (c2 s2 (rest c2))) + ((null c1) t) + (when (not (equal (first c1) + (first c2))) + (return nil)))) + +;;; f. +;;; Write a predicate APPEARSP that returns T if one DNA strand appears anywhere within another. For example, (C A T) appears in (T C A T G) but not in (T C C G T A). +;;; Hint: If x appears in y, then x is eather a prefix of y, or of (REST y), or of (REST (REST y)), and so on. +(defun appearsp (a b) + (do ((l b (rest l))) + ((null l) nil) + (if (prefixp a l) + (return t)))) + +;;; g. +;;; Write a predicate COVERP that returns T if its first input, repeated some number of times, matches all of its second input. +;;; Example: (A G C) covers (A G C A G C A G C) but not (A G C T T G). +;;; You may assume that neither strand will be null. +(defun coverp (a b) + (do ((l b (subseq l (length a)))) + ((null l) t) + (when (not (prefixp a l)) + (return nil)))) + +;;; alternative solution +(defun coverp (strand1 strand2) + (do* ((len1 (length strand1)) + (s2 strand2 (nthcdr len1 s2))) + ((null s2) t) + (unless (prefixp strand1 s2) + (return nil)))) + +;;; h. +;;; Write a function PREFIX that returns the leftmost N bases of a DNA strand. +;;; (PREFIX 4 '(C G A T T A G)) should return (C G A T). +;;; Do not confuse the function PREFIX with the predicate PREFIXP. +(defun prefix (n l) + (do ((cnt 0 (+ cnt 1)) + (buf l (rest buf)) + (result nil)) + ((equal cnt n) (reverse result)) + (push (first buf) result))) + +;;; alternative solution +(defun prefix (n strand) + (do ((i 0 (+ i 1)) + (res nil (cons (nth i strand) res))) + ((equal i n) (reverse res)))) + +;;; i. +;;; Biologists have found that portions of some naturally occuring DNA strands consist of many repetitions of a short "kernel" sequence. +;;; Write a function KERNEL that returns the shortest prefix of a DNA strand that can be repeated to cover the strand. +;;; (KERNEL '(A G C A G C A G C)) should return (A G C). +;;; (KERNEL '(A A A A A)) should return (A). +;;; (KERNEL '(A G G T C)) should return (A G G T C), because in this case only a single repetition of the entire strand will cover the strand. +;;; Hint: To find the kernel, look at prefixes of increasing length until you find one that can be repeated to cover the strand. +(defun kernel (l) + (do* ((len (length l)) + (cnt 1 (+ cnt 1)) + (pref (prefix cnt l) (prefix cnt l))) + ((equal len cnt) l) + (when (coverp pref l) + (return pref)))) + +;;; alternative solution +(defun kernel (strand) + (do ((i 1 (+ i 1))) + ((coverp (prefix i strand) strand) + (prefix i strand)))) + +;;; j. +;;; Write a function DRAW-DNA that takes a single-stranded DNA sequence as input and draws it along with its complementary strand, as in the diagram at the beginning of this exercise. +(defun draw-helper (c str) + (do ((cnt c) + (n 0 (+ n 1))) + ((equal n cnt) nil) + (format t "~A" str))) + +(defun draw-dna (strand) + (draw-helper (length strand) "-----") + (format t "~&") + (draw-helper (length strand) " ! ") + (format t "~&") + (dolist (element strand) + (format t " ~A " element)) + (format t "~&") + (draw-helper (length strand) " . ") + (format t "~&") + (draw-helper (length strand) " . ") + (format t "~&") + (dolist (element (complement-strand strand)) + (format t " ~A " element)) + (format t "~&") + (draw-helper (length strand) " ! ") + (format t "~&") + (draw-helper (length strand) "-----")) + + diff --git a/CL-gentle-intro/list-data-structures.lisp b/CL-gentle-intro/list-data-structures.lisp new file mode 100644 index 00000000..4c9f14ec --- /dev/null +++ b/CL-gentle-intro/list-data-structures.lisp @@ -0,0 +1,271 @@ +;;; Chapter 6 - List Data Structures +;;; Exercises + +;;; Ex 6.6 +;;; Use the LAST function to write a function called LAST-ELEMENT that returns the last element of a list instead of the last cons cell. +;;; Write another version of LAST-ELEMENT using REVERSE instead of LAST. Write another version using NTH and LENGTH. +(defun last-element (l) + "Returns last element of list version 1" + (car (last l))) + +(defun last-element (l) + "Returns last element of list version 2" + (car (reverse l))) + +(defun last-element (l) + "Returns last element of list version 3" + (nth (- (length l) 1) l)) + +;;; Ex 6.7 +;;; Use REVERSE to write a NEXT-TO-LAST function that returns the next-to-last element of a list. Write another version using NTH. +(defun next-to-last (l) + (cadr (reverse l))) + +(defun next-to-last (l) + (nth (- (length l) 2) l)) + +;;; Ex 6.8 +;;; Write a function MY-BUTLAST that returns a list with the last element removed. +;;; (MY-BUTLAST '(ROSES ARE RED)) should return the list (ROSES ARE). (MY-BUTLAST '(G A G A)) should return (G A G). +(defun my-butlast (l) + (reverse (rest (reverse l)))) + + +;;; Ex 6.9 +;;; What primitive function does the following reduce to? +(defun mystery (x) + (first (last (reverse x)))) +;;; answer: CAR + +;;; Ex 6.10 +;;; A palindrome is a sequence that reads the same forward and backwards. The list (A B C D C B A) is a palindrome; (A B C A B C) is not. +;;; Write a function PALINDROMEP that returns T if its input is a palindrome. +(defun palindromep (l) + (equal l (reverse l))) + +;;; Ex 6.11 +;;; Write a function MAKE-PALINDROME that makes a palindrome out of a list, for example, given (YOU AND ME) as input it should return (YOU AND ME ME AND YOU). +(defun make-palindrome (l) + (append l (reverse l))) + +;;; Ex 6.15 +;;; We can use MEMBER to write a predicate that returns a true value if a sentence contains the word "the." +(defun contains-the-p (sent) + (member 'the sent)) +;;; Suppose we instead want a predicate CONTAINS-ARTICLE-P that returns a true value if a sentence contains any article, such as "the," "a," or "an." Write a version of this predicate using INTERSECTION. +;;; Write another version using MEMBER and OR. Could the problem be solved with AND instead or OR? +(defun contains-article-p (sent) + (intersection '(the a an) sent)) + +(defun contains-article-p (sent) + (or (member 'the sent) (member 'a sent) (member 'an sent))) + +(defun contains-article-p (sent) + (not (and (not (member 'the sent)) + (not (member 'a sent)) + (not (member 'an sent))))) + +;;; Ex 6.18 +;;; Write a function ADD-VOWELS that takes a set of letters as input and adds the vowels (A E I O U) to the set. +;;; For example, calling ADD-VOWELS on the set (X A E Z) should produce the set (X A E Z I O U), except that the exact order of the elements in the result is unimportant. +(defun add-vowels (s) + (union s '(a e i o u))) + +;;; Ex 6.21 +;;; If set x is a subset of set y, then subtracting y from x should leave the empty set. +;;; Write MY-SUBSETP, a version of the SUBSETP predicate that returns T if its first input is a subset of its second input. +(defun my-subsetp (a b) + (not (set-difference a b))) + +;;; Ex 6.24 +;;; Sets are said to be equal if they contain exactly the same elements. +;;; Order does not matter in a set, so the sets (RED BLUE GREEN) and (GREEN BLUE RED) are considered equal. +;;; However, the EQUAL predicate does not consider them equal, because it treats them as lists, not as sets. Write a SET-EQUAL predicate that returns T if two things are equal as sets. +;;; (Hint: If two sets are equal, then each is a subset of the other.) +(defun set-equal (a b) + (and (subsetp a b) (subsetp b a))) + +;;; Ex 6.25 +;;; A set X is a proper subset of a set Y if X is a subset of Y but not equal to Y. +;;; Thus, (A C) is a proper subset of (C A B). (A B C) is a subset of (C A B), but not a proper subset of it. +;;; Write the PROPER-SUBSETP predicate, which returns T if its first input is a proper subset of its second input. +(defun proper-subset (a b) + (and (subsetp a b) (not (subsetp b a)))) + +;;; Ex 6.26 +;;; We are going to write a program that compares the descriptions of two objects and tells how many features they have in common. +;;; The descriptions will be represented as a list of features, with the symbol -VS- separating the first object from the second. +;;; Thus, when given a list like (large red shiny cube -vs- small shiny red four-sided pyramid) +;;; the program will respond with (2 COMMON FEATURES). We will compose this program from several small functions that you will write and test one at a time. +;;; a. +;;; Write a function RIGHT-SIDE that returns all the features to the right of the -VS- symbol. RIGHT-SIDE of the list shown above should return (SMALL SHINY RED FOUR-SIDED PYRAMID). +;;; Test your function to make sure it works correctly. +(defun right-side (o) + (cdr (member '-vs- o))) + +;;; b. +;;; Write a function LEFT-SIDE that returns all the features to the left of the -VS-. You can't use the MEMBER trick directly for this one. +(defun left-side (o) + (cdr (member '-vs- (reverse o)))) + +;;; c. +;;; Write a function COUNT-COMMON that returns the number of features the left and right sides of the input have in common. +(defun count-common (o) + (length (intersection (left-side o) (right-side o)))) + +;;; d. +;;; Write the main function, COMPARE, that takes a list of features describing two objects, with a -VS- between them, and reports the number of features they have in common. +;;; COMPARE should return a list of form (n COMMON FEATURES). +(defun compare (o) + (cons (count-common o) '(common features))) + +;;; Ex 6.30 +;;; Make a table called BOOKS of five books and their authors. The first entry might be (WAR-AND-PEACE LEO-TOLSTOY) +(defvar *books* + '((2666 Roberto-Bolano) + (Crimes-and-Punishments Fedor-Dostoievsky) + (Kolyma-Tales Varlam-Shalamov) + (Valis Philip-K-Dick) + (Politics Aristotle))) + +;;; Ex 6.31 +;;; Write the function WHO-WROTE that takes the name of a book as input and returns the book's author. +(defun who-wrote (b) + (cadr (assoc b *books*))) + +;;; Ex 6.35 +;;; In this problem we will simulate the behaviour of a very simple-minded creature, Nerdus Americanis (also known as Computerus Hackerus). +;;; This creature has only five states: Sleeping, Eating, Waiting-for-a-Computer, Programming, and Debugging. Its behavior is cyclic: After it sleeps it always eats, after it eats it always waits for a computer, and so on, until after debugging it goes back to sleep for a while. +;;; a. Write a data structure for the five-state cycle given above, and store it in a global variable called NERD-STATES. +(defvar NERD-STATES + '(Sleeping Eating Waiting-for-a-computer Programming Debugging)) + +;;; b. Write a function NERDUS that takes the name of a state as input and uses the data structure you designed to determine the next state the creature will be in. +;;; (NERDUS 'SLEEPING) should return EATING, for example. +;;; (NERDUS 'DEBUGGING) should return SLEEPING. +(defun nerdus (s) + (if (eq s 'debugging) + 'sleeping + (cadr (member s nerd-states)))) + +;;; c. What is the result of (NERDUS 'PLAYING-GUITAR)? +NIL + +;;; d. When Nerdus Americanis ingests too many stimulants (caffeine overdose), it stops sleeping. After finishing Debugging, it immediately goes on to state Eating. +;;; Write a function SLEEPLESS-NERD that works just like NERDUS except it never sleeps. +;;; Your function should refer to the global variable NERD-STATES, as NERDUS does. +(defun sleepless-nerd (s) + (let ((n (nerdus s))) + (if (eq n 'sleeping) + 'eating + n))) + +;;; e. Exposing Nerdus Americanis to extreme amounts of chemical stimulants produces pathological behavior. Instead of an orderly advance to its next state, the creature advances two states. +;;; For example, it goes from Eating directly to Programming, and from there to Sleeping. Write a function NERD-ON-CAFFEINE that exhibits this unusual pathology. Your function should use the same table as NERDUS. +(defun nerd-on-caffeine (s) + (cond ((eq s 'programming) 'sleeping) + ((eq s 'debugging) 'eating) + (t (nerdus (nerdus s))))) + +;;; Ex 6.36 +;;; Write a function to swap the first and last element of any list. (SWAP-FIRST-LAST '(YOU CANT BUY LOVE)) should return (LOVE CANT BUY YOU). +(defun swap-first-last (x) + (let* ((f (reverse (rest x))) + (l (reverse (rest f)))) + (cons (first f) (append l (list (first x)))))) + +;;; Ex 6.37 +;;; ROTATE-LEFT and ROTATE-RIGHT are functions that rotate the elements of a list. +;;; (ROTATE-LEFT '(A B C D E)) returns (B C D E A), whereas ROTATE-RIGHT returns (E A B C D). Write these functions. +(defun rotate-left (x) + (append (rest x) (list (first x)))) + +(defun rotate-right (x) + (let* ((l (first (reverse x))) + (r (rest (reverse x)))) + (append (list l) (reverse r)))) + +;;; Ex 6.41 +;;; Table rooms containing layout of the house +(defvar rooms + '((library (east upstairs-bedroom) (south back-stairs)) + (back-stairs (north library) (south downstairs-bedroom)) + (downstairs-bedroom (north back-stairs) (east dinin-room)) + (upstairs-bedroom (west library) (south front-stairs)) + (front-stairs (north upstairs-bedroom) (south living-room)) + (living-room (north front-stairs) (east kitchen) (south dining-room)) + (dining-room (north living-room) (west downstairs-bedroom) (east pantry)) + (kitchen (west living-room) (south pantry)) + (pantry (north kitchen) (west dining-room)))) + +;;; a. +;;; Write a function CHOICES that take the name of a room as input and returns the table of permissible directions Robbie the Robot may take from that room. +;;; For example (CHOICES 'PANTRY) should return the list ((NORTH KITCHEN) (WEST DINING-ROOM)). +;;; Test your function to make sure it returns the correct result. +(defun choices (n) + (rest (assoc n rooms))) + +;;; b. +;;; Write a function LOOK that takes two inputs, a direction and a room, and tells where Robbie would end up if he moved in that direction from that room. For example, (LOOK 'NORTH 'PANTRY) should return KITCHEN. +;;; (LOOK 'SOUTH 'PANTRY) should return NIL. Hint: The CHOICES function will be a useful building block. +(defun look (d r) + (rest (assoc d (choices r)))) + +;;; c. +;;; We will use the global variable LOC to hold Robbie's location. Type in an expression to set his location to be the pantry. The following function should be used whenever you want to change his location. +(defun set-robbie-location (p) + "Moves Robbie to PLACE by setting the variable LOC." + (setf loc p)) + +(set-robbie-location 'pantry) + +;;; d. +;;; Write a function HOW-MANY-CHOICES that tells how many choices Robbie has for where to move to next. Your function should refer to the global variable LOC to find his current location. If he is in the pantry, (HOW-MANY-CHOICES) should return 2. +(defun how-many-choices () + (length (choices loc))) + +;;; e. +;;; Write a predicate UPSTAIRSP that returns T if its input is an upstairs location. (The library and the upstairs bedroom are the only two locations upstairs.) +;;; Write a predicate ONSTAIRSP that returns T if its input is either FRONT-STAIRS or BACK-STAIRS. +(defun upstairsp (l) + (not (not (member l '(library upstairs-bedroom))))) + +(defun onstairsp (l) + (or (equal l 'front-stairs) + (equal l 'back-stairs))) + +;;; f. +;;; Where's Robbie? Write a function of no inputs called WHERE that tells where Robbie is. If he is in the library, (WHERE) should say (ROBBIE IS UPSTAIRS IN THE LIBRARY). If he is in the kitchen, it should say (ROBBIE IS DOWNSTAIRS IN THE KITCHEN). +;;; If he is on the front stairs, it should say (ROBBIE IS ON THE FRONT-STAIRS). +(defun where () + (cond ((upstairsp loc) (append '(robbie is upstairs in the) (list loc))) + ((and (not (upstairsp loc)) + (not (onstairsp loc))) + (append '(robbie is downstairs in the) (list loc))) + ((onstairsp loc) (append '(robbie is on the) (list loc))))) + +;;; g. +;;; Write a function MOVE that takes one input, a direction, and moves Robbie in that direction. MOVE should make use of the LOOK function you wrote previously, and should call SET-ROBBIE-LOCATION to move him. +;;; If Robbie can't move in the specified direction an appropriate message should be returned. +;;; For example, if Robbie is in the pantry, (MOVE 'SOUTH) should return something like (OUCH! ROBBIE HIT A WALL). (MOVE 'NORTH) should change Robbie's location and return (ROBBIE IS DOWNSTAIRS IN THE KITCHEN). +(defun move (d) + (let ((l (look d loc))) + (cond ((not (not l)) + (set-robbie-location (car l)) + (where)) + (t '(ouch! robbie hit a wall))))) + +;;; h. +;;; Starting from the pantry, take Robbie to the library via the back stairs. Then take him to the kitchen, but do not lead him through the downstairs bedroom on the way. +(set-robbie-location 'pantry) +(move 'west) +(move 'west) +(move 'north) +(move 'north) +;;; In the library. +;;; Heading to the kitchen. +(move 'east) +(move 'south) +(move 'south) +(move 'east) +;;; In the kitchen. diff --git a/CL-gentle-intro/lists.lisp b/CL-gentle-intro/lists.lisp new file mode 100644 index 00000000..2c94c699 --- /dev/null +++ b/CL-gentle-intro/lists.lisp @@ -0,0 +1,84 @@ +;;;; CL, Gentle Introduction to symbolic computation +;;; Chap. 2 exercises + +;; Ex 2.8 +; Show how to write MY-THIRD using FIRST ans two RESTs. +(defun my-third (a-list) + (first (rest (rest a-list)))) + +;; Ex 2.9 +; Show how to write MY-THIRD using SECOND. +(defun my-third-b (a-list) + (second (rest a-list))) + +;; Ex 2.13 +; Write the functions to get each word in the list: (((FUN)) (IN THE) (SUN)) +(defun get-first (my-list) + (caaar my-list)) + +(defun get-second-first (my-list) + (caadr my-list)) + +(defun get-second-second (my-list) + (cadadr my-list)) + +(defun get-third (my-list) + (caaddr my-list)) + +;; Ex 2.18 +; Write a function that takes any two inputs and make a list of them using CONS +(defun generate-list (a b) + (cons a (cons b nil))) + +;; Ex 2.21 +; Write a function that takes four inputs and returns a two-element nested list. +; The first element should be a list of the two inputs, and the second element a list of the last two inputs. +(defun my-four-list (a b c d) + (list (list a b) (list c d))) + +;; Ex 2.22 +; Suppose we wanted to make a function called DUO-CONS that added two elements to the front of a list. Remember that the regular CONS function adds only one element to a list. +; DUO-CONS would be a function of three inputs. For example, if the inputs were the symbol PATRICK, the symbol SEYMOUR, and the list (MARVIN), DUO-CONS would return the list (PATRICK SEYMOUR MARVIN). +; Show how to write the DUO-CONS function. +(defun duo-cons (a b alist) + (cons a (cons b alist))) + +;;; Ex 2.23 +;; TWO-DEEPER is a function that surrounds its input with two level of parentheses. +;; TWO-DEEPER of MOO is ((MOO)). TWO-DEEPER of (BOW WOW) is (((BOW WOW))). +;; Show how to write TWO-DEEPER using list. Write another version using CONS. +; LIST version: +(defun two-deeper (el) + (list (list el))) +; CONS version: +(defun two-deeper (el) + (cons (cons el nil) nil)) + +;; Ex 2.24 +; What built-in Lisp function would extract the symbol NIGHT from the list (((GOOD)) ((NIGHT)))? +(caaadr '(((GOOD)) ((NIGHT)))) + +;; Ex 2.29 +; Write a function UNARY-ADD1 that increases a unary number by one. +(defun unary-add1 (n) + (cons 'x n)) + +;; Ex 2.31 +; Write a UNARY-ZEROP predicate +(defun unary-zerop (n) + (eq (length n) 0)) + +;; Ex 2.32 +; Write a UNARY-GREATERP predicate, analogous to the > predicate on ordinary numbers. +(defun unary-greater (n m) + (> (length n) m)) + +;; Ex 2.34 +; Write an expression involving cascaded calls to CONS to construct the dotted list (A B C . D). +(defun my-func () + (cons 'a (cons 'b (cons 'c 'd)))) + +;; Ex 2.35 +; Write an expression to construct this list: ((A . B) (C . D)). +(defun my-cons () + (list (cons 'a 'b) (cons 'c 'd))) diff --git a/CL-gentle-intro/macros-and-compilation.lisp b/CL-gentle-intro/macros-and-compilation.lisp new file mode 100644 index 00000000..bc336d63 --- /dev/null +++ b/CL-gentle-intro/macros-and-compilation.lisp @@ -0,0 +1,250 @@ +;;; Chapter 14 - Macros and Compilation + +;;; Exercises + +;;; Ex 14.3 +;;; Write a SET-NIL macro that sets a variable to NIL. +(defmacro set-nil (var) + (list 'setq var nil)) + +;;; Ex 14.4 +;;; Write a macro called SIMPLE-ROTATEF that switches the value of two variables. +;;; for example, if A is two and B is seven, then (SIMPLE-ROTATEF A B) shoul make A seven and B two. +;;; Obviously, setting A to B first, and then setting B to A won't work. +;;; Your macro should expand into a LET expression that holds on to the original values of the two variables and then assigns them their new values in its body. +(defmacro simple-rotatef (a b) + `(let ((clone-a ,a) + (clone-b ,b)) + (setf ,a clone-b) + (setf ,b clone-a))) + +;;; Ex 14.5 +;;; Write a macro SET-MUTUAL that takes two variable names as input and expands into an expression that sets each variable to the name of the other. +;;; (SET-MUTUAL A B) should set A to 'B, and B to 'A. +(defmacro set-mutual (a b) + `(let ((var-a ',b) + (var-b ',a)) + (setf ,a var-a) + (setf ,b var-b))) + +;;; Ex 14.6 +;;; Write a macro called VARIABLE-CHAIN that accepts any number of inputs. +;;; The expression (VARIABLE-CHAIN A B C D) should expand into an expression that sets A to 'B, B to 'C, and C to 'D. +(defmacro set-zero (&rest vars) + `(progn ,@(mapcar #'(lambda (var) + (list 'setf var 0)) + vars) + '(zeroed ,@vars))) + +(defmacro variable-chain (&rest vars) + `(progn ,@(mapcar #'(lambda (a b) + `(setf ,a ',b)) + vars + (rest vars)) + '(done ,@vars))) + +;;; Alternative solution +(defmacro variable-chain (&rest vars) + `(progn + ,@(do ((v vars (rest v)) + (res nil)) + ((null (rest v)) (reverse res)) + (push `(setf ,(first v) + ',(second v)) + res)))) + +;;; CASE STUDY: Finite State Machines +(defstruct (node (:print-function print-node)) + (name nil) + (inputs nil) + (outputs nil)) + +(defun print-node (node stream depth) + (format stream "#" + (node-name node))) + +(defstruct (arc (:print-function print-arc)) + (from nil) + (to nil) + (label nil) + (action nil)) + +(defun print-arc (arc stream depth) + (format stream "#" + (node-name (arc-from arc)) + (arc-label arc) + (node-name (arc-to arc)))) + +(defvar *nodes*) +(defvar *arcs*) +(defvar *current-node*) + +(defun initialize () + (setf *nodes* nil) + (setf *arcs* nil) + (setf *current-node* nil)) + +(defmacro defnode (name) + `(add-node ', name)) + +(defun add-node (name) + (let ((new-node (make-node :name name))) + (setf *nodes* (nconc *nodes* (list new-node))) + new-node)) + +(defun find-node (name) + (or (find name *nodes* :key #'node-name) + (error "No node named ~A exists." name))) + +(defmacro defarc (from label to &optional action) + `(add-arc ',from ',label ',to ',action)) + +(defun add-arc (from-name label to-name action) + (let* ((from (find-node from-name)) + (to (find-node to-name)) + (new-arc (make-arc :from from + :label label + :to to + :action action))) + (setf *arcs* (nconc *arcs* (list new-arc))) + (setf (node-outputs from) + (nconc (node-outputs from) + (list new-arc))) + (setf (node-inputs to) + (nconc (node-inputs to) + (list new-arc))) + new-arc)) + +(defun fsm (&optional (starting-point 'start)) + (setf *current-node* (find-node starting-point)) + (do () + ((null (node-outputs *current-node*))) + (one-transition))) + +(defun one-transition () + (format t "~&State ~A. Input: " + (node-name *current-node*)) + (let* ((ans (read)) + (arc (find ans + (node-outputs *current-node*) + :key #'arc-label))) + (unless arc + (format t "~&No arc from ~A has label ~A.~%" + (node-name *current-node*) ans) + (return-from one-transition nil)) + (let ((new (arc-to arc))) + (format t "~&~A" (arc-action arc)) + (setf *current-node* new)))) + +(defnode start) +(defnode have-5) +(defnode have-10) +(defnode have-15) +(defnode have-20) +(defnode end) + +(defarc start nickel have-5 "Clunk!") +(defarc start dime have-10 "Clink!") +(defarc start coin-return start "Nothing to return!") + +(defarc have-5 nickel have-10 "Clunk!") +(defarc have-5 dime have-15 "Clink!") +(defarc have-5 coin-return start "Returned five cents.") + +(defarc have-10 nickel have-15 "Clunk!") +(defarc have-10 dime have-20 "Clink!") +(defarc have-10 coin-return start "Returned ten cents.") + +(defarc have-15 nickel have-20 "Clunk!") +(defarc have-15 dime have-20 "Nickel change.") +(defarc have-15 gum-button end "Deliver gum.") +(defarc have-15 coin-return start "Returned fifteen cents.") + +(defarc have-20 nickel have-20 "Nickel returned.") +(defarc have-20 dime have-20 "Dime returned.") +(defarc have-20 gum-button end "Deliver gum, nickel change.") + +(defarc have-20 mint-button end "Deliver mints.") +(defarc have-20 coin-return start "Returned twenty cents.") + +;;; Ex 14.7 +;;; Extend the vending machine example to sell chocolate bars for 25 cents. +;;; Make it accept quarters as well as nickels and dimes. +;;; When you put in a quarter it should go "Ker-chunck!" + +(defnode have-25) +(defnode have-30) +(defnode have-35) +(defarc start quarter have-25 "Ker-chunck!") +(defarc have-5 quarter have-30 "Ker-chunck!") +(defarc have-10 quarter have-35 "Ker-chunck!") + +(defarc have-25 choc-button end "Deliver chocolate.") +(defarc have-30 choc-button end "Deliver chocolate, nickel change.") +(defarc have-35 choc-button end "Deliver chocolate, dime change.") + +(defarc have-25 coin-return start "Returned twenty five cents.") +(defarc have-30 coin-return start "Returned thirty cents.") +(defarc have-35 coin-return start "Returned thirty five cents.") + +;;; Ex 14.11 +;;; In this keyboard exercise we will write a compiler for finite state machines that turns each node into a function. +;;; The definition of the vending machine's nodes and arcs should already be loaded into your Lisp before beginning the exercise. + +;;; a. +;;; Write a function COMPILE-ARC that takes an arc as input and returns a COND clause, following the example shown previously. +;;; Test your function on some of the elements in the list *ARCS*. +;;; (COMPILE-ARC (FIRST *ARCS*)) should return this list: +((equal this-input 'nickel) + (format t "~&~A" "Clunk!") + (have-5 (rest input-syms))) + +(defun compile-arc (arc) + `((equal this-input ',(arc-label arc)) + (format t "~&~A" ,(arc-action arc)) + (,(node-name (arc-to arc)) (rest input-syms)))) + +;;; b. +;;; Write a function COMPILE-NODE that takes a node as input and returns a DEFUN expression for that node. +;;; (COMPILE-NODE (FIND-NODE 'START)) should return the DEFUN shown previously. +(defun compile-node (node) + `(defun ,(node-name node) (input-syms + &aux (this-input (first input-syms))) + (cond ((null input-syms) ',(node-name node)) + ,@(cn-helper node) + (t (format t "No arc for ~A with label ~A." + ',(node-name node) this-input))))) + +(defun cn-helper (node) + (do ((result nil) + (arcs (node-outputs node) (rest arcs))) + ((null arcs) result) + (setf result + (cons (compile-arc (first arcs)) result)))) + +;;; Book's solution +(defun compile-node (node) + (let ((name (node-name node)) + (arc-clauses + (mapcar #'compile-arc + (node-outputs node)))) + `(defun ,name (input-syms + &aux (this-input + (first input-syms))) + (cond ((null input-syms) ',name) + ,@arc-clauses + (t (format t + "~&There is no arc from ~A with label ~S" + ',name this-input)))))) +;;; c. +;;; Write a macro COMPILE-MACHINE that expands into a PROGN containing a DEFUN for each node in *NODES*. +(defmacro compile-machine () + `(progn ,@(mapcar #'compile-node *nodes*))) + +;;; d. +;;; Compile the vending machine. What does the expression (START '(DIME DIME DIME GUM-BUTTO)) produce? +Clink! +Clink! +Dime returned. +Deliver gum, nickel change. +End diff --git a/CL-gentle-intro/recursion.lisp b/CL-gentle-intro/recursion.lisp new file mode 100644 index 00000000..93de5a7c --- /dev/null +++ b/CL-gentle-intro/recursion.lisp @@ -0,0 +1,755 @@ +;;; Chapter 8 - Recursion +;;; Exercises + +;;; Ex 8.2 +;;; Show how to write ANYODDP using IF instead of COND +(defun anyoddp (x) + (cond ((null x) nil) + ((oddp (first x)) t) + (t (anyoddp (rest x))))) + +(defun anyoddp (x) + (if (null x) + nil + (if (oddp (first x)) + t + (anyoddp (rest x))))) + +(defun fact (n) + (cond ((zerop n) 1) + (t (* n (fact (- n 1)))))) + +;;; Ex 8.4 +;;; We are going to write a function called LAUGH that takes a number as input and returns a list of that many HAs. +;;; (LAUGH 3) should return the list (HA HA HA). (LAUGH 0) should return a list with no HAs in it. +(defun laugh (n) + (cond ((or (zerop n) (< n 0)) nil) + (t (cons 'ha (laugh (- n 1)))))) + + +;;; Ex 8.5 +;;; In this exercise we are going to write a function ADD-UP to add up all the numbers in a list. (ADD-UP '(2 3 7)) should return 12. +;;; You already known how to solve this problem applicatively with REDUCE; now you'll learn to solve it recursively. +;;; Write down the complete definition of ADD-UP. Type it into the computer and then try adding up a list of numbers. +(defun add-up (l) + (cond ((null l) 0) + (t (+ (first l) (add-up (rest l)))))) + +;;; Ex 8.6 +;;; Write ALLODDP, a recursive function that returns T if all the numbers in a list are odd. +(defun alloddp (l) + (cond ((or (null l)) t) + (t (and (oddp (first l)) (alloddp (rest l)))))) + +;;; Ex 8.7 +;;; Write a recursive version of MEMBER. Call it REC-MEMBER so you don't redefine the built-in MEMBER function. +(defun rec-member (n l) + (cond ((null l) nil) + (t (if (eq n (first l)) + (append l (rec-member n nil)) + (rec-member n (rest l)))))) + +;;; Ex 8.8 +;;; Write a recursive version of ASSOC. Call it REC-ASSOC. +(defun rec-assoc (n l) + (cond ((null l) nil) + (t (if (eq n (caar l)) + (append (car l) (rec-assoc n nil)) + (rec-assoc n (rest l)))))) + +;;; Ex 8.9 +;;; Write a recursive function of NTH. Call it REC-NTH. +(defun rec-nth (n l) + (cond ((or (null l) (< n 0)) nil) + (t (if (zerop n) + (first l) + (rec-nth (- n 1) (rest l)))))) + +;;; Ex 8.10 +;;; For x a nonnegative integer and y a positive integer, x+y equals x+1+(y-1). If y is zero then x+y equals x. Use these equations to build a recursive version of + called REC-PLUS out of ADD1, SUB1, COND and ZEROP. +;;; You'll have to write ADD1 and SUB1 too. +(defun add1 (x) + (+ x 1)) + +(defun subb1 (x) + (- x 1)) + +(defun rec-plus (x y) + (cond ((zerop y) x) + (t (rec-plus (add1 x) (subb1 y))))) + +;;; Ex 8.11 +;;; The missing part of Martin's Fibonacci algorithm is the rule for Fib(1) and Fib(0). both of these are defined to be 1. +;;; Using this information, write a correct version of the FIB function. (FIB 4) should return five. (FIB 5) should return eight. +(defun fib (n) + (if (or (zerop n) (eq n 1)) + 1 + (+ (fib (- n 1)) (fib (- n 2))))) + +;;; Ex 8.17 +;;; Use double-test tail recursion to write FIND-FIRST-ODD, a function that returns the first odd number in a list, or NIL if there are none. Start by copying the recursion template values for ANYODDP; only a small change is necessary to derive FIND-FIRST-ODD. +(defun anyoddp (x) + (cond ((null x) nil) + ((oddp (first x)) t) + (t (anyoddp (rest x))))) + +(defun find-first-odd (x) + (cond ((null x) nil) + ((oddp (first x)) (first x)) + (t (find-first-odd (rest x))))) + +;;; Ex 8.18 +;;; Use single-test tail recursion to write LAST-ELEMENT, a function that returns the last element of a list. +;;; LAST-ELEMENT should recursively travel down the list until it reaches the last cons cell (a cell whose cdr is an atom); then it should return the car of this cell. +(defun last-element (x) + (cond ((atom (cdr x)) (car x)) + (t (last-element (rest x))))) + + +;;; Ex 8.21 +;;; Write a recursive function ADD-NUMS that add up the numbers N, N-1, N-2 and so on, down to 0, and returns the result. +;;; For example, (ADD-NUMS 5) should compute 5+4+3+2+1+0, which is 15. +(defun add-nums (x) + (cond ((zerop x) 0) + (t (+ x (add-nums (- x 1)))))) + +;;; Ex 8.22 +;;; Write a recursive function ALL-EQUAL that returns T if the first element of a list is equal to the second, the second is equal to the third, the third is equal to the fourth, and so on. (ALL-EQUAL '(I I I I)) shoul return T. +;;; (ALL-EQUAL '(I I E I)) should return NIL. ALL-EQUAL should return T for lists with less than two elements. +(defun all-equal (l) + (cond ((atom (cdr l)) t) + (t (and (eq (first l) (second l)) (all-equal (rest l)))))) + +;;; Ex 8.24 +;;; Write COUNT-DOWN, a function that counts down from n using list-counsing recursion. +;;; (COUNT-DOWN 5) should produce the list (5 4 3 2 1). +(defun count-down (n) + (cond ((zerop n) nil) + (t (cons n (count-down (- n 1)))))) + +;;; Ex 8.25 +;;; How could COUNT-DOWN be used to write an applicative version of FACT? +(defun fact (n) + (cond ((zerop n) 1) + (t (* n (fact (- n 1)))))) + +(defun fact (n) + (reduce #'(lambda (x y) (* x y)) + (count-down n))) + +;;; Ex 8.26 +;;; Suppose we wanted to modify COUNT-DOWN so that the list it constructs ends in zero. +;;; For example, (COUNT-DOWN 5) would produce (5 4 3 2 1 0). Show two ways this can be done. +(defun count-down (n) + (cond ((zerop n) (cons n nil)) + (t (cons n (count-down (- n 1)))))) + +(defun count-down (n) + (cond ((zerop n) (list n)) + (t (cons n (count-down (- n 1)))))) + +;;; Ex 8.27 +;;; Write SQUARE-LIST, a recursive function that takes a list of numbers as input and returns a list of their squares. (SQUARE-LIST '(3 4 5 6)) should return (9 16 25 36). +(defun square-list (l) + (cond ((null l) nil) + (t (cons (* (car l) (car l)) (square-list (rest l)))))) + +;;; Ex 8.27 +;;; The expressions (MY-NTH 5 '(A B C)) and (MY-NTH 1000 '(A B C)) both run off the end of the list, and hence produce a NIL result. +;;; Yet the second expression takes quite a bit longer to execute than the first. +;;; Modify MY-NTH so that the recursion stops as soon the function runs off the end of the list. +(defun my-nth (n x) + (cond ((zerop n) (first x)) + (t (my-nth (- n 1) (rest x))))) + +(defun my-nth (n x) + (cond ((or (zerop n) (atom (cdr x))) (first x)) + (t (my-nth (- n 1) (rest x))))) + +;;; Ex 8.29 +;;; Write MY-MEMBER, a recursive version of MEMBER. This function will take two inputs, but you will only want to reduce one of them with each successive call. +;;; The other should remain unchanged. +(defun my-member (x l) + (cond ((null l) nil) + ((eq (first l) x) l) + (t (my-member x (rest l))))) + +;;; Ex 8.30 +;;; Write MY-ASSOC, a recursive version of ASSOC. +(defun my-assoc (x l) + (cond ((null l) nil) + ((member x (first l)) (first l)) + (t (my-assoc x (rest l))))) + +;;; Ex 8.31 +;;; Suppose we want to tell as quickly as possible whether one list is shorter than another. If one list has five elements and the other has a million, we don't want to have to go through all one million cons cells before deciding that the second list is longer. +;;; So we must not call LENGTH on the two lists. Write a recursive function COMPARE-LENGTH that takes two lists as input and returns one of the following symbols: +;;; SAME-LENGTH, FIRST-IS-LONGER, or SECOND-IS-LONGER. +;;; Use triple-test simultanous recursion. +(defun compare-length (m n) + (cond ((and (null m) (null n)) 'same-length) + ((null m) 'second-is-longer) + ((null n) 'first-is-longer) + (t (compare-length (rest m) (rest n))))) + +;;; Ex 8.32 +;;; Write the function SUM-NUMERIC-ELEMENTS, which adds up all the numbers in a list and ignores the non-numbers. (SUM-NUMERIC-ELEMENTS '(3 BEARS 3 BOWLS AND 1 GIRL)) should return seven. +(defun sum-numeric-elements (l) + (cond ((null l) 0) + ((numberp (first l)) (+ (first l) (sum-numeric-elements (rest l)))) + (t (sum-numeric-elements (rest l))))) + +;;; Ex 8.33 +;;; Write MY-REMOVE, a recursive version of the REMOVE function. +(defun my-remove (s l) + (cond ((null l) nil) + ((eq s (first l)) (my-remove s (rest l))) + (t (cons (first l) (my-remove s (rest l)))))) + +;;; Ex 8.34 +;;; Write MY-INTERSECTION, a recursive version of the INTERSECTION function. +(defun my-intersection (a b) + (cond ((or (null a) (null b)) nil) + ((member (first a) b) + (cons (first a) + (my-intersection (rest a) (remove (first a) b)))) + (t (my-intersection (rest a) b)))) + +;;; Ex 8.35 +;;; Write MY-SET-DIFFERENCE, a recursive version of the SET-DIFFERENCE function. +(defun my-set-difference (a b) + (cond ((or (null a) (null b)) nil) + ((not (member (first a) b)) + (cons (first a) + (my-set-difference (rest a) (remove (first a) b)))) + (t (my-set-difference (rest a) b)))) + +;;; Ex 8.36 +;;; The function COUNT-ODD counts the number of odd elements in a list of numbers; for example, (COUNT-ODD '(4 5 6 7 8)) should return two. +;;; Show how to write COUNT-ODD using conditional augmentation. +;;; Then write another version of COUNT-ODD using the regular augmenting recursion template. +(defun count-odd (l) + (cond ((null l) 0) + ((oddp (first l)) (+ 1 (count-odd (rest l)))) + (t (count-odd (rest l))))) + +(defun count-odd (l) + (cond ((null l) 0) + (t (+ (if (oddp (first l)) 1 0) (count-odd (rest l)))))) + +;;; Ex 8.37 +;;; Define a simple function COMBINE that takes two numbers as input and returns their sum. Now replace the occurence of + in FIB with COMBINE. Trace FIB and COMBINE. Trace FIB and COMBINE, and try evaluating (FIB 3) or (FIB 4). What can you say about the relationship between COMBINE, terminal calls, and nonterminal calls? +(defun combine (a b) + (+ a b)) + +(defun fib (n) + (cond ((equal n 0) 1) + ((equal n 1) 1) + (t (combine (fib (- n 1)) (fib (- n 2)))))) + +(defun fib (n) + (cond ((equal n 0) 1) + ((equal n 1) 1) + (t (+ (fib (- n 1)) (fib (- n 2)))))) + +;;; Ex 8.39 +;;; Write a function COUNT-ATOMS that returns the number of atoms in a tree. +;;; (COUNT-ATOMS '(A (B) C)) should return five, since in addition to A, B, and C there are two NILS in the tree. +(defun count-atoms (l) + (cond ((atom l) 1) + (t (+ (count-atoms (car l)) (count-atoms (cdr l)))))) + +;;; Ex 8.40 +;;; Write COUNT-CONS, a function that returns the number of cons cells in a tree. +;;; (COUNT-CONS '(FOO)) should return one. (COUNT-CONS '(FOO BAR)) should return two. (COUNT-CONS '((FOO))) should also return two, since the list ((FOO)) requires two cons cells. +;;; (COUNT-CONS 'FRED) should return zero. +(defun count-cons (l) + (cond ((atom l) 0) + (t (+ 1 (count-cons (car l)) (count-cons (cdr l)))))) + +;;; Ex 8.41 +;;; write a function SUM-TREE that returns the sum of all the numbers appearing in a tree. Nonnumbers should be ignored. +;;; (SUM-TREE '((3 BEARS) (3 BOWLS) (1 GIRL))) should return seven. +(defun sum-tree (l) + (cond ((or (null l) (symbolp l)) 0) + ((numberp l) l) + (t (+ (sum-tree (car l)) (sum-tree (cdr l)))))) + +;;; Ex 8.42 +;;; Write MY-SUBST, a recursive version of the SUBST function. +(defun my-subst (n o l) + (cond ((eq l o) n) + ((atom l) l) + (t (cons (my-subst n o (car l)) (my-subst n o (cdr l)))))) + +;;; Ex 8.43 +;;; Write FLATTEN, a function that returns all the element of an arbitrarily nested list in a single-level list. +;;; (FLATTEN '((A B (R)) A C (A D ((A (B)) R) A))) should return (A B R A C A D A B R A). +(defun flatten (l) + (cond ((null l) nil) + ((atom l) (list l)) + (t (append (flatten (car l)) (flatten (cdr l)))))) + +;;; Ex 8.44 +;;; Write a function TREE-DEPTH that returns the maximum depth of a binary tree. +;;; (TREE-DEPTH '(A . B)) should return one. +;;; (TREE-DEPTH '((A B C D))) should return five and (TREE-DEPTH '((A . B).(C . D))) should return two. +(defun tree-depth (l) + (cond ((atom l) 0) + (t (+ 1 (max (tree-depth (car l)) (tree-depth (cdr l))))))) + +;;; Ex 8.45 +;;; Write a function PAREN-DEPTH that returns the maximum depth of nested parentheses in a list. (PAREN-DEPTH '(A B C)) should return one, whereas TREE-DEPTH would return three. +;;; (PAREN-DEPTH '(A B ((C) D) E)) should return three, since there is an element C that is nested in three level of parentheses. +(defun paren-depth (l) + (cond ((atom l) 0) + (t (max (+ 1 (paren-depth (car l))) (paren-depth (cdr l)))))) + +;;; Ex 8.46 +;;; Another way to solve the problem of counting upward is to add an element to the end of the list with each recursive call instead of adding elements at the beginning. +;;; This approach doesn't require a helping function. Write this version of COUNT-UP. +(defun count-up (n) + (count-up-recursively 1 n)) + +(defun count-up-recursively (cnt n) + (cond ((> cnt n) nil) + (t (cons cnt + (count-up-recursively + (+ cnt 1) n))))) + +(defun count-up (n) + (cond ((zerop n) nil) + (t (append (count-up (- n 1)) (list n))))) + +;;; Ex 8.47 +;;; Write MAKE-LOAF, a function that returns a loaf of size N. +;;; (MAKE-LOAF 4) should return (X X X X). Use IF instead of COND. +(defun make-loaf (n) + (if (zerop n) + nil + (append (make-loaf (- n 1)) (list 'X)))) + +;;; Ex 8.48 +;;; Write a recursive function BURY that buries an item under n levels of parentheses. (BURY 'FRED 2) should return ((FRED)), while (BURY 'FRED 5) should return (((((FRED))))). +;;; Which recursion template did you use? +(defun bury (s n) + (cond ((zerop n) s) + (t (bury (list s) (- n 1))))) + +;;; Ex 8.49 +;;; Write PAIRING, a function that pairs the elements of two lists. +;;; (PAIRING '(A B C) '(1 2 3)) should return ((A 1) (B 2) (C 3)). +;;; You may assume that the two lists will be of equal length. +(defun pairing (a b) + (cond ((null a) nil) + (t (cons (list (first a) (first b)) + (pairing (rest a) (rest b)))))) + +;;; Ex 8.50 +;;; Write SUBLISTS, a function that returns the successive sublist of a list. +;;; (SUBLIST '(FEE FIE FOE)) should return ((FEE FIE FOE) (FIE FOE) (FOE)). +(defun sublists (l) + (cond ((null l) nil) + (t (cons l (sublists (rest l)))))) + +;;; Ex 8.51 +;;; The simplest way to write MY-REVERSE, a recursive version of REVERSE, is with a helping function plus a recursive function of two inputs. +;;; Write this version of MY-REVERSE. +(defun my-reverse (l) + (cond ((null l) nil) + (t (append (last l) (my-reverse (butlast l)))))) + +;;; Ex 8.52 +;;; Write MY-UNION, a recursive version of UNION. +(defun my-union (a b) + (cond ((null a) b) + (t (append (list (first a)) + (my-union (rest a) + (remove (first a) b)))))) + +;;; Ex 8.53 +;;; Write LARGEST-EVEN, a recursive function that returns the largest even number in a list of nonnegative integers. +;;; (LARGEST-EVEN '(5 2 4 3)) should return four. +;;; (LARGEST-EVEN NIL) should return zero. +;;; Use the built-in MAX function, which returns the largest of its inputs. +(defun largest-even (l) + (cond ((null l) 0) + (t (max (if (evenp (first l)) + (first l) 0) + (largest-even + (rest l)))))) + +;;; Ex 8.54 +;;; Write a recursive function HUGE that raises a number to its own power. (HUGE 2) shoul return 4, (HUGE 3) should return 27, and so on. +;;; Do not use REDUCE. +(defun huge-helper (x n) + (cond ((zerop n) 1) + (t (* x (huge-helper x (- n 1)))))) + +(defun huge (n) + (huge-helper n n)) + +;;; Ex 8.56 +;;; Write EVERY-OTHER, a recursive function that returns every other element of a list--the first, third, fifth, and so on. +;;; (EVERY-OTHER '(A B C D E F G)) should return (A C E G). +;;; (EVERY-OTHER '(I CAME I SAW I CONQUERED)) should return (I I I). +(defun every-other-helper (n l) + (cond ((null l) nil) + (t (append (if (oddp n) + (list (first l)) + nil) + (every-other-helper (+ n 1) (rest l)))))) + +(defun every-other (l) + (every-other-helper 1 l)) + +;;; Ex 8.57 +;;; Write LEFT-HALF, a recursive function in two parts that returns the first n/2 element of a list of length n. +;;; (LEFT-HALF '(A B C D E)) should return (A B C). +;;; (LEFT-HALF '(1 2 3 4 5 6 7 8)) should return (1 2 3 4). +;;; You may use LENGTH but not REVERSE in your definition. +(defun left-half-helper (n l) + (cond ((zerop n) (list (first l))) + (t (append (list (first l)) + (left-half-helper (- n 1) (rest l)))))) + +(defun left-half (l) + (left-half-helper (round (/ (length l) 2)) l)) + +;;; Ex 8.58 +;;; Write MERGE-LISTS, a function that takes two lists of numbers, each in increasing order, as input. The function should return a list that is a merger of the elements in its inputs, in order. +;;; (MERGE-LISTS '(1 2 6 8 10 12) '(2 3 5 9 13)) should return (1 2 2 3 5 6 8 9 10 12 13). +(defun merge-lists (a b) + (cond ((null a) b) + ((null b) a) + ((and (null a) (null b) nil)) + (t (append (if (> (first a) (first b)) + (list (first b) (first a)) + (list (first a) (first b))) + (merge-lists (rest a) (rest b)))))) + +;;; Ex 8.60 +;;; Each person in the database is represented by an entry of form +;;; (name father mother). +;;; When someone's father or mother is unknown, a value of NIL is used. +(setf family + '((colin nil nil) (deirdre nil nil) (arthur nil nil) + (kate nil nil) (frank nil nil) (linda nil nil) + (suzanne colin deirdre) (bruce arthur kate) (charles arthur kate) + (david arthur kate) (ellen arthur kate) (george frank linda) + (hillary frank linda) (andre nil nil) (tamara bruce suzanne) + (vincent bruce suzanne) (wanda nil nil) (ivan george ellen) + (julie george ellen) (marie george ellen) (nigel andre hillary) + (frederick nil tamara) (zelda vincent wanda) (joshua ivan wanda) + (quentin nil nil) (robert quentin julie) (olivia nigel marie) + (peter nigel marie) (erica nil nil) (yvette robert zelda) + (diane peter erica))) + +;;; a. +;;; Write the functions FATHER, MOTHER, PARENTS, and CHILDREN that returns a person's father, mother, a list of his or her known parents, and a list of his or her children, respectively. +;;; (FATHER 'SUZANNE) should return COLIN. +;;; (PARENTS 'SUZANNE) should return (COLIN DEIRDRE). +;;; (PARENTS 'FREDERICK) should return (TAMARA), since Frederick's father is unknown. (CHILDREN 'ARTHUR) should return the set (BRUCE CHARLES DAVID ELLEN). +;;; If any of these functions is given NIL as input, it should return NIL. +;;; This feature will be useful later when we write some recursive functions. +(defun father (n) + (cadr (find-if #'(lambda (m) + (eq (car m) n)) + family))) + +(defun father (n) + (cadr (assoc n family))) + +(defun mother (n) + (caddr (find-if #'(lambda (m) + (eq (car m) n)) + family))) + +(defun mother (n) + (caddr (assoc n family))) + +(defun parents (n) + (remove nil (cdr (find-if #'(lambda (m) + (eq (car m) n)) + family)))) + +(defun parents (n) + (set-difference + (assoc n family) + (list n))) + +(defun children (n) + (mapcar #'(lambda (p) + (car p)) + (remove-if-not #'(lambda (m) + (or (eq (cadr m) n) (eq (caddr m) n))) + family))) + +;;; b. +;;; Write SIBLINGS, a function that returns a list of a person's siblings, including genetic half-siblings. +;;; (SIBLINGS 'BRUCE) should return (CHARLES DAVID ELLEN). +;;; (SIBLINGS 'ZELDA) should return (JOSHUA). +(defun list-fathers-helper (f) + (cond ((null f) nil) + (t (append (if (null (cadr (first f))) + nil + (list (cadr (first f)))) + (list-fathers-helper (rest f)))))) + +(defun list-fathers (f) + (remove-duplicates (list-fathers-helper f))) + +(defun list-mothers-helper (f) + (cond ((null f) nil) + (t (append (if (null (caddr (first f))) + nil + (list (caddr (first f)))) + (list-mothers-helper (rest f)))))) + +(defun list-mothers (f) + (remove-duplicates (list-mothers-helper f))) + +(defun list-parents (f) + (union (list-fathers f) (list-mothers f))) + +(defun siblings (n) + (remove n (assoc n + (remove-if-not #'(lambda (x) + (> (length x) 1)) + (mapcar #'children + (list-parents family)))))) + + +;;; simpler solution for siblings +(defun siblings (x) + (set-difference (union (children (father x)) + (children (mother x))) + (list x))) + +;;; c. +;;; Write MAPUNION, an applicative operator that takes a function and a list as input, applies the function to every element of the list, and computes the union of all the results. +;;; An example is (MAPUNION #'REST '((1 A B C) (2 E C J) (3 F A B C D))), which should return the set (A B C E J F D). Hint: MAPUNION can be defined as a combination of two applicative operators you already know. +(defun mapunion (fn l) + (reduce #'(lambda (x y) + (union x y)) + (mapcar #'(lambda (x) (funcall fn x)) l))) + +;;; d. +;;; Write GRANDPARENTS, a function that returns the set of a person's grandparents. Use MAPUNION in your solution. +(defun grandparents (fn n) + (mapunion fn (funcall fn n))) + +;;; e. +;;; Write COUSINS, a function that returns the set of a person's genetically related first cousins, in other words, the children of any of their parents' siblings. +;;; (COUSINS 'JULIE) should return the set (TAMARA VINCENT NIGEL). +;;; Use MAPUNION in your solution. +(defun cousins (n) + (mapunion #'children + (mapunion #'siblings + (parents n)))) + +;;; f. +;;; Write the two-input recursive predicate DESCENDED-FROM that returns a true value if the first person is descended from the second. +;;; (DESCENDED-FROM 'TAMARA 'ARTHUR) should return T. (DESCENDED-FROM 'TAMARA 'LINDA) should return NIL. +;;; (Hint: You are descended from someone if he is one of your parents, or if either your father or mother is descended from him. This is a recursive definition.) +(defun descended-from (n m) + (cond ((null (parents n)) nil) + ((not (null (member m (parents n)))) t) + (t (or (descended-from (father n) m) (descended-from (mother n) m))))) + +;;; g. +;;; Write the recursive function ANCESTORS that returns a person's set of ancestors. (ANCESTORS 'MARIE) should return the set (ELLEN ARTHUR KATE GEORGE FRANK LINDA). +;;; (Hint: A person's ancestors are his parents plus his parents' ancestors. This is a recursive definition.) +(defun ancestors (n) + (cond ((null (parents n)) nil) + (t (append (parents n) (parents (father n)) (parents (mother n)))))) + +;;; h. +;;; Write the recursive function GENERATION-GAP that returns the number of generations separating a person and one of his or her ancestors. +;;; (GENERATION-GAP 'SUZANNE 'COLIN) should return one. +;;; (GENERATION-GAP 'FREDERICK 'COLIN) should return three. +;;; (GENERATION-GAP 'SUZANNE 'LINDA) should return NIL, because Linda is not an ancestor of Frederick. +(defun generation-gap (n m) + (cond ((null (descended-from n m)) nil) + ((member m (parents n)) 1) + (t (if (null (descended-from (father n) m)) + (+ 1 (generation-gap (mother n) m)) + (+ 1 (generation-gap (father n) m)))))) + +;;; i. +;;; Use the functions you have written to answer the following questions: +;;; 1. Is Robert descended from Deirdre? +(descended-from 'robert 'deirdre) +NIL + +;;; 2. Who are Yvette's ancestors? +(ancestors 'yvette) +(ZELDA ROBERT JULIE QUENTIN WANDA VINCENT) + +;;; 3. What is the generation gap between Olivia and Frank? +(generation-gap 'olivia 'frank) +3 + +;;; 4. Who are Peter's cousins? +(cousins 'peter) +(JOSHUA ROBERT) + +;;; 5. Who are Olivia's grandparents? +(grandparents #'parents 'olivia) +(GEORGE ELLEN HILLARY ANDRE) + +;;; Ex 8.61 +;;; Write a tail-recursive version of COUNT-UP. +(defun count-up (n) + (tr-count-up n nil)) + +(defun tr-count-up (n result) + (cond ((zerop n) result) + (t (tr-count-up (- n 1) (cons n result))))) + +;;; Ex 8.62 +;;; Write a tail-recursive version of FACT. +(defun fact (n) + (tr-fact (- n 1) (* (- n 1) n))) + +(defun tr-fact (n result) + (cond ((eq n 1) result) + (t (tr-fact (- n 1) (* (- n 1) result))))) + +;;; Write tail-recursive versions of UNION, INTERSECTION, and SET-DIFFERENCE. Your functions need not return results in the same order as the built-in functions. +;;; UNION +(defun my-union (a b) + (tr-my-union a b nil)) + +(defun tr-my-union (a b result) + (cond ((null a) (append b result)) + (t (tr-my-union (rest a) (remove (first a) b) + (cons (first a) result))))) + +;;; INTERSECTION +(defun my-intersection (a b) + (tr-my-intersection a b nil)) + +(defun tr-my-intersection (a b result) + (cond ((null a) result) + (t (tr-my-intersection (rest a) b (if (member (first a) b) + (cons (first a) result) + result))))) + +;;; SET-DIFFERENCE +(defun my-set-difference (a b) + (tr-set-difference a b nil)) + +(defun tr-set-difference (a b result) + (cond ((null a) result) + (t (tr-set-difference (rest a) b (if (not (member (first a) b)) + (cons (first a) result) + result))))) + +;;; Ex 8.64 +;;; Write a TREE-FIND-IF operator that returns the first non-NIL atom of a tree that satisfies a predicate. +;;; (TREE-FIND-IF #'ODDP '((2 4) (5 6) (7))) should return 5. +(defun tree-find-if (fn x) + (cond ((null x) nil) + (t (or (tr-tree-find-if fn (first x)) (tree-find-if fn (rest x)))))) + +(defun tr-tree-find-if (fn x) + (cond ((null x) nil) + ((funcall fn (first x)) (first x)) + (t (tr-tree-find-if fn (rest x))))) + +;;; 8.65 +;;; Use LABELS to write versions of TR-COUNT-SLICES and TR-REVERSE. + +;;; TR-COUNT-SLICES +(defun tr-count-slices (loaf) + (tr-cs1 loaf 0)) + +(defun tr-cs1 (loaf n) + (cond ((null loaf) n) + (t (tr-cs1 (rest loaf) (+ n 1))))) + +(defun tr-count-slices (loaf) + (labels ((tr-cs1 (loaf n) + (cond ((null loaf) n) + (t (tr-cs1 (rest loaf) (+ n 1)))))) + (tr-cs1 loaf 0))) + +;;; TR-REVERSE +(defun tr-reverse (x) + (tr-rev1 x nil)) + +(defun tr-rev1 (x result) + (cond ((null x) result) + (t (tr-rev1 + (rest x) + (cons (first x) result))))) + +(defun tr-reverse (x) + (labels ((tr-rev1 (x result) + (cond ((null x) result) + (t (tr-rev1 (rest x) (cons (first x) result)))))) + (tr-rev1 x nil))) + +;;; Ex 8.66 +;;; Write ARITH-EVAL, a function that evaluates arithmetic expressions. +;;; (ARITH-EVAL '(2 + (3 * 4))) should return 14. +(defun arith-eval (x) + (cond ((numberp x) x) + (t (funcall (second x) (if (numberp (first x)) + (first x) + (arith-eval (first x))) + (if (numberp (third x)) + (third x) + (arith-eval (third x))))))) + + +(defun arith-eval (x) + (cond ((numberp x) x) + (t (funcall (second x) + (arith-eval (first x)) + (arith-eval (third x)))))) + +;;; Ex 8.67 +;;; Write a predicate LEGALP that returns T if its input is a legal arithmetic expression. For example, (LEGALP 4) and (LEGALP '((2 * 2) - 3)) should return T. +;;; (LEGALP NIL) and (LEGALP '(A B C D)) should return NIL. +(defun legalp (x) + (cond ((null x) nil) + ((numberp x) t) + ((or (symbolp (first x)) (symbolp (third x))) nil) + (t (and (legalp (first x)) (symbolp (second x)) (legalp (third x)))))) + +;;; Alternative solution +(defun legalp (x) + (cond ((numberp x) t) + ((atom x) nil) + (t (and (legalp (first x)) + (member (second x) + '(+ - * /)) + (legalp (third x)))))) + +;;; Ex 8.69 +;;; Of the positive integers greater than one, some are primes while others are not. Primes are numbers that are divisible only by themselves and by 1. +;;; A nonprime, which is known as a composite number, can always be factored into primes. The number 60 has factors 2, 2, 3 and 5 which means 60 = 2x2x3x5. +;;; Write a recursive definition for positive integers greater than one in terms of prime numbers. +(defun factors (n) + (factors-help n 2)) + +(defun factors-help (n p) + (cond ((equal n 1) nil) + ((zerop (rem n p)) + (cons p (factors-help (/ n p) p))) + (t (factors-help n (+ p 1))))) + +;;; Ex 8.70 +;;; Write a FACTOR-TREE function that returns a factorization tree. +;;; (FACTOR-TREE 60) should return the list (60 2 (30 2 (15 3 5))). +(defun factor-tree (n) + (factor-tree-help n 2)) + +(defun factor-tree-help (n p) + (cond ((eq n p) n) + ((zerop (rem n p)) + (list n p (factor-tree-help (/ n p) p))) + (t (factor-tree-help n (+ p 1))))) + diff --git a/CL-gentle-intro/structures-type-system.lisp b/CL-gentle-intro/structures-type-system.lisp new file mode 100644 index 00000000..82da1491 --- /dev/null +++ b/CL-gentle-intro/structures-type-system.lisp @@ -0,0 +1,137 @@ +;;; Chapter 12 - Structures and The Type System + +;;; Exercises + +;;; Ex 12.4 +;;; In this exercise we will create a discrimination net for automotive diagnosis that mimics the behaviour of the system shown before. + +;;; a. +;;; Write a DEFSTRUCT for a structure called NODE, with four components called NAME,QUESTION, YES-CASE, and NO-CASE. +(defstruct node + (name nil) + (question nil) + (yes-case nil) + (no-case nil)) + +;;; b. +;;; Define a global variable *NODE-LIST* that will hold all the nodes in the discrimination net. Write a function INIT that initializes the network by setting *NODE-LIST* to NIL. +(setf *NODE-LIST* nil) + +(defun init () + (setf *NODE-LIST* nil) + 'initialized) + +;;; c. +;;; Write ADD-NODE. It should return the name of the node it added. +(defun add-node (name question yes-case no-case) + (push (make-node :name name + :question question + :yes-case yes-case + :no-case no-case) + *NODE-LIST*) + name) + +;;; d. Write FIND-NODE, which takes a node name as input and returns the node if it appears in *NODE-LIST*, or NIL if it doesn't. +(defun find-node (name) + (dolist (n *NODE-LIST*) + (when (equal name (node-name n)) + (return n)))) + +;;; e. +;;; Write PROCESS-NODE. It takes a node name as input. If it can't find the node, it prints a message that the node hasn't been defined yet, and returns NIL. +;;; Otherwise it asks the user the question associated with that node, and then returns the node's yes action or no action depending on how the user responds. +(defun process-node (name) + (let ((n (find-node name))) + (cond ((null n) + (format t "~&The node hasn't been defined yet.")) + (t (format t "~&~A " (node-question n)) + (node-question n) + (let ((ans (read))) + (cond ((equal ans 'yes) (node-yes-case n)) + ((equal ans 'no) (node-no-case n)) + (t (process-node name)))))))) + +;;; alternative solution +(defun process-node (name) + (let ((nd (find-node name))) + (if nd + (if (y-or-n-p "~&~A " + (node-question nd)) + (node-yes-case nd) + (node-no-case nd)) + (format t + "~&Node ~S not yet defined." name)))) + +;;; f. +;;; Write the function RUN. It maintains a local variable named CURRENT-NODE, whose initial value is START. +;;; It loops, calling PROCESS-NODE to process the current node, and storing the value returned by PROCESS-NODE back into CURRENT-NODE. +;;; If the value returned is a string, the function prints the string and stops. If the value returned is NIL, it also stops. +(defun run () + (do ((current-node 'start (process-node current-node))) + ((or (stringp current-node) + (null current-node)) + (format t "~&~A" current-node)))) + +;;; alternative solution +(defun run () + (do ((current-node 'start + (process-node current-node))) + ((null current-node) nil) + (cond ((stringp current-node) + (format t "~&~A" current-node) + (return nil))))) + +;;; g. +;;; Write an interactive function to add a new node. It should prompt the user for the node name, the question, and the yes and no actions. +;;; Remember that the question must be a string, enclosed in double quotes. +;;; Your function should add the new node to the net. +(defun get-node-data () + (format t "~&Enter the node's name: ") + (let ((name (read))) + (format t "~&Enter the node's question: ") + (let ((question (read))) + (format t "~&Enter the yes action: ") + (let ((yes (read))) + (format t "~&Enter the no action: ") + (let ((no (read))) + (add-node name question yes no)))))) + + +;;; Alternative solution +(defun interactive-add () + (let ((question nil) + (name nil) + (yes-case nil) + (no-case nil)) + (format t "~&Name? ") + (setf name (read)) + (format t "~&Question? ") + (setf question (read)) + (format t "~&Yes action? ") + (setf yes (read)) + (format t "~&No action? ") + (setf no (read)) + (add-node name question yes no))) + +;;; Ex 12.5 +;;; Create a defstruct for CAPTAIN with fields NAME, AGE, and SHIP. +;;; Make a structure describing James T Kirk, captain of the Enterprise, age 35. +;;; Make the Enterprise point back to Kirk through its CAPTAIN component. +;;; Notice that when you print Kirk, you see his ship as well. +;;; Now define a print function for CAPTAIN that displays only the name, such as #. +(defstruct (captain (:print-function print-captain)) + (name nil) + (age nil) + (ship nil)) + +(defun print-captain (x stream depth) + (format stream "#" + (captain-name x))) + +(setf s1 (make-captain :name "James T Kirk" + :age 35 + :ship "Enterprise")) + + + + diff --git a/CL-gentle-intro/variables-side-effects.lisp b/CL-gentle-intro/variables-side-effects.lisp new file mode 100644 index 00000000..5251e617 --- /dev/null +++ b/CL-gentle-intro/variables-side-effects.lisp @@ -0,0 +1,96 @@ +;;; Chapter 5 - Variables and Side Effects +;;; Exercises + +;;; Ex 5.1 +;;; Rewrite function POOR-STYLE to create a new local variable Q using LET, instead of using SETF to change P. +;;; Call your new function GOOD-STYLE. +(defun poor-style (p) + (setf p (+ p 5)) + (list 'result 'is p)) + +(defun good-style (p) + (let ((q (+ p 5))) + (list 'result 'is q))) + +;;; Ex 5.6 a +;;; Write a function THROW-DIE that returns a random number from 1 to 6, inclusive. Remember that (RANDOM 6) will pick numbers from 0 to 5. +;;; THROW-DIE doesn't need any inputs, so its argument list should be NIL. +(defun throw-die () + "Returns a random number from 1 to 6." + (+ (random 6) 1)) + +;;; Ex 5.6 b +;;; Write a function THROW-DICE that throws two dice and returns a list of two numbers: the value of the first die and the value of the second. We'll call this list a "throw." +;;; For example, (THROW-DICE) migh return the throw (3 5), indicating that the first die was a 3 and the second a 5. +(defun throw-dice () + "Throws two dice and returns the result in a list" + (list (throw-die) (throw-die))) + +;;; Ex 5.6 c +;;; Throwing two ones is called "snake eyes"; two sixes is called "boxcars." Write predicates SNAKE-EYES-P and BOXCARS-P that takes a throw as input and return T if the throw is equal to (1 1) or (6 6), respectively. +(defun snake-eyes-p (l) + (eq (+ (car l) (cadr l)) 2)) + +(defun boxcars-p (l) + (eq (+ (car l) (cadr l)) 12)) + +;;; Ex 5.6 d +;;; In playing craps, the first throw of the dice is crucial. A throw of 7 or 11 is an instant win. A throw of 2, 3 or 12 is an instant loss (American casino rules). +;;; Write predicates INSTANT-WIN-P and INSTANT-LOSS-P to detect these conditions. Each should take a throw as input. +(defun instant-win-p (l) + (let ((s (+ (car l) (cadr l)))) + (if (or (eq s 7) (eq s 11)) t))) + +(defun instant-loss-p (l) + (let ((s (+ (car l) (cadr l)))) + (if (or (eq s 2) (eq s 3) (eq s 12)) t))) + +;;; Ex 5.6 e +;;; Write a function SAY-THROW that takes a throw as input and returns either the sum of the two dice or the symbol SNAKE-EYES or BOXCARS if the sum is 2 or 12. +;;; (SAY-THROW '(3 4)) should return 7. (SAY-THROW '(6 6)) should return BOXCARS. +(defun say-throw (l) + (cond ((snake-eyes-p l) 'snake-eyes) + ((boxcars-p l) 'boxcars) + (t (+ (car l) (cadr l))))) + +;;; Ex 5.6 f +;;; If you don't win or lose on the first throw of the dice, the value you threw becomes your "point," which will be explained shortly. +;;; Write a function (CRAPS) that produces the following sort of behaviour. Your solution should make use of the functions you wrote in previous steps. +;;; > (craps) +;;; (THROW 1 AND 1 -- SNAKEYES -- YOU LOSE) +;;; > (craps) +;;; (THROW 3 AND 4 -- 7 -- YOU WIN) +;;; > (craps) +;;; (THROW 2 AND 4 -- YOUR POINT IS 6) +(defun craps () + (let ((l (list (throw-die) (throw-die)))) + (cond ((instant-win-p l) + (list 'throw (car l) 'and (cadr l) '-- + (+ (car l) (cadr l)) 'you 'win)) + ((instant-loss-p l) + (cond ((snake-eyes-p l) '(throw 1 and 1 -- snakeeyes -- you lose)) + ((boxcars-p l) '(throw 6 and 6 -- boxcars -- you lose)) + (t (list 'throw (car l) 'and (cadr l) '-- + (+ (car l) (cadr l)) 'you 'lose)))) + (t (list 'throw (car l) 'and (cadr l) '-- + 'your 'point 'is (+ (car l) (cadr l))))))) + +;;; Ex 5.6 g +;;; Once a point has been established, you continue throwing the dice until you either win by making the point again or lose by throwing a 7. +;;; Write the function TRY-FOR-POINT that simulates this part of the game, as follows: +;;; > (try-for-point 6) +;;; (THROW 3 and 5 -- 8 -- THROW AGAIN) +;;; > (try-for-point 6) +;;; (THROW 5 and 1 -- 6 -- YOU WIN) +;;; > (craps) +;;; (THROW 3 and 6 -- 9 -- YOUR POINT IS 9) +;;; > (try-for-point 9) +;;; (THROW 6 and 1 -- 7 -- YOU LOSE) +(defun try-for-point (x) + (let* ((l (list (throw-die) (throw-die))) + (s (+ (car l) (cadr l)))) + (if (eq s x) + (list 'throw (car l) 'and (cadr l) '-- s '-- 'you 'win) + (if (eq (random 2) 1) + (list 'throw (car l) 'and (cadr l) '-- s '-- 'throw 'again) + (list 'throw (car l) 'and (cadr l) '-- s '-- 'you 'lose)))))