Message Boards Message Boards

GROUPS:

Access to Roman Maeder's Package for Computational Science with Mathematica

Posted 2 years ago
6072 Views
|
14 Replies
|
10 Total Likes
|

Dear community members, I just started reading Roman Maeder's book "Computer Science with Mathematica" and I'd like to do the computations along but unfortunately the page to download the CSM package is no longer available: http://www.mathconsult.ch/en/showroom/pubs/CSM

Does anybody know an alternative way to have access to the Mathematica package?

Many thanks in advance.

14 Replies

True, there is nothing to download from the publisher's webpage. Have you already tried to email the publisher or the author? Here are the public contact details:

mc-enquiries@mathconsult.ch (tel. +41 44 687 4051)

lecturers@cambridge.org (tel. +44 1223 358 331)

EDIT: i made a few phone calls and the information is that the original code/packages are not fully compatible with the latest Mathematica versions which is why the author prefers to not see the material being posted/shared/distributed publicly anymore. However, if you were to send an email to the above .ch address, he would be happy to share the material (via email attachment) confidentially with you. You are allowed to use it privately but you'd have no permission to share it further. Best i could do, raspi

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.

Posted 4 months ago

Did you have any luck getting the CSM packages? I also sent a few emails to the addresses above, but didn't get any response. I am very interested in the packages. It doesn't matter if they are not fully compatible with the latest version.

Unfortunately not.

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.

Posted 3 months ago

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: enter image description here

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}]
Posted 3 months ago

Thank you for your reply. I bought this book also and agree that „Informatik für Mathematiker und Naturwissenschaftler“ is in some way the German version of „Computer Science with Mathematica“. The book was used and the disk was unfortunately not included. I got a new copy of Computer Science with Mathematica and therefore it is a little bit frustrating that the packages cannot be obtained anymore. It is true that a lot of coding is printed in the book and can be retyped but not all coding is included.

As far as I know the file in question is called CSM1.zip.

Posted 3 months ago

If you tell me which chapter you are interested in, I can try to reconstruct the missing code.

Posted 3 months ago

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!

Posted 3 months ago
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.

Posted 3 months ago

Actually I missed a file which I cannot retype completely:

Chapter 7 - KnapG.m (the graphical version of Knapsack - especially KnapsackPlot would be interesting)

Thank you very much!

Posted 3 months ago

Hi Oliver,

I don't know what to say. Thank you very much!! I really appreciate your help!

Happy new year!

Philipp

Posted 3 months ago

Knapsack:

größe[element_] := element[[1]]
wert[element_] := element[[2]]

total[knapsack_, wg_] := Plus @@ wert /@ wg[[knapsack]]   (*Wert*)
inhalt[knapsack_, wg_] := Plus @@ größe /@ wg[[knapsack]]   (*Gewicht*)

Knapsack[{}, g_Integer?NonNegative] := {}

Knapsack[wg_List, g_Integer?NonNegative] := 
 Module[{gn = größe[Last[wg]], wn = wert[Last[wg]], n = Length[wg], 
   rest = Drop[wg, -1], k1, k2}, 
  k1 = Knapsack[rest, g];(*ohne letzten Gegenstand*)
  If[g >= gn, k2 = Knapsack[wg, g - gn];(*mit letztem Gegenstand*)
   k2 = Append[k2, n];
   If[total[k1, wg] >= total[k2, wg], k1, k2], k1]]

KnapsackGraph[{}, 
  inhalt_Integer?NonNegative] := {{}, {knoten[{inhalt, 0}, 0]}}

KnapsackGraph[wg_List, inhalt_Integer?NonNegative] := 
 Module[{gn = größe[Last[wg]], wn = wert[Last[wg]], n = Length[wg], 
   rest = Drop[wg, -1], k1, k2, g, k, g1, g2}, {k1, g1} = 
   KnapsackGraph[rest, inhalt];
  If[inhalt >= gn, {k2, g2} = KnapsackGraph[wg, inhalt - gn];
   k2 = Append[k2, n];
   If[total[k1, wg] >= total[k2, wg], k = k1; 
    g = {arrow[{inhalt, n}, {inhalt, n - 1}, True], 
      arrow[{inhalt, n}, {inhalt - gn, n}]}, k = k2; 
    g = {arrow[{inhalt, n}, {inhalt, n - 1}], 
      arrow[{inhalt, n}, {inhalt - gn, n}, True]}], k = k1; 
   g = {arrow[{inhalt, n}, {inhalt, n - 1}, True]};
   g2 = {};];
  {k, Join[g, g1, g2, {knoten[{inhalt, n}, total[k, wg]]}]}]

diskr = 0.4;                             (*Disk Radius*)
sf = 2;                                  (*vertical scaling*)
scale[{x_, y_}] := {x, sf y}
knoten[xy_List, text_] := {{GrayLevel[1], Disk[scale[xy], diskr]}, 
  Circle[scale[xy], diskr], Text[text, scale[xy]]}

t0 = 0.4; t1 = 1.1;(*Thickness[] in Punkten*)
arrow[from_, to_, 
  fett_ : False] := {AbsoluteThickness[If[fett, t1, t0]], 
  Line[{scale[from], scale[to]}]}

xticks[min_, max_] := Range[Round[min + 1], Round[max - 1], 2]
yticks[min_, max_] := 
 Table[{i, i/2}, {i, Round[sf (min + 1)], Round[sf (max - 1)], sf}]

KnapsackPlot[wg_List, inhalt_Integer?NonNegative, opts___] := 
 Module[{gr}, gr = KnapsackGraph[wg, inhalt][[2]];
  Show[Graphics[gr], opts, Frame -> True, AspectRatio -> Automatic, 
   FrameLabel -> {"g", "n"}, 
   PlotRange -> {{-1, inhalt + 1}, {-1, sf Length[wg] + 1}}, 
   FrameTicks -> {xticks, yticks, xticks, yticks}]]

Iterative Version:

KnapsackIterative[wg_List, inhalt_Integer?NonNegative] := 
 Module[{ks}, ks[0, in_] = {};
  ks[n_, in_] := 
   ks[n, in] = 
    Module[{gn = größe[wg[[n]]], wn = wert[wg[[n]]], k1, k2}, 
     k1 = ks[n - 1, in];
     If[in >= gn, k2 = ks[n, in - gn]; k2 = Append[k2, n];
      If[total[k1, wg] >= total[k2, wg], k1, k2], k1]];
  ks[Length[wg], inhalt]]

Examples:

sizes = {3, 4, 7, 8, 9};
values = {4, 5, 10, 11, 13};
things = {sizes, values}\[Transpose];
KnapsackPlot[things, 17]
Posted 3 months ago

Hi Oliver,

great! Thank you once again!

Philipp

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