Lazarus

Miscellaneous => Other => Topic started by: avk on August 07, 2019, 07:22:55 am

Title: Pascal programs in the Rosetta Code collection
Post by: avk on August 07, 2019, 07:22:55 am
According to this wiki page https://wiki.freepascal.org/Add_Pascal_programs_to_the_Rosetta_Code_collection (https://wiki.freepascal.org/Add_Pascal_programs_to_the_Rosetta_Code_collection),
it seems for the first task(15 Puzzle Game) this code can be submitted:
Code: Pascal  [Select][+][-]
  1. program fifteen;
  2. {$mode objfpc}
  3. {$modeswitch advancedrecords}
  4. {$coperators on}
  5. uses
  6.   SysUtils;
  7. type
  8.   TPuzzle = record
  9.   private
  10.   const
  11.     ROW_COUNT  = 4;
  12.     COL_COUNT  = 4;
  13.     CELL_COUNT = ROW_COUNT * COL_COUNT;
  14.     RAND_RANGE = 101;
  15.   type
  16.     TTile          = 0..CELL_COUNT;
  17.     TAdjacentCell  = (acLeft, acTop, acRight, acBottom);
  18.     TPossibleMoves = set of TTile;
  19.     TAdjacency     = set of TAdjacentCell;
  20.     TBoard         = array[0..Pred(CELL_COUNT)] of TTile;
  21.   class var
  22.     HBar: string;
  23.   var
  24.     FBoard: TBoard;
  25.     FZeroPos,
  26.     FMoveCount: Integer;
  27.     FZeroAdjacency: TAdjacency;
  28.     FPossibleMoves: TPossibleMoves;
  29.     FSolved: Boolean;
  30.     procedure DoMove(aTile: TTile);
  31.     procedure CheckPossibleMoves;
  32.     procedure PrintBoard;
  33.     procedure PrintPossibleMoves;
  34.     procedure TestSolved;
  35.     procedure GenerateBoard;
  36.     class constructor Init;
  37.   public
  38.     procedure New;
  39.     function  UserMoved: Boolean;
  40.     property  MoveCount: Integer read FMoveCount;
  41.     property  Solved: Boolean read FSolved;
  42.   end;
  43.  
  44. procedure TPuzzle.DoMove(aTile: TTile);
  45. var
  46.   Pos: Integer = -1;
  47.   Adj: TAdjacentCell;
  48. begin
  49.   for Adj in FZeroAdjacency do
  50.     begin
  51.       case Adj of
  52.         acLeft:   Pos := Pred(FZeroPos);
  53.         acTop:    Pos := FZeroPos - COL_COUNT;
  54.         acRight:  Pos := Succ(FZeroPos);
  55.         acBottom: Pos := FZeroPos + COL_COUNT;
  56.       end;
  57.       if FBoard[Pos] = aTile then
  58.         break;
  59.     end;
  60.   FBoard[FZeroPos] := aTile;
  61.   FZeroPos := Pos;
  62.   FBoard[Pos] := 0;
  63. end;
  64.  
  65. procedure TPuzzle.CheckPossibleMoves;
  66. var
  67.   Row, Col: Integer;
  68. begin
  69.   Row := FZeroPos div COL_COUNT;
  70.   Col := FZeroPos mod COL_COUNT;
  71.   FPossibleMoves := [];
  72.   FZeroAdjacency := [];
  73.   if Row > 0 then
  74.     begin
  75.       FPossibleMoves += [FBoard[FZeroPos - COL_COUNT]];
  76.       FZeroAdjacency += [acTop];
  77.     end;
  78.   if Row < Pred(ROW_COUNT) then
  79.     begin
  80.       FPossibleMoves += [FBoard[FZeroPos + COL_COUNT]];
  81.       FZeroAdjacency += [acBottom];
  82.     end;
  83.   if Col > 0 then
  84.     begin
  85.       FPossibleMoves += [FBoard[Pred(FZeroPos)]];
  86.       FZeroAdjacency += [acLeft];
  87.     end;
  88.   if Col < Pred(COL_COUNT) then
  89.     begin
  90.       FPossibleMoves += [FBoard[Succ(FZeroPos)]];
  91.       FZeroAdjacency += [acRight];
  92.     end;
  93. end;
  94.  
  95. procedure TPuzzle.PrintBoard;
  96. const
  97.   Space = ' ';
  98.   VBar  = '|';
  99.   VBar1 = '| ';
  100.   VBar2 = '|  ';
  101.   VBar3 = '|    ';
  102. var
  103.   I, J, Pos, Tile: Integer;
  104.   Row: string;
  105. begin
  106.   Pos := 0;
  107.   WriteLn(HBar);
  108.   for I := 1 to ROW_COUNT do
  109.     begin
  110.       Row := '';
  111.       for J := 1 to COL_COUNT do
  112.         begin
  113.           Tile := Integer(FBoard[Pos]);
  114.           case Tile of
  115.             0:    Row += VBar3;
  116.             1..9: Row += VBar2 + Tile.ToString + Space;
  117.           else
  118.             Row += VBar1 + Tile.ToString + Space;
  119.           end;
  120.           Inc(Pos);
  121.         end;
  122.       WriteLn(Row + VBar);
  123.       WriteLn(HBar);
  124.     end;
  125.   if not Solved then
  126.     PrintPossibleMoves;
  127. end;
  128.  
  129. procedure TPuzzle.PrintPossibleMoves;
  130. var
  131.   pm: TTile;
  132.   spm: string = '';
  133. begin
  134.   for pm in FPossibleMoves do
  135.     spm += Integer(pm).ToString + ' ';
  136.   WriteLn('possible moves: ', spm);
  137. end;
  138.  
  139. procedure TPuzzle.TestSolved;
  140.   function IsSolved: Boolean;
  141.   var
  142.     I: Integer;
  143.   begin
  144.     for I := 0 to CELL_COUNT - 3 do
  145.       if FBoard[I] <> Pred(FBoard[Succ(I)]) then
  146.         exit(False);
  147.     Result := True;
  148.   end;
  149. begin
  150.   FSolved := IsSolved;
  151.   if not Solved then
  152.     CheckPossibleMoves;
  153. end;
  154.  
  155. procedure TPuzzle.GenerateBoard;
  156. var
  157.   I, CurrMove, SelMove: Integer;
  158.   Tile: TTile;
  159. begin
  160.   FZeroPos := Pred(CELL_COUNT);
  161.   FBoard[FZeroPos] := 0;
  162.   for I := 0 to CELL_COUNT - 2 do
  163.     FBoard[I] := Succ(I);
  164.   for I := 1 to Random(RAND_RANGE) do
  165.     begin
  166.       CheckPossibleMoves;
  167.       SelMove := 0;
  168.       for Tile in FPossibleMoves do
  169.         Inc(SelMove);
  170.       SelMove := Random(SelMove);
  171.       CurrMove := 0;
  172.       for Tile in FPossibleMoves do
  173.         begin
  174.           if CurrMove = SelMove then
  175.             begin
  176.               DoMove(Tile);
  177.               break;
  178.             end;
  179.           Inc(CurrMove);
  180.         end;
  181.     end;
  182. end;
  183.  
  184. class constructor TPuzzle.Init;
  185. var
  186.   I: Integer;
  187. begin
  188.   HBar := '';
  189.   for I := 1 to COL_COUNT do
  190.     HBar += '+----';
  191.   HBar += '+';
  192. end;
  193.  
  194. procedure TPuzzle.New;
  195. begin
  196.   FSolved := False;
  197.   FMoveCount := 0;
  198.   GenerateBoard;
  199.   CheckPossibleMoves;
  200.   PrintBoard;
  201. end;
  202.  
  203. function TPuzzle.UserMoved: Boolean;
  204. const
  205.   Sorry          = 'sorry, ';
  206.   InvalidInput   = ' is invalid input';
  207.   ImpossibleMove = ' is impossible move';
  208. var
  209.   UserInput: string;
  210.   Tile: Integer;
  211. begin
  212.   ReadLn(UserInput);
  213.   case LowerCase(UserInput) of
  214.     'c', 'cancel': exit(False);
  215.   end;
  216.   Result := True;
  217.   if not Tile.TryParse(UserInput, Tile) then
  218.     begin
  219.       WriteLn(Sorry, UserInput, InvalidInput);
  220.       exit;
  221.     end;
  222.   if not (Tile in [1..Pred(CELL_COUNT)]) then
  223.     begin
  224.       WriteLn(Sorry, Tile, InvalidInput);
  225.       exit;
  226.     end;
  227.   if not (Tile in FPossibleMoves) then
  228.     begin
  229.       WriteLn(Sorry, Tile, ImpossibleMove);
  230.       PrintPossibleMoves;
  231.       exit;
  232.     end;
  233.   DoMove(Tile);
  234.   Inc(FMoveCount);
  235.   TestSolved;
  236.   PrintBoard;
  237. end;
  238.  
  239. procedure PrintStart;
  240. begin
  241.   WriteLn('Fifteen puzzle start:');
  242.   WriteLn('  enter a tile number and press <enter> to move' );
  243.   WriteLn('  enter Cancel(C) and press <enter> to exit' );
  244.   WriteLn;
  245. end;
  246.  
  247. procedure Terminate;
  248. begin
  249.   WriteLn('Fifteen puzzle exit.');
  250.   Halt;
  251. end;
  252.  
  253. function UserWantContinue(aMoveCount: Integer): Boolean;
  254. var
  255.   UserInput: string;
  256. begin
  257.   WriteLn('Congratulations! Puzzle solved in ', aMoveCount, ' moves.');
  258.   WriteLn('Play again(Yes(Y)/<any button>)?');
  259.   ReadLn(UserInput);
  260.   case LowerCase(UserInput) of
  261.     'y', 'yes': exit(True);
  262.   end;
  263.   Result := False;
  264. end;
  265.  
  266. procedure Run;
  267. var
  268.   Puzzle: TPuzzle;
  269. begin
  270.   Randomize;
  271.   PrintStart;
  272.   repeat
  273.     Puzzle.New;
  274.     while not Puzzle.Solved do
  275.       if not Puzzle.UserMoved then
  276.         Terminate;
  277.     if not UserWantContinue(Puzzle.MoveCount) then
  278.       Terminate;
  279.   until False;
  280. end;
  281.  
  282. begin
  283.   Run;
  284. end.  
  285.  
