blob: aa4993b4a9e942bf41b72d8bc7cd0f9896a47cbd (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
|
;; Pieces themselves: the buffer is a reference to the buffer they take their
;; data from.
;; Start and end are numbers.
;; The type defines how they should be rendered, it makes
;; possible to account for hyperlinks or stuff like that in the future with
;; ease.
(define-record-type <piece>
(make-piece buffer start length type)
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!))
;; 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 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-buffer add-buffer pieces)
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!))
(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)))))
(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))
(let* ((piece (car pieces))
(end (piece-length piece)))
(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-text-length piece-table)
(reduce + 0 (map piece-length (piece-table-pieces piece-table))))
(define (piece-table-text-pos->piece-idx+remainder piece-table pos)
"Returns (values piece remainder)"
(let loop ((idx 0)
(ps (piece-table-pieces piece-table))
(rem pos))
(let* ((current (car ps))
(len (piece-length current)))
(if (<= rem len)
(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)))))))
;; Serialization - Deserialization
(define (piece-table-write port)
"Write a piece table to port"
#f)
(define (piece-table-read port)
"Read a piece table stored in port"
#f)
;; From/to string
(define string->piece-table make-piece-table)
(define (piece-table->string piece-table)
(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))))))))
|
