OpenSource/GildedRose-Refactoring-Kata
1
0
Fork 0
mirror of https://github.com/emilybache/GildedRose-Refactoring-Kata.git synced 2025-12-11 20:02:09 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity

Port to (Turbo) Pascal. Feeling retro ;-)

Browse Source
This commit is contained in:
Peter Kofler 2017-12-07 19:54:14 +01:00
parent 6f972d0c5f
commit e2b491b8c5
6 changed files with 385 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
pascal/.gitignore vendored Normal file
View File

@ -0,0 +1,11 @@
syntax: glob
*.bak
*.BAK
*.tpu
*.TPU
*.exe
*.EXE
*.$$$
*.DSK
*.TP

19
pascal/README.md Normal file
View File

@ -0,0 +1,19 @@
# Pascal port of the Gilded-Rose Kata
This is a (Turbo) Pascal port of the *Gilded-Rose-Kata*.
## Building and Running
* Compile the unit `ROSE.PAS`, this is the Gilded Rose Logic.
* Compile the application `TEXTTEST.PAS` for the Texttest fixture.
* Run `TEXTTEST`.
## Unit Test
`TPUNIT.PAS` is a minimalist implementation of xUnit in Pascal style.
There are several assertions available, e.g. `AssertEquals`, `AssertEqualsStr`, `AssertTrue` etc.
It needs _Far Calls_ enabled in compiler options.
* First compile the unit `TPUNIT.PAS`.
* Then compile application `ROSE_T.PAS`.
* Run `ROSE_T` to run the tests.

137
pascal/ROSE.PAS Normal file
View File

@ -0,0 +1,137 @@
unit Rose;
interface
type
Item = record { 260b memory }
Name: string;
SellIn: Integer;
Quality: Integer;
end;
Items = array [0..251] of Item; { 64kb memory }
ListOfItems = record
Elements: ^Items;
Length: Word;
end;
procedure ResizeList(var List: ListOfItems; Size: Word);
procedure ClearList(var List: ListOfItems);
procedure InitItem(var Item: Item; Name: string; SellIn: Integer; Quality: Integer);
function StrItem(Item: Item): string;
procedure UpdateQuality(Items: ListOfItems);
implementation
procedure ResizeList(var List: ListOfItems; Size: Word);
begin
List.Length := Size;
GetMem(List.Elements, Size * SizeOf(Item));
end;
procedure ClearList(var List: ListOfItems);
begin
FreeMem(List.Elements, List.Length * SizeOf(Item));
List.Length := 0;
end;
procedure InitItem(var Item: Item; Name: string; SellIn: Integer; Quality: Integer);
begin
Item.Name := Name;
Item.SellIn := SellIn;
Item.Quality := Quality;
end;
function StrItem(Item: Item): string;
var SellInStr: string;
QualityStr: string;
begin
Str(Item.SellIn, SellInStr);
Str(Item.Quality, QualityStr);
StrItem := Item.Name + ', ' + SellInStr + ', ' + QualityStr;
end;
procedure UpdateQuality(Items: ListOfItems);
var I: Word;
begin
for I := 0 to Items.Length-1 do
begin
if (Items.Elements^[I].Name <> 'Aged Brie') and
(Items.Elements^[I].Name <> 'Backstage passes to a TAFKAL80ETC concert') then
begin
if Items.Elements^[I].Quality > 0 then
begin
if Items.Elements^[I].Name <> 'Sulfuras, Hand of Ragnaros' then
begin
Items.Elements^[I].Quality := Items.Elements^[I].Quality - 1;
end;
end;
end
else
begin
if Items.Elements^[I].Quality < 50 then
begin
Items.Elements^[I].Quality := Items.Elements^[I].Quality + 1;
if Items.Elements^[I].Name = 'Backstage passes to a TAFKAL80ETC concert' then
begin
if Items.Elements^[I].SellIn < 11 then
begin
if Items.Elements^[I].Quality < 50 then
begin
Items.Elements^[I].Quality := Items.Elements^[I].Quality + 1;
end;
end;
if Items.Elements^[I].SellIn < 6 then
begin
if Items.Elements^[I].Quality < 50 then
begin
Items.Elements^[I].Quality := Items.Elements^[I].Quality + 1;
end;
end;
end;
end;
end;
if Items.Elements^[I].Name <> 'Sulfuras, Hand of Ragnaros' then
begin
Items.Elements^[I].SellIn := Items.Elements^[I].SellIn - 1;
end;
if Items.Elements^[I].SellIn < 0 then
begin
if Items.Elements^[I].Name <> 'Aged Brie' then
begin
if Items.Elements^[I].Name <> 'Backstage passes to a TAFKAL80ETC concert' then
begin
if Items.Elements^[I].Quality > 0 then
begin
if Items.Elements^[I].Name <> 'Sulfuras, Hand of Ragnaros' then
begin
Items.Elements^[I].Quality := Items.Elements^[I].Quality - 1;
end;
end;
end
else
begin
Items.Elements^[I].Quality := Items.Elements^[I].Quality - Items.Elements^[I].Quality;
end;
end
else
begin
if Items.Elements^[I].Quality < 50 then
begin
Items.Elements^[I].Quality := Items.Elements^[I].Quality + 1;
end;
end;
end;
end;
end;
end.

29
pascal/ROSE_T.PAS Normal file
View File

@ -0,0 +1,29 @@
{F+} { need to set Far Calls in Compiler Options too }
program Rose_T;
uses TPUnit, Rose;
var Items: ListOfItems;
procedure CreateItem;
begin
ResizeList(Items, 1);
end;
procedure DisposeItem;
begin
ClearList(Items);
end;
procedure Foo;
begin
InitItem(Items.Elements^[0], 'foo', 0, 0);
UpdateQuality(Items);
AssertEqualsStr('name', 'fixme', Items.Elements^[0].Name);
end;
begin
RunFixtures('foo', CreateItem, Foo, DisposeItem);
end.

