blob: 9f967c00eedb1dfcc7a81748886aba7d597ff671 (
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
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
|
;; 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
;; 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!))
(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))))
(define (merge-pieces! a b)
(set-piece-length! a (+ (piece-length a) (piece-length b)))
a)
(define (split-piece! a at)
(values
(make-piece (piece-buffer a)
(piece-start a)
at
(piece-type a))
(make-piece (piece-buffer a)
(+ at (piece-start a))
(- (piece-length a) at)
(piece-type a))))
;; 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 (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) ; TODO not cool when removing!
(values idx rem)
(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)))))
(define (piece-table-insert! piece-table pos str type)
(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))
(can-merge-pieces? piece candidate))
(append! beg (list (merge-pieces! piece candidate)) end)
(let-values (((first second) (split-piece! piece rem)))
(append! beg (list first candidate second) end))))))
; TODO: SET-CDR for the win?
; - That would need other way to find the affected pieces and manipulate them.
; > we'll leave it for the future
(define (piece-table-delete! piece-table pos)
(let*-values (((idx rem) (piece-table-text-pos->piece-idx+remainder
piece-table (+ 1 pos))) ; TODO because of the <=
((beg piece end) (list-ref-with-context
(piece-table-pieces piece-table)
idx)))
(let ((piece-len (piece-length piece)))
(cond
((= piece-len 1)
(append! beg end))
((= rem piece-len)
(set-piece-length! piece (- piece-len 1)))
((= rem 1)
(set-piece-start! piece (+ 1 (piece-start piece))))
(else
(let-values (((first second) (split-piece! piece rem)))
(set-piece-length! first (- rem 1))
(set-piece-table-pieces!
piece-table
(append! beg (list first second) end))))))))
;; 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))))))))
|
