branch: externals/org-real
commit 4a569a106b201df9265032edd580ad216962a37d
Merge: dd03f41 6d8351f
Author: Tyler Grinn <ty...@tygr.info>
Commit: Tyler Grinn <ty...@tygr.info>
Merge branch 'next' into 'main'
Beta
See merge request tygrdev/org-real!1
---
.gitlab-ci.yml | 2 +-
Eldev | 8 +-
README.org | 10 +-
org-real-box.el | 560 +++++++++++++++++++++++++++++++++++++++++++++++++++++
org-real-pkg.el | 5 +
org-real.el | 592 ++++++++++++++------------------------------------------
6 files changed, 722 insertions(+), 455 deletions(-)
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml
index 4f95502..95db3a4 100644
--- a/.gitlab-ci.yml
+++ b/.gitlab-ci.yml
@@ -9,7 +9,7 @@ package:
- curl -fsSL https://raw.github.com/doublep/eldev/master/webinstall/eldev
| sh
script:
- /root/.eldev/bin/eldev -dtT lint
- - /root/.eldev/bin/eldev -dtT compile
+ - /root/.eldev/bin/eldev -dtT compile -W
- /root/.eldev/bin/eldev -dtT package
- /root/.eldev/bin/eldev -dtT md5
artifacts:
diff --git a/Eldev b/Eldev
index 49da7f0..84e9700 100644
--- a/Eldev
+++ b/Eldev
@@ -1,12 +1,14 @@
; -*- mode: emacs-lisp; lexical-binding: t -*-
(eldev-defcommand
- eventuel-md5 (&rest parameters)
+ org_real-md5 (&rest parameters)
"Create md5 checksum of tar files in dist folder"
- (mapcar
+ (mapc
(lambda (file)
(write-region
(secure-hash 'md5 file)
nil
(concat (file-name-sans-extension file) ".md5")))
- (directory-files eldev-dist-dir t "\\.el\\'")))
+ (append
+ (directory-files eldev-dist-dir t "\\.tar\\'")
+ (directory-files eldev-dist-dir t "\\.el\\'"))))
diff --git a/README.org b/README.org
index e759def..6aa89fb 100644
--- a/README.org
+++ b/README.org
@@ -1,6 +1,6 @@
#+TITLE: Org Real
-Keep track of real things as org links.
+Keep track of real things as org-mode links.
#+begin_src emacs-lisp
(use-package org-real
@@ -11,8 +11,8 @@ Keep track of real things as org links.
[[https://gitlab.com/tygrdev/org-real/-/releases][Download the latest release]]
-* Status *ALPHA*
- - TODO Ask to replace all occurences after editing a link
+* Status *BETA*
+ - TODO ERT tests
* Usage
** Inserting a link
@@ -72,6 +72,10 @@ Keep track of real things as org links.
[[file:demo/edit-link.gif]]
+ If any container in the new link does not match an existing
+ container in the buffer, org-real will prompt you to replace all
+ occurences of that thing with the new context and relationships.
+
** Opening links
To open a link, place the cursor within the link and press =C-c
diff --git a/org-real-box.el b/org-real-box.el
new file mode 100644
index 0000000..710c78a
--- /dev/null
+++ b/org-real-box.el
@@ -0,0 +1,560 @@
+;;; org-real-box.el --- Keep track of real things as org-mode links -*-
lexical-binding: t -*-
+
+;; Author: Tyler Grinn <tylergr...@gmail.com>
+;; Version: 0.1.0
+;; File: org-real-box.el
+;; Package-Requires: ((emacs "26.1"))
+;; Keywords: tools
+;; URL: https://gitlab.com/tygrdev/org-real
+
+;;; Commentary:
+
+;; Box class definition and related methods
+
+;;; Code:
+
+;;;; Patch! 0.0.1 -> 0.1.0+
+;;;; Will be removed in version 1.0.0+
+
+(and (fboundp 'org-real--merge) (fmakunbound 'org-real--merge))
+(and (fboundp 'org-real--map-immediate) (fmakunbound 'org-real--map-immediate))
+(and (fboundp 'org-real--next) (fmakunbound 'org-real--next))
+(and (fboundp 'org-real--merge-into) (fmakunbound 'org-real--merge-into))
+(and (fboundp 'org-real--add-matching) (fmakunbound 'org-real--add-matching))
+(and (fboundp 'org-real--flex-add) (fmakunbound 'org-real--flex-add))
+(and (fboundp 'org-real--expand) (fmakunbound 'org-real--expand))
+(and (fboundp 'org-real--draw) (fmakunbound 'org-real--draw))
+(and (fboundp 'org-real--get-width) (fmakunbound 'org-real--get-width))
+(and (fboundp 'org-real--get-height) (fmakunbound 'org-real--get-height))
+(and (fboundp 'org-real--get-top) (fmakunbound 'org-real--get-top))
+(and (fboundp 'org-real--get-left) (fmakunbound 'org-real--get-left))
+
+;;;; Requirements:
+
+(require 'eieio)
+(require 'cl-lib)
+
+;;;; Variables from org-real.el
+
+(eval-when-compile
+ (defvar org-real-padding)
+ (defvar org-real-margin))
+
+;;;; Class definitions
+
+(defclass org-real-box-collection ()
+ ((box :initarg :box
+ :type org-real-box)
+ (next :initarg :next
+ :type org-real-box-collection))
+ "A collection of `org-real-box'es.")
+
+(defclass org-real-box ()
+ ((name :initarg :name
+ :type string)
+ (rel :initarg :rel
+ :type string)
+ (rel-box :initarg :rel-box
+ :type org-real-box)
+ (x-order :initarg :x-order
+ :initform 0
+ :type number)
+ (y-order :initarg :y-order
+ :initform 0
+ :type number)
+ (in-front :initarg :in-front
+ :initform nil
+ :type boolean)
+ (behind :initarg :behind
+ :initform nil
+ :type boolean)
+ (parent :initarg :parent
+ :type org-real-box)
+ (children :initarg :children
+ :initform (org-real-box-collection)
+ :type org-real-box-collection)
+ (primary :initarg :primary
+ :initform nil
+ :type boolean))
+ "A representation of a box in 3D space.")
+
+
+;;;; Exports
+
+(cl-defmethod org-real--make-instance ((_ (subclass org-real-box)) containers)
+ "Create an instance of `org-real-box' from CONTAINERS.
+
+CONTAINERS is a list of plists containing at least a :name
+property and optionally a :rel property."
+ (when-let* ((world (org-real-box))
+ (base-container (pop containers))
+ (base (org-real-box :name (plist-get base-container :name))))
+ (oset base :parent world)
+ (with-slots (children) world
+ (setq children (org-real--add-to-list children base)))
+ (if containers
+ (org-real--make-instance-helper containers world base))
+ world))
+
+(cl-defmethod org-real--merge (boxes)
+ "Merge BOXES into a single box."
+ (if (< (length boxes) 2)
+ (if (= 0 (length boxes))
+ (org-real-box)
+ (car boxes))
+ (let ((world (org-real-box)))
+ (while boxes
+ (org-real--merge-into (pop boxes) world))
+ world)))
+
+;;;; Drawing
+
+(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."
+ (let ((children (with-slots (children) box (org-real--get-all children))))
+ (if (slot-boundp box :name)
+ (with-slots (name behind (align-bottom in-front) (dashed behind)
primary) box
+ (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)))
+ (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))))
+ (draw (cons top left)
+ (concat "┌" (make-string (- width 2) (if dashed #x254c
#x2500)) "┐"))
+ (if align-bottom
+ (draw (cons (+ top height) left)
+ (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 (cdr org-real-padding))
+ (+ left 1 (car org-real-padding)))
+ name
+ primary)
+ (let ((r (+ top 1))
+ (c1 left)
+ (c2 (+ left width -1)))
+ (dotimes (_ (- height (if align-bottom 1 2)))
+ (draw (cons r c1) (if dashed "╎" "│"))
+ (draw (cons r c2) (if dashed "╎" "│"))
+ (setq r (+ r 1))))))))
+ (mapc
+ (lambda (child) (org-real--draw child offset))
+ children)))
+
+(cl-defmethod org-real--get-width ((box org-real-box))
+ "Get the width of BOX."
+ (let* ((base-width (+ 2 ; box walls
+ (* 2 (car org-real-padding))))
+ (width (+ base-width
+ (if (slot-boundp box :name)
+ (with-slots (name) box (length name))
+ 0)))
+ (children (with-slots (children) box (org-real--get-all children))))
+ (if (not children)
+ width
+ (let* ((column-indices (cl-delete-duplicates
+ (mapcar (lambda (child) (with-slots (x-order)
child x-order)) children)))
+ (columns (mapcar
+ (lambda (c)
+ (seq-filter
+ (lambda (child)
+ (with-slots (x-order) child
+ (= c x-order)))
+ children))
+ column-indices))
+ (column-widths (mapcar
+ (lambda (column)
+ (apply 'max (mapcar 'org-real--get-width
column)))
+ columns))
+ (children-width (seq-reduce
+ (lambda (total width)
+ (+ total (car org-real-margin) width))
+ column-widths
+ (* -1 (car org-real-margin)))))
+ (if (> width (+ (* 2 (car org-real-margin)) children-width))
+ width
+ (+ base-width children-width))))))
+
+(cl-defmethod org-real--get-height ((box org-real-box))
+ "Get the height of BOX."
+ (let* ((in-front (with-slots (in-front) box in-front))
+ (height (+ (if in-front
+ (* -1 (cdr org-real-margin))
+ 0)
+ 3 ; box walls + text
+ (cdr org-real-padding)
+ (cdr org-real-margin)))
+ (children (with-slots (children) box (org-real--get-all children))))
+ (if (not children)
+ height
+ (let* ((row-indices (cl-delete-duplicates
+ (mapcar (lambda (child) (with-slots (y-order) child
y-order)) children)))
+ (rows (mapcar
+ (lambda (r)
+ (seq-filter
+ (lambda (child)
+ (with-slots (y-order) child
+ (= r y-order)))
+ children))
+ row-indices))
+ (row-heights (mapcar
+ (lambda (row)
+ (apply 'max (mapcar 'org-real--get-height row)))
+ rows)))
+ (+ height (seq-reduce '+ row-heights 0))))))
+
+(cl-defmethod org-real--get-top ((box org-real-box))
+ "Get the top row index of BOX."
+ (if (not (slot-boundp box :parent))
+ 0
+ (with-slots (parent x-order y-order) box
+ (let* ((offset (+ 2 (cdr org-real-padding) (cdr org-real-margin)))
+ (top (+ offset (org-real--get-top parent)))
+ (above (seq-filter
+ (lambda (child)
+ (with-slots ((child-x x-order) (child-y y-order)) child
+ (and (= x-order child-x)
+ (< child-y y-order))))
+ (org-real--get-all (with-slots (children) parent
children))))
+ (directly-above (and above (seq-reduce
+ (lambda (max child)
+ (with-slots ((max-y y-order)) max
+ (with-slots ((child-y y-order))
child
+ (if (> child-y max-y)
+ child
+ max))))
+ above
+ (org-real-box :y-order -9999))))
+ (above-height (and directly-above (apply 'max
+ (mapcar
+ 'org-real--get-height
+ (seq-filter
+ (lambda (child)
+ (= (with-slots
(y-order) directly-above y-order)
+ (with-slots
(y-order) child y-order)))
+ (org-real--get-all
+ (with-slots
(children) parent children))))))))
+ (if directly-above
+ (+ (org-real--get-top directly-above)
+ above-height)
+ (with-slots (rel rel-box) box
+ (if (and (slot-boundp box :rel)
+ (or (string= "to the left of" rel)
+ (string= "to the right of" rel)))
+ (org-real--get-top rel-box)
+ top)))))))
+
+(cl-defmethod org-real--get-left ((box org-real-box))
+ "Get the left column index of BOX."
+ (if (not (slot-boundp box :parent))
+ 0
+ (with-slots (parent x-order y-order) box
+ (let* ((left (+ 1
+ (car org-real-padding)
+ (org-real--get-left parent)))
+ (to-the-left (seq-filter
+ (lambda (child)
+ (with-slots ((child-y y-order) (child-x x-order))
child
+ (and (= y-order child-y)
+ (< child-x x-order))))
+ (org-real--get-all (with-slots (children) parent
children))))
+ (directly-left (and to-the-left
+ (seq-reduce
+ (lambda (max child)
+ (with-slots ((max-x x-order)) max
+ (with-slots ((child-x x-order)) child
+ (if (> child-x max-x)
+ child
+ max))))
+ to-the-left
+ (org-real-box :x-order -9999)))))
+ (if directly-left
+ (+ (org-real--get-left directly-left)
+ (org-real--get-width directly-left)
+ (car org-real-margin))
+ (with-slots (rel rel-box) box
+ (if (and (slot-boundp box :rel)
+ (or (string= "above" rel)
+ (string= "below" rel)))
+ (org-real--get-left rel-box)
+ left)))))))
+
+;;;; Utility expressions
+
+(cl-defmethod org-real--get-all ((collection org-real-box-collection))
+ "Get all boxes in COLLECTION as a sequence."
+ (with-slots (box next) collection
+ (append (if (slot-boundp collection :box) (list box))
+ (if (slot-boundp collection :next) (org-real--get-all next)))))
+
+(cl-defmethod org-real--add-to-list ((collection org-real-box-collection)
+ (box org-real-box))
+ "Add BOX to COLLECTION and return new COLLECTION."
+ (if (slot-boundp collection :box)
+ (org-real-box-collection
+ :box box
+ :next collection)
+ (oset collection :box box)
+ collection))
+
+(cl-defmethod org-real--make-instance-helper (containers parent (prev
org-real-box))
+ "Help create a 3D representation of CONTAINERS.
+
+PREV must already existing in PARENT."
+ (let* ((container (pop containers))
+ (rel (plist-get container :rel))
+ (box (org-real-box :name (plist-get container :name))))
+ (when prev
+ (oset box :rel (plist-get container :rel))
+ (oset box :rel-box prev)
+ (with-slots
+ ((cur-x x-order)
+ (cur-y y-order)
+ (cur-behind behind)
+ (cur-in-front in-front))
+ box
+ (with-slots
+ ((prev-x x-order)
+ (prev-y y-order)
+ (prev-behind behind)
+ (prev-in-front in-front))
+ prev
+ (cond ((or (string= rel "in") (string= rel "on"))
+ (setq cur-x prev-x)
+ (setq cur-y prev-y)
+ (setq cur-behind prev-behind))
+ ((string= rel "behind")
+ (setq cur-x prev-x)
+ (setq cur-y prev-y)
+ (setq cur-behind t))
+ ((string= rel "in front of")
+ (setq cur-x prev-x)
+ (setq cur-y 9999)
+ (setq cur-behind prev-behind)
+ (setq cur-in-front t))
+ ((string= rel "above")
+ (setq cur-x prev-x)
+ (setq cur-y (- prev-y 1))
+ (setq cur-behind prev-behind))
+ ((string= rel "below")
+ (setq cur-x prev-x)
+ (setq cur-y (+ 1 prev-y))
+ (setq cur-behind prev-behind)
+ (setq cur-in-front prev-in-front))
+ ((string= rel "to the left of")
+ (setq cur-x (- prev-x 1))
+ (setq cur-y prev-y)
+ (setq cur-behind prev-behind)
+ (setq cur-in-front prev-in-front))
+ ((string= rel "to the right of")
+ (setq cur-x (+ 1 prev-x))
+ (setq cur-y prev-y)
+ (setq cur-behind prev-behind)
+ (setq cur-in-front prev-in-front))))))
+
+ (if (and prev (member rel '("in" "on" "behind" "in front of")))
+ (progn
+ (oset box :parent prev)
+ (oset prev :children (org-real--add-to-list (with-slots (children)
prev children) box))
+ (if containers
+ (org-real--make-instance-helper containers prev box)
+ (oset box :primary t)))
+ (oset box :parent parent)
+ (oset parent :children (org-real--add-to-list (with-slots (children)
parent children) box))
+ (if containers
+ (org-real--make-instance-helper containers parent box)
+ (oset box :primary t)))))
+
+(cl-defmethod org-real--map-immediate (fn (box org-real-box))
+ "Map a function FN across all immediate relatives of BOX, including BOX.
+
+Any box with a :rel-box slot equivalent to BOX will be passed to
+FN."
+ (progn
+ (funcall fn box)
+ (mapc
+ (lambda (box) (org-real--map-immediate fn box))
+ (org-real--next box t))))
+
+(cl-defmethod org-real--next ((box org-real-box) &optional exclude-children)
+ "Retrieve any boxes for which the :rel-box slot is BOX.
+
+If EXCLUDE-CHILDREN, only retrieve sibling boxes."
+ (let ((relatives (append (if exclude-children '() (org-real--get-all
+ (with-slots (children)
box children)))
+ (if (slot-boundp box :parent)
+ (org-real--get-all
+ (with-slots
+ (children)
+ (with-slots (parent) box parent)
+ children))
+ '()))))
+ (seq-filter
+ (lambda (relative)
+ (and (slot-boundp relative :rel-box)
+ (string= (with-slots
+ (name)
+ (with-slots (rel-box) relative rel-box)
+ name)
+ (with-slots (name) box name))))
+ relatives)))
+
+(cl-defmethod org-real--expand ((box org-real-box))
+ "Get a list of all boxes, including BOX, that are children of BOX."
+ (with-slots (children) box
+ (apply 'append (list box) (mapcar 'org-real--expand (org-real--get-all
children)))))
+
+(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 (reverse (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 to)
+ t))
+ to-boxes))
+ from-boxes)
+ (org-real--flex-add from to to))))
+
+(cl-defmethod org-real--add-matching ((box org-real-box)
+ (match org-real-box)
+ (world org-real-box))
+ "Add BOX to WORLD after finding a matching box MATCH already in WORLD.
+
+MATCH is used to set the :rel-box and :parent slots on children
+of BOX."
+ (with-slots
+ (parent
+ (match-y y-order)
+ (match-x x-order)
+ (match-behind behind)
+ (match-in-front in-front))
+ match
+ (let ((next-boxes (org-real--next box)))
+ (mapc
+ (lambda (next)
+ (with-slots
+ (rel
+ (next-y y-order)
+ (next-x x-order)
+ (next-behind behind)
+ (next-in-front in-front))
+ next
+ (cond
+ ((string= rel "above")
+ (setq next-y match-y)
+ (org-real--map-immediate
+ (lambda (child)
+ (with-slots ((child-y y-order)) child
+ (when (>= child-y match-y)
+ (setq child-y (+ 1 child-y)))))
+ match)
+ (setq next-x match-x)
+ (setq next-behind match-behind))
+ ((string= rel "below")
+ (setq next-y (+ 1 match-y))
+ (org-real--map-immediate
+ (lambda (child)
+ (with-slots ((child-y y-order)) child
+ (when (> child-y match-y)
+ (setq child-y (+ 1 child-y)))))
+ match)
+ (setq next-x match-x)
+ (setq next-behind match-behind))
+ ((string= rel "to the right of")
+ (setq next-x (+ 1 match-x))
+ (org-real--map-immediate
+ (lambda (child)
+ (with-slots ((child-x x-order)) child
+ (when (> child-x match-x)
+ (setq child-x (+ 1 child-x)))))
+ match)
+ (setq next-y match-y)
+ (setq next-behind match-behind)
+ (setq next-in-front match-in-front))
+ ((string= rel "to the left of")
+ (setq next-x match-x)
+ (org-real--map-immediate
+ (lambda (child)
+ (with-slots ((child-x x-order)) child
+ (when (>= child-x match-x)
+ (setq child-x (+ 1 child-x)))))
+ match)
+ (setq next-y match-y)
+ (setq next-behind match-behind)
+ (setq next-in-front match-in-front)))
+
+ (oset next :rel-box match)
+ (if (member rel '("in" "on" "behind" "in front of"))
+ (org-real--flex-add next match world)
+ (oset next :parent parent)
+ (oset parent :children (org-real--add-to-list
+ (with-slots (children) parent children)
+ next)))
+ (org-real--add-matching next next world)))
+ next-boxes))))
+
+(cl-defmethod org-real--flex-add ((box org-real-box)
+ (parent org-real-box)
+ (world org-real-box))
+ "Add BOX to a PARENT box already existing in WORLD.
+
+This function ignores the :rel slot and adds BOX in such a way
+that the width of WORLD is kept below 80 characters if possible."
+ (with-slots ((siblings children)) parent
+ (let* ((cur-width (org-real--get-width world))
+ (siblings (org-real--get-all siblings))
+ (last-sibling (and siblings (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)))))
+ (seq-filter
+ (lambda (sibling)
+ (not (with-slots (in-front) sibling
in-front)))
+ siblings)
+ (org-real-box :y-order -9999)))))
+ (oset box :parent parent)
+ (oset parent :children (org-real--add-to-list (with-slots (children)
parent children) box))
+ (when (and last-sibling (not (with-slots (in-front) box in-front)))
+ (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 ((new-width (org-real--get-width world)))
+ (when (and (> new-width cur-width) (> new-width 80))
+ (oset box :y-order (+ 1 last-sibling-y))
+ (oset box :x-order 0))))))))
+
+
+
+(provide 'org-real-box)
+
+;;; org-real-box.el ends here
diff --git a/org-real-pkg.el b/org-real-pkg.el
new file mode 100644
index 0000000..7745852
--- /dev/null
+++ b/org-real-pkg.el
@@ -0,0 +1,5 @@
+(define-package
+ "org-real"
+ "0.1.0"
+ "Keep track of real things as org-mode links"
+ '((emacs "26.1")))
diff --git a/org-real.el b/org-real.el
index 0cc3a1d..45309d6 100644
--- a/org-real.el
+++ b/org-real.el
@@ -1,7 +1,7 @@
-;;; org-real.el --- Create org-mode links to real things -*- lexical-binding:
t -*-
+;;; org-real.el --- Keep track of real things as org-mode links -*-
lexical-binding: t -*-
;; Author: Tyler Grinn <tylergr...@gmail.com>
-;; Version: 0.0.1
+;; Version: 0.1.0
;; File: org-real.el
;; Package-Requires: ((emacs "26.1"))
;; Keywords: tools
@@ -19,102 +19,28 @@
;;;; Requirements
-(require 'eieio)
-(require 'org)
-(require 'cl-lib)
-
-;;;; Classes
-
-(defclass org-real--box ()
- ((name :initarg :name
- :type string)
- (rel :initarg :rel
- :type string)
- (rel-box :initarg :rel-box
- :type org-real--box)
- (x-order :initarg :x-order
- :initform 0
- :type number)
- (y-order :initarg :y-order
- :initform 0
- :type number)
- (in-front :initarg :in-front
- :initform nil
- :type boolean)
- (behind :initarg :behind
- :initform nil
- :type boolean)
- (parent :initarg :parent
- :type org-real--box)
- (children :initarg :children
- :initform '()
- :type list)
- (primary :initarg :primary
- :initform nil
- :type boolean)))
-
-(defun org-real--create-box (containers &optional parent prev)
- "Create an `org-real--box' from CONTAINERS.
-
-CONTAINERS is a list of plists containing at least a :name
-property and optionally a :rel property. PARENT and PREV
-parameters are used internally and should not be supplied."
- (if (not parent)
- (let ((world (org-real--box)))
- (org-real--create-box containers world)
- world)
- (let* ((container (pop containers))
- (rel (plist-get container :rel))
- (box (org-real--box :name (plist-get container :name))))
- (when prev
- (oset box :rel (plist-get container :rel))
- (oset box :rel-box prev)
- (cond ((or (string= rel "in") (string= rel "on"))
- (oset box :x-order (oref prev :x-order))
- (oset box :y-order (oref prev :y-order))
- (oset box :behind (oref prev :behind)))
- ((string= rel "behind")
- (oset box :x-order (oref prev :x-order))
- (oset box :y-order (oref prev :y-order))
- (oset box :behind t))
- ((string= rel "in front of")
- (oset box :x-order (oref prev :x-order))
- (oset box :y-order 9999)
- (oset box :behind (oref prev :behind))
- (oset box :in-front t))
- ((string= rel "above")
- (oset box :x-order (oref prev :x-order))
- (oset box :y-order (- (oref prev :y-order) 1))
- (oset box :behind (oref prev :behind)))
- ((string= rel "below")
- (oset box :x-order (oref prev :x-order))
- (oset box :y-order (+ 1 (oref prev :y-order)))
- (oset box :behind (oref prev :behind))
- (oset box :in-front (oref prev :in-front)))
- ((string= rel "to the left of")
- (oset box :x-order (- (oref prev :x-order) 1))
- (oset box :y-order (oref prev :y-order))
- (oset box :behind (oref prev :behind))
- (oset box :in-front (oref prev :in-front)))
- ((string= rel "to the right of")
- (oset box :x-order (+ 1 (oref prev :x-order)))
- (oset box :y-order (oref prev :y-order))
- (oset box :behind (oref prev :behind))
- (oset box :in-front (oref prev :in-front)))))
-
- (if (and prev (member (oref box :rel)
- '("in" "on" "behind" "in front of")))
- (progn
- (oset box :parent prev)
- (object-add-to-list prev :children box)
- (if containers
- (org-real--create-box containers prev box)
- (oset box :primary t)))
- (oset box :parent parent)
- (object-add-to-list parent :children box)
- (if containers
- (org-real--create-box containers parent box)
- (oset box :primary t))))))
+(require 'org-element)
+(require 'cl-extra)
+
+(require 'org-real-box)
+
+;;;; Customization variables
+
+(defcustom org-real-margin '(2 . 1)
+ "Margin to be used when displaying boxes.
+
+The first number is the horizontal margin, second is the vertical
+margin"
+ :type 'cons
+ :group 'org-real)
+
+(defcustom org-real-padding '(2 . 1)
+ "Padding to be used when displaying boxes.
+
+The first number is the horizontal padding, second is the
+vertical padding"
+ :type 'cons
+ :group 'org-real)
;;;; Faces
@@ -129,10 +55,6 @@ parameters are used internally and should not be supplied."
(defconst org-real-prepositions
'("in" "on" "behind" "in front of" "above" "below" "to the left of" "to the
right of")
"List of available prepositions for things.")
-(defvar org-real--padding '(2 . 1)
- "Padding used when displaying a real link.")
-(defvar org-real--margin '(2 . 1)
- "Margin used when displaying a real link.")
;;;; Utility expressions
@@ -147,6 +69,28 @@ parameters are used internally and should not be supplied."
(reverse sequence))
nil)))
+(defun org-real--link-make-string (link &optional description)
+ "Make a bracket link, consisting of LINK and DESCRIPTION.
+LINK is escaped with backslashes for inclusion in buffer."
+ (let* ((zero-width-space (string ?\x200B))
+ (description
+ (and (org-string-nw-p description)
+ ;; Description cannot contain two consecutive square
+ ;; brackets, or end with a square bracket. To prevent
+ ;; this, insert a zero width space character between
+ ;; the brackets, or at the end of the description.
+ (replace-regexp-in-string
+ "\\(]\\)\\(]\\)"
+ (concat "\\1" zero-width-space "\\2")
+ (replace-regexp-in-string "]\\'"
+ (concat "\\&" zero-width-space)
+ (org-trim description))))))
+ (if (not (org-string-nw-p link)) description
+ (format "[[%s]%s]"
+ (org-link-escape link)
+ (if description (format "[%s]" description) "")))))
+
+
(defun org-real--parse-url (str)
"Parse STR into a list of plists.
@@ -194,154 +138,6 @@ Returns a list of plists with a :name property and
optionally a
containers
"/")))
-(defun org-real--map-immediate (fn box)
- "Map a function across all immediate relatives of a box.
-
-Any box with a :rel-box slot equivalent to BOX will be passed to
-FN."
- (progn
- (funcall fn box)
- (mapc
- (lambda (box) (org-real--map-immediate fn box))
- (org-real--next box t))))
-
-(defun org-real--next (box &optional exclude-children)
- "Retrieve any boxes for which the :rel-box slot is BOX.
-
-If EXCLUDE-CHILDREN, only retrieve sibling boxes."
- (let ((relatives (append (if exclude-children '() (oref box :children))
- (if (slot-boundp box :parent) (oref (oref box
:parent) :children) '()))))
- (seq-filter
- (lambda (relative)
- (and (slot-boundp relative :rel-box)
- (string= (oref (oref relative :rel-box) :name)
- (oref box :name))))
- relatives)))
-
-(defun org-real--merge (boxes)
- "Merge BOXES into a single box."
- (if (< (length boxes) 2)
- (if (= 0 (length boxes))
- (org-real--box)
- (car boxes))
- (let ((world (org-real--box)))
- (while boxes
- (org-real--merge-into (pop boxes) world))
- world)))
-
-(defun org-real--expand (box)
- "Get a list of all boxes, including BOX, that are children of BOX."
- (apply 'append (list box) (mapcar 'org-real--expand (oref box :children))))
-
-(defun org-real--merge-into (from to)
- "Merge FROM box into TO box."
- (let ((from-boxes (reverse (org-real--expand from)))
- (to-boxes (reverse (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= (oref from-box :name) (oref to-box
:name)))
- (org-real--add-matching from-box to-box to)
- t))
- to-boxes))
- from-boxes)
- (org-real--flex-add from to to))))
-
-
-(defun org-real--add-matching (box match world)
- "Add BOX to WORLD after finding a matching box MATCH already in WORLD.
-
-MATCH is used to set the :rel-box and :parent slots on children
-of BOX."
- (let ((next-boxes (org-real--next box))
- (parent (oref match :parent)))
- (mapc
- (lambda (next)
- (let ((rel (oref next :rel)))
- (cond
- ((string= rel "above")
- (let ((y-order (oref match :y-order)))
- (oset next :y-order y-order)
- (org-real--map-immediate
- (lambda (box) (when (>= (oref box :y-order) y-order)
- (oset box :y-order (+ 1 (oref box :y-order)))))
- match))
- (oset next :x-order (oref match :x-order))
- (oset next :behind (oref match :behind)))
- ((string= rel "below")
- (let ((y-order (oref match :y-order)))
- (oset next :y-order (+ 1 y-order))
- (org-real--map-immediate
- (lambda (box) (when (> (oref box :y-order) y-order)
- (oset box :y-order (+ 1 (oref box :y-order)))))
- match))
- (oset next :x-order (oref match :x-order))
- (oset next :behind (oref match :behind)))
- ((string= rel "to the right of")
- (let ((x-order (oref match :x-order)))
- (oset next :x-order (+ 1 x-order))
- (org-real--map-immediate
- (lambda (box) (when (> (oref box :x-order) x-order)
- (oset box :x-order (+ 1 (oref box :x-order)))))
- match))
- (oset next :y-order (oref match :y-order))
- (oset next :behind (oref match :behind))
- (oset next :in-front (oref match :in-front)))
- ((string= rel "to the left of")
- (let ((x-order (oref match :x-order)))
- (oset next :x-order x-order)
- (org-real--map-immediate
- (lambda (box) (when (>= (oref box :x-order) x-order)
- (oset box :x-order (+ 1 (oref box :x-order)))))
- match))
- (oset next :y-order (oref match :y-order))
- (oset next :behind (oref match :behind))
- (oset next :in-front (oref match :in-front))))
-
- (oset next :rel-box match)
- (if (member rel '("in" "on" "behind" "in front of"))
- (org-real--flex-add next match world)
- (oset next :parent parent)
- (object-add-to-list parent :children next))
- (org-real--add-matching next next world)))
- next-boxes)))
-
-(defun org-real--flex-add (box parent world)
- "Add BOX to a PARENT box already existing in WORLD.
-
-This function ignores the :rel slot and adds BOX in such a way
-that the width of WORLD is kept below 80 characters if possible."
- (let* ((cur-width (org-real--get-width world))
- (siblings (oref parent :children))
- (last-sibling (and siblings (seq-reduce
- (lambda (max sibling)
- (let ((max-x (oref max :x-order))
- (max-y (oref max :y-order))
- (sibling-x (oref sibling :x-order))
- (sibling-y (oref sibling
:y-order)))
- (if (> sibling-y max-y)
- sibling
- (if (and (= max-y sibling-y) (>
sibling-x max-x))
- sibling
- max))))
- (seq-filter
- (lambda (sibling) (not (oref sibling
:in-front)))
- siblings)
- (org-real--box :y-order -9999)))))
- (oset box :parent parent)
- (object-add-to-list parent :children box)
- (when (and last-sibling (not (oref box :in-front)))
- (oset box :y-order (oref last-sibling :y-order))
- (oset box :x-order (+ 1 (oref last-sibling :x-order)))
- (let ((new-width (org-real--get-width world)))
- (when (and (> new-width cur-width) (> new-width 80))
- (oset box :y-order (+ 1 (oref last-sibling :y-order)))
- (oset box :x-order 0))))))
-
-
;;;; Interactive functions
(defun org-real-world ()
@@ -349,8 +145,10 @@ that the width of WORLD is kept below 80 characters if
possible."
(interactive)
(org-real--pp
(org-real--merge
- (mapcar 'org-real--create-box
- (org-real--parse-buffer)))))
+ (mapcar
+ (lambda (containers)
+ (org-real--make-instance 'org-real-box containers))
+ (org-real--parse-buffer)))))
;;;; `org-insert-link' configuration
@@ -358,15 +156,12 @@ that the width of WORLD is kept below 80 characters if
possible."
:follow #'org-real-follow
:complete #'org-real-complete)
-(defun org-real-follow (url &rest args)
- "Open a real link URL in a popup buffer.
-
-ARGS are ignored."
+(defun org-real-follow (url &rest _)
+ "Open a real link URL in a popup buffer."
(let* ((containers (org-real--parse-url url))
- (box (org-real--create-box (copy-tree containers))))
+ (box (org-real--make-instance 'org-real-box (copy-tree containers))))
(org-real--pp box (copy-tree containers))))
-
(defun org-real-complete (&optional existing)
"Complete a real link or edit EXISTING link."
(let* ((container-matrix (org-real--parse-buffer))
@@ -375,7 +170,7 @@ ARGS are ignored."
(org-real--complete-thing "Thing: " container-matrix))))
(catch 'confirm
(while t
- (org-real--pp (org-real--create-box containers) containers)
+ (org-real--pp (org-real--make-instance 'org-real-box containers)
containers)
(let ((response (read-event "RETURN - Confirm\nBACKSPACE - Remove
context\n+ - Add context")))
(cond
((eq response 'return)
@@ -425,6 +220,8 @@ matching the one returned from `completing-read'."
existing-containers
`((:name ,result)))))
+;;; Hooks
+
(defun org-real--read-string-advice (orig prompt link &rest args)
"Advise `read-string' during `org-insert-link' to use custom completion.
@@ -434,20 +231,92 @@ passed to it."
(org-real-complete link)
(apply orig prompt link args)))
-(defun org-real--insert-link-before (&rest args)
+(defun org-real--maybe-edit-link (orig &rest args)
"Advise `org-insert-link' to advise `read-string' during editing of a link.
-ARGS are the arguments passed to `org-insert-link'."
- (advice-add 'read-string :around #'org-real--read-string-advice))
-
-(defun org-real--insert-link-after (&rest args)
- "Advise `org-insert-link' to advise `read-string' during editing of a link.
-
-ARGS are the arguments passed to `org-insert-link'."
- (advice-remove 'read-string #'org-real--read-string-advice))
-
-(advice-add 'org-insert-link :before #'org-real--insert-link-before)
-(advice-add 'org-insert-link :after #'org-real--insert-link-after)
+ORIG is `org-insert-link', ARGS are the arguments passed to it."
+ (advice-add 'read-string :around #'org-real--read-string-advice)
+ (unwind-protect
+ (if (called-interactively-p 'any)
+ (call-interactively orig)
+ (apply orig args))
+ (advice-remove 'read-string #'org-real--read-string-advice)))
+
+(advice-add 'org-insert-link :around #'org-real--maybe-edit-link)
+
+(defun org-real--apply (&rest _)
+ "Apply any change to the current buffer if last inserted link is real."
+ (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))))
+ (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))))
+
+ (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))))
+ (old-desc ""))
+ (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)
+ (goto-char begin)
+ (if (org-in-regexp org-link-bracket-re 1)
+ (setq old-desc (when (match-end 2)
(match-string-no-properties 2))))
+ (push
+ `(lambda ()
+ (delete-region ,begin ,end)
+ (goto-char ,begin)
+ (insert (org-real--link-make-string ,replace-link
,old-desc)))
+ 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))
+
+(advice-add 'org-insert-link :after #'org-real--apply)
;;;; Pretty printing
@@ -466,23 +335,21 @@ describing where BOX is."
(toggle-truncate-lines t)
(if containers (org-real--pp-text containers))
(let ((offset (- (line-number-at-pos)
- (cdr org-real--margin)
- (* 2 (cdr org-real--padding)))))
+ (cdr org-real-margin)
+ (* 2 (cdr org-real-padding)))))
(dotimes (_ (+ top height)) (insert (concat (make-string width ?\s)
"\n")))
(org-real--draw box offset)
(special-mode)))
(display-buffer buffer `(display-buffer-pop-up-window
(window-width . 80)
(window-height . ,height)))))
-
-
(defun org-real--pp-text (containers)
"Insert a textual representation of CONTAINERS into the current buffer."
(let* ((reversed (reverse containers))
(container (pop reversed))
(primary-name (plist-get container :name)))
- (dotimes (_ (cdr org-real--padding)) (insert "\n"))
- (insert (make-string (car org-real--padding) ?\s))
+ (dotimes (_ (cdr org-real-padding)) (insert "\n"))
+ (insert (make-string (car org-real-padding) ?\s))
(insert "The ")
(put-text-property 0 (length primary-name) 'face 'org-real-primary
primary-name)
@@ -498,177 +365,6 @@ describing where BOX is."
(fill-paragraph)
(insert "\n")))
-(defun org-real--draw (box offset)
- "Insert an ascii drawing of BOX into the current buffer.
-
-OFFSET is the starting line to start insertion."
- (let ((children (oref box :children)))
- (if (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))
- (name (oref box :name))
- (dashed (oref box :behind))
- (align-bottom (oref box :in-front))
- (primary (oref box :primary)))
- (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))))
- (draw (cons top left)
- (concat "┌" (make-string (- width 2) (if dashed #x254c
#x2500)) "┐"))
- (if align-bottom
- (draw (cons (+ top height -1 (cdr org-real--margin)) left)
- (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 (cdr org-real--padding))
- (+ left 1 (car org-real--padding)))
- name
- primary)
- (let ((r (+ top 1))
- (c1 left)
- (c2 (+ left width -1)))
- (dotimes (_ (- height (if align-bottom 1 2)))
- (draw (cons r c1) (if dashed "╎" "│"))
- (draw (cons r c2) (if dashed "╎" "│"))
- (setq r (+ r 1)))))))
- (mapc
- (lambda (child) (org-real--draw child offset))
- children)))
-
-
-(defun org-real--get-width (box)
- "Get the width of BOX."
- (let* ((base-width (+ 2 ; box walls
- (* 2 (car org-real--padding))))
- (width (+ base-width (if (slot-boundp box :name)
- (length (oref box :name))
- 0)))
- (children (oref box :children)))
- (if (not children)
- width
- (let* ((column-indices (delete-duplicates
- (mapcar (lambda (child) (oref child :x-order))
children)))
- (columns (mapcar
- (lambda (c)
- (seq-filter
- (lambda (child)
- (= c (oref child :x-order)))
- children))
- column-indices))
- (column-widths (mapcar
- (lambda (column)
- (apply 'max (mapcar 'org-real--get-width
column)))
- columns))
- (children-width (seq-reduce
- (lambda (total width)
- (+ total (car org-real--margin) width))
- column-widths
- (* -1 (car org-real--margin)))))
- (if (> width (+ (* 2 (car org-real--margin)) children-width))
- width
- (+ base-width children-width))))))
-
-(defun org-real--get-height (box)
- "Get the height of BOX."
- (let* ((in-front (oref box :in-front))
- (height (+ (if in-front
- (* -1 (cdr org-real--margin))
- 0)
- 2 ; box walls
- (* 2 (cdr org-real--padding))
- (cdr org-real--margin)))
- (children (oref box :children)))
- (if (not children)
- height
- (let* ((row-indices (delete-duplicates
- (mapcar (lambda (child) (oref child :y-order))
children)))
- (rows (mapcar
- (lambda (r)
- (seq-filter
- (lambda (child)
- (= r (oref child :y-order)))
- children))
- row-indices))
- (row-heights (mapcar
- (lambda (row)
- (apply 'max (mapcar 'org-real--get-height row)))
- rows)))
- (+ height (seq-reduce '+ row-heights 0))))))
-
-(defun org-real--get-top (box)
- "Get the top row index of BOX."
- (if (not (slot-boundp box :parent))
- 0
- (let* ((offset (+ 1 (* 2 (cdr org-real--padding)) (cdr org-real--margin)))
- (parent (oref box :parent))
- (top (+ offset (org-real--get-top parent))))
- (let* ((x-order (oref box :x-order))
- (y-order (oref box :y-order))
- (above (seq-filter
- (lambda (child) (and (= x-order (oref child :x-order))
- (< (oref child :y-order) y-order)))
- (oref parent :children)))
- (directly-above (and above (seq-reduce
- (lambda (max child)
- (if (> (oref child :y-order) (oref
max :y-order))
- child
- max))
- above
- (org-real--box :y-order -9999))))
- (above-height (and directly-above (apply 'max
- (mapcar
- 'org-real--get-height
- (seq-filter
- (lambda (child)
- (= (oref
directly-above :y-order)
- (oref child
:y-order)))
- (oref parent
:children)))))))
- (if directly-above
- (+ (org-real--get-top directly-above)
- above-height)
- (if (and (slot-boundp box :rel)
- (or (string= "to the left of" (oref box :rel))
- (string= "to the right of" (oref box :rel))))
- (org-real--get-top (oref box :rel-box))
- top))))))
-
-(defun org-real--get-left (box)
- "Get the left column index of BOX."
- (if (not (slot-boundp box :parent))
- 0
- (let* ((parent (oref box :parent))
- (left (+ 1
- (car org-real--padding)
- (org-real--get-left parent)))
- (to-the-left (seq-filter
- (lambda (child) (and (= (oref box :y-order) (oref
child :y-order))
- (< (oref child :x-order) (oref
box :x-order))))
- (oref parent :children)))
- (directly-left (and to-the-left
- (seq-reduce
- (lambda (max child)
- (if (> (oref child :x-order) (oref max
:x-order))
- child
- max))
- to-the-left
- (org-real--box :x-order -9999)))))
- (if directly-left
- (+ (org-real--get-left directly-left)
- (org-real--get-width directly-left)
- (car org-real--margin))
- (if (and (slot-boundp box :rel)
- (or (string= "above" (oref box :rel))
- (string= "below" (oref box :rel))))
- (org-real--get-left (oref box :rel-box))
- left)))))
-
(provide 'org-real)
;;; org-real.el ends here
