clojure: set relational ops — select, project, rename, index, join
ober
b8e67f1869fc15a70f27fff8d260ab4f4a5f700d
--- a/lib/std/clojure.sls +++ b/lib/std/clojure.sls @@ -73,6 +73,9 @@ hash-set set set? disj union intersection difference subset? superset? + ;; ---- Set relational ops (clojure.set) ---- + set-select set-project set-rename set-index set-join + map-invert ;; ---- Constructors (aliases) ---- hash-map vec list* vector* @@ -1080,6 +1083,121 @@ (define (superset? s1 s2) (subset? s2 s1)) ;; ========================================================================= + ;; Set relational operations (clojure.set) + ;; + ;; These operate on "relations" — sets of maps (persistent sets of + ;; persistent maps). Like Clojure, they provide a tiny relational + ;; algebra over in-memory data. + ;; ========================================================================= + + ;; set-select — return subset where (pred map) is true + ;; Like clojure.set/select: (select even? #{1 2 3 4}) => #{2 4} + (define (set-select pred rel) + (let ([result pset-empty]) + (for-each (lambda (item) + (when (pred item) + (set! result (persistent-set-add result item)))) + (persistent-set->list rel)) + result)) + + ;; set-project — project a relation onto a subset of keys + ;; Like clojure.set/project: return set of maps with only given keys + (define (set-project rel ks) + (let ([result pset-empty]) + (for-each (lambda (m) + (let ([projected (select-keys m ks)]) + (set! result (persistent-set-add result projected)))) + (persistent-set->list rel)) + result)) + + ;; set-rename — rename keys in all maps of a relation + ;; kmap: alist or pmap of old-key → new-key + (define (set-rename rel kmap) + (let ([pairs (cond + [(persistent-map? kmap) (persistent-map->list kmap)] + [(list? kmap) kmap] + [else (error 'set-rename "kmap must be a map or alist" kmap)])] + [result pset-empty]) + (for-each (lambda (m) + (let ([new-m (fold-left + (lambda (acc pair) + (let ([old-k (car pair)] [new-k (cdr pair)]) + (if (contains? acc old-k) + (assoc (dissoc acc old-k) new-k (get acc old-k)) + acc))) + m pairs)]) + (set! result (persistent-set-add result new-m)))) + (persistent-set->list rel)) + result)) + + ;; set-index — index a relation by a set of keys + ;; Returns a Chez hashtable (using =?/hash for key equality) + ;; mapping key-map → set of matching rows. + ;; Note: uses a mutable hashtable because persistent maps can't be + ;; used as keys in other persistent maps (equal? doesn't work on them). + (define (set-index rel ks) + (let ([ht (make-hashtable hash =?)]) + (for-each + (lambda (m) + (let ([key-map (select-keys m ks)]) + (let ([existing (hashtable-ref ht key-map #f)]) + (hashtable-set! ht key-map + (if existing + (persistent-set-add existing m) + (persistent-set-add pset-empty m)))))) + (persistent-set->list rel)) + ht)) + + ;; set-join — natural join of two relations + ;; Joins on shared keys. Like clojure.set/join. + (define set-join + (case-lambda + [(rel1 rel2) + ;; Natural join: find shared keys from first elements + (if (or (zero? (persistent-set-size rel1)) + (zero? (persistent-set-size rel2))) + pset-empty + (let* ([m1 (car (persistent-set->list rel1))] + [m2 (car (persistent-set->list rel2))] + [k1 (keys m1)] + [k2 (keys m2)] + [shared (filter (lambda (k) (contains? m2 k)) k1)] + [idx (set-index rel2 shared)] + [result pset-empty]) + (for-each + (lambda (row1) + (let* ([key-map (select-keys row1 shared)] + [matches (hashtable-ref idx key-map #f)]) + (when matches + (for-each + (lambda (row2) + (set! result + (persistent-set-add result (merge row1 row2)))) + (persistent-set->list matches))))) + (persistent-set->list rel1)) + result))] + [(rel1 rel2 km) + ;; Join with key mapping: km maps keys in rel1 to keys in rel2 + (let* ([pairs (cond + [(persistent-map? km) (persistent-map->list km)] + [(list? km) km] + [else (error 'set-join "km must be a map or alist" km)])] + [renamed (set-rename rel2 + (map (lambda (p) (cons (cdr p) (car p))) pairs))]) + (set-join rel1 renamed))])) + + ;; map-invert — swap keys and values in a map + (define (map-invert m) + (let ([entries (cond + [(persistent-map? m) (persistent-map->list m)] + [(and (pair? m) (pair? (car m))) m] + [else (error 'map-invert "not a map" m)])]) + (fold-left (lambda (acc pair) + (assoc acc (cdr pair) (car pair))) + pmap-empty + entries))) + + ;; ========================================================================= ;; Map-convenience stragglers — Clojure's `merge-with`, `zipmap`, ;; `reduce-kv`, and `min-key`/`max-key`. ;; ========================================================================= new file mode 100644 --- /dev/null +++ b/tests/test-set-relational.ss @@ -0,0 +1,135 @@ +(import (jerboa prelude)) +(import (std clojure)) + +(def test-count 0) +(def pass-count 0) + +(defrule (test name body ...) + (begin + (set! test-count (+ test-count 1)) + (guard (exn [#t + (displayln (str "FAIL: " name)) + (displayln (str " Error: " (if (message-condition? exn) + (condition-message exn) exn)))]) + body ... + (set! pass-count (+ pass-count 1)) + (displayln (str "PASS: " name))))) + +(defrule (assert-equal got expected msg) + (unless (equal? got expected) + (error 'assert msg (list 'got: got 'expected: expected)))) + +(defrule (assert-true val msg) + (unless val (error 'assert msg))) + +;; Helper: create a relation (set of maps) +(def (make-rel . rows) + (fold-left (lambda (s row) + (conj s (apply hash-map row))) + (hash-set) + rows)) + +;; ========================================================================= +;; set-select tests +;; ========================================================================= + +(test "set-select filters elements" + (let ([nums (hash-set 1 2 3 4 5 6)]) + (let ([evens (set-select even? nums)]) + (assert-true (contains? evens 2) "has 2") + (assert-true (contains? evens 4) "has 4") + (assert-true (contains? evens 6) "has 6") + (assert-true (not (contains? evens 1)) "no 1") + (assert-true (not (contains? evens 3)) "no 3")))) + +(test "set-select on maps" + (let ([rel (make-rel '("name" "Alice" "age" 30) + '("name" "Bob" "age" 25) + '("name" "Carol" "age" 35))]) + (let ([over30 (set-select (lambda (m) (>= (get m "age") 30)) rel)]) + (assert-equal (count over30) 2 "two people >= 30")))) + +;; ========================================================================= +;; set-project tests +;; ========================================================================= + +(test "set-project extracts keys" + (let ([rel (make-rel '("name" "Alice" "age" 30 "city" "NYC") + '("name" "Bob" "age" 25 "city" "LA"))]) + (let ([names-only (set-project rel '("name"))]) + (assert-equal (count names-only) 2 "two rows") + (for-each (lambda (m) + (assert-true (contains? m "name") "has name") + (assert-true (not (contains? m "age")) "no age")) + (persistent-set->list names-only))))) + +;; ========================================================================= +;; set-rename tests +;; ========================================================================= + +(test "set-rename renames keys" + (let ([rel (make-rel '("name" "Alice" "age" 30))]) + (let ([renamed (set-rename rel '(("name" . "full_name")))]) + (let ([row (car (persistent-set->list renamed))]) + (assert-true (contains? row "full_name") "has full_name") + (assert-equal (get row "full_name") "Alice" "value preserved") + (assert-true (not (contains? row "name")) "no old name"))))) + +;; ========================================================================= +;; set-index tests +;; ========================================================================= + +(test "set-index groups by keys" + (let ([rel (make-rel '("dept" "eng" "name" "Alice") + '("dept" "eng" "name" "Bob") + '("dept" "sales" "name" "Carol"))]) + (let ([idx (set-index rel '("dept"))]) + ;; set-index returns a Chez hashtable with =?/hash equality + (let ([eng-key (hash-map "dept" "eng")]) + (let ([eng-set (hashtable-ref idx eng-key #f)]) + (assert-true eng-set "has eng group") + (assert-equal (count eng-set) 2 "two engineers")))))) + +;; ========================================================================= +;; set-join tests +;; ========================================================================= + +(test "set-join natural join" + (let ([employees (make-rel '("name" "Alice" "dept" "eng") + '("name" "Bob" "dept" "sales"))] + [depts (make-rel '("dept" "eng" "building" "A") + '("dept" "sales" "building" "B"))]) + (let ([joined (set-join employees depts)]) + (assert-equal (count joined) 2 "two joined rows") + ;; Each row should have name, dept, AND building + (for-each (lambda (m) + (assert-true (contains? m "name") "has name") + (assert-true (contains? m "dept") "has dept") + (assert-true (contains? m "building") "has building")) + (persistent-set->list joined))))) + +(test "set-join empty result" + (let ([r1 (make-rel '("a" 1 "b" 2))] + [r2 (make-rel '("a" 99 "c" 3))]) + (let ([joined (set-join r1 r2)]) + (assert-equal (count joined) 0 "no matches")))) + +;; ========================================================================= +;; map-invert tests +;; ========================================================================= + +(test "map-invert swaps keys and values" + (let ([m (hash-map "a" 1 "b" 2)]) + (let ([inv (map-invert m)]) + (assert-equal (get inv 1) "a" "1 -> a") + (assert-equal (get inv 2) "b" "2 -> b")))) + +;; ========================================================================= +;; Summary +;; ========================================================================= +(newline) +(displayln (str "=========================================")) +(displayln (str "Results: " pass-count "/" test-count " passed")) +(displayln (str "=========================================")) +(when (< pass-count test-count) + (exit 1))