Euler 43 - is there a monad to help write this list comprehension?

Question

Here is a way to solve Euler problem 43 (please let me know if this doesn't give the correct answer). Is there a monad or some other syntatic sugar which could assist with keeping track of the notElem conditions?

toNum xs = foldl (\s d -> s*10+d) 0 xs

numTest xs m = (toNum xs) `mod` m == 0

pandigitals = [ [d0,d1,d2,d3,d4,d5,d6,d7,d8,d9] |
                d7 <- [0..9],
                d8 <- [0..9], d8 `notElem` [d7],
                d9 <- [0..9], d9 `notElem` [d8,d7],
                numTest [d7,d8,d9] 17,
                d5 <- [0,5],  d5 `notElem` [d9,d8,d7],
                d3 <- [0,2,4,6,8], d3 `notElem` [d5,d9,d8,d7],
                d6 <- [0..9], d6 `notElem` [d3,d5,d9,d8,d7],
                numTest [d6,d7,d8] 13,
                numTest [d5,d6,d7] 11,
                d4 <- [0..9], d4 `notElem` [d6,d3,d5,d9,d8,d7],
                numTest [d4,d5,d6] 7,
                d2 <- [0..9], d2 `notElem` [d4,d6,d3,d5,d9,d8,d7],
                numTest [d2,d3,d4] 3,
                d1 <- [0..9], d1 `notElem` [d2,d4,d6,d3,d5,d9,d8,d7],
                d0 <- [1..9], d0 `notElem` [d1,d2,d4,d6,d3,d5,d9,d8,d7]
              ]

main = do
         let nums = map toNum pandigitals
         print $ nums
         putStrLn ""
         print $ sum nums

For instance, in this case the assignment to d3 is not optimal - it really should be moved to just before the numTest [d2,d3,d4] 3 test. Doing that, however, would mean changing some of the notElem tests to remove d3 from the list being checked. Since the successive notElem lists are obtained by just consing the last chosen value to the previous list, it seems like this should be doable - somehow.

UPDATE: Here is the above program re-written with Louis' UniqueSel monad below:

toNum xs = foldl (\s d -> s*10+d) 0 xs
numTest xs m = (toNum xs) `mod` m == 0

pandigitalUS =
  do d7 <- choose
     d8 <- choose
     d9 <- choose
     guard $ numTest [d7,d8,d9] 17
     d6 <- choose
     guard $ numTest [d6,d7,d8] 13
     d5 <- choose
     guard $ d5 == 0 || d5 == 5
     guard $ numTest [d5,d6,d7] 11
     d4 <- choose
     guard $ numTest [d4,d5,d6] 7
     d3 <- choose
     d2 <- choose
     guard $ numTest [d2,d3,d4] 3
     d1 <- choose
     guard $ numTest [d1,d2,d3] 2
     d0 <- choose
     guard $ d0 /= 0
     return [d0,d1,d2,d3,d4,d5,d6,d7,d8,d9]

pandigitals = map snd $ runUS pandigitalUS [0..9]

main = do print $ pandigitals

Answer 1

Sure.

newtype UniqueSel a = UniqueSel {runUS :: [Int] -> [([Int], a)]}
instance Monad UniqueSel where
  return a = UniqueSel (\ choices -> [(choices, a)])
  m >>= k = UniqueSel (\ choices -> 
    concatMap (\ (choices', a) -> runUS (k a) choices')
      (runUS m choices))

instance MonadPlus UniqueSel where
  mzero = UniqueSel $ \ _ -> []
  UniqueSel m `mplus` UniqueSel k = UniqueSel $ \ choices ->
    m choices ++ k choices

-- choose something that hasn't been chosen before
choose :: UniqueSel Int
choose = UniqueSel $ \ choices ->
  [(pre ++ suc, x) | (pre, x:suc) <- zip (inits choices) (tails choices)]

and then you treat it like the List monad, with guard to enforce choices, except that it won't choose an item more than once. Once you have a UniqueSel [Int] computation, just do map snd (runUS computation [0..9]) to give it [0..9] as the choices to select from.

Answer 2

Before jumping to monads, let's consider guided unique selection from finite domains first:

-- all possibilities:
pick_any []     = []       
pick_any (x:xs) = (xs,x) : [ (x:dom,y) | (dom,y) <- pick_any xs ]

-- guided selection (assume there's no repetitions in the domain):
one_of ns xs = [ (dom,y) | let choices = pick_any xs, n <- ns,
                           (dom,y) <- take 1 $ filter ((==n).snd) choices ]

With this a list comprehension can be written without the use of elem calls:

p43 = sum [ fromDigits [d0,d1,d2,d3,d4,d5,d6,d7,d8,d9]
            | (dom5,d5) <- one_of [0,5] [0..9]
            , (dom6,d6) <- pick_any dom5          
            , (dom7,d7) <- pick_any dom6          
            , rem (100*d5+10*d6+d7) 11 == 0 
            ....

fromDigits    :: (Integral a) => [a] -> Integer
fromDigits ds = foldl' (\s d-> s*10 + fromIntegral d) 0 ds

The monad from Louis Wasserman's answer can be further augmented with additional operations based on the functions above:

import Control.Monad 

newtype UniqueSel a = UniqueSel { runUS :: [Int] -> [([Int], a)] }
instance Monad UniqueSel where
  -- as in Louis's answer

instance MonadPlus UniqueSel where
  -- as in Louis's answer

choose             = UniqueSel pick_any   
choose_one_of xs   = UniqueSel $ one_of xs
choose_n n         = replicateM n choose
set_choices cs     = UniqueSel (\ _ -> [(cs, ())])
get_choices        = UniqueSel (\cs -> [(cs, cs)])

So that we can write

numTest xs m = fromDigits xs `rem` m == 0

pandigitalUS :: UniqueSel [Int]
pandigitalUS = do
     set_choices [0..9]
     [d7,d8,d9] <- choose_n 3
     guard $ numTest [d7,d8,d9] 17
     d6 <- choose
     guard $ numTest [d6,d7,d8] 13
     d5 <- choose_one_of [0,5]
     guard $ numTest [d5,d6,d7] 11
     d4 <- choose
     guard $ numTest [d4,d5,d6] 7
     d3 <- choose_one_of [0,2..8]
     d2 <- choose
     guard $ rem (d2+d3+d4) 3 == 0 
     [d1,d0] <- choose_n 2
     guard $ d0 /= 0
     return [d0,d1,d2,d3,d4,d5,d6,d7,d8,d9]

pandigitals = map (fromDigits.snd) $ runUS pandigitalUS []

main = do print $ sum pandigitals

Answer 3

The UniqueSel monad suggested by Louis Wasserman is exactly StateT [Integer] [] (I'm using Integer everywhere for simplicity).

The state keeps the available digits and every computation is nondeterministic - from a given state we can select different digits to continue with. Now the choose function can be implemented as

import Control.Monad
import Control.Monad.State
import Control.Monad.Trans
import Data.List

choose :: PanM Integer
choose = do
    xs <- get
    x <- lift xs -- pick one of `xs`
    let xs' = x `delete` xs
    put xs'
    return x

And then the monad is run by evalStateT as

main = do
         let nums = evalStateT pandigitals [0..9]
         -- ...