Message Boards Message Boards

GROUPS:

[Numberphile] James ❤️ A Card Trick Simulation

Posted 1 year ago
4486 Views
|
5 Replies
|
22 Total Likes
|

Please download the notebook at the end of the discussion including dynamic feature


simulation

July 4th is a fabulous holiday season for American families to enjoy the summer with road trip and BBQ party. You can use a deck of poker to entertain your kids and family friends with James Grime's new card trick on Numberphile.

Background

You are given $10$ cards, from Ace to 10. Shuffle them and split them into $2$ rows with five cards in each. Sort one row in ascending order, the other in descending order. Both orders are oriented from left to right. Calculate the absolute values of the difference between two rows and add them up. You can play the poker game multiple times and you will find the sum is always $25$. If you do not have poker at hand, please take a look at the animation above.

Code

Let's work on the problem with Mathematica to help us understand. In the code I use the icons from this website:

$icon="https://www.iconfinder.com/icons/1331558/card_game_diamond_gambling_game_jewelry_poker_sport_icon";

then I directly assign them to spade and diamond in a notebook:

spadediamond

Use Framed to create a nice and simple poker card:

cardpicture1[{suit_, val_}] := Framed[Column[{val, suit}, Center, 0, ItemSize -> {6, 2}, 
   ItemStyle -> Directive[24, "Label", Bold]], RoundingRadius -> 8]

poker

Use Map to create a list of poker cards:

n=10;
numbers = Range[n];
pokers1 = AssociationMap[cardpicture1[{spade, #}] &, numbers];
differences = AssociationMap[cardpicture1[{diamond, #}] &, numbers];

Now lets shuffle the deck of 10 cards:

shuffle=Permute[numbers,RandomPermutation[10]]
(* {3,6,7,5,9,10,8,4,1,2} *)

I use this generic permutation method because you can replace numbers with other list like 10 prime numbers.

Then split it into two rows

{row1,row2}={#[[1;;n/2]],#[[n/2+1;;]]}&[shuffle]
(* {{3,6,7,5,9},{10,8,4,1,2}} *)
Style[Grid[Map[pokers1, {row1, row2}, {2}]], ImageSizeMultipliers -> {1, 1}]

deck

The last two steps are to sort two rows and find the sum of the absolute values of the pairwise differences between the two rows. I use Grid an Style to make the output neat.

With[{r1=Sort@row1,r2=Sort[row2,Greater]},
    Module[{sum},sum=Inactive[Plus]@@Abs[r2-r1];
        Style[Grid[{
            pokers1/@r1,
            pokers1/@r2,
            (differences/@Abs[r2-r1]),
            {Null,SpanFromLeft},
            {Style[Row@{sum," = ",Activate[sum]},Large,Italic],SpanFromLeft}}],
        ImageSizeMultipliers->{1, 1}]
    ]
]

sorteddeck

Proof

You might already notice I have variables like pokers1 and cardpicture1 in the code above. I am definitely hiding from something from you.

The companion pokers I have, namely pokers2, is a deck of super power cards of which the styles get updated given the face value greater than $5$:

pokers2 = AssociationMap[cardpicture2[{spade, #}] &, numbers];

where

cardpicture2[{suit_, val_}] := 
 Framed[Column[{val, suit}, Center, 0, ItemSize -> {6, 2}, 
   ItemStyle -> Directive[24, "Label", Bold]], 
  FrameStyle -> Directive[If[val > 5, Dashed, Black]],
  RoundingRadius -> 8]

Once we use the super power card, we can see a pattern matches exactly what James claimed in the Numberphile video (using contradiction of stacking dashed/purple numbered card):

hint

Lets take look at one frame:

direction

The third diamond line is from the following flipping transition (dash-solid or purple-black)

transition

$ 25 = 7 + 3 + 2 + 5 + 8$

$ = (10 - 3) + (8 - 5 ) + (6 - 4 )+ (7 - 2 ) + (9 - 1) $

$= (10 + 9 + 8 + 7 + 6) -(1 + 2 + 3 + 4 + 5)$

The sorted rows tells you that all dashed card must sit together. Same happens to the solid line cards. Therefore there is exactly one transition from solid -> dash or dash -> solid in each row.

If dashed cards overlapping vertically means we either have at least 6 such cards or one row is not properly sorted. This is contradiction.

Comment

There are nice functions used here

  • Use Inactive[Plus]@@{...} and then to active the sum expression with Activate[]: prints nice hold sum formula and delayed evaluation
  • AssociationMap to create key-poker face dictionary
  • Animation is generated by Refresh. Attached at the end of the thread.
  • Poker design code is from this demonstration

Code snippet just for the calculation (minimum visualization):

n = 12;
{row1, row2} = {#[[1 ;; n/2]], #[[n/2 + 1 ;;]]} &[Permute[Range[n], RandomPermutation[n]]]
f[m_] := If[m > n/2, Framed[m], m]
{Grid[{row1,row2}],Sequence@@With[{r1=Sort@row1,r2=Reverse@Sort@row2},{Grid[Map[f,{r1,r2},{2}]],Abs[r1-r2]//Total}]}

shortcode

Formula:

Sum[k, {k, 2*m}] - 2*Sum[k, {k, m}] // Simplify 
(* m^2 *)
Attachments:
5 Replies

enter image description here - Congratulations! This post is now featured in our Staff Pick column as distinguished by a badge on your profile of a Featured Contributor! Thank you, keep it coming, and consider contributing your work to the The Notebook Archive!

If you want fancier playing card graphics,you could also use... https://resources.wolframcloud.com/FunctionRepository/resources/PlayingCardGraphic

Jon,

These resource function is amazing! Very beautiful animation can be generated with your code.

Thanks

poker

Very informative thank you, Shenghui

Eleazar

Thanks for sharing! Very nice!

Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract