home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1989 / 07 / beilage / permber.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-04-11  |  7.3 KB  |  230 lines
  1.  
  2. PROGRAM permutationsberechnungen;
  3. {-------------------------------------------------}
  4. { Permutationsberechnungen  (Turbo Pascal 3.0)    }
  5. {                                                 }
  6. { (C) 1989 TOOLBOX & Jörg Müller                  }
  7. {-------------------------------------------------}
  8.  
  9. TYPE   strng = STRING[80];
  10.  
  11. VAR  txt,tem : strng;
  12.           ch : CHAR;
  13.           nr : REAL;
  14.    step_mode : BOOLEAN;
  15.  
  16. {-------------------------------------------------}
  17. PROCEDURE wait_of_return;       {wartet auf RETURN}
  18. BEGIN
  19.   WRITE('RETURN drücken ');  READLN;  CLRSCR;
  20. END;
  21. {-------------------------------------------------}
  22. FUNCTION left(txt : strng;  m : BYTE):strng;
  23.                     { liefert von links m Zeichen }
  24.  
  25. BEGIN
  26.   left:=COPY(txt,1,m);
  27. END;
  28. {-------------------------------------------------}
  29. FUNCTION right(txt : strng;  m : BYTE):strng;
  30.                      { liefert von rechts m Chars }
  31. VAR    pos : BYTE;
  32. BEGIN
  33.   pos:=LENGTH(txt)-m+1;
  34.   IF LENGTH(txt)-m+1<1 THEN right:=txt
  35.            ELSE right:=COPY(txt,LENGTH(txt)-m+1,m);
  36. END;
  37. {-------------------------------------------------}
  38. FUNCTION fak(n : BYTE):REAL;   { Fakultätsfunkton }
  39. VAR     help : REAL;   i : INTEGER;
  40. BEGIN
  41.   help:=1.0; FOR i:=2 TO n DO help:=help*i;
  42.   fak:=help;
  43. END;
  44. {-------------------------------------------------}
  45.  
  46. {=================================================}
  47. PROCEDURE nte_permut(txt:strng; nr:REAL;
  48.           step_mode:BOOLEAN; VAR tem:strng);
  49.   {-----------------------------------------------}
  50.   { Ermittlung des Wortes, das bei einer          }
  51.   { lexikographisch geordneten Permutation        }
  52.   { Eingabeparameter :                            }
  53.   { txt: Zeichenkette, in der die Zeichen, die    }
  54.   {     permutiert werden sollen, in sortierter   }
  55.   {     Reihenfolge stehen müssen.                }
  56.   { nr: Enthält die Nummer des Permutationswortes,}
  57.   {     das ermittelt werden soll.                }
  58.   { step_mode: bei TRUE : Ausgabe von Zwischen-   }
  59.   {     ergebnissen                               }
  60.   { FALSE : keine Ausgabe von Zwischenergebnissen.}
  61.   { Rückgabeparameter :                           }
  62.   { tem: Das ermittelte Permutationswort.         }
  63. {-------------------------------------------------}
  64. CONST    eps = 1e-8;
  65. VAR      n,i,j,k : BYTE;
  66.          help    : CHAR;
  67.          alt,neu : REAL;
  68. BEGIN
  69.   n:=LENGTH(txt);
  70.   FOR i:=1 TO (n Div 2) DO BEGIN       { umdrehen }
  71.     help:=txt[i];  txt[i]:=txt[n-i+1];
  72.     txt[n-i+1]:=help;
  73.   END;
  74.   alt:=0.0;
  75.   neu:=0.0;
  76.   i:=0;
  77.   REPEAT
  78.     i:=i+1;
  79.     help:=txt[n];
  80.                       { rotieren: letzte --> i.te }
  81.     FOR k:=n-1 DOWNTO i DO txt[k+1]:=txt[k];
  82.     txt[i]:=help;
  83.     j:=0;
  84.     REPEAT
  85.       j:=j+1;
  86.       IF j>1 THEN BEGIN
  87.         help:=txt[i];  txt[i]:=txt[n+2-j];
  88.         txt[n+2-j]:=help;
  89.                                        { tauschen }
  90.       END;
  91.       alt:=neu;
  92.       neu:=neu+fak(n-i);
  93.       IF step_mode THEN WRITELN(neu:5:0,' >',txt);
  94.     UNTIL neu>=nr;
  95.     IF Abs(neu-nr)<eps THEN alt:=neu;
  96.     neu:=alt;
  97.   UNTIL (Abs(alt-nr)<eps) OR (i=n);
  98.   tem:=txt;
  99. END;
  100. {=================================================}
  101. FUNCTION num_permut(txt,tem:strng):REAL;
  102.   {-----------------------------------------------}
  103.   { Ermittlung der Nummer (Stelle) an der das Per-}
  104.   { mutationswort "TXT" bei einer lexikographisch }
  105.   { geordneten Permutation steht.                 }
  106.   { Eingabeparameter :                            }
  107.   { txt : Zeichenkette, die das Permutationswort  }
  108.   {       enthält, dessen Nummer ermittelt wird.  }
  109.   { tem : Zeichenkette, die die Zeichen von "TXT" }
  110.   {       in sortierter Reihenfolge enthält.      }
  111.   { Rückgabeparameter :                           }
  112.   { Funktionswert : Nummer der Permutation        }
  113.   {-----------------------------------------------}
  114. VAR     n,i,j : BYTE;
  115.         help  : CHAR;
  116.         nr    : REAL;
  117. BEGIN
  118.   n:=LENGTH(txt);
  119.   nr:=0.0;
  120.   FOR i:=1 TO n DO BEGIN
  121.     help:=txt[i];
  122.     j:=0;
  123.     REPEAT
  124.       j:=j+1;
  125.     UNTIL tem[j]=help;
  126.     tem:=left(tem,j-1)+right(tem,n-i-j+1);
  127.     nr:=nr+(j-1)*fak(n-i);
  128.   END; { for }
  129.   num_permut:=nr+1.0;
  130. END;
  131. {=================================================}
  132.  
  133. {-------------------------------------------------}
  134. PROCEDURE sort_strng(txt:strng; VAR tem:strng);
  135.   {-----------------------------------------------}
  136. { Sortiert die Zeichen in "txt" mit aufsteigender }
  137. { Reihenfolge und gibt diese mit "tem" als        }
  138. { Rückgabeparameter zurück.                       }
  139.  
  140. {-------------------------------------------------}
  141. VAR      n,i,j : BYTE;
  142.          help  : CHAR;
  143.          f     : BOOLEAN;
  144. BEGIN
  145.   n:=LENGTH(txt);
  146.   FOR i:=1 TO n DO BEGIN
  147.     help:=txt[i];
  148.     j:=0;
  149.     IF i<2 THEN tem:=help
  150.     ELSE BEGIN
  151.       REPEAT
  152.         j:=j+1;
  153.         f:=tem[j]>help;
  154.       UNTIL f OR (j>=i-1);
  155.       IF f THEN tem:=left(tem,j-1)+help
  156.                      +right(tem,i-j)
  157.            ELSE tem:=tem+help;
  158.     END;
  159.   END; { for }
  160. END;
  161. {-------------------------------------------------}
  162. PROCEDURE get_perm_strng(VAR txt,tem:strng);
  163.                    { Zeichen einlesen & sortieren }
  164. BEGIN
  165.   CLRSCR;
  166.   WRITELN('Geben Sie die Zeichen (hinter ">") an,
  167.            die im Permutationswort ');
  168.   WRITELN;
  169.   WRITELN('enthalten sein sollen.');  WRITELN;
  170.   WRITELN;
  171.   WRITE('>');  READLN(txt);
  172.   sort_strng(txt,tem);
  173.   WRITELN;  WRITELN;  WRITELN;
  174.   WRITELN('Da beide Routinen die Zeichen in');
  175.   WRITELN('sortierter Folge benötigen, habe');
  176.   WRITELN('ich Ihre Eingabe sortiert. Hier sind');
  177.   WRITELN('Ihre Zeichen in sortierter');
  178.   WRITELN('Reihenfolge !!!');  WRITELN;  WRITELN;
  179.   WRITE('>');  WRITELN(tem);   WRITELN;  WRITELN;
  180.   wait_of_return;
  181. END;
  182. {-------------------------------------------------}
  183.  
  184. BEGIN           (* Hauptprogramm *)
  185.   REPEAT
  186.     CLRSCR;
  187.     WRITELN('Permutationsberechnungen : (es geht,
  188.             'immer um lexikographisch ,
  189.             '-------------------------- ,
  190.             'angeordnete Permutationen)'); WRITELN;
  191.     WRITELN(' (1) Berechnen der Nummer einer,
  192.             ' Permutation');
  193.     WRITELN(' (2) Berechnen der Permutation,
  194.             ' mit der Nummer NR');
  195.     WRITELN;
  196.     WRITELN(' (0) Programmende');  WRITELN;
  197.     WRITELN;
  198.     WRITE('Ihre Wahl >');
  199.     REPEAT  READ(kbd,ch);  UNTIL ch IN ['0'..'2'];
  200.     CASE ch OF
  201.       '1' : BEGIN
  202.               get_perm_strng(txt,tem);
  203.               WRITELN('>',txt);  WRITELN;  WRITELN;
  204.               WRITELN('Dies ist die,
  205.                       ',num_permut(txt,tem):7:0,
  206.                       '.te Permutation');
  207.               WRITELN;  WRITELN;  wait_of_return;
  208.             END;
  209.       '2' : BEGIN
  210.               get_perm_strng(txt,tem);
  211.               WRITELN('>',tem);  WRITELN;  WRITELN;
  212.               WRITE('Die wievielte Permutation,
  213.                     'wollen Sie haben  Nr : ');
  214.               READLN(nr);  WRITELN;
  215.               WRITE('Schritt-Modus (J/N) : ');
  216.               REPEAT  READ(kbd,ch);
  217.                      UNTIL UPCASE(ch) IN ['J','N'];
  218.               WRITELN(ch);  WRITELN;
  219.               step_mode:=(UPCASE(ch)='J');
  220.               nte_permut(tem,nr,step_mode,txt);
  221.               WRITELN;  WRITELN;  WRITELN;
  222.               WRITELN('Ergebnis : ');  WRITELN;
  223.               WRITELN('>',txt);
  224.               WRITELN;  WRITELN;  wait_of_return;
  225.             END;
  226.     END;
  227.   UNTIL ch='0';
  228.   CLRSCR;
  229. END.
  230.