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

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

Several changes, none really worthy of individual note given the state
of this file.

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