Joseph5.Pas Program Listing




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

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

Program Joseph5; { Graphical Orbits in Josephus permutations }

uses Crt, Graph; { Turbo Pascal 6.0 interface }

const
  Name    = 'Joseph5 - Graphical Orbits in Josephus permutations';
  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: (See Joseph1.Exe)
--------------------
  n = 1000,  m = 2,  f = 1:  Object 976 was selected last!
  There is 1 fixed element:  1.
--------------------
Note: When m = 2 and f = 1, the last object selected = 2^P - 2(2^P - n)
 = 2n - 2^P, where 2^P is the next power of 2 greater than or equal to n.
In this case n = 1000 so the last object selected = 2000 - 1024 = 976.
}

{ Developed in Turbo Pascal 6.0 }

const
  Maxn = 15000; { The maximum total number of objects in the circle }

type
  ColorType = 0 .. MaxColors; { Turbo Pascal type for colors }
  Reals     = Double;         { Change Double to Real if no coprocessor }

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 in permutation }
  Maxm : Integer; { Maximum m for selecting every m'th object }

{ Graphics variables }
  x       : Integer; { Current value of x }
  y       : Integer; { Next step on circle, x --> y }
  AspectR : Reals;   { Aspect ratio, EGA Hi = 10000 / 7750 = 1.2903225806 }
  XAsp    : Word;    { Horizontal aspect }
  YAsp    : Word;    { Vertical aspect }
  Ra      : Reals;   { Radius of circle }
  SlopeX  : Reals;   { Slope of transform of X to pixels }
  SlopeY  : Reals;   { Slope of transform of Y to pixels }
  X0      : Reals;   { X  of point in transform of X to pixels }
  Xp0     : Reals;   { Xp of point in transform of X to pixels }
  Y0      : Reals;   { Y  of point in transform of Y to pixels }
  Yp0     : Reals;   { Yp of point in transform of Y to pixels }
  Border  : Reals;   { Size of border on screen in X pixels }
  Device  : Integer; { Turbo Pascal graphics device code }
  Mode    : Integer; { Turbo Pascal graphics device mode code }
  TH      : Integer; { Text height = TextHeight('M') }
  TH3     : Integer; { Text height + 3 }
  MaxXPix : Word;    { Max pixel number in X direction, [0, MaxXPix] }
  MaxYPix : Word;    { Max pixel number in Y direction, [0, MaxYPix] }
  PreRead : Boolean; { Ch has been preread by PlotIt procedure }
  Color   : ColorType;   { Turbo Pascal color code }
  Palette : PaletteType; { Turbo Pascal color palette }
  X1, X2, X3 : Reals;    { Points to plot in real coordinates }
  Y1, Y2, Y3 : Reals;

{--------------------------------------}
procedure ExitProc; { Exit the program }
begin
  RestoreCrtMode;
  CloseGraph;
  Halt(0);
end; { ExitProc }

{--------------------------------------}
function I2St( I : LongInt) : String; { Convert Integer to a String }
var St : String[11];
begin
  Str( I, St);  I2St:= St;
end; { I2St }

{--------------------------------------}
function ForceColor( Color : ColorType) : ColorType;
begin
  Color:= Color mod Palette.Size;
  IF Color = 0 then Color:= 1;
  SetColor( Color);
  ForceColor:= Color;
end; { ForceColor }

{--------------------------------------}
procedure WriteIn( Ind : Integer; St : String); { Write a line indented }
begin
  for i:= 1 to Ind do  Write(' ');
  WriteLn( St);
end; { WriteIn }

{--------------------------------------}
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 TestIt; { Halt the run if ESC typed }
begin
  while Keypressed do  Ch:= ReadKey;
  if Ord( Ch) = 27 then  ExitProc;
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  ExitProc;
  WriteLn;  WriteLn;
end; { Pause }

{--------------------------------------}
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 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 InitHead; { Initialize header }
begin
  TextBackground( Blue);
  TextColor( Yellow);
  ClrScr;
  WriteLn;
  WriteC( Name);
  WriteC( Version);
  WriteC( Author);
  WriteC( Address);
  WriteLn;
  Story;             { Tell the story of what the Josephus problem is }
  WriteLn(
    '    This program uses the mod function to speed up the solution.');
  WriteLn;
end; { InitHead }

{--------------------------------------}
procedure Init; { Initialize program }
begin
  InitHead; { Init header before and after InitGraph, InitGraph may hang }
  Device:= Detect;  Mode:= 0;
  InitGraph( Device, Mode, '');          { Determine type of graphics device }
  while Device < 0 do begin
    WriteLn('*** Cannot initialize graphics ***');  Pause;
    Mode:= 0;
    ReadInt('Input Device #, 0 for Automatic Detection', 0, 10, 0, Device);
    if Device <> 0 then  ReadInt('Input Mode #', 0, 5, 0, Mode);
    InitGraph( Device, Mode, '');
  end;
  MaxXPix:= GetMaxX;  MaxYPix:= GetMaxY; { Initialize graphics }
  GetAspectRatio( XAsp, YAsp);
  AspectR:= YAsp / XAsp;
  GetPalette( Palette);
  IF Palette.Size < 2 then  Palette.Size:= 2;
  TH:= TextHeight('M');
  TH3:= TH + 3;
  Border:= 4 * TH3 * AspectR;
  RestoreCrtMode;
  InitHead;
  WriteLn('Device, Mode, MaxX, MaxY = ',
           Device, ' ', Mode, ' ', MaxXPix, ' ', MaxYPix);
  Write('Palette.Size: Colors = ', Palette.Size, ':');
  FOR I:= 0 TO Palette.Size-1 DO
    Write(' ', Palette.Colors[I]);       { Show hardware information }
  WriteLn;
  WriteLn('Screen pixel aspect ratio = ', AspectR:0:9);
  WriteLn;
  Pause;                   { Pause and allow operator to escape }
  { 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, n,      1,  f);
  SetGraphMode( Mode);
  IF Palette.Size > 8 then  SetBkColor( Blue);
  Color:= ForceColor( Yellow);
  PreRead:= False;
end; { Init }

{--------------------------------------}
function TranX( X : Reals) : Integer; { Transform X to Pixels }
begin
  TranX:= Round((X - X0) * SlopeX + Xp0);
end; { TranX }

{--------------------------------------}
function TranY( Y : Reals) : Integer; { Transform Y to Pixels }
begin
  TranY:= Round((Y - Y0) * SlopeY + Yp0);
end; { TranY }

{--------------------------------------}
procedure CompTran; { Compute constants for transforms to pixels }
                    { Using point-slope form of linear transform }
begin
  Ra:= 1.0;
  SlopeX:= (1.0 + MaxXPix - 2.0 * Border) / (2.0 * Ra);
  X0:= -Ra;  Xp0:= Border;
  SlopeY:= -SlopeX / AspectR;
  Y0:= 0;  Yp0:= (1.0 + MaxYPix) / 2.0;
  if (TranY( Ra) * AspectR < Border) then begin
    SlopeY:= -(1 + MaxYPix - 2.0 * Border / AspectR) / (2 * Ra);
    Y0:= Ra;  Yp0:= Border / AspectR;
    SlopeX:= -SlopeY * AspectR;
    X0:= 0;   Xp0:= (1 + MaxXPix) / 2.0;
  end;
end; { CompTran }

{--------------------------------------}
procedure Orbits; { Determine the orbits }
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 }
    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 }
  s:= 0;                            { Count number of fixed elements }
  for i:= 1 to n do
    if B[i] = i then  Inc( s);
