From 051b09b2b2e547a1b319ad27cc9f3f2ca8e9b6a0 Mon Sep 17 00:00:00 2001
From: Karl Ostmo <kostmo@gmail.com>
Date: Sat, 24 Jun 2023 02:26:50 -0700
Subject: [PATCH] powerset scenario

---
 .../Challenges/Ranching/00-ORDER.txt          |   1 +
 .../Challenges/Ranching/_powerset/setup.sw    | 247 ++++++++++++++++++
 .../Challenges/Ranching/_powerset/solution.sw | 157 +++++++++++
 .../Challenges/Ranching/powerset.yaml         | 181 +++++++++++++
 test/integration/Main.hs                      |   1 +
 5 files changed, 587 insertions(+)
 create mode 100644 data/scenarios/Challenges/Ranching/_powerset/setup.sw
 create mode 100644 data/scenarios/Challenges/Ranching/_powerset/solution.sw
 create mode 100644 data/scenarios/Challenges/Ranching/powerset.yaml

diff --git a/data/scenarios/Challenges/Ranching/00-ORDER.txt b/data/scenarios/Challenges/Ranching/00-ORDER.txt
index b219781921..95978ccd78 100644
--- a/data/scenarios/Challenges/Ranching/00-ORDER.txt
+++ b/data/scenarios/Challenges/Ranching/00-ORDER.txt
@@ -1,2 +1,3 @@
 capture.yaml
+powerset.yaml
 gated-paddock.yaml
