codepad

Language:

; cluster

(define sort #f)
(define merge #f)
(let ()
  (define dosort
    (lambda (pred? ls n)
      (if (= n 1)
          (list (car ls))
          (let ((i (quotient n 2)))
            (domerge pred?
                     (dosort pred? ls i)
                     (dosort pred? (list-tail ls i) (- n i)))))))
  (define domerge
    (lambda (pred? l1 l2)
      (cond
        ((null? l1) l2)
        ((null? l2) l1)
        ((pred? (car l2) (car l1))
         (cons (car l2) (domerge pred? l1 (cdr l2))))
        (else (cons (car l1) (domerge pred? (cdr l1) l2))))))
  (set! sort
    (lambda (pred? l)
      (if (null? l) l (dosort pred? l (length l)))))
  (set! merge
    (lambda (pred? l1 l2)
      (domerge pred? l1 l2))))
(define (cluster proc lt? lst)
  (define (insert key value tree)
    (cond ((null? tree)
            (list key (list value) '() '()))
          ((lt? key (car tree))
            (let ((left (insert key value (caddr tree))))
              (list (car tree) (cadr tree) left (cadddr tree))))
          ((lt? (car tree) key)
            (let ((right (insert key value (cadddr tree))))
              (list (car tree) (cadr tree) (caddr tree) right)))
          (else
            (let ((new (cons value (cadr tree))))
              (list key new (caddr tree) (cadddr tree))))))
  (define (in-order tree)
    (if (null? tree) '()
      (append (in-order (caddr tree))
              (list (cadr tree))
              (in-order (cadddr tree)))))
  (let loop ((lst lst) (tree '()))
    (if (null? lst) (in-order tree)
      (loop (cdr lst) (insert (proc (car lst)) (car lst) tree)))))

(define x '("this" "is" "a" "fun" "and" "useful" "program"))
(display (cluster string-length < x)) (newline)
(display (cluster (lambda (x) (string-ref x 0)) char<? x)) (newline)

(define (anagram s) (list->string (sort char<? (string->list s))))
(define dict '("pots" "time" "spot" "pans" "item" "tops"))
(display (cluster anagram string<? dict)) (newline)

Private [?]

Run code