Permalink
Browse files

sequences and accumulations

  • Loading branch information...
1 parent 9a642ca commit 6380993fa03acf896b0eb4c27e90fb0e71147e36 @sarabander committed Aug 17, 2011
Showing with 390 additions and 0 deletions.
  1. +28 −0 2.2/2.33.scm
  2. +14 −0 2.2/2.34.scm
  3. +15 −0 2.2/2.35.scm
  4. +10 −0 2.2/2.36.scm
  5. +33 −0 2.2/2.37.scm
  6. +51 −0 2.2/2.38.scm
  7. +13 −0 2.2/2.39.scm
  8. +39 −0 2.2/2.40.scm
  9. +23 −0 2.2/2.41.scm
  10. +138 −0 2.2/2.42.scm
  11. +26 −0 2.2/2.43.scm
View
@@ -0,0 +1,28 @@
+
+(define nil empty)
+
+;; From the book
+(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence)))))
+;; -------------
+
+(define (my-map p sequence)
+ (accumulate (λ (x y) (cons (p x) y)) nil sequence))
+
+(my-map add1 '(1 2 3 4))
+(my-map sqrt '(100 121 36 49))
+
+(define (my-append seq1 seq2)
+ (accumulate cons seq2 seq1))
+
+(my-append '(1 2 3) '(4 5 6))
+(my-append '(a b (c d)) '(e f))
+
+(define (my-length sequence)
+ (accumulate (λ (x y) (add1 y)) 0 sequence))
+
+(my-length '())
+(my-length '(5 7 3))
View
@@ -0,0 +1,14 @@
+
+(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence)))))
+
+(define (horner-eval x coefficient-sequence)
+ (accumulate (λ (this-coeff higher-terms)
+ (+ this-coeff (* x higher-terms)))
+ 0
+ coefficient-sequence))
+
+(horner-eval 2 (list 1 3 0 5 0 1))
View
@@ -0,0 +1,15 @@
+
+(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence)))))
+
+(define (count-leaves t)
+ (accumulate + 0 (map (λ (x) (if (not (pair? x))
+ 1
+ (count-leaves x)))
+ t)))
+
+(count-leaves '(3 4 5 6)) ; 4
+(count-leaves '(a (b (c)) ((d ((e)) f) g) (h i))) ; 9
View
@@ -0,0 +1,10 @@
+
+(define (accumulate-n op init seqs)
+ (if (null? (car seqs))
+ empty
+ (cons (accumulate op init (map car seqs))
+ (accumulate-n op init (map cdr seqs)))))
+
+(define s '((1 2 3) (4 5 6) (7 8 9) (10 11 12)))
+
+(accumulate-n + 0 s) ; '(22 26 30)
View
@@ -0,0 +1,33 @@
+
+(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))
+ empty
+ (cons (accumulate op init (map car seqs))
+ (accumulate-n op init (map cdr seqs)))))
+
+(define (dot-product v w)
+ (accumulate + 0 (map * v w)))
+
+(define (matrix-*-vector m v)
+ (map (λ (row) (dot-product row v)) m))
+
+(matrix-*-vector '((2 3) (1 4) (-1 0)) '(3 5)) ; '(21 23 -3)
+
+(define (transpose mat)
+ (accumulate-n cons empty mat))
+
+(transpose '((2 3) (1 4) (-1 0))) ; '((2 1 -1) (3 4 0))
+
+(define (matrix-*-matrix m n)
+ (let ((cols (transpose n)))
+ (map (λ (row) (matrix-*-vector cols row)) m)))
+
+(matrix-*-matrix '((1 2) (3 4) (5 6))
+ '((7 9 11) (8 10 12)))
+; '((23 29 35) (53 67 81) (83 105 127))
View
@@ -0,0 +1,51 @@
+
+(define fold-right accumulate)
+
+(define (fold-left op initial sequence)
+ (define (iter result rest)
+ (if (null? rest)
+ result
+ (iter (op result (car rest))
+ (cdr rest))))
+ (iter initial sequence))
+
+(fold-right / 1 (list 1 2 3)) ; 3/2
+(fold-left / 1 (list 1 2 3)) ; 1/6
+(fold-right list nil (list 1 2 3)) ; '(1 (2 (3 ())))
+(fold-left list nil (list 1 2 3)) ; '(((() 1) 2) 3)
+
+;; That property is commutativity (or associativity?)
+(fold-right + 0 '(1 2 3 4 5)) ; 15
+(fold-left + 0 '(1 2 3 4 5)) ; 15
+
+(fold-right * 1 '(1 2 3 4 5)) ; 120
+(fold-left * 1 '(1 2 3 4 5)) ; 120
+
+;; More tests to identify the right property
+
+(define identity-matrix1 '((1 0 0) (0 1 0) (0 0 1)))
+(define identity-matrix2 '((1 0) (0 1)))
+
+(define matrix1 '((2 3) (-7 1) (5 -2)))
+(define matrix2 '((8 -6 3) (-9 4 5)))
+(define matrix3 '((4 10) (-1 2) (7 4)))
+
+;; Depends on 2.37
+(matrix-*-matrix identity-matrix1 matrix1)
+(matrix-*-matrix matrix3 identity-matrix2)
+
+;; Not commutative
+(matrix-*-matrix matrix1 matrix2) ; '((-11 0 21) (-65 46 -16) (58 -38 5))
+(matrix-*-matrix matrix2 matrix1) ; '((73 12) (-21 -33))
+
+;; Associative
+(matrix-*-matrix (matrix-*-matrix matrix1 matrix2) matrix3)
+(matrix-*-matrix matrix1 (matrix-*-matrix matrix2 matrix3))
+; both '((103 -26) (-418 -622) (305 524))
+
+(fold-left matrix-*-matrix identity-matrix1 (list matrix1 matrix2 matrix3))
+(fold-right matrix-*-matrix identity-matrix2 (list matrix1 matrix2 matrix3))
+; both '((103 -26) (-418 -622) (305 524))
+
+;; So the operation should be associative for fold-right and fold-left
+;; to give the same result.
View
@@ -0,0 +1,13 @@
+
+(define (reverse sequence)
+ (fold-right (λ (x y) (append y (list x)))
+ nil
+ sequence))
+
+(define (reverse sequence)
+ (fold-left (λ (x y) (cons y x))
+ nil
+ sequence))
+
+(reverse '(1 2 3 4))
+(reverse '(a b c))
View
@@ -0,0 +1,39 @@
+
+(define (unique-pairs n)
+ (flatmap (λ (i)
+ (map (λ (j)
+ (list i j))
+ (enumerate-interval 1 (- i 1))))
+ (enumerate-interval 1 n)))
+
+(unique-pairs 5)
+
+(define (prime-sum-pairs n)
+ (map make-pair-sum
+ (filter prime-sum?
+ (unique-pairs n))))
+
+;; Helper procedures
+(define (flatmap proc seq)
+ (accumulate append nil (map proc seq)))
+
+(define (prime-sum? pair)
+ (prime? (+ (car pair) (cadr pair))))
+
+(define (make-pair-sum pair)
+ (list (car pair) (cadr pair) (+ (car pair) (cadr pair))))
+
+(define (square x) (* x x))
+
+(define (prime? n)
+ (define (smallest-divisor n)
+ (find-divisor n 2))
+ (define (find-divisor n test-divisor)
+ (cond ((> (square test-divisor) n) n)
+ ((divides? test-divisor n) test-divisor)
+ (else (find-divisor n (+ test-divisor 1)))))
+ (define (divides? a b)
+ (= (remainder b a) 0))
+ (= n (smallest-divisor n)))
+
+(prime-sum-pairs 6)
View
@@ -0,0 +1,23 @@
+
+(define (unique-triples n)
+ (flatmap (λ (i)
+ (flatmap (λ (j)
+ (map (λ (k)
+ (list k j i))
+ (enumerate-interval 1 (- j 1))))
+ (enumerate-interval 1 (- i 1))))
+ (enumerate-interval 1 n)))
+
+(unique-triples 4) ; '((1 2 3) (1 2 4) (1 3 4) (2 3 4))
+
+(define (triplesum triple)
+ (+ (first triple)
+ (second triple)
+ (third triple)))
+
+(define (triples-less-than-or-equal-to-n-summing-to-s n s)
+ (filter (λ (triple) (= (triplesum triple) s))
+ (unique-triples n)))
+
+(triples-less-than-or-equal-to-n-summing-to-s 9 12)
+; '((3 4 5) (2 4 6) (1 5 6) (2 3 7) (1 4 7) (1 3 8) (1 2 9))
View
@@ -0,0 +1,138 @@
+
+;; From the book
+(define (enumerate-interval low high)
+ (if (> low high)
+ empty
+ (cons low (enumerate-interval (+ low 1) high))))
+
+(define (flatmap proc seq)
+ (accumulate append nil (map proc seq)))
+
+(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence)))))
+;; --------------
+
+(define nil empty)
+
+(define (add0 x) x)
+
+;; Produces a list of positions emanating like 3 rays from queen in center:
+;; diagonally up, left and diagonally down:
+;;
+;; *
+;; *
+;; *
+;; * * * Q
+;; *
+;; *
+;; *
+;;
+(define (rays center board-size)
+ (define (ray center orientation)
+ (let* ((rowstep (cond ((equal? orientation 'upstairs) sub1)
+ ((equal? orientation 'leftward) add0)
+ ((equal? orientation 'downstairs) add1)
+ (else
+ (error
+ "Must be 'upstairs, 'leftward or 'downstairs."))))
+ (rowindex (rowstep (car center)))
+ (columnindex (sub1 (cadr center)))
+ (out-of-board? (or (< rowindex 1)
+ (< columnindex 1)
+ (> rowindex board-size)
+ (> columnindex board-size))))
+ (if out-of-board?
+ empty
+ (cons (list rowindex columnindex)
+ (ray (list rowindex columnindex) orientation)))))
+ (append (ray center 'upstairs)
+ (ray center 'leftward)
+ (ray center 'downstairs)))
+
+(define (intersection set1 set2)
+ (flatmap (λ (pos1) (filter (λ (pos2) (equal? pos1 pos2))
+ set2))
+ set1))
+
+(define (disjoint? set1 set2)
+ (empty? (intersection set1 set2)))
+
+;; Unit tests
+(rays '(4 7) 8)
+
+(define queens1 '((3 1) (7 2) (2 3) (8 4) (5 5) (1 6)))
+(define queens2 (reverse queens1))
+
+(intersection queens2 (rays '(5 7) 8)) ; '((5 5) (8 4))
+
+(empty? (intersection '(1 2 3 10) '(0 3 5))) ; #f
+
+;; The main procedure. Position is a pair: (rowindex columnindex).
+;; Here chessboard squares are enumerated from upper left corner (1 1).
+(define (queens board-size)
+ (define empty-board '())
+ (define (adjoin-position new-row k rest-of-queens)
+ (cons (list new-row k) rest-of-queens))
+ (define (safe? k positions) ; k is not used
+ (disjoint? (rays (car positions) board-size)
+ (cdr positions)))
+ (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))
+
+;; Tests
+(queens 4) ; '(((3 4) (1 3) (4 2) (2 1)) ((2 4) (4 3) (1 2) (3 1))) (correct)
+(queens 8) ; '((6 8) (4 7) (1 6) (5 5) (8 4) (2 3) (7 2) (3 1))
+;; this is one solution from the generated sequence, same as in figure 2.8.
+
+;; Number of solutions with increasing board sizes:
+(length (queens 1)) ; 1
+(length (queens 2)) ; 0
+(length (queens 3)) ; 0
+(length (queens 4)) ; 2
+(length (queens 5)) ; 10
+(length (queens 6)) ; 4
+(length (queens 7)) ; 40
+(length (queens 8)) ; 92
+(length (queens 9)) ; 352
+(length (queens 10)) ; 724
+
+;; Appendix
+;; Testing map and filter
+(define (safe? k positions)
+ (disjoint? (rays (car positions) 8)
+ (cdr positions)))
+
+(filter
+ (lambda (positions) (safe? 1 positions))
+ (flatmap
+ (lambda (rest-of-queens)
+ (map (lambda (new-row)
+ (adjoin-position new-row
+ 1
+ rest-of-queens))
+ (enumerate-interval 1 8)))
+ '(())))
+
+(filter
+ (lambda (positions) (safe? 2 positions))
+ (flatmap
+ (lambda (rest-of-queens)
+ (map (lambda (new-row)
+ (adjoin-position new-row
+ 2
+ rest-of-queens))
+ (enumerate-interval 1 8)))
+ '(((1 1)) ((2 1)) ((3 1)) ((4 1)) ((5 1)) ((6 1)) ((7 1)) ((8 1)))))
Oops, something went wrong. Retry.

0 comments on commit 6380993

Please sign in to comment.