Euler 43: ¿hay alguna mónada para ayudar a escribir esta lista de comprensión?

Question

Aquí hay una manera de resolver el problema 43 de Euler (por favor, avíseme si esto no da la respuesta correcta). ¿Hay una mónada o algún otro azúcar sintáctico que pueda ayudar a hacer un seguimiento de las condiciones de notElem?

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 

Por ejemplo, en este caso la asignación a d3 no es óptima - lo que realmente debe ser trasladado a justo antes de la prueba numTest [d2,d3,d4] 3. Hacer eso, sin embargo, significaría cambiar algunas de las pruebas notElem para eliminar d3 de la lista que se está verificando. Dado que las sucesivas listas notElem se obtienen con solo incluir el último valor elegido en la lista anterior, parece que esto debería ser factible, de alguna manera.

ACTUALIZACIÓN: Aquí está el programa anterior re-escrito con Louis' UniqueSel mónada a continuación:

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

Claro.

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

y luego tratarla como la mónada lista, con guard para hacer cumplir las opciones, excepto que no se elija un elemento más de una vez. Una vez que tenga un cálculo UniqueSel [Int], simplemente haga map snd (runUS computation [0..9]) para darle [0..9] como las opciones para seleccionar.

Answer 2

Antes de saltar a las mónadas, vamos a considerar guiar selección única de dominios finitos primeros:

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

Con esta una lista por comprensión se puede escribir sin el uso de elem llamadas:

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 

La mónada de Louis Wasserman's answer se puede aumentar aún más con operaciones adicionales basadas en las funciones anteriores:

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

De modo que podemos escribir

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

El UniqueSel mónada sugerido por Louis Wasserman es exactamente StateT [Integer] [] (estoy usando Integer todas partes para simplificar).

El estado mantiene los dígitos disponibles y cada cálculo no es determinístico: desde un estado determinado, podemos seleccionar diferentes dígitos para continuar. Ahora la función choose puede implementarse como

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 

Y entonces la mónada está dirigido por evalStateT como

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