SICP/ex-2_59-66.scm

(load "shared/util.scm")

(display "example - set via unordered list\n")

(define (element-of-set? x set)
  (cond ((null? set) false)
        ((equal? x (car set)) true)
        (else (element-of-set? x (cdr set)))))

(define (adjoin-set x set)
  (if (element-of-set? x set)
    set
    (cons x set)))

(define (intersection-set s1 s2)
  (cond
    ((or (null? s1) (null? s2)) '())
    ((element-of-set? (car s1) s2) (cons (car s1) (intersection-set (cdr s1) s2)))
    (else (intersection-set (cdr s1) s2))))

(define s '(3 1 5))
(display (element-of-set? 3 s)) (newline)
(display (element-of-set? 4 s)) (newline)
(display (adjoin-set 3 s)) (newline)
(display (adjoin-set 4 s)) (newline)
(display (intersection-set s '(3 1))) (newline)


(display "\nex-2.59 - union-set") (newline)

(define (union-set s1 s2)
  (cond
    ((null? s1) s2)
    ((element-of-set? (car s1) s2) (union-set (cdr s1) s2))
    (else (union-set (cdr s1) (cons (car s1) s2)))))


(display (union-set '(3 2 1) '(5 3))) (newline)


(display "\nex-2.60 - set via list with duplicates") (newline)

; Does not change, but runtime increases because we have to iterate over the
; duplicates.
(define element-of-set?-dup element-of-set?)

(define s '(3 1 3 5))
(display (element-of-set?-dup 3 s)) (newline)
(display (element-of-set?-dup 4 s)) (newline)

; Runtime is constant.
(define (adjoin-set-dup x set) (cons x set))
(display (adjoin-set 3 s)) (newline)
(display (adjoin-set 4 s)) (newline)

; Also stays the same, but becomes more expensive because of duplicates.
(define intersection-set-dup intersection-set)
(display (intersection-set s '(3 1))) (newline)

; We could also implement a version that de-duplicates but becomes even more
; expensive.
(define (intersection-set-dup s1 s2)
  (if (or (null? s1) (null? s2))
    '()
    (let ((rest (intersection-set-dup (cdr s1) s2)))
      (if (and (element-of-set?-dup (car s1) s2)
               (not (element-of-set?-dup (car s1) rest)))
        (adjoin-set-dup (car s1) rest)
        rest))))
(display (intersection-set-dup s '(3 1))) (newline)

(define union-set-dup append)
(display (union-set-dup '(3 2 1) '(5 3))) (newline)

; Applications that do a lot of adjoin and union operations would benefit from
; this representation because they run in O(1) and O(n) runtime respectively.

(display "\nex-2.61 - set via ordered list") (newline)

(define (element-of-set? x set)
  (cond ((null? set) false)
        ((= x (car set)) true)
        ((< x (car set)) false)
        (else (element-of-set? x (cdr set)))))

(define (intersection-set s1 s2)
  (if (or (null? s1) (null? s2))
      '()
      (let ((x1 (car s1)) (x2 (car s2)))
        (cond
          ((= x1 x2) (cons x1 (intersection-set (cdr s1) (cdr s2))))
          ((< x1 x2) (intersection-set (cdr s1) s2))
          ((> x1 x2) (intersection-set  s1 (cdr s2)))))))

(define (adjoin-set x set)
  (cond
    ((null? set) (list x))
    ((= x (car set)) set)
    ((< x (car set)) (cons x set))
    (else (cons (car set) (adjoin-set x (cdr set))))))

(define s '(1 3 5))
(display (element-of-set? 3 s)) (newline)
(display (element-of-set? 4 s)) (newline)
(display (adjoin-set 3 s)) (newline)
(display (adjoin-set 4 s)) (newline)
(display (adjoin-set 4 '())) (newline)
(display (adjoin-set 8 s)) (newline)
(display (intersection-set s '(1 3))) (newline)

(display "\nex-2.62") (newline)

(define (union-set s1 s2)
  (cond
    ((null? s1) s2)
    ((null? s2) s1)
    (else
      (let ((x1 (car s1)) (x2 (car s2)))
        (cond
          ((= x1 x2) (cons x1 (union-set (cdr s1) (cdr s2))))
          ((< x1 x2) (cons x1 (union-set (cdr s1) s2)))
          ((> x1 x2) (cons x2 (union-set s1 (cdr s2)))))))))

(display (union-set '(1 3 5 6 7) '(2 3 4 10))) (newline)

(assert (union-set (list 1 3 5) (list 2 4 6)) (list 1 2 3 4 5 6))
(assert (union-set (list 1 3 5) '()) (list 1 3 5))
(assert (union-set '() (list 1 3 5)) (list 1 3 5))
(assert (union-set (list 1 2 5) (list 2 5 6)) (list 1 2 5 6))

(display "\nexample - set via binary tree\n")

(define (entry tree) (car tree))
(define (left-branch tree) (cadr tree))
(define (right-branch tree) (caddr tree))
(define leaf '())
(define (make-tree entry left right)
  (list entry left right))

(define (element-of-set? x set)
  (cond ((null? set) false)
        ((= x (entry set)) true)
        ((< x (entry set))
         (element-of-set? x (left-branch set)))
        ((> x (entry set))
         (element-of-set? x (right-branch set)))))

(define (adjoin-set x set)
  (cond ((null? set) (make-tree x '() '()))
        ((= x (entry set)) set)
        ((< x (entry set))
         (make-tree (entry set)
                    (adjoin-set x (left-branch set))
                    (right-branch set)))
        ((> x (entry set))
         (make-tree (entry set)
                    (left-branch set)
                    (adjoin-set x (right-branch set))))))

(define t (make-tree 7
                     (make-tree 5
                                (make-tree 4 leaf leaf)
                                (make-tree 6 leaf leaf))
                     (make-tree 11 leaf leaf)))

(display (element-of-set? 2 t)) (newline)
(display (element-of-set? 6 t)) (newline)


(display "\nex-2.63") (newline)

(define (tree->list-1 tree)
  (if (null? tree)
      '()
      (append (tree->list-1 (left-branch tree))
              (cons (entry tree)
                    (tree->list-1 (right-branch tree))))))


(define (tree->list-2 tree)
  (define (copy-to-list tree result-list)
    (if (null? tree)
        result-list
        (copy-to-list (left-branch tree)
                      (cons (entry tree)
                            (copy-to-list (right-branch tree)
                                          result-list)))))
  (copy-to-list tree '()))

;        7
;       / \
;      5   11
;     / \
;    4   6
;
; tree->list-1: (list 4 5 6 7 11)
; tree->list-2: (list 4 5 6 7 11)

(assert (tree->list-1 t) (list 4 5 6 7 11))
(assert (tree->list-2 t) (list 4 5 6 7 11))
(display "a) The functions produce the same output.\n")
(display "b) tree->list-1 is O(n*log(n)) because it uses append\n")
(display "   tree->list-2 is O(n) because each element is visited only once\n")

(display "\nex-2.64") (newline)

(define (list->tree elements)
  (car (partial-tree elements (length elements))))

(define (partial-tree elts n)
  (if (= n 0)
      (cons '() elts)
      (let ((left-size (quotient (- n 1) 2)))
        (let ((left-result (partial-tree elts left-size)))
          (let ((left-tree (car left-result))
                (non-left-elts (cdr left-result))
                (right-size (- n (+ left-size 1))))
            (let ((this-entry (car non-left-elts))
                  (right-result (partial-tree (cdr non-left-elts)
                                              right-size)))
              (let ((right-tree (car right-result))
                    (remaining-elts (cdr right-result)))
                (cons (make-tree this-entry left-tree right-tree)
                      remaining-elts))))))))

; a.
;
; Partial-tree uses a divide and conquer approach. For each step the list is
; split into three parts. A left side, a current element and a right side. The
; current element is the middle of the list. That way left side and right side
; are of equal length or equal length minus one (depending on the parity of the
; length of the list). For each half partial tree is called recursively and at
; the end the result is put together. A list of the remaining elements is
; propagated through the process.

;                  5
;                 / \
;                /   \
;               1     9
;                \   / \
;                 3 7   11

; b.
;
; Each element is touched once so it is O(n).

(display (list->tree '(1 2 3 4 5 6))) (newline)
(display "[see comments]")
(newline)

(display "\nex-2.65") (newline)

; 3 * O(n)
(define (union-set-tree s1 s2)
  (list->tree (union-set (tree->list-1 s1)
                         (tree->list-1 s2))))

(define t1 (list->tree (list 2 3 7)))
(define t2 (list->tree (list 1 5 7)))

(display (union-set-tree t1 t2)) (newline)
(assert (tree->list-1 (union-set-tree t1 t2))
        (list 1 2 3 5 7))

(define (intersection-set-tree set1 set2)
  (list->tree (intersection-set-list
                (tree->list-1 set1)
                (tree->list-1 set2))))

; Warning: These solutions only work for trees for which tree->list produces a
; sorted listed.


(display "\nex-2.66") (newline)

(define database
  (list (cons 1 "Aonso")
        (cons 3 "Linus")
        (cons 24 "Allan")))

(define key car)

(define (lookup given-key set-of-records)
  (cond ((null? set-of-records) false)
        ((equal? given-key (key (car set-of-records)))
         (car set-of-records))
        (else (lookup given-key (cdr set-of-records)))))

(assert (lookup 24 database) (cons 24 "Allan"))
(assert (lookup 262 database) #f)

(define (lookup given-key records)
  (if (null? records)
    #f
    (let ((current-key (key (entry records))))
      (cond ((= given-key current-key) (entry records))
            ((< given-key current-key) (lookup given-key (left-branch records)))
            ((> given-key current-key) (lookup given-key (right-branch records)))
            (else "OMG!")))))

(define database (list->tree database))
(assert (lookup 24 database) (cons 24 "Allan"))
(assert (lookup 262 database) #f)