par: piece-table: move a doubly linked list

2 files changed, 116 insertions, 114 deletions

diff --git a/par/piece-table.scm b/par/piece-table.scm
index 21661e7..202b9a1 100644
--- a/par/piece-table.scm
+++ b/par/piece-table.scm
@@ -1,22 +1,3 @@
-;; TODO: REMOVE ME: Chibi scheme fails to append! to empty lists. I fixed it
-;; upstream, but it will take time to get to guix
-(define (concatenate! lists)
-  (if (null? lists)
-      '()
-      (let loop ((acc    '())
-                 (prev   '())
-                 (rem    lists))
-          (cond
-            ((null? rem) acc)
-            ((null? acc) (let ((cur (car rem))) (loop cur cur (cdr rem))))
-            ((null? (car rem)) (loop acc prev (cdr rem)))
-            (else (let ((cur (car rem)))
-                    (set-cdr! (last-pair prev) cur)
-                    (loop acc cur (cdr rem))))))))
-(define (append! . lists) (concatenate! lists))
-;; /REMOVE ME
-
-
 ;; Utils
 (define (character-newline? ch)
   (char=? ch #\newline))
@@ -31,19 +12,21 @@
 ;; ease.
 ;; Linebreaks is a vector of linebreaks (easy to count length)
 (define-record-type <piece>
-  (%make-piece buffer start length type linebreaks)
+  (%make-piece buffer start length type linebreaks next prev)
   piece?
   (buffer piece-buffer set-piece-buffer!)
   (start piece-start set-piece-start!)
   (length piece-length set-piece-length!)
   (type piece-type set-piece-type!)
-  (linebreaks piece-linebreaks set-piece-linebreaks!))
+  (linebreaks piece-linebreaks set-piece-linebreaks!)
+  (next piece-next set-piece-next!)
+  (prev piece-prev set-piece-prev!))
 
 (define (index-linebreaks buffer start length)
   (define str (buffer->string buffer))
   (define (string-foreach* str f from length)
     (let loop ((i 0))
-      (when (not (= i length))
+      (unless (= i length)
         (f i (string-ref str (+ start i)))
         (loop (+ i 1)))))
   (define outlist (list))
@@ -55,19 +38,34 @@
                    start length)
   (list->vector (reverse outlist)))
 
-(define (make-piece buffer start length type)
-  (%make-piece buffer start length type (index-linebreaks buffer start length)))
+(define (make-piece buffer start length type prev next)
+  (%make-piece buffer start length type (index-linebreaks buffer start length)
+               prev next))
 
 (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))))
+  ;; Maybe simplify the and/or/not magic?
+  (and (not (or (null? a) (null? b)))
+       (or
+         (or (= 0 (piece-length a)) (= 0 (piece-length 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)
+  (when (= 0 (piece-length a)) ;; First is empty, so we eat it
+    (set-piece-start! a (piece-start b)))
   (set-piece-length! a (+ (piece-length a) (piece-length b)))
   (set-piece-linebreaks! a (vector-append (piece-linebreaks a)
                                           (piece-linebreaks b)))
-  a)
+  (set-piece-next! a (piece-next b))
+  (unless (null? (piece-next b)) (set-piece-prev! (piece-next b) a)))
+
+(define (connect-pieces! a b)
+  (if (can-merge-pieces? a b)
+    (merge-pieces! a b)
+    (begin
+      (set-piece-next! a b)
+      (set-piece-prev! b a))))
 
 (define (split-linebreaks linebreaks at)
   (let* ((lb-l   (vector-length linebreaks))
@@ -82,17 +80,18 @@
 
 (define (split-piece! a at)
   (let-values (((lb-a lb-b) (split-linebreaks (piece-linebreaks a) at)))
-    (values
-      (%make-piece (piece-buffer a)
-                   (piece-start a)
-                   at
-                   (piece-type a)
-                   lb-a)
-      (%make-piece (piece-buffer a)
-                   (+ at (piece-start a))
-                   (- (piece-length a) at)
-                   (piece-type a)
-                   lb-b))))
+    (letrec* ((b (%make-piece (piece-buffer a)
+                              (+ at (piece-start a))
+                              (- (piece-length a) at)
+                              (piece-type a)
+                              lb-b
+                              (piece-next a)
+                              a)))
+      (unless (null? (piece-next a)) (set-piece-prev! (piece-next a) b))
+      (set-piece-length! a at)
+      (set-piece-linebreaks! a lb-a)
+      (set-piece-next! a b)
+      (values a b))))
 
 
 
@@ -145,45 +144,51 @@
     (string-copy! (add-buffer-string add-buffer) buffer-used str)
     (set-add-buffer-used! add-buffer (+ append-len buffer-used))
 
+    ;; TODO: make this another way? maybe it's fine to do it like this...
     (lambda (type)
       (make-piece add-buffer
                   buffer-used
                   (string-length str)
-                  type))))
+                  type
+                  (list)
+                  (list)))))
 
 
 
 ;; The piece table itself;
 ;; original is a ro-buffer, add is an add-buffer (a string designed to grow)
