[elpa] externals/org-real a5736f1 070/160: Created buttons that link back to the location of the link

[ELPA Syncer]

branch: externals/org-real
commit a5736f1295e4f8efad05243464ee97d3d82b2228
Author: Tyler Grinn <tylergrinn@gmail.com>
Commit: Tyler Grinn <tylergrinn@gmail.com>

    Created buttons that link back to the location of the link
---
 garage.org  |   3 ++
 org-real.el | 171 +++++++++++++++++++++++++++++++++++++++++++++++++-----------
 2 files changed, 144 insertions(+), 30 deletions(-)

diff --git a/garage.org b/garage.org
index f4a4cdb..c6bee47 100644
--- a/garage.org
+++ b/garage.org
@@ -4,6 +4,9 @@
   - [[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/hoe?rel=to the left 
of/snowblower?rel=above/shovel?rel=above][shovel]]
+  - [[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/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]]
diff --git a/org-real.el b/org-real.el
index 3d7d208..2df511e 100644
--- a/org-real.el
+++ b/org-real.el
@@ -91,12 +91,16 @@
   "Face for the last thing in a real link."
   :group 'org-real)
 
-;;;; Constants
+;;;; Constants & variables
 
 (defconst org-real-prepositions
   '("in" "on" "behind" "in front of" "above" "below" "to the left of" "to the 
right of" "on top of")
   "List of available prepositions for things.")
 
+(defvar org-real--tab-ring '()
+  "List of buffer positions of buttons in an Org Real diagram.")
+(make-variable-buffer-local 'org-real--tab-ring)
+
 ;;;; Interactive functions
 
 (defun org-real-world ()
@@ -109,6 +113,33 @@
        (org-real--make-instance 'org-real-box containers))
      (org-real--parse-buffer)))))
 
