bir/bir-extract.el

;;; bir-extract.el --- Extracting functions for BIR  -*- lexical-binding: t; -*-

;; Copyright (C) 2021  c1-g

;; Author: c1-g <char1iegordon@protonmail.com>
;; Keywords: multimedia

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

;; This program 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 General Public License for more details.

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

;;; Commentary:

;;; Code:
(require 'org-roam)
(require 'org-fc)

(defun bir-extract-region (beg end &optional text interactive)
  "docstring"
  (interactive
   (let ((id (org-id-get-create)))
     (list (region-beginning) (region-end) nil t)))
  (let* ((text (or text (buffer-substring beg end)))
         (article-title (if (= (org-outline-level) 0)
                            (cadar (org-collect-keywords '("TITLE")))
                          (save-excursion (while (org-up-heading-safe))
                                          (or (org-entry-get nil "title")
                                              (nth 4 (org-heading-components))))))
         (article-prop (org-entry-get nil bir-article-property t t))
         (article-id (or article-prop
                         (plist-get (org-element--get-global-node-properties) :ID)
                         (save-excursion (while (org-up-heading-safe))
                                         (org-id-get-create))))
         (article (or article-prop
                      (org-link-make-string (concat "id:" article-id) article-title)))
         (parent-title (if (= (org-outline-level) 0)
                           (cadar (org-collect-keywords '("TITLE")))
                         (save-excursion (or (org-entry-get nil "title")
                                             (org-up-heading-safe)
                                             (nth 4 (org-heading-components))))))
         (parent (save-excursion
                   (org-back-to-heading-or-point-min t)
                   (if (string= (org-id-get) article-id)
                       article
                     (org-link-make-string (concat "id:" (org-id-get-create))
                                           parent-title))))
         (template-info nil)
         (node (org-roam-node-at-point))
         (refs (ignore-errors (org-roam-node-refs (org-roam-node-from-id article-id))))
         (template (org-roam-format-template
                    (string-trim (org-capture-fill-template org-roam-extract-new-file-path))
                    (lambda (key default-val)
                      (let ((fn (intern key))
                            (node-fn (intern (concat "org-roam-node-" key)))
                            (ksym (intern (concat ":" key))))
                        (cond
                         ((fboundp fn)
                          (funcall fn node))
                         ((fboundp node-fn)
                          (funcall node-fn node))
                         (t (let ((r (read-from-minibuffer (format "%s: " key) default-val)))
                              (plist-put template-info ksym r)
                              r)))))))
         (file-path (expand-file-name template (file-name-as-directory org-roam-directory)))
         id)
    (when (file-exists-p file-path)
      (user-error "%s exists. Aborting" file-path))
    (with-temp-buffer
      (org-mode)
      (org-set-property bir-article-property article)
      (org-set-property bir-parent-property parent)
      (when refs (org-roam-property-add "ROAM_REFS" (concat "cite:&" (car refs))))
      (write-region (point-min) (point-max) file-path nil t nil t)
      (setq id (org-id-get-create))
      (if interactive
          (funcall (intern (format "org-fc-type-%s-init" (completing-read "Which type?: " org-fc-types))))
        (org-fc-type-topic-init))
      (goto-char (point-max))
      (insert "\n" text "\n")
      (save-buffer))
    (when (and (not buffer-read-only) (eq major-mode 'org-mode))
      (delete-region beg end)
      (insert (org-link-make-string (concat "extract:" id) text)))
    (when interactive
      (find-file file-path))
    id))

(defun bir-extract-cloze (beg end &optional hint interactive)
  "docstring"
  (interactive
   (let ((id (org-id-get-create)))
     (list (region-beginning) (region-end) (read-string "Hint (optional): ") t)))
  (let* ((article-title (if (= (org-outline-level) 0)
                            (org-collect-keywords '("TITLE"))
                          (save-excursion (while (org-up-heading-safe))
                                          (or (org-entry-get nil "title")
                                              (nth 4 (org-heading-components))))))
         (article-prop (org-entry-get nil bir-article-property t))
         (article-id (or (plist-get (org-element--get-global-node-properties) :ID)
                         (when article-prop
                           (progn (string-match org-link-bracket-re article-prop)
                                  (substring-no-properties (match-string 1 article-prop) 3)))
                         (save-excursion (while (org-up-heading-safe))
                                         (org-id-get-create))))
         (article (or (org-entry-get nil bir-article-property t t)
                      (org-link-make-string (concat "id:" article-id) article-title)))
         (parent (save-excursion
                   (org-back-to-heading-or-point-min t)
                   (if (string= (org-id-get) article-id)
                       article
                     (org-link-make-string (concat "id:" (org-id-get-create))
                                           (if (org-at-heading-p)
                                               (nth 4 (org-heading-components))
                                             "")))))
         (template-info nil)
         (node (org-roam-node-at-point))
         (refs (ignore-errors (org-roam-node-refs (org-roam-node-from-id article-id))))
         (template (org-roam-format-template
                    (string-trim (org-capture-fill-template org-roam-extract-new-file-path))
                    (lambda (key default-val)
                      (let ((fn (intern key))
                            (node-fn (intern (concat "org-roam-node-" key)))
                            (ksym (intern (concat ":" key))))
                        (cond
                         ((fboundp fn)
                          (funcall fn node))
                         ((fboundp node-fn)
                          (funcall node-fn node))
                         (t (let ((r (read-from-minibuffer (format "%s: " key) default-val)))
                              (plist-put template-info ksym r)
                              r)))))))
         (file-path (expand-file-name template (file-name-as-directory org-roam-directory)))
         (origin-file (buffer-file-name))
         id)
    (when (file-exists-p file-path)
      (user-error "%s exists. Aborting" file-path))
    (with-temp-buffer
      (insert-file-contents origin-file)
      (org-fc--region-to-cloze beg end nil hint)
      (org-mode)
      (org-with-point-at (point-min)
        (org-set-property bir-article-property article)
        (org-set-property bir-parent-property parent)
        (when refs (org-roam-property-add "ROAM_REFS" (concat "cite:&" (car refs)))))
      (org-delete-property "id")
      (write-region (point-min) (point-max) file-path nil t nil t)
      (ignore-errors (org-fc--deinit-card))
      (setq id (org-id-get-create))
      (save-buffer)
      (revert-buffer-quick)
      (if interactive
          (call-interactively #'org-fc-type-cloze-init)
        (org-fc-type-cloze-init 'deletion))
      (save-buffer))
    (when interactive
      (find-file file-path))
    id))

(defun bir-extract-subtree ()
  "Convert current subtree at point to a node, and extract it into a new file."
  (save-excursion
    (org-id-get-create)
    (let* ((template-info nil)
           (title (org-roam-get-keyword "TITLE"))
           (article-prop (org-entry-get nil bir-article-property t))
           (article-id (or (plist-get (org-element--get-global-node-properties) :ID)
                           (when article-prop
                             (progn (string-match org-link-bracket-re article-prop)
                                    (substring-no-properties (match-string 1 article-prop) 3)))
                           (save-excursion (while (org-up-heading-safe))
                                           (org-id-get-create))))
           (article (org-link-make-string (concat "id:" article-id) title))
           (parent (save-excursion
                     (org-up-heading-safe)
                     (if (string= (org-id-get-create) article-id)
                         article
                       (org-link-make-string (concat "id:" (org-id-get-create))
                                             (org-get-heading t t t t)))))
           (node (org-roam-node-at-point))
           (refs (org-roam-node-refs (org-roam-node-from-id article-id)))
           (template (org-roam-format-template
                      (string-trim (org-capture-fill-template org-roam-extract-new-file-path))
                      (lambda (key default-val)
                        (let ((fn (intern key))
                              (node-fn (intern (concat "org-roam-node-" key)))
                              (ksym (intern (concat ":" key))))
                          (cond
                           ((fboundp fn)
                            (funcall fn node))
                           ((fboundp node-fn)
                            (funcall node-fn node))
                           (t (let ((r (read-from-minibuffer (format "%s: " key) default-val)))
                                (plist-put template-info ksym r)
                                r)))))))
           (file-path (expand-file-name template (file-name-as-directory org-roam-directory)))
           (id (org-id-get)))
      (unless (file-exists-p file-path)
        (let ((kill-do-not-save-duplicates t))
          (org-cut-subtree))
        (with-temp-buffer
          (org-set-property bir-article-property article)
          (org-set-property bir-parent-property parent)
          (when refs (org-set-property "ROAM_REFS" (concat "cite:&" (car refs))))
          (org-paste-subtree 1 nil nil t)
          (write-region (point-min) (point-max) file-path nil t)
          (org-fc-type-topic-init)
          (save-buffer)
          (org-roam-db-update-file)
          id)))))

(provide 'bir-extract)
;;; bir-extract.el ends here