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

;; lib/relations/tests/path.sx — Phase 3: typed relations, path, distance.

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

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

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

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

;; Two kinds coexisting in one db.
;;   parent: a->b, b->c, c->d, a->c (shortcut), x->y (disconnected)
;;   member: c->m, m->n (crosses into a different kind)
(define
  relations-pt-fixture
  (fn
    ()
    (relations-build-db
      (list
        (relations-rel (quote a) (quote b) (quote parent))
        (relations-rel (quote b) (quote c) (quote parent))
        (relations-rel (quote c) (quote d) (quote parent))
        (relations-rel (quote a) (quote c) (quote parent))
        (relations-rel (quote x) (quote y) (quote parent))
        (relations-rel (quote c) (quote m) (quote member))
        (relations-rel (quote m) (quote n) (quote member))))))

;; A cycle with an exit: u->v->w->u, w->exit.
(define
  relations-pt-cyc-fixture
  (fn
    ()
    (relations-build-db
      (list
        (relations-rel (quote u) (quote v) (quote parent))
        (relations-rel (quote v) (quote w) (quote parent))
        (relations-rel (quote w) (quote u) (quote parent))
        (relations-rel (quote w) (quote exit) (quote parent))))))

(define
  relations-pt-run-all!
  (fn
    ()
    (let
      ((db (relations-pt-fixture)) (cyc (relations-pt-cyc-fixture)))
      (do
        (relations-pt-check!
          "shortest path a->d"
          (relations-path db (quote a) (quote d) (quote parent))
          (list (quote a) (quote c) (quote d)))
        (relations-pt-check!
          "distance a->d is 2"
          (relations-distance db (quote a) (quote d) (quote parent))
          2)
        (relations-pt-check!
          "direct edge path a->c"
          (relations-path db (quote a) (quote c) (quote parent))
          (list (quote a) (quote c)))
        (relations-pt-check!
          "distance a->c is 1"
          (relations-distance db (quote a) (quote c) (quote parent))
          1)
        (relations-pt-check!
          "path b->d"
          (relations-path db (quote b) (quote d) (quote parent))
          (list (quote b) (quote c) (quote d)))
        (relations-pt-check!
          "self path"
          (relations-path db (quote a) (quote a) (quote parent))
          (list (quote a)))
        (relations-pt-check!
          "self distance is 0"
          (relations-distance db (quote a) (quote a) (quote parent))
          0)
        (relations-pt-check!
          "unknown target -> nil path"
          (relations-path db (quote a) (quote zzz) (quote parent))
          nil)
        (relations-pt-check!
          "unknown target -> nil distance"
          (relations-distance db (quote a) (quote zzz) (quote parent))
          nil)
        (relations-pt-check!
          "disconnected -> nil path"
          (relations-path db (quote a) (quote y) (quote parent))
          nil)
        (relations-pt-check!
          "no parent path crosses into member edge"
          (relations-path db (quote a) (quote m) (quote parent))
          nil)
        (relations-pt-check!
          "member path c->m"
          (relations-path db (quote c) (quote m) (quote member))
          (list (quote c) (quote m)))
        (relations-pt-check!
          "member path c->n"
          (relations-path db (quote c) (quote n) (quote member))
          (list (quote c) (quote m) (quote n)))
        (relations-pt-check!
          "mixed-kind reachable a->m"
          (relations-reachable-any? db (quote a) (quote m))
          true)
        (relations-pt-check!
          "mixed-kind reachable a->n"
          (relations-reachable-any? db (quote a) (quote n))
          true)
        (relations-pt-check!
          "single-kind a->m not reachable under parent"
          (relations-reachable? db (quote a) (quote m) (quote parent))
          false)
        (relations-pt-check!
          "mixed-kind descendants of a include cross-kind nodes"
          (relations-pt-set=?
            (relations-descendants-any db (quote a))
            (list (quote b) (quote c) (quote d) (quote m) (quote n)))
          true)
        (relations-pt-check!
          "single-kind descendants of a under parent only"
          (relations-pt-set=?
            (relations-descendants db (quote a) (quote parent))
            (list (quote b) (quote c) (quote d)))
          true)
        (relations-pt-check!
          "path out of a cycle"
          (relations-path cyc (quote u) (quote exit) (quote parent))
          (list (quote u) (quote v) (quote w) (quote exit)))
        (relations-pt-check!
          "distance out of a cycle is 3"
          (relations-distance cyc (quote u) (quote exit) (quote parent))
          3)
        (do
          (relations/load!
            (list
              (relations-rel (quote r1) (quote r2) (quote parent))
              (relations-rel (quote r2) (quote r3) (quote parent))
              (relations-rel (quote r3) (quote r4) (quote link))))
          (relations-pt-check!
            "api path"
            (relations/path (quote r1) (quote r3) (quote parent))
            (list (quote r1) (quote r2) (quote r3)))
          (relations-pt-check!
            "api distance"
            (relations/distance (quote r1) (quote r3) (quote parent))
            2)
          (relations-pt-check!
            "api mixed-kind reachable across parent+link"
            (relations/reachable-any? (quote r1) (quote r4))
            true)
          (relations-pt-check!
            "api single-kind not reachable across kinds"
            (relations/reachable? (quote r1) (quote r4) (quote parent))
            false)
          (relations/load! (list)))))))

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