end; { Orbits }

{--------------------------------------}
procedure ReportCyclic; { Generate cyclic notation output }
begin
  Color:= ForceColor( Yellow);
  MoveTo( 10, MaxYPix + 3 - 2 * TH3);
  OutText('Permutation in cyclic notation:');
  MoveTo( 10, MaxYPix + 3 - 1 * TH3);
  p:= B[1];  c:= 1;
  repeat
    OutText('(');
    repeat
      if c <> 0 then begin
        OutText( I2St( c));
        A[p]:= 0;  p:= c;
      end;
      c:= A[p];
      if c <> 0 then OutText(', ');
    until (c = 0) or (GetX > MaxXPix);
    OutText(')');
    i:= 0;
    repeat
      Inc( i);  c:= A[i];
    until (c <> 0) or (i = n);
    if c<> 0 then  p:= B[c];
  until (c = 0) or (GetX > MaxXPix);
end; { ReportCyclic }

{--------------------------------------}
procedure PlotIt; { Plot the circle }
{
                       n
               n-1           1
                       .
                       .         n points equally spaced on the
                       .         circumference of a circle
                      n/2
}
var
  an : Reals;   { Angle between points }
  K1 : Reals;   { Constant for 6  pixel tick mark }
  K2 : Reals;   { Constant for 15 pixel tick mark }
  K3 : Reals;   { Constant for 15 pixel + TextHeight tick mark }
  Ss : String[1]; { String 's' or '' if s = 1 }
  d  : Integer; { Delta spacing for labeling points }