Any critique/comments/tips are highly appreciated.
Title: Re: Pascal programs in the Rosetta Code collection
Post by: Thaddy on August 07, 2019, 08:17:40 am
Nice.
One remark, this removes the single warning in the code:
Code: Pascal  [Select][+][-]
  1. var
  2.   UserInput: string;
  3.   Tile: Integer = 0; // removes warning
Title: Re: Pascal programs in the Rosetta Code collection
Post by: avk on August 07, 2019, 08:28:27 am
@Thaddy, thank you
Code: Pascal  [Select][+][-]
  1. program fifteen;
  2. {$mode objfpc}
  3. {$modeswitch advancedrecords}
  4. {$coperators on}
  5. uses
  6.   SysUtils;
  7. type
  8.   TPuzzle = record
  9.   private
  10.   const
  11.     ROW_COUNT  = 4;
  12.     COL_COUNT  = 4;
  13.     CELL_COUNT = ROW_COUNT * COL_COUNT;
  14.     RAND_RANGE = 101;
  15.   type
  16.     TTile          = 0..CELL_COUNT;
  17.     TAdjacentCell  = (acLeft, acTop, acRight, acBottom);
  18.     TPossibleMoves = set of TTile;
  19.     TAdjacency     = set of TAdjacentCell;
  20.     TBoard         = array[0..Pred(CELL_COUNT)] of TTile;
  21.   class var
  22.     HBar: string;
  23.   var
  24.     FBoard: TBoard;
  25.     FZeroPos,
  26.     FMoveCount: Integer;
  27.     FZeroAdjacency: TAdjacency;
  28.     FPossibleMoves: TPossibleMoves;
  29.     FSolved: Boolean;
  30.     procedure DoMove(aTile: TTile);
  31.     procedure CheckPossibleMoves;
  32.     procedure PrintBoard;
  33.     procedure PrintPossibleMoves;
  34.     procedure TestSolved;
  35.     procedure GenerateBoard;
  36.     class constructor Init;
  37.   public
  38.     procedure New;
  39.     function  UserMoved: Boolean;
  40.     property  MoveCount: Integer read FMoveCount;
  41.     property  Solved: Boolean read FSolved;
  42.   end;
  43.  
  44. procedure TPuzzle.DoMove(aTile: TTile);
  45. var
  46.   Pos: Integer = -1;
  47.   Adj: TAdjacentCell;
  48. begin
  49.   for Adj in FZeroAdjacency do
  50.     begin
  51.       case Adj of
  52.         acLeft:   Pos := Pred(FZeroPos);
  53.         acTop:    Pos := FZeroPos - COL_COUNT;
  54.         acRight:  Pos := Succ(FZeroPos);
  55.         acBottom: Pos := FZeroPos + COL_COUNT;
  56.       end;
  57.       if FBoard[Pos] = aTile then
  58.         break;
  59.     end;
  60.   FBoard[FZeroPos] := aTile;
  61.   FZeroPos := Pos;
  62.   FBoard[Pos] := 0;
  63. end;
  64.  
  65. procedure TPuzzle.CheckPossibleMoves;
  66. var
  67.   Row, Col: Integer;
  68. begin
  69.   Row := FZeroPos div COL_COUNT;
  70.   Col := FZeroPos mod COL_COUNT;
  71.   FPossibleMoves := [];
  72.   FZeroAdjacency := [];
  73.   if Row > 0 then
  74.     begin
  75.       FPossibleMoves += [FBoard[FZeroPos - COL_COUNT]];
  76.       FZeroAdjacency += [acTop];
  77.     end;
  78.   if Row < Pred(ROW_COUNT) then
  79.     begin
  80.       FPossibleMoves += [FBoard[FZeroPos + COL_COUNT]];
  81.       FZeroAdjacency += [acBottom];
  82.     end;
  83.   if Col > 0 then
  84.     begin
  85.       FPossibleMoves += [FBoard[Pred(FZeroPos)]];
  86.       FZeroAdjacency += [acLeft];
  87.     end;
  88.   if Col < Pred(COL_COUNT) then
  89.     begin
  90.       FPossibleMoves += [FBoard[Succ(FZeroPos)]];
  91.       FZeroAdjacency += [acRight];
  92.     end;
  93. end;
  94.  
  95. procedure TPuzzle.PrintBoard;
  96. const
  97.   Space = ' ';
  98.   VBar  = '|';
  99.   VBar1 = '| ';
  100.   VBar2 = '|  ';
  101.   VBar3 = '|    ';
  102. var
  103.   I, J, Pos, Tile: Integer;
  104.   Row: string;
  105. begin
  106.   Pos := 0;
  107.   WriteLn(HBar);
  108.   for I := 1 to ROW_COUNT do
  109.     begin
  110.       Row := '';
  111.       for J := 1 to COL_COUNT do
  112.         begin
  113.           Tile := Integer(FBoard[Pos]);
  114.           case Tile of
  115.             0:    Row += VBar3;
  116.             1..9: Row += VBar2 + Tile.ToString + Space;
  117.           else
  118.             Row += VBar1 + Tile.ToString + Space;
  119.           end;
  120.           Inc(Pos);
  121.         end;
  122.       WriteLn(Row + VBar);
  123.       WriteLn(HBar);
  124.     end;
  125.   if not Solved then
  126.     PrintPossibleMoves;
  127. end;
  128.  
  129. procedure TPuzzle.PrintPossibleMoves;
  130. var
  131.   pm: TTile;
  132.   spm: string = '';
  133. begin
  134.   for pm in FPossibleMoves do
  135.     spm += Integer(pm).ToString + ' ';
  136.   WriteLn('possible moves: ', spm);
  137. end;
  138.  
  139. procedure TPuzzle.TestSolved;
  140.   function IsSolved: Boolean;
  141.   var
  142.     I: Integer;
  143.   begin
  144.     for I := 0 to CELL_COUNT - 3 do
  145.       if FBoard[I] <> Pred(FBoard[Succ(I)]) then
  146.         exit(False);
  147.     Result := True;
  148.   end;
  149. begin
  150.   FSolved := IsSolved;
  151.   if not Solved then
  152.     CheckPossibleMoves;
  153. end;
  154.  
  155. procedure TPuzzle.GenerateBoard;
  156. var
  157.   I, CurrMove, SelMove: Integer;
  158.   Tile: TTile;
  159. begin
  160.   FZeroPos := Pred(CELL_COUNT);
  161.   FBoard[FZeroPos] := 0;
  162.   for I := 0 to CELL_COUNT - 2 do
  163.     FBoard[I] := Succ(I);
  164.   for I := 1 to Random(RAND_RANGE) do
  165.     begin
  166.       CheckPossibleMoves;
  167.       SelMove := 0;
  168.       for Tile in FPossibleMoves do
  169.         Inc(SelMove);
  170.       SelMove := Random(SelMove);
  171.       CurrMove := 0;
  172.       for Tile in FPossibleMoves do
  173.         begin
  174.           if CurrMove = SelMove then
  175.             begin
  176.               DoMove(Tile);
  177.               break;
  178.             end;
  179.           Inc(CurrMove);
  180.         end;
  181.     end;
  182. end;
  183.  
  184. class constructor TPuzzle.Init;
  185. var
  186.   I: Integer;
  187. begin
  188.   HBar := '';
  189.   for I := 1 to COL_COUNT do
  190.     HBar += '+----';
  191.   HBar += '+';
  192. end;
  193.  
  194. procedure TPuzzle.New;
  195. begin
  196.   FSolved := False;
  197.   FMoveCount := 0;
  198.   GenerateBoard;
  199.   CheckPossibleMoves;
  200.   PrintBoard;
  201. end;
  202.  
  203. function TPuzzle.UserMoved: Boolean;
  204. const
  205.   Sorry          = 'sorry, ';
  206.   InvalidInput   = ' is invalid input';
  207.   ImpossibleMove = ' is impossible move';
  208. var
  209.   UserInput: string;
  210.   Tile: Integer = 0;
  211. begin
  212.   ReadLn(UserInput);
  213.   case LowerCase(UserInput) of
  214.     'c', 'cancel': exit(False);
  215.   end;
  216.   Result := True;
  217.   if not Tile.TryParse(UserInput, Tile) then
  218.     begin
  219.       WriteLn(Sorry, UserInput, InvalidInput);
  220.       exit;
  221.     end;
  222.   if not (Tile in [1..Pred(CELL_COUNT)]) then
  223.     begin
  224.       WriteLn(Sorry, Tile, InvalidInput);
  225.       exit;
  226.     end;
  227.   if not (Tile in FPossibleMoves) then
  228.     begin
  229.       WriteLn(Sorry, Tile, ImpossibleMove);
  230.       PrintPossibleMoves;
  231.       exit;
  232.     end;
  233.   DoMove(Tile);
  234.   Inc(FMoveCount);
  235.   TestSolved;
  236.   PrintBoard;
  237. end;
  238.  
  239. procedure PrintStart;
  240. begin
  241.   WriteLn('Fifteen puzzle start:');
  242.   WriteLn('  enter a tile number and press <enter> to move' );
  243.   WriteLn('  enter Cancel(C) and press <enter> to exit' );
  244.   WriteLn;
  245. end;
  246.  
  247. procedure Terminate;
  248. begin
  249.   WriteLn('Fifteen puzzle exit.');
  250.   Halt;
  251. end;
  252.  
  253. function UserWantContinue(aMoveCount: Integer): Boolean;
  254. var
  255.   UserInput: string;
  256. begin
  257.   WriteLn('Congratulations! Puzzle solved in ', aMoveCount, ' moves.');
  258.   WriteLn('Play again(Yes(Y)/<any button>)?');
  259.   ReadLn(UserInput);
  260.   case LowerCase(UserInput) of
  261.     'y', 'yes': exit(True);
  262.   end;
  263.   Result := False;
  264. end;
  265.  
  266. procedure Run;
  267. var
  268.   Puzzle: TPuzzle;
  269. begin
  270.   Randomize;
  271.   PrintStart;
  272.   repeat
  273.     Puzzle.New;
  274.     while not Puzzle.Solved do
  275.       if not Puzzle.UserMoved then
  276.         Terminate;
  277.     if not UserWantContinue(Puzzle.MoveCount) then
  278.       Terminate;
  279.   until False;
  280. end;
  281.  
  282. begin
  283.   Run;
  284. end.  
  285.  
