Rotate balance

dev/benchmark.lisp

@@ -0,0 +1,40 @@
+(in-package #:rope/dev)
+
+;; (progn
+;;   (sb-ext:restrict-compiler-policy 'speed 3 3)
+;;   (sb-ext:restrict-compiler-policy 'debug 0 0)
+;;   ;; (sb-ext:restrict-compiler-policy 'space 0 0)
+;;   (sb-ext:restrict-compiler-policy 'safety 0 0))
+
+
+(defparameter *readme*
+  (merge-pathnames "README.md" (asdf:system-source-directory :rope)))
+
+(defun print-time (time reps length)
+  (format t "rope size: ~a, ~a microseconds~%"
+          length
+          (* 1000000 (/ time reps))))
+
+(defmacro time* (&body body)
+  `(let ((time))
+     (sb-ext:call-with-timing
+      (lambda (&rest plist) (setf time (getf plist :real-time-ms)))
+      (lambda () ,@body))
+     (coerce (/ time 1000) 'float)))
+
+(defun benchmark-insert (&optional (reps 1000000))
+  (with-open-file (s *readme*)
+    (let* ((starting-rope (split-rope (make-rope s) 1000))
+           (rope starting-rope))
+      (dotimes (i 9999)
+        (setf rope (concat-rope rope starting-rope)))
+      (setf starting-rope rope)
+      (dotimes (i 100)
+        (print-time
+         (time*
+           (dotimes (i reps)
+             (insert-rope rope (random (rope-length rope)) "Hello, world!")))
+         reps
+         (rope-length rope))
+        (force-output)
+        (setf rope (concat-rope rope starting-rope))))))

dev/graphviz.lisp

@@ -3,7 +3,7 @@
 (defparameter *string* "In computer programming, a rope, or cord, is a data structure composed of smaller strings that is used to efficiently store and manipulate longer strings or entire texts.")
 
 (defparameter rope::*long-leaf* 24)
-(defparameter rope::*short-leaf* 8)
+(defparameter rope::*short-leaf* 2)
 
 (defclass root ()
   ((name :initarg :name :accessor root-name)
@@ -15,28 +15,28 @@
                    :attributes `(:label ,(format nil "rope: ~a~%length: ~a~%depth: ~a"
                                                  (root-name root)
                                                  (rope-length obj)
-                                                 (rope-depth obj))
+                                                 (rope::rope-depth obj))
                                  :style :filled))))
 
 (defmethod graph-object-points-to ((self (eql 'rope)) (obj root))
   (let ((obj (root-rope obj)))
     (graph-object-points-to self obj)))
 
-(defmethod graph-object-node ((self (eql 'rope)) (obj branch))
+(defmethod graph-object-node ((self (eql 'rope)) (obj rope::branch))
   (make-instance 'node
                  :attributes `(:label ,(format nil "length: ~a~%depth: ~a"
                                                (rope-length obj)
-                                               (rope-depth obj)))))
+                                               (rope::rope-depth obj)))))
 
-(defmethod graph-object-points-to ((self (eql 'rope)) (obj branch))
+(defmethod graph-object-points-to ((self (eql 'rope)) (obj rope::branch))
   (list (make-instance 'attributed
-                       :object (branch-right obj)
+                       :object (rope::branch-right obj)
                        :attributes `(:label "R"))
         (make-instance 'attributed
-                       :object (branch-left obj)
+                       :object (rope::branch-left obj)
                        :attributes `(:label "L"))))
 
-(defmethod graph-object-node ((self (eql 'rope)) (obj leaf))
+(defmethod graph-object-node ((self (eql 'rope)) (obj rope::leaf))
   (make-instance 'node
                  :attributes `(:label ,(format nil "~a"
                                                (rope::leaf-string obj))
@@ -75,3 +75,12 @@
   (setf rope (append-rope rope " we can do it again"))
   (setf rope (append-rope rope " later!"))
   (graph-ropes (list rope)))
+
+#+example
+(let ((rope (rope::make-rope "hello world")))
+  (dotimes (i 15)
+    (setf rope (rope:append-rope rope "!")))
+  (dotimes (i 5)
+    (setf rope (rope:insert-rope rope 8 "@")))
+  (graph-ropes (list rope
+                     )))

dev/package.lisp

@@ -1,4 +1,8 @@
 (defpackage #:rope/dev
   (:use #:cl #:cl-dot #:rope)
   (:export
-   #:graph-ropes))
+   ;; graphviz.lisp
+   #:graph-ropes
+   ;; benchmark.lisp
+   #:benchmark-insert
+   ))

rope.asd

@@ -24,4 +24,5 @@
   :depends-on (#:cl-dot #:rope)
   :components ((:module "dev"
                 :components ((:file "package")
-                             (:file "graphviz")))))
+                             (:file "graphviz")
+                             (:file "benchmark")))))

rope.lisp

@@ -35,6 +35,18 @@
 ;; Utils ;;
 ;;-------;;
 
+(defun branch-weight (branch)
+  (rope-length (branch-left branch)))
+
+(defun leaf-short-p (leaf)
+  (>= *short-leaf* (rope-length leaf)))
+
+(defun strcat (a b)
+  (concatenate 'string a b))
+
+(defun make-leaf (string &optional length)
+  (make-instance 'leaf :string string :length (or length (length string))))
+
 (defgeneric make-rope (source)
   (:documentation "Create a new rope from a string, stream, or pathname.")
   (:method ((source rope))
@@ -43,7 +55,7 @@
     (labels ((read-leaves (&optional acc)
                (let* ((string (make-string *long-leaf*))
                       (length (read-sequence string source))
-                      (leaf (make-instance 'leaf :length length :string (subseq string 0 length))))
+                      (leaf (make-leaf (subseq string 0 length) length)))
                  (if (= *long-leaf* length)
                      (read-leaves (cons leaf acc))
                      (cons leaf acc)))))
@@ -57,19 +69,7 @@
       (if (<= *long-leaf* length)
           (concat-rope (make-rope (subseq source 0 (round length 2)))
                        (make-rope (subseq source (round length 2))))
-          (make-instance 'leaf :length length :string source)))))
-
-(defgeneric rope-weight (rope)
-  (:method ((rope leaf))
-    (rope-length rope))
-  (:method ((rope branch))
-    (rope-length (branch-left rope))))
-
-(defun leaf-short-p (leaf)
-  (>= *short-leaf* (rope-length leaf)))
-
-(defun strcat (a b)
-  (concatenate 'string a b))
+          (make-leaf source length)))))
 
 ;;-----------;;
 ;; Iteration ;;
@@ -101,6 +101,59 @@
 ;; Balancing ;;
 ;;-----------;;
 
+(defgeneric balance-factor (rope)
+  (:method ((rope leaf))
+    0)
+  (:method ((rope branch))
+    (- (rope-depth (branch-left rope))
+       (rope-depth (branch-right rope)))))
+
+(defun rotate-left (rope)
+  (with-slots (left right) rope
+    (concat-rope*
+     (concat-rope left (branch-left right))
+     (branch-right right))))
+
+(defun rotate-right (rope)
+  (with-slots (left right) rope
+    (concat-rope*
+     (branch-left left)
+     (concat-rope (branch-right left) right))))
+
+(defun rotate-left-right (rope)
+  (with-slots (left right) rope
+    (rotate-right (concat-rope* (rotate-left left) right))))
+
+(defun rotate-right-left (rope)
+  (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)))
+              (t
+               rope))))))
+
+;;---------;;
+;; Rebuild ;;
+;;---------;;
+
 (defun normalize-leaves (leaves &optional carry)
   (let ((leaf (car leaves)))
     (cond ((and carry (null leaf))
@@ -115,16 +168,6 @@
           (t
            (cons leaf (normalize-leaves (cdr leaves)))))))
 
-(defgeneric balancedp (rope)
-  (:documentation "Check if a rope is a height-balanced tree.")
-  (:method ((rope leaf))
-    t)
-  (:method ((rope branch))
-    (with-slots (left right) rope
-      (and (balancedp left)
-           (balancedp right)
-           (>= 2 (abs (- (rope-depth left) (rope-depth right))))))))
-
 (defun merge-leaves (leaves start end)
   (let ((range (- end start)))
     (case range
@@ -134,30 +177,28 @@
            (concat-rope (merge-leaves leaves start mid)
                         (merge-leaves leaves mid end)))))))
 
-(defun balance-rope (rope &optional forcep)
+(defun rebuild-rope (rope)
   "Balance a rope by reconstructing it from the bottom up."
-  (if (and (balancedp rope) (not forcep))
-      rope
-      (let ((leaves (normalize-leaves (collect-rope rope))))
-        (merge-leaves leaves 0 (length leaves)))))
+  (let ((leaves (normalize-leaves (collect-rope rope))))
+    (merge-leaves leaves 0 (length leaves))))
 
 ;;--------;;
 ;; Insert ;;
 ;;--------;;
 
 (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 string))
-    (concat-rope (make-rope source) rope))
   (:method (rope (source rope))
-    (concat-rope source rope)))
+    (concat-rope source rope))
+  (:method (rope (source t))
+    (concat-rope (make-rope source) rope)))
 
 (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 string))
-    (concat-rope rope (make-rope source)))
   (:method (rope (source rope))
-    (concat-rope rope source)))
+    (concat-rope rope source))
+  (:method (rope (source t))
+    (concat-rope rope (make-rope source))))
 
 (defun insert-rope (rope index str)
   "Return a new rope with a string or rope inserted at the specified index of a rope."
@@ -175,7 +216,7 @@
   (:method ((rope leaf) index)
     (char (leaf-string rope) index))
   (:method ((rope branch) index)
-    (let ((weight (rope-weight rope)))
+    (let ((weight (branch-weight rope)))
       (if (< index weight)
           (index-rope (branch-left rope) index)
           (index-rope (branch-right rope) (- index weight))))))
@@ -192,14 +233,17 @@
 ;; Concat ;;
 ;;--------;;
 
+(defun concat-rope* (left right)
+  "Concatenates without balancing."
+  (make-instance 'branch
+                 :length (+ (rope-length left) (rope-length right))
+                 :depth (1+ (max (rope-depth left) (rope-depth right)))
+                 :left left
+                 :right right))
+
 (defun concat-rope (left right)
   "Returns a balanced concatenation of two ropes."
-  (balance-rope
-   (make-instance 'branch
-                  :length (+ (rope-length left) (rope-length right))
-                  :depth (1+ (max (rope-depth left) (rope-depth right)))
-                  :left left
-                  :right right)))
+  (balance-rope (concat-rope* left right)))
 
 ;;-------;;
 ;; Split ;;
@@ -212,16 +256,16 @@
             (make-rope (subseq (leaf-string rope) index))))
   (:method ((rope branch) index)
     (with-slots (left right) rope
-      (let ((weight (rope-weight rope)))
+      (let ((weight (branch-weight rope)))
         (cond ((= index weight)
                (values left right))
               ((< index weight)
                (multiple-value-bind (ante post) (split-rope left index)
                  (values (balance-rope ante)
-                         (balance-rope (concat-rope post right)))))
+                         (concat-rope post right))))
               ((> index weight)
                (multiple-value-bind (ante post) (split-rope right (- index weight))
-                 (values (balance-rope (concat-rope left ante))
+                 (values (concat-rope left ante)
                          (balance-rope post)))))))))
 
 ;;------;;