Add alphametics exercise (#104)

Author: keiravillekode

config.json

@@ -804,6 +804,14 @@
         "prerequisites": [],
         "difficulty": 7
       },
+      {
+        "slug": "alphametics",
+        "name": "Alphametics",
+        "uuid": "001eb6d6-0443-4326-888b-ed9d5e9bc120",
+        "practices": [],
+        "prerequisites": [],
+        "difficulty": 8
+      },
       {
         "slug": "connect",
         "name": "Connect",

exercises/practice/alphametics/.docs/instructions.md

@@ -0,0 +1,29 @@
+# Instructions
+
+Given an alphametics puzzle, find the correct solution.
+
+[Alphametics][alphametics] is a puzzle where letters in words are replaced with numbers.
+
+For example `SEND + MORE = MONEY`:
+
+```text
+  S E N D
+  M O R E +
+-----------
+M O N E Y
+```
+
+Replacing these with valid numbers gives:
+
+```text
+  9 5 6 7
+  1 0 8 5 +
+-----------
+1 0 6 5 2
+```
+
+This is correct because every letter is replaced by a different number and the words, translated into numbers, then make a valid sum.
+
+Each letter must represent a different digit, and the leading digit of a multi-digit number must not be zero.
+
+[alphametics]: https://en.wikipedia.org/wiki/Alphametics

exercises/practice/alphametics/.meta/config.json

@@ -0,0 +1,17 @@
+{
+  "authors": [
+    "keiravillekode"
+  ],
+  "files": {
+    "solution": [
+      "Alphametics.pas"
+    ],
+    "test": [
+      "TestCases.pas"
+    ],
+    "example": [
+      ".meta/example.pas"
+    ]
+  },
+  "blurb": "Given an alphametics puzzle, find the correct solution."
+}

exercises/practice/alphametics/.meta/example.pas

@@ -0,0 +1,163 @@
+unit Alphametics;
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+function solve(const puzzle : string) : string;
+
+implementation
+
+uses SysUtils;
+
+type
+  ESolved = class(Exception);
+
+function solve(const puzzle : string) : string;
+type
+  TLetter = record
+    letter  : char;
+    rank    : integer;           { lowest column where letter appears }
+    weight  : array of integer;
+    leading : boolean;           { cannot be assigned 0 }
+    digit   : integer;
+  end;
+  TLetters = array of TLetter;
+var
+  letters : TLetters;
+  nColumns  : integer;
+
+  function ParsePuzzle : TLetters;
+  var
+    table : array[0..25] of TLetter;
+
+    procedure Scan;
+    var
+      i, c, sign, place, prev : integer;
+    begin
+      for i := 0 to 25 do begin
+        table[i].letter  := chr(ord('A') + i);
+        table[i].rank    := High(integer);
+        table[i].weight  := nil;
+        table[i].leading := false;
+      end;
+
+      sign := -1;
+      place := 0;
+      prev := 0;
+      for i := length(puzzle) downto 1 do begin
+        c := ord(puzzle[i]) - ord('A');
+        if (c >= 0) and (c < 26) then
+          begin
+            if place < table[c].rank then
+              table[c].rank := place;
+
+            if length(table[c].weight) <= place then
+              SetLength(table[c].weight, place + 1);
+
+            inc(table[c].weight[place], sign);
+            prev := c;
+            inc(place);
+          end
+        else
+          begin
+            if puzzle[i] = '=' then
+              sign := 1;
+
+            if place > 0 then
+              table[prev].leading := true;
+
+            place := 0;
+          end;
+      end;
+      if place > 0 then
+        table[prev].leading := true;
+    end;
+
+    function Compact : TLetters;
+    var
+      i, j : integer;
+    begin
+      nColumns := 0;
+      result := nil;
+      for i := 0 to 25 do begin
+        if table[i].rank = High(integer) then
+          continue;
+
+        if length(table[i].weight) > nColumns then
+          nColumns := length(table[i].weight);
+
+        j := length(result);
+        SetLength(result, j + 1);
+        while (j > 0) and (result[j - 1].rank > table[i].rank) do
+          begin
+            result[j] := result[j - 1];
+            dec(j);
+          end;
+        result[j] := table[i];
+      end;
+    end;
+
+  begin
+    Scan;
+    result := Compact;
+  end;
+
+  procedure Search(index, claimed, col, carry : integer);
+  var
+    digit, k, colSum : integer;
+  begin
+    if (index = length(letters)) or (letters[index].rank > col) then
+      begin
+        colSum := carry;
+        for k := 0 to index - 1 do
+          if col < length(letters[k].weight) then
+            inc(colSum, letters[k].weight[col] * letters[k].digit);
+
+        if colSum mod 10 = 0 then
+          begin
+            if col + 1 < nColumns then
+              Search(index, claimed, col + 1, colSum div 10)
+            else if colSum div 10 = 0 then
+              raise ESolved.Create('');
+          end;
+      end
+    else
+      for digit := ord(letters[index].leading) to 9 do
+        begin
+          if claimed and (1 shl digit) <> 0 then
+            continue;
+
+          letters[index].digit := digit;
+          Search(index + 1, claimed or (1 shl digit), col, carry);
+        end;
+  end;
+
+  function BuildResult : string;
+  var
+    i     : integer;
+    table : array['A'..'Z'] of char;
+    ch    : char;
+  begin
+    for i := 0 to length(letters) - 1 do
+      table[letters[i].letter] := chr(ord('0') + letters[i].digit);
+
+    result := '';
+    for ch in puzzle do
+      if (ch >= 'A') and (ch <= 'Z') then
+        result += table[ch]
+      else
+        result += ch;
+  end;
+
+begin
+  letters := ParsePuzzle;
+  try
+    Search(0, 0, 0, 0);
+    raise Exception.Create('no solution');
+  except
+    on ESolved do result := BuildResult;
+  end;
+end;
+
+end.

exercises/practice/alphametics/.meta/tests.toml

@@ -0,0 +1,40 @@
+# This is an auto-generated file.
+#
+# Regenerating this file via `configlet sync` will:
+# - Recreate every `description` key/value pair
+# - Recreate every `reimplements` key/value pair, where they exist in problem-specifications
+# - Remove any `include = true` key/value pair (an omitted `include` key implies inclusion)
+# - Preserve any other key/value pair
+#
+# As user-added comments (using the # character) will be removed when this file
+# is regenerated, comments can be added via a `comment` key.
+
+[e0c08b07-9028-4d5f-91e1-d178fead8e1a]
+description = "puzzle with three letters"
+
+[a504ee41-cb92-4ec2-9f11-c37e95ab3f25]
+description = "solution must have unique value for each letter"
+
+[4e3b81d2-be7b-4c5c-9a80-cd72bc6d465a]
+description = "leading zero solution is invalid"
+
+[8a3e3168-d1ee-4df7-94c7-b9c54845ac3a]
+description = "puzzle with two digits final carry"
+
+[a9630645-15bd-48b6-a61e-d85c4021cc09]
+description = "puzzle with four letters"
+
+[3d905a86-5a52-4e4e-bf80-8951535791bd]
+description = "puzzle with six letters"
+
+[4febca56-e7b7-4789-97b9-530d09ba95f0]
+description = "puzzle with seven letters"
+
+[12125a75-7284-4f9a-a5fa-191471e0d44f]
+description = "puzzle with eight letters"
+
+[fb05955f-38dc-477a-a0b6-5ef78969fffa]
+description = "puzzle with ten letters"
+
+[9a101e81-9216-472b-b458-b513a7adacf7]
+description = "puzzle with ten letters and 199 addends"

exercises/practice/alphametics/Alphametics.pas

@@ -0,0 +1,18 @@
+unit Alphametics;
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+function solve(const puzzle : string) : string;
+
+implementation
+
+uses SysUtils;
+
+function solve(const puzzle : string) : string;
+begin
+  raise ENotImplemented.Create('Please implement your solution.'); result := puzzle;
+end;
+
+end.

exercises/practice/alphametics/Makefile

@@ -0,0 +1,15 @@
+SHELL       = /bin/bash
+MAKEFLAGS  += --no-print-directory
+DESTDIR     = build
+EXECUTABLE  = $(DESTDIR)/test
+COMMAND     = fpc -l- -v0 -g -gl -Sa -Cr -Sehnw -Fu./lib test.pas -FE"./$(DESTDIR)"
+
+.ONESHELL:
+
+test:
+	@mkdir -p "./$(DESTDIR)"
+	@cp -r ./lib "./$(DESTDIR)"
+	@$(COMMAND) && ./$(EXECUTABLE) $(test)
+
+clean:
+	@rm -fr "./$(DESTDIR)"