lights out

data/scenarios/Challenges/00-ORDER.txt

@@ -8,6 +8,7 @@ gopher.yaml
 ice-cream.yaml
 hanoi.yaml
 hackman.yaml
+lights-out.yaml
 bucket-brigade.yaml
 wolf-goat-cabbage.yaml
 friend.yaml

data/scenarios/Challenges/_lights-out/assistant.sw

@@ -0,0 +1,269 @@
+def elif = \t. \then. \else. {if t then else} end
+def else = \t. t end
+def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;
+
+def boolToInt = \b.
+    if b {1} {0}
+    end;
+
+// modulus function (%)
+def mod : int -> int -> int = \i.\m.
+  i - m * (i / m)
+end
+
+def isEven = \n.
+    mod n 2 == 0;
+    end
+
+def intersperse = \n. \f2. \f1. if (n > 0) {
+        f1;
+        if (n > 1) {
+            f2;
+        } {};
+        intersperse (n - 1) f2 f1;
+    } {};
+    end;
+
+def sumTuples = \t1. \t2.
+    (fst t1 + fst t2, snd t1 + snd t2);
+    end;
+
+def mapTuple = \f. \t.
+    (f $ fst t, f $ snd t)
+    end;
+
+def replaceWith = \withThis.
+    create withThis;
+    swap withThis;
+    return ();
+    end;
+
+/** Modifies the cell */
+def invertLight = \e.
+    if (e == "off") {
+        replaceWith "on";
+    } $ elif (e == "on") {
+        replaceWith "off";
+    } {}
+    end;
+
+def toggleLightHere =
+    entHere <- scan down;
+    case entHere return invertLight;
+    end;
+
+/** Precondition: in the middle of a "cross" */
+def toggleSingleNeighbor =
+    move;
+    toggleLightHere;
+    turn back;
+    move;
+    end;
+
+def toggleAllNeighbors =
+    doN 2 (
+        doN 2 toggleSingleNeighbor;
+        turn left;
+    );
+    end;
+
+def flipSelfAndNeighbors = \newState. \locOffset.
+    curLoc <- whereami;
+    let newLoc = sumTuples locOffset curLoc in
+    teleport self newLoc;
+    replaceWith newState;
+    toggleAllNeighbors;
+    teleport self curLoc;
+    end;
+
+def togglePending = \state.
+    let pendingEntityName = "pending-" ++ state in
+    maybePending <- detect pendingEntityName ((1, 1), (6, 6));
+    case maybePending return $ flipSelfAndNeighbors state;
+    end;
+
+def observe = \boardWidth. \boardHeight.
+    instant (
+        togglePending "on";
+        togglePending "off";
+    );
+    observe boardWidth boardHeight;
+    end;
+
+def makeOnIf = \b.
+    if b {replaceWith "on"} {};
+    end;
+
+/** Precondition: Light is off */
+def randomOn =
+    x <- random 2;
+    makeOnIf $ x == 0;
+    end;
+
+/**
+This is a distillation into code of the
+first quiet pattern here:
+https://www.jaapsch.net/puzzles/lights.htm#quiet
+
+10101
+10101
+00000
+10101
+10101
+
+Note that the second quiet pattern is just the transpose,
+so we can simply swap the position index arguments to obtain it:
+
+11011
+00000
+11011
+00000
+11011
+
+Indices are zero-based.
+*/
+def isQuietPatternMember = \rowIdx. \colIdx.
+    rowIdx != 2 && mod colIdx 2 == 0;
+    end;
+
+def advanceRowViaTeleport =
+    curLoc <- whereami;
+    teleport self (0, snd curLoc - 1);
+    end;
+
+def shouldCorrectTile : (bool * bool) -> (bool * bool) -> cmd bool = \evenOverlaps. \isQuietTiles.
+    if (evenOverlaps == isQuietTiles) {
+        toggleLightHere;
+        return true;
+    } {
+        return false;
+    }
+    end;
+
+/** Returns the number of lights in common
+with each quiet pattern, for this row.
+*/
+def prepareBoardRow = \abortFunc. \rowIdx. \colIdx.
+    if (colIdx >= 0) {
+
+        isCurrentlyOn <- ishere "on";
+
+        let isQuietTile1 = isQuietPatternMember rowIdx colIdx in
+        let isQuietTile2 = isQuietPatternMember colIdx rowIdx in
+
+        let quietTuple = (isQuietTile1, isQuietTile2) in
+
+        shouldAbort <- abortFunc quietTuple;
+        if shouldAbort {
+            return ((0, 0), true);
+        } {
+            let quietCellOn = mapTuple (\x. x && isCurrentlyOn) quietTuple in
+            let addend = mapTuple boolToInt quietCellOn in
+
+            move;
+            retval <- prepareBoardRow abortFunc rowIdx $ colIdx - 1;
+            let subTotal = fst retval in
+            return $ (sumTuples addend subTotal, snd retval);
+        }
+    } {
+        return ((0, 0), false);
+    }
+    end;
+
+/** Returns the number of lights in common
+with each quiet pattern.
+*/
+def prepareBoardAllRows = \abortFunc. \boardWidth. \rowIdx.
+    if (rowIdx >= 0) {
+        retval <- prepareBoardRow abortFunc rowIdx $ boardWidth - 1;
+        let rowCommonCount = fst retval in
+        let shouldAbort = snd retval in
+
+        if shouldAbort {
+            return (0, 0);
+        } {
+            advanceRowViaTeleport;
+
+            // This reassignment has to happen before the recursive
+            // "prepareBoardAllRows" call due to #1032
+            let rowCommonCountFoo = rowCommonCount in
+            totalCommonCount <- prepareBoardAllRows abortFunc boardWidth $ rowIdx - 1;
+
+            return $ sumTuples rowCommonCountFoo totalCommonCount
+        }
+    } {
+        return (0, 0);
+    }
+    end;
+
+def checkIsSolvable = \boardWidth. \boardHeight.
+    overlapCounts <- prepareBoardAllRows (\_. return false) boardWidth $ boardHeight - 1;
+    // say $ "Overlap counts: " ++ format overlapCounts;
+    return $ mapTuple isEven overlapCounts;
+    end;
+
+/** Teleports to a new location to execute a function
+  then returns to the original location before
+  returning the functions output value.
+*/
+def atLocation = \newLoc. \f.
+    prevLoc <- whereami;
+    teleport self newLoc;
+    retval <- f;
+    teleport self prevLoc;
+    return retval;
+    end;
+
+def analyzeSolvability : int -> int -> cmd (bool * bool) = \boardWidth. \boardHeight.
+    atLocation (0, 0) $
+        checkIsSolvable boardWidth boardHeight;
+    end;
+
+def prepareBoardRandom = \boardWidth. \boardHeight. 
+    atLocation (0, 0) $
+        intersperse boardHeight advanceRowViaTeleport $
+            intersperse boardWidth move randomOn;
+    end;
+
+def ensureSolvability = \evenOverlaps. \boardWidth. \boardHeight.
+    let isSolvable = fst evenOverlaps && snd evenOverlaps in
+    // say $ "isSolvable: " ++ format isSolvable;
+    if isSolvable {} {
+        atLocation (0, 0) $
+            prepareBoardAllRows (shouldCorrectTile $ mapTuple not evenOverlaps) boardWidth $ boardHeight - 1;
+        return ()
+    }
+    end;
+
+/**
+Only about one in four randomly-assigned light patterns
+are actual solvable lights-out games, so we make
+an adjustment if our particular pattern is not solvable.
+
+It so happens that an unsolvable board can be made
+solvable by toggling exactly one carefully chosen light.
+*/
+def generateGame = \boardWidth. \boardHeight.
+
+    prepareBoardRandom boardWidth boardHeight;
+
+    evenOverlaps <- analyzeSolvability boardWidth boardHeight;
+    ensureSolvability evenOverlaps boardWidth boardHeight;
+
+    // Sanity checking:
+    // evenOverlaps2 <- analyzeSolvability boardWidth boardHeight;
+    // let isSolvable2 = fst evenOverlaps2 && snd evenOverlaps2 in
+    // say $ "isSolvable2: " ++ format isSolvable2;
+
+    // "Sentinel" to indicate that board preparation is complete
+    create "flower";
+    end;
+
+def go =
+    let boardWidth = 5 in
+    let boardHeight = 5 in
+    instant $ generateGame boardWidth boardHeight;
+    observe boardWidth boardHeight;
+    end;
+
+go;

data/scenarios/Challenges/_lights-out/design-commentary.md

@@ -0,0 +1,14 @@
+# Puzzle generation
+
+Solvability for a puzzle of given dimensions can be determined by deriving the "quiet patterns" via linear algebra and ensuring that only an even number of "on" lights fall upon each quiet pattern.
+
+For a 5x5 board, the pre-derived quiet patterns from here are used:
+https://www.jaapsch.net/puzzles/lights.htm#quiet
+
+If a randomly-generated light sequence is at first not solvable, it can be made so by toggling the appropriate lights to achieve even parity with the quiet patterns.
+
+See also:
+* https://www.jaapsch.net/puzzles/lomath.htm#solvtest
+* https://www.xarg.org/2018/07/lightsout-solution-using-linear-algebra/
+* https://web.archive.org/web/20100704161251/http://www.haar.clara.co.uk/Lights/solving.html
+* https://en.wikipedia.org/wiki/Lights_Out_(game)#Light_chasing