Something for one of my classes. It may have "several unnecessary features." And be missing some. Can delete if not a propos.
<!--  -->
Some features:
- Parses variables so students may enter functions of `t` or of `x` or of whatever.
- Syntax errors don't clobber the demo. In fact, an edit window preserves the mis-written code for the user to emend. An alternative would be to allow the error-ridden code, but prevent the Fourier analysis and visualization.
- Allows for a parameter, so one can see how the Fourier series changes as the parameter moves.
- An `Animator[]` allows the time to increase indefinitely while the phasor linkage is animated and the graph scrolls to the left.
- An `OpenerView[]` toggles the animated Fourier phasor components.
- One can manually enter a high `order` for a slowly convergent Fourier series.
*Code:*
The `DEBUG` lines and comments could have been eliminated to make the code look shorter.
(*
* Fourier[]
* with componentGrid
* and autovar
* and parameters
* and compiled function
*)
debug = <||>;
DEBUG // ClearAll;
DEBUG // Attributes = {HoldAllComplete};
$debug = False;
DEBUG[x_] /; TrueQ@$debug := x;
$demoSize = 550;
Manipulate[
With[{t = var, a = param},
With[{
line = ReIm[ (* Fourier phasor sum *)
I*Accumulate[
Prepend[ConstantArray[2, order], 1]*
fc*
Exp[2 Pi I Range[0, order] (-tt)]
] +
tt + $circleoffset/2], pt = {tt, series /. t -> tt}
,
plot =
Plot[ (* function and partial series,
with room for rotating phasor sum *)
{functionC[Mod[t, 1], aa], series},
{t, tt - 1.25, tt},
PlotStyle -> {AbsoluteThickness[3], AbsoluteThickness[1.5]},
Exclusions -> None,
PlotRange -> (hmph = {{tt - 1.25,
tt + Max[$circleoffset, 0.5/Pi]}, $yrange}),
PlotRangePadding -> {{0, Scaled[.05]}, {Scaled[0.1],
Scaled[0.1]}},
ImagePadding -> 25, Frame -> True, AspectRatio -> Automatic,
GridLines -> {Range[Ceiling[tt - 1.25],
Floor[tt + $circleoffset]], None},
PlotLabel -> Row@{"var: ", var, ", param: ", param}
]},
OpenerView[{ (* plot of function, series, phasor sum;
individual phasors k=1..10 *)
Show[(* plot of function, series, phasor sum *)
(* line, circle, points for phasor sum *)
Graphics[
{Lighter@Darker@Yellow,
(* rolling circle has diam. 1/(2Pi) => unit circumference ==
one period *)
Circle[First[line], 1/(2 Pi)],
Point@CirclePoints[
First[line], {1/(2 Pi), -2 Pi*(0 tt + line[[1, 1]])}, 8],
(* circle rolls on this line *)
InfiniteLine[First@line - {0, 1/(2 Pi)}, {1, 0}],
Point[ (* ticks on line *)
Thread[{
Range[Floor[tt - 1.25, 0.125],
Ceiling[tt + $circleoffset, 0.125], 0.125],
line[[1, 2]] - 1/(2 Pi)}]]
}
]
,
(* plot of function, series *)
plot
,
(* phasor sum *)
Graphics[
{Line@line, {Thin,
MapThread[Circle, {Most@line, Norm /@ Differences@line}]},
Red, {Opacity[0.5], Line[{Last@line, pt}]},
PointSize@Medium, Point@pt, PointSize@Small, Point@Last@line}
]
,
(* Show[] options *)
ImageSize -> $demoSize,
Options@plot
]
,
(* individual phasors k=1..10 *)
componentGrid /. t -> tt
},
Dynamic@open, (* OpenerView[] state *)
Alignment -> Center]
]]
,
(* controls & options *)
{{tt, 0, Dynamic@var}, 0, 4 (* independent time variable *)
, Row[{ (* slider: *)
Manipulator[Dynamic[Clip[tt, #2], (tt = #) &], ##2],
" ", (* animator for continuous running: *)
Animator[#, {0, Infinity}, AnimationRunning -> False,
AnimationRate -> 1/5]}] &},
{{aa, 0., Dynamic@param}, -1, 1,(* parameter value *)
TrackingFunction -> (updateSeries[Null, order, #] &)},
{{order, 3}, 1, 10, 1, (* truncation order of series *)
TrackingFunction -> (updateSeries[Null, #, Null] &)},
{{function, SquareWave[t - a]/4 + t^2},
Row[{ (* input expression: *)
InputField[Dynamic[#, updateSeries[#, order, Null] &]],
" ",(* setter for independent variable: *)
SetterBar[
Dynamic[var, (var = #; {param} = DeleteCases[syms, var];
updateSeries[function, order, aa]) &], syms],
" edit:",
InputField[
Dynamic[functionText, updateSeries[#, order, Null] &]]}] &},
{{error, None}, Pane@error &}, (* show parse error *)
(* local variables and functions *)
{{functionText, function},
None}, (* last edit of function, even if syntax error *)
{functionC, None}, (* compiled function *)
{fc, None}, (* Fourier coefficient up to order *)
{fcStore, None}, (* Fourier coefficients up to high order *)
{series, None}, (* truncated Fourier series *)
{$yrange, None}, (* y plot range *)
{$circleoffset,
None}, (* offset from graph to give room for Fourier phasor sum *)
{componentGrid, None}, (* grid of Fourier components/phasors *)
{{open, False},
None}, (* OpenerView state (True => component grid is showing *)
{{var, t}, None}, (* function arg symbol/indep. variable *)
{{param, a}, None}, (* parameter symbol *)
{{syms, {t, a}}, None}, (* symbols in the input expression *)
{{updateSeries, updateSeries}, None}, (* update function *)
{maxFC, None}, (* max abs val Fourier coefficient *)
{componentGridFN,
None}, (* function that generates the Fourier component grid *)
(*" initializes update function, phasor grid function,
initial values for Manipulate-user variables "*)
Initialization :> (
updateSeries[newFunction_, newOrder_, newParamValue_] :=
Module[{newSyms, fvals},
DEBUG[debug["time"] = {AbsoluteTime[]}];
(* Parse function *)
error = None;
DEBUG[debug["newFN"] == newFunction];
If[newFunction =!= Null,
functionText = newFunction;
If[Head@newFunction =!= RawBoxes,
(* parse variable/parameter *)
newSyms = Variables@Level[newFunction, {-1}];
If[Length@newSyms == 0, {param, var} = newSyms = {a, t}]; (*
defaults *)
If[
Length@newSyms == 1, {param, var} =
newSyms = Prepend[newSyms, a]];
If[Length@newSyms == 2,
If[! MemberQ[newSyms, var],
{param, var} = newSyms,
{param} = DeleteCases[newSyms, var]
];
If[NumericQ[newFunction /. {var -> tt, param -> aa}],
syms = newSyms;
function = newFunction;
With[{fargs = {{var, param}, PiecewiseExpand@function}},
functionC =
Compile @@
Join[fargs, {RuntimeAttributes -> {Listable},
Parallelization -> True}];
If[! FreeQ[functionC, {46 | 47, __}], (* not compilable *)
functionC = Function @@ Join[fargs, {Listable}]
]
],
error = Pane[
Row@{newFunction, " did not evaluate to a number at ", var,
"=", tt, ", ", param, "=", aa},
$demoSize]
],
error = Pane[
Row@{newFunction,
" should have only one parameter, one variable (",
Sequence @@ Riffle[newSyms, ", "], ")"},
$demoSize]
],
error = Pane[
Row@{newFunction, " incomplete syntax or syntax error"},
$demoSize]
]
];
DEBUG[debug["time"] = {debug["time"], AbsoluteTime[]}];
(* update param value *)
If[newParamValue =!= Null,
aa = newParamValue
];
(* update order value *)
If[newOrder =!= Null,
order = newOrder
];
(* If function parsed ok... *)
If[error === None,
If[newFunction =!= Null || newParamValue =!= Null,
(* calculate Fourier coefficients via FFT *)
(* currently only called when control is active *)
fvals =
functionC[Subdivide[0., 1., ControlActive[2^12, 2^16]], aa];
fcStore = fvals // Fourier // #/Sqrt[Length@# - 1] &;
DEBUG[debug["fcStore"] = fcStore];
maxFC = Max@Abs@fcStore[[;; 11]]; (*
for relative phasor size in componentGrid *)
(* calculate y range for plotting *)
(* overestimates Gibbs;
does not always contain Fourier component line *)
$yrange = MinMax@fvals;
DEBUG[debug["yrange1"] = $yrange];
$yrange = $yrange - {-1, 1} 0.2 Subtract @@ $yrange;
If[$yrange[[1]] > Re@First@fcStore - 0.6/Pi, (*
rolling circle has diam. 1/(2Pi) *)
$yrange[[1]] = Re@First@fcStore - 0.6/Pi];
If[$yrange[[2]] < Re@First@fcStore + 0.6/Pi,
$yrange[[2]] = Re@First@fcStore + 0.6/Pi];
DEBUG[debug["yrange2"] = $yrange];
];
DEBUG[debug["time"] = {debug["time"], AbsoluteTime[]}];
fc = Take[fcStore, order + 1]; (* Fourier coefficients *)
DEBUG[debug["fc"] = fc];
series = Total[ (* Fourier series *)
Prepend[ConstantArray[2, order], 1]*
Abs[fc]*
Sin[2 Pi Range[0, order] (-var) + Arg[fc] + Pi/2]
];
DEBUG[debug["series"] = series];
DEBUG[debug["time"] = {debug["time"], AbsoluteTime[]}];
$circleoffset = 4.4 Total@Abs@Rest@Take[fcStore, 11];
componentGrid = componentGridFN @@ fcStore[[2 ;; 11]];
DEBUG[debug["time"] = {debug["time"], AbsoluteTime[]}];
DEBUG[debug["parsed"] = {var, param, syms, $yrange}]
];
DEBUG[debug["time"] = AbsoluteTime[] - debug["time"]];
];
componentGridFN = (* grid of rotating Fourier component phasors *)
Block[{order, maxFC, var},
(*" Block initial values.
Circle radii relative to largest Fourier coefficient.
Grid is precomputed to save time. "*)
Function@
Evaluate@
With[{$fc =
I Array[Slot, 10]*Exp[2 Pi I Range[1, 10] (-var)]/maxFC},
Labeled[
GraphicsGrid[
Partition[
MapIndexed[
Graphics[{ (* Fourier phasor rep. by circle/angle line *)
If[First@#2 > order, Opacity[0.3], Nothing],
Circle[], Blue,
Circle[{0, 0}, Abs[#1]],
Line[{{0, 0}, ReIm@#1}]},
PlotRange -> {{-1.5, 1.5}, {-1.1, 1.1}}
] &,
$fc (* scaled Fourier components *)
],
5],
ImageSize -> $demoSize
],
Style["Fourier Components", "Label"],
Top
]
]
];
updateSeries[SquareWave[t - a]/4, 3, 0.]
),
TrackedSymbols :> {tt, functionC, order, aa, var}
]
**edit by Nasser (we must have some movies!)**
[![enter image description here][1]][1]
[![enter image description here][2]][2]
[1]: https://i.sstatic.net/0qJdp.gif
[2]: https://i.sstatic.net/rF3md.gif
[3]: https://i.sstatic.net/FJNNB.gif