;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; A straightforward implementation of "Ropes, An Alternative to Strings"
;;   H. Boehm, R. Atkinson, M. Plass
;;   Software Practice and Experience 25, Dec 1995, pp. 1315-1330
;;

(define-record-type node
  (%make-node left right length depth)
  node?
  (left  node-left)
  (right node-right)
  (length node-length)
  (depth node-depth))

(define-record-type leaf
  (%make-leaf string length)
  leaf?
  (string leaf-string)
  (length leaf-length))

(define eof
  (read (open-input-string "")))

(define (⌊n/2⌋ n)
  (inexact->exact (floor (/ n 2))))

(define current-maximum-leaf-length
  (make-parameter 512))

(define empty-rope
  (%make-leaf "" 0))

(define (rope? o)
  (or (leaf? o)
      (node? o)))

(define (rope-length r)
  (if (leaf? r)
      (leaf-length r)
      (node-length r)))

(define (rope-depth r)
  (if (leaf? r)
      0
      (node-depth r)))

(define (rope-null? r)
  (= (rope-length r) 0))

(define make-leaf
  (case-lambda
    ((s)
     (%make-leaf s (string-length s)))
    ((s len)
     (%make-leaf s len))))

(define make-node
  (case-lambda
    ((l r)
     (make-node l r (+ (rope-length l) (rope-length r))))
    ((l r len)
     (%make-node l r len (+ (max (rope-depth l) (rope-depth r)) 1)))
    ((l r len dep)
     (%make-node l r len dep))))

(define (rope->tree r)
  (if (leaf? r)
      (leaf-string r)
      (list
       (rope->tree (node-left r))
       (rope->tree (node-right r)))))

(define (tree->rope t)
  (if (string? t)
      (make-leaf t)
      (make-node
       (tree->rope (car t))
       (tree->rope (cadr t)))))

(define (string->rope s)
  (let lp ((s s))
    (let ((len (string-length s)))
      (if (<= len (current-maximum-leaf-length))
          (make-leaf s len)
          (let ((mid (⌊n/2⌋ len)))
            (make-node
             (lp (substring s 0 mid))
             (lp (substring s mid len))
             len))))))

(define (rope->string r)
  (if (leaf? r)
      (leaf-string r)
      (let* ((len (rope-length r))
             (str (make-string len)))
        (rope-fold-leaves
         (lambda (leaf i)
           (string-copy! str i (leaf-string leaf))
           (+ i (leaf-length leaf)))
         0
         r)
        str)))

(define rope
  (case-lambda
    (() empty-rope)
    ((s) (string->rope s))
    (args (rope-concatenate (map string->rope args)))))

