Joseph1.Pas Program Listing




{ Start of file Joseph1.Pas ************************************************}

{$A+,B-,D+,E+,F-,I+,L+,N+,O-,R-,S+,V+}
{$M 16384,0,655360}

Program Joseph1; { The Flavius Josephus permutation problem }
                 { Uses the mod function to speed up the solution }

uses Crt;

const
  Name    = 'Joseph1 - 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 = 1000,  m = 2,  f = 1:  Object 976 was selected last!
  There is 1 fixed element:  1.
--------------------
  n = 1000,  m = 32767,  f = 32767 => 767:  Object 481 was selected last!
  There are 5 fixed elements:  41, 178, 619, 710, 718.
--------------------
  n = 1000,  m = 1,  f = 1:  Object 1000 was selected last!
  There are 1000 fixed elements:  1, 2, 3, 4, 5, ... .
--------------------
  Execution order, when object i was selected:
  5 4 6 1 3 8 7 2
  Order of execution, object # selected on k'th selection:
  4 8 5 2 1 3 7 6
  The resulting permutation expressed in cyclic notation:
  (1, 5, 3, 6, 8, 2, 4)(7)

  n = 8,  m = 4,  f = 4:  Object 6 was selected last!
  There is 1 fixed element:  7.
--------------------
}

{ 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 }
  r    : Integer; { Remaining number of objects in the circle }
  m    : Integer; { m for selecting every m'th object }
  k    : Integer; { Number of objects selected (killed) so far }
  f    : Integer; { # of first object to be selected }
  c    : Integer; { Index to current object being scanned }
  p    : Integer; { Index to previous object }
  s    : Integer; { Number of fixed (stationary) elements }
  MaxD : Integer; { Max n for which detailed output is given }

{--------------------------------------}
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 ReportDetails; { Generate detailed output }
begin
  WriteLn('Execution order, when object i was selected:');
  for i:= 1 to n do  Write( A[i], ' ');
  WriteLn;  WriteLn;
  WriteLn('Order of execution, object # selected on k''th selection:');
  for i:= 1 to n do  Write( B[i], ' ');
  WriteLn;  WriteLn;
  WriteLn('The resulting permutation expressed in cyclic notation:');
  p:= B[1];  c:= 1;
  repeat
    Write('(');
    repeat
      if c <> 0 then begin
        Write( c);
        A[p]:= 0;  p:= c;
      end;
      c:= A[p];
      if c <> 0 then Write(', ');
    until c = 0;
    Write(')');
    i:= 0;
    repeat
      Inc( i);  c:= A[i];
    until (c <> 0) or (i = n);
    if c<> 0 then  p:= B[c];
  until c = 0;
  WriteLn;  WriteLn;
end; { ReportDetails }

{--------------------------------------}
procedure ReportResults; { Generate normal output }
const
  MaxS = 5;  { Up to 5 saved fixed elements }
var
  X   : array[1..MaxS] of Integer; { Saved fixed elements }
  nx  : Integer;   { Number of saves fixed elements }
  Ss  : String[1]; { String 's' or '' if s = 1 }
  Sis : String[3]; { String 'are' or 'is' if s = 1 }
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 = 1 then begin               { Setup is or are }
    Ss:= '';  Sis:= 'is';
  end else begin
    Ss:= 's';  Sis:= 'are';
  end;
  WriteLn('The fixed element'+Ss+' in this Josephus permutation '+Sis+':');
  for i:= 1 to n do begin
    if B[i] = i then begin          { Output fixed elements }
      Write( i, ' ');
      if KeyPressed then  TestIt;   { Abort run if Esc typed }
    end;
  end;
  if s = 0 then  Write('None!');
  WriteLn;  WriteLn;
  Write('n = ', n, ',  m = ', m, ',  f = ', f);
  if f > n then  Write(' => ', 1 + (f-1) mod n);
  WriteLn(':  Object ', B[n], ' was selected last!');
  Write('There '+Sis+' ', s, ' fixed element'+Ss);
  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('.');  WriteLn;
end; { ReportResults }

{--------------------------------------}
begin { Joseph1 }
  Init;                    { Initialize }
  Story;                   { Tell the story of what the Josephus problem is }
  WriteLn(
    '    This program uses the mod function to speed up the solution.');
  WriteLn;
  Pause;                   { Pause and allow operator to escape }
                           { Read in MaxD }
  ReadInt('Input max n for detailed output', 0, Maxn, 200, MaxD);
  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);
    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 }
      if KeyPressed then  TestIt;     { Abort run if Esc typed }
    until k > n;                      { Until all are selected }
    A[c]:= n;                         { A[c] was clobbered, so restore it }
    if n <= MaxD then begin           { If detailed output desired }
      WriteLn;  WriteLn;
      ReportDetails;                  {   Generate detailed output }
    end;
    ReportResults;                    { Generate normal output }
    Pause;                            { Pause and allow operator to escape }
  until False;                        { Loop back for next problem }
end. { Joseph1 }

{ End of file Joseph1.Pas **************************************************}

Return to Josephus Permutation Problems
Return to Harry's Home Page


This page accessed times since October 20, 2004.
Page created by: hjsmithh@sbcglobal.net
Changes last made on Saturday, 14-May-05 12:48:37 PDT

1