Finding the maximum real part of roots

Question

Suppose that I have this problem

roots = 
  Reduce[
    Sin[z + Sin[z + Sin[z]]] == Cos[z + Cos[z + Cos[z]]] && 
    -3 < Re[z] < 3 && -3 < Im[z] < 3, z] // Quiet;   

ListPlot[{Re[z], Im[z]} /. {ToRules[roots]}, 
  PlotLabel -> 
    Style[TraditionalForm[Sin[z + Sin[z + Sin[z]]] == Cos[z + Cos[z + Cos[z]]]], 14],  
  PlotStyle -> Red, AspectRatio -> 1]

Thus as in https://www.wolfram.com/mathematica/newin7/content/TranscendentalRoots/PlotTheRootsOfANestedTranscendentalEquation.html
I get a beautiful solution. Suppose now that this equation depends on quantity a in a range of (1, 2).

roots[a_] := 
  Reduce[
    Sin[z + Sin[z + Sin[z]]] == a + a Cos[z + a Cos[z + Cos[z]]] && 
    -3 < Re[z] < 3 && -3 < Im[z] < 3, z] // Quiet;  `   

But I don't want the real and imaginary part for each vale of a specified a, rather I would like to have a plot that is a continuous function of a, and the maximum of the real part of the z.

Is there any way to do it?

I have tried this,

Plot[Max[Re[z]] /. {ToRules[roots[a_]]}, {a, 1, 2}, 
  PlotLabel -> PlotStyle -> Red, AspectRatio -> 1]

but it has been running for a day and I still have not got any result.

Answer 1

Clear["Global`*"]

Use a numeric technique, i.e., NSolve.

f[a_?NumericQ] := 
 Max@Re[z /. 
    NSolve[Sin[z + Sin[z + Sin[z]]] == 
       a + Cos[z + a*Cos[z + a*Cos[z]]] && -3 < Re[z] < 3 && 
       -3 < Im[z] < 3 && 1 <= a <= 2, z]]

Since f uses a numeric technique, its argument is restricted to numeric values by using PatternTest with NumericQ. Even using numeric techniques the calculations are slow.

AbsoluteTiming[data = Table[{a, f[a]}, {a, 1, 2, .025}];]

(* {803.729, Null} *)

ListLinePlot[data,
 Frame -> True,
 FrameLabel ->
  (Style[#, 12, Bold] & /@ {"a", "Max[Re[z]]"})]

The plot is not smooth so if you were to use Plot its adaptive sampling would further increase the time required.