diff --git a/data/scenarios/Challenges/Ranching/_powerset/setup.sw b/data/scenarios/Challenges/Ranching/_powerset/setup.sw
new file mode 100644
index 0000000000..e2b237cc75
--- /dev/null
+++ b/data/scenarios/Challenges/Ranching/_powerset/setup.sw
@@ -0,0 +1,247 @@
+def elif = \t. \then. \else. {if t then else} end
+def else = \t. t end
+
+// modulus function (%)
+def mod : int -> int -> int = \i. \m.
+  i - m * (i / m)
+end
+
+def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;
+
+def until = \p. \c. q <- p; if q {} {c; until p c} end;
+def while = \p. until (x <- p; return $ not x) end;
+
+def isDivisibleBy = \dividend. \divisor.
+    (dividend / divisor) * divisor == dividend;
+    end;
+
+def isEven = \x.
+   isDivisibleBy x 2
+   end;
+
+/**
+Performs a right bitshift of "x" by "n" places
+*/
+def shiftRight = \x. \n.
+    x / (2^n);
+    end;
+
+/**
+Performs a left bitshift of "x" by "n" places
+*/
+def shiftLeft = \x. \n.
+    x * (2^n);
+    end;
+
+/**
+Checks whether the bit at index "idx" is set in the "bitmask".
+zero-based indexing; 0 is the LSB.
+*/
+def isBitSet = \bitmask. \idx.
+    not $ isEven $ shiftRight bitmask idx;
+    end;
+
+/**
+Tests whether only a single bit is set in the bitmask.
+Aborts early with 'false' if a second bit is detected.
+*/
+def exactlyOneBit = \foundOneBit. \bitmask.
+    if (bitmask == 0) {
+      foundOneBit;
+    } {
+      let bitIsSet = not $ isEven bitmask in
+      if (foundOneBit && bitIsSet) {
+        false;
+      } {
+        exactlyOneBit (foundOneBit || bitIsSet) $ bitmask / 2;
+      }
+    }
+    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 placeSand =
+    let item = "sand" in
+    create item;
+    place item;
+    move;
+    end;
+
+/**
+Repeatedly generate a random number until
+we find one that's not in the bitmask.
+*/
+def getUnusedRandom = \maxval. \bitmask.
+    nextRandomVal <- random maxval;
+    if (isBitSet bitmask nextRandomVal) {
+        getUnusedRandom maxval bitmask;
+    } {
+        return nextRandomVal;
+    }
+    end;
+
+def getEntName = \idx.
+    if (idx == 1) {
+        "grape"
+    } $ elif (idx == 2) {
+        "lemon"
+    } $ elif (idx == 3) {
+        "apple"
+    } $ elif (idx == 4) {
+        "blueberry"
+    } $ elif (idx == 5) {
+        "watermelon"
+    } $ elif (idx == 6) {
+        "orange"
+    } $ else {
+        "dragonfruit"
+    }
+    end;
+
+def getMissingBitRecursive = \bitmask. \idx.
+    if (idx > 0) {
+        if (isEven bitmask) {
+            idx
+        } {
+            getMissingBitRecursive (bitmask / 2) $ idx - 1;
+        }
+    } {
+        // The MSB was the missing bit.
+        0;
+    }
+    end;
+
+/**
+Returns the index of the right-most bit that is zero.
+*/
+def getMissingBit = \bitmask. \maxIdx.
+    let val = getMissingBitRecursive bitmask maxIdx in
+    maxIdx - val;
+    end;
+
+/**
+Use the `random` function to generate a random permuation of `n` contiguous values.
+Uses a bitmask to ensure uniqueness.
+
+Fisher-Yates would be more efficient, but requires a physical array.
+*/
+def naiveRandomStack = \valueFunc. \maxval. \bitmask. \n.
+    val <- if (n > 1) {
+        nextRandomVal <- getUnusedRandom maxval bitmask;
+
+        // Recursion bug workaround (see #1032):
+        let blahNextRandomVal = nextRandomVal in
+
+        let newBitmask = bitmask + shiftLeft 1 nextRandomVal in
+        naiveRandomStack valueFunc maxval newBitmask $ n - 1;
+        return blahNextRandomVal;
+    } {
+        // We're at the peak of the stack.
+        // Now we unwind it.
+
+        // Saves some time in generating the last number by inferring the
+        // only remaining possible choice.
+        let missingBit = getMissingBit bitmask maxval in
+        return missingBit;
+    };
+    valueFunc val;
+    end;
+
+def placeThing = \entIdx.
+    let entName = getEntName entIdx in
+    create entName;
+    place entName;
+    end;
+
+def placeEntsForBits = \bitmask. \bitIndex.
+    if (isBitSet bitmask bitIndex) {
+        placeThing bitIndex;
+        move;
+    } {};
+    end;
+
+def columnFunc = \exclusionValue. \inputCardinality. \x.
+    if (x != 0 && x != exclusionValue && not (exactlyOneBit false x)) {
+        naiveRandomStack (placeEntsForBits x) inputCardinality 0 inputCardinality;
+        myloc <- whereami;
+        teleport self (fst myloc + 1, 0);
+    } {};
+    end;
+
+def makeSandRow = \length.
+    turn east;
+    atLocation (0, -1) $ doN length placeSand;
+    end;
+
+def chooseExclusionValue = \powersetCardinality.
+
+    // For cardinality 32, for example, the value of "r"
+    // will be between 0 and 30, inclusive.
+    r <- random $ powersetCardinality - 1;
+
+    // We offset by one so as not to exclude zero.
+    // So the exclusion value is now between
+    // 1 and 31, inclusive.
+    let value = r + 1 in
+
+    if (exactlyOneBit false value) {
+      chooseExclusionValue powersetCardinality;
+    } {
+      return value;
+    }
+    end;
+
+/**
+"inputCardinality" is the number of distinct entities
+*/
+def setup = \inputCardinality.
+    let powersetCardinality = 2^inputCardinality in
+    makeSandRow $ powersetCardinality - (1 + inputCardinality);
+
+    turn north;
+    move;
+    exclusionValue <- chooseExclusionValue powersetCardinality;
+    naiveRandomStack (columnFunc exclusionValue inputCardinality) powersetCardinality 0 powersetCardinality;
+    return exclusionValue;
+    end;
+
+/**
+One-based ordinal of the item.
+*/
+def getOrdinal : text -> cmd int = \item.
+    count item;
+    end;
+
+def checkSolutionSum = \runningSum.
+    maybeItem <- scan down;
+    case maybeItem (\_. return runningSum) (\item.
+        // The bell is the only other item we can place in this
+        // scenario besides the fruits.
+        if (item != "bell") {
+            theOrdinal <- getOrdinal item;
+            let binaryValue = shiftLeft 1 $ theOrdinal - 1 in
+            move;
+            checkSolutionSum $ binaryValue + runningSum;
+        } {return runningSum};
+    );
+    end;
+
+def go = \distinctCount.
+    exclusionValue <- instant $ setup distinctCount;
+    while (as base {has "bell"}) $ wait 2;
+    theSum <- checkSolutionSum 0;
+    let sentinelItem = if (exclusionValue == theSum) {"bit (1)"} {"bit (0)"} in
+    create sentinelItem;
+    end;
+
+go 7;
\ No newline at end of file
diff --git a/data/scenarios/Challenges/Ranching/_powerset/solution.sw b/data/scenarios/Challenges/Ranching/_powerset/solution.sw
new file mode 100644
index 0000000000..30707c3cd9
--- /dev/null
+++ b/data/scenarios/Challenges/Ranching/_powerset/solution.sw
@@ -0,0 +1,157 @@
+def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;
+def until = \p. \c. q <- p; if q {} {c; until p c} end;
+def while = \p. until (x <- p; return $ not x) end;
+
+def abs = \n. if (n < 0) {-n} {n} end;
+
+def intersperse = \n. \f2. \f1.
+    if (n > 0) {
+        f1;
+        if (n > 1) {
+            f2;
+        } {};
+        intersperse (n - 1) f2 f1;
+    } {};
+    end;
+
+def mapTuple = \f. \t.
+    (f $ fst t, f $ snd t)
+    end;
+
+def sumTuples = \t1. \t2.
+    (fst t1 + fst t2, snd t1 + snd t2);
+    end;
+
+def negateTuple = \t.
+    mapTuple (\x. -x) t;
+    end;
+
+def getRelativeLocation = \absCurrentLoc. \absDestLoc.
+    let negatedLoc = negateTuple absCurrentLoc in
+    return $ sumTuples negatedLoc absDestLoc;
+    end;
+
+def moveTuple = \tup.
+    let x = fst tup in
+    let y = snd tup in
+    turn $ if (x > 0) {east} {west};
+    doN (abs x) move;
+
+    turn $ if (y > 0) {north} {south};
+    doN (abs y) move;
+    end;
+
+def goToLocation = \currentLoc. \absoluteDestination.
+    relativeDestination <- getRelativeLocation currentLoc absoluteDestination;
+    moveTuple relativeDestination;
+    end;
+
+def recordFirstEncounter = \stashLoc. \item.
+    originalHeading <- heading;
+    originalLoc <- whereami;
+    goToLocation originalLoc stashLoc;
+    turn south;
+    until isempty move;
+    place item;
+
+    newCurrentLoc <- whereami;
+    goToLocation newCurrentLoc originalLoc;
+    turn originalHeading;
+    end;
+
+def tryHarvest = \stashLoc.
+    maybeItem <- scan down;
+    case maybeItem return (\item.
+        hasSome <- has item;
+        harvest;
+        if hasSome {} {
+            while isempty $ wait 1;
+            // Grab another one so that our "sentinel condition" won't
+            // be invalidated when we go on to place it
+            harvest;
+            recordFirstEncounter stashLoc item;
+        };
+    );
+    end;
+
+def doRow = \stashLoc. \sandLength.
+    intersperse (sandLength - 1) move $ tryHarvest stashLoc;
+    end;
+
+def turnaround = \d.
+    turn d;
+    move;
+    turn d;
+    end;
+
+/**
+Precondition:
+At the start of the line, facing along the line.
+*/
+def countLine = \tally.
+    emptyhere <- isempty;
+    if emptyhere {
+        turn back;
+        doN tally move;
+        return tally;
+    } {
+        move;
+        countLine $ tally + 1;
+    }
+    end;
+
+def placeFinalCopy = \item.
+    originalLoc <- whereami;
+    goToLocation originalLoc (fst originalLoc, 0);
+    until isempty move;
+    place item;
+    newLoc <- whereami;
+    goToLocation newLoc originalLoc;
+    end;
+
+def copyIfNeeded = \targetCount.
+    maybeItem <- scan down;
+    case maybeItem return (\item.
+        quantity <- count item;
+        if (quantity < targetCount) {
+            placeFinalCopy item;
+        } {};
+    );
+    move;
+    end;
+
+def harvestForCounts = \rowLength. \stashLoc. \sweepCount.
+
+    intersperse sweepCount (turnaround right) $
+        intersperse 2 (turnaround left) $ doRow stashLoc rowLength;
+    
+    turnaround right;
+    doRow stashLoc rowLength;
+    end;
+
+def go = \sweepCount.
+    move;
+    rowLength <- countLine 0;
+    let stashLoc = (rowLength - 1, -2) in
+    turnaround right;
+
+    harvestForCounts rowLength stashLoc sweepCount;
+
+    originalLoc <- whereami;
+    goToLocation originalLoc stashLoc;
+    turn south;
+
+    entityCardinality <- countLine 0;
+
+    turn back;
+    let expectedCount = 2^(entityCardinality - 1) - 1 in
+    doN entityCardinality $ copyIfNeeded expectedCount;
+
+    // Mark goal-checkability sentinel
+    place "bell";
+    end;
+
+// The sand needs to be placed first by the setup robot.
+wait 1;
+
+go 3;
\ No newline at end of file
diff --git a/data/scenarios/Challenges/Ranching/powerset.yaml b/data/scenarios/Challenges/Ranching/powerset.yaml
new file mode 100644
index 0000000000..c0b0c45e56
--- /dev/null
+++ b/data/scenarios/Challenges/Ranching/powerset.yaml
@@ -0,0 +1,181 @@
+version: 1
+name: Powerset
+author: Karl Ostmo
+description: |
+  Find the missing fruit combination
+creative: false
+attrs:
+  - name: fruit0
+    fg: "#ff0080"
+  - name: fruit1
+    fg: "#b000ff"
+  - name: fruit2
+    fg: "#ffff00"
+  - name: fruit3
+    fg: "#ff0000"
+  - name: fruit4
+    fg: "#0000ff"
+  - name: fruit5
+    fg: "#00ff00"
+  - name: fruit6
+    fg: "#ff8000"
+objectives:
+  - teaser: Find missing hybrid
+    id: complete_powerset
+    goal:
+      - |
+        Farmer Bill is breeding hybrid fruits.
+        Each fruit can be paired with one or more other fruit variety, and Bill
+        wants to evaluate every such combination.
+        He has arranged each hybrid in a column in his orchard.
+      - |
+        However, his experiment is incomplete! He has forgotten one combination.
+      - |
+        Place the missing hybrid combination in the empty eastern-most column.
+        After you have done this, `place` the "bell" anywhere, and then Bill will inspect
+        your work.
+    prerequisite:
+        not: wrong_anwser
+    condition: |
+      r <- robotnamed "setup";
+      as r {has "bit (1)"};
+  - teaser: Wrong answer
+    id: wrong_anwser
+    goal:
+      - |
+        Farmer Bill is disappointed.
+    condition: |
+      r <- robotnamed "setup";
+      as r {has "bit (0)"};
+robots:
+  - name: base
+    dir: [1, 0]
+    devices:
+      - ADT calculator
+      - branch predictor
+      - hourglass
+      - comparator
+      - compass
+      - counter
+      - dictionary
+      - Elmer's glue
+      - fruit picker
+      - fruit planter
+      - GPS receiver
+      - lambda
+      - linotype
+      - lodestone
+      - logger
+      - keyboard
+      - net
+      - scanner
+      - strange loop
+      - treads
+    inventory:
+      - [1, bell]
+  - name: setup
+    system: true
+    dir: [1, 0]
+    display:
+      invisible: true
+    inventory:
+      - [1, dragonfruit]
+      - [2, grape]
+      - [3, lemon]
+      - [4, apple]
+      - [5, blueberry]
+      - [6, watermelon]
+      - [7, orange]
+    program: |
+      run "scenarios/Challenges/Ranching/_powerset/setup.sw"
+solution: |
+   run "scenarios/Challenges/Ranching/_powerset/solution.sw"
+entities:
+  - name: bell
+    display:
+      char: 'B'
+      attr: gold
+    description:
+      - A bell for Bill
+    properties: [known, portable]
+  - name: fruit picker
+    display:
+      char: 'P'
+    description:
+      - Enables the `harvest` command.
+    properties: [known]
+    capabilities: [harvest]
+  - name: fruit planter
+    display:
+      char: 'p'
+    description:
+      - Enables the `place` command.
+    properties: [known]
+    capabilities: [place]
+  - name: dragonfruit
+    display:
+      char: 'M'
+      attr: fruit0
+    description:
+      - Dragonfruits
+    properties: [known, growable, portable]
+    growth: [10, 10]
+  - name: grape
+    display:
+      char: 'M'
+      attr: fruit1
+    description:
+      - Grapes
+    growth: [10, 10]
+    properties: [known, growable, portable]
+  - name: lemon
+    display:
+      char: 'M'
+      attr: fruit2
+    description:
+      - Lemons
+    growth: [10, 10]
+    properties: [known, growable, portable]
+  - name: apple
+    display:
+      char: 'M'
+      attr: fruit3
+    description:
+      - Apple
+    growth: [10, 10]
+    properties: [known, growable, portable]
+  - name: blueberry
+    display:
+      char: 'M'
+      attr: fruit4
+    description:
+      - Blueberries
+    growth: [10, 10]
+    properties: [known, growable, portable]
+  - name: watermelon
+    display:
+      char: 'M'
+      attr: fruit5
+    description:
+      - Watermelons
+    growth: [10, 10]
+    properties: [known, growable, portable]
+  - name: orange
+    display:
+      char: 'M'
+      attr: fruit6
+    description:
+      - Oranges
+    growth: [10, 10]
+    properties: [known, growable, portable]
+known: [sand]
+world:
+  default: [grass]
+  upperleft: [-1, -1]
+  offset: false
+  palette:
+    '.': [grass]
+    'B': [grass, null, base]
+    'M': [grass, null, setup]
+  map: |
+    BM
diff --git a/test/integration/Main.hs b/test/integration/Main.hs
index 0b53abb6ba..2c0aa25cd9 100644
--- a/test/integration/Main.hs
+++ b/test/integration/Main.hs
@@ -211,6 +211,7 @@ testScenarioSolution _ci _em =
         , testGroup
             "Ranching"
             [ testSolution Default "Challenges/Ranching/capture"
+            , testSolution (Sec 30) "Challenges/Ranching/powerset"
             , testSolution (Sec 30) "Challenges/Ranching/gated-paddock"
             ]
         , testGroup