Programme aus dem Buch

          Algorithmen
          - von Hammurapi bis Goedel

          Jochen Ziegenbalg
          Oliver Ziegenbalg 
          Bernd Ziegenbalg

          (C) Harri Deutsch Verlag, Frankfurt am Main 2007 
              (2., verbesserte Auflage) 


Die Bestimmungen des Urheberrechts gelten grundsaetzlich.

Eine Verwendung fuer kommerzielle Zwecke ist nicht erlaubt.

Das Herunterladen ("downloading"), Ueberspielen und die Nutzung der 
Programme erfolgt auf eigene Verantwortung des Benutzers.



Kapitel 3
---------

Heron(a)
  Hilfsvariable:  x, y, xneu, yneu;  
  (* Vereinbarung von lokalen Hilfsvariablen *) 
  x:=a;  y:=1;     (*  :=  Wertzuweisung  *) 
  Solange |x^2 - a|  >  0.000001 tue folgendes: 
    [ xneu := (x+y)/2;   (* Die eckigen Klammern    *) 
      yneu := a/xneu;    (* legen den Gueltigkeits- *) 
      x := xneu;         (* bereich der Solange-    *) 
      y := yneu ];       (* Kontrollstruktur fest.  *) 
  Rueckgabe x            (* x wird als Funktions-   *) 
                         (* wert zurueckgegeben.    *) 
Ende.  



 1:  heron:=proc(a) 
 2:    local x, y, xneu, yneu, L;   # lokale Variable 
 3:    x:=a; y:=1; L:=[[x,y]]; 
 4:    while abs(x^2-a) > 0.000001 do 
 5:      xneu := (x+y)/2; 
 6:      yneu := a/xneu; 
 7:      L:= [op(L), [xneu, yneu]];   
 8:          # Das Paar [xneu, yneu] wird 
 9:          # an die Liste L angehaengt 
10:      x := xneu; 
11:      y := yneu   od; 
12:    RETURN(L); 
13:  end; 



 1: Program Heron_Verfahren; 

 2:  var a, x, y, xneu, yneu, epsilon: real; 
 3:      k: integer; 

 4:  begin  (* Heron *) 
 5:   writeln; 
 6:   writeln('Das Heron-Verfahren '); 
 7:   writeln('zur Bestimmung der Quadratwurzel'); 
 8:   writeln; 

 9:   write('a = ');  readln(a);    (* Eingabe *) 
10:   write('Toleranz: epsilon = '); readln(epsilon); 
11:   k := 0; 
12:   x := a; 
13:   y := 1; 

15:   while abs(x*x - a) > epsilon do 
16:    begin 
17:     writeln(k : 4, x : 13 : 8, y : 12 : 8); 
18:            (* formatierte Ausgabe *) 
19:     k := k+1;
20:     xneu := (x + y) / 2;
21:     yneu := a / xneu; 
22:     x := xneu; 
23:     y := yneu; 
24:    end; 

25:   writeln(k : 4, x : 13 : 8, y : 12 : 8); 
26:   writeln('Wurzel(a)  = ', x : 12 : 8); 
27:  end.  (* Heron *) 



 1:  Heron[a_] :=  
 2:    Module[{x, y, xneu, yneu, L}, 
 3:      (x=a; y=1; L={{x, y}}; 
 4:      While[Abs[x^2-a] > 0.000001, 
 5:        (xneu = (x+y)/2; 
 6:         yneu = a/xneu; 
 7:         L = Append[L, {xneu, yneu}]; 
 8:         x = xneu; 
 9:         y = yneu )]; 
10:      Return[L]) ] 



