WIP
This commit is contained in:
Renaud Casenave-Péré
parent
ddc203a132
commit
52ef89147c
15 changed files with 765 additions and 395 deletions
|
|
@ -53,7 +53,7 @@
|
|||
(when funsym
|
||||
(let ((fun (intern funsym #.*package*)))
|
||||
(when (fboundp fun)
|
||||
(funcall fun *caller* (goto-index index) (cons x y)))))))
|
||||
(funcall fun *caller* (goto-visual-index index) (cons x y)))))))
|
||||
(export ',symbol)))
|
||||
,(let ((symbol (intern (concatenate 'string (symbol-name type) "-DOUBLE-CLICKED")))
|
||||
(funsym (intern (concatenate 'string "DOUBLE-CLICK-ON-" (symbol-name type))
|
||||
|
|
@ -64,7 +64,7 @@
|
|||
(when funsym
|
||||
(let ((fun (intern funsym #.*package*)))
|
||||
(when (fboundp fun)
|
||||
(funcall fun *caller* (goto-index index) (cons x y)))))))
|
||||
(funcall fun *caller* (goto-visual-index index) (cons x y)))))))
|
||||
(export ',symbol)))
|
||||
,(let ((symbol (intern (concatenate 'string (symbol-name type) "-PRESS-AND-HOLD")))
|
||||
(funsym (intern (concatenate 'string "PRESS-AND-HOLD-ON-" (symbol-name type))
|
||||
|
|
@ -75,7 +75,7 @@
|
|||
(when funsym
|
||||
(let ((fun (intern funsym #.*package*)))
|
||||
(when (fboundp fun)
|
||||
(funcall fun *caller* (goto-index index) (cons x y)))))))
|
||||
(funcall fun *caller* (goto-visual-index index) (cons x y)))))))
|
||||
(export ',symbol)))))
|
||||
|
||||
(defaction-type org-line)
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
(:use-reexport
|
||||
:sextant/models/utils
|
||||
:sextant/models/files-model
|
||||
:sextant/models/cursor
|
||||
:sextant/models/commands
|
||||
:sextant/models/actions
|
||||
:sextant/models/org-model))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
(uiop:define-package :sextant/models/commands
|
||||
(:use :cl :eql :org :options :qml-lisp :s-base64 :alexandria
|
||||
:sextant/models/org-model)
|
||||
:sextant/models/org-model
|
||||
:sextant/models/cursor)
|
||||
(:import-from :inferior-shell #:run)
|
||||
(:export #:modify-text
|
||||
#:join-node
|
||||
|
|
@ -85,21 +86,12 @@
|
|||
|
||||
|
||||
|
||||
(defun reparse-node (index &optional (force nil))
|
||||
(let* ((node (goto-index index))
|
||||
(new-node (parse-node node)))
|
||||
(if (or (replace-data node new-node) force)
|
||||
(refresh-data index
|
||||
(progn (goto-end-section) (current-index)))
|
||||
(refresh-data index))
|
||||
new-node))
|
||||
|
||||
(defun do-modify-text (index new-text update-ui)
|
||||
(defun do-modify-text (index new-text update-ui-p)
|
||||
(setf (raw-text-of (goto-index index)) new-text)
|
||||
(when update-ui
|
||||
(when update-ui-p
|
||||
(reparse-node index)))
|
||||
|
||||
(defun do-join-node (command update-ui)
|
||||
(defun do-join-node (command update-ui-p)
|
||||
(let* ((node (goto-index (index-of command)))
|
||||
(next (next-of node))
|
||||
(next-next (next-of next)))
|
||||
|
|
@ -108,16 +100,17 @@
|
|||
(flet ((relink-nodes (n nn)
|
||||
(setf (next-of n) nn)
|
||||
(when nn (setf (previous-of nn) n))))
|
||||
(if update-ui
|
||||
(if update-ui-p
|
||||
(progn
|
||||
(removing-rows ((1+ (index-of command)))
|
||||
(relink-nodes node next-next))
|
||||
(reparse-node (index-of command) (subtypep (type-of next) 'org-headline)))
|
||||
(reparse-node (index-of command))
|
||||
(qjs |focusIndex| "orgDocument" (current-visual-index) t (length (previous-text-of command))))
|
||||
(progn
|
||||
(relink-nodes node next-next)
|
||||
(dec-nodes-count))))))
|
||||
|
||||
(defun do-split-node (command update-ui)
|
||||
(defun do-split-node (command update-ui-p)
|
||||
(let* ((node (goto-index (index-of command)))
|
||||
(next (next-of node))
|
||||
(new-node (make-org-line (next-text-of command) (next-eol-of command))))
|
||||
|
|
@ -129,7 +122,7 @@
|
|||
(when nn
|
||||
(setf (previous-of nn) new
|
||||
(next-of new) nn))))
|
||||
(if update-ui
|
||||
(if update-ui-p
|
||||
(progn
|
||||
(inserting-rows ((1+ (index-of command)))
|
||||
(relink-nodes node next new-node))
|
||||
|
|
@ -137,33 +130,33 @@
|
|||
(reparse-node (1+ (index-of command))))
|
||||
(progn
|
||||
(relink-nodes node next new-node)
|
||||
(inc-nodes-count))))))
|
||||
(inc-visual-nodes-count))))))
|
||||
|
||||
|
||||
|
||||
(defgeneric apply-command (command update-ui))
|
||||
(defgeneric apply-command (command update-ui-p))
|
||||
|
||||
(defmethod apply-command ((command command-modify-text) update-ui)
|
||||
(do-modify-text (index-of command) (after-text-of command) update-ui))
|
||||
(defmethod apply-command ((command command-modify-text) update-ui-p)
|
||||
(do-modify-text (index-of command) (after-text-of command) update-ui-p))
|
||||
|
||||
(defmethod apply-command ((command command-join-node) update-ui)
|
||||
(do-join-node command update-ui))
|
||||
(defmethod apply-command ((command command-join-node) update-ui-p)
|
||||
(do-join-node command update-ui-p))
|
||||
|
||||
(defmethod apply-command ((command command-split-node) update-ui)
|
||||
(do-split-node command update-ui))
|
||||
(defmethod apply-command ((command command-split-node) update-ui-p)
|
||||
(do-split-node command update-ui-p))
|
||||
|
||||
|
||||
|
||||
(defgeneric unapply-command (command update-ui))
|
||||
(defgeneric unapply-command (command update-ui-p))
|
||||
|
||||
(defmethod unapply-command ((command command-modify-text) update-ui)
|
||||
(do-modify-text (index-of command) (before-text-of command) update-ui))
|
||||
(defmethod unapply-command ((command command-modify-text) update-ui-p)
|
||||
(do-modify-text (index-of command) (before-text-of command) update-ui-p))
|
||||
|
||||
(defmethod unapply-command ((command command-join-node) update-ui)
|
||||
(do-split-node command update-ui))
|
||||
(defmethod unapply-command ((command command-join-node) update-ui-p)
|
||||
(do-split-node command update-ui-p))
|
||||
|
||||
(defmethod unapply-command ((command command-split-node) update-ui)
|
||||
(do-join-node command update-ui))
|
||||
(defmethod unapply-command ((command command-split-node) update-ui-p)
|
||||
(do-join-node command update-ui-p))
|
||||
|
||||
|
||||
|
||||
|
|
@ -200,81 +193,80 @@
|
|||
|
||||
|
||||
|
||||
(defun push-command-modify-text (command index before-text after-text update-ui)
|
||||
(let ((next-command (make-instance 'command-modify-text :previous command
|
||||
:index index
|
||||
:before-text before-text
|
||||
:after-text after-text)))
|
||||
(apply-command next-command update-ui)
|
||||
(setf (next-of command) next-command)))
|
||||
(defun make-command-modify-text (command index before-text after-text)
|
||||
(make-instance 'command-modify-text :previous command
|
||||
:index index
|
||||
:before-text before-text
|
||||
:after-text after-text))
|
||||
|
||||
(defun push-command-join-node (command index previous-text previous-eol next-text next-eol update-ui)
|
||||
(let ((next-command (make-instance 'command-join-node :previous command
|
||||
:index index
|
||||
:previous-text previous-text
|
||||
:previous-eol previous-eol
|
||||
:next-text next-text
|
||||
:next-eol next-eol)))
|
||||
(apply-command next-command update-ui)
|
||||
(setf (next-of command) next-command)))
|
||||
(defun make-command-join-node (command index previous-text previous-eol next-text next-eol)
|
||||
(make-instance 'command-join-node :previous command
|
||||
:index index
|
||||
:previous-text previous-text
|
||||
:previous-eol previous-eol
|
||||
:next-text next-text
|
||||
:next-eol next-eol))
|
||||
|
||||
(defun push-command-split-node (command index previous-text previous-eol next-text next-eol update-ui)
|
||||
(let ((next-command (make-instance 'command-split-node :previous command
|
||||
:index index
|
||||
:previous-text previous-text
|
||||
:previous-eol previous-eol
|
||||
:next-text next-text
|
||||
:next-eol next-eol)))
|
||||
(apply-command next-command update-ui)
|
||||
(setf (next-of command) next-command)))
|
||||
(defun make-command-split-node (command index previous-text previous-eol next-text next-eol)
|
||||
(make-instance 'command-split-node :previous command
|
||||
:index index
|
||||
:previous-text previous-text
|
||||
:previous-eol previous-eol
|
||||
:next-text next-text
|
||||
:next-eol next-eol))
|
||||
|
||||
|
||||
|
||||
(defun modify-text (index text &optional update-ui)
|
||||
(let ((node (goto-index index)))
|
||||
(setf *current-state* (push-command-modify-text *current-state* index
|
||||
(raw-text-of node) text update-ui))
|
||||
(when update-ui
|
||||
(refresh-toolbar))))
|
||||
|
||||
(defun join-node (index &optional update-ui)
|
||||
(let* ((node (goto-index index))
|
||||
(next (next-of node)))
|
||||
(setf *current-state* (push-command-join-node *current-state* index
|
||||
(raw-text-of node) (line-ending-of node)
|
||||
(raw-text-of next) (line-ending-of next)
|
||||
update-ui))
|
||||
(when update-ui
|
||||
(refresh-toolbar))))
|
||||
|
||||
(defun split-node (index previous-text next-text &optional update-ui)
|
||||
(let* ((node (goto-index index))
|
||||
(next-eol (line-ending-of node))
|
||||
(previous-eol (if (/= (length next-eol) 0)
|
||||
next-eol
|
||||
(let ((prev (previous-of node)))
|
||||
(if prev
|
||||
(line-ending-of prev)
|
||||
(coerce #(#\Newline) 'string))))))
|
||||
(setf *current-state* (push-command-split-node *current-state* index
|
||||
previous-text previous-eol
|
||||
next-text next-eol update-ui)))
|
||||
(when update-ui
|
||||
(defun modify-text (visual-index text &optional update-ui-p)
|
||||
(multiple-value-bind (node index) (goto-visual-index visual-index)
|
||||
(let ((next-command (make-command-modify-text *current-state* index
|
||||
(raw-text-of node) text)))
|
||||
(apply-command next-command update-ui-p)
|
||||
(setf (next-of *current-state*) next-command)))
|
||||
(when update-ui-p
|
||||
(refresh-toolbar)))
|
||||
|
||||
(defun join-node (visual-index &optional update-ui-p)
|
||||
(multiple-value-bind (node index) (goto-visual-index visual-index)
|
||||
(let* ((previous (previous-of node))
|
||||
(next-command (make-command-join-node *current-state* (1- index)
|
||||
(raw-text-of previous) (line-ending-of previous)
|
||||
(raw-text-of node) (line-ending-of node))))
|
||||
(apply-command next-command update-ui-p)
|
||||
(setf (next-of *current-state*) next-command)))
|
||||
(when update-ui-p
|
||||
(refresh-toolbar)))
|
||||
|
||||
(defun split-node (visual-index previous-text next-text &optional update-ui-p)
|
||||
(multiple-value-bind (node index) (goto-visual-index visual-index)
|
||||
(let* ((next-eol (line-ending-of node))
|
||||
(previous-eol (if (/= (length next-eol) 0)
|
||||
next-eol
|
||||
(let ((prev (previous-of node)))
|
||||
(if prev
|
||||
(line-ending-of prev)
|
||||
(coerce #(#\Newline) 'string)))))
|
||||
(next-command (make-command-split-node *current-state* index
|
||||
previous-text previous-eol
|
||||
next-text next-eol)))
|
||||
(apply-command next-command update-ui-p)
|
||||
(setf (next-of *current-state*) next-command)))
|
||||
(when update-ui-p
|
||||
(refresh-toolbar))
|
||||
|
||||
|
||||
|
||||
(defun undo ()
|
||||
(let ((previous-state (previous-of *current-state*)))
|
||||
(unless (null previous-state)
|
||||
(prog1
|
||||
(index-of *current-state*)
|
||||
(unapply-command *current-state* t)
|
||||
(setf *current-state* previous-state)
|
||||
(refresh-toolbar)))))
|
||||
(defun undo ()
|
||||
(let ((previous-state (previous-of *current-state*)))
|
||||
(unless (null previous-state)
|
||||
(prog1
|
||||
(index-of *current-state*)
|
||||
(unapply-command *current-state* t)
|
||||
(setf *current-state* previous-state)
|
||||
(refresh-toolbar)))))
|
||||
|
||||
(defun can-undo-p ()
|
||||
(not (null (and *current-state* (previous-of *current-state*)))))
|
||||
(defun can-undo-p ()
|
||||
(not (null (and *current-state* (previous-of *current-state*))))))
|
||||
|
||||
(defun redo ()
|
||||
(let ((next-state (next-of *current-state*)))
|
||||
|
|
@ -320,6 +312,7 @@
|
|||
(not (eq *saved-state* *current-state*)))
|
||||
|
||||
(defun refresh-toolbar ()
|
||||
#+harbour-sextant
|
||||
(qjs |refreshToolbar| "orgDocument"
|
||||
(can-undo-p) (can-redo-p) (can-save-p)))
|
||||
|
||||
|
|
@ -341,48 +334,47 @@
|
|||
buffer))))
|
||||
|
||||
(defun hash-base64 (buffer)
|
||||
(if (null buffer)
|
||||
(if (or (null buffer) (= (length buffer) 0))
|
||||
""
|
||||
(with-output-to-string (stream)
|
||||
(encode-base64-bytes (|hash.QCryptographicHash| buffer |QCryptographicHash.Sha1|)
|
||||
stream))))
|
||||
|
||||
(defun load-commands (pathname)
|
||||
(init-commands)
|
||||
(let ((commands-pathname (commands-pathname pathname)))
|
||||
(when (probe-file commands-pathname)
|
||||
(let ((commands (uiop:safe-read-file-form commands-pathname
|
||||
:package :sextant/models/commands))
|
||||
(sha (hash-base64 (load-binary-file pathname))))
|
||||
(let* ((commands (uiop:safe-read-file-form commands-pathname
|
||||
:package :sextant/models/commands))
|
||||
(sha (hash-base64 (load-binary-file pathname))))
|
||||
(cond
|
||||
((= (getf commands :version) 1)
|
||||
(when (string= sha (getf commands :sha1))
|
||||
(let ((command-count (loop with state = *initial-state*
|
||||
for c in (getf commands :commands)
|
||||
count c
|
||||
while c
|
||||
do (let ((command (apply #'make-instance c)))
|
||||
(setf (next-of state) command
|
||||
(previous-of command) state)
|
||||
(setf state command)))))
|
||||
(let ((saved-index (getf commands :saved-state)))
|
||||
(if (or (< saved-index 0) (> saved-index command-count))
|
||||
(setf (next-of *initial-state*) nil)
|
||||
(progn
|
||||
(dotimes (i saved-index)
|
||||
(setf *saved-state* (next-of *saved-state*)))
|
||||
(setf *current-state* *saved-state*)
|
||||
(let ((current-index (getf commands :current-state)))
|
||||
(when (and (>= current-index 0) (<= current-index command-count))
|
||||
(let ((c *current-state*))
|
||||
(cond
|
||||
((> current-index saved-index)
|
||||
(dotimes (i (- current-index saved-index))
|
||||
(setf *current-state* (next-of *current-state*))
|
||||
(apply-command *current-state* nil)))
|
||||
((< current-index saved-index)
|
||||
(dotimes (i (- saved-index current-index))
|
||||
(unapply-command *current-state* nil)
|
||||
(setf *current-state* (previous-of *current-state*)))))))))))))))))))
|
||||
(let ((saved-index (getf commands :saved-state))
|
||||
(current-index (getf commands :current-state)))
|
||||
(when (string= sha (getf commands :sha1))
|
||||
(let ((command-count (loop with state = *initial-state*
|
||||
for c in (getf commands :commands)
|
||||
count c
|
||||
while c
|
||||
do (let ((command (apply #'make-instance c)))
|
||||
(setf (next-of state) command
|
||||
(previous-of command) state)
|
||||
(setf state command)))))
|
||||
(when (and (>= saved-index 0) (< saved-index command-count))
|
||||
(dotimes (i saved-index)
|
||||
(setf *saved-state* (next-of *saved-state*)))
|
||||
(setf *current-state* *saved-state*)
|
||||
(when (and (>= current-index 0) (<= current-index command-count))
|
||||
(let ((c *current-state*))
|
||||
(cond
|
||||
((> current-index saved-index)
|
||||
(dotimes (i (- current-index saved-index))
|
||||
(setf *current-state* (next-of *current-state*))
|
||||
(apply-command *current-state* nil)))
|
||||
((< current-index saved-index)
|
||||
(dotimes (i (- saved-index current-index))
|
||||
(unapply-command *current-state* nil)
|
||||
(setf *current-state* (previous-of *current-state*)))))))))))))))))
|
||||
|
||||
(defun save-commands (pathname)
|
||||
(unless (or (null *initial-state*) (null (next-of *initial-state*)))
|
||||
|
|
@ -414,11 +406,12 @@
|
|||
(princ "))" stream)
|
||||
(terpri stream)))))
|
||||
|
||||
(defun initialize-commands (pathname)
|
||||
(setf *saved-hash* (hash-base64 (load-binary-file pathname)))
|
||||
(defun initialize-commands (&optional pathname)
|
||||
(setf *saved-state*
|
||||
(setf *current-state*
|
||||
(setf *initial-state*
|
||||
(make-instance 'command-initial-state))))
|
||||
(load-commands pathname)
|
||||
(when pathname
|
||||
(setf *saved-hash* (hash-base64 (load-binary-file pathname)))
|
||||
(load-commands pathname))
|
||||
(qlater #'refresh-toolbar))
|
||||
|
|
|
|||
319
lisp/local-projects/sextant/models/cursor.lisp
Normal file
319
lisp/local-projects/sextant/models/cursor.lisp
Normal file
|
|
@ -0,0 +1,319 @@
|
|||
(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))
|
||||
|
|
@ -1,16 +1,20 @@
|
|||
(uiop:define-package :sextant/models/org-model
|
||||
(:use :cl :eql :org :qml-lisp :s-base64 :alexandria
|
||||
:sextant/models/utils)
|
||||
(:export #:org-document
|
||||
#:inc-nodes-count
|
||||
#:dec-nodes-count
|
||||
#:replace-data
|
||||
:sextant/models/utils
|
||||
:sextant/models/cursor)
|
||||
(:export #:inc-visual-nodes-count
|
||||
#:dec-visual-nodes-count
|
||||
#:refresh-data
|
||||
#:hiding-rows
|
||||
#:showing-rows
|
||||
#:remove-rows
|
||||
#:removing-rows
|
||||
#:insert-rows
|
||||
#:inserting-rows
|
||||
#:step-to-node
|
||||
#:reparse-node
|
||||
#:goto-visual-index
|
||||
#:goto-end-visible-section
|
||||
#:goto-index
|
||||
#:goto-end-section
|
||||
#:ensure-visible
|
||||
#:expand-headline
|
||||
#:collapse-headline
|
||||
|
|
@ -26,270 +30,168 @@
|
|||
+last-item-role+)
|
||||
|
||||
(defvar *current-pathname* nil)
|
||||
(defvar *org-document* nil)
|
||||
(defvar *nodes-count* 0)
|
||||
(defvar *visual-nodes-count* 0)
|
||||
|
||||
(defvar *org-model* nil)
|
||||
(defvar *empty-model-index* (qnew "QModelIndex"))
|
||||
|
||||
|
||||
|
||||
(defvar *cursor* (list nil nil 0))
|
||||
|
||||
(defun current-node () (nth 0 *cursor*))
|
||||
(defun current-headline () (nth 1 *cursor*))
|
||||
(defun current-index () (nth 2 *cursor*))
|
||||
|
||||
(defun move-cursor (node headline step)
|
||||
(setf *cursor* (list node headline (+ (current-index) step))))
|
||||
|
||||
(defun set-current-node (node) (setf (nth 0 *cursor*) node))
|
||||
(defun set-current-headline (node) (setf (nth 1 *cursor*) node))
|
||||
(defun set-current-index (index) (setf (nth 2 *cursor*) index))
|
||||
|
||||
(defun inc-current-index (&optional (step 1)) (incf (nth 2 *cursor*) step))
|
||||
(defun dec-current-index (&optional (step 1)) (decf (nth 2 *cursor*) step))
|
||||
|
||||
(defvar *saved-cursors* nil)
|
||||
|
||||
(defmacro save-excursion (&body body)
|
||||
`(prog2
|
||||
(push (copy-seq *cursor*) *saved-cursors*)
|
||||
(progn ,@body)
|
||||
(pop *saved-cursors*)))
|
||||
|
||||
|
||||
|
||||
(defun org-document () *org-document*)
|
||||
|
||||
(defun model-index (index)
|
||||
(|index| *org-model* index))
|
||||
|
||||
(defun inc-nodes-count (&optional (count 1))
|
||||
(incf *nodes-count* count))
|
||||
(defun inc-visual-nodes-count (&optional (count 1))
|
||||
(incf *visual-nodes-count* count))
|
||||
|
||||
(defun dec-nodes-count (&optional (count 1))
|
||||
(decf *nodes-count* count))
|
||||
(defun dec-visual-nodes-count (&optional (count 1))
|
||||
(decf *visual-nodes-count* count))
|
||||
|
||||
|
||||
|
||||
(defun replace-data (node new-node)
|
||||
(prog1
|
||||
(replace-node node new-node)
|
||||
(when (eq (current-node) node)
|
||||
(set-current-node new-node))
|
||||
(when (subtypep (type-of new-node) 'org-headline)
|
||||
(set-current-headline new-node))
|
||||
(when (eq (current-headline) node)
|
||||
(set-current-headline (if (subtypep (type-of new-node) 'org-headline)
|
||||
new-node
|
||||
(headline-of new-node))))))
|
||||
|
||||
(defun refresh-data (start &optional (end start))
|
||||
(let* ((start-index (model-index start))
|
||||
(end-index (if (= end start) start-index (model-index end))))
|
||||
(|dataChanged| *org-model* start-index end-index)))
|
||||
|
||||
(defmacro removing-rows ((start &optional (end start)) &body body)
|
||||
(once-only (start end)
|
||||
`(progn
|
||||
(|beginRemoveRows| sextant/models/org-model::*org-model*
|
||||
sextant/models/org-model::*empty-model-index* ,start ,end)
|
||||
,@body
|
||||
(decf sextant/models/org-model::*nodes-count* (1+ (- ,end ,start)))
|
||||
(|endRemoveRows| sextant/models/org-model::*org-model*))))
|
||||
(defun reparse-node (index)
|
||||
(let* ((node (goto-index index))
|
||||
(new-node (parse-node node)))
|
||||
(assert (node-visible-p node))
|
||||
(case (compare-nodes node new-node)
|
||||
(:depth->
|
||||
(expand-headline)
|
||||
(when (> index 0)
|
||||
(ensure-visible (1- index)))
|
||||
(swap-nodes node new-node)
|
||||
(refresh-data index (save-excursion (nth-value 1 (goto-end-visual-section)))))
|
||||
(:depth-<
|
||||
(swap-nodes node new-node)
|
||||
(refresh-data index (save-excursion (nth-value 1 (goto-end-visual-section))))))
|
||||
(replace-cursor new-node index)
|
||||
new-node))
|
||||
|
||||
(defun remove-rows (start count)
|
||||
|
||||
|
||||
(defun remove-rows (start count fun)
|
||||
(let ((end (+ start (1- count))))
|
||||
(|beginRemoveRows| *org-model* *empty-model-index* start end)
|
||||
(decf *nodes-count* count)
|
||||
(funcall fun)
|
||||
(decf *visual-nodes-count* count)
|
||||
(|endRemoveRows| *org-model*)))
|
||||
|
||||
(defmacro inserting-rows ((start &optional (end start)) &body body)
|
||||
(once-only (start end)
|
||||
`(progn
|
||||
(|beginInsertRows| sextant/models/org-model::*org-model*
|
||||
sextant/models/org-model::*empty-model-index* ,start ,end)
|
||||
,@body
|
||||
(incf sextant/models/org-model::*nodes-count* (1+ (- ,end ,start)))
|
||||
(|endInsertRows| sextant/models/org-model::*org-model*))))
|
||||
(defmacro removing-rows ((start &optional (count 1)) &body body)
|
||||
`(sextant/models/org-model::remove-rows
|
||||
,start ,count
|
||||
(lambda ()
|
||||
,(sextant/models/cursor::adjust-saved-cursors-before-remove start count)
|
||||
,@body)))
|
||||
|
||||
(defun insert-rows (start count)
|
||||
(defmacro hiding-rows ((start &optional (count 1)) &body body)
|
||||
`(sextant/models/org-model::remove-rows ,start ,count (lambda () ,@body)))
|
||||
|
||||
(defun insert-rows (start count fun)
|
||||
(let ((end (+ start (1- count))))
|
||||
(|beginInsertRows| *org-model* *empty-model-index* start end)
|
||||
(incf *nodes-count* count)
|
||||
(funcall fun)
|
||||
(incf *visual-nodes-count* count)
|
||||
(|endInsertRows| *org-model*)))
|
||||
|
||||
|
||||
(defmacro inserting-rows ((start &optional (count 1)) &body body)
|
||||
`(sextant/models/org-model::insert-rows
|
||||
,start ,count
|
||||
(lambda ()
|
||||
,(sextant/models/cursor::adjust-saved-cursors-before-insert start count)
|
||||
,@body)))
|
||||
|
||||
(defgeneric node-depth (node))
|
||||
|
||||
(defmethod node-depth ((node org-line))
|
||||
(if (current-headline)
|
||||
(1+ (depth-of (current-headline)))
|
||||
0))
|
||||
|
||||
(defmethod node-depth ((node org-headline))
|
||||
(depth-of node))
|
||||
|
||||
(defun previous-visible-headline (headline)
|
||||
(let ((prev (previous-headline-of headline)))
|
||||
(if (or (null prev) (<= (depth-of prev) (depth-of headline)))
|
||||
prev
|
||||
(loop with depth = (depth-of prev)
|
||||
for h = (previous-headline-of prev) then (previous-headline-of h)
|
||||
until (or (null h)
|
||||
(and (< (depth-of h) depth)
|
||||
(eq (property-of h :visibility) :expanded)))
|
||||
when (< (depth-of h) depth)
|
||||
do (setf prev h
|
||||
depth (depth-of h))
|
||||
finally (return prev)))))
|
||||
|
||||
(defun %%previous-node (node headline)
|
||||
(values (previous-of node)
|
||||
(if (eq node headline)
|
||||
(previous-headline-of headline)
|
||||
headline)))
|
||||
|
||||
(defgeneric %previous-node (node headline))
|
||||
|
||||
(defmethod %previous-node ((node org-line) headline)
|
||||
(%%previous-node node headline))
|
||||
|
||||
(defmethod %previous-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 (let ((prev (previous-visible-headline node)))
|
||||
(values prev prev))))))
|
||||
|
||||
(defun previous-node ()
|
||||
(multiple-value-bind (node headline) (%previous-node (current-node) (current-headline))
|
||||
(when node
|
||||
(move-cursor node headline -1))))
|
||||
|
||||
(defun %%next-node (node headline)
|
||||
(let ((next (next-of node)))
|
||||
(values next
|
||||
(if (subtypep (type-of next) 'org-headline)
|
||||
next
|
||||
headline))))
|
||||
|
||||
(defgeneric %next-node (node headline))
|
||||
|
||||
(defmethod %next-node ((node org-line) headline)
|
||||
(%%next-node node headline))
|
||||
|
||||
(defmethod %next-node ((node org-headline) headline)
|
||||
(assert (eq node headline))
|
||||
(ecase (property-of node :visibility)
|
||||
(:expanded (%%next-node node headline))
|
||||
(:collapsed (let ((depth (depth-of node)))
|
||||
(loop for n = (next-headline-of node) then (next-headline-of n)
|
||||
until (or (null n) (<= (depth-of n) depth))
|
||||
finally (return (values n n)))))))
|
||||
|
||||
(defun next-node ()
|
||||
(multiple-value-bind (node headline) (%next-node (current-node) (current-headline))
|
||||
(when node
|
||||
(move-cursor node headline 1))))
|
||||
|
||||
(defun goto-index (index)
|
||||
(assert (>= index 0))
|
||||
(assert (< index *nodes-count*))
|
||||
(unless (= index (current-index))
|
||||
(let* ((step (- index (current-index))))
|
||||
(if (< step 0)
|
||||
(loop do (progn
|
||||
(previous-node)
|
||||
(incf step))
|
||||
until (= step 0))
|
||||
(loop do (progn
|
||||
(next-node)
|
||||
(decf step))
|
||||
until (= step 0)))))
|
||||
(values-list *cursor*))
|
||||
|
||||
(defun goto-end-section ()
|
||||
(let ((depth (and (current-headline) (depth-of (current-headline)))))
|
||||
(loop for (n h i) = (next-node) then (next-node)
|
||||
until (or (null n) (<= (node-depth n) depth)))
|
||||
(if (<= (node-depth (current-node)) depth)
|
||||
(previous-node)
|
||||
*cursor*)))
|
||||
(defmacro showing-rows ((start &optional (count 1)) &body body)
|
||||
`(sextant/models/org-model::insert-rows ,start ,count (lambda () ,@body)))
|
||||
|
||||
|
||||
|
||||
(defun ensure-visible (node)
|
||||
(unless (node-visible-p node)
|
||||
(let* ((parent-node (current-node)))
|
||||
(assert (eq parent-node (current-headline)))
|
||||
(expand-headline (node-path node parent-node)))))
|
||||
(defun ensure-visible (index)
|
||||
(let ((node (goto-index index)))
|
||||
(unless (node-visible-p node)
|
||||
(expand-headline (node-path node (current-headline))))))
|
||||
|
||||
(defun expand-headline (&optional recurse)
|
||||
(let* ((node (current-node))
|
||||
(depth (node-depth node)))
|
||||
(if (null recurse)
|
||||
(when (eq (property-of node :visibility) :collapsed)
|
||||
(save-excursion
|
||||
(loop with index = (1+ (current-index))
|
||||
for (n h i) = (next-node) then (next-node)
|
||||
until (or (null n) (<= (node-depth n) depth))
|
||||
count n into count
|
||||
finally (insert-rows index count))))
|
||||
(let ((depth/visibility (list (cons depth (property-of node :visibility)))))
|
||||
(setf (property-of node :visibility) :expanded)
|
||||
(flet ((parent-depth () (assert (not (null depth/visibility))) (car (first depth/visibility)))
|
||||
(parent-collapsed () (assert (not (null depth/visibility))) (eq (cdr (first depth/visibility)) :collapsed)))
|
||||
(save-excursion
|
||||
(loop with index = -1
|
||||
for (n h i) = (next-node) then (next-node)
|
||||
until (or (null n) (<= (node-depth n) depth))
|
||||
when (and (parent-collapsed) (= index -1))
|
||||
(assert (eq (current-visual-node) (current-node)))
|
||||
(let* ((node (current-visual-node))
|
||||
(depth (node-depth)))
|
||||
(assert (eq node (current-visual-headline)))
|
||||
(save-excursion
|
||||
(if (null recurse)
|
||||
(when (eq (property-of node :visibility) :collapsed)
|
||||
(let ((count (save-excursion
|
||||
(loop with index = (1+ (current-index))
|
||||
and sub-headline-depth = nil
|
||||
for n = (next-node) then (next-node)
|
||||
until (or (null n) (<= (node-depth) depth))
|
||||
when (eq (current-node) (current-headline))
|
||||
do (setf sub-headline-depth (node-depth))
|
||||
count (or (null sub-headline-depth) (= (node-depth) sub-headline-depth))))))
|
||||
(showing-rows ((1+ (current-index)) count)
|
||||
(setf (property-of node :visibility) :expanded))))
|
||||
(let ((depth/visibility (list (cons depth (property-of node :visibility)))))
|
||||
(flet ((parent-depth () (assert (not (null depth/visibility))) (car (first depth/visibility)))
|
||||
(parent-collapsed-p () (assert (not (null depth/visibility))) (eq (cdr (first depth/visibility)) :collapsed))
|
||||
(push-depth/visibility (depth visibility)
|
||||
(assert (> depth (parent-depth)))
|
||||
(push (cons depth visibility) depth/visibility))
|
||||
(expand-those-headlines (index count headlines)
|
||||
(assert (> count 0))
|
||||
(save-excursion
|
||||
(showing-rows (index count)
|
||||
(loop for h in headlines
|
||||
do (progn
|
||||
(assert (subtypep (type-of h) 'org-headline))
|
||||
(setf (property-of h :visibility) :expanded)))))))
|
||||
(loop with headlines-to-expand = (if (parent-collapsed-p) node nil)
|
||||
and index = (if (parent-collapsed-p) (1+ (current-index)) -1)
|
||||
for n = (next-node) then (next-node)
|
||||
until (or (null n) (<= (node-depth) depth))
|
||||
when (and (parent-collapsed-p) (= index -1))
|
||||
do (setf index (current-index))
|
||||
when (eq n h)
|
||||
when (eq n (current-headline))
|
||||
do (progn
|
||||
(loop
|
||||
while (<= (node-depth n) (parent-depth))
|
||||
do (pop depth/visibility))
|
||||
(when (and (/= index -1) (not (parent-collapsed)))
|
||||
(insert-rows index count)
|
||||
(setf index -1 count 0))
|
||||
(assert (> (node-depth n) (parent-depth)))
|
||||
(push (cons (node-depth n) (property-of n :visibility)) depth/visibility)
|
||||
(cond
|
||||
((eq recurse t)
|
||||
(setf (property-of n :visibility) :expanded))
|
||||
((and (listp recurse) (eq n (first recurse)))
|
||||
(pop recurse)
|
||||
(setf (property-of n :visibility) :expanded))))
|
||||
(loop while (<= (node-depth) (parent-depth))
|
||||
do (pop depth/visibility))
|
||||
(when (and (/= index -1) (not (parent-collapsed-p)))
|
||||
(expand-those-headlines index count headlines-to-expand)
|
||||
(setf index -1
|
||||
count 0
|
||||
headlines-to-expand nil)
|
||||
(push-depth/visibility (node-depth) (property-of n :visibility))
|
||||
(cond
|
||||
((eq recurse t)
|
||||
(push n headlines-to-expand))
|
||||
((and (listp recurse) (eq n (first recurse)))
|
||||
(pop recurse)
|
||||
(push n headlines-to-expand)))))
|
||||
count (/= index -1) into count
|
||||
finally (when (/= index -1)
|
||||
(assert (> count 0))
|
||||
(insert-rows index count)))))))))
|
||||
(expand-those-headlines index count headlines-to-expand)))))))))
|
||||
|
||||
(defun collapse-headline ()
|
||||
(let* ((node (current-node))
|
||||
(depth (node-depth node)))
|
||||
(assert (subtypep (type-of node) 'org-headline))
|
||||
(destructuring-bind (count . headlines)
|
||||
(save-excursion
|
||||
(loop for (n h i) = (next-node) then (next-node)
|
||||
until (or (null n) (<= (node-depth n) depth))
|
||||
(assert (eq (current-visual-node) (current-node)))
|
||||
(let* ((node (current-visual-node))
|
||||
(depth (node-depth)))
|
||||
(assert (eq node (current-visual-headline)))
|
||||
(save-excursion
|
||||
(destructuring-bind (count . headlines)
|
||||
(save-excursion
|
||||
(loop for n = (next-visual-node) then (next-visual-node)
|
||||
until (or (null n) (<= (visual-node-depth) depth))
|
||||
count n into count
|
||||
when (eq n h)
|
||||
when (eq n (current-visual-headline))
|
||||
collect n into headlines
|
||||
finally (return (cons count headlines))))
|
||||
(when (> count 0)
|
||||
(removing-rows ((1+ (current-index)) (+ (current-index) count))
|
||||
(loop for n in headlines
|
||||
do (progn
|
||||
(assert (subtypep (type-of n) 'org-headline))
|
||||
(setf (property-of n :visibility) :collapsed)))
|
||||
(setf (property-of node :visibility) :collapsed))))))
|
||||
(when (> count 0)
|
||||
(hiding-rows ((1+ (current-visual-index)) count)
|
||||
(loop for n in headlines
|
||||
do (progn
|
||||
(assert (subtypep (type-of n) 'org-headline))
|
||||
(setf (property-of n :visibility) :collapsed)))
|
||||
(setf (property-of node :visibility) :collapsed)))))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -298,12 +200,12 @@
|
|||
(qoverride model "rowCount(QModelIndex)"
|
||||
(lambda (index)
|
||||
(declare (ignore index))
|
||||
*nodes-count*))
|
||||
*visual-nodes-count*))
|
||||
(qoverride model "data(QModelIndex,int)"
|
||||
(lambda (index role)
|
||||
(let ((row (|row| index)))
|
||||
(when (and (> row -1) (< row *nodes-count*))
|
||||
(let ((item (goto-index row)))
|
||||
(when (and (> row -1) (< row *visual-nodes-count*))
|
||||
(let ((item (goto-visual-index row)))
|
||||
(case role
|
||||
(#.+nodetype-role+
|
||||
(qvariant-from-value (string-downcase (symbol-name (type-of item)))
|
||||
|
|
@ -311,11 +213,11 @@
|
|||
(#.+rawtext-role+
|
||||
(qvariant-from-value (raw-text-of item) "QString"))
|
||||
(#.+depth-role+
|
||||
(qvariant-from-value (node-depth item) "int"))
|
||||
(qvariant-from-value (node-depth) "int"))
|
||||
(#.+title-role+
|
||||
(qvariant-from-value (title-of item) "QString"))
|
||||
(#.+last-item-role+
|
||||
(qvariant-from-value (= row (1- *nodes-count*)) "bool"))))))))
|
||||
(qvariant-from-value (= row (1- *visual-nodes-count*)) "bool"))))))))
|
||||
(qoverride model "roleNames()"
|
||||
(lambda ()
|
||||
(list (cons +nodetype-role+ "nodeType")
|
||||
|
|
@ -326,6 +228,7 @@
|
|||
(when *org-model*
|
||||
(qdelete *org-model*))
|
||||
(setf *org-model* model)
|
||||
#+harbour-sextant
|
||||
(|setContextProperty| (|rootContext| qml:*quick-view*) "orgModel" *org-model*)))
|
||||
|
||||
(defun make-org-model (pathname org-document &optional force)
|
||||
|
|
@ -333,10 +236,8 @@
|
|||
(construct-org-model))
|
||||
(setf *current-pathname* pathname)
|
||||
(|beginResetModel| *org-model*)
|
||||
(setf *org-document* org-document
|
||||
*nodes-count* (loop for node = (next-of org-document) then (next-of node)
|
||||
while node count node))
|
||||
(let* ((node (next-of org-document))
|
||||
(headline (and (subtypep (type-of node) 'org-headline) node)))
|
||||
(setf *cursor* (list node headline 0)))
|
||||
(init-cursor org-document)
|
||||
(setf *visual-nodes-count* (save-excursion
|
||||
(loop for node = (current-visual-node) then (next-visual-node)
|
||||
while node count node)))
|
||||
(|endResetModel| *org-model*))
|
||||
|
|
|
|||
|
|
@ -3,5 +3,6 @@
|
|||
(:use-reexport
|
||||
:sextant/org/nodes
|
||||
:sextant/org/cursor
|
||||
:sextant/org/commands
|
||||
:sextant/org/parser
|
||||
:sextant/org/printer))
|
||||
|
|
|
|||
111
lisp/local-projects/sextant/org/commands.lisp
Normal file
111
lisp/local-projects/sextant/org/commands.lisp
Normal file
|
|
@ -0,0 +1,111 @@
|
|||
(uiop:define-package :sextant/org/commands
|
||||
(:use :cl :s-base64 :alexandria
|
||||
:sextant/org/cursor)
|
||||
(:import-from :inferior-shell #:run))
|
||||
(in-package :sextant/org/commands)
|
||||
|
||||
(defclass command ()
|
||||
((index :initarg :index
|
||||
:type integer
|
||||
:accessor index-of
|
||||
:initform 0
|
||||
:documentation "The index of the related node.")
|
||||
(previous :initarg :previous
|
||||
:type command
|
||||
:accessor previous-of
|
||||
:initform nil
|
||||
:documentation "A link to the previous command in the list.")
|
||||
(next :initarg :next
|
||||
:type command
|
||||
:accessor next-of
|
||||
:initform nil
|
||||
:documentation "A link to the next command in the list.")))
|
||||
|
||||
(defclass command-initial-state (command)
|
||||
())
|
||||
|
||||
(defclass command-edit-text (command)
|
||||
((before-text :initarg :before-text
|
||||
:type string
|
||||
:accessor before-text-of
|
||||
:initform ""
|
||||
:documentation "The text node had before this command.")
|
||||
(after-text :initarg :after-text
|
||||
:type string
|
||||
:accessor after-text-of
|
||||
:initform ""
|
||||
:documentation "The text this command needs to apply.")))
|
||||
|
||||
(defclass command-join/split-node (command)
|
||||
((previous-text :initarg :previous-text
|
||||
:type string
|
||||
:accessor previous-text-of
|
||||
:initform ""
|
||||
:documentation "The text of the previous node.")
|
||||
(previous-eol :initarg :previous-eol
|
||||
:type string
|
||||
:accessor previous-eol-of
|
||||
:initform ""
|
||||
:documentation "The line ending of the previous node.")
|
||||
(next-text :initarg :next-text
|
||||
:type string
|
||||
:accessor next-text-of
|
||||
:initform ""
|
||||
:documentation "The text of the next node.")
|
||||
(next-eol :initarg :next-eol
|
||||
:type string
|
||||
:accessor next-eol-of
|
||||
:initform ""
|
||||
:documentation "The line ending of the next node.")))
|
||||
|
||||
(defclass command-join-node (command-join/split-node)
|
||||
())
|
||||
|
||||
(defclass command-split-node (command-join/split-node)
|
||||
())
|
||||
|
||||
|
||||
|
||||
(defun make-command-edit-text (command index before-text after-text)
|
||||
(make-instance 'command-edit-text :previous command
|
||||
:index index
|
||||
:before-text before-text
|
||||
:after-text after-text))
|
||||
|
||||
(defun make-command-join-node (command index previous-text previous-eol next-text next-eol)
|
||||
(make-instance 'command-join-node :previous command
|
||||
:index index
|
||||
:previous-text previous-text
|
||||
:previous-eol previous-eol
|
||||
:next-text next-text
|
||||
:next-eol next-eol))
|
||||
|
||||
(defun make-command-split-node (command index previous-text previous-eol next-text next-eol)
|
||||
(make-instance 'command-split-node :previous command
|
||||
:index index
|
||||
:previous-text previous-text
|
||||
:previous-eol previous-eol
|
||||
:next-text next-text
|
||||
:next-eol next-eol))
|
||||
|
||||
|
||||
|
||||
(defun do-edit-text (cursor target-index new-text)
|
||||
)
|
||||
|
||||
|
||||
|
||||
(defgeneric apply-command (cursor command))
|
||||
|
||||
(defmethod apply-command (cursor (command command-edit-text))
|
||||
(do-edit-text ()))
|
||||
|
||||
|
||||
|
||||
(defun edit-text (cursor text)
|
||||
(let ((command (make-command-edit-text (document-commands cursor)
|
||||
(cursor-index cursor)
|
||||
(raw-text-of (cursor-node cursor))
|
||||
text)))
|
||||
(setf (document-commands cursor) command)
|
||||
(apply-command cursor command)))
|
||||
|
|
@ -3,9 +3,10 @@
|
|||
(:export #:make-cursor
|
||||
#:cursor-node
|
||||
#:cursor-index
|
||||
#:visual-index
|
||||
#:visible-node
|
||||
#:visible-index
|
||||
#:visual-index
|
||||
#:document-commands
|
||||
#:move-cursor
|
||||
#:previous-visible-node
|
||||
#:previous-visible-headline
|
||||
|
|
@ -14,11 +15,13 @@
|
|||
#:next-visible-node
|
||||
#:next-visible-headline
|
||||
#:next-node
|
||||
#:next-headline))
|
||||
#:next-headline
|
||||
#:goto-index))
|
||||
(in-package :sextant/org/cursor)
|
||||
|
||||
(defstruct (cursor (:constructor make-cursor (node index visual-index)))
|
||||
(node nil)
|
||||
(defstruct (cursor (:constructor make-cursor (document node index visual-index)))
|
||||
(document nil :type org-document)
|
||||
(node nil :type org-node)
|
||||
(index 0 :type number)
|
||||
(visual-index 0 :type number))
|
||||
|
||||
|
|
@ -36,6 +39,9 @@
|
|||
(cursor-index cursor)
|
||||
(- (cursor-index cursor) (count-nodes (visible-headline-of node) node)))))
|
||||
|
||||
(defun document-commands (cursor)
|
||||
(property-of (cursor-document cursor) :commands))
|
||||
|
||||
|
||||
|
||||
(defgeneric node-index (prev next))
|
||||
|
|
@ -55,10 +61,10 @@
|
|||
(- (visual-index next) (count-visible-nodes (if (node-visible-p prev) prev (visible-headline-of prev)) (visible-node next))))
|
||||
|
||||
(defun move-cursor-< (cursor target)
|
||||
(make-cursor target (node-index target cursor) (node-visual-index target cursor)))
|
||||
(make-cursor (cursor-document cursor) target (node-index target cursor) (node-visual-index target cursor)))
|
||||
|
||||
(defun move-cursor-> (cursor target)
|
||||
(make-cursor target (node-index cursor target) (node-visual-index cursor target)))
|
||||
(make-cursor (cursor-document cursor) target (node-index cursor target) (node-visual-index cursor target)))
|
||||
|
||||
(defun move-cursor (cursor target direction)
|
||||
(if (plusp direction)
|
||||
|
|
@ -109,3 +115,16 @@
|
|||
(defun next-headline (cursor)
|
||||
(when-let ((target (next-headline-of (cursor-node cursor))))
|
||||
(move-cursor-> cursor target)))
|
||||
|
||||
|
||||
|
||||
(defun goto-index (cursor index)
|
||||
(if (< index (cursor-index cursor))
|
||||
(loop for step below (- (cursor-index cursor) index)
|
||||
and n = (cursor-node cursor) then (previous-of n)
|
||||
until (null n)
|
||||
finally (return (and n (move-cursor-< cursor n))))
|
||||
(loop for step below (- index (cursor-index cursor))
|
||||
and n = (cursor-node cursor) then (next-of n)
|
||||
until (null n)
|
||||
finally (return (and n (move-cursor-> cursor n))))))
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
:defsystem-depends-on (:asdf-package-system)
|
||||
:class :package-inferred-system
|
||||
:around-compile (lambda (thunk)
|
||||
(proclaim '(optimize (debug 0) (safety 1) (speed 3)))
|
||||
(proclaim '(optimize (debug 3) (safety 3) (speed 0)))
|
||||
(funcall thunk))
|
||||
:depends-on #.(append (uiop:read-file-form (merge-pathnames #p"dependencies.sexp" (or *load-pathname* *compile-file-pathname*)))
|
||||
'("sextant/org/all")
|
||||
|
|
|
|||
|
|
@ -43,13 +43,13 @@ Item {
|
|||
cache: true
|
||||
}
|
||||
|
||||
|
||||
onFocusedChanged: {
|
||||
if (focused)
|
||||
document.focusedItem = orgItem
|
||||
}
|
||||
|
||||
function forceCommit (update) { loader.item.forceCommit(update) }
|
||||
function setCursorPosition(index) { loader.item.setCursorPosition(index) }
|
||||
function setCursorPositionAtEnd (fix) { loader.item.setCursorPositionAtEnd(fix) }
|
||||
function editRawText () { loader.item.editRawText() }
|
||||
}
|
||||
|
|
|
|||
|
|
@ -40,18 +40,18 @@ TextArea {
|
|||
if (index > 0 && text[0] != sentinelChar) {
|
||||
var textEmpty = text.length == 0
|
||||
forceCommit(false)
|
||||
document.focusedIndex = index - 1
|
||||
var focusedItem = document.focusedItem
|
||||
focusedItem.setCursorPositionAtEnd(!textEmpty)
|
||||
Lisp.call("models:join-node", index - 1, true)
|
||||
focusedItem.editRawText()
|
||||
/* document.focusedIndex = index - 1 */
|
||||
/* var focusedItem = document.focusedItem */
|
||||
/* focusedItem.setCursorPositionAtEnd(!textEmpty) */
|
||||
Lisp.call("models:join-node", index, true)
|
||||
/* focusedItem.editRawText() */
|
||||
} else {
|
||||
var split = text.indexOf("\n")
|
||||
if (split != -1) {
|
||||
forceCommit(false)
|
||||
Lisp.call("models:split-node", index, text.substring(index > 0 ? 1 : 0, split), text.substring(split + 1), true)
|
||||
document.focusedIndex = index + 1
|
||||
document.focusedItem.editRawText()
|
||||
/* document.focusedIndex = index + 1 */
|
||||
/* document.focusedItem.editRawText() */
|
||||
} else {
|
||||
lastText = getText()
|
||||
textModified = lastText != rawtext
|
||||
|
|
@ -105,6 +105,10 @@ TextArea {
|
|||
}
|
||||
}
|
||||
|
||||
function setCursorPosition(index) {
|
||||
cursorPosition = index
|
||||
}
|
||||
|
||||
function setCursorPositionAt(x, y) {
|
||||
cursorPosition = positionAt(x, y)
|
||||
}
|
||||
|
|
|
|||
|
|
@ -27,6 +27,7 @@ MouseArea {
|
|||
function editRawText() { editing = true }
|
||||
|
||||
function forceCommit (update) { edit.forceCommit(update) }
|
||||
function setCursorPosition(index) { edit.setCursorPosition(index) }
|
||||
function setCursorPositionAt (x, y) { edit.setCursorPositionAt(x, y) }
|
||||
function setCursorPositionAtEnd (fix) { edit.setCursorPositionAtEnd(fix) }
|
||||
}
|
||||
|
|
|
|||
|
|
@ -39,6 +39,14 @@ Page {
|
|||
focusedItem = null
|
||||
}
|
||||
|
||||
function focusIndex(index, edit, cursorPos) {
|
||||
focusedIndex = index
|
||||
if (edit) {
|
||||
focusedItem.setCursorPosition(cursorPos)
|
||||
focusedItem.editRawText()
|
||||
}
|
||||
}
|
||||
|
||||
function refreshToolbar(undoEnabled, redoEnabled, saveEnabled) {
|
||||
undo.enabled = undoEnabled
|
||||
redo.enabled = redoEnabled
|
||||
|
|
|
|||
13
sextant.pro
13
sextant.pro
|
|
@ -16,20 +16,21 @@ LISP_FILES = make.lisp \
|
|||
lisp/local-projects/sextant/options/config.lisp \
|
||||
lisp/local-projects/sextant/options/options.lisp \
|
||||
lisp/local-projects/sextant/options/all.lisp \
|
||||
lisp/local-projects/sextant/dependencies.sexp \
|
||||
lisp/local-projects/sextant/models/utils.lisp \
|
||||
lisp/local-projects/sextant/models/org-model.lisp \
|
||||
lisp/local-projects/sextant/models/files-model.lisp \
|
||||
lisp/local-projects/sextant/models/commands.lisp \
|
||||
lisp/local-projects/sextant/org/nodes.lisp \
|
||||
lisp/local-projects/sextant/org/cursor.lisp \
|
||||
lisp/local-projects/sextant/org/parser.lisp \
|
||||
lisp/local-projects/sextant/org/printer.lisp \
|
||||
lisp/local-projects/sextant/org/all.lisp \
|
||||
lisp/local-projects/sextant/models/actions.lisp \
|
||||
lisp/local-projects/sextant/models/commands.lisp \
|
||||
lisp/local-projects/sextant/models/cursor.lisp \
|
||||
lisp/local-projects/sextant/models/files-model.lisp \
|
||||
lisp/local-projects/sextant/models/org-model.lisp \
|
||||
lisp/local-projects/sextant/models/utils.lisp \
|
||||
lisp/local-projects/sextant/models/all.lisp \
|
||||
lisp/local-projects/sextant/sextant.lisp \
|
||||
lisp/local-projects/sextant/sextant.asd \
|
||||
lisp/local-projects/sextant/dependencies.sexp \
|
||||
lisp/local-projects/sextant/sextant.asd
|
||||
|
||||
lisp.output = libsextant.a
|
||||
lisp.commands = $$PWD/sextant-bootstrap -platform minimal -make
|
||||
|
|
|
|||
11
tests.lisp
11
tests.lisp
|
|
@ -307,4 +307,15 @@ line 4
|
|||
(check-visible-cursor cursor line-3 6 1)
|
||||
(check-cursor cursor line-3 6 1))))
|
||||
|
||||
(test goto-index
|
||||
(with-test-org-1
|
||||
(let ((cursor (make-cursor test-org preamble-1 0 0)))
|
||||
(setf cursor (goto-index cursor 4))
|
||||
(check-cursor cursor line-2 4 4)
|
||||
(setf cursor (goto-index cursor 9))
|
||||
(check-cursor cursor line-5 9 9)
|
||||
(setf cursor (goto-index cursor 0))
|
||||
(check-cursor cursor preamble-1 0 0)
|
||||
(is (null (goto-index cursor 10))))))
|
||||
|
||||
(run! 'all-tests)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue