nx.el

;;; nx.el --- Description -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2024 Benjamin Andresen
;;
;; Author: Benjamin Andresen <b@lambda.icu>
;; Maintainer: Benjamin Andresen <b@lambda.icu>
;; Created: August 20, 2024
;; Modified: August 20, 2024
;; Version: 0.0.1
;; Keywords: abbrev bib c calendar comm convenience data docs emulations extensions faces files frames games hardware help hypermedia i18n internal languages lisp local maint mail matching mouse multimedia news outlines processes terminals tex tools unix vc wp
;; Homepage: https://github.com/bennyandresen/nx
;; Package-Requires: ((emacs "27.1"))
;;
;; This file is not part of GNU Emacs.
;;
;;; Commentary:

;; This module provides a lightweight, flexible tree structure implementation
;; for Emacs Lisp, primarily designed for building interactive, hierarchical
;; user interfaces.
;;
;; The main concept is the 'nx node', which represents a single element in
;; the tree. Each node has a type, properties, and can contain child nodes.
;; This structure allows for efficient creation, manipulation, and rendering
;; of complex, nested data structures.
;;
;; Key features:
;; - Simple node creation with `nx-node` (aliased to `nx`)
;; - Efficient tree diffing and patching
;; - Utilities for traversing and manipulating the tree structure
;; - Integration with hash-tables for flexible property storage
;;
;; This module is designed to be used as a foundation for building more
;; complex UI components or data representations in Emacs Lisp applications.

