How to find the circulating fraction by pattern matching?

Question

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.

Answer 1

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.

Answer 2

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.

Answer 3

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}}}

Answer 4

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]