Ensure trees are balanced

dev/graphviz.lisp

@@ -24,9 +24,13 @@
 
 (defmethod graph-object-node ((self (eql 'rope)) (obj rope::branch))
   (make-instance 'node
-                 :attributes `(:label ,(format nil "length: ~a~%depth: ~a"
+                 :attributes `(:label ,(format nil "length: ~a~%bf: ~a~%depth: ~a"
                                                (rope-length obj)
-                                               (rope::rope-depth obj)))))
+                                               (rope::balance-factor obj)
+                                               (rope::rope-depth obj))
+                               :style ,(if (>= 1 (abs (rope::balance-factor obj)))
+                                           :solid
+                                           :filled))))
 
 (defmethod graph-object-points-to ((self (eql 'rope)) (obj rope::branch))
   (list (make-instance 'attributed

rope.asd

@@ -9,7 +9,8 @@
 (asdf:defsystem #:rope/test
   :depends-on (#:alexandria #:fiasco #:rope)
   :components ((:module "test"
-                :components ((:file "basic")
+                :components ((:file "util")
+                             (:file "basic")
                              (:file "fuzz"))))
   :perform (asdf:test-op
             (o c)

rope.lisp

@@ -38,8 +38,11 @@
 (defun branch-weight (branch)
   (rope-length (branch-left branch)))
 
-(defun leaf-short-p (leaf)
-  (>= *short-leaf* (rope-length leaf)))
+(defun leaf-short-p (leaf &optional other)
+  (>= *short-leaf*
+      (if other
+          (+ (rope-length leaf) (rope-length other))
+          (rope-length leaf))))
 
 (defun strcat (a b)
   (concatenate 'string a b))
@@ -128,25 +131,22 @@
   (with-slots (left right) rope
     (rotate-left (concat-rope* left (rotate-right right)))))
 
-(defun balance-children (rope)
-  (with-slots (left right) rope
-    (concat-rope* (balance-rope left)
-                  (balance-rope right))))
-
 (defgeneric balance-rope (rope)
   (:method ((rope leaf))
     rope)
   (:method ((rope branch))
     (with-slots (left right) rope
       (let ((bf (balance-factor rope)))
-        (cond ((< 0 bf)
-               (if (minusp (balance-factor left))
-                   (rotate-left-right rope)
-                   (rotate-right rope)))
-              ((> 0 bf)
-               (if (plusp (balance-factor right))
-                   (rotate-right-left rope)
-                   (rotate-left rope)))
+        (cond ((< 1 bf)
+               (balance-rope
+                (if (minusp (balance-factor left))
+                    (rotate-left-right rope)
+                    (rotate-right rope))))
+              ((> -1 bf)
+               (balance-rope
+                (if (plusp (balance-factor right))
+                    (rotate-right-left rope)
+                    (rotate-left rope))))
               (t
                rope))))))
 
@@ -178,7 +178,9 @@
                         (merge-leaves leaves mid end)))))))
 
 (defun rebuild-rope (rope)
-  "Balance a rope by reconstructing it from the bottom up."
+  "Reconstruct a rope from the bottom up.
+Doing this occasionally can reduce the number of leaves in a rope,
+but it is expensive - O(n)."
   (let ((leaves (normalize-leaves (collect-rope rope))))
     (merge-leaves leaves 0 (length leaves))))
 
@@ -188,17 +190,31 @@
 
 (defgeneric prepend-rope (rope source)
   (:documentation "Return a new rope with a string or rope inserted at the beginning of a rope.")
-  (:method (rope (source rope))
-    (concat-rope source rope))
   (:method (rope (source t))
-    (concat-rope (make-rope source) rope)))
+    (prepend-rope rope (make-rope source)))
+  (:method (rope (source branch))
+    (concat-rope source rope))
+  (:method ((rope leaf) (source leaf))
+    (if (leaf-short-p rope source)
+        (make-leaf (strcat (leaf-string source) (leaf-string rope)))
+        (concat-rope* source rope)))
+  (:method ((rope branch) (source leaf))
+    (with-slots (left right) rope
+      (concat-rope* (prepend-rope left source) right))))
 
 (defgeneric append-rope (rope source)
   (:documentation "Return a new rope with a string or rope inserted at the end of a rope.")
-  (:method (rope (source rope))
-    (concat-rope rope source))
   (:method (rope (source t))
-    (concat-rope rope (make-rope source))))
+    (append-rope rope (make-rope source)))
+  (:method (rope (source branch))
+    (concat-rope rope source))
+  (:method ((rope leaf) (source leaf))
+    (if (leaf-short-p rope source)
+        (make-leaf (strcat (leaf-string rope) (leaf-string source)))
+        (concat-rope* rope source)))
+  (:method ((rope branch) (source leaf))
+    (with-slots (left right) rope
+      (concat-rope* left (append-rope right source)))))
 
 (defun insert-rope (rope index str)
   "Return a new rope with a string or rope inserted at the specified index of a rope."

test/basic.lisp

@@ -1,4 +1,5 @@
-(fiasco:define-test-package :rope/test/basic)
+(fiasco:define-test-package :rope/test/basic
+  (:use #:rope/test/util))
 (in-package :rope/test/basic)
 
 (defparameter *string-1*
@@ -19,15 +20,19 @@ can be done efficiently.")
     (is (= (length *string-1*) (rope:rope-length rope-1)))
     (is (= (length *string-2*) (rope:rope-length rope-2)))
     (is (string= *string-1* (rope:write-rope rope-1 nil)))
-    (is (string= *string-2* (rope:write-rope rope-2 nil)))))
+    (is (string= *string-2* (rope:write-rope rope-2 nil)))
+    (is (balancedp rope-1))
+    (is (balancedp rope-2))))
 
 (deftest split ()
   "Test splitting ropes and check to ensure it is the same as splitting strings."
   (dotimes (i (length *string-2*))
     (let ((rope (rope:make-rope *string-2*)))
       (multiple-value-bind (ante post) (rope:split-rope rope i)
         (is (string= (subseq *string-2* 0 i) (rope:write-rope ante nil)))
-        (is (string= (subseq *string-2* i) (rope:write-rope post nil)))))))
+        (is (string= (subseq *string-2* i) (rope:write-rope post nil)))
+        (is (balancedp ante))
+        (is (balancedp post))))))
 
 (deftest delete-and-insert ()
   "Make a rope, then a rope with a part deleted, then inserted."
@@ -38,7 +43,10 @@ can be done efficiently.")
     (is (string= "Hello, rope!" (rope:write-rope rope nil)))
     (is (string= ", rope!" (rope:write-rope killed nil)))
     (is (string= "Goodbye, rope!" (rope:write-rope inserted nil)))
-    (is (string= "Hello, super rope!" (rope:write-rope super nil)))))
+    (is (string= "Hello, super rope!" (rope:write-rope super nil)))
+    (is (balancedp killed))
+    (is (balancedp inserted))
+    (is (balancedp super))))
 
 (deftest index-rope ()
   "Test accessing characters and strings by index"
@@ -53,7 +61,9 @@ can be done efficiently.")
   "Test reading a file to a rope."
   (let* ((pathname (merge-pathnames "README.md" (asdf:system-source-directory :rope)))
          (rope (rope:make-rope pathname)))
-    (is (string= (uiop:read-file-string pathname) (rope:write-rope rope nil))))
+    (is (string= (uiop:read-file-string pathname) (rope:write-rope rope nil)))
+    (is (balancedp rope)))
   (let* ((stream (make-string-input-stream *string-2*))
          (rope (rope:make-rope stream)))
-    (is (string= *string-2* (rope:write-rope rope nil)))))
+    (is (string= *string-2* (rope:write-rope rope nil)))
+    (is (balancedp rope))))

