commit 95d9109ee298e00aba7940524f076e37bf56c744 parent 11a5759d3ad293cc2e38127888edf5d1e2db503e Author: Yuval Langer <yuval.langer@gmail.com> Date: Mon, 27 Mar 2023 17:14:31 +0300 Fix exercise 2.69 solution and restructure directories: * Fix exercise 2.69 solution. * Move `./utils*scm` to `./sicp/` * Move tests from `./solutions/tests/` to `./sicp/tests/`. * Move solutions from `./solutions/` to `./sicp/solutions/`. Diffstat:
84 files changed, 250 insertions(+), 200 deletions(-)
diff --git a/solutions/exercise-1.1.scm b/sicp/solutions/exercise-1.1.scm diff --git a/solutions/exercise-1.10.scm b/sicp/solutions/exercise-1.10.scm diff --git a/solutions/exercise-1.11.scm b/sicp/solutions/exercise-1.11.scm diff --git a/solutions/exercise-1.12.scm b/sicp/solutions/exercise-1.12.scm diff --git a/solutions/exercise-1.13.scm b/sicp/solutions/exercise-1.13.scm diff --git a/solutions/exercise-1.14.scm b/sicp/solutions/exercise-1.14.scm diff --git a/solutions/exercise-1.16.scm b/sicp/solutions/exercise-1.16.scm diff --git a/solutions/exercise-1.17.scm b/sicp/solutions/exercise-1.17.scm diff --git a/solutions/exercise-1.18.scm b/sicp/solutions/exercise-1.18.scm diff --git a/solutions/exercise-1.19.scm b/sicp/solutions/exercise-1.19.scm diff --git a/solutions/exercise-1.2.scm b/sicp/solutions/exercise-1.2.scm diff --git a/solutions/exercise-1.20.scm b/sicp/solutions/exercise-1.20.scm diff --git a/solutions/exercise-1.21.scm b/sicp/solutions/exercise-1.21.scm diff --git a/solutions/exercise-1.22.scm b/sicp/solutions/exercise-1.22.scm diff --git a/solutions/exercise-1.23.scm b/sicp/solutions/exercise-1.23.scm diff --git a/solutions/exercise-1.24.scm b/sicp/solutions/exercise-1.24.scm diff --git a/solutions/exercise-1.3.scm b/sicp/solutions/exercise-1.3.scm diff --git a/solutions/exercise-1.4.scm b/sicp/solutions/exercise-1.4.scm diff --git a/solutions/exercise-1.5.scm b/sicp/solutions/exercise-1.5.scm diff --git a/solutions/exercise-1.6.scm b/sicp/solutions/exercise-1.6.scm diff --git a/solutions/exercise-1.7.scm b/sicp/solutions/exercise-1.7.scm diff --git a/solutions/exercise-1.8.scm b/sicp/solutions/exercise-1.8.scm diff --git a/solutions/exercise-1.9.scm b/sicp/solutions/exercise-1.9.scm diff --git a/solutions/exercise-2.1.scm b/sicp/solutions/exercise-2.1.scm diff --git a/solutions/exercise-2.17.scm b/sicp/solutions/exercise-2.17.scm diff --git a/solutions/exercise-2.18.scm b/sicp/solutions/exercise-2.18.scm diff --git a/solutions/exercise-2.19.scm b/sicp/solutions/exercise-2.19.scm diff --git a/solutions/exercise-2.2.scm b/sicp/solutions/exercise-2.2.scm diff --git a/solutions/exercise-2.20.scm b/sicp/solutions/exercise-2.20.scm diff --git a/solutions/exercise-2.21.scm b/sicp/solutions/exercise-2.21.scm diff --git a/solutions/exercise-2.22.scm b/sicp/solutions/exercise-2.22.scm diff --git a/solutions/exercise-2.23.scm b/sicp/solutions/exercise-2.23.scm diff --git a/solutions/exercise-2.24.scm b/sicp/solutions/exercise-2.24.scm diff --git a/solutions/exercise-2.25.scm b/sicp/solutions/exercise-2.25.scm diff --git a/solutions/exercise-2.26.scm b/sicp/solutions/exercise-2.26.scm diff --git a/solutions/exercise-2.27.scm b/sicp/solutions/exercise-2.27.scm diff --git a/solutions/exercise-2.28.scm b/sicp/solutions/exercise-2.28.scm diff --git a/solutions/exercise-2.29.scm b/sicp/solutions/exercise-2.29.scm diff --git a/solutions/exercise-2.3.scm b/sicp/solutions/exercise-2.3.scm diff --git a/solutions/exercise-2.30.scm b/sicp/solutions/exercise-2.30.scm diff --git a/solutions/exercise-2.31.scm b/sicp/solutions/exercise-2.31.scm diff --git a/solutions/exercise-2.32.scm b/sicp/solutions/exercise-2.32.scm diff --git a/solutions/exercise-2.33.scm b/sicp/solutions/exercise-2.33.scm diff --git a/solutions/exercise-2.34.scm b/sicp/solutions/exercise-2.34.scm diff --git a/solutions/exercise-2.35.scm b/sicp/solutions/exercise-2.35.scm diff --git a/solutions/exercise-2.36.scm b/sicp/solutions/exercise-2.36.scm diff --git a/solutions/exercise-2.37.scm b/sicp/solutions/exercise-2.37.scm diff --git a/solutions/exercise-2.38.scm b/sicp/solutions/exercise-2.38.scm diff --git a/solutions/exercise-2.39.scm b/sicp/solutions/exercise-2.39.scm diff --git a/solutions/exercise-2.4.scm b/sicp/solutions/exercise-2.4.scm diff --git a/solutions/exercise-2.40.scm b/sicp/solutions/exercise-2.40.scm diff --git a/solutions/exercise-2.41.scm b/sicp/solutions/exercise-2.41.scm diff --git a/solutions/exercise-2.42.scm b/sicp/solutions/exercise-2.42.scm diff --git a/solutions/exercise-2.5.scm b/sicp/solutions/exercise-2.5.scm diff --git a/solutions/exercise-2.53.scm b/sicp/solutions/exercise-2.53.scm diff --git a/solutions/exercise-2.54.scm b/sicp/solutions/exercise-2.54.scm diff --git a/solutions/exercise-2.55.scm b/sicp/solutions/exercise-2.55.scm diff --git a/solutions/exercise-2.56.scm b/sicp/solutions/exercise-2.56.scm diff --git a/solutions/exercise-2.59.scm b/sicp/solutions/exercise-2.59.scm diff --git a/solutions/exercise-2.6.scm b/sicp/solutions/exercise-2.6.scm diff --git a/solutions/exercise-2.60.scm b/sicp/solutions/exercise-2.60.scm diff --git a/solutions/exercise-2.61-2.62.scm b/sicp/solutions/exercise-2.61-2.62.scm diff --git a/solutions/exercise-2.64.scm b/sicp/solutions/exercise-2.64.scm diff --git a/solutions/exercise-2.7.scm b/sicp/solutions/exercise-2.7.scm diff --git a/sicp/solutions/huffman-codes-stuff.scm b/sicp/solutions/huffman-codes-stuff.scm @@ -0,0 +1,180 @@ +(define-library (sicp solutions huffman-codes-stuff) + (import (scheme base)) + (import (scheme cxr)) + (import (sicp utils)) + (export make-code-tree + make-leaf + sample-message + sample-tree + generate-huffman-tree) + + (begin + (define (make-leaf symbol weight) + (list 'leaf symbol weight)) + + (define (leaf? object) + (eq? (car object) 'leaf)) + + (define (symbol-leaf x) (cadr x)) + (define (weight-leaf x) (caddr x)) + + (define (make-code-tree left right) + (list left + right + (append (symbols left) + (symbols right)) + (+ (weight left) + (weight right)))) + + (define (left-branch tree) (car tree)) + (define (right-branch tree) (cadr tree)) + + (define (symbols tree) + (if (leaf? tree) + (list (symbol-leaf tree)) + (caddr tree))) + + (define (weight tree) + (if (leaf? tree) + (weight-leaf tree) + (cadddr tree))) + + (define (decode bits tree) + (define (decode-1 bits current-branch) + (if (null? bits) + '() + (let ([next-branch + (choose-branch + (car bits) + current-branch)]) + (if (leaf? next-branch) + (cons + (symbol-leaf next-branch) + (decode-1 (cdr bits) tree)) + (decode-1 (cdr bits) + next-branch))))) + (decode-1 bits tree)) + (define (choose-branch bit branch) + (cond ((= bit 0) (left-branch branch)) + ((= bit 1) (right-branch branch)) + (else (error "Bad bit: + CHOOSE-BRANCH" bit)))) + + (define (adjoin-set x set) + (cond + ((null? set) (list x)) + ((< (weight x) + (weight (car set))) + (cons x set)) + (else (cons (car set) + (adjoin-set x + (cdr set)))))) + + (define (make-leaf-set pairs) + (if (null? pairs) + '() + (let ([pair (car pairs)]) + (adjoin-set + (make-leaf (car pair) + (cadr pair)) + (make-leaf-set (cdr pairs)))))) + + ;; Exercise 2.67 + + (define sample-tree + (make-code-tree + (make-leaf 'A 4) + (make-code-tree + (make-leaf 'B 2) + (make-code-tree + (make-leaf 'D 1) + (make-leaf 'C 1))))) + + (define sample-message + '(0 1 1 0 0 1 0 1 0 1 1 1 0)) + + + ;; Exercise 2.68 + + (define (element-of-set? x elements) + (cond + ((null? elements) #f) + ((eq? x (car elements)) #t) + (else (element-of-set? x (cdr elements))))) + + (define (encode-symbol symbol tree) + (define (encode-symbol' bits current-tree) + (cond + ((leaf? current-tree) bits) + ((element-of-set? symbol + (symbols (left-branch current-tree))) + (encode-symbol' (cons 0 bits) + (left-branch current-tree))) + ((element-of-set? symbol + (symbols (right-branch current-tree))) + (encode-symbol' (cons 1 bits) + (right-branch current-tree))) + (else (error "Symbol is unknown: " symbol)))) + + (reverse (encode-symbol' '() tree))) + + (define (encode message tree) + (if (null? message) + '() + (append + (encode-symbol (car message) + tree) + (encode (cdr message) + tree)))) + + '({(A 8) (B 3) (C 1) (D 1) (E 1) (F 1) (G 1) (H 1)} + {(A 8) (B 3) ({C D} 2) (E 1) (F 1) (G 1) (H 1)} + {(A 8) (B 3) ({C D} 2) ({E F} 2) (G 1) (H 1)} + {(A 8) (B 3) ({C D} 2) ({E F} 2) ({G H} 2)} + {(A 8) (B 3) ({C D} 2) ({E F G H} 4)} + {(A 8) ({B C D} 5) ({E F G H} 4)} + {(A 8) ({B C D E F G H} 9)} + {({A B C D E F G H} 17)}) + + (define (successive-merge leaf-set) + (define (inner-merge leaf-set) + (define minimal-weighted-leaf + (accumulate (lambda (x y) (if (< (weight x) + (weight y)) + x + y)) + (car leaf-set) + leaf-set)) + (define leaf-set-without-minimal-weighted-leaf + (filter (lambda (x) (not (equal? minimal-weighted-leaf + x))) + leaf-set)) + (define next-to-minimal-weighted-leaf + (accumulate (lambda (x y) (if (< (weight x) + (weight y)) + x + y)) + (car leaf-set-without-minimal-weighted-leaf) + leaf-set-without-minimal-weighted-leaf)) + (define results + (cons (make-code-tree + next-to-minimal-weighted-leaf + minimal-weighted-leaf) + (filter (lambda (x) (not (equal? next-to-minimal-weighted-leaf + x))) + leaf-set-without-minimal-weighted-leaf))) + + results) + + (define (successive-merge' leaf-set) + (cond + ((null? leaf-set) + (error "Empty set of weighted symbols:" leaf-set)) + ((null? (cdr leaf-set)) leaf-set) + (else (successive-merge' (inner-merge leaf-set))))) + + (car (successive-merge' leaf-set))) + + (define (generate-huffman-tree pairs) + (successive-merge + (make-leaf-set pairs))))) diff --git a/solutions/tree-stuff.scm b/sicp/solutions/tree-stuff.scm diff --git a/solutions/tests/exercise-1.21-tests.scm b/sicp/tests/exercise-1.21-tests.scm diff --git a/solutions/tests/exercise-2.33-tests.scm b/sicp/tests/exercise-2.33-tests.scm diff --git a/solutions/tests/exercise-2.34-tests.scm b/sicp/tests/exercise-2.34-tests.scm diff --git a/solutions/tests/exercise-2.35-tests.scm b/sicp/tests/exercise-2.35-tests.scm diff --git a/solutions/tests/exercise-2.36-tests.scm b/sicp/tests/exercise-2.36-tests.scm diff --git a/solutions/tests/exercise-2.40-tests.scm b/sicp/tests/exercise-2.40-tests.scm diff --git a/solutions/tests/exercise-2.41-tests.scm b/sicp/tests/exercise-2.41-tests.scm diff --git a/solutions/tests/exercise-2.42-tests.scm b/sicp/tests/exercise-2.42-tests.scm diff --git a/solutions/tests/exercise-2.61-tests.scm b/sicp/tests/exercise-2.61-tests.scm diff --git a/solutions/tests/exercise-2.62-tests.scm b/sicp/tests/exercise-2.62-tests.scm diff --git a/solutions/tests/exercise-2.67-tests.scm b/sicp/tests/exercise-2.67-tests.scm diff --git a/solutions/tests/exercise-2.68-tests.scm b/sicp/tests/exercise-2.68-tests.scm diff --git a/sicp/tests/exercise-2.69-tests.scm b/sicp/tests/exercise-2.69-tests.scm @@ -0,0 +1,28 @@ +(import (srfi :64)) +(import (sicp solutions huffman-codes-stuff)) + +'(make-code-tree + (make-code-tree (make-leaf 'A 1) + (make-leaf 'B 1)) + (make-code-tree (make-leaf 'C 1) + (make-leaf 'D 1))) +'(((leaf A 1) (leaf B 1) (A B) 2) + ((leaf C 1) (leaf D 1) (C D) 2) + (A B C D) + 4) + +(test-begin "2.69") +(test-equal + (make-leaf 'A 1) + (generate-huffman-tree '((A 1)))) +(test-equal + (make-code-tree (make-leaf 'A 1) + (make-leaf 'B 1)) + (generate-huffman-tree '((A 1) (B 1)))) +(test-equal + sample-tree + (generate-huffman-tree '((D 1) + (C 1) + (B 2) + (A 4)))) +(test-end "2.69") diff --git a/utils-tests.scm b/sicp/utils-tests.scm diff --git a/sicp/utils.scm b/sicp/utils.scm @@ -0,0 +1,42 @@ +(define-library (sicp utils) + (import (scheme base)) + (import (srfi srfi-1)) + (import (srfi srfi-64)) + (export enumerate-interval + filter + flatmap + accumulate) + + (begin + (define (filter predicate sequence) + ;; From 2.2.3 Sequences as Conventional Interfaces + (cond ((null? sequence) nil) + ((predicate (car sequence)) + (cons (car sequence) + (filter predicate + (cdr sequence)))) + (else (filter predicate + (cdr sequence))))) + + (define (enumerate-interval low high) + ;; (iota (- high low -1) low) + ;; From 2.2.3 Sequences as Conventional Interfaces + (if (> low high) + '() + (cons low + (enumerate-interval (+ 1 low) + high)))) + + (define (accumulate op initial sequence) + ;; From 2.2.3 Sequences as Conventional Interfaces + (if (null? sequence) + initial + (op (car sequence) + (accumulate op + initial + (cdr sequence))))) + + (define (flatmap proc seq) + (accumulate append + '() + (map proc seq))))) diff --git a/solutions/huffman-codes-stuff.scm b/solutions/huffman-codes-stuff.scm @@ -1,143 +0,0 @@ -(define-library (huffman-codes-stuff) - (import (scheme base)) - (import (scheme cxr)) - (export make-code-tree - make-leaf - sample-message - sample-tree - generate-huffman-tree) - - (begin - (define (make-leaf symbol weight) - (list 'leaf symbol weight)) - - (define (leaf? object) - (eq? (car object) 'leaf)) - - (define (symbol-leaf x) (cadr x)) - (define (weight-leaf x) (caddr x)) - - (define (make-code-tree left right) - (list left - right - (append (symbols left) - (symbols right)) - (+ (weight left) - (weight right)))) - - (define (left-branch tree) (car tree)) - (define (right-branch tree) (cadr tree)) - - (define (symbols tree) - (if (leaf? tree) - (list (symbol-leaf tree)) - (caddr tree))) - - (define (weight tree) - (if (leaf? tree) - (weight-leaf tree) - (cadddr tree))) - - (define (decode bits tree) - (define (decode-1 bits current-branch) - (if (null? bits) - '() - (let ([next-branch - (choose-branch - (car bits) - current-branch)]) - (if (leaf? next-branch) - (cons - (symbol-leaf next-branch) - (decode-1 (cdr bits) tree)) - (decode-1 (cdr bits) - next-branch))))) - (decode-1 bits tree)) - (define (choose-branch bit branch) - (cond ((= bit 0) (left-branch branch)) - ((= bit 1) (right-branch branch)) - (else (error "Bad bit: - CHOOSE-BRANCH" bit)))) - - (define (adjoin-set x set) - (cond - ((null? set) (list x)) - ((< (weight x) - (weight (car set))) - (cons x set)) - (else (cons (car set) - (adjoin-set x - (cdr set)))))) - - (define (make-leaf-set pairs) - (if (null? pairs) - '() - (let ([pair (car pairs)]) - (adjoin-set - (make-leaf (car pair) - (cadr pair)) - (make-leaf-set (cdr pairs)))))) - - ;; Exercise 2.67 - - (define sample-tree - (make-code-tree - (make-leaf 'A 4) - (make-code-tree - (make-leaf 'B 2) - (make-code-tree - (make-leaf 'D 1) - (make-leaf 'C 1))))) - - (define sample-message - '(0 1 1 0 0 1 0 1 0 1 1 1 0)) - - - ;; Exercise 2.68 - - (define (element-of-set? x elements) - (cond - ((null? elements) #f) - ((eq? x (car elements)) #t) - (else (element-of-set? x (cdr elements))))) - - (define (encode-symbol symbol tree) - (define (encode-symbol' bits current-tree) - (cond - ((leaf? current-tree) bits) - ((element-of-set? symbol - (symbols (left-branch current-tree))) - (encode-symbol' (cons 0 bits) - (left-branch current-tree))) - ((element-of-set? symbol - (symbols (right-branch current-tree))) - (encode-symbol' (cons 1 bits) - (right-branch current-tree))) - (else (error "Symbol is unknown: " symbol)))) - - (reverse (encode-symbol' '() tree))) - - (define (encode message tree) - (if (null? message) - '() - (append - (encode-symbol (car message) - tree) - (encode (cdr message) - tree)))) - - (define (successive-merge leaf-set) - (define (successive-merge' leaf-set) - (cond - ((null? leaf-set) '()) - ((null? (cdr leaf-set)) - (car leaf-set)) - (else (make-code-tree - (car leaf-set) - (successive-merge' - (cdr leaf-set)))))) - (successive-merge' (reverse leaf-set))) - - (define (generate-huffman-tree pairs) - (successive-merge - (make-leaf-set pairs))))) diff --git a/solutions/tests/exercise-2.69-tests.scm b/solutions/tests/exercise-2.69-tests.scm @@ -1,28 +0,0 @@ -(import (srfi :64)) -(import (huffman-codes-stuff)) - -'(make-code-tree - (make-code-tree (make-leaf 'A 1) - (make-leaf 'B 1)) - (make-code-tree (make-leaf 'C 1) - (make-leaf 'D 1))) -'(((leaf A 1) (leaf B 1) (A B) 2) - ((leaf C 1) (leaf D 1) (C D) 2) - (A B C D) - 4) - -(test-begin "2.69") -(test-equal - (make-leaf 'A 1) - (generate-huffman-tree '((A 1)))) -(test-equal - (make-code-tree (make-leaf 'A 1) - (make-leaf 'B 1)) - (generate-huffman-tree '((A 1) (B 1)))) -(test-equal - sample-tree - (generate-huffman-tree '((D 1) - (C 1) - (B 2) - (A 4)))) -(test-end "2.69") diff --git a/utils.scm b/utils.scm @@ -1,29 +0,0 @@ -(define-library (sicp utils) - (import (scheme base)) - (import (srfi srfi-1)) - (import (srfi srfi-64)) - (export accumulate enumerate-interval flatmap) - - (begin - (define (enumerate-interval low high) -;; (iota (- high low -1) low) -;; From 2.2.3 Sequences as Conventional Interfaces - (if (> low high) - '() - (cons low - (enumerate-interval (+ 1 low) - high)))) - - (define (accumulate op initial sequence) - ;; From 2.2.3 Sequences as Conventional Interfaces - (if (null? sequence) - initial - (op (car sequence) - (accumulate op - initial - (cdr sequence))))) - - (define (flatmap proc seq) - (accumulate append - '() - (map proc seq)))))