Title: Re: Pascal programs in the Rosetta Code collection
Post by: Thaddy on August 07, 2019, 08:52:46 am
And maybe a gotoxy now and then to keep the board and input  in a single place?
Title: Re: Pascal programs in the Rosetta Code collection
Post by: avk on August 07, 2019, 07:06:44 pm
Good point. Maybe something like this?
Code: Pascal  [Select][+][-]
  1. program fifteen;
  2. {$mode objfpc}
  3. {$modeswitch advancedrecords}
  4. {$coperators on}
  5. uses
  6.   SysUtils, crt;
  7. type
  8.   TPuzzle = record
  9.   private
  10.   const
  11.     ROW_COUNT  = 4;
  12.     COL_COUNT  = 4;
  13.     CELL_COUNT = ROW_COUNT * COL_COUNT;
  14.     RAND_RANGE = 101;
  15.   type
  16.     TTile          = 0..CELL_COUNT;
  17.     TAdjacentCell  = (acLeft, acTop, acRight, acBottom);
  18.     TPossibleMoves = set of TTile;
  19.     TAdjacency     = set of TAdjacentCell;
  20.     TBoard         = array[0..Pred(CELL_COUNT)] of TTile;
  21.   class var
  22.     HBar: string;
  23.   var
  24.     FBoard: TBoard;
  25.     FZeroPos,
  26.     FMoveCount: Integer;
  27.     FZeroAdjacency: TAdjacency;
  28.     FPossibleMoves: TPossibleMoves;
  29.     FSolved: Boolean;
  30.     procedure DoMove(aTile: TTile);
  31.     procedure CheckPossibleMoves;
  32.     procedure PrintBoard;
  33.     procedure PrintPossibleMoves;
  34.     procedure TestSolved;
  35.     procedure GenerateBoard;
  36.     class constructor Init;
  37.   public
  38.     procedure New;
  39.     function  UserMoved: Boolean;
  40.     property  MoveCount: Integer read FMoveCount;
  41.     property  Solved: Boolean read FSolved;
  42.   end;
  43.  
  44. procedure TPuzzle.DoMove(aTile: TTile);
  45. var
  46.   Pos: Integer = -1;
  47.   Adj: TAdjacentCell;
  48. begin
  49.   for Adj in FZeroAdjacency do
  50.     begin
  51.       case Adj of
  52.         acLeft:   Pos := Pred(FZeroPos);
  53.         acTop:    Pos := FZeroPos - COL_COUNT;
  54.         acRight:  Pos := Succ(FZeroPos);
  55.         acBottom: Pos := FZeroPos + COL_COUNT;
  56.       end;
  57.       if FBoard[Pos] = aTile then
  58.         break;
  59.     end;
  60.   FBoard[FZeroPos] := aTile;
  61.   FZeroPos := Pos;
  62.   FBoard[Pos] := 0;
  63. end;
  64.  
  65. procedure TPuzzle.CheckPossibleMoves;
  66. var
  67.   Row, Col: Integer;
  68. begin
  69.   Row := FZeroPos div COL_COUNT;
  70.   Col := FZeroPos mod COL_COUNT;
  71.   FPossibleMoves := [];
  72.   FZeroAdjacency := [];
  73.   if Row > 0 then
  74.     begin
  75.       FPossibleMoves += [FBoard[FZeroPos - COL_COUNT]];
  76.       FZeroAdjacency += [acTop];
  77.     end;
  78.   if Row < Pred(ROW_COUNT) then
  79.     begin
  80.       FPossibleMoves += [FBoard[FZeroPos + COL_COUNT]];
  81.       FZeroAdjacency += [acBottom];
  82.     end;
  83.   if Col > 0 then
  84.     begin
  85.       FPossibleMoves += [FBoard[Pred(FZeroPos)]];
  86.       FZeroAdjacency += [acLeft];
  87.     end;
  88.   if Col < Pred(COL_COUNT) then
  89.     begin
  90.       FPossibleMoves += [FBoard[Succ(FZeroPos)]];
  91.       FZeroAdjacency += [acRight];
  92.     end;
  93. end;
  94.  
  95. procedure TPuzzle.PrintBoard;
  96. const
  97.   Space = ' ';
  98.   VBar  = '|';
  99.   VBar1 = '| ';
  100.   VBar2 = '|  ';
  101.   VBar3 = '|    ';
  102. var
  103.   I, J, Pos, Tile: Integer;
  104.   Row: string;
  105. begin
  106.   ClrScr;
  107.   Pos := 0;
  108.   WriteLn(HBar);
  109.   for I := 1 to ROW_COUNT do
  110.     begin
  111.       Row := '';
  112.       for J := 1 to COL_COUNT do
  113.         begin
  114.           Tile := Integer(FBoard[Pos]);
  115.           case Tile of
  116.             0:    Row += VBar3;
  117.             1..9: Row += VBar2 + Tile.ToString + Space;
  118.           else
  119.             Row += VBar1 + Tile.ToString + Space;
  120.           end;
  121.           Inc(Pos);
  122.         end;
  123.       WriteLn(Row + VBar);
  124.       WriteLn(HBar);
  125.     end;
  126.   if not Solved then
  127.     PrintPossibleMoves;
  128. end;
  129.  
  130. procedure TPuzzle.PrintPossibleMoves;
  131. var
  132.   pm: TTile;
  133.   spm: string = '';
  134. begin
  135.   for pm in FPossibleMoves do
  136.     spm += Integer(pm).ToString + ' ';
  137.   WriteLn('possible moves: ', spm);
  138. end;
  139.  
  140. procedure TPuzzle.TestSolved;
  141.   function IsSolved: Boolean;
  142.   var
  143.     I: Integer;
  144.   begin
  145.     for I := 0 to CELL_COUNT - 3 do
  146.       if FBoard[I] <> Pred(FBoard[Succ(I)]) then
  147.         exit(False);
  148.     Result := True;
  149.   end;
  150. begin
  151.   FSolved := IsSolved;
  152.   if not Solved then
  153.     CheckPossibleMoves;
  154. end;
  155.  
  156. procedure TPuzzle.GenerateBoard;
  157. var
  158.   I, CurrMove, SelMove: Integer;
  159.   Tile: TTile;
  160. begin
  161.   FZeroPos := Pred(CELL_COUNT);
  162.   FBoard[FZeroPos] := 0;
  163.   for I := 0 to CELL_COUNT - 2 do
  164.     FBoard[I] := Succ(I);
  165.   for I := 1 to Random(RAND_RANGE) do
  166.     begin
  167.       CheckPossibleMoves;
  168.       SelMove := 0;
  169.       for Tile in FPossibleMoves do
  170.         Inc(SelMove);
  171.       SelMove := Random(SelMove);
  172.       CurrMove := 0;
  173.       for Tile in FPossibleMoves do
  174.         begin
  175.           if CurrMove = SelMove then
  176.             begin
  177.               DoMove(Tile);
  178.               break;
  179.             end;
  180.           Inc(CurrMove);
  181.         end;
  182.     end;
  183. end;
  184.  
  185. class constructor TPuzzle.Init;
  186. var
  187.   I: Integer;
  188. begin
  189.   HBar := '';
  190.   for I := 1 to COL_COUNT do
  191.     HBar += '+----';
  192.   HBar += '+';
  193. end;
  194.  
  195. procedure TPuzzle.New;
  196. begin
  197.   FSolved := False;
  198.   FMoveCount := 0;
  199.   GenerateBoard;
  200.   CheckPossibleMoves;
  201.   PrintBoard;
  202. end;
  203.  
  204. function TPuzzle.UserMoved: Boolean;
  205. const
  206.   Sorry          = 'sorry, ';
  207.   InvalidInput   = ' is invalid input';
  208.   ImpossibleMove = ' is impossible move';
  209. var
  210.   UserInput: string;
  211.   Tile: Integer = 0;
  212. begin
  213.   ReadLn(UserInput);
  214.   case LowerCase(UserInput) of
  215.     'c', 'cancel': exit(False);
  216.   end;
  217.   Result := True;
  218.   if not Tile.TryParse(UserInput, Tile) then
  219.     begin
  220.       WriteLn(Sorry, UserInput, InvalidInput);
  221.       exit;
  222.     end;
  223.   if not (Tile in [1..Pred(CELL_COUNT)]) then
  224.     begin
  225.       WriteLn(Sorry, Tile, InvalidInput);
  226.       exit;
  227.     end;
  228.   if not (Tile in FPossibleMoves) then
  229.     begin
  230.       WriteLn(Sorry, Tile, ImpossibleMove);
  231.       PrintPossibleMoves;
  232.       exit;
  233.     end;
  234.   DoMove(Tile);
  235.   Inc(FMoveCount);
  236.   TestSolved;
  237.   PrintBoard;
  238. end;
  239.  
  240. procedure PrintStart;
  241. begin
  242.   ClrScr;
  243.   WriteLn('Fifteen puzzle start:');
  244.   WriteLn('  enter a tile number and press <enter> to move' );
  245.   WriteLn('  enter Cancel(C) and press <enter> to exit' );
  246.   Window(10, 4, 58, 21);
  247. end;
  248.  
  249. procedure Terminate;
  250. begin
  251.   ClrScr;
  252.   Window(1, 1, 80, 25);
  253.   ClrScr;
  254.   WriteLn('Fifteen puzzle exit.');
  255.   Halt;
  256. end;
  257.  
  258. function UserWantContinue(aMoveCount: Integer): Boolean;
  259. var
  260.   UserInput: string;
  261. begin
  262.   WriteLn('Congratulations! Puzzle solved in ', aMoveCount, ' moves.');
  263.   WriteLn('Play again(Yes(Y)/<any button>)?');
  264.   ReadLn(UserInput);
  265.   case LowerCase(UserInput) of
  266.     'y', 'yes': exit(True);
  267.   end;
  268.   Result := False;
  269. end;
  270.  
  271. procedure Run;
  272. var
  273.   Puzzle: TPuzzle;
  274. begin
  275.   Randomize;
  276.   PrintStart;
  277.   repeat
  278.     Puzzle.New;
  279.     while not Puzzle.Solved do
  280.       if not Puzzle.UserMoved then
  281.         Terminate;
  282.     if not UserWantContinue(Puzzle.MoveCount) then
  283.       Terminate;
  284.   until False;
  285. end;
  286.  
  287. begin
  288.   Run;
  289. end.
  290.  