1: EuklidSubtraktionsform(a, b)  
2:   Solange a und b beide von Null verschieden sind, 
3:     fuehre folgendes aus:  
4:     Wenn a ( b, so ersetze a durch a-b, 
5:                 sonst ersetze b durch b-a.  
6:   Die uebrig bleibende, von Null verschiedene ganze 
7:   Zahl ist der gesuchte groesste gemeinsame 
8:   Teiler GGT(a, b).     



1:  EuklidSub[a0_, b0_] := 
2:    Module[{a=a0, b=b0}, 
3:      While[Not[ a*b == 0], 
4:        (* solange a und b beide  
5:           von Null verschieden sind   *)
6:        Print[a, "   ", b];  
7:        If[a >= b, a = a-b, b = b-a ] ]; 
8:      Return[a+b] (* Jetzt ist einer der 
9:                   Summanden gleich Null *) ] 



EuklidDiv[a0_, b0_] := 
  Module[{a=a0, b=b0},
    While[Not[ a*b == 0],
      Print[a, "   ", b];
      If[a >= b, a = Mod[a, b], b = Mod[b,a] ] ];
    Return[a+b] (* Einer der Summanden ist Null *) ]  



1:  EuklidSubRek[a_, b_] := 
2:    (Print[a, "   ", b]; 
3:     Which[a == 0, b, 
4:           b == 0, a, 
5:           a >= b, EuklidSubRek[a-b, b],
6:           a <  b, EuklidSubRek[a, b-a] ] ) 



EuklidDivRek[a_, b_] := 
  (Print[a, "   ", b];
   Which[a == 0, b, 
         b == 0, a, 
         a >= b, EuklidDivRek[Mod[a,b], b],
         a <  b, EuklidDivRek[a, Mod[b,a]] ] )



EuklidReg[a_, 0] = a; 
EuklidReg[a_, b_] := EuklidReg[b, Mod[a, b]]; 



euklid := proc(a0, b0)
  local a, b; 
  a:=a0; b:=b0; 
  while (not a*b = 0) do 
    print(a, b);      #  ggf. auskommentieren 
    if a>=b then a := (a mod b) 
            else b := (b mod a) fi od; 
  RETURN(a+b); 
end;



Program Euklidischer_Algorithmus;  (* Divisionsform *)

var a, b: integer;

begin
 writeln;
 writeln('Euklidischer Algorithmus - Divisionsform');
 writeln;

 write('a = '); readln(a);
 write('b = '); readln(b);

 while a*b <> 0 do    (* a ungleich b *) 
  begin
   writeln(a : 8,  b : 8);
   if a >= b    (* a groesser oder gleich b *) 
      then a := a mod b
      else b := b mod a;
  end;

 writeln('GGT(a,b) = ', a+b);  
        (* Einer der Summanden ist Null *)
end. 



Program sieve;     
        (* etwa wie in BYTE  - nur richtig *) 
const size = 1000;    (* obere Schranke fuer das zu 
                         untersuchende Intervall *) 
var count, i, k, prime: integer;  
  (* count:  Anzahl der Primzahlen, i: Laufvariable *) 
  (* prime: im Siebverfahren ermittelte Primzahl,   *) 
  (* k: Vielfaches von prime (zu streichende Zahl)  *) 

    flags: array [1..size] of integer; 

    (* flags ist ein Feld, das fuer das zu 
       untersuchende Intervall steht. 
       Es enthaelt die Komponenten 
          flags[1], flags[2], ..., flags[size-1], 
          flags[size]. 
       Jede Komponente kann den Wert 0 oder 1 haben.  
       Hat die Zelle  flags[n]  zum Schluss 
       den Inhalt 0, so soll dies bedeuten:  
       n ist keine Primzahl, hat flags[n] am Ende 
       den Wert 1, dann ist n  eine Primzahl. 

       Zu Beginn werden alle Zelleninhalte auf 1 
       gesetzt; der Vorgang des Steichens (im 
       Siebverfahren) wird so umgesetzt, dass der 
       Zelleninhalt der Nicht-Primzahlen 
       auf 0 gesetzt wird.  *) 

begin (* sieve *)
  writeln('The sieve benchmark');
  writeln(chr(7));   (* Start-Signal fuer die 
                        Zeitmessung *) 
  count := 0;        (* Initialisierung: zu Beginn 
                        keine Primzahlen *) 
  for i:=1 to size do flags[i]:=1;  
      (* alle Zellen werden auf 1 gesetzt *) 
  flags[1] := 0;  (* 1 ist keine Primzahl *) 

  for i:=2 to size do 
    if not (flags[i]=0) then  
       (* Wenn flags[i]=0 ist, dann ist die Zahl  *) 
       (* i schon vorher einmal gestrichen worden *) 
       (* i ist dann also keine Primzahl und kann *) 
       (* uebergangen werden.                     *)

       begin  
          (* flags[i] war also von Null verschieden *) 
         prime := i;          
          (* i ist also eine Primzahl               *) 
         count := count + 1;  
          (* Anzahl der Pz#en wird um eins erhoeht  *) 
         k := prime + prime;  
          (* k durchlaeuft die Vielfachen von prime *) 
          (* zunaechst Initialisierung auf den      *) 
          (* Anfangswert *) 
         while not (k > size) do 
            (* Dies ist das Verfahren des Ausnul-   *)
            (* lens (Streichens) der Vielfachen von *)
           begin               
             flags[k] := 0;      (* prime. *) 
             k := k + prime; 
                (* naechstes Vielfaches ... *)  
           end; (* ... solange k <= size    *)  
       end; 
   writeln('done: ', count, ' primes found'); 
     (* Die Anzahl der gefundenen      
        Primzahlen wird ausgedruckt *) 
   writeln(chr(7));              
     (* Schluss-Signal fuer die Zeitmessung *)
   writeln('cells and flags'); 
   for i:=1 to size do              
       writeln(i : 5, flags[i] : 5);   
       (* Die Zellen-Nummern und ihre Inhalte 
          werden ausgedruckt.  *)
   writeln('all the primes up to ', size);
   for i:=1 to size do 
     if flags[i]=1 then writeln(i);    
     (* Nur die Primzahlen  werden ausgedruckt. *)
end. 



TableForm[ 
  Table[ 
    {n, 3*2^n, N[u[3*2^n]/(2*r)], N[U[3*2^n]/(2*r)]}, 
    {n, 0, 11} ] ] 



Program Archimedes_Pi;

var r, se, su, ue, uu: real;
    i, n: longint;
    d: integer;

begin
 d := 10;  (* Nachkomma-Stellen fuer das Ausdrucken *) 
 r := 1; 
 n := 3; 
 se :=  sqrt(3);  (* Belegung mit den Anfangswerten *) 
 ue :=  3 * se;   (* d.h.:  Werte fuer das Dreieck  *) 
 su := 2 * sqrt(3); 
 uu := 3 * su; 
 writeln(0:2, n:10, ue/2:15:d, uu/2:15:d, se*se:15:d); 

 for i := 1 to 20 do   (* Iteration *)
  begin
   n  := n * 2;
   se := r*sqrt(2-2*sqrt(1-(se/(2*r))*(se/(2*r))));
   ue := n * se;
   su := se / sqrt(1 - (se/(2*r)) * (se/(2*r)) );
   uu := n * su;
   writeln(i:2,n:10,ue/2:15:d,uu/2:15:d,se*se:15:d);
  end
end.



Kapitel 4 
---------


Program fermat_test; 
var n: integer; 

 function pot(a, n: integer): longint; 
  begin 
   if n=0 then pot:=1 else pot := a * pot(a, n-1); 
  end; 

procedure fermat(n: integer); 
 var a, b, c: integer; 
 begin 
  a:=0; 
  while a < 1000 do 
   begin 
    a:= a+1; 
    for b:=1 to a do 
     for c:=1 to a+b do 
      if pot(a,n) + pot(b,n) = pot(c,n) then 
        writeln('a = ',a, '   b = ',b, '   c = ',c); 
   end; 
 end; 
begin (* Hauptprogramm Fermat-Test *) 
 writeln; writeln; writeln; 
 writeln('Fermat-Test'); 
 writeln; 
 write('Exponent: n = ');  readln(n);
 fermat(n); 
end.  (* Hauptprogramm Fermat-Test *)



Stammbruch[a_, b_] := 
  Module[{x, n, t}, 
    n=0; x=a/b; t={Floor[x]}; x=x-Floor[x]; 
    While[x>0, 
      n=n+1; 
      If[x>=(1/n), x=x-1/n; t=Append[t,1/n] ] ]; 
    Return[t] ] 



Stammbruch[a_, b_] := 
  Module[{x, n, t}, 
    n=0; x=a/b; t={Floor[x]}; x=x-Floor[x]; 
    While[x>0, 
      n=n+1; 
      If[x>=(1/n), x=x-1/n; t=Append[t,1/n] ] ]; 
    Return[t] ] 



f = proc(n) 
      if   n=1 then 1 else n * f(n-1)   fi 
    end 



f[n_] := If[n==1, 1, n*f[n-1]] 



fib[n_] := Which[n==0, 0,
                 n==1, 1,
                 n>1,  fib[n-1]+fib[n-2] ]



fibit[n_] := 
  Module[{f0=0, f1=1, f2=1, i=0}, 
    While[i<n, (i=i+1; f0=f1; f1=f2; f2=f0+f1)];
    Return[f0] ] 



hanoi[n_, start_, hilf_, ziel_] := 
  Which[ n==1, {{start, ziel}}, 
         True, Join[hanoi[n-1, start, ziel, hilf], 
                    {{start, ziel}}, 
                    hanoi[n-1, hilf, start, ziel]] ]



kleiner[TE_, L_] := 
  Which[
    L=={}, {}, 
    First[L] < TE, Prepend[kleiner[TE, 
                     Drop[L, 1]], First[L] ], 
    First[L] >= TE, kleiner[TE, Drop[L, 1]] ] 

gleich[TE_, L_] := 
  Which[
    L=={}, {}, 
    First[L] == TE, Prepend[gleich[TE, 
                      Drop[L, 1]], First[L] ],
    First[L] != TE, gleich[TE, Drop[L, 1]] ]

groesser[TE_, L_] := 
  Which[
    L=={}, {}, 
    First[L] > TE, Prepend[groesser[TE, 
                     Drop[L, 1]], First[L] ],
    First[L] <= TE, groesser[TE, Drop[L, 1]] ] 

quicksort[L_] := 
  If[L=={}, {}, 
            Join[quicksort[kleiner[First[L], L]], 
                 gleich[First[L], L],
                 quicksort[groesser[First[L], L]] ]]



sep[L_, TE_] :=    (* fuer separiere *)  
  Module[{L1=L, KL={}, GL={}, GR={} },   
         (* lokale Variablen *) 
    While[L1 != {},   (* != ... ungleich *)
      Which[
        First[L1] < TE, AppendTo[KL, First[L1]], 
        First[L1]== TE, AppendTo[GL, First[L1]],
        First[L1] > TE, AppendTo[GR, First[L1]] ];
      L1 = Rest[L1] ];
    Return[List[KL, GL, GR]] ] 

qs[L_] :=    (* quicksort unter Verwendung von sep *)
  If[L=={}, {}, 
    Module[{S=sep[L, First[L]], KL, GL, GR},   
           (* lokale Variablen *) 
      KL=First[S];  GL=First[Rest[S]];  GR=Last[S]; 
      Return[Join[qs[KL], GL, qs[GR] ] ] ] ] 



Wurzel[Baum_] := First[Baum]
Folgebaeume[Baum_] := Rest[Baum]



ts[B_] := ts1[Wurzel[B], Folgebaeume[B]]   
          (* Tiefensuche *)

ts1[W_, BB_] := 
  (Print[W];
   If[Not[BB=={}],
      ts1[Wurzel[First[BB]],
          Join[Folgebaeume[First[BB]], Rest[BB]] ] ] ) 



tsf[B_] := 
  If[B=={}, {},
     Prepend[
       Apply[Join, Map[tsf, Folgebaeume[B]]], 
                   Wurzel[B] ] ]



bs[B_] := bs1[Wurzel[B], Folgebaeume[B]]  
          (* Breitensuche *)

bs1[W_, BB_] :=  
 (Print[W]; 
  If[Not[BB=={}],
     bs1[Wurzel[First[BB]],
         Join[Rest[BB], 
              Folgebaeume[First[BB]] ] ] ] ) 



bsf[B_] := bsf1[Wurzel[B], Folgebaeume[B]] 

bsf1[W_, BB_] := 
  If[BB=={}, {W},
     Prepend[  
       bsf1[Wurzel[First[BB]], 
           Join[Rest[BB], Rest[First[BB]]] ], 
       W ] ]



Warenkorb = {{a, 40, 700}, {b, 100, 1500}, 
             {c, 80, 900}, {d, 50, 700}, 
             {e, 120, 1700}, {f, 130, 2000}, 
             {g, 30, 500} } 


Name[G_] := First[G]; 
Wert[G_] := First[Rest[G]]     (* G:  Einzel-Gut *) 
Gewicht[G_] := Last[G] 
Namen[Bag_] := Map[Name, Bag]  (* Bag: Teilmenge der 
                                       Gueter *) 
Werte[Bag_] := Map[Wert, Bag] 
Gesamtwert[Bag_] := Apply[Plus, Werte[Bag]] 
Gewichte[Bag_] := Map[Gewicht, Bag] 
Gesamtgewicht[Bag_] := Apply[Plus, Gewichte[Bag]] 
Optimum[B1_, B2_] := 
  If[Gesamtwert[B1] >= Gesamtwert[B2], B1, B2] 


Rucksack[W_, L_]:=    
  (* W:  Waren;  L:  Gewichts-Limit *) 
  Module[{G1, GR, W1, WR}, 
    (*  Print[Namen[W], "   ", L];  *)  
    If[W == {}, {}, 
    ( G1 = Gewicht[First[W]]; 
      GR = Gesamtgewicht[Rest[W]]; 
      W1 = Wert[First[W]]; 
      WR = Gesamtwert[Rest[W]]; 
      Which[ 
        G1 <= L, Optimum[ 
                   Prepend[Rucksack[Rest[W], L-G1], 
                           First[W]], 
                   Rucksack[Rest[W], L] ],
        True, Rucksack[Rest[W], L] ]) ] ]    



Program Damen;
 const max = 20;

var n, i, code, loesungszahl: integer;
    zeile_frei: array[1..max] of boolean;
    nebendiagonale_frei: array[2 .. 2*max] of boolean;
    hauptdiagonale_frei: array[-(max-1) .. (max-1)] 
                           of boolean; 
    position: array[1 .. max] of integer; 

procedure schreibeloesung;
 var k: integer;
 begin
  for k := 1 to n do write(position[k] : 4);
  writeln;
 end;

procedure plaziere_dame_in_spalte(i: integer);
 (* Ergaenzung der bisherigen (zulaessigen) Plazierung 
    in der ersten noch nicht belegten Spalte i  *) 

 var j: integer;

 begin
  for j := 1 to n do
   begin
    (*  writeln('Spalte i = ' : 11+2*i, i : 3,
                'Zeile  j = ' : 15+2*j, j : 3);  *)
    (* zur Dokumentation des Ablaufs *)
    if zeile_frei[j] and
     nebendiagonale_frei[i+j] and
     hauptdiagonale_frei[i-j] then
      begin
       position[i] := j;
       zeile_frei[j] := false;
       nebendiagonale_frei[i+j] := false;
       hauptdiagonale_frei[i-j] := false;
       if i < n
        then plaziere_dame_in_spalte(i+1)
        else
         begin
          schreibeloesung;
          loesungszahl := loesungszahl + 1;
         end;
       zeile_frei[j] := true;   
       nebendiagonale_frei[i+j] := true;  
       hauptdiagonale_frei[i-j] := true;
        (* Freigabe der Belegung *) 
        (* fuer naechstes j      *) 
      end;
   end; 
 end;

begin
 writeln('Das Damenproblem');
 repeat
  write('n = '); readln(n);
 until n <= max;
 loesungszahl := 0;
 for i:=1 to max do zeile_frei[i] := true;
 for i:=2 to 2*max do nebendiagonale_frei[i] := true;
 for i:=(max-1) downto -(max-1) do 
                hauptdiagonale_frei[i] := true;
 writeln;
 for i:= 1 to n do write(chr(ord('A')+i-1) : 4); 
 writeln;
 write('  '); for i:=1 to n do write('----'); 
 writeln;
 plaziere_dame_in_spalte(1);
 write('  '); for i:=1 to n do write('----'); 
 writeln;
 writeln;
 writeln('  Anzahl der Loesungen: ', loesungszahl);
 readln;
end.



Program sammlerproblem;
 (* Elementarst-Version: 
    Wuerfel mit 6 Seiten, ohne "Extras" *)

var a: array[1..6] of integer;
    r, i, wartezeit: integer;
    komplett: boolean;

procedure vollstaendigkeitstest;
 begin
  komplett := true; 
  for i := 1 to 6 do 
   if a[i] = 0 then komplett := false; 
 end; 

begin
 writeln; writeln; writeln;
 writeln('Sammlerproblem ');
 writeln('(Warten auf einen vollstaendigen Satz) ');
 writeln;
 randomize;
 komplett := false;
 for i := 1 to 6 do a[i] := 0;
 wartezeit := 0;
 while not komplett do
  begin
   r := random(6)+1;     
        (* Simulation des Wuerfelvorgangs *) 
   write(r, ' ');
   a[r] := a[r]+1;
   wartezeit := wartezeit+1;
   if (wartezeit mod 40 = 0) then writeln;
    vollstaendigkeitstest;
  end;
 writeln; writeln;
 writeln('Haeufigkeitsverteilung: ');
 writeln;
 for i := 1 to 6 do writeln(i : 2, a[i] : 8);
 writeln;
 writeln('Wartezeit: ', wartezeit : 8); 
end.



Program Das_Ziegenproblem;
 var wert_tuer, offen_tuer, wahl1, wahl2, 
     summe1, summe2, versuchszahl, i: integer;

 begin
  summe1 := 0;
  summe2 := 0;
  randomize;
  versuchszahl := 1000;

  for i:=1 to versuchszahl do
   begin
    wert_tuer := random(3)+1;
    wahl1 := random(3)+1;
    repeat
     offen_tuer := random(3)+1;
    until (offen_tuer <> wahl1) 
           and (offen_tuer <> wert_tuer);
    repeat
     wahl2 := random(3)+1;
    until (wahl2 <> wahl1) and (wahl2 <> offen_tuer); 
    if wahl1 = wert_tuer then summe1 := summe1+1;
    if wahl2 = wert_tuer then summe2 := summe2+1;
    writeln(i : 4, wert_tuer : 4, wahl1 : 4,
            offen_tuer : 4, wahl2 : 4, 
            summe1 : 6, summe2 : 6);
   end;
 end.



Kapitel 5 
---------


Programmversion A (rekursiv): 

Program fibonacci_zahlen_rekursiv;
var n, i: integer; 

function fib(n: integer): integer;
begin
 if (n=0) or (n=1) then fib := n 
    else fib := fib(n-1) + fib(n-2); 
end;

begin   (* Hauptprogramm *)
 writeln('Fibonacci-Zahlen (rekursiv) ');
 write('n = '); readln(n);
 writeln(fib(n));
end.



Programmversion B (iterativ): 

Program fibonacci_zahlen_iterativ;
var n: integer;

function fib(n: integer): longint;
var i, f0, f1, f2: longint;
begin
 f0 := 0; f1 := 1; f2 := 1;
 i := 0;
 while i < n do
   begin
    i := i+1;
    f0 := f1;
    f1 := f2;
    f2 := f1 + f0;
   end;
  fib := f0;
end;

begin 
  writeln('Fibonacci-Zahlen (iterativ) ');
  write('n = '); readln(n);
  writeln(fib(n));
end.



spot[a_, n_] :=   (* schnelles Potenzieren *) 
  Which[
    n==0, 1, 
    Mod[n, 2]==0, spot[a^2, n/2], 
    True, a*spot[a, n-1] ]



T[n_] :=  
  Which[
    n==0, 0, 
    Mod[n, 2]==0, T[n/2] + 1, 
    True, T[n-1] + 1] 



Basis[b_, n_]  :=  
  If[n == 0, 
       {}, 
       Append[Basis[b, Quotient[n, b]], Mod[n, b] ]  ]  



Kapitel 6
---------

FOR X = 0.95 TO 1 STEP 0.01 
PRINT X 
NEXT X 



Program integer_arithmetik_beispiel;
var a, b: integer;
begin
 a := 32767;
 b := a + 1;
 writeln(a);
 writeln(b);
end.



1:  spot[a_, n_] :=   (* schnelles Potenzieren *) 
2:    Which[
3:      n==0, 1, 
4:      Mod[n, 2]==0, spot[a^2, n/2], 
5:      True, a*spot[a, n-1] ]



Program Russische_Bauernmultiplikation; 

var x, y: integer;

function rbm(a, b: integer): integer;
var a1, b1, c: integer;
begin
 a1 := a;
 b1 := b;
 c  := 0;   (* Es ist:  c + a1*b1 = a*b *) 

  (* Als Schleifeninvariante wird im folgenden der  
     Term  c + a1*b1  verwendet.  Die Variablen a1, b1 
     und c  werden dabei so kontrolliert, dass der 
     Wert des Terms c + a1*b1 stets gleich a*b ist.  
     Im Verfahren wird b1 stets verkleinert.  
     Wenn  b1=0  ist, ist dann also  c = a*b  *) 

 while  b1 <> 0 do 
  (* Es ist:  c+a1*b1 = a*b  und  b1 <> 0 *) 
  begin 
   if (b1 mod 2 = 0)  (* d.h.: falls b1 gerade ist *) 
    then 
     begin 
      a1 := 2*a1;
      b1 := b1 div 2;
     end  (* Es ist unveraendert:  c+a1*b1 = a*b; 
             denn b1 war gerade und somit ist 
             (2*a1) * (b1 div 2) = (a1 * b1)  *)
    else   (* d.h.:  falls b1 ungerade ist *)
     begin 
      c := c + a1; 
      b1 := b1 - 1; 
     end;  (* Es ist unveraendert:  c + a1*b1 = a*b; 
              denn  c + a1 + a1*(b1-1) = c + a1*b1 *) 
  end; (* Es ist:  c = a * b; 
          denn c + a1*b1 = a*b  und  b1 = 0 *) 
  rbm := c; 
end; 

begin 
 writeln(' Russische Bauern-Multiplikation '); 
 writeln(' oder auch: aegyptische Multiplikation '); 
 writeln; 
 write('Eingabe x (ganzzahlig): ');  readln(x); 
 write('Eingabe y (ganzzahlig): ');  readln(y); 
 writeln('x * y = ' , rbm(x, y) ) 
end.



Kapitel 8
---------

in Pascal:  FUNCTION sum(a, b: INTEGER): INTEGER;
                BEGIN 
                  sum := a+b  
                END;  

in Lisp:    (DEFINE  (SUM  A  B)  
                (+  A  B) ) 

in Prolog:  sum(A, B, C)  if  C = A + B 



1:  kmw(0, _, []).  

2:  kmw(N, [A1 | AT], [A1 | XT]) if  
3:    N > 0,  
4:    N1 = N-1 and  
5:    kmw(N1, [A1 | AT], XT).  

6:  kmw(N, [_ | AT], X) if  
7:    N > 0,  
8:    kmw(N, AT, X).  



Kapitel 9
---------


StaedteListe  =  { {1, 7}, {2, 3}, {2, 12}, {3, 9}, 
   {5, 1}, {5, 12}, {7, 5}, {8, 2}, {8, 10}, {9, 6}, 
   {10, 1}, {10, 12}, {11, 9}, {12, 4}, {12, 11} } 


InitialPopulation = 
 {{8, 6, 12, 7, 13, 4, 1, 10, 5, 14, 15, 2, 11, 9, 3}, 
  {11, 2, 9, 10, 3, 8, 14, 12, 13, 1, 4, 6, 5, 15, 7}, 
  {13, 11, 12, 7, 4, 1, 6, 15, 5, 8, 2, 3, 10, 9, 14}, 
  {7, 15, 5, 14, 4, 1, 9, 11, 2, 10, 8, 3, 6, 12, 13}, 
  {10, 13, 6, 9, 4, 2, 7, 3, 8, 5, 1, 12, 14, 11, 15}, 
  {8, 11, 9, 4, 5, 2, 6, 3, 7, 12, 10, 1, 13, 15, 14}, 
  {13, 11, 1, 12, 5, 2, 9, 14, 6, 7, 15, 3, 10, 4, 8}, 
  {11, 10, 3, 6, 12, 7, 5, 9, 15, 1, 13, 14, 2, 4, 8}, 
  {9, 13, 15, 7, 3, 12, 11, 8, 6, 14, 5, 1, 2, 4, 10}, 
  {3, 12, 5, 1, 10, 2, 4, 7, 11, 14, 8, 9, 13, 15, 6}, 
  {11, 15, 2, 5, 12, 14, 7, 8, 10, 3, 13, 6, 1, 9, 4}, 
  {15, 8, 5, 9, 13, 3, 6, 12, 14, 4, 11, 2, 1, 10, 7}, 
  {2, 9, 5, 8, 14, 1, 7, 13, 11, 6, 4, 12, 10, 15, 3}, 
  {10, 3, 8, 12, 2, 6, 11, 14, 7, 9, 1, 15, 5, 4, 13}, 
  {14, 4, 9, 13, 3, 11, 2, 12, 8, 1, 6, 7, 15, 10, 5}, 
  {6, 2, 8, 5, 15, 13, 3, 9, 10, 14, 7, 4, 1, 12, 11}, 
  {15, 11, 14, 13, 7, 1, 6, 8, 3, 4, 10, 2, 5, 9, 12}, 
  {6, 8, 9, 15, 7, 1, 5, 11, 4, 3, 10, 12, 13, 14, 2}, 
  {10, 12, 2, 14, 9, 6, 5, 1, 8, 7, 15, 11, 4, 13, 3}, 
  {13, 4, 8, 12, 10, 5, 3, 15, 7, 14, 2, 1, 6, 11, 9}, 
  {3, 14, 6, 7, 2, 1, 4, 10, 5, 13, 11, 12, 9, 15, 8}, 
  {1, 7, 6, 5, 3, 2, 4, 14, 13, 12, 8, 15, 9, 10, 11}, 
  {13, 6, 12, 11, 8, 9, 4, 7, 1, 2, 14, 3, 5, 10, 15}, 
  {3, 5, 4, 10, 9, 2, 14, 7, 6, 8, 12, 15, 13, 1, 11}, 
  {12, 8, 13, 5, 9, 1, 6, 14, 10, 11, 2, 7, 15, 3, 4}} 


Distanz[S1_, S2_] :=  
  (* Abstand zwischen den Staedten S1 und S2 *) 
  Sqrt[(S1[[1]]-S2[[1]])^2 + (S1[[2]]-S2[[2]])^2] //N 


Kosten[Rundreise_] :=         
  (* Kosten der Rundreise bezueglich der 
     (globalen) StaedteListe  *) 
  (Sum[Distanz[StaedteListe[[Rundreise[[i]] ]], 
               StaedteListe[[Rundreise[[i+1]]] ]], 
         {i, 1, Length[Rundreise]-1} ] 
    + Distanz[StaedteListe[[Last[Rundreise]]], 
              StaedteListe[[First[Rundreise]]]]) //N 


BesteLoesung[Population_] :=  
  Module[{KL, BestesElement, PosBest},
         (* KL:  Kosten-Liste 
            PosBest: Position des besten Elements *)
    KL = Map[Kosten, Population];   
    BestesElement = Min[KL];
    PosBest = First[ 
                First[Position[KL, BestesElement]]]; 
    Return[Population[[PosBest]]] ] 


Selektion[Pop_] :=
  Module[{NeuPop={BesteLoesung[Pop]}},
    (* Diese Initialisierung dient nur dazu, den 
       Selektionsdruck zu erhoehen *)
    For[j=1, j<Length[Pop], j=j+1,
      r1 = Random[Integer, {1, Length[Pop]} ];   
      r2 = Random[Integer, {1, Length[Pop]} ];
           (* Zwei Zufallszahlen werden ausgewaehlt *)
      If[Kosten[Pop[[r1]]] <= Kosten[Pop[[r2]]],
           NeuPop = Append[NeuPop, Pop[[r1]]],
           NeuPop = Append[NeuPop, Pop[[r2]]] ] ];
             (* Die beiden zufaellig ausgewaehlten 
                Loesungsvorschlaege werden verglichen 
                und der mit der kuerzeren Tour  
                wird ausgewaehlt, d.h. zu NeuPop 
                hinzugefuegt *)  
    Return[NeuPop] ]


Crossover[Pop_, CW_] :=
  Module[{NeuPop={}, 
          Schnitt1, Schnitt2, Segment1, Segment2,
          kind1, kind2 },
    For[j=1, j<Length[Pop], j=j+2, 
      elt1 = Pop[[j]]; 
      elt2 = Pop[[j+1]]; 
        (* Das Elternpaar wird aus der Population 
           ausgewaehlt *)
      If[Random[Real] < CW, 
        Schnitt1 = Random[Integer, {1, Length[elt1]}];
        Schnitt2 = Random[Integer, {Schnitt1, 
                                       Length[elt1]}]; 
          (* Ein Segment wird zufaellig ausgewaehlt *) 
        Segment1 = Take[elt1, {Schnitt1, Schnitt2}]; 
        Segment2 = Take[elt2, {Schnitt1, Schnitt2}]; 
          (* Diese Segmente werden bei den Eltern 
             ausgeschnitten *)
        kind1={}; kind2={};
          (* Die Kinder werden initialisiert *)
        For[i=1, i<=Length[elt2], i=i+1,
          If[FreeQ[Segment1, elt2[[i]]],
               kind1 = Append[kind1, elt2[[i]]] ]; 
          If[FreeQ[Segment2, elt1[[i]]],
               kind2 = Append[kind2, elt1[[i]]] ] ];
               (* Alle Werte des elt2-Segments werden 
                  bei elt1 geloescht.  
                  Alle Werte des elt1-Segments werden 
                  bei elt2 geloescht. 
                  Die uebrigbleibenden Listen sind 
                  kind1 und kind2 . 
                  Dies kann leider nicht mit der 
                  Funktion "Complement" gemacht 
                  werden, da Complement die 
                  Ausgabeliste sortiert  *)
        kind1 = Flatten[
                  Insert[kind1, Segment1, Schnitt1]];  
        kind2 = Flatten[
                  Insert[kind2, Segment2, Schnitt1]];
          (* Die Segmente der Eltern werden bei kind1 
             und kind2 an ihren urspruenglichen 
             Positionen wieder eingesetzt. *) 
        NeuPop = Join[NeuPop, {kind1}, {kind2}], 
          (* Die Kinder werden in die neue Population 
             eingefuegt *)
        NeuPop = Join[NeuPop, {elt1}, {elt2}] ] ];
          (* Falls nicht gepaart wurde, werden die 
             Eltern unveraendert uebernommen *)
    Return[NeuPop] ]; 


Mutation[Population_, MW_] :=
  Module[{Pop=Population, r1, r2, Individuum, 
          Hilfsvariable}, 
    For[i=1, i<=Length[Pop], i=i+1, 
      If[Random[Real] < MW, 
           (* Der Zufall hat entschieden, daß das 
              Element Nr. i mutiert wird *)
         Individuum = Pop[[i]];
         r1 = Random[
                Integer, {1, Length[Individuum]}];
         r2 = Random[
                Integer, {1, Length[Individuum]}];
            (* Zwei Zufallszahlen werden ausgelost *)
         Hilfsvariable = Individuum[[r1]]; 
         Individuum[[r1]] = Individuum[[r2]]; 
         Individuum[[r2]] = Hilfsvariable; 
           (* Die Staedte an den Positionen r1 und r2 
              werden ausgetauscht *)
         Pop[[i]] = Individuum ] ];
    Return[Pop]]



TravelingSalesman[CW_, MW_, MaxGen_] := 
  (* Der Modul verwendet die globalen Variablen 
     StaedteListe und InitialPopulation;  
     die formalen Parameter haben folgende Bedeutung: 
       CW: Crossoverwahrscheinlichkeit
       MW: Mutationswahrscheinlichkeit 
       MaxGen: maximale Anzahl an Generationen  *)
  Module[{P = InitialPopulation, BL}, 
    For[n=1, n<=MaxGen, n=n+1, 
        P = Selektion[P]; 
        P = Crossover[P, CW]; 
        P = Mutation[P, MW]; 
        BL = BesteLoesung[P]; 
        Print[n, ":   ", BL, "   ", Kosten[BL]] ]; 
    Return[P] ] 



GewMat = Sum[Table[ms[[i,j]] * ms[[i,k]],
              {j, Length[ms[[1]]]}, 
              {k, Length[ms[[1]]]}], 
          {i, 1, Length[ms]} ]; 
          (* ms ist der Mustersatz, ms[[5,3]] greift 
             z.B. auf das dritte Element des fuenften 
             Musters zu *) 
For[i=1, i<=Length[ms[[1]]], i=i+1, GewMat[[i,i]]=0]; 
  (* Die Gewichte w[[i,i]] werden auf Null gesetzt *)



Mustererkennung[Eingabemuster_, Block_] := 
 Module[{M = Eingabemuster, B = Block, Zustandalt}, 
   Zustandalt = M; 
   ListDensityPlot[Reverse[Partition[Zustandalt, B]]]; 
    (* Das Muster wird in seinem derzeitigen Zustand 
       auf dem Bildschirm, geteilt in Bloecke der Laenge 
       B, ausgegeben.*) 
   Zustandneu = 
    Table[
     Signum[
      Sum[GewMat[[i,j]] * Zustandalt[[j]], 
       {j, 1, Length[M]}]], 
     {i, 1, Length[M]} ]; 
  (* Entsprechend der Aktivierungsfunktion Signum wird 
     der neue Netzzustand berechnet.  *) 
   While[Not[Zustandalt = Zustandneu], 
    Zustandalt = Zustandneu; 
    ListDensityPlot[
     Reverse[Partition[Zustandneu, B]] ]; 
    Zustandneu = 
     Table[
      Signum[ 
       Sum[GewMat[[i,j]] * Zustandalt[[j]], 
        {j, 1, Length[M]}]], 
      {i, 1, Length[M]} ] ] 
     (* Waehrend alter und neuer Netzzustand nicht 
        uebereinstimmen, wird der neue Netzzustand zum 
        alten und der Prozess beginnt wieder von 
        vorn *) 
   Return[Zustandneu] ]; 



Signum[x_] := If[x >= 0, 1, -1]; 



Staedteliste = {{0.5, 4}, {3, 0.9}, {4, 4}, {5, 1}, {0.2, 0.3}, {6, 3}, {2.5, 2}, {3, 3}, {4, 2}, {1, 2}} 



TSPNN[SL_, Durchlaeufe_, Lernrate_] := 
 Module[{Sz, Nz, Nb, Signal, AbstandsL, MinAbst, 
         ErrZent}, 
  Sz = Length[SL];     (* Anzahl der Staedte *)
  Nz = 3*Sz;           (* Anzahl der Neuronen *)
  Nb = Table[{N[2*Sin[i*360/Nz Degree]]+5, 
              N[2*Cos[i*360/Nz Degree]]+5}, {i, Nz}];
   (* Startanordnung des Neuronenbandes (Kreis) *)
  For[j=0, j <= Durchlaeufe, j=j+1, 
   If[Mod[j, 200] == 0, GraphikModul[SL, Nb] ]; 
   Signal = Random[Integer, {1, Sz}]; 
   AbstandsL = 
    Table[N[Sqrt[(SL[[Signal, 1]] - Nb[[i, 1]])^2+ 
                 (SL[[Signal, 2]] - Nb[[i, 2]])^2]], 
     {i, Nz}]; 
     (* Abstandsliste der Neuronen zum Signal *)
   MinAbst = Min[AbstandsL]; 
   ErrZent = 
    First[First[Position[AbstandsL, MinAbst]]];
    (* Neuron mit dem kleinsten Abstand zum Signal *)  
   Nb = 
    Nb + 
     Table[
      Lernrate 
       * N[Exp[-((Min[Abs[ErrZent-i], 
                     Abs[ErrZent + Abs[Nz-i]] ])^2) / 
             (2 * (50 * (0.02^(j/Durchlaeufe)))^2) ] ] 
       * (SL[[Signal]] - Nb[[i]]), 
      {i, Nz}] 
      (* Berechnung der Positionsveraenderung der 
         Neuronen *) 
  ] ];



GraphikModul[Stl_, Neub_] := 
 Module[{Staedte, Abschluss, Ad1, Ad2}, 
  Staedte = Table[Point[Stl[[i]]],{i, Length[Stl]}]; 
  Abschluss = Append[Neub,Neub[[1]]]; 
  Ad1 = ListPlot[Abschluss, PlotJoined->True];
  Ad2 = Show[Ad1,Graphics[{PointSize[0.01],Staedte}]] ] 



##########################################################################
Ende
##########################################################################