Data commit

Task/Permutations/AppleScript/permutations-4.applescript

@@ -0,0 +1,114 @@
+-- Translation of "Improved version of Heap's method (recursive)" found in
+-- Robert Sedgewick's PDF document "Permutation Generation Methods"
+-- <https://www.cs.princeton.edu/~rs/talks/perms.pdf>
+
+on allPermutations(theList)
+    script o
+        -- Work list and precalculated indices for its last four items (assuming that many).
+        property workList : missing value --(Set to a copy of theList below.)
+        property r : (count theList)
+        property rMinus1 : r - 1
+        property rMinus2 : r - 2
+        property rMinus3 : r - 3
+        -- Output list and traversal index.
+        property output : {}
+        property p : 1
+
+        -- Recursive handler.
+        on prmt(l)
+            -- Is the range length covered by this recursion level even?
+            set rangeLenEven to ((r - l) mod 2 = 1)
+            -- Tail call elimination repeat. Gives way to hard-coding for the lowest three levels.
+            repeat with l from l to rMinus3
+                -- Recursively permute items (l + 1) thru r of the work list.
+                set lPlus1 to l + 1
+                prmt(lPlus1)
+                -- And again after swaps of item l with each of the items to its right
+                -- (if the range l to r is even) or with the rightmost item r - l times
+                -- (if the range length is odd). The "recursion" after the last swap will
+                -- instead be the next iteration of this tail call elimination repeat.
+                if (rangeLenEven) then
+                    repeat with swapIdx from r to (lPlus1 + 1) by -1
+                        tell my workList's item l
+                            set my workList's item l to my workList's item swapIdx
+                            set my workList's item swapIdx to it
+                        end tell
+                        prmt(lPlus1)
+                    end repeat
+                    set swapIdx to lPlus1
+                else
+                    repeat (r - lPlus1) times
+                        tell my workList's item l
+                            set my workList's item l to my workList's item r
+                            set my workList's item r to it
+                        end tell
+                        prmt(lPlus1)
+                    end repeat
+                    set swapIdx to r
+                end if
+                tell my workList's item l
+                    set my workList's item l to my workList's item swapIdx
+                    set my workList's item swapIdx to it
+                end tell
+                set rangeLenEven to (not rangeLenEven)
+            end repeat
+            -- Store a copy of the work list's current state.
+            set my output's item p to my workList's items
+            -- Then five more with the three rightmost items permuted.
+            set v1 to my workList's item rMinus2
+            set v2 to my workList's item rMinus1
+            set v3 to my workList's end
+            set my workList's item rMinus1 to v3
+            set my workList's item r to v2
+            set my output's item (p + 1) to my workList's items
+            set my workList's item rMinus2 to v2
+            set my workList's item r to v1
+            set my output's item (p + 2) to my workList's items
+            set my workList's item rMinus1 to v1
+            set my workList's item r to v3
+            set my output's item (p + 3) to my workList's items
+            set my workList's item rMinus2 to v3
+            set my workList's item r to v2
+            set my output's item (p + 4) to my workList's items
+            set my workList's item rMinus1 to v2
+            set my workList's item r to v1
+            set my output's item (p + 5) to my workList's items
+            set p to p + 6
+        end prmt
+    end script
+
+    if (o's r < 3) then
+        -- Fewer than three items in the input list.
+        copy theList to o's output's beginning
+        if (o's r is 2) then set o's output's end to theList's reverse
+    else
+        -- Otherwise prepare a list to hold (factorial of input list length) permutations …
+        copy theList to o's workList
+        set factorial to 2
+        repeat with i from 3 to o's r
+            set factorial to factorial * i
+        end repeat
+        set o's output to makeList(factorial, missing value)
+        -- … and call o's recursive handler.
+        o's prmt(1)
+    end if
+
+    return o's output
+end allPermutations
+
+on makeList(limit, filler)
+    if (limit < 1) then return {}
+    script o
+        property lst : {filler}
+    end script
+
+    set counter to 1
+    repeat until (counter + counter > limit)
+        set o's lst to o's lst & o's lst
+        set counter to counter + counter
+    end repeat
+    if (counter < limit) then set o's lst to o's lst & o's lst's items 1 thru (limit - counter)
+    return o's lst
+end makeList
+
+return allPermutations({1, 2, 3, 4})