begin
  if KeyPressed then  Exit;
  Ss:= 's';
  if s = 1 then  Ss:= '';
  Ch:= ' ';
  I:= 1;
  ClearViewPort;
  SetLineStyle(SolidLn, 0, NormWidth);
  K1:= (SlopeY - 0.55 * TH3) / SlopeY;
  K2:= (SlopeY - 1.36 * TH3) / SlopeY;
  K3:= (SlopeY - 2.09 * TH3) / SlopeY;
  an:= 2 * Pi / n;  x:= 0;
  Color:= ForceColor( Yellow);
  MoveTo( 10, 1);
  OutText('Graphical Orbits in Josephus permutations');
  MoveTo( 10, TH3);
  OutText('Type arrow keys to change m and f');
  MoveTo( 10, 2 * TH3);
  OutText('PgUp/PgDn to change n');
  MoveTo( 10, 3 * TH3);
  OutText('+/- for next');
  MoveTo( 10, 4 * TH3);
  OutText('Home to restart');
  MoveTo( 10, 5 * TH3);
  OutText('or Esc to quit');
  MoveTo( 10, 6 * TH3);
  OutText('n = ' + I2St(n) + ', m = ' + I2St(m) + ',');
  MoveTo( 10, 7 * TH3);
  OutText('f = ' + I2St(f));
  MoveTo( 10, 8 * TH3);
  OutText(I2St( s) + ' fixed point' + Ss);
  MoveTo( 10, 9 * TH3);
  OutText('# ' + I2St( B[n]) + ' last');
  Color:= ForceColor( Green);
  MoveTo( TranX( 0), TranY( 0));
  LineTo( TranX( 0), TranY( 0));
  Circle( TranX( 0), TranY(0), 10);
  Circle( TranX( 0), TranY(0), Round( Ra * -SlopeY * AspectR));
  x:= 1;  d:= n div 50;
  if      d <= 1   then  d:= 1
  else if d <= 2   then  d:= 2
  else if d <= 5   then  d:= 5
  else if d <= 10  then  d:= 10
  else if d <= 20  then  d:= 20
  else if d <= 50  then  d:= 50
  else if d <= 100 then  d:= 100
  else if d <= 200 then  d:= 200
  else if d <= 500 then  d:= 500;
  repeat
    X1:= Sin( x * an);  Y1:= Cos( x * an);
    if ((x mod d) = 0) or (x = n) then begin
      X2:= K2 * X1;  Y2:= K2 * Y1;
    end
    else begin
      X2:= K1 * X1;  Y2:= K1 * Y1;
    end;
    MoveTo( TranX( X1), TranY( Y1));  { Draw tick marks at each Point x }
    LineTo( TranX( X2), TranY( Y2));
    if (x mod d) = 0 then begin
      X3:= K3 * X1;  Y3:= K3 * Y1;
      MoveTo( TranX( X3) - TextWidth(I2St( x)) div 2,
              TranY( Y3) - TH div 2);
      OutText( I2St( x));
    end;
    Inc( x);
  until (x > n) or KeyPressed;
  Color:= ForceColor( Yellow);
  MoveTo( TranX( 0), TranY( Ra));
  MoveRel( 2, - TH3 - 3);
  OutText('n');
  x:= 1;  Color:= ForceColor( Yellow);
  repeat
    y:= A[x];
    X1:= Sin( x * an);  Y1:= Cos( x * an);
    X3:= Sin( y * an);  Y3:= Cos( y * an);
    X2:= (X1 + 19 * X3) / 20;    Y2:= (Y1 + 19 * Y3) / 20;
    MoveTo( TranX( X1), TranY( Y1)); { Draw line from point x to Point y }
    LineTo( TranX( X2), TranY( Y2));
    Inc( x);
  until (x > n) or KeyPressed;
  SetLineStyle(SolidLn, 0, ThickWidth);
  x:= 1;  Color:= ForceColor( LightRed);
  repeat
    y:= A[x];
    X1:= Sin( x * an);  Y1:= Cos( x * an);
    X3:= Sin( y * an);  Y3:= Cos( y * an);
    X2:= (X1 + 19 * X3) / 20;    Y2:= (Y1 + 19 * Y3) / 20;
    MoveTo( TranX( X2), TranY( Y2)); { Draw arrow head in red to Point y }
    LineTo( TranX( X3), TranY( Y3));
    Inc( x);
  until (x > n) or KeyPressed;
  Color:= ForceColor( White);
  x:= 1;
  repeat
    y:= A[x];
    if x = y then begin
      X1:= Sin( x * an);  Y1:= Cos( x * an);
      MoveTo( TranX( X1),  TranY( Y1));  { Draw black holes last }
      LineTo( TranX( X1),  TranY( Y1));
    end;
    Inc( x);
  until (x > n) or KeyPressed;
  ReportCyclic;
  Ch:= ReadKey;
  PreRead:= True;
