9
$\begingroup$

Important note:

It's not hard to solve this problem, hence please explain how to use patterm matching instead of how to find the recurring period of a fraction.


We can easily extract real digits from a number, for example, $99/700$, using RealDigits[99/700, 10, 24][[1]] or so. The result is {1, 4, 1, 4, 2, 8, 5, 7, 1, 4, 2, 8, 5, 7, 1, 4, 2, 8, 5, 7, 1, 4, 2, 8}.

Now I would like to find out the recurring period which is {1,4,2,8,5,7}. This result is quite easy to get via this code: RealDigits[99/700, 10][[1, -1]].

Well, I tried to find out this period myself and practice my programming ability with pattern matching when I found out I cannot easily do this job via this code:

RealDigits[99/700, 10, 
   24][[1]] /. {Shortest[pre___, 2], 
    Longest[Repeated[Shortest[r__, 3], {2, Infinity}], 4], 
    Shortest[inc___, 1]} /; 
   MatchQ[{r}, {inc, __}] -> {{pre}, {r}, {inc}}

I think this code could generate a proper result as:

  1. Pattern matching will find out how to make the recurring range largest.

  2. Then it will try to make the recurring body shortest.

  3. After that it will ensure it leaves the least digits before the recurrence started.

  4. At the next priority, it shall keep the left overs shortest.

  5. Finally it will make sure that the left over shall be the starting part of the recurrence.

But in fact it gives out something like:

{{1, 4, 1, 4, 2, 8, 5}, {7, 1, 4, 2, 8, 5}, {7, 1, 4, 2, 8}}

Not that pleasant, still have place for improvements.

How to solve this problem? And furthermore, how can I throw away that {2,Infinity} in the Repeated and let the Shortest and Longest do the job? I think, theoretically, it's okay as Longest always find out the largest range while Shortest find out the smallest cycle. But I cannot think of a way to do this.

$\endgroup$
  • 1
    $\begingroup$ How would you plan to do with fractions like 123123123123123/10^24 + 1234/(10^28 - 1)? I think your problem cannot be solved purely using Shortest and Longest, because you need to check whether the last part (the incomplete recurring period) belongs to the sequence you found. $\endgroup$ – happy fish Jul 3 '16 at 6:56
  • $\begingroup$ Er, as I've said before, this is more like a toy problem. So I'm sure that this sequence has a recurring period after just a couple of digits. And, I think my code included the check about the left over of the sequence. I wrote /;MatchQ[{r},{inc,__}] to deal with it. $\endgroup$ – Wjx Jul 3 '16 at 8:10
  • $\begingroup$ Somewhat related: (43801) $\endgroup$ – Mr.Wizard Jul 31 '16 at 9:40
6
$\begingroup$

This problem can be solved very efficiently using string patterns:

str = ToString[FromDigits@RealDigits[99/700, 10, 24][[1]]];

AbsoluteTiming[StringReplace[str,
  StartOfString ~~
  pre : Shortest[DigitCharacter ...] ~~
  Repeated[rep : Shortest[DigitCharacter ..], {2, Infinity}] ~~
  inc : DigitCharacter ... ~~
  EndOfString /;
    StringMatchQ[rep, inc ~~ __] :> pre <> "(" <> rep <> ")" <> inc]]
{0.00488615, "14(142857)1428"}

Even million of digits takes lesser than 2 seconds to process:

str = ToString[FromDigits@RealDigits[99/700, 10, 1000000][[1]]];

AbsoluteTiming[StringReplace[str,
  StartOfString ~~
  pre : Shortest[DigitCharacter ...] ~~
  Repeated[rep : Shortest[DigitCharacter ..], {2, Infinity}] ~~
  inc : DigitCharacter ... ~~
  EndOfString /;
    StringMatchQ[rep, inc ~~ __] :> pre <> "(" <> rep <> ")" <> inc]]
{1.27581, "14(142857)14"}

