319 lines
11 KiB
Common Lisp
319 lines
11 KiB
Common Lisp
(uiop:define-package :sextant/models/cursor
|
||
(:use :cl :sextant/org/nodes)
|
||
(:export #:init-cursor
|
||
#:root
|
||
#:current-visual-node
|
||
#:current-visual-headline
|
||
#:current-visual-index
|
||
#:current-visual-only-index
|
||
#:set-visual-cursor
|
||
#:move-visual-cursor
|
||
#:current-node
|
||
#:current-headline
|
||
#:current-index
|
||
#:reset-cursor
|
||
#:move-cursor
|
||
#:replace-cursor
|
||
#:save-current-cursor
|
||
#:restore-last-cursor
|
||
#:save-excursion
|
||
#:adjust-saved-cursors-before-remove
|
||
#:adjust-saved-cursors-before-insert
|
||
#:visual-node-depth
|
||
#:node-depth
|
||
#:previous-visual-node
|
||
#:previous-visual-headline
|
||
#:previous-node
|
||
#:previous-headline
|
||
#:next-visual-node
|
||
#:next-visual-headline
|
||
#:next-node
|
||
#:next-headline
|
||
#:goto-end-visual-section
|
||
#:goto-end-section
|
||
#:goto-visual-index
|
||
#:goto-index))
|
||
(in-package :sextant/models/cursor)
|
||
|
||
(defvar *cursor* (make-cursor))
|
||
(defvar *root* nil)
|
||
|
||
(defun init-cursor (document)
|
||
(setq *root* document)
|
||
(let ((node (next-of document)))
|
||
(when node
|
||
(set-visual-cursor node (and (subtypep (type-of node) 'org-headline) node) 0))))
|
||
|
||
(defun root () *root*)
|
||
|
||
(defun current-visual-node () (%cursor-node (cursor-visual-cursor *cursor*)))
|
||
(defun (setf current-visual-node) (node)
|
||
(setf (%cursor-node (cursor-visual-cursor *cursor*)) node
|
||
(%cursor-node (cursor-cursor *cursor*)) node))
|
||
|
||
(defun current-visual-headline () (%cursor-headline (cursor-visual-cursor *cursor*)))
|
||
(defun (setf current-visual-headline) (headline)
|
||
(setf (%cursor-headline (cursor-visual-cursor *cursor*)) headline
|
||
(%cursor-headline (cursor-cursor *cursor*)) headline))
|
||
|
||
(defun current-visual-index () (%cursor-index (cursor-visual-cursor *cursor*)))
|
||
(defun (setf current-visual-index) (index)
|
||
(setf (%cursor-index (cursor-visual-cursor *cursor*)) index
|
||
(%cursor-index (cursor-cursor *cursor*)) index))
|
||
|
||
(defun current-visual-only-index () (cursor-visual-only-index *cursor*))
|
||
(defun (setf current-visual-only-index) (index) (setf (cursor-visual-only-index *cursor*) index))
|
||
|
||
(defun set-visual-cursor (node headline index &optional (visual-only-index index))
|
||
(setf (current-visual-node) node
|
||
(current-visual-headline) headline
|
||
(current-visual-index) index
|
||
(current-visual-only-index) visual-only-index))
|
||
|
||
(defun move-visual-cursor (node headline step &optional (visual-step step))
|
||
(setf (current-visual-node) node
|
||
(current-visual-headline) headline)
|
||
(incf (current-visual-index) step)
|
||
(incf (current-visual-only-index) visual-step)
|
||
node)
|
||
|
||
(defun current-node () (%cursor-node (cursor-cursor *cursor*)))
|
||
(defun (setf current-node) (node) (setf (%cursor-node (cursor-cursor *cursor*)) node))
|
||
|
||
(defun current-headline () (%cursor-headline (cursor-cursor *cursor*)))
|
||
(defun (setf current-headline) (headline) (setf (%cursor-headline (cursor-cursor *cursor*)) headline))
|
||
|
||
(defun current-index () (%cursor-index (cursor-cursor *cursor*)))
|
||
(defun (setf current-index) (index) (setf (%cursor-index (cursor-cursor *cursor*)) index))
|
||
|
||
(defun reset-cursor () (move-visual-cursor (current-visual-node) (current-visual-headline) 0))
|
||
|
||
(defun move-cursor (node headline step)
|
||
(setf (current-node) node
|
||
(current-headline) headline)
|
||
(incf (current-index) step)
|
||
node)
|
||
|
||
(defun replace-cursor (node index)
|
||
(when (= (current-index) index)
|
||
(if (= (current-index) (current-visual-index))
|
||
(setf (current-visual-node) node
|
||
(current-visual-headline) (if (subtypep (type-of node) 'org-headline)
|
||
node
|
||
(current-visual-headline)))
|
||
(setf (current-node) node
|
||
(current-headline) (if (subtypep (type-of node) 'org-headline)
|
||
node
|
||
(current-headline))))))
|
||
|
||
|
||
|
||
(defvar *saved-cursor-indices* nil)
|
||
|
||
(defun save-current-cursor ()
|
||
(push (%cursor-index (cursor-cursor *cursor*)) *saved-cursor-indices*))
|
||
|
||
(defun restore-last-cursor ()
|
||
(goto-index (pop *saved-cursor-indices*)))
|
||
|
||
(defmacro save-excursion (&body body)
|
||
`(prog2
|
||
(save-current-cursor)
|
||
(progn ,@body)
|
||
(restore-last-cursor)))
|
||
|
||
(defun adjust-saved-cursors-before-remove (start count)
|
||
(loop for index in *saved-cursor-indices*
|
||
when (>= index start)
|
||
do (if (> index (+ start count))
|
||
(decf index count)
|
||
(setf index (1+ start)))))
|
||
|
||
(defun adjust-saved-cursors-before-insert (start count)
|
||
(loop for index in *saved-cursor-indices*
|
||
when (>= index start)
|
||
do (incf index count)))
|
||
|
||
|
||
|
||
(defgeneric %node-depth (node headline))
|
||
|
||
(defmethod %node-depth ((node org-line) headline)
|
||
(if headline (1+ (depth-of headline)) 0))
|
||
|
||
(defmethod %node-depth ((node org-headline) headline)
|
||
(assert (eq node headline))
|
||
(depth-of node))
|
||
|
||
(defun visual-node-depth () (%node-depth (current-visual-node) (current-visual-headline)))
|
||
|
||
(defun node-depth () (%node-depth (current-node) (current-headline)))
|
||
|
||
|
||
|
||
(defun %%previous-node (node headline)
|
||
(when (previous-of node)
|
||
(move-visual-cursor (previous-of node)
|
||
(if (eq node headline)
|
||
(previous-headline-of headline)
|
||
headline)
|
||
-1)))
|
||
|
||
(defgeneric %previous-visual-node (node headline))
|
||
|
||
(defmethod %previous-visual-node ((node org-line) headline)
|
||
(%%previous-node node headline))
|
||
|
||
(defmethod %previous-visual-node ((node org-headline) headline)
|
||
(assert (eq node headline))
|
||
(if (null (previous-headline-of node))
|
||
(%%previous-node node node)
|
||
(ecase (property-of (previous-headline-of node) :visibility)
|
||
(:expanded (%%previous-node node node))
|
||
(:collapsed
|
||
(loop with prev = (previous-visual-headline-of node)
|
||
for n = (previous-of node) then (previous-of n)
|
||
until (or (null n) (eq n prev))
|
||
count n into step
|
||
finally (progn
|
||
(assert (not (null n)))
|
||
(return (move-visual-cursor n prev (- step) -1))))))))
|
||
|
||
(defun previous-visual-node ()
|
||
(%previous-visual-node (current-visual-node) (current-visual-headline)))
|
||
|
||
(defun previous-visual-headline ()
|
||
(loop for n = (previous-visual-node) then (previous-visual-node)
|
||
until (or (null n) (eq n (current-visual-headline)))
|
||
finally (return n)))
|
||
|
||
(defun previous-node ()
|
||
(let* (peek-cursor
|
||
(prev-index (save-excursion (previous-visual-node)
|
||
(setf peek-cursor *cursor*)
|
||
(current-visual-index))))
|
||
(if (= prev-index (1- (current-index)))
|
||
(progn
|
||
(setf *cursor* peek-cursor)
|
||
(current-visual-node))
|
||
(let* ((node (current-node))
|
||
(headline (current-headline))
|
||
(prev (previous-of node)))
|
||
(when prev
|
||
(move-cursor prev
|
||
(if (eq node headline)
|
||
(previous-headline-of headline)
|
||
headline)
|
||
-1))))))
|
||
|
||
(defun previous-headline ()
|
||
(loop for n = (previous-node) then (previous-node)
|
||
until (or (null n) (eq n (current-headline)))
|
||
finally (return n)))
|
||
|
||
|
||
|
||
(defun %%next-node (node headline)
|
||
(let ((next (next-of node)))
|
||
(when next
|
||
(move-visual-cursor next
|
||
(if (subtypep (type-of next) 'org-headline)
|
||
next
|
||
headline)
|
||
1))))
|
||
|
||
(defgeneric %next-visual-node (node headline))
|
||
|
||
(defmethod %next-visual-node ((node org-line) headline)
|
||
(%%next-node node headline))
|
||
|
||
(defmethod %next-visual-node ((node org-headline) headline)
|
||
(assert (eq node headline))
|
||
(ecase (property-of node :visibility)
|
||
(:expanded (%%next-node node headline))
|
||
(:collapsed (let ((next (next-visual-headline-of node)))
|
||
(when next
|
||
(loop for n = (next-of node) then (next-of node)
|
||
until (or (null n) (eq n next))
|
||
count n into step
|
||
finally (progn
|
||
(assert (not (null n)))
|
||
(return (move-visual-cursor n next step 1)))))))))
|
||
|
||
(defun next-visual-node ()
|
||
(%next-visual-node (current-visual-node) (current-visual-headline)))
|
||
|
||
(defun next-visual-headline ()
|
||
(loop for n = (next-visual-node) then (next-visual-node)
|
||
until (or (null n) (eq n (current-visual-headline)))
|
||
finally (return n)))
|
||
|
||
(defun next-node ()
|
||
(let* (peek-cursor
|
||
(next-index (save-excursion
|
||
(next-visual-node)
|
||
(setf peek-cursor *cursor*)
|
||
(current-visual-index))))
|
||
(if (= next-index (1+ (current-index)))
|
||
(progn
|
||
(setf *cursor* peek-cursor)
|
||
(current-visual-node))
|
||
(let ((next (next-of (current-node))))
|
||
(when next
|
||
(move-cursor next
|
||
(if (subtypep (type-of next) 'org-headline)
|
||
next
|
||
(current-headline))
|
||
1)
|
||
next)))))
|
||
|
||
(defun next-headline ()
|
||
(loop for n = (next-node) then (next-node)
|
||
until (or (null n) (eq n (current-headline)))
|
||
finally (return n)))
|
||
|
||
|
||
|
||
(defun goto-end-visual-section ()
|
||
(if (next-visual-headline)
|
||
(previous-visual-node)
|
||
(values (current-visual-node) (current-visual-index))))
|
||
|
||
(defun goto-end-section ()
|
||
(if (next-headline)
|
||
(previous-node)
|
||
(values (current-node) (current-index))))
|
||
|
||
|
||
|
||
(defun goto-visual-index (index)
|
||
(reset-cursor)
|
||
(unless (= index (current-visual-only-index))
|
||
(flet ((walk (stepper)
|
||
(loop for n = (funcall stepper) then (funcall stepper)
|
||
until (or (null n) (= index (current-visual-only-index)))
|
||
finally (return n))))
|
||
(walk (if (< index (current-visual-only-index)) #'previous-visual-node #'next-visual-node))))
|
||
(values (current-visual-node) (current-visual-index)))
|
||
|
||
(defun goto-index (index)
|
||
(assert (>= index 0))
|
||
(unless (= index (current-index))
|
||
(reset-cursor)
|
||
(flet ((walk (stepper pred)
|
||
(loop for n = (funcall stepper) then (funcall stepper)
|
||
until (or (null n) (apply pred (current-visual-index) index))
|
||
finally (return n))))
|
||
(if (< index (current-visual-index))
|
||
(walk #'previous-node #'<=)
|
||
(when (walk #'next-node #'>)
|
||
(previous-node)))
|
||
(loop with headline = (current-visual-headline)
|
||
for internal-node = (current-visual-node) then (next-of internal-node)
|
||
and internal-index = (current-visual-index) then (1+ internal-index)
|
||
until (or (null internal-node) (= internal-index index))
|
||
when (eq internal-node (next-headline-of headline))
|
||
do (setf headline internal-node)
|
||
finally (move-cursor internal-node headline
|
||
(- internal-index (current-visual-index))))))
|
||
(current-node))
|