sicp-2-2-3-sequences-as-interfaces

#lang racket

(require math/number-theory) ; for prime? used in 2.40

;;;;;;;;;;
;; 2.33 ;;
;;;;;;;;;;

(define (accumulate op initial sequence)
  (if (empty? sequence)
    initial
    (op (first sequence)
        (accumulate op initial (rest sequence)))))

(define (my-map p sequence)
  (accumulate (lambda (x y) (cons (p x) y)) empty sequence))

(my-map sqr (list 1 2 3))
;; '(1 4 9)

(define (my-append seq1 seq2)
  (accumulate cons seq2 seq1))

(my-append (list 1 2 3) (list 4 5 6))
;; '(1 2 3 4 5 6)

(define (my-length sequence)
  (accumulate (lambda (x y) (add1 y)) 0 sequence))

(my-length (list 1 2 3 4))
;; 4

;;;;;;;;;;
;; 2.34 ;;
;;;;;;;;;;

(define (horner-eval x coefficient-sequence)
  (accumulate (lambda (this-coeff higher-terms)
                (+ this-coeff (* x higher-terms)))
              0
              coefficient-sequence))

(horner-eval 2 (list 1 3 0 5 0 1)) ; 1 + 3 * 2 + 5 * 2 ^ 3 + 2 ^ 5 = 79
;; 79

;;;;;;;;;;
;; 2.35 ;;
;;;;;;;;;;

(define (enumerate-tree tree)
  (cond [(empty? tree) empty]
        [(not (pair? tree)) (list tree)]
        [else (append (enumerate-tree (first tree))
                      (enumerate-tree (rest tree)))]))

(define (count-leaves t)
  (accumulate +
              0
              (map (lambda (x) 1) (enumerate-tree t))))

(count-leaves (list (list 1 2) (list 3 (list 4 5))))
;; 5

;;;;;;;;;;
;; 2.36 ;;
;;;;;;;;;;

(define (accumulate-n op init seqs)
  (if (empty? (first seqs))
    empty
    (cons (accumulate op init (map first seqs))
          (accumulate-n op init (map rest seqs)))))

(accumulate-n +
              0
              (list (list 1 2 3)
                    (list 4 5 6)
                    (list 7 8 9)))
;; '(12 15 18)

;;;;;;;;;;
;; 2.37 ;;
;;;;;;;;;;

(define (dot-product v w)
  (accumulate + 0 (map * v w)))

(dot-product (list 1 2) (list 4 5))
;; 14

(define (matrix-*-vector m v)
  (map (lambda (row) (dot-product row v))
       m))

(matrix-*-vector (list (list 1 2 3)
                       (list 4 5 6)
                       (list 7 8 9))
                 (list 1 1 1))
;; '(6 15 24)

(define (transpose mat)
  (accumulate-n cons
                empty
                mat))

(transpose (list (list 1 2 3)
                 (list 4 5 6)
                 (list 7 8 9)))
;; '((1 4 7) (2 5 8) (3 6 9))

(define (matrix-*-matrix m n)
  (define cols (transpose n))
  (map (lambda (row) (matrix-*-vector cols row))
       m))

(matrix-*-matrix (list (list 1 2 3)
                       (list 4 5 6)
                       (list 7 8 9))
                 (list (list 0 1 0)
                       (list 0 0 1)
                       (list 1 0 0)))
;; '((3 1 2) (6 4 5) (9 7 8))

;;;;;;;;;;
;; 2.38 ;;
;;;;;;;;;;

(define fold-right accumulate)

(define (fold-left op initial sequence)
  (define (iter result rst)
    (if (null? rst)
      result
      (iter (op result (first rst))
            (rest rst))))
  (iter initial sequence))

(fold-right / 1 (list 1 2 3)) ; 1 / (2 / (3 / 1))
;; 3/2
(fold-left / 1 (list 1 2 3)) ; ((1 / 1) / 2) / 3
;; 1/6
(fold-right list empty (list 1 2 3))
;; '(1 (2 (3 ())))
(fold-left list empty (list 1 2 3))
;; '(((() 1) 2) 3)

;; If op is associative and initial is an identity for op, then fold-right and
;; fold-left will produce the same value for any sequence.  Also note that
;; fold-left is constant space but fold-right is linear space.

;;;;;;;;;;
;; 2.39 ;;
;;;;;;;;;;

(define (reverse1 sequence)
  (fold-right (lambda (x y) (append y (list x)))
              empty
              sequence))

(reverse1 (list 1 2 3))
;; '(3 2 1)

(define (reverse2 sequence)
  (fold-left (lambda (x y) (cons y x))
             empty
             sequence))

(reverse2 (list 1 2 3))
;; '(3 2 1)

;;;;;;;;;;
;; 2.40 ;;
;;;;;;;;;;

(define (enumerate-interval low high)
  (if (> low high)
    empty
    (cons low (enumerate-interval (add1 low) high))))

(define (flatmap proc seq) ; only sensible when proc returns a list
  (accumulate append empty (map proc seq)))

(define (prime-sum? pair)
  (prime? (+ (first pair) (second pair))))

(define (make-pair-sum pair)
  (list (first pair) (second pair) (+ (first pair) (second pair))))

(define (unique-pairs n)
  (flatmap (lambda (i)
             (map (lambda (j) (list i j))
                  (enumerate-interval 1 (sub1 i))))
           (enumerate-interval 1 n)))

(unique-pairs 5)
;; '((2 1) (3 1) (3 2) (4 1) (4 2) (4 3) (5 1) (5 2) (5 3) (5 4))

