Permutations with repetitions: Difference between revisions

Content added Content deleted
Line 15: Line 15:


=={{header|AppleScript}}==
=={{header|AppleScript}}==
===Strict evaluation===
===Strict evaluation of the whole set===
Permutations with repetitions, using strict evaluation, generating the entire set (where system constraints permit) with some degree of efficiency. For lazy or interruptible evaluation, see the second example below.
Permutations with repetitions, using strict evaluation, generating the entire set (where system constraints permit) with some degree of efficiency. For lazy or interruptible evaluation, see the second example below.


<lang AppleScript>-- PERMUTATIONS WITH REPETITION ----------------------------------------------
<lang AppleScript>-- e.g. replicateM(3, {1, 2})) ->
-- {{1, 1, 1}, {1, 1, 2}, {1, 2, 1}, {1, 2, 2}, {2, 1, 1},
-- {2, 1, 2}, {2, 2, 1}, {2, 2, 2}}


-- permutationsWithRepetition :: Int -> [a] -> [[a]]
-- replicateM :: Int -> [a] -> [[a]]
on permutationsWithRepetition(n, xs)
on replicateM(n, xs)
script go
if length of xs > 0 then
script cons
foldl1(curry(my cartesianProduct)'s |λ|(xs), replicate(n, xs))
on |λ|(a, bs)
else
{}
{a} & bs
end if
end |λ|
end script
end permutationsWithRepetition
on |λ|(x)
if x ≤ 0 then
{{}}
else
liftA2List(cons, xs, |λ|(x - 1))
end if
end |λ|
end script
go's |λ|(n)
end replicateM




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




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


-- cartesianProduct :: [a] -> [b] -> [[a, b]]
-- concatMap :: (a -> [b]) -> [a] -> [b]
on cartesianProduct(xs, ys)
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

-- liftA2List :: (a -> b -> c) -> [a] -> [b] -> [c]
on liftA2List(f, xs, ys)
script
script
property g : mReturn(f)'s |λ|
on |λ|(x)
on |λ|(x)
script
script
on |λ|(y)
on |λ|(y)
{{x} & y}
{g(x, y)}
end |λ|
end |λ|
end script
end script
concatMap(result, ys)
concatMap(result, ys)
end |λ|
end |λ|
end script
end script
concatMap(result, xs)
concatMap(result, xs)
end liftA2List
end cartesianProduct

-- concatMap :: (a -> [b]) -> [a] -> [b]
on concatMap(f, xs)
script append
on |λ|(a, b)
a & b
end |λ|
end script
foldl(append, {}, map(f, xs))
end concatMap

-- curry :: (Script|Handler) -> Script
on curry(f)
script
on |λ|(a)
script
on |λ|(b)
|λ|(a, b) of mReturn(f)
end |λ|
end script
end |λ|
end script
end curry

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

-- foldl1 :: (a -> a -> a) -> [a] -> a
on foldl1(f, xs)
if length of xs > 0 then
foldl(f, item 1 of xs, tail(xs))
else
{}
end if
end foldl1

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


-- Lift 2nd class handler function into 1st class script wrapper
-- Lift 2nd class handler function into 1st class script wrapper
-- mReturn :: Handler -> Script
-- mReturn :: First-class m => (a -> b) -> m (a -> b)
on mReturn(f)
on mReturn(f)
if class of f is script then
if class of f is script then
Line 125: Line 92:
end script
end script
end if
end if
end mReturn
end mReturn</lang>

-- replicate :: Int -> a -> [a]
on replicate(n, a)
set out to {}
if n < 1 then return out
set dbl to {a}
repeat while (n > 1)
if (n mod 2) > 0 then set out to out & dbl
set n to (n div 2)
set dbl to (dbl & dbl)
end repeat
return out & dbl
end replicate

-- tail :: [a] -> [a]
on tail(xs)
if length of xs > 1 then
items 2 thru -1 of xs
else
{}
end if
end tail</lang>
{{Out}}
{{Out}}
<lang AppleScript>{{1, 1}, {1, 2}, {1, 3}, {2, 1}, {2, 2}, {2, 3}, {3, 1}, {3, 2}, {3, 3}}</lang>
<lang AppleScript>{{1, 1}, {1, 2}, {1, 3}, {2, 1}, {2, 2}, {2, 3}, {3, 1}, {3, 2}, {3, 3}}</lang>
Retrieved from "https://rosettacode.org/wiki/Permutations_with_repetitions"