12
$\begingroup$

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

Mathematica graphics

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
$\endgroup$
2
  • $\begingroup$ @Leonid Actually, I've found a case where Mathematica uses a similar approach. Check the Details under TextSearch. It uses List for And, Alternatives for Or and Except for Not. According to PrintDefinitions spelunking, there is a full-blown query-set-algebra, check e.g. TextSearch^IndexSearch^PackagePrivate^compileQuery and ...^exec: QNot, QUnion, QIntersection, QComplement, QString are the specific functions. (backticks are replaced by ^) $\endgroup$ Mar 9, 2016 at 21:23
  • $\begingroup$ Thanks for letting me know, @Istvan. I will definitely look it up. These things interest me a lot. $\endgroup$ Mar 9, 2016 at 21:42

4 Answers 4

8
$\begingroup$

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.

$\endgroup$
17
  • $\begingroup$ You know how it is... After 3 days of intensive brainstorming you close in on the core of your problem. And that is the point where you won't see the wood from the tree. $\endgroup$ Feb 16, 2013 at 18:13
  • $\begingroup$ To answer your Q about the complicatedness of life in general: in my case I refrained to use Union, Intersection and Complement because I inject the sets later into placeholders which are not sets themselves, thus functions like Union must be hold. Instead of holding, I went the other way. $\endgroup$ Feb 16, 2013 at 18:19
  • $\begingroup$ @IstvánZachar Actually, I changed my mind after reading the question more carefully, for more complex patterns of the type you ask for we may benefit from something else than Complement and Intersection - such as pattern-matcher. Working on an automatic translator from your patterns to the ones I use here... $\endgroup$ Feb 16, 2013 at 18:24
  • 2
    $\begingroup$ Ha! The late addition Simplify was the problem: apparently, Simplify[And[1,2]] simplifies to 2. I didn't know that 0/1 booleans are handled this way! $\endgroup$ Feb 16, 2013 at 18:42
  • 1
    $\begingroup$ @IstvánZachar I analyzed the current setup and came to a conclusion that your pattern language is ambiguous because it is underspecified. What you need is to introduce two new quantors: exists and for all. Then, your logical operators such as Not or Identity will be applied to these. Then, there will be no ambiguities left. $\endgroup$ Feb 16, 2013 at 19:13
5
$\begingroup$

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
$\endgroup$
3
  • $\begingroup$ Looks like I won't have time to look at this today, but I will surely do as soon as I have time, and +1 in advance :) $\endgroup$ Feb 17, 2013 at 16:32
  • $\begingroup$ I just realized you hit 20k without me saying anything: congratulations! $\endgroup$
    – Mr.Wizard
    Feb 17, 2013 at 19:28
  • $\begingroup$ @Mr.Wizard thanks :), now go get the 50k $\endgroup$
    – Rojo
    Feb 17, 2013 at 19:34
1
$\begingroup$

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}} *)
$\endgroup$
0
1
$\begingroup$

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

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.