blob: f20dbd566c16c6b32dbd33960e7c01cd0e4f7860 (
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
|
;; 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 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!)
(next %piece-next %set-piece-next!)
(prev %piece-prev %set-piece-prev!))
(define-record-type <sentinel-piece>
(make-sentinel-piece next prev)
sentinel-piece?
(next %sentinel-piece-next %set-sentinel-piece-next!)
(prev %sentinel-piece-prev %set-sentinel-piece-prev!))
;; TODO think about a way to make all this polymorphism automagic
(define (piece-next p)
(cond
((sentinel-piece? p) (%sentinel-piece-next p))
((piece? p) (%piece-next p))))
(define (piece-prev p)
(cond
((sentinel-piece? p) (%sentinel-piece-prev p))
((piece? p) (%piece-prev p))))
(define (set-piece-prev! p prev)
(cond
((sentinel-piece? p) (%set-sentinel-piece-prev! p prev))
((piece? p) (%set-piece-prev! p prev))))
(define (set-piece-next! p next)
(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)
(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)
(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)))
;; The piece table itself;
;; 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 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!)
(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
#f #f))
(sentinel (make-sentinel-piece #f #f)))
(connect-pieces! sentinel piece)
(connect-pieces! piece sentinel)
(%make-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)
(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-table-insert! piece-table pos str type)
;; TODO
(piece-table-update-length! (string-length str)))
(define (piece-table-delete! piece-table from len)
;; TODO
(piece-table-update-length! (- len)))
(define (piece-table-change-looks!)
#f)
;; 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-substring piece-table from to)
(let ((out-string (make-string (- to from))))
(let loop ((piece (piece-next (piece-table-sentinel piece-table)))
(acc 0))
(if (or (sentinel-piece? piece) (>= acc to))
out-string
(begin
(when (>= (+ (piece-length piece) acc) from)
(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 (piece-next piece) (+ acc (piece-length piece))))))))
(define (piece-table->string piece-table)
(piece-table-substring piece-table 0 (piece-table-length piece-table)))
|
