summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--par/%piece-table-all.sld24
-rw-r--r--par/piece-table.scm257
-rw-r--r--par/piece-table.sld10
-rw-r--r--tests/piece-table.scm101
4 files changed, 156 insertions, 236 deletions
diff --git a/par/%piece-table-all.sld b/par/%piece-table-all.sld
new file mode 100644
index 0000000..99894ee
--- /dev/null
+++ b/par/%piece-table-all.sld
@@ -0,0 +1,24 @@
+(define-library (par %piece-table-all)
+ (import (scheme base)
+ (par buffers)
+ (srfi 11))
+ (export make-piece
+ piece-next
+ piece-prev
+ split-piece!
+ merge-pieces!
+ connect-pieces!
+ can-merge-pieces?
+ piece-empty?
+
+ make-piece-table
+ piece-table-sentinel
+ piece-table-index
+ piece-table-length
+ piece-table-insert!
+ piece-table-delete!
+ piece-table-change-looks!
+
+ piece-table->string
+ string->piece-table)
+ (include "piece-table.scm"))
diff --git a/par/piece-table.scm b/par/piece-table.scm
index 5012a94..f20dbd5 100644
--- a/par/piece-table.scm
+++ b/par/piece-table.scm
@@ -5,7 +5,7 @@
;; possible to account for hyperlinks or stuff like that in the future with
;; ease.
(define-record-type <piece>
- (%make-piece buffer start length type next prev)
+ (make-piece buffer start length type next prev)
piece?
(buffer piece-buffer set-piece-buffer!)
(start piece-start set-piece-start!)
@@ -40,53 +40,40 @@
(cond
((sentinel-piece? p) (%set-sentinel-piece-next! p next))
((piece? p) (%set-piece-next! p next))))
+;; End polymorphic magic
-
+(define (piece-empty? p)
+ (= (piece-length p) 0))
(define (can-merge-pieces? a b)
- ;; Maybe simplify the and/or/not magic?
- (and (not (or (sentinel-piece? a) (sentinel-piece? 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-next! a (piece-next b))
- (unless (sentinel-piece? (piece-next b)) (set-piece-prev! (piece-next b) a)))
-
-
-
-;; Piece API
-(define (make-piece buffer start length type prev next)
- (%make-piece buffer start length type prev next))
+ (and (piece? a) (piece? b)
+ (or (piece-empty? a) (piece-empty? b)
+ (and
+ (equal? (piece-buffer a) (piece-buffer b))
+ (= (+ (piece-start a) (piece-length a)) (piece-start b))
+ (equal? (piece-type a) (piece-type b)) ))))
(define (connect-pieces! a b)
- (begin
- (set-piece-next! a b)
- (set-piece-prev! b a)))
-
-(define (split-piece! a at)
- (if (and (= at 0) (sentinel-piece? a))
- (values a a) ;; Just return the sentinel twice, as this is only used to
- ;; take one of them
- (letrec* ((b (%make-piece (piece-buffer a)
- (+ at (piece-start a))
- (- (piece-length a) at)
- (piece-type a)
- (piece-next a)
- a)))
- (unless (sentinel-piece? (piece-next a))
- (set-piece-prev! (piece-next a) b))
- (set-piece-length! a at)
- (set-piece-next! a b)
- (values a b))))
+ (set-piece-next! a b)
+ (set-piece-prev! b a))
-
+(define (merge-pieces! a b)
+ (set-piece-length! a (+ (piece-length a) (piece-length b)))
+ (connect-pieces! a (piece-next b)))
+
+(define (split-piece! a pos)
+ (when (sentinel-piece? a)
+ (error "Attempting to split the sentinel-piece"))
+ (when (>= pos (piece-length a))
+ (error "Attempting a split out of a piece"))
+ (let ((new-p (make-piece (piece-buffer a)
+ (+ (piece-start a) pos)
+ (- (piece-length a) pos)
+ (piece-type a)
+ #f #f)))
+ (set-piece-length! a pos)
+ (connect-pieces! new-p (piece-next a))
+ (connect-pieces! a new-p)))
@@ -94,165 +81,73 @@
;; original is a ro-buffer, add is an add-buffer (a string designed to grow)
;; and pieces is a piece that has its prev and next.
(define-record-type <piece-table>
- (%make-piece-table original-buffer add-buffer piece)
+ (%make-piece-table original-buffer add-buffer sentinel length
+ cached-piece cached-origin)
piece-table?
(original-buffer piece-table-original-buffer set-piece-table-original-buffer!)
(add-buffer piece-table-add-buffer set-piece-table-add-buffer!)
- (piece piece-table-piece set-piece-table-piece!))
+ (sentinel piece-table-sentinel set-piece-table-sentinel!)
+ (length piece-table-length set-piece-table-length!)
+ (cached-piece piece-table-cached-piece set-piece-table-cached-piece!)
+ (cached-origin piece-table-cached-origin set-piece-table-cached-origin!))
(define (make-piece-table original)
(letrec* ((ro-buffer (make-ro-buffer original))
(piece (make-piece ro-buffer 0 (string-length original) 'normal
- sentinel sentinel))
- (sentinel (make-sentinel-piece piece piece)))
- (set-piece-prev! piece sentinel)
- (set-piece-next! piece sentinel)
+ #f #f))
+ (sentinel (make-sentinel-piece #f #f)))
+ (connect-pieces! sentinel piece)
+ (connect-pieces! piece sentinel)
(%make-piece-table
- ro-buffer (make-add-buffer) piece)))
-
-(define (piece-table-index->piece+index piece-table pos)
- "Returns (values piece remainder) or eof-object"
- (let loop ((piece (piece-table-piece piece-table))
- (rem pos))
- (cond
- ((sentinel-piece? piece)
- (if (= rem 0)
- (values piece rem)
- (error "Requested position out of piece-table")))
- ((< rem (piece-length piece))
- (values piece rem))
- (else
- (loop (piece-next piece) (- rem (piece-length piece)))))))
-
-(define (piece-table-last-piece piece-table)
- (piece-prev (piece-prev (piece-table-piece piece-table))))
+ ro-buffer (make-add-buffer) sentinel (string-length original) piece 0)))
+
+(define (piece-table-update-length! piece-table by)
+ (set-piece-table-length! piece-table
+ (+ (piece-table-length piece-table) by)))
+
+(define (piece-table-find-piece piece-table pos)
+ "Returns (values piece origin) so the local coordinate is (- pos origin)"
+ (define (search-forward piece origin)
+ (if (>= pos (+ origin (piece-length piece)))
+ (search-forward (piece-next piece) (+ (piece-length piece) origin))
+ (values piece origin)))
+ (define (search-backwards piece origin)
+ (if (< pos origin)
+ (search-backwards (piece-prev piece) (- origin (piece-length piece)))
+ (values piece origin)))
+
+ (let-values (((piece origin)
+ ((if (> pos (piece-table-cached-origin piece-table))
+ search-forward search-backwards)
+ (piece-table-cached-piece piece-table)
+ (piece-table-cached-origin piece-table))))
+ (set-piece-table-cached-piece! piece-table piece)
+ (set-piece-table-cached-origin! piece-table origin)
+ (values piece origin)))
-
;; API
-
(define (piece-table-index piece-table pos)
- ;; TODO: Validate input
- (let-values (((piece idx) (piece-table-index->piece+index piece-table pos)))
- (string-ref (buffer->string (piece-buffer piece))
- (+ (piece-start piece) idx))))
-
-(define (piece-table-text-length piece-table)
- (let loop ((piece (piece-table-piece piece-table))
- (acc 0))
- (if (sentinel-piece? (piece-next piece))
- (+ acc (piece-length piece))
- (loop (piece-next piece) (+ (piece-length piece) acc)))))
-
-(define (%piece-fold-from piece f identity)
- (let loop ((piece piece)
- (acc identity))
- (unless (sentinel-piece? piece)
- (loop (piece-next piece) (f piece acc)))))
+ (when (< -1 pos (piece-table-length piece-table))
+ (let-values (((piece origin) (piece-table-find-piece piece-table pos)))
+ (string-ref (buffer->string (piece-buffer piece))
+ (+ (piece-start piece) (- pos origin))))))
-(define (%piece-fold-from-right piece f identity)
- (let loop ((piece piece)
- (acc identity))
- (unless (sentinel-piece? piece)
- (loop (piece-prev piece) (f piece acc)))))
-
-
-(define (piece-table-for-each piece-table f from to)
- ;; TODO: default from and to
- ;; TODO: maybe combine with the `piece-table-index->piece+index` to find the
- ;; `from`
- ;; TODO: make this lower level, searching from a piece, not from the table
- ;; TODO: implement using `%piece-fold-from`
- "Calls `f` through the characters of the piece-table, like `string-for-each`
- would do, but the `f` call also includes the piece (to expose extra data) and
- the index of the character"
- (let loop ((idx 0)
- (start 0)
- (piece (piece-table-piece piece-table)))
- (let* ((len (piece-length piece))
- (end (+ start len))
- (more? (not (sentinel-piece? (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 (piece-next piece)))
- ;; Current piece contains part of the section we need, go char by
- ;; char
- (begin
- (when (<= from idx)
- (f
- (string-ref (buffer->string (piece-buffer piece))
- (+ (piece-start piece) (- idx start)))
- idx
- piece))
- ;; There are chars to process in this piece
- (loop (+ idx 1) start piece)))))))
-
-(define (piece-table-for-each-right piece-table f from to)
- "-right version of piece-table-for-each, it finds the tail and goes
- backwards"
- ;; TODO: not implemented yet
- ;; TODO: make this lower level, searching from a piece, not from the table
- )
(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!
-
- (let* ((add-buffer (piece-table-add-buffer piece-table))
- (start (add-buffer-used add-buffer))
- (_ (add-buffer-append! add-buffer str))
- (candidate (make-piece add-buffer
- start
- (string-length str)
- type
- #f #f)))
- (unless (= 0 (string-length str))
- (let*-values (((piece idx)
- (piece-table-index->piece+index piece-table pos)))
- (cond
- ((= idx 0)
- (connect-pieces! (piece-prev piece) candidate)
- (connect-pieces! candidate piece)
- (when (can-merge-pieces? (piece-prev piece) candidate)
- (merge-pieces! (piece-prev piece) candidate)))
- (else
- (let-values (((first second) (split-piece! piece idx)))
- (connect-pieces! first candidate)
- (connect-pieces! candidate second)
- (when (can-merge-pieces? first candidate)
- (merge-pieces! first candidate)))))))))
+ ;; TODO
+ (piece-table-update-length! (string-length str)))
(define (piece-table-delete! piece-table from len)
- (unless (= 0 len)
- (let*-values (((start-piece idx) (piece-table-index->piece+index
- piece-table from))
- ((first second) (split-piece! start-piece idx))
- ((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))))
+ ;; TODO
+ (piece-table-update-length! (- len)))
-;; Finding:
-(define (piece-table-find piece-table char from)
- ;; TODO: generalize the from
- ;; TODO: Implement the backwards one too
- (call/cc (lambda (cont)
- (piece-table-for-each
- piece-table
- (lambda (c i p)
- (when (char=? c char)
- (cont i)))
- from
- (piece-table-text-length piece-table))
- (cont (eof-object)))))
+(define (piece-table-change-looks!)
+ #f)
@@ -271,7 +166,7 @@
(define (piece-table-substring piece-table from to)
(let ((out-string (make-string (- to from))))
- (let loop ((piece (piece-table-piece piece-table))
+ (let loop ((piece (piece-next (piece-table-sentinel piece-table)))
(acc 0))
(if (or (sentinel-piece? piece) (>= acc to))
out-string
@@ -286,4 +181,4 @@
(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)))
+ (piece-table-substring piece-table 0 (piece-table-length piece-table)))
diff --git a/par/piece-table.sld b/par/piece-table.sld
index cdef979..6215fb0 100644
--- a/par/piece-table.sld
+++ b/par/piece-table.sld
@@ -4,13 +4,11 @@
(srfi 11))
(export make-piece-table
piece-table-index
- piece-table-text-length
+ piece-table-length
piece-table-insert!
piece-table-delete!
+ piece-table-change-looks!
+
piece-table->string
- piece-table-substring
- string->piece-table
- add-buffer-length
- piece-table-for-each
- piece-table-find)
+ string->piece-table)
(include "piece-table.scm"))
diff --git a/tests/piece-table.scm b/tests/piece-table.scm
index c8d1280..620b50c 100644
--- a/tests/piece-table.scm
+++ b/tests/piece-table.scm
@@ -1,67 +1,70 @@
(import (srfi 64)
- (scheme base)
- (par piece-table))
+ (scheme small)
+ (par %piece-table-all))
;; https://srfi.schemers.org/srfi-64/srfi-64.html
(test-begin "index")
(define table (make-piece-table "HOLA"))
+ (split-piece! (piece-next (piece-table-sentinel table)) 2) ;;Spice up the test
(test-equal #\H (piece-table-index table 0))
(test-equal #\O (piece-table-index table 1))
(test-equal #\L (piece-table-index table 2))
(test-equal #\A (piece-table-index table 3))
+ (test-equal #\O (piece-table-index table 1))
(test-end "index")
(test-begin "length")
(define table (make-piece-table "HOLA"))
- (test-equal 4 (piece-table-text-length table))
+ (test-equal 4 (piece-table-length table))
(test-end "length")
-(test-begin "insert")
- (define table (make-piece-table "HOLA"))
- (piece-table-insert! table 4 "9" 'normal)
- (test-equal #\9 (piece-table-index table 4))
- (piece-table-insert! table 5 "0" 'normal)
- (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 "substring")
- (parameterize ((add-buffer-length 10))
- (define table (make-piece-table "1234567890"))
- (test-equal "1234567890" (piece-table-substring table 0 10))
- (test-equal "67890" (piece-table-substring table 5 10))
- (piece-table-insert! table 6 "X" 'normal)
- (test-equal "6X78" (piece-table-substring table 5 9)))
-(test-end "substring")
-
-(test-begin "delete")
- (define table (make-piece-table "HOLA SOY EKAITZ"))
- (piece-table-delete! table 4 1)
- (test-equal "HOLASOY EKAITZ" (piece-table->string table))
- (piece-table-delete! table 0 1)
- (test-equal "OLASOY EKAITZ" (piece-table->string table))
- (piece-table-delete! table 12 1)
- (test-equal "OLASOY EKAIT" (piece-table->string table))
-(test-end "delete")
-
-(test-begin "for-each")
- (define table (make-piece-table "12346890"))
- (piece-table-insert! table 4 "5" 'normal)
- (test-equal "123456890" (piece-table->string table))
- (piece-table-insert! table 6 "7" 'normal)
- (test-equal "1234567890" (piece-table->string table))
- (piece-table-for-each table
- (lambda (c i p)
- (test-equal c (string-ref "1234567890" i)))
- 0
- 10)
-(test-end "for-each")
-(test-begin "find")
- (define table (make-piece-table "1234567890"))
- (test-equal 8 (piece-table-find table #\9 0))
-(test-end "find")
+;(test-begin "insert")
+; (define table (make-piece-table "HOLA"))
+; (piece-table-insert! table 4 "9" 'normal)
+; (test-equal #\9 (piece-table-index table 4))
+; (piece-table-insert! table 5 "0" 'normal)
+; (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 "substring")
+; (parameterize ((add-buffer-length 10))
+; (define table (make-piece-table "1234567890"))
+; (test-equal "1234567890" (piece-table-substring table 0 10))
+; (test-equal "67890" (piece-table-substring table 5 10))
+; (piece-table-insert! table 6 "X" 'normal)
+; (test-equal "6X78" (piece-table-substring table 5 9)))
+;(test-end "substring")
+;
+;(test-begin "delete")
+; (define table (make-piece-table "HOLA SOY EKAITZ"))
+; (piece-table-delete! table 4 1)
+; (test-equal "HOLASOY EKAITZ" (piece-table->string table))
+; (piece-table-delete! table 0 1)
+; (test-equal "OLASOY EKAITZ" (piece-table->string table))
+; (piece-table-delete! table 12 1)
+; (test-equal "OLASOY EKAIT" (piece-table->string table))
+;(test-end "delete")
+;
+;(test-begin "for-each")
+; (define table (make-piece-table "12346890"))
+; (piece-table-insert! table 4 "5" 'normal)
+; (test-equal "123456890" (piece-table->string table))
+; (piece-table-insert! table 6 "7" 'normal)
+; (test-equal "1234567890" (piece-table->string table))
+; (piece-table-for-each table
+; (lambda (c i p)
+; (test-equal c (string-ref "1234567890" i)))
+; 0
+; 10)
+;(test-end "for-each")
+;
+;(test-begin "find")
+; (define table (make-piece-table "1234567890"))
+; (test-equal 8 (piece-table-find table #\9 0))
+;(test-end "find")