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

Last change on this file since 12859 was 12859, checked in by gz, 10 years ago

Make sure that all hemlock functions defined outside of hemlock are in the hemlock-ext package, to make it easier to keep track of them

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        (hemlock-ext: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.