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)}))

      ;; ── Cooking posts (canonical Phase 10 example) ─────────
      (dl-demo-test-set! "cooking posts by network"
        (dl-query
          (dl-demo-make
            (quote
              ((follows me alice) (follows alice bob) (follows alice carol)
               (authored alice p1) (authored bob p2)
               (authored carol p3) (authored carol p4)
               (tagged p1 travel) (tagged p2 cooking)
               (tagged p3 cooking) (tagged p4 books)))
            dl-demo-cooking-rules)
          (quote (cooking-post-by-network me P)))
        (list {:P (quote p2)} {:P (quote p3)}))

      (dl-demo-test-set! "cooking — direct follow only"
        (dl-query
          (dl-demo-make
            (quote
              ((follows me bob)
               (authored bob p1) (authored bob p2)
               (tagged p1 cooking) (tagged p2 books)))
            dl-demo-cooking-rules)
          (quote (cooking-post-by-network me P)))
        (list {:P (quote p1)}))

      (dl-demo-test-set! "cooking — none in network"
        (dl-query
          (dl-demo-make
            (quote
              ((follows me bob)
               (authored bob p1) (tagged p1 books)))
            dl-demo-cooking-rules)
          (quote (cooking-post-by-network me P)))
        (list))

      (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})))