Title: Re: Pascal programs in the Rosetta Code collection
Post by: Thaddy on August 07, 2019, 07:38:44 pm
Now THAT looks like a game... compliments..
Title: Re: Pascal programs in the Rosetta Code collection
Post by: avk on August 07, 2019, 07:44:24 pm
Thank you. :)
Title: Re: Pascal programs in the Rosetta Code collection
Post by: Thaddy on August 07, 2019, 08:29:38 pm
Btw: add it to the wiki: it is an excellent starting point (game logic) for beginners to cut up a picture and turn it into a graphical game.
(You and me are NOT going to do that... :D )
Title: Re: Pascal programs in the Rosetta Code collection
Post by: avk on August 10, 2019, 03:38:48 pm
I've updated appropriate Rosetta Code page.
Title: Re: Pascal programs in the Rosetta Code collection
Post by: julkas on August 10, 2019, 03:45:15 pm
@avk Rosetta Code in Pascal is low qaulity code.
Title: Re: Pascal programs in the Rosetta Code collection
Post by: avk on August 10, 2019, 04:18:08 pm
Can you clarify your point?
Title: Re: Pascal programs in the Rosetta Code collection
Post by: Thaddy on August 10, 2019, 05:02:59 pm
Yes, plz, because I have about 10 entries there as well. (Unless somebody tried to "improve") And I know my code is good enough  :D. As is avk's code.
Give us the examples of badly written or slow - I often use C code as a benchmark - , code you encountered. on Rosetta code.
Also, examples that are algorithmiccally not sound.

