Wolfram Blog News, views, and ideas from the front lines at Wolfram Research. 2018-05-24T18:11:49Z http://blog.wolfram.com/feed/atom/ WordPress Carlo Giacometti <![CDATA[Learning to Listen: Neural Networks Application for Recognizing Speech]]> http://blog.internal.wolfram.com/?p=46044 2018-05-24T18:11:49Z 2018-05-24T17:00:03Z Introduction

Recognizing words is one of the simplest tasks a human can do, yet it has proven extremely difficult for machines to achieve similar levels of performance. Things have changed dramatically with the ubiquity of machine learning and neural networks, though: the performance achieved by modern techniques is dramatically higher compared with the results from just a few years ago. In this post, I’m excited to show a reduced but practical and educational version of the speech recognition problem—the assumption is that we’ll consider only a limited set of words. This has two main advantages: first of all, we have easy access to a dataset through the Wolfram Data Repository (the Spoken Digit Commands dataset), and, maybe most importantly, all of the classifiers/networks I’ll present can be trained in a reasonable time on a laptop.

It’s been about two years since the initial introduction of the Audio object into the Wolfram Language, and we are thrilled to see so many interesting applications of it. One of the main additions to Version 11.3 of the Wolfram Language was tight integration of Audio objects into our machine learning and neural net framework, and this will be a cornerstone in all of the examples I’ll be showing today.

Without further ado, let’s squeeze out as much information as possible from the Spoken Digit Commands dataset!

Spoken Digit Commands dataset

The Data

Let’s get started by accessing and inspecting the dataset a bit:

&#10005

ro=ResourceObject["Spoken Digit Commands"]

The dataset is a subset of the Speech Commands dataset released by Google. We wanted to have a “spoken MNIST,” which would let us produce small, self-enclosed examples of machine learning on audio signals. Since the Spoken Digit Commands dataset is a ResourceObject, it’s easy to get all the training and testing data within the Wolfram Language:

&#10005

trainingData=ResourceData[ro,"TrainingData"];
testingData=ResourceData[ro,"TestData"];
RandomSample[trainingData,3]//Dataset

One important thing we made sure of is that the speakers in the training and testing sets are different. This means that in the testing phase, the trained classifier/network will encounter speakers that it has never heard before.

&#10005

Intersection[trainingData[[All,"SpeakerID"]],testingData[[All,"SpeakerID"]]]

The possible output values are the digits from 0 to 9:

&#10005

classes=Union[trainingData[[All,"Output"]]]

Conveniently, the length of all the input data is between .5 and 1 seconds, with the majority for the signals being one second long:

&#10005

