Skip to main content

list manipulation - How to find the circulating fraction by pattern matching?


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



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.



Comments

Post a Comment

Popular posts from this blog

plotting - Filling between two spheres in SphericalPlot3D

Manipulate[ SphericalPlot3D[{1, 2 - n}, {θ, 0, Pi}, {ϕ, 0, 1.5 Pi}, Mesh -> None, PlotPoints -> 15, PlotRange -> {-2.2, 2.2}], {n, 0, 1}] I cant' seem to be able to make a filling between two spheres. I've already tried the obvious Filling -> {1 -> {2}} but Mathematica doesn't seem to like that option. Is there any easy way around this or ... Answer There is no built-in filling in SphericalPlot3D . One option is to use ParametricPlot3D to draw the surfaces between the two shells: Manipulate[ Show[SphericalPlot3D[{1, 2 - n}, {θ, 0, Pi}, {ϕ, 0, 1.5 Pi}, PlotPoints -> 15, PlotRange -> {-2.2, 2.2}], ParametricPlot3D[{ r {Sin[t] Cos[1.5 Pi], Sin[t] Sin[1.5 Pi], Cos[t]}, r {Sin[t] Cos[0 Pi], Sin[t] Sin[0 Pi], Cos[t]}}, {r, 1, 2 - n}, {t, 0, Pi}, PlotStyle -> Yellow, Mesh -> {2, 15}]], {n, 0, 1}]
Post a Comment
Read more

plotting - Plot 4D data with color as 4th dimension

I have a list of 4D data (x position, y position, amplitude, wavelength). I want to plot x, y, and amplitude on a 3D plot and have the color of the points correspond to the wavelength. I have seen many examples using functions to define color but my wavelength cannot be expressed by an analytic function. Is there a simple way to do this? Answer Here a another possible way to visualize 4D data: data = Flatten[Table[{x, y, x^2 + y^2, Sin[x - y]}, {x, -Pi, Pi,Pi/10}, {y,-Pi,Pi, Pi/10}], 1]; You can use the function Point along with VertexColors . Now the points are places using the first three elements and the color is determined by the fourth. In this case I used Hue, but you can use whatever you prefer. Graphics3D[ Point[data[[All, 1 ;; 3]], VertexColors -> Hue /@ data[[All, 4]]], Axes -> True, BoxRatios -> {1, 1, 1/GoldenRatio}]
Post a Comment
Read more

plotting - Adding a thick curve to a regionplot

Suppose we have the following simple RegionPlot: f[x_] := 1 - x^2 g[x_] := 1 - 0.5 x^2 RegionPlot[{y < f[x], f[x] < y < g[x], y > g[x]}, {x, 0, 2}, {y, 0, 2}] Now I'm trying to change the curve defined by $y=g[x]$ into a thick black curve, while leaving all other boundaries in the plot unchanged. I've tried adding the region $y=g[x]$ and playing with the plotstyle, which didn't work, and I've tried BoundaryStyle, which changed all the boundaries in the plot. Now I'm kinda out of ideas... Any help would be appreciated! Answer With f[x_] := 1 - x^2 g[x_] := 1 - 0.5 x^2 You can use Epilog to add the thick line: RegionPlot[{y < f[x], f[x] < y < g[x], y > g[x]}, {x, 0, 2}, {y, 0, 2}, PlotPoints -> 50, Epilog -> (Plot[g[x], {x, 0, 2}, PlotStyle -> {Black, Thick}][[1]]), PlotStyle -> {Directive[Yellow, Opacity[0.4]], Directive[Pink, Opacity[0.4]],
Post a Comment
Read more