path: root/emacs/.emacs.d/lisp/my/my-org.el

;;; my-org.el -- Extensions for org -*- lexical-binding: t -*-

;; Copyright (C) 2023 Free Software Foundation.

;; Author: Yuchen Pei <id@ypei.org>
;; Package-Requires: ((emacs "28.2"))

;; This file is part of dotfiles.

;; dotfiles is free software: you can redistribute it and/or modify it under
;; the terms of the GNU Affero General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; dotfiles is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Affero General
;; Public License for more details.

;; You should have received a copy of the GNU Affero General Public
;; License along with dotfiles.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; Extensions for org.

;;; Code:


(require 'org)

;;; org mode
(defun my-org-open-shell-at-attach-dir ()
  (interactive)
  (require 'my-prog)
  (my-shell-with-directory (concat (org-attach-dir-get-create) "/")))

(defun my-org-links-in-entry ()
  "Get all link urls in an entry"
  (save-excursion
    (org-back-to-heading t)
    (let (links
	        (end (save-excursion (outline-next-heading) (point))))
	    (while (re-search-forward org-link-any-re end t)
	      (push
         (org-unbracket-string "<" ">"
					 (or
						;; [[target][desc]]
						(match-string-no-properties 2)
						;; plain link or <...>
						(match-string-no-properties 0)))
         links))
      links)))

(defun my-org-http-s-links-in-entry ()
  "Get all http(s) urls in an entry"
  (seq-filter (lambda (link)
                (string-prefix-p
                 "http"
                 (progn (string-match org-link-types-re link)
                        (match-string 1 link))))
              (my-org-links-in-entry)))

(defun my-org-insert-date-range (inactive)
  "Insert two dates to form an active date range.

With a prefix, insert inactive dates.
"
  (interactive "P")
  (org-time-stamp nil inactive)
  (insert "--")
  (org-time-stamp nil inactive))

(defun my-org-follow-link-after ()
  (when (eq major-mode 'mhtml-mode)
    (browse-url-of-buffer)))

;; navigation
(defun my-org-jump-to-last-visible-child ()
  "Goto the last visible child."
  (interactive)
  (let (level (pos (point)) (re org-outline-regexp-bol))
    (when (ignore-errors (org-back-to-heading t))
      (setq level (outline-level))
      (forward-char 1)
      (while (and (re-search-forward re nil t) (> (outline-level) level))
	      (when (and (= (outline-level) (1+ level))
		               (not (get-char-property (point) 'invisible)))
	        (setq pos (match-beginning 0)))))
    (goto-char pos)))

(defun my-org-entry-toggle-drawer-visibility ()
  (interactive)
  (save-excursion
    (save-restriction
      (org-narrow-to-subtree)
      (goto-char (point-min))
      (when (re-search-forward "^\\s-*:PROPERTIES:" nil t)
        (org-hide-drawer-toggle)))))

(defun my-org-open-default-notes-file ()
  (interactive)
  (find-file org-default-notes-file))

;; links
(defun my-org-substitute-gnus-link-after-archiving ()
  "Fix a captured gnus article link after they've been archived"
  (interactive)
  (when (org-in-regexp org-link-bracket-re)
    ;; We do have a link at point, and we are going to edit it.
    (save-excursion
      (let ((remove (list (match-beginning 0) (match-end 0)))
            (desc (when (match-end 2) (match-string-no-properties 2)))
            (link (match-string-no-properties 1))
            (target (alist-get 'archive my-gnus-group-default-targets)))
        (pcase-dolist (`(,re . ,info) my-gnus-group-alist)
          (when (and (string-match re link)
                     (alist-get 'archive info))
            (setq target (alist-get 'archive info))))
        (setq new-link
	            (replace-regexp-in-string "/.*?#" (format "/%s#" target)
                                        link))
        (apply #'delete-region remove)
        (insert (org-link-make-string new-link desc))
        (sit-for 0)))))

;; editing heading
(defun my-org-orgzly-merge-link ()
  "Fixes orgzly entries with links separated from headlines.
Find the first link in the entry, and add that to the headline
title, and remove the body."
  (interactive)
  (save-restriction
    (save-excursion
      (org-narrow-to-subtree)
      (goto-char (point-min))
      (forward-line)
      (when (re-search-forward org-link-any-re)
	      (let ((link (buffer-substring-no-properties
		                 (match-beginning 0) (match-end 0)))
              (unused (replace-match "" nil))
	            (desc (org-entry-get (point) "ITEM"))
              (title-loc))
          (goto-char (point-min))
          (search-forward desc nil t)
          (setq title-loc (match-beginning 0))
          (replace-match "" nil)
          (while (search-forward desc nil t) (replace-match "" nil))
	        (goto-char title-loc)
	        (insert (org-link-make-string link desc))))))
  (my-org-node-flush-empty-lines))

(defun my-org-node-flush-empty-lines ()
  (save-restriction
    (save-excursion
      (org-narrow-to-subtree)
      (flush-lines "^$"))))

(defun my-org-element-contents-at-point ()
  (let ((element (org-element-at-point)))
    (buffer-substring-no-properties
     (org-element-property :contents-begin element)
     (org-element-property :contents-end element))))


(defun my-org-append-subheading (arg)
	"Append a subheading as a first child, or with an arg as a last child."
	(interactive "P")
	(if arg
			(org-insert-subheading '(4))
		(let ((required-level (1+ (or (org-current-level) 0))))
			(org-show-children)
			(org-next-visible-heading 1)
			(org-insert-subheading nil)
			(while (> (org-current-level) required-level)
				(org-promote-subtree))
			(while (< (org-current-level) required-level)
				(org-demote-subtree)))))

;; copy a link
;;; fixme: do we still need this?
(defun my-org-copy-link-at-point ()
  (interactive)
  (let ((link (my-org-link-at-point)))
    (if link
        (progn
          (kill-new link)
          (message "Copied: %s" link))
      (message "Point is not an org link!"))))

(defun my-org-link-at-point ()
  (interactive)
  (when (org-in-regexp org-link-any-re)
    (org-unbracket-string "<" ">"
			(or
			 ;; [[target][desc]]
			 (match-string-no-properties 2)
			 ;; plain link or <...>
			 (match-string-no-properties 0)))))

(defun my-org-store-link-and-return ()
  "run org-goto to select a heading, stores its link and insert it."
  (interactive)
  (save-restriction
    (widen)
    (save-excursion
      (call-interactively 'org-goto)
      (call-interactively 'org-store-link)))
  (call-interactively 'org-insert-last-stored-link))

;; overload org-insert-all-links (do we need autoload as in the original file?)
(defun my-org-insert-all-links (arg &optional pre post)
  "Insert all links in `org-stored-links'.
When a universal prefix, do not delete the links from `org-stored-links'.
When `ARG' is a number, insert the last N link(s).
`PRE' and `POST' are optional arguments to define a string to
prepend or to append."
  (interactive "P")
  (let ((org-link-keep-stored-after-insertion (equal arg '(4)))
	      (links (copy-sequence org-stored-links))
	      (pr (or pre "- "))
	      (po (or post "\n"))
	      (cnt 1) l)
    (if (null org-stored-links)
	      (message "No link to insert")
      (while (and (or (listp arg) (>= arg cnt))
		              (setq l (if (listp arg)
			                        (pop links)
			                      (pop org-stored-links))))
	      (setq cnt (1+ cnt))
	      (insert pr)
	      (org-insert-link nil (car l) (or (cadr l) ""))
	      (insert po)))))

;; overload org-open-at-point-global to fix bug property link not
;; opened in external browser (2d0e61c8-da74-417e-8ccd-c4099ccd88d8)
(defun my-org-open-at-point-global (&optional arg)
  "Follow a link or a time-stamp like Org mode does.
Also follow links and emails as seen by `thing-at-point'.
This command can be called in any mode to follow an external
link or a time-stamp that has Org mode syntax.  Its behavior
is undefined when called on internal links like fuzzy links.
Raise a user error when there is nothing to follow."
  (interactive "P")
  (let ((tap-url (thing-at-point 'url))
	      (tap-email (thing-at-point 'email)))
    (cond ((org-in-regexp org-link-any-re)
	         (org-link-open-from-string (match-string-no-properties 0) arg))
	        ((or (org-in-regexp org-ts-regexp-both nil t)
	             (org-in-regexp org-tsr-regexp-both nil t))
	         (org-follow-timestamp-link))
	        (tap-url (org-link-open-from-string tap-url))
	        (tap-email (org-link-open-from-string
		                  (concat "mailto:" tap-email)))
	        (t (user-error "No link found")))))

;; overload org-refile-get-targets
(defun my-org-refile-get-targets (&optional default-buffer)
  "Produce a table with refile targets."
  (let ((case-fold-search nil)
	      ;; otherwise org confuses "TODO" as a kw and "Todo" as a word
	      (entries (or org-refile-targets '((nil . (:level . 1)))))
	      targets tgs files desc descre)
    (message "Getting targets...")
    (with-current-buffer (or default-buffer (current-buffer))
      (dolist (entry entries)
	      (setq files (car entry) desc (cdr entry))
	      (cond
	       ((null files) (setq files (list (current-buffer))))
	       ((eq files 'org-agenda-files)
	        (setq files (org-agenda-files 'unrestricted)))
	       ((and (symbolp files) (fboundp files))
	        (setq files (funcall files)))
	       ((and (symbolp files) (boundp files))
	        (setq files (symbol-value files))))
	      (when (stringp files) (setq files (list files)))
	      (cond
	       ((eq (car desc) :tag)
	        (setq descre (concat "^\\*+[ \t]+.*?:" (regexp-quote (cdr desc)) ":")))
	       ((eq (car desc) :todo)
	        (setq descre (concat "^\\*+[ \t]+" (regexp-quote (cdr desc)) "[ \t]")))
	       ((eq (car desc) :regexp)
	        (setq descre (cdr desc)))
	       ((eq (car desc) :level)
	        (setq descre (concat "^\\*\\{" (number-to-string
					                                (if org-odd-levels-only
					                                    (1- (* 2 (cdr desc)))
					                                  (cdr desc)))
			                         "\\}[ \t]")))
	       ((eq (car desc) :maxlevel)
	        (setq descre (concat "^\\*\\{1," (number-to-string
					                                  (if org-odd-levels-only
						                                    (1- (* 2 (cdr desc)))
					                                    (cdr desc)))
			                         "\\}[ \t]")))
	       (t (error "Bad refiling target description %s" desc)))
	      (dolist (f files)
	        (with-current-buffer (if (bufferp f) f (org-get-agenda-file-buffer f))
	          (or
	           (setq tgs (org-refile-cache-get
                        (buffer-file-name
                         (when (bufferp f) (buffer-base-buffer f)))
                        descre))
	           (progn
	             (when (bufferp f)
		             (setq f (buffer-file-name (buffer-base-buffer f))))
	             (setq f (and f (expand-file-name f)))
	             (when (eq org-refile-use-outline-path 'file)
		             (push (list (and f (file-name-nondirectory f)) f nil nil) tgs))
	             (when (eq org-refile-use-outline-path 'buffer-name)
		             (push (list (buffer-name (buffer-base-buffer)) f nil nil) tgs))
	             (when (eq org-refile-use-outline-path 'full-file-path)
		             (push (list (and (buffer-file-name (buffer-base-buffer))
                                  (file-truename (buffer-file-name (buffer-base-buffer))))
                             f nil nil) tgs))
	             (org-with-wide-buffer
		            (goto-char (point-min))
		            (setq org-outline-path-cache nil)
		            (while (re-search-forward descre nil t)
		              (beginning-of-line)
		              (let ((case-fold-search nil))
		                (looking-at org-complex-heading-regexp))
		              (let ((begin (point))
			                  (heading (match-string-no-properties 4)))
		                (unless (or (and
				                         org-refile-target-verify-function
				                         (not
				                          (funcall org-refile-target-verify-function)))
				                        (not heading))
		                  (let ((re (format org-complex-heading-regexp-format
					                              (regexp-quote heading)))
			                      (target
			                       (if (not org-refile-use-outline-path) heading
			                         (mapconcat
				                        #'identity
				                        (append
				                         (pcase org-refile-use-outline-path
				                           (`file (list
                                           (and (buffer-file-name (buffer-base-buffer))
                                                (file-name-nondirectory
                                                 (buffer-file-name (buffer-base-buffer))))))
				                           (`full-file-path
				                            (list (buffer-file-name
					                                 (buffer-base-buffer))))
				                           (`buffer-name
				                            (list (buffer-name
					                                 (buffer-base-buffer))))
				                           (_ nil))
				                         (mapcar (lambda (s) (replace-regexp-in-string
						                                          "/" "\\/" s nil t))
					                               (org-get-outline-path t t)))
				                        "/"))))
			                  (push (list target f re (org-refile-marker (point)))
			                        tgs)))
		                (when (= (point) begin)
		                  ;; Verification function has not moved point.
		                  (end-of-line)))))))
	          (when org-refile-use-cache
	            (org-refile-cache-put tgs (buffer-file-name) descre))
	          (setq targets (append tgs targets))))))
    (message "Getting targets...done")
    (delete-dups (nreverse targets))))

