Browse Source

Initial commit from current SICP lecture exercises

master
commit
c01bb03e46
  1. 79
      2.40.scm
  2. 64
      2.41.scm
  3. 66
      2.42.scm
  4. 9
      2.44.scm
  5. 14
      2.45.scm
  6. 94
      displaylib.scm
  7. 18
      ex2.32.scm
  8. 26
      ex2.33.scm
  9. 24
      ex2.34.scm
  10. 21
      ex2.35.scm
  11. 23
      ex2.36.scm
  12. 43
      ex2.37.scm
  13. 26
      ex2.38.scm
  14. 10
      ex2.39.scm
  15. 2
      run
  16. 38
      section2.scm

79
2.40.scm

@ -0,0 +1,79 @@
(newline)
(display "Exercise 2.40")(newline)
; -- Defs --
(define nil ())
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
; -- Start --
(define (flatmap proc seq)
(accumulate append nil (map proc seq)))
; --------
(define (permutations s)
(if (null? s) ; empty set?
(list nil) ; sequence containing empty set
(flatmap (lambda (x)
(map (lambda (p) (cons x p))
(permutations (remove x s))))
s)))
(define (remove item sequence)
(filter (lambda (x) (not (= item x)))
sequence))
; (display "Permutations")(newline)
; (display (permutations (list 1 2 3)))(newline)
; Star exercise 2.40
; Define a procedure unique-pairs that, given an integer n, generates the sequence of pairs (i,j) with (1 <= j < i <= n). Use unique-pairs to simplify the definition of prime-sum-pairs
(define (seq start stop)
(if (> start stop)
(list)
(cons start (seq (+ start 1) stop))))
; (display "(seq 1 3)")(newline)
; (display (seq 1 3))(newline)
; unique-pairs n -> [ (i,j) | 1<=i<j<=n ]
(define (unique-pairs n)
(flatmap (lambda (i)
(map (lambda (j) (list j i))
(seq 1 (- i 1))))
(seq 1 n)))
; simplified version of prime-sum
; true if m | n
; false otherwise
(define (div? m n)
(= (modulo n m) 0))
; true if n is prime
(define (prime? n)
(accumulate
(lambda (x y)
(and y (not (div? x n)) ))
true
(seq 2 (floor (sqrt n)))))
(define (prime-sum? pair)
(prime? (+ (car pair) (cadr pair))))
(define (make-pair-sum pair)
(list (car pair) (cadr pair) (+ (car pair) (cadr pair))))
(define (prime-sum-pairs n)
(map make-pair-sum
(filter prime-sum? (unique-pairs n))))
; (display "(unique-pairs 10)")(newline)
; (display (unique-pairs 10))(newline)
; (display "(filter prime-sum? (unique-pairs 10))")(newline)
; (display (filter prime-sum? (unique-pairs 10)))(newline)
; (display "(make-pair-sum (list 3 4))")(newline)
; (display (make-pair-sum (list 3 4)))(newline)
(display "(prime-sum-pairs 10)")(newline)
(display (prime-sum-pairs 10))(newline)

64
2.41.scm

@ -0,0 +1,64 @@
(newline)
(display " ---------------")(newline)
(display " Exercise 2.41")(newline)
(display "-----------------------------------------------------------")(newline)
; -- Defs --
(define nil ())
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
; -- Start --
(define (flatmap proc seq)
(accumulate append nil (map proc seq)))
; --------
; Star exercise 2.41
(display " Write a pro cedure to find all ordered triples")(newline)
(display " of distinct positive integers i, j and k")(newline)
(display " less than or equal to a given interger n")(newline)
(display " that sum to a given integer s")(newline)
(display "-----------------------------------------------------------")(newline)
(newline)
(define (seq start stop)
(if (> start stop)
(list)
(cons start (seq (+ start 1) stop))))
; unique-pairs n -> [ (i,j) | 1<=i<j<=n ]
(define (unique-pairs n)
(flatmap (lambda (i)
(map (lambda (j) (list j i))
(seq 1 (- i 1))))
(seq 1 n)))
(define (fst l) (car l))
(define (snd l) (cadr l))
(define (is-ordered triplet)
(and
(< (car triplet) (cadr triplet))
(< (cadr triplet) (caddr triplet))))
(define (unique-triplets n s)
(map (lambda (doublon)
(list (car doublon)
(cadr doublon)
(- s
(+ (car doublon)
(cadr doublon)))))
(unique-pairs n)))
; (display "(unique-triplets 10 10)")(newline)
; (display (unique-triplets 10 10))(newline)
(define (triplets n s)
(filter
is-ordered
(unique-triplets n s)))
(display "(triplets 10 12)")(newline)
(display (triplets 10 12))(newline)
(newline)
(display " --- END ---")(newline)