-;; and pieces is a list of pieces (should we avoid allocations?)
+;; and pieces is a piece that has its prev and next.
 (define-record-type <piece-table>
-  (%make-piece-table original-buffer add-buffer pieces)
+  (%make-piece-table original-buffer add-buffer piece)
   piece-table?
   (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!))
+  (piece piece-table-piece set-piece-table-piece!))
 
 
 (define (make-piece-table original)
   (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)))))
+      (make-piece ro-buffer 0 (string-length original) 'normal (list) (list)))))
 
 (define (piece-table-index piece-table pos)
   ;; TODO: Validate input
-  (let loop ((pieces (piece-table-pieces piece-table))
+  (let loop ((p (piece-table-piece piece-table))
              (start 0))
-    (let* ((piece (car pieces))
-           (end   (piece-length piece)))
+    (let* ((end   (piece-length p)))
       (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))
+        (string-ref (buffer->string (piece-buffer p)) (- pos start))
+        (if (not (null? (piece-next p)))
+          (loop (piece-next p) (+ start end))
           (eof-object))))))
 
 (define (piece-table-text-length piece-table)
-  (reduce + 0 (map piece-length (piece-table-pieces piece-table))))
+  (let loop ((piece (piece-table-piece piece-table))
+             (acc   0))
+    (if (null? (piece-next piece))
+      (+ acc (piece-length piece))
+      (loop (piece-next piece) (+ (piece-length piece) acc)))))
 
 (define (piece-table-for-each piece-table f from to)
   ;; TODO: default from and to
@@ -192,16 +197,15 @@
   the index of the character"
   (let loop ((idx   0)
              (start 0)
-             (pieces (piece-table-pieces piece-table)))
-    (let* ((piece (car pieces))
-           (len   (piece-length piece))
+             (piece (piece-table-piece piece-table)))
+    (let* ((len   (piece-length piece))
            (end   (+ start len))
-           (more? (not (null? (cdr pieces)))))
+           (more? (not (null? (piece-next piece)))))
       (when (< idx to) ;; Skip tail
         (if (or (= idx end) (<= end from))
           ;; Current piece doesn't contain the section we need or finished
           ;; Jump to next piece
-          (when more? (loop end end (cdr pieces)))
+          (when more? (loop end end (piece-next piece)))
           ;; Current piece contains part of the section we need, go char by
           ;; char
           (begin
@@ -212,60 +216,67 @@
                 idx
                 piece))
             ;; There are chars to process in this piece
-            (loop (+ idx 1) start pieces)))))))
+            (loop (+ idx 1) start piece)))))))
 
 (define (piece-table-find-line-break piece-table idx)
   (let loop ((idx 0)
-             (ps (piece-table-pieces piece-table))
+             (piece (piece-table-piece piece-table))
              (rem idx))
-     (let* ((current (car ps))
-            (len     (piece-length current))
-            (lines   (piece-linebreaks current))
+     (let* ((len     (piece-length piece))
+            (lines   (piece-linebreaks piece))
             (lc      (vector-length lines)))
         (cond
-          ((< rem lc)         (+ idx (vector-ref lines rem)))
-          ((null? (cdr ps))   (eof-object)) ;; TODO: No more pieces, return the end or eof?
-          (else               (loop (+ idx len) (cdr ps) (- rem lc)))))))
-
-(define (piece-table-text-pos->piece-idx+remainder piece-table pos)
+          ((< rem lc)
+           (+ idx (vector-ref lines rem)))
+          ;; TODO: No more pieces, return the end or eof?
+          ((null? (piece-next piece))
+           (eof-object))
+          (else
+           (loop (+ idx len) (piece-next piece) (- rem lc)))))))
+
+(define (piece-table-index->piece+index piece-table pos)
   "Returns (values piece remainder) or eof-object"
   (let loop ((idx 0)
-             (ps (piece-table-pieces piece-table))
+             (piece (piece-table-piece piece-table))
              (rem pos))
-     (let* ((current (car ps))
-            (len     (piece-length current)))
+     (let ((len (piece-length piece)))
        (cond
-         ((<= rem len)       (values idx rem))
-         ((null? (cdr ps))   (eof-object)) ;; TODO: No more pieces, return the end or eof?
-         (else               (loop (+ idx 1) (cdr ps) (- rem len)))))))
-
-(define (list-ref-with-context l i)
-  (let ((len (length l)))
-    (values (take l i) (list-ref l i) (drop l (+ 1 i)))))
+         ((<= rem len)
+          (values piece rem))
+         ((null? (piece-next piece))
+          ;; TODO: No more pieces, return the end or eof?
+          (error "Requested position out of piece-table"))
+         (else
+          (loop (+ idx 1) (piece-next piece) (- rem len)))))))
+
+(define (piece-table-piece-index piece-table i)
+  (let ((piece-prev/next (if (< i 0) piece-prev piece-next))
+        (inc/dec         (if (< i 0) - +)))
+    (let loop ((piece (piece-table-piece piece-table))
+               (idx   0))
+      (if (= idx i)
+        piece
+        (loop (piece-prev/next piece) (inc/dec idx 1))))))
 
 (define (piece-table-insert! piece-table pos str type)
   ;; TODO: validate input
   ;; TODO: Try to reuse the caracters on the target buffer if they are already
   ;; there? Is this maximum evilness? => it's just a string-ref and it prevents
   ;; us from creating pieces!
+
+  ;; TODO Maybe remove this?
   (define candidate ((add-buffer-append!
                        (piece-table-add-buffer piece-table) str)
                      type))
 
-  (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))
+  (unless (= 0 (string-length str))
+    (let*-values (((piece idx) (piece-table-index->piece+index piece-table pos)))
+      (if (and (= idx (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
-                   (remove (lambda (p) (= 0 (piece-length p)))
-                           (list first candidate second))
-                   end))))))
+        (merge-pieces! piece candidate)
+        (let-values (((first second) (split-piece! piece idx)))
+          (connect-pieces! first candidate)
+          (connect-pieces! candidate second))))))
 
 
 ; TODO: SET-CDR for the win?
