rose-ash/lib/git/tests/dag.sx

; Phase 3 — dag: log (topo), ancestry, is-ancestor?, reachability, merge-base,
; and the minimal Datalog ancestor-closure bridge.
; Fixtures: a linear chain, a diamond merge, a criss-cross (two LCAs),
; and two unrelated roots.

(define gdt-db (persist/mem-backend))
(define gdt (git/repo gdt-db))

(define
  gdt-commit!
  (fn
    (msg parents)
    (git/write gdt (git/commit (git/write-blob gdt msg) parents {:message msg}))))

; linear chain c1 <- c2 <- c3
(define gdt-c1 (gdt-commit! "c1" (list)))
(define gdt-c2 (gdt-commit! "c2" (list gdt-c1)))
(define gdt-c3 (gdt-commit! "c3" (list gdt-c2)))

; diamond: b1 <- p, b1 <- q, m = merge(p q)
(define gdt-b1 (gdt-commit! "b1" (list)))
(define gdt-p (gdt-commit! "p" (list gdt-b1)))
(define gdt-q (gdt-commit! "q" (list gdt-b1)))
(define gdt-m (gdt-commit! "m" (list gdt-p gdt-q)))

; criss-cross: base <- a, base <- b; x = merge(a b), y = merge(a b) via
; distinct messages so x != y
(define gdt-base (gdt-commit! "base" (list)))
(define gdt-a (gdt-commit! "a" (list gdt-base)))
(define gdt-b (gdt-commit! "b" (list gdt-base)))
(define gdt-x (gdt-commit! "x" (list gdt-a gdt-b)))
(define gdt-y (gdt-commit! "y" (list gdt-a gdt-b)))

; unrelated root
(define gdt-lone (gdt-commit! "lone" (list)))

; ---- parents ----
(git-test
  "parents of a root commit"
  (= (git/parents gdt gdt-c1) (list))
  true)
(git-test
  "parents of a merge commit"
  (= (git/parents gdt gdt-m) (list gdt-p gdt-q))
  true)
(git-test
  "parents of a non-commit cid"
  (= (git/parents gdt "sx1:junk") (list))
  true)

; ---- reachability ----
(git-test
  "reachable includes self"
  (git/dag-member? gdt-c3 (git/reachable gdt gdt-c3))
  true)
(git-test
  "reachable spans the chain"
  (= (git/reachable gdt gdt-c3) (list gdt-c1 gdt-c2 gdt-c3))
  true)
(git-test
  "reachable covers both diamond legs"
  (len (git/reachable gdt gdt-m))
  4)
(git-test
  "reachable-all merges from several heads without duplicates"
  (len (git/reachable-all gdt (list gdt-x gdt-y)))
  5)

; ---- log: children before parents ----
(git-test
  "log on a chain is newest-first"
  (= (git/log gdt gdt-c3) (list gdt-c3 gdt-c2 gdt-c1))
  true)
(git-test
  "log messages read newest-first"
  (= (git/log-messages gdt gdt-c3) (list "c3" "c2" "c1"))
  true)
(git-test
  "log of a diamond is a valid topo order"
  (= (git/log gdt gdt-m) (list gdt-m gdt-q gdt-p gdt-b1))
  true)
(git-test
  "log of a root is just the root"
  (= (git/log gdt gdt-c1) (list gdt-c1))
  true)

; ---- ancestors / is-ancestor? ----
(git-test
  "ancestors excludes self"
  (git/dag-member? gdt-c3 (git/ancestors gdt gdt-c3))
  false)
(git-test
  "ancestors of the chain tip"
  (= (git/ancestors gdt gdt-c3) (list gdt-c1 gdt-c2))
  true)
(git-test
  "ancestors of a merge include both legs and the base"
  (len (git/ancestors gdt gdt-m))
  3)
(git-test
  "is-ancestor? along the chain"
  (git/is-ancestor? gdt gdt-c1 gdt-c3)
  true)
(git-test
  "is-ancestor? is directed"
  (git/is-ancestor? gdt gdt-c3 gdt-c1)
  false)
(git-test
  "is-ancestor? is reflexive"
  (git/is-ancestor? gdt gdt-c2 gdt-c2)
  true)
(git-test
  "is-ancestor? false across unrelated history"
  (git/is-ancestor? gdt gdt-c1 gdt-lone)
  false)

; ---- merge-base ----
(git-test
  "merge-base of the diamond legs is the base"
  (git/merge-base gdt gdt-p gdt-q)
  gdt-b1)
(git-test
  "merge-base when one side is an ancestor is that side"
  (git/merge-base gdt gdt-c1 gdt-c3)
  gdt-c1)
(git-test "merge-base with self" (git/merge-base gdt gdt-c3 gdt-c3) gdt-c3)
(git-test
  "merge-base of unrelated commits is nil"
  (git/merge-base gdt gdt-c3 gdt-lone)
  nil)
(git-test
  "merge-base is symmetric"
  (equal? (git/merge-base gdt gdt-p gdt-q) (git/merge-base gdt gdt-q gdt-p))
  true)
(git-test
  "criss-cross yields BOTH best common ancestors"
  (=
    (git/merge-bases gdt gdt-x gdt-y)
    (artdag/sort-strings (list gdt-a gdt-b)))
  true)
(git-test
  "dominated common ancestor is not a merge-base"
  (git/dag-member? gdt-base (git/merge-bases gdt gdt-x gdt-y))
  false)

; ---- Datalog bridge ----
(git-test
  "dag-facts exports one fact per parent edge"
  (len (git/dag-facts gdt (list gdt-m)))
  4)
(git-test
  "datalog ancestors match the SX-side walk"
  (let
    ((db (git/dag-db gdt (list gdt-m))))
    (=
      (git/ancestors-dl db gdt-m)
      (artdag/sort-strings (git/ancestors gdt gdt-m))))
  true)
(git-test
  "datalog is-ancestor? positive"
  (git/is-ancestor-dl? (git/dag-db gdt (list gdt-m)) gdt-b1 gdt-m)
  true)
(git-test
  "datalog is-ancestor? negative"
  (git/is-ancestor-dl? (git/dag-db gdt (list gdt-m)) gdt-m gdt-b1)
  false)
(git-test
  "datalog closure spans the chain"
  (=
    (git/ancestors-dl (git/dag-db gdt (list gdt-c3)) gdt-c3)
    (artdag/sort-strings (list gdt-c1 gdt-c2)))
  true)