Combinations of multiple matching patterns

Question

I wonder if there is any nice way to combine DownValues (or any other suitable rule-/pattern-/function -based Mathematica construct) when multiple patterns match an expression. Let me explain what I mean with a somewhat silly example:

f[x_?(Mod[#,2]==0 &&Mod[#,3]==0&)]:= "FizzBuzz"
f[x_?(Mod[#,2]==0& )]:= "Fizz"
f[x_?(Mod[#,3]==0&)]:= "Buzz"
f[x_]:=x

Range@15 //Map@f
(* {1,Fizz,Buzz,Fizz,5,FizzBuzz,7,Fizz,Buzz,Fizz,11,FizzBuzz,13,Fizz,Buzz} *)

It would be really nice if one could do away with the first DownValue of f which checks if an expression is divisible by both 2 and 3 (since this is just a combination of the PatternTests used by the two DownValues defined beneath it). In this simple case one additional DownValue might not be an issue but if one adds more and more "rules" the number of additional combinations to check increases rapidly with the number of "rules". For instance:

g[x_?(Mod[#,2]==0 &&Mod[#,3]==0 && #<10&)]:= "FizzBuzzZapp"
g[x_?(Mod[#,2]==0 &&Mod[#,3]==0&)]:= "FizzBuzz"
g[x_?(Mod[#,2]==0&& #<10& )]:= "FizzZapp"
g[x_?(Mod[#,2]==0& )]:= "Fizz"
g[x_?(Mod[#,3]==0&& #<10& )]:= "BuzzZapp"
g[x_?(Mod[#,3]==0&)]:= "Buzz"
g[x_?(#<10&)]:= "Zapp"
g[x_]:=x

Range@15 //Map@g
(* {Zapp,FizzZapp,BuzzZapp,FizzZapp,Zapp,FizzBuzzZapp,Zapp,FizzZapp,
BuzzZapp,Fizz,11,FizzBuzz,13,Fizz,Buzz} *)

Is there an elegant idiom for this?

Edit:

I actually came up with this whole question when looking at this website about fizzbuzz in too much detail and thinking that the presented FP solution was not really comprehensible anymore. As this fizzbuzz task is all about rule-replacement one might assume that a pattern-matching/rule-replacement/functional approach should give the most natural, elegant and easy to understand representation but this seems not necessarily to be true.

Answer 1

In keeping with the multiple DownValues part of the question, this is an option:

ClearAll@f
conditions[x_] := {Mod[x, 2] == 0, Mod[x, 3] == 0, x < 10}
f[x_ /; Or @@ conditions[x]] := StringJoin@Pick[{"Fizz", "Buzz", "Zapp"}, conditions[x]]
f[x_] := x

It tests for any of the conditions first, and then within the body of the function uses the individual conditions to Pick out the correct words.

Of course, with something as simple as this, we could just define

ClearAll@f
f[x_] := With[{cons = conditions[x]}, 
   If[Or @@ cons, StringJoin@Pick[{"Fizz", "Buzz", "Zapp"}, cons], x]
  ]

to begin with, because this doesn't require multiple calls to the conditions. Or, packaging everything together (in which case you can switch out the conditions and the list of strings):

ClearAll@f
f[x_] := Module[{
   cons = {Mod[x, 2] == 0, Mod[x, 3] == 0, x < 10},
   strs = {"Fizz", "Buzz", "Zapp"}
  },
  If[Or @@ cons, StringJoin@Pick[strs, cons], x]
 ]

However, none of the conditions are used in the definition of f, which isn't really in keeping with the nature of the question, which I read as how to deal with multiple DownValues with overlapping conditions. It might be that that's just not the natural way to deal with these constructions, but I'm still interested in an answer to that specific question.

---

To further see the usefulness here, I'll implement the second function that Sascha did in their answer.

ClearAll@f
regions = 1/2*{{1, -Sqrt[3]/3}, {0, 2 Sqrt[3]/3}, {-1, -Sqrt[3]/3}} // Map@Disk;

f[x_] := Module[{cons = RegionMember[#, x] & /@ regions},
    {If[Or @@ cons, RGBColor @@ Plus @@ Pick[IdentityMatrix[3], cons], Black], Point@x}
  ]

Then (since I have version 10.0, I don't have RandomPoint, so I use a direct method to generate a random point in the disk):

f /@ Table[6/Sqrt[2 π] Sqrt[RandomReal[{0, 1}]] {Cos@#, Sin@#} &@ RandomReal[{0, 2 π}], {5000}] // Graphics

---

In addition, if there is interest in calling subfunctions, here's another example. Let's say that we want to compose a set of function depending on which conditions are met (and the ordering in which the conditions are met matters!). I'll return to the original conditions:

ClearAll@f
f[x_] := Module[{
    cons = {Mod[x, 2] == 0, Mod[x, 3] == 0, x < 10},
    strs = {g, h, m}
   },
  If[Or @@ cons, Apply[Composition, Pick[strs, cons]]@x, x]
 ]
f /@ Range[11]
(* {m[1], g[m[2]], h[m[3]], g[m[4]], m[5], g[h[m[6]]], m[7], g[m[8]], h[m[9]], g[10], 11} *)

Answer 2

This does not answers my own question fully (I am still interested to see if someone might come up with an truly elegant solution based on DownValues) but I found a rule-based solution that is imho. elegant non the less.

fizzbuzz[rls_]:= With[{res=ReplaceList[#, rls]}, If[res=={}, #, StringJoin@res]]& 

fizzbuzz[{_?(Mod[#,2]==0&) -> "Fizz",
          _?(Mod[#,3]==0&) -> "Buzz",
          _?(#<10&) -> "Zapp"}] /@ Range@15

Looks especially neat (or obfuscated, depending on your point of view) with the escfnesc glyph for Function

Update: Generalization of my solution and Example

Because some confusion arose in the comments on march's answer I though I should address those in my own answer and give another example to show that this approach can be easily extended to all kinds of rules. So here is a generalization of my function fizzbuzz. It takes three arguments:

• a list of (possibly overlapping) replacement rules
• a function to be applied to the expressions found via pattern matching (note that the function also has access to the actual variable not only the results from pattern matching, see example below)

• an alternative function to be applied if no pattern matched

func[rls_, f_, alt_]:= With[{res=ReplaceList[#, rls]}, If[res=={}, alt@#, f[res,#]]]&  

**Example**

regions=1/2*{{1, -Sqrt[3]/3}, {0, 2 Sqrt[3]/3}, {-1, -Sqrt[3]/3}} //Map@Disk;

f = func[{x_ /;RegionMember[regions[[1]],x]:> {1,0,0},
          x_ /;RegionMember[regions[[2]],x]:> {0,1,0},
          x_ /;RegionMember[regions[[3]],x]:> {0,0,1}},  
          {RGBColor@(Plus@@#1), Point[#2]}&, Point[#]& ] 

f/@ RandomPoint[Disk[{0,0}, 2], 5000] //Graphics

Answer 3

An alternative approach

It seems at its heart that you want more than one rule to match a given expression and each match to return a value, which is then to be combined. I cannot think of any "clever" method to do this that is not contrived and questionable. Perhaps something more standard has at least some service for you.

Your rules, each one in a sublist:

rules =
  {{_?(Mod[#, 2] == 0 &) :> "Fizz"},
   {_?(Mod[#, 3] == 0 &) :> "Buzz"},
   {_?(# < 10 &)         :> "Zapp"}};

Then any one of the next three lines will produce:

Range@15 /. rules // Thread
Array[Replace[rules], 15]
Replace[rules] /@ Range[15]

{{1, 1, "Zapp"}, {"Fizz", 2, "Zapp"}, {3, "Buzz", "Zapp"}, {"Fizz", 4, "Zapp"},
 {5, 5, "Zapp"}, {"Fizz", "Buzz", "Zapp"}, {7, 7, "Zapp"}, {"Fizz", 8, "Zapp"},
 {9, "Buzz", "Zapp"}, {"Fizz", 10, 10}, {11, 11, 11}, {"Fizz", "Buzz", 12},
 {13, 13, 13}, {"Fizz", 14, 14}, {15, "Buzz", 15}}

You could then, if possible, process from there, e.g.

post[x_List] := "" <> Cases[x, _String] /. "" :> First[x];

Array[post @* Replace[rules], 15]

{"Zapp", "FizzZapp", "BuzzZapp", "FizzZapp", "Zapp", "FizzBuzzZapp",
 "Zapp", "FizzZapp", "BuzzZapp", "Fizz", 11, "FizzBuzz", 13, "Fizz", "Buzz"}

---

A second try at the specific request

As for that "contrived and questionable" method I might as well post it; it actually doesn't look quite so bad "on paper" as it did in my head.

stack[] = {};
push[x_] := (stack[] = {stack[], x};)
end[] := # &["" <> stack[], stack[] = {}]

g[x_] /; Mod[x, 2] == 0 && push["Fizz"] = Null;
g[x_] /; Mod[x, 3] == 0 && push["Buzz"] = Null;
g[x_] /; x < 10 && push["Zapp"] = Null;

g[else_] := If[stack[] =!= {}, end[], else]

Array[g, 15]

{"Zapp", "FizzZapp", "BuzzZapp", "FizzZapp", "Zapp", "FizzBuzzZapp", "Zapp",
 "FizzZapp", "BuzzZapp", "Fizz", 11, "FizzBuzz", 13, "Fizz", "Buzz"}

Answer 4

f[x_] := With[{res = f1[x] <> f2[x] <> f3[x]}, 
         Switch[res, "", x, _, res]]
f1[x_?(Mod[#, 2] == 0 &)] := "Fizz"
f1[x_] := ""
f2[x_?(Mod[#, 3] == 0 &)] := "Buzz"
f2[x_] := ""
f3[x_?(# < 10 &)] := "Zapp"
f3[x_] := ""

f /@ Range@15

{"Zapp", "FizzZapp", "BuzzZapp", "FizzZapp", "Zapp", "FizzBuzzZapp", "Zapp", "FizzZapp", "BuzzZapp", "Fizz", 11, "FizzBuzz", 13, "Fizz", "Buzz"}

Answer 5

I have probably missed the point but wanted to play:

f[lst_, ru_, lab_] := Module[
  {r, u, s},
  r = Boole@Through[ru[#]] & /@ lst;
  u = (lab # /. {0 -> Sequence[]} & /@ r) /. {{} -> 1};
  s = StringJoin @@@ u;
  Thread[{lst, s}] /. {{_, y_String} :> y, {x_, 1} :> x}
  ]

So,

f[Range[100], {Mod[#, 2] == 0 &, Mod[#, 3] == 0 &, # < 10 &}, {"Fizz",
   "Buzz", "Zapp"}]

yields:

{"Zapp", "FizzZapp", "BuzzZapp", "FizzZapp", "Zapp", "FizzBuzzZapp", \
"Zapp", "FizzZapp", "BuzzZapp", "Fizz", 11, "FizzBuzz", 13, "Fizz", \
"Buzz", "Fizz", 17, "FizzBuzz", 19, "Fizz", "Buzz", "Fizz", 23, \
"FizzBuzz", 25, "Fizz", "Buzz", "Fizz", 29, "FizzBuzz", 31, "Fizz", \
"Buzz", "Fizz", 35, "FizzBuzz", 37, "Fizz", "Buzz", "Fizz", 41, \
"FizzBuzz", 43, "Fizz", "Buzz", "Fizz", 47, "FizzBuzz", 49, "Fizz", \
"Buzz", "Fizz", 53, "FizzBuzz", 55, "Fizz", "Buzz", "Fizz", 59, \
"FizzBuzz", 61, "Fizz", "Buzz", "Fizz", 65, "FizzBuzz", 67, "Fizz", \
"Buzz", "Fizz", 71, "FizzBuzz", 73, "Fizz", "Buzz", "Fizz", 77, \
"FizzBuzz", 79, "Fizz", "Buzz", "Fizz", 83, "FizzBuzz", 85, "Fizz", \
"Buzz", "Fizz", 89, "FizzBuzz", 91, "Fizz", "Buzz", "Fizz", 95, \
"FizzBuzz", 97, "Fizz", "Buzz", "Fizz"}

Answer 6

Perhabs

g[x_] := Switch[{Mod[x, 2] == 0, Mod[x, 3] == 0, x < 10},
   {True, True, True}, "FizzBuzzZapp",
   {True, True, False}, "FizzBuzz",
   {True, False, True}, "FizzZapp",
   {True, False, False}, "Fizz",
   {False, True, True}, "BuzzZapp",
   {False, True, False}, "Buzz",
   {False, False, True}, "Zapp",
   _, x]

Not sure about elegance but at least every test is performed only once per function call. And it seems that the function definition cannot be much simpler (in general), if you have a large number of cases to define.