home *** CD-ROM | disk | FTP | other *** search
/ 64'er / 64ER_CD.iso / 86xx / 8605.d64 / joseph < prev    next >
Text File  |  1995-03-30  |  783b  |  35 lines
  1. program joseph;
  2. const anzahl=41;
  3.       rest=2;
  4.       abzaehl=3;
  5. var i,j,k:integer;
  6.     reihe:set of 1..anzahl;
  7. begin
  8. (*initialisieren*)
  9.   reihe:=[1..anzahl];
  10.  i:=anzahl;
  11.  k:=anzahl;
  12.  (*wiederhole bis nur noch 2
  13.    elemente in der reihe sind
  14.    diese geben die gesuchten
  15.    positionen an *)
  16.  while k>rest do
  17.    begin
  18.     for j:= 1 to abzaehl do
  19.        repeat
  20.         if i<anzahl then i:=i+1
  21.           else i:=1;
  22.        until i in reihe;
  23.  (* der jeweils dritte wird gestrichen *)
  24.     reihe:=reihe-[i];
  25.     k:=0;
  26.  (* jetzt wird festgestellt, wieviele elemente die
  27.     menge noch enthaelt *)
  28.     for j:= 1 to anzahl do
  29.       if j in reihe then k:=k+1;
  30.   end; (* ende der while-schleife*)
  31.    for j:= 1 to anzahl do
  32.      if j in reihe then
  33.         writeln('gesuchte positionnr.: ',j)
  34. end.
  35.