@@ -273,25 +284,17 @@
 ; > we'll leave it for the future
 (define (piece-table-delete! piece-table from len)
   ;; TODO: Validate input
-  (let*-values (((idx rem) (piece-table-text-pos->piece-idx+remainder
-                             piece-table from)) ; TODO because of the <=
-                ((end-idx end-rem) (piece-table-text-pos->piece-idx+remainder
-                                     piece-table (+ from len)))
-                ((beg piece _) (list-ref-with-context
-                                 (piece-table-pieces piece-table)
-                                 idx))
-
-                ((_ end-piece end) (list-ref-with-context
-                                     (piece-table-pieces piece-table)
-                                     end-idx)))
-    (let*-values (((first second) (split-piece! piece rem))
-                  ((third fourth) (split-piece! end-piece end-rem)))
-      (set-piece-table-pieces!
-        piece-table
-        (append! beg
-                 (remove (lambda (p) (= 0 (piece-length p)))
-                         (list first fourth))
-                 end)))))
+  (unless (= 0 len)
+    (let*-values (((start-piece idx) (piece-table-index->piece+index
+                                       piece-table from))
+                  ((first second) (split-piece! start-piece idx))
+                  ;; We can search from the `second` here, because it's going
+                  ;; to be at least in second, and we only iterate once that
+                  ;; way
+                  ((end-piece end-idx) (piece-table-index->piece+index
+                                         piece-table (+ from len)))
+                  ((third fourth) (split-piece! end-piece end-idx)))
+      (connect-pieces! first fourth))))
 
 
 
@@ -310,18 +313,18 @@
 
 (define (piece-table-substring piece-table from to)
   (let ((out-string (make-string (- to from))))
-    (let loop ((pieces (piece-table-pieces piece-table))
-               (acc    0))
-      (if (or (null? pieces) (>= acc to))
+    (let loop ((piece (piece-table-piece piece-table))
+               (acc   0))
+      (if (or (null? piece) (>= acc to))
         out-string
-        (let ((piece (car pieces)))
+        (begin
           (string-copy!
             out-string
             (max (- acc from) 0)
             (buffer->string (piece-buffer piece))
             (+ (piece-start piece) (max (- from acc) 0))
             (+ (piece-start piece) (min (- to acc) (piece-length piece))))
-          (loop (cdr pieces) (+ acc (piece-length piece))))))))
+          (loop (piece-next piece) (+ acc (piece-length piece))))))))
 
 (define (piece-table->string piece-table)
   (piece-table-substring piece-table 0 (piece-table-text-length piece-table)))
diff --git a/par/piece-table.sld b/par/piece-table.sld
index 427b389..c197181 100644
--- a/par/piece-table.sld
+++ b/par/piece-table.sld
@@ -1,6 +1,5 @@
 (define-library (par piece-table)
   (import (scheme base)
-          (srfi 1)
           (srfi 11))
   (export make-piece-table
           piece-table-index