66
2.42.scm

@ -0,0 +1,66 @@
(load "displaylib.scm")
(title "Exercise 2.42")
(doc "The eight-queens puzzle asks how to place eight queenson a chessboard so that no queen is in check from any other(i.e., no two queens are in the same row, column, or diagonal). One possible solution is shown in figure 2.8. One way to solve the puzzle is to work across the board, placing a queen in each column. Once we have placed k - 1 queens, we must place the kth queen in a position where it does not check any of the queens already on the board. We can formulate this approach recursively: Assume that we have already generated the sequence of all possible ways to place k - 1 queens in the first k - 1 columns of the board. For each of these ways, generate an extended set of positions by placinga queen in each row of the kth column. Now filter these, keeping only the positions for which the queen in the kth column is safe with respect to the other queens. This producesthe sequence of all ways to place k queens in the first k columns. By continuing this process, we will produce not only one solution, but all solutions to the puzzle.\n\n We implement this solution as a procedure queens, which returns a sequence of all solutions to the problem of placing n queens on an n× n chessboard. Queens has an internal procedurequeen-cols that returns the sequence of all ways to place queens in the first k columns of the board.\n\n In this procedure rest-of-queens is a way to place k - 1 queens in thefirst k - 1 columns, and new-row is a proposed row in whichto place the queen for the kth column. Complete the programby implementing the representation for sets of board positions, including the procedure adjoin-position, which adjoinsa new row-column position to a set of positions, and empty-board, which represents an empty set of positions. You mustalso write the procedure safe?, which determines for a set of positions, whether the queen in the kth column is safe with respect to the others. (Note that we need only check whether the new queen is safe -- the other queens are already guaranteed safe with respect to each other.) ")
(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 (- k 1))))))
(queen-cols board-size))
; Data structure definition
; a partial board is a list of int
; (3 5) represent two columns of the board (in the direction you want)
; where a queen is on the row 3 and on the row 5.
; etc...
; a complete board is simple a partial board of good size.
(define (empty-board) nil)
(define (enumerate-interval start stop) (seq start stop))
(define (adjoin-position new-row k rest-of-queens)
(cons new-row rest-of-queens))
(define (one-equals position positions)
(accumulate
(lambda (b c) (or b c))
#f
(map (lambda (x) (= x position)) positions)))
(define (safe? k positions)
(let ((current-index (car positions)))
(not
(or
; no queen on same line
(one-equals current-index (cdr positions))
; no queen on same positive diagonal
(one-equals current-index (positive-diags (cdr positions) 1))
; no queen on same negative diagonal
(one-equals current-index (negative-diags (cdr positions) 1))))))
;
(define (positive-diags l n)
(if (null? l)
nil
(cons (+ (car l) n) (positive-diags (cdr l) (+ n 1)))))
(define (negative-diags l n)
(if (null? l)
nil
(cons (- (car l) n) (negative-diags (cdr l) (+ n 1)))))
(display "(safe? 0 (list 1 4 7))")(newline)
(display (safe? 0 (list 1 4 7)))(newline)
(display "(safe? 0 (list 1 4 1))")(newline)
(display (safe? 0 (list 1 4 1)))(newline)
(display "(queens 4)")(newline)
(display (queens 4))(newline)
(display "(queens 8)")(newline)
(display (queens 8))(newline)

9
2.44.scm

@ -0,0 +1,9 @@
(load "displaylib.scm")
(title "Exercise 2.44")
(doc "Define the procedure up-split used by corner-split. It is similar to right-split, except that it switches the roles of below and beside.")
(define (up-split painter n)
(if (= n 0)
painter
(let ((smaller (up-split painter (- n 1))))
(below painter (beside smaller smaller)))))

14
2.45.scm