+;;;; Org Real mode
+
+(defun org-real-tab-cycle ()
+  "Cycle through buttons in the current Org Real buffer."
+  (interactive)
+  (if-let ((pos (seq-find (lambda (pos) (> pos (point))) org-real--tab-ring)))
+      (goto-char pos)))
+
+(defun org-real-tab-uncycle ()
+  "Cycle through buttons in the current Org Real buffer in reverse."
+  (interactive)
+  (if-let ((pos (seq-find (lambda (pos) (< pos (point))) (reverse 
org-real--tab-ring))))
+      (goto-char pos)))
+
+(define-derived-mode org-real-mode special-mode
+  "Org Real"
+  "Mode for viewing an org-real diagram.
+
+The following commands are available:
+
+\\{org-real-mode-map}"
+  :group 'org-mode
+  (toggle-truncate-lines t))
+
+(define-key org-real-mode-map (kbd "TAB") 'org-real-tab-cycle)
+(define-key org-real-mode-map (kbd "<backtab>") 'org-real-tab-uncycle)
+
 ;;;; Pretty printing
 
 (defun org-real--pp (box &optional containers)
@@ -122,17 +153,20 @@ describing where BOX is."
         (inhibit-read-only t)
         (buffer (get-buffer-create "Org Real")))
     (with-current-buffer buffer
+      (org-real-mode)
       (erase-buffer)
-      (toggle-truncate-lines t)
+      (setq org-real--tab-ring '())
       (if containers (org-real--pp-text containers))
       (let ((offset (- (line-number-at-pos)
                        org-real-margin-y
                        (* 2 org-real-padding-y))))
         (dotimes (_ (+ top height)) (insert (concat (make-string width ?\s) 
"\n")))
         (org-real--draw box offset)
-        (special-mode)))
+        (goto-char 0)
+        (setq org-real--tab-ring
+              (seq-sort '< org-real--tab-ring))))
     (display-buffer buffer `(display-buffer-pop-up-window
-                             (window-width . 80)
+                             (window-width . ,width)
                              (window-height . ,height)))))
 
 (defun org-real--pp-text (containers)
@@ -165,7 +199,7 @@ describing where BOX is."
 
 (defun org-real-follow (url &rest _)
   "Open a real link URL in a popup buffer."
-  (let* ((containers (org-real--parse-url url))
+  (let* ((containers (org-real--parse-url url (point-marker)))
          (box (org-real--make-instance 'org-real-box (copy-tree containers))))
     (if org-real-include-context
         (let* ((primary-name (plist-get (car (reverse containers)) :name))
@@ -188,7 +222,7 @@ describing where BOX is."
   "Complete a real link or edit EXISTING link."
   (let* ((container-matrix (org-real--parse-buffer))
          (containers (if existing
-                         (org-real--parse-url existing)
+                         (org-real--parse-url existing (point-marker))
                        (org-real--complete-thing "Thing: " container-matrix 
'()))))
     (catch 'confirm
       (while t
@@ -284,7 +318,7 @@ ORIG is `org-insert-link', ARGS are the arguments passed to 
it."
       (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))))
+      (let ((new-containers (reverse (org-real--parse-url new-link 
(point-marker)))))
         (while new-containers
           (let ((primary (plist-get (car new-containers) :name))
                 (changes '())
@@ -293,7 +327,8 @@ ORIG is `org-insert-link', ARGS are the arguments passed to 
it."
               (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))))
+                                                 (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
@@ -396,7 +431,10 @@ ORIG is `org-insert-link', ARGS are the arguments passed 
to it."
            :type number)
    (primary :initarg :primary
             :initform nil
-            :type boolean))
+            :type boolean)
+   (locations :initarg :locations
+              :initform '()
+              :type list))
   "A representation of a box in 3D space.")
 
 
@@ -426,7 +464,8 @@ property and optionally a :rel property.  If SKIP-PRIMARY is
 non-nil, skip setting :primary slot on the last box."
   (when-let* ((world (org-real-box))
               (base-container (pop containers))
-              (base (org-real-box :name (plist-get base-container :name))))
+              (base (org-real-box :name (plist-get base-container :name)
+                                  :locations (list (plist-get base-container 
:loc)))))
     (oset base :parent world)
     (with-slots (children) world
       (setq children (org-real--push children base)))
@@ -451,23 +490,34 @@ non-nil, skip setting :primary slot on the last box."
 (cl-defmethod org-real--draw ((box org-real-box) offset)
   "Insert an ascii drawing of BOX into the current buffer.
 
-OFFSET is the starting line to start insertion."
+OFFSET is the starting line to start insertion.
+
+Adds to list `org-real--tab-ring' the buffer position of each
+button drawn."
   (let ((children (with-slots (children) box (org-real--get-all children))))
-    (with-slots (name behind in-front on-top (dashed behind) primary) box
+    (with-slots (name behind in-front on-top (dashed behind) primary 
locations) box
       (when (slot-boundp box :name)
         (let* ((top (+ offset (org-real--get-top box)))
                (left (org-real--get-left box))
                (width (org-real--get-width box))
                (height (org-real--get-height box))
                (align-bottom (or in-front on-top)))
-          (cl-flet ((draw (coords str &optional primary)
-                          (forward-line (- (car coords) (line-number-at-pos)))
-                          (move-to-column (cdr coords) t)
-                          (if primary
-                              (put-text-property 0 (length str) 'face 
'org-real-primary
-                                                 str))
-                          (insert str)
-                          (delete-char (length str))))
+          (cl-flet* ((draw (coords str)
+                           (forward-line (- (car coords) (line-number-at-pos)))
+                           (move-to-column (cdr coords) t)
+                           (insert str)
+                           (delete-char (length str)))
+                     (button (coords str &optional primary)
+                               (if (not locations) (draw coords str)
+                                 (forward-line (- (car coords) 
(line-number-at-pos)))
+                                 (move-to-column (cdr coords) t)
+                                 (add-to-list 'org-real--tab-ring (point))
+                                 (if primary (put-text-property 0 (length str)
+                                                                'face 
'org-real-primary str))
+                                 (insert-button str
+                                                'help-echo "Jump to first 
occurence"
+                                                'keymap 
(org-real--create-button-keymap box))
+                                 (delete-char (length str)))))
             (draw (cons top left)
                   (concat "┌" (make-string (- width 2) (if dashed #x254c 
#x2500)) "┐"))
             (if align-bottom
@@ -475,7 +525,7 @@ OFFSET is the starting line to start insertion."
                       (concat "┴" (make-string (- width 2) (if dashed #x254c 
#x2500)) "┴"))
               (draw (cons (+ top height -1) left)
                     (concat "└" (make-string (- width 2) (if dashed #x254c 
#x2500)) "┘")))
-            (draw (cons (+ top 1 org-real-padding-y)
+            (button (cons (+ top 1 org-real-padding-y)
                         (+ left 1 org-real-padding-x))
                   name
                   primary)
@@ -683,9 +733,11 @@ If INCLUDE-ON-TOP is non-nil, also include height on top 
of box."
 PREV must already exist in PARENT."
   (let* ((container (pop containers))
          (rel (plist-get container :rel))
-         (box (org-real-box :name (plist-get container :name))))
-    (oset box :rel (plist-get container :rel))
-    (oset box :rel-box prev)
+         (box (org-real-box
+               :name (plist-get container :name)
+               :rel (plist-get container :rel)
+               :rel-box prev
+               :locations (list (plist-get container :loc)))))
     (with-slots
         ((cur-x x-order)
          (cur-y y-order)
@@ -759,7 +811,7 @@ PREV must already exist in PARENT."
                      (setq cur-behind prev-behind)
                      (setq cur-on-top prev-on-top)
                      (setq cur-in-front prev-in-front)))
-              
+
               (if (and prev (member rel '("in" "on" "behind" "in front of" "on 
top of")))
                   (progn
                     (oset box :parent prev)
@@ -838,6 +890,8 @@ 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-matching-helper next match world))
@@ -982,6 +1036,61 @@ characters if possible."
         (oset box :parent parent)
         (setq siblings (org-real--push siblings box))))))
 
+;;;; Org real mode buttons
+
+(defun org-real--jump-other-window (markers)
+  "Jump to location of link in other window.
+
+MARKERS is a list of locations of each button in the buffer."
+  (let ((i 0))
+    (lambda ()
+      (interactive)
+      (let* ((marker (nth i markers))
+             (buffer (marker-buffer marker))
+             (pos (marker-position marker)))
+        (save-selected-window
+          (switch-to-buffer-other-window buffer)
+          (goto-char pos))
+        (setq i (mod (+ 1 i) (length markers)))))))
+
+(defun org-real--jump-to (marker)
+  "Jump to the first occurrence of a link in the same window.
+
+MARKER is the position of the first occurrence of the link."
+  (lambda ()
+    (interactive)
+    (switch-to-buffer (marker-buffer marker))
+    (goto-char (marker-position marker))))
+
+(defun org-real--jump-all (markers)
+  "View all occurrences of a link in the same window.
+
+MARKERS is the list of positions of the link."
+  (lambda ()
+    (interactive)
+    (let ((size (/ (window-height) (length markers))))
+      (or (<= window-min-height size)
+          (error "To many buffers to visit simultaneously"))
+      (switch-to-buffer (marker-buffer (car markers)))
+      (goto-char (marker-position (car markers)))
+      (dolist (marker (cdr markers))
+        (select-window (split-window nil size))
+        (switch-to-buffer (marker-buffer marker))
+        (goto-char (marker-position marker))))))
+
+(cl-defmethod org-real--create-button-keymap ((box org-real-box))
+  "Create a keymap for a button in Org Real mode.
+
+BOX is the box the button is being made for."
+  (with-slots (locations) box
+    (easy-mmode-define-keymap
+     (mapcar
+      (lambda (key) (cons (kbd (car key)) (cdr key)))
+      `(("o" . ,(org-real--jump-other-window locations))
+        ("<mouse-1>" . ,(org-real--jump-to (car locations)))
+        ("RET" . ,(org-real--jump-to (car locations)))
+        ("M-RET" . ,(org-real--jump-all locations)))))))
+
 ;;;; Utility expressions
 
 (defun org-real--find-last-index (pred sequence)
@@ -1016,11 +1125,12 @@ LINK is escaped with backslashes for inclusion in 
buffer."
         (org-link-escape link)
         (if description (format "[%s]" description) "")))))
 
