commit 5feb489ff2a8e317fc7157f05a4a766d18286db1
parent 40c492a3ea9d3c46cf93c94b9afe6e56d864b243
Author: Yuval Langer <yuval.langer@gmail.com>
Date: Sat, 18 Mar 2023 16:38:41 +0200
Add some more exercise solutions. A bit messy.
Diffstat:
| M | guile.scm | | | 411 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
1 file changed, 411 insertions(+), 0 deletions(-)
diff --git a/guile.scm b/guile.scm
@@ -2785,3 +2785,414 @@ Iterative.
(test-end "2.41"))
(exercise-2.41)
+
+(define (exercise-2.42)
+ (define (make-position row column)
+ (cons row column))
+
+ (define (position-row position)
+ (car position))
+
+ (define (position-column position)
+ (cdr position))
+
+ (define (adjoin-position row column rest-of-queens)
+ (cons (make-position row column)
+ rest-of-queens))
+
+ (define empty-board '()) ;; queens 0 will return [[]].
+
+ (define (threatening-pair? queen-a-position queen-b-position)
+ (define a-row (position-row queen-a-position))
+ (define b-row (position-row queen-b-position))
+
+ (define a-column (position-column queen-a-position))
+ (define b-column (position-column queen-b-position))
+
+ (define rows-equal (= a-row
+ b-row))
+
+ (define on-same-diagonal (= (abs (- a-row
+ b-row))
+ (abs (- a-column
+ b-column))))
+
+ (or rows-equal
+ on-same-diagonal))
+
+ "
+ Q
+ Q
+ Q
+
+Q1 = (2, 1)
+Q2 = (3, 2)
+Q1 - Q2 = (2 - 3, 1 - 2)
+= (-1, -1)
+Q3 = (4, 3)
+Q1 - Q3 = (2 - 4, 1 - 3)
+= (-2, -2)
+
+ Q
+ Q
+ Q
+Q
+
+Q1 = (4, 1)
+Q2 = (3, 2)
+Q3 = (2, 3)
+
+Q1 - Q2 = (4 - 3, 1 - 2)
+= (1, -1)
+Q1 - Q3 = (4 - 2, 1 - 3)
+= (2, -2)
+Q1 - Q4 = (4 - 1, 1 - 4)
+= (3, -3)
+"
+
+
+ (define (safe? our-column board)
+ (define our-row (position-row (car board)))
+
+ (if (null?
+ (filter
+ (lambda (position)
+ (threatening-pair?
+ (make-position our-row
+ our-column)
+ position))
+ (cdr board)))
+ #t
+ #f))
+
+ (define (queens board-size)
+ (define (queen-cols k)
+ (if (= k 0)
+ (list empty-board)
+ (filter
+ (lambda (positions)
+ (safe? k
+ positions))
+ (flatmap
+ (lambda (rest-of-queens)
+ (map (lambda (new-row)
+ (adjoin-position
+ new-row
+ k
+ rest-of-queens))
+ (enumerate-interval
+ 1
+ board-size)))
+ (queen-cols (1- k))))))
+ (queen-cols board-size))
+
+ (define (display-board board n)
+ (define sorted-board
+ (sort board
+ (lambda (a b)
+ (or
+ (< (position-row a)
+ (position-row b))
+ ;; (< (position-column a)
+ ;; (position-column b))
+ ))))
+ '(define sorted-board board)
+
+ (define (display-row column n)
+ (pretty-print (list column n))
+ (cond
+ ((zero? n) '())
+ ((= column n)
+ (display "Q\n")
+ (display-row column (1- n)))
+ (else (display ".")
+ (display-row column (1- n)))))
+
+ (for-each
+ (lambda (position)
+ (display-row
+ (position-column position)
+ n))
+ sorted-board))
+
+ '(for-each (lambda (board)
+ (display-board board
+ (reduce
+ (lambda (x y)
+ (max (position-column x)
+ (position-column y)))
+ 0
+ board))
+ (pretty-print board))
+ (flatmap queens
+ (enumerate-interval 1 8)))
+
+ (test-begin "2.42")
+ (test-equal
+ #f
+ (safe? 2
+ (list (make-position 1 2)
+ (make-position 2 1))))
+ (test-equal
+ #t
+ (safe? 2
+ (list (make-position 4 2)
+ (make-position 2 1))))
+ (test-equal
+ '()
+ (queens 8))
+ (test-end "2.42"))
+
+(exercise-2.42)
+
+;; Exercise 2.43 XXX
+
+;; Exercise 2.44 XXX
+
+(define (exercise-2.44)
+ (test-begin "2.44")
+ (test-end "2.44"))
+
+(exercise-2.44)
+
+;; Exercise 2.53
+
+(define (exercise-2.53)
+ (test-begin "2.53")
+ (test-equal
+ '(a b c)
+ (list 'a 'b 'c))
+ (test-equal
+ '((george))
+ (list (list 'george)))
+ (test-equal
+ '((y1 y2))
+ ;; '((x1 x2) (y1 y2)) is a pair whose first item is (x1 x2) and
+ ;; second is a pair whose first item is (y1 y2) and second is nil,
+ ;; so (cdr '((x1 x2) (y1 y2))) is ((y1 y2)).
+ (cdr '((x1 x2) (y1 y2))))
+ (test-equal
+ '(y1 y2)
+ ;; the cadr is the first element of the pair whose first item is (y1 y2) and second is nil.
+ (cadr '((x1 x2) (y1 y2))))
+ (test-equal
+ #f
+ (pair? (car '(a short list))))
+ (test-equal
+ #f
+ ;; No symbol red in the list, so answer is false.
+ (memq 'red '((red shoes) (blue socks))))
+ (test-equal
+ '(red shoes blue socks)
+ ;; The first element of the first pair is red, so that pair is returned.
+ (memq 'red '(red shoes blue socks)))
+ (test-end "2.53"))
+
+(exercise-2.53)
+
+(define (exercise-2.54)
+ (define (my-equal? a b)
+ (cond
+ ((and (null? a)
+ (null? b))
+ #t)
+ ((and (symbol? a)
+ (symbol? b))
+ (eq? a
+ b))
+ ((and (pair? a)
+ (pair? b))
+ (and (my-equal? (car a)
+ (car b))
+ (my-equal? (cdr a)
+ (cdr b))))
+ (else #f)))
+
+ (test-begin "2.54")
+ (test-equal
+ #t
+ (my-equal? 'a 'a))
+ (test-equal
+ #f
+ (my-equal? 'a 'b))
+ (test-equal
+ #f
+ (my-equal? '(a) 'b))
+ (test-equal
+ #t
+ (my-equal? '(a) '(a)))
+ (test-equal
+ #t
+ (my-equal? '((a b c ((d e) f) g h)) '((a b c ((d e) f) g h))))
+ (test-equal
+ #f
+ (my-equal? '((a b c ((d e) f) g h)) '((a b c (d e f) g h))))
+ (test-equal
+ #f
+ (my-equal? '((a b c ((d e) f) g h)) '((a b c ((d d) f) g h))))
+ (test-end "2.54"))
+
+(exercise-2.54)
+
+;; Exercise 2.55
+
+;; The 'foo is syntactic sugar for (quote foo).
+;; If foo is 'abracadabra, which is (quote abracadabra),
+;; then ''abracadabra is (quote (quote abracadabra)).
+
+;; Exercise 2.56
+
+(define (deriv-stuff)
+ ;; Original:
+ ;; (define (make-sum a1 a2)
+ ;; (list '+ a1 a2))
+
+ (define (=number? exp num)
+ (and (number? exp)
+ (= exp num)))
+
+ ;; Simplificating make-sum:
+ (define (make-sum a1 a2)
+ (cond
+ ((=number? a1 0) a2)
+ ((=number? a2 0) a1)
+ ((and (number? a1)
+ (number? a2))
+ (+ a1 a2))
+ (else (list '+ a1 a2))))
+
+ (define (sum? x)
+ (and (pair? x)
+ (eq? (car x)
+ '+)))
+
+ (define (addend s)
+ (cadr s))
+
+ (define (augend s)
+ (caddr s))
+
+ ;; Original:
+ ;; (define (make-product m1 m2)
+ ;; (list '* m1 m2))
+
+ ;; Simplificating make-product:
+ (define (make-product m1 m2)
+ (cond
+ ((or (=number? m1 0)
+ (=number? m2 0))
+ 0)
+ ((=number? m1 1) m2)
+ ((=number? m2 1) m1)
+ ((and (number? m1)
+ (number? m2))
+ (* m1 m2))
+ (else (list '* m1 m2))))
+
+ (define (product? x)
+ (and (pair? x)
+ (eq? (car x)
+ '*)))
+
+ (define (multiplier p)
+ (cadr p))
+
+ (define (multiplicand p)
+ (caddr p))
+
+ (define (make-exponentiation b e)
+ (cond
+ ((=number? e 0) 1)
+ ((=number? b 1) b)
+ (else (list '** b e))))
+
+ ;; Exercise 2.56
+ (define (exponentiation? e)
+ (and (pair? e)
+ (eq? (car e)
+ '**)))
+
+ (define (base e)
+ (cadr e))
+
+ (define (exponent e)
+ (caddr e))
+
+ (define (variable? x)
+ (symbol? x))
+
+ (define (same-variable? v1 v2)
+ (and (variable? v1)
+ (variable? v2)
+ (eq? v1 v2)))
+
+ (define (deriv exp var)
+ (cond
+ ((number? exp) 0)
+ ((variable? exp)
+ (if (same-variable? exp
+ var)
+ 1
+ 0))
+ ((sum? exp)
+ (make-sum (deriv (addend exp)
+ var)
+ (deriv (augend exp)
+ var)))
+ ((product? exp)
+ (make-sum
+ (make-product (multiplier exp)
+ (deriv (multiplicand exp)
+ var))
+ (make-product (deriv (multiplier exp)
+ var)
+ (multiplicand exp))))
+ ;; Exercise 2.56
+ ((exponentiation? exp)
+ ;; d(x**n)/dx = n*x**(n-1)
+ (make-product (exponent exp)
+ (make-exponentiation (base exp)
+ (make-sum (exponent exp)
+ -1))))
+ (else (error "Unknown expression
+ type: DERIV" exp))))
+
+ (test-begin "deriv-stuff")
+ ;; Original:
+ ;; (test-equal
+ ;; '(+ 1 0)
+ ;; (deriv '(+ x 3) 'x))
+ ;; (test-equal
+ ;; '(+ (* x 0) (* 1 y))
+ ;; (deriv '(* x y) 'x))
+ ;; (test-equal
+ ;; '(+ (* (* x
+ ;; y)
+ ;; (+ 1
+ ;; 0))
+ ;; (* (+ (* x 0)
+ ;; (* 1 y))
+ ;; (+ x 3)))
+ ;; (deriv '(* (* x y) (+ x 3)) 'x))
+
+ ;; Simplificating:
+ (test-equal
+ 1
+ (deriv '(+ x 3) 'x))
+ (test-equal
+ 'y
+ (deriv '(* x y) 'x))
+ (test-equal
+ '(+ (* x y)
+ (* y
+ (+ x 3)))
+ (deriv '(* (* x y) (+ x 3)) 'x))
+ (test-equal
+ '(* 3 (** x 2))
+ (deriv '(** x 3) 'x))
+ (test-equal
+ '()
+ (deriv '(** x -1) 'x))
+ (test-end "deriv-stuff"))
+
+(deriv-stuff)
