BeginPackage["Informatik`Heureka`"]
faces::usage = "faces[t] ist die Liste der Polygone zur Zeit t."
heureka::usage = "heureka[t] ist die Graphik zu Zeit t, 0 <= t <= \
2Sqrt[2]."
Begin["`Private`"]
s2 = N[Sqrt[2]];
al[1][t_] = {3^(-1/2),
0, ((4 - t^2 - t*(8 - 3*t^2)^(1/2))^(1/2)*(2 +
t*(8 - 3*t^2)^(1/2)))/(24^(1/2)*(-2 + t^2))}
bl[1][t_] = {(4 - 3*t^2 +
t*(8 - 3*t^2)^(1/2))/(4*3^(1/2)), -((4*t^2 - t^4 +
t^3*(8 - 3*t^2)^(1/2))^(1/2)/
2^(3/2)), -((4 - t^2 - t*(8 - 3*t^2)^(1/2))^(1/2)/24^(1/2))}
cl[1][t_] = {(1 + t*(8 - 3*t^2)^(1/2))/(2*3^(1/2)),
If[t <= 1, (1 - 2*t^2 + t^4)^(1/2)/2, -(1 - 2*t^2 + t^4)^(1/2)/
2], (4 - t^2 - t*(8 - 3*t^2)^(1/2))^(1/2)/24^(1/2)}
dl[1][t_] = {1/(2*3^(1/2)),
1/2, -(((4 - t^2 - t*(8 - 3*t^2)^(1/2))^(1/2)*(2 +
t*(8 - 3*t^2)^(1/2)))/(24^(1/2)*(-2 + t^2)))}
rotl = {{-1/2, Sqrt[3]/2, 0}, {-Sqrt[3]/2, -1/2, 0}, {0, 0, 1}}
al[n_][t_] := al[1][t] . MatrixPower[rotl, n - 1]
bl[n_][t_] := bl[1][t] . MatrixPower[rotl, n - 1]
cl[n_][t_] := cl[1][t] . MatrixPower[rotl, n - 1]
dl[n_][t_] := dl[1][t] . MatrixPower[rotl, n - 1]
mirrorxz = {1, -1, 1}
ar[1][t_] := al[1][t] mirrorxz
br[1][t_] := bl[1][t] mirrorxz
cr[1][t_] := cl[1][t] mirrorxz
dr[1][t_] := dl[1][t] mirrorxz
rotr = {{-1/2, -Sqrt[3]/2, 0}, {Sqrt[3]/2, -1/2, 0}, {0, 0, 1}}
ar[n_][t_] := ar[1][t] . MatrixPower[rotr, n - 1]
br[n_][t_] := br[1][t] . MatrixPower[rotr, n - 1]
cr[n_][t_] := cr[1][t] . MatrixPower[rotr, n - 1]
dr[n_][t_] := dr[1][t] . MatrixPower[rotr, n - 1]
a[n_][t_] := If[t < s2, al[n][t], ar[n][2 s2 - t]]
b[n_][t_] := If[t < s2, bl[n][t], br[n][2 s2 - t]]
c[n_][t_] := If[t < s2, cl[n][t], cr[n][2 s2 - t]]
d[n_][t_] := If[t < s2, dl[n][t], dr[n][2 s2 - t]]
faces[tt_] := {RGBColor[1, 0, 0],
Polygon[{a[1][tt], a[2][tt], a[3][tt]}],
Polygon[{a[1][tt], c[1][tt], b[2][tt]}],
Polygon[{a[2][tt], c[2][tt], b[3][tt]}],
Polygon[{a[3][tt], c[3][tt], b[1][tt]}],
Polygon[{b[2][tt], d[1][tt], c[2][tt]}],
Polygon[{b[3][tt], d[2][tt], c[3][tt]}],
Polygon[{b[1][tt], d[3][tt], c[1][tt]}],
Polygon[{d[1][tt], d[3][tt], d[2][tt]}]}
heureka[tt_] := Graphics3D[N[faces[tt]]]
End[]
Protect[faces, heureka]
EndPackage[]
BinBaum (BinaryTree):
BeginPackage["Informatik`BinBaum`"]
leererBaum::usage = "leererBaum gibt einen leeren Binärbaum."
Knoten::usage = "Knoten[info, links, rechts] erzeugt einen Binärbaum
mit info in der Wurzel und gegebenen linken und rechten Teilbäumen."
Info::usage = "Info[baum] gibt das Info-Feld in der Wurzel von baum."
LinkerBaum::usage = "LinkerBaum[baum] gibt den linken Teilbaum."
RechterBaum::usage = "RechterBaum[baum] gibt den rechten Teilbaum."
BaumEinfügen::usage = "BaumEinfügen[baum, info, Schlüssel] fügt einen \
Knoten
mit gegebenem Info-Feld in baum ein."
BaumSuche::usage = "BaumSuche[baum, schlüssel, Schlüssel] gibt
das Info-Feld zurück, dessen Schlüssel gleich schlüssel ist."
BaumLöschen::usage = "BaumEinfügen[baum, schlüssel, Schlüssel] löscht \
einen Knoten
mit gegebenem schlüssel von baum."
Baum::usage = "Baum[liste, Schluessel] fügt die Elemente von liste
nacheinander in einen leeren Baum ein."
InOrder::usage = "InOrder[baum] gibt die Liste aller
Knoten in baum in Inorder."
PreOrder::usage = "PreOrder[baum] gibt die Liste aller
Knoten in baum in Preorder."
PostOrder::usage = "PostOrder[baum] gibt die Liste aller
Knoten in baum in Postorder."
Tiefe::usage = "Tiefe[baum] gibt die maximale Tiefe des Baumes."
BaumPlot::usage = "BaumPlot[baum] zeichnet ein Diagramm eines Baumes."
Begin["`Private`"]
Knoten[info_, links_, rechts_] := baum[info, links, rechts]
LinkerBaum[baum[_, links_, _]] := links
RechterBaum[baum[_, _, rechts_]] := rechts
Info[baum[info_, _, _]] := info
(*Einfügen*)
BaumEinfügen[leererBaum, info_, S_ : Identity] :=
Knoten[info, leererBaum, leererBaum]
BaumEinfügen[baum_, info_, S_ : Identity] :=
baum /; Order[S[info], S[Info[baum]]] == 0
BaumEinfügen[baum_, info_, S_ : Identity] :=
Knoten[Info[baum], BaumEinfügen[LinkerBaum[baum], info, S],
RechterBaum[baum]] /; Order[S[info], S[Info[baum]]] > 0
BaumEinfügen[baum_, info_, S_ : Identity] :=
Knoten[Info[baum], LinkerBaum[baum],
BaumEinfügen[RechterBaum[baum], info, S]] /;
Order[S[info], S[Info[baum]]] < 0
(*Suchen,ergibt Null,falls nicht gefunden*)
BaumSuche[leererBaum, schlüssel_, S_ : Identity] := Null
BaumSuche[baum_, schlüssel_, S_ : Identity] :=
Info[baum] /; Order[S[Info[baum]], schlüssel] == 0
BaumSuche[baum_, schlüssel_, S_ : Identity] :=
BaumSuche[LinkerBaum[baum], schlüssel, S] /;
Order[S[Info[baum]], schlüssel] < 0
BaumSuche[baum_, schlüssel_, S_ : Identity] :=
BaumSuche[RechterBaum[baum], schlüssel, S] /;
Order[S[Info[baum]], schlüssel] > 0
(*Format[b_baum]:="-binärer Baum-"*)
(*Traversierungen*)
InOrder[baum_] :=
Flatten[Traversierung[baum, Traversierung[LinkerBaum[#1], ##2] &,
Info[#1] &, Traversierung[RechterBaum[#1], ##2] &]]
PreOrder[baum_] :=
Flatten[Traversierung[baum, Info[#1] &,
Traversierung[LinkerBaum[#1], ##2] &,
Traversierung[RechterBaum[#1], ##2] &]]
PostOrder[baum_] :=
Flatten[Traversierung[baum, Traversierung[LinkerBaum[#1], ##2] &,
Traversierung[RechterBaum[#1], ##2] &, Info[#1] &]]
Traversierung[leererBaum, ___] := {}
Traversierung[baum_, one_, two_,
three_] := {one[baum, one, two, three], two[baum, one, two, three],
three[baum, one, two, three]}
BaumLöschen[leererBaum, schlüssel_, S_ : Identity] := leererBaum
BaumLöschen[baum_, schlüssel_, S_ : Identity] :=
Knoten[Info[baum], BaumLöschen[LinkerBaum[baum], schlüssel, S],
RechterBaum[baum]] /; Order[S[Info[baum]], schlüssel] < 0
BaumLöschen[baum_, schlüssel_, S_ : Identity] :=
Knoten[Info[baum], LinkerBaum[baum],
BaumLöschen[RechterBaum[baum], schlüssel, S]] /;
Order[S[Info[baum]], schlüssel] > 0
(*wir müssen die Wurzel löschen*)
BaumLöschen[baum_, schlüssel_, S_ : Identity] :=
RechterBaum[baum] /; LinkerBaum[baum] == leererBaum
BaumLöschen[baum_, schlüssel_, S_ : Identity] :=
LinkerBaum[baum] /; RechterBaum[baum] == leererBaum
(*allgemeiner Fall*)
BaumLöschen[baum_, schlüssel_, S_ : Identity] :=
With[{nextinfo = KleinsterKnoten[RechterBaum[baum]]},
Knoten[nextinfo, LinkerBaum[baum],
BaumLöschen[RechterBaum[baum], S[nextinfo], S]]]
KleinsterKnoten[leererBaum] = Null
KleinsterKnoten[baum_] := Info[baum] /; LinkerBaum[baum] === leererBaum
KleinsterKnoten[baum_] := KleinsterKnoten[LinkerBaum[baum]]
Tiefe[leererBaum] := 0
Tiefe[baum_] :=
1 + Max[Tiefe[LinkerBaum[baum]], Tiefe[RechterBaum[baum]]]
Baum[l_List, S_ : Identity] :=
Fold[BaumEinfügen[#1, #2, S] &, leererBaum, l]
diskr = 0.4
maxnode = 7
margin = 0.5
plot0[leererBaum, stufe_, nextx_] := {nextx, nextx + 1, {}}
plot0[baum_, stufe_, nextx_] :=
Module[{wx, nextl, nextr, wl, wr, gl, gr, g = {}},
If[LinkerBaum[baum] =!= leererBaum, {wl, nextl, gl} =
plot0[LinkerBaum[baum], stufe - 1, nextx];
wx = nextl;
AppendTo[g, Line[{{wl, stufe - 1}, {wx, stufe}}]];
AppendTo[g, gl],(*else*)wx = nextx];
If[RechterBaum[baum] =!= leererBaum, {wr, nextr, gr} =
plot0[RechterBaum[baum], stufe - 1, wx + 1];
AppendTo[g, Line[{{wr, stufe - 1}, {wx, stufe}}]];
AppendTo[g, gr],(*else*)nextr = wx + 1];
g = Join[
g, {{GrayLevel[1], Disk[{wx, stufe}, diskr]},
Circle[{wx, stufe}, diskr], Text[Info[baum], {wx, stufe}]}];
{wx, nextr, g}]
BaumPlot[baum_, opts___] :=
Module[{wx, nextx, g, x0, x1}, {wx, nextx, g} = plot0[baum, 0, 0];
g = Prepend[g, Line[{{wx, 0}, {wx, 1}}]];
If[nextx >
maxnode, {x0, x1} = {0, nextx - 1}, {x0,
x1} = {0 - (maxnode - (nextx - 1))/2,
nextx - 1 + (maxnode - (nextx - 1))/2}];
Show[Graphics[g], opts, AspectRatio -> Automatic,
PlotRange -> {{x0 - margin, x1 + margin}, All}]]
End[]
EndPackage[]
Call it like this:
BaumPlot[Baum[{3, 7, 5, 4, 8, 6, 2}]]
Heap:
BeginPackage["Informatik`Heap`"]
neuerHeap::usage = "neuerHeap[n] ergibt einen leeren Heap mit Platz \
für n Elemente."
aufwärts::usage = "aufwärts[h, k] verschiebt Element k aufwärts, bis \
die
Heap-Bedingung wieder erfüllt ist."
abwärts::usage = "abwärts[h, n] verschiebt das erste Element des \
Heaps mit
n Elementen abwärts, bis die Heap-Bedingung wieder erfüllt ist."
einfügen::usage = "einfügen[h, n, v] fügt ein neues Element v in \
einen Heap
mit n Elementen ein."
löschen::usage = "löschen[h, n] löscht das größte Element im Heap h."
HeapSort::usage = "HeapSort[liste] sortiert eine Liste mittels \
Heapsort."
HeapPlot::usage = "HeapPlot[heap, k] zeichnet ein Diagramm eines \
Heaps."
HeapSortList;
Begin["`Private`"]
p[k_Integer?Positive] := Floor[k/2] (*Vorgängerknoten*)
neuerHeap[n_Integer?NonNegative] := Table[Null, {n}]
SetAttributes[aufwärts, HoldFirst]
aufwärts[h_Symbol, k0_] :=
Module[{v = h[[k0]], k = k0},
While[p[k] > 0 && h[[p[k]]] <= v, h[[k]] = h[[p[k]]];
k = p[k]];
h[[k]] = v;
h]
SetAttributes[einfügen, HoldAll]
einfügen[h_Symbol, n_Symbol, v_] := (h[[++n]] = v; aufwärts[h, n]; h)
SetAttributes[abwärts, HoldFirst]
abwärts[h_Symbol, n_] :=
Module[{v = h[[1]], k = 1, j}, While[k <= n/2, j = 2 k;
(*finde größten Nachfolger*)If[j < n && h[[j]] < h[[j + 1]], j++];
If[v > h[[j]], Break[]];(*ok*)h[[k]] = h[[j]];
k = j];
h[[k]] = v;
h]
SetAttributes[löschen, HoldAll]
löschen[h_Symbol, n_Symbol] := Module[{v = h[[1]]}, h[[1]] = h[[n--]];
abwärts[h, n];
v]
HeapSort[a_List] :=
Module[{n = 0, h = a, i},
Do[einfügen[h, n, a[[i]]], {i, 1, Length[a]}];
Do[h[[i]] = löschen[h, n], {i, Length[a], 1, -1}];
h]
HeapSortList[a_] :=
Module[{n = 0, h = a, res = {a}},
Do[einfügen[h, n, a[[i]]]; AppendTo[res, h], {i, 1, Length[a]}];
Do[h[[i]] = löschen[h, n]; AppendTo[res, h], {i, Length[a], 1, -1}];
res]
(*Graphik Parameter*)
diskr = 0.4
maxnode = 7
margin = 0.5
plot0[heap_, k_, i_, stufe_, nextx_] /; i > k := {nextx, nextx + 1, {}}
plot0[heap_, k_, i_, stufe_, nextx_] :=
Module[{wx, nextl, nextr, wl, wr, gl, gr, g = {}},
If[2 i <= k, {wl, nextl, gl} = plot0[heap, k, 2 i, stufe - 1, nextx];
wx = nextl;
AppendTo[g, Line[{{wl, stufe - 1}, {wx, stufe}}]];
AppendTo[g, gl],(*else*)wx = nextx];
If[2 i + 1 <= k, {wr, nextr, gr} =
plot0[heap, k, 2 i + 1, stufe - 1, wx + 1];
AppendTo[g, Line[{{wr, stufe - 1}, {wx, stufe}}]];
AppendTo[g, gr],(*else*)nextr = wx + 1];
g = Join[
g, {{GrayLevel[1], Disk[{wx, stufe}, diskr]},
Circle[{wx, stufe}, diskr], Text[heap[[i]], {wx, stufe}]}];
{wx, nextr, g}]
HeapPlot[heap_, k_, opts___] /; 0 <= k <= Length[heap] :=
Module[{wx, nextx, g, x0, x1}, {wx, nextx, g} =
plot0[heap, k, 1, 0, 0];
g = Prepend[g, Line[{{wx, 0}, {wx, 1}}]];
If[nextx >
maxnode, {x0, x1} = {0, nextx - 1}, {x0,
x1} = {0 - (maxnode - (nextx - 1))/2,
nextx - 1 + (maxnode - (nextx - 1))/2}];
Show[Graphics[g], opts, AspectRatio -> Automatic,
PlotRange -> {{x0 - margin, x1 + margin}, All}]]
End[]
EndPackage[]
QSortG (Tausche is swap):
SetAttributes[Tausche, {HoldFirst}]
Tausche[l_Symbol, i_, j_] := ({l[[i]], l[[j]]} = {l[[j]], l[[i]]}; l)
QuickSort::usage = "QuickSort[list] sortiert die Liste list.";
maxl = 8;
thin = 0.002;
thick = 0.01;
gray = 0.7;
QuickSort[list_] :=
Module[{l = list, res}, y = -1; gr = {Thickness[thin]};
res = QSort[l, 1, Length[list]];
Print[Show[Graphics[gr], Axes -> None, AspectRatio -> Automatic,
PlotRange -> {{0.9, maxl + 1.1}, {y + 1.4, 0.1}}]];
res]
SetAttributes[QSort, HoldFirst]
QSort[l_, n0_, n1_] := l /; n0 >= n1
QSort[l_, n0_, n1_] :=
Module[{lm = l[[Floor[(n0 + n1)/2]]], i = n0, j = n1},
While[True, While[l[[i]] < lm, i++];
While[l[[j]] > lm, j--];
Zeichne[l, n0, n1, i, j];
If[i >= j, Break[]];
Tausche[l, i, j];
i++; j--];
QSort[l, n0, i - 1];
QSort[l, j + 1, n1];
l]
rect[{x0_, y0_}, {x1_, y1_}] :=
Line[{{x0, y0}, {x1, y0}, {x1, y1}, {x0, y1}, {x0, y0}}]
Zeichne[l_, n0_, n1_, i_, j_] :=
Module[{g1, g2},
Which[i < j,
g1 = {GrayLevel[gray], Rectangle[{i, y}, {i + 1, y + 1}],
Rectangle[{j, y}, {j + 1, y + 1}]}, i == j,
g1 = {Thickness[thick], rect[{i, y}, {i + 1, y + 1}],
GrayLevel[gray], Rectangle[{i, y}, {i + 1, y + 1}]}, i > j,
g1 = {Thickness[thick], Line[{{i, y}, {i, y + 1}}]}];
g2 = Table[{rect[{x, y}, {x + 1, y + 1}],
Text[l[[x]], {x + 1/2, y + 1/2}]}, {x, n0, n1}];
AppendTo[gr, {g1, g2}];
y -= 1.5;]
call it like this:
QuickSort[{2, 1, 5, 3, 6, 4}]
There is a good implementation of Turing in THE MATHEMATICA PROGRAMMER II
TuringR:
BeginPackage["Informatik`TuringR`", {"Informatik`Turing`",
"Informatik`TuringM`"}]
null::usage = "null ist das TM Program für die Null."
plus1::usage = "plus1 ist das TM Program für den Nachfolger."
p::usage = "p[k, n] ist das TM Program für die Projektion p^n_k."
comp::usage = "comp[n, f, {g1, ..., gp}] ist das TM Program für die
Komposition."
pr::usage = "pr[n, f, g] ist das TM Program für die primitive \
Rekursion."
args::usage = "args[n1, n2, ...] erzeugt die initiale Bandinschrift \
entsprechend
den Argumentent n1, n2,..."
Begin["`Private`"]
null = noop
plus1 = komposition[skip[1], {anweisung[1, b, m, r, 0]},(*schreibe 1*)
skip[-1]]
(*Projektoren,k-tes Argument von n*)
p[k_, n_] :=
komposition[komposition @@ Table[eat1[j], {j, n, n - k + 2, -1}],
If[k < n,
komposition[skip[1],
komposition @@ Table[eat1[j], {j, n - k, 1, -1}], skip[-1]], noop]]
(*Zusammensetzung von p Funktionen von n Argumenten \
f[g1[...],...,gp[...]]*)
comp[n_, f_, gs_List] :=
With[{p = Length[gs]},
komposition[
komposition @@
Table[komposition[copy[n, n + i - 1],(*kopiere Argumente*)
gs[[i]],(*führe g_i aus*)
skip[-(n + i - 1)] (*zurück zum Anfang*)], {i, 1, p}],
komposition @@ Table[eat1[i + p], {i, n, 1, -1}], f]]
(*subtrahiere 1,Zahlen größer 0,mit n folgenden Argumenten*)
sub1[n_] :=
komposition[rechts, {anweisung[1, m, b, s, 0]}, shiftleft[n + 1]]
(*primitive Rekursion h(k,m1,...,mn)*)
pr[n_, f_, g_] :=
komposition[(*:k m1...mn*)skip[n + 1],(*k m1...mn:*)null,(*k m1...mn:
0*)skip[-n],(*k:m1...mn 0*)copy[n, n + 1],(*k m1...mn 0:m1...mn*)
f,(*k m1...mn 0:h0*)skip[-(n + 2)],(*:k m1...mn 0 h0*)
rechts,(*k m1...mn 0 h0*)
while[(*k>0*)
komposition[links,(*:k' m1...mn:i hi*)sub1[n + 2],(*:
k m1...mn i hi*)skip[n + 1],(*k m1...mn:i hi*)
copy[2, 2],(*k m1...mn i hi:i hi*)skip[-(n + 2)],(*k:
m1...mn i hi i hi*)copy[n, n + 4],(*k m1...mn i hi i hi:m1...mn*)
skip[-2],(*k m1...mn i hi:i hi m1...mn*)g,(*k m1...mn i hi:hi'*)
skip[-2],(*k m1...mn:i hi hi'*)copy[1, 3],(*k m1...mn i hi hi':i*)
plus1,(*k m1...mn i hi hi':i'*)skip[-1],(*k m1...mn i hi:hi' i'*)
copy[1, 2],(*k m1...mn i hi hi' i':hi'*)skip[-4],(*k m1...mn:
i hi hi' i' hi'*)eat1[5],(*k m1...mn:hi hi' i' hi'*)
eat1[4],(*k m1...mn:hi' i' hi'*)eat1[3],(*k m1...mn:i' hi'*)
skip[-(n + 1)],(*:k m1...mn i' hi'*)
rechts (*k m1...mn i' hi'*)]], links,(*:0 m1...mn k hk*)
p[n + 3, n + 3] (*:hk*)]
unary[n_] := Prepend[Table[m, {n}], b]
args[n___] := Join @@ unary /@ {n}
End[]
EndPackage[]
just in case:
BeginPackage["Informatik`TuringM`", "Informatik`Turing`"]
(*calling convention:a macro is an instruction sequence that starts \
in state 1 and halts in state 0. It does not use the tape to the left \
of its initial position.The square to the left of its first argument \
is empty.Arguments are separated by one empty square.The head is \
initially one square before the first argument.It should end in the \
same position with the result following it.*)
relozieren::usage = "relozieren[anw, offset, return] addiert offset
zu allen Zuständen und ändert Zustand 0 in return."
komposition::usage = "komposition[anweisungslisten...] assembliert die
Anweisungslisten in ein sequentielles Programm."
while::usage = "while[ instrs ] loops over the instructions while the \
symbol
under the head is not empty."
(*useful sequences*)
rechts::usage = "rechts bewegt den Kopf um eins nach rechts."
links::usage = "links bewegt den Kopf um eins nach links."
noop::usage = "noop macht nichts."
skip::usage = "skip[n] überspring n Argumente. Negatives n springt \
nach links"
copy::usage = "copy[n, m] kopiert n Argumente über m weitere und hält \
vor der Kopie."
shiftleft::usage = "shiftleft[n] verschiebt n Argumente um eine Zelle \
nach links."
eat1::usage = "eat1[n] löscht das erste von n Argumenten."
Begin["`Private`"]
relozieren[anw_List, offset_, return_] :=
anw /. {anweisung[st_, sy_, nsy_, mv_, 0] :>
anweisung[st + offset, sy, nsy, mv, return],
anweisung[st_, sy_, nsy_, mv_, nst_] :>
anweisung[st + offset, sy, nsy, mv, nst + offset]}
maxState[{}] = 0
maxState[anw_List] := Max[zustand /@ anw]
SetAttributes[komposition, {Flat, OneIdentity}]
komposition[anw1_, anw2_] :=
With[{offset = maxState[anw1]},
Join[relozieren[anw1, 0, offset + 1], relozieren[anw2, offset, 0]]]
komposition[anw1_, {}] := anw1(*confer MathProg`TuringMacros`*)
(*looping*)
while[anw_] :=
Join[{anweisung[1, b, b, s, 0], anweisung[1, m, m, s, 2]},
relozieren[anw, 1, 1]]
(*primitive movements*)
rechts = {anweisung[1, b, b, r, 0], anweisung[1, m, m, r, 0]}
links = {anweisung[1, b, b, l, 0], anweisung[1, m, m, l, 0]}
noop = {anweisung[1, b, b, s, 0], anweisung[1, m, m, s, 0]}
(*skip arg*)
skip1 = komposition[rechts, while[{anweisung[1, m, m, r, 0]}]]
skipback1 = komposition[links, while[{anweisung[1, m, m, l, 0]}]]
(*skip n args*)
skip[n_?Negative] := skipback[-n]
skip[n_] := komposition @@ Table[skip1, {n}]
skipback[n_] := komposition @@ Table[skipback1, {n}]
(*copy an arg over n others and return after original*)
copy1[n_] :=
komposition[rechts,
while[komposition[{anweisung[1, m, b, s, 0]},(*b is sentinel*)
skip[n + 2], {anweisung[1, b, m, r, 0]},(*write 1*)
skip[-(n + 2)], {anweisung[1, b, m, r, 0]}] (*restore 1*)]]
(*copy n arguments over m and stop before the \
copy.arg1.arg2...argn.argn1...argm\[Rule]
^
.arg1.arg2...argn.argn1...argm.arg1.arg2...argn.
^*)
copy[n_] := copy[n, n]
copy[n_, m_] :=
komposition[komposition @@ Table[copy1[m - 1], {n}], skip[m - n]]
(*shift arg left one pos,ending 2 after the shifted arg*)
(*.11111.-->11111..^ ^*)
shiftl = {anweisung[1, b, m, r, 2],(*write 1*)
anweisung[2, m, m, r, 2],(*skip 1s*)anweisung[2, b, b, l, 3],(*end*)
anweisung[3, m, b, r, 0] (*erase 1*)}
(*shift n args left by one pos.*)
shiftleft[n_] :=
komposition[komposition @@ Table[shiftl, {n}], skip[-(n + 1)]]
(*eat an argument of n args*)
eat1[n_] :=
komposition[rechts,
while[komposition[{anweisung[1, m, b, s, 0]},(*erase it*)
shiftleft[n], rechts]], shiftleft[n - 1]]
End[]
EndPackage[]
and:
BeginPackage["Informatik`Turing`", "Informatik`Band`", \
"Utilities`FilterOptions`"]
(*Symbole,b ist das Leerzeichen*)
b::usage = "b ist das Vorgabe-Leerzeichen."
m::usage = "m ist die Vorgabe-Marke."
(*anweisung data type*)
l::usage = "l ist die Bewegung nach links."
r::usage = "r ist die Bewegung nach rechts."
s::usage = "s ist das Stillstehen des Kopfes."
anweisung::usage = "anweisung[zustand, symbol, sNeu, bewegung, zNeu]
baut eine Anweisung."
zustand::usage = "zustand[anw] gibt den Zustand einer Anweisung."
symbol::usage = "symbol[anw] gibt das (alte) Symbol einer Anweisung."
symbolNeu::usage = "symbolNeu[anw] gibt das neue Symbol nach einer \
Anweisung."
bewegung::usage = "bewegung[anw] gibt die Kopfbewegung einer \
Anweisung."
zustandNeu::usage = "zustandNeu[anw] gibt den neuen Zustand nach \
einer Anweisung."
(*configuration data type*)
config::usage = "config[s0, t0, p0] ist eine Konfiguration in Zustand \
s0,
mit Band t0 und mit Kopfposition p0."
zustand::usage =
zustand::usage <>
"zustand[config] ist der Zustand einer Konfiguration."
band::usage = "band[config] ist das Band einer Konfiguration."
head::usage = "head[config] ist die Kopfposition einer Konfiguration."
symbol::usage = "head[config] ist das Symbol unter dem Kopf in einer \
Konfiguration."
(*simulation*)
nächsteKonfiguration::usage = " nächsteKonfiguration[config, \
anweisungen]
führt einen Schritt der Maschine aus."
anfangsKonfiguration::usage = "anfangsKonfiguration[liste]
ist die Konfiguration mit Zustand 1, Band gegeben durch liste."
run::usage = "run[config, anweisungen, n:Infinity] simuliert
die Maschine beginnend mit Konfiguration config bis zum Halten,
spätestens aber nach n Schritten. run[liste, ...] verwendet
die Liste als Bandinhalt und startet in Zustand 1."
runList::usage = "runList[args] gibt die Zwischenschritte der \
Simulation
mittels run[args] zurück."
(*plotting*)
PlotTuring::usage = "PlotTuring[configlist, opts...] zeichnet die
Konfigurationen (erhalten durch runList[])."
Columns::usage = "Columns -> n ist eine Option von PlotTuring,
die die Anzahl zu zeichnender Spalten angibt."
b = "_"
m = "*"
nächsteKonfiguration::noinstr = "Keine Anweisung mit Zustand `1` und \
Symbol `2` gefunden."
Begin["`Private`"]
(*anweisung Datentyp*)
anweisung[zustand_, symbol_, sNeu_, bewegung_,
zNeu_] := {zustand, symbol} -> {sNeu, bewegung, zNeu}
zustand[anweisung[zustand_, symbol_, sNeu_, bewegung_,
zNeu_]] := zustand
symbol[anweisung[zustand_, symbol_, sNeu_, bewegung_, zNeu_]] := symbol
symbolNeu[
anweisung[zustand_, symbol_, sNeu_, bewegung_, zNeu_]] := sNeu
bewegung[anweisung[zustand_, symbol_, sNeu_, bewegung_,
zNeu_]] := bewegung
zustandNeu[
anweisung[zustand_, symbol_, sNeu_, bewegung_, zNeu_]] := zNeu
(*configuration Datentyp*)
zustand[config[s_, t_, head_]] := s
band[config[s_, t_, head_]] := t
head[config[s_, t_, head_]] := head
symbol[config[s_, t_, head_]] := t[head]
(*Zustandsübergang*)
nächsteKonfiguration[c_config /; zustand[c] == 0, anweisungen_] := c
moverules = Dispatch[{r -> 1, l -> -1, s -> 0}]
nächsteKonfiguration[c_config, anw_List | anw_Dispatch] :=
Module[{zNeu, sNeu,
bewegung}, {sNeu, bewegung, zNeu} = {zustand[c], symbol[c]} /. anw;
If[Head[zNeu] === Symbol,
Message[nächsteKonfiguration::noinstr, zustand[c], symbol[c]];
Return[c]];
config[zNeu, update[band[c], sNeu, head[c]],
head[c] + bewegung /. moverules]]
(*Anfangskonfiguration*)
anfangsKonfiguration[l_List] := config[1, neuesBand[l, b], 1]
(*execution history*)
run[c_config, anw_List | anw_Dispatch, n_ : Infinity] :=
FixedPoint[nächsteKonfiguration[#, anw] &, c, n]
run[init_List, anweisungen_, n_ : Infinity] :=
run[anfangsKonfiguration[init], anweisungen, n]
runList[c_config, anw_List | anw_Dispatch, n_ : Infinity] :=
Module[{configs},
configs = FixedPointList[nächsteKonfiguration[#, anw] &, c, n];
If[Length[configs] < n + 1, Drop[configs, -1], configs]]
runList[init_List, anweisungen_, n_ : Infinity] :=
runList[anfangsKonfiguration[init], anweisungen, n]
(*Graphik*)
nonblank[s_] := If[s === b, "", s] (*suppress blanks*)
rect[{x0_, y0_}, {x1_, y1_}] :=
Line[{{x0, y0}, {x1, y0}, {x1, y1}, {x0, y1}, {x0, y0}}]
rect[{x0_, y0_}, {x1_, y1_}, fill_] := {fill,
Rectangle[{x0, y0}, {x1, y1}]}
drawConfig[c_config, y0_, x0_, x1_] :=
Module[{i, cells},
cells = Table[{rect[{i, y0}, {i + 1, y0 + 1}],
Text[nonblank[band[c][i]], {i + 1/2, y0 + 1/2}]}, {i, x0, x1}];
Join[{AbsoluteThickness[0.25],
rect[{head[c], y0}, {head[c] + 1, y0 + 1}, GrayLevel[0.7]]},
cells, {Text[zustand[c], {x0 - 1/2, y0 + 1/2}, {1, 0}]}]]
maxl = 8
Options[PlotTuring] = {Columns -> 1}
PlotTuring[configs_List, opts___] :=
Module[{y = 0, rows, cols, gr, gropt, n},
minx = Min[head /@ configs, low[band[configs[[-1]]]], 0];
maxx = Max[head /@ configs, high[band[configs[[-1]]]], maxl];
rows = Table[y -= 1.5;
drawConfig[configs[[i]], y, minx, maxx], {i, 1, Length[configs]}];
cols = Columns /. {opts} /. Options[PlotTuring];
gropt = {FilterOptions[Graphics, opts], Axes -> None,
AspectRatio -> Automatic,
PlotRange -> {{minx - 2.2, maxx + 1.1}, All}};
If[cols > 1, n = Ceiling[Length[rows]/cols];
gr = Partition[rows, n];
If[n cols != Length[rows],
AppendTo[gr, Take[rows, -(Length[rows] - n (cols - 1))]]];
gr = Graphics[#, gropt] & /@ gr;
(*GraphicsArray to GraphicsGrid*)
gr = GraphicsGrid[{gr}, {FilterOptions[GraphicsGrid, opts],
PlotRange -> All}];, gr = Graphics[rows, gropt];];
Show[gr]]
PlotTuring[c_config, opts___] := PlotTuring[{c}, opts]
End[]
Protect[zustand, symbol, symbolNeu, bewegung, zustandNeu, head, \
config, nächsteKonfiguration, anfangsKonfiguration, runList, run, \
PlotTuring, Columns]
Protect[r, l, s]
EndPackage[]
and:
BeginPackage["Informatik`Band`"]
leeresBand::usage = "leeresBand[b] ist ein leeres Band mit \
Leerzeichen b."
update::usage = "update[band, sym, i] ist ein Band, das mit band
übereinstimmt, außer in Zelle i, wo der Wert gleich sym ist."
neuesBand::usage = "neuesBand[liste,b,p0:1] ist ein Band,dessen \
Inhalt von
der Liste genommen wird.Das erste Element ist an Stelle p0."
low::usage = "low[band] ist der kleinste Index einer nichtleeren \
Zelle."
high::usage = "high[band] ist der größte Index einer nichtleeren \
Zelle."
Begin["`Private`"]
(*list[[j]] ist die Bandposition i=offset+j*)
leeresBand[b_] := band[{}, 0, b]
band[list_, offset_, b_][i_Integer] :=
list[[i - offset]] /; 0 < i - offset <= Length[list]
band[list_, offset_, b_][i_Integer] := b
band /: update[band[list_, offset_, b_], new_, i_Integer] :=
Which[i - offset <= 0,
band[Join[{new}, Table[b, {offset - i}], list], i - 1, b],
i - offset > Length[list],
band[Join[list, Table[b, {i - offset - Length[list] - 1}], {new}],
offset, b], True,
band[ReplacePart[list, new, i - offset], offset, b]]
neuesBand[l_List, b_, p0_ : 1] := band[l, p0 - 1, b]
band /: low[band[list_, offset_, b_]] :=
Module[{j = 1}, While[j <= Length[list] && list[[j]] === b, j++];
If[j <= Length[list], offset + j, Infinity]]
band /: high[band[list_, offset_, b_]] :=
Module[{j = Length[list]}, While[j >= 1 && list[[j]] === b, j--];
If[j >= 1, offset + j, -Infinity]]
Format[t_band] := SequenceForm["<", Infix[Array[t, 6, 1], " "], "...>"]
Protect[band]
End[]
Protect[leeresBand, update, neuesBand]
EndPackage[]
hope ä,ö and ü don't mess things up.
If still something is missing, let me know.
