rose-ash/lib/git/dag.sx

; lib/git/dag.sx — sx-git Phase 3: the commit DAG as queries.
; The workhorse walks (log, ancestry, reachability, merge-base) run SX-side
; over parent edges read straight from commit objects. The Datalog bridge
; exports those edges as (git-parent child parent) facts under a deliberately
; MINIMAL two-rule ancestor closure (every dl-query re-saturates the ruleset —
; keep it lean, walk SX-side; see lib/relations/engine.sx for the precedent).
; Requires: lib/git/object.sx; datalog stack only for the git/dag-db bridge.

(define
  git/parents
  (fn
    (repo cid)
    (let
      ((c (git/read repo cid)))
      (if (git/commit? c) (git/commit-parents c) (list)))))

; ---- DFS postorder over parent edges, visited-set threaded through ----
; returns (seen acc); acc lists each commit AFTER all its parents.
(define
  git/dag-post
  (fn
    (repo cid seen acc)
    (if
      (has-key? seen cid)
      (list seen acc)
      (let
        ((res (git/dag-post-list repo (git/parents repo cid) (assoc seen cid true) acc)))
        (list (first res) (append (nth res 1) (list cid)))))))

(define
  git/dag-post-list
  (fn
    (repo cids seen acc)
    (if
      (empty? cids)
      (list seen acc)
      (let
        ((res (git/dag-post repo (first cids) seen acc)))
        (git/dag-post-list
          repo
          (rest cids)
          (first res)
          (nth res 1))))))

; all commits reachable from cid, INCLUDING cid (parents-first order)
(define
  git/reachable
  (fn
    (repo cid)
    (nth (git/dag-post repo cid {} (list)) 1)))

(define
  git/reachable-all
  (fn
    (repo cids)
    (nth (git/dag-post-list repo cids {} (list)) 1)))

; ---- log: topological, children before parents (reverse DFS postorder) ----
(define
  git/log
  (fn (repo head-cid) (reverse (git/reachable repo head-cid))))

(define
  git/log-messages
  (fn
    (repo head-cid)
    (map
      (fn (c) (git/commit-message (git/read repo c)))
      (git/log repo head-cid))))

; ---- ancestry ----
; proper ancestors of cid (excludes cid itself unless reachable via a cycle,
; which a well-formed commit DAG never has)
(define
  git/ancestors
  (fn
    (repo cid)
    (nth
      (git/dag-post-list repo (git/parents repo cid) {} (list))
      1)))

(define
  git/dag-member?
  (fn (x xs) (reduce (fn (acc y) (or acc (equal? x y))) false xs)))

; reflexive, like `git merge-base --is-ancestor A B`: is a an ancestor of b?
(define
  git/is-ancestor?
  (fn
    (repo a b)
    (if (equal? a b) true (git/dag-member? a (git/ancestors repo b)))))

; ---- merge-base (LCA) ----
(define
  git/dag-set
  (fn (xs) (reduce (fn (acc x) (assoc acc x true)) {} xs)))

(define
  git/common-ancestors
  (fn
    (repo a b)
    (let
      ((sb (git/dag-set (git/reachable repo b))))
      (filter (fn (c) (has-key? sb c)) (git/reachable repo a)))))

; all best common ancestors: common ancestors dominated by no other common
; ancestor (c is dominated when it is a proper ancestor of another common d)
(define
  git/merge-bases
  (fn
    (repo a b)
    (let
      ((common (git/common-ancestors repo a b)))
      (artdag/sort-strings
        (filter
          (fn
            (c)
            (not
              (reduce
                (fn
                  (acc d)
                  (or
                    acc
                    (and
                      (not (equal? c d))
                      (git/dag-member? c (git/ancestors repo d)))))
                false
                common)))
          common)))))

(define
  git/merge-base
  (fn
    (repo a b)
    (let
      ((bs (git/merge-bases repo a b)))
      (if (empty? bs) nil (first bs)))))

; ---- Datalog bridge: parent edges as facts, minimal ancestor closure ----
(define
  git/dag-rules
  (quote
    ((git-anc X Y <- (git-parent X Y))
      (git-anc X Y <- (git-parent X Z) (git-anc Z Y)))))

(define
  git/dag-facts
  (fn
    (repo heads)
    (reduce
      (fn
        (acc c)
        (append
          acc
          (map
            (fn (p) (list (quote git-parent) c p))
            (git/parents repo c))))
      (list)
      (git/reachable-all repo heads))))

(define
  git/dag-db
  (fn
    (repo heads)
    (dl-program-data (git/dag-facts repo heads) git/dag-rules)))

(define
  git/ancestors-dl
  (fn
    (db cid)
    (artdag/sort-strings
      (map
        (fn (s) (get s :Y))
        (dl-query db (list (quote git-anc) cid (quote Y)))))))

(define
  git/is-ancestor-dl?
  (fn
    (db a b)
    (> (len (dl-query db (list (quote git-anc) b a))) 0)))