What is important, addition of arbitrary integer part doesn't alter the period even if this integer part contains recurring sequence of numbers:

str = ToString[FromDigits@RealDigits[141414141414141414 + 99/700, 10, 1000][[1]]];

AbsoluteTiming[StringReplace[str,
  StartOfString ~~
  pre : Shortest[DigitCharacter ...] ~~
  Repeated[rep : Shortest[DigitCharacter ..], {2, Infinity}] ~~
  inc : DigitCharacter ... ~~
  EndOfString /;
    StringMatchQ[rep, inc ~~ __] :> pre <> "(" <> rep <> ")" <> inc]]
{0.049049, "14141414141414141414(142857)14"}

The crucial part here is pre : Shortest[DigitCharacter ...] which is converted internally to RegularExpression["(\\d*?)"] containing lazy quantifier *?. The algorithm behind this quantifier along with the Condition are what always gives us the optimal (not shifted) recurring period. By introducing pseudo-condition (Print[{pre, rep, inc}]; True) we can observe joint work of them both:

str = ToString[FromDigits@RealDigits[14 + 99/700, 10, 24][[1]]];

StringReplace[str,
  StartOfString ~~
  pre : Shortest[DigitCharacter ...] ~~
  Repeated[rep : Shortest[DigitCharacter ..], {2, Infinity}] ~~
  inc : DigitCharacter ... ~~
  EndOfString /;
    (Print[{pre, rep, inc}]; True) && StringMatchQ[rep, inc ~~ __] :> 
      pre <> "(" <> rep <> ")" <> inc];

{, 14, 285714285714285714}

{, 14, 14285714285714285714}

{1, 41, 4285714285714285714}

{14, 14, 285714285714285714}

{1414, 142857, 14}

From the above we can clearly see how the lazy quantifier *? works and what is the role of the Condition in rejecting inappropriate matches.

Note that the above condition StringMatchQ[rep, inc ~~ __] isn't sufficiently strict to provide the optimal period without the optimal searching algorithm. For example if we reverse the string and change the condition correspondingly, we get shifted period because now the leading pattern is inc : DigitCharacter ... and hence the search is performed in wrong order:

str = ToString[FromDigits@RealDigits[99/700, 10, 24][[1]]];

StringReplace[StringReverse@str,
  StartOfString ~~
  inc : DigitCharacter ... ~~
  Repeated[rep : Shortest[DigitCharacter ..], {2, Infinity}] ~~
  pre : Shortest[DigitCharacter ...] ~~
  EndOfString /;
    (Print[StringReverse /@ {pre, rep, inc}]; True) && StringMatchQ[rep, __ ~~ inc] :> 
      inc <> ")" <> rep <> "(" <> pre] // StringReverse;

{, 14, 28571428571428571428}

{14, 142857, 1428571428}

{141, 428571, 428571428}

{1414, 285714, 28571428}

{14142, 857142, 8571428}

{141428, 571428, 571428}

{1414285, 714285, 71428}

"1414285(714285)71428"

With a more rigorous condition StringMatchQ[rep, __ ~~ inc] && UnsameQ @@ StringTake[{pre, rep}, UpTo[1]] we get the optimal result despite the suboptimal searching algorithm:

StringReplace[StringReverse@str,
  StartOfString ~~
  inc : DigitCharacter ... ~~
  Repeated[rep : Shortest[DigitCharacter ..], {2, Infinity}] ~~
  pre : Shortest[DigitCharacter ...] ~~
  EndOfString /;
    StringMatchQ[rep, __ ~~ inc] && UnsameQ @@ StringTake[{pre, rep}, UpTo[1]] :> 
      inc <> ")" <> rep <> "(" <> pre] // StringReverse
"14(142857)1428"

It is worth to note that Mr.Wizard's elegant solution via the native Mathematica's patterns also can't process correctly the list in the reverse direction. In the following I essentially have changed only the condition in order to allow it to match the reversed list:

