rose-ash/lib/datalog/tests/demo.sx

;; lib/datalog/tests/demo.sx — Phase 10 demo programs.

(define dl-demo-pass 0)
(define dl-demo-fail 0)
(define dl-demo-failures (list))

(define
  dl-demo-deep=?
  (fn
    (a b)
    (cond
      ((and (list? a) (list? b))
        (and (= (len a) (len b)) (dl-demo-deq-l? a b 0)))
      ((and (dict? a) (dict? b))
        (let ((ka (keys a)) (kb (keys b)))
          (and (= (len ka) (len kb)) (dl-demo-deq-d? a b ka 0))))
      ((and (number? a) (number? b)) (= a b))
      (else (equal? a b)))))

(define
  dl-demo-deq-l?
  (fn
    (a b i)
    (cond
      ((>= i (len a)) true)
      ((not (dl-demo-deep=? (nth a i) (nth b i))) false)
      (else (dl-demo-deq-l? a b (+ i 1))))))

(define
  dl-demo-deq-d?
  (fn
    (a b ka i)
    (cond
      ((>= i (len ka)) true)
      ((let ((k (nth ka i)))
         (not (dl-demo-deep=? (get a k) (get b k))))
        false)
      (else (dl-demo-deq-d? a b ka (+ i 1))))))

(define
  dl-demo-set=?
  (fn
    (a b)
    (and
      (= (len a) (len b))
      (dl-demo-subset? a b)
      (dl-demo-subset? b a))))

(define
  dl-demo-subset?
  (fn
    (xs ys)
    (cond
      ((= (len xs) 0) true)
      ((not (dl-demo-contains? ys (first xs))) false)
      (else (dl-demo-subset? (rest xs) ys)))))

(define
  dl-demo-contains?
  (fn
    (xs target)
    (cond
      ((= (len xs) 0) false)
      ((dl-demo-deep=? (first xs) target) true)
      (else (dl-demo-contains? (rest xs) target)))))

(define
  dl-demo-test-set!
  (fn
    (name got expected)
    (if
      (dl-demo-set=? got expected)
      (set! dl-demo-pass (+ dl-demo-pass 1))
      (do
        (set! dl-demo-fail (+ dl-demo-fail 1))
        (append!
          dl-demo-failures
          (str
            name
            "\n    expected (set): " expected
            "\n    got:            " got))))))

(define
  dl-demo-run-all!
  (fn
    ()
    (do
      ;; ── Federation ──────────────────────────────────────────
      (dl-demo-test-set! "mutuals"
        (dl-query
          (dl-demo-make
            (quote ((follows alice bob) (follows bob alice)
                    (follows bob carol) (follows carol dave)))
            dl-demo-federation-rules)
          (quote (mutual alice X)))
        (list {:X (quote bob)}))

      (dl-demo-test-set! "reachable transitive"
        (dl-query
          (dl-demo-make
            (quote ((follows alice bob) (follows bob carol) (follows carol dave)))
            dl-demo-federation-rules)
          (quote (reachable alice X)))
        (list {:X (quote bob)} {:X (quote carol)} {:X (quote dave)}))

      (dl-demo-test-set! "foaf"
        (dl-query
          (dl-demo-make
            (quote ((follows alice bob) (follows bob carol) (follows alice dave)))
            dl-demo-federation-rules)
          (quote (foaf alice X)))
        (list {:X (quote carol)}))

      ;; ── Content ─────────────────────────────────────────────
      (dl-demo-test-set! "popular posts"
        (dl-query
          (dl-demo-make
            (quote
              ((authored alice p1) (authored bob p2) (authored carol p3)
               (liked u1 p1) (liked u2 p1) (liked u3 p1)
               (liked u1 p2)))
            dl-demo-content-rules)
          (quote (popular P)))
        (list {:P (quote p1)}))

      (dl-demo-test-set! "interesting feed"
        (dl-query
          (dl-demo-make
            (quote
              ((follows me alice) (follows me bob)
               (authored alice p1) (authored bob p2)
               (liked u1 p1) (liked u2 p1) (liked u3 p1)
               (liked u4 p2)))
            dl-demo-content-rules)
          (quote (interesting me P)))
        (list {:P (quote p1)}))

      (dl-demo-test-set! "post likes count"
        (dl-query
          (dl-demo-make
            (quote
              ((authored alice p1)
               (liked u1 p1) (liked u2 p1) (liked u3 p1)))
            dl-demo-content-rules)
          (quote (post-likes p1 N)))
        (list {:N 3}))

      ;; ── Permissions ─────────────────────────────────────────
      (dl-demo-test-set! "direct group access"
        (dl-query
          (dl-demo-make
            (quote
              ((member alice editors)
               (allowed editors blog)))
            dl-demo-perm-rules)
          (quote (can-access X blog)))
        (list {:X (quote alice)}))

      (dl-demo-test-set! "subgroup access"
        (dl-query
          (dl-demo-make
            (quote
              ((member bob writers)
               (subgroup writers editors)
               (allowed editors blog)))
            dl-demo-perm-rules)
          (quote (can-access X blog)))
        (list {:X (quote bob)}))

      (dl-demo-test-set! "transitive subgroup"
        (dl-query
          (dl-demo-make
            (quote
              ((member carol drafters)
               (subgroup drafters writers)
               (subgroup writers editors)
               (allowed editors blog)))
            dl-demo-perm-rules)
          (quote (can-access X blog)))
        (list {:X (quote carol)}))

      (dl-demo-test-set! "no access without grant"
        (dl-query
          (dl-demo-make
            (quote ((member dave outsiders) (allowed editors blog)))
            dl-demo-perm-rules)
          (quote (can-access X blog)))
        (list)))))

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