diff --git a/pascal/.gitignore b/pascal/.gitignore new file mode 100644 index 00000000..76fb8f67 --- /dev/null +++ b/pascal/.gitignore @@ -0,0 +1,11 @@ + +syntax: glob +*.bak +*.BAK +*.tpu +*.TPU +*.exe +*.EXE +*.$$$ +*.DSK +*.TP diff --git a/pascal/README.md b/pascal/README.md new file mode 100644 index 00000000..ef3e3985 --- /dev/null +++ b/pascal/README.md @@ -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. diff --git a/pascal/ROSE.PAS b/pascal/ROSE.PAS new file mode 100644 index 00000000..f78f3057 --- /dev/null +++ b/pascal/ROSE.PAS @@ -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. diff --git a/pascal/ROSE_T.PAS b/pascal/ROSE_T.PAS new file mode 100644 index 00000000..87b6679e --- /dev/null +++ b/pascal/ROSE_T.PAS @@ -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. diff --git a/pascal/TEXTTEST.PAS b/pascal/TEXTTEST.PAS new file mode 100644 index 00000000..dc06febc --- /dev/null +++ b/pascal/TEXTTEST.PAS @@ -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. diff --git a/pascal/TPUNIT.PAS b/pascal/TPUNIT.PAS new file mode 100644 index 00000000..01235de4 --- /dev/null +++ b/pascal/TPUNIT.PAS @@ -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.