SICP/ex-2_33-43.scm

(load "shared/util.scm")

(display "\nex-2.33 - list operations in terms of accumulate\n")

(define (accumulate op initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence)
          (accumulate op initial (cdr sequence)))))

(define (map-acc p sequence)
  (accumulate (lambda (x y) (cons (p x) y)) nil sequence))

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

(define (length-acc sequence)
  (accumulate (lambda (x y) (+ 1 y)) 0 sequence))

(display (map-acc square (list 1 2 3))) (newline)
(display (append-acc (list 1 2 3) (list 4 5 6))) (newline)
(display (length-acc (list 1 2 3))) (newline)

(display "\nex-2.34 - Horner's rule\n")

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

(display (horner-eval 2 (list 1 3 0 5 0 1))) (newline)


(display "\nex-2.35 - count-leaves via accumulate\n")

(define x (cons (list 1 2) (list 3 4)))

(define (count-leaves t)
  (define (count-leaves-sub t)
    (cond ((null? t) 0)
          ((pair? t) (count-leaves t))
          (else 1)))
  (accumulate + 0 (map count-leaves-sub t)))

(display (count-leaves x)) (newline)

(display "\nex-2.36 - accumulate-n\n")

(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)))))

(display (accumulate-n +
                       0
                       (list (list 1 2) (list 3 4) (list 5 6))))
(newline)
; (9 12)

(display "\nex-2.37 - matrix operations\n")

(define (display-matrix m)
  (map (lambda (row) (display row) (newline)) m))

(define m (list (list 1 2 3)
                (list 4 5 6)
                (list 7 8 9)))
(define v (list 3 2 1))

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

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

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

(define (matrix-*-matrix m n)
  (let ((cols (transpose n)))
    (map (lambda (r) (map (lambda (c) (dot-product r c)) cols)) m)))

(display (dot-product v v)) (newline)
(display (matrix-*-vector m v)) (newline)
(display-matrix (transpose m)) (newline)
(display-matrix (matrix-*-matrix m m))

(display "\nex-2.38\n")

(define (fold-left op initial sequence)
  (define (iter result rest)
    (if (null? rest)
        result
        (iter (op result (car rest))
              (cdr rest))))
  (iter initial sequence))

(define (fold-right op initial sequence) ; same as accumulate
  (if (null? sequence)
      initial
      (op (car sequence)
          (fold-right op initial (cdr sequence)))))

(display (fold-right / 1 (list 1 2 3))) (newline)      ; 3/2
(display (fold-left / 1 (list 1 2 3))) (newline)       ; 1/6
(display (fold-right list nil (list 1 2 3))) (newline) ; (1 (2 (3 ())
(display (fold-left list nil (list 1 2 3))) (newline)  ; (() 1) 2) 3)

(display "\nex-2.39 - reverse via foldl and foldr\n")

(define (reverse-l sequence)
  (fold-left (lambda (x y) (cons y x)) nil sequence))

(define (reverse-r sequence)
  (fold-right (lambda (x y) (append y (list x))) nil sequence))


(display (reverse-r (list 1 2 3 4))) (newline)
(display (reverse-l (list 1 2 3 4))) (newline)

(display "\nex-2.40 - prime pairs\n")

(define (flatmap proc seq)
  (accumulate append nil (map proc seq)))

; Two versions for remove from me and the official one
(define (remove x s)
  (cond
    ((null? s) s)
    ((= x (car s)) (cdr s))
    (else (cons (car s) (remove x (cdr s))))))

(define (remove x s)
  (accumulate (lambda (current rest)
                (if (= current x) rest (cons current rest)))
              nil s))

(define (remove item sequence)
  (filter (lambda (x) (not (= x item)))
          sequence))

(define (prime-sum? p) (prime? (+ (car p) (cadr p))))

(define (prime-sum-pairs n)
  (map make-pair-sum
       (filter prime-sum?
               (flatmap
                (lambda (i)
                  (map (lambda (j) (list i j))
                       (enumerate-interval 1 (- i 1))))
                (enumerate-interval 1 n)))))

(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 (make-pair-sum p)
  (list (car p) (cadr p) (+ (car p) (cadr p))))

(display (permutations (list 1 2))) (newline)
(display (prime-sum-pairs 3)) (newline)

; Here starts the actual exercise
(define (unique-pairs n)
  (flatmap
    (lambda (a) (map (lambda (b) (list a b)) (enumerate-interval 1 (- a 1))))
    (enumerate-interval 1 n)))

(display (unique-pairs 3)) (newline)

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

(display (prime-sum-pairs 3)) (newline)


(display "\nex-2.41 - unique triples\n")

(define (unique-triples n)
  (flatmap
    (lambda (c)
      (flatmap (lambda (b)
                 (map (lambda (a) (list a b c))
                  (enumerate-interval 1 (- b 1))))
        (enumerate-interval 1 (- c 1))))
      (enumerate-interval 1 n)))


(define (add-lower-numbers xs)
  (flatmap
    (lambda (x)
      (map (lambda (i) (cons i x))
           (enumerate-interval 1 (- (car x) 1))))
    xs))

(define (unique-tuples n k)
  (define (add-element tuples k)
    (if (= k 0)
      tuples
      (add-element (add-lower-numbers tuples) (- k 1))))
  (add-element (map list (enumerate-interval 1 n)) (- k 1)))

(define (list-sum l)
  (accumulate + 0 l))

(define (unique-sum-triples n s)
  (filter (lambda (t) (= (list-sum t) s)) (unique-triples n)))

(display (unique-sum-triples 6 10)) (newline)

(define (unique-sum-triples n s)
  (filter (lambda (t) (= (list-sum t) s)) (unique-tuples n 3)))

(display (unique-sum-triples 6 10)) (newline)

(display "\nex-2.42 - eight queens\n")

; Creates a new list with numbers [1..n] cons'd to the current lists
(define (add-numbers n xs)
  (flatmap
    (lambda (x) (map (lambda (i) (cons i x)) (enumerate-interval 1 n)))
    xs))

; Checks if the first queen on the board is safe relative to the other queens
(define (safe? board)
  (define (valid-position row diag board)
    (if (null? board)
      #t
      (let ((cur_row (car board)))
        (if (or (= row cur_row)           ; same row
                (= (+ row diag) cur_row)  ; upper right diagonal
                (= (- row diag) cur_row)) ; lower left diagonal
          #f
          (valid-position row (+ diag 1) (cdr board))))))
  (valid-position (car board) 1 (cdr board)))

(define empty-board (list nil))

(define (queens n)
  (define (queens-cols k)
    (if (= k 0)
      empty-board
      (filter safe? (add-numbers n (queens-cols (- k 1))))))
  (queens-cols n))

(display (length (queens 8))) (newline)

; Till here was my own implementation for practice.
; Here is the official solution:

(define (adjoin-position new-row k rest-of-queens)
  (cons new-row rest-of-queens))

(define (queens board-size)
  (define empty-board nil)
  (define (queen-cols k)
    (if (= k 0)
        (list empty-board)
        (filter
         (lambda (positions) (safe? positions)) ; removed k because we don't need it
         (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))

(display (length (queens 8))) (newline)

(display "\nex-2.43 - see comments\n")
(display "[done]\n")

;(flatmap
; (lambda (new-row)
;   (map (lambda (rest-of-queens)
;          (adjoin-position new-row k rest-of-queens))
;        (queen-cols (- k 1))))
; (enumerate-interval 1 board-size))

; Louis' implementation computes the queens for the remaining columns
; board-size times for each column. That means for two columns the program is
; two times slower. For three, two times times three times, in other words, the
; execution time is (board-size! * T).