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

;; lib/relations/tests/shape.sx — extension: siblings, degree, undirected
;; connectivity.

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

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

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

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

;; A small tree plus a disconnected pair.
;;   parent: p->a, p->b, p->c, a->d ; q->r (disconnected)
;;   member: m->x, m->y (a different kind, same db)
(define
  relations-st-fixture
  (fn
    ()
    (relations-build-db
      (list
        (relations-rel (quote p) (quote a) (quote parent))
        (relations-rel (quote p) (quote b) (quote parent))
        (relations-rel (quote p) (quote c) (quote parent))
        (relations-rel (quote a) (quote d) (quote parent))
        (relations-rel (quote q) (quote r) (quote parent))
        (relations-rel (quote m) (quote x) (quote member))
        (relations-rel (quote m) (quote y) (quote member))))))

(define
  relations-st-run-all!
  (fn
    ()
    (let
      ((db (relations-st-fixture)))
      (do
        (relations-st-check!
          "siblings of a"
          (relations-st-set=?
            (relations-siblings db (quote a) (quote parent))
            (list (quote b) (quote c)))
          true)
        (relations-st-check!
          "only child has no siblings"
          (relations-siblings db (quote d) (quote parent))
          (list))
        (relations-st-check!
          "siblings respect kind"
          (relations-st-set=?
            (relations-siblings db (quote x) (quote member))
            (list (quote y)))
          true)
        (relations-st-check!
          "no cross-kind siblings"
          (relations-siblings db (quote a) (quote member))
          (list))
        (relations-st-check!
          "out-degree of p"
          (relations-out-degree db (quote p) (quote parent))
          3)
        (relations-st-check!
          "out-degree of a"
          (relations-out-degree db (quote a) (quote parent))
          1)
        (relations-st-check!
          "out-degree of leaf"
          (relations-out-degree db (quote d) (quote parent))
          0)
        (relations-st-check!
          "in-degree of a"
          (relations-in-degree db (quote a) (quote parent))
          1)
        (relations-st-check!
          "in-degree of root"
          (relations-in-degree db (quote p) (quote parent))
          0)
        (relations-st-check!
          "siblings are connected"
          (relations-connected? db (quote b) (quote c) (quote parent))
          true)
        (relations-st-check!
          "cousin connected (b <-> d)"
          (relations-connected? db (quote b) (quote d) (quote parent))
          true)
        (relations-st-check!
          "self connected"
          (relations-connected? db (quote a) (quote a) (quote parent))
          true)
        (relations-st-check!
          "disconnected components not connected"
          (relations-connected? db (quote a) (quote q) (quote parent))
          false)
        (relations-st-check!
          "directed-unreachable but undirected-connected"
          (and
            (not
              (relations-reachable? db (quote b) (quote c) (quote parent)))
            (relations-connected? db (quote b) (quote c) (quote parent)))
          true)
        (relations-st-check!
          "connectivity respects kind"
          (relations-connected? db (quote a) (quote x) (quote member))
          false)
        (do
          (relations/load!
            (list
              (relations-rel (quote g) (quote h) (quote parent))
              (relations-rel (quote g) (quote i) (quote parent))))
          (relations-st-check!
            "api siblings"
            (relations-st-set=?
              (relations/siblings (quote h) (quote parent))
              (list (quote i)))
            true)
          (relations-st-check!
            "api out-degree"
            (relations/out-degree (quote g) (quote parent))
            2)
          (relations-st-check!
            "api connected"
            (relations/connected? (quote h) (quote i) (quote parent))
            true)
          (relations/load! (list)))))))

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