60
pascal/TEXTTEST.PAS Normal file
View File

@ -0,0 +1,60 @@
program TextTests;
uses Rose;
var Items: ListOfItems;
Last: Word;
Days, Day: Integer;
ErrorCode: Integer;
DayStr: string;
I: Word;
begin
WriteLn('OMGHAI!');
ResizeList(Items, 9);
Last := 0;
InitItem(Items.Elements^[Last], '+5 Dexterity Vest', 10, 20);
Inc(Last);
InitItem(Items.Elements^[Last], 'Aged Brie', 2, 0);
Inc(Last);
InitItem(Items.Elements^[Last], 'Elixir of the Mongoose', 5, 7);
Inc(Last);
InitItem(Items.Elements^[Last], 'Sulfuras, Hand of Ragnaros', 0, 80);
Inc(Last);
InitItem(Items.Elements^[Last], 'Sulfuras, Hand of Ragnaros', -1, 80);
Inc(Last);
InitItem(Items.Elements^[Last], 'Backstage passes to a TAFKAL80ETC concert', 15, 20);
Inc(Last);
InitItem(Items.Elements^[Last], 'Backstage passes to a TAFKAL80ETC concert', 10, 49);
Inc(Last);
InitItem(Items.Elements^[Last], 'Backstage passes to a TAFKAL80ETC concert', 5, 49);
Inc(Last);
{ this Conjured item doesn't yet work properly }
InitItem(Items.Elements^[Last], 'Conjured Mana Cake', 3, 6);
Inc(Last);
Items.Length := Last;
Days := 2;
if ParamCount > 0 then
begin
Val(ParamStr(1), Days, ErrorCode);
Inc(Days);
end;
for Day := 0 to Days-1 do
begin
Str(Day, DayStr);
WriteLn('-------- day ' + DayStr + ' --------');
WriteLn('name, sellIn, quality');
for I := 0 to Items.Length-1 do
begin
WriteLn(StrItem(Items.Elements^[I]));
end;
WriteLn('');
UpdateQuality(Items);
end;
ClearList(Items);
end.

129
pascal/TPUNIT.PAS Normal file
View File

@ -0,0 +1,129 @@
{F+} { need to set Far Calls in Compiler Options too }
(* ------------------------------------------------------------------ *)
(* Minimalist xUnit implementation for Turbo Pascal in TP style. *)
(* Version: 2.01 *)
(* Language: Turbo Pascal 6.01 *)
(* Copyright: (c) 2010 Peter Kofler, www.code-cop.org *)
(* License: BSD, http://www.opensource.org/licenses/bsd-license.php *)
(* ------------------------------------------------------------------ *)
unit TPUnit;
interface
{
uses TPUnit;
Tests are added as methods without arguments to the test
program as usual and use asserts provided by the unit.
The first failed assertion stops program execution.
procedure TestAddition;
begin
AssertEquals('use asserts in tests', 2, 1 + 1);
end;
Due to the lack of introspection each test has to
be called manually in the main body.
begin
RunTest('TestAddition', TestAddition);
end.
}
type
TestMethod = procedure;
{ Asserts }
procedure AssertEquals(Message: string; Expected, Actual: Longint);
procedure AssertEqualsStr(Message: string; Expected, Actual: string);
procedure AssertNotNil(Message: string; Actual: Pointer);
procedure AssertNil(Message: string; Actual: Pointer);
procedure AssertTrue(Message: string; Actual: Boolean);
procedure AssertFalse(Message: string; Actual: Boolean);
procedure Fail(Message: string);
{ Test Runner }
procedure RunTest(Name: string; Test: TestMethod);
procedure RunFixtures(Name: string; SetUp, Test, TearDown: TestMethod);
procedure Empty;
implementation
uses Crt;
procedure AssertEquals(Message: string; Expected, Actual: Longint);
var ExpectedStr, ActualStr: string;
begin
if Expected <> Actual then
begin
Str(Expected, ExpectedStr);
Str(Actual, ActualStr);
Fail(Concat(Message, ' Expected ', ExpectedStr, ' but was ', ActualStr));
end;
end;
procedure AssertEqualsStr(Message: string; Expected, Actual: string);
begin
if Expected <> Actual then
begin
Fail(Concat(Message, ' Expected ', Expected, ' but was ', Actual));
end;
end;
procedure AssertNotNil(Message: string; Actual: Pointer);
begin
AssertFalse(Message, Actual = nil);
end;
procedure AssertNil(Message: string; Actual: Pointer);
begin
AssertTrue(Message, Actual = nil);
end;
procedure AssertTrue(Message: string; Actual: Boolean);
begin
if not Actual then
begin
Fail(Message);
end;
end;
procedure AssertFalse(Message: string; Actual: Boolean);
begin
AssertTrue(Message, not Actual);
end;
procedure Fail(Message: string);
begin
TextColor(Red);
WriteLn(' - FAILED');
NormVideo;
WriteLn(Message);
Halt(1);
end;
procedure Empty;
begin
end;
procedure RunTest(Name: string; Test: TestMethod);
begin
RunFixtures(Name, Empty, Test, Empty);
end;
procedure RunFixtures(Name: string; SetUp, Test, TearDown: TestMethod);
begin
Write('TEST ', Name);
SetUp;
Test;
TearDown;
TextColor(Green);
WriteLn(' - OK');
NormVideo;
end;
begin
Crt.ClrScr;
end.