Multiset system: auto rule input counting (#656)

## Changes

* `MultisetSubstitutionSystem` will automatically figure out the number of inputs in some classes of rules and adjust `"MinEventInputs"` and `"MaxEventInputs"` accordingly.
* This was one of the bottlenecks in `MultisetSubstitutionSystem` performance.

## Comments

* It cannot recognize all cases (in particular there is a condition in which `Length` is used). However, it does go inside conditions in simple cases, so something like `{a_, b_} /; a < b` is recognized.
* This will be disabled in the new WL versions in case new pattern symbols appear.
* @taliesinb, can you think of a better way to do this?

## Examples

* This now works without a `"MaxEventInputs"` spec:
```wl
In[] := #["ExpressionsEventsGraph", VertexLabels -> Placed[Automatic, After]] &@
 SetReplaceTypeConvert[{WolframModelEvolutionObject, 2}]@
  GenerateMultihistory[MultisetSubstitutionSystem[{a_, b_} /; a < b :> {a + b}], {"MaxDestroyerEvents" -> 1}, None, 
    EventOrderingFunctions[MultisetSubstitutionSystem], {}]@range[10]
```
<img width="399" alt="image" src="https://user-images.githubusercontent.com/1479325/122101996-91589b80-cdda-11eb-8ea4-5fa5f6d525e0.png">

Author: maxitg

Documentation/Generators/EventOrderingFunctions.md

@@ -7,7 +7,7 @@ match any pair of numbers, many of which overlap:
 In[] := #["ExpressionsEventsGraph", VertexLabels -> Placed[Automatic, After]] & @
   SetReplaceTypeConvert[{WolframModelEvolutionObject, 2}] @
     GenerateMultihistory[MultisetSubstitutionSystem[{a_, b_} /; a < b :> {a + b}],
-                         {"MaxGeneration" -> 1, "MaxEventInputs" -> 2},
+                         "MaxGeneration" -> 1,
                          None,
                          EventOrderingFunctions[MultisetSubstitutionSystem],
                          {}] @
@@ -32,7 +32,7 @@ function at the moment):
 In[] := #["ExpressionsEventsGraph", VertexLabels -> Placed[Automatic, After]] & /@
   SetReplaceTypeConvert[{WolframModelEvolutionObject, 2}] /@
     GenerateMultihistory[MultisetSubstitutionSystem[{a_, b_} /; a < b :> {a + b}],
-                         {"MaxDestroyerEvents" -> 1},
+                         "MaxDestroyerEvents" -> 1,
                          None,
                          EventOrderingFunctions[MultisetSubstitutionSystem],
                          {}] /@
@@ -50,7 +50,7 @@ However, this is not the case for all systems. For example, see what happens if
 In[] := #["ExpressionsEventsGraph", VertexLabels -> Placed[Automatic, After]] & /@
   SetReplaceTypeConvert[{WolframModelEvolutionObject, 2}] /@
     GenerateMultihistory[MultisetSubstitutionSystem[{a_, b_} /; a < b :> {a - b}],
-                         {"MaxDestroyerEvents" -> 1},
+                         "MaxDestroyerEvents" -> 1,
                          None,
                          EventOrderingFunctions[MultisetSubstitutionSystem],
                          {}] /@

Documentation/Generators/EventSelectionParameters.md

@@ -44,7 +44,7 @@ another event is created instead:
 ```wl
 In[] := #["ExpressionsEventsGraph"] & @ SetReplaceTypeConvert[{WolframModelEvolutionObject, 2}] @
   GenerateMultihistory[MultisetSubstitutionSystem[{a__} /; Total[{a}] == 5 :> {Total[{a}] - 1, Total[{a}] + 1}],
-                       {"MaxGeneration" -> 1},
+                       "MaxGeneration" -> 1,
                        None,
                        EventOrderingFunctions[MultisetSubstitutionSystem],
                        "MaxEvents" -> 3] @ {1, 2, 3}
@@ -61,7 +61,7 @@ parameters) does not have a corresponding termination reason.
 ```wl
 In[] := #[[2, "TerminationReason"]] & @
   GenerateMultihistory[MultisetSubstitutionSystem[{a__} /; Total[{a}] == 5 :> {Total[{a}] - 1, Total[{a}] + 1}],
-                       {"MaxGeneration" -> 1},
+                       "MaxGeneration" -> 1,
                        None,
                        EventOrderingFunctions[MultisetSubstitutionSystem],
                        "MaxEvents" -> 3] @ {1, 2, 3}