;; A more Racketeering way of writing unique-pairs would be to use the built-in
;; list comprehensions:

(define (racket-unique-pairs n)
  (for*/list ([i (in-range 1 (add1 n))]
              [j (in-range 1 i)])
             (list i j)))

(racket-unique-pairs 5)
;; '((2 1) (3 1) (3 2) (4 1) (4 2) (4 3) (5 1) (5 2) (5 3) (5 4))

(define (prime-sum-pairs n)
  (map make-pair-sum (filter prime-sum? (unique-pairs n))))

(prime-sum-pairs 5)
;; '((2 1 3) (3 2 5) (4 1 5) (4 3 7) (5 2 7))

;;;;;;;;;;
;; 2.41 ;;
;;;;;;;;;;

(define (sum-triples n s)
  (filter (lambda (triple) (= (apply + triple) s))
          (for*/list ([i (in-range 1 (add1 n))]
                      [j (in-range 1 i)]
                      [k (in-range 1 j)])
                     (list k j i))))

(sum-triples 9 12)
;; '((3 4 5) (2 4 6) (1 5 6) (2 3 7) (1 4 7) (1 3 8) (1 2 9))

;;;;;;;;;;
;; 2.42 ;;
;;;;;;;;;;

(define (queens board-size)
  (define (queen-cols k)
    (if (zero? k)
      (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 (sub1 k))))))
  (queen-cols board-size))

;; A queen is a list of row and column coordinates.  A position is a list of queens.

(define empty-board empty)

(define (make-queen column row) (list column row))
(define (col-coord queen) (first queen))
(define (row-coord queen) (second queen))

(define (adjoin-position column row position)
  (cons (make-queen column row) position))

(define (safe? k position)
  ; #t if the first queen in position is safe from the other k - 1 queens
  (define (safe-from-one? queen1 queen2)
    (and (not (= (col-coord queen1)
                 (col-coord queen2)))
         (not (= (row-coord queen1)
                 (row-coord queen2)))
         (not (= (abs (- (col-coord queen1) ; different diagonals
                         (col-coord queen2)))
                 (abs (- (row-coord queen1)
                         (row-coord queen2)))))))
  (andmap (lambda (q) (safe-from-one? (first position) q))
          (rest position)))

(queens 3)
;; '()

(queens 4)
;; '(((3 4) (1 3) (4 2) (2 1)) ((2 4) (4 3) (1 2) (3 1)))

(queens 5)
;; '(((4 5) (2 4) (5 3) (3 2) (1 1))
  ;; ((3 5) (5 4) (2 3) (4 2) (1 1))
  ;; ((5 5) (3 4) (1 3) (4 2) (2 1))
  ;; ((4 5) (1 4) (3 3) (5 2) (2 1))
  ;; ((5 5) (2 4) (4 3) (1 2) (3 1))
  ;; ((1 5) (4 4) (2 3) (5 2) (3 1))
  ;; ((2 5) (5 4) (3 3) (1 2) (4 1))
  ;; ((1 5) (3 4) (5 3) (2 2) (4 1))
  ;; ((3 5) (1 4) (4 3) (2 2) (5 1))
  ;; ((2 5) (4 4) (1 3) (3 2) (5 1)))

(queens 6)
;; '(((5 6) (3 5) (1 4) (6 3) (4 2) (2 1))
  ;; ((4 6) (1 5) (5 4) (2 3) (6 2) (3 1))
  ;; ((3 6) (6 5) (2 4) (5 3) (1 2) (4 1))
  ;; ((2 6) (4 5) (6 4) (1 3) (3 2) (5 1)))

;;;;;;;;;;
;; 2.43 ;;
;;;;;;;;;;

(define (slow-queens board-size)
  (define (slow-queen-cols k)
    (if (zero? k)
      (list empty-board)
      (filter (lambda (positions) (safe? k positions))
              (flatmap (lambda (new-row)
                         (map (lambda (rest-of-queens)
                                (adjoin-position new-row k rest-of-queens))
                              (slow-queen-cols (sub1 k))))
                       (enumerate-interval 1 board-size)))))
  (slow-queen-cols board-size))

;; Interchanging the order of the loops causes the program to needlessly repeat
;; the call to queen-cols(k - 1) board-size times, for each new column k.  But
;; it's even worse than that, because each one of those calls causes the program
;; to needlessly repeat all the recursive calls to queen-cols(j) for smaller j.

;; I'm not really sure what that does to the overall run time of queens(n).  I
;; think it should be increased by a factor = 1 + n + n ^ 2 + ... + n ^ (n - 1)
;; which is on the order of n ^ (n - 1), but I couldn't get enough run times to
;; really test that.

(for ([n (in-range 6 10)])
  (define fast-start-time (current-inexact-milliseconds))
  (define fast-num-solns (queens n))
  (define fast-time (- (current-inexact-milliseconds) fast-start-time))
  (define slow-start-time (current-inexact-milliseconds))
  (define slow-num-solns (slow-queens n))
  (define slow-time (- (current-inexact-milliseconds) slow-start-time))
  (printf "~a ~a ~a ~a ~a ~a ~n"
          n
          (length fast-num-solns)
          (round fast-time)
          (length slow-num-solns)
          (round slow-time)
          (round (/ slow-time fast-time))))

;;   n   solns1   fast-time   solns2   slow-time   ratio
;;   6   4        1.0         4        101.0       101.0
;;   7   40       3.0         40       1571.0      523.0
;;   8   92       15.0        92       32677.0     2252.0
;;   9   352      82.0        352      776164.0    9459.0