First /@
 Last[
  SortBy[
    GatherBy[{#, StringJoin[Sort[ToUpperCase[Characters[#]]]]} &
        /@ DictionaryLookup[{"English", All}],
     Last],
    Length]
]

The idea here is to extract every word from the English dictionary. Then we create pairs consisting of the initial word and the initial word with letters sorted and converted to uppercase. The idea is that the second entry is a anagram key — all words that are anagrams of each other will share the same key.

Then we use GatherBy to consolidate all the pairs with common keys and SortBy to order by the number of anagrams in the set. Finally Last is used to find the words that form the largest anagram set in the English dictionary and First to extract only the words (I drop the keys).

Here is some output that will make the steps clearer.

In[59]:= Take[SortBy[
GatherBy[{#, StringJoin[Sort[ToUpperCase[Characters[#]]]]} & /@
DictionaryLookup[{"English", All}], Last], Length], -10]
Out[59]= {{{“ales”, “AELS”}, {“Elsa”, “AELS”}, {“lase”, “AELS”}, {“leas”,
“AELS”}, {“Lesa”, “AELS”}, {“sale”, “AELS”}, {“seal”, “AELS”}}, {{“capers”,
“ACEPRS”}, {“crapes”, “ACEPRS”}, {“pacers”, “ACEPRS”}, {“parsec”,
“ACEPRS”}, {“recaps”, “ACEPRS”}, {“scrape”, “ACEPRS”}, {“spacer”,
“ACEPRS”}}, {{“carets”, “ACERST”}, {“caster”, “ACERST”}, {“caters”,
“ACERST”}, {“crates”, “ACERST”}, {“reacts”, “ACERST”}, {“recast”,
“ACERST”}, {“traces”, “ACERST”}}, {{“elan”, “AELN”}, {“lane”,
“AELN”}, {“Lane”, “AELN”}, {“lean”, “AELN”}, {“Lean”, “AELN”}, {“Lena”,
“AELN”}, {“Neal”, “AELN”}}, {{“Ingres”, “EGINRS”}, {“reigns”,
“EGINRS”}, {“resign”, “EGINRS”}, {“sering”, “EGINRS”}, {“signer”,
“EGINRS”}, {“singer”, “EGINRS”}, {“Singer”, “EGINRS”}}, {{“notes”,
“ENOST”}, {“onset”, “ENOST”}, {“Seton”, “ENOST”}, {“steno”,
“ENOST”}, {“stone”, “ENOST”}, {“Stone”, “ENOST”}, {“tones”,
“ENOST”}}, {{“opts”, “OPST”}, {“post”, “OPST”}, {“Post”, “OPST”}, {“pots”,
“OPST”}, {“spot”, “OPST”}, {“stop”, “OPST”}, {“tops”, “OPST”}}, {{“pares”,
“AEPRS”}, {“parse”, “AEPRS”}, {“pears”, “AEPRS”}, {“rapes”,
“AEPRS”}, {“reaps”, “AEPRS”}, {“spare”, “AEPRS”}, {“spear”,
“AEPRS”}}, {{“ates”, “AEST”}, {“east”, “AEST”}, {“East”, “AEST”}, {“eats”,
“AEST”}, {“etas”, “AEST”}, {“sate”, “AEST”}, {“seat”, “AEST”}, {“teas”,
“AEST”}}, {{“least”, “AELST”}, {“slate”, “AELST”}, {“Stael”,
“AELST”}, {“stale”, “AELST”}, {“steal”, “AELST”}, {“tales”,
“AELST”}, {“teals”, “AELST”}, {“Tesla”, “AELST”}}}

The above shows the last 10 anagram families with the associated anagram key. The last one is the one used to generate the challenge output.

Out[1]= {"least", "slate", "Stael", "stale", "steal", "tales", 
"teals", "Tesla"}

The first question you need to answer is, what do these words have in common? This is pretty easy.

Next, what makes this particular set special?

Finally, what Mathematica code that output this set. Please no wise-guy answers like:

List["least", "slate", "Stael", "stale", "steal", "tales", "teals", "Tesla"]

The point is that this list can be computed from code that does not contain any of these words and the solution relates to the two questions asked above.

I’ll post the code in a few days if no one provides an answer.

Can you come up with a smaller one? Post it to my comments.

Dynamic[Refresh[
  Transpose[
     IntegerDigits[#, 2, 4] & /@
      Flatten[
       IntegerDigits[\[LeftFloor]#\[RightFloor], 10, 2] & /@
        Date[][[4 ;; 6]]]] /. {0 -> \[EmptyCircle],
     1 -> \[FilledCircle]} // TableForm, UpdateInterval -> 1]]

Download

In part 1 I defined the game structure and in part 2 I added the first level but at this point the game is still very amateurish. Today’s goals are to:

1. polish the look and feel of the game by adding more villans, backgrounds, and sound.
2. introduce a new level with more difficulty and more coding complexity
3. consider how the added complexity may call for different coding techniques

Let’s start with the background image for the game.  Working with images in notebooks is easy because you can just copy and paste the image and assign to a variable (Fig 1).

Fig 1

The next step is getting the background into the game. This can be done using Inset. The inset image should be behind all graphics so we place it in the Prolog option of Graphics which cause it to be rendered before any other graphics object.  Fig 2 shows how to do this. You should read the documentation for Inset for the details but basically you map a point on the image to a point on the graphic and specify a size for the resulting image.

Fig 2

For sound, Mathematica provides a primitives Sound, SoundNote, and EmitSound. Again, I am not going to spend a lot of time explaining these now. There is a full chapter on Music and Sound in Mathematica Cookbook written by a domain expert, John Kiehl, but the Mathematica documentation is extensive as well. As a test I created a CDF that emits a sound when two objects collide.

Manipulate[
 If[EuclideanDistance[p1, {0, 0}] < 0.1,   Quiet@EmitSound[Sound[SoundNote["Snare"]]]];  Graphics[   {    Text[Style["x", 28], p1],    Text[Style["y", 28], {0.0, 0.0}]    },   PlotRange -> {{-1, 1}, {-1, 1}}
  ]
 ,
 {p1, {-1, -1}, {1, 1}},
 SaveDefinitions -> True
 ]

NOTE: The juxtaposition of Quiet and EmitSound above may look discordant but they do different things. Quiet suppresses any messages that may be generated by EmitSound.

Now that we have some of the preliminaries out of the way we can get back to the game. So far our game has been simple but even it is simplicity there is quite a few variables and logic for managing the game state. As we introduce more game elements it is clear this can quickly get out of hand so we need to take a step back and think like a software engineer.

The two techniques that tend to result in elegant Mathematica programs are Functional and Rule-Based programming. I will use both. My first goal is to encapsulate the state of the game’s villans (i.e. the irrationals). The state of a villan partly static (e.g. its name stays constant), partly dynamic in relation to the current state( e.g. a sound should be emitted just at the point of collision) and partly a function of prior states (e.g. once a villan is struck it should remain in the struck state). This implies a villan can be represented by a function that has memory of the past. Such a function is called a closure. But what should the function return? How about a set of rules that specify the present state of the villan. Let me describe what I mean step by step.

I want the present state of a villan to be a set of rules. For example:

villan1 =
    {
        name->"π",
        hit -> False,
        fontw -> Bold,
        color ->  Green,
        size -> 32,
        pos -> {0,1},
        transform -> Identity,
        sound -> Sound[SoundNote[None]]]
    }

This states that currently villan1 has name π, has not be hit, is displaying as Bold and Green at a particular position and is neither transformed (e.g. not Rotated) nor emitting a sound. But this is the instantaneous representation of the villan. What we really want is to represent the villan as a function of the games state and history. The way to do that is to make the villan into a function (henceforth called the villan function).

villan1 = Function[{projPos},
    {
        name->"pi",
        hit -> collision[{0,1},projPos],
        fontw -> Bold,
        color ->  If[collision[{0,1},projPos],Pink,Green],
        size -> 32,
        pos -> {0,1},
        transform -> If[collision[{0,1},projPos],
                           Rotate[#1,30 Degrees]&,Identity]
        sound -> If[collision[{0,1},projPos],
                       Sound[SoundNote["Snare"]],
                       Sound[SoundNote[None]]]
    }

This now says that the rules for hit, color and transform and sound are a function of the projectiles position (i.e. a function of whether this particular villan is involved in a collision with the rational projectile).

But this is still not correct. Because, some of the rules are not simply a function of the projectile being hit but rather a function of ever being hit. That is to say, we need memory of the past. Now we can store this memory of the past externally and pass it in as another function argument but that complicates matters because now we need to maintain a bit of extra state for each villan separate from the villan. What we want is the villan itself to keep its own state. What we want is a closure. Now Mathematica does not explicitly provide closures but it is fairly easy to emulate them by taking advantage of the feature of Module that guarantees variables scoped within the Module are unique. We associate the module’s variables with the function by using a villan constructor (makeVillan). In addition, we use Options on the villan constructor to capture the default values. Keep in mind that makeVillan is distinct from the villan function (its return value). 

Options[makeVillan] = {fontw -> Bold, color -> Green, size -> IrrSZ};
makeVillan[aName_, aPos_, OptionsPattern[]] :=
 Module[{c1 = False},
  Function[{projPos, reset},
   With[{c2 = collision[aPos, projPos]},
    c1 = c1 || c2;
    c1 = If[reset, False, c1];
    {
     hit -> c1,
     name -> nm,
     fontw -> OptionValue[fontw],
     color ->  If[c1, Pink, OptionValue[color]],
     size -> OptionValue[size],
     pos -> aPos,
     transform -> If[c1,
                        Rotate[#1, 30 Degree] &,
                        Identity],
     sound -> If[c2,
                    Sound[SoundNote["Snare"]]],
                    Sound[SoundNote[None]]]
     }
    ]
   ]
  ]

This is relatively little code but it concentrates many Mathematica concepts so let’s review it line by line.

Options[makeVillan] = {fontw -> Bold, color -> Green, size -> IrrSZ};
This establish the defaults for a villan constructor. It says villans should be Bold and Green and have a size IrrSZ (which is a constant defined elsewhere.

makeVillan[aName_, aPos_, OptionsPattern[]] :=
This says that to make a villan we provide a name and its position as well as additional options which can override the defaults.

Module[{c1 = False},
This says the makeVillan rule has a lexically scoped variable c1 whose initial value is False. This in itself is unremarkable except in relation to what comes next. For now, I'll say that c1 means "has this villan ever been involved in a collision".

Function[{projPos, reset},
The value produced by makeVillan is a Function (i.e. we are returning a Function) and that function takes a projPos and another argument called reset (more on that later).

With[{c2 = collision[aPos, projPos]},
Here we use With inside of the function to define a constant c2 which is a Boolean that states “is the villan currently hit”.

c1 = c1 || c2;
c1 = If[reset, False, c1];
These lines say, that it is true that the villan has been hit if it was hit before or is currently hit except if we are reseting its previous state of being hit. Being able to reset the state is important to starting a level over.

{
hit -> c1,
name -> nm,
fontw -> OptionValue[fontw],
color -> If[c1, Pink, OptionValue[color]],
size -> OptionValue[size],
pos -> aPos,
transform -> If[c1, Rotate[#1, 30 Degree] &, Identity],
sound -> If[c2, Sound[SoundNote["Snare"]]],Sound[SoundNote[None]]]
}
These lines provide the return value of the villan function and as we alluded before, the value is a set of rules. But note that these rules reference the Module variable c1. But c1‘s scope is not active during the invocation of the villan function; it is active only during the invocation of the constructor (makeVillan) hence we can see a bit of hanky-panky is going on here. What I am doing is stealing c1 and relying on the fact that internally Mathematica has replaced c1 with a name that is unique (see documentation for Module if this is unclear). Hence, our villan function acts as a closure over some unique global variable that has taken c1‘s place (again, this is all under the covers). Since Mathematica guarantees the Kernel will have no other such variable, we are safe. In essence, we dynamically allocated a bit of storage for a villan function to remember the past. You should note that the rule for sound use c2 rather than c1 because a sound is only a function of the instaneous state of a collision not the past state.

I have introduced a lot of concepts but the payoff, as you will see, is that our next game level will be almost trivial to implement. In this level we will have 3 villans positioned along points of a Sine wave. The player will need to set the amplitude and frequency of the wave such that the rational projectile (3/4) collides will all 3 villans.

Below is the code for the new level. This includes the code that we explained above and the Manipulate for the actual game play. Note how the Manipulate is now devoid of game state management and control logic except for replacement rules and the controls. Most of the code in the Manipulate is simple option settings for the Graphics and the Manipulate itself.

With[{COLLIDETHRS = 0.25, IrrSZ = 48},
 collision =
  Function[{p1, p2}, EuclideanDistance[p1, p2] < COLLIDETHRS];
 villanCls = transform@Text[Style[name, fontw, color, size], pos];
 Options[makeVillan] = {fontw -> Bold, color -> Green,
   size -> IrrSZ};
 makeVillan[nm_, p_, OptionsPattern[]] :=
  Module[{c1 = False},
   Function[{projPos, reset},
    With[{c2 = collision[p, projPos]},
     c1 = c1 || c2;
     c1 = If[reset, False, c1];
     {
      hit -> c1,
      name -> nm,
      fontw -> OptionValue[fontw],
      color ->  If[c1, Pink, OptionValue[color]],
      size -> OptionValue[size],
      pos -> p,
      transform -> If[c1,
                         Rotate[#1, 30 Degree] &,
                         Identity],
      sound -> If[c2,
                     Quiet@EmitSound[Sound[SoundNote["Snare"]]]]
      }
     ]
    ]
   ]
 ]

With[{PiX1 = 2, PiY1 = 1.5, PiX2 = 10, PiY2 = 1.5, PiSZ = 28, EX1 = 6,
   EY1 = -1.5},
 villans = {makeVillan["\[Pi]", {PiX1, PiY1}],
    makeVillan["\[ExponentialE]", {EX1, EY1}],
    villan3 = makeVillan["\[Pi]", {PiX2, PiY2}] };
 ]

With[{TSTART = 0.2, TEND = 12.0},
 Manipulate[
  DynamicModule[{villans, pos, reset, path},
   reset = t <= TSTART;
   pos = {t, f[t, p1, p2]};
   villans = {villan1[pos, reset], villan2[pos, reset],
     villan3[pos, reset]};
   sound /. villans;
   path = Table[{t, f[t, p1, p2]}, {t, TSTART, t, 0.1}];
   Graphics[
    {
     Line[path],
     Text[Style[3/4, Bold, Red, 24], pos],
     villanCls /. villans
     },
    Axes -> True,
    PlotRange -> {{0, 11}, {-3.5, 3.5}},
    PlotRangePadding -> 0.35,
    ImagePadding -> {{0, 0}, {0, 0}},
    Prolog -> Inset[background, Center, Center, 13.0]]]

  ,
  {t, TSTART, TEND, Trigger},
  {p1, 0.0, 2.0},
  {p2, -1, 1},
  FrameLabel ->  Style["p1 Sin[p2 t]", 18],
  TrackedSymbols :> {t}
  ]
 ]

Here is what the level looks like (this CDF has embedding issues. I am told this will improve in the next release of Mathematica)

Fig 3

Download CDF

Conclusion

This installment covered a lot of ground but I hope gave you some food for thought. It is possible to create Manipulates that encompass a lot of logic without drowning in the logic as long as you think carefully how to encapsulate the logic by leveraging the best features of Mathematica. The techniques covered here are also discussed extensively in my book (plus a lot more!).

This will be my last post on Angry Rationals for a while but I plan on continuing to work on the game as I have time and I will provide the final notebook for you to download to play and tweak when it is ready.

See message from Tim O’Reilly.

Level 1 of our game challenges  the player to set the initial position of a rational projectile (1/2) so its path along a parabola causes it to crash into the game’s first irrational villan (π). The level will have several effects:

1. The projectile should leave a trace of its path as it flies across the screen.
2. If hit, the villan should change color to provide feedback to the player.
3. If hit, the villan should tip over to provide a degree of satisfaction to the player (and the rational).

Additional effects, such as sound would be nice but we will save those for a future installment.

The first effect can be achieved using Line and Table to generate the points. The points come from the trigger variable t, the single user set parameter p1 and the function for a parabola f[t_] := 1 – t^2. Despite its name, Line can generate smooth curves provided the collection of points are finely spaced.

f[t_] := 1 - t^2;
path = Table[{t1 + p1, f[t1]}, {t1, TSTART + p1, t + p1, PathIncr}];


The second effect requires a means to detect collisions. EuclideanDistance does the trick as long as we define a collision as an intersection of two points within a reasonable delta.

collision[p1_, p2_] := EuclideanDistance[p1, p2] < COLLIDETHRS;


The game and sprites are implemented in terms of Mathematica’s 2D Graphics primitives. I already mentioned Line and I also use Text and Style. The third effect, tipping over the Pi is done using Rotate.

The remainder of the code is game state logic. In particular, when using Manipulate, remember that the body of the Manipulate is continuously being evaluated. This means that you must arrange for state variables to always represent the current state of play. For example, we have a state variable called success that is updated using the following logic.


success = success || collision[{t + p1, f[t]}, {PiX, PiY}];
success = success && t > TSTART;


This keeps the value of success False until a collision is detected and then keeps the value of success True until the trigger variable t is reset to TSTART.

The complete code for level 1 follows.

DynamicModule[{success = False},
 With[{LMARGIN = 50, RMARGIN = 50, BMARGIN = 50, TMARGIN = 50,
   TSTART = -1, TEND = 1, COLLIDETHRS = 0.05, PiX = 0.85, PiY = 0.35,
   PiSZ = 48, ratSZ = 28, PathIncr = 0.05, PlRngPad = 0.25,
   PlotRng = {{-1, 1}, {0, 1}}},
   Manipulate[
   DynamicModule[{f, pi, collision, path},
    f[t_] := 1 - t^2;
    path =
     Table[{t1 + p1, f[t1]}, {t1, TSTART + p1, t + p1, PathIncr}];
    collision[p1_, p2_] := EuclideanDistance[p1, p2] < COLLIDETHRS;     success = success || collision[{t + p1, f[t]}, {PiX, PiY}];     success = success && t > TSTART;
    pi = If[success,
      Rotate[Text[
        Style[\[Pi], Bold, Pink, PiSZ], {PiX, PiY}], -30 Degree],
      Text[Style[\[Pi], Bold, Green, PiSZ], {PiX, PiY}]];

    Graphics[
     {
      Text[Style[1/2, Bold, Red, ratSZ], {t + p1, f[t]}],
      pi,
      Line[path]
      },
     PlotRange -> PlotRng,
     PlotRangePadding -> PlRngPad,
     ImagePadding -> None]
    ],
   {p1, -0.1, 0.1},
   {t, TSTART, TEND, Trigger},
   FrameMargins -> {{LMARGIN, RMARGIN}, {BMARGIN, TMARGIN}}
   ]]]

Here is level 1 to try out by itself as a CDF. I needed to alter the structure because it seems Wolfram does not allow CDF’s containing DynamaicModule or With, which is a shame. This explains why Part 1 would not work.

Lou can download the entire game, integrated into the framework from Part 1. In the next installment I’ll add more levels, sound and make the whole game it a bit more polished.

Let’s create a game using Mathematica’s dynamic interactive features. Games are complex pieces of software so they present lots of opportunity to dig deep into Mathematica’s interactive features. However, this complexity also means we should GO SLOW and build up the game in an iterative step-by-step fashion. In fact, it’s a good idea to build all complex pieces of Mathematica code this way. Therefore, I’ll break the blog up into several installments as I add functionality.

The Game

Angry Rationals is inspired by the mega-hit, Angry Birds (if you need to click on that link you may need to get out more!). Here is the games premise:

The Rationals are ANGRY. Afterall, the rationals are the real work horses of the modern world. Engineers, mechanics and crafts-people of all kinds construct the objects of the world based on rulers that are ticked-off in rational divisions like 1/2, 3/4 and 7/8, etc. Did you ever hear a mechanic say, hey Bob, hand me a Φ-sized socket wrench? Of course, not! So, in addition to ticking off rulers the rationals are ticked-off at the irrationals (and especially those snooty transcendentals) because the mathematicians give them too much attention! To make matters worse, the rationals, although infinite in quantity are out-numbered by their more numerous enemy (may a scourge be brought upon Cantor’s house)!

The object of the game is to help the rationals seek revenge by causing them to fly out and smash the irrationals into Cantor Dust (metaphorically speaking). But unlike Angry Birds, you will use no sling shot but rather your mathematical wits to estimate the parameters of a function that govern the rationals trajectory so that they intersect with the irrationals and obliterate them!

Preliminaries

Before reading further you should have a basic understanding of Mathematica’s dynamic features because I will not be spelling out every detail here. Introduction to Manipulate  and  Introduction to Dynamic are essential but you may want to read the advanced tutorials as well (Advanced Manipulate and Dynamic). Alternatively, you can read along and consult the documentation when you don’t understand something.

Modest Beginnings

As I already mentioned, the game is going to be built step by step so you won’t get to destroy any irrationals today! Instead, I am going to build a rough structure for the game to implement logic that allows a player to proceed through a set of increasingly difficult game levels. I’ll write this code in the first way that comes to mind but as the game increases in complexity it may need some refactoring.

First off, I use PaneSelector as the top most game controller. The goal here is to use a different pane for each level and transition between these levels via dynamic changes to the level variable.


PaneSelector[{
BYE -> bye,
LOST -> lost,
WON -> won,
1 -> level1,
LAST -> last}, level]

For now, I’ll have only one “real” playing level (1->level1). BYE, LOST and WON are constants that represent pseudo-levels for interacting with the player when they win, or lose a level and when they quit. The final level (LAST->last) will tell them that they have beaten the entire game.

The lowercase variables bye, lost, won, level1 and last  will evaluate to either DynamicModule or Manipulate as the requirements dictate. In general, I use DynamicModule+Dynamic when I need more flexibility than Manipulate provides.

Here is an example of a pseudo-level that gets activated when the player loses the current level of the game.

lost =
     DynamicModule[{}, 
         Panel[
            Column[ {
               Graphics[{
                   Text[Style["You Lost!", Black, 20], {0, 0.8}],
                   Text[Style["Play Again?", Red, 20], {0, 0.5}]
                   },
                   PlotRange -> {{-1, 1}, {0, 1}}],
               Row[{
                    Button["Yes", reset[savelevel]],
                    Button["No", level = -3]
                  }]
               },
               Alignment -> Center
            ]
         ]
     ];

Here the goal is to tell the user they lost and allow them to transition to the level they just were playing or to exit the game. Visually it looks like this:

Level 1 of the game is just a stub that we will develop further later. For now, the object of level 1 is simply to press a button before a counter reaches 1.0 (my boys told me this may win the lamest game of the year award). The counter is implemented using a Trigger . The game play starts when the trigger is activated. In the future, the dynamic trigger variable t will drive the movement of the game sprites.

Here is the entire game structure that we will build upon in future installments. I wrap the whole structure in a Manipulate, since this is a requirement for publishing as a CDF. This outer Manipulate has a dummy variable with property None so it is not mapped to a controller. I also use options Paneled->FALSE and AppearanceElements -> None to hide the visual elements and controls of the outer Manipulate. This is because I want all the interactions to live inside the PaneSelector. I use With to set up constants and DynamicModule to encapsulate the game state variables.

Manipulate[
 With[{BYE = -3, LOST = -2, WON = -1, LAST=2, LMARGIN = 100, RMARGIN = 100,
   TMARGIN = 100, BMARGIN = 100, TSTART = -1.0, TEND = 1.0},
  DynamicModule[
   {success = False, savelevel = 1, bye, lost, won, level1, last,
    reset},
   reset[l_] := DynamicModule[{}, success = False; level = l];
   bye = Graphics[{Text[Style["Bye", Red, 24]]}];
   lost = DynamicModule[{},
     Panel[
      Column[
       {
        Graphics[
         {
          Text[Style["You Lost!", Black, 20], {0, 0.8}],
          Text[Style["Play Again?", Red, 20], {0, 0.5}]
          },
         PlotRange -> {{-1, 1}, {0, 1}}],
        Row[{Button["Yes", reset[savelevel]],
          Button["No", reset[BYE]]}]
        },
       Alignment -> Center
       ],
      FrameMargins -> {{LMARGIN, RMARGIN}, {BMARGIN, TMARGIN}}
      ]
     ];
   (*Level1 - For now,
   the player need only press the button before t==1*)

   level1 = Manipulate[
     (*If user won, react immediatly *)

     If[success , level = savelevel + 1,
      (*Only evaluate failure when level is done (t>=1)*)

      If[t >= 1.0,
        savelevel = If[level > 0, level, savelevel];
        level = LOST;
        ];
      ];
     (*Active game area for this level*)

     Row[{t, Button["Press", success = True,
        Enabled -> (t > -1.0)]}],
     {t, TSTART, TEND, Trigger},
     FrameMargins -> {{LMARGIN, RMARGIN}, {BMARGIN, TMARGIN}}
     ];
   (*last - Getting last means you beat all levels*)
     last = DynamicModule[{},
     Dynamic[
      Panel[
       Column[
        {
         Graphics[
          {
           Text[Style["You Beat All Levels!", Black, 20], {0, 0.8}],
           Text[Style["Play Again?", Red, 20], {0, 0.5}]
           },
          PlotRange -> {{-1, 1}, {0, 1}}],
         Row[{Button["Yes", reset[1]], Button["No", reset[BYE]]}]
         }, Alignment -> Center
        ], FrameMargins -> {{LMARGIN, RMARGIN}, {BMARGIN, TMARGIN}}
       ]]
     ];
   PaneSelector[{
     BYE -> bye,
     LOST -> lost,
     WON -> won,
     1 -> level1,
     LAST -> last}, level]]
  ],
 {dummy, 0, 1, None},
 SaveDefinitions -> True, Paneled -> False,
 AppearanceElements -> None, Deployed -> True,
 Initialization :> {level = 1}
 ]

In the next installment I will be adding some more compelling game logic to the first level (although impressing my hard-core gaming kids is gonna take some effort).

The question was how to go about generating a set of pseudo-random numbers within a particular range that met some constraint. The obvious solution is to keep generating numbers in that range until the constraint is satisfied and that is where the thread ended. But this got me wondering if this is the best approach. Before diving into another possible approach let’s first explore the tools Mathematica provides for generating pseudo-randomness.

RandomInteger and RandomReal are the most basic functions for random number generation. They can generate 1 or many numbers in specified range.


In[1]:= RandomInteger[{1, 30}]
Out[1]= 23
In[2]:= RandomInteger[{1, 30}, 5]
Out[2]= {6, 1, 30, 6, 7}


Here I generate a single integer in the range {1,30} and then 5 integers in that range. One of the first constraints you might have in generating a set random numbers is that there be no repetitions. RandomInteger is not useful here because it provides no such guarantee. Calling RandomInteger repeatedly until there are no repetitions is way to brutish for anyone’s taste and certainly unnecessary because Mathematica provides the proper tools.

RandomChoice and RandomSample are two functions that select random numbers from a set you provide. RandomSample will never sample an element of the set more than once, so for this application it is exactly what we need. You simple generate the Range of numbers you want and RandomSample does the rest.



In[3]:= RandomSample[Range[30], 5]
Out[3]= {14, 22, 30, 29, 4}


Given these tools we are close to solving the problem in the method suggested on Math Forum. All we need is a function that specifies the constraints. In the post the constraints were stated to be:

1. 5 integers in the Range[1,30]
2. At most 2 integers <= 12
3. At least one integer >=25
4. Each of the integers 3,4 and 7 can’t be a divisor for more than 3 of the random chosen integers
5. At most two consecutive integers.

The first constraint is satisfied by simply using Range. The remainder can be tested using the following function. This function returns the list if the constraint is satisfied otherwise returns the empty list.




constraint[l_List] := If[
  Count[l, x_Integer /; x <= 12] <= 2 &&
   Count[l, x_Integer /; x >= 25] >= 1 &&
   Count[l, x_Integer /; Or @@ Divisible[x, {3, 4, 7}]] <= 3 &&
   Not[MatchQ[
     Sort[l], {___, x1_, y1_, ___, x2_, y2_, ___} /;
      x1 == y1 - 1 && (x2 == y2 - 1 || y1 == x2 - 1)]], l, {}]

We can now generate random numbers that satisfy the constraint as follows.


In[5]:= Module[{s},
While[Length[s = constraint[Evaluate[RandomSample[Range[30], 5]]]] == 0];s]
Out[5]= {19, 27, 6, 13, 20}


This is basically the solution arrived at in Math Forum, except that solution uses Reap and Sow, (and seems to change the problem definition by the end of the post), but in spirit these solutions are the same.

What bothered me about this solution in general is that there could be many calls to RandomSample before the constraint is satisfied. To see how many, we can make a small modification.



In[6]:= Module[{s, n = 1},
While[Length[s = constraint[Evaluate[RandomSample[Range[30], 5]]]] ==
0, n++];
{s, n}]
Out[6]= {{2, 23, 29, 12, 22}, 2}

This code counts how many calls were made before the constraint was met and returns a list with the value and the count. This time we got lucky and met the constraint in 2 calls to RandomSample. Let’s wrap this in a table to see how we do over several calls.

In[8]:= Table[
Module[{s, n = 1},
While[Length[
s = constraint[Evaluate[RandomSample[Range[30], 5]]]] == 0,
n++];
{s, n}], {30}]
Out[8]= {{{5, 20, 3, 29, 28}, 3}, {{30, 14, 21, 11, 13},
7}, {{18, 1, 29, 22, 28}, 4}, {{25, 29, 12, 28, 6},
1}, {{22, 14, 30, 18, 26}, 1}, {{12, 18, 13, 1, 30},
2}, {{25, 4, 22, 18, 15}, 3}, {{26, 24, 9, 16, 19},
2}, {{5, 20, 6, 26, 18}, 5}, {{16, 8, 22, 1, 30},
6}, {{23, 22, 27, 13, 8}, 6}, {{25, 26, 30, 23, 12},
3}, {{3, 6, 22, 25, 24}, 3}, {{15, 14, 29, 1, 26},
3}, {{27, 24, 22, 7, 26}, 4}, {{2, 29, 26, 23, 19},
1}, {{17, 23, 28, 5, 21}, 1}, {{6, 27, 20, 19, 17},
1}, {{9, 29, 17, 19, 30}, 1}, {{29, 15, 25, 7, 27},
3}, {{10, 28, 29, 27, 18}, 2}, {{28, 20, 17, 19, 26},
1}, {{22, 28, 18, 21, 5}, 3}, {{5, 13, 7, 25, 24},
1}, {{18, 10, 25, 30, 4}, 5}, {{1, 26, 12, 21, 17},
3}, {{27, 22, 8, 26, 1}, 2}, {{28, 11, 26, 21, 10},
1}, {{23, 24, 19, 27, 9}, 5}, {{27, 19, 20, 14, 22}, 4}}

Here you can see that it took up to 7 calls before RandomSample found a match. This is not that bad and for this problem it is probably a satisfactory solution. However, I tend to think in general terms when programming. In general terms, we could have a constraint that was very restrictive such that only a handful of values in the space we are sampling met the constraint. This would be bad because then RandomSample could be called many more times before in wandered onto a set that met the constraint.

After mulling over this for a day, another approach hit me. Why not generate every set that meets the constraint and then simply use RandomSample to select from that set. This solution has a potential problem of its own, in that the sample space might be huge! But let’s see how we do in this particular case.


constraint[l_List] :=
 Count[l, x_Integer /; x <= 12] <= 2 &&
  Count[l, x_Integer /; x >= 25] >= 1 &&
  Count[l, x_Integer /; Or @@ Divisible[x, {3, 4, 7}]] <= 3 &&
  Not[MatchQ[
    Sort[l], {___, x1_, y1_, ___, x2_, y2_, ___} /;
     x1 == y1 – 1 && (x2 == y2 – 1 || y1 == x2 – 1)]]

In[19]:= sampleSpace = Select[Subsets[Range[30], {5}], constraint];
Length[sampleSpace]
Out[20]= 54047

It took a few seconds to complete, but we see that the sample space is a manageable 54047 elements. Note, I tweaked the constraint function to simply return True or False so using it with Select is easier. Here Subsets is used to generate all subsets of the integers 1-30 of exactly length 5 (that is what {5} means – the {} is important without the curly’s it will generate all subsets of 5 items or less).

Now that we captured sampleSpace we can simply use RandomChoice to generate as many sets as we need and be guaranteed that each answer will meet the constraint.


In[22]:= RandomChoice[sampleSpace, 25]
Out[22]= {{11, 22, 24, 26, 28}, {2, 12, 19, 22, 30}, {2, 15, 19, 23,
25}, {3, 4, 21, 26, 29}, {8, 14, 23, 26, 29}, {6, 18, 23, 28,
29}, {8, 18, 19, 22, 26}, {2, 9, 23, 28, 29}, {9, 11, 16, 22,
28}, {9, 13, 15, 22, 30}, {6, 8, 13, 16, 26}, {11, 13, 15, 27,
28}, {2, 14, 18, 19, 27}, {2, 7, 26, 27, 30}, {3, 15, 17, 22,
29}, {3, 5, 13, 16, 30}, {2, 5, 18, 19, 28}, {1, 7, 21, 22, 26}, {1,
8, 18, 22, 26}, {10, 14, 16, 21, 26}, {3, 15, 21, 22, 29}, {2, 4,
20, 23, 25}, {2, 13, 16, 19, 25}, {11, 16, 19, 20, 28}, {2, 6, 14,
25, 26}}

Conclusion

Two viable solutions are presented to the problem of generating sets of random numbers subject to constraints. Which one is better depends on the particular parameters of your problem. For this particular problem, either is okay. For problems with a huge sample space, the first solution is better because finding a value should not take too many calls to RandomSample. For small sample spaces, the second technique is much better. This is a classic time/space trade-off and you’ll need to decide for yourself which technique suits the problem at hand.

Perhaps you have another approach? If so, I’d love to hear it!

Download Notebook

1. i – identity
2. v – rotation by 120 degrees
3. w – rotation by 240 degrees
4. x – flipping about the axis defined by bisecting the angle at point a
5. y – flipping about the axis defined by bisecting the angle at point b
6. z – flipping about the axis defined by bisecting the angle at point c

We can implement these transformations as Mathematica functions on the points that define the triangle.

Clear[a, b, c, i, v, w, x, y, z];

i[l : {p1_, p2_, p3_}] := l

v[l : {p1_, p2_, p3_}] := RotateRight[l, 1]

w[l : {p1_, p2_, p3_}] := RotateRight[l, 2]

x[{p1_, p2_, p3_}] := {p1, p3, p2}

y[{p1_, p2_, p3_}] := {p3, p2, p1}

z[{p1_, p2_, p3_}] := {p2, p1, p3}

Now we can visualize the behavior to verify these functions each result in an equilateral triangle of the same orientation.

Clear[draw];
draw[{a_, b_, c_}] :=
Graphics[{Pink, Opacity[0.5], Polygon[{a, b, c}], Opacity[1], Black,
Text[Style["A", Large, Bold], a], Text[Style["B", Large, Bold], b],
Text[Style["C", Large, Bold], c]}, Frame -> True, PlotRange -> All]
Manipulate[draw[f[eqtri]], {f, {i, v, w, x, y, z}}]


Download

Okay, that’s nice but what I really want to talk about now is the functional programming function known as Composition. In Chapter 2, Recipe 2.13 I discuss Composition and how it can be used with InverseFunction. Here I will discuss how it can be used to illustrate group theoretic concepts.

The 4 requirements of a mathematical group are:

1. Closure
2. Associativity
3. Identity
4. Inverse

Closure

Closure says that every composition of operations in the group must result in an operation that is in the group. We can test that the symetries of the equilateral triangle meet this criteria with the help of Composition.

Module[{test = {a, b, c}, operations = {i, w, v, x, y, z}},
TableForm[Table[Composition[f1, f2][test],
{f1, operations},
{f2, operations}] /. {i[test] -> i, v[test] -> v, w[test] -> w,
x[test] -> x, y[test] -> y, z[test] -> z},
TableHeadings -> {operations, operations}]]


Here I use Table to generate every possible composition of the operations we defined on the equilateral triangle {a,b,c}. I then use ReplaceAll (/.) to substitute the result of these compositions with the name of the operation matching on the result of applying each function by itself. If the operations were not closed under composition then I would have at least one entry in the table that was not an operation in our set. This is not the case so I demonstrate the operations are indeed closed and in the process create a table that illustrates every composition.

Associativity

Associativity says that for every operation o1, o2, o3, (o1 . o2) . o3 = o1 . (o2 . o3) where . means composition. We can test that as well.

In[29]:= Module[{test = {a, b, c}, operations = {i, w, v, x, y, z}},
And @@ Flatten[
Table[Composition[Composition[o1, o2], o3][test] ==
Composition[o1, Composition[o2, o3]][test],
{o1, operations},
{o2, operations},
{o3, operations}] ]]

Out[29]= True

This code uses Table to construct every possible composition of three operations by composing o1 and o2 first and then composing the result with o3 and verifying that is the same as composing o1 with the composition of o2 and o3. By Anding the results together we verify that each comparison evaluated to True.

Identity and Inverse

We included an identity operation i so there is nothing to verify there. Groups also require that every operation has an inverse. This means that o . Inverse[o] == i for every o. We can see that is the case by inspecting the table of compositions and verifying in that each column and each row has one and only one i. This confirms that an inverse exists and it is unique for every o.

Conclusion

When I first encountered Composition in Mathematica, I did not know what to make of it. It seemed to be of only theoretical utility. But, again and again I find neat applications. In fact, Composition was an integral element in my entry in the 2010 Mathematica one-liner competition. If you are interested in learning Group Theory you might try the above exercise on other groups. You can find some here, here or here. You probably want to stick with the finite ones!

Get the notebook code