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

;; lib/relations/tests/routes.sx — extension: all simple paths (route enumeration).

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

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

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

;; Order-insensitive set equality; elements compared structurally (works for
;; lists-of-paths since `=` is structural).
(define
  relations-ro-set=?
  (fn
    (xs ys)
    (and
      (= (len xs) (len ys))
      (relations-ro-subset? xs ys)
      (relations-ro-subset? ys xs))))

;; Diamond + branch + a cycle with an exit.
;;   parent: a->b, a->c, b->d, c->d, b->e
;;   member: a->z (a different kind, to test isolation)
;;   parent cycle: g->h, h->g, h->out
(define
  relations-ro-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 a) (quote z) (quote member))
        (relations-rel (quote g) (quote h) (quote parent))
        (relations-rel (quote h) (quote g) (quote parent))
        (relations-rel (quote h) (quote out) (quote parent))))))

(define
  relations-ro-run-all!
  (fn
    ()
    (let
      ((db (relations-ro-fixture)))
      (do
        (relations-ro-check!
          "two routes a->d"
          (relations-ro-set=?
            (relations-all-paths db (quote a) (quote d) (quote parent))
            (list
              (list (quote a) (quote b) (quote d))
              (list (quote a) (quote c) (quote d))))
          true)
        (relations-ro-check!
          "single route a->e"
          (relations-all-paths db (quote a) (quote e) (quote parent))
          (list (list (quote a) (quote b) (quote e))))
        (relations-ro-check!
          "no route -> empty"
          (relations-all-paths db (quote a) (quote zzz) (quote parent))
          (list))
        (relations-ro-check!
          "self route is the singleton path"
          (relations-all-paths db (quote a) (quote a) (quote parent))
          (list (list (quote a))))
        (relations-ro-check!
          "route through a cycle terminates"
          (relations-all-paths db (quote g) (quote out) (quote parent))
          (list (list (quote g) (quote h) (quote out))))
        (relations-ro-check!
          "route count a->d is 2"
          (len (relations-all-paths db (quote a) (quote d) (quote parent)))
          2)
        (relations-ro-check!
          "kind isolation: no parent route to member target"
          (relations-all-paths db (quote a) (quote z) (quote parent))
          (list))
        (relations-ro-check!
          "member route a->z"
          (relations-all-paths db (quote a) (quote z) (quote member))
          (list (list (quote a) (quote z))))
        (do
          (relations/load!
            (list
              (relations-rel (quote p) (quote q) (quote parent))
              (relations-rel (quote p) (quote r) (quote parent))
              (relations-rel (quote q) (quote s) (quote parent))
              (relations-rel (quote r) (quote s) (quote parent))))
          (relations-ro-check!
            "api all-paths two routes p->s"
            (relations-ro-set=?
              (relations/all-paths (quote p) (quote s) (quote parent))
              (list
                (list (quote p) (quote q) (quote s))
                (list (quote p) (quote r) (quote s))))
            true)
          (relations/load! (list)))))))

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