diff options
| -rw-r--r-- | par/piece-table.scm | 229 | ||||
| -rw-r--r-- | par/piece-table.sld | 1 |
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 |