;; shadow org-insert-last-stored-link (do not insert \n at the end)
(defun my-org-insert-last-stored-link (arg)
  "Insert the last link stored in `org-stored-links'."
  (interactive "p")
  (org-insert-all-links arg "" ""))

(defun my-org-info-open-new-window (path)
  "Open info in a new buffer"
  (my-select-new-window-matching-mode 'Info-mode)
  (org-info-follow-link path))

(defun my-org-rt-open-new-window (path)
  "Open rt in a new buffer"
  (my-select-new-window-matching-mode 'rt-liber-browser-mode)
  (rt-org-open path))

;; fix org src overlay face
(defun my-org-src--make-source-overlay (beg end edit-buffer)
  "Create overlay between BEG and END positions and return it.
EDIT-BUFFER is the buffer currently editing area between BEG and
END."
  (let ((overlay (make-overlay beg end)))
    (overlay-put overlay 'face 'region)
    (overlay-put overlay 'edit-buffer edit-buffer)
    (overlay-put overlay 'help-echo
		             "Click with mouse-1 to switch to buffer editing this segment")
    (overlay-put overlay 'face 'region)
    (overlay-put overlay 'keymap
		             (let ((map (make-sparse-keymap)))
		               (define-key map [mouse-1] 'org-edit-src-continue)
		               map))
    (let ((read-only
	         (list
	          (lambda (&rest _)
	            (user-error
	             "Cannot modify an area being edited in a dedicated buffer")))))
      (overlay-put overlay 'modification-hooks read-only)
      (overlay-put overlay 'insert-in-front-hooks read-only)
      (overlay-put overlay 'insert-behind-hooks read-only))
    overlay))

(defun my-org-copy-property-value (name)
  (interactive
   (list (completing-read "Copy property: " (org-entry-properties))))
  (let ((value (org-entry-get (point) name)))
    (kill-new value)
    (message "Copied %s" value)))

(defvar my-org-common-properties nil
  "Property list for completion when setting the property of an org node, to
  avoid scanning the whole notes.")

(defun my-org-set-common-property ()
  (interactive)
  (let* ((property
          (completing-read "Which property to set: "
                           my-org-common-properties))
         (value
          (org-read-property-value property)))
    (org-set-property property value)))

(defun my-org-copy-src-block-at-point ()
  (interactive)
  (when (org-in-src-block-p)
    (kill-new (nth 1 (org-babel-get-src-block-info t)))
    (message "org src block copied!")))
(defun my-org-in-or-at-block-p ()
  (or (org-at-block-p)
      (org-in-block-p '("example" "source" "export"
                        "center" "quote" "verse"))))
(defun my-org-copy-block-at-point ()
  (interactive)
  (save-excursion
    (unless (org-at-block-p)
      (org-previous-block 1)
      (let ((element (org-element-at-point)))
        (kill-new (or
                   (org-element-property :value element)
                   (buffer-substring
                    (org-element-property :contents-begin element)
                    (org-element-property :contents-end element))))
        (message "org block copied!")))))

;; clock save timer doesn't seem to be working
(defun my-org-clock-maybe-save ()
  (when (equal major-mode 'org-mode)
    (org-clock-save)))

(defun my-org-refile-cache-rebuild ()
  (org-refile-cache-clear)
  (org-refile-get-targets))

(defun my-org-store-agenda-view-A ()
  (interactive)
  (org-store-agenda-views)
  (my-org-agenda-ensure-A))

(defun my-org-agenda-priority-0 ()
  (interactive)
  (org-agenda-priority ?\ ))
(defun my-org-agenda-priority-A ()
  (interactive)
  (org-agenda-priority ?A))
(defun my-org-agenda-priority-B ()
  (interactive)
  (org-agenda-priority ?B))
(defun my-org-agenda-priority-C ()
  (interactive)
  (org-agenda-priority ?C))

(defun my-org-next-block-or-results (arg &optional backward)
  "Jump to the next block or results.

With a prefix argument ARG, jump forward ARG many blocks.

When BACKWARD is non-nil, jump to the previous block.

When BLOCK-REGEXP is non-nil, use this regexp to find blocks.
Match data is set according to this regexp when the function
returns.

Return point at beginning of the opening line of found block.
Throw an error if no block is found."
  (interactive "p")
  (let ((re "^[ \t]*#\\+\\(BEGIN\\|RESULTS:\\)")
	      (case-fold-search t)
	      (search-fn (if backward #'re-search-backward #'re-search-forward))
	      (count (or arg 1))
	      (origin (point))
	      last-element)
    (if backward (beginning-of-line) (end-of-line))
    (while (and (> count 0) (funcall search-fn re nil t))
      (let ((element (save-excursion
		                   (goto-char (match-beginning 0))
		                   (save-match-data (org-element-at-point)))))
	      (when (and (memq (org-element-type element)
			                   '(center-block comment-block dynamic-block
					                              example-block export-block quote-block
					                              special-block src-block verse-block fixed-width))
		               (<= (match-beginning 0)
		                   (org-element-property :post-affiliated element)))
	        (setq last-element element)
	        (cl-decf count))))
    (if (= count 0)
	      (prog1 (goto-char (org-element-property :post-affiliated last-element))
	        (save-match-data (org-show-context)))
      (goto-char origin)
      (user-error "No %s code blocks" (if backward "previous" "further")))))

(defun my-org-previous-block-or-results (arg)
  "Jump to the previous block or results.
With a prefix argument ARG, jump backward ARG many source blocks.
When BLOCK-REGEXP is non-nil, use this regexp to find blocks."
  (interactive "p")
  (my-org-next-block-or-results arg t))

;; override org-next-link to include search in any places, including property
;; drawers.
;; TODO: not working yet
;; https://lists.gnu.org/archive/html/emacs-orgmode/2020-01/msg00186.html
(defun my-org-next-link ()
  (interactive)
  (when (org-in-regexp org-any-link-re)
    (re-search-forward org-any-link-re nil t))
  (re-search-forward org-any-link-re nil t)
  (re-search-backward org-any-link-re nil t)
  (when-let ((link (org-element-lineage (org-element-context) '(link) t)))
    (goto-char (org-element-property :begin link)))
  (when (org-invisible-p) (org-show-context)))

(defun my-org-previous-link ()
  (interactive)
  (re-search-backward org-any-link-re nil t)
  (when-let ((link (org-element-lineage (org-element-context) '(link) t)))
    (goto-char (org-element-property :begin link)))
  (when (org-invisible-p) (org-show-context)))

(defun my-org-attach-edit-attached-image ()
  (interactive)
  (start-process
   "pinta" nil "/usr/bin/pinta"
   (concat (org-attach-dir) "/"
	         (org-element-property :path (org-element-context)))))

(defun my-org-capture-place-template-dont-delete-windows (oldfun args)
  (cl-letf (((symbol-function 'delete-other-windows) 'ignore))
    (apply oldfun args)))

(defvar my-org-attach-copy-attached-targets nil
  "Alist of targets to copy attached to, in the form of (name . path)")
(defvar my-org-attach-copy-attached-doc-exts
  '("epub" "pdf" "mobi"))
(defvar my-org-attach-copy-attached-doc-re
  (format "\\.\\(%s\\)$"
          (string-join
           my-org-attach-copy-attached-doc-exts "\\|")))

(defun my-org-attach-copy-attached-docs ()
  (interactive)
  (let* ((name
          (completing-read "Copy attached docs to: "
                           my-org-attach-copy-attached-targets))
         (path (alist-get name my-org-attach-copy-attached-targets
                          nil nil #'equal)))
    (let ((basedir (org-attach-dir)))
      (dolist (attached (org-attach-file-list basedir))
        (when (string-match my-org-attach-copy-attached-doc-re attached)
	        (message "Copying %s to %s (%s)..." attached name path)
	        (copy-file (file-name-concat basedir attached)
		                 (file-name-concat
                      path
			                (replace-regexp-in-string ":" "_" attached)))
	        (message "Done!")))))
  )

(defun my-org-attach-all-url-plaintext (arg)
  (interactive "P")
  (dolist (url (my-org-http-s-links-in-entry))
    (my-org-attach-url-plaintext url)))

(defun my-org-attach-url-plaintext (url)
  (interactive (list (completing-read "Url to fetch: " (my-org-http-s-links-in-entry))))
  (my-org-attach-url-plaintext-internal url current-prefix-arg t))

(defun my-org-attach-url-plaintext-all-media (url)
  (interactive (list (completing-read "Url to fetch: "
                                      (my-org-http-s-links-in-entry))))
  (my-org-attach-url-plaintext-internal url current-prefix-arg t t))

(defun my-org-attach-url (url)
  (interactive (list (completing-read "Url to fetch: "
                                      (my-org-http-s-links-in-entry))))
  (let* ((url (my-rewrite-url url))
         (filename (expand-file-name (my-make-filename-from-url url)
                                     (org-attach-dir t))))
    (my-wget-async url filename current-prefix-arg)))

(defun my-org-attach-url-plaintext-internal (url &optional no-tor move-if-large save-all-media)
  (let* ((lynx-buffer (format "*lynx %s*" url))
         (url (my-rewrite-url url))
         (filename (expand-file-name (my-make-filename-from-url url)
                                     (org-attach-dir t)))
         (coding-system-for-write 'utf-8))
    (ignore-errors (kill-buffer lynx-buffer))
    (my-touch-new-file filename)
    (org-attach-sync)
    (set-process-sentinel
     (my-start-process-with-torsocks
      current-prefix-arg
      "org-lynx" lynx-buffer "lynx" "-dump" "--display_charset" "utf-8" url)
     (lambda (process event)
       (with-current-buffer (process-buffer process)
         (goto-char (point-min))
         (write-file filename)
         (message "Lynx dumped to: %s" filename)
         (when save-all-media
           (when-let ((urls (http-s-media-links-in-buffer)))
             (message "Downloading %d media files..." (length urls))
             (wget-async-urls-with-prefix
              urls (concat filename "-") no-tor move-if-large))))))))

;; node creation; start of grok
;; FIXME: decouple clients from org
(defun my-org-create-node (info &optional attach)
  (cond ((alist-get "Authors" info nil nil 'string=)
	       (my-org-create-book-node info attach))
	      ((alist-get "Director" info nil nil 'string=)
	       (my-org-create-video-node info attach))
	      ((and (alist-get "Developers" info nil nil 'string=)
              (string-match "\\<game\\>"
                            (alist-get "Description" info nil nil 'string=)))
	       (my-org-create-video-game-node info attach))
        ((alist-get "Developers" info nil nil 'string=)
         (my-org-create-software-node info attach))
	      ((alist-get "Designers" info nil nil 'string=)
	       (my-org-create-game-node info attach))
	      ((alist-get "Founded" info nil nil 'string=)
         (my-org-create-organisation-node info attach))
        ((alist-get "Latitude" info nil nil 'string=)
	       (my-org-create-location-node info attach))
        ((alist-get "Born" info nil nil 'string=)
         (my-org-create-people-node info attach))
	      (t (my-org-create-entity-node info attach))))

(defun my-org-attach-and-add-properties-to-node (info attach)
  (when (and attach (alist-get "Cover" info nil nil 'string=))
    (ignore-error 'file-already-exists
      (org-attach-url (alist-get "Cover" info nil nil 'string=)))
    (setq info (assoc-delete-all "Cover" info 'string=)))
  (dolist (pair info)
    (when (and (cdr pair) (string> (cdr pair) ""))
      (org-entry-put (point)
		                 (decode-coding-string (car pair) 'utf-8)
		                 (decode-coding-string (cdr pair) 'utf-8))))
  (org-entry-put (point) "CREATED"
                 (format-time-string "[%Y-%m-%d %a %H:%M]" (current-time)))
  (org-attach-sync)
  (when (buffer-narrowed-p)
    (goto-char (point-min))))

(defun my-org-create-book-node (book-info attach)
  (org-capture nil "book")
  (insert (format
	         "%s - %s - %s"
	         (or (alist-get "Authors" book-info "" nil 'string=) "")
	         (alist-get "Title" book-info "" nil 'string=)
	         (my-extract-year
	          (alist-get "Published" book-info "" nil 'string=))))
  (my-org-attach-and-add-properties-to-node book-info attach))
(defun my-org-create-video-node (video-info attach)
  (org-capture nil "video")
  (insert (format
	         "%s - %s - %s"
	         (alist-get "Director" video-info "" nil 'string=)
	         (alist-get "Title" video-info "" nil 'string=)
	         (my-extract-year
	          (alist-get "Released" video-info "" nil 'string=))))
  (my-org-attach-and-add-properties-to-node video-info attach))
(defun my-org-create-location-node (book-info attach)
  (org-capture nil "location")
  (insert (format
	         "%s"
	         (alist-get "Title" book-info "" nil 'string=)))
  (my-org-attach-and-add-properties-to-node book-info attach))
(defun my-org-create-game-node (game-info attach)
  (org-capture nil "game")
  (insert (format
	         "%s - %s - %s"
	         (alist-get "Designers" game-info "" nil 'string=)
	         (alist-get "Title" game-info "" nil 'string=)
	         (my-extract-year
	          (alist-get "Published" game-info "" nil 'string=))))
  (my-org-attach-and-add-properties-to-node game-info attach))
(defun my-org-create-video-game-node (game-info attach)
  (org-capture nil "videogame")
  (insert (format
	         "%s - %s - %s"
	         (alist-get "Developers" game-info "" nil 'string=)
	         (alist-get "Title" game-info "" nil 'string=)
	         (my-extract-year
	          (alist-get "Released" game-info "" nil 'string=))))
  (my-org-attach-and-add-properties-to-node game-info attach))
(defun my-org-create-software-node (software-info attach)
  (org-capture nil "software")
  (insert (format
	         "%s - %s"
           (alist-get "Title" software-info "" nil 'string=)
	         (my-extract-year
	          (alist-get "Released" software-info "" nil 'string=))))
  (my-org-attach-and-add-properties-to-node software-info attach))
(defun my-org-create-organisation-node (organisation-info attach)
  (org-capture nil "organisation")
  (insert (format
	         "%s - %s"
           (alist-get "Title" organisation-info "" nil 'string=)
           (my-extract-year
            (alist-get "Founded" organisation-info "" nil 'string=))))
  (my-org-attach-and-add-properties-to-node organisation-info attach))
(defun my-org-create-people-node (people-info attach)
  (org-capture nil "people")
  (insert (format
	         "%s - %s-%s"
           (alist-get "Title" people-info "" nil 'string=)
           (my-extract-year (alist-get "Born" people-info "" nil 'string=))
           (my-extract-year (alist-get "Died" people-info "" nil 'string=))))
  (my-org-attach-and-add-properties-to-node people-info attach))
(defun my-org-create-pacman-software-node (package)
  (interactive "sPacman package name: ")
  (my-org-create-software-node (my-grok-pacman package) nil))
(defun my-org-create-entity-node (entity-info attach)
  (org-capture nil "entity")
  (insert (format
	         "%s"
	         (alist-get "Title" entity-info "" nil 'string=)))
  (my-org-attach-and-add-properties-to-node entity-info attach))
(defun my-org-create-audio-node (audio-info attach)
  (org-capture nil "ya")
  (insert (format
	         "%s - %s - %s"
	         (or (alist-get "Authors" audio-info "" nil 'string=) "")
	         (alist-get "Title" audio-info "" nil 'string=)
	         (my-extract-year
	          (alist-get "Published" audio-info "" nil 'string=))))
  (my-org-attach-and-add-properties-to-node audio-info attach))

;; TODO: these requires are unnecessary for more essential functionalities of
;; org customisation. Find a way to delay them
(require 'my-wikipedia)
(require 'my-github)
(require 'my-gitlab)
(require 'my-pacman)
(require 'my-openlibrary)
(defun my-grok-dispatcher (url)
  (when-let ((host (url-host (url-generic-parse-url url))))
    (cond ((string-match "wikipedia\\.org" host) 'my-grok-wikipedia)
          ((string-match "github\\.com" host) 'my-grok-github)
          ((string-match "\\(gitlab\\.\\|salsa.debian.org\\)" host)
           'my-grok-gitlab)
          ((string-match "openlibrary.org" host) 'my-grok-openlibrary)
          (t nil))))
(defun my-grok-update-properties ()
  (interactive)
  (when-let* ((url (org-entry-get (point) "Source"))
              (source-dispatcher (my-grok-dispatcher url)))
    (my-org-attach-and-add-properties-to-node
     (funcall source-dispatcher url) t))
  (when-let ((isbn (org-entry-get (point) "ISBN")))
    (my-org-attach-and-add-properties-to-node (my-grok-openlibrary-isbn isbn) t))
  (when-let ((url (org-entry-get (point) "OpenLibrary-link")))
    (my-org-attach-and-add-properties-to-node (my-grok-openlibrary url) t))
  (when-let ((package (org-entry-get (point) "Pacman-package-name")))
    (my-org-attach-and-add-properties-to-node (my-grok-pacman package) nil))
  (when-let ((url (org-entry-get (point) "Wikipedia-link")))
    (my-org-attach-and-add-properties-to-node (my-grok-wikipedia url) t)))
(defun my-org-protocol-grok (data)
  (when-let ((url (plist-get data :url)))
    (my-org-grok url))
  nil)

(defun my-org-grok (url)
  (when-let* ((grok-fun (my-grok-dispatcher url))
              (info (funcall grok-fun url)))
    (my-org-create-node info t)))

(defun my-eww-org-protocol-grok ()
  "grok from eww"
  (interactive)
  (org-protocol-grok
   (list :url (plist-get eww-data :url))))

;; org capture rss
(defun my-org-rss-xml-create-audio-node (url)
  (interactive (list (read-string "Feed URL: "
				                          (thing-at-point-url-at-point))))
  (my-org-rss-xml-create-node url 'my-org-create-audio-node))
(defun my-org-rss-xml-create-book-node (url)
  (interactive (list (read-string "Feed URL: "
				                          (thing-at-point-url-at-point))))
  (my-org-rss-xml-create-node url 'my-org-create-book-node))
(defun my-org-rss-xml-create-node (url create-node-fun)
  (let* ((xml
	        (with-current-buffer (url-retrieve-synchronously url)
	          (my-skip-http-header)
	          (car (xml-parse-region (point) (point-max)))))
	       (channel (my-xml-get-first-child xml 'channel))
	       )
    (funcall create-node-fun
	           (list
	            (cons "Feed-url" url)
	            (cons "Title" (decode-coding-string
                             (my-xml-get-first-child-text channel 'title) 'utf-8))
	            (cons "Description"
		                (decode-coding-string
                     (my-xml-get-first-child-text channel 'description) 'utf-8))
	            (cons "Website" (my-xml-get-first-child-text channel 'link))
	            (cons "Cover"
		                (or (my-xml-get-first-child-text
			                   (my-xml-get-first-child channel 'image) 'url)
			                  (dom-attr
			                   (my-xml-get-first-child channel 'itunes:image) 'href)))
	            (cons "Authors" (my-xml-get-first-child-text
                               channel 'itunes:author)))
	           t)))

(require 'my-algo)
(defun my-radix-org-from-tree (tree)
  (let ((radix-tree-type 'vector))
    (radix-tree-iter-subtrees
     tree
     (my-radix-org-iter-n 1 []))))

(defun my-radix-org-iter-n (depth prefix)
  (lambda (p s)
    (let ((nprefix (seq-concatenate radix-tree-type prefix p)))
      (insert (make-string depth ?*) " ")
      (pcase s
        ((radix-tree-leaf v) (insert "[[" (string-join nprefix "/") "][" (string-join p "/") "]]" "\n"))
        (_
         (insert (string-join p "/") "\n")
         (radix-tree-iter-subtrees s (my-radix-org-iter-n (1+ depth) nprefix)))))))

(defun my-radix-org ()
  (interactive)
  (let* ((file-name (buffer-file-name))
         (buffer-name (file-name-with-extension
                       (file-name-base file-name)
                       "org"))
         (save-file-name (file-name-with-extension file-name "org"))
         (tree (let ((max-lisp-eval-depth 32000))
                 (save-excursion (my-radix-tree-from-list)))))
    (with-current-buffer (get-buffer-create buffer-name)
      (org-mode)
      (erase-buffer)
      (my-radix-org-from-tree tree)
      (goto-char (point-min)))
    (switch-to-buffer buffer-name)))

;;; format org mode elements
(defun my-org-format-link (url text)
  (format "[[%s][%s]]" url text))

(defun my-org-format-heading (text level)
  (format "%s %s"
          (make-string level ?*) text))

(defun my-org-update-updated ()
  (interactive)
  (when (derived-mode-p 'org-mode)
    (org-entry-put
     (point) "UPDATED"
     (format-time-string "[%Y-%m-%d %a %H:%M]" (current-time)))))

;;; override org-recoll-format-results
(defun my-org-recoll-format-results ()
  (require 'org-recoll)
  "Format recoll results in buffer."
  ;; Format results in org format and tidy up
  (org-recoll-regexp-replace-in-buffer
   "^.*?\\[\\(.*?\\)\\]\\s-*\\[\\(.*?\\)\\]\\(.*\\)$"
   "* [[\\1][\\2]] <\\1>\\3")
  (org-recoll-regexp-replace-in-buffer
   (format "<file://.*?%s\\(.*/\\).*>" (substring my-docs-root-dir 1))
   "(\\1)")
  (org-recoll-regexp-replace-in-buffer "\\/ABSTRACT" "")
  (org-recoll-regexp-replace-in-buffer "ABSTRACT" "")
  ;; Justify results
  (goto-char (point-min))
  (org-recoll-fill-region-paragraphs)
  ;; Add emphasis
  (highlight-phrase (org-recoll-reformat-for-file-search
                     org-recoll-search-query)
                    'bold-italic))

(defun my-org-recoll-mdn (query)
  (interactive "sSearch mdn: ")
  (org-recoll-search (format "%s dir:mdn" query)))

(defun my-org-recoll-python (query)
  (interactive "sSearch python: ")
  (org-recoll-search (format "%s dir:python-3.9.7-docs-html" query)))

(defun my-org-recoll-php (query)
  (interactive "sSearch php: ")
  (org-recoll-search (format "%s dir:php-chunked-xhtml" query)))

(defun my-org-recoll-yesod (query)
  (interactive "sSearch yesod: ")
  (org-recoll-search (format "%s dir:yesod-cookbook OR dir:yesodweb.com" query)))

(defun my-org-entry-at-point-to-tsv (id)
  (string-join
   (cons (number-to-string id)
         (mapcar
          (lambda (key) (org-entry-get (point) key))
          (list "ITEM" "Referral" "Wikipedia-link" "IMDB-link")))
   "\t"))

(defvar org-entries-tsv-buffer "*org-entries-tsv*")
(defun my-org-entries-at-point-to-tsv (beg end)
  (interactive "r")
  (with-current-buffer (get-buffer-create org-entries-tsv-buffer)
    (erase-buffer))
  (let ((row) (id 0))
    (save-excursion
      (goto-char beg)
      (while (< (point) end)
        (when (equal (org-entry-get (point) "TODO") "TODO")
          (setq row (my-org-entry-at-point-to-tsv id))
          (with-current-buffer org-entries-tsv-buffer
            (insert row "\n"))
          (setq id (1+ id)))
        (org-next-visible-heading 1))))
  (switch-to-buffer-other-window org-entries-tsv-buffer))

(defun my-org-entries-attach-plaintext-all-media (beg end)
  (interactive "r")
  (save-excursion
    (goto-char beg)
    (while (< (point) end)
      (my-org-attach-url-plaintext-all-media (car (my-org-http-s-links-in-entry)))
      (org-next-visible-heading 1))))

(defvar my-org-doc-dir nil "Directory to docs written in org.")
(defun my-org-open-org-doc (filename)
  (interactive
   (list
    (completing-read
     "Open org doc: "
     (mapcar (lambda (name) (substring name (length my-org-doc-dir)))
             (directory-files-recursively my-org-doc-dir "\\.org$")))))
  (find-file (concat my-org-doc-dir filename)))

(defun my-org-open-org-file (filename)
  (interactive
   (list
    (completing-read
     "Open org file: "
     (directory-files org-directory nil "\\.org$"))))
  (find-file (file-name-concat org-directory filename)))

(defun my-org-agenda-after-show () (beginning-of-line 1))

(defun my-org-agenda-ensure-A ()
  (org-agenda nil "A")
  (unless (get-text-property (point) 'org-series-redo-cmd)
    (kill-buffer)
    (org-agenda nil "A")))

(defun my-org-agenda-redo-all ()
  (interactive)
  (message "time now is %s"
           (format-time-string "%Y-%m-%d %a %H:%M:%S" (current-time)))
  (my-org-agenda-ensure-A)
  (dolist (buffer (buffer-list))
    (with-current-buffer buffer
      (when (derived-mode-p 'org-agenda-mode)
        (print buffer)
        (org-agenda-redo t)))))

(defun my-org-copy-dwim ()
  (interactive)
  (cond ((org-in-src-block-p)
	       (my-org-copy-src-block-at-point))
        ((my-org-in-or-at-block-p) (my-org-copy-block-at-point))
        (t (org-refile-copy))))

;; to override `org--mouse-open-at-point' - we don't want
;; `org-open-at-point' to toggle a checkbox when point is at the
;; beginning of a link
(defun my-org--mouse-open-at-point (orig-fun &rest args)
  (let ((context (org-context)))
    (cond
     ((assq :headline-stars context) (org-cycle))
     ((assq :item-bullet context)
      (let ((org-cycle-include-plain-lists t)) (org-cycle)))
     ((org-footnote-at-reference-p) nil)
     (t (apply orig-fun args)))))

(provide 'my-org)
;;; my-org.el ends here