Comparing the last output of a nested function with all the previous ones

Question

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}

Answer 1

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.

Answer 2

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.

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

Answer 3

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] &

Answer 4

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}

Answer 5

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}

Answer 6

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