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

pascal/.gitignore

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

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.

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.

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.

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.

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.