test/fuzz.lisp

@@ -1,39 +1,7 @@
 (fiasco:define-test-package :rope/test/fuzz
-  (:local-nicknames (#:a #:alexandria)))
+  (:use #:rope/test/util))
 (in-package :rope/test/fuzz)
 
-(defvar *charset* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789")
-
-(defun random-string (&key (length 128) (acc ""))
-  (if (= 0 length)
-      acc
-      (random-string
-       :length (1- length)
-       :acc (rope::strcat acc (string (a:random-elt *charset*))))))
-
-(defun random-rope (total-length)
-  (with-open-file (source "/dev/urandom" :element-type '(unsigned-byte 8))
-    (labels ((read-leaves (&optional acc (acc-length 0))
-               (let* ((string* (make-array (min rope::*long-leaf* (- total-length acc-length))
-                                           :element-type '(unsigned-byte 8)))
-                      (length (read-sequence string* source))
-                      (string (map 'string #'code-char string*))
-                      (leaf (rope::make-leaf (subseq string 0 length) length)))
-                 (if (and (= rope::*long-leaf* length)
-                          (not (= total-length (+ length acc-length))))
-                     (read-leaves (cons leaf acc) (+ length acc-length))
-                     (cons leaf acc)))))
-      (let ((leaves (nreverse (read-leaves))))
-        (rope::merge-leaves leaves 0 (length leaves))))))
-
-(defgeneric balancedp (rope)
-  (:method ((rope rope::leaf))
-    t)
-  (:method ((rope rope::branch))
-    (and (>= 1 (abs (rope::balance-factor rope)))
-         (balancedp (rope::branch-left rope))
-         (balancedp (rope::branch-right rope)))))
-
 (deftest fuzz-basic-tests ()
   "Run the basic test suite with different leaf sizes."
   (loop :for i :from 1 :to 64
@@ -85,16 +53,25 @@
       (is (balancedp new-rope))
       (is (string= new-string (rope:write-rope new-rope nil))))))
 
-#+ignore
 (deftest fuzz-insert-balance ()
   (setf rope::*long-leaf* 128)
   (dotimes (i 10)
-    (let ((rope (random-rope 1000)))
-      (dotimes (i 100)
+    (let ((rope (random-rope 10)))
+      (dotimes (i 1000)
         (setf rope
               (rope:insert-rope rope
                                 (random (rope:rope-length rope))
-                                (random-string :length (random 512))))
-        (unless (balancedp rope)
-          (return-from fuzz-insert-balance rope))
+                                (random-string :length (random 5))))
         (is (balancedp rope))))))
+
+;; (deftest fuzz-random-actions-balance
+;;     (&key (rope (random-rope (random 256)))
+;;           (iterations 1000))
+;;   (cond ((> 50000 (rope:rope-length rope))
+;;          (fuzz-random-actions-balance
+;;           :rope (random-insert rope)
+;;           :iterations (1- iterations)))
+;;         ((< 12 (rope:rope-length rope))
+;;          (fuzz-random-actions-balance
+;;           :rope (random-kill rope)
+;;           :iterations (1- iterations)))))

test/util.lisp

@@ -0,0 +1,75 @@
+(defpackage :rope/test/util
+  (:use #:cl)
+  (:local-nicknames
+   (#:a #:alexandria))
+  (:export
+   #:balancedp
+   #:random-string
+   #:random-rope
+   #:random-path
+   #:random-insert
+   #:random-kill))
+(in-package :rope/test/util)
+
+(defgeneric balancedp (rope)
+  (:method ((rope rope::leaf))
+    t)
+  (:method ((rope rope::branch))
+    (and (>= 1 (abs (rope::balance-factor rope)))
+         (balancedp (rope::branch-left rope))
+         (balancedp (rope::branch-right rope)))))
+
+(defvar *charset* "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789")
+
+(defun random-string (&key (length 128) (acc ""))
+  (if (= 0 length)
+      acc
+      (random-string
+       :length (1- length)
+       :acc (rope::strcat acc (string (a:random-elt *charset*))))))
+
+(defun random-rope (total-length)
+  (with-open-file (source "/dev/urandom" :element-type '(unsigned-byte 8))
+    (labels ((read-leaves (&optional acc (acc-length 0))
+               (let* ((string* (make-array (min rope::*long-leaf* (- total-length acc-length))
+                                           :element-type '(unsigned-byte 8)))
+                      (length (read-sequence string* source))
+                      (string (map 'string #'code-char string*))
+                      (leaf (rope::make-leaf (subseq string 0 length) length)))
+                 (if (and (= rope::*long-leaf* length)
+                          (not (= total-length (+ length acc-length))))
+                     (read-leaves (cons leaf acc) (+ length acc-length))
+                     (cons leaf acc)))))
+      (let ((leaves (nreverse (read-leaves))))
+        (rope::merge-leaves leaves 0 (length leaves))))))
+
+(defmacro random-path (&body forms)
+  `(case (random ,(length forms))
+     ,@(loop :with i := 0
+             :for form :in forms
+             :collect (list i form)
+             :do (incf i))))
+
+(defun random-insert (rope)
+  (random-path
+    (rope:insert-rope
+     rope
+     (random (rope:rope-length rope))
+     (random-path
+       (random-string :length (random 1024))
+       (random-rope (random 1024))))
+    (rope:append-rope
+     rope
+     (random-path
+       (random-string :length (random 1024))
+       (random-rope (random 1024))))
+    (rope:prepend-rope
+     rope
+     (random-path
+       (random-string :length (random 1024))
+       (random-rope (random 1024))))))
+
+(defun random-kill (rope)
+  (random-path
+    (rope:kill-rope rope (random (rope:rope-length rope)))
+    ))