branch: externals/org-real
commit f3b5fc7d03401c64bad5415a577796c72d5fadd3
Author: Tyler Grinn <tylergr...@gmail.com>
Commit: Tyler Grinn <tylergr...@gmail.com>
More edge cases
---
demo/garage.org | 2 +-
org-real.el | 76 +++++++++++++++++++++++++++++++---------------------
tests/edge-cases.org | 30 ++++++++++++---------
3 files changed, 65 insertions(+), 43 deletions(-)
diff --git a/demo/garage.org b/demo/garage.org
index 2ad5cca..ae95ec8 100644
--- a/demo/garage.org
+++ b/demo/garage.org
@@ -14,4 +14,4 @@
- [[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/saw?rel=on][saw]]
- - [[real://garage/workbench?rel=in/hammer?rel=on/screws?rel=to the right
of/pliers?rel=above][pliers]]
+ - [[real://garage/workbench?rel=in/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 bbb0bf0..b8368a3 100644
--- a/org-real.el
+++ b/org-real.el
@@ -1090,8 +1090,8 @@ PREV must already exist in PARENT."
(if (>= x-order cur-x)
(setq x-order (+ 1 x-order)))))
row-siblings))))
- (oset box :rel-box prev)
(oset box :rel rel)
+ (oset box :rel-box prev)
(if (not (slot-boundp box :name)) (setq cur-level 0))
(let ((visible (or (= 0 org-real--visibility) (<= cur-level
org-real--visibility))))
(if (and prev (member rel '("in" "on" "behind" "in front of" "on
top of")))
@@ -1161,22 +1161,53 @@ If EXCLUDE-CHILDREN, only retrieve sibling boxes."
(with-slots (children) box
(apply 'append (mapcar 'org-real--expand (org-real--get-all
children))))))
+(cl-defmethod org-real--primary-boxes ((box org-real-box))
+ "Get a list of boxes from BOX which have no further relatives."
+ (if (slot-boundp box :name)
+ (if-let ((next-boxes (org-real--next box)))
+ (apply 'append (mapcar 'org-real--primary-boxes next-boxes))
+ (list box))
+ (with-slots (children) box
+ (apply 'append (mapcar 'org-real--primary-boxes (org-real--get-all
children))))))
+
+(cl-defmethod org-real--find-matching ((search-box org-real-box) (world
org-real-box))
+ "Find and add box to WORLD with a matching name as SEARCH-BOX."
+ (when (slot-boundp search-box :name)
+ (with-slots ((search-name name)) search-box
+ (seq-find
+ (lambda (box)
+ (and (slot-boundp box :name)
+ (string= search-name
+ (with-slots (name) box name))))
+ (org-real--expand world)))))
+
+(cl-defmethod org-real--add-matching ((box org-real-box) (match org-real-box))
+ "Add relatives of BOX to MATCH."
+ (oset match :primary (or (with-slots (primary) match primary)
+ (with-slots (primary) box primary)))
+ (oset match :locations (append (with-slots (locations) match locations)
+ (with-slots (locations) box locations)))
+ (let ((world (org-real--get-world match)))
+ (mapc
+ (lambda (next)
+ (if (not (org-real--find-matching next world))
+ (org-real--add-next next match)))
+ (org-real--next box))))
+
(cl-defmethod org-real--merge-into ((from org-real-box) (to org-real-box))
"Merge FROM box into TO box."
- (let ((from-boxes (reverse (org-real--expand from)))
- (to-boxes (org-real--expand to)))
- (unless (seq-some
- (lambda (from-box)
- (seq-some
- (lambda (to-box)
- (when (and (slot-boundp from-box :name)
- (slot-boundp to-box :name)
- (string= (with-slots (name) from-box name)
- (with-slots (name) to-box name)))
- (org-real--add-matching from-box to-box)
- t))
- to-boxes))
- from-boxes)
+ (let (match-found)
+ (mapc
+ (lambda (from-box)
+ (let ((match (org-real--find-matching from-box to)))
+ (while (and (not match) (slot-boundp from-box :rel-box))
+ (setq from-box (with-slots (rel-box) from-box rel-box))
+ (setq match (org-real--find-matching from-box to)))
+ (when match
+ (setq match-found t)
+ (org-real--add-matching from-box match))))
+ (org-real--primary-boxes from))
+ (unless match-found
(let ((all-from-children (with-slots (children hidden-children) from
(append (org-real--get-all children)
(org-real--get-all
hidden-children)))))
@@ -1185,21 +1216,6 @@ If EXCLUDE-CHILDREN, only retrieve sibling boxes."
(org-real--flex-add (car all-from-children) to)
(org-real--flex-add from to)))))))
-(cl-defmethod org-real--add-matching ((box org-real-box)
- (match org-real-box))
- "Add relatives to BOX to MATCH.
-
-MATCH is used to set the :rel-box and :parent slots on relatives
-of BOX."
- (oset match :primary (or (with-slots (primary) match primary)
- (with-slots (primary) box primary)))
- (oset match :locations (append (with-slots (locations) match locations)
- (with-slots (locations) box locations)))
- (mapc
- (lambda (next)
- (org-real--add-next next match))
- (org-real--next box)))
-
(cl-defmethod org-real--add-next ((next org-real-box)
(prev org-real-box)
&optional force-visible)
diff --git a/tests/edge-cases.org b/tests/edge-cases.org
index 3c8a2ba..0d41305 100644
--- a/tests/edge-cases.org
+++ b/tests/edge-cases.org
@@ -193,22 +193,28 @@
#+end_example
* Merging links
-** PASS Merges two boxes
+** PASS Merges a box on top of a box
#+begin_src org
- - [[real://thing3/thing2?rel=on top of/thing1?rel=to the right of]]
- - [[real://thing3/thing2?rel=on top of]]
+ - [[real://thing2/thing1?rel=on top of]]
+ - [[real://thing2/thing1?rel=on top of/above?rel=above]]
#+end_src
#+begin_example
- ┌──────────┐ ┌──────────┐
- │ │ │ │
- │ thing2 │ │ thing1 │
- │ │ │ │
- ┌──┴──────────┴──┴──────────┴──┐
- │ │
- │ thing3 │
- │ │
- └──────────────────────────────┘
+ ┌─────────┐
+ │ │
+ │ above │
+ │ │
+ └─────────┘
+
+ ┌──────────┐
+ │ │
+ │ thing1 │
+ │ │
+ ┌──┴──────────┴──┐
+ │ │
+ │ thing2 │
+ │ │
+ └────────────────┘
#+end_example
