par: piece-table: implement insert and more

3 files changed, 143 insertions, 18 deletions

diff --git a/par/piece-table.scm b/par/piece-table.scm
index 6876541..7a1cae7 100644
--- a/par/piece-table.scm
+++ b/par/piece-table.scm
@@ -14,40 +14,152 @@
 
 
 
+;; INTERNAL BUFFERS: The indirection level of the buffer records is cool, so we
+;; can resize the underlying strings and keep all the pieces untouched and
+;; pointing to the correct thing.
+
+;; There's nothing preventing the programmer from writing in the ro-buffer...
+;; but it will be hidden under the piece-table interface so nothing should
+;; happen
+(define-record-type <ro-buffer>
+  (make-ro-buffer string)
+  ro-buffer?
+  (string ro-buffer-string))
+
+;; This is where things are added, it's able to grow to handle new additions
+(define-record-type <add-buffer>
+  (%make-add-buffer string used)
+  add-buffer?
+  (string add-buffer-string set-add-buffer-string!)
+  (used add-buffer-used set-add-buffer-used!))
+
+(define (buffer->string buffer)
+  "Returns the underlying string of the buffer"
+  (cond
+    ((add-buffer? buffer) (add-buffer-string buffer))
+    ((ro-buffer? buffer) (ro-buffer-string buffer))))
+
+(define %DEFAULT-ADD-BUFFER-LENGTH 64)
+
+(define (make-add-buffer)
+  (%make-add-buffer (make-string %DEFAULT-ADD-BUFFER-LENGTH) 0))
+
+(define (enlarge-add-buffer! add-buffer at-least)
+  (let* ((str (add-buffer-string add-buffer))
+         (len (string-length str))
+         ; TODO: Better algo here?
+         (new (make-string (+ len at-least %DEFAULT-ADD-BUFFER-LENGTH))))
+    (set-add-buffer-string! add-buffer new)
+    (string-copy! new 0 str)))
+
+(define (add-buffer-append! add-buffer str)
+  "Appends to add buffer, growing if necessary and returns the resulting piece
+  as a template function"
+  (let ((append-len  (string-length str))
+        (buffer-used (add-buffer-used add-buffer))
+        (buffer-size (string-length (add-buffer-string add-buffer))))
+    (when (>= (+ append-len buffer-used) buffer-size)
+      (enlarge-add-buffer! add-buffer append-len))
+    (string-copy! (add-buffer-string add-buffer) buffer-used str)
+    (set-add-buffer-used! add-buffer (+ append-len buffer-used))
+
+    (lambda (type)
+      (make-piece add-buffer
+                  buffer-used
+                  (string-length str)
+                  type))))
+
+
+
 ;; The piece table itself;
-;; original and add are strings and pieces is a list of pieces
+;; original is a ro-buffer, add is an add-buffer (a string designed to grow)
+;; and pieces is a list of pieces
 (define-record-type <piece-table>
-  (%make-piece-table original add pieces)
+  (%make-piece-table original-buffer add-buffer pieces)
   piece-table?
-  (original piece-table-original set-piece-table-original!)
-  (add piece-table-add set-piece-table-add!)
+  (original-buffer piece-table-original-buffer set-piece-table-original-buffer!)
+  (add-buffer piece-table-add-buffer set-piece-table-add-buffer!)
   (pieces piece-table-pieces set-piece-table-pieces!))
 
-(define %DEFAULT-ADD-BUFFER-LENGTH 1024)
 
 (define (make-piece-table original)
-  (%make-piece-table
-    original
-    (make-string %DEFAULT-ADD-BUFFER-LENGTH)
-    (list (make-piece original 0 (string-length original) 'normal))))
+  (let ((ro-buffer (make-ro-buffer original)))
+    (%make-piece-table
+      ro-buffer (make-add-buffer)
+      (list (make-piece ro-buffer 0 (string-length original) 'normal)))))
 
 (define (add-piece-table-piece! piece-table piece)
-  (append (piece-table-pieces piece-table) (list 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))
     (let* ((piece (car pieces))
            (end   (piece-length piece)))
-      (if (<= start pos (- end 1))
-        (string-ref (piece-buffer piece) (+ start pos))
+      (if (<= start pos (+ start end -1))
+        (string-ref (buffer->string (piece-buffer piece)) (- pos start))
         (if (not (null? (cdr pieces)))
           (loop (cdr pieces) (+ start end))
           (eof-object))))))
 
-(define (piece-table-insert! piece-table pos char)
-  #f)
+(define (piece-table-text-length piece-table)
+  (reduce + 0 (map piece-length (piece-table-pieces piece-table))))
+
+(define (piece-table-insert! piece-table pos str)
+
+  (define (pos->piece-idx-pos ps pos)
+    (let loop ((idx 0)
+               (pieces ps)
+               (rem pos))
+       (let* ((current (car pieces))
+              (len     (piece-length current)))
+        (if (<= rem len)
+          (values idx rem)
+          (loop (+ idx 1) (cdr pieces) (- rem len))))))
+
+  ;; 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
+      (call-with-values
+        (lambda () (pos->piece-idx-pos (piece-table-pieces piece-table) pos))
+        (lambda (idx rem)
+          (call-with-values
+            (lambda ()
+              (split-at! (piece-table-pieces piece-table) idx))
+            (lambda (beg end)
+              (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-delete! piece-table pos)
   #f)
@@ -68,4 +180,15 @@
 (define string->piece-table make-piece-table)
 
 (define (piece-table->string piece-table)
-  #f)
+  (let ((out-string (make-string (piece-table-text-length piece-table))))
+    (let loop ((pieces (piece-table-pieces piece-table))
+               (acc    0))
+      (if (null? pieces)
+        out-string
+        (let ((piece (car pieces)))
+          (string-copy! out-string
+                        acc
+                        (buffer->string (piece-buffer piece))
+                        (piece-start piece)
+                        (+ (piece-start piece) (piece-length piece)))
+          (loop (cdr pieces) (+ acc (piece-length piece))))))))
diff --git a/par/piece-table.sld b/par/piece-table.sld
index 4f428b0..1c915d7 100644
--- a/par/piece-table.sld
+++ b/par/piece-table.sld
@@ -1,5 +1,6 @@
 (define-library (par piece-table)
-  (import (scheme base))
+  (import (scheme base)
+          (srfi 1))
   (export make-piece-table
           piece-table-index
           piece-table-insert!
diff --git a/tests/piece-table.scm b/tests/piece-table.scm
index 8f3af80..d1fa32a 100644
--- a/tests/piece-table.scm
+++ b/tests/piece-table.scm
@@ -12,8 +12,9 @@
 
 (test-begin "insert")
   (define table (make-piece-table "HOLA"))
-  (piece-table-insert! table 2 #\9)
+  (piece-table-insert! table 2 "90")
   (test-equal #\9 (piece-table-index table 2))
+  (test-equal #\0 (piece-table-index table 3))
 (test-end "insert")
 
 (test-begin "delete")