Recent

Author Topic: Pascal programs in the Rosetta Code collection  (Read 2237 times)

avk

  • Full Member
  • ***
  • Posts: 170
    • my self-education project
Pascal programs in the Rosetta Code collection
« 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,
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.

Thaddy

  • Hero Member
  • *****
  • Posts: 9303
Re: Pascal programs in the Rosetta Code collection
« Reply #1 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
also related to equus asinus.

avk

  • Full Member
  • ***
  • Posts: 170
    • my self-education project
Re: Pascal programs in the Rosetta Code collection
« Reply #2 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.  

Thaddy

  • Hero Member
  • *****
  • Posts: 9303
Re: Pascal programs in the Rosetta Code collection
« Reply #3 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?
also related to equus asinus.

avk

  • Full Member
  • ***
  • Posts: 170
    • my self-education project
Re: Pascal programs in the Rosetta Code collection
« Reply #4 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.  

Thaddy

  • Hero Member
  • *****
  • Posts: 9303
Re: Pascal programs in the Rosetta Code collection
« Reply #5 on: August 07, 2019, 07:38:44 pm »
Now THAT looks like a game... compliments..
also related to equus asinus.

avk

  • Full Member
  • ***
  • Posts: 170
    • my self-education project
Re: Pascal programs in the Rosetta Code collection
« Reply #6 on: August 07, 2019, 07:44:24 pm »
Thank you. :)

Thaddy

  • Hero Member
  • *****
  • Posts: 9303
Re: Pascal programs in the Rosetta Code collection
« Reply #7 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 )
also related to equus asinus.

avk

  • Full Member
  • ***
  • Posts: 170
    • my self-education project
Re: Pascal programs in the Rosetta Code collection
« Reply #8 on: August 10, 2019, 03:38:48 pm »
I've updated appropriate Rosetta Code page.

julkas

  • Sr. Member
  • ****
  • Posts: 440
  • KISS principle / Lazarus 2.0.0 / FPC 3.0.4
Re: Pascal programs in the Rosetta Code collection
« Reply #9 on: August 10, 2019, 03:45:15 pm »
@avk Rosetta Code in Pascal is low qaulity code.
procedure mulu64(a, b: QWORD; out clo, chi: QWORD); assembler;
asm
  mov rax, a
  mov rdx, b
  mul rdx
  mov [clo], rax
  mov [chi], rdx
end;

avk

  • Full Member
  • ***
  • Posts: 170
    • my self-education project
Re: Pascal programs in the Rosetta Code collection
« Reply #10 on: August 10, 2019, 04:18:08 pm »
Can you clarify your point?

Thaddy

  • Hero Member
  • *****
  • Posts: 9303
Re: Pascal programs in the Rosetta Code collection
« Reply #11 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.
« Last Edit: August 10, 2019, 05:11:45 pm by Thaddy »
also related to equus asinus.

julkas

  • Sr. Member
  • ****
  • Posts: 440
  • KISS principle / Lazarus 2.0.0 / FPC 3.0.4
Re: Pascal programs in the Rosetta Code collection
« Reply #12 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.
procedure mulu64(a, b: QWORD; out clo, chi: QWORD); assembler;
asm
  mov rax, a
  mov rdx, b
  mul rdx
  mov [clo], rax
  mov [chi], rdx
end;

Thaddy

  • Hero Member
  • *****
  • Posts: 9303
Re: Pascal programs in the Rosetta Code collection
« Reply #13 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.
« Last Edit: August 10, 2019, 07:55:34 pm by Thaddy »
also related to equus asinus.

rvk

  • Hero Member
  • *****
  • Posts: 3842
Re: Pascal programs in the Rosetta Code collection
« Reply #14 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.