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

front end - keyboard shortcut to invoke Insert new matrix

I frequently need to type in some matrices, and the menu command Insert > Table/Matrix > New... allows matrices with lines drawn between columns and rows, which is very helpful. I would like to make a keyboard shortcut for it, but cannot find the relevant frontend token command (4209405) for it. Since the FullForm[] and InputForm[] of matrices with lines drawn between rows and columns is the same as those without lines, it's hard to do this via 3rd party system-wide text expanders (e.g. autohotkey or atext on mac). How does one assign a keyboard shortcut for the menu item Insert > Table/Matrix > New... , preferably using only mathematica? Thanks! Answer In the MenuSetup.tr (for linux located in the $InstallationDirectory/SystemFiles/FrontEnd/TextResources/X/ directory), I changed the line MenuItem["&New...", "CreateGridBoxDialog"] to read MenuItem["&New...", "CreateGridBoxDialog", MenuKey["m", Modifiers-...
Post a Comment
Read more

How to thread a list

I have data in format data = {{a1, a2}, {b1, b2}, {c1, c2}, {d1, d2}} Tableform: I want to thread it to : tdata = {{{a1, b1}, {a2, b2}}, {{a1, c1}, {a2, c2}}, {{a1, d1}, {a2, d2}}} Tableform: And I would like to do better then pseudofunction[n_] := Transpose[{data2[[1]], data2[[n]]}]; SetAttributes[pseudofunction, Listable]; Range[2, 4] // pseudofunction Here is my benchmark data, where data3 is normal sample of real data. data3 = Drop[ExcelWorkBook[[Column1 ;; Column4]], None, 1]; data2 = {a #, b #, c #, d #} & /@ Range[1, 10^5]; data = RandomReal[{0, 1}, {10^6, 4}]; Here is my benchmark code kptnw[list_] := Transpose[{Table[First@#, {Length@# - 1}], Rest@#}, {3, 1, 2}] &@list kptnw2[list_] := Transpose[{ConstantArray[First@#, Length@# - 1], Rest@#}, {3, 1, 2}] &@list OleksandrR[list_] := Flatten[Outer[List, List@First[list], Rest[list], 1], {{2}, {1, 4}}] paradox2[list_] := Partition[Riffle[list[[1]], #], 2] & /@ Drop[list, 1] RM[list_] := FoldList[Transpose[{First@li...
Post a Comment
Read more

functions - Get leading series expansion term?

Given a function f[x] , I would like to have a function leadingSeries that returns just the leading term in the series around x=0 . For example: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x)] x and leadingSeries[(1/x + 2 + (1 - 1/x^3)/4)/(4 + x)] -(1/(16 x^3)) Is there such a function in Mathematica? Or maybe one can implement it efficiently? EDIT I finally went with the following implementation, based on Carl Woll 's answer: lds[ex_,x_]:=( (ex/.x->(x+O[x]^2))/.SeriesData[U_,Z_,L_List,Mi_,Ma_,De_]:>SeriesData[U,Z,{L[[1]]},Mi,Mi+1,De]//Quiet//Normal) The advantage is, that this one also properly works with functions whose leading term is a constant: lds[Exp[x],x] 1 Answer Update 1 Updated to eliminate SeriesData and to not return additional terms Perhaps you could use: leadingSeries[expr_, x_] := Normal[expr /. x->(x+O[x]^2) /. a_List :> Take[a, 1]] Then for your examples: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x), x] leadingSeries[Exp[x], x] leadingSeries[(1/x + 2 + (1 - 1/x...
Post a Comment
Read more