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

;; lib/relations/tests/comp.sx — extension: weakly-connected components.

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

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

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

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

;; Does `comps` (a list of node-lists) contain a component set-equal to `want`?
(define
  relations-cp-has-comp?
  (fn
    (comps want)
    (cond
      ((= (len comps) 0) false)
      ((relations-cp-set=? (first comps) want) true)
      (else (relations-cp-has-comp? (rest comps) want)))))

;; Three parent components + a separate member graph.
;;   parent: a->b, b->c ; x->y ; z->z (self-loop, its own component)
;;   member: m->n
(define
  relations-cp-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 x) (quote y) (quote parent))
        (relations-rel (quote z) (quote z) (quote parent))
        (relations-rel (quote m) (quote n) (quote member))))))

(define
  relations-cp-run-all!
  (fn
    ()
    (let
      ((db (relations-cp-fixture)))
      (do
        (relations-cp-check!
          "component of a"
          (relations-cp-set=?
            (relations-component db (quote a) (quote parent))
            (list (quote a) (quote b) (quote c)))
          true)
        (relations-cp-check!
          "component of c (same as a, undirected)"
          (relations-cp-set=?
            (relations-component db (quote c) (quote parent))
            (list (quote a) (quote b) (quote c)))
          true)
        (relations-cp-check!
          "self-loop node is its own component"
          (relations-cp-set=?
            (relations-component db (quote z) (quote parent))
            (list (quote z)))
          true)
        (relations-cp-check!
          "three parent components"
          (relations-component-count db (quote parent))
          3)
        (relations-cp-check!
          "one member component"
          (relations-component-count db (quote member))
          1)
        (let
          ((comps (relations-components db (quote parent))))
          (do
            (relations-cp-check!
              "partition includes a-b-c"
              (relations-cp-has-comp?
                comps
                (list (quote a) (quote b) (quote c)))
              true)
            (relations-cp-check!
              "partition includes x-y"
              (relations-cp-has-comp? comps (list (quote x) (quote y)))
              true)
            (relations-cp-check!
              "partition includes z"
              (relations-cp-has-comp? comps (list (quote z)))
              true)))
        (relations-cp-check!
          "kind isolation: member component count is 1"
          (relations-component-count db (quote member))
          1)
        (do
          (relations/load!
            (list
              (relations-rel (quote p) (quote q) (quote parent))
              (relations-rel (quote r) (quote s) (quote parent))))
          (relations-cp-check!
            "api component"
            (relations-cp-set=?
              (relations/component (quote p) (quote parent))
              (list (quote p) (quote q)))
            true)
          (relations-cp-check!
            "api component-count"
            (relations/component-count (quote parent))
            2)
          (relations/load! (list)))))))

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