Easy to correct if we know what you are talking about.
Title: Re: Pascal programs in the Rosetta Code collection
Post by: julkas on August 10, 2019, 06:10:12 pm
It's just my poor opinion.
You can agree or not...
https://rosettacode.org/wiki/Sieve_of_Eratosthenes#Pascal
If it is classic sieve of Eratosthenes - I am alien.
Title: Re: Pascal programs in the Rosetta Code collection
Post by: Thaddy on August 10, 2019, 06:29:44 pm
Well, actually that code (first one) https://rosettacode.org/wiki/Sieve_of_Eratosthenes#Pascal is pretty good.
To compile with FPC adjust to use the hashed set from rtl-generics and change 1000 to 1013 (being prime) or just 251(is prime) to compile in all modes..
The second example (wheel) is fast but has too many breaks for elegance.
This is actually elegant:
Code: Pascal  [Select][+][-]
  1. program prime(output);
  2. const
  3.  PrimeLimit = 251; // highest prime < 255
  4.  
  5. var
  6.  primes: set of 1 .. PrimeLimit;
  7.  n, k: integer;
  8.  needcomma: boolean;
  9.  
  10. begin
  11.  { calculate the primes }
  12.  primes := [2 .. PrimeLimit];
  13.  for n := 1 to trunc(sqrt(PrimeLimit)) do
  14.   begin
  15.    if n in primes
  16.     then
  17.      begin
  18.       k := n*n;
  19.       while k < PrimeLimit do
  20.        begin
  21.         primes := primes - [k];
  22.         k := k + n
  23.        end
  24.      end
  25.   end;
  26.  
  27.   { output the primes }
  28.   needcomma := false;
  29.   for n := 1 to PrimeLimit do
  30.    if n in primes
  31.     then
  32.      begin
  33.       if needcomma
  34.        then
  35.         write(', ');
  36.       write(n);
  37.       needcomma := true
  38.      end
  39. end.program prime(output);
  40. const
  41.  PrimeLimit = 255;
  42.  
  43. var
  44.  primes: set of 1 .. PrimeLimit;
  45.  n, k: integer;
  46.  needcomma: boolean;
  47.  
  48. begin
  49.  { calculate the primes }
  50.  primes := [2 .. PrimeLimit];
  51.  for n := 1 to trunc(sqrt(PrimeLimit)) do
  52.   begin
  53.    if n in primes
  54.     then
  55.      begin
  56.       k := n*n;
  57.       while k < PrimeLimit do
  58.        begin
  59.         primes := primes - [k];
  60.         k := k + n
  61.        end
  62.      end
  63.   end;
  64.  
  65.   { output the primes }
  66.   needcomma := false;
  67.   for n := 1 to PrimeLimit do
  68.    if n in primes
  69.     then
  70.      begin
  71.       if needcomma
  72.        then
  73.         write(', ');
  74.       write(n);
  75.       needcomma := true
  76.      end
  77. end.
Title: Re: Pascal programs in the Rosetta Code collection
Post by: rvk on August 10, 2019, 06:42:54 pm
Also note that there is a difference in the Rosetta Code collection between (plain) Pascal, Object Pascal and Delphi. The given example in this topic might not belong under Pascal but under Object Pascal.
Title: Re: Pascal programs in the Rosetta Code collection
Post by: Thaddy on August 10, 2019, 06:53:39 pm
This entry is an exception. Added code for review.
Title: Re: Pascal programs in the Rosetta Code collection
Post by: avk on August 10, 2019, 07:13:03 pm
@julkas, I beleave I understand what you are talking about: you do not like some of the Pascal suggestions. Well, after all, the wiki article mentioned in the first post is just about that. Correct what seems wrong to you if you are sure that you are doing the right thing, or add another solution.

@rvk, do they have any basis for this separation?
Title: Re: Pascal programs in the Rosetta Code collection
Post by: Thaddy on August 10, 2019, 07:28:59 pm
@rvk, do they have any basis for this separation?
There is: on Rosetta code some entries are categorized depending on flavor, which is highly confusing.
But in this case the code is quite good.(imnsho). for the record: I did not write that entry.

Except:
https://rosettacode.org/wiki/Sieve_of_Eratosthenes#Delphi which has a lot to be desired. (And does not compile!)

I really wonder what entry he is referring to..
Title: Re: Pascal programs in the Rosetta Code collection
Post by: rvk on August 10, 2019, 07:38:22 pm
@rvk, do they have any basis for this separation?
There is a Object Pascal category.
https://rosettacode.org/wiki/Category:Object_Pascal

So it only seems logical that Object Pascal solutions would be in that category.
(And I think this qualifies as a OP solution)

Most Pascal solutions are just pure standard pascal. Otherwise it wouldn't make sense to have a separate OP category. But maybe I'm wrong.
Title: Re: Pascal programs in the Rosetta Code collection
Post by: Thaddy on August 10, 2019, 07:43:48 pm
Well, if you mean that there is no object pascal entry for the sieve you are right, but the pascal entries are both sound. The delphi entry is not.

So are you going to add it? Or shall I do it? It is a 10 minute job.... O:-)
Title: Re: Pascal programs in the Rosetta Code collection
Post by: avk on August 10, 2019, 07:53:11 pm
@rvk, I am wondering if there is any standard that documents this separation (marketing slogans of commercial companies do not matter).
Heh, Ada-83, Ada-95 and Ada-2007 are different languages? Note that they have one entry.
Title: Re: Pascal programs in the Rosetta Code collection
Post by: rvk on August 10, 2019, 08:20:39 pm
@rvk, I am wondering if there is any standard that documents this separation (marketing slogans of commercial companies do not matter).
Heh, Ada-83, Ada-95 and Ada-2007 are different languages? Note that they have one entry.
Yes, but if there were such a seperation, one should put the code in the correct category.
I'm not aware of any official document explaining the seperation between Pascal, Object Pascal and Delphi. Also, when needed, one could add languages.

I'm not sure if there are more Object Pascal solutions posted in the Pascal category. The Object Pascal category seems to have much less entries.

So are you going to add it? Or shall I do it? It is a 10 minute job.... O:-)
You could do it. I'm on a little mobile screen at the moment  ::)
Title: Re: Pascal programs in the Rosetta Code collection
Post by: avk on August 10, 2019, 08:38:30 pm
Yes, but if there were such a seperation, one should put the code in the correct category.
I'm not aware of any official document explaining the seperation between Pascal, Object Pascal and Delphi. Also, when needed, one could add languages...
I believe that this separation was created by the contributors themselves. I would not want to aggravate this.
Title: Re: Pascal programs in the Rosetta Code collection
Post by: julkas on August 11, 2019, 02:40:24 pm
http://rosettacode.org/wiki/Prime_decomposition#Pascal
Title: Re: Pascal programs in the Rosetta Code collection
Post by: Thaddy on August 11, 2019, 05:28:18 pm
http://rosettacode.org/wiki/Prime_decomposition#Pascal
Yes, that's awful code: using setlength in a loop... Sigh.
Title: Re: Pascal programs in the Rosetta Code collection
Post by: julkas on August 11, 2019, 05:43:04 pm
https://rosettacode.org/wiki/Empty_string#Pascal
Title: Re: Pascal programs in the Rosetta Code collection
Post by: Thaddy on August 11, 2019, 06:03:39 pm
That Delphi code: nothing wrong except maybe inline. Also compiles with FPC.
Title: Re: Pascal programs in the Rosetta Code collection
Post by: avk on August 12, 2019, 12:50:32 pm
Can this be suggested as a simple variant for the "Sieve of Eratosthenes" task?
Code: Pascal  [Select][+][-]
  1. program prime_sieve;
  2. {$mode objfpc}{$H+}
  3. uses
  4.   SysUtils;
  5. const
  6.   MAX_PRIME_LIMIT = {$ifdef cpu32}1024*1024*1024{$else}High(Integer){$endif};
  7. type
  8.   TIntArray = array of Integer;
  9.  
  10. function EstimatePrimeCount(aLimit: Integer): Integer; inline;
  11. begin
  12.   if aLimit <= 200 then
  13.     Result := Trunc((1.6 * aLimit)/Ln(aLimit)) + 1
  14.   else
  15.     Result := Trunc(aLimit/(Ln(aLimit) - 2)) + 1;
  16. end;
  17.  
  18. function SelectPrimes(aLimit: Integer): TIntArray;
  19. var
  20.   IsPrime: array of Boolean;
  21.   I, UpBound: Integer;
  22.   Counter: Integer = 0;
  23.   J: Int64;
  24. begin
  25.   SetLength(IsPrime, Succ(aLimit));
  26.   FillChar(Pointer(IsPrime)^, Succ(aLimit), Byte(True));
  27.   UpBound := Trunc(Sqrt(aLimit));
  28.   for I := 2 to UpBound do
  29.     if IsPrime[I] then
  30.       begin
  31.         J := Int64(I) * Int64(I);
  32.         while J <= aLimit do
  33.           begin
  34.             IsPrime[J] := False;
  35.             Inc(J, I);
  36.           end;
  37.       end;
  38.   SetLength(Result, EstimatePrimeCount(aLimit));
  39.   for I := 2 to aLimit do
  40.     if IsPrime[I] then
  41.       begin
  42.         Result[Counter] := I;
  43.         Inc(Counter);
  44.       end;
  45.   SetLength(Result, Counter);
  46. end;
  47.  
  48. var
  49.   Primes: TIntArray;
  50.   Limit: Integer = -1;
  51.   I: Integer;
  52.  
  53. function ReadLimit: Boolean;
  54. var
  55.   Lim: DWord;
  56. begin
  57.   if (ParamCount <> 1) or not DWord.TryParse(ParamStr(1), Lim) then
  58.     exit(False);
  59.   if (Lim < 2) or (Lim > MAX_PRIME_LIMIT) then
  60.     exit(False);
  61.   Limit := Integer(Lim);
  62.   Result := True;
  63. end;
  64.  
  65. begin
  66.   if not ReadLimit then
  67.     begin
  68.       WriteLn('Usage: prime_sieve Limit');
  69.       WriteLn('  where Limit in the range [2, ', MAX_PRIME_LIMIT, ']');
  70.       Halt;
  71.     end;
  72.   Primes := SelectPrimes(Limit);
  73.   for I := 0 to High(Primes) - 1 do
  74.     Write(Primes[I], ', ');
  75.   WriteLn(Primes[High(Primes)]);
  76. end.
  77.  