(define (rope-ref r i)
  (if (or (negative? 0)
          (>= i (rope-length r)))
      (error 'rope-ref "out of range" r i)
      (let lp ((r r)
               (i i))
        (if (leaf? r)
            (string-ref (leaf-string r) i)
            (let* ((l (node-left r))
                   (m (rope-length l)))
              (if (< i m)
                  (lp l i)
                  (lp (node-right r)
                      (- i m))))))))

(define subrope
  (case-lambda
    ((r s)
     (subrope r s (rope-length r)))
    ((r s e)
     (if (or (negative? s)
             (> s e)
             (> s (rope-length r)))
         (error 'subrope "out of range" r s)
         (let lp ((r r)
                  (s s)
                  (e e))
           (if (leaf? r)
               (if (and (= s 0) (= e (+ s (leaf-length r))))
                   r
                   (make-leaf
                    (substring (leaf-string r) s e)))
               (let* ((l (node-left r))
                      (r (node-right r))
                      (m (rope-length l)))
                 (cond
                   ((<= e m)
                    (lp l s e))
                   ((>= s m)
                    (lp r (- s m) (- e m)))
                   ((and (= s 0) (= e (rope-length r)))
                    r)
                   (else
                    (make-node
                     (lp l s m)
                     (lp r 0 (- e m))))))))))))

;; Characterwise iterator over rope r.
(define (make-rope-iterator r)
  (let ((k #f))
    (if (leaf? r)
        (lambda ()
          (if k (k)
                (let lp ((l (string->list (leaf-string r))))
                  (if (null? l)
                      eof
                      (begin
                        (set! k
                          (lambda ()
                            (lp (cdr l))))
                        (car l))))))
        ;; We could delay creating the right iterator.
        (let ((l (make-rope-iterator (node-left r)))
              (r (make-rope-iterator (node-right r))))
          (set! k l)
          (lambda ()
            (let ((c (k)))
              (if (not (eof-object? c))
                  c
                  (begin
                    (set! k r)
                    (r)))))))))

;; Characterwise left fold.
(define rope-fold
  (let ()
    ;; Single-rope version.
    (define (rope-fold-1 f a r)
      (if (leaf? r)
          (fold f a (string->list (leaf-string r)))
          (rope-fold-1 f (rope-fold f a (node-left r)) (node-right r))))
    ;; For n-ary kons.
    (lambda (f a r1 . rn)
      (if (null? rn)
          (rope-fold-1 f a r1)
          (let ((is (map make-rope-iterator (cons r1 rn))))
            (let lp ((a a))
              (let ((cs (map (lambda (f) (f)) is)))
                (if (find eof-object? cs)
                    a
                    (lp (apply f
                          (append cs (list a))))))))))))

;; Leafwise left fold.
(define (rope-fold-leaves f a r)
  (if (leaf? r)
      (f r a)
      (rope-fold-leaves f (rope-fold-leaves f a (node-left r)) (node-right r))))

(define (rope-for-each f r1 . rn)
  (let ((n (+ (length rn) 1)))
    (apply rope-fold (lambda args (apply f (take args n))) #f r1 rn)
    (void)))

(define (rope-for-each-leaf f r)
  (rope-fold-leaves f #f r)
  (void))

(define (rope=? r1 r2)
  (or (eq? r1 r2)
      (and (= (rope-length r1) (rope-length r2))
           (if (and (leaf? r1) (leaf? r2))
               (string=? (leaf-string r1) (leaf-string r2))
               (call/cc
                (lambda (k)
                  (rope-fold
                   (lambda (c1 c2 t)
                     (or (char=? c1 c2)
                         (k #f)))
                   #t
                   r1
                   r2)))))))

(define-values (rope-balanced? rope-balance)
  (let ()
    (define √5 (sqrt 5))
    (define φ  (/ (+ √5 1) 2))
    (define (fib n)
      (floor (+ (/ (expt φ n) √5) .5)))
    (define (unfib n) ; for n > 2
      (floor (/ (log (+ (* n √5) .5)) (log φ))))
    (define first-50-fibs
      (let ((v (make-vector 50)))
        (do ((i 0 (+ i 1)))
            ((= i 50) v)
          (vector-set! v i (fib i)))))
    (define (fib* n)
      (if (< n 50)
          (vector-ref first-50-fibs n)
          (fib n)))
    (define (fib-length r)
      (fib* (inexact->exact (unfib (max (rope-length r) 1)))))
    (define (reorder r)
      (rope-fold-leaves
       (lambda (leaf subropes)
         (let ((len (fib-length leaf)))
           (if (or (null? subropes) (< len (fib-length (car subropes))))
               (cons leaf subropes)
               (let ll ((l '())
                        (r subropes))
                 (if (< len (fib-length (car r)))
                     (ll (cons (car r) l)
                         (cdr r))
                     (let lr ((l (fold make-node leaf l))
                              (r r))
                       (if (or (null? r) (< (fib-length l) (fib-length (car r))))
                           (cons l r)
                           (lr (make-node (car r) l)
                               (cdr r)))))))))
       '()
       r))
    (values
     (lambda (r)
       (let ((l (rope-length r)))
         (or (zero? l)
             (>= l (fib* (+ (rope-depth r) 2))))))
     (lambda (r)
       (let ((n (reorder r)))
         (fold make-node (car n) (cdr n)))))))

(define rope-append
  (let ()
    (define (leaf-append r1 r2)
      (let ((len (+ (leaf-length r1) (leaf-length r2))))
        (make-leaf (string-append (leaf-string r1) (leaf-string r2)) len)))
    ;; Flatten r2 onto r1 if both are short leaves.
    (define (rope-append* r1 r2)
      (let* ((len1 (rope-length r1))
             (len2 (rope-length r2))
             (len  (+ len1 len2)))
        (cond
          ((zero? len2) r1)
          ((zero? len1) r2)
          ((leaf? r2)
           (let ((mll (current-maximum-leaf-length)))
             (if (leaf? r1)
                 (if (<= len mll)
                     (leaf-append r1 r2)
                     (make-node r1 r2 len))
                 (let ((r1r (node-right r1)))
                   (if (and (leaf? r1r) (<= (+ (rope-length r1r) len2) mll))
                       (make-node (node-left r1) (leaf-append r1r r2))
                       (make-node r1 r2 len))))))
          (else
           (make-node r1 r2 len)))))
    (define (ensure-balanced r)
      (if (rope-balanced? r)
          r
          (rope-balance r)))
    (case-lambda
      (() empty-rope)
      ((r1) r1)
      ((r1 r2)
       (ensure-balanced
        (rope-append* r1 r2)))
      ((r1 r2 r3)
       (ensure-balanced
        (rope-append* (rope-append* r1 r2) r3)))
      ((r1 r2 r3 r4)
       (ensure-balanced
        (rope-append*
         (rope-append* r1 r2)
         (rope-append* r3 r4))))
      (ropes
       (rope-concatenate ropes)))))

(define (rope-concatenate ropes)
  (let lp ((ropes ropes)
           (middle (⌊n/2⌋ (length ropes))))
    (if (< middle 2)
        (apply rope-append ropes)
        (call-with-values
          (lambda ()
            (split-at ropes middle))
          (lambda (l r)
            (let ((m (⌊n/2⌋ middle)))
              (make-node (lp l m) (lp r m))))))))

;; Ssssllllloooowwwwwww.
(define (rope-reverse r)
  (rope-concatenate
   (rope-fold-leaves
    (lambda (r a)
      (cons (make-leaf (string-reverse (leaf-string r))) a))
    '()
    r)))