Puzzle.hs

parts s = do
    a <- [1..s-1]
    b <- [1..s-a]
    c <- [1..s-a-b]
    d <- [1..s-a-b-c]
    return [a, b, c, d]

Is it any easier to understand without do notation?

partsb s =
  [1..(s-1)] >>=
  \a -> [1..(s-a)] >>=
        \b -> [1..s-a-b] >>=
              \c -> [1..s-a-b-c] >>=
                    \d -> return [a,b,c,d]

parts' :: (Integral a, Show a, Read a) => a -> [[a]]
parts' s = do
    a <- f 1
    b <- f . sum $ [a]
    c <- f . sum $ [a, b]
    d <- f . sum $ [a, b, c]
    return [a, b, c, d]

    where
      f x = [1..s-x]

Here's a solution as a monadic unfold, in both fixed-length and unrestricted-length versions:

-- All sequences of n positive numbers summing to at most s.
partsOf :: (Enum s, Num s, Num n, Ord n) => n -> s -> [[s]]
n `partsOf` s = unfoldM step (n,s)
  where step (n,s)
             | 0 < n     = [Just (s', (n-1,s-s')) | s' <- [1..s]]
             | otherwise = [Nothing]

-- All sequences of positive numbers summing to at most s.
allPartsOf :: (Enum s, Num s, Ord s) => s -> [[s]]
allPartsOf s = unfoldM step s
  where step s
             | 0 < s     = [Just (s', s-s') | s' <- [1..s]]
             | otherwise = [Nothing]

ghci> 5 `partsOf` 5
[[1,1,1,1,1]]
ghci> 3 `partsOf` 5
[[1,1,1],[1,1,2],[1,1,3],[1,2,1],[1,2,2],[1,3,1],[2,1,1],[2,1,2],[2,2,1],[3,1,1]]
ghci> 1 `partsOf` 5
[[1],[2],[3],[4],[5]]

ghci> allPartsOf 4
[[1,1,1,1],[1,1,2],[1,2,1],[1,3],[2,1,1],[2,2],[3,1],[4]]

You can get unfoldM from monad-extras, or you can derive it from unfoldr like this:

unfoldr :: (b -> Maybe (a, b)) -> b -> [a]
unfoldr f b = next $ f b
  where
    next (Just (a, b')) = (a:) (next $ f b')
    next Nothing        = []

unfoldM :: Monad m => (b -> m (Maybe (a, b))) -> b -> m [a]
unfoldM f b = next =<< f b
  where
    next (Just (a, b')) = (a:) <$> (next =<< f b')
    next Nothing        = pure []

(I think this derivation of unfoldM is quite cool: if you start with the right applicative-style definition of unfoldr, you can get the monadic version of it with no changes to the body except for adjusting function applications and values to their lifted versions, where the types demand it.)

unfoldM is the one from monad-extras, not from monad-loops. I just spent 15 minutes scratching my head trying to figure out how this could possibly work before checking hoogle a second time :)

That's right: the unfoldM in monad-extras is the one that's a monadic version of unfoldr.

The unfoldM in monad-loops is more like a monadic, terminating repeat. Perhaps a better name for it would have been repeatMaybeM?

Alright, here's my attempt at explaining the intuition behind the unfoldM-based solution above, with a detour into unfoldr too, as a mini-tutorial.

(This assumes some existing familiarity with the [] functor.)

1. Almost a solution: sequence

Observe that whenever you have this pattern:

do
    a <- foo
    b <- bar
    c <- baz
    ...
    return [a, b, c, ...]

then you can simplify it to the following if the expressions are independent:

sequence [foo, bar, baz, ...]

This is tantalizingly close to a solution for the puzzle: if we could define the right expressions for each element, and control the list's length, then we would have our solution.

The idea of controlling the length of a sequence is close to what replicateM does:

ghci> replicateM 3 [0..1]  -- sequence [[0..1],[0..1],[0..1]]
[[0,0,0],[0,0,1],[0,1,0],[0,1,1],[1,0,0],[1,0,1],[1,1,0],[1,1,1]]

ghci> replicateM 2 [0..1]  -- sequence [[0..1],[0..1]]
[[0,0],[0,1],[1,0],[1,1]]

ghci> replicateM 1 [0..1]  -- sequence [[0..1]]
[[0],[1]]

ghci> replicateM 0 [0..1]  -- sequence []
[[]]

However, replicateM only replicates identical copies of the same element, as the name suggests.

Can we fix the length like replicateM, but vary the elements?

One approach we can try is to generate lists of the desired length, with elements close to the shape of the puzzle:

-- A list of length n, shaped like [[1..n],[1..n-1],...,[1..1]]
staircase :: (Enum n, Num n) => n -> [[n]]
staircase n =[[1..s] | s <- reverse [1..n]]

ghci> staircase 4
[[1,2,3,4],[1,2,3],[1,2],[1]]

ghci> staircase 3
[[1,2,3],[1,2],[1]]

We can sequence these:

ghci> sequence (staircase 4)  -- sequence [[1,2,3,4],[1,2,3],[1,2],[1]]
[[1,1,1,1],[1,1,2,1],[1,2,1,1],[1,2,2,1],[1,3,1,1],[1,3,2,1],[2,1,1,1],[2,1,2,1],[2,2,1,1],[2,2,2,1],[2,3,1,1],[2,3,2,1]
,[3,1,1,1],[3,1,2,1],[3,2,1,1],[3,2,2,1],[3,3,1,1],[3,3,2,1],[4,1,1,1],[4,1,2,1],[4,2,1,1],[4,2,2,1],[4,3,1,1],[4,3,2,1]]

ghci> sequence (staircase 3)  -- sequence [[1,2,3],[1,2],[1]]
[[1,1,1],[1,2,1],[2,1,1],[2,2,1],[3,1,1],[3,2,1]]

ghci> sequence (staircase 2)  -- sequence [[1,2],[1]]
[[1,1],[2,1]]

But now, we run into the fundamental limitation of sequence mentioned before: once the elements are generated and passed to sequence, each element represents an independent list of alternative values for that element. This means that the list of alternatives at each position is predetermined: any selection made for an element at one position cannot affect the list of alternative values for an element at another position.

By contrast, our problem defines the list of possible alternatives for each element in terms of the selection made for the previous element: starting with an initial sum, each element's selection is subtracted from it to get the remaining sum that the following element may range up to.

So, to solve the problem, we need a way to generate a list element by element, starting from a seed value (the initial sum), with each step generating a value from the seed (an integer between 1 and the sum) and passing along a modified seed (the remaining sum).

This is exactly what unfoldr does for pure lists, and unfoldM does for lists in the context of a monad.

Side-note: The above limitation is actually the key difference between the Applicative functor interface, which does not allow such dependencies between functor values, and the Monad interface, which does (via join or bind).

Side-note 2: This difference is obscured by the fact that for historical reasons, the Prelude specialises the type of sequence to Monad instead of Applicative (with sequenceA being introduced separately). However, you can always think of sequence as an Applicative operation, not a Monad one.

2. Intermission: unfoldr

A quick refresher: wherefoldr consumes a list by breaking down its structure to a summary value, unfoldr produces a list by generating its structure from a seed value. Formally, the two functions are dual to each other.

The type of unfoldr looks a bit strange, at first, compared to foldr:

foldr :: (a -> b -> b) -> b -> [a] -> b
unfoldr :: (b -> Maybe (a, b)) -> b -> [a]

but this difference is mainly technical: Haskell does not have anonymous sum types, so the function uses Just (a, b) and Nothing as stand-ins to represent the choice between generating a cons or a nil at each step.

Digression: To see more clearly how foldr and unfoldr are dual to each other, try defining foldr with the following variation of its usual type:

foldr :: (Maybe (a, b) -> b) -> [a] -> b

Like foldr, unfoldr is widely useful for anything that produces lists, and many common functions can be defined in terms of it:

iterate :: (a -> a) -> a -> [a]
iterate f = unfoldr (\x -> Just (x, f x))

repeat :: a -> [a]
repeat x = unfoldr (\_ -> Just (x, undefined)) undefined

replicate :: (Num n, Ord n) => n -> a -> [a]
replicate n x = unfoldr next n
  where
    next i | 0 < i     = Just (x, i-1)
           | otherwise = Nothing

Even map, which is usually presented as a foldr (map f = foldr ((:) . f) []), can also be formulated as an unfoldr, which consumes the input list as it produces the output list:

map :: (a -> b) -> [a] -> [b]
map f = unfoldr next
  where
    next (x:xs) = Just (f x, xs)
    next []     = Nothing

3. Counting down with unfoldr

Before tackling the main problem and unfoldM, let's consider a simple but similar toy problem which can be solved with unfoldr.

The problem is to generate countdown lists:

1. Start from an arbitrary number
2. Generate a list of descending integers
3. Stop either when a target number like 0 is reached, or as a variation, after a fixed number of steps

Counting down to a target is easy enough:

countdown :: (Num s, Ord s) => s -> [s]
countdown s = unfoldr next s
  where next s
             | 0 <= s    = Just (s, s-1)
             | otherwise = Nothing

ghci> countdown 10
[10,9,8,7,6,5,4,3,2,1,0]

(Note how this is almost identical to replicate, except for filling in the list elements with the count itself, rather than the fixed value.)

Counting a fixed number of counts from an arbitrary number is a bit trickier: we can no longer reuse the same number for both the current count and the number of steps left. However, we can keep track of both at the same time:

countdownsFrom :: (Num s, Num n, Ord n) => n -> s -> [s]
n `countdownsFrom` s = unfoldr next (n,s)
  where next (n,s)
             | 0 < n     = Just (s, (n-1,s-1))
             | otherwise = Nothing

ghci> 10 `countdownsFrom` 99
[99,98,97,96,95,94,93,92,91,90]

ghci> 10 `countdownsFrom` 5
[5,4,3,2,1,0,-1,-2,-3,-4]

(We can simplify this further by calculating the target to avoid keeping track of both numbers, but that's outside the scope of this explanation.)

4. Counting down with unfoldM

Earlier, I said that unfoldM is like unfoldr in the context of a monad, but what does this actually mean, intuitively?

Compare the types:

unfoldr :: (b -> Maybe (a, b)) -> b -> [a]
unfoldM :: Monad m => (b -> m (Maybe (a, b))) -> b -> m [a]

Compared to unfoldr, unfoldM adds m to the generating function's result and the final result. This means that each generating step takes the current seed and returns the next step as a monadic value.

We can experiment with this by making a variation of countdown that uses unfoldM with IO actions to prompt the user for how much to count down by, at each step:

-- Helper: Prompt for user input.
prompt :: Read a => String -> IO a
prompt p = putStr (p ++ "? ") *> readLn


wonkyCountdown :: (Num s, Ord s, Read s, Show s) => s -> IO [s]
wonkyCountdown s = unfoldM next s
  where next s
             | 0 <= s    = let count diff = Just (s, s-diff)
                            in count <$> prompt (show s)
             | otherwise = Nothing <$ putStrLn "Done!"

ghci> wonkyCountdown 10
10? 1
9? -1
10? 4
6? 1
5? 2
3? 2
1? 2
Done!
[10,9,10,6,5,3,1]
ghci>

Note how the only change was to insert the relevant IO actions around the Just and Nothing results.

How about swapping IO for []? Instead of reading the amount from the user, we can list all possible amounts to count down by as alternative values:

multiCountdown :: (Enum s, Num s, Ord s) => s -> [[s]]
multiCountdown s = unfoldM next s
  where next s
             | 0 <= s    = [Just (s, s-d) | d <- [1..s `max` 1]]
             | otherwise = [Nothing]

(The max is necessary to ensure we always count down by at least 1.)

This gives us a list of possible countdowns by non-zero increments:

ghci> multiCountdown 1
[[1,0]]

ghci> multiCountdown 2
[[2,1,0],[2,0]]

ghci> multiCountdown 3
[[3,2,1,0],[3,2,0],[3,1,0],[3,0]]

ghci> multiCountdown 4
[[4,3,2,1,0],[4,3,2,0],[4,3,1,0],[4,3,0],[4,2,1,0],[4,2,0],[4,1,0],[4,0]]

#5. The solution: Counting down differences

multiCountdown looks very reminiscent of our puzzle solution.

In fact, it is the puzzle solution, if you take the differences between the countdown numbers.

With a tweak to the edge condition, and letting the value of each element be the difference rather than the current seed (or remaining sum), we can transform multiCountdown into allPartsOf:

allPartsOf :: (Enum s, Num s, Ord s) => s -> [[s]]
allPartsOf s = unfoldM next s
  where next s
             | 0 < s    = [Just (d, s-d) | d <- [1..s]]
             | otherwise = [Nothing]

Bonus solution: StateT and []

There's a different approach to this problem, using the StateT monad transformer with [].

This combination can be viewed as enriching each alternative value with a state, or as extending state actions to be "state multi-actions".

This lets lets us define a "multi-action" that reads the current sum, and then splits itself into alternatives, one for each possible selection and remaining sum:

import Control.Monad.Trans.Class
import Control.Monad.Trans.State

part :: (Enum n, Num n) => StateT n [] n
part = do s <- get
         d <- lift [1..s]
         put (s-d)
         return d

With this defined, we can implement partsOf simply by repeating part with replicateM, and feeding it the initial sum:

-- We can simply repeat the the part action.
partsOf :: (Enum n, Num n) => Int -> n -> [[n]]
n `partsOf` s = replicateM n part `evalStateT` s

For allPartsOf, we need something that conditionally repeats the action until the state (remaining sum) hits 0. We could implement this ourselves, but conveniently, monad-loops already has whileM, which repeats a monadic value until a monadic condition is met:

import Control.Monad.Loops (whileM)

allPartsOf :: (Enum n, Num n, Ord n) => n -> [[n]]
allPartsOf s = whileM ((0 <) <$> get) part `evalStateT` s