|
#lang racket/base |
|
(require rackunit) |
|
|
|
;; Lazy lists: See chapter 3 of SICP |
|
;; https://mitpress.mit.edu/sicp/full-text/book/book-Z-H-24.html#%_sec_3.5 |
|
|
|
(define-syntax delay |
|
(syntax-rules () |
|
((delay form) (lambda () form)))) |
|
|
|
(define (force delayed) |
|
(delayed)) |
|
|
|
(define-syntax lazy-cons |
|
(syntax-rules () |
|
((lazy-cons item items) (cons item (delay items))))) |
|
|
|
(define (lazy-list items) |
|
(if (null? items) |
|
'() |
|
(lazy-cons (car items) (lazy-list (cdr items))))) |
|
|
|
(define (lazy-cdr lazy-list) |
|
(force (cdr lazy-list))) |
|
|
|
;; Purely functional queues: See Okasaki |
|
;; http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.47.8825 |
|
|
|
(define empty-queue (list (cons '() 0) (cons '() 0))) |
|
|
|
(define (right-side queue) (car (cdr queue))) |
|
|
|
(define (left-side queue) (car queue)) |
|
|
|
(define (left-side-length queue) |
|
(cdr (left-side queue))) |
|
|
|
(define (right-side-length queue) |
|
(cdr (right-side queue))) |
|
|
|
(define (left-side-list queue) |
|
(car (left-side queue))) |
|
|
|
(define (right-side-list queue) |
|
(car (right-side queue))) |
|
|
|
(define (rotate left right) |
|
(define (rotate-recur left right accumulator) |
|
(if (null? left) |
|
(lazy-cons (car right) accumulator) |
|
(lazy-cons (car left) (rotate-recur (lazy-cdr left) |
|
(lazy-cdr right) |
|
(lazy-cons (car right) accumulator))))) |
|
(rotate-recur left right '())) |
|
|
|
(define (balance-queue left right) |
|
(if (<= (cdr right) (cdr left)) |
|
(list left right) |
|
(list (cons (rotate (car left) |
|
(car right)) |
|
(+ (cdr left) (cdr right))) |
|
(cons '() 0)))) |
|
|
|
(define (insert-item item queue) |
|
(balance-queue (left-side queue) |
|
(cons (lazy-cons item (right-side-list queue)) |
|
(+ 1 (right-side-length queue))))) |
|
|
|
(define (remove-item queue) |
|
(if (and (null? (left-side-list queue)) (null? (right-side-list queue))) |
|
'() |
|
(list (car (left-side-list queue)) |
|
(balance-queue (cons (lazy-cdr (car (left-side queue))) |
|
(- (left-side-length queue) 1)) |
|
(right-side queue))))) |
|
|
|
(define (insert-items items queue) |
|
(if (null? items) |
|
queue |
|
(insert-items (cdr items) (insert-item (car items) queue)))) |
|
|
|
;; Breadth-first numbering |
|
|
|
(define (visit-order tree) |
|
(define breadth-first-traversal |
|
(lambda (queue visited n) |
|
(if (null? (remove-item queue)) visited |
|
(let ((node (car (remove-item queue))) |
|
(new-q (car (cdr (remove-item queue))))) |
|
(if (equal? "leaf" node) |
|
(breadth-first-traversal new-q visited n) |
|
(breadth-first-traversal (insert-items (cdr node) new-q) |
|
(cons (cons (car node) n) visited) |
|
(+ 1 n))))))) |
|
(breadth-first-traversal (insert-item tree empty-queue) '() 1)) |
|
|
|
(define (walk-map func items) |
|
(define (apply-or-map item) |
|
(cond ((null? item) '()) |
|
((pair? item) (map apply-or-map item)) |
|
(else (func item)))) |
|
(map apply-or-map items)) |
|
|
|
(define (make-node-label-map visit-order) |
|
(let ((label-map (make-hash))) |
|
(define (add-labels labels) |
|
(if (null? labels) |
|
label-map |
|
(let ((node (car (car labels))) |
|
(number (cdr (car labels)))) |
|
(hash-set! label-map node number) |
|
(add-labels (cdr labels))))) |
|
(add-labels visit-order))) |
|
|
|
(define (number-tree tree) |
|
(let ((label-map (make-node-label-map (visit-order tree)))) |
|
(walk-map (lambda (node) (if (equal? "leaf" node) |
|
"leaf" |
|
(hash-ref label-map node))) |
|
tree))) |
|
|
|
(define example-tree '("A" ("B" "leaf" |
|
("C" "leaf" |
|
"leaf")) |
|
("D" "leaf" |
|
"leaf"))) |
|
|
|
(define five-nodes '("A" ("B" ("D" "leaf" |
|
"leaf") |
|
("E" "leaf" |
|
"leaf")) |
|
("C" "leaf" |
|
"leaf"))) |
|
|
|
(define twelve-nodes '("A" ("B" "leaf") |
|
("C" "leaf" |
|
("D" ("F" "leaf" |
|
"leaf") |
|
("G" ("I" "leaf" |
|
"leaf") "leaf") |
|
("H" ("J" "leaf" |
|
"leaf" |
|
"leaf") |
|
("K" "leaf") |
|
("L" "leaf"))) |
|
("E" "leaf")))) |
|
|
|
(check-equal? (number-tree example-tree) '(1 (2 "leaf" (4 "leaf" "leaf")) (3 "leaf" "leaf"))) |
|
|
|
(check-equal? (number-tree five-nodes) '(1 (2 (4 "leaf" "leaf") (5 "leaf" "leaf")) (3 "leaf" "leaf"))) |
|
|
|
(check-equal? (number-tree twelve-nodes) '(1 |
|
(2 "leaf") |
|
(3 |
|
"leaf" |
|
(4 |
|
(6 "leaf" "leaf") |
|
(7 (9 "leaf" "leaf") "leaf") |
|
(8 (10 "leaf" "leaf" "leaf") (11 "leaf") (12 "leaf"))) |
|
(5 "leaf")))) |