16
$\begingroup$

my main question is how I can compare the last output of a nested function with all the previous ones and stop iterating when I find a repeating value. (I have 2 other questions but I think they are so simple that they do not deserve a separate topic, so I'll post them here).

For example, let's say I want to see if a number is happy or not (I got the idea from a recent topic) and look at all the iterations. Here is the code I wrote

f = NestWhileList[Total @ (#^2 & @ IntegerDigits[#]) &, #, !(# == 1 || # == 4) &] &

for f@309 I get

{309, 90, 81, 65, 61, 37, 58, 89, 145, 42, 20, 4}

I wrote that code because I know that the list will eventually reach 1 or 4. What if I didn't? Let's say I know only that the list will reach a cycle, but the numbers can change. How can I compare the last iteration with all the others and stop when I find a number repeated? In this case the list should stop at

{309, 90, 81, 65, 61, 37, 58, 89, 145, 42, 20, 4, 16, 37}

because 37 is already there.

Subquestion 1.

f @ {309,21} don't work, I have to write f /@ {309,21}. I thought that pure functions were listable, like #^3 &, why is f not? Has it something to do with Nest?

Subquestion 2.

It's a little question about pure functions, what's the difference between f := #^2 & and f = #^2 &?

EDIT 2

Thank you for the answers, if someone is curious, here is a timing test on my computer. Naming

(* Leonid *)
f1[n_] := Module[{appeared}, appeared[_] = False;
   NestWhileList[Total[IntegerDigits[#]^2] &, 
    n, (! appeared[#] && (appeared[#] = True)) &]];
(* Belisarius/WReach *)
f2 = NestWhileList[Total@(#^2 &@IntegerDigits[#]) &, #, Unequal, 
    All] &;
(* j.Vincent *)
f3 = NestWhile[Append[#, Total@(#^2 &@IntegerDigits[#[[-1]]])] &, {#},
     Length[Union[#]] == Length[#] &] &;
f4 = Block[{continue}, (continue[a_] := (continue[a] = False; True);
     NestWhileList[Total@(#^2 &@IntegerDigits[#]) &, #, continue])] &;
(* image_doctor *)
f5 = FixedPoint[
    DeleteDuplicates@
      Append[#, Total@(#^2 &@IntegerDigits[#]) & @ Last[#]] &, {#}] &;
(* WReach *)
nestUntilCycle[f_, x_] := 
  Module[{fast = x, more = True}, 
   NestWhile[f, f@x, (fast = f@f@fast; # != fast) &]; 
   NestWhileList[(If[more, fast = f@fast]; f@#) &, 
    x, # != fast || more && (more = False; True) &]];
(* Mr.Wizard *)
f6 = Module[{in}, 
    in[x_] := (in[x] = "Exit"; Total[IntegerDigits[x]^2]);
    Most@NestWhileList[in, #, # =!= "Exit" &]] &;
f7 = NestWhileList[Total[IntegerDigits[#]^2] &, #, 
    Signature@{##} =!= 0 &, All] &;

I obtained

AbsoluteTiming[f1 /@ Range[1, 25000];]
AbsoluteTiming[f2 /@ Range[1, 25000];]
AbsoluteTiming[f3 /@ Range[1, 25000];]
AbsoluteTiming[f4 /@ Range[1, 25000];]
AbsoluteTiming[f5 /@ Range[1, 25000];]
AbsoluteTiming[nestUntilCycle[Total@(#^2 &@IntegerDigits[#]) &, #] & /@ Range[1,25000];]
AbsoluteTiming[f6 /@ Range[1, 25000];]
AbsoluteTiming[f7 /@ Range[1, 25000];]

{3.0888054, Null}
{1.7004030, Null}
{2.6676047, Null}
{2.5740045, Null}
{1.9500035, Null}
{5.6784099, Null}
{2.9640052, Null}
{2.6520046, Null}

Time was not an issue, I included it only for completeness. Note: as Leonid and others pointed out, in this case the differences are negligible, but with longer lists and cycles it is better to avoid methods with quadratic complexity.

Let's use the function proposed by Mr.Wizard and see what changes

f0 = Mod[# + 1, 2000] &;
(* Leonid *)
f1[n_] := Module[{appeared}, appeared[_] = False;
   NestWhileList[f0, n, (! appeared[#] && (appeared[#] = True)) &]];
(* Belisarius/WReach *)
f2 = NestWhileList[f0, #, Unequal, All] &;
(* j.Vincent *)
f3 = NestWhile[Append[#, f0[#[[-1]]]] &, {#}, 
    Length[Union[#]] == Length[#] &] &;
f4 = Block[{continue}, (continue[a_] := (continue[a] = False; True);
     NestWhileList[f0, #, continue])] &;
(* image_doctor *)
f5 = FixedPoint[DeleteDuplicates@Append[#, f0 @ Last[#]] &, {#}] &;
(* WReach *)
nestUntilCycle[f_, x_] := 
  Module[{fast = x, more = True}, 
   NestWhile[f, f@x, (fast = f@f@fast; # != fast) &]; 
   NestWhileList[(If[more, fast = f@fast]; f@#) &, 
    x, # != fast || more && (more = False; True) &]];
(* Mr.Wizard *)
f6 = Module[{in}, in[x_] := (in[x] = "Exit"; f0[x]);
    Most@NestWhileList[in, #, # =!= "Exit" &]] &;
f7 = NestWhileList[f0, #, Signature@{##} =!= 0 &, All] &;  

On my pc

AbsoluteTiming[f1@ 0;]
AbsoluteTiming[f2@ 0;]
AbsoluteTiming[f3@ 0;]
AbsoluteTiming[f4@ 0;]
AbsoluteTiming[f5@ 0;]
AbsoluteTiming[nestUntilCycle[f0, #] & @0;]
AbsoluteTiming[f6@ 0;]
AbsoluteTiming[f7@ 0;]

{0.0110007, Null}
{17.0559755, Null}
{0.0940053, Null}
{0.0080004, Null}
{0.0160010, Null}
{0.0150008, Null}
{0.0100006, Null}
{0.3420196, Null}

Calling out f2 and trying with f0 = Mod[# + 1, 20000] & these are the results

{0.1140065, Null}
{8.9305108, Null}
{0.0840048, Null}
{0.9790560, Null}
{0.1470084, Null}
{0.1040060, Null}
{55.5261759, Null}
$\endgroup$
13
  • $\begingroup$ I think that that question you mentioned provides good solutions to the problem (particularly one by @Rojo). If you insist on NestWhile(List), my solution there uses it. The problem with currently posted answers based on Append is that Append-based accumulation method has a quadratic complexity in the size of the iteration results, and that sort or destroys the purpose of NestWhile(List). $\endgroup$ Jul 18, 2012 at 13:03
  • $\begingroup$ Yeah, in fact I used your function in the edit, with Module instead of Block, but I still don't get it. When does appeard[] change to True? $\endgroup$
    – Jane T.
    Jul 18, 2012 at 14:17
  • $\begingroup$ @LeonidShifrin isn't the quadratic scaling actually required in this case? I mean you wouldn't be able to carry out calculations based on the past inputs to the function unless you somehow pass them along. $\endgroup$
    – jVincent
    Jul 18, 2012 at 14:48
  • $\begingroup$ @jVincent That depends. You can, for example, store those in a hash table (like I did, in a way), linked list, some tree, etc. Storing them in a linked list, for instance (which has constant time to add a new element to the end) will replace the problem of efficient inserts to one of efficient access. If it happens that full random access is not needed at each step, one can win big. But generally, I feel that for such problems the general NestWhile abstraction is just not very good, and using data structures optimal for a particular problem (lists, hashes, trees, etc) may be better. $\endgroup$ Jul 18, 2012 at 15:16
  • 1
    $\begingroup$ @jVincent See my comment to JaneT - my function is only slower because the lists produced by complete iterations are never large for this problem, and symbolic Mathematica overhead hides the complexity for small lists. I was just making a general comment that for this type of problems, the right solution / choice of data structures hugely depends on the access pattern. If you need full random access at every step of the iteration, then yes, there is no way around quadratic complexity. But most problems are not like that, and this one in particular isn't (Rojo's solution and others show that). $\endgroup$ Jul 18, 2012 at 15:35

6 Answers 6

10
$\begingroup$

If you only want to compare the output of the function consider just passing along a list as the input to the function, while only operating on the last element. That way each iteration of the function has access to the complete history and the condition as well. Here is an implimentation striving to be as close to your code as possible.

f=NestWhile[Append[#, Total@(#^2 &@IntegerDigits[#[[-1]]])] &, {#},
 Length[Union[#]] == Length[#] &] &;
f@309
   {309, 90, 81, 65, 61, 37, 58, 89, 145, 42, 20, 4, 16, 37}

Since the passed parameter is now the entire list, you still get the outputs from all iterations in the end.

Subquestion 1.

Pure functions are not listable, consider the problem that would arise from a pure function given as:

 #[[1]]^2+#[[2]]^2&@{1,2}

If it was listable per default, this would lead to an error saying that 1[[1]] does not exist. the reason #^3& seems listable is because power is Listable.

Attributes[Power]

{Listable, NumericFunction, OneIdentity, Protected}

SubQuestion 2.

Firstly remember that you are not just giving a pure function a name, you are assigning a pure function to a symbol using Set and SetDelayed the difference is in when the pure function is evaluated. Set evaluates once immediately, while SetDelayed will evaluate each time the symbol is used. An example of this difference is given in the code below:

n = 2;
f1 = Evaluate[#^n] &;
f2 := Evaluate[#^n] &;
n = 3;
f1@2
f2@2
4
8

Underling the aspect of SetDelayed[] that it is reevaluated whenever it is called. Though Evaluate is needed to force evaluation of n at the time of setting.

Additional method

After some discussion with Leonid Shifrin, who's insightfully pointed out that the scaling on this code is very bad for large number of iterations due to the cost associated with appending in each iteration, I went ahead and wrote a version of his code with wins the timing contest on my setup:

f4=Block[{continue},
(continue[a_]:=(continue[a]=False;True);
NestWhileList[Total@(#^2&@IntegerDigits[#])&,#,continue])
]&;

AbsoluteTiming[# /@ Range[1, 25000];][[1]]&/@{f1,f2,f3,f4}(*f1-3 are defined in the question*)

{3.5937500, 3.6093750, 2.9687500, 2.9218750}

Though it's only bairly faster, it should scale much better for arbitrary testing functions. I believe the difference in timing is due to Block vs. Module, though it also avoids some Boolean operations.

$\endgroup$
3
  • $\begingroup$ Good answers, thank you very much. So, for practical purposes, f := #^2 & and f = #^2 & are the same, since there is nothing that can change in successive evaluation (like n in your example)... am I right? $\endgroup$
    – Jane T.
    Jul 18, 2012 at 14:21
  • $\begingroup$ @Jane T. I would suspect that unless Mathematica knows to optimize away the repeated calls to the definition that f:=#^2& would be unnecessarily slower. On my system the timings when calling Table[f@i, {i, 10^6}] are 1.25 for f=#^2& and 1.45 for f:=#^2&, so while there is no difference in the results it appears that there is a difference in the way you arrive at the results. I would suggest always using set in cases such as this where the definition isn't supposed to be reevaluated at every call. $\endgroup$
    – jVincent
    Jul 18, 2012 at 14:37
  • $\begingroup$ Compare your timings with the solution suggested by @WReach in the comments under my question f5 = NestWhileList[f0, #, Unequal, All] &; (30% faster) $\endgroup$ Jul 19, 2012 at 0:21
15
$\begingroup$

There is an old trick used by many LISP implementations to deal with circular lists. That trick is based upon Floyd's cycle-finding algorithm and could be adapted to the task at hand.

Here is nestUntilCycle, a function similar to Nest except that it stops when it detects a value that has been seen before:

nestUntilCycle[f_, x_] :=
  Module[{fast = x, more = True}
  , NestWhile[f, f @ x, (fast = f @ f @ fast; # != fast) &]
  ; NestWhileList[
      (If[more, fast = f @ fast]; f @ #) &
    , x
    , # != fast || more && (more = False; True) &
    ]
  ]

This implementation is less self-evident than some of the other answers to this question (for me, at least), but it has the advantage that it runs in near linear time and uses a constant amount of additional working storage. In particular, it neither searches through all the predecessors of each value (quadratic run-time), nor does it keep any auxiliary memoization data or hash tables.

Following Floyd, the function examines the generated sequence of values by means of two "pointers", a "slow" pointer that visits every value and a "fast" pointer that only visits every second value. If the sequence contains a cycle, then the fast pointer must eventually land on the same element as the slow pointer. After that, some tricky sequence traversals can identify both the lead-in to the cycle and the cycle itself. See the Wikipedia reference for the niggly details. If the sequence does not contain a cycle, then the CPU will get hot but no result will ever be generated. It is left as an exercise to the reader to add other Nest-like features such as an optional iteration limit count to handle non-cyclic sequences.

Note that this implementation will only work for functions in the mathematical sense: functions that generate exactly one result for any given input.

We can use the "happy number" computation to test out nestUntilCycle:

h[n_] := IntegerDigits[n] ^ 2 // Total

nestUntilCycle[h, 1]
(* {1, 1} *)

nestUntilCycle[h, 4]
(* {4, 16, 37, 58, 89, 145, 42, 20, 4} *)

nestUntilCycle[h, 61]
(* {61, 37, 58, 89, 145, 42, 20, 4, 16, 37} *)

nestUntilCycle[h, 309]
(* {309, 90, 81, 65, 61, 37, 58, 89, 145, 42, 20, 4, 16, 37} *)

Visualization

The code below creates a crude visualization of nestUntilCycle in operation. One can press the Step button repeatedly to watch how the "slow" and "fast" pointers progress through the sequence and how the result is built up.

Visualization Screenshot

The code requires the definitions of nestUntilCycle and h from above.

DynamicModule[{start, graph, draw, vertex, state, ptr, step, phase, reset}
, start = 309
; graph = Rule @@@ Partition[nestUntilCycle[h, start], 2, 1]
; reset[] := state = {1, h @ start, h @ h @ start, {}}
; vertex[pos_, n_] :=
    Inset[
      Column[
        { ptr["slow", n, state[[2]]]
        , Framed[n, Background -> LightYellow]
        , ptr["fast", n, state[[3]]]
        }
      ]
    , pos
    ]
; ptr[label_, a_, a_] := Style[label, {Bold, Larger}]
; ptr[_, _, _] := ""
; step[{1, n_, n_, r_}] := {2, start, n, r}
; step[{1, slow_, fast_, r_}] := {1, h @ slow, h @ h @ fast, r}
; step[{2, slow_, fast_, r_}] := {3, slow, fast, {start}}
; step[{3, n_, n_, {r__}}] := {4, h @ n, n, {r, h @ n}}
; step[{3, slow_, fast_, {r__}}] := {3, h @ slow, h @ fast, {r, h @ slow}}
; step[{4, n_, n_, r_}] := {5, n, n, r}
; step[{4, slow_, fast_, {r__}}] := {4, h @ slow, fast, {r, h @ slow}}
; step[{5, ___}] := reset[]
; phase[{1, n_, n_, _}] := Style["NestWhile loop: slow and fast coincide: cycle found!", Red]
; phase[{1, _, _, _}] := "NestWhile loop: slow advances by 1 value each step, fast advances by 2"
; phase[{2, _, _, _}] := Style["Transitioning to NestWhileListLoop: slow is reset to the start", Red]
; phase[{3, n_, n_, _}] := Style["NestWhileListLoop: slow and fast pointers coincide: cycle start has been found", Red]
; phase[{3, _, _, _}] := "NestWhileListLoop: slow and fast both advance by 1 value each step"
; phase[{4, n_, n_, _}] := Style["NestWhileListLoop: slow and fast coincide: the end of the cycle has been found", Red]
; phase[{4, _, _, _}] := "NestWhileListLoop (more = False): slow (only) traverses the cycle one by one"
; phase[{5, _, _, _}] := Style["DONE!", Red]
; draw[_] :=
    Column[
      { GraphPlot[
          graph
        , VertexRenderingFunction -> vertex
        , DirectedEdges -> True
        , ImageSize -> Full
        ]
      , Row[{Button["Step", state = step[state], ImageSize -> Automatic], phase[state]}, "  "]
      , Row[{"Result So Far: ", Last @ state}]
      }
    , Alignment -> Left
    ]
; reset[]
; Dynamic[draw[state], TrackedSymbols :> {state}]
]
$\endgroup$
10
  • $\begingroup$ Big +1, this is just brilliant. I feel ashamed since I knew about the pointer trick for loop detection, and yet this did not come to my mind in this context. It took me some time to understand the details of your implementation. The key point you could have mentioned is that n==L-m mod L, where n is the number of initial steps before we enter the loop, L is the length of the loop, and m is the position where fast ends up after your first NestWhile, counted from the start of the loop (I did not bother to read Wikipedia article, perhaps it is there). $\endgroup$ Jul 18, 2012 at 20:35
  • $\begingroup$ @Leonid Thanks for the feedback. Instead of trying to explain the slow and fast pointer movement in words, I elected to draw a dynamic picture instead. Please see the new Visualization section. $\endgroup$
    – WReach
    Jul 18, 2012 at 23:46
  • $\begingroup$ I've seen this method used without explanation on Project Euler. Thanks for drawing pretty pictures so I finally understand it. +1 $\endgroup$
    – Mr.Wizard
    Jul 19, 2012 at 1:59
  • $\begingroup$ For fast functions with long cycles this is a killer method. However for somewhat slower functions it is slow; do you know if it is possible to modify this method to use some caching to reduce the number of function applications before a cycle is detected? In other words a hybrid method? $\endgroup$
    – Mr.Wizard
    Jul 19, 2012 at 2:45
  • $\begingroup$ @Mr.Wizard Given that we are building a list of the full cyclic sequence, we could retain the values visited by the "slow" pointer on the first pass instead of discarding them and recalculating like nestUntilCycle does. Of course, the more elements we retain, the closer we get to simple memoization. Memoization is what I would almost certainly use in "real life". Memoization had already been mentioned in the edited question, but I threw this solution into the mix because all prior solutions needed quadratic time or linear space (linear space is moot, given the result list). $\endgroup$
    – WReach
    Jul 19, 2012 at 3:30
12
$\begingroup$
f0 = Total@(#^2 &@IntegerDigits[#]) &; (* Your Function *)
f = NestWhileList[f0, #, ! MemberQ[Most@{##}, Last@{##}] &, All] &
f@309

{309, 90, 81, 65, 61, 37, 58, 89, 145, 42, 20, 4, 16, 37}

Edit

The suggestion made in a comment by @WReach is elegant and improves the performance by a factor of 2.

 f = NestWhileList[f0, #, Unequal, All] &
$\endgroup$
9
  • 1
    $\begingroup$ Nice, in my attemps I used ## and Last[##] forgetting the {}. $\endgroup$
    – Jane T.
    Jul 18, 2012 at 14:19
  • $\begingroup$ @JaneT. Yours is a common mistake. The arguments are provided as a Sequence[]. Always remember you can make up the test part as (Print@##;If[...])& to see what your arguments really are. $\endgroup$ Jul 18, 2012 at 14:21
  • $\begingroup$ I will remember it, thank you. $\endgroup$
    – Jane T.
    Jul 18, 2012 at 14:27
  • 4
    $\begingroup$ +1 f could be expressed more simply thus: f = NestWhileList[f0, #, Unequal, All] & $\endgroup$
    – WReach
    Jul 18, 2012 at 16:47
  • 1
    $\begingroup$ Or, alternatively, NestWhileList[Total@(#^2 &@IntegerDigits[#]) &, #, UnsameQ, All] & @ 309 $\endgroup$
    – user1066
    Jul 19, 2012 at 4:19
9
$\begingroup$

I haven't worked through the other answers yet, and it appears WReach may have provided the definitive method. Nevertheless, here are a couple of straightforward ones.

Hash table with redefinition

f =
 Module[{in},
   in[x_] := (in[x] = "Exit"; Total[IntegerDigits[x]^2]);
   Most@NestWhileList[in, #, # =!= "Exit" &]
 ] &;

f @ 309
{309, 90, 81, 65, 61, 37, 58, 89, 145, 42, 20, 4, 16, 37}

Signature

f2 =
  NestWhileList[
    Total[IntegerDigits[#]^2] &,
    #, Signature@{##} =!= 0 &, All
  ] &;

f2 @ 417
{417, 66, 72, 53, 34, 25, 29, 85, 89, 145, 42, 20, 4, 16, 37, 58, 89}

While the method with Unequal (from WReach, posted by belisarius) is elegant, it is horrendously inefficient on longer cycles. Signature is faster, and the hash table is much faster still.

f0 = Mod[# + 1, 2000] &;

NestWhileList[f0, 0, Unequal, All] // Timing // First

NestWhileList[f0, 0, Signature@{##} =!= 0 &, All] // Timing // First

Module[{in},
  in[x_] := (in[x] = "Exit"; f0[x]);
  Most@NestWhileList[in, 0, # =!= "Exit" &]
] // Timing // First

15.506

0.2496

0.005616


Since it is fun to turn this into a speed competition here is my next entry:

f3 =
  Block[{hash, test},
    hash = System`Utilities`HashTable[];
    test = System`Utilities`HashTableAdd[hash, #] === Null &;
    NestWhileList[#, #2, test] // Quiet
  ] &;

f3[Mod[# + 1, 1*^6] &, 0] // Length // Timing

{1.763, 1000001}

$\endgroup$
2
  • $\begingroup$ Very fast indeed, thank you for the examples. $\endgroup$
    – Jane T.
    Jul 19, 2012 at 8:06
  • $\begingroup$ @Jane I added another method for you to try. Thanks for doing the speed testing; it makes this fun. :-) $\endgroup$
    – Mr.Wizard
    Jul 19, 2012 at 19:59
5
$\begingroup$

This doesn't quite strictly meet the specifications of the original question, but its close and offers slightly different approach which might be appropriate in some circumstances.

Borrowing from Belisarius's answer:

f10 = Total@(#^2 &@IntegerDigits[#]) &;

f11 = DeleteDuplicates@Append[#, f10[Last@#]] &

FixedPoint[f11, {309}]

{309, 90, 81, 65, 61, 37, 58, 89, 145, 42, 20, 4, 16}

As you can see it omits the last, repeated, element of the list but does terminate when a duplicate is detected and utilises FixedPoint in place of NestWhile.

Timings were as follows:

AbsoluteTiming[f1 /@ Range[1, 25000];]
AbsoluteTiming[f2 /@ Range[1, 25000];]
AbsoluteTiming[f3 /@ Range[1, 25000];]
AbsoluteTiming[FixedPoint[f11, {#}] & /@ Range[1, 25000];]

{1.824699, Null}

{1.602500, Null}

{1.513778, Null}

{1.247677, Null}

$\endgroup$
3
$\begingroup$

Ugly but answers the first question :

ugly = NestWhileList[{Append[#[[1]], #[[2]]], Function[x, Total[(#^2 & /@ IntegerDigits[x])]][#[[2]]]} &, {{}, 309}, ! MemberQ[#[[1]], #[[2]]] &] ;

ugly[[All, 2]]

(* {309,90,81,65,61,37,58,89,145,42,20,4,16,37} *)
$\endgroup$
0

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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