dmg-org-roam-para.el

;; -*- lexical-binding: t; -*-

;; so they can't be simply changed
(setq dmg-parea-list (list "PROJ" "SPROJ" "AREA"))


;; this are probably hardcoded in some of the queries below
(setq dmg-org-roam-view-with-ancestors  "v_dmg_todos_with_ancestor")
(setq dmg-org-roam-view-prarea "v_dmg_prarea")
(setq dmg-org-roam-view-nexts  "v_dmg_nexts")

(setq dmg-org-roam-headers-table      'dmg_headers)
(setq dmg-org-roam-headers-tags-table 'dmg_headers_tags)
(setq dmg-org-roam-tags-priority-table 'dmg_tags_priority)

;; the list of tags that are important

(setq dmg-org-roam-tags-priority (list (vector "research"  98)
                                       (vector "grad_students" 97)
                                       (vector "teaching" 97)
                                       (vector "email"'      100)
                                       (vector "none" nil)
                                       (vector "uvic"  90)
                                       (vector "jp"    80)
                                       (vector "emacs"  75)
                                       (vector "reading"    70)
                                       (vector "home"  50)
                                       (vector "annoy"  42)
                                       (vector "hacking"  40)
                                       ))

(defun dmg-node-get-property (prop)
  "Get the deadline of the current Org mode heading, if any."
  (interactive)
  (let* (
         (element (org-element-at-point))
         )
    (org-entry-get (org-element-at-point) prop)
    ))

(defun dmg-org-roam-get-parent-id ()
  "Get the ID of the parent heading of the current heading in Org-mode."
  (interactive)
  (save-excursion
    (when (org-up-heading-safe)
      ;; Retrieve the ID property of the parent heading
      (org-roam-id-at-point))
    ))


(defun dmg-org-roam-get-prarea-id ()
  "Get the ID of the prarea parent heading of the current heading in Org-mode."
  (interactive)
  (save-excursion
    (when (org-up-heading-safe)
      ;; Retrieve the ID property of the parent heading
      (let* (
             (header (org-heading-components))
             (id     (org-id-get))
             (prarea (and header
                          (nth 2 header)))
             )
        (if (and id (member prarea dmg-parea-list))
            id
          (dmg-org-roam-get-prarea-id)
          ))) 
    ))

(defun dmg-org-roam-type-tag (tag)
  "The type of TAG."
  (cond
   ((string-prefix-p "@" tag)  "location")
   ((string-prefix-p "p_" tag) "project")
   ((string-prefix-p "a_" tag) "area")
   ((string= "today" tag) "date")
   ((string= "dmgTodo" tag) "gtd")
   (t nil)
   ))

(defun dmg-org-roam-heading-process-tag (tag)
  "Return tag information for the TAG.  Returns a vector
  ready to be inserted into the database."
  (let (
        (is-inherited (get-text-property 0 'inherited tag))
        (rawtag       (substring-no-properties tag)) 
        )
    (vector (buffer-file-name)
            (point)
            (org-id-get) 
            rawtag
            is-inherited
            (dmg-org-roam-type-tag tag))))

(defun dmg-org-roam-heading-tags ()
  "return the tags split into a list of vectors the info for each tag"
  ;; we need to split tags into inherited and not inherited
  (let* (
         (tags (org-get-tags))
         )
    ;; map each tag to get its type and
    (mapcar 'dmg-org-roam-heading-process-tag tags)
    ))

(defun dmg-org-roam-heading-process-properties (prio)
  "return a vector of the properties of a priority"
  (let (
        (pos (point))
        (name (car prio))
        (value (cdr prio))
        )
    (vector (buffer-file-name) pos (org-id-get) name value)
    ))

(defun dmg-org-roam-header-keep-property-p (prop)
  "determine if we are interested in this property.
We skip FILE, ITEM, PRIORITY, ALLTAGS, ..."
  ;; do we keep this property? prop is a cons pair
  ;; 
  (let ((key (car prop))
        (value (cdr prop))
        )
                                        ;    (message "Property check [%S][%s][%s]" prop key value)
    (cond
     ;; not empty
     ((not value) nil)
     ((string-empty-p value) t)
     ;; not in this list
     ((member key '("FILE" "ITEM" "PRIORITY" "ALLTAGS" "TAGS" "BLOCKED")) nil) 
     ;; category's default is the same as filename
     ((string= "CATEGORY" key) (not (string= (file-name-base (buffer-file-name)) value)))
     (t t)
     )
    ))

(defun dmg-org-roam-heading-properties ()
  "return a list of vectors with the properties of the heading"
  (let* (
         (prio (org-entry-properties))
         (keep (seq-filter 'dmg-org-roam-header-keep-property-p prio))
                                        ;         (prio2 (mapcar 'dmg-org-roam-heading-process-priorities prio))
         )
    ;; map each property to create a list to insert into db
                                        ;    (message "Properies...[%S] " keep)
    (mapcar 'dmg-org-roam-heading-process-properties  keep)
    ))


(defun dmg-org-get-date-string (st)
  "Get the scheduled date of the current Org-mode node as a formatted string we can insert to the DB."
  (let (
        (timestamp (and st (org-time-string-to-time st)))
        )
    (if timestamp
        (let* (
               (decoded  (decode-time timestamp))
               (min      (nth 1 decoded))
               (hour     (nth 2 decoded))
               )
          (progn
            (format "%s %s"
                    (format-time-string "%Y-%m-%d" timestamp)
                    (if (and (= min 0)
                             (= hour 0))
                        "23:59"
                      (format "%02d:%02d" hour min)
                      )))
          )
      st
      )
    ))

(defun dmg-org-roam-entries-list ()
  ;; returns a list of 3 elements
  ;; first is the tuple for dmg_headers
  ;; second is a list of tags tuples
  ;; third is the list of properties
  (let (
        (fname (buffer-file-name))
        )
    (org-map-entries
     (lambda ()
       (list 
        (vconcat (list fname
                       (point)
                       (org-id-get)
                                        ;                      (org-roam-id-at-point)
                       (dmg-org-roam-get-parent-id)
                       (dmg-org-roam-get-prarea-id)
                       (dmg-org-get-date-string (org-entry-get nil "CREATED"))
                       (dmg-org-get-date-string (dmg-node-get-property "SCHEDULED"))
                       (dmg-org-get-date-string (dmg-node-get-property "DEADLINE"))
                       ) 
                 (org-heading-components)
                 ) 
        (dmg-org-roam-heading-tags)
        (dmg-org-roam-heading-properties)) 
       ))))

(defun dmg-org-roam-file-list-org-headers ()
  "List all headers metadata in the current Org buffer,
  Returns three lists:

  1) first list

  - file,
  - position in buffer,
  - id,
  - parent id
  - prarea id
  - created date
  - scheduled date
  - deadline date
  - the level as an integer
  - the reduced level, different if ‘org-odd-levels-only’ is set.
  - the TODO keyword, or nil
  - the priority character, like ?A, or nil if no priority is given
  - the headline text itself, or the tags string if no headline text
  - the tags string, or nil.

  2) second list
     - tag, inherited, type

  3) properties
     - pname, value, inherited

  "
  (interactive)
                                        ;  (with-silent-modifications
  (save-excursion
    (save-restriction
      (widen)
      (let (
            (entries (dmg-org-roam-entries-list))
            )
        entries
        )
      )
                                        ;      )
    )
  )

(defun dmg-org-roam-get-tags-from-headers (headers)
  ;; for every header, the cdr has a list of vectors
  ;; so we need to extract these lists and flatten them
  (let (
        (tags-lists (mapcar (lambda (x) (nth 1 x)) headers))
        )
    (apply #'append tags-lists))) 

(defun dmg-org-roam-get-properties-from-headers (headers)
  ;; for every header, the cdr has a list of vectors
  ;; so we need to extract these lists and flatten them
  (let (
        (properties-lists (mapcar (lambda (x) (nth 2 x)) headers))
        )
    (apply #'append properties-lists))) 


(defun dmg-sql-update-headers-of-buffer (onlyDelete)
  
  (let (
        (db (org-roam-db))
        )
    (condition-case err
        (progn
          (emacsql db [:begin])
          
          ;; cascading deletes them from the tags table
          (emacsql db [:delete 
                       :from $i1
                       :where (= file $s2)]
                   'dmg_headers (buffer-file-name)) 
          
          (unless onlyDelete
            (let* (
                   (headers-data (dmg-org-roam-file-list-org-headers))
                   (headers (mapcar 'car headers-data))
                   (tags    (dmg-org-roam-get-tags-from-headers headers-data))
                   (properties (dmg-org-roam-get-properties-from-headers headers-data)))
                                        ;              (message "doing headers")
              (when (> (length headers) 0)
                (emacsql db [:insert 
                             :into $i1
                             :values $v2]
                         'dmg_headers headers))
                                        ;              (message "doing tags")
              (when (> (length tags) 0)
                (emacsql db [:insert 
                             :into $i1
                             :values $v2]
                         'dmg_headers_tags tags))
                                        ;              (message "doing properties")
              (when (> (length properties) 0)
                                        ;                (message "Properties [%S]" properties)
                (emacsql db [:insert 
                             :into $i1 ;; [file pos id property value]
                             :values $v2]
                         'dmg_headers_properties properties))) ;; unless
            (emacsql db [:commit])
            ) ;; unless
          ) ;; progn
      (error
       (emacsql db [:rollback])
       (message "There was an error in updating the headers of the table... aborting transaction" ) 
       (message "Full [%S]" err) 
       ) ;; error
      ) ;; condition
    ) ;; let
  ) ;;defun


(defun dmg-org-roam-table-headers-create  (db)
                                        ;  (interactive)
  (emacsql db
           "drop table if exists dmg_headers")
  (emacsql db
           "
  CREATE TABLE dmg_headers(
               file not null,
               pos  not null,
               id,
               parentid,
               prareaid,
               created text,
               scheduled,
               deadline,
               level,
               rlevel,
               todo,
               priority,
               title,
               tags,
               primary key (file, pos),
               foreign key (file) references files on delete cascade)
  "
           )
  )

(defun dmg-org-roam-table-headers-tags-create  (db)
                                        ;  (interactive)
  (emacsql db
           "drop table if exists dmg_headers_tags")
  (emacsql db
           "
  CREATE TABLE dmg_headers_tags(
               file not null,
               pos  not null,
               id,
               tag not null, 
               inherited,
               tagtype,
               primary key (file, pos, tag),
               foreign key (file) references files on delete cascade,
               foreign key (file, pos) references dmg_headers on delete cascade
             );
  "
           )
  )

(defun dmg-org-roam-table-headers-properties-create  (db)
                                        ;  (interactive)
  (emacsql db
           "drop table if exists dmg_properties_tags")
  (emacsql db
           "
  CREATE TABLE dmg_headers_properties(
               file not null,
               pos  not null,
               id,
               property not null,
               value,
               primary key (file, pos, property),
               foreign key (file) references files on delete cascade,
               foreign key (file, pos) references dmg_headers on delete cascade
             );
  "
           )
  )


(defun dmg-org-roam-create-view (db vname create-stmt force)
  (if (or force
          (not (dmg-sqlite-verify-table-exists-p db vname "view")))
      (dmg-sqlite-create db vname "view" create-stmt force)
    ))




;; ancestors view



(setq dmg-org-roam-view-with-ancestors-create
      (format "create view %s as %s;" dmg-org-roam-view-with-ancestors
"
  WITH recursive Ancestors AS (
    -- Anchor member: Start with each node
    SELECT
        file,
        title, pos,
        id,
        parentid,
        todo,
        level,
        priority,
        parentid AS ancestor_id,
        level AS ancestor_level
    FROM 
        dmg_headers
    where
        todo is not null
    
    UNION ALL
    
    -- Recursive member: Traverse to the parent of the current node
    SELECT
        c.file,
        c.title,
        c.pos,
        c.id,
        c.parentid, 
        c.todo,     
        c.level,
        c.priority,
        p.parentid AS ancestor_id,
        p.level AS ancestor_level 
    FROM 
        dmg_headers p
    JOIN 
        Ancestors c ON (c.ancestor_id = p.id and c.file = p.file and p.id <> p.parentid)
)
select * from ancestors"))

(setq dmg-org-roam-nexts-query "
-- schema of the result
--- file, anchor, prarea, prtodo, prlevel,
--- prpriority, nnext, title, todo, scheduled,
--- priority

-- the anchor is 1 if there is no header (so it jumps to the beginning of file)

with
  nexts as (select
     d.file as file,
     d.pos,
     d.title as title,
     d.todo as todo,
     d.scheduled,
     d.priority as priority,
     n.title AS prarea,
     n.level as prlevel,
     n.id as prid,
     n.todo as prtodo,
     n.priority as prpriority,
     tag,
     coalesce(tpriority,0) as tpriority
     from 
        dmg_headers d left join nodes n
        left join dmg_headers_tags using (file, pos)
        left join dmg_tags_priority using(tag)
     where (d.prareaid = n.id)
       and  d.todo = '\"NEXT\"'
       and lower(tag) not in ('\"attach\"', '\"dmgtodo\"', '\"crypt\"')
   ),
   projs as (select prid, count(*) as nnext, min(pos) as pos
            from nexts group by prid),
   maxprio as (
       select file, pos, max(tpriority) as tpriority from
       nexts group by file, pos)

select 
       file,
       case when prlevel = 0 then '1' else  prarea end as anchor,
       prarea,
       prtodo ,
       prlevel, --5
       prpriority,
       nnext,
       title,
       todo,
       scheduled,
       priority,
       tag,
       tpriority,
     row_number() over (partition by tag ) as row_num
     from projs natural join nexts
         natural join maxprio
     %s -- for optinal where clause
     group by file, pos, tag
    order by
          tpriority desc, tag, row_num,
          prpriority nulls last,
          scheduled desc nulls last,
          priority, prarea, todo desc, file
")
     
(setq dmg-org-roam-view-nexts-create
      (format "create view %s as %s;" dmg-org-roam-view-nexts
              (format dmg-org-roam-nexts-query "")))


(defun dmg-org-roam-create-view-nexts (db &optional force)
  (dmg-org-roam-create-view db dmg-org-roam-view-nexts dmg-org-roam-view-nexts-create force)
  )




(setq dmg-org-roam-view-prarea-create (format "create view %s as %s" dmg-org-roam-view-prarea
"with prarea as  (
  SELECT  tag,
        tpriority as tpriority, d.id, d.file, d.title, d.todo, d.priority, --5
        ta.level,
        sum(a.todo = '\"NEXT\"') as next,
        sum(a.todo = '\"TODO\"') as ntodo,
        sum(a.todo = '\"WAITING\"') as waiting,
        sum(a.todo = '\"SOMEDAY\"') as someday,   -- 10 
        mtime
    FROM 
        dmg_headers  d left join v_dmg_todos_with_ancestor a on (a.ancestor_id = d.id)
            left join dmg_headers_tags t using (file, pos)
            left join dmg_tags_priority using (tag)
            left join files using (file)
            left join v_dmg_todos_with_ancestor ta using (file, pos)
   where d.todo in ('\"AREA\"',
                    '\"PROJ\"',
                    '\"SPROJ\"',
                    '\"FPROJ\"'
                    )  and
        (lower(tag) not in ('\"attach\"', '\"dmgtodo\"', '\"crypt\"') or
          tag is null)
   group by tag, d.id, d.file, d.title, d.todo
   order by d.id)
select * from prarea"))

(defun dmg-org-roam-create-view-prarea (db &optional force)
  (dmg-org-roam-create-view db dmg-org-roam-view-prarea dmg-org-roam-view-prarea-create force)
  )



(defun dmg-org-roam-create-view-todo-with-ancestors (db &optional force)
  (dmg-org-roam-create-view db dmg-org-roam-view-with-ancestors dmg-org-roam-view-with-ancestors-create force)
  )

(defun dmg-org-roam-views-create (db &optional force)
  (dmg-org-roam-create-view-todo-with-ancestors db force)
  (dmg-org-roam-create-view-nexts db force)
  (dmg-org-roam-create-view-prarea db force)
  )

(defun dmg-org-roam-tables-create (db)
  (message "Creating dmg-org-roam tables")
  ;; we need to drop depending table first
  (dmg-org-roam-table-headers-create db)
  (dmg-org-roam-table-headers-tags-create db)
  (dmg-org-roam-table-headers-properties-create db)

  (dmg-org-roam-verify-tags-priority-exists db)
  )  


(defun dmg-org-roam-tables-create-if-needed (db)
  (unless(and
          (dmg-sqlite-verify-table-exists-p db dmg-org-roam-headers-table)
          (dmg-sqlite-verify-table-exists-p db dmg-org-roam-headers-tags-table))
    (dmg-org-roam-tables-create db)
    (message "Created dmg org roam tables")
    )
  (unless (and (dmg-sqlite-verify-table-exists-p db "v_dmg_nexts" "view")
               (dmg-sqlite-verify-table-exists-p db dmg-org-roam-view-nexts "view")
               (dmg-sqlite-verify-table-exists-p db dmg-org-roam-view-with-ancestors "view"))
    (dmg-org-roam-views-create db t)
    (message "Created dmg org roam views")))
  


(defun dmg-org-roam-update-headers-of-buffer (buffer)
  (switch-to-buffer buffer)
  (when (org-roam-file-p (buffer-file-name))
    (dmg-org-roam-tables-create-if-needed (org-roam-db)) 
    (dmg-sql-update-headers-of-buffer (dmg-filetag-p "dmgNoHeaders"))
    )
  )

(defun dmg-org-roam-table-headers-tags-priority-create  (db)
  (condition-case err
      (progn
        (emacsql db [:begin])
        
        (emacsql db [:drop-table :if-exists $i1] dmg-org-roam-tags-priority-table)
        
        (emacsql db
                 [:create-table $i1
                                ([(tag text :primary-key)]
                                 (tpriority integer)
                                 )]
                 dmg-org-roam-tags-priority-table)
        
        (message "Inserting [%S]" dmg-org-roam-tags-priority)
        (emacsql db [:insert :into $i1 :values $v2]
                 dmg-org-roam-tags-priority-table
                 dmg-org-roam-tags-priority)
        
        (emacsql db [:commit])
        (message "Successfully created [%S] table" dmg-org-roam-tags-priority-table)
        )
    (error
     (progn
       (emacsql db [:abort])
       (message "There was an error in the creation of the table... aborting transaction" ) 
       (message "Full [%S]" err) 
       )
     )
    ))
  
(defun dmg-org-roam-verify-tags-priority-exists (db)
  (unless (dmg-sqlite-verify-table-exists-p db dmg-org-roam-tags-priority-table)
    (message "Creating table with tags priority [%s]"  dmg-org-roam-tags-priority-table)
    (dmg-org-roam-table-headers-tags-priority-create db)))

;;;XXXXXXXXXXXXXXXXXXXXXXXXX
;; add code to verify orgroam



(defun dmg-org-get-filetags (e)
  (let ((type (org-element-type e))
        (key (org-element-property :key e))
        (value (org-element-property :value e)))
    (if (and (eq type 'keyword) (equal key "FILETAGS"))
        (string-split value ":" t))))

(defun dmg-org-get-buffer-filetags-fast ()
  "Extract filetags from the current org-mode buffer."
  (save-excursion
    (widen)
    (goto-char (point-min))
    (if (re-search-forward "^#\\+FILETAGS: \\(.*\\)$" nil t)
        (split-string (nth 0
         (split-string (substring-no-properties (match-string 1)) " " t))
         ":" t)
      nil)))

(defun dmg-filetag-p-slow (tag)
  "returns whether a given tag is in the FILETAGS"
      (save-excursion
      (goto-char (point-min))
      (search-forward "#+FILETAGS:")
      (beginning-of-line)
      (let (
            (tags  (dmg-org-get-filetags (org-element-at-point))))
        (member tag tags)
        )
      ))

(defun dmg-filetag-p (tag)
  "returns whether a given tag is in the FILETAGS"
  (member tag (dmg-org-get-buffer-filetags-fast)))

(defun dmg-org-roam-db-update-file (&optional file-path no-require)
  (save-excursion
    (save-window-excursion
      (condition-case err
          (progn
            (dmg-org-roam-tables-create-if-needed (org-roam-db))
            (org-roam-with-file file-path nil
              (dmg-org-roam-update-headers-of-buffer (current-buffer))
              )
            )
        (error
         (progn
           (message "Error updating dmg org-roam database headers [%S]" (error-message-string err))
           (message "Full [%S]" err) 
           ))
        )
      )
    )
  )

(defun dmg-org-roam-db-clear-file (&optional file)
  (unless (dmg-sqlite-verify-table-exists-p (org-roam-db) dmg-org-roam-headers-table)
    (dmg-org-roam-table-headers-create (org-roam-db)))
  (let* (
         (file-path (or file
                        (buffer-file-name)))
         )
    ;; single operation, can be its own transaction
    (org-roam-db-query [:delete :from 'dmg_headers
                                :where (= file $s1)]
                       file
                       )))

(advice-add 'org-roam-db--init :after #'dmg-org-roam-tables-create-if-needed)
(advice-add 'org-roam-db-clear-file :after #'dmg-org-roam-db-clear-file)
(advice-add 'org-roam-db-update-file :after #'dmg-org-roam-db-update-file)

;; at this point org-roam has been already created.. unfortunately
;; which means we have to create the database twice
(dmg-org-roam-tables-create-if-needed (org-roam-db))

(provide 'dmg-org-roam-para)

Well done. Very inspiration!