rose-ash/lib/relations/tests/tree.sx

;; lib/relations/tests/tree.sx — extension: common ancestors, LCA, topo order.

(define relations-tt-pass 0)
(define relations-tt-fail 0)
(define relations-tt-failures (list))

(define
  relations-tt-check!
  (fn
    (name got expected)
    (if
      (= got expected)
      (set! relations-tt-pass (+ relations-tt-pass 1))
      (do
        (set! relations-tt-fail (+ relations-tt-fail 1))
        (append!
          relations-tt-failures
          (str name "\n    expected: " expected "\n    got:      " got))))))

(define
  relations-tt-subset?
  (fn
    (xs ys)
    (cond
      ((= (len xs) 0) true)
      ((relations-member? (first xs) ys)
        (relations-tt-subset? (rest xs) ys))
      (else false))))

(define
  relations-tt-set=?
  (fn
    (xs ys)
    (and
      (= (len xs) (len ys))
      (relations-tt-subset? xs ys)
      (relations-tt-subset? ys xs))))

;; Is xs a valid topo order? every node appears once and no node precedes one of
;; its ancestors. We check the simpler invariant: for each edge u->v (parent),
;; u appears before v in the order.
(define
  relations-tt-index-of
  (fn
    (x xs i)
    (cond
      ((= (len xs) 0) -1)
      ((= (first xs) x) i)
      (else (relations-tt-index-of x (rest xs) (+ i 1))))))

;; Diamond with an extra branch:
;;   parent: a->b, a->c, b->d, c->d, b->e
;; member (different kind): m->n
(define
  relations-tt-fixture
  (fn
    ()
    (relations-build-db
      (list
        (relations-rel (quote a) (quote b) (quote parent))
        (relations-rel (quote a) (quote c) (quote parent))
        (relations-rel (quote b) (quote d) (quote parent))
        (relations-rel (quote c) (quote d) (quote parent))
        (relations-rel (quote b) (quote e) (quote parent))
        (relations-rel (quote m) (quote n) (quote member))))))

;; A cyclic kind, to confirm topo-order refuses it.
(define
  relations-tt-cyc-fixture
  (fn
    ()
    (relations-build-db
      (list
        (relations-rel (quote x) (quote y) (quote parent))
        (relations-rel (quote y) (quote x) (quote parent))))))

(define
  relations-tt-run-all!
  (fn
    ()
    (let
      ((db (relations-tt-fixture)) (cyc (relations-tt-cyc-fixture)))
      (do
        (relations-tt-check!
          "common ancestors of d and e"
          (relations-tt-set=?
            (relations-common-ancestors
              db
              (quote d)
              (quote e)
              (quote parent))
            (list (quote a) (quote b)))
          true)
        (relations-tt-check!
          "common ancestors of b and c"
          (relations-tt-set=?
            (relations-common-ancestors
              db
              (quote b)
              (quote c)
              (quote parent))
            (list (quote a)))
          true)
        (relations-tt-check!
          "no common ancestors across kinds"
          (relations-common-ancestors db (quote d) (quote n) (quote parent))
          (list))
        (relations-tt-check!
          "lca of d and e is b"
          (relations-tt-set=?
            (relations-lca db (quote d) (quote e) (quote parent))
            (list (quote b)))
          true)
        (relations-tt-check!
          "lca of b and c is a"
          (relations-tt-set=?
            (relations-lca db (quote b) (quote c) (quote parent))
            (list (quote a)))
          true)
        (relations-tt-check!
          "lca of d and d-sibling-path picks deepest"
          (relations-tt-set=?
            (relations-lca db (quote d) (quote d) (quote parent))
            (list (quote b) (quote c)))
          true)
        (relations-tt-check!
          "no lca when unrelated"
          (relations-lca db (quote a) (quote n) (quote parent))
          (list))
        (let
          ((order (relations-topo-order db (quote parent))))
          (do
            (relations-tt-check!
              "topo order covers all nodes"
              (relations-tt-set=?
                order
                (list (quote a) (quote b) (quote c) (quote d) (quote e)))
              true)
            (relations-tt-check!
              "topo: a before b"
              (<
                (relations-tt-index-of (quote a) order 0)
                (relations-tt-index-of (quote b) order 0))
              true)
            (relations-tt-check!
              "topo: b before d"
              (<
                (relations-tt-index-of (quote b) order 0)
                (relations-tt-index-of (quote d) order 0))
              true)
            (relations-tt-check!
              "topo: c before d"
              (<
                (relations-tt-index-of (quote c) order 0)
                (relations-tt-index-of (quote d) order 0))
              true)
            (relations-tt-check!
              "topo: b before e"
              (<
                (relations-tt-index-of (quote b) order 0)
                (relations-tt-index-of (quote e) order 0))
              true)))
        (relations-tt-check!
          "topo order of cyclic kind is nil"
          (relations-topo-order cyc (quote parent))
          nil)
        (do
          (relations/load!
            (list
              (relations-rel (quote r) (quote s) (quote parent))
              (relations-rel (quote r) (quote t) (quote parent))
              (relations-rel (quote s) (quote u) (quote parent))
              (relations-rel (quote t) (quote u) (quote parent))))
          (relations-tt-check!
            "api common-ancestors"
            (relations-tt-set=?
              (relations/common-ancestors
                (quote u)
                (quote u)
                (quote parent))
              (list (quote r) (quote s) (quote t)))
            true)
          (relations-tt-check!
            "api lca"
            (relations-tt-set=?
              (relations/lca (quote s) (quote t) (quote parent))
              (list (quote r)))
            true)
          (relations-tt-check!
            "api topo-order covers nodes"
            (relations-tt-set=?
              (relations/topo-order (quote parent))
              (list (quote r) (quote s) (quote t) (quote u)))
            true)
          (relations/load! (list)))))))

(define
  relations-tree-tests-run!
  (fn
    ()
    (do
      (set! relations-tt-pass 0)
      (set! relations-tt-fail 0)
      (set! relations-tt-failures (list))
      (relations-tt-run-all!)
      {:failures relations-tt-failures :total (+ relations-tt-pass relations-tt-fail) :passed relations-tt-pass :failed relations-tt-fail})))