Patternmatching sets

Question

How to match set-patterns against sets?

A set (in the mathematical sense) is a list of elements without repetition and order of elements does not matter. For example, we have a pattern set {3, 1} that should match sets {1, 3}, {1, 2, 3}, {1, 2, 3, 4} and so on. Note, that the list-length of the pattern is not relevant: any set that contains elements 3 and 1 should match the pattern. So far, this is simple subset testing - but there are two problems:

1. Since order does matter for the patternmatcher, one has to write e.g. Cases[sets, {___, 3, ___, 1, ____}|{___, 1, ___, 3, ____}] which causes a combinatorial expansion for an increasing number of element-wise matches. Thus I used MemberQ instead of structural patterns.

2. I would like to use more complicated patterns, like: "Find all sets that contain 1 and 3 but not 2!".

I have a working solution, but it is neither effective nor elegant in my opinion. It involves a Boolean description of the pattern (And to include all listed elements, Or to include any listed element, Not to exclude an element), but I am not sure it is the right way to do it. The function simply wraps each element that apperas in the pattern into MemberQ, so the Boolean expression translates to a logical combination of MemberQ and Not@MemberQ calls.

setCases[sets_List, patt_] := Module[{elem = Union @@ sets},
   Cases[sets, _?((patt /. x_ /; MemberQ[elem, x] :> MemberQ[#, x]) &), {1}]
   ];

Define a list of sets, and a list of patterns for testing:

sets = Subsets[{1, 2, 3, 4}];

patterns = {1, \[Not] 1, 1 \[And] \[Not] 2, 1 \[Or] \[Not] 2, 
   1 \[Or] 2 \[Or] 3, 1 \[And] 2 \[And] 3, 
   1 \[And] \[Not] 2 \[And] \[Not] 3, 1 \[Or] (2 \[And] \[Not] 3), 
   1 \[And] \[Not] (2 \[And] 3), 1 \[And] \[Not] (2 \[Or] 3), 
   1 \[And] \[Not] (2 \[Or] (3 \[And] \[Not] 4)),
   \[Not] 1 \[And] \[Not] 2 \[And] \[Not] 3 \[And] \[Not] 4}

Grid[{#, setCases[sets, #]} & /@ patterns, Alignment -> Left, 
 Background -> {None, {{LightGray, White}}}, Spacings -> {1, 1}] // TraditionalForm

Let's examine one case closer, by displaying the ultimate pattern that is tested:

(1 \[Or] 2) \[And] \[Not] 3 /. x_Integer :> MemberQ[#, x]

(MemberQ[#1, 1] & || (MemberQ[#1, 2] &)) && ! (MemberQ[#1, 3] &)

As one can see, the function is far from being economic: alternatives could have been gathered under one MemberQ (MemberQ[#, 1]& || MemberQ[#, 2]& is equivalent to MemberQ[#, 1|2]&) and I think that Except should be used as well, though have no idea how. I am interested in robust, fast solutions.

Note: Do NOT try to simplify the logical patterns, as:

Simplify[And[1, 2]] ==> 2
Simplify[And[0, 1]] ==> False

Answer 1

A main idea of a pattern-based solution

I don't know why we should make life so complicated, since you can always use things like Intersection and Complement to test whether a given set is a subset of another set. But if you want to use the pattern-matcher, here is one option:

ClearAll[set];
SetAttributes[set, {Orderless, Flat, OneIdentity}];

ClearAll[setCasesLS]
setCasesLS[sets : {__List}, patt_] :=
   List @@@ Cases[set @@@ sets, patt];

Now, for example:

setCasesLS[sets, set[1,__]]

(*  {{1}, {1, 2}, {1, 3}, {1, 4}, {1, 2, 3}, {1, 2, 4}, {1, 3, 4}, {1, 2, 3, 4}}  *)

setCasesLS[sets,set[1,Except[2|set[3 ,Except[4]]]...]]

(* {{1},{1,3},{1,4},{1,3,4}}  *)

It may be an interesting sub-problem to to translate your specs into the patterns used here (involving Except etc), but at least conceptually this could be a valid starting point.

Pattern translator (a sketch, may contain errors)

Ok, it seems that I was able to write a pattern translator which translates your patterns into those which can be used with setCasesLS. But the code is long and ugly, and I would not be suprised if it won't work in more complicated cases. Anyway, here goes:

This is a set of preprocessing functions:

ClearAll[or, and, not];
SetAttributes[{or, and}, {Flat, OneIdentity}];
or[left : Except[_not] ..., x_not, y : Except[_not], rest___] :=
   or[left, y, x, rest];
and[left : Except[_not] ..., x_not, y : Except[_not], rest___] :=
   and[left, y, x, rest];
and[not[x_], not[y_]] /; FreeQ[{x, y}, _not] := not[or[x, y]];
not[not[x_]] := x;
not[and[x_, y_]] := or[not[x], not[y]];
and[left___, or[not[x_], y___], right___] :=
   or[and[left, not[x], right], and[left, y, right]];

Clear[process];
process[expr_] :=  expr /. {And -> and, Not -> not, Or -> or}

Here is a pattern converter:

ClearAll[convert];
convert[HoldPattern[pattern[or[simple : Except[_not | _and] .., rest___]]]] :=
   Alternatives[
     set[Alternatives @@ simple, ___],
     Sequence @@ convert[pattern[or[rest]]]
   ];
convert[HoldPattern[pattern[or[args___]]]] :=
    Alternatives @@ 
        Map[
          If[MatchQ[#, _not], set[convert[#]], convert[pattern[#]]] &, 
          {args}
        ];
convert[HoldPattern[pattern[and[args : Except[_not] ..]]]] :=
   set @@ Append[Map[convert, {args}], ___];
convert[HoldPattern[pattern[and[args___]]]] :=
   set @@ Map[convert, {args}];
convert[HoldPattern[pattern[not[x_]]]] := Except[convert[pattern@x]];
convert[HoldPattern[not[x_]]] := Except[convert[x]] ...;
convert[HoldPattern[or[args___]]] := Alternatives[args];
convert[pattern[x_]] := set[x, ___];
convert[x_] := x;

and this is a main function to bring it all together:

ClearAll[fullConvert];
fullConvert[patt_] :=
  With[{res = convert@pattern@process@patt},
     res /; FreeQ[res, not | and | or]
  ];
fullConvert[patt_] :=
  With[{res = convert@pattern@not@process@Not@patt},
     res /; FreeQ[res, not | and | or]
  ];
fullConvert[patt_] := $Failed;

If it does not succeed in converting a direct pattern, it attempts to convert a negated one. If that also fails, it returns $Failed.

Here is how this works on your patterns:

fullConvert/@patterns

{
    set[1,___],
    Except[set[1,___]],
    set[1,Except[2]...],
    set[1,___]|set[Except[2]...],
    set[1,___]|set[2,___]|set[3,___],
    set[1,2,3,___],
    set[1,Except[2|3]...],
    set[1,___]|set[2,Except[3]...],
    set[1,Except[3]...]|set[1,Except[2]...],
    set[1,Except[2|3]...],
    Except[set[2,___]|set[3,Except[4]...]|set[Except[1]...]],
    Except[set[1,___]|set[4,___]|set[2,___]|set[3,___]]
 }

If you now execute

 setCasesLS[sets, fullConvert[#]]} & /@ patterns

you get the results identical to yours.

I actually think that I am missing some simplificatins which would make the above code shorter, more general and more robust at the same time, but the current solution still seems interesting enough to post it.

Answer 2

This is just to give set the proper attributes and make it simplify double ___ and __

ClearAll[set];
set[a___, Verbatim[___], Verbatim[___] .., b___] := set[a, ___, b];
set[a___, Verbatim[__], Verbatim[__] .., Verbatim[___] ..., b___] := 
  set[a, __, b];
SetAttributes[set, {Orderless, Flat, OneIdentity}];

The patterns will be a boolean function of subset[el1, el2, el3...], with the possibility of mixing patterns, so Except[subset[1,2]] would represent any subset that is not subset[1,2], and subset[1, 3, _] would represent any subset with 1, 3, and any other element.

forms = {"DNF", "CNF",  "AND", "OR"};

convertPattern[patt_, 
  type : (Alternatives @@ forms | Automatic) : Automatic] := 
 With[{pat = BooleanMinimize[patt, type]}, 
  Internal`InheritedBlock[{And, Or}, SetAttributes[{And, Or}, Orderless]; 
   ClearAttributes[{And, Or}, Flat]; And[patt] //. convertionRules]]

convertionRules = {
   And[a___, b : (\[Not] _) .. // Longest] :> 
    Except[Alternatives[b]~Thread~Not // First, And[a]],
   And[a_subset, b__subset, rest___ // Shortest] :> 
    And[set @@ 
      Append[List @@@ Unevaluated@leastCommonElements[a, b], ___], 
     rest],
   (subset | And)[a___] :> set[a, ___], Or -> Alternatives,
   Not -> Except,
   Verbatim[Alternatives][a_] :> a};

(*Thanks @rm-rf*)
leastCommonElements[lists___List] := 
 Join @@ Composition[Last, Sort] /@ 
   GatherBy[Join @@ Gather /@ {lists}, First]

So given

patterns = {1, \[Not] 1, 1 \[And] \[Not] 2, 1 \[Or] \[Not] 2, 
  1 \[Or] 2 \[Or] 3, 1 \[And] 2 \[And] 3, 
  1 \[And] \[Not] 2 \[And] \[Not] 3, 1 \[Or] (2 \[And] \[Not] 3), 
  1 \[And] \[Not] (2 \[And] 3), 1 \[And] \[Not] (2 \[Or] 3), 
  1 \[And] \[Not] (2 \[Or] (3 \[And] \[Not] 4)), \[Not] 
    1 \[And] \[Not] 2 \[And] \[Not] 3 \[And] \[Not] 4}

sets = Subsets[Range[6]];

To translate your patterns to our form we just need to wrap the integers in subset, if I understood correctly

newPatterns = patterns /. i_Integer :> subset[i]

Now, we can see the patterns converted

Table[{patterns, convertPattern[#, form] & /@ (newPatterns)}\[Transpose] // 
  TableForm , {form, forms}]

Finally, we can test it

Cases[set @@@ sets, convertPattern[#]]&/@newPatterns/.set->List//Column

Answer 3

OrderlessPatternSequence

Using the first four patterns ({1, ¬ 1, 1 ∧ ¬ 2, 1 ∨ ¬ 2} ) from Istvan's table:

Pick[sets, MatchQ[{OrderlessPatternSequence[___, 1, ___]}] /@ sets]

{{1}, {1, 2}, {1, 3}, {1, 4}, {1, 2, 3}, {1, 2, 4}, {1, 3, 4}, {1, 2, 3, 4}}

Pick[sets, MatchQ[Except@{OrderlessPatternSequence[___, 1, ___]}] /@ sets]

{{}, {2}, {3}, {4}, {2, 3}, {2, 4}, {3, 4}, {2, 3, 4}}

Pick[sets, MatchQ[Except[{OrderlessPatternSequence[___, 2, ___]},
    {OrderlessPatternSequence[___, 1, ___]}]] /@ sets]

{{1}, {1, 3}, {1, 4}, {1, 3, 4}}

Pick[sets, MatchQ[Except[{OrderlessPatternSequence[___,  2, ___]}] | 
  {OrderlessPatternSequence[___, 1, ___]}] /@ sets]

{{}, {1}, {3}, {4}, {1, 2}, {1, 3}, {1, 4}, {3, 4}, {1, 2, 3}, {1, 2, 4}, {1, 3, 4}, {1, 2, 3, 4}}

Answer 4

This solution is in the same spirit as your approach:

Clear@findSets
findSets[list_, all_, any_, none_] := Block[{set},
    SetAttributes[set, {Flat, Orderless}];
    Select[set @@@ list, 
        Function[s,
            !FreeQ[s, set @@ all] &&
            Or @@ (! FreeQ[s, set@#] & /@ any /. {} -> True) &&        
            And @@ (FreeQ[s, set@#] & /@ none)
        ]
   ] /. set -> List
]

Use an empty set if you're not specifying anything. You can also use default values of {} or convert the arguments to options such as Any -> {1,2}, All -> {3}, None -> {4} if that's easier to read. Here's an example usage:

l = Subsets[{1, 2, 3, 4}];
findSets[l, {2}, {3}, {}]
(* {{2, 3}, {1, 2, 3}, {2, 3, 4}, {1, 2, 3, 4}} *)

findSets[l, {1, 2}, {}, {4}]
(* {{1, 2}, {1, 2, 3}} *)

findSets[l, {1}, {2, 4}, {3}]
(* {{1, 2}, {1, 4}, {1, 2, 4}} *)