Title: Re: Pascal programs in the Rosetta Code collection
Post by: julkas on August 12, 2019, 01:05:06 pm
Good code, but in other languages -
https://www.nayuki.io/page/the-versatile-sieve-of-eratosthenes
Title: Re: Pascal programs in the Rosetta Code collection
Post by: Thaddy on August 12, 2019, 01:18:02 pm
Do you think this is good code? <bemused> https://www.nayuki.io/res/the-versatile-sieve-of-eratosthenes/eratosthenes-sieves.c
Title: Re: Pascal programs in the Rosetta Code collection
Post by: julkas on August 12, 2019, 01:31:17 pm
Do you think this is good code? <bemused> https://www.nayuki.io/res/the-versatile-sieve-of-eratosthenes/eratosthenes-sieves.c
If you want simple classic sieve of Eratosthenes - yes.
If you want advanced - https://github.com/kimwalisch/primesieve
Title: Re: Pascal programs in the Rosetta Code collection
Post by: avk on August 12, 2019, 02:17:38 pm
Hmm, I've eliminated the extra pass through the array (although I doubt it will be faster). I will try to consider advanced variants later.
Code: Pascal  [Select][+][-]
  1. program prime_sieve;
  2. {$mode objfpc}{$H+}
  3. uses
  4.   SysUtils;
  5. const
  6.   MAX_PRIME_LIMIT = {$ifdef cpu32}1024*1024*1024{$else}High(Integer){$endif};
  7. type
  8.   TIntArray = array of Integer;
  9.  
  10. function EstimatePrimeCount(aLimit: Integer): Integer; inline;
  11. begin
  12.   if aLimit <= 200 then
  13.     Result := Trunc((1.6 * aLimit)/Ln(aLimit)) + 1
  14.   else
  15.     Result := Trunc(aLimit/(Ln(aLimit) - 2)) + 1;
  16. end;
  17.  
  18. function SelectPrimes(aLimit: Integer): TIntArray;
  19. var
  20.   IsPrime: array of Boolean;
  21.   I, SqrtBound: Integer;
  22.   Counter: Integer = 0;
  23.   J: Int64;
  24. begin
  25.   SetLength(IsPrime, Succ(aLimit));
  26.   FillChar(Pointer(IsPrime)^, Succ(aLimit), Byte(True));
  27.   SqrtBound := Trunc(Sqrt(aLimit));
  28.   SetLength(Result, EstimatePrimeCount(aLimit));
  29.   for I := 2 to aLimit do
  30.     if IsPrime[I] then
  31.       begin
  32.         Result[Counter] := I;
  33.         Inc(Counter);
  34.         if I <= SqrtBound then
  35.           begin
  36.             J := Int64(I) * Int64(I);
  37.             while J <= aLimit do
  38.               begin
  39.                 IsPrime[J] := False;
  40.                 Inc(J, I);
  41.               end;
  42.           end;
  43.       end;
  44.   SetLength(Result, Counter);
  45. end;
  46.  
  47. var
  48.   Primes: TIntArray;
  49.   Limit: Integer = -1;
  50.   I: Integer;
  51.  
  52. function ReadLimit: Boolean;
  53. var
  54.   Lim: DWord;
  55. begin
  56.   if (ParamCount <> 1) or not DWord.TryParse(ParamStr(1), Lim) then
  57.     exit(False);
  58.   if (Lim < 2) or (Lim > MAX_PRIME_LIMIT) then
  59.     exit(False);
  60.   Limit := Integer(Lim);
  61.   Result := True;
  62. end;
  63.  
  64. begin
  65.   if not ReadLimit then
  66.     begin
  67.       WriteLn('Usage: prime_sieve Limit');
  68.       WriteLn('  where Limit in the range [2, ', MAX_PRIME_LIMIT, ']');
  69.       Halt;
  70.     end;
  71.   Primes := SelectPrimes(Limit);
  72.   for I := 0 to High(Primes) - 1 do
  73.     Write(Primes[I], ', ');
  74.   WriteLn(Primes[High(Primes)]);
  75. end.
  76.  
Title: Re: Pascal programs in the Rosetta Code collection
Post by: julkas on August 12, 2019, 02:36:19 pm
@avk In my Python code I always use bytearray. May be for Pascal bool and byte are same (in perf. terms).
Also I don't precompute prime count - simple primes.append()
Title: Re: Pascal programs in the Rosetta Code collection
Post by: avk on August 12, 2019, 02:50:24 pm
@avk In my Python code I always use bytearray. May be for Pascal bool and byte are same (in perf. terms)...
I beleave, it is.

