par: piece-table: rewrite insert to make it work

3 files changed, 54 insertions, 46 deletions

diff --git a/par/piece-table.scm b/par/piece-table.scm
index aa4993b..7ddab44 100644
--- a/par/piece-table.scm
+++ b/par/piece-table.scm
@@ -12,6 +12,26 @@
   (length piece-length set-piece-length!)
   (type piece-type set-piece-type!))
 
+(define (can-merge-pieces? a b)
+  (and (eq? (piece-buffer a) (piece-buffer b))
+       (= (+ (piece-start a) (piece-length a)) (piece-start b))
+       (equal? (piece-type a) (piece-type b))))
+
+(define (merge-pieces! a b)
+  (set-piece-length! a (+ (piece-length a) (piece-length b)))
+  a)
+
+(define (split-piece! a at)
+  (values
+    (make-piece (piece-buffer a)
+                (piece-start a)
+                at
+                (piece-type a))
+    (make-piece (piece-buffer a)
+                (+ at (piece-start a))
+                (- (piece-length a) at)
+                (piece-type a))))
+
 
 
 ;; INTERNAL BUFFERS: The indirection level of the buffer records is cool, so we
@@ -88,12 +108,6 @@
       ro-buffer (make-add-buffer)
       (list (make-piece ro-buffer 0 (string-length original) 'normal)))))
 
-(define (add-piece-table-piece! piece-table piece)
-  "Add a new piece to the piece table. Piece is added in the end. Order is
-  important."
-  (set-piece-table-pieces! piece-table
-    (append! (piece-table-pieces piece-table) (list piece))))
-
 (define (piece-table-index piece-table pos)
   (let loop ((pieces (piece-table-pieces piece-table))
              (start 0))
@@ -119,42 +133,30 @@
         (values idx rem)
         (loop (+ idx 1) (cdr ps) (- rem len))))))
 
-(define (piece-table-insert! piece-table pos str)
-  ;; Write to add-buffer first
-  (let ((piece-to-insert (add-buffer-append! (piece-table-add-buffer piece-table) str)))
-    ;; Now assign a piece for what we wrote
-    ;; It's probably reasonable to combine both branches in just the one in the
-    ;; bottom
-    (if (= (piece-table-text-length piece-table) pos)
-      ;; last position
-      (let ((last-piece (last (piece-table-pieces piece-table))))
-        (if (eq? (piece-table-add-buffer piece-table)
-                 (piece-buffer last-piece))
-          (set-piece-length! last-piece (+ (string-length str)
-                                           (piece-length last-piece)))
-          (add-piece-table-piece! piece-table
-                                  (piece-to-insert #f))))
-
-      ;; not last
-      (let*-values (((idx rem) (piece-table-text-pos->piece-idx+remainder
-                                 piece-table pos))
-                    ((beg end) (split-at! (piece-table-pieces piece-table) idx)))
-        (let* ((altered (car end))
-               (rest    (cdr end))
-               (buffer (piece-buffer altered))
-               (start  (piece-start  altered))
-               (length (piece-length altered))
-               (add-buffer (piece-table-add-buffer piece-table)))
-          (set-piece-table-pieces!
-            piece-table
-            (append beg
-                    (list (make-piece buffer start rem #f)
-                          (piece-to-insert #f)
-                          (make-piece buffer
-                                      (+ start rem)
-                                      (- length rem)
-                                      #f))
-                    rest)))))))
+(define (piece-table-insert! piece-table pos str type)
+  (define candidate ((add-buffer-append!
+                       (piece-table-add-buffer piece-table) str)
+                     type))
+
+  (define (list-ref-with-context l i)
+    (let ((len (length l)))
+      (values (take l i) (list-ref l i) (drop l (+ 1 i)))))
+
+  (set-piece-table-pieces! piece-table
+    (let*-values (((idx rem) (piece-table-text-pos->piece-idx+remainder
+                               piece-table pos))
+                  ((beg piece end) (list-ref-with-context
+                                     (piece-table-pieces piece-table)
+                                     idx)))
+      (if (and (= rem (piece-length piece))
+               (can-merge-pieces? piece candidate))
+        (append beg (list (merge-pieces! piece candidate)) end)
+        (let-values (((first second) (split-piece! piece rem)))
+          (append beg (list first candidate second) end))))))
+
+
+(define (piece-table-delete! piece-table pos len)
+  #f)
 
 
 
diff --git a/par/piece-table.sld b/par/piece-table.sld
index 1c915d7..053b863 100644
--- a/par/piece-table.sld
+++ b/par/piece-table.sld
@@ -1,9 +1,11 @@
 (define-library (par piece-table)
   (import (scheme base)
-          (srfi 1))
+          (srfi 1)
+          (srfi 11))
   (export make-piece-table
           piece-table-index
           piece-table-insert!
           piece-table-delete!
+          piece-table->string
           string->piece-table)
   (include "piece-table.scm"))
diff --git a/tests/piece-table.scm b/tests/piece-table.scm
index d1fa32a..04a62bc 100644
--- a/tests/piece-table.scm
+++ b/tests/piece-table.scm
@@ -12,9 +12,13 @@
 
 (test-begin "insert")
   (define table (make-piece-table "HOLA"))
-  (piece-table-insert! table 2 "90")
-  (test-equal #\9 (piece-table-index table 2))
-  (test-equal #\0 (piece-table-index table 3))
+  (piece-table-insert! table 4 "9" 'normal)
+  (piece-table-insert! table 5 "0" 'normal)
+  (test-equal #\9 (piece-table-index table 4))
+  (test-equal #\0 (piece-table-index table 5))
+  (test-equal "HOLA90" (piece-table->string table))
+  (piece-table-insert! table 5 "1" 'normal)
+  (test-equal "HOLA910" (piece-table->string table))
 (test-end "insert")
 
 (test-begin "delete")