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

;; lib/relations/tests/reach.sx — Phase 2: reachability, roots/leaves, cycles.

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

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

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

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

;; Diamond + a disconnected pair under parent, plus a reply cross-edge.
;;   parent: a->b, a->c, b->d, c->d ; e->f
;;   reply:  b->z
(define
  relations-rt-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 e) (quote f) (quote parent))
        (relations-rel (quote b) (quote z) (quote reply))))))

;; Cycles: c1<->c2, self-loop s->s, plus acyclic t->u, all under parent.
(define
  relations-rt-cyc-fixture
  (fn
    ()
    (relations-build-db
      (list
        (relations-rel (quote c1) (quote c2) (quote parent))
        (relations-rel (quote c2) (quote c1) (quote parent))
        (relations-rel (quote s) (quote s) (quote parent))
        (relations-rel (quote t) (quote u) (quote parent))))))

(define
  relations-rt-run-all!
  (fn
    ()
    (let
      ((db (relations-rt-fixture)) (cyc (relations-rt-cyc-fixture)))
      (do
        (relations-rt-check!
          "descendants of a (diamond)"
          (relations-rt-set=?
            (relations-descendants db (quote a) (quote parent))
            (list (quote b) (quote c) (quote d)))
          true)
        (relations-rt-check!
          "ancestors of d (diamond)"
          (relations-rt-set=?
            (relations-ancestors db (quote d) (quote parent))
            (list (quote a) (quote b) (quote c)))
          true)
        (relations-rt-check!
          "reachable a->d"
          (relations-reachable? db (quote a) (quote d) (quote parent))
          true)
        (relations-rt-check!
          "not reachable d->a"
          (relations-reachable? db (quote d) (quote a) (quote parent))
          false)
        (relations-rt-check!
          "disconnected components"
          (relations-reachable? db (quote a) (quote f) (quote parent))
          false)
        (relations-rt-check!
          "leaf has no descendants"
          (relations-descendants db (quote d) (quote parent))
          (list))
        (relations-rt-check!
          "root has no ancestors"
          (relations-ancestors db (quote a) (quote parent))
          (list))
        (relations-rt-check!
          "roots under parent"
          (relations-rt-set=?
            (relations-roots db (quote parent))
            (list (quote a) (quote e)))
          true)
        (relations-rt-check!
          "leaves under parent"
          (relations-rt-set=?
            (relations-leaves db (quote parent))
            (list (quote d) (quote f)))
          true)
        (relations-rt-check!
          "parent descendants exclude reply target"
          (relations-member?
            (quote z)
            (relations-descendants db (quote a) (quote parent)))
          false)
        (relations-rt-check!
          "reply reachable b->z"
          (relations-reachable? db (quote b) (quote z) (quote reply))
          true)
        (relations-rt-check!
          "parent unreachable a->z"
          (relations-reachable? db (quote a) (quote z) (quote parent))
          false)
        (relations-rt-check!
          "diamond is acyclic"
          (relations-acyclic? db (quote parent))
          true)
        (relations-rt-check!
          "no node cycles in diamond"
          (relations-cycle? db (quote a) (quote parent))
          false)
        (relations-rt-check!
          "c1 is on a cycle"
          (relations-cycle? cyc (quote c1) (quote parent))
          true)
        (relations-rt-check!
          "self-loop counts as cycle"
          (relations-cycle? cyc (quote s) (quote parent))
          true)
        (relations-rt-check!
          "acyclic node t not on cycle"
          (relations-cycle? cyc (quote t) (quote parent))
          false)
        (relations-rt-check!
          "kind with a cycle is not acyclic"
          (relations-acyclic? cyc (quote parent))
          false)
        (relations-rt-check!
          "cycle reachable both ways"
          (and
            (relations-reachable? cyc (quote c1) (quote c2) (quote parent))
            (relations-reachable? cyc (quote c2) (quote c1) (quote parent)))
          true)
        (relations-rt-check!
          "node in cycle reaches itself"
          (relations-member?
            (quote c1)
            (relations-descendants cyc (quote c1) (quote parent)))
          true)
        (do
          (relations/load!
            (list
              (relations-rel (quote r) (quote m) (quote parent))
              (relations-rel (quote m) (quote n) (quote parent))))
          (relations-rt-check!
            "api descendants"
            (relations-rt-set=?
              (relations/descendants (quote r) (quote parent))
              (list (quote m) (quote n)))
            true)
          (relations-rt-check!
            "api reachable"
            (relations/reachable? (quote r) (quote n) (quote parent))
            true)
          (relations-rt-check!
            "api roots"
            (relations-rt-set=?
              (relations/roots (quote parent))
              (list (quote r)))
            true)
          (relations-rt-check!
            "api acyclic"
            (relations/acyclic? (quote parent))
            true)
          (relations/load! (list)))))))

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