...Also I don't precompute prime count - simple primes.append()
It would be possible to use TVector<Integer>, but I suppose it would be slower.
Title: Re: Pascal programs in the Rosetta Code collection
Post by: avk on August 15, 2019, 10:27:23 am
Some advanced sieve versions:
Code: Pascal  [Select][+][-]
  1. unit sieves;
  2. {$mode objfpc}{$H+}
  3. {$modeswitch advancedrecords}
  4. {$inline on}
  5. interface
  6. uses
  7.   SysUtils;
  8.  
  9. const
  10.   MAX_LIMIT = High(DWord) - 131072; //to avoid overflow
  11.  
  12. type
  13.   TDWordArray = array of DWord;
  14.  
  15. { uses bit-packed array }
  16.   function BpSieve(aLimit: DWord): TDWordArray;
  17. { uses bit-packed array and skips even numbers}
  18.   function OddSieve(aLimit: DWord): TDWordArray;
  19. { segmented sieve version }
  20.   function SegmentSieve(aLimit: DWord): TDWordArray;
  21.  
  22. implementation
  23.  
  24. type
  25.   TBitArray   = record
  26.   private
  27.     FBits: array of Byte;
  28.     function  GetBit(aIndex: DWord): Boolean; inline;
  29.     procedure SetBit(aIndex: DWord; aValue: Boolean); inline;
  30.   public
  31.     constructor Create(aSize: DWord);
  32.     property Bits[aIndex: DWord]: Boolean read GetBit write SetBit; default;
  33.   end;
  34.  
  35. function TBitArray.GetBit(aIndex: DWord): Boolean;
  36. begin
  37.   Result := Boolean(FBits[aIndex shr 3] and (1 shl (aIndex and 7)));
  38. end;
  39.  
  40. procedure TBitArray.SetBit(aIndex: DWord; aValue: Boolean);
  41. begin
  42.   if aValue then
  43.     FBits[aIndex shr 3] := FBits[aIndex shr 3] or (1 shl (aIndex and 7))
  44.   else
  45.     FBits[aIndex shr 3] := FBits[aIndex shr 3] and not(1 shl (aIndex and 7));
  46. end;
  47.  
  48. constructor TBitArray.Create(aSize: DWord);
  49. begin
  50.   SetLength(FBits, aSize shr 3 + Ord(aSize and 7 <> 0));
  51.   FillChar(Pointer(FBits)^, Length(FBits), $ff);
  52. end;
  53.  
  54. function EstimatePrimeCount(aLimit: DWord): DWord;
  55. begin
  56.   if aLimit < 2 then
  57.     exit(0);
  58.   if aLimit <= 200 then
  59.     Result := Trunc((1.6 * aLimit)/Ln(aLimit)) + 1
  60.   else
  61.     Result := Trunc(aLimit/(Ln(aLimit) - 2)) + 1;
  62. end;
  63.  
  64. function BpSieve(aLimit: DWord): TDWordArray;
  65. var
  66.   IsPrime: TBitArray;
  67.   I, J, SqrtBound: DWord;
  68.   Count: Integer = 0;
  69. begin
  70.   if aLimit > MAX_LIMIT then
  71.     raise Exception.Create('Prime limit exceeded');
  72.   if aLimit < 2 then
  73.     exit(nil);
  74.   IsPrime := TBitArray.Create(Succ(aLimit));
  75.   SqrtBound := Trunc(Sqrt(aLimit));
  76.   SetLength(Result, EstimatePrimeCount(aLimit));
  77.   for I := 2 to aLimit do
  78.     if IsPrime[I] then
  79.       begin
  80.         Result[Count] := I;
  81.         Inc(Count);
  82.         if I <= SqrtBound then
  83.           begin
  84.             J := I * I;
  85.             repeat
  86.               IsPrime[J] := False;
  87.               Inc(J, I);
  88.             until J > aLimit;
  89.           end;
  90.       end;
  91.   SetLength(Result, Count);
  92. end;
  93.  
  94. function OddSieve(aLimit: DWord): TDWordArray;
  95. var
  96.   IsPrime: TBitArray;
  97.   I: DWord = 3;
  98.   J, SqrtBound: DWord;
  99.   Count: Integer = 1;
  100. begin
  101.   if aLimit > MAX_LIMIT then
  102.     raise Exception.Create('Prime limit exceeded');
  103.   if aLimit < 2 then
  104.     exit(nil);
  105.   IsPrime := TBitArray.Create(aLimit div 2);
  106.   SqrtBound := Trunc(Sqrt(aLimit));
  107.   SetLength(Result, EstimatePrimeCount(aLimit));
  108.   Result[0] := 2;
  109.   while I <= aLimit do
  110.     begin
  111.       if IsPrime[(I - 3) shr 1] then
  112.         begin
  113.           Result[Count] := I;
  114.           Inc(Count);
  115.           if I <= SqrtBound then
  116.             begin
  117.               J := I * I;
  118.               repeat
  119.                 IsPrime[(J - 3) shr 1] := False;
  120.                 Inc(J, I shl 1);
  121.               until J > aLimit;
  122.             end;
  123.         end;
  124.       Inc(I, 2);
  125.     end;
  126.   SetLength(Result, Count);
  127. end;
  128.  
  129. function SegmentSieve(aLimit: DWord): TDWordArray;
  130. const
  131.   SEG_SIZE = $8000;
  132. var
  133.   Segment: array[0..Pred(SEG_SIZE)] of Boolean;
  134.   FirstPrimes, Primes: TDWordArray;
  135.   I, J, Prime: DWord;
  136.   Count: Integer = 0;
  137. begin
  138.   if aLimit > MAX_LIMIT then
  139.     raise Exception.Create('Prime limit exceeded');
  140.   if aLimit <= SEG_SIZE * 2 then
  141.     exit(OddSieve(aLimit));
  142.   I := Trunc(Sqrt(aLimit)) + 1;
  143.   FirstPrimes := OddSieve(I);
  144.   SetLength(Primes, EstimatePrimeCount(aLimit) - Length(FirstPrimes));
  145.   Dec(I);
  146.   while I < aLimit do
  147.     begin
  148.       FillChar(Segment, SEG_SIZE, Byte(True));
  149.       for Prime in FirstPrimes do
  150.         begin
  151.           J := I mod Prime;
  152.           if J <> 0 then
  153.             J := Prime - J;
  154.           while J < SEG_SIZE do
  155.             begin
  156.               Segment[J] := False;
  157.               Inc(J, Prime);
  158.             end;
  159.         end;
  160.       for J := 0 to Pred(SEG_SIZE) do
  161.         if (J + I <= aLimit) and Segment[J] then
  162.           begin
  163.             Primes[Count] := J + I;
  164.             Inc(Count);
  165.           end;
  166.       Inc(I, SEG_SIZE);
  167.     end;
  168.   SetLength(FirstPrimes, Length(FirstPrimes) + Count);
  169.   Move(Primes[0], FirstPrimes[Length(FirstPrimes) - Count], Count * SizeOf(DWord));
  170.   Result := FirstPrimes;
  171. end;
  172.  
  173. end.
  174.  
Title: Re: Pascal programs in the Rosetta Code collection
Post by: BrunoK on August 15, 2019, 04:28:10 pm
And another entry that goes up to High(DWORD) values.
Code: Pascal  [Select][+][-]
  1. program pgmSieve;
  2.  
  3. {$mode objfpc}{$H+}
  4. {$modeswitch advancedrecords}
  5. {$inline on}
  6.  
  7. // Checking primes : https://primes.utm.edu/nthprime/index.php#nth
  8.  
  9. // Compiled -O1 -OoREGVAR so one can debug
  10.  
  11. uses
  12.   Classes,
  13.   SysUtils;
  14.  
  15. type
  16.  
  17.   { RSieveBits }
  18.  
  19.   RSieveBits = record
  20.   private
  21.     FBits : array of Byte;
  22.     FMaxPrime : DWord;
  23.  
  24.     FPrimeCount : integer; // Number of primes found
  25.     FMaxCount : integer;   // Maximum primes that can be stored
  26.     procedure FlagNonPrimes(aPrime : DWord);
  27.   public
  28.     procedure Init(aSize: DWord);
  29.     procedure BpSieve(var aPrimes : array of DWord; aSize : DWord);
  30.   end;
  31.  
  32. { Flag multiples as non primes }
  33. procedure RSieveBits.FlagNonPrimes(aPrime: DWord);
  34. var
  35.   lByteIx: integer;
  36.   lpByte: PByte;
  37.   lPrime : DWord;
  38.   lLastPrime : DWord;
  39. begin
  40.   lPrime := aPrime + aPrime;
  41.   while lPrime <= FMaxPrime do begin
  42.     if lPrime<=aPrime then // Wrap around -> exit
  43.       exit;
  44.     if (lPrime and 1) <> 0 then begin // Only odd values
  45.       lByteIx := lPrime shr 4;
  46.       lpByte:=@FBits[lByteIx];
  47.       if lpByte^ <> 0 then begin
  48.         lpByte^ := lpByte^ and not (1 shl ((lPrime and 15) shr 1));
  49.       end;
  50.     end;
  51.     inc(lPrime, aPrime);
  52.   end;
  53. end;
  54.  
  55. procedure RSieveBits.Init(aSize: DWord);
  56. var
  57.   lQWord : QWord;
  58. begin
  59.   lQWord := (QWord(aSize) shr 4) + 1;
  60.   SetLength(FBits, lQWord);  // Only odd bits
  61.   FillChar(FBits[0], Length(FBits), $ff);
  62.   FMaxPrime := aSize;
  63. end;
  64.  
  65. procedure RSieveBits.BpSieve(var aPrimes: array of DWord; aSize: DWord);
  66. var
  67.   lPrime: DWORD;
  68.   lByteIx: integer;
  69.   lByte: byte;
  70. begin
  71.   if aSize<2 then
  72.     exit;
  73.   Init(aSize);
  74.   FMaxCount := Length(aPrimes);
  75.   FBits[0] := 254; // One is NOT prime
  76.   aPrimes[FPrimeCount] := 2;
  77.   inc(FPrimeCount);
  78.   lPrime := 3;
  79.   while lPrime <= FMaxPrime do begin
  80.     lByteIx := lPrime shr 4;
  81.     lByte := FBits[lPrime shr 4];
  82.     if lByte<>0 then begin
  83.       if (lByte and (1 shl ((lPrime and 15) shr 1))) <> 0 then begin
  84.         if FPrimeCount>=FMaxCount then begin
  85.           WriteLn('Stopped after ', FPrimeCount, ' primes. Next prime to store = ', lPrime,
  86.                   ' due to result set array full');
  87.           Break;
  88.         end;
  89.         aPrimes[FPrimeCount] := lPrime;
  90.         inc(FPrimeCount);
  91.         FlagNonPrimes(lPrime);
  92.       end;
  93.       inc(lPrime, 2);   // Only odd numbers
  94.     end
  95.     else
  96.       lPrime := ((lByteIx + 1) shl 4) + 1;
  97.     if lPrime<=3 then // Wrap around -> done
  98.       break;
  99.   end;
  100. end;
  101.  
  102. const             // 1'000'000'000
  103.   cMaxPrime: DWord = 1000000000; // ~60 secs for high(DWORD);
  104. var
  105.   vPrimes: Array[0..Maxint div 8] of DWord;  // Array of primes found
  106.   i : integer;
  107.   lSieveBits : RSieveBits;
  108.   lTickStart : int64;
  109.   lFrom : integer;
  110. begin
  111.   lTickStart := GetTickCount64;
  112.   lSieveBits.BpSieve(vPrimes, cMaxPrime);
  113.   WriteLn('Max Prime=',cMaxPrime, ' Nb of primes found=',lSieveBits.FPrimeCount);
  114.   lFrom := lSieveBits.FPrimeCount-20; // Write last 20 primes in ranges
  115.   if lFrom<0 then
  116.     lFrom := 0;
  117.   for i := lFrom to lSieveBits.FPrimeCount-1 do
  118.     WriteLn(DWord(vPrimes[i]));
  119.   WriteLn('Done in ', GetTickCount64 - lTickStart, ' milliseconds');
  120.   ReadLn;
  121. end.
  122.  
