source: trunk/source/cocoa-ide/hemlock/src/charprops.lisp @ 13429

Last change on this file since 13429 was 13429, checked in by gz, 11 years ago

Try harder to recognize whole line

File size: 34.8 KB
Line 
1(in-package "HI")
2
3(defun make-empty-charprops-changes (&optional (size 2))
4  (make-array size :adjustable t :fill-pointer 0))
5
6(defun insert-charprops-change (changes index new)
7  "Insert a new change into the charprops changes vector at index.  Objects
8   at and beyond INDEX are shifted right to make room."
9  (vector-push-extend nil changes)
10  (replace changes changes :start1 (1+ index) :start2 index)
11  (setf (aref changes index) new))
12
13(defun delete-charprops-change (changes index)
14  "Delete the change at index from the charprops changes vector.  Objects
15   beyond INDEX are shifted left to fill the empty spot."
16  (unless (= (fill-pointer changes) index)
17    (replace changes changes :start1 index :start2 (1+ index)))
18  (decf (fill-pointer changes)))
19
20(defun push-charprops-change (change changes)
21  (vector-push-extend change changes))
22
23;;; Return the index of the charprops change that applies to
24;;; charpos, or else NIL if the charpos has (implicit)
25;;; default properties.
26(defun charprops-change-index-for-position (changes charpos)
27  (do ((i 0 (1+ i))
28       (i-1 nil i)
29       (change nil))
30      ((= i (length changes)) i-1)
31    (setq change (aref changes i))
32    (when (< charpos (charprops-change-index change))
33      (return i-1))))
34
35;;; Real programmers can write assembly in any language.
36(defun line-charprops-for-position (line charpos)
37  "Return, as multiple values, the plist, and start position and end
38   position over which the plist applies."
39  (unless (and (>= charpos 0)
40               (<= charpos (line-length line)))
41    (error "index ~d out of range" charpos))
42  (let* ((changes (line-charprops-changes line))
43         (change nil)
44         (prior-change nil)
45         (start-pos 0)
46         (end-pos 0))
47    (dotimes (i (length changes) (values (and change
48                                              (charprops-change-plist change))
49                                         start-pos (1+ (line-length line))))
50      (setq prior-change change)
51      (setq change (aref changes i))
52      (setq end-pos (charprops-change-index change))
53      (when (< charpos (charprops-change-index change))
54        (return (values (and prior-change (charprops-change-plist prior-change))
55                        start-pos end-pos)))
56      (setq start-pos (charprops-change-index change)))))
57
58(defun squeeze-out-superseded-changes (changes idx)
59  (let* ((base-change (aref changes idx)))
60    (do* ((i (1+ idx) (1+ i))
61          (change nil)
62          (n 0))
63         ((= i (length changes))
64          ;;(format t "~&start1 = ~d start2 = ~d" (1+ idx) (+ n 1 idx))
65          (replace changes changes :start1 (1+ idx) :start2 (+ n 1 idx))
66          (decf (fill-pointer changes) n)
67          changes)
68      (setq change (aref changes i))
69      (when (<= (charprops-change-index change)
70                (charprops-change-index base-change))
71        (setf (charprops-change-plist base-change) (charprops-change-plist change))
72        (incf n)
73        (setf (aref changes i) nil)))))
74
75;;; Set the charprops of the specified LINE between positions START and
76;;; END.  If END is NIL, that means the end of the line.  Note that this
77;;; doesn't merge in properties: it replaces whatever is there.
78(defun set-line-charprops (line charprops &key (start 0) end &aux plist)
79  (setq plist (charprops-as-plist charprops))
80  (when (and end (= end (line-length line)))
81    (setq end nil))
82  (when (and (null plist) (= start 0) (null end))
83    (setf (line-charprops-changes line) nil)
84    (return-from set-line-charprops))
85  (let* ((changes (line-charprops-changes line))
86         (new-change (make-charprops-change start plist)))
87    (if (null changes)
88      (let ((new-changes (make-array 2 :adjustable t :fill-pointer 0)))
89        (vector-push new-change new-changes)
90        (when end
91          (vector-push (make-charprops-change end nil) new-changes))
92        (setf (line-charprops-changes line) new-changes)
93        (line-charprops-changes line))
94      ;; Put the new charprops change into the right place in the charprops
95      ;; changes vector, making note of its position.
96      (do* ((i 0 (1+ i))
97            (change nil)
98            (prior-change nil change))
99           ((= i (length changes))
100            (insert-charprops-change changes i new-change)
101            (when end
102              (let ((prior-plist (and prior-change
103                                      (charprops-change-plist prior-change))))
104                (insert-charprops-change changes (1+ i)
105                                         (make-charprops-change end prior-plist)))))
106        (setq change (aref changes i))
107        (when (<= start (charprops-change-index change))
108          (insert-charprops-change changes i new-change)
109          (incf i)
110          (if (null end)
111            (setf (fill-pointer changes) i)
112            (let ((prior-plist (and prior-change
113                                    (charprops-change-plist prior-change))))
114              (insert-charprops-change changes i (make-charprops-change end prior-plist))
115              (squeeze-out-superseded-changes changes i)))
116          (return))))))
117
118(defun add-line-charprop-value (line name value &key (start 0) end)
119  (let* ((changes (line-charprops-changes line))
120         (start-idx (charprops-change-index-for-position changes start))
121         (end-idx (charprops-change-index-for-position changes
122                                                       (or end
123                                                           (setq end (line-length line))))))
124    (cond ((or (null changes)
125               (and (null start-idx) (null end-idx)))
126           ;; Either the line has no existing charprops, or we're within the
127           ;; implicit run of default properties at the start of the line.
128           ;; Just set the charprops over the relevant range and return.
129           (set-line-charprops line (list name value) :start start :end end)
130           (return-from add-line-charprop-value changes))
131          ((null start-idx)
132           ;; The starting position is in the implicit run of default
133           ;; properties at the start of the line.
134           (let ((new-change (make-charprops-change start (list name value))))
135             (insert-charprops-change changes 0 new-change)
136             (setq start-idx 0)
137             (incf end-idx))
138           (let ((end-change (aref changes end-idx)))
139             (unless (= (charprops-change-index end-change) end)
140               (let ((new-change (copy-charprops-change end-change)))
141                 (setf (charprops-change-index new-change) end)
142                 (insert-charprops-change changes (1+ end-idx) new-change)
143                 (incf end-idx)))))
144          ((and start-idx end-idx)
145           (let ((start-change (aref changes start-idx)))
146             (unless (= (charprops-change-index start-change) start)
147               (let ((new-change (copy-charprops-change start-change)))
148                 (setf (charprops-change-index new-change) start)
149                 (insert-charprops-change  changes (1+ start-idx) new-change)
150                 (incf start-idx)
151                 (incf end-idx))))
152           (let ((end-change (aref changes end-idx))
153                 (next-end-idx (charprops-change-index-for-position changes (1+ end))))
154             ;; If end-idx and next-end-idx differ, then the end
155             ;; position comes at the very end of a run, and we don't
156             ;; need to split.  We also don't need to split if end is
157             ;; at the very end of the line.
158             (when (and (= end-idx next-end-idx)
159                        (not (= end (line-length line))))
160               (let ((new-change (copy-charprops-change end-change)))
161                 (setf (charprops-change-index new-change) end)
162                 (insert-charprops-change changes (1+ end-idx) new-change)))))
163          (t (error "how did we get here?")))
164    (loop for i from start-idx to end-idx
165      as change = (aref changes i)
166      do (if (null value)
167           (remf (charprops-change-plist change) name)
168           (setf (getf (charprops-change-plist change) name) value)))))
169
170(defun set-region-charprops (region charprops)
171  (let* ((start (region-start region))
172         (end (region-end region))
173         (first-line (mark-line start))
174         (last-line (mark-line end)))
175    (cond ((eq first-line last-line)
176           (set-line-charprops first-line charprops :start (mark-charpos start)
177                               :end (mark-charpos end))
178           (coalesce-line-charprops first-line))
179          (t
180           (set-line-charprops first-line charprops :start (mark-charpos start))
181           (do* ((line (line-next first-line) (line-next line)))
182                ((eq line last-line)
183                 (set-line-charprops line charprops :end (mark-charpos end)))
184             (set-line-charprops line charprops))))))
185
186;;; Returns two values: fresh charprops change vectors for the line's characters
187;;; before and after charpos.
188(defun split-line-charprops (line charpos)
189  (let* ((changes (line-charprops-changes line))
190         (nchanges (length changes)))
191    (when (> nchanges 0)
192      (let ((left (make-array 2 :adjustable t :fill-pointer 0))
193            (right (make-array 2 :adjustable t :fill-pointer 0))
194            (pivot nil)
195            (prior-change nil))
196        (do* ((i 0 (1+ i))
197              (change nil))
198             ((or pivot
199                  (= i nchanges))
200              (if (null pivot)
201                ;; The last change extends to the end of line, so that will be the
202                ;; charprops in effect at the beginning of the new line.
203                (if (null (charprops-change-plist change))
204                  (setq right nil)
205                  (let* ((c (copy-charprops-change change)))
206                    (setf (charprops-change-index c) 0)
207                    (push-charprops-change c right)))
208                ;; Some charprops changes remain.  First, split the prior change
209                ;; if necessary, and then pick up the rest of the shifts.
210                (progn
211                  (when (and prior-change
212                             (> charpos (charprops-change-index prior-change)))
213                    ;; need to split change
214                    (let* ((c (copy-charprops-change prior-change)))
215                      (setf (charprops-change-index c) 0)
216                      (push-charprops-change c right)))
217                  (loop for i from pivot below nchanges
218                    as change = (aref changes i)
219                    do (decf (charprops-change-index change) charpos)
220                    (push-charprops-change (aref changes i) right))))
221              (values left right pivot))
222          (setq change (aref changes i))
223          (if (< (charprops-change-index change) charpos)
224            (progn
225              (push-charprops-change change left)
226              (setq prior-change change))
227            (setq pivot i)))))))
228
229(defun append-line-charprops (line changes)
230  (let* ((left (line-charprops-changes line))
231         (len (line-length line))
232         (right changes))
233    (cond ((and left right)
234           (loop for c across right
235                 for new-change = (copy-charprops-change c)
236                 do (incf (charprops-change-index new-change) len)
237                    (push-charprops-change new-change left)))
238          ((and (null left) right)
239           (setq left (copy-charprops-changes right))
240           (adjust-charprops-change-indexes left len)
241           (setf (line-charprops-changes line) left))
242          ((and left (null right))
243           (push-charprops-change (make-charprops-change len nil) left)))
244    left))
245
246;;; Append the charprops-changes from line2 onto line1, modifying their
247;;; indexes appropriately.
248(defun join-line-charprops (line1 line2)
249  (let* ((left (line-charprops-changes line1))
250         (lidx (1- (length left)))
251         (right (line-charprops-changes line2))
252         (ridx 0)
253         (line1-len (line-length line1)))
254    (cond ((and left right)
255           ;; If the last change on line1 and the first change on line2
256           ;; represent the same properties, then omit line2's first
257           ;; change.
258           (let* ((lchange (aref left lidx))
259                  (lprops (charprops-change-plist lchange))
260                  (rchange (aref right ridx))
261                  (rprops (charprops-change-plist rchange)))
262             (if (> 0 (charprops-change-index rchange))
263               ;; There is an implicit run of default charprops at the
264               ;; start of the line.
265               (unless (null lprops)
266                 ;; The last change on line1 represents some non-default
267                 ;; set of charprops, so insert an explicit change to the
268                 ;; default set before copying over the rest.
269                 (push-charprops-change (make-charprops-change (1+ line1-len) nil)
270                                        left))
271               (when (charprops-equal lprops rprops)
272                 (incf ridx)))
273             (do* ((i ridx (1+ i))
274                   (change nil))
275                  ((= i (length right)))
276               (setq change (aref right i))
277               (incf (charprops-change-index change) (1+ line1-len))
278               (push-charprops-change change left))))
279          ((and (null left) right)
280           (adjust-charprops-change-indexes right line1-len)
281           (setf (line-charprops-changes line1) right))
282          ((and left (null right))
283           (let* ((lchange (aref left lidx)))
284             (unless (null (charprops-change-plist lchange))
285               (push-charprops-change (make-charprops-change (1+ line1-len) nil)
286                                   left))))
287          ;; otherwise both nil, so don't need to do anything.
288          )
289    left))
290
291(defun copy-line-charprops (line &key (start 0) end)
292  "Return a freshly-consed vector of charprops changes that applies to the
293   characters in the interval [start, end) on the specified line.  If the
294   charprops in between start and end are the default charprops, return
295   NIL."
296  (let ((changes (line-charprops-changes line)))
297    ;; some early-out special cases
298    (cond ((null changes)
299           (return-from copy-line-charprops))
300          ((and (= start 0) (or (null end) (eql end (line-length line))))
301           (return-from copy-line-charprops (copy-charprops-changes changes))))
302    (unless end
303      (setq end (line-length line)))
304    (let* ((new-changes (make-empty-charprops-changes))
305           (start-idx (charprops-change-index-for-position changes start))
306           (end-idx (charprops-change-index-for-position changes (1- end))))
307      (if (eql start-idx end-idx)
308        (if (null start-idx)
309          (setq new-changes nil)
310          (let* ((change (aref changes start-idx))
311                 (plist (charprops-change-plist change)))
312            (if (null plist)
313              (setq new-changes nil)
314              (push-charprops-change (make-charprops-change start plist)
315                                     new-changes))))
316        (do ((i (or start-idx 0) (1+ i)))
317            ((> i end-idx))
318          (let* ((change (aref changes i))
319                 (index (charprops-change-index change))
320                 (plist (charprops-change-plist change)))
321          (push-charprops-change (make-charprops-change
322                                  (max 0 (- index start)) plist)
323                                 new-changes))))
324      new-changes)))
325
326(defun delete-line-charprops (line &key (start 0) end)
327  (let ((changes (line-charprops-changes line)))
328    ;; some early-out special cases
329    (cond ((null changes)
330           (return-from delete-line-charprops))
331          ((and (= start 0) (null end))
332           (setf (line-charprops-changes line) nil)
333           (return-from delete-line-charprops)))
334    (unless end
335      (setq end (line-length line)))
336    (assert (<= start end) (start end))
337    (let* ((start-idx (charprops-change-index-for-position changes start))
338           (end-idx (charprops-change-index-for-position changes (1- end))))
339      (cond ((null start-idx)
340             (if (null end-idx)
341               (adjust-charprops-change-indexes changes (- start end) :start 0)
342               (progn
343                 ;; delete changes before end-idx
344                 (replace changes changes :start1 0 :start2 end-idx)
345                 (decf (fill-pointer changes) end-idx)
346                 (setf (charprops-change-index (aref changes 0)) start)
347                 ;; move back start of subsequent changes, if there are any
348                 (when (> (length changes) 1)
349                   (adjust-charprops-change-indexes changes (- start end)
350                                                    :start 1)
351                   ;; if the change is now zero-length, remove it
352                   (when (= (charprops-change-index (aref changes 0))
353                            (charprops-change-index (aref changes 1)))
354                     (delete-charprops-change changes 0))))))
355            ((eql start-idx end-idx)
356             ;; The deletion takes place within the scope of a single
357             ;; charprops run.
358             ;; Move back start of subsequent changes, if there are any
359             (when (> (length changes) (1+ start-idx))
360               (adjust-charprops-change-indexes changes (- start end)
361                                                :start (1+ start-idx))
362               ;; if the change is now zero-length, remove it
363               (when (= (charprops-change-index (aref changes start-idx))
364                        (charprops-change-index (aref changes (1+ start-idx))))
365                 (delete-charprops-change changes start-idx))))
366            (t
367             ;; Remove changes between start-idx and and end-idx.
368             (replace changes changes :start1 (1+ start-idx)
369                      :start2 end-idx)
370             (decf (fill-pointer changes) (- end-idx (1+ start-idx)))
371             (setf (charprops-change-index (aref changes (1+ start-idx))) start)
372             (when (> (length changes) (1+ start-idx))
373               (adjust-charprops-change-indexes changes (- start end)
374                                                :start (+ 2 start-idx))
375               ;; if first change is now zero-length, remove it
376               (when (= (charprops-change-index (aref changes start-idx))
377                        (charprops-change-index (aref changes (1+ start-idx))))
378                 (delete-charprops-change changes start-idx))))))
379    (coalesce-line-charprops line)))
380
381;;; Coalesce adjacent changes with CHARPROP-EQUAL plists.
382;;; Maybe make this remove zero-length changes, too?
383(defun coalesce-line-charprops (line)
384  (let ((changes (line-charprops-changes line)))
385    (do* ((i 0 (1+ i))
386          (change nil))
387         ((>= i (length changes)))
388      (setq change (aref changes i))
389      (loop with j = (1+ i)
390        while (and (< j (length changes))
391                   (charprops-equal (charprops-change-plist change)
392                                    (charprops-change-plist (aref changes j))))
393        do (delete-charprops-change changes j)))
394    ;; Elide any changes with NIL plists at the start of the line.
395    (loop
396      while (and (> (length changes) 0)
397                 (null (charprops-change-plist (aref changes 0))))
398      do (delete-charprops-change changes 0))
399    (when (zerop (length changes))
400      (setf (line-charprops-changes line) nil)))
401  (line-charprops-changes line))
402     
403(defun adjust-charprops-change-indexes (changes delta &key (start 0))
404  (do* ((i start (1+ i))
405        (change nil))
406       ((>= i (length changes))
407        changes)
408    (setq change (aref changes i))
409    (incf (charprops-change-index change) delta)))
410
411;;; Add delta to the starting index of all charprops changes after the one
412;;; containing start.
413(defun adjust-line-charprops (line delta &key (start 0))
414  (let* ((changes (line-charprops-changes line))
415         (start-idx (charprops-change-index-for-position changes start)))
416    (adjust-charprops-change-indexes changes delta :start (if start-idx
417                                                            (1+ start-idx)
418                                                            0))))
419
420(defun apply-line-charprops (line changes start-pos end-pos)
421  (cond ((null changes)
422         (set-line-charprops line nil :start start-pos :end end-pos))
423        (t
424         (setq changes (copy-charprops-changes changes))
425         (do* ((i 0 (1+ i))
426               (change nil))
427              ((= i (length changes)))
428           (setq change (aref changes i))
429           (set-line-charprops line (charprops-change-plist change)
430                               :start (+ (charprops-change-index change) start-pos)
431                               :end end-pos))
432         (coalesce-line-charprops line)))
433  (line-charprops-changes line))
434
435(defvar *display-properties*
436  '(:font-name
437    :font-size
438    :font-weight
439    :font-width
440    :font-slant
441    :font-underline
442    :font-color
443    :background-color))
444
445;;; Setting and accessing charprops
446
447(defun next-charprop-value (mark name &key view)
448  (let ((props (next-charprops mark :view view)))
449    (getf props name)))
450
451(defun previous-charprop-value (mark name &key view)
452  (let ((props (previous-charprops mark :view view)))
453    (getf props name)))
454
455(defun set-charprop-value (mark name value &key (count 1 count-supplied-p) end view)
456  (declare (ignore view))
457  (when (and count-supplied-p end)
458    (error "Cannot specify both :COUNT and :END"))
459  (with-mark ((start-mark mark)
460              (end-mark mark))
461    (if end
462      (move-mark end-mark end)
463      (character-offset end-mark count))
464    (let* ((start-line (mark-line start-mark))
465           (start-charpos (mark-charpos start-mark))
466           (end-line (mark-line end-mark))
467           (end-charpos (mark-charpos end-mark)))
468      (cond ((eq start-line end-line)
469             (add-line-charprop-value start-line name value
470                                      :start start-charpos
471                                      :end end-charpos))
472            (t
473             (do* ((line start-line (line-next line))
474                   (start start-charpos 0))
475                  ((eq line end-line)
476                   (add-line-charprop-value end-line name value
477                                            :start 0
478                                            :end end-charpos))
479               (add-line-charprop-value line name value :start start))))
480      (let ((n (count-characters (region start-mark end-mark)))
481            (buffer (line-%buffer start-line)))
482        (hemlock-ext:buffer-note-modification buffer mark n)))))
483
484(defun find-line-charprop-value (line name value &key (start 0) end)
485  (unless end
486    (setq end (line-length line)))
487  (let* ((changes (line-charprops-changes line))
488         (start-idx (or (charprops-change-index-for-position changes start) 0))
489         (end-idx (or (charprops-change-index-for-position changes end) 0)))
490    (when changes
491      (loop for i from start-idx to end-idx
492         as change = (aref changes i)
493         as plist = (charprops-change-plist change)
494         as found-value = (getf plist name)
495         do (when (and found-value
496                       (charprop-equal found-value value))
497              (return (max start (charprops-change-index change))))))))
498
499(defun find-charprop-value (mark name value &key (count nil count-supplied-p)
500                            end view from-end)
501  (declare (ignore from-end view))
502  (with-mark ((start-mark mark)
503              (end-mark mark))
504    (when (and count-supplied-p end)
505      (error "Cannot specify both :COUNT and :END"))
506    (let* ((buffer (line-buffer (mark-line mark))))
507      (unless (bufferp buffer)
508        (error "text must be in a buffer"))
509      (if count-supplied-p
510        (character-offset end-mark count)
511        (move-mark end-mark (buffer-end-mark buffer)))
512      (let* ((start-line (mark-line start-mark))
513             (start-charpos (mark-charpos start-mark))
514             (end-line (mark-line end-mark))
515             (end-charpos (mark-charpos end-mark)))
516        (do* ((line start-line (line-next line))
517              (charpos start-charpos 0))
518             ((eq line end-line)
519              (let ((pos (find-line-charprop-value end-line name value
520                                                   :start charpos
521                                                   :end end-charpos)))
522                (when pos
523                  (move-to-position mark pos end-line)
524                  mark)))
525          (let ((pos (find-line-charprop-value line name value :start charpos)))
526            (when pos
527              (move-to-position mark pos line)
528              (return mark))))))))
529
530(defun filter-match (filter name)
531  (cond ((functionp filter)
532         (funcall filter name))
533        ((eq filter :display)
534         (member name *display-properties* :test #'eq))
535        ((typep filter 'sequence)
536         (member name filter))
537        (t
538         name)))
539
540(defun filter-charprops (filter charprops)
541  (if (eq filter t)
542    charprops
543    (typecase charprops
544      ((satisfies ccl::plistp) (loop for (k v) on charprops by #'cddr
545                                 when (filter-match filter k)
546                                 collect k and collect v))
547      (hash-table (loop for k being the hash-keys of charprops using (hash-value v)
548                    when (filter-match filter k)
549                    collect k and collect v)))))
550
551(defun next-charprops (mark &key view (filter t))
552  "Return the properties of the character after MARK."
553  (declare (ignore view))
554  (when (next-character mark)
555    (let* ((props (line-charprops-for-position (mark-line mark) (mark-charpos mark))))
556      (filter-charprops filter props))))
557
558(defun previous-charprops (mark &key view (filter t))
559  "Return the properties of the character before MARK."
560  (with-mark ((m mark))
561    (when (mark-before m)
562      (next-charprops m :view view :filter filter))))
563
564(defun set-charprops (mark charprops &key (count 1 count-supplied-p)
565                           (end nil end-supplied-p) (filter (charprops-names charprops)))
566  (when (and count-supplied-p end-supplied-p)
567    (error "Only one of count or end can be supplied."))
568  (setq charprops (charprops-as-plist charprops :filter filter))
569  (with-mark ((start-mark mark)
570              (end-mark mark))
571    (if end
572      (move-mark end-mark end)
573      (character-offset end-mark count))
574    ;; lame.
575    (loop for (k v) on charprops by #'cddr
576       do (set-charprop-value start-mark k v :end end-mark))))
577
578;;; Return a list of charprops-change vectors that correspond to the lines
579;;; of text in the region defined by the paramaters.
580(defun charprops-in-region (region-or-mark &key (count 1 count-supplied-p)
581                                           end filter)
582  (declare (ignore filter))
583  (when (and count-supplied-p end)
584    (error "Only one of count or end can be supplied."))
585  (let (region result)
586    (etypecase region-or-mark
587      (mark (with-mark ((m region-or-mark))
588              (when end
589                (setq count (- end (mark-absolute-position m))))
590              (character-offset m count)
591              (setq region (region region-or-mark m))))
592      (region (when (or count-supplied-p end)
593                (error "Can't specify count or end when passing in a region."))
594              (setq region region-or-mark)))
595    (let* ((start (region-start region))
596           (first-line (mark-line start))
597           (first-charpos (mark-charpos start))
598           (end (region-end region))
599           (last-line (mark-line end))
600           (last-charpos (mark-charpos end)))
601      (cond
602       ((eq first-line last-line)
603        (list (copy-line-charprops first-line :start first-charpos)))
604       (t
605        (push (copy-line-charprops first-line :start first-charpos) result)
606        (do* ((line (line-next first-line) (line-next line))
607              (m (copy-mark start) (line-start m line)))
608             ((eq line last-line)
609              (push (copy-line-charprops last-line :end last-charpos) result)
610              (nreverse result))
611          (push (copy-line-charprops line) result)))))))
612
613(defun apply-charprops (mark charprops-range &key filter from-end)
614  (declare (ignore from-end filter charprops-range mark)))
615
616#|
617  (let* ((start-line (mark-line mark))
618         (start-charpos (mark-charpos))
619         (nlines (length charprops-range))
620         (first-changes (pop charprops-range)))
621
622    ;; do possibly-partial first line
623    (let ((left (split-line-charprops start-line start-charpos)))
624      (setf (line-charprops start-line) left)
625      (append-line-charprops start-line first-changes))
626    ;; do some number of whole lines
627    (do* ((line (line-next start-line) (line-next line))
628          (previous-line start-line (line-next previous-line))
629          (cc-list charprops-range (cdr charprops-range))
630          (changes (car cc-list) (car cc-list)))
631         ((or (null line) (endp cc-list)))
632      (setf (line-charprops-changes line) (copy-charprops-changes changes)))
633    ;; I don't know what to do about a partial last line.  There's no
634    ;; way that I can see to know whether the last charprops change vector
635    ;; in the charprops-range list is to apply to an entire line or to end
636    ;; at a particular charpos on that line.  Maybe that information needs
637    ;; to be stored as part of the charprops-range list.  For example, if the
638    ;; element of the charprops-range list is a non-null list, the list could
639    ;; be (charprops-change-vector start-charpos end-charpos).
640
641    (multiple-value-bind (left right)
642                         (split-line-charprops last-line last-charpos)
643      (setf (line-charprops last-line) last-changes)
644      (append-line-charprops last-line right)))
645|#
646
647(defun find-charprops (mark charprops &key count end view filter from-end)
648  (declare (ignore from-end filter view end count charprops mark)))
649
650(defun find-charprops-change (mark &key count end view filter from-end)
651  (declare (ignore from-end filter view end count))
652  (let* ((line (mark-line mark))
653         (charpos (mark-charpos mark))
654         (changes (line-charprops-changes line))
655         (idx (charprops-change-index-for-position changes charpos)))
656    (loop
657      (incf idx)
658      (if (= idx (length changes))
659        (setf line (line-next line)
660              charpos 0
661              changes (line-charprops-changes line)
662              idx (charprops-change-index-for-position changes charpos))
663        (return (move-mark mark (charprops-change-index (aref changes idx))))))))
664
665(defun print-line-charprops (line &key (start 0) (end (hi:line-length line)))
666  (let* ((string (hi:line-string line))
667         (charprops-changes (hi::line-charprops-changes line)))
668    (let ((index start)
669          (plist nil)
670          (x 0))
671      (loop for change across charprops-changes
672        do (let* ((next-index (charprops-change-index change))
673                  (next-plist (charprops-change-plist change))
674                  (end (min end next-index)))
675             (when (and (>= index start)
676                        (< index end))
677               (format t "~& ~d: [~d, ~d) ~s: ~s" x index end
678                       (subseq string index end) plist))
679             (setq index next-index)
680             (setq plist next-plist)
681             (incf x)))
682      ;; final part of line
683      (format t "~& ~d: [~d, ~d) ~s: ~s" x index end
684              (subseq string index end) plist))))
685
686(defun copy-charprops (charprops)
687  (copy-list charprops))
688
689
690;;; Utility functions
691
692(defun charprop-equal (value1 value2)
693  (cond ((and (stringp value1) (stringp value2))
694         (string= value1 value2))
695        ((and (numberp value1) (numberp value2))
696         (= value1 value2))
697        (t
698         (eql value1 value2))))
699
700(defun charprops-get (charprops name &key (filter t))
701  (when (and name (filter-match filter name))
702    (etypecase charprops
703      ((satisfies ccl::plistp) (getf charprops name))
704      (hash-table (gethash name charprops)))))
705
706(defun charprops-set (charprops name value)
707  (etypecase charprops
708    ((satisfies ccl::plistp) (setf (getf charprops name) value))
709    (hash-table (setf (gethash name charprops) value)))
710  charprops)
711
712(defun same-sets (s1 s2 &key (test #'eql))
713  (and (subsetp s1 s2 :test test)
714       (subsetp s2 s1 :test test)))
715
716;; I wonder if this will be a hot spot...
717(defun charprops-equal (charprops1 charprops2 &key (filter t))
718  (setq charprops1 (charprops-as-plist charprops1 :filter filter)
719        charprops2 (charprops-as-plist charprops2 :filter filter))
720  (let (keys1 values1 keys2 values2)
721    (loop for (k1 v1) on charprops1 by #'cddr
722      do (push k1 keys1)
723         (push v1 values1))
724    (loop for (k2 v2) on charprops2 by #'cddr
725      do (push k2 keys2)
726         (push v2 values2))
727    (and (same-sets keys1 keys2)
728         (same-sets values1 values2 :test #'charprop-equal))))
729
730(defun charprops-as-plist (charprops &key (filter t))
731  (etypecase charprops
732    ((satisfies ccl::plistp) (if (eq filter t)
733                               charprops
734                               (loop for (k v) on charprops by #'cddr
735                                 when (filter-match filter k)
736                                 collect k and collect v)))
737    (hash-table (loop for k being the hash-keys of charprops using (hash-value v)
738                  when (filter-match filter k)
739                  collect k and collect v))))
740
741(defun charprops-as-hash (charprops &key (filter t))
742  (etypecase charprops
743    ((satisfies ccl::plistp) (let ((hash (make-hash-table)))
744                               (loop for (k v) on charprops by #'cddr
745                                 when (filter-match filter k)
746                                 do (setf (gethash k hash) v))
747                               hash))
748    (hash-table (if (eq filter t)
749                  charprops
750                  (let ((hash (make-hash-table)))
751                    (maphash #'(lambda (k v)
752                                 (when (filter-match filter k)
753                                   (setf (gethash k hash) v)))
754                             charprops))))))
755
756(defun charprops-names (charprops &key (filter t))
757  (etypecase charprops
758    ((satisfies ccl::plistp) (loop for name in charprops by #'cddr
759                               when (filter-match filter name)
760                               collect name))
761    (hash-table (loop for name being the hash-keys of charprops
762                  when (filter-match filter name)
763                  collect name))))
764
765;;; From <AppKit/NSAttributedString.h>
766(defparameter *cocoa-attributes*
767  `((:ns-font . ,#&NSFontAttributeName)
768    (:ns-paragraph-style . ,#&NSParagraphStyleAttributeName)
769    (:ns-foreground-color . ,#&NSForegroundColorAttributeName)
770    (:ns-underline-style . ,#&NSUnderlineStyleAttributeName)
771    (:ns-superscript . ,#&NSSuperscriptAttributeName)
772    (:ns-background-color . ,#&NSBackgroundColorAttributeName)
773    (:ns-attachment . ,#&NSAttachmentAttributeName)
774    (:ns-ligature . ,#&NSLigatureAttributeName)
775    (:ns-baseline-offset . ,#&NSBaselineOffsetAttributeName)
776    (:ns-kern . ,#&NSKernAttributeName)
777    (:ns-link . ,#&NSLinkAttributeName)
778    (:ns-stroke-width . ,#&NSStrokeWidthAttributeName)
779    (:ns-stroke-color . ,#&NSStrokeColorAttributeName)
780    (:ns-underline-color . ,#&NSUnderlineColorAttributeName)
781    (:ns-strikethrough-style . ,#&NSStrikethroughStyleAttributeName)
782    (:ns-strikethrough-color . ,#&NSStrikethroughColorAttributeName)
783    (:ns-shadow . ,#&NSShadowAttributeName)
784    (:ns-obliqueness . ,#&NSObliquenessAttributeName)
785    (:ns-expansion . ,#&NSExpansionAttributeName)
786    (:ns-cursor . ,#&NSCursorAttributeName)
787    (:ns-tool-tip . ,#&NSToolTipAttributeName)
788    #-cocotron
789    (:ns-character-shape . ,#&NSCharacterShapeAttributeName)
790    #-cocotron
791    (:ns-glyph-info . ,#&NSGlyphInfoAttributeName)
792    ;;(:ns-marked-clause-segment . #&NSMarkedClauseSegmentAttributeName)
793    ;;(:ns-spelling-state . #&NSSpellingStateAttributeName)
794    ))
795
Note: See TracBrowser for help on using the repository browser.