1
0
Fork 0
tinmop/src/message-window.lisp

845 lines
36 KiB
Common Lisp

;; tinmop: an humble gemini and pleroma client
;; Copyright (C) 2020 cage
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(in-package :message-window)
(define-constant +row-invisible-field-key+ :invisible :test #'eq)
(define-constant +row-vertical-space-field-key+ :vertical-space :test #'eq)
(defclass message-window (wrapper-window
row-oriented-widget
focus-marked-window
title-window)
((line-position-mark
:initform (make-tui-string "0")
:initarg :line-position-mark
:accessor line-position-mark)
(metadata
:initform nil
:initarg :metadata
:accessor metadata)
(adjust-rows-strategy
:initform #'adjust-rows-noop
:initarg :adjust-rows-strategy
:accessor adjust-rows-strategy)
(text-starting-column
:initform 0
:initarg :text-starting-column
:accessor text-starting-column)))
(defgeneric prepare-for-rendering (object text-data &key jump-to-first-row))
(defgeneric scroll-down (object &optional amount))
(defgeneric scroll-up (object &optional amount))
(defgeneric scroll-left (object &optional amount))
(defgeneric scroll-right (object &optional amount))
(defgeneric scroll-end (object))
(defgeneric scroll-begin (object))
(defgeneric scroll-next-page (object))
(defgeneric scroll-previous-page (object))
(defgeneric search-regex (object regex))
(defgeneric jump-to-group-id (object gid-looking-for))
(defgeneric text->rendered-lines-rows (window text))
(defgeneric colorize-lines (object))
(defgeneric viewport-width (object))
(defgeneric generate-toc (object))
(defun gemini-window-p* (window)
(display-gemini-text-p window))
(defun gemini-window-p ()
(gemini-window-p* specials:*message-window*))
(defun display-gemini-text-p (window)
(eq (keybindings window)
keybindings:*gemini-message-keymap*))
(defun display-chat-p (window)
(eq (keybindings window)
keybindings:*chat-message-keymap*))
(defun prepare-for-display-status-mode (window)
(when (not (or (display-gemini-text-p window)
(display-chat-p window)))
(setf (keybindings window)
keybindings:*message-keymap*)))
(defun refresh-line-mark-config (window)
(multiple-value-bind (mark-value mark-fg mark-bg)
(swconf:message-window-line-mark-values)
(setf (line-position-mark window)
(make-tui-string mark-value
:fgcolor mark-fg
:bgcolor mark-bg))))
(defmethod refresh-config :after ((object message-window))
(refresh-config-colors object swconf:+key-message-window+)
(refresh-line-mark-config object)
(let* ((reference-window (if command-line:*gemini-full-screen-mode*
*main-window*
*thread-window*))
(reference-window-width (if (and command-line:*gemini-full-screen-mode*
*gemini-toc-window*)
(- (win-width *main-window*)
(win-width *gemini-toc-window*))
(win-width reference-window)))
(reference-window-height (win-height reference-window))
(command-window-height (win-height *command-window*))
(main-window-height (win-height *main-window*))
(height (if (eq reference-window *thread-window*)
(- main-window-height
command-window-height
reference-window-height)
(- main-window-height
command-window-height
(swconf:config-gemini-fullscreen-links-height))))
(width reference-window-width)
(x (if (and command-line:*gemini-full-screen-mode*
*gemini-toc-window*)
(win-width *gemini-toc-window*)
(win-x reference-window)))
(y (if (and command-line:*gemini-full-screen-mode*
*gemini-toc-window*)
(swconf:config-gemini-fullscreen-links-height)
(+ (win-y reference-window)
reference-window-height))))
(win-resize object width height)
(win-move object x y)))
(defmethod calculate ((object message-window) dt)
(declare (ignore object dt)))
(defun visible-rows (window)
(with-accessors ((row-selected-index row-selected-index)) window
(let* ((start (max 0 row-selected-index))
(end (+ start
(win-height-no-border window)))
(rows (rows-safe-subseq window
row-selected-index
:end end)))
(values rows
start
(length rows)))))
(defun draw-text (window)
(when hooks:*before-rendering-message-text*
(hooks:run-hook 'hooks:*before-rendering-message-text* window))
(with-accessors ((row-selected-index row-selected-index)
(text-starting-column text-starting-column)) window
(let ((visible-rows (visible-rows window))
(window-width (win-width-no-border window))
(content-available-on-the-left-mark (swconf:left-arrow)))
(when hooks:*before-rendering-message-visible-rows*
(hooks:run-hook 'hooks:*before-rendering-message-visible-rows* visible-rows window))
(loop for line in visible-rows
for y from 1
do
(cond
;; testing invisibility should never returns true as
;; the method `row' is specialized on message-window
;; and always removes from the rows the invisible
;; ones.
((row-invisible-p line)
(decf y))
((not (row-vertical-space-p line))
(let* ((text-line (remove-corrupting-utf8-chars (normal-text line)))
(text-length (text-length text-line))
(truncate-at (- window-width
text-length
text-starting-column))
(truncatep (< truncate-at 0))
(actual-text-line (cond
((= text-length 0)
"")
((>= text-starting-column text-length)
content-available-on-the-left-mark)
(truncatep
(tui-string-subseq text-line
text-starting-column
(min text-length
(+ window-width
text-starting-column))))
(t
(tui-string-subseq text-line
text-starting-column
nil)))))
(print-text window actual-text-line 1 y))))))))
(defun draw-buffer-line-mark (window)
(with-accessors ((rows rows)
(row-selected-index row-selected-index)
(line-position-mark line-position-mark)) window
(let* ((height (1- (win-height-no-border window)))
(rows-count (- (rows-length window) height))
(fraction (/ row-selected-index
(max 1 rows-count)))
(mark-y (1+ (truncate (* fraction height))))
(mark-x (1- (win-width window))))
(print-text window line-position-mark mark-x mark-y))))
(defmethod draw ((object message-window))
(when-window-shown (object)
(win-clear object :redraw nil)
(win-box object)
(draw-text object)
(when (not (line-oriented-window:rows-empty-p object))
(draw-buffer-line-mark object))
(call-next-method)))
(let ((index 0)
(frames -1)
(slowness 15))
(declare (fixnum index frames slowness))
(defun draw-downloading-animation (window)
(declare (optimize (debug 0) (speed 3)))
(let* ((animation-frames (swconf:gemini-downloading-animation))
(max (length (the list animation-frames))))
(print-text window (elt animation-frames index) 0 0 :attributes (attribute-bold))
(incf frames)
(when (= (rem frames slowness)
0)
(setf index (rem (1+ index) max))))))
(defgeneric row-add-original-object (lines original-object))
(defgeneric row-find-original-object (object thing
&key from-end start end key))
(defgeneric row-position-original-object (object thing &key start from-end end))
(defmethod row-add-original-object ((lines line) original-object)
(push original-object
(fields lines))
(push :original-object
(fields lines))
lines)
(defun extract-original-object (row)
(getf (fields row) :original-object))
(defmethod row-add-original-object ((lines list) original-object)
(mapcar (lambda (a) (row-add-original-object a original-object))
lines)
lines)
(defmethod row-find-original-object ((object message-window) (thing symbol)
&key from-end (start 0) end key)
(rows-find-if object (lambda (a) (typep (extract-original-object a) thing))
:from-end from-end
:start start
:end end
:key key))
(defmethod row-find-original-object ((object list) (thing symbol)
&key from-end (start 0) end key)
(find-if (lambda (a) (typep (extract-original-object a) thing))
object
:from-end from-end
:start start
:end end
:key key))
(defmethod row-position-original-object ((object message-window) (thing symbol)
&key (start 0) (from-end nil) (end nil))
(when (and (>= start 0)
(< start (rows-length object))
(or (null end)
(and (< end (rows-length object))
(>= end start))))
(rows-position-if object (lambda (a) (typep (extract-original-object a) thing))
:start start
:end end
:from-end from-end)))
(defmethod row-position-original-object ((object list) (thing symbol)
&key (start 0) (from-end nil) (end nil))
(position-if (lambda (a) (typep (extract-original-object a) thing))
object
:start start
:end end
:from-end from-end))
(defun row-get-original-object (line)
(getf (fields line) :original-object))
(defun row-add-group-id (line group-id)
(push group-id
(fields line))
(push :group-id
(fields line))
line)
(defun row-get-group-id (line)
(getf (fields line) :group-id))
(defun make-render-vspace-row (&optional (original-object
(make-instance 'gemini-parser:vertical-space)))
(let ((res (make-instance 'line
:normal-text (make-tui-string (format nil "~%"))
:fields (list +row-vertical-space-field-key+ 1))))
(row-add-original-object res original-object)
(row-add-group-id res (gemini-parser:group-id original-object))
res))
(defun row-vertical-space-p (row)
(getf (fields row) +row-vertical-space-field-key+))
(defun make-invisible-row (original-object &optional (text ""))
(let ((res (make-instance 'line
:fields (list +row-invisible-field-key+ t)
:normal-text (if (typep text 'c:complex-string)
text
(make-tui-string text)))))
(row-add-original-object res original-object)
res))
(defun row-link-p (row)
(typep (row-get-original-object row)
'gemini-parser:link-line))
(defun row-pre-start-p (row)
(typep (row-get-original-object row)
'gemini-parser:pre-start))
(defun row-preformatted-p (row)
(typep (row-get-original-object row)
'gemini-parser:pre-line))
(defun row-invisible-p (row)
(getf (fields row) +row-invisible-field-key+))
(defun row-visible-p (row)
(not (row-invisible-p row)))
(defun row-set-invisible (row)
(with-accessors ((fields fields)) row
(when (not (row-invisible-p row))
(push t fields)
(push +row-invisible-field-key+ fields))
row))
(defun row-set-visible (row)
(setf (fields row) (remove-from-plist (fields row) +row-invisible-field-key+))
row)
(defmacro with-map-update-raw-rows ((window function) &body body)
(with-gensyms (new-rows)
`(let ((,new-rows (rows-map-raw ,window
,function)))
,@body
(update-all-rows ,window ,new-rows)
(draw ,window))))
(defun row-hide-preformatted (message-window)
(with-map-update-raw-rows (message-window
(lambda (a)
(when (row-preformatted-p a)
(row-set-invisible a))
a))))
(defun row-show-pre-start (message-window)
(with-map-update-raw-rows (message-window
(lambda (a)
(when (row-pre-start-p a)
(row-set-visible a))
a))))
(defun row-show-preformatted (message-window)
(with-map-update-raw-rows (message-window
(lambda (a)
(when (row-preformatted-p a)
(row-set-visible a))
a))))
(defun row-hide-pre-start (message-window)
(with-map-update-raw-rows (message-window
(lambda (a)
(when (row-pre-start-p a)
(row-set-invisible a))
a))))
(let ((pre-visible-p t))
(defun set-default-preformatted-visibility (visibility)
(setf pre-visible-p visibility))
(defun get-default-preformatted-visibility ()
pre-visible-p)
(defun toggle-default-preformatted-visibility ()
(setf pre-visible-p (not pre-visible-p)))
(defun toggle-preformatted-block (message-window)
(if pre-visible-p
(progn
(row-hide-preformatted message-window)
(row-show-pre-start message-window))
(progn
(row-show-preformatted message-window)
(row-hide-pre-start message-window)))
(toggle-default-preformatted-visibility)
message-window))
(defmethod text->rendered-lines-rows (window (text gemini-parser:vertical-space))
(make-render-vspace-row text))
(defmethod text->rendered-lines-rows (window (text gemini-parser:pre-start))
(make-invisible-row text (gemini-parser:alt-text text)))
(defmethod text->rendered-lines-rows (window (text gemini-parser:pre-end))
(make-invisible-row text))
(defmethod text->rendered-lines-rows (window (text gemini-parser:pre-line))
(let ((res (make-instance 'line
:normal-text
(reduce #'tui:cat-complex-string
(text->rendered-lines-rows window (gemini-parser:lines text)))
:fields (list :alt-text (gemini-parser:alt-text text)
:group-id (gemini-parser:group-id text)))))
(row-add-original-object res text)
res)) ; even if row-add-original-object returns the modified line explicit returns for clarity
(defmethod text->rendered-lines-rows (window (text list))
(flatten (loop for i in text
collect
(text->rendered-lines-rows window i))))
(defmethod text->rendered-lines-rows (window (text c:complex-string))
text)
(defgeneric collect-lines-from-ir (object window &key &allow-other-keys))
(defmethod collect-lines-from-ir ((object gemini-parser:with-lines) (window message-window)
&key
(width (win-width-no-border window))
(empty-line-transform-fn (lambda () (make-render-vspace-row)))
&allow-other-keys)
(let ((colorized-lines (colorize-lines (%fit-lines window
(gemini-parser:lines object)
:width width
:empty-line-transform-fn
empty-line-transform-fn))))
(loop for text in colorized-lines
collect
(let ((res-line (text->line text))
(group-id (gemini-parser:group-id object)))
(row-add-original-object res-line object)
(row-add-group-id res-line group-id)
res-line))))
(defmethod text->rendered-lines-rows (window (text gemini-parser:quoted-lines))
(let* ((rows (collect-lines-from-ir text window
:width (1- (win-width-no-border window))
:empty-line-transform-fn (lambda () ""))))
(loop for row in rows do
(setf (normal-text row)
(colorize-lines (strcat (gemini-parser::prefix text)
(tui-string->chars-string (normal-text row))))))
rows))
(defmethod text->rendered-lines-rows (window (text gemini-parser:header-line))
(collect-lines-from-ir text window))
(defmethod text->rendered-lines-rows (window (text gemini-parser:unordered-list-line))
(collect-lines-from-ir text window))
(defmethod text->rendered-lines-rows (window (text gemini-parser:link-line))
(let ((res (make-instance 'line :normal-text (gemini-parser:link-text text))))
(row-add-original-object res text)
(row-add-group-id res (gemini-parser:group-id text))
res)) ; even if row-add-original-object returns the modified line explicit returns for clarity
(defun %fit-text (window text)
(let ((lines (split-lines text)))
(%fit-lines window lines)))
(defun %fit-lines (window lines
&key
(width (win-width-no-border window))
(empty-line-transform-fn (lambda () (make-render-vspace-row))))
(let ((res ()))
(loop for line in lines do
(cond
((string-empty-p (trim-blanks line))
(push (funcall empty-line-transform-fn) res))
(t
(loop for fitted-line in (flush-left-mono-text (split-words line) width) do
(push fitted-line res)))))
(reverse res)))
(defgeneric text->line (object))
(defmethod text->line ((object line))
object)
(defmethod text->line (object)
(make-instance 'line
:normal-text object))
(defmethod text->rendered-lines-rows (window (text string))
(let* ((fitted-lines (%fit-text window text))
(new-rows (colorize-lines fitted-lines)))
(mapcar #'text->line new-rows)))
(defmethod text->rendered-lines-rows (window (text gemini-parser:simple-line))
(let* ((fitted-lines (%fit-text window (gemini-parser:text-line text)))
(new-rows (colorize-lines fitted-lines)))
(mapcar (lambda (text-line)
(let ((res (text->line text-line)))
(row-add-original-object res text)
(row-add-group-id res (gemini-parser:group-id text))))
new-rows)))
(defun remove-invisible-rows (rows)
(remove-if #'row-invisible-p rows))
(defmethod text->rendered-lines-rows (window (text line))
text)
(defmethod rows ((object message-window))
(with-slots (rows) object
(remove-invisible-rows rows)))
(defmethod colorize-lines ((object line))
object)
(defmethod colorize-lines ((object c:complex-string))
(make-instance 'line :normal-text object))
(defmethod colorize-lines ((object string))
(let ((color-re (swconf:color-regexps))
(res object))
(loop for re in color-re do
(setf res (colorize-line res re)))
(colorized-line->tui-string res)))
(defmethod colorize-lines ((object list))
(loop for line in object
collect
(colorize-lines line)))
(defmethod viewport-width ((object message-window))
(windows:win-width-no-border object))
(defmethod prepare-for-rendering ((object message-window) text-data &key (jump-to-first-row t))
(update-all-rows object (text->rendered-lines-rows object text-data))
(when jump-to-first-row
(select-row object 0))
object)
(defun offset-to-move-end (win)
(with-accessors ((rows rows)
(row-selected-index row-selected-index)) win
(let ((win-height (win-height-no-border win)))
(- (- (rows-length win)
(- win-height 1))
row-selected-index))))
(defun scroll-end-reached-p (win)
(with-accessors ((rows rows)
(row-selected-index row-selected-index)) win
(let* ((win-height (win-height-no-border win))
(rows-left (- (rows-length win) row-selected-index)))
(< rows-left
win-height))))
(defmethod scroll-down ((object message-window) &optional (amount 1))
(when (not (or (scroll-end-reached-p object)
(= (row-move object amount)
0)))
(draw object)))
(defmethod scroll-up ((object message-window) &optional (amount 1))
(when (/= (row-move object (- amount))
0)
(draw object)))
(defmethod scroll-left ((object message-window) &optional (amount 1))
(with-accessors ((text-starting-column text-starting-column)) object
(when (> text-starting-column 0)
(decf text-starting-column amount)
(draw object))))
(defmethod scroll-right ((object message-window) &optional (amount 1))
(with-accessors ((text-starting-column text-starting-column)) object
(incf text-starting-column amount)
(draw object)))
(defmethod scroll-end ((object message-window))
(with-accessors ((rows rows)
(row-selected-index row-selected-index)) object
(let ((offset (offset-to-move-end object)))
(when (/= (row-move object offset)
0)
(draw object)))))
(defmethod scroll-begin ((object message-window))
(with-accessors ((rows rows)
(row-selected-index row-selected-index)) object
(when (/= (row-move object (- row-selected-index))
0)
(draw object))))
(defmethod scroll-next-page ((object message-window))
(with-accessors ((rows rows)
(row-selected-index row-selected-index)) object
(let ((actual-window-height (1- (win-height-no-border object)))
(rows-length (rows-length object)))
(when (and (> (- rows-length
row-selected-index)
actual-window-height)
(/= (row-move object (min actual-window-height
(- rows-length
(+ row-selected-index
actual-window-height))))
0))
(draw object)))))
(defmethod scroll-previous-page ((object message-window))
(when (/= (row-move object (- (win-height-no-border object)))
0)
(draw object)))
(defun first-line->string (window)
(with-accessors ((row-selected-index row-selected-index)) window
(let ((complex (normal-text (rows-elt window row-selected-index))))
(values (tui-string->chars-string complex)
complex))))
(defmethod search-regex ((object message-window) regex)
(with-accessors ((row-selected-index row-selected-index)) object
(when-let ((selected-row (selected-row object)))
(let* ((selected-text (normal-text selected-row))
(actual-row-starting (if (scan regex
(tui-string->chars-string selected-text))
(1+ row-selected-index)
row-selected-index))
(line-found (rows-position-if object
(lambda (a)
(scan regex
(tui-string->chars-string (normal-text a))))
:start (clamp actual-row-starting
0
(rows-length object))))
(replacements-strings ()))
(when line-found
(row-move object (- line-found row-selected-index))
(draw object)
(multiple-value-bind (first-window-line-simple first-window-line-complex)
(first-line->string object)
(labels ((calc-highlight (&optional (start-scan 0))
(multiple-value-bind (start end)
(scan regex first-window-line-simple :start start-scan)
(when start
(let* ((mask (make-tui-string (subseq first-window-line-simple
start end)
:fgcolor (win-bgcolor object)
:bgcolor (win-fgcolor object)))
(prefix (tui-string-subseq first-window-line-complex
0
start))
(new-prefix (cat-tui-string prefix mask)))
(push new-prefix replacements-strings)
(calc-highlight end)))))
(highlight ()
(loop for replacement in replacements-strings do
(print-text object replacement 1 1))))
(calc-highlight)
(highlight))))))))
(defmethod jump-to-group-id ((object message-window) gid-looking-for)
(when-let ((line-found (rows-position-if object
(lambda (a)
(when-let ((header (row-get-original-object a)))
(when (typep header 'gemini-parser:header-line)
(let ((gid (gemini-parser:group-id header)))
(= gid gid-looking-for)))))
:start 0)))
(select-row object 0)
(row-move object line-found)
(draw object)))
(defmethod generate-gemini-toc ((object message-window))
(let* ((toc-number (make-list gemini-parser:+max-header-level+ :initial-element 0))
(current-gid -1)
(all-headers (remove-if-not (lambda (a)
(typep (row-get-original-object a)
'gemini-parser:header-line))
(rows object)))
(toc (loop for row in all-headers
collect
(let* ((header (row-get-original-object row))
(level (gemini-parser:level header))
(gid (gemini-parser:group-id header)))
(when (/= gid current-gid)
(setf current-gid gid)
(incf (elt toc-number (1- level)))
(loop for i from level below (length toc-number) do
(setf (elt toc-number i) 0))
(loop for i from (- level 2 ) downto 0
when (= (elt toc-number i) 0) do
(setf (elt toc-number i) 1))
(list :header (first (gemini-parser:lines header))
:group-id gid
:number (subseq toc-number
0
level)))))))
(remove-if #'null toc)))
(defun gemini-toc-header (fields)
(getf fields :header))
(defun gemini-toc-max-number-length (toc)
(* 2
(num:find-max (mapcar (lambda (a) (length (getf a :number)))
toc))))
(defun gemini-toc-number (fields toc)
(let ((raw (mapcar #'to-s (getf fields :number)))
(max-number-length (gemini-toc-max-number-length toc)))
(right-padding (join-with-strings raw ".")
max-number-length
:padding-char (swconf:gemini-toc-padding-char))))
(defun gemini-toc-entry (fields toc)
(format nil "~a ~a" (gemini-toc-number fields toc) (gemini-toc-header fields)))
(defun gemini-toc-group-id (fields)
(getf fields :group-id))
(defun message-window-title ()
(if command-line:*gemini-full-screen-mode*
(_ "Gemini stream")
(_ "Messages")))
(defun init ()
(let* ((low-level-window (make-croatoan-window :enable-function-keys t)))
(setf *message-window*
(make-instance 'message-window
:title (message-window-title)
:keybindings keybindings:*message-keymap*
:key-config swconf:+key-message-window+
:croatoan-window low-level-window))
(refresh-config *message-window*)
(draw *message-window*)
*message-window*))
(defun original-source-metadata (row)
(let* ((original-line (row-get-original-object row))
(source-line (gemini-parser:source-line original-line))
(source-line-id (gemini-parser:source-line-id original-line))
(artificialp (gemini-parser:artificialp original-line)))
(values source-line-id source-line artificialp)))
(defun search-gemini-fragment (window fragment)
"Search `fragment' in the source lines of the gemini steams and -if
fragment matches- move the window to the line when matching occurred."
(labels ((prefix-diff (text-rows source-line)
(- (length (first (split-words (first text-rows))))
(length (first (split-words source-line)))))
(reconstruct-source-lines (text-rows blanks &optional (accum '()))
(if (null text-rows)
(mapcar (lambda (a) (reduce #'strcat a)) accum)
(let ((text-rows-words (remove-if #'string-empty-p
(split-words (first text-rows)))))
(multiple-value-bind (reconstructed rest-blanks)
(reconstruct-source-line text-rows-words blanks)
(reconstruct-source-lines (rest text-rows)
rest-blanks
(append accum (list reconstructed)))))))
(quoted-line-p (row)
(typep (row-get-original-object row) 'gemini-parser:quoted-lines))
(strip-prefix-from-quoted-lines (text-rows prefix)
(append (list (first text-rows))
(mapcar (lambda (a) (regex-replace prefix a ""))
(rest text-rows))))
(rows->text-rows (rows)
(let ((text-rows (mapcar (lambda (a)
(tui-string->chars-string (normal-text a)))
rows)))
(if (quoted-line-p (first rows))
(let ((prefix (gemini-parser::prefix (row-get-original-object (first rows)))))
(strip-prefix-from-quoted-lines text-rows prefix))
text-rows)))
(reconstruct-source-line (words blanks)
(let ((rest-blanks '())
(res '()))
(loop for word in words
for blank in blanks
for ct from 1
do
(push word res)
(push blank res)
finally (setf rest-blanks (subseq blanks ct)))
(values (reverse res) rest-blanks))))
(with-accessors ((row-selected-index row-selected-index)) window
(let ((rest-rows (rest (rows-safe-subseq window row-selected-index)))
(matching-source-line nil)
(matching-source-id nil)
(matching-source-position nil)
(starting-match-row-pos nil))
(loop named sid-loop
for i from 0 below (length rest-rows)
for count-line-to-start-matching from 0
for current-row in rest-rows do
(multiple-value-bind (source-line-id source-line)
(original-source-metadata current-row)
(let* ((matching-string-pos (scan fragment source-line)))
(when matching-string-pos
(setf starting-match-row-pos count-line-to-start-matching)
(setf matching-source-line source-line)
(setf matching-source-id source-line-id)
(setf matching-source-position matching-string-pos)
(return-from sid-loop t)))))
(when matching-source-id
(let* ((matching-rows (remove-if-not (lambda (a)
(multiple-value-bind (source-line-id x artificialp)
(original-source-metadata a)
(declare (ignore x))
(and (not artificialp)
(= source-line-id matching-source-id))))
rest-rows))
(text-rows (rows->text-rows matching-rows))
(matching-source-blanks (extract-blanks matching-source-line))
(reconstructed-rows (reconstruct-source-lines text-rows matching-source-blanks))
(line-matched (loop
for reconstructed-row in reconstructed-rows
for line from 1
for length-accum = (length reconstructed-row)
then (+ length-accum
(length reconstructed-row))
while (<= (- length-accum
(prefix-diff text-rows matching-source-line))
matching-source-position)
finally (return line))))
(row-move window (+ starting-match-row-pos line-matched))
(draw window)))))))