Hi Oliver,

great! Thank you once again!

Philipp

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.

That is very nice. Book "Informatik für Mathematiker und Naturwissenschaftler":

Chapter 6.2: QSortG.m - the graphical Version of Q-Sort

Chapter 6.3: the implementation of BaumPlot would be interesting. The rest of BinBaum.m I can retype.

Chapter 8.4.2: Function HeapPlot

Chapter 12: TuringR.m

Chapter B.2: Heureka.m

Thank you very much for your effort!

This book is based on an older book (written in german) by the same author from 1993 "Informatik für Mathematiker und Naturwissenschaftler". As far as I can see it is just a translation.

I own the 1993 german book, but sadly the source code messes up with the german "Umlaut" i.e. ä, ö. ü on my recent computer.

But as far as i can see there are only a few packages. The most part is printed in the book, so it can be retyped. (I did this for FunctionIteration and BinaryTree)

Here is the (slightly edited (good for more recent Mathematica version)) code for FunctionIteration:

FunctionIteration[f_, x0_, initial_ : 0, length_, {xmin_, xmax_}, 
  opts___] :=
     Module[{start, orbits, plot, lines, x},
          start = Nest[f, N[x0], initial];
          If[ Head[start] =!= List, start = {start} ];
          orbits = Transpose[ NestList[f, start, length] ];
          plot = Plot[f[x], {x, xmin, xmax}];
          lines = Line[Partition[
                         Flatten[Transpose[{#, #}], 1], 2, 1]] & /@ 
    orbits;
          Show[ plot,
                 Graphics[{Thickness[.0001],  PointSize[.02],
                             lines, Point[{#, #}] & /@ start,
                             Line[{{xmin, xmin}, {xmax, xmax}}]}],
                 opts,
                 AxesOrigin -> {xmin, xmin},
                 PlotRange -> {{xmin, xmax}, {xmin, xmax}},
                 AspectRatio -> 1
           ]
      ]

and here is an example:

FunctionIteration[4 # (1 - #) &, {0.099, 0.1, 0, 0.101}, 0, 4, {0, 1}]

which gives:

and NewtonIeration:

NewtonIteration[f_, x0_, length_, {xmin_, xmax_}, opts___] :=
     Module[{start = x0, xvals, plot, lines, x, fp = f'},
          If[ Head[start] =!= List, start = {start} ];

  xvals = Transpose[ NestList[# - f[#]/fp[#] &, start, length] ];
          plot = Plot[f[x], {x, xmin, xmax}];

  lines = Line[Partition[Flatten[{#, 0, #, f[#]} & /@ #, 1], 2]] & /@ 
    xvals;
          Show[ plot,
                 Graphics[{Thickness[.0001],  PointSize[.02],
                             lines, Point[{#, 0}] & /@ start}],
                 opts
           ]
      ]

with an example:

NewtonIteration[Cos, 0.5, 3, {0, 3}]

I checked to see if I had the software on my hard drive -- I bought the book when it was new. Unfortunately, I no longer have it.

I looked at the book. It was written for version 4, so there is quite a bit that is obsolete. Someone who is experienced with Mathematica could figure out what the good bits are, but a beginner might find it hard going. Surprisingly, some of Roman's earlier books fare better, because he concentrates on basic programming in them, and that part has changed relatively little from version 1, certainly 2.2.

Some years ago, I tried to update a Mathematica book that I liked, but which was obsolete. There was so much to change, that what I ended up with was an entirely different book, which is not what I was after.

My suggestion is that you try reading the book for the ideas, and then try implementing them in current Wolfram Language syntax. The code in the book may point in the right direction in many cases, but there are quite a few things that will just bite you if you try to implement them as written.

I am beginning to think that Knuth was right (as usual): put all the actual code in a generic pseudo-code and force the reader to figure out the implementation. Not much good if you just want quick answers, but more edifying in the long run. You could treat the code in the book as a kind of pseudo-code that resembles Wolfram Language.

good luck.

Thanks for the suggestion. I actually sent an email to both, the publisher and the author but I didn't get any reply. That's why I decided to post the message in the group.

Unfortunately not.