-(defun org-real--parse-url (str)
+(defun org-real--parse-url (str marker)
   "Parse STR into a list of plists.
 
 Returns a list of plists with a :name property and optionally a
-:rel property."
+:rel property.  MARKER is the location of the link and will be
+set to the :loc slot of each box."
   (let* ((url (url-generic-parse-url str))
          (host (url-host url))
          (path-and-query (url-path-and-query url))
@@ -1031,14 +1141,14 @@ Returns a list of plists with a :name property and 
optionally a
          (containers (mapcar
                       (lambda (token)
                         (let* ((location (split-string token "\\?"))
-                               (container (list :name (car location)))
+                               (container (list :name (car location) :loc 
marker))
                                (rel (and (string-match "&?rel=\\([^&]*\\)" 
(cadr location))
                                          (match-string 1 (cadr location)))))
                           (if rel
                               (plist-put container :rel rel)
                             container)))
                       tokens)))
-    (push (list :name host) containers)))
+    (push (list :name host :loc marker) containers)))
 
 (defun org-real--parse-buffer ()
   "Parse all real links in the current buffer."
@@ -1048,7 +1158,8 @@ Returns a list of plists with a :name property and 
optionally a
         (if (string= (org-element-property :type link) "real")
             (add-to-list 'container-matrix
                           (org-real--parse-url
-                           (org-element-property :raw-link link))
+                           (org-element-property :raw-link link)
+                           (set-marker (point-marker) (org-element-property 
:begin link)))
                           t))))
     container-matrix))