branch: externals/org-real
commit da816c28fc1d994c6933a9414a6d5b6a3d59c4a4
Merge: f80251e 58989c3
Author: Tyler Grinn <ty...@tygr.info>
Commit: Tyler Grinn <ty...@tygr.info>
Merge branch 'next' into 'main'
# Jump to location when entering org real mode
With either org-real-world or org-real-headlines, org-real will try to find
and jump to the matching box if point is in a link or a headline, respectively.
# Reworked flexible layout
flex-adjust no longer rearranges children, is faster.
# Reworked cycle-down/up
Now uses Cartesian distance to find the next box to jump to.
See merge request tygrdev/org-real!7
---
demo/garage.org | 30 +--
org-real.el | 670 +++++++++++++++++++++++++++++---------------------------
2 files changed, 367 insertions(+), 333 deletions(-)
diff --git a/demo/garage.org b/demo/garage.org
index ae95ec8..9cef143 100644
--- a/demo/garage.org
+++ b/demo/garage.org
@@ -1,17 +1,17 @@
* Items in the garage
- - [[real://garage/workbench?rel=in][workbench]]
- - [[real://garage/workbench?rel=in/paintbrush?rel=in front of][paintbrush]]
- - [[real://garage/workbench?rel=in/paintbrush?rel=in front of/wrench?rel=to
the left of][wrench]]
- - [[real://garage/workbench?rel=in/nails?rel=on top of/screwdriver?rel=on
top of][screwdriver]]
- - [[real://garage/workbench?rel=in/ratchet?rel=on top of][ratchet]]
- - [[real://garage/east wall?rel=in/rake?rel=on/hoe?rel=to the left
of/snowblower?rel=above/shovel?rel=above][shovel]]
- - [[real://garage/east wall?rel=in/rake?rel=on][rake]]
- - [[real://garage/workbench?rel=in/hammer?rel=on][hammer]]
- - [[real://garage/east wall?rel=in/rake?rel=on/hoe?rel=to the left of][hoe]]
- - [[real://garage/car?rel=in/air freshener?rel=in][air freshener]]
- - [[real://garage/workbench?rel=in/nails?rel=on top of][nails]]
- - [[real://garage/east wall?rel=in][East wall]]
- - [[real://garage/east wall?rel=in/rake?rel=on/hoe?rel=to the left
of/snowblower?rel=above][snowblower]]
- - [[real://garage/workbench?rel=in/hammer?rel=on/screws?rel=to the right
of][screws]]
+ - [[real://garage/workbench][workbench]]
+ - [[real://garage/workbench/paintbrush?rel=in front of][paintbrush]]
+ - [[real://garage/workbench/paintbrush?rel=in front of/wrench?rel=to the
left of][wrench]]
+ - [[real://garage/workbench/nails?rel=on top of/screwdriver?rel=on top
of][screwdriver]]
+ - [[real://garage/workbench/ratchet?rel=on top of][ratchet]]
+ - [[real://garage/east wall/rake?rel=on/hoe?rel=to the left
of/snowblower?rel=above/shovel?rel=above][shovel]]
+ - [[real://garage/east wall/rake?rel=on][rake]]
+ - [[real://garage/workbench/hammer?rel=on][hammer]]
+ - [[real://garage/east wall/rake?rel=on/hoe?rel=to the left of][hoe]]
+ - [[real://garage/car/air freshener][air freshener]]
+ - [[real://garage/workbench/nails?rel=on top of][nails]]
+ - [[real://garage/east wall][East wall]]
+ - [[real://garage/east wall/rake?rel=on/hoe?rel=to the left
of/snowblower?rel=above][snowblower]]
+ - [[real://garage/workbench/hammer?rel=on/screws?rel=to the right
of][screws]]
- [[real://garage/saw?rel=on][saw]]
- - [[real://garage/workbench?rel=in/paintbrush?rel=in front of/wrench?rel=to
the left of/pliers?rel=below][pliers]]
+ - [[real://garage/workbench/paintbrush?rel=in front of/wrench?rel=to the
left of/pliers?rel=below][pliers]]
diff --git a/org-real.el b/org-real.el
index 3f13785..b8c14f2 100644
--- a/org-real.el
+++ b/org-real.el
@@ -1,7 +1,7 @@
;;; org-real.el --- Keep track of real things as org-mode links -*-
lexical-binding: t -*-
;; Author: Tyler Grinn <tylergr...@gmail.com>
-;; Version: 0.4.0
+;; Version: 0.4.1
;; File: org-real.el
;; Package-Requires: ((emacs "26.1"))
;; Keywords: tools
@@ -212,106 +212,6 @@
'("in" "on" "behind")
"List of prepositions for which boxes are flexibly added to their parent.")
-;;;; Interactive functions
-
-(defun org-real-world ()
- "View all real links in the current buffer."
- (interactive)
- (org-real--pp
- (org-real--merge
- (mapcar
- (lambda (containers)
- (org-real--make-instance 'org-real-box containers))
- (org-real--parse-buffer)))
- nil nil t))
-
-(defun org-real-headlines ()
- "View all org headlines as an org real diagram.
-
-MAX-LEVEL is the maximum level to show headlines for."
- (interactive)
- (org-real--pp
- (org-real--parse-headlines)
- nil
- 'display-buffer-same-window
- t 1 2))
-
-(defun org-real-apply ()
- "Apply any change from the real link at point to the current buffer."
- (interactive)
- (let (new-link replace-all)
- (cond
- ((org-in-regexp org-link-bracket-re 1)
- (setq new-link (match-string-no-properties 1)))
- ((org-in-regexp org-link-plain-re)
- (setq new-link (org-unbracket-string "<" ">" (match-string 0)))))
- (when (and new-link
- (string= "real" (ignore-errors (url-type (url-generic-parse-url
new-link)))))
- (let ((new-containers (reverse (org-real--parse-url new-link
(point-marker)))))
- (while new-containers
- (let ((primary (plist-get (car new-containers) :name))
- (changes '())
- old-containers)
- (org-element-map (org-element-parse-buffer) 'link
- (lambda (old-link)
- (when (string= (org-element-property :type old-link) "real")
- (setq old-containers (reverse (org-real--parse-url
- (org-element-property
:raw-link old-link)
- (set-marker (point-marker)
(org-element-property :begin old-link)))))
- (when-let* ((new-index 0)
- (old-index (seq-position
- old-containers
- primary
- (lambda (a b) (string= (plist-get a
:name) b))))
- (begin (org-element-property :begin old-link))
- (end (org-element-property :end old-link))
- (replace-link (org-real--to-link
- (reverse
- (append (cl-subseq
old-containers 0 old-index)
- new-containers)))))
- (when (catch 'conflict
- (if (not (= (length new-containers) (- (length
old-containers) old-index)))
- (throw 'conflict t))
- (while (< new-index (length new-containers))
- (if (or (not (string= (plist-get (nth new-index
new-containers) :name)
- (plist-get (nth old-index
old-containers) :name)))
- (not (string= (plist-get (nth new-index
new-containers) :rel)
- (plist-get (nth old-index
old-containers) :rel))))
- (throw 'conflict t))
- (setq new-index (+ 1 new-index))
- (setq old-index (+ 1 old-index)))
- nil)
- (let* ((old-desc (save-excursion
- (and (goto-char begin)
- (org-in-regexp
org-link-bracket-re 1)
- (match-end 2)
- (match-string-no-properties 2))))
- (new-link (org-real--link-make-string
replace-link old-desc)))
- (push
- `(lambda ()
- (save-excursion
- (delete-region ,begin ,end)
- (goto-char ,begin)
- (insert ,new-link)))
- changes)))))))
- (when (and changes
- (or replace-all (let ((response
- (read-char-choice
- (concat
- "Replace all occurrences of "
- primary
- " in current buffer? y/n/a ")
- '(?y ?Y ?n ?N ?a ?A)
- t)))
- (cond
- ((or (= response ?y) (= response
?Y)) t)
- ((or (= response ?n) (= response
?N)) nil)
- ((or (= response ?a) (= response ?A))
- (setq replace-all t))))))
- (mapc 'funcall changes)))
- (pop new-containers)))))
- (message nil))
-
;;;; Org Real mode
(defvar org-real--box-ring '()
@@ -353,36 +253,44 @@ MAX-LEVEL is the maximum level to show headlines for."
(defun org-real-mode-cycle-down ()
"Cycle to the next button on the row below."
(interactive)
- (let ((col (current-column)))
- (forward-line 1)
- (org-real-mode-cycle)
- (move-to-column col)
- (let ((pos (point)))
- (goto-char (seq-reduce
- (lambda (closest p)
- (if (< (abs (- pos p))
- (abs (- pos closest)))
- p
- closest))
- org-real--box-ring
- 1.0e+INF)))))
+ (let ((coords (cons (line-number-at-pos) (current-column))))
+ (goto-char (seq-reduce
+ (lambda (closest pos)
+ (goto-char pos)
+ (if (<= (line-number-at-pos) (car coords))
+ closest
+ (let* ((pos-coords (cons (line-number-at-pos)
(current-column)))
+ (pos-dist (sqrt (+ (expt (- (car pos-coords) (car
coords)) 2)
+ (expt (- (cdr pos-coords) (cdr
coords)) 2))))
+ (closest-coords (and (goto-char closest) (cons
(line-number-at-pos) (current-column))))
+ (closest-dist (sqrt (+ (expt (- (car
closest-coords) (car coords)) 2)
+ (expt (- (cdr
closest-coords) (cdr coords)) 2)))))
+ (if (< pos-dist closest-dist)
+ pos
+ closest))))
+ org-real--box-ring
+ (point-max)))))
(defun org-real-mode-cycle-up ()
"Cycle to the next button on the row above."
(interactive)
- (let ((col (current-column)))
- (forward-line -1)
- (org-real-mode-uncycle)
- (move-to-column col)
- (let ((pos (point)))
- (goto-char (seq-reduce
- (lambda (closest p)
- (if (< (abs (- pos p))
- (abs (- pos closest)))
- p
- closest))
- org-real--box-ring
- 1.0e+INF)))))
+ (let ((coords (cons (line-number-at-pos) (current-column))))
+ (goto-char (seq-reduce
+ (lambda (closest pos)
+ (goto-char pos)
+ (if (>= (line-number-at-pos) (car coords))
+ closest
+ (let* ((pos-coords (cons (line-number-at-pos)
(current-column)))
+ (pos-dist (sqrt (+ (expt (- (car pos-coords) (car
coords)) 2)
+ (expt (- (cdr pos-coords) (cdr
coords)) 2))))
+ (closest-coords (and (goto-char closest) (cons
(line-number-at-pos) (current-column))))
+ (closest-dist (sqrt (+ (expt (- (car
closest-coords) (car coords)) 2)
+ (expt (- (cdr
closest-coords) (cdr coords)) 2)))))
+ (if (< pos-dist closest-dist)
+ pos
+ closest))))
+ org-real--box-ring
+ (point-min)))))
(defun org-real-mode-cycle-visibility ()
"Cycle visibility on all children in the current buffer."
@@ -401,7 +309,7 @@ MAX-LEVEL is the maximum level to show headlines for."
(defun org-real-mode-redraw ()
"Redraw `org-real--current-box' in the current buffer."
(org-real--make-dirty org-real--current-box)
- (org-real--flex-adjust org-real--current-box)
+ (org-real--flex-adjust org-real--current-box org-real--current-box)
(let ((inhibit-read-only t))
(erase-buffer)
(if org-real--current-containers
@@ -452,6 +360,136 @@ The following commands are available:
("n" . org-real-mode-cycle-down)
("<backtab>" . org-real-mode-cycle-visibility)))
+;;;; Interactive functions
+
+(defun org-real-world ()
+ "View all real links in the current buffer."
+ (interactive)
+ (let ((link (cond
+ ((org-in-regexp org-link-bracket-re 1)
+ (match-string-no-properties 1))
+ ((org-in-regexp org-link-plain-re)
+ (org-unbracket-string "<" ">" (match-string 0)))))
+ (world (org-real--merge
+ (mapcar
+ (lambda (containers)
+ (org-real--make-instance 'org-real-box containers))
+ (org-real--parse-buffer)))))
+ (org-real--pp world nil nil t)
+ (if (and link (string= "real" (ignore-errors (url-type
(url-generic-parse-url link)))))
+ (let ((containers (reverse (org-real--parse-url link)))
+ match)
+ (while (and containers (or (not match) (not (org-real--is-visible
match t))))
+ (setq match (org-real--find-matching
+ (org-real-box :name (plist-get (pop containers)
:name))
+ world)))
+ (when match
+ (let ((top (org-real--get-top match))
+ (left (org-real--get-left match)))
+ (run-with-timer
+ 0 nil
+ (lambda ()
+ (forward-line (- (+ org-real--current-offset top 1
org-real-padding-y)
+ (line-number-at-pos)))
+ (move-to-column (+ left 1 org-real-padding-x))))))))))
+
+(defun org-real-headlines ()
+ "View all org headlines as an org real diagram.
+
+MAX-LEVEL is the maximum level to show headlines for."
+ (interactive)
+ (let ((path (seq-filter 'identity (append (list (org-entry-get nil "ITEM"))
(reverse (org-get-outline-path)))))
+ (world (save-excursion (org-real--parse-headlines)))
+ match)
+ (org-real--pp world nil 'display-buffer-same-window t 1 2)
+ (while (and path (or (not match) (not (org-real--is-visible match t))))
+ (setq match (org-real--find-matching (org-real-box :name (pop path))
world)))
+ (when match
+ (let ((top (org-real--get-top match))
+ (left (org-real--get-left match)))
+ (run-with-timer
+ 0 nil
+ (lambda ()
+ (forward-line (- (+ org-real--current-offset top 1
org-real-padding-y)
+ (line-number-at-pos)))
+ (move-to-column (+ left 1 org-real-padding-x))))))))
+
+(defun org-real-apply ()
+ "Apply any change from the real link at point to the current buffer."
+ (interactive)
+ (let (new-link replace-all)
+ (cond
+ ((org-in-regexp org-link-bracket-re 1)
+ (setq new-link (match-string-no-properties 1)))
+ ((org-in-regexp org-link-plain-re)
+ (setq new-link (org-unbracket-string "<" ">" (match-string 0)))))
+ (when (and new-link
+ (string= "real" (ignore-errors (url-type (url-generic-parse-url
new-link)))))
+ (let ((new-containers (reverse (org-real--parse-url new-link
(point-marker)))))
+ (while new-containers
+ (let ((primary (plist-get (car new-containers) :name))
+ (changes '())
+ old-containers)
+ (org-element-map (org-element-parse-buffer) 'link
+ (lambda (old-link)
+ (when (string= (org-element-property :type old-link) "real")
+ (setq old-containers (reverse (org-real--parse-url
+ (org-element-property
:raw-link old-link)
+ (set-marker (point-marker)
(org-element-property :begin old-link)))))
+ (when-let* ((new-index 0)
+ (old-index (seq-position
+ old-containers
+ primary
+ (lambda (a b) (string= (plist-get a
:name) b))))
+ (begin (org-element-property :begin old-link))
+ (end (org-element-property :end old-link))
+ (replace-link (org-real--to-link
+ (reverse
+ (append (cl-subseq
old-containers 0 old-index)
+ new-containers)))))
+ (when (catch 'conflict
+ (if (not (= (length new-containers) (- (length
old-containers) old-index)))
+ (throw 'conflict t))
+ (while (< new-index (length new-containers))
+ (if (or (not (string= (plist-get (nth new-index
new-containers) :name)
+ (plist-get (nth old-index
old-containers) :name)))
+ (not (string= (plist-get (nth new-index
new-containers) :rel)
+ (plist-get (nth old-index
old-containers) :rel))))
+ (throw 'conflict t))
+ (setq new-index (+ 1 new-index))
+ (setq old-index (+ 1 old-index)))
+ nil)
+ (let* ((old-desc (save-excursion
+ (and (goto-char begin)
+ (org-in-regexp
org-link-bracket-re 1)
+ (match-end 2)
+ (match-string-no-properties 2))))
+ (new-link (org-real--link-make-string
replace-link old-desc)))
+ (push
+ `(lambda ()
+ (save-excursion
+ (delete-region ,begin ,end)
+ (goto-char ,begin)
+ (insert ,new-link)))
+ changes)))))))
+ (when (and changes
+ (or replace-all (let ((response
+ (read-char-choice
+ (concat
+ "Replace all occurrences of "
+ primary
+ " in current buffer? y/n/a ")
+ '(?y ?Y ?n ?N ?a ?A)
+ t)))
+ (cond
+ ((or (= response ?y) (= response
?Y)) t)
+ ((or (= response ?n) (= response
?N)) nil)
+ ((or (= response ?a) (= response ?A))
+ (setq replace-all t))))))
+ (mapc 'funcall changes)))
+ (pop new-containers)))))
+ (message nil))
+
;;;; Pretty printing
(defun org-real--pp (box
@@ -674,6 +712,10 @@ ORIG is `org-insert-link', ARGS are the arguments passed
to it."
:type string)
(rel-box :initarg :rel-box
:type org-real-box)
+ (display-rel :initarg :display-rel
+ :type string)
+ (display-rel-box :initarg :display-rel-box
+ :type org-real-box)
(x-order :initarg :x-order
:initform 0
:type number)
@@ -783,8 +825,11 @@ non-nil, skip setting :primary slot on the last box."
(let ((all-from-children (org-real--get-children from 'all)))
(with-slots ((to-children children) (to-behind behind)) to
(if (= 1 (length all-from-children))
- (org-real--flex-add (car all-from-children) to)
- (org-real--flex-add from to)))))))
+ (progn
+ (oset (car all-from-children) :flex t)
+ (org-real--add-child to (car all-from-children)))
+ (oset from :flex t)
+ (org-real--add-child to from)))))))
(cl-defmethod org-real--update-visibility ((box org-real-box))
"Update visibility of BOX and all of its children."
@@ -1130,7 +1175,7 @@ If INCLUDE-ON-TOP is non-nil, also include height on top
of box."
(cl-defmethod org-real--create-cursor-function ((box org-real-box))
"Create cursor functions for entering and leaving BOX."
- (with-slots (rel rel-box name metadata) box
+ (with-slots (rel rel-box display-rel-box display-rel name metadata) box
(let (tooltip-timer)
(lambda (_window _oldpos dir)
(let ((inhibit-read-only t))
@@ -1140,17 +1185,27 @@ If INCLUDE-ON-TOP is non-nil, also include height on
top of box."
(if (slot-boundp box :metadata)
(setq tooltip-timer (org-real--tooltip metadata))
(if (and (slot-boundp box :name) (slot-boundp box :rel))
- (with-slots ((rel-name name)) rel-box
+ (with-slots ((rel-name name)) (if (slot-boundp box
:display-rel-box)
+ display-rel-box
+ rel-box)
(setq tooltip-timer
(org-real--tooltip
(with-temp-buffer
(insert (format "The %s is %s the %s."
- name rel rel-name))
+ name
+ (if (slot-boundp box
:display-rel)
+ display-rel
+ rel)
+ rel-name))
(let ((fill-column
org-real-tooltip-max-width))
(fill-paragraph t))
(buffer-string)))))))
- (if (slot-boundp box :rel-box)
- (org-real--draw rel-box 'rel))
+ (if (slot-boundp box :display-rel-box)
+ (if (org-real--is-visible display-rel-box t)
+ (org-real--draw display-rel-box 'rel))
+ (if (and (slot-boundp box :rel-box)
+ (org-real--is-visible rel-box t))
+ (org-real--draw rel-box 'rel)))
(org-real--draw box 'selected))
(if tooltip-timer (cancel-timer tooltip-timer))
(if (slot-boundp box :rel-box)
@@ -1231,11 +1286,18 @@ BOX is the box the button is being made for."
;;;; Private class methods
-(cl-defmethod org-real--is-visible ((box org-real-box))
- "Determine if BOX is visible according to `org-real--visibility'."
- (with-slots (level) box
- (or (= 0 org-real--visibility)
- (<= level org-real--visibility))))
+(cl-defmethod org-real--is-visible ((box org-real-box) &optional calculate)
+ "Determine if BOX is visible according to `org-real--visibility'.
+
+If CALCULATE, determine if the box has been expanded manually."
+ (if calculate
+ (with-slots (parent) box
+ (seq-find
+ (lambda (sibling) (eq sibling box))
+ (org-real--get-children parent)))
+ (with-slots (level) box
+ (or (= 0 org-real--visibility)
+ (<= level org-real--visibility)))))
(cl-defmethod org-real--get-children ((box org-real-box) &optional arg)
"Get all visible children of BOX.
@@ -1261,9 +1323,14 @@ If optional ARG is 'hidden, only return hidden children"
If FORCE-VISIBLE, always make CHILD visible in PARENT."
(oset child :parent parent)
(with-slots (children hidden-children) parent
- (if (or force-visible (org-real--is-visible child))
- (setq children (org-real--push children child))
- (setq hidden-children (org-real--push hidden-children child)))))
+ (if (org-real--get-all hidden-children)
+ (progn
+ (setq hidden-children (org-real--push hidden-children child))
+ (if (or force-visible (org-real--is-visible child))
+ (cl-rotatef children hidden-children)))
+ (if (or force-visible (org-real--is-visible child))
+ (setq children (org-real--push children child))
+ (setq hidden-children (org-real--push hidden-children child))))))
(cl-defmethod org-real--get-world ((box org-real-box))
"Get the top most box related to BOX."
@@ -1331,88 +1398,62 @@ PREV must already exist in PARENT."
:name (plist-get container :name)
:locations (list (plist-get container :loc)))))
(with-slots
- ((cur-x x-order)
- (cur-y y-order)
- (cur-level level)
+ ((cur-level level)
(cur-behind behind)
(cur-on-top on-top)
- (cur-in-front in-front))
+ (cur-in-front in-front)
+ display-rel
+ display-rel-box
+ flex)
box
(with-slots
- ((prev-x x-order)
- (prev-y y-order)
- (prev-level level)
+ ((prev-level level)
(prev-behind behind)
(prev-on-top on-top)
(prev-in-front in-front))
prev
(cond
((or (string= rel "in") (string= rel "on"))
+ (setq flex t)
(setq cur-level (+ 1 prev-level))
(setq cur-behind prev-behind))
((string= rel "behind")
+ (setq flex t)
(setq cur-level (+ 1 prev-level))
(setq cur-behind t))
((string= rel "in front of")
(setq cur-level (+ 1 prev-level))
- (setq cur-y 1.0e+INF)
(setq cur-behind prev-behind)
(setq cur-in-front t))
((string= rel "on top of")
(setq cur-level (+ 1 prev-level))
- (setq cur-y -1.0e+INF)
(setq cur-behind prev-behind)
(setq cur-on-top t))
((member rel '("above" "below"))
(setq cur-behind prev-behind)
- (setq cur-x prev-x)
(cond
((and prev-in-front (string= rel "below"))
+ (setq display-rel-box prev)
(while (with-slots (in-front) prev in-front)
(setq prev (with-slots (parent) prev parent)))
(setq parent (with-slots (parent) prev parent)))
((and prev-on-top (string= rel "above"))
+ (setq display-rel-box prev)
(while (with-slots (on-top) prev on-top)
(setq prev (with-slots (parent) prev parent)))
(setq parent (with-slots (parent) prev parent)))
((and prev-on-top (string= rel "below"))
+ (setq display-rel rel)
+ (setq display-rel-box prev)
(setq rel "in")
- (setq prev parent)))
- (setq cur-level (+ 1 (with-slots (level) parent level)))
- (let ((sibling-y-orders
- (mapcar
- (lambda (sibling) (with-slots (y-order) sibling y-order))
- (seq-filter
- (lambda (sibling)
- (with-slots (in-front on-top) sibling
- (not (or in-front on-top))))
- (org-real--get-children parent 'all)))))
- (if (or prev-on-top (string= rel "above"))
- (setq cur-y (- (apply 'min 0 sibling-y-orders) 1))
- (setq cur-y (+ 1 (apply 'max 0 sibling-y-orders))))))
+ (setq prev parent))))
((member rel '("to the left of" "to the right of"))
(setq cur-level prev-level)
- (setq cur-y prev-y)
(setq cur-behind prev-behind)
(setq cur-on-top prev-on-top)
- (setq cur-in-front prev-in-front)
- (if (string= rel "to the left of")
- (setq cur-x prev-x)
- (setq cur-x (+ 1 prev-x)))
- (let ((row-siblings (seq-filter
- (lambda (sibling)
- (with-slots (y-order) sibling
- (= prev-y y-order)))
- (org-real--get-children parent 'all))))
- (mapc
- (lambda (sibling)
- (with-slots (x-order) sibling
- (if (>= x-order cur-x)
- (setq x-order (+ 1 x-order)))))
- row-siblings))))
+ (setq cur-in-front prev-in-front)))
(oset box :rel rel)
(oset box :rel-box prev)
- (if (not (slot-boundp box :name)) (setq cur-level 0))
(if (member rel org-real-children-prepositions)
(progn
(org-real--add-child prev box)
@@ -1447,19 +1488,20 @@ PREV must already exist in PARENT."
(cl-defmethod org-real--add-next ((next org-real-box)
(prev org-real-box)
- &optional force-visible)
+ &optional force-visible skip-next)
"Add NEXT to world according to its relationship to PREV.
If FORCE-VISIBLE, show the box regardless of
-`org-real--visibility'."
+`org-real--visibility'
+
+If SKIP-NEXT, don't add expansion slots for boxes related to
+NEXT."
(with-slots
(children
hidden-children
parent
(prev-level level)
(prev-primary primary)
- (prev-y y-order)
- (prev-x x-order)
(prev-behind behind)
(prev-in-front in-front)
(prev-on-top on-top))
@@ -1468,9 +1510,8 @@ If FORCE-VISIBLE, show the box regardless of
(rel
rel-box
extra-data
+ flex
(next-level level)
- (next-y y-order)
- (next-x x-order)
(next-behind behind)
(next-in-front in-front)
(next-on-top on-top))
@@ -1494,82 +1535,100 @@ If FORCE-VISIBLE, show the box regardless of
(cond
((member rel '("to the left of" "to the right of"))
(setq next-level prev-level)
- (setq next-y prev-y)
(setq next-behind prev-behind)
(setq next-in-front prev-in-front)
- (setq next-on-top prev-on-top)
- (if (string= rel "to the left of")
- (setq next-x prev-x)
- (setq next-x (+ 1 prev-x)))
- (let ((row-siblings (seq-filter
- (lambda (sibling)
- (with-slots (y-order) sibling
- (= y-order prev-y)))
- (org-real--get-children parent 'all))))
- (mapc
- (lambda (sibling)
- (with-slots (x-order) sibling
- (if (>= x-order next-x)
- (setq x-order (+ 1 x-order)))))
- row-siblings)))
+ (setq next-on-top prev-on-top))
((member rel '("above" "below"))
(setq next-level prev-level)
- (setq next-x prev-x)
- (setq next-behind prev-behind)
- (let ((sibling-y-orders (mapcar
- (lambda (sibling) (with-slots (y-order)
sibling y-order))
- (seq-filter
- (lambda (sibling)
- (with-slots (in-front on-top) sibling
- (not (or in-front on-top))))
- (org-real--get-children parent 'all)))))
- (if (string= rel "above")
- (setq next-y (- (apply 'min 0 sibling-y-orders) 1))
- (setq next-y (+ 1 (apply 'max 0 sibling-y-orders))))))
+ (setq next-behind prev-behind))
((or next-on-top next-in-front)
(setq next-level (+ 1 prev-level))
- (setq next-x (+ 1 (apply 'max 0
- (mapcar
- (lambda (child) (with-slots (x-order)
child x-order))
- (seq-filter
- (lambda (child)
- (with-slots (in-front on-top) child
- (and (eq next-in-front in-front)
- (eq next-on-top on-top))))
- (org-real--get-children prev 'all))))))
(setq next-behind prev-behind))
((member rel '("in" "on" "behind"))
+ (setq flex t)
+ (setq next-level (+ 1 prev-level)))
+ ((string= rel "behind")
+ (setq flex t)
(setq next-level (+ 1 prev-level))
- (setq next-behind prev-behind)))
- (if (not (slot-boundp next :name)) (setq next-level 0))
+ (setq next-behind t)))
(oset next :rel-box prev)
(if (member rel org-real-children-prepositions)
- (if (member rel org-real-flex-prepositions)
- (org-real--flex-add next prev)
- (org-real--add-child prev next force-visible))
+ (org-real--add-child prev next force-visible)
(org-real--add-child parent next force-visible))
- (if children-boxes
- (oset next :expand-children
- '(lambda (box)
- (mapc
- (lambda (child) (org-real--add-next child box))
- (alist-get 'children (oref box :extra-data))))))
- (if sibling-boxes
- (oset next :expand-siblings
- '(lambda (box)
- (mapc
- (lambda (sibling) (org-real--add-next sibling box t))
- (alist-get 'siblings (oref box :extra-data)))))))))))
+ (unless skip-next
+ (if children-boxes
+ (oset next :expand-children
+ '(lambda (box)
+ (mapc
+ (lambda (child) (org-real--add-next child box))
+ (alist-get 'children (oref box :extra-data))))))
+ (if sibling-boxes
+ (oset next :expand-siblings
+ '(lambda (box)
+ (mapc
+ (lambda (sibling) (org-real--add-next sibling box t))
+ (alist-get 'siblings (oref box
:extra-data))))))))))))
+
+(cl-defmethod org-real--position-box ((box org-real-box))
+ "Adjust BOX's position."
+ (with-slots (rel-box rel parent x-order y-order on-top in-front parent) box
+ (with-slots ((rel-y y-order) (rel-x x-order)) rel-box
+ (unless (org-real--find-matching box rel-box)
+ (if on-top
+ (setq y-order -1.0e+INF))
+ (if in-front
+ (setq y-order 1.0e+INF))
+ (cond
+ ((member rel '("to the left of" "to the right of"))
+ (setq y-order rel-y)
+ (if (string= rel "to the left of")
+ (setq x-order rel-x)
+ (setq x-order (+ 1 rel-x)))
+ (let ((row-siblings (seq-filter
+ (lambda (sibling)
+ (with-slots ((sibling-y y-order)) sibling
+ (= sibling-y rel-y)))
+ (org-real--get-children parent 'all))))
+ (mapc
+ (lambda (sibling)
+ (with-slots ((sibling-x x-order)) sibling
+ (if (>= sibling-x x-order)
+ (setq sibling-x (+ 1 sibling-x)))))
+ row-siblings)))
+ ((member rel '("above" "below"))
+ (setq x-order rel-x)
+ (let ((sibling-y-orders (mapcar
+ (lambda (sibling) (with-slots (y-order)
sibling y-order))
+ (seq-filter
+ (lambda (sibling)
+ (with-slots (in-front on-top) sibling
+ (not (or in-front on-top))))
+ (org-real--get-children parent 'all)))))
+ (if (string= rel "above")
+ (setq y-order (- (apply 'min 0 sibling-y-orders) 1))
+ (setq y-order (+ 1 (apply 'max 0 sibling-y-orders))))))
+ ((or on-top in-front)
+ (setq x-order (+ 1 (apply 'max 0
+ (mapcar
+ (lambda (child) (with-slots (x-order)
child x-order))
+ (seq-filter
+ (lambda (child)
+ (with-slots ((child-in-front in-front)
(child-on-top on-top)) child
+ (and (eq in-front child-in-front)
+ (eq on-top child-on-top))))
+ (org-real--get-children rel-box
'all))))))))
+ (org-real--add-child parent box t)))))
+
(cl-defmethod org-real--flex-add ((box org-real-box)
- (parent org-real-box))
+ (parent org-real-box)
+ (world org-real-box))
"Add BOX to a PARENT box flexibly.
This function ignores the :rel slot and adds BOX in such a way
-that the width of the world is kept below `org-real-flex-width'
+that the width of the WORLD is kept below `org-real-flex-width'
characters if possible."
- (let* ((world (org-real--get-world parent))
- (cur-width (org-real--get-width world)))
+ (let ((cur-width (org-real--get-width world)))
(org-real--make-dirty world)
(with-slots ((parent-level level) (parent-behind behind)) parent
(let* ((level (+ 1 parent-level))
@@ -1577,7 +1636,7 @@ characters if possible."
(lambda (sibling)
(with-slots (in-front on-top) sibling
(not (or in-front on-top))))
- (org-real--get-children parent 'all)))
+ (org-real--get-children parent)))
(last-sibling (and all-siblings
(seq-reduce
(lambda (max sibling)
@@ -1593,7 +1652,8 @@ characters if possible."
(oset box :flex t)
(oset box :behind parent-behind)
(org-real--apply-level box level)
- (org-real--add-child parent box)
+ (org-real--add-child parent box t)
+ (org-real--flex-adjust box world)
(when last-sibling
(with-slots
((last-sibling-y y-order)
@@ -1605,70 +1665,46 @@ characters if possible."
(org-real--make-dirty world)
(when (and (> new-width cur-width) (> new-width
org-real-flex-width))
(oset box :y-order (+ 1 last-sibling-y))
- (oset box :x-order 0)))))))))
-
-(cl-defmethod org-real--flex-adjust ((box org-real-box))
- "Adjust BOX x and y orders to try to fit BOX within `org-real-flex-width'."
- (let ((cur-width (org-real--get-width box))
- new-width)
- (org-real--flex-adjust-helper box box)
- (setq new-width (org-real--get-width box))
- (while (and (< new-width cur-width)
- (> new-width org-real-flex-width))
- (setq cur-width new-width)
- (org-real--flex-adjust-helper box box)
- (setq new-width (org-real--get-width box)))))
-
-(cl-defmethod org-real--flex-adjust-helper ((box org-real-box) (world
org-real-box))
+ (oset box :x-order 0)
+ (org-real--flex-adjust box world)))))))))
+
+(cl-defmethod org-real--partition (fn (collection org-real-box-collection))
+ "Partition COLLECTION into two collections using predicate FN."
+ (if (not (slot-boundp collection :box))
+ (list (org-real-box-collection) (org-real-box-collection))
+ (let ((pass (org-real-box-collection))
+ (fail (org-real-box-collection)))
+ (while (slot-boundp collection :box)
+ (with-slots (box next) collection
+ (if (funcall fn box)
+ (setq pass (org-real--push pass box))
+ (setq fail (org-real--push fail box)))
+ (if (slot-boundp collection :next)
+ (setq collection next)
+ (setq collection (org-real-box-collection)))))
+ (list pass fail))))
+
+(cl-defmethod org-real--flex-adjust ((box org-real-box) (world org-real-box))
"Adjust BOX x and y orders to try to fit WORLD within `org-real-flex-width'."
- (with-slots (flex parent) box
- (when flex
- (let ((cur-width (org-real--get-width world)))
- (when (> cur-width org-real-flex-width)
- (let ((left (org-real--get-left box))
- (width (org-real--get-width box)))
- (when (> (+ left width) org-real-flex-width)
- (org-real--make-dirty world)
- (when-let* ((all-siblings (seq-filter
- (lambda (sibling)
- (with-slots (in-front on-top)
sibling
- (not (or in-front on-top))))
- (org-real--get-children parent)))
- (last-sibling (seq-reduce
- (lambda (max sibling)
- (with-slots ((max-x x-order) (max-y
y-order)) max
- (with-slots
- ((sibling-x x-order)
- (sibling-y y-order))
- sibling
- (if (> sibling-y max-y)
- sibling
- (if (and (= max-y sibling-y)
(> sibling-x max-x))
- sibling
- max)))))
- all-siblings
- (org-real-box :y-order -1.0e+INF))))
- (with-slots
- ((last-sibling-y y-order)
- (last-sibling-x x-order))
- last-sibling
- (oset box :y-order last-sibling-y)
- (oset box :x-order (+ 1 last-sibling-x))
- (let ((when-last (org-real--get-width world)))
- (when (> when-last org-real-flex-width)
- (org-real--make-dirty world)
- (oset box :y-order (+ 1 last-sibling-y))
- (oset box :x-order 0)
- (let ((when-new-row (org-real--get-width world)))
- (when (>= when-new-row when-last)
- (org-real--make-dirty world)
- (oset box :y-order last-sibling-y)
- (oset box :x-order (+ 1 last-sibling-x))))))))))))))
- (mapc
- (lambda (child)
- (org-real--flex-adjust-helper child world))
- (org-real--get-children box)))
-
+ (with-slots (children) box
+ (let* ((partitioned (org-real--partition
+ (lambda (child) (with-slots (flex) child flex))
+ children))
+ (flex-children (org-real--get-all (car partitioned)))
+ (other-children (org-real--get-all (cadr partitioned))))
+ (setq children (org-real-box-collection))
+ (org-real--make-dirty world)
+ (mapc
+ (lambda (flex-child)
+ (org-real--flex-add flex-child box world))
+ flex-children)
+ (mapc
+ (lambda (other-child)
+ (if (not (slot-boundp other-child :rel-box))
+ (org-real--flex-add other-child box world)
+ (org-real--position-box other-child)
+ (org-real--flex-adjust other-child world)))
+ other-children))))
(cl-defmethod org-real--add-headline (headline
(parent org-real-box))
@@ -1687,14 +1723,14 @@ characters if possible."
(cddr headline)))
(children (alist-get 'children partitioned))
(siblings (alist-get 'siblings partitioned))
- (pos (goto-char (org-element-property :begin headline)))
- (columns (org-columns--collect-values))
+ (pos (org-element-property :begin headline))
+ (columns (save-excursion (goto-char pos)
(org-columns--collect-values)))
(max-column-length (apply 'max 0
(mapcar
(lambda (column)
(length (cadr (car column))))
columns)))
- (rel (or (org-entry-get nil "REL") "in"))
+ (rel (save-excursion (goto-char pos) (or (org-entry-get nil
"REL") "in")))
(level (if (member rel org-real-children-prepositions)
(+ 1 parent-level)
parent-level))
@@ -1899,7 +1935,6 @@ set to the :loc slot of each box."
t))))
container-matrix))
-
(defun org-real--parse-headlines ()
"Create an org real box from the current buffer's headlines."
(org-columns-get-format)
@@ -1911,14 +1946,13 @@ set to the :loc slot of each box."
(document (org-real-box :name title
:metadata ""
:locations (list (point-min-marker)))))
- (org-real--flex-add document world)
+ (org-real--flex-add document world world)
(mapc
(lambda (headline)
(org-real--add-headline headline document))
headlines)
world))
-
(defun org-real--to-link (containers)
"Create a link string from CONTAINERS."
(concat "real://"