Reverse[RealDigits[99/700, 10, 24][[1]]] /. 
  {inc___, Repeated[rep__, {2, Infinity}], pre___} /; 
    MatchQ[{rep}, {__, inc}] :> Reverse /@ {{pre}, {rep}, {inc}}
{{1, 4, 1, 4, 2, 8, 5, 7, 1, 4, 2, 8}, {5, 7, 1, 4, 2, 8}, {}}

But it can be cured easily by wrapping pre___ with Shortest:

Reverse[RealDigits[99/700, 10, 24][[1]]] /. 
  {inc___, Repeated[rep__, {2, Infinity}], Shortest@pre___} /; 
   MatchQ[{rep}, {__, inc}] :> Reverse /@ {{pre}, {rep}, {inc}}
{{1, 4}, {1, 4, 2, 8, 5, 7}, {1, 4, 2, 8}}

This improved solution also works well with the original list:

RealDigits[99/700, 10, 24][[1]] /. 
  {Shortest@pre___, Repeated[rep__, {2, Infinity}], inc___} /; 
    MatchQ[{rep}, {inc, __}] :> {{pre}, {rep}, {inc}}
{{1, 4}, {1, 4, 2, 8, 5, 7}, {1, 4, 2, 8}}

Note that there is no way to cure the string pattern in order to allow it to process the string in the reverse direction the same way as in the forward direction. This illustrates the fundamental difference between string patterns (based on regular expressions) and native Mathematica's patterns. Although one should understand that (at least in the general case) the latter also work differently depending on the direction as can be seen from the following excerpt from the Documentation and proven using ReplaceList (as described here):

If several Shortest objects occur in the same expression, those that appear first are given higher priority to match shortest sequences.

$\endgroup$
  • 2
    $\begingroup$ Nice circumvention of the OP's opening paragraph. This is pattern-matching after all. :-) $\endgroup$ – Mr.Wizard Jul 31 '16 at 13:06
  • $\begingroup$ @Mr.Wizard I'm rather surprised that Mathematica's pattern matcher works so slowly in this case. Probably it isn't designed/optimized for such purposes at all? $\endgroup$ – Alexey Popkov Jul 31 '16 at 13:10
  • 1
    $\begingroup$ There are lots of cases where it is abysmally slow and I believe the explanation is the engine handling every test independently to allow for fringe cases like stateful conditions, which I just remarked upon today (121852). A much older post: (8522876) $\endgroup$ – Mr.Wizard Jul 31 '16 at 13:18
  • $\begingroup$ @Mr.Wizard This topic seems to be very subtle and little known. Admittedly I still don't fully understand what you mean by "stateful conditions" available with the Mathematica's patterns and not available with the string patterns (both support Condition after all!). Could you elaborate it? $\endgroup$ – Alexey Popkov Jul 31 '16 at 14:50
  • 2
    $\begingroup$ I am referring to this: (8485700) $\endgroup$ – Mr.Wizard Jul 31 '16 at 14:54
9
$\begingroup$

This is an extended comment, and should give an answer to your first question.

If you are fine with your current code style, I did find a setting of your priority of Shortest and Longest that gives you the expected result. So here they are:

RealDigits[99/700, 10, 24][[1]]/.{Shortest[pre___, 3], 
 Longest[Repeated[Shortest[rep__, 1], {2, Infinity}]], 
 Shortest[inc___, 2]} /; MatchQ[{rep}, {inc, __}] :> {{pre}, {rep}, {inc}}

In my experiments, I found that the priority of Shortest and Longest is not related, so the setting for Longest can be removed. If you are curious why I have this conclusion, here is the list of "full" parameters I found:

{{3, 1, 4, 2}, {4, 1, 2, 3}, {4, 1, 3, 2}, {4, 2, 1, 3}}

The third argument is for Longest, and clearly its priority does not matter.

Also, I think {2, Infinity} in your Repeat can't be omitted, otherwise the program tends to regard the whole sequence as the recurring period.

