Set consolidation: Difference between revisions

<lang txr>@(do

(defun mkset (p x) (set [p x] (or [p x] x)))

(defun fnd (p x) (if (eq [p x] x) x (fnd p [p x])))

(defun uni (p x y)

(let ((xr (fnd p x)) (yr (fnd p y)))

(set [p xr] yr)))

(defun consoli (sets)

(let ((p (hash)))

(each ((s sets))

(each ((e s))

(mkset p e)

(uni p e (car s))))

(hash-values

[group-by (op fnd p) (hash-keys

[group-by identity (flatten sets)])])))

;; tests

(each ((test '(((a b) (c d))

((a b) (b d))

((a b) (c d) (d b))

((h i k) (a b) (c d) (d b) (f g h)))))

(format t "~s -> ~s\n" test (consoli test))))</lang>

<pre>((a b) (c d)) -> ((d c) (b a))

((a b) (b d)) -> ((d b a))

((a b) (c d) (d b)) -> ((d c b a))

((h i k) (a b) (c d) (d b) (f g h)) -> ((d c b a) (g f k i h))</pre>

<lang txr>@(do

(defun mkset (items) [group-by identity items])

(defun empty-p (set) (zerop (hash-count set)))

(defun consoli (ss)

(defun comb (cs s)

(cond ((empty-p s) cs)

((null cs) (list s))

((empty-p (hash-isec s (first cs)))

(cons (first cs) (comb (rest cs) s)))

(t (consoli (cons (hash-uni s (first cs)) (rest cs))))))

[reduce-left comb ss nil])

;; tests

(each ((test '(((a b) (c d))

((a b) (b d))

((a b) (c d) (d b))

((h i k) (a b) (c d) (d b) (f g h)))))

(format t "~s -> ~s\n" test

[mapcar hash-keys (consoli [mapcar mkset test])])))</lang>

((a b) (b d)) -> ((b a d))

((a b) (c d) (d b)) -> ((b a d c))

((h i k) (a b) (c d) (d b) (f g h)) -> ((g f k i h) (b a d c))</pre>