Check if list is singleton in sub linear time

Question

A singleton is a list whose elements are equal. Some ways of checking this in Mathematica:

{Equal@@#&,
 1==Length@Union@#&,
 MatchQ[#,{x_ ..}]&}

I started benchmarking:

Table[First@RepeatedTiming[#@RandomInteger[{-10,10},n]]&/@%1,{n,100}]
Table[First@RepeatedTiming[#@RandomInteger[{-10,10},10^n]]&/@%1,{n,6}]

Plotting the transposes of these lists yields

That's disappointing. Clearly none of these functions terminated early after seeing an inequality between a single pair of elements. I've tried a few other functions, the most promising being

If[Null===Do[If[#[[i]]==#[[i+1]],Return@0],{i,Length@#-1}],True,False]&

It does slightly worse than MatchQ; its running time scales with input too

All SingletonQ functions are $O(n)$. Is it possible to write a SingletonQ which is $\Omega(n)$? Or perhaps there is always a linear cost associated with array passing conventions, and a specially allocated array is needed to achieve a constant time function (for a list whose first two elements are unequal; for a uniformly i.i.d. list I believe the running time should mimick $\log_kn$ where $k$ is the sample size for each element, which would be satisfactory to see implemented).

For the curious, here's the four functions evaluated on lists of size 100000Range@10

Interestingly, last two are rougly (in ratio, asymptotically) equivalent in running time.

Answer 1

The test for singletons:

# == RotateLeft[#] &

@Daniel's setup:

ll1 = RandomInteger[{-10, 10}, nn = 10^6];
ll2 = ConstantArray[10, nn];
ll3 = ll2;
ll3[[2]] = -10;
ll4 = ll2;
ll4[[-1]] = -10;
ll5 = ll2;
ll5[[Ceiling[nn/2]]] = -10;

Timing

Map[AbsoluteTiming[# == RotateLeft[#]] &, {ll1, ll2, ll3, ll4, ll5}]
(*
  {{0.012303, False}, {0.001629, True}, {0.000892, False},
   {0.001699, False}, {0.001329, False}}
*)

---

Update: Response to comment — Early exit

My original answer of above is (1) simple, (2) takes advantage of efficient memory management on the CPU with RotateLeft, and (3) takes advantage of the vectorized Equal. I thought it would hard to beat in actual performance, because the hardware/library optimizations are usually hard to beat with Mathematica code, even in Compile. But @DanielLichtblau's comment set me thinking further. Here's a way to chunk the input vector, so you get the advantages (2) and (3) plus you get, somewhat, the desired early exit as soon as the difference is found (by chunk). The optimal size of the chunk is open to investigation. It depends on where the first difference occurs and perhaps the size of the cache on the CPU and so forth.

With[{chunk = 2^15 (* 32K *)},
 singletonCF = Compile[{{a, _Integer, 1}},
   Module[{
     b,
     res = a[[1]] == a[[-1]],
     k = 1,
     kmax = Length[a] - chunk},
    If[kmax < 1,
     res = Most[a] == Rest[a]
     ];
    While[res && k < kmax,
     b = a[[k ;; k + chunk]];
     res = res && Most@b == Rest@b;
     k = k + chunk
     ];
    res
    ],
   CompilationTarget -> "C"
   ]
 ]

Like a lot of Compile codes that take advantage of vectorization, compiling to C gives only a small speed-up.

array = ConstantArray[0, 10^7];
Table[
  foo = array;
  foo[[Min[k, Length@array]]] = 1;
  First@RepeatedTiming[singletonCF[foo]],
  {k, 1, 1 + Length@array, Floor[Length@array/20]}] // ListPlot

Answer 2

This can perhaps be optimized (certainly if Compile is used). The idea is to short-circuit if an element not equal to the first is encountered.

allsame[ll_List] := With[
  {first = ll[[1]]},
  Catch[
   Scan[If[# != first, Throw[False]] &, ll];
   True
   ]]

You can get an idea of how it behaves by testing against large lists both random and structured. For the latter class we have all equal elements, second one different, last one different, (one of) middle element different.

n = 10^6;
ll1 = RandomInteger[{-10, 10}, n];
ll2 = ConstantArray[10, n];
ll3 = ll2;
ll3[[2]] = -10;
ll4 = ll2;
ll4[[-1]] = -10;
ll5 = ll2;
ll5[[Ceiling[n/2]]] = -10;

In[117]:= Map[Timing[allsame[#]] &, {ll1, ll2, ll3, ll4, ll5}]

(* Out[117]= {{0.03125, False}, {1.57813, True}, {0.03125, 
  False}, {1.54688, False}, {0.765625, False}} *)

It has the expected complexity at least.

Answer 3

I'd use 'LengthWhile' and compare the length to the original list:

singletonTest[a_List]:=LengthWhile[Rest@a,First@a==#&]==Length@a;

timings = Table[
   a = RandomInteger[{-10, 10}, n];
   {n, First@RepeatedTiming[singletonTest[a]]}
   , {n, 10, 1000, 10}
   ];
ListPlot[timings, AxesLabel -> {"n", "Time[s]"}]

Which gives:

For constant arrays:

timings = Table[
   a = Array[10 &, n];
   {n, First@RepeatedTiming[singletonTest[a];]}
   , {n, 10, 100, 10}
   ];
ListPlot[timings, AxesLabel -> {"n", "Time[s]"}]

Answer 4

The compeditors:

adam0[l_List]:=Equal@@l;
adam1[l_List]:=1==Length@Union@l;
adam2[l_List]:=MatchQ[l,{x_ ..}];
adam3[l_List]:=If[Null===Do[If[l[[i]]==l[[i+1]],Return@0],{i,Length@l-1}],True,False];
allsame[ll_List]:=With[{first=ll[[1]]},Catch[Scan[If[#!=first,Throw[False]]&,ll];True]];
me2[l_List]:=l==RotateLeft[l];
singletonTest[a_List]:=LengthWhile[Rest@a,First@a==#&]==Length@a;
cw[l_List]:=Equal@@MinMax@l;
funcs={adam0,adam1,adam2,adam3,allsame,me2,singletonTest,cw};

The results on lists with 100000,200000,...1000000 random elements:

ListLinePlot[Transpose@Table[With[{list=RandomReal[{-10,10},n]},First@Timing[#@list]&/@funcs],{n,100000,1000000,100000}],PlotLegends->funcs]

adam0, allsame and adam1 are the three slowest. With them excluded, the timings look like

Carl Woll's Equal@MinMax is darn fast. But pattern matching is blazingly fast.

The results on lists with 100000,200000,...1000000 constant elements:

ListLinePlot[Transpose@Table[With[{list=ConstantArray[1,n]},First@Timing[#@list]&/@funcs],{n,100000,1000000,100000}],PlotLegends->funcs]

singletonTest and allsame are the slowest. With them excluded, the timings look like

Equal@MinMax wins in this case. Michael E2's RotateLeft is a close second.

Takeaway the first: don't try to beat Mathematica. Also don't write code like a mathematician (looking at you, 1==Length@Union).

Takeaway the second: the biggest brain answers are always hidden in comments!

For now, the accept goes to Michael E2: #==RotateLeft@# appears to be a great all rounder.