;;; graph.el --- Graph-oriented Extensions -*- lexical-binding: t; -*-

 ;; Copyright (C) 2024  The Compiler Company

 ;; Version: "0.2.0"

 ;; Author: Richard Westhaver <richard.westhaver@gmail.com>

 ;; Keywords: docs, maint, outlines, extensions

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

 (require 'default)

 (require 'ulang)

 (defgroup graph nil

   "CC Graph")

 (defcustom org-graph-db-directory (join-paths user-org-stash-directory "graph")

   "graph database storage directory."

   :type 'directory

   :group 'graph)

 (defcustom org-graph-locations (list (join-paths company-org-directory "notes/"))

   "List of directories to check for nodes."

   :type '(list directory)

   :group 'graph)

 (defcustom org-graph-include-agenda-files nil

   "When non-nil, include `org-agenda-files' in the graph."

   :type 'boolean

   :group 'graph)

 (defcustom org-graph-include-archive nil

   "When non-nil, include `org-arhive-location' in the graph."

   :type 'boolean

   :group 'graph)

 (defcustom org-graph-include-org-directory nil

   "When non-nil, include `org-directory' files in the graph."

   :type 'boolean

   :group 'graph)

 (defcustom org-graph-compaction-hook nil

   "Hook run when a graph is compacted to `org-graph-db'."

   :type 'hook

   :group 'graph)

 (defcustom org-graph-capture-hook nil

   "Hook run when a node is added to the graph."

   :type 'hook

   :group 'graph)

 (defcustom org-graph-db-init-script (join-paths company-source-directory "infra/scripts/org-db-init.lisp")

   "Path to a lisp script responsible for initializing the `org-graph-db-directory'.")

 (cl-defstruct org-graph-db-handle

   (type :rocksdb)

   (name "org-graph-db")

   init

   get

   put

   delete

   merge

   compact

   shutdown)

 (defcustom org-graph-db (make-org-graph-db-handle)

   "A handle to the database backend which stores nodes and edges."

   :type 'org-graph-db-handle

   :group 'graph)

 (defun org-graph-from-id-locations (&optional edges local)

   "Populate the `org-graph' from `org-id-locations', filtering out any

 entries not under a member of `org-graph-locations'. When EDGES is

 non-nil visit each node and collect all edges found."

   (interactive "P")

   (save-excursion

     (let* ((node-ids (copy-hash-table (org-id-locations-load))) ;; don't overwrite `org-id-locations'

            (graph (make-org-graph :nodes node-ids)))

       (maphash

        (lambda (k v)

          (if-let ((ok (cl-loop for l in org-graph-locations

                                when (string-prefix-p l (file-truename v))

                                return t)))

              (let ((pos (cdr (org-id-find-id-in-file k v))))

                (message "%s %s" k v)

                (org-with-file-buffer v

                  (goto-char pos)

                  (org-graph-node-at-point graph)

                  (when edges (org-graph-edges-at-point graph))))

            (remhash k (org-graph-nodes graph))))

        (org-graph-nodes graph))

       (if local

           (setq-local org-graph graph)

         (setq org-graph graph)))))

 (defun org-graph-files ()

   (org-list-files org-graph-locations org-agenda-extensions))

 (cl-defstruct org-graph

   ;; TODO 2024-09-17: use integers instead of string

   (nodes (make-hash-table :test 'equal))

   (edges (make-hash-table :test 'equal)))

 (defvar org-graph (make-org-graph)

   "The Emacs-native org-graph. Should be assigned to an `org-graph' instance.")

 (cl-defstruct org-graph-node id name file point)

 (cl-defstruct org-graph-edge (type 'link) in properties timestamp point out)

 (defun org-graph--file-hash (file)

   "Compute the hash of FILE."

   (with-temp-buffer

     (set-buffer-multibyte nil)

     (insert-file-contents-literally file)

     (secure-hash 'md5 (current-buffer))))

 (defun org-graph-node-at-point (&optional update)

   "Return the `org-graph-node' at point. When UPDATE is non-nil insert or

 update the node into the org-graph object specified or when 't' use the

 currently active org-graph."

   (let* ((file (buffer-file-name))

          (node (make-org-graph-node :point (point) :file file)))

     (if (derived-mode-p 'org-mode)

         (progn

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

               (setf (org-graph-node-name node) (org-get-title)

                     ;; use the filename, create a hash as id

                     (org-graph-node-id node) (org-graph--file-hash file))

             (setf (org-graph-node-id node) (org-id-get)

                   (org-graph-node-name node) (elt (org-heading-components) 4))))

       (setf (org-graph-node-id node) (org-graph--file-hash file)

             (org-graph-node-name node) (file-name-nondirectory file)))

     (when update

       (puthash (org-graph-node-id node) node (org-graph-nodes (if (eql t update) org-graph update))))

     node))

 ;; TODO 2024-09-22: properties

 (defun org-graph-collect-edge ()

   "Collect the edge at point which should be a line created with `org-graph-edge--insert'."

   (org-with-point-at (beginning-of-line)

     (when (org-at-timestamp-p 'lax)

       (let ((ep (point))

             (ts (match-string-no-properties 0))

             (end (match-end 0)))

         (goto-char (1+ end))

         ;; next 2 chars are the arrow

         (let ((arrow (org-graph-edge-arrow* (buffer-substring-no-properties (point) (+ 2 (point))))))

           (goto-char (+ (point) 4))

           (make-org-graph-edge :in (org-id-get)

                                :type arrow

                                :point ep

                                :timestamp (org-parse-time-string ts t) 

                                :out (string-trim (org--link-at-point) "id:")))))))

 (defun org-graph-map-edges (function)

   "Eval FUNCTION once for each edge in node at point with point at start of the edge."

   (with-org-graph-edge-drawer (end)

     (re-search-backward (rx bol ?: (literal (org-graph-edge-drawer)) ?: eol) nil t)

     (goto-char (1+ (match-end 0)))

     (cl-loop while (> (point-max) end (point))

              collect (funcall function)

              do (next-line))))

 ;; TODO 2024-09-23: 

 (defun org-link-info (link)

   (let ((path (org-element-property :path link))

         (type (org-element-property :type link))

         (desc (substring-no-properties (nth 2 link))))

     (list type path desc)))

 ;; TODO 2024-09-22: 

 (defun org-graph-infer-edges ()

   "Infer edges from the contents of the node at point. The result of this

 function is a list of org-graph-edge objects."

   ;; collect links

   (with-org-graph-edge-drawer (beg)

     (org-element-map (org-element-parse-buffer) 'link

       (lambda (link)

         (print link)

         ;; (org-graph-edge-link-builder (funcall 'org-element-create link))

         ))))

 (defun org-graph-reduce-edges (function)

   "Same as `cl-reduce' where SEQ is the list of edges at point. FUNCTION

 takes two `org-graph-edge' objects as input."

   (let ((edges (org-graph-map-edges 'org-graph-collect-edge)))

     (cl-reduce function edges)))

 (defun org-graph-collect-edges-at-point (&optional update)

   "Collect the contents of the EDGES drawer from node at point. When UPDATE

 is non-nil insert or update the node into the org-graph object specified

 or when 't' use the currently active org-graph."

   (let ((edges (org-graph-map-edges 'org-graph-collect-edge)))

     (when update

       (mapc (lambda (e)

               (puthash 

                (org-graph-edge-in e)

                e

                (org-graph-edges (if (eql t update) org-graph update))))

             edges))

     edges))

 (defun org-graph-edge-equal (a b)

   "Return non-nil if A and B are 'equal' org-graph-edge objects."

   (equal (org-graph-edge-out a) (org-graph-edge-out b)))

 (defun org-graph-edge-remove-duplicates ()

   "Remove duplicate edge entries from node at point."

   (org-graph-reduce-edges 

    (lambda (a b) 

      (when (org-graph-edge-equal a b)

        (let ((tsa (org-graph-edge-timestamp a))

              (tsb (org-graph-edge-timestamp b)))

          (goto-char (org-graph-edge-point (if (org-time> tsa tsb) b a)))

          (delete-line))))))

 (defun org-graph-edges-at-point (&optional update)

   "Return a list of `org-graph-edge' instances associated with the node at

 point. When UPDATE is non-nil insert or update the edges into the

 currently active org-graph."

   (interactive)

     (when (derived-mode-p 'org-mode)

       (org-graph-collect-edges-at-point update)))

 (defun org-graph-buffer-update (&optional buffer)

   "Map over an org buffer adding all nodes to the active org-graph."

   (interactive)

   (save-excursion

     (with-current-buffer (or buffer (current-buffer))

       ;; capture file node

       (goto-char (point-min))

       (org-graph-node-at-point t)

       (when (derived-mode-p 'org-mode)

         (org-map-entries (lambda () (org-graph-node-at-point t)))))))

 ;;; Edges

 ;; See https://github.com/toshism/org-super-links/blob/develop/org-super-links.el

 (declare-function org-make-link-description-function "ext:org-mode")

 (defvar org-graph-edge-drawer "EDGES"

   "Controls how/where to insert edges. If nil edges will just be inserted

 under the heading.")

 ;; TODO 2024-09-16: edge properties

 (defvar org-graph-edge-prefix 'org-graph-edge-prefix-timestamp

   "Prefix to insert before the edge.

 This can be a string, nil, or a function that takes no arguments and

 returns a string.

 Default is the function `org-graph-edge-prefix-timestamp'

 which returns an inactive timestamp formatted according to the variable

 `org-time-stamp-formats'.")

 ;;  TODO 2024-09-16: do we need this? what sort of information for a

 ;;  given edge would go in the postfix? this may be better suited as a

 ;;  per-edge value rather than global - maybe use for comments.

 (defvar org-graph-edge-postfix nil

   "Postfix to insert after the edge.

 This can be a string, nil, or a function that takes no arguments and

 returns a string")

 (defvar org-graph-edge-link-prefix nil

   "Prefix to insert before the link.

 This can be a string, nil, or a function that takes no arguments and

 returns a string")

 (defvar org-graph-edge-link-postfix nil

   "Postfix to insert after the link.

 This can be a string, nil, or a function that takes no arguments and

 returns a string")

 (defvar org-graph-edge-default-description-formatter org-make-link-description-function

   "What to use if no description is provided.

 This can be a string, nil or a function that accepts two arguments

 LINK and DESC and returns a string.

 nil will return the default desciption or the link.

 string will be used only as a default fall back if set.

 function will be called for every link.

 Default is the variable `org-make-link-desciption-function'.")

 (defvar org-graph-edge-search-function 'org-graph-edge-get-location

   "The interface to use for finding target links. If you provide a custom

 function it will be called with the `point` at the location the link

 should be inserted.  The only other requirement is that it should call

 the function `org-graph-edge-insert-link-marker' with a marker to the target

 link. AKA the place you want the edge.

 `org-graph-edge-get-location' internally uses `org-refile-get-location'.")

 (defvar org-graph-edge-pre-link-hook nil

   "Hook called before storing the link on the link side.

 This is called with point at the location where it was called.")

 (defvar org-graph-edge-pre-backlink-hook nil

   "Hook called before storing the link on the backlink side.

 This is called with point in the heading of the backlink.")

 (defvar org-graph-edge-indicator-alist

   '((link . "->")

     (backlink . "<-")

     (relation . "--")

     (parent . ">>")

     (child . "<<"))

   "An alist of (EDGE-TYPE . INDICATOR) pairs. Each INDICATOR is a string

 which will be printed between the properties and backlink of the

 associated EDGE-TYPE.")

 (defun org-graph-edge-arrow (sym)

   (cdr (assoc sym org-graph-edge-indicator-alist)))

 (defun org-graph-edge-arrow* (str)

   "Reverse lookup of edge arrow symbol."

   (car (rassoc str org-graph-edge-indicator-alist)))

 (defun org-graph-edge-get-location ()

   "Default for function `org-graph-edge-search-function' that reuses the `org-refile' machinery."

   (org-refile-get-location "Node"))

 (cl-defmacro with-org-graph-edge-drawer ((start &optional create) &rest body)

   "START is a symbol which is bound to the start of the edge drawer."

   (declare (indent 1))

   `(save-excursion

      (org-with-wide-buffer

       (let ((org-log-into-drawer (org-graph-edge-drawer)))

         (org-graph-narrow-to-node)

         (let ((,start (org-log-beginning ,create)))

           (when (or (re-search-forward (rx bol ?: "END" ?: eol) nil t)

                     (re-search-backward (rx bol ?: "END" ?: eol) nil t))

             (goto-char ,start)

             ,@body))))))

 (defun org-graph-edge-search-function ()

   "Call the search interface specified in variable `org-graph-edge-search-function'."

   (funcall org-graph-edge-search-function))

 (defun org-graph-edge-prefix ()

   "Return an appropriate string based on variable `org-graph-edge-prefix'."

   (cond ((equal org-graph-edge-prefix nil) "")

         ((stringp org-graph-edge-prefix) org-graph-edge-prefix)

         (t (funcall org-graph-edge-prefix))))

 (defun org-graph-edge-postfix ()

   "Return an appropriate string based on variable `org-graph-edge-postfix'."

   (cond ((equal org-graph-edge-postfix nil) "\n")

         ((stringp org-graph-edge-postfix) org-graph-edge-postfix)

         (t (funcall org-graph-edge-postfix))))

 (defun org-graph-edge-link-prefix ()

   "Return an appropriate string based on variable `org-graph-edge-link-prefix'."

   (cond ((equal org-graph-edge-link-prefix nil) "")

         ((stringp org-graph-edge-link-prefix) org-graph-edge-link-prefix)

         (t (funcall org-graph-edge-link-prefix))))

 (defun org-graph-edge-link-postfix ()

   "Return an appropriate string based on variable `org-graph-edge-link-postfix'."

   (cond ((equal org-graph-edge-link-postfix nil) "")

         ((stringp org-graph-edge-link-postfix) org-graph-edge-link-postfix)

         (t (funcall org-graph-edge-link-postfix))))

 ;; TODO 2024-09-16: edge-properties

 (defun org-graph-edge-prefix-timestamp ()

   "Return the default prefix string for an edge.

 Inactive timestamp formatted according to `org-time-stamp-formats'."

   (format-time-string (org-time-stamp-format t t) (current-time)))

 (defun org-graph-edge-default-description-formatter (link desc)

   "Return a string to use as the link desciption.

 LINK is the link target.  DESC is the provided desc."

   (let ((p org-graph-edge-default-description-formatter))

     (cond ((equal p nil) (or desc link))

           ((stringp p) (or desc p))

           ((fboundp p) (funcall p link desc))

           (t desc))))