;;; Code:
(require 'ht)
(require 'dash)
(require 'dash-x)
(require 'cl-extra)

(defun nx-node (type &optional props children)
  "Create a node with TYPE, optional PROPS and CHILDREN.
If :_nx/id is present in PROPS, it will be used as the node's ID
instead of an autogenerated one."
  (let* ((contains-nxid? (lambda (props) (and (ht? props) (ht-contains? props :_nx/id))))
         (id (if (funcall contains-nxid? props)
                 (ht-get props :_nx/id)
               (intern (symbol-name (gensym "nx-"))))))
    (when (funcall contains-nxid? props)
      (ht-remove props :_nx/id))
    (ht (:id id)
        (:type type)
        (:props (or props (ht)))
        (:children children))))

(defalias 'nx 'nx-node)

(-comment
 (nx-node :foo)
 (nx-node :foo (ht (:_nx/id 1)))

 )

(defun nx-type (node)
  "Get the type of NODE."
  (ht-get node :type))

(defun nx-props (node)
  "Get the properties of NODE."
  (ht-copy (ht-get node :props)))

(defun nx-children (node)
  "Get the children of NODE."
  (ht-get node :children))

(-tests
 (nx :foo)
 )

(defun nx--node-equal (node1 node2)
  "Deeply compare NODE1 and NODE2 for equality."
  (and (eq (nx-type node1) (nx-type node2))
       (ht-equal? (nx-props node1) (nx-props node2))
       (let ((children1 (nx-children node1))
             (children2 (nx-children node2)))
         (and (eq (length children1) (length children2))
              (cl-every #'nx--node-equal children1 children2)))))

(-comment
 (nx--node-equal (nx :root (ht) (list
                                 (nx :bar (ht))
                                 (nx :foo (ht (:bar t)))))
                 (nx :root (ht) (list
                                 (nx :bar (ht))
                                 (nx :foo (ht (:bar t))))))
 )

(defun nx--diff-children (old-children new-children parent-id)
  "Compare OLD-CHILDREN and NEW-CHILDREN under PARENT-ID, returning list of changes."
  (let ((changes nil)
        (old-by-id (ht))
        (new-by-id (ht)))

    ;; Index children by ID for faster lookup
    (dolist (child old-children)
      (ht-set! old-by-id (nx-id child) child))
    (dolist (child new-children)
      (ht-set! new-by-id (nx-id child) child))

    ;; Find removed children
    (dolist (old-child old-children)
      (let ((id (nx-id old-child)))
        (unless (ht-get new-by-id id)
          (push (ht (:op :remove)
                    (:ref-id id))
                changes))))

    ;; Find new and modified children
    (dolist (new-child new-children)
      (let* ((id (nx-id new-child))
             (old-child (ht-get old-by-id id)))
        (if old-child
            ;; Child exists - check for modifications
            (setq changes (append (nx--diff-nodes old-child new-child parent-id)
                                  changes))
          ;; New child - check for next existing sibling
          (let ((next-sibling (cl-find-if (lambda (node)
                                            (gethash (nx-id node) old-by-id))
                                          (cdr (member new-child new-children)))))
            (if next-sibling
                (push (ht (:op :insert-before)
                          (:parent-id parent-id)
                          (:ref-id (nx-id next-sibling))
                          (:node new-child))
                      changes)
              (push (ht (:op :insert-last)
                        (:parent-id parent-id)
                        (:node new-child))
                    changes))))))

    (nreverse changes)))

(defun nx-diff-trees (old-tree new-tree)
  "Compare OLD-TREE and NEW-TREE, returning a list of change operations."
  (nx--diff-nodes old-tree new-tree nil))

(defun nx--diff-nodes (old-node new-node parent-id)
  "Compare OLD-NODE and NEW-NODE under PARENT-ID, returning a list of change operations."
  (cond
   ;; Nodes are identical
   ((nx--node-equal old-node new-node)
    nil)
   ;; Node is new
   ((null old-node)
    (list (ht (:op :insert-last)
              (:parent-id parent-id)
              (:node new-node))))
   ;; Node is removed
   ((null new-node)
    (list (ht (:op :remove)
              (:ref-id (nx-id old-node)))))
   ;; Node type changed
   ((not (eq (ht-get old-node :type) (ht-get new-node :type)))
    (list (ht (:op :replace)
              (:ref-id (nx-id old-node))
              (:node new-node))))
   ;; Properties changed
   ((not (ht-equal? (ht-get old-node :props) (ht-get new-node :props)))
    (append
     (list (ht (:op :update-props)
               (:ref-id (nx-id old-node))
               (:new-props (nx-props new-node))))
     (nx--diff-children
      (ht-get old-node :children)
      (ht-get new-node :children)
      (ht-get old-node :id))))
   ;; Compare children
   (t
    (nx--diff-children
     (ht-get old-node :children)
     (ht-get new-node :children)
     (ht-get old-node :id)))))

(defun nx-copy (node)
  "Create a deep copy of NODE, preserving IDs."
  (let* ((old-props (ht-get node :props))
         (new-props (ht-copy old-props))
         (new-children (mapcar #'nx-copy (ht-get node :children))))
    (when (ht-get node :id)
      (ht-set! new-props :_nx/id (ht-get node :id)))
    (nx (ht-get node :type) new-props new-children)))


(defun nx-type (node)
  "Get the type of NODE."
  (ht-get node :type))

(defun nx-props (node)
  "Get the properties of NODE."
  (ht-copy (ht-get node :props)))

(defun nx-children (node)
  "Get the children of NODE."
  (ht-get node :children))

(defun nx-id (node)
  "Get the internal id of NODE."
  (ht-get node :id))

(defun nx? (obj)
  "Check if OBJ is a valid nx node.
Returns t if OBJ is a valid nx node, nil otherwise."
  (and (hash-table-p obj)
       (keywordp (ht-get obj :type))
       (hash-table-p (ht-get obj :props))
       (or (null (ht-get obj :children))
           (and (listp (ht-get obj :children))
                (cl-every #'nx? (ht-get obj :children))))))

(defun nx?-strict (obj)
  "Strictly check if OBJ is a valid nx node.
Throws an error with a descriptive message if OBJ is not a valid nx node.
Returns t if OBJ is a valid nx node."
  (cond
   ((not (hash-table-p obj))
    (error "Not a hash table: %S" obj))
   ((not (keywordp (ht-get obj :type)))
    (error "Invalid or missing :type: %S" (ht-get obj :type)))
   ((not (hash-table-p (ht-get obj :props)))
    (error "Invalid or missing :props: %S" (ht-get obj :props)))
   ((not (or (null (ht-get obj :children))
             (and (listp (ht-get obj :children))
                  (cl-every #'nx?-strict (ht-get obj :children)))))
    (error "Invalid :children: %S" (ht-get obj :children)))
   (t t)))

(defun nx--build-node-map (tree)
  "Build a hash table mapping node IDs to nodes in TREE."
  (let ((node-map (ht)))
    (nx--traverse-tree tree (lambda (node)
                              (ht-set! node-map (ht-get node :id) node)))
    node-map))

(defun nx--traverse-tree (node fn)
  "Traverse the tree starting at NODE, calling FN on each node."
  (funcall fn node)
  (dolist (child (ht-get node :children))
    (nx--traverse-tree child fn)))

(defun nx--find-parent (tree node)
  "Find the parent of NODE in TREE."
  (nx--find-parent-helper tree node nil))

(defun nx--find-parent-helper (current-node target-node parent)
  "Helper function for nx--find-parent."
  (if (eq current-node target-node)
      parent
    (catch 'found
      (dolist (child (ht-get current-node :children))
        (let ((result (nx--find-parent-helper child target-node current-node)))
          (when result
            (throw 'found result))))
      nil)))

(defun nx-apply-diff (tree diff-ops)
  "Apply DIFF-OPS to a copy of TREE and return the resulting new tree.
WARNING: Uses unsafe hash-set! operations to achieve its goal."
  (let* ((new-tree (nx-copy tree))
         (node-map (nx--build-node-map new-tree)))
    (dolist (op diff-ops)
      (-let [(&hash :op op-type
                    :parent-id parent-id
                    :node node
                    :node-id node-id
                    :ref-id ref-id
                    :new-props new-props)
             op]
        (pcase op-type
          (:insert-last
           (let ((parent (ht-get node-map parent-id)))
             (when parent
               (let ((new-children (append (ht-get parent :children) (list (nx-copy node)))))
                 (ht-set! parent :children new-children)
                 (nx--add-to-node-map node-map (nx-copy node))))))

          (:insert-before
           (let ((parent (ht-get node-map parent-id)))
             (when parent
               (let* ((children (ht-get parent :children))
                      (sibling-pos (cl-position-if
                                    (lambda (node)
                                      (equal (nx-id node) ref-id))
                                    children))
                      (new-children (if sibling-pos
                                        (append (cl-subseq children 0 sibling-pos)
                                                (list (nx-copy node))
                                                (cl-subseq children sibling-pos))
                                      (append children (list (nx-copy node))))))
                 (ht-set! parent :children new-children)
                 (nx--add-to-node-map node-map (nx-copy node))))))

          (:remove
           (let* ((node (ht-get node-map ref-id))
                  (parent (nx--find-parent new-tree node)))
             (when parent
               (let ((new-children (remove node (ht-get parent :children))))
                 (ht-set! parent :children new-children)))))

          (:update-props
           (let ((node (ht-get node-map ref-id)))
             (when node
               (ht-set! node :props new-props))))

          (:replace
           (let* ((old-node (ht-get node-map ref-id))
                  (parent (nx--find-parent new-tree old-node)))
             (when parent
               (let ((new-children (mapcar (lambda (child)
                                             (if (equal (nx-id child) ref-id)
                                                 (nx-copy node)
                                               child))
                                           (ht-get parent :children))))
                 (ht-set! parent :children new-children)
                 (nx--add-to-node-map node-map (nx-copy node)))))))))
    new-tree))

(defun nx--add-to-node-map (node-map node)
  "Add NODE and its children to NODE-MAP."
  (ht-set! node-map (ht-get node :id) node)
  (dolist (child (ht-get node :children))
    (nx--add-to-node-map node-map child)))

(-comment
 ;; create an initial tree
 (setq initial-tree
       (nx :root (ht (:_nx/id 'root))
           (list (nx :child (ht (:_nx/id 'child1) (:prop "old-value"))
                     (list (nx :grandchild (ht (:_nx/id 'grandchild)))))
                 (nx :child (ht (:_nx/id 'child2)))
                 (nx :child (ht (:_nx/id 'child4))))))
 (jujutsu-dev--display-in-buffer initial-tree)

 ;; single addition of a :child ('child3) works
 (setq modified-tree
       (nx :root (ht (:_nx/id 'root))
           (list (nx :child (ht (:_nx/id 'child1) (:prop "new-value"))
                     (list (nx :grandchild (ht (:_nx/id 'grandchild)))))
                 (nx :child (ht (:_nx/id 'child2)))
                 (nx :child (ht (:_nx/id 'child3)))
                 (nx :child (ht (:_nx/id 'child4))))))

 ;; generate diff operations
 (setq diff-ops (nx-diff-trees initial-tree modified-tree))
 (jujutsu-dev-dump-tree diff-ops "*jj diff ops*")

 ;; Apply the diff to the initial tree
 (setq result-tree (nx-apply-diff initial-tree diff-ops))
 (jujutsu-dev-dump-tree result-tree "*jj results*")

 (setq modified-tree2
       (nx :root (ht (:_nx/id 'root))
           (list (nx :child (ht (:_nx/id 'child1) (:prop "new-value"))
                     (list (nx :grandchild (ht (:_nx/id 'grandchild)))))
                 (nx :child (ht (:_nx/id 'child3)))
                 (nx :child (ht (:_nx/id 'child4))))))

 (setq diff-ops2 (nx-diff-trees initial-tree modified-tree2))
 (jujutsu-dev-dump-tree diff-ops2 "*jj diff ops*")
 (setq result-tree2 (nx-apply-diff initial-tree diff-ops2))
 (jujutsu-dev-dump-tree result-tree2 "*jj results*")

 )

(defun nx-buffer-apply-diff (buffer state-and-ops render-fn)
  "Apply DIFF-OPS to BUFFER using RENDER-FN to render nodes.
RENDER-FN should take a node and return a string representation."
  (-let* [((&hash :diff-ops diff-ops
                  :state state)
           state-and-ops)
          (node-map (nx--build-node-map state))]
    (with-current-buffer buffer
      (save-excursion
        (-comment
         (jujutsu-dev-dump-display (ht
                                    (:length-dops (length diff-ops))
                                    (:nmap node-map)
                                    (:dops diff-ops))))

        (dolist (op diff-ops)
          (-let [(&hash :op op-type
                        :parent-id parent-id
                        :node new-node
                        :ref-id ref-id
                        :new-props new-props)
                 op]
            ;; TODO: I need to grab the state and find the actual nx-node in that state based on the node-id, ref-id, etc.
            (pcase op-type
              ;; confirmed to work for the simple case
              ;; XXX: harvest potential children
              (:remove (nx--buffer-delete-region buffer ref-id))

              ;; not yet confirmed
              ;; XXX: harvest potential children
              (:replace (nx--buffer-replace-region buffer ref-id new-node render-fn))

              ;; functionally :update does the same as :replace
              ;; confirmed to work for the simple case
              ;; XXX: harvest potential children
              (:update-props (nx--buffer-replace-region buffer ref-id (ht-merge (ht-get node-map ref-id) (ht (:props new-props))) render-fn))

              ;; confirmed to work
              (:insert-last (nx--buffer-insert-last buffer (ht-get node-map parent-id) new-node render-fn))

              ;; confirmed to work
              (:insert-before (nx--buffer-insert-before buffer ref-id new-node render-fn)))))))))

(defun nx--buffer-get-point-id-boundaries (buffer &optional pos)
  "Get boundaries of nx/id property at POS or (point) in BUFFER.
Returns hash table with :nx/id, :beg, and :end if position has nx/id property."
  (with-current-buffer buffer
    (let* ((pos (or pos (point)))
           (id (get-text-property pos 'nx/id)))
      (when id
        (let* ((beg (previous-single-property-change (1+ pos) 'nx/id nil (point-min)))
               (beg (if (equal id (get-text-property beg 'nx/id))
                        beg
                      (or (next-single-property-change beg 'nx/id)
                          (point-min))))
               (end (or (next-single-property-change pos 'nx/id)
                        (point-max))))
          (ht (:nx/id id) (:beg beg) (:end end)))))))

(defun nx--buffer-find-id-position (buffer id)
  "Find position in BUFFER where text property `nx/id' equals ID."
  (with-current-buffer buffer
    (save-excursion
      (goto-char (point-min))
      (let ((pos (text-property-search-forward 'nx/id id t)))
        (when pos
          (prop-match-beginning pos))))))

(defun nx--buffer-delete-region (buffer id)
  "Delete the region in BUFFER corresponding to node with ID."
  (with-current-buffer buffer
    (let ((inhibit-read-only t))
      (when-let* ((pos (nx--buffer-find-id-position buffer id))
                  (bounds (nx--buffer-get-point-id-boundaries buffer pos)))
        (delete-region (ht-get bounds :beg) (ht-get bounds :end))))))

(defun nx--buffer-replace-region (buffer id new-node render-fn)
  "Replace region for `nx/id' ID in BUFFER with rendered NEW-NODE using RENDER-FN."
  (with-current-buffer buffer
    (let ((inhibit-read-only t))
      (when-let* ((pos (nx--buffer-find-id-position buffer id))
                  (bounds (nx--buffer-get-point-id-boundaries buffer pos)))
        (delete-region (ht-get bounds :beg) (ht-get bounds :end))
        (goto-char (ht-get bounds :beg))
        (nx--buffer-insert-node new-node render-fn)))))

(defun nx--buffer-id-map (buffer)
  "Build hash table mapping nx/id values to their buffer positions in BUFFER."
  (with-current-buffer buffer
    (let ((id-map (make-hash-table :test 'equal))
          (pos (point-min)))
      (while (< pos (point-max))
        (when-let* ((id (get-text-property pos 'nx/id))
                    (end (next-property-change pos)))
          (puthash id (vector pos end) id-map)
          (setq pos end))
        (setq pos (1+ pos)))
      id-map)))

(defun nx--buffer-insert-last (buffer parent node render-fn)
  "Insert rendered NODE at end of PARENT region in BUFFER using RENDER-FN."
  (with-current-buffer buffer
    (let* ((inhibit-read-only t)
           (buf-map (nx--buffer-id-map (current-buffer)))
           (parent-id (nx-id parent))
           (node-id (nx-id node))
           (ids-to-search (-concat (list parent-id)
                                   (->> parent nx-children (-map #'nx-id) nreverse))))
      ;; XXX: if the node is already present, skip search and replace
      (if (ht-get buf-map node-id)
          (nx--buffer-replace-region buffer node-id node render-fn))
      (catch 'found
        (dolist (id ids-to-search)
          (when-let* ((pos-bounds (ht-get buf-map id))
                      (beg (aref pos-bounds 0))
                      (end (aref pos-bounds 1)))
            (goto-char end)
            (nx--buffer-insert-node node render-fn)
            (throw 'found t)))
        ;; If no positions found, append to buffer end
        (goto-char (point-max))
        (nx--buffer-insert-node node render-fn)))))

(defun nx--buffer-insert-before (buffer ref-id node render-fn)
  "Insert rendered NODE before REF-ID in BUFFER using RENDER-FN."
  (with-current-buffer buffer
    (let ((inhibit-read-only t))
      (when-let* ((pos (nx--buffer-find-id-position buffer ref-id))
                  (bounds (nx--buffer-get-point-id-boundaries buffer pos)))
        (goto-char (ht-get bounds :beg))
        (nx--buffer-insert-node node render-fn)))))

(defun nx--buffer-insert-node (node render-fn)
  "Insert NODE into current buffer using RENDER-FN. "
  ;; TODO: validate that the inserted text has a `nx/id' text property on every
  ;;       char of the string
  (insert (funcall render-fn node "")))

(provide 'nx)
;;; nx.el ends here