Title: Re: Pascal programs in the Rosetta Code collection
Post by: Thaddy on August 15, 2019, 07:51:13 pm
Please note Rosetta Code is supposed to be algorithmically fast, but clean code. Not optimized to death.
I would suggest avk's odd solution as a comprehensible and fast solution compared to the current (elegant and short) one.
It is more about the expressiveness of a language than its speed. It is not a compiler shoot-out. Remember that.
Keep code simple and elegant on Rosetta code and use the expressiveness of the language.

You impress more with few lines. That's what it is about. (everything else can theoretically be handled by the compiler)

Alternatively write code for the compiler shout-out.... :D (ok, shoot... O:-) )

Btw: you are only allowed standard libraries from FreePascal, note that too. I always try to limit it to system and classes.

And there will be always noise on the line by speed freaks. Then they do not understand the purpose of Rosetta code and have zilch.none, whatsoever knowledge....about computer science. <grumpy   >:D >
This goes for many other languages entries too, so don't be offended.
Title: Re: Pascal programs in the Rosetta Code collection
Post by: avk on August 16, 2019, 08:05:47 am
As for performance, on my machine for the limit of 1,000,000,000, the results look like this:
Code: Text  [Select][+][-]
  1.   basic sieve:      16.7s
  2.   BrunoK's BpSieve: 13s
  3.   BpSieve:          12.1s
  4.   OddSieve:         6.1s
  5.   wheel sieve:      4.2s
  6.   SegmentSieve:     3.3s  
  7.  
Title: Re: Pascal programs in the Rosetta Code collection
Post by: Kays on August 16, 2019, 12:39:19 pm
[…] There is a Object Pascal category. […]
There is even a FreePascal category (https://rosettacode.org/wiki/Category:Free_Pascal). And FreePascal/Lazarus (https://rosettacode.org/wiki/Category:Free_Pascal/Lazarus).

I second Thaddy’s latest reasoning. I’d use RC to “lure” programmers into using FPC. If you wanna show (off your language skills, and) how to tweak code, write an article in our own wiki (http://wiki.freepascal.org/).
Title: Re: Pascal programs in the Rosetta Code collection
Post by: Thaddy on August 16, 2019, 07:20:24 pm
second Thaddy’s latest reasoning.

Thanks. The Rosetta stone history and its meaning gets often lost on Rosetta code.
It is really about the expressiveness, not about speed. Many "slow" languages have entries too, even scripting.
Title: Re: Pascal programs in the Rosetta Code collection
Post by: avk on August 17, 2019, 04:33:55 pm
...I second Thaddy’s latest reasoning...
Any critique appreciated. :)

Well, I’ll try to explain why I personally don’t like this "pretty good" algorithm(first RC entry).
RC for this task says: "It is important that the sieve algorithm be the actual algorithm used to find prime numbers for the task.", but the above algorithm is not very practical. The bottleneck of the classic sieve of Eratosthenes is a rather large space complexity (O(N)),
which in particular leads to the fact that the real time complexity is worse than theoretical due to cache misses.
As for this algorithm, it more aggravates the situation by using a hashset(my guess) for storage, which increases memory consumption by an order of magnitude and is also much slower than plane array.
The snippets that I submitted demonstrate step by step how to reduce memory consumption and how it affects performance.
And yes, I have one more snippet - odd segmented sieve: :)
Code: Pascal  [Select][+][-]
  1. function OddSegmentSieve(aLimit: DWord): TDWordArray;
  2. const
  3.   SEG_SIZE = $8000;
  4. var
  5.   Segment: array[0..Pred(SEG_SIZE)] of Boolean;
  6.   NewPrimes: TDWordArray;
  7.   I, J, K, Prime: DWord;
  8.   Count: Integer = 0;
  9. begin
  10.   if aLimit > MAX_LIMIT then
  11.     raise Exception.Create('Prime limit exceeded');
  12.   if aLimit <= SEG_SIZE * 2 then
  13.     exit(OddSieve(aLimit));
  14.   I := Trunc(Sqrt(aLimit));
  15.   Result := OddSieve(Succ(I));
  16.   I += Ord(not Odd(I));
  17.   SetLength(NewPrimes, EstimatePrimeCount(aLimit) - Length(Result));
  18.   while I <= aLimit do
  19.     begin
  20.       FillChar(Segment, SizeOf(Segment), Byte(True));
  21.       for K := 1 to High(Result) do
  22.         begin
  23.           Prime := Result[K];
  24.           J := I mod Prime;
  25.           if J <> 0 then
  26.             if Boolean(J and 1) then
  27.               J := Prime - J
  28.             else
  29.               J := Prime shl 1 - J;
  30.           while J < SEG_SIZE * 2 do
  31.             begin
  32.               Segment[J shr 1] := False;
  33.               J += Prime shl 1;
  34.             end;
  35.         end;
  36.       K := Min(Pred(SEG_SIZE * 2), aLimit - I);
  37.       J := 0;
  38.       while J <= K do
  39.         begin
  40.           if Segment[J shr 1] then
  41.             begin
  42.               NewPrimes[Count] := J + I;
  43.               Inc(Count);
  44.             end;
  45.           J += 2;
  46.         end;
  47.       I += SEG_SIZE * 2;
  48.     end;
  49.   SetLength(Result, Length(Result) + Count);
  50.   Move(NewPrimes[0], Result[Length(Result) - Count], Count * SizeOf(DWord));
  51. end;
  52.  

The performance comparison table now looks like this:
Code: Text  [Select][+][-]
  1.   basic sieve:      16.7s
  2.   BrunoK's BpSieve: 13s
  3.   BpSieve:          12.1s
  4.   OddSieve:         6.1s
  5.   wheel sieve:      4.2s
  6.   SegmentSieve:     3.3s
  7.   OddSegmentSieve:  2.1s  
  8.  
Also lazy prime iterator seems to be very useful.
Any opinions? 
Title: Re: Pascal programs in the Rosetta Code collection
Post by: Thaddy on August 17, 2019, 06:25:45 pm
@avk
I would solve it like this:
- provide a very clean one
AND
- provide an understandable optimized one with references.
Title: Re: Pascal programs in the Rosetta Code collection
Post by: avk on August 18, 2019, 05:44:14 pm
@Thaddy, thanks, you are probably right.
TinyPortal © 2005-2018