Message Boards Message Boards

GROUPS:

Happy Harmonic 2017 !

Posted 5 years ago
7503 Views
|
1 Reply
|
13 Total Likes
|

enter image description here

Import and process the sound

Import Auld Lang Syne as a MIDI file.

auldlangsyne = Import["http://www.evatoller.se/zipped/women/womenschoir_midi_etc_A-D.zip",
  "womenschoir_midi_etc_A-D/midi/auldlangsyne_piano.mid"]

enter image description here

Extract the notes:

notes = Select[Import["http://www.evatoller.se/zipped/women/womenschoir_midi_etc_A-D.zip",
    {"womenschoir_midi_etc_A-D/midi/auldlangsyne_piano.mid", {"SoundNotes"}}], Length[#] > 0 &];

Length /@ notes

{87, 73, 82, 86}

The beginnings of the four voices:

Sound /@ AssociationThread[{"Soprano", "Alto", "Tenor", "Bass"} -> Take[notes[[All, 1 ;; 10]]]]

enter image description here

tmax = Max[notes[[All, -1, 2]]]

49.4958

Convert notes to frequencies:

frequency = <|
   "C4" -> Quantity[261.626`, "Hertz"], 
   "F4" -> Quantity[349.228`, "Hertz"], 
   "D4" -> Quantity[293.665`, "Hertz"], 
   "A#3" -> Quantity[233.082`, "Hertz"], 
   "A3" -> Quantity[220, "Hertz"], 
    "A4" -> Quantity[440, "Hertz"], 
   "F3" -> Quantity[174.614`, "Hertz"], 
   "G4" -> Quantity[391.995`, "Hertz"], 
   "E4" -> Quantity[329.628`, "Hertz"], 
   "G3" -> Quantity[195.998`, "Hertz"], 
   "C5" -> Quantity[523.25`, "Hertz"], 
   "D#4" -> Quantity[311.127`, "Hertz"], 
   "D5" -> Quantity[587.33`, "Hertz"], 
   "A#4" -> Quantity[466.164`, "Hertz"], 
   "E3" -> Quantity[164.814`, "Hertz"], 
   "B3" -> Quantity[246.942`, "Hertz"], 
   "F5" -> Quantity[698.46`, "Hertz"], 
   "C#4" -> Quantity[277.183`, "Hertz"]|>;

\[ScriptF] = QuantityMagnitude[frequency];    
{minf, maxf} = MinMax[\[ScriptF]] + {-20, 20};

Interpolate the frequencies smoothly for each voice.

interpolate[{SoundNote[n1_, {t11_, t12_}, ___], 
SoundNote[n2_, {t21_, t22_}, ___]}, t_, M_] :=
With[{?t1 = t12 - t11, ?t2 = 
t22 - t21, ? = (t21 - t12) + (t12 - t11)/M + (t22 - t21)/M},
Piecewise[{{\[ScriptF][n1], 
t11 + 1/M ?t1 < t < t12 - 1/M ?t1},
{Cos[(t - (t12 - 1/M ?t1))/? Pi/2]^2   \[ScriptF][n1] +                        
Sin[(t - (t12 - 1/M ?t1))/? Pi/2]^2   \[ScriptF][n2] , 
t12 - 1/M ?t1 <= t <= t21 + 1/M ?t2}}]]

endSegments[{SoundNote[n1_, {t11_, t12_}, ___], __, 
   SoundNote[n2_, {t21_, t22_}, ___]}, t_, M_] := 
 With[{?t1 = t12 - t11, ?t2 = t22 - t21},
  Piecewise[{{\[ScriptF][n1], t <= t11 + 1/M ?t1}}] + 
   Piecewise[{{\[ScriptF][n2], t >= t21 + 1/M ?t2}}] ]

Plot the smoothed frequency(time) curves:

height[t_] = With[{M = 3}, Map[Function[d, endSegments[d, t, M] + 
      Total[ interpolate[#, t, M] & /@ Partition[d, 2, 1]] ], notes]];

pl = Plot[Evaluate[height[t]], {t, 0, 50}, Exclusions -> {}, 
  AxesLabel -> {"time", "frequency"}]

enter image description here

Compare with the piecewise constant frequencies from the MIDI file.

Graphics[Transpose[{{
    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]},
   Apply[Function[{n, t, i, v}, With[{f = \[ScriptF][n]}, Line[{#, f} & /@ t]]], notes, {2}]}], 
   Axes -> True, AspectRatio -> 1/2, AxesLabel -> {"time", "frequency"},AxesOrigin -> {0, 167}]

enter image description here

Make the digits of the year 2017

Make a region named dr with thickened versions of 2, 0, 1, 7 cut out:

(* image of "2017" *)
im = ImagePad[ImageCrop@Image[Rasterize[
      Style["2\[ThinSpace]0\[ThinSpace]1\[ThinSpace]7", 60, Bold, FontFamily -> "Helvetica"],
      ImageSize -> 800, ColorSpace -> "Grayscale"]], 80, White];

(* boundary mesh of 2017 *)
reg = ImageMesh[im];

(* triangle mesh of 2017 *)
dr = DiscretizeRegion[reg, MaxCellMeasure -> 60]; 
rectangle = Rectangle[{0, 0}, {xmax, ymax} = Round[Max /@ RegionBounds[dr]]];

(* enclosing letter rectangles *)
{x20, x01, x17} = 
  Round[Mean[{#1[[1, 2]], #2[[1, 1]]}]] & @@@ 
   Partition[RegionBounds /@ SortBy[ 
      Take[SortBy[ConnectedMeshComponents[RegionBoundary[dr]], 
        ArcLength], {2, -2}],Mean[MeshCoordinates[#]][[1]] &], 2, 1];
twoR = 1 < x < x20 && 1 < y < ymax - 1;
zeroR = x20 < x < x01 && 1 < y < ymax - 1;
oneR = x01 < x < x17 && 1 < y < ymax - 1;
sevenR = x17 < x < xmax - 1 && 1 < y < ymax - 1; 

dr

enter image description here

The digits 2, 0, 1, 7 that fit into the above holes:

The digits 2, 0, 1, 7 that fit into the above holes.

{reg2, reg0, reg1, reg7} = 
  DiscretizeRegion[RegionDifference[Rectangle[{#1, 0}, {#2, ymax}], dr], 
     MaxCellMeasure -> 30] & @@@ Partition[{0, x20, x01, x17, xmax}, 2, 1];

colored2017[{col2_, col0_, col1_, col7_}, {h2_, h0_, h1_, h7_}] =  
    {EdgeForm[],  Function[{r, h, c}, 
    {c, GraphicsComplex[Append[#, h] & /@ MeshCoordinates[r], MeshCells[r, 2]]}] @@@ 
    Transpose[{{reg2, reg0, reg1, reg7}, {h2, h0, h1, h7}, {col2, col0, col1, col7}}]};

    Graphics3D[colored2017[
        {XYZColor[0.6043974419855613, 0.5481627489703486, 0.06070758994993585], 
        XYZColor[0.3180480185280479, 0.39882321040206814`, 0.053488882016709094`], 
        XYZColor[0.23839222210493904`, 0.3403322196839612, 0.3831722497463972], 
        XYZColor[0.2524840935517123, 0.21748522921280664`, 0.7341325788952462]}, 
    {400, 300, 200, 100}]]

enter image description here

Make a harmonic function

Hold the digits 2, 0, 1, 7 at a fixed potential and solve the Laplace equation:

(* function to prescribe values on the boundaries of 2, 0, 1, 7 *)
boundaryValue[{x_,y_}, {two_,zero_,one_,seven_},outside_] := 
Piecewise[{{two, twoR},{zero,zeroR},{one,oneR},{seven,sevenR},
                      {minf, y==0},  {maxf, y==ymax},
                      {minf+(1-Sqrt[1-(y/ymax)^2 ])(maxf-minf),x==0||x==xmax  }},0] 

harmonic2017[?_]:=
Module[{nd=NDSolveValue[{Laplacian[u[x,y],{x,y}]==0,
DirichletCondition[u[x,y]==boundaryValue[{x,y},height[?],315],True]}, u,{x,y}?dr],f,H},  
f[x_Real,y_Real]=nd[x,y];
H= Plot3D[f[x,y],{x,y}?dr, 
Axes -> False, NormalsFunction->"Average", Boxed->False,
ViewPoint->{1,-2.75,2.5},Mesh -> 12,MeshFunctions->{Function[{x,y,z},z]},
BoxRatios->{xmax,ymax,400} , PlotRange ->{{0,xmax},{0,ymax},{140, 720}},
PlotTheme->"Web"];
Show[{H,  Graphics3D[{ colored2017[Directive[#, Specularity[#, 20]]&/@ {
XYZColor[0.6043974419855613, 0.5481627489703486, 0.06070758994993585],
XYZColor[0.3180480185280479, 0.39882321040206814`, 0.053488882016709094`],
XYZColor[0.23839222210493904`, 0.3403322196839612, 0.3831722497463972],
XYZColor[0.2524840935517123, 0.21748522921280664`, 0.7341325788952462]},
height[?]]}]}]]

harmonic2017[35]

enter image description here

Interactive demonstration

Move through the song interactively:

Manipulate[
Row[{
Column[{ControlActive[Quiet[EmitSound@
    Sound[SoundNote[DeleteCases[als[t],0],0.5,"Piano"]]],None;],
    Show[{pl,Graphics[{Black, Line[{{t,minf},{t,maxf}}]}]},ImageSize->400]}], 
    Show[ harmonic2017[t],ImageSize->400]}],
{{t,20}, 0, tmax}]
Attachments:

enter image description here - Congratulations! This post is now Staff Pick! Thank you for your wonderful contributions. Please, keep them coming!

Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract