Menu Close

Primos hereditarios

José A. Alonso,

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
Tagged , , , , , , , , , , , , ,

4 Comments

  1. Jesús Navas Orozco
    Responder 
    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
      Responder

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

    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.