Menu Close

Primos hereditarios

Un número primo es hereditario si todos los números obtenidos eliminando dígitos por la derecha o por la izquierda son primos. Por ejemplo, 3797 es hereditario ya que los números obtenidos eliminando dígitos por la derecha son 3797, 379, 37 y 3 y los obtenidos eliminando dígitos por la izquierda son 3797, 797, 97 y 7 y todos ellos son primos.

Definir la sucesión

   hereditarios :: [Integer]

cuyos elementos son los números hereditarios. Por ejemplo,

   ghci> take 15 hereditarios
   [2,3,5,7,23,37,53,73,313,317,373,797,3137,3797,739397]

Soluciones

import Data.List (inits, tails)
import Data.Char (digitToInt)
import Data.Numbers.Primes (primes, isPrime)
 
hereditarios :: [Integer]
hereditarios = [n | n <- primes, hereditario n]
 
hereditario :: Integer -> Bool
hereditario n = 
    all odd (map digitToInt (tail ds)) &&
    all isPrime (map read (tail (inits ds))) &&
    all isPrime (map read (init (tails ds)))
    where ds = show n
Posted in Medio

4 Comments

  1. Jesús Navas Orozco
    import Data.Numbers.Primes (isPrime)
     
    hereditarios :: [Integer]
    hereditarios = [x | x <- [1..], hereditario x]
       where hereditario x = derecha x && izquierda x
     
    derecha :: Integer -> Bool
    derecha 0 = True
    derecha x = isPrime x && derecha (x `div` 10)
     
    izquierda :: Integer -> Bool
    izquierda x = all isPrime [x `mod` 10^i | i <- [1..l]]
        where l = length (show x)
    • Jesús Navas Orozco

      La búsqueda se puede reducir a los números primos, pues es una condición necesaria para que sea hereditario:

      hereditarios :: [Integer]
      hereditarios = [x | x <- primes, hereditario x]
          where hereditario x = derecha x && izquierda x
  2. Pedro Martín Chávez
    import Data.Numbers.Primes
     
    hereditarios :: [Integer]
    hereditarios = [p | p <- primes, hereditario (show p)]
        where hereditario xs = and [aux a && aux b | n <- [1..length xs - 1],
                                                     let (a,b) = splitAt n xs]
              aux = isPrime . read
  3. josejuan

    Aunque algo elaborado puede hacerse exponencialmente más rápido que la solución trivial.
    Generamos desde la izquierda el árbol con podas hasta la mitad de dígitos.
    Generamos desde la derecha el árbol con podas hasta la mitad de dígitos.
    Vamos fusionando ambos árboles podando combinaciones que no encajan.
    Por A024785, no existirá ningún hereditario de más de 24 dígitos (¿existe alguna cota inferior?).
    Así, obtenerlos todos (sin saber que son 15) toma unos 95 mS y tomar los 15 unos 48 mS.

    import Data.Maybe
    import Data.Numbers.Primes
    import System.Environment
     
    type Digit   = Integer
    type Power10 = Integer
     
    -- Primos crecientes por la derecha
    data AD = AD Digit [AD] deriving Show
     
    -- sin llegar nunca a la izquierda del todo (en que habría que incluir todos los dígitos primos)
    generateAD :: Int -> [AD]
    generateAD = gen [AD d [] | d <- [3,7]]
        where gen ad 1 = ad
              gen ad n = gen (extendADsto [1,3,7,9] ad) (n - 1)
     
    extendADto :: Digit -> [AD] -> Maybe AD
    extendADto d = restrictADto 0 . AD d
     
    extendADsto :: [Digit] -> [AD] -> [AD]
    extendADsto ds ad = catMaybes [extendADto d ad | d <- ds]
     
    restrictADto :: Integer -> AD -> Maybe AD
    restrictADto z h@(AD d []) = if isPrime (10 * z + d) then Just h else Nothing
    restrictADto z   (AD d ad) = case restrictADsto (10 * z + d) ad of
                                    []  -> Nothing
                                    ad_ -> Just $ AD d ad_
     
    restrictADsto :: Integer -> [AD] -> [AD]
    restrictADsto z = catMaybes . map (restrictADto z)
     
    -- Primos crecientes por la izquierda
    data AI = AI Digit [AI] deriving Show
     
    -- sin llegar nunca a la derecha del todo (en que habría que excluir al 9)
    generateAI :: Int -> [AI]
    generateAI = gen [AI d [] | d <- [2,3,5,7]]
        where gen ad 1 = ad
              gen ad n = gen (extendAIsto [1,3,7,9] ad) (n - 1)
     
    extendAIto :: Digit -> [AI] -> Maybe AI
    extendAIto d = restrictAIto (0, 1) . AI d
     
    extendAIsto :: [Digit] -> [AI] -> [AI]
    extendAIsto ds ai = catMaybes [extendAIto d ai | d <- ds]
     
    restrictAIto :: (Integer, Power10) -> AI -> Maybe AI
    restrictAIto (z, p10) h@(AI d []) = if isPrime (p10 * d + z) then Just h else Nothing
    restrictAIto (z, p10)   (AI d ai) = case restrictAIsto (p10 * d + z, 10 * p10) ai of
                                            []  -> Nothing
                                            ai_ -> Just $ AI d ai_
     
    restrictAIsto :: (Integer, Power10) -> [AI] -> [AI]
    restrictAIsto zp = catMaybes . map (restrictAIto zp)
     
    -- Fusión central
    data Fus = Fus [AI] (Integer, Power10) [AD] deriving Show
     
    simplify :: Fus -> [Fus]
    simplify (Fus ai zp ad) = catMaybes [fuss zp i d | i <- ai, d <- ad]
     
    fuss :: (Integer, Power10) -> AI -> AD -> Maybe Fus
    fuss (z, p10) aii@(AI di (_:_)) add@(AD dd (_:_)) =
        case (restrictAIto (10 * z + dd, 10 * p10) aii, restrictADto w add) of
            (Just (AI _ ai_), Just (AD _ ad_)) -> Just $ Fus ai_ (10 * w + dd, 100 * p10) ad_
            _                                  -> Nothing
        where w = p10 * di + z
    fuss _ _ _ = error "Final step must be computed through `simplifyHer`"
     
    -- Reduce el último paso y generar los hereditarios que queden
    simplifyHer :: Fus -> [Integer]
    simplifyHer (Fus aii zp add) = catMaybes [fussHer zp i d | i <- aii, d <- add]
     
    fussHer (z, p10) aii@(AI di []) add@(AD dd []) = let p = (p10 * di + z) * 10 + dd
                                                     in if isPrime p then Just p else Nothing
    fussHer _ _ _ = error "Invalid argument. Must be a final step."
     
    -- Reducir hasta último paso y generar los hereditarios que queden
    solve :: [Fus] -> [Integer]
    solve [] = []
    solve xs@((Fus ((AI _ []):_) _ ((AD _ []):_)):_) = concatMap simplifyHer xs
    solve ((Fus ((AI _ []):_) _ _):_) = [] -- sin solución
    solve ((Fus _ _ ((AD _ []):_)):_) = [] -- sin solución
    solve xs = solve $ concatMap simplify xs
     
    -- Dados dos árboles (AI y AD) expande el cancidato con dígitos pares e impares (el pares + 1)
    solveN :: Int -> [Integer]
    solveN n = let aii = generateAI n
                   add = generateAD n
               in  solve ((Fus aii (0, 1) add): [ Fus aii_ zp add_
                                                    | d <- [1,3,7,9]
                                                    , let zp = (d, 10)
                                                          aii_ = restrictAIsto zp aii
                                                          add_ = restrictADsto  d add
                                                    , not (null aii_)
                                                    , not (null add_)
                                                    ])
     
    -- no hace falta revisar más de 24 dígitos porque:
    -- A024785: Last term is a(4260) = 357686312646216567629137 (Angell and Godwin)
    hereditarios :: [Integer]
    hereditarios = [2,3,5,7] ++ concatMap solveN [1..12]
     
    main = do
        (n:_) <- getArgs >>= return . map read
        print $ take n hereditarios
     
    {-
     
    josejuan@haskell /cygdrive/d/Projects/haskell
    $ time ./hereditarios.exe 15
    [2,3,5,7,23,37,53,73,313,317,373,797,3137,3797,739397]
     
    real    0m0.048s
    user    0m0.000s
    sys     0m0.015s
     
    josejuan@haskell /cygdrive/d/Projects/haskell
    $ time ./hereditarios.exe 150
    [2,3,5,7,23,37,53,73,313,317,373,797,3137,3797,739397]
     
    real    0m0.092s
    user    0m0.000s
    sys     0m0.015s
     
    -}

Escribe tu solución

Este sitio usa Akismet para reducir el spam. Aprende cómo se procesan los datos de tus comentarios.