Raganwald's recursive data structures.

recursive.rkt

#lang racket

;; Raganwald's recursive data structures.
;; http://raganwald.com/2016/12/27/recursive-data-structures.html

(require racket/list)

(define (merge1 lists)
  (cond ((or (empty? (first lists))
             (empty? (second lists)))
         (apply append lists))
        ((< (first (first lists))
            (first (second lists)))
         (cons (first (first lists))
               (merge1 (list (rest (first lists)) (second lists)))))
        (else (cons (first (second lists))
                    (merge1 (list (first lists) (rest (second lists))))))))

(define (sum1 list)
  (cond ((empty? list) 0)
        (else (+ (first list) (sum1 (rest list))))))

(define (linrec indivisible? value divide combine)
  (letrec ((self (lambda (input)
                   (if (indivisible? input)
                       (value input)
                       (let-values (((atom remainder) (divide input)))
                         (combine atom (self remainder)))))))
    self))

(define sum2 (linrec empty?
                     (lambda _ 0)
                     (lambda (list) (values (first list) (rest list)))
                     +))

(define merge2 (linrec (lambda (lists)
                         (or (empty? (first lists))
                             (empty? (second lists))))
                       (lambda (lists) (apply append lists))
                       (lambda (lists)
                         (if (< (first (first lists))
                                (first (second lists)))
                             (values (first (first lists))
                                     (list (rest (first lists)) (second lists)))
                             (values (first (second lists))
                                     (list (first lists) (rest (second lists))))))
                       cons))

(define (binrec indivisible? value divide combine)
  (letrec ((self (lambda (input)
                   (if (indivisible? input)
                       (value input)
                       (let-values (((left right) (divide input)))
                         (combine (self left) (self right)))))))
    self))

(define mergesort (binrec (lambda (l) (< (length l) 2))
                          identity
                          (lambda (list)
                            (split-at list (quotient (length list) 2)))
                          (lambda (x y) (merge2 (list x y)))))

(define (multirec indivisible? value divide combine)
  (letrec ((self (lambda (input)
                   (if (indivisible? input)
                       (value input)
                       (let ((parts (divide input)))
                         (combine (map self parts)))))))
    self))

(define mergesort1
  (multirec (lambda (l) (< (length l) 2))
            identity
            (lambda (l)
              (let-values (((l r)
                            (split-at l (quotient (length l) 2))))
                (list l r)))
            merge2))

(define (at-most-one? l) (> 2 (length l)))

(define (bisect l) (split-at l (quotient (length l) 2)))

(define (bisect-lists l)
  (let-values (((l r) (bisect l)))
    (list l r)))

(define mergesort2 (multirec at-most-one? identity bisect-lists merge2))

(require pict)

(struct quadtree (nw sw ne se))

;; An Array is one of
;; - (circle 5)
;; - (disk 5)
;; - (quadtree Array Array Array Array)

(define (array? x)
  (or (pict? x) (quadtree? x)))

(define (draw-array i)
  (cond ((pict? i) i)
        (else (vl-append (ht-append (draw-array (quadtree-nw i))
                                    (draw-array (quadtree-ne i)))
                         (ht-append (draw-array (quadtree-sw i))
                                    (draw-array (quadtree-se i)))))))

(define ac (circle 15))
(define ad (disk 15))

(define array0 (quadtree ac ac ac ac))
(define array1 (quadtree ac ac ad ad))
(define array2 (quadtree array0 array0 array0 array1))
(define array3 (quadtree (quadtree array0 array0 array0 (quadtree ac ac ad ac))
                         (quadtree array0 array0 (quadtree ad ac ad ac) array0)
                         (quadtree array0 (quadtree ac ad ac ac) array0 array0)
                         (quadtree (quadtree ad ac ac ac) array0 array0 array0)))

(define rotate (multirec pict?
                         identity
                         (lambda (qt)
                           (list (quadtree-ne qt)
                                 (quadtree-nw qt)
                                 (quadtree-se qt)
                                 (quadtree-sw qt)))
                         (lambda (parts) (apply quadtree parts))))

(draw-array array3)
(draw-array (rotate array3))