@@ -92,7 +92,7 @@ multihistory (similar to `GenerateFullMultihistory`) subject to other selection
 In[] := #["ExpressionsEventsGraph", VertexLabels -> Placed[Automatic, After]] & @
   SetReplaceTypeConvert[{WolframModelEvolutionObject, 2}] @
     GenerateMultihistory[MultisetSubstitutionSystem[{a_, b_} :> {a + b}],
-                         {"MaxDestroyerEvents" -> Infinity, "MaxGeneration" -> 1, "MaxEventInputs" -> 2},
+                         {"MaxDestroyerEvents" -> Infinity, "MaxGeneration" -> 1},
                          None,
                          EventOrderingFunctions[MultisetSubstitutionSystem],
                          {}] @ {1, 2, 3}
@@ -106,7 +106,7 @@ If set to a finite number, it will generate a partial multihistory:
 In[] := #["ExpressionsEventsGraph", VertexLabels -> Placed[Automatic, After]] & @
   SetReplaceTypeConvert[{WolframModelEvolutionObject, 2}] @
     GenerateMultihistory[MultisetSubstitutionSystem[{a_, b_} :> {a + b}],
-                         {"MaxDestroyerEvents" -> 5, "MaxEventInputs" -> 2},
+                         "MaxDestroyerEvents" -> 5,
                          None,
                          EventOrderingFunctions[MultisetSubstitutionSystem],
                          {}] @ {1, 2, 3}

Documentation/Generators/README.md

@@ -22,7 +22,7 @@ a single history (no nondeterministic branching):
 In[] := #["ExpressionsEventsGraph", VertexLabels -> Placed[Automatic, After]] & @
   SetReplaceTypeConvert[{WolframModelEvolutionObject, 2}] @
     GenerateMultihistory[MultisetSubstitutionSystem[{a_, b_} /; a < b :> {a + b}],
-                         {"MaxDestroyerEvents" -> 1, "MaxEventInputs" -> 2},
+                         "MaxDestroyerEvents" -> 1,
                          None,
                          EventOrderingFunctions[MultisetSubstitutionSystem],
                          {}] @ {1, 2, 3, 4}
