paip/part-1.lisp

303 lines
8.7 KiB
Common Lisp
Raw Permalink Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;;; paip.lisp
(in-package #:paip)
;;; Chapter 1
;; 1.1 define a version of `last-name' that handles "Rex Morgan MD," "Morton
;; Downey, Jr.," etc.
(defparameter *titles* '(MD Sr. Jr. Sir)
"Titles aren't part of names.")
(defun first-name (name)
"Select the first name from a NAME represented as a list."
(if (member (first name) *titles*)
(first-name (rest name))
(first name)))
(defun last-name (name)
"Select the last name from a NAME represented as a list."
(first-name (reverse name)))
;; 1.2 Write a function to exponentiate, or raise a number to an integer
;; power. For example: (power 3 2) = 3 ^ 2 = 9.
(defun power (n m)
"Raise N to an integer power M."
(cond
((= m 0) 1)
((= m 1) n)
(t (* n (power n (- m 1))))))
;; 1.3 Write a function that counts the number of atoms in an expression. For
;; example: (count-atoms '(a (b) c)) = 3. Notice that there is something of an
;; ambiguity in this: shoul (a nil c) count as 3 atoms, or as two, because it's
;; the equivalent to (a () c) ?
(defun count-atoms (expr)
"Count how many atoms are in EXPR, disregarding NIL."
(cond
((null expr) 0)
((atom expr) 1)
(t (+ (count-atoms (first expr))
(count-atoms (rest expr))))))
(defun count-all-atoms (expr &optional (if-null 1))
"Count all atoms in EXPR, including NILs only in non-tail position."
(cond
((null expr) if-null)
((atom expr) 1)
(t (+ (count-all-atoms (first expr) 1)
(count-all-atoms (rest expr) 0)))))
;; 1.4 Write a function that counts the number of times an expression occurs
;; anywhere in another expression. Example: (count-anywhere 'a '(a ((a) b) a))
;; => 3.
(defun count-anywhere (obj expr &optional (test #'eq))
"Count how many times an OBJ appears anywhere in an EXPR."
(cond
((null expr) 0)
((atom expr) (if (funcall test obj expr) 1 0))
(t (+ (count-anywhere obj (first expr) test)
(count-anywhere obj (rest expr) test)))))
;; Exercise 1.5 [m] Write a function to compute the dot product of two
;; sequences of numbers, represented as lists. The dot product is computed by
;; multiplying corresponding elements and then adding up the resulting
;; products. Example: (dot-product '(10 20) '(3 4)) = 10 × 3 + 20 × 4 = 110
(defun dot-product (list1 list2)
"Compute the dot product of LIST1 and LIST2"
(apply #'+ (mapcar #'* list1 list2)))
;;; Chapter 2
(defun mappend (fn list)
"Apply FN to each element of LIST and append the results."
(apply #'append (mapcar fn list)))
(defun one-of (set)
"Pick one element of SET, and make a list of it."
(list (random-elt set)))
(defun random-elt (choices)
"Choose a random element from list CHOICES."
(elt choices (random (length choices))))
(defparameter *simple-grammar*
'((sentence (noun-phrase verb-phrase))
(noun-phrase (Article Noun))
(verb-phrase (Verb noun-phrase))
(Article the a)
(Noun man ball woman table)
(Verb hit took saw liked))
"A grammar for a trivial subset of English.")
(defvar *grammar* *simple-grammar*
"The grammar used by `generate'.")
(defun rule-lhs (rule)
"The left-hand side of a RULE."
(first rule))
(defun rule-rhs (rule)
"The right-hand side of a RULE."
(rest rule))
(defun rewrites (category)
"Return a list of the possible rewrites for CATEGORY."
(rule-rhs (assoc category *grammar*)))
;; 2.1. Write a version of `generate' that uses `cond' but avoids calling
;; `rewrites' twice.
(defun generate (phrase)
"Generate a random LHS present in `*grammar*'."
(let ((rw-list (rewrites phrase)))
(cond ((listp phrase) (mappend #'generate phrase))
(rw-list (generate (random-elt rw-list)))
(t (list phrase)))))
;; 2.2. Write a version of `generate' that explicitly differentiates between
;; terminal symbols (those with no rewrite rules) and nonterminal symbols.
;; I'm gonna be honest, this one is tougher. I'm going to let it sit a minute.
;; (defun generate2 (phrase)
;; (let ((rw-list (rewrites phrase)))
;; (if rw-list
;; (let ((relt (random-elt rw-list)))
;; (if (listp relt)
;; (mappend #'generate2 phrase)
;; (generate2 relt)))
;; (list phrase))))
(defparameter *bigger-grammar*
'((sentence (noun-phrase verb-phrase))
(noun-phrase (Article Adj* Noun PP*) (Name) (Pronoun))
(verb-phrase (Verb noun-phrase PP*))
(PP* () (PP PP*))
(Adj* () (Adj Adj*))
(PP (Prep noun-phrase))
(Prep to in by with on)
(Adj big little blue green adiabatic)
(Article the a)
(Name Pat Kim Lee Terry Robin)
(Noun man ball woman table)
(Verb hit took saw liked)
(Pronoun he she it these those that)))
(setf *grammar* *bigger-grammar*)
(defun generate-tree (phrase)
"Generate a random PHRASE, with a complete parse tree."
(cond ((listp phrase) (mapcar #'generate-tree phrase))
((rewrites phrase) (cons phrase
(generate-tree (random-elt (rewrites phrase)))))
(t (list phrase))))
(defun generate-all (phrase)
"Generate a list of all possible expansions of PHRASE."
(cond ((null phrase) (list nil))
((listp phrase)
(combine-all (generate-all (first phrase))
(generate-all (rest phrase))))
((rewrites phrase)
(mappend #'generate-all (rewrites phrase)))
(t (list (list phrase)))))
(defun combine-all (xlist ylist)
"Return a list of lists formed by appending a YLIST to an XLIST.
E.g., (combine-all '((a) (b)) '((1) (2)))
=> ((A 1) (B 1) (A 2) (B 2))."
(cross-product #'append xlist ylist))
;; Exercise 2.4 [m] One way of describing combine-all is that it calculates the
;; cross-product of the function append on the argument lists. Write the
;; higher-order function cross-product, and define combine-all in terms of it.
;; The moral is to make your code as general as possible, because you never
;; know what you may want to do with it next.
;; NOTE[acd]: it's the CARTESIAN product.
(defun cross-product (fn as bs)
"Calculate the result of passing FN to the cross (or Cartesian) product of
lists of AS and BS."
(mappend #'(lambda (b)
(mapcar #'(lambda (a) (funcall fn a b)) as))
bs))
;;; Chapter 3
;; Exercise 3.1 [m] Show a lambda expression that is equivalent to the below
;; let* expression. You may need more than one lambda.
;; (let* ((x 6)
;; (y (* x x)))
;; (+ x y)) => 42
(defun test-let*-lambda ()
(list
;; let* expression
(let* ((x 6)
(y (* x x)))
(+ x y))
;; lambda expression
((lambda (x)
(+ x ((lambda (y) (* y y)) x)))
6)))
;; Various forms of length using different looping structures
(defun length1 (list)
(let ((len 0))
(dolist (element list)
(incf len))
len))
(defun length1.1 (list)
(let ((len 0))
(dolist (element list len)
(incf len))))
(defun length2 (list)
(let ((len 0))
(mapc #'(lambda (element)
(declare (ignore element))
(incf len))
list)
len))
(defun length3 (list)
(do ((len 0 (+ len 1))
(l list (rest l)))
((null l) len)))
(defun length4 (list)
(loop :for element :in list
:count t))
(defun length4.1 (list)
(loop :for element :in list
:summing 1))
(defun length4.2 (list)
(loop :for element := (pop list)
:with len := 0
:until (null list)
:do (incf len)
:finally (return len)))
(defun length5 (list)
(count-if #'true list))
(defun true (x)
(declare (ignore x))
t)
;; not the most straightforward ;P
(defun length6 (list)
(if (null list)
0
(+ 1 (position-if #'true list :from-end t))))
;; NOT TAIL RECURSIVE -- length7 calls itself, then adds 1, then returns
(defun length7 (list)
(if (null list)
0
(+ 1 (length7 (rest list)))))
;; TAIL RECURSIVE -- length8-aux calls itself LAST
(defun length8 (list)
(length8-aux list 0))
(defun length8-aux (sublist len-so-far)
(if (null sublist)
len-so-far
(length8-aux (rest sublist) (+ 1 len-so-far))))
;; other options to avoid 2 functions
(defun length8-optional (list &optional (len-so-far 0))
(if (null list)
len-so-far
(length8-optional (rest list) (+ 1 len-so-far))))
(defun length8-labels (list)
(labels ((length8-inside-label (the-list len-so-far)
(if (null the-list)
len-so-far
(length8-inside-label (rest the-list) (+ 1 len-so-far)))))
(length8-inside-label list 0)))
;; example of RETURN special form
;; `dolist' has an implicit `block' form that `return' returns to
(defun product (numbers)
"Multiply all the numbers together to compute their product."
(let ((prod 1))
(dolist (n numbers prod)
(format t "~a ~a~%" n prod)
(if (= n 0)
(return 0)
(setf prod (* n prod))))))