end; { PlotIt }

{--------------------------------------}
procedure CompMaxm; { Compute Max m = (n-1)! or MaxInt }
begin
  if n > 8 then  Maxm:= MaxInt
  else begin                    { Maxm = (n-1)! }
    Maxm:= 1;
    for i:= 2 to n-1 do  Maxm:= i * Maxm;
  end;
end; { CompMaxm }

{--------------------------------------}
begin { Joseph5 }
  repeat
    Init;         { Initialize program }
    CompTran;     { Compute constants for transforms }
    repeat
      Orbits;     { Determine the orbits }
      PlotIt;     { Plot the circle }
      if not PreRead then  Ch:= ReadKey;  { Wait for operator action }
      PreRead:= False;
      if Ch = Chr(0)  then  Ch:= ReadKey;
      CompMaxm;
      if Ch = '+' then begin
        Inc(f);
        if f > n then begin
          f:= 1;  Inc(m);
          if (m > Maxm) or (m < 0) then begin
            m:= 1;
            if n < Maxn then  Inc(n)
            else  n:= 1;
          end;
        end;
      end
      else if Ch = '-' then begin
        Dec(f);
        if f < 1 then begin
          f:= n;  Dec(m);
          if m < 1 then begin
            if n > 1 then  Dec(n);
            f:= n;
            CompMaxm;
            m:= Maxm;
          end;
        end;
      end
      else begin
        if Ch = Chr(73) then  Inc(n); { Page Up }
        if Ch = Chr(81) then  Dec(n); { Page Down }
        if Ch = Chr(72) then  Inc(m); { Up    arrow }
        if Ch = Chr(80) then  Dec(m); { Down  arrow }
        if Ch = Chr(75) then  Dec(f); { Left  arrow }
        if Ch = Chr(77) then  Inc(f); { Right arrow }
        if n <  1       then  n:= 1;
        if n >  Maxn    then  n:= Maxn;
        if m <  0       then  m:= 1;     { Prevent m overflow }
        if m =  0       then  m:= MaxInt;
        if m >  MaxInt  then  m:= 1;
        if f <  1       then  f:= n;
        if f >  n       then  f:= 1;
      end;
    until (Ch = Chr(27)) or (Ch = Chr(71)); { Esc or Home }
    RestoreCrtMode;
    CloseGraph;
  until Ch = Chr(27);
  ExitProc;            { Exit the program }
end. { Joseph5 }

{ End of file Joseph5.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:32 PDT

1