1 files changed, 133 insertions, 0 deletions
diff --git a/appl/math/crackerbarrel.b b/appl/math/crackerbarrel.b
new file mode 100644
index 00000000..e5e1357b
--- /dev/null
+++ b/appl/math/crackerbarrel.b
@@ -0,0 +1,133 @@
+implement CBPuzzle;
+
+# Cracker Barrel Puzzle
+#
+# Holes are drilled in a triangular arrangement into which all but one
+# are seated pegs. A 6th order puzzle appears in the diagram below.
+# Note, the hole in the lower left corner of the triangle is empty.
+#
+#                 V
+#               V   V
+#             V   V   V
+#           V   V   V   V
+#         V   V   V   V   V
+#       O   V   V   V   V   V
+#
+# Pegs are moved by jumping over a neighboring peg thereby removing the
+# jumped peg. A peg can only be moved if a neighboring hole contains a
+# peg and the hole on the other side of the neighbor is empty. The last
+# peg cannot be removed.
+#
+# The object is to remove as many pegs as possible.
+
+include "sys.m";
+   sys: Sys;
+include "draw.m";
+
+CBPuzzle: module {
+   init: fn(nil: ref Draw->Context, args: list of string);
+};
+
+ORDER: con 6;
+
+Move: adt {
+   x, y: int;
+};
+
+valid:= array[] of {Move (1,0), (0,1), (-1,1), (-1,0), (0,-1), (1,-1)};
+
+board:= array[ORDER*ORDER] of int;
+pegs, minpegs: int;
+
+puzzle(): int
+{
+   if (pegs < minpegs)
+      minpegs = pegs;
+
+   if (pegs == 1)
+      return 1;
+
+   # Check each row of puzzle
+   for (r := 0; r < ORDER; r += 1)
+      # Check each column
+      for (c := 0; c < ORDER-r; c += 1) {
+         fromx := r*ORDER + c;
+         # Is a peg in this hole?
+         if (board[fromx])
+            # Check valid moves from this hole
+            for (m := 0; m < len valid; m += 1) {
+               tor := r + 2*valid[m].y;
+               toc := c + 2*valid[m].x;
+
+               # Is new location still on the board?
+               if (tor + toc < ORDER && tor >= 0 && toc >= 0) {
+                  jumpr := r + valid[m].y;
+                  jumpc := c + valid[m].x;
+                  jumpx := jumpr*ORDER + jumpc;
+
+                  # Is neighboring hole occupied?
+                  if (board[jumpx]) {
+                     # Is new location empty?
+                     tox := tor*ORDER + toc;
+
+                     if (! board[tox]) {
+                        # Jump neighboring hole
+                        board[fromx] = 0;
+                        board[jumpx] = 0;
+                        board[tox] = 1;
+                        pegs -= 1;
+
+                        # Try solving puzzle from here
+                        if (puzzle()) {
+                           #sys->print("(%d,%d) - (%d,%d)\n", r, c, tor, toc);
+                           return 1;
+                        }
+                        # Dead end, put pegs back and try another move
+                        board[fromx] = 1;
+                        board[jumpx] = 1;
+                        board[tox] = 0;
+                        pegs += 1;
+                     } # empty location
+                  } # occupied neighbor
+               } # still on board
+            } # valid moves
+      }
+   return 0;
+}
+
+solve(): int
+{
+   minpegs = pegs = (ORDER+1)*ORDER/2 - 1;
+
+   # Put pegs on board
+   for (r := 0; r < ORDER; r += 1)
+      for (c := 0; c < ORDER - r; c += 1)
+         board[r*ORDER + c] = 1;
+
+   # Remove one peg
+   board[0] = 0;
+
+   return puzzle();
+}
+
+init(nil: ref Draw->Context, args: list of string)
+{
+   sys = load Sys Sys->PATH;
+
+   TRIALS: int;
+   if (len args < 2)
+      TRIALS = 1;
+   else
+      TRIALS = int hd tl args;
+
+   start := sys->millisec();
+   for (trials := 0; trials < TRIALS; trials += 1)
+      solved := solve();
+   end := sys->millisec();
+
+   sys->print("%d ms\n", end - start);
+
+   if (! solved)
+      sys->print("No solution\n");
+   sys->print("Minimum pegs: %d\n", minpegs);
+}