Dataset[trainingData][Histogram[#,ScalingFunctions->"Log"]&@*Duration,"Input"]

Encoders

In Version 11.3, we built a collection of audio encoders in NetEncoder and properly integrated it into the rest of the machine learning and neural net framework. Now we can seamlessly extract features from a large collection of audio recordings; inject them into a net; and train, test and evaluate networks for a variety of applications.

Since there are multiple features that one might want to extract from an audio signal, we decided that it was a good idea to have one encoder per feature rather than a single generic "Audio" one. Here is the full list:

"Audio"
"AudioSTFT"
"AudioSpectrogram"
"AudioMelSpectrogram"
"AudioMFCC"

The first step (which is common in all encoders) is the preprocessing: the signal is reduced to a single channel, resampled to a fixed sample rate and can be padded or trimmed to a specified duration.

The simplest one is NetEncoder["Audio"], which just returns the raw waveform:

&#10005

encoder=NetEncoder["Audio"]

&#10005

encoder[RandomChoice[trainingData]["Input"]]//Flatten//ListLinePlot

The starting point for all of the other audio encoders is the short-time Fourier transform, where the signal is partitioned in (potentially overlapping) chunks, and the Fourier transform is computed on each of them. This way we can get both time (since each chunk is at a very specific time) and frequency (thanks to the Fourier transform) information. We can visualize this process by using the Spectrogram function:

&#10005

a=AudioGenerator[{"Sin",TimeSeries[{{0,1000},{1,4000}}]},2];
Spectrogram[a]

The main parameters for this operation that are common to all of the frequency domain features are WindowSize and Offset, which control the sizes of the chunks and their offsets.

Each NetEncoder supports the "TargetLength" option. If this is set to a specific number, the input audio will be trimmed or padded to the correct duration; otherwise, the length of the output of the NetEncoder will depend on the length of the original signal.

For the scope of this blog post, I’ll be using the "AudioMFCC" NetEncoder, since it is a feature that packs a lot of information about the signal while keeping the dimensionality low:

&#10005

encoder=NetEncoder[{"AudioMFCC","TargetLength"->All,"SampleRate"->16000,"WindowSize" -> 1024,"Offset"-> 570,"NumberOfCoefficients"->28,"Normalization"->True}]
encoder[RandomChoice[trainingData]["Input"]]//Transpose//MatrixPlot

As I mentioned at the beginning, these encoders are quite fast: this specific one on my not-very-new machine runs through all 10,000 examples in slightly more than two seconds:

&#10005

encoder[trainingData[[All,"Input"]]];//AbsoluteTiming

Machine Learning, the Automated Way

Now we have the data and an efficient way of extracting features. Let’s find out what Classify can do for us.

To start, let’s massage our data into a format that Classify would be happier with:

classifyTrainingData = #Input -> #Output & /@ trainingData;
classifyTestingData = #Input -> #Output & /@ testingData;

Classify does have some trouble dealing with variable-length sequences (which hopefully will be improved on soon), so we’ll have to find ways to work around that.

Mean of MFCC

To make the problem simpler, we can get rid of the variable length of the features. One naive way is to compute the mean of the sequence:

&#10005

cl=Classify[classifyTrainingData,FeatureExtractor->(Mean@*encoder),PerformanceGoal->"Quality"];

The result is a bit disheartening, but not unexpected, since we are trying to summarize each signal with only 28 parameters. Not stunning.

&#10005

cm=ClassifierMeasurements[cl,classifyTestingData];
cm["Accuracy"]
cm["ConfusionMatrixPlot"]

Adding Some Statistics

To improve the results of Classify, we can feed it more information about the signal by adding the standard deviation of each sequence as well:

&#10005

cl=Classify[classifyTrainingData,FeatureExtractor->(Flatten[{Mean[#],StandardDeviation[#]}]&@*encoder),PerformanceGoal->"Quality"];

Some effort does pay off:

&#10005

cm=ClassifierMeasurements[cl,classifyTestingData];
cm["Accuracy"]
cm["ConfusionMatrixPlot"]

Even More Statistics

We can follow this strategy a bit more, and also add the Kurtosis of the sequence:

&#10005

cl=Classify[classifyTrainingData,FeatureExtractor->(Flatten[{Mean[#],StandardDeviation[#],Kurtosis[#]}]&@*encoder),PerformanceGoal->"Quality"];

The improvement is not as huge, but it is there:

&#10005

cm=ClassifierMeasurements[cl,classifyTestingData];
cm["Accuracy"]
cm["ConfusionMatrixPlot"]

Fixed-Length Sequences

We could continue dripping information about statistics of the sequences, with smaller and smaller returns. But with this specific dataset, we can follow a simpler strategy: remember how we noticed that most recordings were about 1 second long? That means that if we fix the length of the extracted feature to the equivalent of 1 second (about 28 frames) using the "TargetLength" option, the encoder will take care of doing the padding or trimming as appropriate. This way, all the inputs to Classify will have the same dimensions of {28,28}:

&#10005

encoderFixed=NetEncoder[{"AudioMFCC","TargetLength"->28,"SampleRate"->16000,"WindowSize" -> 1024,"Offset"-> 570,"NumberOfCoefficients"->28,"Normalization"->True}]

&#10005

cl=Classify[classifyTrainingData,FeatureExtractor->encoderFixed,PerformanceGoal->"DirectTraining"];

The training time is longer, but we do still get an accuracy bump:

&#10005

cm=ClassifierMeasurements[cl,classifyTestingData];
cm["Accuracy"]
cm["ConfusionMatrixPlot"]

This is about as far as we can get with Classify and low-level features. Time to ditch the automation and to bring out the neural networks machinery!

Convolutional Neural Network

Let’s remember that we’re playing with a spoken versions of MNIST, so what could be a better starting place than LeNet? This is a network that is often used as a benchmark on the standard image MNIST, and is very fast to train (even without GPU).

We’ll use the same strategy as in the last Classify example: we’ll fix the length of the signals to about one second, and we’ll tune the parameters of the NetEncoder so that the input will have the same dimensions of the MNIST images. This is one of the reasons we can confidently use a CNN architecture for this job: we are dealing with 2D matrices (images, in essence—actually, that’s how we usually look at MFCC), and we want the network to infer information from their structures.

Let’s grab LeNet from NetModel:

&#10005

lenet=NetModel["LeNet Trained on MNIST Data","UninitializedEvaluationNet"]

Since the "AudioMFCC" NetEncoder produces two-dimensional data (time x frequency), and the net requires three-dimensional inputs (where the first dimensions are the channel dimensions), we can use ReplicateLayer to make them compatible:

&#10005

lenet=NetPrepend[lenet,ReplicateLayer[1]]

Using NetReplacePart, we can attach the "AudioMFCC" NetEncoder to the input and the appropriate NetDecoder to the output:

&#10005

audioLeNet=NetReplacePart[lenet,
{
"Input"->NetEncoder[{"AudioMFCC","TargetLength"->28,"SampleRate"->16000,"WindowSize" -> 1024,"Offset"-> 570,"NumberOfCoefficients"->28,"Normalization"->True}],
"Output"->NetDecoder[{"Class",classes}]
}
]

To speed up convergence and prevent overfitting, we can use NetReplace to add a BatchNormalizationLayer after every convolution:

&#10005

audioLeNet=NetReplace[audioLeNet,{x_ConvolutionLayer:>NetChain[{x,BatchNormalizationLayer[]}]}]

NetInformation allows us to visualize at a glance the net’s structure:

NetInformation

NetInformation[audioLeNet,"SummaryGraphic"]

Now our net is ready for training! After defining a validation set on 5% of the training data, we can let NetTrain worry about all hyperparameters:

&#10005

resultObject=NetTrain[
audioLeNet,
trainingData,
All,
ValidationSet->Scaled[.05]
]

Seems good! Now we can use ClassifierMeasurements on the net to measure the performance:

&#10005

cm=ClassifierMeasurements[resultObject["TrainedNet"],classifyTestingData];
cm["Accuracy"]
cm["ConfusionMatrixPlot"]

It looks like the added effort paid off!

Recurrent Neural Network

We can also embrace the variable-length nature of the problem by specifying "TargetLength"→All in the encoder:

&#10005

encoder=NetEncoder[{"AudioMFCC","TargetLength"->All,"NumberOfCoefficients"->28,"SampleRate"->16000,"WindowSize" -> 1024,"Offset"-> 571,"Normalization"->True}]

This time we’ll use an architecture based on the GatedRecurrentLayer. Used on its own, it returns its state per each time step, but we are only interested in the classification of the entire sequence, i.e. we want a single output for all time steps. We can use SequenceLastLayer to extract the last state for the sequence. After that, we can add a couple of fully connected layers to do the classification:

&#10005

rnn=
NetChain[{
GatedRecurrentLayer[32,"Dropout"->{"VariationalInput"->0.3}],
GatedRecurrentLayer[64,"Dropout"->{"VariationalInput"->0.3}],
SequenceLastLayer[],
LinearLayer[64],
Ramp,
LinearLayer[Length@classes],
SoftmaxLayer[]},
"Input"->encoder,
"Output"->NetDecoder[{"Class",classes}]
]

Again, we’ll let NetTrain worry about all hyperparameters:

&#10005

resultObjectRNN=NetTrain[
rnn,
trainingData,
All,
ValidationSet->Scaled[.05]
]

… and measure the performance:

&#10005

cm=ClassifierMeasurements[resultObjectRNN["TrainedNet"],classifyTestingData];
cm["Accuracy"]
cm["ConfusionMatrixPlot"]

It seems that treating the input as a pure sequence and letting the network figure out how to extract meaning from it works quite well!

An Interlude

Now that we have some trained networks, we can play with them a bit. First of all, let’s take the recurrent network and chop off the last two layers:

&#10005

choppedNet=NetTake[resultObjectRNN["TrainedNet"],{1,5}]

This leaves us with something that produces a vector of 64 numbers per each input signal. We can try to use this chopped network as a feature extractor and plot the results:

&#10005

FeatureSpacePlot[Style[#["Input"],ColorData[97][#["Output"]+1]]->#["Output"]&/@testingData,FeatureExtractor->choppedNet]

It looks like the various classes get properly separated!

We can also record a signal, and test the trained network on it:

&#10005

a=AudioTrim@AudioCapture[]

&#10005

resultObjectRNN["TrainedNet"][a]

RNN Using CTC Loss

We can attempt something more adventurous on this dataset: up until now, we have simply done classification (a sequence goes in, a single class comes out). What if we tried transduction: a sequence (the MFCC features) goes in, and another sequence (the characters) comes out?

First of all, let’s add string labels to our data:

labels = <|0 -> "zero", 1 -> "one", 2 -> "two", 3 -> "three",
   4 -> "four", 5 -> "five", 6 -> "six", 7 -> "seven", 8 -> "eight",
   9 -> "nine"|>;
trainingDataString =
  Append[#, "Target" -> labels[#Output]] & /@ trainingData;
testingDataString =
  Append[#, "Target" -> labels[#Output]] & /@ testingData;

We need to remember that once trained, this will not be a general speech-recognition network: it will only have been exposed to one word at a time, only to a limited set of characters and only 10 words!

&#10005

Union[Flatten@Characters@Values@labels]//Sort

A recurrent architecture would output a sequence of the same length as the input, which is not what we want. Luckily, we can use the CTCBeamSearch NetDecoder to take care of this. Say that the input sequence is n steps long, and the decoding has m different classes: the NetDecoder will expect an input of dimensions (there are m possible states, plus a special blank character). Given this information, the decoder will find the most likely sequence of states by collapsing all of the ones that are not separated by the blank symbol.

Another difference with the previous architecture will be the use of NetBidirectionalOperator. This operator applies a net to a sequence and its reverse, catenating both results into one single output sequence:

&#10005

net=NetGraph[{NetBidirectionalOperator@GatedRecurrentLayer[64,"Dropout"->{"VariationalInput"->0.4}],
NetBidirectionalOperator@GatedRecurrentLayer[64,"Dropout"->{"VariationalInput"->0.4}],
NetMapOperator[{LinearLayer[128],Ramp,LinearLayer[],SoftmaxLayer[]}]},
{NetPort["Input"]->1->2->3->NetPort["Target"]},
"Input"->NetEncoder[{"AudioMFCC","TargetLength"->All,"NumberOfCoefficients"->28,"SampleRate"->16000,"WindowSize" -> 1024,"Offset"-> 571,"Normalization"->True}],
"Target"->NetDecoder[{"CTCBeamSearch",Alphabet[]}]]

To train the network, we need a way to compute the loss that takes the decoding into account. This is what the CTCLossLayer is for:

&#10005

trainedCTC=NetTrain[net,trainingDataString,LossFunction->CTCLossLayer["Target"->NetEncoder[{"Characters",Alphabet[]}]],ValidationSet->Scaled[.05],MaxTrainingRounds->20];

Let’s pick a random example from the test set:

&#10005

a=RandomChoice@testingDataString

Look at how the trained network behaves:

&#10005

trainedCTC[a["Input"]]

We can also look at the output of the net just before the CTC decoding takes place. This represents the probability of each character per time step:

&#10005

probabilities=NetReplacePart[trainedCTC,"Target"->None][a["Input"]];
ArrayPlot[Transpose@probabilities,DataReversed->True,FrameTicks->{Thread[{Range[26],Alphabet[]}],None}]

We can also show these probabilities superimposed on the spectrogram of the signal:

&#10005

Show[{ArrayPlot[Transpose@probabilities,DataReversed->True,FrameTicks->{Thread[{Range[26],Alphabet[]}],None}],Graphics@{Opacity[.5],Spectrogram[a["Input"],DataRange->{{0,Length[probabilities]},{0,27}},PlotRange->All][[1]]}}]

There is definitely the possibility that the network would make small spelling mistakes (e.g. “sixo” instead of “six”). We can visually inspect these spelling mistakes by applying the net to all classes and get a WordCloud of them:

&#10005

WordCloud[StringJoin/@trainedCTC[#[[All,"Input"]]]]&/@GroupBy[testingDataString,Last]

Most of these spelling mistakes are quite small, and a simple Nearest function might be enough to correct them:

&#10005

nearest=First@*Nearest[Values@labels];
nearest["sixo"]

To measure the performance of the net and the Nearest function, first we need to define a function that, given an output for the net (a list of characters), computes the probability per each class:

&#10005

probs=AssociationThread[Values[labels]->0];
getProbabilities[chars:{___String}]:=Append[probs,nearest[StringJoin[chars]]->1]

Let’s check that it works:

&#10005

getProbabilities[{"s","i","x","o"}]
getProbabilities[{"f","o","u","r"}]

Now we can use ClassifierMeasurements by giving an association of probabilities and the correct labels per each example as input:

&#10005

cm=ClassifierMeasurements[getProbabilities/@trainedCTC[testingDataString[[All,"Input"]]],testingDataString[[All,"Target"]]]

The accuracy is quite high!

&#10005

cm["Accuracy"]
cm["ConfusionMatrixPlot"]

Encoder/Decoder

Up till now, the architectures we have been experimenting with are fairly straightforward. We can now attempt to do something more ambitious: an encoder/decoder architecture. The basic idea is that we’ll have two main components in the net: the encoder, whose job is to encode all the information about the input features into a single vector (of 128 elements, in our case); and the decoder, which will take this vector (the “encoded” version of the input) and be able to produce a “translation” of it as a sequence of characters.

Let’s define the NetEncoder that will deal with the strings:

&#10005

targetEnc=NetEncoder[{"Characters",{Alphabet[],{StartOfString,EndOfString}->Automatic},"UnitVector"}]

… and the one that will deal with the Audio objects:

&#10005

inputEnc=NetEncoder[{"AudioMFCC","TargetLength"->All,"NumberOfCoefficients"->28,"SampleRate"->16000,"WindowSize" -> 1024,"Offset"-> 571,"Normalization"->True}]

Our encoder network will consist of a single GatedRecurrentLayer and a SequenceLastLayer to extract the last state, which will become our encoded representation of the input signal:

&#10005

encoderNet=NetChain[{GatedRecurrentLayer[128,"Dropout"->{"VariationalInput"->0.3}],SequenceLastLayer[]}]

The decoder network will take a vector of 128 elements and a sequence of vectors as input, and will return a sequence of vectors:

&#10005

decoderNet=NetGraph[{
SequenceMostLayer[],
GatedRecurrentLayer[128,"Dropout"->{"VariationalInput"->0.3}],
NetMapOperator[LinearLayer[]],
SoftmaxLayer[]},
{NetPort["Input"]->1->2->3->4,
NetPort["State"]->NetPort[2,"State"]}
]

We then need to define a network to train the encoder and decoder. This configuration is usually called a “teacher forcing” network:

&#10005

teacherForcingNet=NetGraph[<|"encoder"->encoderNet,"decoder"->decoderNet,"loss"->CrossEntropyLossLayer["Probabilities"],"rest"->SequenceRestLayer[]|>,
{NetPort["Input"]->"encoder"->NetPort["decoder","State"],
NetPort["Target"]->NetPort["decoder","Input"],
"decoder"->NetPort["loss","Input"],
NetPort["Target"]->"rest"->NetPort["loss","Target"]},
"Input"->inputEnc,"Target"->targetEnc]

Using NetInformation, we can look at the whole structure with one glance:

&#10005

NetInformation[teacherForcingNet,"FullSummaryGraphic"]

The idea is that the decoder is presented with the encoded input and most of the target, and its job is to predict the next character. We can now go ahead and train the net:

&#10005

trainedEncDec=NetTrain[teacherForcingNet,trainingDataString,ValidationSet->Scaled[.05]]

Now let’s inspect what happened. First of all, we have a trained encoder:

&#10005

trainedEncoder=NetReplacePart[NetExtract[trainedEncDec,"encoder"],"Input"->inputEnc]

This takes an Audio object and outputs a single vector of 150 elements. Hopefully, all of the interesting information of the original signal is included here:

&#10005

example=RandomChoice[testingDataString]

Let’s use the trained encoder to encode the example input:

&#10005

encodedVector=trainedEncoder[example["Input"]];
ListLinePlot[encodedVector]

Of course, this doesn’t tell us much on its own, but we could use the trained encoder as feature extractor to visualize all of the testing set:

&#10005

FeatureSpacePlot[Style[#["Input"],ColorData[97][#["Output"]+1]]->#["Output"]&/@testingData,FeatureExtractor->trainedEncoder]

To extract information from the encoded vector, we need help from our trusty decoder (which has been trained as well):

&#10005

trainedDecoder=NetExtract[trainedEncDec,"decoder"]

Let’s add some processing of the input and output:

&#10005

decoder=NetReplacePart[trainedDecoder,{"Input"->targetEnc,"Output"->NetDecoder[targetEnc]}]

If we feed the decoder the encoded state and a seed string to start the reconstruction and iterate the process, the decoder will do its job nicely:

&#10005

res=decoder[<|"State"->encodedVector,"Input"->"c"|>]
res=decoder[<|"State"->encodedVector,"Input"->res|>]
res=decoder[<|"State"->encodedVector,"Input"->res|>]

We can make this decoding process more compact, though; we want to construct a net that will compute the output automatically until the end-of-string character is reached. As a first step, let’s extract the two main components of the decoder net:

&#10005

gru=NetExtract[trainedEncDec,{"decoder",2}]
linear=NetExtract[trainedEncDec,{"decoder",3,"Net"}]

Define some additional processing of the input and output of the net that includes special classes to indicate the start and end of the string:

&#10005

classEnc=NetEncoder[{"Class",Append[Alphabet[],StartOfString],"UnitVector"}];
classDec=NetDecoder[{"Class",Append[Alphabet[],EndOfString]}];

Define a character-level predictor that takes a single character, runs one step of the GatedRecurrentLayer and produces a single softmax prediction:

&#10005

charPredictor=NetChain[{ReshapeLayer[{1,27}],gru,ReshapeLayer[{128}],linear,SoftmaxLayer[]},"Input"->classEnc,"Output"->classDec]

Now we can use NetStateObject to inject the encoded vector into the state of the recurrent layer:

&#10005

sobj=NetStateObject[charPredictor,<|{2,"State"}->encodedVector|>]

If we now feed this predictor the StartOfString character, this will predict the next character:

&#10005

sobj[StartOfString]

Then we can iterate the process:

&#10005

sobj[%]
sobj[%]
sobj[%]

We can now encapsulate this process in a single function:

&#10005

predict[input_]:=Module[{encoded,sobj,res},
encoded=trainedEncoder[input];
sobj=NetStateObject[charPredictor,<|{2,"State"}->encoded|>];
res=NestWhileList[sobj,StartOfString,#=!=EndOfString&];
StringJoin@res[[2;;-2]]
]

This way, we can directly compute the full output:

&#10005

predict[example["Input"]]

Again, we need to define a function that, given an output for the net, computes the probability per each class:

&#10005

probs=AssociationThread[Values[labels]->0];
getProbabilities[in_]:=Append[probs,nearest@predict[in]->1];

Now we can use ClassifierMeasurements by giving as input an association of probabilities and the correct labels per each example:

&#10005

cm=ClassifierMeasurements[getProbabilities/@testingDataString[[All,"Input"]],testingDataString[[All,"Target"]]]

&#10005

cm["Accuracy"]
cm["ConfusionMatrixPlot"]

Audio signals are less ubiquitous than images in the machine learning world, but that doesn’t mean they are less interesting to analyze. As we continue to complete and optimize audio analysis using modern machine learning and neural net approaches in the Wolfram Language, we are also excited to use it ourselves to build high-level applications in the domains of speech analysis, music understanding and many other areas.

Machine Learning Webinar


Download this post as a Wolfram Notebook.

]]>
2
Michael Trott <![CDATA[Strange Circles in the Complex Plane—More Experimental Mathematics Results]]> http://blog.internal.wolfram.com/?p=45347 2018-05-11T20:14:41Z 2018-05-10T20:00:04Z #post-45347 h2 { margin: 2px 0 0 0; font-size: 22px; padding: 12px 0 6px; display: block; float: none; } #post-45347 blockquote { //padding: 10px 25px; font-family: Georgia; font-style: italic; font-size: 130%; line-height: 1.4; color: #e26a0f; margin: 0 0 8px; //border-top: 1px solid #c3c3c3; //border-bottom: 1px solid #c3c3c3; } #post-45347 blockquote p { margin: 0; padding: 0; }

The Shape of the Differences of the Complex Zeros of Three-Term Exponential Polynomials

In my last blog, I looked at the distribution of the distances of the real zeros of functions of the form with incommensurate , . And after analyzing the real case, I now want to have a look at the differences of the zeros of three-term exponential polynomials of the form for real , , . (While we could rescale to set and for the zero set , keeping and will make the resulting formulas look more symmetric.) Looking at the zeros in the complex plane, one does not see any obvious pattern. But by forming differences of pairs of zeros, regularities and patterns emerge, which often give some deeper insight into a problem. We do not make any special assumptions about the incommensurability of , , .

The differences of the zeros of this type of function are all located on oval-shaped curves. We will find a closed form for these ovals. Using experimental mathematics techniques, we will show that ovals are described by the solutions of the following equation:


… where:


Here this situation is visualized for the function , meaning and , , , , . We calculate a few dozen exact zeros and plot the described curve.

edzs = Sort[
   N[z /. Solve[
      Exp[I z] + 2/3 Exp[I Sqrt[2] z] + 1/2 Exp[I Sqrt[3] z] ==
        0 \[And]
                                  -5 < Im[z] < 5 \[And]
       0 < Re[z] < 500, z]]];

Show[{(* curves of zeros *)

  RegionPlot[(2/3)^(2 (Sqrt[3] - 1)) (1/2)^(2 (1 - Sqrt[2])) *
     (Cosh[(Sqrt[2] - 1) y] - Cos[(Sqrt[2] - 1) x])^(
     Sqrt[2] - 1) (Cosh[(1 - Sqrt[3]) y] - Cos[(1 - Sqrt[3]) x])^(
     1 - Sqrt[
      3]) (Cosh[(Sqrt[3] - Sqrt[2]) y] - Cos[(Sqrt[3] - Sqrt[2]) x])^(
     Sqrt[3] - Sqrt[2]) > 1, {x, 0, 55}, {y, -3, 3},
   PlotPoints -> 60,
   PlotStyle -> Directive[RGBColor[0.88, 0.61, 0.14], Opacity[0.3]],
   BoundaryStyle -> None],
  (* numerically calculated zeros *)

  ListPlot[-ReIm[Apply[Subtract, Subsets[edzs, {2}], {1}]],
   PlotRange -> {{0, 55}, {-3, 3}}]}, AspectRatio -> 1/3]

While one easily sees the ovals emerge from numerically calculated zeros, how does one find a closed form for the curves on which they all fall? Using an experimental mathematics approach that includes symbolic polynomial manipulations as well as numerical techniques, including high-precision calculations, one can find the previously shown closed form of the curves. In this blog, I will show how to find these curves.

Expressions containing for occur from time to time in complex analysis---for instance, for the Dirichlet kernel of a strip (Widder, 1961) or in fluid dynamics (see e.g. Baker and Pham, 2006).

From cos to exp: Exponential Polynomials

A natural generalization of the function used in the last blog is for real . There is a lot of literature on exponential polynomials that are prime examples of almost periodic functions (see e.g. Jessen and Tornehave, 1945, Moreno, 1973, Sepulcre, 2016, and Mora, Sepulcre and Vidal, 2013.)

Let us have a quick look at this function. Like in the last blog, we use the special instance .

fGoldenExp[z_] :=
 Exp[I z] + Exp[I GoldenRatio z] + Exp[I GoldenRatio^2 z]

We calculate the first zeros, extrema and inflection points.

zeis = Table[
   z /. Solve[
     D[fGoldenExp[z], {z, k}] == 0 \[And] -5 < Im[z] < 5 \[And]
      0 < Re[z] < 50, z], {k, 0, 2}];

Plotting the zeros, extrema and inflection points in the complex plane shows that the real parts are nearly identical for each "group" of zero, extrema and inflection point triples.

Legended[ContourPlot[
  Evaluate[# == 0 & /@ ReIm[fGoldenExp[x + I y] ]],
  {x, 000, 050}, {y, -3, 3}, PlotPoints -> 50, AspectRatio -> 1/2,
  Epilog :> {Purple, PointSize[0.01], Point[N[ReIm[#]] & /@ zeis[[1]]],
    Darker[Green], Point[N[ReIm[#]] & /@ zeis[[2]]],
    Darker[Red], Point[N[ReIm[#]] & /@ zeis[[3]]]}],
 LineLegend[{Directive[Thick, Purple], Darker[Green], Darker[Red]},
  {"zeros", "extrema", "inflection points"}]]

(The "nice" vertical alignment of the zeros of the function and their derivatives is not always the case---for instance, when and have different signs, the alignment is broken.)

I now calculate ~5k zeros of . This time, we can't use the differential equation technique; instead we use Solve. We sort the zeros by increasing real part.

Monitor[fGoldenExpZeros =
   SortBy[N@
     Flatten[Table[
       z /.

        Solve[fGoldenExp[z] == 0 \[And] -5 < Im[z] < 5 \[And]
          100 k <= Re[z] < 100 k + 100, z],
       {k, 0, 200}]], Re];, k]

Length[fGoldenExpZeros]

The values of the three exponential summands at the zeros form interesting shapes in the complex plane.

Legended[
 Graphics[{Thickness[0.001],
   Transpose[{{RGBColor[0.36, 0.50, 0.71], RGBColor[0.88, 0.61, 0.14],
       RGBColor[0.56, 0.69, 0.19]},
     Line /@ Transpose[Function[z, {{{0, 0}, ReIm[Exp[I z]]} ,
          {{0, 0}, ReIm[Exp[I GoldenRatio z]]}, {{0, 0},
           ReIm[Exp[I GoldenRatio^2 z]]}}] /@
        RandomSample[fGoldenExpZeros, 500]]}]},
  Frame -> True],
 LineLegend[{Directive[Thick, RGBColor[0.36, 0.50, 0.71]],
   Directive[Thick, RGBColor[0.88, 0.61, 0.14]],
   Directive[Thick, RGBColor[0.56, 0.69, 0.19]]}, {Exp[I z],
   Exp[I GoldenRatio z], Exp[I GoldenRatio^2 z]}]]

As one can already see from the graphic, the term is never the smallest and never the largest at a zero.

(Function[z, Sort[{{Abs[Exp[I z]], 1},
       {Abs[Exp[I GoldenRatio z]], 2}, {Abs[Exp[I GoldenRatio^2 z]],
        3}}][[2, 2]]] /@ fGoldenExpZeros) // Union

Looking at the number of curves for vanishing real and imaginary parts for large positive and negative real parts of z shows that the slowest and fastest oscillating terms dominate the function behavior in the upper and lower half-plane. The mean spacing along the real axis between zeros follows from this observation as .

2 Pi/(GoldenRatio^2 - 1) // N

This value agrees well with the spacing derived from the calculated zeros.

Re[fGoldenExpZeros[[-1]]]/Length[fGoldenExpZeros]

Plotting the zeros with the real parts modulo the mean spacing confirms the calculated value. All roots are within a constant distance from the reduced center.

Manipulate[
 Graphics[{Thickness[0.001], RGBColor[0.36, 0.51, 0.71],
   Opacity[0.3],
   Line[{Mod[Re[#], \[CapitalDelta]], Im[#]} & /@
     Take[fGoldenExpZeros, 1000]]}],
 {{\[CapitalDelta], 2 Pi/(GoldenRatio^2 - 1.)}, 3, 5,
  Appearance -> "Labeled"},
 TrackedSymbols :> True, SaveDefinitions -> True]

At the zeros, is strongly correlated with . For a given real part, there is a unique imaginary part.

Histogram3D[{Mod[Re[#1], 2 Pi], Im[#2]} & @@@
  Partition[fGoldenExpZeros, 2, 1], 100]

The real and imaginary parts of have the following distributions at the zeros.

Histogram[#[fGoldenExp' /@ fGoldenExpZeros], 100] & /@ {Re, Im}

The distribution of the complex values of the three summands , , has some unexpected shapes.

Function[p, Histogram3D[{Mod[#1, p], #2} & @@@
     (ReIm /@ (-Subtract @@@
         Subsets[RandomSample[fGoldenExpZeros, 2000],
          {2}])), 100]] /@ (2 Pi/{1, GoldenRatio, GoldenRatio^2 })

Following the main thread of the distribution of zero distances, I sort the zeros by increasing real parts and calculate the differences. Interestingly, one gets a Stonehenge-like distribution for the differences in the complex plane.

Finding Strange Circles

differencesGoldenExp = Differences[fGoldenExpZeros];

Histogram3D[ReIm /@ differencesGoldenExp, 100]

The figure looks like a perfect circle. I fit an ellipse to the data.

ellipseData = ((Re[#] - xm)^2/a^2 + (Im[#] - ym)^2/b^2 - 1^2) & /@
   differencesGoldenExp;

fmEllipse = FindMinimum[ellipseData.ellipseData,
                              {{xm,
    Mean[ReIm /@ differencesGoldenExp][[1]]}, {ym, 0}, {a, 1}, {b,
    1}},
                                  PrecisionGoal -> 10]

Interestingly, the figure is nearly a circle. The blue circle is the best-fit ellipse, and the black points are the observed differences. (Trying to fit a rotated ellipse does not improve the fit.)

{#, Show[#, PlotRange -> {{4, 4.1}, {1.11, 1.15}}]} &[
 Graphics[{Blue, Circle[{xm, ym}, Abs[{a, b}]] /. fmEllipse[[2]],
                      PointSize[0.002], Black,
   Point[ReIm /@ differencesGoldenExp]}, Axes -> True]]

But it is not quite a circle or even an ellipse; zooming in, one sees some small oscillating deviations from the circle. The following plot shows the difference in local radius of the fitted circle to the calculated zeros as a function of the complex argument.

ListPlot[({Arg[# - (xm + I ym)], Abs[# - (xm + I ym)]} /.
     fmEllipse[[2]]) & /@  differencesGoldenExp]

Successive differences are often quite different. I connect successive differences in the complex plane. The angles between two successive line segments seem to be approximately constant.

Graphics[{Thickness[0.001], RGBColor[0.36, 0.51, 0.71],
  Line[ReIm /@ Take[differencesGoldenExp, 200]]}]

The angle between successive line segments in the last image is quite localized to a narrow range, with the minimal and maximal angles occurring the most frequently.

Histogram[
 VectorAngle[#1 - #2, #3 - #2] & @@@
  Partition[ReIm /@ differencesGoldenExp, 3, 1], 100,
 PlotRange -> {{0, Pi}, All}]

The pair correlation of successive differences shows a strict correlation of successive zeros.

Histogram3D[Partition[Arg /@ differencesGoldenExp, 2, 1], 100]

These patterns observed for successive differences are all also present in the differences of next-neighboring zeros. The following graphics array shows the zero differences for j=3,4,...,11.

Table[Graphics[{Thickness[0.001], RGBColor[0.36, 0.51, 0.71],
    Line[ReIm[#[[-1]] - #[[1]]] & /@
      Partition[Take[differencesGoldenExp, 500], k, 1]]},
                     ImageSize -> 160], {k, 3, 11}] //
 Partition[#, 3] &

The observed properties are: 1) zeros, extrema and inflection points line up with nearly identical real parts; and 2) the differences of successive zeros that are approximately on an ellipse are not special to the exponential polynomial with =, but hold for general . For generic , we still see these ellipses. And, similar to the previous Stonehenge image, the rightmost parts of the histogram are often the largest.

Similar to what I did in my last blog for , we shift the argument of and show how the function behaves in the neighborhoods of zeros. The following graphic shows the curves of the vanishing real part in gray and the vanishing imaginary part in blue in the neighborhood of the first 30 zeros. The genesis of the zero accumulation on near-circles is clearly visible.

Show[{Table[
   ContourPlot[Evaluate[# == 0 & /@ ReIm[fGoldenExp[z0 + (x + I y)]]],
    {x, 0, 10}, {y, -2, 2},
    ContourStyle -> {Directive[Gray, Opacity[0.4], Thickness[0.001]],
      Directive[RGBColor[0.36, 0.51, 0.71], Opacity[0.6],
       Thickness[0.001]]}], {z0, Take[fGoldenExpZeros, 30]}],
  Graphics[{Purple, PointSize[0.004],
    Point[ReIm /@
      Table[fGoldenExpZeros[[j + 1]] - fGoldenExpZeros[[j]], {j,
        30}]] ,
    Point[
     ReIm /@ Table[
       fGoldenExpZeros[[j + 2]] - fGoldenExpZeros[[j]], {j, 30}]]}]},
 AspectRatio -> Automatic]

Comparing the last graphic with a version that uses randomized phases between the three exponential terms does not reproduce the circle patterns of the zeros.

fGoldenExpRandomPhases[
  z_, {\[CurlyPhi]2_, \[CurlyPhi]3_}] := (-Exp[I \[CurlyPhi]2] -
     Exp[I \[CurlyPhi]3]) Exp[I z] +
  Exp[I \[CurlyPhi]2] Exp[I GoldenRatio z] +
  Exp[I \[CurlyPhi]3] Exp[I GoldenRatio^2 z] 

Module[{\[CurlyPhi]2, \[CurlyPhi]3},
 plData =
  Table[\[CurlyPhi]2 = RandomReal[{0, 2 Pi}]; \[CurlyPhi]3 =
    RandomReal[{0, 2 Pi}];
   {ContourPlot[
     Evaluate[# == 0 & /@
       ReIm[fGoldenExpRandomPhases[
         x + I y, {\[CurlyPhi]2, \[CurlyPhi]3}]]],
     {x, 0, 10}, {y, -2, 2},
     ContourStyle -> {Directive[Gray, Opacity[0.4],
        Thickness[0.001]],
       Directive[RGBColor[0.36, 0.51, 0.71], Opacity[0.6],
        Thickness[0.001]]}],
     Point[
      ReIm /@ (z /.
         Solve[fGoldenExpRandomPhases[
             z, {\[CurlyPhi]2, \[CurlyPhi]3}] == 0 \[And]
           0 < Re[z] < 10 \[And] -3 < Im[z] < 3, z])] //
     Quiet} , {30}];
 Show[{First /@ plData,
   Graphics[{Purple, PointSize[0.004], Last /@ plData}]},
  AspectRatio -> Automatic]]

This time, it does not make sense to form the envelope with, say, because the resulting equation is independent of and so has no family of solutions, but rather just isolated points.

Factor[Subtract @@
  Eliminate[{fGoldenExpRandomPhases[
       z, {\[CurlyPhi]2, \[CurlyPhi]3}] == 0,
     D[fGoldenExpRandomPhases[
        z, {\[CurlyPhi]2, \[CurlyPhi]3}], \[CurlyPhi]2] ==
      0} /. \[CurlyPhi]2 -> Log[C]/I, C]  ]

It is possible to derive a closed form for the circle-shaped curves on which the differences of the zeros are located.

A Closed Form of the Exponential Polynomial Zero Rings

The locations of the zero differences on the ellipse-shaped curves are curious. Can we get a closed-form equation for these shapes? As it turns out, we can. Since the derivation is a bit longer, we carry it out in this appendix. Rather than dealing with the general , situation, we will deal with , and then generalize to generic , by guessing based on the golden ratio result.

f\[Alpha][z_] :=
 Exp[I z] + Exp[I \[Alpha] z] +(* \[Equal]\[ThinSpace]Exp[
  I \[Alpha]^2 z] for \[Alpha]\[ThinSpace]\[Equal]\[ThinSpace]\[Phi] *)
  Exp[I z] Exp[I \[Alpha] z]

We start by writing down the conditions for and , which should both be zeros of .

{f\[Alpha][z0], f\[Alpha][z0 + \[Delta]z]} // ExpandAll

We separate real and imaginary parts using and ; supplement with two trigonometric identities; and rewrite , , and as polynomial variables.

eqs1 = {Re[f\[Alpha][x0 + I y0]]  // ComplexExpand // TrigExpand,

   Im[f\[Alpha][x0 + I y0]]  // ComplexExpand // TrigExpand,

   Re[f\[Alpha][x0 + I y0 + \[Delta]x + I \[Delta]y]] //
      ComplexExpand // ExpandAll // TrigExpand,

   Im[f\[Alpha][x0 + I y0 + \[Delta]x + I \[Delta]y]] //
      ComplexExpand // ExpandAll // TrigExpand,
          Cos[x0]^2 + Sin[x0]^2 - 1,

   Cos[\[Alpha] x0]^2 + Sin[\[Alpha] x0]^2 - 1 } /. {Cos[x0] -> c0,
   Sin[x0] -> s0, Cos[\[Alpha] x0] -> c\[Alpha],
   Sin[\[Alpha] x0] -> s\[Alpha]}

This system of equations does describe the possible positions of the zeros at . A quick numerical experiment confirms this.

of1 = eqs1.eqs1 /. \[Alpha] -> GoldenRatio;

Monitor[nsol1 = Module[{fm}, Table[
     fm = FindMinimum[Evaluate[of1],
        {c0, RandomReal[{-1, 1}]}, {s0, RandomReal[{-1, 1}]},
        {c\[Alpha], RandomReal[{-1, 1}]}, {s\[Alpha],
         RandomReal[{-1, 1}]},
        {\[Delta]x, RandomReal[{2, 4}]}, {\[Delta]y,
         RandomReal[{-1.5, 1.5}]},
        {y0, RandomReal[{-1.5, 1.5}]},
        PrecisionGoal -> 12, AccuracyGoal -> 15,
        WorkingPrecision -> 30,
        Method -> "Newton"] // Quiet;
     If[fm[[1]] < 10^-8, fm, Sequence @@ {}], {j, 100}]];, j]

Graphics[{RGBColor[0.36, 0.51, 0.71],
  Point[{\[Delta]x, \[Delta]y} /. N[nsol1[[All, 2]]]]},
                     PlotRange -> {{0, 8}, {-2, 2}}, Axes -> True]

Now we want to eliminate the variables and to obtain universally valid formulas for any root. We introduce some more polynomial variables and eliminate the four terms that contain .

eqs2 = Numerator[
  Together[eqs1 /.
                              \[Alpha] y0 ->
        Log[Y\[Alpha]0] /. y0 -> Log[Y0] /. \[Alpha] \[Delta]y ->
      Log[\[Delta]Y\[Alpha]] /. \[Delta]y -> Log[\[Delta]Y]]]

gb2 = GroebnerBasis[eqs2, {}, { c0, s0, c\[Alpha], s\[Alpha]},
    MonomialOrder -> EliminationOrder] // Factor;

Now we have 15 equations.

Length[gb2]

These equations still describe the positions of the roots.

of2 = Evaluate[
   gb2.gb2 /. {\[Delta]Y -> Exp[\[Delta]y], \[Delta]Y\[Alpha] ->
         Exp[\[Alpha] \[Delta]y]} /. Y0 -> Exp[y0] /.
     Y\[Alpha]0 -> Exp[\[Alpha] y0] /. \[Alpha] -> GoldenRatio];
Monitor[nsol2 = Module[{fm}, Table[
     fm = FindMinimum[Evaluate[of2],
        {\[Delta]x, RandomReal[{2, 4}]}, {\[Delta]y,
         RandomReal[{-1.5, 1.5}]},
        {y0, RandomReal[{-2, 2}]},
        PrecisionGoal -> 12, AccuracyGoal -> 15,
        WorkingPrecision -> 30,
        Method -> "Newton"] // Quiet;
     If[fm[[1]] < 10^-8, fm, Sequence @@ {}] , {j, 100}]];, j]

Graphics[{RGBColor[0.36, 0.51, 0.71],
  Point[{\[Delta]x, \[Delta]y} /. N[nsol2[[All, 2]]]]},
                     PlotRange -> {{0, 8}, {-2, 2}}, Axes -> True]

Let's hope that we do not need 15 equations to find an equation that describes the three values , and . Fortunately, using just the three smallest elements of the GroebnerBasis still yields the desired zero shape.

gb2Sorted = SortBy[gb2, Length];

of3 = Evaluate[#.# &[
        Take[gb2Sorted, 3]] /. {\[Delta]Y ->
         Exp[\[Delta]y], \[Delta]Y\[Alpha] ->
         Exp[\[Alpha] \[Delta]y]} /. Y0 -> Exp[y0] /.
     Y\[Alpha]0 -> Exp[\[Alpha] y0] /. \[Alpha] -> GoldenRatio];
Monitor[nsol3 = Module[{fm}, Table[
     fm = FindMinimum[Evaluate[of3],
        {\[Delta]x, RandomReal[{2, 4}]}, {\[Delta]y,
         RandomReal[{-1.5, 1.5}]},
        {y0, RandomReal[{-2, 2}]},
        PrecisionGoal -> 12, AccuracyGoal -> 15,
        WorkingPrecision -> 30,
        Method -> "Newton"] // Quiet;
     If[fm[[1]] < 10^-8, fm, Sequence @@ {}] , {j, 100}]];, j]

Graphics[{RGBColor[0.36, 0.51, 0.71],
  Point[{\[Delta]x, \[Delta]y} /. N[nsol3[[All, 2]]]]},
                     PlotRange -> {{0, 8}, {-2, 2}}, Axes -> True]

These three equations can be further reduced to just two equations.

eqs3 = List @@ FullSimplify[And @@ (# == 0 & /@ Take[gb2Sorted, 3])]

Plotting these two equations together as functions of , and shows that the regions where both equations are fulfilled are just the ellipse-shaped rings we are after.

eqs3A = (List @@ eqs3) /. {\[Delta]Y ->
    Exp[\[Delta]y], \[Delta]Y\[Alpha] -> Exp[\[Alpha] \[Delta]y],
   Y0 -> Exp[y0], Y\[Alpha]0 -> Exp[\[Alpha] y0]}

ContourPlot3D[Evaluate[eqs3A /. \[Alpha] -> GoldenRatio],
 {\[Delta]x, 0, 8}, {\[Delta]y, -2, 2}, {y0, -2, 2},
 MeshFunctions -> {#3 &}, BoxRatios -> Automatic,
 ViewPoint -> {0.39, 3.059, 1.39}]

To obtain one equation that describes the rings, we also have to eliminate the imaginary parts of the reference zero, meaning . Unfortunately, because the two terms and are not algebraically related, we cannot use GroebnerBasis or Resultant to eliminate . But we are lucky and can solve the first equation for .

sol3A = Solve[eqs3A[[1]], y0]

The resulting implicit equation for the rings is a bit ugly.

(Subtract @@ eqs3A[[2]] == 0) /. sol3A[[2]]

But it can be simplified to a quite nice-looking closed form.

FullSimplify[% /.
  sol3A[[2]], \[Delta]x > 0 \[And] \[Delta]y \[Element]
   Reals \[And] \[Alpha] > 0] 

Plotting this equation together with the zeros calculated above shows a perfect match of the zeros and the closed forms of the curves.

ContourPlot[
 Evaluate[Cos[\[Delta]x] + (-Cos[\[Alpha] \[Delta]x] +
        Cosh[\[Alpha] \[Delta]y])^\[Alpha] (-Cos[\[Delta]x - \[Alpha] \
\[Delta]x] + Cosh[\[Delta]y - \[Alpha] \[Delta]y])^(1 - \[Alpha]) ==
    Cosh[\[Delta]y] /. \[Alpha] -> GoldenRatio],
 {\[Delta]x, 0, 8}, {\[Delta]y, -2, 2}, AspectRatio -> Automatic,
 Prolog -> {RGBColor[0.88, 0.61, 0.14], PointSize[0.01], Opacity[0.5],
    Table[Point[
     ReIm[#[[-1]] - #[[1]]] & /@
      Partition[Take[fGoldenExpZeros, 200], j, 1]], {j, 2, 6}]},
 AxesLabel -> {"\[Delta]x", "\[Delta]y"} ]

Now, taking into account that for general , the resulting formula that describes the roots must be symmetric in and and that for the general three-term sums , it is not difficult to conjecture a closed form for the rings. We have the following implicit description for the relative zero positions. (We use , , to make the equation fully symmetric.)

zeros\[Alpha]\[Beta]\[Gamma][{\[Alpha]_, \[Beta]_, \[Gamma]_}, {\
\[Delta]x_, \[Delta]y_}] := (Cosh[(\[Beta] - \[Alpha]) \[Delta]y] -
     Cos[(\[Beta] - \[Alpha]) \[Delta]x])^(\[Beta] - \[Alpha]) \
(Cosh[(\[Gamma] - \[Beta]) \[Delta]y] -
     Cos[(\[Gamma] - \[Beta]) \[Delta]x])^(\[Gamma] - \[Beta]) \
(Cosh[(\[Gamma] - \[Alpha]) \[Delta]y] -
     Cos[(\[Gamma] - \[Alpha]) \[Delta]x])^(\[Alpha] - \[Gamma]) == 1

A quick check for the exponential polynomial confirms the conjectured equation.

Monitor[fSqrt3EPiExpZeros = SortBy[Flatten[Table[
      z /.
       Solve[Exp[I Sqrt[3] z] + Exp[I E z] + Exp[I Pi z] == 0 \[And]
           -5 < Im[z] < 5 \[And] 50 k <= Re[z] < 50 k + 50, z], {k, 0,
        20}]], Re];, k]

ContourPlot[
 Evaluate[
  zeros\[Alpha]\[Beta]\[Gamma][{Sqrt[3], E,
    Pi}, {\[Delta]x, \[Delta]y}] ],
 {\[Delta]x, 0, 25}, {\[Delta]y, -2, 2}, AspectRatio -> Automatic,
 PerformanceGoal -> "Quality", PlotPoints -> 40,
 MaxRecursion -> 1, PlotPoints -> {120, 40}, WorkingPrecision -> 40,
 Prolog -> {RGBColor[0.88, 0.61, 0.14], PointSize[0.005],
   Opacity[0.5],
   Table[Point[
     ReIm[#[[-1]] - #[[1]]] & /@
      Partition[Take[N@fSqrt3EPiExpZeros, 200], j, 1]], {j, 2, 6}]},
 AxesLabel -> {"\[Delta]x", "\[Delta]y"} ]

In addition to this visual check, we should perform a more stringent test. To do this, we have a look at the difference of the two sides of the equation zeros.

zeros\[Alpha]\[Beta]\[Gamma]Difference[{\[Alpha]_, \[Beta]_, \
\[Gamma]_}, {\[Delta]x_, \[Delta]y_}] =
 Subtract @@
  zeros\[Alpha]\[Beta]\[Gamma][{\[Alpha], \[Beta], \[Gamma]}, {\
\[Delta]x, \[Delta]y}]

Checking the identity with all zeros calculated to one thousand digits shows that the conjectured identity indeed holds. While this is not a proof, it is a very comforting check.

With[{zerosHP = N[fSqrt3EPiExpZeros, 1000]},
   Table[zeros\[Alpha]\[Beta]\[Gamma]Difference[{Sqrt[3], E, Pi},
       ReIm[#[[-1]] - #[[1]]]] & /@ Partition[zerosHP, j, 1], {j, 2,
     6}]] // Abs // Max

The function that appears in the last formula has the following shape in space.

Y[\[Sigma]_, {x_, y_}] := (Cosh[\[Sigma] y] -
   Cos[\[Sigma] x])^\[Sigma]

ContourPlot3D[
 Y[\[Sigma], {x, y}] == 1 , {x, -4 Pi, 4 Pi}, {y, -4, 4}, {\[Sigma],
  0, 3},
 AxesLabel -> {x, y, \[Sigma]}, ViewPoint -> {0.64, -3.02, 1.37},
 MeshFunctions -> {#3 &},
 BoxRatios -> {2, 1, 1}, PlotPoints -> {80, 40, 60},
 MaxRecursion -> 0]

As a function of and , the function Y obeys two symmetric differential equations:

{D[f[x, y], x]^2 - D[f[x, y], y]^2 + 2 D[f[x, y], y]^2 \[Sigma] -
    2 f[x, y] D[f[x, y], y, y] \[Sigma] + f[x, y]^2 \[Sigma]^4,
   D[f[x, y], x]^2 - D[f[x, y], y]^2 - 2 D[f[x, y], x]^2 \[Sigma] +
    2 f[x, y] D[f[x, y], x, x] \[Sigma] + f[x, y]^2 \[Sigma]^4}  /.

  f -> Function[{x, y}, Y[\[Sigma], {x, y}] ] // Simplify

And the even simpler equation:

  \[Sigma] f[x, y] D[f[x, y], x, y] +
   D[f[x, y], x] (D[f[x, y], y] - \[Sigma] D[f[x, y], y]) /.
  f -> Function[{x, y}, Y[\[Sigma], {x, y}] ] // Simplify

A Generalization

One can easily generalize the previous formula that describes the location of the zero differences to the case .

zeroABC\[Alpha]\[Beta]\[Gamma]Curve[{A_, B_,
   C_}, {\[Alpha]_, \[Beta]_, \[Gamma]_}, {x_, y_}] :=
 Abs[A]^(2 (\[Beta] - \[Gamma])) Abs[B]^(2 (\[Gamma] - \[Alpha]))
   Abs[C]^(2 (\[Alpha] - \[Beta]))
   Y[\[Alpha] - \[Gamma], {x, y}] Y[\[Gamma] - \[Beta], {x,
    y}] Y[\[Beta] - \[Alpha], {x, y}]

Here is a random example of a three-term sum with prefactors.

f2[{A_, B_, C_}, {\[Alpha]_, \[Beta]_, \[Gamma]_}, z_] :=
 A Exp[I \[Alpha] z] + B Exp[I \[Beta] z] + C Exp[I \[Gamma]  z] 

The numerically calculated zero differences all are on the implicitly described curve zeroABCCurve.

With[{\[Alpha] = Sqrt[2], \[Beta] = Sqrt[3], \[Gamma] = E/3,
  A = 1/2 Exp[2 I], B = 3/4 Exp[3^(1/3) I], C = 5/4},
 edzs = Sort[
   N[z /. Solve[
      f2[{A, B, C}, {\[Alpha], \[Beta], \[Gamma]}, z] == 0 \[And] -5 <
         Im[z] < 5 \[And] 0 < Re[z] < 500, z], 100]];
 zeroPairs = -Subtract @@@ Subsets[edzs, {2}];
 lp = ListPlot[ReIm /@ zeroPairs, PlotRange -> {{0, 30}, {-2, 2}}];
 Show[{RegionPlot[
    Evaluate[
     zeroABC\[Alpha]\[Beta]\[Gamma]Curve[{A, B,
        C}, {\[Alpha], \[Beta], \[Gamma]}, {x, y}] > 1], {x, 0,
     30}, {y, -2, 2},
    PlotPoints -> 60,
    PlotStyle -> Directive[RGBColor[0.88, 0.61, 0.14], Opacity[0.3]],
    BoundaryStyle -> None], lp}, AspectRatio -> 1/3]]

Phases in the three exponents have no influence on the positions and shapes of the ovals. Here is an example that demonstrates this. The blue points with zero phases are on the same curve as the yellow/brown points that come from the exponential polynomial with phases. Just their position on the curve depends on the phases.

f3[{A_, B_,
   C_}, {\[Alpha]_, \[Beta]_, \[Gamma]_}, {\[CurlyPhi]\[Alpha]_, \
\[CurlyPhi]\[Beta]_, \[CurlyPhi]\[Gamma]_}, z_] :=
 A Exp[I \[Alpha] z + I \[CurlyPhi]\[Alpha]] +
  B Exp[I \[Beta] z + I \[CurlyPhi]\[Beta]] +
  C Exp[I \[Gamma] z + I \[CurlyPhi]\[Gamma]] 

With[{\[Alpha] = Sqrt[2], \[Beta] = Sqrt[3], \[Gamma] = E/3, A = 1/2,
  B = 3/4, C = 5/4,  \[CurlyPhi]\[Alpha] = 1, \[CurlyPhi]\[Beta] =
   2, \[CurlyPhi]\[Gamma] = 3},
 edzs1 = Sort[
   N[z /. Solve[
      f3[{A, B, C}, {\[Alpha], \[Beta], \[Gamma]}, {0, 0, 0}, z] ==
        0 \[And]
                  -5 < Im[z] < 5 \[And] 0 < Re[z] < 500, z], 100]];
 edzs2 = Sort[
   N[z /. Solve[
      f3[{A, B,
          C}, {\[Alpha], \[Beta], \[Gamma]}, {\[CurlyPhi]\[Alpha], \
\[CurlyPhi]\[Beta], \[CurlyPhi]\[Gamma]}, z] == 0 \[And]
       -5 < Im[z] < 5 \[And] 0 < Re[z] < 500, z], 100]];
   ListPlot[{ReIm /@ (-Subtract @@@ Subsets[edzs1, {2}]),
                    ReIm /@ (-Subtract @@@ Subsets[edzs2, {2}])},
  PlotRange -> {{0, 30}, {-2, 2}}] ]

The ovals don't always have to be separated. For appropriate parameter values , , , , and the ovals can melt onto strips. Here is an example.

ContourPlot[
 Evaluate[zeroABC\[Alpha]\[Beta]\[Gamma]Curve[{1, 2, 1}, {0, Log[2],
     Log[3]}, {x, y}] == 1], {x, 0, 40}, {y, -5, 5},
 PlotPoints -> {80, 20}, AspectRatio -> 1/2]

If we use , , that are not incommensurable, the zeros still lay on the curve described by zeroABCCurve. In this case, we sometimes can get closed forms for all zeros. Here is a simple example that brings us back to the golden ratio shown previously.

Solve[ 2 + 2 Exp[1/2 I z] + I Exp[1 I z] == 0, z]

For C[1]==0, we form the difference of the two zeros.

diff = (Subtract @@ (z /. % /. ConditionalExpression[x_, _] :> x /.
      C[1] -> 0)) // FullSimplify

zeroABC\[Alpha]\[Beta]\[Gamma]Curve[{2, 2, I}, {0, 1/2, 1},
   ReIm[diff]] /. (ri : (_Re | _Im)) :>
   ComplexExpand[ri, TargetFunctions -> {Re, Im}] // FullSimplify

N[%, 50]

The two expressions in the denominator are exotic representations of and 1/.

N[{Cosh[ArcTan[Im[((1 + I) - Sqrt[-1 + 2 I])^I]/
      Re[((1 + I) - Sqrt[-1 + 2 I])^I]]],
    Cos[Log[Abs[((1 + I) - Sqrt[-1 + 2 I])^I]]]} - {GoldenRatio,
    1/GoldenRatio}, 20] // Quiet

Unfortunately there is no similar equation that describes the zeros of the sum of four exponentials. The addition of the fourth exponential term changes the behavior of the zero differences dramatically. We calculate 100+ zeros of the three-term sum .

zs = With[{L = 200},
   Monitor[Flatten@Table[
      N[z /.
        Solve[Exp[I Sqrt[2] z] + Exp[I Zeta[3] z] + Exp[I E/2 z] ==
           0 \[And] -30 < Im[z] < 20 \[And] j L < Re[z] < j L + L, z],
        20] , {j, 0, 20}] , j]];

We calculate the -dependent zeros of using the differential equations of these zeros.

nds = NDSolveValue[
  {D[Exp[I Sqrt[2] z[\[CurlyEpsilon]]] +
      Exp[I Zeta[3] z[\[CurlyEpsilon]]] +
      Exp[I E/2 z[\[CurlyEpsilon]]] + \[CurlyEpsilon] Exp[
        I 3^(1/3) z[\[CurlyEpsilon]]], \[CurlyEpsilon]] == 0,
   z[0] == zs}, z, {\[CurlyEpsilon], 0, 1}]

Graphically, the zeros on their own mostly change the real part.

pt[\[CurlyEpsilon]_Real] := ReIm[nds[\[CurlyEpsilon]]]
ParametricPlot[pt[\[CurlyEpsilon]], {\[CurlyEpsilon], 0, 1},
 AspectRatio -> 1/3]

But the differences of the zeros show a much more complicated dependence of .

diffs[\[CurlyEpsilon]_Real] :=
 With[{zeros = SortBy[nds[\[CurlyEpsilon]], Re]},
  ReIm[Flatten[
    Table[zeros[[i + j]] - zeros[[i]], {j, 1, 4}, {i,
      Length[zeros] - j}]]]]

ListPlot[Transpose[
  Table[diffs[N[\[CurlyEpsilon]]], {\[CurlyEpsilon], 0, 1, 1/100}]],
 Joined -> True, PlotStyle -> Thickness[0.002]]

Generically, in the case of four exponentials, the differences between zeros are no longer located on curves, but fill regions of the complex plane densely. The following input calculated about 75,000 zeros of a four-term exponential polynomial. (In the notebook, this cell is set to unevaluatable because it will run a few hours.)

L = 200; counter = 0;
Monitor[
 zs = Flatten@Table[
     N[z /.
       Solve[Exp[I Sqrt[2] z] + Exp[I Zeta[3] z] + Exp[I E/2 z] +
           Exp[I 3^(1/3) z] == 0 \[And] -30 < Im[z] < 20 \[And]
         jj L < Re[z] < jj L + L, z], 20],
     counter = counter + Length[zeros];, {jj, 0, 10^4}]; , { jj,
  counter}]

Plotting the first few differences shows how the zero differences fill out a stripe along the real axis.

ListPlot[Table[
  ReIm[#[[-1]] - #[[1]]] & /@ (
    Partition[SortBy[N[zs], Re], jk, 1]), {jk, 8}],
 PlotStyle -> {PointSize[0.001]}, Frame -> True,
 PlotRange -> {{10, All}, All}, AspectRatio -> 1/2]

Reduced forms of a sum of four exponentials, e.g. one constant term and the remaining three terms algebraically dependent, show an intermediate degree of complexity in the zero differences. Here is an example.

f\[Alpha][z_] :=
 A + 2 Exp[I z] + Exp[I \[Alpha] z] Exp[-I z] +
  Exp[I \[Alpha] z] Exp[I z]

Monitor[sol = Flatten[
    Table[
     Solve[(f\[Alpha][z] ==
          0 /. {A -> 1/3, \[Alpha] -> Sqrt[3]}) && -10 < Im[z] < 10 &&
        20 k < Re[z] < 20 k + 20, z], {k, 0, 50}], 1], k];

zs = Cases[N[z /. sol], _Complex];

ListPlot[ReIm[Subtract @@@ (Reverse /@  Subsets[zs, {2}])],
 PlotRange -> {{0, 12}, All}, Frame -> True, AspectRatio -> 1/3]

Finding a closed form for these curves is surely possible, but the symbolic expressions that are needed in intermediate steps are quite large. So we will postpone this calculation to a later time.

To summarize: continuing some mathematical experiments about the positions of zeros of sums of complex trigonometric functions, "strange" circles were observed. Using a mixture of visualization, numerical experiments and algebraic computations, all of which work seamlessly together in the Wolfram Language, we were able to determine a closed form equation for the positions of these "circles."


Download this post as a Computable Document Format (CDF) file. New to CDF? Get your copy for free with this one-time download.

]]>
2
Melanie Moore <![CDATA[Experience Innovation and Insight at the 2018 Wolfram Technology Conference]]> http://blog.internal.wolfram.com/?p=45350 2018-05-03T19:37:21Z 2018-05-03T19:37:21Z Join us October 16–19, 2018, for four days of hands-on training, workshops, talks and networking with creators, experts and enthusiasts of Wolfram technology. We’ll kick off on Tuesday, October 16, with a keynote address by Wolfram founder and CEO Stephen Wolfram.



Before the conference begins, take a tour of the Wolfram Research headquarters or join one of our in-depth training sessions. Pre-conference opportunities include:

  • Wolfram Language Crash Course for Scientists & Engineers
  • Learn Image Processing with the Wolfram Language
  • The Multiparadigm Data Science Workflow
  • The Data Science Pipeline: Analysis to Insight

Interested in speaking at the conference? The Wolfram Technology Conference is a great platform to share your innovations, stories and work. Submit your abstract by July 27, 2018, for consideration.

Data Science, Engineering, Math and More!

This year’s conference will have three distinct focus areas: Data Science & AI, Engineering & Modeling and Math & Science.

  • Data Science & AI provides hands-on experience, allowing you to work with industry experts to apply automated machine learning, deep neural networks and advanced human-data interfaces to real-world problems.
  • Keep up with the newest tech and best practices in Engineering & Modeling by exploring ways to integrate symbolic-numeric computation, machine learning, visualizations and automated algorithm selection into your workflows.
  • Finally, dive into the latest trends and functionalities in a variety of topical areas, from machine learning to advanced geometry, statistics, chemistry and more in the Math & Science track.

Last year, we introduced the Wolfram Livecoding Championship, where participants answered challenges from Stephen using Wolfram Language code, showing off their skills and competing for the Wolfram Livecoding Championship belt. We’re bringing the Championship back this year, along with other favorites and some new special treats.

To reserve your spot at this year’s Wolfram Technology Conference, register today.

]]>
2
Michael Trott <![CDATA[A Tale of Three Cosines—An Experimental Mathematics Adventure]]> http://blog.internal.wolfram.com/?p=44716 2018-05-11T19:42:20Z 2018-04-24T17:00:05Z #post-44716 h2 { margin: 2px 0 0 0; font-size: 22px; padding: 12px 0 6px; display: block; float: none; } #post-44716 h3 { color: #333; margin: 5px 0 10px; font-size: 18px; } #post-44716 blockquote { //padding: 10px 25px; font-family: Georgia; font-style: italic; font-size: 130%; line-height: 1.4; color: #e26a0f; margin: 0 0 8px; //border-top: 1px solid #c3c3c3; //border-bottom: 1px solid #c3c3c3; } #post-44716 blockquote p { margin: 0; padding: 0; }

Identifying Peaks in Distributions of Zeros and Extrema of Almost-Periodic Functions: Inspired by Answering a MathOverflow Question

One of the Holy Grails of mathematics is the Riemann zeta function, especially its zeros. One representation of is the infinite sum . In the last few years, the interest in partial sums of such infinite sums and their zeros has grown. A single cosine or sine function is periodic, and the distribution of its zeros is straightforward to describe. A sum of two cosine functions can be written as a product of two cosines, . Similarly, a sum of two sine functions can be written as a product of . This reduces the zero-finding of a sum of two cosines or sines to the case of a single one. A sum of three cosine or sine functions, , is already much more interesting.

Fifteen years ago, in the notes to chapter 4 of Stephen Wolfram’s A New Kind of Science, a log plot of the distribution of the zero distances…

A New Kind of Science, notes from Chapter 4

… of the zero distribution of —showing characteristic peaks—was shown.

And a recent question on MathOverflow.net asked for the closed forms of the positions of the maxima of the distribution of the distances of successive zeros of almost-periodic functions of the form for incommensurate and . The post showed some interesting-looking graphics, the first of which was the following ( is the golden ratio) for the distance between successive zeros (taking into account the first 100k positive zeros):

Positions of the maxima

At first, one might be skeptical seeing such an unusual-looking histogram, but a quick one-liner that calculates all zeros in the intervals and does confirm a distribution of the shape shown above as a universal shape independent of the argument range for large enough intervals.

Function[x0, Histogram[Differences[
     t /. Solve[
      Cos[t] + Cos[GoldenRatio t] + Cos[GoldenRatio^2 t] == 0 \[And]
       x0 < t < x0 + 10^3 \[Pi], t]], 200]] /@ {0, 10^6}

Output 1

And the MathOverflow post goes on to conjecture that the continued fraction expansions of are involved in the closed-form expressions for the position of the clearly visible peaks around zero distance , with 1, 1.5, 1.8 and 3.0. In the following, we will reproduce this plot, as well as generate, interpret and analyze many related ones; we will also try to come to an intuitive as well as algebraic understanding of why the distribution looks so.

It turns out the answer is simpler, and one does not need the continued fraction expansion of . Analyzing hundreds of thousands of zeros, plotting the curves around zeros and extrema and identifying envelope curves lets one conjecture that the positions of the four dominant singularities are twice the smallest roots of the four equations.

Or in short form: .

The idea that the concrete Diophantine properties of and determine the positions of the zeros and their distances seems quite natural. A well-known example where the continued fraction expansion does matter is the difference set of the sets of numbers for a fixed irrational (Bleher, 1990). Truncating the set of for , one obtains the following distributions for the spacings between neighboring values of . The distributions are visibly different and do depend on the continued fraction properties of .

sumSpacings[\[Alpha]_, n_] :=
 With[{k = Ceiling[Sqrt[n/\[Alpha]]]}, Take[#, UpTo[n]] &@N@
    Differences[
     Sort[Flatten[
       Table[N[i + \[Alpha] j, 10], {i, Ceiling[\[Alpha] k]}, {j,
         k}]]]]]

ListLogLogPlot[Tally[sumSpacings[1/#, 100000]],
                              Filling -> Axis,
   PlotRange -> {{10^-3, 1}, All},
   PlotLabel -> HoldForm[\[Alpha] == 1/#],

   Ticks -> {{ 0.01, 0.1, 0.5}, Automatic}] & /@ {GoldenRatio, Pi,
  CubeRoot[3]}

Output 2

Because for incommensurate values of and , one could intuitively assume that all possible relative phases between the three cos terms occur with increasing . And because most relative phase situations do occur, the details of the (continued fraction) digits of and do not matter. But not every possible curve shape of the sum of the three cos terms will be after a zero, nor will they be realized; the occurring phases might not be equally or uniformly distributed. But concrete realizations of the phases will define a boundary curve of the possible curve shapes. At these boundaries (envelopes), the curve will cluster, and these clustered curves will lead to the spikes visible in the aforementioned graphic. This clustering together with the almost-periodic property of the function leads to the sharp peaks in the distribution of the zeros.

The first image in the previously mentioned post uses the function , with being the golden ratio. Some structures in the zero distribution are universal and occur for all functions of the form for generic nonrational , , but some structures are special to the concrete coefficients , , the reason being that the relation slips in some dependencies between the three summands , and . (The three-parameter case of can be rescaled to the above case with only two parameters, and .) At the same time, the choice , has most of the features of the generic case. As we will see, using , for other quadratic irrationals generates zero spacing distributions with additional structures.

In this blog, I will demonstrate how one could come to the conjecture that the above four equations describe the positions of the singularities using static and interactive visualizations for gaining intuition of the behavior of functions and families of functions; numerical computations for obtaining tens of thousand of zeros; and symbolic polynomial computations to derive (sometimes quite large) equations.

Although just a simple sum, three real cosines with linear arguments, the zeros, extrema and function values will show a remarkable variety of shapes and distributions.

After investigating an intuitive approach based on envelopes, an algebraic approach will be used to determine the peaks of the zero distributions as well as the maximal possible distance between two successive zeros.

Rather than stating and proving the result for the position of the peaks, in this blog I want to show how, with graphical and numerical experiments, one is naturally led to the result. Despite ( being the golden ratio) being such a simple-looking function, it turns out that the distribution and correlation of its function values, zeros and extrema are rich sources of interesting, and for most people unexpected, structures. So in addition to finding the peak position, I will construct and analyze various related graphics and features, as well as some related functions.

While this blog does contain a fair amount of Wolfram Language code, the vast majority of inputs are short and straightforward. Only a few more complicated functions will have to be defined.

The overall plan will be the following:

    • Look at the function values of for various and to get a first impression of the function
    • Calculate and visualize the zeros of
    • Calculate and visualize the extrema of
    • Divide the zeros into groups and plot them around their zeros to identify common features
    • Ponder about the plots of around the zeros, and identify the role of envelopes
    • Develop algebraic equations that describe the peak positions of the zero distributions
    • Numerically and semi-analytically investigate the distribution in the neighborhood of the peaks
    • Determine the maximal spacing between successive zeros

From time to time, we will take a little detour to have a look at some questions that come up naturally while carrying out the outlined steps. Although simple and short looking, the function has a lot of interesting features, and even in this long blog (the longest one I have ever written!), not all features of interest can be discussed.

The distribution of function values of the sums of the three sine/cosine function is discussed in Blevins, 1997, and the pair correlation between successive zeros was looked at in Maeda, 1996.

Introduction and Almost Recurrences

Here are some almost-periodic functions. The functions are all of the form for incommensurate and .

fGolden[x_] := Cos[x] + Cos[GoldenRatio x] + Cos[GoldenRatio^2 x]

fPi[x_] := Cos[x] + Cos[Pi x] + Cos[Pi^2 x]

fSqrt[x_] := Cos[x] + Cos[Sqrt[2] x] + Cos[Sqrt[3] x]

fCbrt[x_] := Cos[x] + Cos[CubeRoot[2] x] + Cos[CubeRoot[3] x]

Here is a plot of these four functions. Note that they have a visibly different character, e.g. the blue curve, on average, doesn’t seem to extend as much toward negative values as the other curves.

Plot[{fGolden[x], fPi[x], fSqrt[x], fCbrt[x]} // Evaluate, {x, 0,
  10 Pi},
 PlotStyle -> Thickness[0.002], PlotLegends -> "Expressions"] 

Output 3

The following interactive demonstration allows one to change the parameters and as well as the ranges over which the function is plotted. (Try to find parameter values such that four or more consecutive extrema are all above or below the real axis.)

Manipulate[
 Plot[Evaluate[
   Cos[x0 + \[Delta]x] + Cos[\[Alpha]\[Beta][[1]] (x0 + \[Delta]x)] +
    Cos[\[Alpha]\[Beta][[2]] (x0 + \[Delta]x)]],
             {\[Delta]x, -X, X}, PlotPoints -> 60, PlotRange -> 3.2,

  PlotLabel ->
   Row[{{"\[Alpha]", "\[Beta]"}, "\[Equal]\[ThinSpace]",
     NumberForm[\[Alpha]\[Beta], 3]}]],
 {{\[Alpha]\[Beta], {3., 2.5}, "\[Alpha],\[Beta]"}, {0, 0}, {3, 3}},
 {{X, 22.7}, 0, 30, Appearance -> "Labeled"},
 {{x0, 473, Subscript["x", 0]}, 0, 1000, Appearance -> "Labeled"},
 TrackedSymbols :> True]

Output 4

And here is a 2D plot of the function over the plane. The interplay between periodicity and broken periodicity is nicely visible.

 With[{m = 600},
 ReliefPlot[
  Log[Abs[Table[
      Evaluate[N[1. Cos[x] + Cos[\[Alpha] x] + Cos[\[Alpha]^2 x]]] ,
                                                 {\[Alpha], 0, 3/2,
       3/2/m}, {x, 0, 48 Pi, 48 Pi/(2 m)}]] + 1],
                         FrameTicks -> True, AspectRatio -> 1/3,
                         DataRange -> {{0, 48 Pi}, {0, 3/2}},
  FrameLabel -> {x, \[Alpha]}]]

Output 5

The interplay between translation symmetry along the axis and symmetry violations becomes even more visible if one colors the connected regions where the function value is negative.

rp = RegionPlot[
  Cos[x] + Cos[\[Alpha] x] + Cos[\[Alpha]^2 x] < 0, {x, 0,
   48 Pi}, {\[Alpha], 0, 5/4},
                         PlotPoints -> {200, 80}, AspectRatio -> 1/3,
  FrameLabel -> {x, \[Alpha]}]

Output 6

We color the connected regions with different colors. The connected regions of one color will gain more meaning below when we construct parts of the Riemann surface of .

Graphics[{EdgeForm[], Antialiasing -> False,
    Blend[{RGBColor[0.88, 0.61, 0.14], RGBColor[0.36, 0.51, 0.71]},
     RandomReal[]], MeshPrimitives[#, 2]} & /@
  ConnectedMeshComponents[
   MeshRegion[#1, Cases[#2, _Polygon, \[Infinity]]] & @@
    Cases[rp, _GraphicsComplex, \[Infinity]][[1]]],
 AspectRatio -> 1/3, Frame -> True, FrameLabel -> {x, \[Alpha]}]

Output 7

The zero set of the more general surface forms a regular network-like surface. A 3D plot of the zero surface shows this nicely. The irregularities in the last image with the colored regions arise from slicing the 3D surface from the next image with the surface .

ContourPlot3D[
 Cos[x] + Cos[\[Alpha] x] + Cos[\[Beta] x] == 0, {x, 0,
  80}, {\[Alpha], 0, 3/2}, {\[Beta], 0, 3/2},
 RegionFunction -> (#2 < #3 &), MeshFunctions -> {Norm[{#1, #2}] &},
 PlotPoints -> {60, 60, 160}, MaxRecursion -> 0,
 BoxRatios -> {3, 1, 1},
 ViewPoint -> {-1.04, -3.52, 0.39},
 AxesLabel -> {x, \[Alpha], \[Beta]}, ImageSize -> 400]

Output 8

Let’s now focus on the first function from above, . As already mentioned, this function is a bit special compared to the generic case where and are totally unrelated. Expanding the two golden ratios, we have the following representation.

fGolden[x] // FunctionExpand // Simplify

Output 9

This function will generate a distribution of zero distances with sharp discontinuities, something that will not happen in the generic case.

Plot[fGolden[x], {x, 0, 33 Pi}]

Output 10

Interestingly, and probably unexpectedly, one sees many positions with , but no function values with .

The special nature of the sum of the three-cosine term comes from the fundamental identities that define the golden ratio.

Entity["MathematicalConstant", "GoldenRatio"]["Identities"] //
  Take[#, 5] & // TraditionalForm

Output 11

While will never strictly repeat itself (its period is zero)...

FunctionPeriod[fGolden[x], x]

Output 12

... when we calculate the squared difference of and over , one sees that the function nearly repeats itself many, many times. (To make the values where and are nearly identical, I plot the negative logarithm of the difference, meaning spikes correspond to the values of where over a domain of size .)

overlapDiff = (Integrate[#, {x, 0, X}] & /@
    Expand[(fGolden[x] - fGolden[T + x])^2]);
cfOverlapDiff = Compile[{T, X}, Evaluate[overlapDiff]];

Plot[-Log[Abs[cfOverlapDiff[T, 2 Pi]]], {T, 1, 10000},
           AxesOrigin -> {0, -4}, PlotPoints -> 2000,
 PlotRange -> All, AxesLabel -> {T, None}]

Output 13

Locating the peak around 2,400, more precisely, one sees that in this neighborhood the two functions nearly coincide. The difference over a  interval is quite small, on the order of 0.005. We can easily locate the exact location of this local maximum.

FindMaximum[-Log[Abs[overlapDiff /. X -> 2 Pi]], {T, 2369},
                              WorkingPrecision -> 50,
  PrecisionGoal -> 20] // N[#, 20] &

Output 14

In the left graphic, the two curves are not distinguishable; the right plot shows the difference between the two curves.

With[{T = 2368.763898630},
     {Plot[{fGolden[x], fGolden[T + x]}, {x, 0, 2 Pi}],
  Plot[fGolden[x] - fGolden[T + x], {x, 0, 2 Pi},
   PlotLabel -> "difference"]}]

Output 15

The choice , results in some nontypical (compared to the case of general ) correlations between the last two summands. The following interactive demonstration shows a phase space–like plot of and its derivative with changeable and .

Manipulate[
 Column[{Row[{Row[{"\[Alpha]",
        "\[ThinSpace]\[Equal]\[ThinSpace]", \[Alpha]}], "  |  ",
      Row[{"\[Beta]",
        "\[ThinSpace]\[Equal]\[ThinSpace]", \[Beta]}]}],
    If[d == 2,
     ParametricPlot[
      Evaluate[{Cos[x] + Cos[\[Alpha] x] + Cos[\[Beta] x],
        D[Cos[x] + Cos[\[Alpha] x] + Cos[\[Beta] x], x]}],
                               {x, 0, 10^xMax}, AspectRatio -> 1,
      PlotPoints -> Ceiling[10^xMax 4],

      PlotStyle ->
       Directive[Thickness[0.001], RGBColor[0.36, 0.51, 0.71]],
                                 ImageSize -> 360,
      PlotRange -> {3 {-1, 1}, (1 + \[Alpha] + \[Beta]) {-1, 1}},
                                 Frame -> True, Axes -> False],
       ParametricPlot3D[
      Evaluate[{Cos[x] + Cos[\[Alpha] x] + Cos[\[Beta] x],
        D[Cos[x] + Cos[\[Alpha] x] + Cos[\[Beta] x], x],

        D[Cos[x] + Cos[\[Alpha] x] + Cos[\[Beta] x], x, x]}],
                               {x, 0, 10^xMax}, AspectRatio -> 1,
      PlotPoints -> Ceiling[10^xMax 4],

      PlotStyle ->
       Directive[Thickness[0.001], RGBColor[0.36, 0.51, 0.71]],
                                 ImageSize -> 360,
      Axes -> False,     

      PlotRange -> {3 {-1, 1}, (1 + \[Alpha] + \[Beta]) {-1,
          1}, (1 + \[Alpha]^2 + \[Beta]^2) {-1, 1}} ]]},
                                            Alignment -> Center] //
  TraditionalForm,
 {{d, 2, ""}, {2 ->
    Row[{Style["x", Italic], ",", Style["x", Italic], "'"}], 

   3 -> Row[{Style["x", Italic], ",", Style["x", Italic], "'", ",",
      Style["x", Italic], "''"}]}},
 {{xMax, 2.8, Subscript["x", "max"]}, 0.1, 4},
 {{\[Alpha], GoldenRatio}, 1/2, 3}, {{\[Beta], GoldenRatio^2}, 1/2, 3},
 TrackedSymbols :> True]

Output 16

The fϕ(x) ≈ 3 Recurrences

Among the positions where the function will nearly repeat will also be intervals where . Let’s find such values. To do this, one needs to find values of such that simultaneously the three expressions , and are very near to integer multiples of . The function rationalize yields simultaneous rational approximations with an approximate error of . (See Zhang and Liu, 2017 for a nice statistical physics-inspired discussion of recurrences.)

rationalize[\[Alpha]s_List, \[CurlyEpsilon]_] :=
 Module[{B, RB, q, T, Q = Round[1/\[CurlyEpsilon]]},
       B = Normal[SparseArray[Flatten[ {{1, 1} -> 1,
        MapIndexed[({1, #2[[1]] + 1} -> Round[Q #]) &, \[Alpha]s],
       Table[{j, j} -> Q, {j, 2, Length[\[Alpha]s] + 1}]}]]];
      RB = LatticeReduce[B];
      (* common denominator *) q = Abs[RB[[1, 1]]];
  -Round[Rest[RB[[1]]]/Q - q \[Alpha]s]/q ] 

Here is an example of three rationals (with a common denominator) that within an error of about are approximations of 1, , . (The first one could be written as .)

rationalize[{1, GoldenRatio, GoldenRatio^2}, 10^-40]

Output 17

Block[{$MaxExtraPrecision = 1000},
 N[% - {1, GoldenRatio, GoldenRatio^2}, 10]]

Output 18

Given these approximations, one can easily calculate the corresponding “almost” period of (meaning ).

getPeriod[\[Alpha]s_, \[CurlyEpsilon]_] :=
 Module[{rat, den, period},
                   rat = rationalize[\[Alpha]s, \[CurlyEpsilon]];
                  den = Denominator[Last[rat]];
                 period = 2 Pi den ]

The arguments are listed in increasing order, such that assumes values very close to 3.

(nearlyThreeArguments =
   Table[period =
      getPeriod[{1, GoldenRatio, GoldenRatio^2}, 10^-exp];
              {period, N[3 - fGolden[period], 10]},
     {exp, 2, 20, 0.1}] // DeleteDuplicates) // Short[#, 6] &

Output 19

ListLogLogPlot[nearlyThreeArguments]

Output 20

Around , the function again takes on the value 3 up to a difference on the order of .

TLarge = getPeriod[{1, GoldenRatio, GoldenRatio^2}, 10^-1001]

Output 21

Block[{$MaxExtraPrecision = 10000}, N[3 - fGolden[TLarge], 10]]

Output 22

The Function Values of fϕ(x)

Now let us look at the function in more detail, namely the distribution of the function values of at various scales and discretizations. The distribution seems invariant with respect to discretization scales (we use the same amount of points in each of the four intervals.).

 (With[{max = Round[500 #/0.001]},
     Histogram[Table[Evaluate[N[fGolden[x]]], {x, 0, max Pi, #}],
      500, PlotLabel -> Row[{"[", 0, ",", max Pi, "]"}]]] & /@
                                           {0.001, 0.01, 0.1, 1}) //
 Partition[#, 2] &

Output 23

Interestingly, the three terms , and are always partially phase locked, and so not all function values between –3 and 3 are attained. Here are the values of the three summands for different arguments. Interpreted as 3-tuples within the cube , these values are on a 2D surface. (This is not the generic situation for general and , in which case the cube is generically densely filled; see below).

Graphics3D[{PointSize[0.001], RGBColor[0.36, 0.51, 0.71], Opacity[0.4],
  Point[Union@
    Round[Table[
      Evaluate[
       N[{Cos[x], Cos[GoldenRatio x], Cos[GoldenRatio^2 x]}]],
                                                      {x, 0, 500 Pi,
       0.02}], 0.01]]},
                          PlotRange -> {{-1, 1}, {-1, 1}, {-1, 1}},
 Axes -> True,

 AxesLabel -> {x, Cos[GoldenRatio x], Cos[GoldenRatio^2 x]}]

Output 24

The points are all on a tetrahedron-like surface. Plotting the images of the intervals in different colors shows nicely how this surface is more and more covered by repeatedly winding around the tetrahedron-like surface, and no point is ever assumed twice.

Show[Table[
  ParametricPlot3D[
   Evaluate[N[{Cos[x], Cos[GoldenRatio x], Cos[GoldenRatio^2 x]}]],
                     {x, k 2 Pi, (k + 1) 2 Pi},
   PlotStyle ->
    Directive[
     Blend[{{0, RGBColor[0.88, 0.61, 0.14]}, {30,
        RGBColor[0.36, 0.51, 0.71]},
       {60, RGBColor[0.561, 0.69, 0.19]}}, k],
     Thickness[0.001]]], {k, 0, 60}],

 AxesLabel -> {x, Cos[GoldenRatio x], Cos[GoldenRatio^2 x]}]

Output 25

Ultimately, the fact that the points are all on a surface reduces to the fact that the points are not filling the cube densely, but rather are located on parallel planes with finite distance between them.

Graphics3D[{PointSize[0.002], RGBColor[0.36, 0.51, 0.71],

  Point[Table[
    Mod[{x, GoldenRatio x, GoldenRatio^2 x}, 2 Pi], {x, 0.,
     10000}]]},

 AxesLabel -> (HoldForm[Mod[# x, 2 Pi]] & /@ {1, GoldenRatio,
     GoldenRatio^2}),

 PlotRange -> {{0, 2 Pi}, {0, 2 Pi}, {0, 2 Pi}}]

Output 26

As we will look at distances often in this blog, let us have a quick look at the distances of points on the surface. To do this, we use 1,000 points per intervals, and we will use 1,000 intervals. The left graphic shows the distribution between consecutive points, and the right graphic shows the distance to the nearest point for all points. The peaks in the right-hand histogram come from points near the corners as well as from points of bands around diameters around the smooth parts of the tetrahedron-like surface.

Module[{pts =
   Table[ {Cos[x], Cos[GoldenRatio x], Cos[GoldenRatio^2 x]},
                                      {x, 0. 2 Pi, 1000 2 Pi,
     2 Pi/1000}], nf},
 nf = Nearest[pts];
    {Histogram[EuclideanDistance @@@ Partition[pts, 2, 1], 1000,
   PlotRange -> All],
  Histogram[EuclideanDistance[#, nf[#, 2][[-1]]] & /@ pts, 1000,
   PlotRange -> All]}]

Output 27

The tetrahedron-like shape looks like a Cayley surface, and indeed, the values fulfill the equation of a Cayley surface. (Later, after complexifying the equation for , it will be obvious why a Cayley surface appears here.)

x^2 + y^2 + z^2 == 1 + 2 x y z /.
  {x -> Cos[t], y -> Cos[GoldenRatio t],
   z -> Cos[GoldenRatio^2 t]} // FullSimplify

Output 28

While the three functions , , are algebraically related through a quadratic polynomial, any pair of these three functions is not related through an algebraic relation; with ranging over the real numbers, any pair covers the square densely.

With[{c1 = Cos[1 x], c\[Phi] = Cos[GoldenRatio x],
  c\[Phi]2 = Cos[GoldenRatio^2 x], m = 100000},
 Graphics[{PointSize[0.001], RGBColor[0.36, 0.51, 0.71],
     Point[Table[#, {x, 0., m, 1}]]}] & /@ {{c1, c\[Phi]}, {c1,
    c\[Phi]2}, {c\[Phi], c\[Phi]2}}]

Output 29

This means that our function for a given contains only two algebraically independent components. This algebraic relation will be essential for understanding the special case of the cosine sum for , and for getting some closed-form polynomials for the zero distances later.

This polynomial equation of the three summands also explains purely algebraically why the observed minimal function value of is not –3, but rather –3/2.

MinValue[{x + y + z,
  x^2 + y^2 + z^2 == 1 + 2 x y z \[And] -1 < x < 1 \[And] -1 < y <
    1 \[And] -1 < z < 1}, {x, y, z}]

Output 30

cayley = ContourPlot3D[
   x^2 + y^2 + z^2 == 1 + 2 x y z, {x, -1, 1}, {y, -1, 1}, {z, -1, 1},
    Mesh -> None];

And the points are indeed on it. Advancing the argument by and coloring the spheres successively, one gets the following graphic.

With[{M = 10000, \[Delta] = 1},
 Show[{cayley, Graphics3D[Table[{ColorData["DarkRainbow"][x/M],
      Sphere[N[{Cos[1. x], Cos[GoldenRatio x], Cos[GoldenRatio^2 x]}],
        0.02]},
                                                      {x, 0,
      M, \[Delta]}]]}, Method -> {"SpherePoints" -> 8}]]

Output 31

Here I will make use of the function , which arises from by adding independent phases to the three cosine terms. The resulting surface formed by as varies and forms a more complicated shape than just a Cayley surface.

Manipulate[
 With[{pts =
    Table[Evaluate[
      N[{Cos[x + \[CurlyPhi]1], Cos[GoldenRatio x + \[CurlyPhi]2],
        Cos[GoldenRatio^2 x + \[CurlyPhi]3]}]], {x, 0, M Pi,
      10^\[Delta]t}]},
  Graphics3D[{PointSize[0.003], RGBColor[0.36, 0.51, 0.71],
    Thickness[0.002],

    Which[pl == "points", Point[pts], pl == "line", Line[pts],
     pl == "spheres", Sphere[pts, 0.2/CubeRoot[Length[pts]]]]},
   PlotRange -> {{-1, 1}, {-1, 1}, {-1, 1}},
   Method -> {"SpherePoints" -> 8}]],
 {{pl, "line", ""}, {"line", "points", "spheres"}},
 {{M, 100}, 1, 500, Appearance -> "Labeled"},
 {{\[Delta]t, -1.6}, -2, 1},
 {{\[CurlyPhi]1, Pi/2, Subscript["\[CurlyPhi]", 1]}, 0, 2 Pi,
  Appearance -> "Labeled"},
 {{\[CurlyPhi]2, Pi/2, Subscript["\[CurlyPhi]", 2]}, 0, 2 Pi,
  Appearance -> "Labeled"},
 {{\[CurlyPhi]3, Pi/2, Subscript["\[CurlyPhi]", 3]}, 0, 2 Pi,
  Appearance -> "Labeled"},
  TrackedSymbols :> True] 

Output 32

The points are still located on an algebraic surface; the implicit equation of the surface is now the following.

surface[{x_, y_,
   z_}, {\[CurlyPhi]1_, \[CurlyPhi]2_, \[CurlyPhi]3_}] := (x^4 + y^4 +
     z^4) - (x^2 + y^2 + z^2) + 4 x^2 y^2 z^2 -
  x y z (4 (x^2 + y^2 + z^2) -
     5) Cos[\[CurlyPhi]1 + \[CurlyPhi]2 - \[CurlyPhi]3] + (2 (x^2 y^2 \
+ x^2 z^2 + y^2 z^2) - (x^2 + y^2 + z^2) + 1/2) Cos[
    2 (\[CurlyPhi]1 + \[CurlyPhi]2 - \[CurlyPhi]3)] -
  x y z Cos[3 (\[CurlyPhi]1 + \[CurlyPhi]2 - \[CurlyPhi]3)] +
  Cos[4 (\[CurlyPhi]1 + \[CurlyPhi]2 - \[CurlyPhi]3)]/8 + 3/8

surface[{Cos[t + \[CurlyPhi]1], Cos[GoldenRatio t + \[CurlyPhi]2],
     Cos[GoldenRatio^2 t + \[CurlyPhi]3]}, {\[CurlyPhi]1, \
\[CurlyPhi]2, \[CurlyPhi]3}] // TrigToExp // Factor // Simplify

Output 33

For vanishing phases , and , one recovers the Cayley surface.

surface[{x, y, z}, {0, 0, 0}] // Simplify

Output 34

Note that the implicit equation does only depend on a linear combination of the three parameters, namely . Here are some examples of the surface.

Partition[
 Table[ContourPlot3D[
   Evaluate[surface[{x, y, z}, {c, 0, 0}] == 0], {x, -1.1,
    1.1}, {y, -1.1, 1.1}, {z, -1.1, 1.1},
   MeshFunctions -> (Norm[{#1, #2, #3}] &),
   MeshStyle -> RGBColor[0.36, 0.51, 0.71],
   PlotPoints -> 40, MaxRecursion -> 2, Axes -> False,
   ImageSize -> 180], {c, 6}], 3]

Output 35

As a side note, I want to mention that for being the smallest positive solution of are also all on the Cayley surface.

Table[With[{p = Root[-1 - # + #^deg &, 1]},
   x^2 + y^2 + z^2 - (1 + 2 x y z) /.
    {x -> Cos[t], y -> Cos[p t], z -> Cos[p^deg t]}] //
  FullSimplify, {deg, 2, 12}]

Output 36

An easy way to understand why the function values of are on a Cayley surface is to look at the functions whose real part is just . For the exponential case = , due to the additivity of the exponents, the corresponding formula becomes quite simply due to the defining equality for the golden ratio.

Exp[I z] *  Exp[I GoldenRatio z] == Exp[I GoldenRatio^2 z] // Simplify

Output 37

Using the last formula and splitting it into real and imaginary parts, it is now easy to derive the Cayley surface equation from the above. We do this by writing down a system of equations for the real and imaginary components, the corresponding equations for all occurring arguments and eliminate the trigonometric functions.

GroebnerBasis[
 {xc yc - zc,
  xc - (Cos[t] + I Sin[t]),
  yc - (Cos[GoldenRatio t] + I Sin[GoldenRatio t]),
  zc - (Cos[GoldenRatio^2 t] + I Sin[GoldenRatio^2 t]),
  x - Cos[t], y - Cos[GoldenRatio t], z - Cos[GoldenRatio^2 t],
  Cos[t]^2 + Sin[t]^2 - 1,
  Cos[GoldenRatio t]^2 + Sin[GoldenRatio t]^2 - 1,
  Cos[GoldenRatio ^2 t]^2 + Sin[GoldenRatio^2 t]^2 - 1 }, {},
    {Cos[t], Cos[GoldenRatio t], Cos[GoldenRatio^2 t],
  Sin[t], Sin[GoldenRatio t], Sin[GoldenRatio^2 t], xc, yc, zc}]

Output 38

For generic , , the set of triples for with increasing will fill the cube. For rational , , the points are on a 1D curve for special algebraic values of , . The following interactive demonstration allows one to explore the position of the triples in the cube. The demonstration uses three 2D sliders (rather than just one) for specifying and to allow for minor modifications of the values of and .

Manipulate[
 With[{\[Alpha] = \[Alpha]\[Beta][[1]] + \[Delta]\[Alpha]\[Beta][[
      1]] + \[Delta]\[Delta]\[Alpha]\[Beta][[
      1]], \[Beta] = \[Alpha]\[Beta][[2]] + \[Delta]\[Alpha]\[Beta][[
      2]] + \[Delta]\[Delta]\[Alpha]\[Beta][[2]]},
  Graphics3D[{PointSize[0.003], RGBColor[0.36, 0.51, 0.71],
    Opacity[0.66],
    Point[
     Table[Evaluate[N[{Cos[x], Cos[\[Alpha] x], Cos[\[Beta] x]}]], {x,
        0, M Pi, 10^\[Delta]t}]]},
   PlotRange -> {{-1, 1}, {-1, 1}, {-1, 1}},
   PlotLabel ->
    NumberForm[
     Grid[{{"\[Alpha]", \[Alpha]}, {"\[Beta]", \[Beta]}},
      Dividers -> Center], 6]]],
 {{M, 100}, 1, 500, Appearance -> "Labeled"},
 {{\[Delta]t, -2,
   Row[{"\[Delta]" Style["\[NegativeThinSpace]t", Italic]}]}, -3,
  1},
 Grid[{{"{\[Alpha],\[Beta] }", "{\[Alpha], \[Beta]} zoom",
    "{\[Alpha], \[Beta]} zoom 2"},
   {Control[{{\[Alpha]\[Beta], {0.888905, 1.27779}, ""}, {1/2,
       1/2}, {3, 3}, ImageSize -> {100, 100}}],
    Control[{{\[Delta]\[Alpha]\[Beta], {0.011, -0.005},
       ""}, {-0.02, -0.02}, {0.02, 0.02}, ImageSize -> {100, 100}}],
    Control[{{\[Delta]\[Delta]\[Alpha]\[Beta], {-0.00006, 0.00008},
       ""}, {-0.0002, -0.0002}, {0.0002, 0.0002},
      ImageSize -> {100, 100}}]}}] , TrackedSymbols :> True]

Output 39

The degree of filling depends sensitively on the values of and . Counting how many values after rounding are used in the cube gives an estimation of the filling. For the case , the following plot shows that the filling degree is a discontinuous function of . The lowest filling degree is obtained for rational with small denominators, which results in closed curves in the cube. (We use rational values for , which explains most of the small filling ratios.)

usedCubes[\[Alpha]_] := Length[Union[Round[Table[Evaluate[
      N[{Cos[x], Cos[\[Alpha] x], Cos[\[Alpha]^2 x]}]], {x, 0.,
      1000 Pi, Pi/100.}],
         (* rounding *)0.01]]]

ListLogPlot[
 Table[{\[Alpha], usedCubes[\[Alpha]]}, {\[Alpha], 1, 2, 0.0005}],
 Joined -> True,
                           GridLines -> {{GoldenRatio}, {}}]

Output 40

Plotting over a large domain shows clearly that not all possible values of occur equally often. Function values near –1 seem to be assumed much more frequently.

Plot[Evaluate[fGolden[x]], {x, 0, 1000 Pi},
 PlotStyle -> Directive[ Opacity[0.3], Thickness[0.001]],
 Frame -> True, PlotPoints -> 10000]

Output 42

How special is with respect to not taking on negative values near –3? The following graphic shows the smallest function values of the function over the domain as a function of . The special behavior near is clearly visible, but other values of , such that the extremal function value is greater than –3, do exist (especially rational and/or rational ).

ListPlot[Monitor[
     Table[{\[Alpha],
    Min[Table[
      Evaluate[N[Cos[x] + Cos[\[Alpha] x] + Cos[\[Alpha]^2 x]]],
      {x, 0., 100 Pi, Pi/100.}]]}, {\[Alpha], 1, 2,
    0.0001}], \[Alpha]],
 PlotRange -> All, AxesLabel -> {"\[Alpha]", None}]

Output 43

And the next graphic shows the minimum values over the plane. I sample the function in the intervals and . Straight lines with simple rational relations between and emerge.

cfMin = Compile[{max},
   Table[Min[
     Table[Cos[x] + Cos[\[Alpha] x] + Cos[\[Beta] x], {x, 1. Pi, max,
       Pi/100}]], {\[Beta], 0, 2, 1/300}, {\[Alpha], 0, 2, 1/300}]];

ReliefPlot[cfMin[#], Frame -> True, FrameTicks -> True,
   DataRange -> {{0, 2}, {0, 2}}, ImageSize -> 200] & /@ {10 Pi,
  100 Pi} 

Here are the two equivalent images for the maxima.

cfMax = Compile[{max},
   Table[Max[
     Table[Cos[x] + Cos[\[Alpha] x] + Cos[\[Beta] x], {x, 1. Pi, max,
       Pi/100}]], {\[Beta], 1/2, 2, 1/300}, {\[Alpha], 1/2, 2,
     1/300}]];

ReliefPlot[cfMax[#], Frame -> True, FrameTicks -> True,
   DataRange -> {{0, 2}, {0, 2}}, ImageSize -> 200] & /@ {10 Pi,
  100 Pi} 

The Zeros of fϕ(x) and Distances between Successive Zeros

Now I will work toward reproducing the first graphic that was shown in the MathOverflow post. The poster also gives a clever method to quickly calculate 100k+ zeros based on solving the differential equation and recording zero crossings on the fly using WhenEvent to detect zeros. As NDSolve will adaptively select step sizes, a zero of the function can be conveniently detected as a side effect of solving the differential equation of the derivative of the function whose zeros we are interested in. I use an optional third argument for function values different from zero. This code is not guaranteed to catch every single zero—it might happen that a zero is missed; using the MaxStepSize option, one could control the probability of a miss. Because we are only interested in statistical properties of the zeros, we use the default option value of MaxStepSize.

findZeros[f_, n_, f0_: 0, ndsolveoptions : OptionsPattern[]] :=
 Module[{F, zeroList, counter, t0},
  zeroList = Table[0, {n}];
  counter = 0;
  Monitor[
    NDSolve[{F'[t] == D[f[t], t], F[0] == f[0],
                    WhenEvent[F[t] == f0, counter++; t0 = t;
                                          (* locate zeros,
       store zero,
       and use new starting value *)
                                 \
         If[counter <= n, zeroList[[counter]] = t0,
                                           F[t0] = f[t0];
        "StopIntegration"],
       "LocationMethod" -> {"Brent", PrecisionGoal -> 10}]},
     F, {t, 10^8,  10^8},
         ndsolveoptions, Method -> "BDF", PrecisionGoal -> 12,
     MaxSteps -> 10^8, MaxStepSize -> 0.1],
    {"zero counter" -> counter, "zero abscissa" -> t0}] // Quiet;
  zeroList]

Here are the first 20 zeros of .

zerosGolden = findZeros[fGolden, 20]

Output 44

They are indeed the zeros of .

Plot[fGolden[x], {x, 0, 10 Pi},
 Epilog -> {Darker[Red], Point[{#, fGolden[#]} & /@ zerosGolden]}]

Output 45

Of course, using Solve, one could also get the roots.

Short[exactZerosGolden =
  x /. Solve[fGolden[x] == 0 \[And] 0 < x < 36, x], 4]

Output 46

The two sets of zeros coincide.

Max[Abs[zerosGolden - exactZerosGolden]]

Output 47

While this gives more reliable results, it is slower, and for the statistics of the zeros that we are interested in, exact solutions are not needed.

Calculating 100k zeros takes on the order of a minute.

(zerosGolden = findZeros[fGolden, 10^5];) // Timing

Output 48

The quality of the zeros () is good enough for various histograms and plots to be made.

Mean[Abs[fGolden /@ zerosGolden]]

Output 49

But one could improve the quality of the roots needed to, say, by using a Newton method, with the found roots as starting values.

zerosGoldenRefined =
  FixedPoint[Function[x, Evaluate[N[x - fGolden[x]/fGolden'[x]]]], #,
     10] & /@ Take[zerosGolden, All]; 

Mean[Abs[fGolden /@ zerosGoldenRefined]]

Output 50

The process of applying Newton iterations to find zeros as a function of the starting values has its very own interesting features for the function , as the basins of attraction as well as the convergence properties are not equal for all zeros, e.g. the braided strand near the zero stands out. The following graphic gives a glimpse of the dramatic differences, but we will not look into this quite-interesting subtopic any deeper in this post.

Graphics[{Thickness[0.001], Opacity[0.1], RGBColor[0.36, 0.51, 0.71],
  Table[BSplineCurve[Transpose[{N@
       NestList[(# - fGolden[#]/fGolden'[#]) &, N[x0, 50], 20],
      Range[21]}]], {x0, 1/100, 40, 1/100}]},
 PlotRange -> { {-10, 50}, All}, AspectRatio -> 1/3, Frame -> True,
 FrameLabel -> {x, "iterations"},
 PlotRangeClipping -> True]

Output 51

If we consider the function , it has a constant function value between the zeros. The Fourier transform of this function, calculated based on the zeros, shows all possible harmonics between the three frequencies 1, and .

Module[{ft, nf, pl, labels},
 (* Fourier transform *)
 ft = Compile[\[Omega], Evaluate[
    Total[
     Function[{a, b},
       Sign[fGolden[
          Mean[{a, b}]]] I (Exp[I a \[Omega]] -
           Exp[I b \[Omega]])/\[Omega] ] @@@ 

      Partition[Take[zerosGolden, 10000], 2, 1]]]];
 (* identify harmonics *)

 nf = Nearest[
    SortBy[Last /@ #, LeafCount][[1]] & /@
     Split[Sort[{N[#, 10], #} & /@
         Flatten[
         Table[Total /@
           Tuples[{1, GoldenRatio, GoldenRatio^2, -1, -GoldenRatio,
             -GoldenRatio^2}, {j}], {j, 8}]]], #1[[1]] === #2[[
         1]] &]] // Quiet;
 (* plot Fourier transforms *)

 pl = Plot[Abs[ft[\[Omega]]], {\[Omega], 0.01, 8},
   PlotRange -> {0, 1000}, Filling -> Axis, PlotPoints -> 100];
 (* label peaks *)

 labels = SortBy[#, #[[1, 2]] &][[-1]] & /@
   GatherBy[Select[{{#1, #2}, nf[#1][[1]]} & @@@ 

      Select[Level[Cases[Normal[pl], _Line, \[Infinity]], {-2}],
       Last[#] > 100 &], Abs[#[[1, 1]] - #[[2]]] < 10^-2 &], Last];
 Show[{pl, ListPlot[Callout @@@ labels, PlotStyle -> None]},
         PlotRange -> {{0.1, 8.5}, {0, 1100}}, Axes -> {True, False}]]

Output 52

There is a clearly visible zero-free region of the zeros mod 2π around .

Histogram[Mod[zerosGolden, 2 Pi], 200]

Output 53

Plotting the square of in a polar plot around the unit circle (in yellow/brown) shows the zero-free region nicely.

PolarPlot[1 + fGolden[t]^2/6, {t, 0, 200 2 Pi},

 PlotStyle ->
  Directive[Opacity[0.4], RGBColor[0.36, 0.51, 0.71],
   Thickness[0.001]],
                      PlotPoints -> 1000,
 Prolog -> {RGBColor[0.88, 0.61, 0.14], Disk[]}]

Output 54

Modulo we again see the two peaks and a flat distribution between them.

Histogram[(# - Round[#, Pi]) & /@ zerosGolden, 200]

Output 55

The next graphic shows the distance between the zeros (vertical) as a function of . The zero-free region, as well as the to-be-discussed clustering of the roots, is clearly visible.

Graphics[{RGBColor[0.36, 0.51, 0.71],

  Function[{a, b}, Line[{{a, b - a}, {b, b - a}}]] @@@
                                                                      \
                   Partition[Take[zerosGolden, 10000], 2, 1]},
                     AspectRatio -> 1/2, Frame -> True,
 FrameLabel -> {x, "zero distance"}]

Output 56

Statistically, the three terms of the defining sum of do not contribute equally to the formation of the zeros.

summandValues = {Cos[#], Cos[GoldenRatio #], Cos[GoldenRatio^2 #]} & /@
   zerosGolden;

Histogram[#, 200] & /@ Transpose[summandValues]

Output 57

Table[Histogram3D[{#[[1]], #[[-1]]} & /@
   Partition[fGolden' /@ zerosGolden, j, 1], 100,
  PlotLabel -> Row[{"shift \[Equal] ", j - 1}]],
 {j, 2, 4}]

Output 58

The slopes of at the zeros are strongly correlated to the slopes of successive zeros.

Table[Histogram3D[{#[[1]], #[[-1]]} & /@
   Partition[fGolden' /@ zerosGolden, j, 1], 100,
  PlotLabel -> Row[{"shift \[Equal] ", j - 1}]],
 {j, 2, 4}]

Output 59

A plot of the summands and their derivatives for randomly selected zeros shows that the values of the summands are not unrelated at the zeros. The graphic shows triangles made from the three components of the two derivatives.

fGoldenfGoldenPrime[
   x_] = {D[{Cos[x], Cos[GoldenRatio x], Cos[GoldenRatio^2 x]}, x],
                                                              {Cos[
     x], Cos[GoldenRatio x], Cos[GoldenRatio^2 x]}};

Graphics[{Thickness[0.001], Opacity[0.05],
  RGBColor[0.88, 0.61, 0.14],

  Line[Append[#, First[#]] &@Transpose[fGoldenfGoldenPrime[#]]] & /@
                                                                      \
           RandomSample[zerosGolden, 10000]}]

Output 60

Here are the values of the three terms shown in a 3D plot. As a cross-section of the above Cayley surface, it is a closed 1D curve.

Graphics3D[{PointSize[0.002], RGBColor[0.36, 0.51, 0.71],
                       Point[Union@Round[summandValues, 0.01]]},
                         PlotRange -> {{-1, 1}, {-1, 1}, {-1, 1}},
 Axes -> True,

 AxesLabel -> {Cos[x], Cos[GoldenRatio x], Cos[GoldenRatio^2 x]}]

Output 61

And here is the distribution of the distances between successive zeros. This is the graphic shown in the original MathOverflow post. The position of the peaks is what was asked for.

differencesGolden = Differences[zerosGolden];

Histogram[differencesGolden, 1000, PlotRange -> All]

The pair correlation function between successive zero distances is localized along a few curve segments.

Histogram3D[Partition[differencesGolden, 2, 1], 100, PlotRange -> All]

Output 62

The nonrandomness of successive zero distances also becomes visible by forming an angle path with the zero distances as step sizes.

Graphics[{Thickness[0.001], Opacity[0.5], RGBColor[0.36, 0.51, 0.71],
  Line[AnglePath[{#, 2 Pi/5} & /@ Take[differencesGolden, 50000]]]},
 Frame -> True]

Output 63

Here are some higher-order differences of the distances between successive zeros.

{Histogram[Differences[zerosGolden, 2], 1000, PlotRange -> All],
 Histogram[Differences[zerosGolden, 3], 1000, PlotRange -> All]}

Output 64

Even the nearest-neighbor differences show a lot of correlation between them. The next graphic shows their bivariate distribution for , with each distribution in a different color.

Show[Table[
  Histogram3D[Partition[differencesGolden, m, 1][[All, {1, -1}]],
   400,
   ColorFunction -> (Evaluate[{RGBColor[0.368417, 0.506779, 0.709798],
          RGBColor[0.880722, 0.611041, 0.142051], RGBColor[
         0.560181, 0.691569, 0.194885], RGBColor[
         0.922526, 0.385626, 0.209179], RGBColor[
         0.528488, 0.470624, 0.701351], RGBColor[
         0.772079, 0.431554, 0.102387], RGBColor[
         0.363898, 0.618501, 0.782349], RGBColor[1, 0.75, 0],
         RGBColor[0.647624, 0.37816, 0.614037], RGBColor[
         0.571589, 0.586483, 0.], RGBColor[0.915, 0.3325, 0.2125],
         RGBColor[0.40082222609352647`, 0.5220066643438841, 0.85]}[[
        m]]] &)], {m, 12}],
            PlotRange -> All, ViewPoint -> {2, -2, 3}]

Output 65

The distribution of the slopes at the zeros have much less structure and show the existence of a maximal slope.

Histogram[fGolden' /@ zerosGolden, 1000]

Output 66

The distribution of the distance of the zeros with either positive or negative slope at the zeros is identical for the two signs.

Function[lg,
  Histogram[Differences[Select[zerosGolden, lg[fGolden'[#], 0] &]],
   1000,

   PlotLabel ->
    HoldForm[lg[Subscript["f", "\[Phi]"]'[x], 0]]]] /@ {Less, Greater}

Output 67

A plot of the values of the first versus the second derivative of at the zeros shows a strong correlation between these two values.

Histogram3D[{fGolden'[#], fGolden''[#]} & /@ zerosGolden, 100,
 PlotRange -> All]

Output 68

The ratio of the values of the first to the second derivative at the zeros shows an interesting-looking distribution with two well-pronounced peaks at ±1. (Note the logarithmic vertical scale.)

Histogram[
 Select[fGolden''[#]/fGolden'[#] & /@ zerosGolden,
  Abs[#] < 3 &], 1000, {"Log", "Count"}]

Output 69

As we will see in later examples, this is typically not the case for generic sums of three-cosine terms. Assuming that locally around a zero the function would look like++, the possible region in  is larger. In the next graphic, the blue region shows the allowed region, and the black curve shows the actually observed pairs.

slopeCurvatureRegion[{\[CurlyPhi]2_, \[CurlyPhi]3_}, {\[Alpha]_, \
\[Beta]_}] :=

 Module[{v = Sqrt[1 - (-Cos[\[CurlyPhi]2] - Cos[\[CurlyPhi]3])^2]},
               {# v - \[Alpha] Sin[\[CurlyPhi]2] - \[Beta] Sin[\
\[CurlyPhi]3],
     Cos[\[CurlyPhi]2] - \[Alpha]^2 Cos[\[CurlyPhi]2] +
      Cos[\[CurlyPhi]3] - \[Beta]^2 Cos[\[CurlyPhi]3]} & /@ {-1, 1}]

Show[{ParametricPlot[
   slopeCurvatureRegion[{\[CurlyPhi]2, \[CurlyPhi]3}, {GoldenRatio,
     GoldenRatio^2}],
                                   {\[CurlyPhi]2, 0,
    2 Pi}, {\[CurlyPhi]3, 0, 2 Pi}, PlotRange -> All, AspectRatio -> 1,
                                    PlotPoints -> 120,
   BoundaryStyle -> None, FrameLabel -> {f', f''}],
  Graphics[{PointSize[0.003], RGBColor[0.88, 0.61, 0.14],
    Point[{fGolden'[#], fGolden''[#]} & /@ zerosGolden]}]}]

Output 70

For , the possible region is indeed fully used.

Show[{ParametricPlot[
   slopeCurvatureRegion[{\[CurlyPhi]2, \[CurlyPhi]3}, {Pi, Pi^2}],
                                   {\[CurlyPhi]2, 0,
    2 Pi}, {\[CurlyPhi]3, 0, 2 Pi}, PlotRange -> All, AspectRatio -> 1,
                                    PlotPoints -> 20,
   BoundaryStyle -> None, FrameLabel -> {f', f''}],
  Graphics[{PointSize[0.003], RGBColor[0.88, 0.61, 0.14],
                   Opacity[0.4],
    Point[{fPi'[#], fPi''[#]} & /@ findZeros[fPi, 20000]]}]}]

Output 71

Similar to the fact that the function values of do not take on larger negative values, the maximum slope observed at the zeros is smaller than the one realizable with a free choice of phases in ++, which is for .

Max[Abs[fGolden' /@ zerosGolden]]

Output 72

In the above histograms, we have seen the distribution for the distances of the zeros of . While in some sense zeros are always special, a natural generalization to look at are the distances between successive values such that as a function of . The following input calculates this data from . I exclude small intervals around the endpoints because the distances between values become quite large and thus the calculation becomes time-consuming. (This calculation will take a few hours.)

Monitor[cDistancesGolden = Table[ zeros = findZeros[fGolden, 25000, c];
        {c, Tally[Round[Differences[zeros] , 0.005]]}, {c, -1.49,
    2.99, 0.0025}],
 Row[{"c", "\[ThinSpace]=\[ThinSpace]", c}]]

cDistancesGoldenSA =
  SparseArray[
   Flatten[Table[({j, Round[200 #1] + 1} -> #2) & @@@

      cDistancesGolden[[j]][[2]], {j, Length[cDistancesGolden]}], 1]];

The following relief plot of the logarithm of the density shows that sharp peaks (as shown above) for the zeros exist for any value of in .

ReliefPlot[Log[1 + Take[cDistancesGoldenSA, All, {1, 1600}]],

 DataRange -> {{0, 1600 0.005}, {-1.49, 2.99}}, FrameTicks -> True,

 FrameLabel -> {"\[CapitalDelta] zeros", Subscript[ f, "\[Phi]"]}]

Output 73

Interlude I: The Function f2(x) = cos(x) + cos(ϕ x)

Before analyzing in more detail, for comparison—and as a warmup for later calculations—let us look at the simpler case of a sum of two cos terms, concretely . The zeros also do not have a uniform distance.

f2Terms[x_] := Cos[x] + Cos[GoldenRatio x]

zeros2Terms = findZeros[f2Terms, 10^5];

Here is a plot of ; the zeros are again marked with a red dot.

Plot[f2Terms[x], {x, 0, 12 Pi},

 Epilog -> {Darker[Red],
   Point[{#, f2Terms[#]} & /@ Take[zeros2Terms, 100]]}]

Output 74

But one distance (at ) is exponentially more common than others (note the logarithmic scaling of the vertical axis!).

Histogram[Differences[zeros2Terms], 1000, {"Log", "Count"},
 PlotRange -> All]

Output 75

About 60% of all zeros seem to cluster near a distance of approximately 2.4. I write the sum of the two cosine terms as a product.

f2Terms[x]  // TrigFactor

Output 76

The two terms have different period, the smaller one being approximately 2.4.

{FunctionPeriod[Cos[(Sqrt[5] - 1)/4 x], x],
 FunctionPeriod[Cos[(Sqrt[5] + 3)/4 x], x]}

Output 77

N[%/2]

Output 77

Plotting the zeros for each of the two factors explains why one sees so many zero distances with approximate distance 2.4.

Solve[f2Terms[x] == 0, x]

Output 78

Plot[{Sqrt[2] Cos[(Sqrt[5] - 1)/4 x],
  Sqrt[2] Cos[(Sqrt[5] + 3)/4 x]}, {x, 0, 20 Pi},

 Epilog -> {{Blue, PointSize[0.01],
    Point[Table[{(2 (2 k - 1) Pi)/(3 + Sqrt[5]), 0}, {k, 230}]]},
                              {Darker[Red], PointSize[0.01],
    Point[Table[{1/2 (1 + Sqrt[5]) (4 k - 1) Pi, 0}, {k, 10}]]}}]

Output 79

SortBy[Tally[Round[Differences[zeros2Terms], 0.0001]], Last][[-1]]

Output 80

Let us look at and next to each other. One observes an obvious difference between the two curves: in , ones sees triples of maximum-minimum-maximum, with all three extrema being negative. This situation does not occur in .

GraphicsRow[{Plot[fGolden[x], {x, 0, 14 Pi},
   PlotLabel -> Subscript[f, \[Phi]], ImageSize -> 320],
  Plot[f2Terms[x], {x, 0, 14 Pi}, PlotLabel -> Subscript[f, 2],
   ImageSize -> 320]}]

Output 81

Here is a plot of after a zero for 1,000 randomly selected zeros. Graphically, one sees many curves crossing zero exactly at the first zero of . Mouse over the curves to see the underlying curve in red to better follow its graph.

Show[Plot[f2Terms[t - #], {t, -2, 0 + 5}, PlotRange -> All,
     PlotStyle ->
      Directive[RGBColor[0.36, 0.51, 0.71], Thickness[0.001],
       Opacity[0.3]]] & /@
   RandomSample[zeros2Terms, 1000],
  PlotRange -> All, Frame -> True, GridLines -> {{0}, {3}},
  ImageSize -> 400]  /.

 l_Line :> Mouseover[l, {Red, Thickness[0.002], Opacity[1], l}]

Output 82

The distance from the origin to the first zero of is indeed the most commonly occurring distance between zeros.

{#, N[#]} &@(2 x /. Solve[f2Terms[x] == 0 \[And] 1 < x < 2, x] //
   Simplify)

Output 83

Let us note that adding more terms does not lead to more zeros. Consider the function .

f2TermsB[x_] := Cos[GoldenRatio^2 x]

zeros2TermsB = findZeros[f2TermsB, 10^5];

It has many more zeros up to a given (large) than the function .

Max[zeros2TermsB]/Max[zerosGolden]

Output 84

The reason for this is that the addition of the slower oscillating functions ( and ) effectively “converts” some zeros into minimum-maximum-minimum triples all below (above) the real axis. The following graphic visualizes this effect.

Plot[{fGolden[x], Cos[GoldenRatio^2 x]}, {x, 10000, 10036},
 Filling -> Axis]

 

Output 85

Seeing Envelopes in Families of Curves

Now let’s come back to our function composed of three cos terms.

If we are at a given zero of , what will happen afterward? If we are at a zero that has distance to its next zero , how different can the function behave in the interval ? For the function , there is a very strong correlation between the function value and the zero distances, even if we move to the function values in the intervals , .

Table[Histogram3D[{#[[1, 1]], fGolden[#[[-1, 2]] + #[[-1, 1]]/2]} & /@
     Partition[Transpose[{differencesGolden, Most[zerosGolden]}], k,
     1], 100,
   PlotLabel -> Row[{"shift:\[ThinSpace]", k - 0.5}],
   AxesLabel -> {HoldForm[d], Subscript[f, \[Phi]], None}], {k, 4}] //
  Partition[#, 2] &

Output 86

Plotting the function starting at zeros shows envelopes. Using a mouseover effect allows one to highlight individual curves. The graphic shows a few clearly recognizable envelopes. Near to them, many of the curves cluster. The four purple points indicate the intersections of the envelopes with the axis.

Show[Plot[fGolden[# + t], {t, -2, 0 + 5}, PlotRange -> All,
     PlotStyle ->
      Directive[RGBColor[0.36, 0.51, 0.71], Thickness[0.001],
       Opacity[0.3]]] & /@
   RandomSample[zerosGolden, 1000],
  Epilog -> {Directive[Purple, PointSize[0.012]],
    Point[{#, 0} & /@ {1.81362, 1.04398, 1.49906, 3.01144}]},
  PlotRange -> All, Frame -> True, GridLines -> {{0}, {-1, 3}},
  ImageSize -> 400] /.

 l_Line :> Mouseover[l, {Red, Thickness[0.002], Opacity[1], l}]

Output 87

The envelope that belongs to zeros that are followed with nearly reaching explains the position of the largest maximum in the zero-distance distribution.

zerosGolden[[1]]

Output 88

Using transcendental roots, one can obtain a closed-form representation of the root that can be numericalized to any precision.

Solve[fGolden[x] == 0 \[And] 1/2 < x < 3/2, x]

Output 89

root3 = N[
  Root[{Cos[#1] + Cos[GoldenRatio #1] + Cos[GoldenRatio^2 #1] &,
                     0.9068093955855631129`20}], 50]

Output 90

The next graphic shows the histogram of the zero distances together with the just-calculated root.

Histogram[differencesGolden, 1000, ChartStyle -> Opacity[0.4],
  PlotRange -> {{1.7, 1.9}, All},
 GridLines -> {{2 zerosGolden[[1]]}, {}}, GridLinesStyle -> Purple]

Output 91

We select zeros with a spacing to the next zero that are in a small neighborhood of the just-calculated zero spacing.

getNearbyZeros[zeros_, z0_, \[Delta]_] :=
 Last /@ Select[Transpose[{Differences[zeros], Most[zeros]}],
   z0 - \[Delta] < #[[1]] < z0 + \[Delta] &]

zerosAroundPeak = getNearbyZeros[zerosGolden, 2 root3, 0.001];
Length[zerosAroundPeak]

Output 92

Plotting these curves shifted by the corresponding zeros such that they all have the point in common shows that all these curves are indeed locally (nearly) identical.

Show[Plot[fGolden[# + t], {t, -3, 6}, PlotRange -> All,
     PlotStyle ->
      Directive[RGBColor[0.36, 0.51, 0.71], Thickness[0.001],
       Opacity[0.3]]] & /@
   RandomSample[zerosAroundPeak, 100],
  PlotRange -> All, Frame -> True, GridLines -> {{0}, {-1, 1, 3}},
  ImageSize -> 400] /.

 l_Line :> Mouseover[l, {Red, Thickness[0.002], Opacity[1], l}]

Output 93

Curves that start at the zero function value and attain a function value of ≈3 will soon move apart. The next graphic shows the mean value of spread of the distances after a selected distance. This spread is the reason that the zero distances that appear after 2 root3 are not peaks in the distribution of zero distances.

Module[{zeroPosis, data},
 zeroPosis = Select[Last /@ Select[Transpose[{differencesGolden,
       Range[Length[zerosGolden] - 1]}],
     2 root3 - 0.001 < #[[1]] < 2 root3 + 0.001 &], # < 99000 &];
 data = Table[{j, Mean[#] \[PlusMinus] StandardDeviation[#]} &[
    differencesGolden[[zeroPosis + j]]], {j, 100}];
 Graphics[{RGBColor[0.36, 0.51, 0.71],
   Line[{{#1, Subtract @@ #2}, {#1, Plus @@ #2}} & @@@ data]},
                    AspectRatio -> 1/2, Frame -> True]]

Output 94

Instead of looking for the distance of successive roots of , one could look at the roots with an arbitrary right-hand side . Based on the above graphics, the most interesting distribution might occur for . Similar to the two-summand case, the distance between the zeros of the fastest component, namely , dominates the distribution. (Note the logarithmic vertical scale.)

Histogram[
 Differences[findZeros[fGolden, 10^5, -1]], 1000, {"Log", "Count"},
 PlotRange -> All]

Output 95

The above plot of seemed to show that the smallest values attained are around –1.5. This is indeed the absolute minimum possible; this follows from the fact that the summands lie on the Cayley surface.

Minimize[{x + y + z,
  x^2 + y^2 + z^2 == 1 + 2 x y z \[And] -1 <= x <= 1 \[And] -1 <= y <=
     1 \[And] -1 <= z <= 1}, {x, y, z}]

Output 96

I use findZeros to find some near-minima positions. Note the relatively large distances between these minima. Because of numerical errors, one sometimes gets two nearby values, in which case duplicates are deleted.

zerosGoldenMin =
  findZeros[fGolden, 100, -3/2] //
   DeleteDuplicates[#, Abs[#1 - #2] < 0.1 &] &;

Close to these absolute minima positions, the function takes on two universal shapes. This is clearly visible by plotting in the neighborhoods of all 100 minima.

Show[Plot[fGolden[# + t], {t, -2, 0 + 5}, PlotRange -> All,
    PlotStyle ->
     Directive[RGBColor[0.36, 0.51, 0.71], Thickness[0.001],
      Opacity[0.3]]] & /@ zerosGoldenMin,
        GridLines -> {{}, {-3/2, 3}}]

Output 97

Interlude II: Using Rational Approximations of ϕ

The structure in the zero-distance distribution is already visible in relatively low-degree rational approximations of .

fGoldenApprox[x_] =
 fGolden[x] /. GoldenRatio -> Convergents[GoldenRatio, 12][[-1]]

Output 98

zerosGoldenApprox = findZeros[fGoldenApprox, 100000];

Histogram[Differences[zerosGoldenApprox], 1000, PlotRange -> All]

Output 99

For small rational values of , in , one can factor the expression and calculate the roots of each factor symbolically to more quickly generate the list of zeros.

getFirstZeros[f_[x_] + f_[\[Alpha]_ x_] + f_[\[Beta]_ x_] , n_] :=
 Module[{sols, zs},
    sols =
   Select[x /. Solve[f[x] + f[\[Alpha] x] + f[\[Beta] x] == 0, x] //
       N // ExpandAll // Chop, FreeQ[#, _Complex, \[Infinity]] &];
     zs = getZeros[#, Ceiling[n/Length[sols]]] & /@ sols;
    Sort@Take[Flatten[zs], n]]

getZeros[ConditionalExpression[a_. + C[1] b_,
   C[1] \[Element] Integers], n_] := a + b Range[n]

Table[Histogram[
   Differences[
    getFirstZeros[
     Cos[x] + Cos[\[Alpha] x] + Cos[\[Alpha]^2 x] /. \[Alpha] ->
       Convergents[GoldenRatio, d][[-1]], 100000]], 1000,
   PlotRange -> All,
   PlotLabel -> Row[{"convergent" , " \[Rule] ", d}]], {d, 2, 5}] //
 Partition[#, 2] &

Output 100

For comparison, here are the corresponding plots for .

Table[Histogram[
   Differences[
    getFirstZeros[
     Sin[x] + Sin[\[Alpha] x] + Sin[\[Alpha]^2 x] /. \[Alpha] ->
       Convergents[GoldenRatio, d][[-1]], 100000]], 1000,
   PlotRange -> All,
   PlotLabel -> Row[{"convergent" , " \[Rule] ", d}]], {d, 2, 5}] //
 Partition[#, 2] &

Output 101

The Extrema of fϕ(x)

I now repeat some of the above visualizations for the extrema instead of the zeros.

findExtremas[f_, n_] := findZeros[f', n]

extremasGolden = Prepend[findExtremas[fGolden, 100000], 0.];

Here is a plot of together with the extrema, marked with the just-calculated values.

Plot[fGolden[x], {x, 0, 10 Pi},
 Epilog -> {Darker[Red],
   Point[{#, fGolden[#]} & /@ Take[ extremasGolden, 30]]}]

Output 102

The extrema in the plane shows that extrema cluster around .

Graphics[{PointSize[0.001], RGBColor[0.36, 0.51, 0.71], Opacity[0.1],
  Point[N[{#, fGolden[#]} & /@ extremasGolden]]},
                    AspectRatio -> 1/2, ImageSize -> 400,
 Frame -> True]

Output 103

The distribution of the function values at the extrema is already visible in the last graphic. The peaks are at –3/2, –1 and 3. The following histogram shows how pronounced the density increases at these three values.

Histogram[fGolden /@ extremasGolden, 1000,
                      GridLines -> {{-3/2, -1, 3}, {}},
 PlotRange -> All]

Output 104

In a 3D histogram, one sees a strong correlation between the position of the extrema mod and the function value at the extrema.

Histogram3D[{Mod[#, 2 Pi], fGolden[#]} & /@ extremasGolden, 100,

 AxesLabel -> {\[CapitalDelta]x, Subscript[f, \[Phi]], None}]

Output 105

If one separates the minima and the maxima, one obtains the following distributions.

Function[lg,
  Histogram3D[{Mod[#, 2 Pi], fGolden[#]} & /@

    Select[extremasGolden, lg[fGolden''[#], 0] &], 100,

   AxesLabel -> {\[CapitalDelta]x, Subscript[f, \[Phi]],
     None}]] /@ {Less, Greater}

Output 106

The function values of extrema ordinates are strongly correlated to the function values of successive extrema.

Table[Histogram3D[{#[[1]], #[[-1]]} & /@
   Partition[fGolden /@ extremasGolden, j, 1], 100,
  PlotLabel -> Row[{"shift:", j - 1}]],
 {j, 2, 4}]

Output 107

A periodogram of the function values at the extrema shows a lot of structure. The various periodicities arising from the three cosine terms and their interference terms become visible. (The equivalent curve for the slope at the zeros is much noisier.) For all , , the periodogram of the function values at the extrema is a relatively smooth curve with only a few structures.

Periodogram[fGolden /@ extremasGolden,
 PlotStyle -> RGBColor[0.88, 0.61, 0.14], Filling -> Axis]

Output 108

Here again are two graphics that show how the three terms contribute to the function value at the maximum. The value of the term at the extrema is quite limited.

summandValuesE = {Cos[#], Cos[GoldenRatio #],
     Cos[GoldenRatio^2 #]} & /@ extremasGolden;

Graphics3D[{PointSize[0.002], RGBColor[0.36, 0.51, 0.71],
  Point[Union@Round[summandValuesE, 0.01]]},
                        PlotRange -> {{-1, 1}, {-1, 1}, {-1, 1}},
 Axes -> True,

 AxesLabel -> {Subscript[f, \[Phi]], Cos[GoldenRatio x],
   Cos[GoldenRatio^2 x]}]

Output 109

Histogram[#, 200] & /@ Transpose[summandValuesE]

Output 110

The two disconnected supports arise from the contributions at the minima and maxima. The contribution at the maxima is quite localized.

Histogram[Cos[GoldenRatio^2 #], 200,
   PlotRange -> {{-1, 1}, All}] & /@  {Select[extremasGolden,
   fGolden''[#] > 0 &], Select[extremasGolden, fGolden''[#] < 0 &]}

Output 111

I zoom into the second graphic of the last result.

Histogram[
 Cos[GoldenRatio^2 #] & /@
  Select[extremasGolden, fGolden''[#] < 0 &], 200,
 PlotRange -> {{0.94, 1}, All}]

Output 113

Here is the distribution of the function values at the minima and maxima.

{Histogram[fGolden /@ Select[extremasGolden, fGolden''[#] > 0 &], 200],
 Histogram[fGolden /@ Select[extremasGolden, fGolden''[#] < 0 &],
  200]}

Output 114

Reduced to the interval , one sees a small, smooth peak around .

Histogram[Mod[extremasGolden, 2 Pi], 200]

Output 115

And this is the overall distribution of the distances between successive extrema. Compared with the zeros, it does not show much unexpected structure.

Histogram[Differences[extremasGolden], 1000, PlotRange -> All]

Output 116

Higher differences do show some interesting structure.

Histogram[Differences[extremasGolden, 2], 1000, PlotRange -> All]

Output 117

In an analogy to the zeros, I also show the pair correlation function. (In this context, this is also called a peak-to-peak plot.)

Histogram3D[{#2 - #1, #3 - #2} & @@@
  Partition[extremasGolden, 3, 1], 100, PlotRange -> All]

Output 118

And here are the shapes of near the extrema for 1,000 randomly selected extrema.

Show[Plot[fGolden[# + t], {t, -2, 0 + 5}, PlotRange -> All,
     PlotStyle ->
      Directive[RGBColor[0.36, 0.51, 0.71], Thickness[0.001],
       Opacity[0.3]]] & /@
                                                                      \
              RandomSample[extremasGolden, 1000],
         PlotRange -> All, Frame -> True, GridLines -> {{0}, {3}},
  ImageSize -> 400] /.

 l_Line :> Mouseover[l, {Red, Thickness[0.002], Opacity[1], l}]

Output 119

For use in the next section and in the next example, I form a list of the zeros and extrema in the order in which they are on the real axis.

zerosAndExtremaGolden =
  Sort[Join[{#, "zero"} & /@ zerosGolden, {#, "extrema"} & /@
     extremasGolden]];

Using this list, one can make a correlation plot of the slope at a zero with the height of the following maximum. One sees quite a strong correlation.

Histogram3D[{fGolden'[#1[[1]]], fGolden[#2[[1]]]} & @@@
  Cases[Partition[zerosAndExtremaGolden, 2,
    1], {{_, "zero"}, {_, "extrema"}}], 120]

Output 120

There is even a strong correlation between the slope at a zero and the second next extrema value.

Histogram3D[{fGolden'[#[[1, 1]]],
    fGolden[Cases[#, {_, "extrema"}][[2, 1]]]} & /@
  Take[Cases[
    Partition[zerosAndExtremaGolden, 5, 1], {{_, "zero"}, __}],
   60000], 120]

Output 120

Interlude III: The Complex Zeros of fϕ(x)

All zeros of are on the real axis, while does have complex zeros—exactly at the maximum in the negative maximum-minimum-maximum triples. A plot of shows zeros as peaks. These pairs of zeros with nonvanishing imaginary parts result in relatively large spacing between successive roots in . (The appearance of these complex-valued zeros does not depend on , being irrational, but also occurs for rational , .)

Plot3D[Evaluate[-Log[Abs[fGolden[x + I y]]]], {x, 0, 12}, {y, -1, 1},
 PlotPoints -> {60, 60},
 BoxRatios -> {3, 1, 1}, MeshFunctions -> {#3 &},
 ViewPoint -> {1.9, -2.4, 1.46},
 MeshStyle -> RGBColor[0.36, 0.51, 0.71],
 AxesLabel -> {x,  y, Subscript[f, \[Phi]][x + I y]}]

Output 121

A contour plot showing the curves of vanishing real and imaginary parts has the zeros as crossings of curves of different color.

ContourPlot[
 Evaluate[# == 0 & /@ ReIm[fGolden[x + I y]]], {x, 0, 24}, {y, -1, 1},
  PlotPoints -> {60, 60},
 AspectRatio -> 1/3,
 Epilog -> {Purple, PointSize[0.012],
   Point[ ReIm[
     z /. Solve[
       fGolden[z] == 0 \[And] -2 < Im[z] < 2 \[And]
        0 < Re[z] < 24]]]}]

Output 122

Similar to the above case along the real axis, here is the path of convergence in Newton iterations.

Module[{ppx = 111, ppy = 21,
  f = Evaluate[(# - fGolden[#]/fGolden'[#])] &, data, vals, color},
 data = Table[
   NestList[f, N[x0 + I y0], 20], {y0, -1, 1, 2/ppy}, {x0, 0, 30,
    30/ppx}];
 vals = First /@
   Select[Reverse[
     SortBy[Tally[Flatten[Round[Map[Last, data, {2}], 0.001]]],
      Last]], #[[2]] > 50 &];
 (color[#] =
     Blend[{{0, RGBColor[0.88, 0.61, 0.14]}, {1/2,
        RGBColor[0.36, 0.51, 0.71]},
       {1, RGBColor[0.561, 0.69, 0.19]}}, RandomReal[]]) & /@ vals;
 Graphics3D[{Thickness[0.001], Opacity[0.5],
   Map[If[MemberQ[vals, Round[Last[#], 0.001]],
      {color[Round[Last[#], 0.001]],
       BSplineCurve[MapIndexed[Append[#, #2[[1]]] &, ReIm[#]]]}, {}] &,
    data, {2}]}, BoxRatios -> {3, 1, 2},
  ViewPoint -> {0.95, -3.17, 0.70}]]

Output 123

Now that we have the positions of the zeros and extrema, we can also have a look at the complex zeros in more detail. In the above plots of over the complex plane, we saw that complex zeros occur when we have the situation maximum-minimum-maximum with all three function values at these negative extrema. Using the zeros and the extrema, we can easily find the positions of these extrema triples.

tripleExtrema =
  SequenceCases[
    zerosAndExtremaGolden, {{_, "extrema"}, {_, "extrema"}, {_,
      "extrema"}}][[All, 2, 1]];

About one-seventh of all these roots have a nonvanishing imaginary part.

Length[tripleExtrema]/(Length[tripleExtrema] + Length[zerosGolden]) //
  N

Output 124

The function value of the maximum of all of these consecutive triple extrema are indeed all negative and never smaller than –1.

Histogram[fGolden /@ tripleExtrema, 100]

Output 125

A log-log histogram of the absolute values of these middle maxima suggests that over a large range, a power law relation between their frequencies and their function values holds.

Histogram[
 Sort[-Select[fGolden /@ tripleExtrema, Negative]], {"Log",
  100}, {"Log", "Count"}]

Output 126

Interestingly, the distance between the middle maxima is narrowly concentrated at three different distances.

Output 127

tripleExtremaDifferences = Differences[tripleExtrema];

Histogram[tripleExtremaDifferences, 100]

Output 128

The next three plots zoom into the last three localized structures.

Function[x,
  Histogram[Select[tripleExtremaDifferences, x - 1 < # < x + 1 &],
   100]] /@ {5, 7, 12}

Output 129

Here are the three typical shapes that belong to these three classes of distances. I show 100 randomly selected and shifted pieces of .

extremaGroups =
  With[{L =
     Sort[Transpose[{tripleExtremaDifferences, Most[tripleExtrema]}]]},
   Function[x, {x, Select[L, x - 1 < #[[1]] < x + 1 & ]}] /@ {5, 7,
     12}];

Function[{\[CapitalDelta], l},
  Show[Plot[Evaluate[fGolden[# + t]], {t, -2, \[CapitalDelta] + 2},
        PlotRange -> All,
      PlotLabel ->
       Row[{HoldForm[\[CapitalDelta]x == \[CapitalDelta]]}],
         PlotStyle ->
       Directive[Thickness[0.001], RGBColor[0.36, 0.51, 0.71],
        Opacity[0.6]]] & /@
    RandomSample[l[[All, 2]], 100]]] @@@ extremaGroups

Output 130

I use the position of all middle maxima as starting values for a numerical root-finding procedure to get the nearby complex roots.

cRoots = If[Im[#] < 0, Conjugate[#]] & /@ z /.

     FindRoot[Evaluate[fGolden[z] == 0], {z, # + 1/2 I}] & /@
   tripleExtrema;

Large imaginary parts of the complex zeros occur at real parts that are nearby multiples of π.

Histogram3D[{Mod[Re[#], 2 Pi], Im[#]} & /@ cRoots, 100,
                          AxesLabel -> {Im[x], Mod[Re[x], 2 Pi]}]

Output 131

The function value at a middle maximum is strongly correlated with the magnitude of the imaginary part of the nearby complex root.

Histogram3D[Transpose[{fGolden /@ tripleExtrema, Im[cRoots]}], 100,
                           AxesLabel -> {Subscript[f, \[Phi]], Im[z]}]

Output 132

And here are the distributions of imaginary parts and the differences of the imaginary parts of consecutive (along the real axis) zeros.

{Histogram[Im[cRoots], 100], Histogram[Differences[Im[cRoots]], 100]}

Output 133

If one splits the complex roots into the three groups from above, one obtains the following distributions.

Column[GraphicsRow[{Histogram[Im[#], 100],
       Histogram[Differences[Im[#]], 100]} &[

     If[Im[#] < 0, Conjugate[#]] & /@ z /.

        FindRoot[Evaluate[fGolden[z] == 0], {z, # + 1/2 I}] & /@ #2[[
       All, 2]]],
                        ImageSize -> 360,
    PlotLabel -> Row[{HoldForm[\[CapitalDelta]x == #1]}]] & @@@
  extremaGroups]

As a function of , the complex zeros of periodically join the real axis. The following graphic shows the surface in the -space in yellow/brown and the complex zeros as blue tubes. We first plot the surface and then plot the curves as mesh lines on this surface.

ContourPlot3D[
 Re[Cos[x + I y] + Cos[\[Alpha] (x + I y)] +
   Cos[\[Alpha]^2 (x + I y)]], {x, 0, 12}, {y, 0, 1}, {\[Alpha], 1,
  2}, Contours -> {0}, BoxRatios -> {3, 1, 1},
 ContourStyle -> {Directive[RGBColor[0.88, 0.61, 0.14], Opacity[0.3],
    Specularity[RGBColor[0.36, 0.51, 0.71], 10]]},
 BoundaryStyle -> None, ImageSize -> 600, PlotPoints -> {160, 80, 80},
  MaxRecursion -> 0,
 MeshStyle -> Directive[RGBColor[0.36, 0.51, 0.71], Thickness[0.006]],
  Mesh -> {{0}},
 MeshFunctions -> {Function[{x, y, \[Alpha]},
    Im[Cos[x + I y] + Cos[\[Alpha] (x + I y)] +
      Cos[\[Alpha]^2 (x + I y)]]]}, AxesLabel -> {x,  y, \[Alpha]}]

Output 134

The next natural step (and the last one for this section) would be to look at the defined implicitly through. As for any value of , we will have (possibly infinitely) many ; we want to construct the Riemann surface for . A convenient way to calculate Riemann surfaces is through solving the differential equation for the defining function. Through differentiation, we immediately get the differential equation.

f\[Alpha][z_, \[Alpha]_] :=
 Cos[z] + Cos[\[Alpha] z] + Cos[\[Alpha]^2 z]

Solve[D[f\[Alpha][z[\[Alpha]], \[Alpha]], \[Alpha]] == 0,
  Derivative[1][z][\[Alpha]]] // Simplify

Output 135

rhs[z_, \[Alpha]_] := -((
  z (Sin[\[Alpha] z] + 2 \[Alpha] Sin[\[Alpha]^2 z]) )/(
  Sin[z] + \[Alpha] (Sin[\[Alpha] z] + \[Alpha] Sin[\[Alpha]^2 z])))

As starting values, I use along a segment of the real axis.

ICs\[Alpha]x =
  Cases[Flatten[
    Table[{#, x} & /@
                            (\[Alpha] /.
        Quiet[Solve[
          f\[Alpha][N[1, 40] x, \[Alpha]] == 0 \[And]
           0 < \[Alpha] < 2, \[Alpha]]]),  {x, 0, 6, 6/100}], 1],
                            {_Real, _}];

These are the points that we will use for the numerical differential equation solving.

cp = ContourPlot[
  f\[Alpha][x, \[Alpha]] == 0, {x, 0, 6}, {\[Alpha], 0, 1.9},
  Epilog -> {Purple, Point[Reverse /@ ICs\[Alpha]x]},
  FrameLabel -> {x, \[Alpha]}]

Output 136

Starting at a point , we move on a semicircle around the origin of the complex plane. To make sure we stay on the defining Riemann surface, we use the projection method for the numerical solution. And we change variables from , where .

Monitor[rsf\[Alpha]Data =
   Table[With[{r = ICs\[Alpha]x[[k, 1]]},
         nds\[Alpha] =
       NDSolveValue[{Derivative[1][z][\[CurlyPhi]] ==
          I r Exp[I \[CurlyPhi]] rhs[z[\[CurlyPhi]],
            r Exp[I \[CurlyPhi]]], z[0] == ICs\[Alpha]x[[k, 2]]},
        z, {\[CurlyPhi], 0 , Pi }, WorkingPrecision -> 30,
        PrecisionGoal -> 6, AccuracyGoal -> 6,
        Method -> {"Projection", Method -> "StiffnessSwitching",
          "Invariants" ->
           f\[Alpha][z[\[CurlyPhi]], r Exp[I \[CurlyPhi]]]},
        MaxStepSize -> 0.01, MaxSteps -> 10^5];
        {{r, nds\[Alpha][0], nds\[Alpha][Pi]},   

       ParametricPlot3D[
          Evaluate[{r Cos[\[CurlyPhi]],
            r Sin[\[CurlyPhi]], #[nds\[Alpha][\[CurlyPhi]]]}],
          Evaluate[Flatten[{\[CurlyPhi], nds\[Alpha][[1]]}]],
          BoxRatios -> {1, 1, 1}, Axes -> True, PlotRange -> All,
          PlotStyle -> Directive[Thickness[0.002], Darker[Blue]],
          ColorFunctionScaling -> False,
          ColorFunction -> (ColorData["DarkRainbow"][
              Abs[1 - #4/ Pi]] &)] & /@ {Re, Im}}], {k,
      Length[ICs\[Alpha]x]}] // Quiet;,
 Text@ Row[{"path ", k, " of ", Length[ICs\[Alpha]x]}]]

Here is a plot of the real part of . One clearly sees how the sets of initially nearby zeros split at branch points in the complex plane.

rsfRe = Show[rsf\[Alpha]Data[[All, 2, 1]],
  PlotRange -> {All, {0, All}, 10 {-1, 1}},
  AxesLabel -> {Re[\[Alpha]], Im[\[Alpha]], Re[z]},
          ViewPoint -> {-0.512, -3.293, 0.581}]  

Output 137

One can calculate the branch points numerically as the simultaneous solutions of and .

branchPointEqs[z_, \[Alpha]_] = {f\[Alpha][z, \[Alpha]],
  D[f\[Alpha][z, \[Alpha]], z]}

Output 138

branchPoints =
  Union[Round[Select[#, Total[Abs[branchPointEqs @@ #]] < 10^-10 &],
      10.^-6]] &@
   ( Table[{z, \[Alpha]} /.
       FindRoot[Evaluate[branchPointEqs[z, \[Alpha]] == {0, 0}] ,
                     {z,
         RandomReal[{-8, 8}] + I RandomReal[{-8, 8}] },
                     {\[Alpha],
         RandomReal[{-5, 5}] + I RandomReal[{-5, 5}] },
        PrecisionGoal -> 10] // Quiet,
                     {20000}]);

Here are the branch points near the origin of the complex plane.

Graphics[{RGBColor[0.36, 0.51, 0.71],
  Point[ReIm /@ Last /@ branchPoints]},
                    Frame -> True, PlotRange -> 3.5,
 FrameLabel -> {Re[\[Alpha]], Im[\[Alpha]]},
 PlotRangeClipping -> True]

Output 139

Representing the positions of the branch points in the above plot as vertical cylinders shows that the splitting indeed occurs at the branch points (we do not include the branch points with to have a better view of this complicated surface).

Show[{rsfRe,
  Graphics3D[{CapForm[None], GrayLevel[0.3], Specularity[Purple, 20],
    Cylinder[{Append[ReIm[#], -10], Append[ReIm[#], 10]}, 0.02] & /@
     Select[Last /@ branchPoints, Im[#] > 10^-2 &]}]},
 PlotRange -> {{-2, 2}, {0, 2}, 8 {-1, 1}},
 ViewPoint -> {-1.46, 2.87, 1.05}]

Output 140

Finding More Envelopes

The possible “shapes” of fGolden near points where the function has an extremum and a value ≈±1 is quite limited. The three possible curves arise from the different ways to form the sum –1 from the values ±1 of the three summands.

maxMinus1Value =
  Select[extremasGolden, Abs[fGolden[#] - (-1)] < 10^-4 &];
Length[maxMinus1Value]

Output 141

Take[maxMinus1Value, 12]

Output 142

Show[Plot[fGolden[# + t], {t, 0 - 2, 0 + 5}, PlotRange -> All,
    PlotStyle ->
     Directive[RGBColor[0.36, 0.51, 0.71], Thickness[0.001],
      Opacity[0.3]]] & /@ maxMinus1Value,
 PlotRange -> All, Frame -> True, GridLines -> {{0}, {3}},
 ImageSize -> 400]  

Output 143

We compare these three curves with the possible curves that could be obtained from considering all possible phases between the three summands—meaning we consider all+ + such that and .

gGolden[x_, {\[CurlyPhi]1_, \[CurlyPhi]2_, \[CurlyPhi]3_}] :=
  Cos[x + \[CurlyPhi]1] + Cos[GoldenRatio x + \[CurlyPhi]2] +
   Cos[GoldenRatio^2 x + \[CurlyPhi]3];

phaseList = Table[
    Block[{\[CurlyPhi]1 = RandomReal[{-Pi, Pi}]},
     Check[Flatten[{\[CurlyPhi]1, {\[CurlyPhi]2, \[CurlyPhi]3} /.
         FindRoot[{Cos[\[CurlyPhi]1] + Cos[\[CurlyPhi]2] +
             Cos[\[CurlyPhi]3] == -1,
                                                      -Sin[\[CurlyPhi]\
1] - GoldenRatio Sin[\[CurlyPhi]2] - GoldenRatio^2 Sin[\[CurlyPhi]3] ==
            0},
                              {{\[CurlyPhi]2,
            RandomReal[{-Pi, Pi}]}, {\[CurlyPhi]3,
            RandomReal[{-Pi, Pi}]}}]}],
      {}]], {600}]; // Quiet

The next graphic shows the two curve families together.

 Show[
 {Plot[Evaluate[
    gGolden[x, #] &@  DeleteCases[Take[phaseList, All], {}]], {t, -2,
    0 + 5},
   PlotRange -> All,
   PlotStyle ->
    Directive[RGBColor[0.36, 0.51, 0.71], Opacity[0.3],
     Thickness[0.001]]],
  Plot[fGolden[t - #], {t, -2, 0 + 5}, PlotRange -> All,
     PlotStyle ->
      Directive[RGBColor[0.88, 0.61, 0.14], Thickness[0.003],
       Opacity[0.3]]] & /@ maxMinus1Value}]

Output 144

These curves now allow us to answer the original question about the location of the singularities in the distribution of the distances of successive zeros. Similar to the largest peak identified above arising from the bunching of curves with function values , the other three maxima arise from curves with local minima or maxima . We calculate some of these zeros numerically.

minEnvelopeZeros =
 Union[Round[
   Sort[\[Delta] /.
       Quiet[FindRoot[
         fGolden[# + \[Delta]] == 0, {\[Delta],
          1/2}]] & /@

     Take[maxMinus1Value, 100]], 0.025]]

Output 145

Indeed, the gridlines match the singularities precisely.

Histogram[Differences[zerosGolden], 1000, PlotRange -> All,
 GridLines -> {Flatten[{2 zerosGolden[[1]], 2 minEnvelopeZeros}], {}}]

Output 146

The unifying feature of all four singularities is their location at the zeros of envelope curves. Here are the curves of fGolden around 100 zeros for each of the four singularities.

With[{L = {#[[1, 1]], Last /@ #} & /@
     Reverse[SortBy[Split[Sort[Transpose[
          {Round[differencesGolden, 0.002], Most[zerosGolden]}]], #1[[
           1]] === #2[[1]] &], Length]]},
  Partition[Function[p,
     Show[
      Plot[fGolden[# + t], {t, -2, 0 + 5}, PlotRange -> All,
         PlotLabel -> Row[{"x", "\[TildeTilde]", p}],
         GridLines -> {None, {-1, 3}},
         PlotStyle ->
          Directive[RGBColor[0.36, 0.51, 0.71], Thickness[0.001],
           Opacity[0.3]]] & /@
       Take[Select[L, Abs[#[[1]] - p] < 0.1 &, 1][[1, 2]],
        UpTo[100]]]] /@ {1, 1.5, 1.8, 3}, 2]] // Grid

Output 147

These graphics show strikingly the common feature of these four groups of zero distances: either maxima cluster around or minima cluster around .

The curves in the plane that fulfill the two conditions are shown in the next contour plot.

 ContourPlot[
 Evaluate[Function[sign,
    Derivative[1, {0, 0, 0}][gGolden][
       0, {\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3}] ==
      0 /.
     (Solve[
         gGolden[0, {\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3}] ==
          sign 1, \[CurlyPhi]1] /.
        ConditionalExpression[x_, _] :> x /. _C :> 0)] /@ {-1, 1}],
 {\[CurlyPhi]2, 0, 2 Pi}, {\[CurlyPhi]3, 0, 2 Pi}, PlotPoints -> 60,
 ContourStyle -> RGBColor[0.36, 0.51, 0.71]]

Output 148

Now we can also calculate a numerical approximation to the exact value of the position of the first singularity. We consider the envelope of all curves with the properties , . The envelope property is represented through the vanishing partial derivative with respect to .

(Table[Round[
      Mod[{\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3} /.

         FindRoot[
          Evaluate[{gGolden[
              0, {\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3}] == -1, 

            Derivative[1, {0, 0, 0}][gGolden][
              0, {\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3}] == 0,

            Derivative[0, {1, 0, 0}][gGolden][
              0, {\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3}] == 0}],
          {\[CurlyPhi]1, RandomReal[{-Pi, Pi}]}, {\[CurlyPhi]2,
           RandomReal[{-Pi, Pi}]}, {\[CurlyPhi]3,
           RandomReal[{-Pi, Pi}]},
          PrecisionGoal -> 12] , 2 Pi]  /.
       x_?(Abs[#] < 10^-6 || Abs[2 Pi - #] < 10.^-6 &) :> 0,
      10.^-6], {100}] // Quiet // Tally) /.
 x_Real?(Abs[# - Pi] < 0.01 &) :> Pi

Output 149

The envelope curve of this family is a small modification of our original function—the sign of the first term is inverted.

cosEqs = {gGolden[x, {Pi, Pi, 0}], gGolden[x, {0, Pi, Pi}],
  gGolden[x, {Pi, 0, Pi}]} 

Output 150

The positions of the first roots of the last equations are , and . Multiplying these numbers by two to account for their symmetric distance from the origin yields the zero distances seen above at , and .

FindRoot[# == 0, {x, 1/2}] & /@ cosEqs

Output 151

And, using the higher-precision root, we zoom into the neighborhood of the first peak to confirm our conjecture.

With[{z0 =
   2 x /. FindRoot[
     Evaluate[Cos[x] - Cos[GoldenRatio x] - Cos[GoldenRatio^2 x] == 0],
     {x, 1/2}, PrecisionGoal -> 12]},
 Histogram[
  Select[Differences[
     zerosGoldenRefined], -0.0003 < z0 - # < 0.0004 &] - z0, 100,
  "PDF",
  GridLines -> {{0}, {}}]]

Output 152

The envelope arises from the fact that a small variation in can be compensated by appropriate changes in and .

((-\[Alpha] + \[Beta]*Sqrt[\[Alpha]^2 + \[Beta]^2 - 1])*Sin[x*\[Alpha]])/(\[Alpha]^2 + \[Beta]^2) + ((-\[Beta] - \[Alpha]*Sqrt[\[Alpha]^2 + \[Beta]^2 - 1])*Sin[x*\[Beta]])/
   (\[Alpha]^2 + \[Beta]^2) // FullSimplify

Output 153

((-\[Alpha] + \[Beta] Sqrt[\[Alpha]^2 + \[Beta]^2 - 1]) Sin[x \[Alpha]] - (\[Beta] + \[Alpha] Sqrt[\[Alpha]^2 + \[Beta]^2 - 1]) Sin[x \[Beta]])/(\[Alpha]^2 + \[Beta]^2) 

Output 154

Manipulate[
 Plot[Evaluate[{-Cos[x] + Cos[\[Alpha] x] + Cos[\[Beta] x], -Cos[x] +
       Cos[x \[Alpha]] + Cos[x \[Beta]] +
                   (((-\[Alpha] + \[Beta] Sqrt[\[Alpha]^2 + \[Beta]^2 \
- 1]) Sin[x \[Alpha]] -
             (\[Beta] + \[Alpha] Sqrt[\[Alpha]^2 + \[Beta]^2 -
                  1]) Sin[
              x \[Beta]])/(\[Alpha]^2 + \[Beta]^2)) \
\[CurlyPhi]1MinusPi} /.
     { \[Alpha] -> GoldenRatio, \[Beta] ->
       GoldenRatio^2} /. \[CurlyPhi]1 -> Pi + 0.1],
  {x, 0, 1}],
 {{\[CurlyPhi]1MinusPi, 0.3, HoldForm[\[CurlyPhi]1 - Pi]}, -0.5, 0.5,
  Appearance -> "Labeled"},
 TrackedSymbols :> True]

Output 155

These zeros of the equation do indeed match the position of the above singularities in the distribution of the zero distances.

We end this section by noting that envelope condition, meaning the vanishing of derivatives with respect to the phases, is a very convenient method for finding special families of curves. For instance, there are families of solutions such that many curves meet at a zero.

findSolutions[eqs_] := Module[{fm},
   While[fm = FindRoot[Evaluate[eqs],
      {\[CurlyPhi]1, RandomReal[{0, 2 Pi}]}, {\[CurlyPhi]2,
       RandomReal[{0, 2 Pi}]}, {\[CurlyPhi]3,
       RandomReal[{0, 2 Pi}]},
      {d, RandomReal[{1/2, 5}]}] // Quiet;
         Not[
    Total[Abs[(Subtract @@@ eqs) /. fm]] < 10^-6 \[And]
     10^-3 < Abs[d /. fm] < 5]  ] ;
  fm /. (\[CurlyPhi] : (\[CurlyPhi]1 | \[CurlyPhi]2 | \[CurlyPhi]3) \
-> \[Xi]_) :> (\[CurlyPhi] -> Mod[\[Xi], 2 Pi])]

Modulo reflection symmetry, there is a unique solution to this problem.

SeedRandom[1];
fs1 = findSolutions[{gGolden[
     0, {\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3}] == 0,

   Derivative[0, {1, 0, 0}][gGolden][
     0, {\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3}] == 0,

   gGolden[d, {\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3}] == 0,

   Derivative[0, {1, 0, 0}][gGolden][
     d, {\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3}] == 0}]

Output 156

Plotting a family of curves with different values of shows that at the two zeros, the family of curves bunches up.

Plot[Evaluate[
  Table[gGolden[
     x, {\[CurlyPhi]1 + \[Delta]\[CurlyPhi]1, \[CurlyPhi]2, \
\[CurlyPhi]3}], {\[Delta]\[CurlyPhi]1, -0.2, 0.2, 0.4/6}] /.
   fs1], {x, -3, 6}, GridLines -> ({{d}, {}} /. fs1)]

Output 157

And here are some solutions that show curves that bunch at a zero and at an extremum.

Function[sr, SeedRandom[sr];
  fs2 = findSolutions[{gGolden[
       0, {\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3}] == 0,

     Derivative[0, {1, 0, 0}][gGolden][
       0, {\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3}] == 0,

     Derivative[1, {0, 0, 0}][gGolden][
       d, {\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3}] == 0,

     Derivative[0, {1, 0, 0}][gGolden][
       d, {\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3}] == 0}];
  Plot[Evaluate[
    Table[gGolden[
       x, {\[CurlyPhi]1 + \[Delta]\[CurlyPhi]1, \[CurlyPhi]2, \
\[CurlyPhi]3}], {\[Delta]\[CurlyPhi]1, -0.2, 0.2, 0.4/6}] /.
     fs2], {x, -3, 6}, GridLines -> ({{d}, {}} /. fs2)]] /@ {1, 6, 38}

Output 158

We also look at a second family of envelope solutions: what are the most general types of curves that fulfill the envelope condition at an extremum? This means we have to simultaneously fulfill the following two equations.

{Derivative[1, {0, 0, 0}][gGolden][
   0, {\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3}] == 0,
 Derivative[0, {1, 0, 0}][gGolden][
   0, {\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3}] == 0}

Output 159

This in turn means we must have .

cpExtEnv =
 ContourPlot[-GoldenRatio Sin[\[CurlyPhi]2] -
    GoldenRatio^2 Sin[\[CurlyPhi]3] == 0,
                                                {\[CurlyPhi]2, 0,
   2 Pi}, {\[CurlyPhi]3, 0, 2 Pi}, PlotPoints -> 40]

Output 160

Here is a contour plot of the curves in the plane where the extremum envelope condition is fulfilled.

linesExtEnv = Cases[Normal[cpExtEnv], _Line, \[Infinity]];

Show[ Plot[
    Cos[x + 0] + Cos[GoldenRatio x + #1] +
     Cos[GoldenRatio^2 x + #2], {x, -5, 5},
       PlotStyle ->
     Directive[Thickness[0.001], RGBColor[0.36, 0.51, 0.71],
      Opacity[0.5]],
       PlotRange -> All,
    GridLines -> {{}, {-3, -1, 1,
       3}}] & @@@
                                                    \

  RandomSample[Level[linesExtEnv, {-2}], UpTo[300]]]

Output 161

We add a mouseover to the contour plot that shows a family of curves near to the envelope conditions.

make\[CurlyPhi]2\[CurlyPhi]3Plot[{\[CurlyPhi]2_, \[CurlyPhi]3_}] :=
 Column[{Plot[
    Evaluate[
     Table[gGolden[
       x, {\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3}], {\[CurlyPhi]1, \
-0.15, 0.15, 0.3/6}]],
                            {x, -4, 4},
    PlotLabel -> Subscript[\[CurlyPhi], 1] \[TildeTilde] 0],
         Plot[
    Evaluate[
     Table[gGolden[
       x, {Pi + \[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3}], {\
\[CurlyPhi]1, -0.15, 0.15, 0.3/6}]],
                           {x, -4, 4},
    PlotLabel -> Subscript[\[CurlyPhi], 1] \[TildeTilde] Pi]},
  Dividers -> Center]

Normal[cpExtEnv] /.
 Line[l_] :> (Tooltip[Line[ #],
      Dynamic[make\[CurlyPhi]2\[CurlyPhi]3Plot[Mean[#]]]] & /@
    Partition[l, 2, 1] )

Output 162

And the next graphic shows the distance between the nearest (to the origin) positive or negative roots.

addHeight[{\[CurlyPhi]2_, \[CurlyPhi]3_}, pm_] :=
 Module[{roots, \[Rho] },
  roots =
   Sort[x /.
      Solve[gGolden[x, {0, \[CurlyPhi]2, \[CurlyPhi]3}] ==
         0 \[And] -6 < x < 6, x]] // Quiet;
  \[Rho] =
   If[pm === 1,
     Select[roots, # > 0 &, 1], -Select[Sort[-roots], # > 0 &, 1] ][[
    1]];
  {{\[CurlyPhi]2, \[CurlyPhi]3,
    0}, {\[CurlyPhi]2, \[CurlyPhi]3, \[Rho]}}]

Graphics3D[{Opacity[0.2], Gray,
  Polygon[{{0, 0, 0}, {2 Pi, 0, 0}, {2 Pi, 2 Pi, 0}, {0, 2 Pi, 0}}],
  EdgeForm[], Opacity[1],
  Transpose[{{RGBColor[0.88, 0.61, 0.14],
     RGBColor[0.36, 0.51, 0.71]},
    Table[
     Polygon[Join[#1, Reverse[#2]] & @@@
         Partition[addHeight[#, s] & /@ #[[1]], 2, 1]] & /@
      linesExtEnv,
     {s, {1, -1}}]}]}, PlotRange -> All, Axes -> True,
 Lighting -> "Neutral",
 AxesLabel -> {Subscript[\[CurlyPhi], 2], Subscript[\[CurlyPhi], 3],
\!\(\*SubscriptBox[\(\[Rho]\), \("\<\[PlusMinus]\>"\)]\)} ]

Output 163

The Peak Positions of the Zero Distances

Now I can implement the following function, maximaPositions, to find the singularities of the distributions of the distances of successive zeros for functions of the form + for arbitrary real .

maximaPositions[
  a1_. Cos[x_] + a2_. Cos[\[Alpha]_ x_] + a3_. Cos[\[Beta]_ x_], x_] :=

  2*(Function[{s1, s2, s3},
     Min[N[
       x /. Solve[
         s1 a1 Cos[x] + s2 a2 Cos[\[Alpha] x] +
            s3 a3 Cos[\[Beta] x] == 0 \[And]
          0 < x < 10, x]]]] @@@ {{1, 1, 1}, {-1, 1, 1}, {1, -1,
      1}, {1, 1, -1}})

Here are the positions of the peaks for .

peaksGolden = maximaPositions[fGolden[x], x]

Output 164

Zooming into the histogram shows again that the predicted peak positions match the observed ones well.

Partition[Histogram[Differences[zerosGolden], 2000,
     PlotRange -> {{# - 0.02, # + 0.02}, All},
     GridLines -> {peaksGolden, {}},
     PlotRangeClipping -> True] & /@ peaksGolden, 2] // Grid

Output 165

Here is a quick numerical/graphical check for a “random” function of the prescribed form with not identically one.

testFunction[x_] := Cos[x] + 2 Cos[Sqrt[2] x] + Sqrt[3] Cos[Pi x]

 zerosTestFunction = findZeros[testFunction, 10^5]; 

singPosFunction = maximaPositions[testFunction[x], x]

Output 166

Histogram[Differences[zerosTestFunction], 100,
 GridLines -> {singPosFunction, {}}]

Output 167

We should check for an extended range of parameters if the conjectured formula for the position of the singularities really holds. So for a few hundred values of in , we calculate the histograms of the zero distances. This calculation will take a few hours. (In the interactive version, the cell is set to unevaluatable.)

With[{p\[Alpha] = 200},
 Monitor[
  \[Alpha]Data =
   SparseArray[
      Flatten[Table[({j, Round[p\[Alpha] #1] + 1} -> #2) & @@@ #[[
           j]][[2]], {j, Length[#]}], 1]] & @
    Table[
     f\[Alpha][x_] := Cos[x] + Cos[\[Alpha] x] + Cos[\[Alpha]^2 x];
                  zList = findZeros[f\[Alpha], 20000, 0];
                          {\[Alpha],
      Tally[Round[Differences[zList], N[1/p\[Alpha]]]]};,
              {\[Alpha], 1/2, 2, 1/(120 Pi)}],
  Row[{"\[Alpha]=", N[\[Alpha]]}]]]   

rPlot\[Alpha] =
 ReliefPlot[Log[1 + Take[\[Alpha]Data, {2, -1}, {1, 1200}]],

  DataRange -> {{0, 1200 0.005}, {1/2, 2}}, FrameTicks -> True,

  FrameLabel -> {"\[CapitalDelta] zeros", "\[Alpha]"},
  AspectRatio -> 1/3]

Output 168

Output 169

I overlay with the predicted positions of the singularities; they match perfectly.

Monitor[\[Alpha]Sings =
   Table[{#, \[Alpha]} & /@
     maximaPositions[N[Cos[x] + Cos[\[Alpha] x] + Cos[\[Alpha]^2 x]],
      x],
                                      {\[Alpha], 0.5, 2,
     1/5/201}];, \[Alpha]]

Output 170

Now, what do the positions of the singularities in the case of two parameters , in look like? Plotting the locations of a few thousand singularity positions in space clearly shows four intersecting surfaces.

singGraphics3D =
 Graphics3D[{RGBColor[0.36, 0.51, 0.71], Sphere[Flatten[
     Table[{\[Alpha], \[Beta], #} & /@
       Quiet[maximaPositions[
         N[Cos[x] + Cos[\[Alpha] x] + Cos[\[Beta] x]], x]],
      {\[Beta], 1/2 + Pi/1000, 5/2 + Pi/1000, 2/31},
      {\[Alpha], 1/2 + Pi/1001, 5/2 + Pi/1001, 2/31}], 2], 0.015]},
  PlotRange -> {{0.5, 2.5}, {0.5, 2.5}, {0, 6}},
  BoxRatios -> {1, 1, 1}, Axes -> True,
  ViewPoint -> {2.83, 1.76, -0.61}, Method -> {"SpherePoints" -> 6}]

Output 171

Instead of calculating many concrete tuples of positions, we can consider the positions of the singularities as functions of , in . Differentiating the last expression allows us to get a partial differential equation for each of the four equations that, given boundary conditions, we can solve numerically and then plot. Or instead of solving a partial differential equation, we can fix one of the two parameters and and obtain a family of parametrized ordinary differential equations. We carry this procedure out for the two sheets that don’t cross each other.

smallestRoot[{pm1_, pm2_, pm3_}, \[Alpha]_, \[Beta]_] :=
 Min@Select[DeleteCases[Table[
     Quiet@
      Check[x /.
        FindRoot[
         pm1 Cos[x] + pm2 Cos[\[Alpha] x] + pm3 Cos[\[Beta] x] == 0,
             {x, RandomReal[{0, Pi}]},
         PrecisionGoal -> 12], {}], {40}], {}], # > 0 &]

makeGrid[{pm1_, pm2_, pm3_}, M_] :=
 Show[Cases[Flatten[
     {Table[
       nds\[Alpha] =
        NDSolveValue[{D[
            Cos[x[\[Alpha]]] + Cos[\[Alpha] x[\[Alpha]]] +
             Cos[\[Beta] x[\[Alpha]]], \[Alpha]] == 0,
          x[E] == smallestRoot[{pm1, pm2, pm3}, E, \[Beta]]},
         x, {\[Alpha], 3/4, 3}, PrecisionGoal -> 12];
       ParametricPlot3D[{\[Alpha], \[Beta], 2 nds\[Alpha][\[Alpha]]},
        Evaluate[Flatten[{\[Alpha], nds\[Alpha][[1]]}]],
        PlotRange -> All, PlotStyle -> Gray], {\[Beta],
        3/4 + Pi/1000, 3 + Pi/1000, 2/M}],
      Table[
       nds\[Beta] =
        NDSolveValue[{D[
            Cos[x[\[Beta]]] + Cos[\[Alpha] x[\[Beta]]] +
             Cos[\[Beta] x[\[Beta]]], \[Beta]] == 0,
          x[E] == smallestRoot[{pm1, pm2, pm3}, \[Alpha], E]},
         x, {\[Beta], 3/4, 3}, PrecisionGoal -> 12];
       ParametricPlot3D[{\[Alpha], \[Beta], 2 nds\[Beta][\[Beta]]},
        Evaluate[Flatten[{\[Beta], nds\[Beta][[1]]}]],
        PlotRange -> All,
        PlotStyle ->
         Directive[RGBColor[0.88, 0.61, 0.14], Thickness[0.002]]],
       {\[Alpha], 3/4 + Pi/1000, 3 + Pi/1000, 2/M}]
      }], _Graphics3D], PlotRange -> All,
   AxesLabel -> {"\[Alpha]", "\[Beta]", None}] // Quiet

Show[{singGraphics3D, makeGrid[{1, 1, 1}, 20],
  makeGrid[{-1, 1, 1}, 20]}]

Output 172

The other two sheets could also be calculated, but things would become a bit more complicated because the initial conditions calculated with smallestRoot are no longer continuous functions of and . The following graphic visualizes this situation when new zeros suddenly appear that didn’t exist for the blue curve due to a small change in .

Module[{\[Alpha] = 2.02, \[Beta] = 2.704},
 Plot[{Cos[x] - Cos[\[Alpha] x] + Cos[\[Beta] x],
   Cos[x] - Cos[(\[Alpha] - 0.1) x] + Cos[\[Beta] x]}, {x, 0, 3}]]

Output 173

Interestingly, one can generalize even further the above formula for the peaks in the distance between successive zeros and allow arbitrary phases in the three cos functions. Numerical experiments indicate that for many such cosine sums, one can just ignore the phases and find the smallest zeros of exactly the same equations as above.

maximaPositionsGeneralized[
  a1_. Cos[x_ + \[CurlyPhi]1_.] +
   a2_. Cos[\[Alpha]_ x_ + \[CurlyPhi]2_.] +
   a3_. Cos[\[Beta]_ x_ + \[CurlyPhi]3_.], 

  x_] := maximaPositions[
  a1 Cos[x] + a2 Cos[\[Alpha] x] + a3 Cos[\[Beta] x], x]  

Here is another random example.

fRandom[x_] :=
 1/2 Cos[x + 1] + Sqrt[2] Cos[GoldenRatio x + Pi/5] +
  Sqrt[3] Cos[Pi x + 2]
zerosRandom = findZeros[fRandom, 10^5]; 

singPosFunction = maximaPositionsGeneralized[fRandom[x], x]

Output 174

Histogram[Differences[zerosRandom], 100,
 GridLines -> {singPosFunction, {}}]

Output 175

I modify the phases in the above function fRandom, and obtain the same position for the singularities.

fRandom2[x_] :=
 1/2 Cos[x + Cos[3]] + Sqrt[2] Cos[GoldenRatio x + Log[2]] +
  Sqrt[3] Cos[Pi x + E]
zerosRandom2 = findZeros[fRandom2, 10^5]; 

Histogram[Differences[zerosRandom2], 100,
 GridLines -> {singPosFunction, {}}]

Output 176

In degenerate cases, such as all phases being , meaning , the positions of the peaks in the distribution of the zero distances will sometimes be different from the just-given conjecture. This means that e.g. the position of the spacings of the extrema of the sin equivalent of are not described by the above equations.

Even More Peaks—Well, Sometimes

In the last section, we established the position of the peaks of the original MathOverflow post as twice the smallest zeros of . And for many random instances of and , these four numbers indeed characterize the peaks visible in the distribution of successive zero distances of . We saw this clearly in the plots in the last section that spanned various parameter ranges for and .

Earlier, I remarked that the original MathOverflow plot that used the function has some features special to this function, like the gaps in the distribution of the zero distances. At the same time, the function is generic in the sense that the zero-spacing distribution has exactly four peaks, as we expect for generic and : the four red curves in the above graphic for rPlotα. We consider a slight modification of fGolden where instead of , we use .

\[Phi]Brass = (1 + Sqrt[3])/2;
fBrass[x_] := Cos[x] + Cos[\[Phi]Brass x] + Cos[\[Phi]Brass^2 x]

We again calculate the first 100k zeros and their distances.

zerosBrass = findZeros[fBrass, 10^5];

differencesBrass = Differences[zerosBrass];

Interestingly, we now get a distribution with six maxima. Four of the maxima are again well described by the maxima position conjectured above.

peaksBrass = maximaPositions[fBrass[x], x];

Histogram[differencesBrass, 1000, GridLines -> {peaksBrass, {}}]

Output 177

The square root term makes all these examples special. The function is ultimately only dependent on two, rather than three, algebraically independent terms.

Cos[x] + Cos[(1 + Sqrt[n])/2 x] + Cos[(1 + Sqrt[n])/2 ^2 x] //
  ExpandAll // TrigExpand 

Output 178

Collect[Subtract @@
  Eliminate[{fSqrtN == %, Cos[x/4]^2 + Sin[x/4]^2 == 1,
    Cos[Sqrt[n] x/4]^2 + Sin[Sqrt[n] x/4]^2 == 1}, {Sin[x/4],
    Sin[Sqrt[n] x/4]}] , fP, Factor]

Output 179

This is reflected in the fact that the triples , similar to the above equivalent for the golden ratio, are located on relatively simple 2D surfaces.

Show[{ContourPlot3D[(-1 + x + 2 y^2)^2 + 4 (-1 + x - 2 x y^2) z^2 +
     4 z^4 == 0,
                                 {x, -1, 1}, {y, -1, 1}, {z, -1, 1},
   PlotPoints -> 40, Mesh -> None,
                                  ContourStyle -> Opacity[0.5]],
  Graphics3D[{PointSize[0.005],
    Point[
     Table[{Cos[x] , Cos[\[Phi]Brass x] , Cos[\[Phi]Brass^2 x]}, {x,
       1., 10000., 1.}]]}]}]

Output 180

A tempting and easy generalization of the positions of the maxima might be zero distances that follow the previously calculated four distances. This generalization is easy to implement.

rootDistances[
  a1_. Cos[x_] + a2_. Cos[\[Alpha]_ x_] + a3_. Cos[\[Beta]_ x_], x_,
  xMax_] := Function[{s1, s2, s3},
   DeleteDuplicates[Differences[ Sort[
      N[x /.
        Solve[s1 a1 Cos[x] + s2 a2 Cos[\[Alpha] x] +
            s3 a3 Cos[\[Beta] x] == 0 \[And] -xMax < x < xMax,
         x]]]]]] @@@ {{1, 1, 1}, {-1, 1, 1}, {1, -1, 1}, {1, 1, -1}}

Interestingly, that gives nearly the correct positions, but not quite.

rdBrass = rootDistances[fBrass[x], x, 12]

Output 181

Function[c,
  Histogram[Select[differencesBrass, c - 0.005 < # < c + 0.005 &],
   100, GridLines -> {Flatten[rdBrass], {}},
                           PlotRangeClipping -> True]] /@ {1.0977,
  2.366}

Output 182

Where are these additional maxima? We will not calculate their exact positions here. But a quick look at the neighborhood of zeros that have the peak distances shows clearly that there are additional families of envelope curves involved. Interestingly again, families with occur, and this time reflected and translated versions of the curve arise.

With[{L = {#[[1, 1]], Last /@ #} & /@
     Reverse[SortBy[Split[Sort[Transpose[
          {Round[differencesBrass, 0.001], Most[zerosBrass]}]], #1[[
           1]] === #2[[1]] &], Length]]},
  Function[p,
    Show[Plot[fBrass[# + t], {t, -10, 0 + 10}, PlotRange -> All,
        PlotLabel -> Row[{"x", "\[TildeTilde]", p}],
        GridLines -> {None, {-1, 1, 3}},
        PlotStyle ->
         Directive[RGBColor[0.36, 0.51, 0.71], Thickness[0.001],
          Opacity[0.5]]] & /@
      Take[Select[L, Abs[#[[1]] - p] < 0.1 &, 1][[
         1, 2]], UpTo[50]]]] /@ {1.098, 2.367}] /.
 l_Line :> Mouseover[l, {Red, Thick, l}] 

Output 183

We will not try to interpret the family of curves that form these singularities here and now; in the next section we will develop some general methods to identify the positions of the singularities on the zero distances.

For larger square roots, even stranger distributions with even more maxima can occur in the distribution of the zero spacings. Here is the case:

\[Phi]Platinum = (1 + Sqrt[13])/2;
fPlatinum[x_] :=
 Cos[x] + Cos[\[Phi]Platinum x] + Cos[\[Phi]Platinum^2 x]
zerosPlatinum = findZeros[fPlatinum, 10^5];

The zeros mod have multiple gaps.

Histogram[Mod[zerosPlatinum, 2 Pi], 1000]

Output 184

PolarPlot[1 + fPlatinum[t]^2/6, {t, 0, 200 2 Pi},

 PlotStyle ->
  Directive[Opacity[0.4], RGBColor[0.36, 0.51, 0.71],
   Thickness[0.001]],
                     PlotPoints -> 1000,
 Prolog -> {RGBColor[0.88, 0.61, 0.14], Disk[]}]

Output 185

differencesPlatinum = Differences[zerosPlatinum];
peaksPlatinum = maximaPositions[fPlatinum[x], x];
Histogram[differencesPlatinum, 1000, GridLines -> {peaksPlatinum, {}}]

Output 186

We end this section with the square root of 11, which has an even more complicated zero-spacing distribution.

\[Phi]Rhodium = (1 + Sqrt[11]);
fRhodium[x_] := Cos[x] + Cos[\[Phi]Rhodium x] + Cos[\[Phi]Rhodium^2 x]
zerosRhodium = findZeros[fRhodium, 10^5];
peaksRhodium = maximaPositions[fRhodium[x], x]
Histogram[Differences[zerosRhodium], 1000,
 GridLines -> {peaksRhodium, {}}, PlotRange -> All]

Output 187

Output 188

Zero Distances between Nonsuccessive Zeros

So far, we have looked at the distribution of the distances between successive zeros. In this section, we will generalize to the distribution between any pair of zeros. While this seems like a more general problem, the equations describing the possible distances will easily allow us to determine the peak positions for successive zero distances.

If we consider not only the distance between consecutive zeros but also between more distant zeros, we get a more complicated distribution of zero distances.

hgd = Histogram[
  zeroDistancesAll =
   Select[(zerosGolden[[#2]] - zerosGolden[[#1]]) & @@@
     Sort[Flatten[Table[{k, k + j}, {k, 20000}, {j, 1, 50}], 1]],
    # < 20 &], {0.001}]

Output 189

All of the peaks are sums of the four peaks seen in the distances between consecutive zeros. But the reverse is not true—not all sums of consecutive zero distances show up as peaks. We identify the sums that are observed.

observedPeaks =
  Sort[First /@
    Select[Tally[ Round[zeroDistancesAll, 0.001]], Last[#] > 50 &]];

calculatedPeaks =
  Flatten[Table[Union[{Total[First /@ #], Sort[Last /@ #]} & /@
      Tuples[
       Transpose[{{1.8136187, 1.04397, 1.49906, 3.01144},
         Range[4]}], {j}]],
    {j, 1, 10}], 1];

nf = Nearest[(#[[1]] -> #) & /@ calculatedPeaks];

peakSums = DeleteDuplicates[Sort[nf[#][[1]] & /@ observedPeaks]]

Output 190

Here is the left half of the last histogram shown together with the peak sum positions.

Show[{hgd,
  ListPlot[Callout[ {#1, 20 + 12 #}, Row[#2]] & @@@ peakSums,
   Filling -> Axis,
   PlotStyle -> PointSize[0.008]]}]

Output 191

The variable ranges from 0 to infinity in and so is not suited to be used as a parametrization variable to show large ranges. The three expressions , and are all in the interval . Above, we plotted the summands in these cosine terms; now we plot the triples , where is the distance between the and the zero. This gives some interesting-looking curves.

zeroPairIndices =
  Sort[Flatten[Table[{k, k + j}, {k, 25000}, {j, 1, 30}], 1]];

Graphics3D[{PointSize[0.001], RGBColor[0.36, 0.51, 0.71], Point[
   {Cos[GoldenRatio zerosGolden[[#1]]],
      Cos[GoldenRatio^2 zerosGolden[[#1]]],
      zerosGolden[[#2]] - zerosGolden[[#1]]} & @@@ zeroPairIndices]},
 BoxRatios -> {1, 1, 2}, Axes -> True,
 PlotRange -> {{-1, 1}, {-1, 1}, {0, 8}}]

Output 192

In the case of , we just get a curve; in the case of general and , we obtain an intricate-looking surface—for instance, for .

zerosEPi =
  findZeros[Function[x, Cos[x] + Cos[E x] + Cos[Pi x]], 4 10^4];

Graphics3D[{PointSize[0.001], RGBColor[0.36, 0.51, 0.71], Point[
   {Cos[ E zerosEPi[[#1]]], Cos[Pi zerosEPi[[#1]]],
      zerosEPi[[#2]] - zerosEPi[[#1]]} & @@@ zeroPairIndices]},
 BoxRatios -> {1, 1, 2}, Axes -> True,
 PlotRange -> {{-1, 1}, {-1, 1}, {0, 8}},
 ViewPoint -> {1.37, -3.08, 0.28},
 AxesLabel -> {Cos[\[Alpha] Subscript[z, i]],
   Cos[\[Beta] Subscript[z, i]], Subscript[z, j] - Subscript[z, i]}]

Output 193

Now, can we find a closed form of this surface? Turns out, we can. For generic  and , we will have no algebraic relation between and , so these two expressions are natural independent variables. Assume that is a zero of and that another zero has distance to . Then the sum of the three cosines implies a relation between and and . We can calculate this relation by eliminating unwanted variables from and .

f\[Alpha]\[Beta][x_] := Cos[x] + Cos[\[Alpha] x] + Cos[\[Beta] x]

 f\[Alpha]\[Beta][x0 + \[Delta]] // ExpandAll // TrigExpand

c\[Alpha]c\[Beta]\[Delta]Equation = GroebnerBasis[
      {f\[Alpha]\[Beta][x0],
       f\[Alpha]\[Beta][x0 + \[Delta]] // ExpandAll // TrigExpand,
       (* algebaric identities for Cos[...], Sin[...]  *)

       Cos[x0]^2 + Sin[x0]^2 - 1,
       Cos[\[Alpha] x0]^2 + Sin[\[Alpha] x0]^2 - 1,
       Cos[\[Beta] x0]^2 + Sin[\[Beta] x0]^2 - 1}, {},
      {Cos[x0], Sin[x0], Sin[\[Alpha] x0], Sin[\[Beta] x0]},
      MonomialOrder -> EliminationOrder][[
     1]] /.
    {Cos[x0 \[Alpha]] -> c\[Alpha],
     Cos[x0 \[Beta]] -> c\[Beta]} // Factor;

The resulting polynomial (in , ) is pretty large, with more than 2,500 terms.

{Exponent[c\[Alpha]c\[Beta]\[Delta]Equation, {c\[Alpha], c\[Beta]}],
 Length[c\[Alpha]c\[Beta]\[Delta]Equation]}

Output 194

Here is a snippet of the resulting equation.

Short[c\[Alpha]c\[Beta]\[Delta]Equation, 8]

Output 195

The displayed curve and surface are special cases of this equation. Because of its size, we compile the equation for faster plotting.

cf\[Alpha]\[Beta] =
 Compile[{\[Alpha], \[Beta], c\[Alpha], c\[Beta], \[Delta]},
  Evaluate[c\[Alpha]c\[Beta]\[Delta]Equation],
  CompilationOptions -> {"ExpressionOptimization" -> True}]

Output 196

We cut part of the surface open to get a better look at the inside of it. (Because of the complicated nature of the surface, we plot over a smaller vertical range compared to the above plot that used points for the zeros.)

Module[{pp = 160, \[CurlyEpsilon] = 10^-1, data},
 Monitor[
  data = Table[
     cf\[Alpha]\[Beta][GoldenRatio, GoldenRatio^2, c\[Alpha],
      c\[Beta], \[Delta]],
     {\[Delta], \[CurlyEpsilon],
      4, (4 - \[CurlyEpsilon])/pp}, {c\[Beta], -1, 1,
      2/pp}, {c\[Alpha], -1, 1, 2/pp}];, N[\[Delta]]];
 ListContourPlot3D[data,
  DataRange -> {{-1, 1}, {-1, 1}, {\[CurlyEpsilon], 4}},
  Contours -> {0}, RegionFunction -> (Not[#1 > 0 \[And] #2 < 0] &),
  MeshFunctions -> {Norm[{#1, #2}] &, #3 &},
  BoundaryStyle ->
   Directive[RGBColor[0.36, 0.51, 0.71], Thickness[0.004]],
  ViewPoint -> {2.49, -2.22, 0.53}, BoxRatios -> {1, 1, 2},
  AxesLabel -> {Cos[\[Alpha] Subscript[z, i]],
    Cos[\[Beta] Subscript[z, i]], Subscript[z, j] - Subscript[z, i]}]]

Output 197

In the case of and , we have the above algebraic equation of the Cayley surface at our disposal to remove the term.

auxEq = Cos[x0]^2 + Cos[\[Alpha] x0]^2 +
    Cos[\[Beta] x0]^2 - (1 +
      2 Cos[x0] Cos[\[Alpha] x0] Cos[\[Beta] x0]) /.
   Cos[x0] -> -Cos[\[Alpha] x0] - Cos[\[Beta] x0] /. {Cos[
     x0 \[Alpha]] -> c\[Alpha], Cos[x0 \[Beta]] -> c\[Beta]}

Output 198

(Note that the last equation is zero only for , , only at zeros and not for all values of . Eliminating the variable cβ gives us an even larger implicit equation for the distances of nonsuccessive zeros, with more than 74,000 terms.)

c\[Alpha]\[Delta]Equation =
  Resultant[c\[Alpha]c\[Beta]\[Delta]Equation, auxEq, c\[Beta]];

{Exponent[c\[Alpha]\[Delta]Equation, c\[Alpha]],
 Length[c\[Alpha]\[Delta]Equation]}

Output 199

Luckily, this large equation factors in about 10 minutes into 4 much smaller equations, each having “only” 300 summands.

(c\[Alpha]\[Delta]EquationFactored =
    Factor[c\[Alpha]\[Delta]Equation];) // Timing

{Length[c\[Alpha]\[Delta]EquationFactored],
 Length /@ (List @@ c\[Alpha]\[Delta]EquationFactored)}

Output 200

Here is a simplified form of the first factor. (For brevity of the resulting expression, we don’t yet substitute and , but will do so in a moment.)

firstFactor =
 Collect[c\[Alpha]\[Delta]EquationFactored[[1]], c\[Alpha],
  FullSimplify]

Output 201

cpc\[Phi] =
 ContourPlot[
   Evaluate[Block[{\[Alpha] = GoldenRatio, \[Beta] = GoldenRatio^2},
     (# == 0) & /@ (List @@
        c\[Alpha]\[Delta]EquationFactored)]], {c\[Alpha], -1,
    1}, {\[Delta], 0.1, 6},
   PlotPoints -> 60, AspectRatio -> 3/2] /. Tooltip[x_, _] :> x

Output 202

We overlay a few thousand randomly selected distances from the 100k zeros of calculated above. The points all fall on the blue curve, meaning the equation firstFactor describes the position of the nonsuccessive zero distances. We indicate the positions of the maxima in the successive zero distances by horizontal gridlines. (As we used generic , in the derivation of the four functions of cαδEquationFactored, we could also use and obtain a similar image.)

c\[Phi]Points = Module[{i, j},
        Select[
    Table[i = RandomInteger[{1, 99900}]; j = RandomInteger[{1, 10}];
               {Cos[GoldenRatio  zerosGolden[[i]]],
      zerosGolden[[i + j]] - zerosGolden[[i]]},
                              {50000}], #[[2]] < 6 &]];

Show[{cpc\[Phi],
  Graphics[{Black, Opacity[0.2], PointSize[0.005],
    Point[c\[Phi]Points]}]},
             GridLines -> {{}, {1.8136, 1.0439, 1.4990, 3.0114`} }]

Output 203

We see that the peak positions of the successive zero distances (gridlines) are horizontal tangents on the curves. Intuitively, this is to be expected: at a horizontal tangent, many zero distances have approximately equal values, and so the singularities in the distribution form. This horizontal tangent observation now gives us a purely algebraic method to determine the peak positions of the zero distances. The condition of horizontal tangents on the given curve described by firstFactor gives two curves whose intersection points determine the peak positions we are looking for. Here are the curves for firstFactor and the curves that represent the conditions of horizontal tangents plotted together. The intersections of the blue and the yellow/brown curves are the relevant points.

ContourPlot[
  Evaluate[Block[{\[Alpha] = GoldenRatio, \[Beta] = GoldenRatio^2},
    {firstFactor == 0,
     D[firstFactor == 0 /. \[Delta] -> \[Delta][c\[Alpha]],
        c\[Alpha] ] /. \[Delta]'[c\[Alpha]] -> 0 /. \[Delta][
        c\[Alpha]] -> \[Delta]}]],
  {c\[Alpha], -1, 1}, {\[Delta], 0, 3.5}, PlotPoints -> 60,
  GridLines -> {{}, {1.8136, 1.044, 1.5, 3.011}}] /.
 Tooltip[x_, _] :> x

Output 204

By eliminating the variable cα, we are left with a univariate equation in the zero spacing. But the resulting intermediate polynomials will be quite large (~877k terms!). So instead, we calculate a numerically high-precision approximation of the values of the horizontal tangents.

firstFactorTangents =
 FindRoot[Evaluate[
     Block[{\[Alpha] = GoldenRatio, \[Beta] = GoldenRatio^2},
                       {firstFactor == 0,
       D[firstFactor == 0 /. \[Delta] -> \[Delta][c\[Alpha]],
          c\[Alpha] ] /. \[Delta]'[c\[Alpha]] -> 0 /. \[Delta][
          c\[Alpha]] -> \[Delta]}]],
                       {c\[Alpha], #1}, {\[Delta], #2},
    WorkingPrecision -> 50, Method -> "Newton"] & @@@ {{0.3,
    1.8}, {-0.6, 1.04}, {0.3, 1.5}, {0.8, 3.01}}

Output 205

The four peak position values agree perfectly with the previously calculated values.

peakFunctions =
  Function[x, #1 Cos[x] + #2 Cos[GoldenRatio x] + #3 Cos[
        GoldenRatio^2 x]] & @@@ {{1, 1, 1}, {-1, 1, 1}, {1, -1,
     1}, {1, 1, -1}};

#1[\[Delta]/2 /. #2] & @@@
 Transpose[{peakFunctions, firstFactorTangents}]

Output 206

As a function of the zero distance , the function firstFactor describes not only the distance between successive zeros, but also between distant zeros. In the following graphic, we connect the points of the zeros and for . The graphic shows how firstFactor does indeed describe the zero distances.

Show[{
  Graphics[{Thickness[0.001], Opacity[0.2],
    Table[{{RGBColor[0.368417, 0.506779, 0.709798], RGBColor[
        0.880722, 0.611041, 0.142051], RGBColor[
        0.560181, 0.691569, 0.194885], RGBColor[
        0.922526, 0.385626, 0.209179], RGBColor[
        0.528488, 0.470624, 0.701351], RGBColor[
        0.772079, 0.431554, 0.102387], RGBColor[
        0.363898, 0.618501, 0.782349], RGBColor[1, 0.75, 0], RGBColor[
        0.647624, 0.37816, 0.614037], RGBColor[
        0.571589, 0.586483, 0.], RGBColor[0.915, 0.3325, 0.2125],
        RGBColor[0.40082222609352647`, 0.5220066643438841, 0.85]}[[
       k - 1]],
      Line[{ #[[-1]] - #1[[1]], Cos[GoldenRatio #[[1]]]} & /@
        Take[Partition[zerosGolden, k, 1], 2000]]},
     {k, 2, 7}]}, Axes -> True, PlotRange -> {{0, 10}, {-1, 1}}],
  ContourPlot[
    Evaluate[
     Block[{\[Alpha] = (1 + Sqrt[5])/
         2, \[Beta] = ((1 + Sqrt[5])/2)^2},
      firstFactor == 0]], {\[Delta], 0.1, 10}, {c\[Alpha], -1, 1},
    PlotPoints -> {80, 20}, ContourStyle -> Black] /.
   Tooltip[x_, _] :> x},
 Frame -> True, Axes -> False, PlotRangeClipping -> True,
 AspectRatio -> 1/4]

Output 207

The graphic also shows the string correlation between successive zeros that we saw in the previous pair correlation histogram.

Histogram[
 VectorAngle[#1 - #2, #3 - #2] & @@@
  Partition[{ #[[-1]] - #1[[1]], Cos[GoldenRatio #[[1]]]} & /@
                                   Partition[zerosGolden, 2, 1], 3,
   1], 1000, {"Log", "Count"}]

Output 208

Above, we plotted the zero distances over the complex plane. The expression firstFactor allows us to plot the value of over the complexplane. The next graphic shows the real part of over a part of the first quadrant.

Module[{pp = 60, pts, c\[Alpha]Zeros},
 (c\[Alpha]Zeros[\[Delta]_] :=
     c\[Alpha] /.
      Solve[Block[{\[Alpha] = GoldenRatio, \[Beta] =
          GoldenRatio^2}, # == 0], c\[Alpha]]) &[firstFactor];
 pts = Cases[
   Flatten[Table[
     N@{\[Delta]x, \[Delta]y, Re[#]} & /@
      c\[Alpha]Zeros[N[\[Delta]x + I \[Delta]y]],
                                {\[Delta]y, -0, 2, 2/pp}, {\[Delta]x,
      0, 2, 2/pp}], 2], {_Real, _Real, _Real}];
 Graphics3D[{RGBColor[0.36, 0.51, 0.71], Sphere[pts, 0.01]},
  BoxRatios -> {1, 1, 3/2}, Axes -> True,
  PlotRange -> {All, All, 6 {-1, 1}},
  AxesLabel -> {Re[\[Delta]], Im[\[Delta]], Re[c\[Alpha]]},
  ViewPoint -> {1.98, -2.66, 0.65}, Method -> {"SpherePoints" -> 6}]]

Output 209

Now we have all equations at hand to determine the two remaining peak positions of the function fBrass, which had the approximate values and . We use the implicit equation obeyed by and at zeros of .

c\[Alpha]c\[Beta]Brass[c\[Alpha]_, c\[Beta]_] =
 Collect[1 + 2 c\[Alpha] - 3 c\[Alpha]^2 - 4 c\[Alpha]^3 +
   4 c\[Alpha]^4 + 2 c\[Beta] + 2 c\[Alpha] c\[Beta] -
   4 c\[Alpha]^2 c\[Beta] - 3 c\[Beta]^2 - 4 c\[Alpha] c\[Beta]^2 +
   8 c\[Alpha]^3 c\[Beta]^2 - 4 c\[Beta]^3 +
   8 c\[Alpha]^2 c\[Beta]^3 + 4 c\[Beta]^4, c\[Beta]]

Output 210

Rather than eliminating the variable symbolically, for each cα, we numerically calculate all possible values for cβ and substitute these values into cαcβδEquation. For faster numerical evaluation, we compile the resulting expression.

c\[Alpha]\[Delta]BrassCompiled =
 Compile[{{c\[Alpha], _Complex}, {\[Delta], _Complex}},
  Evaluate[Block[{\[Alpha] = (1 + Sqrt[3])/
       2, \[Beta] = ((1 + Sqrt[3])/2)^2},

    Block[{c\[Beta] = #},
       c\[Alpha]c\[Beta]\[Delta]Equation] & /@ (c\[Beta] /.
       Solve[c\[Alpha]c\[Beta]Brass[c\[Alpha], c\[Beta]] == 0,
        c\[Beta]])]],
  CompilationOptions -> {"ExpressionOptimization" -> True}]

Output 211

Calculating the values of cαcβBrass on a dense set of cα, δ grid points as blue points graphically the represents all possible zero distances as a function of cα. We overlay some of the previously calculated zero distances from above as orange points, the four identified peak positions as dark green lines and the two outstanding peak positions as red lines.

Module[{ppc\[Alpha] = 400, pp\[Delta] = 600, data, cp},
 Monitor[data =
    Table[c\[Alpha]\[Delta]BrassCompiled[
      c\[Alpha], \[Delta]], {\[Delta], 0, 4,
      4/pp\[Delta]}, {c\[Alpha], -1, 1, 2/ppc\[Alpha]}];,
  N[{\[Delta], c\[Alpha]}]];
 cp = Show[
   ListContourPlot[Re[#], Contours -> {0}, ContourShading -> None,
      DataRange -> {{-1, 1}, {0, 4}},
      ContourStyle ->
       Directive[RGBColor[0.36, 0.51, 0.71], Thickness[0.004]],
      PlotRange -> {{-1, 1}, {0.1, 4}}] & /@
    Transpose[data, {2, 3, 1}]];
 Show[{Graphics[{PointSize[0.004], Opacity[0.3], Orange,
     Point[{Cos[\[Phi]Brass #1], #2} & @@@

       RandomSample[Transpose[{Most[zerosBrass], differencesBrass}],
        10000]],
     Darker[Green], Opacity[1], Thickness[0.002],
     Line[{{-1, #}, {1, #}} & /@ {2.2299, 1.46396, 2.0722, 3.5761}],
     Red, Line[{{-1, #}, {1, #}} & /@ {1.098, 2.367}]},
    AspectRatio -> 3/2, Frame -> True, PlotRangeClipping -> True,
    PlotRange -> {{-1, 1}, {0.1, 4}}], cp}]]

Output 212

We clearly see that the two remaining peak positions also occur at points where the zero distance curve has a horizontal tangent. Expressing the condition of a horizontal tangent to the curve cαcβδEquation (with the constraint cαcβBrass) numerically allows us to calculate high-precision values for the two remaining peak positions. (We also include the differentiated form of the constraint to have four equations in four variables.)

c\[Alpha]c\[Beta]Brass = (-1 + x + 2 y^2)^2 +
     4 (-1 + x - 2 x y^2) z^2 + 4 z^4 /.
    x -> -y - z /. {y -> c\[Alpha], z -> c\[Beta]} // Simplify

Output 213

horizontalTangentsBrass =
  Block[{\[Alpha] = \[Phi]Brass, \[Beta] = \[Phi]Brass^2},
     {c\[Alpha]c\[Beta]\[Delta]Equation /. {
       c\[Beta] ->
        c\[Beta][c\[Alpha]], \[Delta] -> \[Delta][c\[Alpha]]},
     D[c\[Alpha]c\[Beta]\[Delta]Equation /. {
        c\[Beta] ->
         c\[Beta][c\[Alpha]], \[Delta] -> \[Delta][c\[Alpha]]},
      c\[Alpha]],
     c\[Alpha]c\[Beta]Brass /. c\[Beta] -> c\[Beta][c\[Alpha]],
     D[c\[Alpha]c\[Beta]Brass /. c\[Beta] -> c\[Beta][c\[Alpha]],
      c\[Alpha]]} /. {c\[Beta][c\[Alpha]] -> c\[Beta],
     Derivative[1][c\[Beta]][c\[Alpha]] ->
      c\[Beta]P, \[Delta][c\[Alpha]] -> \[Delta], \[Delta]'[
       c\[Alpha]] -> 0}];

Length[Expand[#]] & /@ horizontalTangentsBrass

Output 214

FindRoot[Evaluate[horizontalTangentsBrass],
                  {c\[Alpha], -4305/100000}, {\[Delta],
  10966/10000}, {c\[Beta], 97/100}, {c\[Beta]P, 78/100},
         WorkingPrecision -> 30, PrecisionGoal -> 10,
 Method -> "Newton", MaxIterations -> 100]

Output 215

FindRoot[Evaluate[horizontalTangentsBrass],
                   {c\[Alpha], 39/100}, {\[Delta],
  2366/1000}, {c\[Beta], -38/100}, {c\[Beta]P, -71/100},
         WorkingPrecision -> 30, PrecisionGoal -> 10,
 Method -> "Newton", MaxIterations -> 100]

Output 216

And now the calculated peak positions of the zero distances agree perfectly with the numerically observed ones.

Function[c,
  Histogram[Select[differencesBrass, c - 0.005 < # < c + 0.005 &],
   100, 

   GridLines -> {{1.0966482948, 2.3673493597}, {}},
                       PlotRangeClipping -> True,
   Method -> {"GridLinesInFront" -> True}]] /@ {1.0977, 2.366}

Output 217

Power Laws near the Peaks of the Zero Distances?

Now that we have found equations for the positions of the singularities, how does the density of the zero distances behave near such a singularity? To find out, we select bins near the singularities and count the number of distances in these bins.

singData =
  Table[Module[{sel}, sel =
     If[j == 2 || j == 3 || j == 4,
      Select[differencesGolden,
       Evaluate[peaksGolden[[j]] <= # <= peaksGolden[[j]] + 0.2] &],
      Select[differencesGolden,
       Evaluate[peaksGolden[[j]] - 0.2 <= # <= peaksGolden[[j]]] &]];
    {Abs[#1 - peaksGolden[[j]]], #2} & @@@ Tally[Round[sel, 0.001]]],
   {j, 4}];

A log-log plot of the counts versus the distance to the singularities shows straight lines. This encourages us to conjecture that the behavior of the density near a singularity behaves as .

ListLogLogPlot[singData, PlotRange -> {{5 10^-3, 1.8 10^-1}, All},
 PlotLegends -> (Row[{"x", "\[TildeTilde]", NumberForm[#, 4]}] & /@
    peaksGolden)]

Output 218

The numerical value of depends on the concrete singularity, and seems to be in the range of . Numerical experiments with other sums of three trigonometric functions show a power law behavior near the singularities in general. The values of the exponents vary.

Coefficient[
   Fit[Log[Select[#, 10^-3 <= #[[1]] <= 10^-1 &]], {1, x}, x],
   x] & /@ singData

Output 219

We can now also model what would happen if the phases in++ were random (but fulfilling the conditions for the envelopes). Here we do this for the local extrema at with function value –1 at this point.

gGolden[x_, {\[CurlyPhi]1_, \[CurlyPhi]2_, \[CurlyPhi]3_}] :=
  Cos[x + \[CurlyPhi]1] + Cos[GoldenRatio x + \[CurlyPhi]2] +
   Cos[GoldenRatio^2 x + \[CurlyPhi]3];

We select a random value for and calculate values for and so that , .

phases = DeleteCases[
   Table[Check[Block[{\[CurlyPhi]1 = RandomReal[{-Pi, Pi}]},
       {\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3} /.
        FindRoot[
         Evaluate[{gGolden[
             0, {\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3}] == -1,
                                                                      \
        Derivative[1, {0, 0, 0}][gGolden][
             0, {\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3}] == 0}],
         {\[CurlyPhi]2, RandomReal[{-Pi, Pi}]}, {\[CurlyPhi]3,
          RandomReal[{-Pi, Pi}]}]], {}],
                    {100000}] // Quiet, {}];

Due to the two constraint equations, the phases are correlated.

Histogram3D[Mod[phases, 2 Pi][[All, {##}]], 100,

   AxesLabel -> {Subscript["\[CurlyPhi]", #1],
     Subscript[
      "\[CurlyPhi]", #2]}] & @@@
                                     \
                                                                      \
     {{1, 2}, {1, 3}, {2, 3}}

Output 220

Two of the three remaining envelope zeros are clearly visible. (With the numerical root-finding method, one catches only a few curves that are near the green curve.) While the overall graphics look symmetric with respect to the line, the individual curves are not. In contrast to the behavior of , under the assumption of totally random phases between , and , the sums with random phases quickly take on values smaller than –3/2.

Plot[Evaluate[gGolden[x, #] & /@ RandomSample[phases, 250]], {x, -2,
   5},

  PlotStyle -> Directive[Thickness[0.001], Opacity[0.2], Gray],
  Prolog -> {Plot[
      Cos[x] - Cos[GoldenRatio x] - Cos[GoldenRatio^2 x], {x, -2, 5},

      PlotStyle ->
       Directive[RGBColor[0.36, 0.51, 0.71], Opacity[0.5]]][[1]],

    Plot[-Cos[x] + Cos[GoldenRatio x] - Cos[GoldenRatio^2 x], {x, -2,
       5},

      PlotStyle ->
       Directive[RGBColor[0.88, 0.61, 0.14], Opacity[0.5]]][[1]],

    Plot[-Cos[x] - Cos[GoldenRatio x] + Cos[GoldenRatio^2 x], {x, -2,
       5},

      PlotStyle ->
       Directive[ RGBColor[0.56, 0.69, 0.19], Opacity[0.5]]][[1]]},
  GridLines -> {{}, {-1, 3}},
  Epilog -> {Directive[Purple, PointSize[0.01]], 

    Point[{#/2, 0} & /@ {1.04398, 1.49906, 3.01144}]}] /.

 l_Line :> Mouseover[l, {Red, Thickness[0.002], Opacity[1], l}]

gGoldenZeros =
  Quiet[x /. FindRoot[Evaluate[gGolden[x, #]], {x, 1/2}] & /@ phases];

The estimated in obtained from the zeros of these curves with random phases agree remarkably well with the two values from the above histograms. This suggests that, to a certain degree, the assumption of random local phases is justified.

phasesmpp =
  With[{\[Xi] = peaksGolden[[2]]/2},
   Select[gGoldenZeros, \[Xi] < # < \[Xi] + 0.1 &] - \[Xi]];
\[Gamma]2 =
  Coefficient[
   Fit[N[Cases[Log[Tally[Round[phasesmpp, 0.001]]], {_Real, _}]], {1,
     x}, x], x];
Histogram[phasesmpp, 100,
 PlotLabel ->
  Row[{"\[Gamma]", "\[ThinSpace]\[TildeTilde]\[ThinSpace]",
    NumberForm[\[Gamma]2, 2]}]]

Output 221

phasespmp =
  With[{\[Xi] =
     peaksGolden[[3]]/
      2}, -(Select[gGoldenZeros, \[Xi] - 0.03 < # < \[Xi] &] - \[Xi])];
\[Gamma]3 =
  Coefficient[
   Fit[N[Cases[Log[Tally[Round[phasespmp, 0.001]]], {_Real, _}]], {1,
     x}, x], x];
Histogram[phasespmp, 100,
 PlotLabel ->
  Row[{"\[Gamma]", "\[ThinSpace]\[TildeTilde]\[ThinSpace]",
    NumberForm[\[Gamma]3, 2]}]]

Output 222

The appendix contains some calculations based on the computed zero density (assuming uniform distribution of phases) to see if the power law holds exactly or is approximate.

The Inflection Points of fɸ(x)

For completeness, I repeat the distance investigations that were carried out for the zeros and extrema for inflection points.

The inflection points are the zeros of the second derivative.

findInflectionPoints[f_, n_] := findZeros[f'', n]

inflectionsGolden =
  Prepend[findInflectionPoints[fGolden, 100000], 0.];

The following plots are the direct equivalent to the case of extrema, so we skip commenting on them individually.

Plot[fGolden[x], {x, 0, 10.3 Pi},
 Epilog -> {Darker[Red],
   Point[{#, fGolden[#]} & /@ Take[ inflectionsGolden, 30]]}]

Output 223

Graphics[{PointSize[0.001], RGBColor[0.36, 0.51, 0.71], Opacity[0.2],
  Point[N[{#, fGolden[#]} & /@ inflectionsGolden]]},
 AspectRatio -> 1/2, ImageSize -> 400, Frame -> True]

Output 224

Histogram[Mod[inflectionsGolden, 2 Pi], 200]

Output 225

Histogram[Differences[inflectionsGolden], 1000, PlotRange -> All]

Output 226

Histogram[Differences[inflectionsGolden, 2], 1000, PlotRange -> All]

Output 227

Histogram3D[{#2 - #1, #3 - #2} & @@@
  Partition[inflectionsGolden, 3, 1], 100, PlotRange -> All]

Output 228

summandValuesI = {Cos[#], Cos[GoldenRatio #],
     Cos[GoldenRatio^2 #]} & /@ inflectionsGolden;

Graphics3D[{PointSize[0.002], RGBColor[0.36, 0.51, 0.71],
  Point[Union@Round[summandValuesI, 0.01]]},
 PlotRange -> {{-1, 1}, {-1, 1}, {-1, 1}}, Axes -> True,
 AxesLabel -> {Cos[x], Cos[GoldenRatio x], Cos[GoldenRatio^2 x]}]

Output 229

Maximal Distance between Successive Zeros

Having found the positions of the peaks of the distribution of the distances of the zeros, another natural question to ask about the zero distribution is: what is the largest possible distance between two successive roots? The largest distance will occur in the following situation: starting at a zero, the function will increase or decrease, then have a first extremum, then a second and a third extremum, and then will have another zero. When the middle extremum barely touches the real axis, the distance between the two zeros will be largest. Here are some plots of the function around zeros that are the furthest apart. Note that while the curves look, at first glance, symmetric around x ≈ 1.6, the low maxima on the left side belongs to the curve with the high maxima on the right side and vice versa.

Show[Plot[fGolden[# + t], {t, -2, 0 + 5}, PlotRange -> All,
     PlotStyle ->
      Directive[RGBColor[0.36, 0.51, 0.71], Thickness[0.001],
       Opacity[0.3]]] & /@
   Take[Sort[
      Transpose[{differencesGolden, Most[zerosGolden]}]], -500][[All,
    2]],
  PlotRange -> All, Frame -> True, GridLines -> {{0}, {-1, 3}},
  ImageSize -> 400] /.

 l_Line :> Mouseover[l, {Red, Thickness[0.002], Opacity[1], l}]

Output 230

For the random phase model, I calculate the phases that make the middle extrema just touch the real axis.

h[x_] = Cos[x + \[CurlyPhi]1] + Cos[\[Alpha] x + \[CurlyPhi]2] +
   Cos[\[Beta] x + \[CurlyPhi]3] ;
\[CurlyPhi]2\[CurlyPhi]3MaxD\[CurlyPhi]1[] = (Solve[{h[x] == 0,
        D[h[x], x] == 0, D[h[x], \[CurlyPhi]1] == 0} /.
       x -> 0, {\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3}] /. _C ->
      0 // Simplify);
{Length[\[CurlyPhi]2\[CurlyPhi]3MaxD\[CurlyPhi]1[]], \[CurlyPhi]2\
\[CurlyPhi]3MaxD\[CurlyPhi]1[][[1]]}

Output 230

Here is a plot of a solution with the middle extrema touching the real axis.

touchingSolutions\[CurlyPhi]1[x_] =
  h[x] /. Select[ \[CurlyPhi]2\[CurlyPhi]3MaxD\[CurlyPhi]1[],
     Im[h[x] /. # /.
                                  {\[Alpha] ->
            GoldenRatio, \[Beta] -> GoldenRatio^2} /. x -> 5.] ==
       0 &] /.
   {\[Alpha] -> GoldenRatio, \[Beta] -> GoldenRatio^2};

Here is one of the solutions.

touchingSolutions\[CurlyPhi]1[x][[1]] // FullSimplify

Output 231

Here is a plot of a solution with the middle extrema touching the real axis. The four solutions each give the same maximal zero distance.

Plot[touchingSolutions\[CurlyPhi]1[x], {x, -3, 3}]

Output 232

The so-obtained maximal distance between two zeros agrees well with the observed value. The calculated maximum is slightly larger than the observed one. (The reverse situation would be bad.)

(Min[x /.
     Solve[touchingSolutions\[CurlyPhi]1[x][[1]] == 0 \[And]
       1/10 < x < 4, x, Reals]] -
   Max[x /.
     Solve[touchingSolutions\[CurlyPhi]1[x][[1]] == 0 \[And] -4 <
        x < -1/10, x, Reals]]) // N[#, 5] &

Output 233

Max[differencesGolden]

Output 234

Finding the envelopes with respect to and does not give a larger result.

\[CurlyPhi]2\[CurlyPhi]3MaxD\[CurlyPhi]2[] = (Solve[{h[x] == 0,
        D[h[x], x] == 0, D[h[x], \[CurlyPhi]2] == 0} /.
       x -> 0, {\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3}] /. _C ->
      0 // Simplify);
touchingSolutions\[CurlyPhi]2[x_] =
  With[{R = {\[Alpha] -> GoldenRatio, \[Beta] -> GoldenRatio^2}},
   h[x] /.

     Select[ \[CurlyPhi]2\[CurlyPhi]3MaxD\[CurlyPhi]2[],
      Im[h[x] /. # /. R /. x -> 5.] == 0 &] /. R];

\[CurlyPhi]2\[CurlyPhi]3MaxD\[CurlyPhi]3[] = (Solve[{h[x] == 0,
        D[h[x], x] == 0, D[h[x], \[CurlyPhi]3] == 0} /.
       x -> 0, {\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3}] /. _C ->
      0 // Simplify);
touchingSolutions\[CurlyPhi]3[x_] =
  With[{R = {\[Alpha] -> GoldenRatio, \[Beta] -> GoldenRatio^2}},
   h[x] /.

     Select[ \[CurlyPhi]2\[CurlyPhi]3MaxD\[CurlyPhi]3[],
      Im[h[x] /. # /. R /. x -> 5.] == 0 &] /. R] ;

(Quiet[Min[x /. Solve[N[#] == 0 \[And] 0 < x < 4, x, Reals]] -
       Max[
        x /. Solve[N[#] == 0 \[And] -4 < x < 0, x,
          Reals]]] & /@ #) & /@ {touchingSolutions\[CurlyPhi]1[x],
  touchingSolutions\[CurlyPhi]2[x], touchingSolutions\[CurlyPhi]3[x]}

Output 235

Here are the three envelope curve families together with near 97,858.4.

With[{x0 = 97858.38930},
 Show[{Plot[fGolden[x0 + x], {x, -3, 3},

    PlotStyle -> Directive[Thickness[0.01], Gray, Opacity[0.4]]],

   Plot[touchingSolutions\[CurlyPhi]1[x], {x, -3, 3},
    PlotStyle -> RGBColor[0.88, 0.61, 0.14]],

   Plot[touchingSolutions\[CurlyPhi]2[x], {x, -3, 3},
    PlotStyle -> RGBColor[0.36, 0.51, 0.71] ],

   Plot[touchingSolutions\[CurlyPhi]3[x], {x, -3, 3},
    PlotStyle -> RGBColor[0.56, 0.69, 0.19] ]},
                PlotRange -> All]]

Output 236

Interestingly, the absolute minimum of the distance between two successive zeros in + + is slightly larger.

rootDistance[{\[CurlyPhi]1_Real, \[CurlyPhi]2_Real, \
\[CurlyPhi]3_Real}] := (Min[Select[#, Positive]] -
     Max[Select[#, Negative]]) &[
  N[x /. Quiet[
     Solve[Cos[x + \[CurlyPhi]1] + Cos[GoldenRatio x + \[CurlyPhi]2] +
          Cos[GoldenRatio^2 x + \[CurlyPhi]3] == 0 \[And] -5 < x < 5,
      x]]]]

If one lets the three phases range over the domains , then one finds a slightly larger maximal distance between zeros.

 With[{pp = 24},
 Monitor[Table[{{\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3},
     rootDistance[
      N@{\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3}]}, {\[CurlyPhi]1,
     0, 2 Pi (1 - 1/pp), 2 Pi/pp},
                   {\[CurlyPhi]2, 0, 2 Pi (1 - 1/pp),
     2 Pi/pp}, {\[CurlyPhi]3, 0, 2 Pi (1 - 1/pp), 2 Pi/pp}];,
  N@{\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3}]]

FindMaximum[
  rootDistance[{\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3}], {{\
\[CurlyPhi]1, 23 Pi/12}, {\[CurlyPhi]2, 7 Pi/6}, {\[CurlyPhi]3,
    Pi/3}}] // Quiet

Output 237

FindMaximum[
  rootDistance[{\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3}], {{\
\[CurlyPhi]1, 23 Pi/12}, {\[CurlyPhi]2, 7 Pi/6}, {\[CurlyPhi]3,
    Pi/3}}] // Quiet

Output 238

This maximum distance is realized when a minimum (maximum) between two zeros barely touches the real axis.

Plot[Cos[x + \[CurlyPhi]1] + Cos[GoldenRatio x + \[CurlyPhi]2] +
   Cos[GoldenRatio^2 x + \[CurlyPhi]3] /. %[[2]], {x, -3, 3}]

Output 239

Calculating the first million zeros of does not yield a value larger than the previously calculated value of 3.334. This suggests that the last curve configuration is not realized along the real axis in .

Here is a list of record maxima slightly below the real axis, found by calculating the first few million extrema of . (This list was found using a version of the above function findZeros for the first derivative and only keeping a list of extremal shallow maxima.)

shallowMaxima =
  {2.4987218706691797180876160929177,
   33.704071215892008970482202830654,
   98.293712744702474592256555931685,
   443.88844400968497878246638591063,
   3388.8528289090563871971140906274,
   12846.898421437481029976313761124,
   55352.647183638537564573877897525,
   124704.59412664060098149321964301,
   166634.14221987979291743435707392,
   304761.83543691954802508678830822,
   457972.87856640025996046175960675,
   776157.81309371886102983541391071,
   1220707.5925697200786171039302735};

The next plot shows how record maxima approach the real axis from below.

ListLogLogPlot[{#, -fGolden[#]} & /@ shallowMaxima,
 AxesLabel -> {x, -Subscript[f, \[Phi]][x]}]

Output 240

Here is a plot of at the least shallow value.

{Plot[fGolden[shallowMaxima[[-1]] + x], {x, -2, 2}],
 Plot[fGolden[shallowMaxima[[-1]] + x], {x, -0.001, 0.001}]}

Output 241

The root difference for this “near” zero is about 3.326058.

Differences[
 N[x /. Solve[
    fGolden[Rationalize[shallowMaxima[[-1]], 0] + x] == 0 \[And] -3 <
      x < 3, x], 15]]

Output 242

Interpolating the data from the last graphic, one gets for the value of the shallowest maxima up to .

The distances between the nearest roots to the right and left of these maxima seem to approach an upper bound below the 3.3340 value from above.

Differences[
     Function[\[CapitalDelta],
       x /. FindRoot[
         Evaluate[fGolden[x] == 0], {x, # + \[CapitalDelta]},
          WorkingPrecision -> 100, PrecisionGoal -> 30]] /@ {-2,
       2}] & /@
                                                      \
                     shallowMaxima // Flatten // N[#, 10] &

Output 243

So is it a special property of that the maximal root distance assuming arbitrary phases is not realized, or is it a more general property of all ? Numerically, experiments with various transcendental values of and suggest that generically the maximal possible root distance obtained from the envelope method agrees with the maximum observed.

Unfortunately, this time the algebraic formulation of the distances between the zeros does not provide the ultimate answer. The following graphic shows the four branches of the factored cαδEquation together with the observed points. No special structure is visible in the curves at the maximal-observed zero distances. The two “strands” of points correspond to the two curves shown in the first plot in this section.

ContourPlot[
  Evaluate[Block[{\[Alpha] = GoldenRatio, \[Beta] = GoldenRatio^2},
    # == 0 & /@ (List @@
       c\[Alpha]\[Delta]EquationFactored)]], {c\[Alpha], -1,
   1}, {\[Delta], 3.25, 3.4}, PlotPoints -> 50,
  Epilog -> {Black, PointSize[0.01],
    Point[{Cos[GoldenRatio #1] , #2 - #1} & @@@
      Select[Partition[zerosGolden, 2,
        1], #[[2]] - #[[1]] > 3.25 &]]},
  GridLines -> {{}, {1.813, 1.044, 1.5, 3.011, 3.334}}] /.
 Tooltip[x_, _] :> x

Output 244

The new root that appears at the maximal root distance is in the algebraic formulation visible as vertical tangents in the curve. Plotting the vertical tangents at the positions of the largest zero distances observed and the observed zero distances shows this clearly.

ContourPlot[
  Evaluate[Block[{\[Alpha] = (1 + Sqrt[5])/
       2, \[Beta] = ((1 + Sqrt[5])/2)^2},
    {firstFactor == 0}]], {c\[Alpha], -1, 1}, {\[Delta], 0, 3.6},
  PlotPoints -> 50,
  Epilog -> {Black, PointSize[0.003],
    Point[{Cos[GoldenRatio #1] , #2 - #1} & @@@
      RandomSample[Partition[zerosGolden, 2, 1], 15000]]},
  GridLines -> {Mean /@
     Split[Sort[
       Cos[GoldenRatio #1] & @@@
        Select[Partition[zerosGolden, 2,
          1], #[[2]] - #[[1]] > 3.32 &]],
      Abs[#1 - #2] < 0.4 &], {} }] /. Tooltip[x_, _] :> x

Output 245

Finding the points of vertical tangents and “lifting” the values of these points to the curve near the observed intersections gives the algebraic prediction for maximal root distances.

verticalTangentsc\[Alpha]\[Delta] =
 FindRoot[Evaluate[
     Block[{\[Alpha] = (1 + Sqrt[5])/
         2, \[Beta] = ((1 + Sqrt[5])/2)^2}, {firstFactor == 0,
       D[firstFactor == 0 /.
           c\[Alpha] -> c\[Alpha][\[Delta]], \[Delta]] /.
         c\[Alpha]'[\[Delta]] -> 0 /.
        c\[Alpha][\[Delta]] -> c\[Alpha]}]],
    {c\[Alpha], #1}, {\[Delta], #2}, WorkingPrecision -> 50,
    PrecisionGoal -> 20, MaxIterations -> 200] & @@@
  {{-0.15,
    1.63}, {0.68, 1.7}}

Output 246

(FindRoot[
     Evaluate[
      Block[{\[Alpha] = (1 + Sqrt[5])/
          2, \[Beta] = ((1 + Sqrt[5])/2)^2},
                        firstFactor == 0 /. #[[1]] ]],
      {\[Delta], 3.3}, WorkingPrecision -> 40, PrecisionGoal -> 20,
     MaxIterations -> 200] //
    N[#, 20] &) & /@ verticalTangentsc\[Alpha]\[Delta]

Output 247

Both zero distances agree; this means the maximal root distance is about 3.32606.

Summary and Features Still to Look At

Through graphical explorations, statistical tests and numerical checks, we have been able to conjecture the answer to the original MathOverflow question: the positions of the peaks in the distribution of zero distances of are two times the positions of the smallest zeros of .

The concrete function exhibits an interesting mixture of generic and nongeneric properties due to the golden ratio factors.

Many other structures within the zeros, extrema and inflection points of the sum of three trigonometric functions could be investigated, as well as the relations between the zeros, extrema and other special points. Here are a few examples.

Special Points mod 2π

For instance, we could visualize the cosine arguments of the zeros, extrema and inflection points. Here are the argument values modulo .

Graphics3D[{PointSize[0.002], RGBColor[0.36, 0.51, 0.71],
   Point[Mod[# {1, GoldenRatio, GoldenRatio^2}, 2 Pi] & /@
     zerosGolden],
   RGBColor[0.88, 0.61, 0.14],
   Point[Mod[# {1, GoldenRatio, GoldenRatio^2}, 2 Pi] & /@
     extremasGolden],
   RGBColor[0.56, 0.69, 0.19],
   Point[Mod[# {1, GoldenRatio, GoldenRatio^2}, 2 Pi] & /@
     inflectionsGolden]},
  PlotRange -> {{0, 2 Pi}, {0, 2 Pi}, {0, 2 Pi}}, Axes -> True] //
 Legended[#,
   LineLegend[{RGBColor[0.36, 0.51, 0.71], RGBColor[0.88, 0.61, 0.14],
      RGBColor[0.56, 0.69, 0.19]}, {"zeros", "extrema",
     "inflection points"}]] &

Output 248

Correctness of the Random Phase Assumption

Or we could look in more detail at how faithful the zero distances are reproduced if one takes the random phases seriously and looks at all functions of the form + +. For a grid of , , values, we calculate the distance between the smallest positive and largest negative zero.

zeroDistance0[
  f_] :=
 (Min[Select[#, Positive]] - Max[Select[#, Negative]]) &[
   Table[x /. FindRoot[f, {x, x0}], {x0, -3, 3, 6/17}]] // Quiet

The resulting distribution of the zero distances looks quantitatively different from the zero distance distributions of . But because the peak positions arise from the envelopes, we see the same peak positions as in .

With[{pp = 40},
 Monitor[
  zeroData =
    Table[zeroDistance0[
      Cos[x + \[CurlyPhi]1] + Cos[GoldenRatio x + \[CurlyPhi]2] +
       Cos[GoldenRatio^2 x + \[CurlyPhi]3]],
     {\[CurlyPhi]3, 0, 2 Pi (1 - 1/pp), 2 Pi/pp}, {\[CurlyPhi]2, 0,
      2 Pi (1 - 1/pp), 2 Pi/pp}, {\[CurlyPhi]1, 0, 2 Pi (1 - 1/pp),
      2 Pi/pp}];,
  N@{\[CurlyPhi]3, \[CurlyPhi]2, \[CurlyPhi]1}]]

Histogram[Flatten[zeroData], 200, GridLines -> {peaksGolden, {}}]

Output 249

Function Value Distribution in the Random Phase Assumption

Or we could model the function value distribution in the general case. The function value distribution for generic , is quite different from the one observed above for . Generically (see the examples in the postlude) it has a characteristic flat middle part in the interval . Assuming again that locally around the function looks like + + with and uniformly distributed and , we can express the probability to see the function value as:

P(y) = \!\(
\*UnderoverscriptBox[\(\[Integral]\), \(0\), \(2  \[Pi]\)]\(
\*UnderoverscriptBox[\(\[Integral]\), \(0\), \(2  \[Pi]\)]\(
\*UnderoverscriptBox[\(\[Integral]\), \(0\), \(2  \[Pi]\)]\*
TemplateBox[{RowBox[{"y", "-",
RowBox[{"(",
RowBox[{
RowBox[{"cos", "(",
SubscriptBox["\[CurlyPhi]", "1"], ")"}], "+",
RowBox[{"cos", "(",
SubscriptBox["\[CurlyPhi]", "2"], ")"}], "+",
RowBox[{"cos", "(",
SubscriptBox["\[CurlyPhi]", "3"], ")"}]}], ")"}]}]},
"DiracDeltaSeq"] \[DifferentialD]
\*SubscriptBox[\(\[CurlyPhi]\), \(1\)] \[DifferentialD]
\*SubscriptBox[\(\[CurlyPhi]\), \(2\)] \[DifferentialD]
\*SubscriptBox[\(\[CurlyPhi]\), \(3\)]\)\)\)

Integrating out the delta function, we obtain the following.

P(y)~\!\(
\*UnderoverscriptBox[\(\[Integral]\), \(0\), \(2  \[Pi]\)]\(
\*UnderoverscriptBox[\(\[Integral]\), \(0\), \(2  \[Pi]\)]
\*FractionBox[\(\[Theta](1 -
\*SuperscriptBox[\((y - cos(
\*SubscriptBox[\(\[CurlyPhi]\), \(1\)]) - cos(
\*SubscriptBox[\(\[CurlyPhi]\), \(2\)]))\), \(2\)])\),
SqrtBox[\(1 -
\*SuperscriptBox[\((y - cos(
\*SubscriptBox[\(\[CurlyPhi]\), \(1\)]) - cos(
\*SubscriptBox[\(\[CurlyPhi]\), \(2\)]))\), \(2\)]\)]] \[DifferentialD]
\*SubscriptBox[\(\[CurlyPhi]\), \(1\)] \[DifferentialD]
\*SubscriptBox[\(\[CurlyPhi]\), \(2\)]\)\)

Carrying out the integral numerically gives exactly the function value distribution shown below.

Pfv[y_] :=
 NIntegrate[
   Piecewise[{{1/(\[Pi] Sqrt[
          1 - (y - Cos[\[CurlyPhi]1] - Cos[\[CurlyPhi]2])^2]),

      1 - (y - Cos[\[CurlyPhi]1] - Cos[\[CurlyPhi]2])^2 >= 0}}],
    {\[CurlyPhi]1, 0, 2 Pi}, {\[CurlyPhi]2, 0, 2 Pi},
   PrecisionGoal -> 3]/(2 Pi)^2

lpPfv = ListPlot[Join[Reverse[{-1, 1} # & /@ #], #] &[
           Monitor[Table[{y, Pfv[y]}, {y, 0, 3, 0.05}], y]],
  Joined -> True, Filling -> Axis]

Output 250

This distribution agrees quite well with the value distribution observed for .

Show[{Histogram[Table[fPi[x], {x, 0, 1000, 0.001}], 100, "PDF"],
  lpPfv}]

Output 251

Mean Zero Spacing in the Random Phase Assumption

The observed value of mean spacing between zeros is ≈1.78.

meanGoldenZeroSpacing = Mean[differencesGolden]

Output 252

Here is a plot showing how the average mean spacing evolves with an increasing number of zeros taken into account. The convergence is approximately proportional to .

{ListPlot[Take[#, 100] &@Transpose[{ Most[zerosGolden],
     MapIndexed[#1/#2[[1]] &, Accumulate[differencesGolden]]}],
  PlotRange -> All, GridLines -> {{}, {meanGoldenZeroSpacing}}],
 Show[{ListLogLogPlot[Transpose[{ Most[zerosGolden],
      Abs[
       MapIndexed[#1/#2[[1]] &, Accumulate[differencesGolden]] -
        meanGoldenZeroSpacing]}]],
   LogLogPlot[5 x^-0.88, {x, 1, 2 10^5}, PlotStyle -> Gray]}]}

Output 253

If one uses the random phase approximation and average over all zero distances with at least one zero in the interval , and using a grid of values for the phases, one gets a value that agrees with the empirically observed spacing to less than 1%.

zeroSpacings[{\[CurlyPhi]1_, \[CurlyPhi]2_, \[CurlyPhi]3_}] :=
 Module[{sols, pos1, pos2},
  sols = Quiet[
    Sort[x /.

      Solve[N[Cos[x + \[CurlyPhi]1] +
           Cos[GoldenRatio x + \[CurlyPhi]2] +
           Cos[GoldenRatio^2 x + \[CurlyPhi]3]] == 0 \[And] -6 < x <
         12, x]]];
  pos1 = Max[Position[sols, _?(# < 0 &)]];
  pos2 = Min[Position[sols, _?(# > 2 Pi &)]];
  Differences[Take[sols, {pos1, pos2}]]]

Module[{pp = 32, sp}, Monitor[
  spacingArray =
    Table[
     sp = zeroSpacings[{\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3}], {\
\[CurlyPhi]1, 0, 2 Pi (1 - 1/pp), 2 Pi/pp},
                             {\[CurlyPhi]2, 0, 2 Pi (1 - 1/pp),
      2 Pi/pp}, {\[CurlyPhi]3, 0, 2 Pi (1 - 1/pp), 2 Pi/pp}];,
  {N@{\[CurlyPhi]1, \[CurlyPhi]2, \[CurlyPhi]3}, sp}]]

Mean[Mean /@ Flatten[spacingArray, 2]]

Output 254

Distribution of Zero-Nearest Extrema

We could also look in more detail at the distribution of the distances to the nearest zero from the extrema.

nfZerosGolden = Nearest[zerosGolden]

Output 255

Histogram[Abs[# - nfZerosGolden[#][[1]]] & /@ extremasGolden, 1000]

Output 256

Distribution of Areas under the Curve

We can look at the distribution of the (unsigned) areas under a curve between successive zeros.

area[{a_, b_}] = Integrate[fGolden[x], {x, a, b}] 

Output 257

Histogram[Abs[area /@ Partition[zerosGolden, 2, 1]], 500]

Output 258

Zero Distance Distribution for Sums of Four Cosines

We should check if the natural generalizations of the conjectures’ peak positions hold. For instance, here is a sum of four cosine terms that uses the plastic constant.

P = N@Root[-1 - # + #^3 &, 1] // ToRadicals;
fPlastic[x_] = Cos[x] + Cos[P x] + Cos[P^2 x] + Cos[P^3 x];

We again calculate 100k zeros. We also calculate the conjectured peak positions and plot both together. One of the predicted peaks turns out to be an edge; the plastic constant is nongeneric for four cosine terms in the same sense as the golden ratio is for three terms.

zerosPlastic = findZeros[fPlastic, 10^5];

peaksPlastic =
  (2 x /.
     FindRoot[{Cos[x], Cos[P x] , Cos[P^2 x],
        Cos[P^3 x]}.#1, {x, #2}]) & @@@
  {{{1, 1, 1, 1},
    1}, {{-1, 1, 1, 1}, 0.8}, {{1, -1, 1, 1}, 0.8}, {{1, 1, -1, 1},
    1}, {{1, 1, 1, -1}, 1.6}}

Output 259

Histogram[Differences[zerosPlastic], 1000, PlotRange -> All,
 GridLines -> {peaksPlastic, {}}]

Output 260

The peak positions again agree perfectly. Plotting the function near the zeros with the peak distances shows similar envelopes as in the three-term case.

With[{aux =
   Sort@Transpose[{Differences[zerosPlastic], Most[zerosPlastic]}]},
 Function[v,
   Show[Plot[fPlastic[# + t], {t, -2, 0 + 5}, PlotRange -> All,
        PlotStyle ->
         Directive[RGBColor[0.36, 0.51, 0.71], Thickness[0.001],
          Opacity[0.3]]] & /@
      Take[Sort[{Abs[#1 - v], #2} & @@@ aux], 100][[All, 2]],
     PlotLabel ->
      Row[{"x", "\[ThinSpace]\[Equal]\[ThinSpace]", NumberForm[v, 3]}],
     PlotRange -> All, Frame -> True, GridLines -> {{0}, {-2, 4}}] /.

        l_Line :>
     Mouseover[l, {Red, Thickness[0.002], Opacity[1], l}]] /@
  peaksPlastic]

Output 261

Visibility Graphs of the Extrema

A plot of the extrema invites us to make visibility graphs from the extrema. Remember that a visibility graph can be constructed from time series–like data by connecting all points that are “visible” to each other. The following graphic is mostly self-explanatory. We consider the vertical lines from the axis as visibility blockers (rather than the actual function graph). The function visibleQ determines if the point p1 is visible from the point p2 (and vice versa), where “visible” means that no line from the axis to any point between p1 and p2 blocks sight.

visibleQ[{p1_, p2_}] := True
visibleQ[{p1_, middle__, p2_}] :=
 (And @@ (C[{p1, #, p2}] & /@ {middle})) /. C :> tf

tf[{{t1_, v1_}, {s_, u_}, {t2_, v2_}}] :=

 With[{U = v1 + (t1 - s)/(t1 - t2) (v2 - v1)},
  If[u < 0, U > 0 || U < u, U > u || U < 0]]

visibilityEdges[pts_] :=
 Monitor[Table[
    If[visibleQ[Take[pts, {i, j}]], i \[UndirectedEdge] j, {}], {i,
     Length[pts] - 1}, {j, i + 1, Length[pts]}],
   {i, j}] // Flatten

extremasGoldenPoints[n_] := {#, fGolden[#]} & /@
  Take[extremasGolden, n]

With[{pts = {#, fGolden[#]} & /@ Take[extremasGolden, 10]},
 Show[{Plot[fGolden[x], {x, 0, 11},
    PlotStyle -> RGBColor[0.36, 0.51, 0.71]],

   ListPlot[pts, Filling -> Axis,
    FillingStyle -> RGBColor[0.88, 0.61, 0.14]],

   Graphics[{RGBColor[0.36, 0.51, 0.71], PointSize[0.02],
     MapIndexed[{Point[{#, fGolden[#]}],
        Black , Text[ #2[[1]], {#, fGolden[#] + 0.2}]} &,
      Take[ extremasGolden, 10]],
     Gray,
     Line[Map[pts[[#]] &,
       List @@@ visibilityEdges[extremasGoldenPoints[10]], {-1}]]}]}]]

Output 262

Here is a larger graph. The maxima with are responsible for the far-distance edges (e.g. 1–179).

visGr = Graph[
  visibilityEdges[{#, fGolden[#]} & /@ Take[extremasGolden, 200]],
  VertexLabels -> "Name", EdgeLabels -> Placed["Name", Tooltip]]

Output 263

The relevant information is contained in the degree distribution of the visibility graph.

ListLogLogPlot[Tally[VertexDegree[visGr]]]

Output 264

Products of Cosines

In addition to more summands, we could also look at products of cosine functions.

f\[CapitalPi][x_] =
 Cos[x]*Product[If[IntegerQ[Sqrt[k]], 1, Cos[Sqrt[k] x]], {k, 2, 6}]

Output 265

Plot[f\[CapitalPi][x], {x, 0, 20}, PlotRange -> All]

Output 266

cosZeros[\[Alpha]_, n_] :=
 Join[Table[(Pi/2 + 2 \[Pi] k)/\[Alpha], {k, 0, n}],
  Table[(-Pi/2 + 2 \[Pi] k)/\[Alpha], {k, n}]]

zeros\[CapitalPi] = With[{n = 10000}, Sort[N@Flatten[{cosZeros[1, n],

       Table[If[IntegerQ[Sqrt[k]], {}, cosZeros[Sqrt[k], n]], {k, 2,
         6}]}]]];

Histogram3D[
 Partition[Select[Differences[zeros\[CapitalPi]], # < 3 &], 2,
  1], 100]

Output 267

Modulo an increase in the degree of the polynomials involved, such products should also be amenable to the algebraic approach used above for the nonsuccessive zero distances.

Sums of Three Sines

If instead of we had used , the distribution of the zero differences would be much less interesting. (For generic , , there is no substantial difference in the zero-distance distribution between , but , is a nongeneric situation).

Calculating the distribution of spacings gives a mostly uniform distribution. The small visible structures on the right are numerical artifacts, and calculating the zeros with a higher precision makes most of them go away.

fGoldenSin[x_] := Sin[x] + Sin[GoldenRatio x] + Sin[GoldenRatio^2 x]
zerosGoldenSin = findZeros[fGoldenSin, 10^5];
Histogram[Differences[zerosGoldenSin], 1000, PlotRange -> All]

Output 268

Visually, the spacing of + + does not seem to depend on .

ContourPlot[
 Cos[x + \[CurlyPhi]] + Cos[Pi x + \[CurlyPhi]] +
   Cos[Pi^2 x + \[CurlyPhi]] == 0,
                           {x, -4 Pi, 4 Pi}, {\[CurlyPhi], 0, 2 Pi},
 PlotPoints -> 120, AspectRatio -> 1/2,
                            GridLines -> {{}, {Pi/2, Pi, 3/2 Pi}}]

Output 269

Let’s end with the example mentioned in the introduction: + + .

fSqrtSin[x_] := Sin[x] + Sin[Sqrt[2] x] + Sin[Sqrt[3] x]
zerosSqrtSin = findZeros[fSqrtSin, 10^5];

The positions of the peaks are described by the formulas conjectured above.

{peak1, peak2, peak3} =
 {2 x /. Solve[-Cos[x] + Cos[Sqrt[2] x] + Cos[Sqrt[3] x] == 0 \[And]
      0 < x < 1, x][[1]],
  2 x /. Solve[+Cos[x] + Cos[Sqrt[2] x] + Cos[Sqrt[3] x] == 0 \[And]
      1 < x < 4, x][[1]],
  2 x /. Solve[+Cos[x] + Cos[Sqrt[2] x] - Cos[Sqrt[3] x] == 0 \[And]
      1 < x < 2, x][[1]]}

Output 270

Histogram[Differences[zerosSqrtSin], 1000, {"Log", "Count"},
 PlotRange -> All, GridLines -> {{peak1, peak2, peak3}, {}}]

Output 271

We note that one of the roots of is very near one of the observed peaks, but it does not describe the peak position.

peak2Alt =
 x /. Solve[
    Sin[x] + Sin[Sqrt[2] x] + Sin[Sqrt[3] x] == 0 \[And] 1 < x < 4,
    x][[1]]

Output 272

Histogram[Select[Differences[zerosSqrtSin], 2.2 < # < 2.35 &], 200,
 PlotRange -> All,

 GridLines -> {{{peak2, Red}, {peak2Alt, Blue}}, {}}]

Output 273

We will end our graphical/numerical investigation of sums of three cosines for today.

The Density of the Zeros

A natural question is the following: can one find a symbolic representation of the density of the zero distances along the algebraic curve derived above? Based on the calculated zeros, we have the following empirical density along the curve.

sdkc\[Alpha]\[Delta] =
 SmoothKernelDistribution[{Cos[GoldenRatio #], #2 - #1} & @@@
                             Take[Partition[zerosGolden, 2, 1], All],
  0.03, PerformanceGoal -> "Quality"]

Output 274

Plot3D[PDF[
  sdkc\[Alpha]\[Delta], {c\[Alpha], \[Delta]}], {c\[Alpha], -1.1,
  1.1}, {\[Delta], 0, 4}, PlotRange -> All, Exclusions -> {},
 PlotPoints -> 120, MeshFunctions -> {#3 &},
 AxesLabel -> {c\[Alpha], \[Delta]}]

Output 275

Quantitative Classification of the Curve Shapes around the Zeros

How can the behavior of a concrete sum of three cosines be classified around their zeros?

For the sums for which an algebraic relation between the three cosine terms exists, the zeros form curves in the plane. Along these curves, the shape of the function around their zeros changes smoothly. And at the self-intersection of the curve, shapes “split.” The next graphic plots the zeros for the above example . Mouse over the points to see shifted versions of near the zero under consideration.

nfc\[Alpha]\[Delta]Brass =
  Nearest[c\[Alpha]\[Delta]ListBrass = ({Cos[\[Phi]Brass #], #2 - #1} \
-> #1) & @@@
     Take[Partition[zerosBrass, 2, 1], All]];

makeZeroPlotBrass[{c\[Alpha]_, \[Delta]_}] :=
 Module[{pts =
    nfc\[Alpha]\[Delta]Brass[{c\[Alpha], \[Delta]}, {All, 0.01}]},
  Plot[Evaluate[(Cos[# + x] + Cos[\[Phi]Brass (# + x)] +
        Cos[\[Phi]Brass^2 (# + x)]) & /@ 

     RandomSample[pts, UpTo[10]]], {x, -4, 4}]]

Graphics[{PointSize[0.002],
   Point[First[#]] & /@
    RandomSample[c\[Alpha]\[Delta]ListBrass, 25000]}, Frame -> True,
  PlotRange -> {{-1, 1}, {0, 2.6}}] /.
 Point[l_] :> (Tooltip[Point[ l], Dynamic[makeZeroPlotBrass[l]]] )

Output 276

For generic , with no algebraic relation between them, the zeros do not form curves in the plane. One could display the zeros in space where they form a surface (see the above example of the function ). Even after projection into the plane. While this gives point clouds, it is still instructive to see the possible curve shapes.

zerosSqrt23 = findZeros[fSqrt, 100000];

nfc\[Alpha]\[Delta]Sqrt23 =
  Nearest[c\[Alpha]\[Delta]ListSqrt23 = ({Cos[
          Sqrt[2] #], #2 - #1} -> #1) & @@@
     Take[Partition[zerosSqrt23, 2, 1], All]];

makeZeroPlotSqrt23[{c\[Alpha]_, \[Delta]_}] :=
 Module[{pts =
    nfc\[Alpha]\[Delta]Sqrt23[{c\[Alpha], \[Delta]}, {All, 0.01}]},
  Plot[Evaluate[
    fSqrt[# + x] & /@ RandomSample[pts, UpTo[10]]], {x, -4, 4}]]

Graphics[{PointSize[0.002],
   Point[First[#]] & /@
    RandomSample[c\[Alpha]\[Delta]ListSqrt23, 25000]}, Frame -> True,
  PlotRange -> {{-1, 1}, {0, 5}}, AspectRatio -> 2] /.
 Point[l_] :> (Tooltip[Point[ l], Dynamic[makeZeroPlotSqrt23[l]]] )

Output 277

Appendix: Modeling the Power Law near the Peaks

Above, based on the observed distribution of the distances between consecutive zeros, a power-law like decay of the distribution was conjectured. In this appendix, we will give some numerical evidence for the power law based on the envelope that defines the smallest zero.

We remind ourselves that we are interested in the smallest zero of + + subject to the constraints , .

Before modeling the power law, let us have a closer look at the data, especially the minima with function values approximately equal to –1 and slope 0 and the following zero. We use the list zerosAndExtremaGolden from above to find such pairs.

minimaAtMinus1 =
  Select[Cases[
    Partition[zerosAndExtremaGolden, 2,
     1], {{_, "extrema"}, {_, "zero"}}],
                 (Abs[fGolden[#[[1, 1]]] + 1] < 0.02 \[And]
      Abs[fGolden'[#[[1, 1]]]] < 0.02) &];

These minima split visibly into two groups.

Show[Plot[Evaluate[fGolden[# + t]], {t, -1, 3},
    PlotStyle ->
     Directive[Thickness[0.001], RGBColor[0.36, 0.51, 0.71]]] & /@
  RandomSample[minimaAtMinus1, 100][[All, 1, 1]], PlotRange -> 1 All]

Output 278

We select the zeros smaller than 0.6.

minimaAtMinus1B =
  Select[minimaAtMinus1, #[[2, 1]] - #[[1, 1]] < 0.6 &];

minimumAndZeroDistances = {#[[1, 1]], #[[2, 1]] - #[[1, 1]]} & /@
   minimaAtMinus1B;

At the minimum , we can locally write + +, which defines three phases , and in = + + .

\[CurlyPhi]1\[CurlyPhi]2\[CurlyPhi]3Triples = ({Mod[-#1, 2 Pi],
       Mod[-GoldenRatio #, 1 2 Pi],
       Mod[-GoldenRatio^2 #1, 2 Pi], #2} & @@@
     minimumAndZeroDistances) /. x_?(# > 5 &) :> (2 Pi - x);

Plotting and shows an approximate linear relationship.

ListPlot[{{#1, #2} & @@@ \[CurlyPhi]1\[CurlyPhi]2\[CurlyPhi]3Triples, \
{#1, #3} & @@@ \[CurlyPhi]1\[CurlyPhi]2\[CurlyPhi]3Triples},

 PlotLegends -> {Subscript["\[CurlyPhi]", 2],
   Subscript["\[CurlyPhi]", 3]},
                     AxesLabel -> {Subscript["\[CurlyPhi]", 1]}]

Output 279

Here are the triples observed in space.

Graphics3D[{RGBColor[0.99, 0.81, 0.495],
  Sphere[#1, 0.0001 #2] & @@@
   Tally[Round[{#1, #2, #3} & @@@ \
\[CurlyPhi]1\[CurlyPhi]2\[CurlyPhi]3Triples, 0.01]]},
 PlotRange -> All, Axes -> True,
 AxesLabel -> {Subscript["\[CurlyPhi]", 1],
   Subscript["\[CurlyPhi]", 2], Subscript["\[CurlyPhi]", 3]}]

Output 280

As a function of the position of the first zero after , where is the smallest root of , we obtain the following graphic. Because near we expect the relative phases to be , and , we display , and .

ListPlot[{{#4, #1} & @@@ \[CurlyPhi]1\[CurlyPhi]2\[CurlyPhi]3Triples, \
{#4, #2 -
      Pi} & @@@ \[CurlyPhi]1\[CurlyPhi]2\[CurlyPhi]3Triples, {#4, #3 -
       Pi} & @@@ \[CurlyPhi]1\[CurlyPhi]2\[CurlyPhi]3Triples},

 PlotLegends -> {Subscript["\[CurlyPhi]", 1],
   Subscript["\[CurlyPhi]", 2], Subscript["\[CurlyPhi]", 3]},
                      AxesLabel -> {Style["z", Italic]}]

Output 281

The distribution of the observed phases near the minima with function value –1 are all approximately uniform. (We will use this fact below to model the power law decay.)

Histogram[#1, 50, PlotLabel -> Subscript["\[CurlyPhi]", #2]] & @@@
 Transpose[{Take[
    Transpose[\[CurlyPhi]1\[CurlyPhi]2\[CurlyPhi]3Triples], 3], {1, 2,
     3}}]

Output 282

Now let us compare this observed phase distribution with all mathematically possible solutions from the envelope conditions.

\[CurlyPhi]1\[CurlyPhi]2Of\[CurlyPhi]3Solution =
  Solve[{Cos[\[CurlyPhi]1] + Cos[\[CurlyPhi]2] +
      Cos[\[CurlyPhi]3] == -1,
                                         -Sin[\[CurlyPhi]1] -
      GoldenRatio Sin[\[CurlyPhi]2] -
      GoldenRatio^2 Sin[\[CurlyPhi]3] ==
     0}, {\[CurlyPhi]1, \[CurlyPhi]2}];

\[CurlyPhi]1\[CurlyPhi]2Of\[CurlyPhi]3CF =
 Compile[{{\[CurlyPhi]3, _Complex}},
  Evaluate[{\[CurlyPhi]1, \[CurlyPhi]2} /. \[CurlyPhi]1\[CurlyPhi]2Of\
\[CurlyPhi]3Solution /.
     ConditionalExpression[\[Zeta]_, _] :> \[Zeta] /. _C :> 0]]

Output 283

\[CurlyPhi]1\[CurlyPhi]2Of\[CurlyPhi]3[\[CurlyPhi]3_Real] :=
 Append[#, \[CurlyPhi]3] & /@
  Cases[Chop[\[CurlyPhi]1\[CurlyPhi]2Of\[CurlyPhi]3CF[\[CurlyPhi]3]], \
{_Real, _Real}]

For a given value of , we either have no, two or four solutions for . The following interactive demonstration allows us to explore the solutions as a function of . We see the two types of solutions represented by the list minimaAtMinus1 above.

Manipulate[
 With[{phases = \
\[CurlyPhi]1\[CurlyPhi]2Of\[CurlyPhi]3[\[CurlyPhi]3]},
   Plot[Evaluate[(Cos[x + #[[1]]] + Cos[GoldenRatio x + #[[2]]] +
         Cos[GoldenRatio^2 x + #[[3]]]) & /@ phases], {x, -1, 3},
    PlotLegends ->
     Placed[({Subscript["\[CurlyPhi]", 1],
           Subscript["\[CurlyPhi]", 2], Subscript["\[CurlyPhi]", 3]} ==
          NumberForm[#, 3] & /@ phases), Below]]] // Quiet,
 {{\[CurlyPhi]3, Pi + 0.2, Subscript["\[CurlyPhi]", 3]}, 0, 2 Pi,
  Appearance -> "Labeled"},
 TrackedSymbols :> True]

Output 284

Here are the possible phases that are compatible with the envelope conditions as a function of , the position of the first zero.

\[CurlyPhi]1\[CurlyPhi]2\[CurlyPhi]3zList =
  Table[{#,
      x /. Quiet[
        Solve[gGolden[x, #] == 0 \[And] 0.4 < x < 0.6,
         x]]} & /@ \
\[CurlyPhi]1\[CurlyPhi]2Of\[CurlyPhi]3[\[CurlyPhi]3], {\[CurlyPhi]3,
    Pi - 0.5, Pi + 0.5, 1/1001}];

\[Pi]ize[x_] := If[x < -Pi/2, 2 Pi + x, x];
\[CurlyPhi]1\[CurlyPhi]2\[CurlyPhi]3zListB = {\[Pi]ize /@ #1, #2} & @@@
   Cases[Flatten[\[CurlyPhi]1\[CurlyPhi]2\[CurlyPhi]3zList,
     1], {_, {_Real}}];

ListPlot[{{#2[[1]], #1[[1]] -
      0} & @@@ \[CurlyPhi]1\[CurlyPhi]2\[CurlyPhi]3zListB,
                    {#2[[1]], #1[[2]] -
      Pi} & @@@ \[CurlyPhi]1\[Curl


Download this post as a Wolfram Notebook or as a Computable Document Format (CDF) file. New to CDF? Get your copy for free with this one-time download.

]]> 5 Joanna Crown <![CDATA[Five Ways to Make Your Technical Presentations Awesome]]> http://blog.internal.wolfram.com/?p=43175 2018-04-19T17:02:15Z 2018-04-19T17:00:39Z #post-43175 h2 { margin: 2px 0 0 0; font-size: 22px; padding: 12px 0 6px; display: block; float: none; } #post-43175 h3 { color: #333; margin: 5px 0 10px; font-size: 18px; } #post-43175 blockquote { padding: 10px 25px; font-family: Georgia; font-style: italic; font-size: 130%; line-height: 1.4; color: #e26a0f; margin: 0 0 8px; border-top: 1px solid #c3c3c3; border-bottom: 1px solid #c3c3c3; } #post-43175 blockquote p { margin: 0; padding: 0; }

“Tell me and I forget. Teach me and I remember. Involve me and I learn.” — Benjamin Franklin

I can count on one hand the best presentations I have ever experienced, the most recent being my university dynamics lecturer bringing out his electric guitar at the end of term to demonstrate sound waves; a pharmaceutical CEO giving an impassioned after-dinner oration about how his love of music influenced his business decisions; and last but not least, my award-winning attempt at explaining quantum entanglement using a marble run and a cardboard box (I won a bottle of wine).

It’s perhaps equally easy to recall all the worst presentations I’ve experienced as well—for example, too many PowerPoint presentations crammed full of more bullet points than a shooting target; infinitesimally small text that only Superman’s telescopic vision could handle; presenters intent on slowly reading every word that they’ve squeezed onto a screen and thoroughly missing the point of a presentation: that of succinctly communicating interesting ideas to an audience.

It is no secret that when it comes to presentations, less is definitely more. A picture may be worth a thousand words, a meme worth a thousand likes, but as much as a technical presenter wants to fill a presentation full of cute pictures, the key point is to communicate their results, findings, explorations, experiments and data in a clear, succinct and beautiful way.

As someone who uses Wolfram Notebooks for everything from a notepad to a word processing document, a coding scratchpad and as a complete computational narrative, I am so excited that it is now possible to present live, interactive technical presentations directly from notebooks.

So What Is Presenter Tools?

As announced this week, Wolfram Presenter Tools is the first responsive technical presentation platform incorporating dynamic interactivity and live computation into the environment.

Presenter Tools features 

What Does This Mean?

You can now change your parameters on the fly, use interactive manipulates to cleanly demonstrate complex ideas, pull real-time data from live feeds and use multimedia to include your audience in your presentation.

This comes with everything you’d expect from a presentation environment: live-time presenter notes and navigation controls, a comprehensive quick-editing toolbar, the ability to position your text, images and interactives within your slides and auto-resizing to any resolution or screen size.

But the Best Part…?

Creating presentations can be automatic from your existing notebooks. You can use the work you’ve already done, the notebooks you’ve already written, the results you’ve already generated, the functions and manipulates already in your reports, and present them immediately. This is the prime-time, go-to technical presenting tool. Take your technical work and present it now.

So How Does This Help Me?

Could Presenter Tools be the electric guitar of your presentation? Of course it can. Let’s revisit Benjamin Franklin:

  • You can tell someone what a static chart of your data means—and they’ll forget.
  • You can teach someone how your data produced the results you concluded—and they may remember.
  • Or you can involve someone in your presentation and let them directly interact with your results.

Therein lies the key to unforgettable, impressive and interactive presentations.

Here Are My Go-To Top Five Presentation Tips…

1) Keep it simple

“If you can’t explain it simply, you don’t understand it well enough.” — Feynstein

Whether it was Albert Einstein or Richard Feynman who said it (there is a fair amount of debate), the sentiment holds true. If you are the expert, it’s very likely that your audience doesn’t have the same grasp of the material that you do. If you’ve been working on your findings for days, weeks, months, bring people on that journey with you and keep it light.

Using cell hierarchies, keep your titles and subsections distinct. Distill your thoughts into clear sections and hide the bits that go on a tangent!

2) Keep it short

“Make sure you have finished speaking before your audience has finished listening.” — Dorothy Sarnoff

We’ve all been on the other side of those presentations that go on and on. Don’t be that person. Make your case clearly and quickly.

Use direct, interactive plots to get your results across, no image duplication required. Demonstrate to them exactly how your data behaves—don’t snapshot it.

3) Keep it on point

“If you can’t state your position in eight words, you don’t have a position.” — Seth Godin

Decide what you want to get across to your audience. What are your top three points? What is your takeaway message?

Going to forget something important? Keep presenter notes on the side to keep you on track.

4) Practice

“All the great speakers were bad speakers at first.” — Ralph Waldo Emerson

The more you’re prepared, the calmer you’ll be and the better you’ll communicate your points. Choose your best examples and talk them through. Find out what works and what doesn’t: iterate, evaluate.

With livecoding, you can make up coding examples on the go. Or if you’d like things to be “safer,” keep tried and trusted examples in your presenter notes palette on the side to insert and evaluate during your talk. It’ll appear spontaneous, but you have the dependable certainty that it’ll run.

5) Be you!

“I didn’t lie. I was writing fiction in my mouth.” — Homer Simpson

If you want to make your mark, be distinctive. If you want to be the person who has a picture of a sheep on each slide, do it. If you want rainbow colors, do it. When you feel comfortable and confident presenting, you’ll be a better presenter. Let your voice come across and people will remember you and your work.

With customizable themes, Presenter Tools allows you to choose the fonts and colors that you want to use, and automatically updates cell styles accordingly. Add images to your heart’s content, and make your presentations your own!

]]>
3
Cat Frazier <![CDATA[Announcing Wolfram Presenter Tools]]> http://blog.internal.wolfram.com/?p=43173 2018-04-17T16:12:37Z 2018-04-17T14:01:32Z Introducing the Ultimate Technical Presentation Environment with Live Interactivity

We are delighted to announce that Wolfram’s latest comprehensive notebook technology extension is here. Released with Version 11.3 of Wolfram desktop products, Wolfram Presenter Tools is the world’s first fully computational presentation environment, seamlessly extending the notebook workflow for easy creation and delivery of dynamic presentations and slide shows, automatically scaled to fit any screen size. Our unique presentation features include rapid stylesheet updating and automatic slide breaking based on cell style.

Working from your existing notebooks or using templated guides, it is now possible to easily create impressive, interactive and beautiful presentations—harnessing the power of the Wolfram Language with interactive manipulates, real-time data and livecoding. Together with publication-quality technical typesetting, coherent design templates and configurable presentation controls, Presenter Tools’ range of customizable themes makes presentations eye-catching and unique to you.

Presenter Tools features 

What Is Involved?

One of Presenter Tools’ key elements is the new quick-editing toolbar, providing authoring style options, slide show controls and fine layout-adjustment tools in one convenient interface. Our new screen environments, for viewing the same notebook in a variety of different presentation modes, include scrolling edit mode, slide edit mode and both slide and continuous presentation environments. In fact, your presentations will now take advantage of all the superior features of the computational notebook. Easily see and manage your manual and automatic slide breaks, and use the hierarchical cell structure of Wolfram Notebooks to arrange your text, output, images and code in an easily digestible format.

Another important feature of Presenter Tools customizes cell styles throughout an entire presentation to make stylesheet changes easy. Update colors, fonts, alignment, spacing and sizing for any given cell style right from the toolbar.

We have added user-friendly controls to make your presentation experience as smooth as possible. From configurable keyboard commands for slide navigation to writing side notes and auto-inserting code cells, we have designed the full toolkit for keeping a computable presentation on point. Remind yourself of your favorite anecdotes and metapoints, or keep ready-to-use livecoding examples for impressive and reliable demonstrations.

Explore these key features and learn more about Wolfram Presenter Tools »

]]>
7
Stephen Wolfram http:// <![CDATA[Launching the Wolfram Challenges Site]]> http://blog.internal.wolfram.com/?p=43986 2018-05-09T20:38:00Z 2018-04-12T16:01:07Z Wolfram Challenges

The more one does computational thinking, the better one gets at it. And today we’re launching the Wolfram Challenges site to give everyone a source of bite-sized computational thinking challenges based on the Wolfram Language. Use them to learn. Use them to stay sharp. Use them to prove how great you are.

The Challenges typically have the form: “Write a function to do X”. But because we’re using the Wolfram Language—with all its built-in computational intelligence—it’s easy to make the X be remarkably sophisticated.

The site has a range of levels of Challenges. Some are good for beginners, while others will require serious effort even for experienced programmers and computational thinkers. Typically each Challenge has at least some known solution that’s at most a few lines of Wolfram Language code. But what are those lines of code?

There may be many different approaches to a particular Challenge, leading to very different kinds of code. Sometimes the code will be smaller, sometimes it will run faster, and so on. And for each Challenge, the site maintains a leaderboard that shows who’s got the smallest, the fastest, etc. solution so far.

What does it take to be able to tackle Challenges on the site? If you’ve read my An Elementary Introduction to the Wolfram Language, for example, you should be well prepared—maybe with some additional help on occasion from the main Wolfram Language documentation. But even if you’re more of a beginner, you should still be able to do simpler Challenges, perhaps looking at parts of my book when you need to. (If you’re an experienced programmer, a good way to jump-start yourself is to look at the Fast Introduction for Programmers.)

How It Works

There are lots of different kinds of Challenges on the site. Each Challenge is tagged with topic areas. And on the front page there are a number of “tracks” that you can use as guides to sequences of related Challenges. Here are the current Challenges in the Real-World Data track:

Real-World Data Challenges

Click one you want to try—and you’ll get a webpage that explains the Challenge:

Antipode above or below Sea Level Challenge

Now you can choose either to download the Challenge notebook to the desktop, or just open it directly in your web browser in the Wolfram Cloud. (It’s free to use the Wolfram Cloud for this, though you’ll have to have a login—otherwise the system won’t be able to give you credit for the Challenges you’ve solved.)

Here’s the cloud version of this particular notebook:

Challenge cloud notebook

You can build up your solution in the Scratch Area, and try it out there. Then when you’re ready, put your code where it says “Enter your code here”. Then press Submit.

What Submit does is to send your solution to the Wolfram Cloud—where it’ll be tested to see if it’s correct. If it’s not correct, you’ll get something like this:

Error code

But if it’s correct, you’ll get this, and you’ll be able to go to the leaderboard and see how your solution compared to other people’s. You can submit the same Challenge as many times as you want. (By the way, you can pick your name and icon for the leaderboard from the Profile tab.)

Challenges leaderboard

The Range of Challenges

The range of Challenges on the site is broad both in terms of difficulty level and topic. (And, by the way, we’re planning to progressively grow the site, not least through material from outside contributors.)

Here’s an example of a simple Challenge, that for example I can personally solve in a few seconds:

Butterflied Strings Challenge

Here’s a significantly more complicated Challenge, that took me a solid 15 minutes to solve at all well:

Babbage Squares Challenge

Some of the Challenges are in a sense “pure algorithm challenges” that don’t depend on any outside data:

Maximal Contiguous Sum Challenge

Some of the Challenges are “real-world”, and make use of the Wolfram Knowledgebase:

Country Chains Challenge

And some of the Challenges are “math-y”, and make use of the math capabilities of the Wolfram Language:

Factorial Zeros Challenge

Count the Number of Squares Challenge

Pre-launch Experience

We’ve been planning to launch a site like Wolfram Challenges for years, but it’s only now, with the current state of the Wolfram Cloud, that we’ve been able to set it up as we have today—so that anyone can just open a web browser and start solving Challenges.

Still, we’ve had unannounced preliminary versions for about three years now—complete with a steadily growing number of Challenges. And in fact, a total of 270 people have discovered the preliminary version—and produced in all no less than 11,400 solutions. Some people have solved the same Challenge many times, coming up with progressively shorter or progressively faster solutions. Others have moved on to different Challenges.

It’s interesting to see how diverse the solutions to even a single Challenge can be. Here are word clouds of the functions used in solutions to three different Challenges:

Functions used in Wolfram Challenges

And when it comes to lengths of solutions (here in characters of code), there can be quite a variation for a particular Challenge:

Length of solutions in Wolfram Challenges

Here’s the distribution of solution lengths for all solutions submitted during the pre-launch period, for all Challenges:

Solution lengths for submitted solutions

It’s not clear what kind of distribution this is (though it seems close to lognormal). But what’s really nice is how concentrated it is on solutions that aren’t much more than a line long. (81% of them would even fit in a 280-character tweet!)

And in fact what we’re seeing can be viewed as a great tribute to the Wolfram Language. In any other programming language most Challenges—if one could do them at all—would take pages of code. But in the Wolfram Language even sophisticated Challenges can often be solved with just tweet-length amounts of code.

Why is this? Well, basically it’s because the Wolfram Language is a different kind of language: it’s a knowledge-based language where lots of knowledge about computation and other things is built right into the language (thanks to 30+ years of hard work on our part).

But then are the Challenges still “real”? Of course! It’s just that the Wolfram Language lets one operate at a higher level. One doesn’t have to worry about writing out the low-level mechanics of how even sophisticated operations get implemented—one can just concentrate on the pure high-level computational thinking of how to get the Challenge done.

Under the Hood

OK, so what have been some of the challenges in setting up the Wolfram Challenges site? Probably the most important is how to check whether a particular solution is correct. After all, we’re not just asking to compute some single result (say, 42) that we can readily compare with. We’re asking to create a function that can take a perhaps infinite set of possible arguments, and in each case give the correct result.

So how can we know if the function is correct? In some simple cases, we can actually see if the code of the function can be transformed in a meaning-preserving way into code that we already know is correct. But most of the time—like in most practical software quality assurance—the best thing to do is just to try test cases. Some will be deterministically chosen—say based on checking simple or corner cases. Others can be probabilistically generated.

But in the end, if we find that the function isn’t correct, we want to give the user a simple case that demonstrates this. Often in practice we may first see failure in some fairly complicated case—but then the system tries to simplify the failure as much as possible.

OK, so another issue is: how does one tell whether a particular value of a function is correct? If the value is just something like an integer (say, 343) or a string (say, “hi”), then it’s easy. But what if it’s an approximate number (say, 3.141592…)? Well, then we have to start worrying about numerical precision. And what if it’s a mathematical expression (say, 1 + 1/x)? What transformations should we allow on the expression?

There are many other cases too. If it’s a network, we’ll probably want to say it’s correct if it’s isomorphic to what we expect (i.e. the same up to relabeling nodes). If it’s a graphic, we’ll probably want to say it’s correct if it visually looks the same as we expected, or at least is close enough. And if we’re dealing with real-world data, then we have to make sure to recompute our expected result, to take account of data in our knowledgebase that’s changed because of changes out there in the real world.

Alright, so let’s say we’ve concluded that a particular function is correct. Well now, to fill in the leaderboard, we have to make some measurements on it. First, how long is the code?

We can just format the code in InputForm, then count characters. That gives us one measure. One can also apply ByteCount to just count bytes in the definition of the function. Or we can apply LeafCount, to count the number of leaves in the expression tree for the definition. The leaderboard separately tracks the values for all these measures of “code size”.

OK, so how about the speed of the code? Well, that’s a bit tricky. First because speed isn’t something abstract like “total number of operations on a Turing machine”—it’s actual speed running a computer. And so it has be normalized for the speed of the computer hardware. Then it has to somehow discard idiosyncrasies (say associated with caching) seen in particular test runs, as achieved by RepeatedTiming. Oh, and even more basically, it has to decide which instances of the function to test, and how to average them. (And it has to make sure that it won’t waste too much time chasing an incredibly slow solution.)

Well, to actually do all these things, one has to make a whole sequence of specific decisions. And in the end what we’ve done is to package everything up into a single “speed score” that we report in the leaderboard.

A final metric in the leaderboard is “memory efficiency”. Like “speed score”, this is derived in a somewhat complicated way from actual test runs of the function. But the point is that within narrow margins, the results should be repeatable between identical solutions. (And, yes, the speed and memory leaderboards might change when they’re run in a new version of the Wolfram Language, with different optimizations.)

Backstory

We first started testing what’s now the Wolfram Challenges site at the Wolfram Summer School in 2016—and it was rapidly clear that many people found the kinds of Challenges we’d developed quite engaging. At first we weren’t sure how long—and perhaps whimsical—to make the Challenges. We experimented with having whole “stories” in each Challenge (like some math competitions and things like Project Euler do). But pretty soon we decided to restrict Challenges to be fairly short to state—albeit sometimes giving them slightly whimsical names.

We tested our Challenges again at the 2017 Wolfram Summer School, as well as at the Wolfram High School Summer Camp—and we discovered that the Challenges were addictive enough that some people systematically went through trying to solve all of them.

We were initially not sure what forms of Challenges to allow. But after a while we made the choice to (at least initially) concentrate on “write a function to do X”, rather than, for example, just “compute X”. Our basic reason was that we wanted the solutions to the Challenges to be more open-ended.

If the challenge is “compute X”, then there’s typically just one final answer, and once you have it, you have it. But with “write a function to do X”, there’s always a different function to write—that might be faster, smaller, or just different. At a practical level, with “compute X” it’s easier to “spoil the fun” by having answers posted on the web. With “write a function”, yes, there could be one version of code for a function posted somewhere, but there’ll always be other versions to write—and if you always submit versions that have been seen before it’ll soon be pretty clear you have to have just copied them from somewhere.

As it turns out, we’ve actually had quite a bit of experience with the “compute X” format. Because in my book An Elementary Introduction to the Wolfram Language all 655 exercises are basically of the form “write code to compute X”. And in the online version of the book, all these exercises are automatically graded.

Automatic grading

Now, if we were just doing “cheap” automatic grading, we’d simply look to see if the code produces the correct result when it runs. But that doesn’t actually check the code. After all, if the answer was supposed to be 42, someone could just give 42 (or maybe 41 + 1) as the “code”.

Our actual automatic grading system is much more sophisticated. It certainly looks at what comes out when the code runs (being careful not to blindly evaluate Quit in a piece of code—and taking account of things like random numbers or graphics or numerical precision). But the real meat of the system is the analysis of the code itself, and the things that happen when it runs.

Because the Wolfram Language is symbolic, “code” is the same kind of thing as “data”. And the automatic grading system makes extensive use of this—not least in applying sequences of symbolic code transformations to determine whether a particular piece of code that’s been entered is equivalent to one that’s known to represent an appropriate solution. (The system has ways to handle “completely novel” code structures too.)

Code equivalence is a difficult (in fact, in general, undecidable) problem. A slightly easier problem (though still in general undecidable) is equivalence of mathematical expressions. And a place where we’ve used this kind of equivalence extensively is in our Wolfram Problem Generator:

Of course, exactly what equivalence we want to allow may depend on the kind of problem we’re generating. Usually we’ll want 1 + x and x + 1 to be considered equivalent. But (1 + x)/x might or might not want to be considered equivalent to 1 + 1/x. It’s not easy to get these things right (and many online grading systems do horribly at it). But by using some of the sophisticated math and symbolic transformation capabilities available in the Wolfram Language, we’ve managed to make this work well in Wolfram Problem Generator.

Contribute New Challenges!

The Wolfram Challenges site as it exists today is only the beginning. We intend it to grow. And the best way for it to grow—like our long-running Wolfram Demonstrations Project—is for people to contribute great new Challenges for us to include.

At the bottom of the Wolfram Challenges home page you can download the Challenges Authoring Notebook:

Challenges Authoring Notebook

Fill this out, press “Submit Challenge”—and off this will go to us for review.

Beyond Challenges

I’m not surprised that Wolfram Challenges seem to appeal to people who like solving math puzzles, crosswords, brain teasers, sudoku and the like. I’m also not surprised that they appeal to people who like gaming and coding competitions. But personally—for better or worse—I don’t happen to fit into any of these categories. And in fact when we were first considering creating Wolfram Challenges I said “yes, lots of people will like it, but I won’t be one of them”.

Well, I have to say I was wrong about myself. Because actually I really like doing these Challenges—and I’m finding I have to avoid getting started on them because I’ll just keep doing them (and, yes, I’m a finisher, so there’s a risk I could just keep going until I’ve done them all, which would be a very serious investment of time).

So what’s different about these Challenges? I think the answer for me is that they feel much more real. Yes, they’ve been made up to be Challenges. But the kind of thinking that’s needed to solve them is essentially just the same as the kind of thinking I end up doing all the time in “real settings”. So when I work on these Challenges, I don’t feel like I’m “just doing something recreational”; I feel like I’m honing my skills for real things.

Now I readily recognize that not everyone’s motivation structure is the same—and many people will like doing these Challenges as true recreations. But I think it’s great that Challenges can also help build real skills. And of course, if one sees that someone has done lots of these Challenges, it shows that they have some real skills. (And, yes, we’re starting to use Challenges as a way to assess applicants, say, for our summer programs.)

It’s worth saying there are some other nice “potentially recreational” uses of the Wolfram Language too.

One example is competitive livecoding. The Wolfram Language is basically unique in being a language in which interesting programs can be written fast enough that it’s fun to watch. Over the years, I’ve done large amounts of (non-competitive) livecoding—both in person and livestreamed. But in the past couple of years we’ve been developing the notion of competitive livecoding as a kind of new sport.

Wolfram Technology Conference

We’ve done some trial runs at our Wolfram Technology Conference—and we’re working towards having robust rules and procedures. In what we’ve done so far, the typical challenges have been of the “compute X” form—and people have taken between a few seconds and perhaps ten minutes to complete them. We’ve used what’s now our Wolfram Chat functionality to distribute Challenges and let contestants submit solutions. And we’ve used automated testing methods—together with human “refereeing”—to judge the competitions.

A different kind of recreational application of the Wolfram Language is our Tweet-a-Program service, released in 2014. The idea here is to write Wolfram Language programs that are short enough to fit in a tweet (and when we launched Tweet-a-Program that meant just 128 characters)—and to make them produce output that is as interesting as possible:

Tweet-a-Program output

We’ve also had a live analog of this at our Wolfram Technology Conference for some time: our annual One-Liner Competition. And I have to say that even though I (presumably) know the Wolfram Language well, I’m always amazed at what people actually manage to do with just a single line of Wolfram Language code.

At our most recent Wolfram Technology Conference, in recognition of our advances in machine learning, we decided to also do a “Machine-Learning Art Competition”—to make the most interesting possible restyled “Wolfie”:

Wolfie submissions

In the future, we’re planning to do machine learning challenges as part of Wolfram Challenges too. In fact, there are several categories of Challenges we expect to add. We’ve already got Challenges that make use of the Wolfram Knowledgebase, and the built-in data it contains. But we’re also planning to add Challenges that use external data from the Wolfram Data Repository. And we want to add Challenges that involve creating things like neural networks.

There’s a new issue that arises here—and that’s actually associated with a large category of possible Challenges. Because with most uses of things like neural networks, one no longer expects to produce a function that definitively “gets the right answer”. Instead, one just wants a function that does the best possible job on a particular task.

There are plenty of examples of Challenges one can imagine that involve finding “the lowest-cost solution”, or the “best fit”. And it’s a similar setup with typical machine learning tasks: find a function (say based on a neural network) that performs best on classifying a certain test set, etc.

And, yes, the basic structure of Wolfram Challenges is well set up to handle a situation like this. It’s just that instead of it definitively telling you that you’ve got a correct solution for a particular Challenge, it’ll just tell you how your solution ranks relative to others on the leaderboard.

The Challenges in the Wolfram Challenges site always have very well-defined end goals. But one of the great things about the Wolfram Language is how easy it is to use it to explore and create in an open-ended way. But as a kind of analog of Challenges one can always give seeds for this. One example is the Go Further sections of the Explorations in Wolfram Programming Lab. And other examples are the many kinds of project suggestions we make for things like our summer programs.

What is the right output for an open-ended exploration? I think a good answer in many cases is a computational essay, written in a Wolfram Notebook, and “telling a story” with a mixture of ordinary text and Wolfram Language code. Of course, unlike Challenges, where one’s doing something that’s intended to be checked and analyzed by machine, computational essays are fundamentally about communicating with humans—and don’t have right or wrong “answers”.

The Path Forward

One of my overarching goals in creating the Wolfram Language has been to bring computational knowledge and computational thinking to as many people as possible. And the launch of the Wolfram Challenges site is the latest step in the long journey of doing this.

It’s a great way to engage with programming and computational thinking. And it’s set up to always let you know how you’re getting on. Did you solve that Challenge? How did you do relative to other people who’ve also solved the Challenge?

I’m looking forward to seeing just how small and efficient people can make the solutions to these Challenges. (And, yes, large numbers of equivalent solutions provide great raw material for doing machine learning on program transformations and optimization.)

Who will be the leaders on the leaderboards of Wolfram Challenges? I think it’ll be a wide range of people—with different backgrounds and education. Some will be young; some will be old. Some will be from the most tech-rich parts of the world; some, I hope, will be from tech-poor areas. Some will already be energetic contributors to the Wolfram Language community; others, I hope, will come to the Wolfram Language through Challenges—and perhaps even be “discovered” as talented programmers and computational thinkers this way.

But most of all, I hope lots of people get lots of enjoyment and fulfillment out of Wolfram Challenges—and get a chance to experience that thrill that comes with figuring out a particularly clever and powerful solution that you can then see run on your computer.

]]>
0
Sandra Sarac <![CDATA[European Wolfram Technology Conference 2018]]> http://blog.internal.wolfram.com/?p=43179 2018-04-12T14:03:04Z 2018-04-12T13:43:44Z

This year, we’ll be in Oxford for the European Wolfram Technology Conference. Join us June 14–15 for two days of expert talks showcasing the latest releases in Wolfram technologies, in-depth explorations of key features and practical use cases for integrating Wolfram technologies in your ecosystem.

Catering to both new and existing users, the conference provides an overview of the entire Wolfram technology stack while also exploring some of our new products and features; you will also learn about the field of multiparadigm data science, the new approach of using modern analytical techniques, automation and human-data interfaces to move the bar on answers.

Session highlights will include keynotes from Conrad Wolfram, Tom Wickham-Jones and a range of Wolfram experts and users from around the world, giving you the inside track on the future direction of computational technology.

Key topics will include:

  • Machine learning and neural networks
  • Enterprise computation strategies
  • Deployment in the Wolfram Cloud
  • Signal and image processing

With a conference dinner rounding out the first day, this is a great opportunity for attendees to not only meet those who develop Wolfram technologies but also connect with our thriving community of like-minded users.

To join us in Oxford, register now.

]]>
1
Patrik Ekenberg <![CDATA[Unleash Your Models with SystemModeler 5.1]]> http://blog.internal.wolfram.com/?p=41690 2018-04-12T16:01:02Z 2018-03-21T17:00:23Z We are excited to announce the latest installment in the Wolfram SystemModeler series, Version 5.1, where our primary focus has been on pushing the scope of use for models of systems beyond the initial stages of development.

Since 2012, SystemModeler has been used in a wide variety of fields with an even larger number of goals—such as optimizing the fuel consumption of a car, finding the optimal dosage of a drug for liver disease and maximizing the lifetime of a battery system. The Version 5.1 update expands SystemModeler beyond its previous usage horizons to include a whole host of options, such as:

  • Exporting models in a form that includes a full simulation engine, which makes them usable in a wide variety of tools
  • Providing the right interface for your models so that they are easy for others to explore and analyze
  • Sharing models with millions of users with the simulation core now included in the Wolfram Language

Wolfram SystemModeler 5.1

Standardized Simulators, Usable Anywhere

With SystemModeler 5, there were two standardized ways of exporting a SystemModeler model: either as Modelica code or using the Functional Mock-up Interface (FMI) for model exchange. In SystemModeler 5.1, we are adding a new, powerful export option, with FMI for co-simulation. While the previous two standards required the importing software to have its own simulation engine, with co-simulation, you are instead exporting a standalone simulator that has the SystemModeler simulation engine built in.

The FMI standard is supported by a wide variety of different tools. This opens up many new use cases, such as:

  • An engineer integrating the model with hardware, for hardware-in-the-loop simulation
  • A game designer using the exported model to drive behaviors in a game engine
  • A project manager using the model as an advanced simulator in e.g. Excel to calculate the return of investment for a power plant

SystemModeler simulate

See how the integration with Excel works in the following video:

Ready Your Models for Exploration, Analysis and Deployment

Whether your models are being simulated by yourself or by others—or whether you are building models for exploration, analysis or deployment—the ability to change or even completely switch configurations in your models is important. It is what allows you to do things like tweak shape parameters to perform optimal cam design, explore fundamental processes in the human body or use different control schemes in a connected system. However, all these possibilities for arranging parameters, variables and configurations can feel daunting.

SystemModeler explore

That is why, with SystemModeler 5.1, we are making it easier to add, document and organize parameters. This makes it possible to quickly set up models that can easily be used, explored and configured by others.

Find out more about the new model development improvements in the following video:

Share Models with Millions of Wolfram Language Users

With SystemModeler 5.1 and Wolfram Language 11.3, the full simulation core of SystemModeler is available to all Wolfram Language users. The system modeling functionality in the Wolfram Language makes it very easy to accomplish tasks such as:

SystemModeler is a great tool to create models of any complexity, and the Wolfram Language is equally great for exploration, analysis and optimization of models. Since this is a natural division of labor, we’ve also made it easy to switch between the two views of models. In fact, SystemModeler and the Wolfram Language use a shared state. When you update a model in one of them, you will see that change directly reflected in the other.

Updated model

SystemModeler users have had a Wolfram Language interface since SystemModeler 3. Based on what we’ve learned from our users since then, we have completely redesigned the system modeling functionality in Wolfram Language 11.3 and SystemModeler 5.1. The functionality has been streamlined, improved and now integrated permanently in the Wolfram Language. This means that you can now share your models with millions of Wolfram Language users whether they have SystemModeler or not.

Share SystemModeler

One potential use of this is creating a virtual lab, where students can try out different hypotheses using interactive interfaces and learn from them. Let’s illustrate this with an example from biology, where the students can explore the spread of genes for sickle cell anemia in a population. Suppose their professor has created the following model:

Input 1

SystemModel["SickleCellAnemia"]

Output 1

The professor can embed the model in a Wolfram Language notebook and then add explanations, questions and interactive interfaces using the Manipulate function. This can then be delivered to students as standalone notebooks with interfaces like this:

With this, students can interact with the simulations to try different scenarios, set up experiments and instantly see if their results match their hypotheses.

We have made a complete version of this virtual lab available. You can download it to test for yourself. You don’t even need a copy of SystemModeler to run it—just the latest version of a desktop Wolfram Language product such as Mathematica 11.3. Of course, you can always download an unrestricted 30-day trial of SystemModeler 5.1 and modify the included models to your own liking, or create your very own models for exploration, teaching or advanced analysis.

For more details on what’s new in Wolfram SystemModeler, visit the What’s New page or see a full list of changes here.

To share your models with other Wolfram Language and SystemModeler users, please join the Wolfram Community.

Introduction to Model Analytics

]]>
4
Swede White <![CDATA[User Research: Deep Learning for Gravitational Wave Detection with the Wolfram Language]]> http://blog.internal.wolfram.com/?p=41555 2018-04-03T16:02:24Z 2018-03-14T17:00:36Z Daniel George is a graduate student at the University of Illinois at Urbana-Champaign, Wolfram Summer School alum and Wolfram intern whose award-winning research on deep learning for gravitational wave detection recently landed in the prestigious pages of Physics Letters B in a special issue commemorating the Nobel Prize in 2017.

We sat down with Daniel to learn more about his research and how the Wolfram Language plays a part in it.

DanielGeorgeAward

How did you become interested in researching gravitational waves?

This was actually a perfect choice in my research area, and the timing was perfect, since within one week after I joined the group, there was the first gravitational wave detection by LIGO, and things got very exciting from there.

I was very fortunate to work in the most exciting fields of astronomy as well as computer science. At the [NCSA] Gravity Group, I had complete freedom to work on any project that I wanted, and funding to avoid any teaching duties, and a lot of support and guidance from my advisors and mentors who are experts in astrophysics and supercomputing. Also, NCSA was an ideal environment for interdisciplinary research.

Initially, my research was focused on developing gravitational waveform models using post-Newtonian methods, calibrated with massively parallel numerical relativity simulations using the Einstein Toolkit on the Blue Waters petascale supercomputer.

These waveform models are used to generate templates that are required for the existing matched-filtering method (a template-matching method) to detect signals in the data from LIGO and estimate their properties.

However, these template-matching methods are slow and extremely computationally expensive, and not scalable to all types of signals. Furthermore, they are not optimal for the complex non-Gaussian noise background in the LIGO detectors. This meant a new approach was necessary to solve these issues.

Your research is also being published in Physics Letters B—that must be pretty exciting…

My article was featured in the special issue commemorating the Nobel Prize in 2017.

Even though peer review is done for free by referees in the scientific community and the expenses to host online articles are negligible, most high-profile journals today are behind expensive paywalls and charge thousands of dollars for publication. However, Physics Letters B is completely open access to everyone in the world for free and has no publication charges for the authors. I believe all journals should follow this example to maximize scientific progress by promoting open science.

This was the main reason why we chose Physics Letters B as the very first journal where we submitted this article.

You recently won an award at SC17 for your work—how was your demo received?

I think the attendees and judges found this very impressive, since it was connecting high-performance parallel numerical simulations with artificial intelligence methods based on deep learning to enable real-time analysis of big data from LIGO for gravitational wave and multimessenger astrophysics. Basically, this research is at the interface of all these exciting topics receiving a lot of hype recently.

Deep learning seems like a novel approach. What led you to explore this?

I was always interested in artificial intelligence since my childhood, but I had no background in deep learning or even machine learning until November 2016, when I attended the Supercomputing Conference (SC16).

There was a lot of hype about deep learning at this conference, especially a lot of demos and workshops by NVIDIA, which got me excited to try out these techniques for my research. This was also right after the new neural network functionality was released in Version 11 of the Wolfram Language. I already had the training data of gravitational wave signals from my research with the NCSA Gravity Group, as mentioned before. So all these came together, and this was a perfect time to try out applying deep learning to tackle the problem of gravitational wave analysis.

Since I had no background in this field, I started out by taking an online course by Geoffrey Hinton on Coursera and CS231 at Stanford, and quickly read through the Deep Learning book by Bengio [Courville and Goodfellow], all in about a week.

Then it took only a couple of days to get used to the neural net framework in the Wolfram Language by reading the documentation. I decided to give time series inputs directly into 1D convolutional neural networks instead of images (spectrograms). Amazingly, the very first convolutional network I tried performed better than expected for gravitational wave analysis, which was very encouraging.

What advantages does deep learning have over other methods?

Here are some advantages of using deep learning over matched filtering:

1) Speed: The analysis can be carried out within milliseconds using deep learning (with minimal computational resources), which will help in finding the electromagnetic counterpart using telescopes faster. Enabling rapid followup observations can lead to new physical insights.

2) Covering more parameters: Only a small subset of the full parameter space of signals can be searched for using matched filtering (template matching), since the computational cost explodes exponentially with the number of parameters. Deep learning is highly scalable and requires only a one-time training process, so the high-dimensional parameter space can be covered.

3) Generalization to new sources: The article shows that signals from new classes of sources beyond the training data, such as spin precessing or eccentric compact binaries, can be automatically detected with this method with the same sensitivity. This is because, unlike template-matching techniques, deep learning can interpolate to points within the training data and generalize beyond it to some extent.

4) Resilience to non-Gaussian noise: The results show that this deep learning method can distinguish signals from transient non-Gaussian noises (glitches) and works even when a signal is contaminated by a glitch, unlike matched filtering. For instance, the occurrence of a glitch in coincidence with the recent detection of the neutron star merger delayed the analysis by several hours using existing methods and required manual inspection. The deep learning technique can automatically find these events and estimate their parameters.

5) Interpretability: Once the deep learning method detects a signal and predicts its parameters, this can be quickly cross-validated using matched filtering with a few templates around these predicted parameters. Therefore, this can be seen as a method to accelerate matched filtering by narrowing down the search space—so the interpretability of the results is not lost.

Why did you choose the Wolfram Language for this research?

I have been using Mathematica since I was an undergraduate at IIT Bombay. I have used it for symbolic calculation as well as numerical computation.

The Wolfram Language is very coherent, unlike other languages such as Python, and includes all the functionality across different domains of science and engineering without relying on any external packages that have to be loaded. All the 6,000 or so functions have explicit names and are designed with a very similar syntax, which means that most of the time you can simply guess the name and usage without referring to any documentation. The documentation is excellent, and it is all in one place.

Overall, the Wolfram Language saves a researcher’s time by a factor of 2–3x compared to other programming languages. This means you can do twice as much research. If everyone used Mathematica, we could double the progress of science!

I also used it for all my coursework, and submitted Mathematica notebooks exported into PDFs, while everyone else in my class was still writing things down with pen and paper.

The Wolfram Language neural network framework was extremely helpful for me. It is a very high-level framework and doesn’t require you to worry about what is happening under the hood. Even someone with zero background in deep learning can use it successfully for their projects by simply referring to just the documentation.

What about GPUs for neural net training?

Using GPUs to do training with the Wolfram Language was as simple as including the string TargetDevice->"GPU" in the code. With this small change, everything ran on GPUs like magic on any of my machines on Windows, OSX or Linux, including my laptop, Blue Waters, the Campus Cluster, the Volta and Pascal NVIDIA DGX-1 deep learning supercomputers and the hybrid machine with four P100 GPUs at the NCSA Innovative Systems Lab.

I used about 12 GPUs in parallel to try out different neural network architectures as well.

Was the Wolfram Language helpful in quick prototyping for successful grant applications?

I completed the whole project, including the research, writing the paper and posting on arXiv, within two weeks after I came up with the idea at SC16, even though I had never done any deep learning–related work before. This was only possible because I used the Wolfram Language.

I had drafted the initial version of the research paper as a Mathematica notebook. This allowed me to write paragraphs of text and typeset everything, even mathematical equations and figures, and organize into sections and subsections just like in a Word document. At the end, I could export everything into a LaTeX file and submit to the journal.

Everything, including the data preparation, preprocessing, training and inference with the deep convolutional neural nets, along with the preparation of figures and diagrams of the neural net architecture, was done with the Wolfram Language.

Apart from programming, I regularly use Mathematica notebooks as a word processor and to create slides for presentations. All this functionality is included with Mathematica.

What would you say to people who are new either to the Wolfram Language or deep learning to get them started?

Read the documentation, which is one of the greatest strengths of the language.

There are a lot of included examples about using deep learning for various types of problems, such as classification, regression in fields such as time series analysis, natural language processing, image processing, etc.

The Wolfram Neural Net Repository is a unique feature in the Wolfram Language that is super helpful. You can directly import state-of-the-art neural network models that are pre-trained for hundreds of different tasks and use them in your code. You can also perform “net surgery” on these models to customize them as you please for your research/applications.

The Mathematica Stack Exchange is a very helpful resource, as is the Fast Introduction for Programmers, along with Mathematica Programming—An Advanced Introduction by Leonid Shifrin.

George’s Research and Publications

Deep Learning for Real-Time Gravitational Wave Detection and Parameter Estimation: Results with Advanced LIGO Data (Physics Letters B)

Glitch Classification and Clustering for LIGO with Deep Transfer Learning (NIPS 2017, Deep Learning for Physical Science)

Deep Neural Networks to Enable Real-Time Multimessenger Astrophysics (Physics Review D)

Daniel George’s University of Illinois website

]]>
0