Source code in the applescript programming language

----------------------- PERMUTATIONS -----------------------

-- permutations :: [a] -> [[a]]
on permutations(xs)
    script go
        on |λ|(xs)
            script h
                on |λ|(x)
                    script ts
                        on |λ|(ys)
                            {{x} & ys}
                        end |λ|
                    end script
                    concatMap(ts, go's |λ|(|delete|(x, xs)))
                end |λ|
            end script
            
            if {} ≠ xs then
                concatMap(h, xs)
            else
                {{}}
            end if
        end |λ|
    end script
    go's |λ|(xs)
end permutations


--------------------------- TEST ---------------------------
on run
    
    permutations({"aardvarks", "eat", "ants"})
    
end run


-------------------- GENERIC FUNCTIONS ---------------------

-- concatMap :: (a -> [b]) -> [a] -> [b]
on concatMap(f, xs)
    set lst to {}
    set lng to length of xs
    tell mReturn(f)
        repeat with i from 1 to lng
            set lst to (lst & |λ|(contents of item i of xs, i, xs))
        end repeat
    end tell
    return lst
end concatMap


-- delete :: a -> [a] -> [a]
on |delete|(x, xs)
    if length of xs > 0 then
        set {h, t} to uncons(xs)
        if x = h then
            t
        else
            {h} & |delete|(x, t)
        end if
    else
        {}
    end if
end |delete|


-- Lift 2nd class handler function into 1st class script wrapper 
-- mReturn :: Handler -> Script
on mReturn(f)
    if class of f is script then
        f
    else
        script
            property |λ| : f
        end script
    end if
end mReturn


-- uncons :: [a] -> Maybe (a, [a])
on uncons(xs)
    if length of xs > 0 then
        {item 1 of xs, rest of xs}
    else
        missing value
    end if
end uncons


to DoPermutations(aList, n)
    --> Heaps's algorithm (Permutation by interchanging pairs)
    if n = 1 then
        tell (a reference to PermList) to copy aList to its end
        -- or: copy aList as text (for concatenated results)
    else
        repeat with i from 1 to n
            DoPermutations(aList, n - 1)
            if n mod 2 = 0 then -- n is even
                tell aList to set [item i, item n] to [item n, item i] -- swaps items i and n of aList
            else
                tell aList to set [item 1, item n] to [item n, item 1] -- swaps items 1 and n of aList
            end if
        end repeat
    end if
    return (a reference to PermList) as list
end DoPermutations

--> Example 1 (list of words)
set [SourceList, PermList] to [{"Good", "Johnny", "Be"}, {}]
DoPermutations(SourceList, SourceList's length)
--> result (value of PermList)
{{"Good", "Johnny", "Be"}, {"Johnny", "Good", "Be"}, {"Be", "Good", "Johnny"}, ¬
    {"Good", "Be", "Johnny"}, {"Johnny", "Be", "Good"}, {"Be", "Johnny", "Good"}}

--> Example 2 (characters with concatenated results)
set [SourceList, PermList] to [{"X", "Y", "Z"}, {}]
DoPermutations(SourceList, SourceList's length)
--> result (value of PermList)
{"XYZ", "YXZ", "ZXY", "XZY", "YZX", "ZYX"}

--> Example 3 (Integers)
set [SourceList, Permlist] to [{1, 2, 3}, {}]
DoPermutations(SourceList, SourceList's length)
--> result (value of Permlist)
{{1, 2, 3}, {2, 1, 3}, {3, 1, 2}, {1, 3, 2}, {2, 3, 1}, {3, 2, 1}}

--> Example 4 (Integers with concatenated results)
set [SourceList, Permlist] to [{1, 2, 3}, {}]
DoPermutations(SourceList, SourceList's length)
--> result (value of Permlist)
{"123", "213", "312", "132", "231", "321"}


----------------------- PERMUTATIONS -----------------------

-- permutations :: [a] -> [[a]]
on permutations(xs)
    script go
        on |λ|(x, a)
            script
                on |λ|(ys)
                    script infix
                        on |λ|(n)
                            if ys ≠ {} then
                                take(n, ys) & {x} & drop(n, ys)
                            else
                                {x}
                            end if
                        end |λ|
                    end script
                    map(infix, enumFromTo(0, (length of ys)))
                end |λ|
            end script
            concatMap(result, a)
        end |λ|
    end script
    foldr(go, {{}}, xs)
end permutations


--------------------------- TEST ---------------------------
on run
    
    permutations({1, 2, 3})
    
    --> {{1, 2, 3}, {2, 1, 3}, {2, 3, 1}, {1, 3, 2}, {3, 1, 2}, {3, 2, 1}}
end run


------------------------- GENERIC --------------------------

-- concatMap :: (a -> [b]) -> [a] -> [b]
on concatMap(f, xs)
    set lng to length of xs
    set acc to {}
    tell mReturn(f)
        repeat with i from 1 to lng
            set acc to acc & |λ|(item i of xs, i, xs)
        end repeat
    end tell
    return acc
end concatMap


-- drop :: Int -> [a] -> [a]
on drop(n, xs)
    if n < length of xs then
        items (1 + n) thru -1 of xs
    else
        {}
    end if
end drop


-- enumFromTo :: Int -> Int -> [Int]
on enumFromTo(m, n)
    if m ≤ n then
        set lst to {}
        repeat with i from m to n
            set end of lst to i
        end repeat
        return lst
    else
        return {}
    end if
end enumFromTo


-- foldr :: (a -> b -> b) -> b -> [a] -> b
on foldr(f, startValue, xs)
    tell mReturn(f)
        set v to startValue
        set lng to length of xs
        repeat with i from lng to 1 by -1
            set v to |λ|(item i of xs, v, i, xs)
        end repeat
        return v
    end tell
end foldr


-- Lift 2nd class handler function into 1st class script wrapper 
-- mReturn :: First-class m => (a -> b) -> m (a -> b)
on mReturn(f)
    if class of f is script then
        f
    else
        script
            property |λ| : f
        end script
    end if
end mReturn


-- map :: (a -> b) -> [a] -> [b]
on map(f, xs)
    tell mReturn(f)
        set lng to length of xs
        set lst to {}
        repeat with i from 1 to lng
            set end of lst to |λ|(item i of xs, i, xs)
        end repeat
        return lst
    end tell
end map


-- min :: Ord a => a -> a -> a
on min(x, y)
    if y < x then
        y
    else
        x
    end if
end min


-- take :: Int -> [a] -> [a]
-- take :: Int -> String -> String
on take(n, xs)
    if 0 < n then
        items 1 thru min(n, length of xs) of xs
    else
        {}
    end if
end take


-- 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})


{{1, 2, 3, 4}, {1, 2, 4, 3}, {1, 3, 4, 2}, {1, 3, 2, 4}, {1, 4, 2, 3}, {1, 4, 3, 2}, {2, 4, 3, 1}, {2, 4, 1, 3}, {2, 3, 1, 4}, {2, 3, 4, 1}, {2, 1, 4, 3}, {2, 1, 3, 4}, {3, 1, 2, 4}, {3, 1, 4, 2}, {3, 2, 4, 1}, {3, 2, 1, 4}, {3, 4, 1, 2}, {3, 4, 2, 1}, {4, 3, 2, 1}, {4, 3, 1, 2}, {4, 2, 1, 3}, {4, 2, 3, 1}, {4, 1, 3, 2}, {4, 1, 2, 3}}