diff --git a/examples/test_alpha_unique_atom.metta b/examples/test_alpha_unique_atom.metta new file mode 100644 index 00000000..04efdcbd --- /dev/null +++ b/examples/test_alpha_unique_atom.metta @@ -0,0 +1,59 @@ +; tests for alpha-unique-atom + +; 1 Basic duplicates with different variables +!(test (=alpha (alpha-unique-atom ((link $x human) (link $y human) (link $z human))) + ((link $a human))) + True) + +!(test (=alpha (alpha-unique-atom ((parent $x human) (parent $y human) (child $z human))) + ((parent $a human) (child $b human))) + True) + +; 2 Different functors +!(test (=alpha (alpha-unique-atom ((parent $x human) (child $y human) (friend $z human))) + ((parent $a human) (child $b human) (friend $c human))) + True) + +!(test (=alpha (alpha-unique-atom ((likes $x) (hates $y) (knows $z))) + ((likes $a) (hates $b) (knows $c))) + True) + +; 3 Nested structures +!(test (=alpha (alpha-unique-atom ((link (foo $x) human) (link (foo $y) human) (link (bar $z) human))) + ((link (foo $a) human) (link (bar $b) human))) + True) + +!(test (=alpha (alpha-unique-atom ((parent (child $x) human) (parent (child $y) human) (parent (child $x) human))) + ((parent (child $a) human))) + True) + +; 4 Mix of unique and duplicates +!(test (=alpha (alpha-unique-atom ((link $x human) (parent $x human) (link $y human) (parent $z human) (link $x human))) + ((link $a human) (parent $a human))) + True) + +!(test (=alpha (alpha-unique-atom ((foo $x) (foo $y) (bar $x) (foo $x) (bar $y))) + ((foo $a) (bar $a))) + True) + +; 5 Numbers and atoms +!(test (=alpha (alpha-unique-atom (1 2 2 3 1 4 4 5)) + (1 2 3 4 5)) + True) + +!(test (=alpha (alpha-unique-atom (a b a c b d e a)) + (a b c d e)) + True) + +; 6 Empty and single-element lists +!(test (=alpha (alpha-unique-atom ()) + ()) + True) + +!(test (=alpha (alpha-unique-atom (1)) + (1)) + True) + +!(test (=alpha (alpha-unique-atom ((link $x human))) + ((link $a human))) + True) diff --git a/src/metta.pl b/src/metta.pl index 8f7a7060..bc8c7218 100644 --- a/src/metta.pl +++ b/src/metta.pl @@ -112,6 +112,29 @@ first([A, _], A). 'second-from-pair'([_, A], A). 'unique-atom'(A, B) :- list_to_set(A, B). + +%%% Alpha-equivalence unique atom %%% +'alpha-unique-atom'(A, B) :- + must_be(list, A), + alpha_list_to_set(A, B). + +alpha_list_to_set(List, Set) :- + empty_assoc(Seen0), + alpha_list_to_set_assoc(List, Seen0, Set). + +alpha_list_to_set_assoc([], _, []). +alpha_list_to_set_assoc([H|T], SeenIn, R) :- + copy_term(H, HCopy), + numbervars(HCopy, 0, _), + term_hash(HCopy, Key), + ( get_assoc(Key, SeenIn, _) -> + alpha_list_to_set_assoc(T, SeenIn, R) + ; + put_assoc(Key, SeenIn, true, SeenOut), + R = [H|RT], + alpha_list_to_set_assoc(T, SeenOut, RT) + ). + 'sort-atom'(List, Sorted) :- msort(List, Sorted). 'size-atom'(List, Size) :- length(List, Size). 'car-atom'([H|_], H). @@ -271,7 +294,7 @@ register_fun(N) :- (fun(N) -> true ; assertz(fun(N))). :- maplist(register_fun, [superpose, empty, let, 'let*', '+','-','*','/', '%', min, max, 'change-state!', 'get-state', 'bind!', '<','>','==', '!=', '=', '=?', '<=', '>=', and, or, xor, implies, not, sqrt, exp, log, cos, sin, - 'first-from-pair', 'second-from-pair', 'car-atom', 'cdr-atom', 'unique-atom', + 'first-from-pair', 'second-from-pair', 'car-atom', 'cdr-atom', 'unique-atom', 'alpha-unique-atom', repr, repra, parse, 'println!', 'readln!', test, assert, 'mm2-exec', atom_concat, atom_chars, copy_term, term_hash, foldl, first, last, append, length, 'size-atom', sort, msort, member, 'is-member', 'exclude-item', list_to_set, maplist, eval, reduce, 'import!', 'add-atom', 'remove-atom', 'get-atoms', match, 'is-var', 'is-expr', 'is-space', 'get-mettatype',