I didn't explore further into this problem or fully tested the settings, so I am not sure how well it can generalize.

$\endgroup$
  • $\begingroup$ So mainly you ommited the priority setting of Longest? but what priority will be get if there's no priority setting? 0? $\endgroup$ – Wjx Jul 3 '16 at 9:51
  • $\begingroup$ @Wjx Please see my edit. $\endgroup$ – happy fish Jul 3 '16 at 9:53
  • $\begingroup$ and, I can see from your profile that you're a Chinese as well? will you mind adding my wechat? $\endgroup$ – Wjx Jul 3 '16 at 9:54
  • $\begingroup$ but that's wierd, I suppose there'll be some situations where we need to specify the priority of both Shortest and Longest? $\endgroup$ – Wjx Jul 3 '16 at 9:56
  • $\begingroup$ @Wjx Of course. I updated my email in my profile, so we can exchange other more private contact via email. Regarding your question, I didn't think of a case that would cause conflict yet. $\endgroup$ – happy fish Jul 3 '16 at 10:05
4
$\begingroup$

Update: I managed to confuse myself with various combinations of Shortest and Longest. The plainest form of all seems to work just fine on my system (Mathematica 10.1 under Windows):

RealDigits[99/700, 10, 24][[1]] /.
  {pre___, Repeated[rep__, {2, Infinity}], inc___} /; 
    MatchQ[{rep}, {inc, __}] :> {{pre}, {rep}, {inc}} // AbsoluteTiming
{7.496, {{1, 4}, {1, 4, 2, 8, 5, 7}, {1, 4, 2, 8}}}

happy fish's code by comparison:

RealDigits[99/700, 10, 24][[1]] /. {Shortest[pre___, 3], 
  Longest[Repeated[Shortest[rep__, 1], {2, Infinity}]], Shortest[inc___, 2]} /; 
    MatchQ[{rep}, {inc, __}] :> {{pre}, {rep}, {inc}} // AbsoluteTiming
{8.5745, {{1, 4}, {1, 4, 2, 8, 5, 7}, {1, 4, 2, 8}}}
$\endgroup$
  • $\begingroup$ though I have enjoyed looking at all these answers, Mma/WL (whichever your preferred) RealDigits[99/700] reports the recurring pattern. $\endgroup$ – ubpdqn Aug 19 '16 at 7:35
  • $\begingroup$ @ubpdqn I am fairly certain that is not what the question is about however, but rather it was simply used as an arbitrary example for the actual question about pattern matching. $\endgroup$ – Mr.Wizard Aug 19 '16 at 7:59
  • $\begingroup$ ok I guess I am suggesting that the algorithm used in the case of argument in integers is very efficient (noting the times in your post). I am sorry for the misinterpretation...after dinner I might think about it... $\endgroup$ – ubpdqn Aug 19 '16 at 8:04
  • $\begingroup$ I did put my 2 cents worth in...I am off to dinner. I apologize for any misunderstanding and I have learned a lot from provided answers. :) $\endgroup$ – ubpdqn Aug 19 '16 at 8:29
1
$\begingroup$

I appreciate this is about pattern matching. I merely point out that Mathematica returns the desired recurring pattern with exact fractions.

I post this 'emulation' of long division as matching the same 'number' using NestWhileList and checking against all. This is how I would work the pattern in my head as a child. Sadly, my facility in this regard has significantly waned.

fun[n_, d_] :=
 Module[{lst = 
    NestWhileList[QuotientRemainder[10 #[[2]], d] &, 
     QuotientRemainder[n, d], UnsameQ, All], p},
  p = Position[lst, lst[[-1]]][[1, 1]];
  {lst[[1 ;; p - 1, 1]], lst[[p ;; -2, 1]]}
  ]

Tests:

test = {1/7, 1/23, 99/700, 1/17, 23/29};
Grid[{#, RealDigits[#], fun[Numerator@#, Denominator@#]} & /@ test, 
 Frame -> All]

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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