Skip to content

Instantly share code, notes, and snippets.

@ecmendenhall
Last active December 18, 2015 21:29
Show Gist options
  • Save ecmendenhall/5847792 to your computer and use it in GitHub Desktop.
Save ecmendenhall/5847792 to your computer and use it in GitHub Desktop.

Breadth-first numbering with a pure functional queue

My solution to Chris Okasaki's functional pearl: given a tree, reproduce a tree with the same structure with nodes numbered in breadth-first order (using only immutable data structures, of course).

For more on streams and lazy lists, check out chapter 3 of SICP. For more on pure functional queues, see this other paper by Chris Okasaki.

I'm not completely happy with my solution. On the plus side, it generalizes to non-binary trees. But performing a breadth-first search to calculate node numbers and a depth-first map to apply them is inefficient. I tried to construct my solution from the most basic Scheme primitives where possible, but a couple macros and a hashmap snuck in.

This was a test-driven solution, but I've edited the code below. If you'd like to see all the tests (and an extra simple queue implementation with eager lists), see this gist, or my blog.

#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"))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment