I have a line of text and wanted to have attributes that described the
text, such as blink, highlight, red, phone-number, etc. The problem is
representing blink when the text is already red, and other such
combinations. I tried using trees, vectors, magic, nothing, etc. but
the result is always a royal pain to use and not as extensible as I'd
like it to be. Ideally I would use an array and have the attributes
encoded as small numbers. This solution sucks because it only works
for predefined attributes and therefore wouldn't allow for
phone-numbers and other oddities.
I've looked around for ideas and have only seen the `your only allowed
these 5 attributes' solutions. I have even seen some really insane
cases where the program would _modify_ the actuall text with the
attributes almost as if the user had typed them in! The attributes are
then removed on save!!!
So what I started to do is use a double linked list that describes
when and where attributes start and end; some attributes could
eventually form a tree to override other attributes I guess - but I
don't really know yet. All I know is it should be be transparent to
normal operations (this seems to be the trick). Anyway, tried doing
this with CLOS but ran into a small problem which I'm almost certain
has a solution but I can't seem to find it. Here's a fragment of the
code. Any comments or suggestions would be appreciated in the utmost.
Ultimately I need a method/function called `find-line-region' which
returns three values: the start of the block of text, the end of the
block of text, and the attribute of the block.
This could be very flexible. I was thinking that overlay-arrows
and such could be done like:
(defmethod find-line-region ((interval overlay-arrow-interval) vt)
(let* ((index (vt-column vt))
(end-of-text-index (vt-total-columns vt))
(virtual-line (svref (vt-virtual-lines vt) (vt-row vt)))
(display-text (vline-text virtual-line))
(widths (vline-widths virtual-line)))
(replace display-text "=> " :start index)
(fill widths 1 :start index :end (+ index 4))
(values (+ index 4) ... ...))).
If the text to be displayed was: `1 2 3' it would result in
`=> 3' where the `=> ' the cursor could not be placed on top of.
I would like to have some non-modifiable regions of text as well. This
would be easy to add.
Here's the code fragment...
(defclass interval () ())
(defclass standard-interval (interval)
((interval-end
:initarg :interval-end
:initform (error ":INTERVAL-END required")
:accessor interval-end)
(interval-previous
:initarg :interval-previous
:initform nil
:accessor interval-previous)
(interval-next
:initarg :interval-next
:initform nil
:accessor interval-next)))
(defclass text-interval (standard-interval) ())
(defclass display-interval (standard-interval) ())
(defclass display-attribute () ())
(defmacro define-display-attribute (name)
(let ((attr-name (intern (concatenate 'string
(symbol-name name) "-MIXIN")
#.*package*))
(keyword (intern name (find-package :keyword))))
`(progn
(defclass ,attr-name (display-attribute) ())
(defmethod interval-attribute ((attribute ,attr-name))
(with-output-to-string (stream nil :element-type 'base-char)
(letf (((cm-output *cm*) stream))
(set-attributes '(,keyword))
stream))))))
(defun push-attribute-mixin (mixin attribute)
(let* ((name (concatenate 'string
(symbol-name (type-of attribute))
"+" (symbol-name mixin)))
(symbol (intern name #.*package*))
(class (or (find-class symbol nil)
(clos:ensure-class symbol
:direct-superclasses (list mixin
(class-of attribute))))))
(change-class attribute class)))
;;; Junk that simply has to go.
(defmethod print-object ((interval standard-interval) stream)
(print-unreadable-object (interval stream :type nil :identity t)
(princ (string-capitalize (symbol-name (type-of interval))) stream)
(write-char #\Space stream)
(cond ((interval-previous interval)
(write-char #\< stream)
(princ (interval-end (interval-previous interval)) stream))
(t (write-string "[0" stream)))
(write-char #\- stream)
(princ (interval-end interval) stream)
(if (interval-next interval)
(write-char #\> stream)
(write-char #\] stream))))
(defun make-interval (end)
(make-instance 'standard-interval
:interval-end end))
;;; This is not very good - but for playing with the idea it seems to
;;; work close enough... There are a couple of bugs (I think in the
;;; deletion) - but before I fix them I wanted to be sure this was a
;;; good idea. Again, just a ten-minute solution to try out my idea.
(defun find-interval (interval point)
(loop while (> point (interval-end interval))
do (setq interval (interval-next interval))
while interval finally (return interval)))
(defun find-interval-start (interval point)
(loop while (>= point (interval-end interval))
do (setq interval (interval-next interval))
while interval finally (return interval)))
(defun split-interval (interval point)
(setq interval (find-interval interval point))
(if (and (= (interval-end interval) point)
(interval-next interval))
(interval-next interval)
(let ((new (make-interval (interval-end interval))))
(setf (interval-end interval) point)
(when (setf (interval-next new) (interval-next interval))
(setf (interval-previous (interval-next new)) new))
(setf (interval-next interval) new)
(setf (interval-previous new) interval)
new)))
(defmethod adjust-intervals-for-insertion (interval point size)
(setq interval (find-interval interval point))
(loop do (incf (interval-end interval) size)
(setq interval (interval-next interval))
while interval))
(defmethod adjust-intervals-for-deletion (interval point size)
(setq interval (find-interval interval point))
(let ((end-point (+ point size)))
(cond ((< end-point (interval-end interval))
(loop do (decf (interval-end interval) size)
(setq interval (interval-next interval))
while interval))
(t
(let ((old interval))
(loop do (setq interval (interval-next interval))
while (<= (interval-end interval) end-point))
(when (setf (interval-next old) interval)
(setf (interval-previous interval) old))
(loop do (decf (interval-end interval) size)
(setq interval (interval-next interval))
while interval))))))
;; Ugh...
(defmethod split-interval-for-newline (interval1 interval2 point size)
(setq interval1 (find-interval interval1 point))
(setq interval2 (find-interval interval2 0))
(let ((next (split-interval interval1 point)))
(let ((temp interval2))
(loop do (incf (interval-end temp) size)
(setq temp (interval-next temp))
while temp))
(setf (interval-previous interval2) next)
(setf (interval-next next) interval2)
(setf (interval-end next) size)
(setf (interval-previous next) nil)
interval2))
;; This is where I would like to put all the complexity of merging and
;; other such fun things.
(defmethod merge-intervals ((interval1 text-interval)
(interval2 text-interval))
(setf (interval-end interval1) (interval-end interval2))
(when (setf (interval-next interval1) (interval-next interval2))
(setf (interval-previous (interval-next interval1)) interval1))
(setf (interval-previous interval2) nil)
(setf (interval-next interval2) nil)
interval1)
;; This is so seductive :)
(defmethod merge-intervals (a b) nil)
;; This is part of an older idea...
(defun add-line-attribute (line class start end)
(split-interval (line-interval line) end)
(change-class (split-interval (line-interval line) start) class))
;;; Whatever
;; Oh, yeah - vt is short for virtual-terminal. Should be
;; virtual-screen, but after a few thousand times vt starts to feel
;; very nice on my fingers.
(defgeneric find-line-region (interval vt))
(defgeneric interval-attribute (interval))
(defmethod find-line-region ((line line) vt)
(find-line-region
(find-interval-start (line-interval line) (vt-column vt)) vt))
(defmethod find-line-region ((interval null) vt)
(declare (ignore vt))
(values nil nil nil))
(defmethod interval-attribute (interval)
(declare (ignore interval))
nil)
(defmethod find-line-region (interval vt)
(declare (ignore vt))
(let ((block-start (if (null (interval-previous interval))
0
(interval-end (interval-previous interval))))
(block-end (interval-end interval))
(attribute (interval-attribute interval)))
(values block-start block-end attribute)))
What I currently have is this.
(define-display-attribute blink)
=> #<STANDARD-METHOD INTERVAL-ATTRIBUTE (BLINK-MIXIN)>
(define-display-attribute underline)
=> #<STANDARD-METHOD INTERVAL-ATTRIBUTE (UNDERLINE-MIXIN)>
(make-interval 20)
=> #<Standard-Interval [0-20] @ #x20427e42>
(interval-attribute (make-interval 20)) => nil
;; The following is excellent.
(let ((interval (make-interval 20)))
(interval-attribute
(push-attribute-mixin 'blink-mixin interval)))
=> "^[[5m" ; turn on blinking
(let ((interval (make-interval 20)))
(interval-attribute
(push-attribute-mixin 'blink-mixin interval)))
=> "^[[0;10m" ; now it knows to turn off blinking
;; This is really great.
(let ((interval (make-interval 20)))
(push-attribute-mixin 'blink-mixin interval)
(push-attribute-mixin 'underline-mixin interval)
interval)
=> #<Standard-Interval+Blink-Mixin+Underline-Mixin [0-20] @ #x2052ac52>
;; This is not so good.
(let ((interval (make-interval 20)))
(push-attribute-mixin 'blink-mixin interval)
(push-attribute-mixin 'underline-mixin interval)
(interval-attribute interval))
=> "^[[4m" ; turn on underline, sigh...
The question is (finally) how do I concatenate the results of all
these mixins? Do I have the right idea using CLOS or am I doing this
wrong? And does anyone think this method maybe a good idea for the
problem (which I probably didn't describe very well) or should I try
something else, and if so, what would that be?
I could post some more code if necessary.
And, the Standard-interval instances should have been
display-intervals but I forgot until now. The problem is the same
though.
I tried using `define-method-combination' but failed miserably. I
could write a couple (thousand) macros or functions to do this, but
that seems less fun than the tree idea.
I could also just skip the line attributes - but this would be less
than satisfying... ugh.
Thanks for any replies...
Steve Gonedes <········@worldnet.att.net> writes:
< (defun push-attribute-mixin (mixin attribute)
< (let* ((name (concatenate 'string
< (symbol-name (type-of attribute))
< "+" (symbol-name mixin)))
< (symbol (intern name #.*package*))
< (class (or (find-class symbol nil)
< (clos:ensure-class symbol
< :direct-superclasses (list mixin
< (class-of attribute))))))
< (change-class attribute class)))
I forgot to mention this was Erik Naggum's idea from a post some time
ago. Wasn't trying to discredit him, just didn't think about it until
reminded...