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

Last change on this file since 12804 was 12804, checked in by rme, 10 years ago

set-charprops

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    (when changes
191      (let ((left (make-array 2 :adjustable t :fill-pointer 0))
192            (right (make-array 2 :adjustable t :fill-pointer 0))
193            (pivot nil)
194            (prior-change nil))
195        (do* ((i 0 (1+ i))
196              (change nil))
197             ((or pivot
198                  (= i (length changes)))
199              (if (null pivot)
200                ;; The last change extends to the end of line, so that will be the
201                ;; charprops in effect at the beginning of the new line.
202                (if (null (charprops-change-plist change))
203                  (setq right nil)
204                  (let* ((c (copy-charprops-change change)))
205                    (setf (charprops-change-index c) 0)
206                    (push-charprops-change c right)))
207                ;; Some charprops changes remain.  First, split the prior change
208                ;; if necessary, and then pick up the rest of the shifts.
209                (progn
210                  (when (and prior-change
211                             (> charpos (charprops-change-index prior-change)))
212                    ;; need to split change
213                    (let* ((c (copy-charprops-change prior-change)))
214                      (setf (charprops-change-index c) 0)
215                      (push-charprops-change c right)))
216                  (loop for i from pivot below (length changes)
217                    as change = (aref changes i)
218                    do (decf (charprops-change-index change) charpos)
219                    (push-charprops-change (aref changes i) right))))
220              (values left right pivot))
221          (setq change (aref changes i))
222          (if (< (charprops-change-index change) charpos)
223            (progn
224              (push-charprops-change change left)
225              (setq prior-change change))
226            (setq pivot i)))))))
227
228(defun append-line-charprops (line changes)
229  (let* ((left (line-charprops-changes line))
230         (len (line-length line))
231         (right changes))
232    (cond ((and left right)
233           (loop for c across right
234                 for new-change = (copy-charprops-change c)
235                 do (incf (charprops-change-index new-change) len)
236                    (push-charprops-change new-change left)))
237          ((and (null left) right)
238           (setq left (copy-charprops-changes right))
239           (adjust-charprops-change-indexes left len)
240           (setf (line-charprops-changes line) left))
241          ((and left (null right))
242           (push-charprops-change (make-charprops-change len nil) left)))
243    left))
244
245;;; Append the charprops-changes from line2 onto line1, modifying their
246;;; indexes appropriately.
247(defun join-line-charprops (line1 line2)
248  (let* ((left (line-charprops-changes line1))
249         (lidx (1- (length left)))
250         (right (line-charprops-changes line2))
251         (ridx 0)
252         (line1-len (line-length line1)))
253    (cond ((and left right)
254           ;; If the last change on line1 and the first change on line2
255           ;; represent the same properties, then omit line2's first
256           ;; change.
257           (let* ((lchange (aref left lidx))
258                  (lprops (charprops-change-plist lchange))
259                  (rchange (aref right ridx))
260                  (rprops (charprops-change-plist rchange)))
261             (if (> 0 (charprops-change-index rchange))
262               ;; There is an implicit run of default charprops at the
263               ;; start of the line.
264               (unless (null lprops)
265                 ;; The last change on line1 represents some non-default
266                 ;; set of charprops, so insert an explicit change to the
267                 ;; default set before copying over the rest.
268                 (push-charprops-change (make-charprops-change (1+ line1-len) nil)
269                                        left))
270               (when (charprops-equal lprops rprops)
271                 (incf ridx)))
272             (do* ((i ridx (1+ i))
273                   (change nil))
274                  ((= i (length right)))
275               (setq change (aref right i))
276               (incf (charprops-change-index change) (1+ line1-len))
277               (push-charprops-change change left))))
278          ((and (null left) right)
279           (adjust-charprops-change-indexes right line1-len)
280           (setf (line-charprops-changes line1) right))
281          ((and left (null right))
282           (let* ((lchange (aref left lidx)))
283             (unless (null (charprops-change-plist lchange))
284               (push-charprops-change (make-charprops-change (1+ line1-len) nil)
285                                   left))))
286          ;; otherwise both nil, so don't need to do anything.
287          )
288    left))
289
290(defun copy-line-charprops (line &key (start 0) end)
291  "Return a freshly-consed vector of charprops changes that applies to the
292   characters in the interval [start, end) on the specified line.  If the
293   charprops in between start and end are the default charprops, return
294   NIL."
295  (let ((changes (line-charprops-changes line)))
296    ;; some early-out special cases
297    (cond ((null changes)
298           (return-from copy-line-charprops))
299          ((and (= start 0) (null end))
300           (return-from copy-line-charprops (copy-charprops-changes changes))))
301    (unless end
302      (setq end (line-length line)))
303    (let* ((new-changes (make-empty-charprops-changes))
304           (start-idx (charprops-change-index-for-position changes start))
305           (end-idx (charprops-change-index-for-position changes (1- end))))
306      (if (eql start-idx end-idx)
307        (if (null start-idx)
308          (setq new-changes nil)
309          (let* ((change (aref changes start-idx))
310                 (plist (charprops-change-plist change)))
311            (if (null plist)
312              (setq new-changes nil)
313              (push-charprops-change (make-charprops-change start plist)
314                                     new-changes))))
315        (do ((i (or start-idx 0) (1+ i)))
316            ((> i end-idx))
317          (let* ((change (aref changes i))
318                 (index (charprops-change-index change))
319                 (plist (charprops-change-plist change)))
320          (push-charprops-change (make-charprops-change
321                                  (max 0 (- index start)) plist)
322                                 new-changes))))
323      new-changes)))
324
325(defun delete-line-charprops (line &key (start 0) end)
326  (let ((changes (line-charprops-changes line)))
327    ;; some early-out special cases
328    (cond ((null changes)
329           (return-from delete-line-charprops))
330          ((and (= start 0) (null end))
331           (setf (line-charprops-changes line) nil)
332           (return-from delete-line-charprops)))
333    (unless end
334      (setq end (line-length line)))
335    (assert (<= start end) (start end))
336    (let* ((start-idx (charprops-change-index-for-position changes start))
337           (end-idx (charprops-change-index-for-position changes (1- end))))
338      (cond ((null start-idx)
339             (if (null end-idx)
340               (adjust-charprops-change-indexes changes (- start end) :start 0)
341               (progn
342                 ;; delete changes before end-idx
343                 (replace changes changes :start1 0 :start2 end-idx)
344                 (decf (fill-pointer changes) end-idx)
345                 (setf (charprops-change-index (aref changes 0)) start)
346                 ;; move back start of subsequent changes, if there are any
347                 (when (> (length changes) 1)
348                   (adjust-charprops-change-indexes changes (- start end)
349                                                    :start 1)
350                   ;; if the change is now zero-length, remove it
351                   (when (= (charprops-change-index (aref changes 0))
352                            (charprops-change-index (aref changes 1)))
353                     (delete-charprops-change changes 0))))))
354            ((eql start-idx end-idx)
355             ;; The deletion takes place within the scope of a single
356             ;; charprops run.
357             ;; Move back start of subsequent changes, if there are any
358             (when (> (length changes) (1+ start-idx))
359               (adjust-charprops-change-indexes changes (- start end)
360                                                :start (1+ start-idx))
361               ;; if the change is now zero-length, remove it
362               (when (= (charprops-change-index (aref changes start-idx))
363                        (charprops-change-index (aref changes (1+ start-idx))))
364                 (delete-charprops-change changes start-idx))))
365            (t
366             ;; Remove changes between start-idx and and end-idx.
367             (replace changes changes :start1 (1+ start-idx)
368                      :start2 end-idx)
369             (decf (fill-pointer changes) (- end-idx (1+ start-idx)))
370             (setf (charprops-change-index (aref changes (1+ start-idx))) start)
371             (when (> (length changes) (1+ start-idx))
372               (adjust-charprops-change-indexes changes (- start end)
373                                                :start (+ 2 start-idx))
374               ;; if first change is now zero-length, remove it
375               (when (= (charprops-change-index (aref changes start-idx))
376                        (charprops-change-index (aref changes (1+ start-idx))))
377                 (delete-charprops-change changes start-idx))))))
378    (coalesce-line-charprops line)))
379
380;;; Coalesce adjacent changes with CHARPROP-EQUAL plists.
381;;; Maybe make this remove zero-length changes, too?
382(defun coalesce-line-charprops (line)
383  (let ((changes (line-charprops-changes line)))
384    (do* ((i 0 (1+ i))
385          (change nil))
386         ((>= i (length changes)))
387      (setq change (aref changes i))
388      (loop with j = (1+ i)
389        while (and (< j (length changes))
390                   (charprops-equal (charprops-change-plist change)
391                                    (charprops-change-plist (aref changes j))))
392        do (delete-charprops-change changes j)))
393    ;; Elide any changes with NIL plists at the start of the line.
394    (loop
395      while (and (> (length changes) 0)
396                 (null (charprops-change-plist (aref changes 0))))
397      do (delete-charprops-change changes 0))
398    (when (zerop (length changes))
399      (setf (line-charprops-changes line) nil)))
400  (line-charprops-changes line))
401     
402(defun adjust-charprops-change-indexes (changes delta &key (start 0))
403  (do* ((i start (1+ i))
404        (change nil))
405       ((>= i (length changes))
406        changes)
407    (setq change (aref changes i))
408    (incf (charprops-change-index change) delta)))
409
410;;; Add delta to the starting index of all charprops changes after the one
411;;; containing start.
412(defun adjust-line-charprops (line delta &key (start 0))
413  (let* ((changes (line-charprops-changes line))
414         (start-idx (charprops-change-index-for-position changes start)))
415    (adjust-charprops-change-indexes changes delta :start (if start-idx
416                                                            (1+ start-idx)
417                                                            0))))
418
419(defun apply-line-charprops (line changes start-pos end-pos)
420  (cond ((null changes)
421         (set-line-charprops line nil :start start-pos :end end-pos))
422        (t
423         (setq changes (copy-charprops-changes changes))
424         (do* ((i 0 (1+ i))
425               (change nil))
426              ((= i (length changes)))
427           (setq change (aref changes i))
428           (set-line-charprops line (charprops-change-plist change)
429                               :start (+ (charprops-change-index change) start-pos)
430                               :end end-pos))
431         (coalesce-line-charprops line)))
432  (line-charprops-changes line))
433
434(defvar *display-properties*
435  '(:font-name
436    :font-size
437    :font-weight
438    :font-width
439    :font-slant
440    :font-underline
441    :font-color
442    :background-color))
443
444;;; Setting and accessing charprops
445
446(defun next-charprop-value (mark name &key view)
447  (let ((props (next-charprops mark :view view)))
448    (getf props name)))
449
450(defun previous-charprop-value (mark name &key view)
451  (let ((props (previous-charprops mark :view view)))
452    (getf props name)))
453
454(defun set-charprop-value (mark name value &key (count 1 count-supplied-p) end view)
455  (declare (ignore view))
456  (when (and count-supplied-p end)
457    (error "Cannot specify both :COUNT and :END"))
458  (with-mark ((start-mark mark)
459              (end-mark mark))
460    (if end
461      (move-mark end-mark end)
462      (character-offset end-mark count))
463    (let* ((start-line (mark-line start-mark))
464           (start-charpos (mark-charpos start-mark))
465           (end-line (mark-line end-mark))
466           (end-charpos (mark-charpos end-mark)))
467      (cond ((eq start-line end-line)
468             (add-line-charprop-value start-line name value
469                                      :start start-charpos
470                                      :end end-charpos))
471            (t
472             (do* ((line start-line (line-next line))
473                   (start start-charpos 0))
474                  ((eq line end-line)
475                   (add-line-charprop-value end-line name value
476                                            :start 0
477                                            :end end-charpos))
478               (add-line-charprop-value line name value :start start))))
479      (let ((n (count-characters (region start-mark end-mark)))
480            (buffer (line-%buffer start-line)))
481        (buffer-note-modification buffer mark n)))))
482
483(defun find-line-charprop-value (line name value &key (start 0) end)
484  (unless end
485    (setq end (line-length line)))
486  (let* ((changes (line-charprops-changes line))
487         (start-idx (or (charprops-change-index-for-position changes start) 0))
488         (end-idx (or (charprops-change-index-for-position changes end) 0)))
489    (when changes
490      (loop for i from start-idx to end-idx
491         as change = (aref changes i)
492         as plist = (charprops-change-plist change)
493         as found-value = (getf plist name)
494         do (when (and found-value
495                       (charprop-equal found-value value))
496              (return (max start (charprops-change-index change))))))))
497
498(defun find-charprop-value (mark name value &key (count nil count-supplied-p)
499                            end view from-end)
500  (declare (ignore from-end view))
501  (with-mark ((start-mark mark)
502              (end-mark mark))
503    (when (and count-supplied-p end)
504      (error "Cannot specify both :COUNT and :END"))
505    (let* ((buffer (line-buffer (mark-line mark))))
506      (unless (bufferp buffer)
507        (error "text must be in a buffer"))
508      (if count-supplied-p
509        (character-offset end-mark count)
510        (move-mark end-mark (buffer-end-mark buffer)))
511      (let* ((start-line (mark-line start-mark))
512             (start-charpos (mark-charpos start-mark))
513             (end-line (mark-line end-mark))
514             (end-charpos (mark-charpos end-mark)))
515        (do* ((line start-line (line-next line))
516              (charpos start-charpos 0))
517             ((eq line end-line)
518              (let ((pos (find-line-charprop-value end-line name value
519                                                   :start charpos
520                                                   :end end-charpos)))
521                (when pos
522                  (move-to-position mark pos end-line)
523                  mark)))
524          (let ((pos (find-line-charprop-value line name value :start charpos)))
525            (when pos
526              (move-to-position mark pos line)
527              (return mark))))))))
528
529(defun filter-match (filter name)
530  (cond ((functionp filter)
531         (funcall filter name))
532        ((eq filter :display)
533         (member name *display-properties* :test #'eq))
534        ((typep filter 'sequence)
535         (member name filter))
536        (t
537         name)))
538
539(defun filter-charprops (filter charprops)
540  (if (eq filter t)
541    charprops
542    (typecase charprops
543      ((satisfies ccl::plistp) (loop for (k v) on charprops by #'cddr
544                                 when (filter-match filter k)
545                                 collect k and collect v))
546      (hash-table (loop for k being the hash-keys of charprops using (hash-value v)
547                    when (filter-match filter k)
548                    collect k and collect v)))))
549
550(defun next-charprops (mark &key view (filter t))
551  "Return the properties of the character after MARK."
552  (declare (ignore view))
553  (when (next-character mark)
554    (let* ((props (line-charprops-for-position (mark-line mark) (mark-charpos mark))))
555      (filter-charprops filter props))))
556
557(defun previous-charprops (mark &key view (filter t))
558  "Return the properties of the character before MARK."
559  (with-mark ((m mark))
560    (when (mark-before m)
561      (next-charprops m :view view :filter filter))))
562
563(defun set-charprops (mark charprops &key (count 1 count-supplied-p)
564                           (end nil end-supplied-p) (filter (charprops-names charprops)))
565  (declare (ignore filter end count charprops mark))
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.