I don´t like mondays

Für einige Jahre kann man die Frage stellen, welcher Tag, wenn man diesen für den 10. Februar 2013 etwa in der Form 10022013 darstellt, eine Primzahl ergibt. Für das Jahr 2013 geht das, für 2014, aus naheliegenden Gründen, nicht.
Dafür kann man für jedes Jahr die Frage stellen, in welchem Tag der größte Primfaktor enthalten ist. Für das Jahr 2014 ist dies etwa der 30. Oktober. 
Mit Hilfe von Mathematica ist es einfach derartige “Spielereien” zu betreiben. Zunächst wird die Liste der Tage eines Jahres eine Liste ganzer Zahlen gemacht, wie in nebenstehendem Mathematica-Code gezeigt.

Zur Vorbereitung erzeugen wir eine Funktion die uns für eine Jahr eine Liste aller Tage in einem bestimmten Format ausgibt. Hier soll eine Liste ausgegeben werden, die jeden Tag des Jahres als ganze Zahl auflistst. für den 16. Mai 2014 soll also die Zahl 16052014 ausgegeben werden. Wir bauen die Funktion Schritt für Schritt auf.

Als erste einefach eine Liste der Ziffern:

listeTageWork[jahr_Integer]:= Reverse /@ DateRange[{jahr,1,1},{jahr,12,31}]

temp = listeTageWork[2014];

list = temp[[1;;10]]

Aus jedem einzelnen Listenelement erzeugen wir nun die zugehörige Ziffernfolge

list=Flatten /@ IntegerDigits /@list

Nun muß aus diesen Ziffernfolgen nur noch jeweils eine Integerzahl aufgebaut werden. Dazu wird die Funktion FromDigits verwendet

FromDigits /@ list

Damit kann die Funktion einfach aufgebaut werden:

listeTage[jahr_Integer]:=FromDigits /@ Flatten /@ IntegerDigits/@ Reverse /@ DateRange[{jahr,1,1},{jahr,12,31}]

tage2014 =listeTage[2014];

Es sind tatsächlich alle 365 Tage:

Length @ tage2014

Aus dieser Liste extrahieren wir nun alle auftretenden Primfaktoren. Dazu wird jede einzelne Zahl zunächst in Primfaktoren zerlegt:

faktorisierteTage = FactorInteger /@ tage2014;

Da jeder der einzelnen Primfaktoren in der Form {Faktor, Häufigkeit} aufgeführt wird müssen wir jeweils die erste Komponenten eines solchen Paares extrahieren, da wir uns in diesem Falle nur für die Primfaktoren, nicht aber für die Häufigkeiten interessieren. Wir wählen hierzu die “brutal-einfache” Methode, da es für “Take”, meines Wissens nach, keine “leveslspec” Anweisung gibt, mit der man direkt auf eine entsprechende Listentiefe zugreifen könnte:

primFaktoren = Take[#,1]&/@Partition[Flatten[faktorisierteTage],2] // Flatten;

Wieviele Primfaktoren gibt es denn nun:

Length @ primFaktoren

Nun kann man auch leicht beispielsweise die 10 größten Primfaktoren aus dieser Liste extrahieren:

Take[Sort @ primFaktoren,-10]

Da kommt schnell die Idee auf für ein gegebenes Jahr denjenigen Tag herauszufinden, der den größten Primfaktor in sich trägt.... Wir machen das erst einmal für eine überschaubare Liste, damit man das Ergebnis gut sieht.

temp = faktorisierteTage[[1;;5]]

Nun brauchen wir von jeder Zerlegung den größten Primfaktor. Das ist einfach, da uns Mathematica freundlicherweise die Primfaktoren in aufsteigender Folge liefert. Wir müssen also nur den jeweils größten, d.h. den am weitesten rechts stehenden Faktor auswählten. Das ist einfach

liste = temp[[All,-1]]

Als Letztes extrahieren wir daraus noch die Primfaktoren

liste = #[[1]]& /@ liste

Aus der Liste der Primfaktoren für jeden Tag des Jahres kann nun einfach das Maximum bestimmt werden:

liste = Max /@liste;

Nun noch die Position des Maximums

Position[liste,Max @ liste]

Damit können wie diese Vorgehensweise nun in eine Mathematica Funktion eingehen lassen, die uns für ein eingegebenes Jahr die Position des größten Primfaktors und den Faktor selbst ausgibt. Die Funktion ist dabei nicht auf Laufzeit, sonder auf Lesbarkeit hin optimiert.

maxPrimfaktor[jahr_Integer]:=Module[{listeJahr},
(* Bilde eine Liste der aus dem Datum zusammengesetzten Zahlen*)
listeJahr = FromDigits /@ Flatten /@ IntegerDigits/@ Reverse /@ DateRange[{jahr,1,1},{jahr,12,31}];
listeJahr = FactorInteger /@listeJahr;(* Faktorisieren der Zahlen *)
listeJahr=listeJahr[[All,-1]]; (*groeßten Faktor wählen*)
listeJahr=#[[1]]& /@listeJahr; (*Haeufigkeit verwerfen*)
{Max @ listeJahr,Flatten @ Position[listeJahr,Max @ listeJahr]}
]

Nun kann de größte Primfaktor einfach ermittelt werden:

First @ maxPrimfaktor[2014]

First @ {15051007,{303}}

Die zweite Lösungskomponente liefert die Position des Tages innerhalb des Jahres, für die dieser Primfaktor angenommen wird:

Last @ maxPrimfaktor[2014]

Damit ist der Tag identifiiert, dessen Darstellung den größten Primfaktor enthält, es ist der 303. Tag des Jahres. Der 30. Oktober 2014, was man sofort erkennt, wenn man sich die dazugehörige Zahl ansieht:

tage2014[[303]]

Man kan nun auch leicht ermitteln, welcher Wochentag es ist. Ein Donnerstag.

temp =DayName @ DatePlus[{2014,1,1},302]

Die Ausgabe hier ist (natürlich) in Englisch, aber das deutschen wir ein....

tageDeutsch = {Sunday-> "Sonntag", Monday-> "Montag", Tuesday->"Dienstag", Wednesday-> "Mittwoch", Thursday-> "Donnerstag", Friday-> "Freitag", Saturday->"Samstag"};

(DayName @ DatePlus[{2014,1,1},302]) /. tageDeutsch

Nun fassen wir diese Ergebnisse zusammen in eine Funktion die für ein gegebenes Jahr den größten Primfaktor in der jeweiligen Zerlegung der Tage ausgibt, die Position des Tages, für den das gilt, wird gleich noch mitgeliefert

{pos, day }= maxPrimfaktor[2011]

Nun braucht es nur noch eine Funktion die aus der Position des Tages den Namen des Wochentages direkt extrahiert. Nach unseren Vorarbeiten nun auch kein Problem mehr:

tagesNamen[jahr_Integer, position_List]:=Module[{tageNamenDeutsch=tageDeutsch = {Sunday-> "Sonntag", Monday-> "Montag", Tuesday->"Dienstag", Wednesday-> "Mittwoch", Thursday-> "Donnerstag", Friday-> "Freitag", Saturday->"Samstag"}},
ReplaceAll[(DayName /@ DateRange[{jahr, 1,1},{jahr, 12,31}][[position]]),tageNamenDeutsch]
]

Dies liefert den Namen des Wochentages bei dem das Maximum der Primfaktoren erreicht wird

tagesNamen[2011,day]

Sehr schön, dann können wir ja mal das aktuelle Jahrhundert auswerten, in welchem Wochentag die größten Primfaktoren stecken. Das ist nun einfach.

Primfaktoren und Positionen bestimmen

jahre = Range[2000,2099]; temp = maxPrimfaktor[#]& /@ jahre;positionen = temp[[All,2]];

Wochentage ermitteln

wochentage = tagesNamen[##]& @@@ ({jahre, positionen}\[Transpose]);

Häufigkeiten berechnen

frequenz = Tally @ wochentage

Jetzt noch ein wenig Kosmetik, damit wir eine schöne, grafische Darstellung erhalten. Also einfach das Ergebnis sortieren und graphisch darstellen:

frequenz = Sort[frequenz,#1[[2]]<#2[[2]]&];

Und zum Schluß noch das Balkendiagramm

BarChart[frequenz[[All,2]], ChartLegends->Flatten @ frequenz[[All,1]],ChartElementFunction->"GlassRectangle", ChartStyle->"TemperatureMap", PlotLabel->Text[ Style["Tagesrangfolge der Jahre 2000 bis 2099",FontFamily->"Helvetica", Bold]]]

Ergebnis: Der Montag schneidet am schlechtesten ab, der Freitag gewinnt und zwar deutlich!