在 Haskell 中使用列表 Monad 回溯

Question

I'm trying to solve a decomposition problem with backtracking and list Monad in Haskell. Here is the problem statement: given a positive integer n , find all lists of consecutive integers (in range i..j ) whose sum is equal to n .

I came out with the following solution which seems to work fine. Could someone suggest a better/more efficient implementation using list Monad and backtracking?

Any suggestions are welcome. Thanks in advance.

import Control.Monad

decompose :: Int -> [[Int]]
decompose n = concatMap (run n) [1 .. n - 1]
  where
    run target n = do
        x <- [n]
        guard $ x <= target
        if x == target
            then return [x]
            else do
                next <- run (target - n) (n + 1)
                return $ x : next

test1 = decompose 10 == [[1,2,3,4]]
test2 = decompose 9 == [[2,3,4],[4,5]]

Answer 1

The sum of a range of numbers k.. l with k≤l is equal to (l×(l+1)-k×(k-1))/2 . For example: 1.. 4 is equal to (4×5-1×0)/2=(20-0)/2=10 ; and the sum of 4.. 5 is (5×6-4×3)/2=(30-12)/2=9 .

If we have a sum S and an offset k , we can thus find out if there is an l for which the sum holds with:

2×S = l×(l+1)-k×(k-1)

0=l ² +l-2×Sk×(k-1)

we can thus solve this equation with:

l=(-1 + √(1+8×S+4×k×(k-1)))/2

If this is an integral number, then the sequence exists. For example for S=9 and k=4 , we get:

l = (-1 + √(1+72+48))/2 = (-1 + 11)/2 = 10/2 = 5 .

We can make use of some function, like the Babylonian method [wiki] to calculate integer square roots fast:

squareRoot :: Integral t => t -> t
squareRoot n 
   | n > 0    = babylon n
   | n == 0   = 0
   | n < 0    = error "Negative input"
   where
   babylon a   | a > b = babylon b
               | otherwise = a
      where b  = quot (a + quot n a) 2

We can check if the found root is indeed the exact square root with by squaring the root and see if we obtain back the original input.

So now that we have that, we can iterate over the lowerbound of the sequence, and look for the upperbound. If that exists, we return the sequence, otherwise, we try the next one:

decompose :: Int -> [[Int]]
decompose s = [ [k .. div (sq-1) 2 ]
              | k <- [1 .. s]
              , let r = 1+8*s+4*k*(k-1)
              , let sq = squareRoot r
              , r == sq*sq
              ]

We can thus for example obtain the items with:

Prelude> decompose 1
[[1]]
Prelude> decompose 2
[[2]]
Prelude> decompose 3
[[1,2],[3]]
Prelude> decompose 3
[[1,2],[3]]
Prelude> decompose 1
[[1]]
Prelude> decompose 2
[[2]]
Prelude> decompose 3
[[1,2],[3]]
Prelude> decompose 4
[[4]]
Prelude> decompose 5
[[2,3],[5]]
Prelude> decompose 6
[[1,2,3],[6]]
Prelude> decompose 7
[[3,4],[7]]
Prelude> decompose 8
[[8]]
Prelude> decompose 9
[[2,3,4],[4,5],[9]]
Prelude> decompose 10
[[1,2,3,4],[10]]
Prelude> decompose 11
[[5,6],[11]]

We can further constrain the ranges, for example specify that k<l , with:

decompose :: Int -> [[Int]]
decompose s = [ [k .. l ]
              | k <- [1 ..  ]
              , let r = 1+8*s+4*k*(k-1)
              , let sq = squareRoot r
              , r == sq*sq
              , let l = div (sq-1) 2
              , 
              ]

This then gives us:

Prelude> decompose 1
[]
Prelude> decompose 2
[]
Prelude> decompose 3
[[1,2]]
Prelude> decompose 4
[]
Prelude> decompose 5
[[2,3]]
Prelude> decompose 6
[[1,2,3]]
Prelude> decompose 7
[[3,4]]
Prelude> decompose 8
[]
Prelude> decompose 9
[[2,3,4],[4,5]]
Prelude> decompose 10
[[1,2,3,4]]
Prelude> decompose 11
[[5,6]]

Answer 2

NB This answer is slightly tangential since the question specifically calls for a direct backtracking solution in Haskell. Posting it in case there is some interest in other approaches to this problem, in particular using off-the-shelf SMT solvers.

These sorts of problems can be easily handled by off-the-shelf constraint solvers, and there are several libraries in Haskell to access them. Without going into too much detail, here's how one can code this using the SBV library ( https://hackage.haskell.org/package/sbv ):

import Data.SBV

decompose :: Integer -> IO AllSatResult
decompose n = allSat $ do
                 i <- sInteger "i"
                 j <- sInteger "j"

                 constrain $ 1 .<= i
                 constrain $ i .<= j
                 constrain $ j .<  literal n

                 constrain $ literal n .== ((j * (j+1)) - ((i-1) * i)) `sDiv` 2

We simply express the constraints on i and j for the given n , using the summation formula. The rest is simply handled by the SMT solver, giving us all possible solutions. Here're a few tests:

*Main> decompose 9
Solution #1:
  i = 4 :: Integer
  j = 5 :: Integer
Solution #2:
  i = 2 :: Integer
  j = 4 :: Integer
Found 2 different solutions.

and

*Main> decompose 10
Solution #1:
  i = 1 :: Integer
  j = 4 :: Integer
This is the only solution.

While this may not provide much insight into how to solve the problem, it sure leverages existing technologies. Again, while this answer doesn't use the list-monad as asked, but hopefully it is of some interest when considering applications of SMT solvers in regular programming.