;;; ulang.el --- ulang compliance lib -*- lexical-binding:t -*-

 ;; Copyright (C) 2023  

 ;; Author:  <ellis@zor>

 ;; Keywords: comm

 ;; 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)

 (require 'org-element)

 (require 'ox)

 (defgroup ulang nil

   "CC Universal Language.")

 (defvar ulang-link-history nil)

 (defvar ulang-file-history nil)

 ;; see org-special-properties

 (defvar ulang-special-properties

   '("VERSION"))

 ;;;###autoload

 (defun dblock-insert-links (regexp)

   "Create dblock to insert links matching REGEXP."

   (interactive (list (read-regexp "Insert links matching: " nil ulang-link-history)))

   (org-create-dblock (list :name "links"

                            :regexp regexp

                            :id-only nil))

   (org-update-dblock))

 (org-dynamic-block-define "links" 'dblock-insert-links)

 ;; (org-export-translate-to-lang (list '("Table of Contents" "Index")) "ulang")

 ;; (setq org-export-global-macros nil)

 ;; todo keywords

 (setq org-stuck-projects '("+PROJECT/-DONE" ("NEXT") nil ""))

 (setq org-todo-keywords

       '((sequence "TBD(0!)" "TODO(t!)" "NEXT(n!)" "WIP(i!)" "|" "DONE(d!)")

         (sequence "HOLD(H@/!)" "WIP(!)" "|")

         (sequence "WAIT(W@/!)" "WIP(!)" "|")

         (sequence "RESEARCH(s!)" "WIP(!)" "REPORT(c!)" "|")

         (sequence "OUTLINE(O!)" "DRAFT(M!)" "REVIEW(V!)" "|")

         (sequence "FIXME(f!)" "WIP(!)" "TEST(T!)" "|")

         (type "FIND(q!)" "READ(r@!)" "WATCH(A@!)" "HACK(h!)"

               "CODE(c!)" "BENCH(b!)" "DEPLOY(D!)" "RUN(X!)"

               "REFILE(w!)" "LOG(L!)" "GOTO(g!)" "|")

         (type "PROJECT(p!)" "PRODUCT(P!)" "SPRINT(S!)" "RELEASE(R!)" "|")

         (sequence "|" "DONE(d!)" "NOPE(x@!)")))

 (setq org-todo-keyword-faces

       '(("PROJECT" . (:foreground "lightseagreen" :weight bold))

         ("PRODUCT" . (:foreground "olivedrab" :weight bold))

         ("RELEASE" . (:foreground "maroon3" :weight bold))

         ("RESEARCH" . (:foreground "maroon2" :weight bold))

         ("HACK" . (:foreground "maroon3" :weight bold))

         ("TBD" . (:foreground "brown" :weight bold))

         ("CODE" . (:foreground "bisque" :weight bold :background "midnightblue"))

         ("HOLD" . (:foreground "red1" :weight bold :background "yellow1"))

         ("WAIT" . (:foreground "red4" :weight bold :background "yellow1"))

         ("WIP" . (:foreground "darkorchid2" :weight bold))

         ("NOPE" . (:foreground "hotpink" :weight bold :background "darkgreen"))))

 ;; link abbrevs

 (setq org-link-abbrev-alist

       '(("vc" . "https://vc.compiler.company/%s")

         ("comp" . "https://compiler.company/%s")

 	("cdn" . "https://cdn.compiler.company/%s")

         ("packy" . "https://packy.compiler.company/%s")

         ("yt" . "https://youtube.com/watch?v=%s")

         ("wikipedia" . "https://en.wikipedia.org/wiki/%s")

         ("reddit" . "https://reddit.com/%s")

         ("hn" . "https://news.ycombinator.com/%s")

         ("so" . "https://stackoverflow.com/%s")))

 ;;; IDs

 (defun org-title-to-filename (title)

   "Convert TITLE to a reasonable filename."

   ;; Based on the slug logic in org-roam, but org-roam also uses a

   ;; timestamp.

   (setq title (downcase title))

   (setq title (s-replace-regexp "[^a-zA-Z0-9]+" "-" title))

   (setq title (s-replace-regexp "-+" "-" title))

   (setq title (s-replace-regexp "^-" "" title))

   (setq title (s-replace-regexp "-$" "" title))

   title)

 (defun org-get-custom-id-list ()

   (flatten

    (org-map-entries

     (lambda ()

       (org-entry-get nil "CUSTOM_ID")))))

 (defun org-generate-custom-id (&optional id-list)

   (let* ((custom-id (org-entry-get nil "CUSTOM_ID"))

          (heading (org-heading-components))

          (level (nth 0 heading))            

          (todo (nth 2 heading))                       

          (headline (nth 4 heading))

          (slug (org-title-to-filename headline))

          (duplicate-id (when id-list (member slug id-list))))

     (when (not duplicate-id)

       (message "Adding CUSTOM_ID %s to %s" slug headline)

       (org-entry-put nil "CUSTOM_ID" slug))))

 (defun org-generate-custom-ids ()                              

   "Generate CUSTOM_ID for any headings that are missing one"   

     (save-excursion                                            

       (org-with-wide-buffer                                    

        (let ((existing-ids (org-get-custom-id-list)))          

          (org-map-entries                                      

           (lambda ()                                           

             (org-generate-custom-id existing-ids)))))))

 ;;;###autoload

 (defun org-id-add-to-headlines-in-file ()

   "Add ID properties to all headlines in the

    current file which do not already have one."

   (interactive)

   (org-map-entries (lambda () (org-id-get (point) 'create))))

 (defun org-id-add-to-headlines-in-files (&optional files)

   (interactive)

   (with-temp-buffer

     (dolist (f (or files org-agenda-files))

       (find-file f)

       (org-id-add-to-headlines-in-file)

       (save-buffer))))

 (defun org-id-add-to-headlines-in-directory (&optional dir)

   (interactive)

   (let ((dir (or dir org-directory)))

     (org-id-add-to-headlines-in-files

      (directory-files-recursively dir "[.]org$"))))

 (message "Initialized ULANG.")

 ;;; Commands

 ;; (org-property-inherit-p "LOCATION")

 ;; currently does not support locations with spaces.. need to walk

 ;; ancestors ourselves to do so. for now only URIs and pathnames are

 ;; supported.

 (defun org-get-with-inheritance (property &optional literal-nil epom)

   "Like `org-entry-get-with-inheritance' but in additional to properties we

 also check file keywords (aka in-buffer settings).

 For example, a PROPERTY value of 'LOCATION' would check all property

 values in addition to the keyword '#+LOCATION:'."

   (interactive (list nil nil))

   (let* ((property (or property (org-read-property-name)))

          (kw (when-let ((val (org-collect-keywords '("LOCATION") nil)))

                (cadar val)))

          ;; most of the work passed through to the property handler

          (props (org-entry-get-with-inheritance property literal-nil epom)))

     (if kw

         (append (list kw) (if (listp props) props (list props)))

       props)))

 (defun org-get-location (point)

   "Get the value of property LOCATION at POINT."

   (interactive "d")

   (let ((path (org-get-with-inheritance "LOCATION" nil point)))

     ;; when the second path component is an absolute path, skip the first

     (when (and (< 1 (length path)) (file-name-absolute-p (print (cadr path))))

       (setq path (cdr path)))

     (message "%s"

              (apply 'join-paths

                     (flatten

                      (mapcar

                       (lambda (x) (split-string x " "))

                       path))))))

 (defun org-set-location (value)

   "Set the value of property LOCATION. If point is before first heading

 instead set or replace the location file keyword."

   (interactive (list nil))

   (let ((val (or value (org-read-property-value "LOCATION" nil nil))))

     (if (org-before-first-heading-p)

         (save-excursion

           (beginning-of-buffer)

           (let ((start (point)))

             (when (re-search-forward (rx bol "#+LOCATION:" (+ space) (group (* (not space))) eol) nil t)

               (setq start (match-beginning 0))

               (goto-char start)

               (delete-line))

             (insert "#+LOCATION: " val "\n")))

       (org-set-property "LOCATION" value))))

 (defun org-follow-location (point)

   "Open the location specified by the LOCATION property of the org heading

 or file at point."

   (interactive "d")

   (let ((loc (org-get-location point)))

     (cond

      ((string-match-p org-link-any-re loc) (org-link-open-from-string loc))

      ;; TODO 2024-08-29: handle other location types (physical, etc)

      (t (find-file loc t)))))

 (provide 'ulang)

 ;;; ulang.el ends here