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
tor ofxor 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
orderfor 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!)
