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

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

set-charprops: remove ignore decl

File size: 34.7 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  (when (and count-supplied-p end-supplied-p)
566    (error "Only one of count or end can be supplied."))
567  (setq charprops (charprops-as-plist charprops :filter filter))
568  (with-mark ((start-mark mark)
569              (end-mark mark))
570    (if end
571      (move-mark end-mark end)
572      (character-offset end-mark count))
573    ;; lame.
574    (loop for (k v) on charprops by #'cddr
575       do (set-charprop-value start-mark k v :end end-mark))))
576
577;;; Return a list of charprops-change vectors that correspond to the lines
578;;; of text in the region defined by the paramaters.
579(defun charprops-in-region (region-or-mark &key (count 1 count-supplied-p)
580                                           end filter)
581  (declare (ignore filter))
582  (when (and count-supplied-p end)
583    (error "Only one of count or end can be supplied."))
584  (let (region result)
585    (etypecase region-or-mark
586      (mark (with-mark ((m region-or-mark))
587              (when end
588                (setq count (- end (mark-absolute-position m))))
589              (character-offset m count)
590              (setq region (region region-or-mark m))))
591      (region (when (or count-supplied-p end)
592                (error "Can't specify count or end when passing in a region."))
593              (setq region region-or-mark)))
594    (let* ((start (region-start region))
595           (first-line (mark-line start))
596           (first-charpos (mark-charpos start))
597           (end (region-end region))
598           (last-line (mark-line end))
599           (last-charpos (mark-charpos end)))
600      (cond
601       ((eq first-line last-line)
602        (list (copy-line-charprops first-line :start first-charpos)))
603       (t
604        (push (copy-line-charprops first-line :start first-charpos) result)
605        (do* ((line (line-next first-line) (line-next line))
606              (m (copy-mark start) (line-start m line)))
607             ((eq line last-line)
608              (push (copy-line-charprops last-line :end last-charpos) result)
609              (nreverse result))
610          (push (copy-line-charprops line) result)))))))
611
612(defun apply-charprops (mark charprops-range &key filter from-end)
613  (declare (ignore from-end filter charprops-range mark)))
614
615#|
616  (let* ((start-line (mark-line mark))
617         (start-charpos (mark-charpos))
618         (nlines (length charprops-range))
619         (first-changes (pop charprops-range)))
620
621    ;; do possibly-partial first line
622    (let ((left (split-line-charprops start-line start-charpos)))
623      (setf (line-charprops start-line) left)
624      (append-line-charprops start-line first-changes))
625    ;; do some number of whole lines
626    (do* ((line (line-next start-line) (line-next line))
627          (previous-line start-line (line-next previous-line))
628          (cc-list charprops-range (cdr charprops-range))
629          (changes (car cc-list) (car cc-list)))
630         ((or (null line) (endp cc-list)))
631      (setf (line-charprops-changes line) (copy-charprops-changes changes)))
632    ;; I don't know what to do about a partial last line.  There's no
633    ;; way that I can see to know whether the last charprops change vector
634    ;; in the charprops-range list is to apply to an entire line or to end
635    ;; at a particular charpos on that line.  Maybe that information needs
636    ;; to be stored as part of the charprops-range list.  For example, if the
637    ;; element of the charprops-range list is a non-null list, the list could
638    ;; be (charprops-change-vector start-charpos end-charpos).
639
640    (multiple-value-bind (left right)
641                         (split-line-charprops last-line last-charpos)
642      (setf (line-charprops last-line) last-changes)
643      (append-line-charprops last-line right)))
644|#
645
646(defun find-charprops (mark charprops &key count end view filter from-end)
647  (declare (ignore from-end filter view end count charprops mark)))
648
649(defun find-charprops-change (mark &key count end view filter from-end)
650  (declare (ignore from-end filter view end count))
651  (let* ((line (mark-line mark))
652         (charpos (mark-charpos mark))
653         (changes (line-charprops-changes line))
654         (idx (charprops-change-index-for-position changes charpos)))
655    (loop
656      (incf idx)
657      (if (= idx (length changes))
658        (setf line (line-next line)
659              charpos 0
660              changes (line-charprops-changes line)
661              idx (charprops-change-index-for-position changes charpos))
662        (return (move-mark mark (charprops-change-index (aref changes idx))))))))
663
664(defun print-line-charprops (line &key (start 0) (end (hi:line-length line)))
665  (let* ((string (hi:line-string line))
666         (charprops-changes (hi::line-charprops-changes line)))
667    (let ((index start)
668          (plist nil)
669          (x 0))
670      (loop for change across charprops-changes
671        do (let* ((next-index (charprops-change-index change))
672                  (next-plist (charprops-change-plist change))
673                  (end (min end next-index)))
674             (when (and (>= index start)
675                        (< index end))
676               (format t "~& ~d: [~d, ~d) ~s: ~s" x index end
677                       (subseq string index end) plist))
678             (setq index next-index)
679             (setq plist next-plist)
680             (incf x)))
681      ;; final part of line
682      (format t "~& ~d: [~d, ~d) ~s: ~s" x index end
683              (subseq string index end) plist))))
684
685(defun copy-charprops (charprops)
686  (copy-list charprops))
687
688
689;;; Utility functions
690
691(defun charprop-equal (value1 value2)
692  (cond ((and (stringp value1) (stringp value2))
693         (string= value1 value2))
694        ((and (numberp value1) (numberp value2))
695         (= value1 value2))
696        (t
697         (eql value1 value2))))
698
699(defun charprops-get (charprops name &key (filter t))
700  (when (and name (filter-match filter name))
701    (etypecase charprops
702      ((satisfies ccl::plistp) (getf charprops name))
703      (hash-table (gethash name charprops)))))
704
705(defun charprops-set (charprops name value)
706  (etypecase charprops
707    ((satisfies ccl::plistp) (setf (getf charprops name) value))
708    (hash-table (setf (gethash name charprops) value)))
709  charprops)
710
711(defun same-sets (s1 s2 &key (test #'eql))
712  (and (subsetp s1 s2 :test test)
713       (subsetp s2 s1 :test test)))
714
715;; I wonder if this will be a hot spot...
716(defun charprops-equal (charprops1 charprops2 &key (filter t))
717  (setq charprops1 (charprops-as-plist charprops1 :filter filter)
718        charprops2 (charprops-as-plist charprops2 :filter filter))
719  (let (keys1 values1 keys2 values2)
720    (loop for (k1 v1) on charprops1 by #'cddr
721      do (push k1 keys1)
722         (push v1 values1))
723    (loop for (k2 v2) on charprops2 by #'cddr
724      do (push k2 keys2)
725         (push v2 values2))
726    (and (same-sets keys1 keys2)
727         (same-sets values1 values2 :test #'charprop-equal))))
728
729(defun charprops-as-plist (charprops &key (filter t))
730  (etypecase charprops
731    ((satisfies ccl::plistp) (if (eq filter t)
732                               charprops
733                               (loop for (k v) on charprops by #'cddr
734                                 when (filter-match filter k)
735                                 collect k and collect v)))
736    (hash-table (loop for k being the hash-keys of charprops using (hash-value v)
737                  when (filter-match filter k)
738                  collect k and collect v))))
739
740(defun charprops-as-hash (charprops &key (filter t))
741  (etypecase charprops
742    ((satisfies ccl::plistp) (let ((hash (make-hash-table)))
743                               (loop for (k v) on charprops by #'cddr
744                                 when (filter-match filter k)
745                                 do (setf (gethash k hash) v))
746                               hash))
747    (hash-table (if (eq filter t)
748                  charprops
749                  (let ((hash (make-hash-table)))
750                    (maphash #'(lambda (k v)
751                                 (when (filter-match filter k)
752                                   (setf (gethash k hash) v)))
753                             charprops))))))
754
755(defun charprops-names (charprops &key (filter t))
756  (etypecase charprops
757    ((satisfies ccl::plistp) (loop for name in charprops by #'cddr
758                               when (filter-match filter name)
759                               collect name))
760    (hash-table (loop for name being the hash-keys of charprops
761                  when (filter-match filter name)
762                  collect name))))
763
764;;; From <AppKit/NSAttributedString.h>
765(defparameter *cocoa-attributes*
766  `((:ns-font . ,#&NSFontAttributeName)
767    (:ns-paragraph-style . ,#&NSParagraphStyleAttributeName)
768    (:ns-foreground-color . ,#&NSForegroundColorAttributeName)
769    (:ns-underline-style . ,#&NSUnderlineStyleAttributeName)
770    (:ns-superscript . ,#&NSSuperscriptAttributeName)
771    (:ns-background-color . ,#&NSBackgroundColorAttributeName)
772    (:ns-attachment . ,#&NSAttachmentAttributeName)
773    (:ns-ligature . ,#&NSLigatureAttributeName)
774    (:ns-baseline-offset . ,#&NSBaselineOffsetAttributeName)
775    (:ns-kern . ,#&NSKernAttributeName)
776    (:ns-link . ,#&NSLinkAttributeName)
777    (:ns-stroke-width . ,#&NSStrokeWidthAttributeName)
778    (:ns-stroke-color . ,#&NSStrokeColorAttributeName)
779    (:ns-underline-color . ,#&NSUnderlineColorAttributeName)
780    (:ns-strikethrough-style . ,#&NSStrikethroughStyleAttributeName)
781    (:ns-strikethrough-color . ,#&NSStrikethroughColorAttributeName)
782    (:ns-shadow . ,#&NSShadowAttributeName)
783    (:ns-obliqueness . ,#&NSObliquenessAttributeName)
784    (:ns-expansion . ,#&NSExpansionAttributeName)
785    (:ns-cursor . ,#&NSCursorAttributeName)
786    (:ns-tool-tip . ,#&NSToolTipAttributeName)
787    #-cocotron
788    (:ns-character-shape . ,#&NSCharacterShapeAttributeName)
789    #-cocotron
790    (:ns-glyph-info . ,#&NSGlyphInfoAttributeName)
791    ;;(:ns-marked-clause-segment . #&NSMarkedClauseSegmentAttributeName)
792    ;;(:ns-spelling-state . #&NSSpellingStateAttributeName)
793    ))
794
Note: See TracBrowser for help on using the repository browser.