@ -0,0 +1,14 @@
(load "displaylib.scm")
(title "Exercise 2.45")
(doc "Right-split and up-split can be expressed as instances of a general splitting operation. Define a procedure split with the property that evaluating
(define right-split (split beside below))
(define up-split (split below beside))
produces procedures right-split and up-split with the same behaviors as the ones already defined.")
(define (up-split painter n)
(if (= n 0)
painter
(let ((smaller (up-split painter (- n 1))))
(below painter (beside smaller smaller)))))

94
displaylib.scm

@ -0,0 +1,94 @@
; -- Defs --
(define nil ())
; -- accumulate (equivalent to foldr)
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
; -- define flatmap
(define (flatmap proc seq)
(accumulate append nil (map proc seq)))
; === Display nicely long strings ===
; search index to cut the line.
(define (rec-last-newline s n)
(if (= n 0)
0
(let ((current-car (substring s n (+ n 1))))
(if (string=? "\n" current-car)
n
(rec-last-newline s (- n 1))))))
(define (last-newline s n)
(let ((index (rec-last-newline s n)))
(if (= index 0)
n
index)))
(define (rec-last-special s n)
(if (= n 0)
0
(let ((current-car (substring s n (+ n 1))))
(if (not
(or
(and
(string>? current-car "A")
(string<? current-car "Z"))
(and
(string>? current-car "a")
(string<? current-car "z"))
(and
(string>? current-car "0")
(string<? current-car "9"))))
n
(rec-last-special s (- n 1))))))
(define (last-special s n)
(let ((index (rec-last-special s n)))
(if (= index 0)
n
index)))
(define (break-index s n)
(let ((last-special-index (last-special s n))
(last-newline-index (last-newline s n)))
(min last-special-index last-newline-index)))
; wrap naturally a long string to 60 char wide
(define (wrap s)
(if (< (string-length s) 60)
s
(let ((index (break-index s 60)))
(string-append
(substring s 0 index)
(string "\n")
(wrap (substring s (+ index 1) (string-length s))))
)))
; print nicely something (wrap + newline)
(define (print s)
(display (wrap s))(newline))
(define (title s)
(newline)
(display " ")(print s)
(newline))
(define (doc s)
(display "------------------------------------------------------------")
(newline)
(print s)
(display "------------------------------------------------------------")
(newline))
; define seq (useful to count, should be called range)
(define (seq start stop)
(if (> start stop)
(list)
(cons start (seq (+ start 1) stop))))

18
ex2.32.scm

@ -0,0 +1,18 @@
; Exercise 2.32
(define nil ())
(newline)
(display "Exercise 2.32 (subsets)")
(define (subsets s)
(if (null? s)
(list nil)
(let ((rest (subsets (cdr s)))
(x (car s)))
(append rest (map (lambda (r) (cons x r)) rest)))))
(define l (list 1 2 3))
(newline)
(display "Subsets of ")
(display l)
(newline)
(display (subsets l))

26
ex2.33.scm

@ -0,0 +1,26 @@
; Exercise 2.33
(newline) (display "Exercise 2.33") (newline)
; -- Defs --
(define nil ())
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
(define (amap p sequence)
(accumulate (lambda (x y) (cons (p x) y)) nil sequence))
(display (amap square (list 1 2 3 4))) (newline)
(define (aappend seq1 seq2)
(accumulate cons seq2 seq1))
(display (aappend (list 1 2 3) (list 4 5 6))) (newline)
(define (alength sequence)
(accumulate (lambda (x y) (+ y 1)) 0 sequence))
(display (alength (list 1 2 3) )) (newline)

24
ex2.34.scm

@ -0,0 +1,24 @@
; Exercise 2.33
(newline) (display "Exercise 2.34") (newline)
; -- Defs --
(define nil ())
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
; -- Start --
(define (horner-eval x coefficient-sequence)
(accumulate (lambda (this-coeff higher-terms) (+ (* higher-terms x) this-coeff))
0
coefficient-sequence))
(display (horner-eval 2 (list 1)))
(newline)
(display (horner-eval 2 (list 0 1)))
(newline)
(display (horner-eval 2 (list 1 1)))
(newline)
(display (horner-eval 2 (list 1 3 0 5 0 1)))
(newline)

21
ex2.35.scm

@ -0,0 +1,21 @@
; Exercise 2.33
(newline) (display "Exercise 2.35") (newline)
; -- Defs --
(define nil ())
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
; -- Start --
(define (count-leaves t)
(accumulate + 0 (map
(lambda (x)
(if (not (pair? x))
1
(count-leaves x))) t)))
(define tree (list 1 (list 2 3) (list 4 (list 5))))
(display tree)(newline)
(display (count-leaves tree)) (newline)

23
ex2.36.scm

@ -0,0 +1,23 @@
; Exercise 2.33
(newline) (display "Exercise 2.36") (newline)
; -- Defs --
(define nil ())
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
; -- Start --
(define (accumulate-n op init seqs)
(if (null? (car seqs))
nil
(cons (accumulate op init (map car seqs))
(accumulate-n op init (map cdr seqs)))))
(define s (list
(list 1 2 3)
(list 4 5 6)
(list 7 8 9)
(list 10 11 12)))
(display (accumulate-n + 0 s))

43
ex2.37.scm

@ -0,0 +1,43 @@
; Exercise 2.33
(newline) (display "Exercise 2.37") (newline)
; -- Defs --
(define nil ())
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
(define (accumulate-n op init seqs)
(if (null? (car seqs))
nil
(cons (accumulate op init (map car seqs))
(accumulate-n op init (map cdr seqs)))))
; -- Start --
(define V (list 3 2 1 0))
(define W (list 1 1 1 1))
(define M (list
(list 0 1 2 3)
(list 1 2 3 4)
(list 2 3 4 5)))
(define (dot-product v w)
(accumulate + 0 (map * v w)))
(define (matrix-*-vector m v)
(map (lambda (x) (dot-product x v)) m))
(define (transpose mat)
(accumulate-n (lambda (x acc) (cons x acc)) nil mat))
(define (matrix-*-matrix m n)
(let ((cols (transpose n)))
(map (lambda (v) (matrix-*-vector cols v)) m)))
(display (dot-product V W)) (newline)
(display (matrix-*-vector M V)) (newline)
(display (transpose M)) (newline)
(display (matrix-*-matrix M (transpose M))) (newline)

26
ex2.38.scm

@ -0,0 +1,26 @@
(newline) (display "Exercise 2.38") (newline)
; -- Defs --
(define nil ())
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
(define (fold-left op initial sequence)
(define (iter result rest)
(if (null? rest)
result
(iter (op result (car rest))
(cdr rest))))
(iter initial sequence))
; -- Start --
; For all initial & l =>
; fold-right op initial l == fold-left op initial l
; <=> (op commutative and associative)
;
; if initial is neutral element of op
; (op x initial) == (op initial x) == x
; Then, it is enough for op to be associative
; for fold-right & fold-left to return the same value.

10
ex2.39.scm

@ -0,0 +1,10 @@
(newline) (display "Exercise 2.39") (newline)
; -- Defs --
(define nil ())
; -- Start --
(define (reverser sequence)
(fold-right (lambda (x y) (append y (list x))) nil sequence))
(define (reversel sequence)
(fold-left (lambda (x y) (cons y x)) nil sequence))
(newline) (display (reverser (list 2 3 9))) (newline)
(newline) (display (reversel (list 2 3 9))) (newline)

2
run

@ -0,0 +1,2 @@
#!/usr/bin/env zsh
scheme --load $1 </dev/null | tail -n +12 | head -n -5

38
section2.scm

@ -0,0 +1,38 @@
(define nil ())
(define (square x) (* x x))
; Exercise 2.31
(define (tree-map f t)
(cond ((null? t) nil)
((not (pair? t)) (f t))
(else (cons (tree-map f (car t))
(tree-map f (cdr t))))))
(define x (list 1
(list 2 (list 3 4) 5)
(list 6 7)))
(define (tree-square t)
(tree-map square t))
; -- Print Results --
(newline)
(display "Exercise 2.31 (tree-map)")
(newline)
(display x)
(newline)
(display (tree-square x))
; Exercise 2.32
(newline)
(display "Exercise 2.32 (subsets)")
(define (subsets s)
(if (null? s)
(list nil)
(let ((rest (subsets (cdr s))))
(append rest (map (lambda (x) (list x (cons (car s) x)) rest))))))
(subsets (list 1 2 3))
Loading…
Cancel
Save