{ Start of file Joseph3.Pas ************************************************}
{$A+,B-,D+,E+,F-,I+,L+,N+,O-,R-,S+,V+}
{$M 16384,0,655360}
Program Joseph3; { The Flavius Josephus permutation problem }
{ Searches for permutations with many fixed elements }
uses Crt;
const
Name = 'Joseph3 - The Flavius Josephus Permutation Problem';
Version = 'Version 1.10, last revised: 1994-04-23, 0600 hours';
Author = 'Copyright (c) 1981-1994 by author: Harry J. Smith,';
Address = '19628 Via Monte Dr., Saratoga CA 95070. All rights reserved.';
{***************************************************************************}
{ Challenge given in REC Jan/Feb/Mar 1991 on page 24.
"The Thousand Roman Slaves" suggested by Steve Wagler
Original Problem: 1000 slaves in a circle, numbered 1 to 1000, are all to
be shot except one lucky survivor. The order of shooting is 1, 3, 5, etc.,
always alternating, and always immediately removing the fallen bodies. Once
a body has fallen, it is no longer considered part of the circle for
purposes of future counting and alternation. Example, n=6: Shoot 1,3,5,2,6;
4 survives.
The General Problem: There is an ordered set of n objects arranged in a
circle with object i (1 <= i <= n) in position i. All n objects are
selected and removed in a certain order and placed in a new circle with
the new position number k beings the order of selection. Object f is
selected first. After each selection, m minus 1 of the remaining objects
following the one removed are skipped and the next object is then
selected. We are interested in the nature of the permutation generated by
this process, its fixed elements, and in particular the original position
L of the last object selected. Note that m and f can be as low as 1 and
can be larger than n.
See Knuth, The Art of Computer Programming, Vol. 1, Pages 158-159, 181,
516, 521 and Vol. 3, Pages 18-19, 579.
Examples:
--------------------
n = 25, m = 25, f = 1: 9 last! 6 fixed: 1, 2, 8, 13, 14, 23.
n = 59, m = 33, f = 22: 14 last! 7 fixed: 9, 15, 19, 26, 28, 45, 58.
n = 90, m = 42, f = 50: 90 last! 8 fixed: 2, 16, 23, 51, 58, 61, 69, 90.
n = 232, m = 189, f = 88: 114 last! 9 fixed: 3, 39, 64, 85, 112, 133,
159, 165, 206.
n = 1000, m = 54, f = 965: 694 last! 8 fixed: 39, 355, 435, 541, 558,
708, 807, 996.
--------------------
}
{ Developed in Turbo Pascal 6.0 }
const
Maxn = 16000; { The maximum total number of objects in the circle }
var
A : array[1..Maxn] of Integer; { Working array of objects }
{ Ends up with A[i] = when object i was selected }
B : array[1..Maxn] of Integer; { Record of objects selected }
{ Ends up with B[i] = object # selected on k'th selection }
Ch : Char; { Character input by ReadKey }
i : Integer; { Utility index }
n : Integer; { The total number of objects in the circle to start with }
n1 : Integer; { Lower limit to search for n }
n2 : Integer; { Upper limit to search for n }
r : Integer; { Remaining number of objects in the circle }
m : Integer; { m for selecting every m'th object }
m1 : Integer; { Lower limit to search for m }
m2 : Integer; { Upper limit to search for m }
k : Integer; { Number of objects selected (killed) so far }
f : Integer; { # of first object to be selected }
f1 : Integer; { Lower limit to search for f }
f2 : Integer; { Upper limit to search for f }
c : Integer; { Index to current object being scanned }
p : Integer; { Index to previous object }
s : Integer; { Number of fixed (stationary) elements }
Ls : Integer; { Largest s found }
{--------------------------------------}
procedure WriteIn( Ind : Integer; St : String); { Write a line indented }
begin
for i:= 1 to Ind do Write(' ');
WriteLn( St);
end; { WriteIn }
{--------------------------------------}
procedure Story; { Tell the story of what the Josephus problem is }
begin
WriteIn( 4,
'The General Problem: There is an ordered set of n objects arranged in a'
); WriteIn( 4,
'circle with object i (1 <= i <= n) in position i. All n objects are'
); WriteIn( 4,
'selected and removed in a certain order and placed in a new circle with'
); WriteIn( 4,
'the new position number k beings the order of selection. Object f is'
); WriteIn( 4,
'selected first. After each selection, m minus 1 of the remaining objects'
); WriteIn( 4,
'following the one removed are skipped and the next object is then'
); WriteIn( 4,
'selected. We are interested in the nature of the permutation generated by'
); WriteIn( 4,
'this process, its fixed elements, and in particular the original position'
); WriteIn( 4,
'L of the last object selected. Note that m and f can be as low as 1 and'
); WriteIn( 4,
'can be larger than n.'
); WriteLn;
end; { Story }
{--------------------------------------}
procedure WriteC( St : String); { Write a line centered }
begin
for i:= 1 to ((78 - Length( St)) div 2) do Write(' ');
WriteLn( St);
end; { WriteIn }
{--------------------------------------}
procedure Init; { Initialize program }
begin
TextBackground( Blue);
TextColor( Yellow);
ClrScr;
WriteLn;
WriteC( Name);
WriteC( Version);
WriteC( Author);
WriteC( Address);
WriteLn;
end; { Init }
{--------------------------------------}
procedure TestIt; { Halt the run if ESC typed }
begin
while Keypressed do Ch:= ReadKey;
if Ord( Ch) = 27 then begin
Halt(0);
end;
end; { TestIt }
{--------------------------------------}
procedure Pause; { Pause and allow operator to escape }
begin
Write('Type any key to continue, or Esc to quit ... ');
if KeyPressed then TestIt; { Strip keyboard input }
Ch:= ReadKey;
if Ord( Ch) = 27 then Halt(0);
WriteLn; WriteLn;
end; { Pause }
{--------------------------------------}
procedure ReadInt( Mess : String; Min, Max, Nom : Integer;
var I : Integer); { Read in an integer from keyboard }
var
St : String[255];
Stat : Integer;
LI : LongInt;
begin
repeat
WriteLn( Mess);
Write(' [', Min, ', ', Max, '] (ENTER => ', Nom, '): ');
ReadLn( St);
Val( St, LI, Stat);
until ((Stat = 0) and (LI >= Min) and (LI <= Max)) or ( Length( St) = 0);
if Length( St) = 0 then LI:= Nom;
I:= LI;
WriteLn('Input = ', I);
WriteLn;
end; { ReadInt }
{--------------------------------------}
procedure ReportResults; { Generate normal output }
const
MaxS = 100; { Up to 100 saved fixed elements }
var
X : array[1..MaxS] of Integer; { Saved fixed elements }
nx : Integer; { Number of saves fixed elements }
begin
s:= 0; { Count number of fixed elements }
for i:= 1 to n do
if B[i] = i then begin
Inc( s);
if s <= MaxS then X[s]:= i; { Save up to MaxS fixed elements }
end;
if s < Ls then exit;
Ls:= s;
Write('n = ', n, ', m = ', m, ', f = ', f);
if f > n then Write(' => ', 1 + (f-1) mod n);
Write(': ', B[n], ' last! ');
Write(s, ' fixed');
if s > 0 then begin
nx:= s;
if nx > MaxS then nx:= MaxS;
Write(': ');
for i:= 1 to nx do begin
Write( X[i]);
if i <> nx then Write(', ');
end;
end;
if s > nx then Write(', ... ');
WriteLn('.');
end; { ReportResults }
{--------------------------------------}
procedure DoIt;
begin
for i:= 1 to n-1 do
A[i]:= i+1; { Set position i to point to next position }
A[n]:= 1;
p:= 1 + ((f mod n) + n - 2) mod n; { Init previous position based on f }
k:= 1; r:= n;
repeat
if (1 < k) and (k < n) then { If not first or last selection }
for i:= 1 to ((m-1) mod r) do { Move m-1 positions (zero OK) }
p:= A[p];
c:= A[p]; { Update current position }
B[k]:= c; c:= A[c]; { Select the object at c }
A[ A[p]]:= k; { Save execution order }
Inc( k); Dec( r);
A[p]:= c; { Re-link circular chain of pointers }
until k > n; { Until all are selected }
A[c]:= n; { A[c] was clobbered, so restore it }
end; { DoIt }
{--------------------------------------}
begin { Joseph3 }
Init; { Initialize }
Story; { Tell the story of what the Josephus problem is }
WriteLn(
' This program searches for permutations with many fixed elements.');
WriteLn;
Pause; { Pause and allow operator to escape }
repeat { Start a new problem }
{ Read in n, m, and f }
ReadInt('Input n, the total number of objects', 1, Maxn, 1000, n);
ReadInt('Input m, positions to move for each choice', 1, MaxInt, 2, m);
ReadInt('Input f, object number to select first', 1, MaxInt, 1, f);
Ls:= 0;
repeat { for n:= 1 to Maxn }
repeat { for m:= 2 to n+2 }
repeat { for f:= 1 to n }
DoIt;
if (f mod 100) = 0 then begin
Write('n = ', n, ', m = ', m, ', f = ', f, ' ');
GoToXY( 1, WhereY);
end;
if KeyPressed then TestIt; { Abort run if Esc typed }
ReportResults; { Generate normal output }
Inc( f);
until f > n;
f:= 1; Inc( m);
until m > n+2;
m:= 2; Inc( n);
until n > Maxn;
Pause; { Pause and allow operator to escape }
until False; { Loop back for next problem }
end. { Joseph3 }
{ End of file Joseph3.Pas **************************************************}
times since October 20, 2004.