@@ -36,7 +36,7 @@ or multiple histories. Note different events (orange) using the same tokens (lig
 In[] := #["ExpressionsEventsGraph", VertexLabels -> Placed[Automatic, After]] & @
   SetReplaceTypeConvert[{WolframModelEvolutionObject, 2}] @
     GenerateMultihistory[MultisetSubstitutionSystem[{a_, b_} /; a < b :> {a + b}],
-                         {"MaxDestroyerEvents" -> 2, "MaxEventInputs" -> 2},
+                         "MaxDestroyerEvents" -> 2,
                          None,
                          EventOrderingFunctions[MultisetSubstitutionSystem],
                          {}] @ {1, 2, 3, 4}

Documentation/Generators/StoppingConditionParameters.md

@@ -24,7 +24,7 @@ This is the most basic stopping condition. It stops the evaluation once the give
 In[] := #["ExpressionsEventsGraph"] & @
   SetReplaceTypeConvert[{WolframModelEvolutionObject, 2}] @
     GenerateMultihistory[MultisetSubstitutionSystem[{a_, b_} /; a < b :> {a + b}],
-                         {"MaxEventInputs" -> 2},
+                         {},
                          None,
                          EventOrderingFunctions[MultisetSubstitutionSystem],
                          {"MaxEvents" -> 9}] @ {1, 2, 3, 4}

Documentation/Systems/MultisetSubstitutionSystem.md

@@ -21,7 +21,7 @@ For example, to make a system that adds pairs of numbers:
 In[] := #["ExpressionsEventsGraph", VertexLabels -> Placed[Automatic, After]] & @
   SetReplaceTypeConvert[{WolframModelEvolutionObject, 2}] @
     GenerateMultihistory[MultisetSubstitutionSystem[{a_, b_} /; a < b :> {a + b}],
-                         {"MaxDestroyerEvents" -> 1, "MaxEventInputs" -> 2},
+                         "MaxDestroyerEvents" -> 1,
                          None,
                          EventOrderingFunctions[MultisetSubstitutionSystem],
                          {}] @ {1, 2, 3, 4}

Kernel/MultisetSubstitutionSystem.m

@@ -33,7 +33,10 @@
     expressionDestroyerEventCounts, destroyerChoices, instantiationCounts, instantiations},
   Module[{rules, maxGeneration, maxDestroyerEvents, minEventInputs, maxEventInputs, maxEvents, init, terminationReason},
     rules = parseRules[rawRules];
+    ruleInputCountRanges = inputCountRange /@ rules;
     {maxGeneration, maxDestroyerEvents, minEventInputs, maxEventInputs} = Values @ rawEventSelection;
+    minEventInputs = Max[minEventInputs, Min[ruleInputCountRanges[[All, 1]]]];
+    maxEventInputs = Min[maxEventInputs, Max[ruleInputCountRanges[[All, 2]]]];
     parseTokenDeduplication[rawTokenDeduplication]; (* Token deduplication is not implemented at the moment *)
     parseEventOrdering[rawEventOrdering];           (* Event ordering is not implemented at the moment *)
     {maxEvents} = Values @ rawStoppingCondition;
@@ -95,6 +98,7 @@
 (* Matching *)
 
 findMatch[rules_, maxGeneration_, maxDestroyerEvents_, minEventInputs_, maxEventInputs_] := ModuleScope[
+  If[minEventInputs === Infinity || minEventInputs > maxEventInputs, Throw["Complete", $$terminationReason]];
   eventInputsCountRange = {minEventInputs, Min[maxEventInputs, expressions["Length"]]};
   subsetCount = With[{n = expressions["Length"], a = eventInputsCountRange[[1]], b = eventInputsCountRange[[2]]},
     (* Sum[Binomial[n, k], {k, a, b}] *)
@@ -236,6 +240,85 @@ according to some (but not all) ordering functions. This new data structure will
 parseRules[rawRules_] := throw[Failure["invalidMultisetRules", <|"rules" -> rawRules|>]];
 parseRules[rawRules___] /; !CheckArguments[MultisetSubstitutionSystem[rawRules], 1] := throw[Failure[None, <||>]];
 
+inputCountRange[(input_ :> _) | (input_ -> _)] := inputCountRange[input];
+inputCountRange[Verbatim[HoldPattern][input_List]] :=
+  Total[Append[ReleaseHold @ Map[sequencePatternLengthRange, Hold[input], {2}], {0, 0}]];
+inputCountRange[input_List] := inputCountRange[HoldPattern[input]];
+inputCountRange[Verbatim[Alternatives][patterns__]] := MinMax[inputCountRange /@ {patterns}];
+inputCountRange[(Verbatim[Condition] | Verbatim[PatternTest])[input_, _]] := inputCountRange[input];
+inputCountRange[Verbatim[Pattern][_, obj_]] := inputCountRange[obj];
+inputCountRange[Verbatim[Except][_, p_]] := inputCountRange[p];
+inputCountRange[Verbatim[Verbatim][p_List]] := ConstantArray[Length[p], 2];
+inputCountRange[_] := {0, Infinity};
+
+(* We need to hold the pattern from now on because sequencePatternLengthRange may be called from inside HoldPattern. *)
+
+Attributes[sequencePatternLengthRange] := {HoldFirst};
+
+(* Here we enumerate all possible WL pattern constructs from https://reference.wolfram.com/language/guide/Patterns.html.
+   If a pattern construct has incorrect syntax, we return {Infinity, 0}, which means nothing can be matched. *)
+
+sequencePatternLengthRange[Verbatim[Pattern][_, obj_]] := sequencePatternLengthRange[obj];
+sequencePatternLengthRange[Verbatim[Pattern][___]] := {Infinity, 0};
+
+sequencePatternLengthRange[_Blank] := {1, 1};
+sequencePatternLengthRange[_BlankSequence] := {1, Infinity};
+sequencePatternLengthRange[_BlankNullSequence] := {0, Infinity};
+sequencePatternLengthRange[Verbatim[Alternatives][p__]] :=
+  MinMax[ReleaseHold @ Map[sequencePatternLengthRange, Hold[{p}], {2}]];
+sequencePatternLengthRange[Verbatim[Alternatives][]] := {Infinity, 0}; (* this does not match to anything *)
+
+zeroPreferenceProduct[0, _] := 0;
+zeroPreferenceProduct[_, 0] := 0;
+zeroPreferenceProduct[a_, b_] := a * b;
+zeroPreferenceProduct[{a_, b_}, {c_, d_}] := {zeroPreferenceProduct[a, c], zeroPreferenceProduct[b, d]};
+
+sequencePatternLengthRange[Verbatim[Repeated][p_]] := {Min @ sequencePatternLengthRange[p], Infinity};
+sequencePatternLengthRange[Verbatim[RepeatedNull][_]] := {0, Infinity};
+sequencePatternLengthRange[Verbatim[Repeated][p_, max_]] :=
+  zeroPreferenceProduct[{1, max}, sequencePatternLengthRange[p]];
+sequencePatternLengthRange[Verbatim[RepeatedNull][p_, max_]] :=
+  {0, zeroPreferenceProduct[max, Max @ sequencePatternLengthRange[p]]};
+sequencePatternLengthRange[(Verbatim[Repeated] | Verbatim[RepeatedNull])[p_, {min_, max_}]] :=
+  zeroPreferenceProduct[{min, max}, sequencePatternLengthRange[p]];
+sequencePatternLengthRange[(Verbatim[Repeated] | Verbatim[RepeatedNull])[p_, {n_}]] :=
+  zeroPreferenceProduct[{n, n}, sequencePatternLengthRange[p]];
+sequencePatternLengthRange[Verbatim[Repeated][___]] := {Infinity, 0};
+sequencePatternLengthRange[Verbatim[RepeatedNull][___]] := {Infinity, 0};
+
+(* Variable-length sequences are not allowed as a second argument to Except. *)
+sequencePatternLengthRange[_Except] := {1, 1};
+
+sequencePatternLengthRange[Verbatim[Longest][p_]] := sequencePatternLengthRange[p];
+sequencePatternLengthRange[Verbatim[Longest][___]] := {Infinity, 0};
+sequencePatternLengthRange[Verbatim[Shortest][p_]] := sequencePatternLengthRange[p];
+sequencePatternLengthRange[Verbatim[Shortest][___]] := {Infinity, 0};
+
+sequencePatternLengthRange[_OptionsPattern] := {0, Infinity};
+
+sequencePatternLengthRange[(Verbatim[PatternSequence] | Verbatim[OrderlessPatternSequence])[ps___]] :=
+  Total[Append[ReleaseHold @ Map[sequencePatternLengthRange, Hold[{ps}], {2}], {0, 0}]];
+
+sequencePatternLengthRange[_Verbatim] := {1, 1};
+
+sequencePatternLengthRange[Verbatim[HoldPattern][p_]] := sequencePatternLengthRange[p];
+sequencePatternLengthRange[Verbatim[HoldPattern][___]] := {Infinity, 0};
+
+sequencePatternLengthRange[_KeyValuePattern] := {1, 1};
+
+sequencePatternLengthRange[Verbatim[Condition][p_, _]] := sequencePatternLengthRange[p];
+sequencePatternLengthRange[Verbatim[Condition][___]] := {Infinity, 0};
+
+sequencePatternLengthRange[Verbatim[PatternTest][p_, _]] := sequencePatternLengthRange[p];
+sequencePatternLengthRange[Verbatim[PatternTest][___]] := {Infinity, 0};
+
+sequencePatternLengthRange[Verbatim[Optional][p_, _]] := {0, Max @ sequencePatternLengthRange[p]};
+sequencePatternLengthRange[Verbatim[Optional][___]] := {Infinity, 0};
+
+(* Since we have enumerated all pattern constructs above, this case does not correspond to a pattern.
+   However, the completeness of checks above needs to be checked for every new WL version. *)
+sequencePatternLengthRange[_] := If[$VersionNumber <= 12.3, {1, 1}, {0, Infinity}];
+
 parseTokenDeduplication[None] := None;
 declareMessage[General::multisetTokenDeduplicationNotImplemented,
                "Token deduplication is not implemented for Multiset Substitution System."];