From dc75c38332b39a252a9d9834075f40c26ba1944c Mon Sep 17 00:00:00 2001
From: Karl Ostmo <kostmo@gmail.com>
Date: Sat, 29 Apr 2023 13:40:54 -0700
Subject: [PATCH] sliding puzzle

---
 .../Challenges/_sliding-puzzle/judge.sw       | 322 +++++++++++++
 .../Challenges/_sliding-puzzle/solution.sw    |  22 +
 .../_sliding-puzzle/validate-board.sw         |  54 +++
 data/scenarios/Challenges/sliding-puzzle.yaml | 437 ++++++++++++++++++
 4 files changed, 835 insertions(+)
 create mode 100644 data/scenarios/Challenges/_sliding-puzzle/judge.sw
 create mode 100644 data/scenarios/Challenges/_sliding-puzzle/solution.sw
 create mode 100644 data/scenarios/Challenges/_sliding-puzzle/validate-board.sw
 create mode 100644 data/scenarios/Challenges/sliding-puzzle.yaml

diff --git a/data/scenarios/Challenges/_sliding-puzzle/judge.sw b/data/scenarios/Challenges/_sliding-puzzle/judge.sw
new file mode 100644
index 0000000000..0b173429a4
--- /dev/null
+++ b/data/scenarios/Challenges/_sliding-puzzle/judge.sw
@@ -0,0 +1,322 @@
+def id = \t. t end
+def elif = \t. \then. \else. {if t then else} end
+def else = id end
+
+/**
+Returns true if should terminate the parent
+function's recursion due to goal being met.
+*/
+def intersperseUntil = \n. \f2. \f1.
+    if (n > 0) {
+        shouldTerminate <- f1;
+        if shouldTerminate {
+            return true;
+        } {
+            if (n > 1) {
+                f2;
+            } {};
+            intersperseUntil (n - 1) f2 f1;
+        };
+    } {
+        return false;
+    };
+    end;
+
+def getDirection = \n.
+    if (n == 0) {
+        forward;
+    } $ elif (n == 1) {
+        right;
+    } $ elif (n == 2) {
+        back;
+    } $ elif (n == 3) {
+        left;
+    } $ else {
+        down;
+    };
+    end;
+
+def watchDir = \n.
+    watch $ getDirection n;
+    if (n > 0) {
+        watchDir $ n - 1;
+    } {};
+    end;
+
+def getOrdinal : text -> cmd int = \item.
+    count $ item ++ "-ordinal";
+    end;
+
+def getValueHere =
+    maybeItem <- scan down;
+    ordNum <- case maybeItem (\_. return 0) getOrdinal;
+    end;
+
+/**
+  Swaps the element at the current position
+  with the element "x" cells away.
+  Useful for an in-place sort.
+
+  Precondition: Facing east.
+*/
+def swapRelative = \x.
+    if (x > 0) {
+        currentItem <- grab;
+        stride x;
+        otherItem <- grab;
+        place currentItem;
+        turn back;
+        stride x;
+        place otherItem;
+        turn back;
+    } {};
+    end;
+
+/**
+  Fisher-Yates shuffle on a physical array
+
+  Precondition:
+  * Array is oriented horizontally
+  * Robot is placed at the head (left end) of the array
+  * Robot is facing right
+
+  "n" is the size of the array.
+*/
+def shuffle = \n. \i.
+    if (i < n - 1) {
+        let randAmplitude = n - i in
+        x <- random randAmplitude;
+        swapRelative x;
+        move;
+        shuffle n $ i + 1;
+    } {};
+    end;
+
+// Inner loop in inversion-counting algorithm
+def countInnerInversions = \n. \referenceVal. \j.
+
+    if (j < n - 1) {
+        move;
+        valueHere <- getValueHere;
+        let addend = if (referenceVal > valueHere) {1} {0} in
+        recursiveSum <- countInnerInversions n referenceVal $ j + 1;
+        let foo = recursiveSum in
+        return $ addend + foo;
+    } {
+        return 0;
+    };
+    end
+
+/**
+  "n" represents array length.
+  Runs in O(n^2) time.
+*/
+def countInversions = \n. \i.
+    if (i < n - 1) {
+        valueHere <- getValueHere;
+        innerCount <- countInnerInversions n valueHere i;
+        let innerCountFoo = innerCount in
+        turn back;
+        // Go backward one fewer space each time.
+        stride $ n - i - 2;
+        turn back;
+        subarrayInversions <- countInversions n $ i + 1;
+        let foo = subarrayInversions in
+        return $ innerCountFoo + foo;
+    } {
+        return 0;
+    };
+    end
+
+/**
+Left is a Boolean indicating whether the tile has been drilled.
+Right is a valid tile entity name.
+*/
+def scanValid : dir -> cmd (bool + text) = \d.
+    maybeTileForward <- scan d;
+    case maybeTileForward
+        (\_. return $ inL false)
+        (\x.
+            if (x == "sliding-tile") {
+                return $ inL true;
+            } {
+                y <- getOrdinal x;
+                return $ if (y > 0) {
+                    inR x;
+                } {
+                    inL false;
+                };
+            };
+        );
+    end
+
+/**
+Returns true if the (multi-row) search should terminate early.
+*/
+def findBlankInRow = \n.
+    if (n > 0) {
+        mt <- isempty;
+        if mt {
+            return true;
+        } {
+            move;
+            findBlankInRow $ n - 1;
+        };
+    } {
+        return false;
+    };
+    end;
+
+def turnaround = \d.
+    turn d;
+    move;
+    turn d;
+    end;
+
+/**
+  Raster-scan the playfield
+  until we get to an empty tile.
+  If we don't find any, raise an exception
+  that will end the game.
+*/
+def moveToBlankTile = \boardWidth.
+    teleport self (0, 0);
+    turn east;
+
+    intersperseUntil 2 (turnaround left;) $
+        intersperseUntil 2 (turnaround right) $
+            findBlankInRow $ boardWidth - 1;
+    end;
+
+/**
+  Precondition: The original item was a valid tile.
+  Returns true if a drilling took place.
+  Returns false if something unexpected happened
+  and we should abort/reset.
+*/
+def actOnItemComparison = \maybeNewItem. \original.
+
+    case maybeNewItem (\isSlidingTile.
+        if isSlidingTile {
+            create original;
+            place original;
+            move;
+            grab;
+            // Abort early from the recursion.
+            return false;
+        } {
+            // The new tile is not a sliding tile.
+            // We assume it's a blank tile and move there.
+            // If it turns out not to be blank, that will
+            // be addressed in the outer "observe" loop.
+            move;
+            return false;
+        };
+    ) (\newItem.
+        let isSame = newItem == original in
+        // We expect the tile to be unchanged, if it is not a sliding tile.
+        if isSame {} {
+            say $ "Original was " ++ original ++ "; newItem was " ++ newItem;
+        };
+        return isSame;
+    );
+    end;
+
+def unwind = \keepChecking. \maybeItem.
+    if keepChecking {
+
+        turn right;
+
+        // For now, we assume that there exist no "drilled" tiles
+        // at the "wind-up"; the drilling shall always happen while
+        // we are waiting at the peak of the recursion stack.
+        maybeItem2 <- scanValid forward;
+
+        keepGoing <- case maybeItem (
+            \isSlidingTile. if isSlidingTile {
+                // Our assumption was invalid; we don't have a
+                // valid reference tile to compared the drilled tile to.
+                say "Unexpected drilling; no reference tile.";
+                return false;
+            } {
+                return true;
+            }
+        ) (actOnItemComparison maybeItem2);
+        return keepGoing;
+    } {
+        return false;
+    };
+    end;
+
+/** Precondition:
+  Robot resides on the single blank tile within the puzzle rectangle.
+  Our initial orientation does not matter.
+
+  Strategy:
+  Observe the entity contents in four directions, winding them into the stack.
+  Then wait for a change to any of those cells.
+  Upon change, unwind the stack, comparing the previously-known entity in each
+  direction to the current entity.
+
+  If there was no change, which can happen due to timeout of the `wait`,
+  just wind up the stack again.
+*/
+def auditNeighbors = \depth.
+    if (depth > 0) {
+        maybeItemBlah <- scanValid forward;
+
+        // NOTE: This let-binding circumvents bug #1032
+        let maybeItem = maybeItemBlah in
+        turn left;
+        keepChecking <- auditNeighbors $ depth - 1;
+        instant $ unwind keepChecking maybeItem;
+    } {
+        instant $ watchDir 4;
+        wait 10000;
+        return true;
+    };
+    end;
+
+def observe = \boardWidth. \boardHeight.
+    // We expect to begin each iteration on an empty tile.
+    // If we are not, reposition ourselves.
+    mt <- isempty;
+    if mt {} {
+        // Will return false
+        moveToBlankTile boardWidth;
+        return ();
+    };
+
+    try {
+        auditNeighbors 4;
+        return ();
+    } {};
+    
+    observe boardWidth boardHeight;
+    end;
+
+def prepareArray = \boardWidth. \boardHeight.
+    let arrayLoc = (-3, -6) in
+    teleport self arrayLoc;
+
+    let cellCount = boardWidth * boardHeight in
+    let arrayLength = cellCount - 1 in
+
+    instant $ shuffle arrayLength 0;
+
+    teleport self arrayLoc;
+    inversionCount <- countInversions arrayLength 0;
+    say $ "Inversion count: " ++ format inversionCount;
+    end;
+
+def go =
+    let boardWidth = 4 in
+    let boardHeight = 4 in
+
+    prepareArray boardWidth boardHeight;
+
+    teleport self (0, 0);
+    observe boardWidth boardHeight;
+    end;
+
+go;
\ No newline at end of file
diff --git a/data/scenarios/Challenges/_sliding-puzzle/solution.sw b/data/scenarios/Challenges/_sliding-puzzle/solution.sw
new file mode 100644
index 0000000000..43c31bbd31
--- /dev/null
+++ b/data/scenarios/Challenges/_sliding-puzzle/solution.sw
@@ -0,0 +1,22 @@
+def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;
+
+def getOrdinal : text -> cmd int = \item.
+    count $ item ++ "-ordinal";
+    end;
+
+def go =
+    doN 5 move;
+    turn right;
+    doN 3 move;
+    turn left;
+
+    maybeItem <- scan forward;
+    // TODO Use this to solve the puzzle
+    ordNum <- case maybeItem (\_. return 0) getOrdinal;
+    log $ "Ordnum: " ++ format ordNum;
+
+    drill forward;
+    end;
+
+wait 10;
+//go;
\ No newline at end of file
diff --git a/data/scenarios/Challenges/_sliding-puzzle/validate-board.sw b/data/scenarios/Challenges/_sliding-puzzle/validate-board.sw
new file mode 100644
index 0000000000..8ea5e85f5d
--- /dev/null
+++ b/data/scenarios/Challenges/_sliding-puzzle/validate-board.sw
@@ -0,0 +1,54 @@
+def id = \t. t end
+def elif = \t. \then. \else. {if t then else} end
+def else = id end
+
+def mod : int -> int -> int = \i.\m.
+  i - m * (i / m)
+end
+
+def getOrdinal : text -> cmd int = \item.
+    count $ item ++ "-ordinal";
+    end;
+
+/**
+  Cells are allowed to be either empty or a valid game tile.
+  Returns a Left if we are non-monotonic.
+  Otherwise returns the next expected value.
+*/
+def isMonotonic : int -> cmd (unit + int) = \expectedVal.
+    maybeItem <- scan down;
+    case maybeItem
+        (\_. return $ inR expectedVal) // Cell was blank
+        (\entity.
+            intVal <- getOrdinal entity;
+            if (intVal == expectedVal) {
+                return $ inR $ expectedVal + 1;
+            } {
+                return $ inL ();
+            };
+        );
+    end;
+
+/**
+  Recurses over all cells in all rows.
+  Moves by teleportation. Uses modulus
+  to traverse between rows.
+*/
+def loopMonotonicityCheck : int -> int -> int -> int -> cmd bool = \boardWidth. \boardHeight. \idx. \expectedVal.
+    if (idx < boardWidth * boardHeight) {
+        let x = mod idx boardWidth in
+        let y = idx / boardWidth in
+        let coords = (x, -y) in
+        teleport self coords;
+        maybeNextVal <- isMonotonic expectedVal;
+        case maybeNextVal
+            (\_. return false)
+            (\nextVal.
+                loopMonotonicityCheck boardWidth boardHeight (idx + 1) nextVal;
+            );
+    } {
+        return true;
+    }
+    end;
+
+loopMonotonicityCheck 4 4 0 1;
\ No newline at end of file
diff --git a/data/scenarios/Challenges/sliding-puzzle.yaml b/data/scenarios/Challenges/sliding-puzzle.yaml
new file mode 100644
index 0000000000..0b5357bcbb
--- /dev/null
+++ b/data/scenarios/Challenges/sliding-puzzle.yaml
@@ -0,0 +1,437 @@
+version: 1
+name: Sliding puzzle
+author: Karl Ostmo
+description: |
+  Place the 15 tiles in order
+creative: false
+seed: 0
+attrs:
+  - name: oddtile
+    fg: "#D2B48C"
+    bg: "#400000"
+  - name: eventile
+    fg: "#000000"
+    bg: "#B0B0B0"
+objectives:
+  - teaser: Solve puzzle
+    goal:
+      - |
+        Arrange the tiles in increasing (row-major) order.
+      - |
+        To slide a tile into the empty space, position yourself
+        behind it and `push`.
+      - |
+        Or, if you prefer, `drill` a tile to cause it to slide
+        into the adjacent empty space. However, you must not drill a tile that
+        has nowhere to slide or drill again too quickly in succession.
+    condition: |
+      j <- robotnamed "judge";
+      as j {run "scenarios/Challenges/_sliding-puzzle/validate-board.sw"};
+robots:
+  - name: base
+    dir: [1, 0]
+    devices:
+      - ADT calculator
+      - antenna
+      - branch predictor
+      - clock
+      - comparator
+      - compass
+      - counter
+      - dictionary
+      - dozer blade
+      - drill
+      - hearing aid
+      - lambda
+      - logger
+      - mirror
+      - scanner
+      - strange loop
+      - string
+      - treads
+      - welder
+      - workbench
+    inventory:
+      - [1, a-tile-ordinal]
+      - [2, b-tile-ordinal]
+      - [3, c-tile-ordinal]
+      - [4, d-tile-ordinal]
+      - [5, e-tile-ordinal]
+      - [6, f-tile-ordinal]
+      - [7, g-tile-ordinal]
+      - [8, h-tile-ordinal]
+      - [9, i-tile-ordinal]
+      - [10, j-tile-ordinal]
+      - [11, k-tile-ordinal]
+      - [12, l-tile-ordinal]
+      - [13, m-tile-ordinal]
+      - [14, n-tile-ordinal]
+      - [15, o-tile-ordinal]
+  - name: judge
+    system: true
+    dir: [1, 0]
+    display:
+      invisible: false
+      attr: 'iron'
+    inventory:
+      - [1, a-tile-ordinal]
+      - [2, b-tile-ordinal]
+      - [3, c-tile-ordinal]
+      - [4, d-tile-ordinal]
+      - [5, e-tile-ordinal]
+      - [6, f-tile-ordinal]
+      - [7, g-tile-ordinal]
+      - [8, h-tile-ordinal]
+      - [9, i-tile-ordinal]
+      - [10, j-tile-ordinal]
+      - [11, k-tile-ordinal]
+      - [12, l-tile-ordinal]
+      - [13, m-tile-ordinal]
+      - [14, n-tile-ordinal]
+      - [15, o-tile-ordinal]
+    program: |
+      run "scenarios/Challenges/_sliding-puzzle/judge.sw";
+solution: |
+   run "scenarios/Challenges/_sliding-puzzle/solution.sw"
+entities:
+  - name: border
+    display:
+      char: '▒'
+    description:
+      - Immovable playfield border
+    properties: [known]
+  - name: dozer blade
+    display:
+      attr: silver
+      char: '/'
+    description:
+    - Facilitates pushing
+    properties: [known, portable]
+    capabilities: [push]
+  - name: sliding-tile
+    display:
+      char: '*'
+    description:
+      - Tile that is being moved
+    properties: [known]
+  - name: a-tile
+    display:
+      char: 'a'
+      attr: oddtile
+    description:
+      - One
+    properties: [known, portable]
+  - name: b-tile
+    display:
+      char: 'b'
+      attr: eventile
+    description:
+      - Two
+    properties: [known, portable]
+  - name: c-tile
+    display:
+      char: 'c'
+      attr: oddtile
+    description:
+      - Three
+    properties: [known, portable]
+  - name: d-tile
+    display:
+      char: 'd'
+      attr: eventile
+    description:
+      - Four
+    properties: [known, portable]
+  - name: e-tile
+    display:
+      char: 'e'
+      attr: eventile
+    description:
+      - Five
+    properties: [known, portable]
+  - name: f-tile
+    display:
+      char: 'f'
+      attr: oddtile
+    description:
+      - Six
+    properties: [known, portable]
+  - name: g-tile
+    display:
+      char: 'g'
+      attr: eventile
+    description:
+      - Seven
+    properties: [known, portable]
+  - name: h-tile
+    display:
+      char: 'h'
+      attr: oddtile
+    description:
+      - Eight
+    properties: [known, portable]
+  - name: i-tile
+    display:
+      char: 'i'
+      attr: oddtile
+    description:
+      - Nine
+    properties: [known, portable]
+  - name: j-tile
+    display:
+      char: 'j'
+      attr: eventile
+    description:
+      - Ten
+    properties: [known, portable]
+  - name: k-tile
+    display:
+      char: 'k'
+      attr: oddtile
+    description:
+      - Eleven
+    properties: [known, portable]
+  - name: l-tile
+    display:
+      char: 'l'
+      attr: eventile
+    description:
+      - Twelve
+    properties: [known, portable]
+  - name: m-tile
+    display:
+      char: 'm'
+      attr: eventile
+    description:
+      - Thirteen
+    properties: [known, portable]
+  - name: n-tile
+    display:
+      char: 'n'
+      attr: oddtile
+    description:
+      - Fourteen
+    properties: [known, portable]
+  - name: o-tile
+    display:
+      char: 'o'
+      attr: eventile
+    description:
+      - Fifteen
+    properties: [known, portable]
+  - name: a-tile-ordinal
+    display:
+      char: 'a'
+    description:
+      - One
+    properties: [known]
+  - name: b-tile-ordinal
+    display:
+      char: 'b'
+    description:
+      - Two
+    properties: [known]
+  - name: c-tile-ordinal
+    display:
+      char: 'c'
+    description:
+      - Three
+    properties: [known]
+  - name: d-tile-ordinal
+    display:
+      char: 'd'
+    description:
+      - Four
+    properties: [known]
+  - name: e-tile-ordinal
+    display:
+      char: 'e'
+    description:
+      - Five
+    properties: [known]
+  - name: f-tile-ordinal
+    display:
+      char: 'f'
+    description:
+      - Six
+    properties: [known]
+  - name: g-tile-ordinal
+    display:
+      char: 'g'
+    description:
+      - Seven
+    properties: [known]
+  - name: h-tile-ordinal
+    display:
+      char: 'h'
+    description:
+      - Eight
+    properties: [known]
+  - name: i-tile-ordinal
+    display:
+      char: 'i'
+    description:
+      - Nine
+    properties: [known]
+  - name: j-tile-ordinal
+    display:
+      char: 'j'
+    description:
+      - Ten
+    properties: [known]
+  - name: k-tile-ordinal
+    display:
+      char: 'k'
+    description:
+      - Eleven
+    properties: [known]
+  - name: l-tile-ordinal
+    display:
+      char: 'l'
+    description:
+      - Twelve
+    properties: [known]
+  - name: m-tile-ordinal
+    display:
+      char: 'm'
+    description:
+      - Thirteen
+    properties: [known]
+  - name: n-tile-ordinal
+    display:
+      char: 'n'
+    description:
+      - Fourteen
+    properties: [known]
+  - name: o-tile-ordinal
+    display:
+      char: 'o'
+    description:
+      - Fifteen
+    properties: [known]
+recipes:
+  - in:
+      - [1, a-tile]
+    out:
+      - [1, sliding-tile]
+    required:
+      - [1, drill]
+  - in:
+      - [1, b-tile]
+    out:
+      - [1, sliding-tile]
+    required:
+      - [1, drill]
+  - in:
+      - [1, c-tile]
+    out:
+      - [1, sliding-tile]
+    required:
+      - [1, drill]
+  - in:
+      - [1, d-tile]
+    out:
+      - [1, sliding-tile]
+    required:
+      - [1, drill]
+  - in:
+      - [1, e-tile]
+    out:
+      - [1, sliding-tile]
+    required:
+      - [1, drill]
+  - in:
+      - [1, f-tile]
+    out:
+      - [1, sliding-tile]
+    required:
+      - [1, drill]
+  - in:
+      - [1, g-tile]
+    out:
+      - [1, sliding-tile]
+    required:
+      - [1, drill]
+  - in:
+      - [1, h-tile]
+    out:
+      - [1, sliding-tile]
+    required:
+      - [1, drill]
+  - in:
+      - [1, i-tile]
+    out:
+      - [1, sliding-tile]
+    required:
+      - [1, drill]
+  - in:
+      - [1, j-tile]
+    out:
+      - [1, sliding-tile]
+    required:
+      - [1, drill]
+  - in:
+      - [1, k-tile]
+    out:
+      - [1, sliding-tile]
+    required:
+      - [1, drill]
+  - in:
+      - [1, l-tile]
+    out:
+      - [1, sliding-tile]
+    required:
+      - [1, drill]
+  - in:
+      - [1, m-tile]
+    out:
+      - [1, sliding-tile]
+    required:
+      - [1, drill]
+  - in:
+      - [1, n-tile]
+    out:
+      - [1, sliding-tile]
+    required:
+      - [1, drill]
+  - in:
+      - [1, o-tile]
+    out:
+      - [1, sliding-tile]
+    required:
+      - [1, drill]
+known: []
+world:
+  default: [grass]
+  upperleft: [-3, 2]
+  offset: false
+  palette:
+    B: [grass, null, base]
+    z: [grass, null, judge]
+    '.': [grass]
+    'x': [grass, border]
+    'a': [grass, a-tile]
+    'b': [grass, b-tile]
+    'c': [grass, c-tile]
+    'd': [grass, d-tile]
+    'e': [grass, e-tile]
+    'f': [grass, f-tile]
+    'g': [grass, g-tile]
+    'h': [grass, h-tile]
+    'i': [grass, i-tile]
+    'j': [grass, j-tile]
+    'k': [grass, k-tile]
+    'l': [grass, l-tile]
+    'm': [grass, m-tile]
+    'n': [grass, n-tile]
+    'o': [grass, o-tile]
+  map: |
+    ...............
+    ..xxxxxx.......
+    B.xabcdx.......
+    ..xefghx.......
+    ..xijkzx.......
+    ..xmnolx.......
+    ..xxxxxx.......
+    ...............
+    abcdefghijklmno
\ No newline at end of file