292 lines
7.9 KiB
Scheme
292 lines
7.9 KiB
Scheme
(load "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")
|
|
;(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).
|
|
|