Ignore:
Timestamp:
Aug 6, 2009, 3:12:33 AM (10 years ago)
Author:
rme
Message:

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

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/cocoa-ide/hemlock/src/charprops.lisp

    r12484 r12536  
    4747    (dotimes (i (length changes) (values (and change
    4848                                              (charprops-change-plist change))
    49                                          start-pos (line-length line)))
     49                                         start-pos (1+ (line-length line))))
    5050      (setq prior-change change)
    5151      (setq change (aref changes i))
     
    116116          (return))))))
    117117
     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
    118186;;; Returns two values: fresh charprops change vectors for the line's characters
    119187;;; before and after charpos.
     
    163231         (right changes))
    164232    (cond ((and left right)
    165            (loop for c across changes
    166              for new-change = (copy-charprops-change c)
    167              do (incf (charprops-change-index new-change) len)
    168                 (push-charprops-change new-change left)))
     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)))
    169237          ((and (null left) right)
    170            (setq left (copy-charprops-changes changes))
     238           (setq left (copy-charprops-changes right))
    171239           (adjust-charprops-change-indexes left len)
    172240           (setf (line-charprops-changes line) left))
     
    229297    (cond ((null changes)
    230298           (return-from copy-line-charprops))
    231           ((and (= start 0) (null end))
     299          ((and (= start 0) (or (= 0 end) (null end)))
    232300           (return-from copy-line-charprops (copy-charprops-changes changes))))
    233301    (unless end
     
    341409
    342410;;; Add delta to the starting index of all charprops changes after the one
    343 ;;; containing charpos.
    344 (defun adjust-charprops-changes (changes charpos delta)
    345   (let ((start-idx (charprops-change-index-for-position changes charpos)))
     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)))
    346415    (adjust-charprops-change-indexes changes delta :start (if start-idx
    347416                                                            (1+ start-idx)
    348417                                                            0))))
    349418
    350 #|
    351 ;;; Both target-changes and source-changes are vectors of charprops-change
    352 ;;; objects.  Insert charprops-changes from source-changes from start2 to end2
    353 ;;; into target-changes at start1.
    354 (defun insert-charprops-changes (target-changes source-changes &key startpos1
    355                                             startpos2 endpos2)
    356   (let* ((target-idx (charprops-change-index-for-position startpos1))
    357          (source-idx (charprops-change-index-for-position startpos2)))
    358     (adjust-charprops-changes target-changes startpos1 (- endpos2 startpos2))
    359     (do* ((i source-idx (1+ i))
    360           (change nil))
    361          ((= i
    362 
    363 
    364 
    365          (start2 (charprops-change-index-for-position startpos2))
    366          (end2 (charprops-change-index-for-position endpos1))
    367          (n (- end2 start2))) ; number of changes to add to target-changes
    368 |#
     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))
    369433
    370434(defvar *display-properties*
     
    372436    :font-size
    373437    :font-weight
     438    :font-width
    374439    :font-slant
    375440    :font-underline
     
    377442    :background-color))
    378443
    379 ;;; Accessing charprops
     444;;; Setting and accessing charprops
    380445
    381446(defun next-charprop-value (mark name &key view)
     
    388453
    389454(defun set-charprop-value (mark name value &key (count 1 count-supplied-p) end view)
    390   (declare (ignore view count value name mark))
     455  (declare (ignore view))
    391456  (when (and count-supplied-p end)
    392     (error "Cannot specify both :COUNT and :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))))))))
    393497
    394498(defun find-charprop-value (mark name value &key (count nil count-supplied-p)
    395                                  end view from-end)
    396   (declare (ignore from-end view count value name mark))
    397   (when (and count-supplied-p end)
    398     (error "Cannot specify both :COUNT and :END")))
     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))))))))
    399528
    400529(defun filter-match (filter name)
     
    432561      (next-charprops m :view view :filter filter))))
    433562
     563#|
    434564(defun set-charprops (mark charprops &key (count 1 count-supplied-p)
    435                            (end nil end-supplied-p) filter)
     565                           (end nil end-supplied-p) (filter charprops-names charprops))
    436566  (declare (ignore filter end count charprops mark))
    437567  (when (and count-supplied-p end-supplied-p)
    438568    (error "Only one of count or end can be supplied."))
    439  
    440 )
     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|#
    441582
    442583;;; Return a list of charprops-change vectors that correspond to the lines
    443 ;;; in the region defined by the paramaters.
     584;;; of text in the region defined by the paramaters.
    444585(defun charprops-in-region (region-or-mark &key (count 1 count-supplied-p)
    445586                                           end filter)
     
    454595              (character-offset m count)
    455596              (setq region (region region-or-mark m))))
    456       (region (setq region region-or-mark)))
     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)))
    457600    (let* ((start (region-start region))
    458601           (first-line (mark-line start))
     602           (first-charpos (mark-charpos start))
    459603           (end (region-end region))
    460            (last-line (mark-line end)))
    461       (do* ((line first-line (line-next line))
    462             (m (copy-mark start) (line-start m line)))
    463            ((eq line last-line)
    464             ;; last line
    465             (let* ((changes (line-charprops-changes line))
    466                    (idx (charprops-change-index-for-position changes (mark-charpos end))))
    467               (push (subseq (line-charprops-changes line) 0 idx) result)
    468               (nreverse result)))
    469         (let* ((changes (line-charprops-changes line))
    470                (idx (or (charprops-change-index-for-position changes (mark-charpos m)) 0)))
    471           (push (subseq changes idx) result))))))
     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)))))))
    472617
    473618(defun apply-charprops (mark charprops-range &key filter from-end)
    474619  (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|#
    475651
    476652(defun find-charprops (mark charprops &key count end view filter from-end)
     
    543719       (subsetp s2 s1 :test test)))
    544720
    545 ;; This may need tuning later.
     721;; I wonder if this will be a hot spot...
    546722(defun charprops-equal (charprops1 charprops2 &key (filter t))
    547723  (setq charprops1 (charprops-as-plist charprops1 :filter filter)
     
    594770;;; From <AppKit/NSAttributedString.h>
    595771(defparameter *cocoa-attributes*
    596   '((:ns-font . #&NSFontAttributeName)
    597     (:ns-paragraph-style . #&NSParagraphStyleAttributeName)
    598     (:ns-foreground-color . #&NSForegroundColorAttributeName)
    599     (:ns-underline-style . #&NSUnderlineStyleAttributeName)
    600     (:ns-superscript . #&NSSuperscriptAttributeName)
    601     (:ns-background-color . #&NSBackgroundColorAttributeName)
    602     (:ns-attachment . #&NSAttachmentAttributeName)
    603     (:ns-ligature . #&NSLigatureAttributeName)
    604     (:ns-baseline-offset . #&NSBaselineOffsetAttributeName)
    605     (:ns-kern . #&NSKernAttributeName)
    606     (:ns-link . #&NSLinkAttributeName)
    607     (:ns-stroke-width . #&NSStrokeWidthAttributeName)
    608     (:ns-stroke-color . #&NSStrokeColorAttributeName)
    609     (:ns-underline-color . #&NSUnderlineColorAttributeName)
    610     (:ns-strikethrough-style . #&NSStrikethroughStyleAttributeName)
    611     (:ns-strikethrough-color . #&NSStrikethroughColorAttributeName)
    612     (:ns-shadow . #&NSShadowAttributeName)
    613     (:ns-obliqueness . #&NSObliquenessAttributeName)
    614     (:ns-expansion . #&NSExpansionAttributeName)
    615     (:ns-cursor . #&NSCursorAttributeName)
    616     (:ns-tool-tip . #&NSToolTipAttributeName)
     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)
    617793    #-cocotron
    618     (:ns-character-shap . #&NSCharacterShapeAttributeName)
     794    (:ns-character-shape . ,#&NSCharacterShapeAttributeName)
    619795    #-cocotron
    620     (:ns-glyph-info . #&NSGlyphInfoAttributeName)
     796    (:ns-glyph-info . ,#&NSGlyphInfoAttributeName)
    621797    ;;(:ns-marked-clause-segment . #&NSMarkedClauseSegmentAttributeName)
    622798    ;;(:ns-spelling-state . #&NSSpellingStateAttributeName)
Note: See TracChangeset for help on using the changeset viewer.