Medio – Exercitium

Números ordenados con cuadrados ordenados

PorJosé A. Alonso 18-marzo-202125-marzo-2021

Un número es ordenado si cada uno de sus dígitos es menor o igual el siguiente dígito. Por ejemplo, 116 es un número creciente y su cuadrado es 13456, que también es ordenado. En cambio, 115 es ordenado pero su cuadrado es 13225 que no es ordenado.

Definir la lista

   numerosOrdenadosConCuadradosOrdenados :: [Integer]

1	numerosOrdenadosConCuadradosOrdenados :: [Integer]

cuyos elementos son los números ordenados cuyos cuadrados también lo son. Por ejemplo,

   λ> take 20 numerosOrdenadosConCuadradosOrdenados
   [0,1,2,3,4,5,6,7,12,13,15,16,17,34,35,37,38,67,116,117]
   λ> length (show (numerosOrdenadosConCuadradosOrdenados !! (10^6)))
   1411
   λ> length (show (numerosOrdenadosConCuadradosOrdenados !! (5*10^6)))
   3159

λ> take 20 numerosOrdenadosConCuadradosOrdenados

[0,1,2,3,4,5,6,7,12,13,15,16,17,34,35,37,38,67,116,117]

λ> length (show (numerosOrdenadosConCuadradosOrdenados !! (10^6)))

1411

λ> length (show (numerosOrdenadosConCuadradosOrdenados !! (5*10^6)))

3159

Soluciones

import Data.List

-- 1ª solución
-- ===========

numerosOrdenadosConCuadradosOrdenados :: [Integer]
numerosOrdenadosConCuadradosOrdenados =
  filter numeroOrdenadoConCuadradoOrdenado [0..]

-- (numeroOrdenadoConCuadradoOrdenado n) se verifica si n es un número
-- ordenado cuyo cuadrado también lo es. Por ejemplo,
--    numeroOrdenadoConCuadradoOrdenado 116  ==  True
--    numeroOrdenadoConCuadradoOrdenado 115  ==  False
numeroOrdenadoConCuadradoOrdenado :: Integer -> Bool
numeroOrdenadoConCuadradoOrdenado n =
  ordenado n && ordenado (n^2)

-- (ordenado n) se verifica si n es un número ordenado. Por ejemplo,
--    ordenado 115  ==  True
--    ordenado 151  ==  False
ordenado :: Integer -> Bool
ordenado n =
  and [x <= y | (x,y) <- zip xs (tail xs)]
  where xs = show n

-- 2ª solución
-- ===========

-- Se basa en la observación de los sisuientes cálculos con la primera
-- solución
--    λ> take 30 numerosOrdenadosConCuadradosOrdenados
--    [0,1,2,3,4,5,6,7,12,13,15,16,17,34,35,37,38,67,116,117,
--     167,334,335,337,367,667,1667,3334,3335,3337]
--    λ> take 21 (dropWhile (<= 117) numerosOrdenadosConCuadradosOrdenados)
--    [167,334,335,337,367,667,
--     1667,3334,3335,3337,3367,3667,6667,
--     16667,33334,33335,33337,33367,33667,36667,66667]
--
-- Se observa que a partir del 167 todos los elementos son de 4 tipos
-- como se ve en la siguente tabla
--    |-------+--------+--------+--------+--------|
--    |       | Tipo A | Tipo B | Tipo C | Tipo D |
--    |-------+--------+--------+--------+--------|
--    |   167 | 16¹7   |        |        |        |
--    |   334 |        | 3²4    |        |        |
--    |   335 |        |        | 3²5    |        |
--    |   337 |        |        |        | 3²6⁰7  |
--    |   367 |        |        |        | 3¹6¹7  |
--    |   667 |        |        |        | 3⁰6²7  |
--    |  1667 | 16²7   |        |        |        |
--    |  3334 |        | 3³4    |        |        |
--    |  3335 |        |        | 3³5    |        |
--    |  3337 |        |        |        | 3³6⁰7  |
--    |  3367 |        |        |        | 3²6¹7  |
--    |  3667 |        |        |        | 3¹6²7  |
--    |  6667 |        |        |        | 3⁰6³7  |
--    | 16667 | 16³7   |        |        |        |
--    | 33334 |        | 3⁴4    |        |        |
--    | 33335 |        |        | 3⁴5    |        |
--    | 33337 |        |        |        | 3⁴6⁰7  |
--    | 33367 |        |        |        | 3³6¹7  |
--    | 33667 |        |        |        | 3²6²7  |
--    | 36667 |        |        |        | 3¹6³7  |
--    | 66667 |        |        |        | 3⁰6⁴7  |
--    |-------+--------+--------+--------+--------|
-- donde el exponente en cad dígito indica el número de repeticiones de
-- dicho dígito.

numerosOrdenadosConCuadradosOrdenados2 :: [Integer]
numerosOrdenadosConCuadradosOrdenados2 =
  [0,1,2,3,4,5,6,7,12,13,15,16,17,34,35,37,38,67,116,117] ++
  map read (concat [['1' : replicate n '6' ++ "7",
                     replicate (n+1) '3' ++ "4",
                     replicate (n+1) '3' ++ "5"] ++
                    [replicate a '3' ++ replicate b '6' ++ "7"
                    | b <- [0..n+1], let a = (n+1) - b]
                   | n <- [1..]])

-- Comparación de eficiencia
-- =========================

-- La comparación es
--    λ> numerosOrdenadosConCuadradosOrdenados !! 50
--    1666667
--    (2.35 secs, 2,173,983,096 bytes)
--    λ> numerosOrdenadosConCuadradosOrdenados2 !! 50
--    1666667
--    (0.01 secs, 125,296 bytes)

-- Comprobación de equivalencia
-- ============================

-- La comprobación es
--    λ> take 50 numerosOrdenadosConCuadradosOrdenados == take 50 numerosOrdenadosConCuadradosOrdenados2
--    True

import Data.List

-- 1ª solución

-- ===========

numerosOrdenadosConCuadradosOrdenados :: [Integer]

numerosOrdenadosConCuadradosOrdenados =

filter numeroOrdenadoConCuadradoOrdenado [0..]

-- (numeroOrdenadoConCuadradoOrdenado n) se verifica si n es un número

-- ordenado cuyo cuadrado también lo es. Por ejemplo,

-- numeroOrdenadoConCuadradoOrdenado 116 == True

-- numeroOrdenadoConCuadradoOrdenado 115 == False

numeroOrdenadoConCuadradoOrdenado :: Integer -> Bool

numeroOrdenadoConCuadradoOrdenado n =

ordenado n && ordenado (n^2)

-- (ordenado n) se verifica si n es un número ordenado. Por ejemplo,

-- ordenado 115 == True

-- ordenado 151 == False

ordenado :: Integer -> Bool

ordenado n =

and [x <= y | (x,y) <- zip xs (tail xs)]

where xs = show n

-- 2ª solución

-- ===========

-- Se basa en la observación de los sisuientes cálculos con la primera

-- solución

-- λ> take 30 numerosOrdenadosConCuadradosOrdenados

-- [0,1,2,3,4,5,6,7,12,13,15,16,17,34,35,37,38,67,116,117,

-- 167,334,335,337,367,667,1667,3334,3335,3337]

-- λ> take 21 (dropWhile (<= 117) numerosOrdenadosConCuadradosOrdenados)

-- [167,334,335,337,367,667,

-- 1667,3334,3335,3337,3367,3667,6667,

-- 16667,33334,33335,33337,33367,33667,36667,66667]

-- Se observa que a partir del 167 todos los elementos son de 4 tipos

-- como se ve en la siguente tabla

-- |-------+--------+--------+--------+--------|

-- |-------+--------+--------+--------+--------|

-- | 167 | 16¹7 | | | |

-- | 334 | | 3²4 | | |

-- | 335 | | | 3²5 | |

-- | 337 | | | | 3²6⁰7 |

-- | 367 | | | | 3¹6¹7 |

-- | 667 | | | | 3⁰6²7 |

-- | 1667 | 16²7 | | | |

-- | 3334 | | 3³4 | | |

-- | 3335 | | | 3³5 | |

-- | 3337 | | | | 3³6⁰7 |

-- | 3367 | | | | 3²6¹7 |

-- | 3667 | | | | 3¹6²7 |

-- | 6667 | | | | 3⁰6³7 |

-- | 16667 | 16³7 | | | |

-- | 33334 | | 3⁴4 | | |

-- | 33335 | | | 3⁴5 | |

-- | 33337 | | | | 3⁴6⁰7 |

-- | 33367 | | | | 3³6¹7 |

-- | 33667 | | | | 3²6²7 |

-- | 36667 | | | | 3¹6³7 |

-- | 66667 | | | | 3⁰6⁴7 |

-- |-------+--------+--------+--------+--------|

-- donde el exponente en cad dígito indica el número de repeticiones de

-- dicho dígito.

numerosOrdenadosConCuadradosOrdenados2 :: [Integer]

numerosOrdenadosConCuadradosOrdenados2 =

[0,1,2,3,4,5,6,7,12,13,15,16,17,34,35,37,38,67,116,117] ++

map read (concat [['1' : replicate n '6' ++ "7",

replicate (n+1) '3' ++ "4",

replicate (n+1) '3' ++ "5"] ++

[replicate a '3' ++ replicate b '6' ++ "7"

| b <- [0..n+1], let a = (n+1) - b]

| n <- [1..]])

-- Comparación de eficiencia

-- =========================

-- La comparación es

-- λ> numerosOrdenadosConCuadradosOrdenados !! 50

-- 1666667

-- (2.35 secs, 2,173,983,096 bytes)

-- λ> numerosOrdenadosConCuadradosOrdenados2 !! 50

-- 1666667

-- (0.01 secs, 125,296 bytes)

-- Comprobación de equivalencia

-- ============================

-- La comprobación es

-- λ> take 50 numerosOrdenadosConCuadradosOrdenados == take 50 numerosOrdenadosConCuadradosOrdenados2

-- True

Nuevas soluciones

En los comentarios se pueden escribir nuevas soluciones.
El código se debe escribir entre una línea con <pre lang="haskell"> y otra con </pre>

Cálculo de pi mediante la fórmula de Brouncker

PorJosé A. Alonso 11-marzo-202118-marzo-2021

El mes de marzo es el mes de pi, ya que el 14 de marzo (3/14) es el día de pi. Con ese motivo, el pasado 3 de marzo se publicó en Twitter un mensaje con la fórmula de Brouncker para el cálculo de pi

La primeras aproximaciones son

     a(1) = 4                                  =  4
     a(2) = 4/(1+1^2)                          =  2.0
     a(3) = 4/(1+1^2/(2+3^2))                  =  3.666666666666667
     a(4) = 4/(1+1^2/(2+3^2/(2+5^2)))          =  2.8
     a(5) = 4/(1+1^2/(2+3^2/(2+5^2/(2+7^2))))  =  3.395238095238095

a(1) = 4 = 4

a(2) = 4/(1+1^2) = 2.0

a(3) = 4/(1+1^2/(2+3^2)) = 3.666666666666667

a(4) = 4/(1+1^2/(2+3^2/(2+5^2))) = 2.8

a(5) = 4/(1+1^2/(2+3^2/(2+5^2/(2+7^2)))) = 3.395238095238095

Definir las funciones

   aproximacionPi :: Int -> Double
   grafica        :: [Int] -> IO ()

1 2	aproximacionPi :: Int -> Double grafica :: [Int] -> IO ()

tales que

(aproximacionPi n) es la n-ésima aproximación de pi con la fórmula de Brouncker. Por ejemplo,

     aproximacionPi 1      ==  4.0
     aproximacionPi 2      ==  2.0
     aproximacionPi 3      ==  3.666666666666667
     aproximacionPi 4      ==  2.8
     aproximacionPi 5      ==  3.395238095238095
     aproximacionPi 10     ==  3.0301437124966535
     aproximacionPi 1000   ==  3.1405916523380406
     aproximacionPi 1001   ==  3.142592653839793
     aproximacionPi 10000  ==  3.141492643588543
     aproximacionPi 10001  ==  3.1416926535900433
     pi                    ==  3.141592653589793

aproximacionPi 1 == 4.0

aproximacionPi 2 == 2.0

aproximacionPi 3 == 3.666666666666667

aproximacionPi 4 == 2.8

aproximacionPi 5 == 3.395238095238095

aproximacionPi 10 == 3.0301437124966535

aproximacionPi 1000 == 3.1405916523380406

aproximacionPi 1001 == 3.142592653839793

aproximacionPi 10000 == 3.141492643588543

aproximacionPi 10001 == 3.1416926535900433

pi == 3.141592653589793

(grafica xs) dibuja la gráfica de las k-ésimas aproximaciones de pi para k en xs. Por ejemplo, (grafica [10..100]) dibuja

Soluciones

import Graphics.Gnuplot.Simple (Attribute (Key, PNG), plotList)

-- 1ª solución
-- ===========

aproximacionPi :: Int -> Double
aproximacionPi 1 = 4
aproximacionPi n = 4/(1 + 1/(aux 1 3))
  where aux a b | a == n-1  = 1
                | otherwise = 2 + (b^2)/(aux (a+1) (b+2))

-- El cálculo es
--    aproximacionPi 2
--      = 4/(1 + 1/(aux 1 3))
--      = 4/(1 + 1/1)
--      = 2.0
--
--    aproximacionPi 3
--      = 4/(1 + 1/(aux 1 3))
--      = 4/(1 + 1/(2 + 3^2/(aux 2 5))
--      = 4/(1 + 1/(2 + 3^2/1))
--      = 3.666666666666667
--
--    aproximacionPi 4
--      = 4/(1 + 1/(aux 1 3))
--      = 4/(1 + 1/(2 + 3^2/(aux 2 5))
--      = 4/(1 + 1/(2 + 3^2/(2 + 5^2/(aux 3 7))))
--      = 4/(1 + 1/(2 + 3^2/(2 + 5^2/1)))
--      = 2.8

-- 2ª solución
-- ===========

aproximacionPi2 :: Int -> Double
aproximacionPi2 n =
  aproximacionFC n fraccionPi

-- fraccionPi es la representación de la fracción continua de pi como un
-- par de listas infinitas.
fraccionPi :: [(Integer, Integer)]
fraccionPi = zip (0 : 1 : [2,2..]) (4 : map (^2) [1,3..])

-- (aproximacionFC n fc) es la n-ésima aproximación de la fracción
-- continua fc (como un par de listas).
aproximacionFC :: Int -> [(Integer, Integer)] -> Double
aproximacionFC n =
  foldr (\(a,b) z -> fromIntegral a + fromIntegral b / z) 1 . take n

-- Gráfica
-- =======

grafica :: [Int] -> IO ()
grafica xs =
  plotList [ Key Nothing
           -- , PNG "Calculo_de_pi_mediante_la_formula_de_Brouncker_1.png"
           ]
           [(k,aproximacionPi k) | k <- xs]

import Graphics.Gnuplot.Simple (Attribute (Key, PNG), plotList)

-- 1ª solución

-- ===========

aproximacionPi :: Int -> Double

aproximacionPi 1 = 4

aproximacionPi n = 4/(1 + 1/(aux 1 3))

where aux a b | a == n-1 = 1

| otherwise = 2 + (b^2)/(aux (a+1) (b+2))

-- El cálculo es

-- aproximacionPi 2

-- = 4/(1 + 1/(aux 1 3))

-- = 4/(1 + 1/1)

-- = 2.0

-- aproximacionPi 3

-- = 4/(1 + 1/(aux 1 3))

-- = 4/(1 + 1/(2 + 3^2/(aux 2 5))

-- = 4/(1 + 1/(2 + 3^2/1))

-- = 3.666666666666667

-- aproximacionPi 4

-- = 4/(1 + 1/(aux 1 3))

-- = 4/(1 + 1/(2 + 3^2/(aux 2 5))

-- = 4/(1 + 1/(2 + 3^2/(2 + 5^2/(aux 3 7))))

-- = 4/(1 + 1/(2 + 3^2/(2 + 5^2/1)))

-- = 2.8

-- 2ª solución

-- ===========

aproximacionPi2 :: Int -> Double

aproximacionPi2 n =

aproximacionFC n fraccionPi

-- fraccionPi es la representación de la fracción continua de pi como un

-- par de listas infinitas.

fraccionPi :: [(Integer, Integer)]

fraccionPi = zip (0 : 1 : [2,2..]) (4 : map (^2) [1,3..])

-- (aproximacionFC n fc) es la n-ésima aproximación de la fracción

-- continua fc (como un par de listas).

aproximacionFC :: Int -> [(Integer, Integer)] -> Double

aproximacionFC n =

foldr (\(a,b) z -> fromIntegral a + fromIntegral b / z) 1 . take n

-- Gráfica

-- =======

grafica :: [Int] -> IO ()

grafica xs =

plotList [ Key Nothing

-- , PNG "Calculo_de_pi_mediante_la_formula_de_Brouncker_1.png"

]

[(k,aproximacionPi k) | k <- xs]

Nuevas soluciones

En los comentarios se pueden escribir nuevas soluciones.
El código se debe escribir entre una línea con <pre lang="haskell"> y otra con </pre>

Sucesión de Rowland

PorJosé A. Alonso 9-marzo-202116-marzo-2021

Definir las siguientes sucesiones

   sucesionA       :: [Integer]
   sucesionB       :: [Integer]
   sucesionRowland :: [Integer]

sucesionA :: [Integer]

sucesionB :: [Integer]

sucesionRowland :: [Integer]

tales que

el término n-ésimo de la sucesionA es a(n) definido por a(1) = 7 y a(n) = a(n-1) + mcd(n, a(n-1)), para n > 1. Por ejemplo,

     λ> take 20 sucesionA
     [7,8,9,10,15,18,19,20,21,22,33,36,37,38,39,40,41,42,43,44]

1 2	λ> take 20 sucesionA [7,8,9,10,15,18,19,20,21,22,33,36,37,38,39,40,41,42,43,44]

los términos de la sucesionB son las diferencias de los términos consecutivos de la sucesionA. Por ejemplo,

     λ> take 30 sucesionB
     [1,1,1,5,3,1,1,1,1,11,3,1,1,1,1,1,1,1,1,1,1,23,3,1,1,1,1,1,1,1]

1 2	λ> take 30 sucesionB [1,1,1,5,3,1,1,1,1,11,3,1,1,1,1,1,1,1,1,1,1,23,3,1,1,1,1,1,1,1]

los términos de la sucesionRowland son los términos de la sucesionB distintos de 1. Por ejemplo,\0

      λ> take 20 sucesionRowland
      [5,3,11,3,23,3,47,3,5,3,101,3,7,11,3,13,233,3,467,3]
      λ> sucesionRowland !! 92
      15567089

λ> take 20 sucesionRowland

[5,3,11,3,23,3,47,3,5,3,101,3,7,11,3,13,233,3,467,3]

λ> sucesionRowland !! 92

15567089

Comprobar con QuickCheck que los elementos de la sucesionRowland son números primos.

Nota: Eric S. Rowland demostró en A natural prime-generating recurrence que los elementos de la sucesionRowland son números primos.

Soluciones

import Data.Numbers.Primes (isPrime)
import Test.QuickCheck (Property, (==>), quickCheck)

sucesionA :: [Integer]
sucesionA =
   7 : zipWith (+) sucesionA (zipWith gcd sucesionA [2..])

sucesionB :: [Integer]
sucesionB = zipWith (-) (tail sucesionA) sucesionA

sucesionRowland :: [Integer]
sucesionRowland =  filter (> 1) sucesionB

-- La propiedad es
prop_sucesionRowland :: Int -> Property
prop_sucesionRowland n =
  n >= 0 ==> isPrime (sucesionRowland !! n)

-- La comprobación es
--    λ> quickCheck prop_sucesionRowland
--    +++ OK, passed 100 tests.

import Data.Numbers.Primes (isPrime)

import Test.QuickCheck (Property, (==>), quickCheck)

sucesionA :: [Integer]

sucesionA =

7 : zipWith (+) sucesionA (zipWith gcd sucesionA [2..])

sucesionB :: [Integer]

sucesionB = zipWith (-) (tail sucesionA) sucesionA

sucesionRowland :: [Integer]

sucesionRowland = filter (> 1) sucesionB

-- La propiedad es

prop_sucesionRowland :: Int -> Property

prop_sucesionRowland n =

n >= 0 ==> isPrime (sucesionRowland !! n)

-- La comprobación es

-- λ> quickCheck prop_sucesionRowland

-- +++ OK, passed 100 tests.

Nuevas soluciones

En los comentarios se pueden escribir nuevas soluciones.
El código se debe escribir entre una línea con <pre lang="haskell"> y otra con </pre>

Siguiente equidigital

PorJosé A. Alonso 5-marzo-202112-marzo-2021

Dos números son equidigitales si tienen el mismo multiconjunto de dígitos. Por ejemplo, 2021 y 2120 son equidigitales ya que ambos tiene a {0,1,2,2} como su multiconjunto de dígitos.

Definir la función

   siguienteEquidigital :: Integer -> Maybe Integer

1	siguienteEquidigital :: Integer -> Maybe Integer

tal que (siguienteEquidigital n) es precisamente el menor número equidigital con n que es mayor que n (es decir, (Just x) si x es dicho número o Nothing si no hay ningún número equidigital con n que sea mayor que n). Por ejemplo,

   siguienteEquidigital 12    ==  Just 21
   siguienteEquidigital 21    ==  Nothing
   siguienteEquidigital 513   ==  Just 531
   siguienteEquidigital 531   ==  Nothing
   siguienteEquidigital 2021  ==  Just 2102
   siguienteEquidigital 2102  ==  Just 2120
   siguienteEquidigital 2120  ==  Just 2201
   siguienteEquidigital 2201  ==  Just 2210
   siguienteEquidigital 2210  ==  Nothing
   fmap (`mod` 1000) (siguienteEquidigital (2^(10^5)))  ==  Just 637

siguienteEquidigital 12 == Just 21

siguienteEquidigital 21 == Nothing

siguienteEquidigital 513 == Just 531

siguienteEquidigital 531 == Nothing

siguienteEquidigital 2021 == Just 2102

siguienteEquidigital 2102 == Just 2120

siguienteEquidigital 2120 == Just 2201

siguienteEquidigital 2201 == Just 2210

siguienteEquidigital 2210 == Nothing

fmap (`mod` 1000) (siguienteEquidigital (2^(10^5))) == Just 637

Soluciones

import Data.List (sort)
import Data.Maybe (listToMaybe)

-- 1ª solución
-- ===========

siguienteEquidigital :: Integer -> Maybe Integer
siguienteEquidigital n
  | null xs = Nothing
  | otherwise = Just (head xs)
  where xs = equidigitalesMayores n

-- (equidigitalesMayores n) es la lista de los equidigitales mayores que
-- n. Por ejemplo,
--    equidigitalesMayores 2021  ==  [2102,2120,2201,2210]
--    equidigitalesMayores 2210  ==  []
equidigitalesMayores :: Integer -> [Integer]
equidigitalesMayores n =
  [x | x <- [n+1..mayorEquidigital n],
       sort (show x) == ds]
  where ds = sort (show n)

-- (mayorEquidigital n) es el mayor número equidigital con n. Por ejemplo,
--    mayorEquidigital 2021  ==  2210
--    mayorEquidigital 2210  ==  2210
mayorEquidigital :: Integer -> Integer
mayorEquidigital = read . reverse . sort . show

-- 2ª solución
-- ===========

siguienteEquidigital2 :: Integer -> Maybe Integer
siguienteEquidigital2 = listToMaybe . equidigitalesMayores

import Data.List (sort)

import Data.Maybe (listToMaybe)

-- 1ª solución

-- ===========

siguienteEquidigital :: Integer -> Maybe Integer

siguienteEquidigital n

| null xs = Nothing

| otherwise = Just (head xs)

where xs = equidigitalesMayores n

-- (equidigitalesMayores n) es la lista de los equidigitales mayores que

-- n. Por ejemplo,

-- equidigitalesMayores 2021 == [2102,2120,2201,2210]

-- equidigitalesMayores 2210 == []

equidigitalesMayores :: Integer -> [Integer]

equidigitalesMayores n =

[x | x <- [n+1..mayorEquidigital n],

sort (show x) == ds]

where ds = sort (show n)

-- (mayorEquidigital n) es el mayor número equidigital con n. Por ejemplo,

-- mayorEquidigital 2021 == 2210

-- mayorEquidigital 2210 == 2210

mayorEquidigital :: Integer -> Integer

mayorEquidigital = read . reverse . sort . show

-- 2ª solución

-- ===========

siguienteEquidigital2 :: Integer -> Maybe Integer

siguienteEquidigital2 = listToMaybe . equidigitalesMayores

Nuevas soluciones

En los comentarios se pueden escribir nuevas soluciones.
El código se debe escribir entre una línea con <pre lang="haskell"> y otra con </pre>

Mínima diferencia de las sumas de las biparticiones de las N primeras potencias de dos

PorJosé A. Alonso 2-marzo-20219-marzo-2021

Se consideran las N primeras potencias de 2 (donde N es un número par). Por ejemplo, para N = 4, las potencias de 2 son 1, 2, 4 y 8. Las biparticiones de dichas potencias en dos conjuntos de igual tamaño son

   ([1,2],[4,8]), ([1,4],[2,8]), ([1,8],[2,4])

1	([1,2],[4,8]), ([1,4],[2,8]), ([1,8],[2,4])

Las sumas de los elementos de las biparticiones son

   (3,12), (5,10), (9,6)

1	(3,12), (5,10), (9,6)

Los valores absolutos de las diferencias de dichas sumas son

   9, 5, 3

9, 5, 3

El mínimo de dichas diferencias es 3.

Definir la función

  minimaDiferencia :: Integer -> Integer

1	minimaDiferencia :: Integer -> Integer

tal que (minimaDiferencia n) es la mínima diferencia de las sumas las biparticiones de las n (donde n es un número par) primeras potencias de dos conjuntos con igual número de elementos. Por ejemplo,

   minimaDiferencia 4  ==  3
   minimaDiferencia 6  ==  7
   minimaDiferencia (10^9) `mod` (10^9)  ==  787109375

minimaDiferencia 4 == 3

minimaDiferencia 6 == 7

minimaDiferencia (10^9) `mod` (10^9) == 787109375

Soluciones

import Test.QuickCheck
import Data.List ((\\))

-- 1ª solución
-- ===========

minimaDiferencia :: Integer -> Integer
minimaDiferencia n =
  minimum [abs (sum xs - sum ys) | (xs,ys) <- particiones n]

-- (particiones n) es la lista de las particiones de las n (donde n es
-- un número par) de las n primeras potencias de 2 en dos conjuntos de
-- igual tamaño. Por ejemplo,
--   λ> particiones 4
--   [([1,2],[4,8]),([1,4],[2,8]),([1,8],[2,4]),
--    ([2,4],[1,8]),([2,8],[1,4]),([4,8],[1,2])]
particiones :: Integer -> [([Integer],[Integer])]
particiones n =
  [(as,xs \\ as) | as <- kSubconjuntos xs (n `div` 2)]
  where xs = [2^k | k <- [0..n-1]]

-- (kSubconjuntos xs k) es la lista de los subconjuntos de xs con k
-- elementos. Por ejemplo,
--    λ> kSubconjuntos "bcde" 2
--    ["bc","bd","be","cd","ce","de"]
--    λ> kSubconjuntos "bcde" 3
--    ["bcd","bce","bde","cde"]
--    λ> kSubconjuntos "abcde" 3
--    ["abc","abd","abe","acd","ace","ade","bcd","bce","bde","cde"]
kSubconjuntos :: [a] -> Integer -> [[a]]
kSubconjuntos _ 0      = [[]]
kSubconjuntos [] _     = []
kSubconjuntos (x:xs) k =
  [x:ys | ys <- kSubconjuntos xs (k-1)] ++ kSubconjuntos xs k

-- 2ª solución
-- ===========

-- Nota: La suma de las primeras (n-1) potencias de 2 es
--    sum [2^i | i <- [0..n-2]] = 2^(n-1) - 1
-- que es menor que la n-ésima potencia de 2 (es decir, 2^(n-1) porque
-- se empieza a contar en 0). Por tanto, para que la diferencia de las
-- suma sea mínima hay que agrupar la última (2^(n-1) con las menores
-- (es decir, desde 0 hasta n/2-2).

minimaDiferencia2 :: Integer -> Integer
minimaDiferencia2 n =
  2^(n-1) + sum [2^i | i <- [0..n `div` 2 - 2]] -
  sum [2^i | i <- [n `div` 2 - 1.. n-2]]

-- 3ª solución
-- ===========

-- Nota: Sea m = n/2 - 2. Entonces la suma de la mayor con las menores
-- es
--    s1 = 2^(n-1) + sum [2^i | i <- [0..m]]
--       = 2^(n-1) + (2^(m+1)-1)
-- y, puesto que la suma de las n primeras potencias es 2^n-1, la suma
-- de las restantes es
--    s2 = (2^n-1) - s1

minimaDiferencia3 :: Integer -> Integer
minimaDiferencia3 n = s1 - s2
  where m = n `div` 2 - 2
        s1 = 2^(n-1) + (2^(m+1)-1)
        s2 = (2^n-1) - s1

-- 4ª solución
-- ===========

-- Nota: Con la notación de la solución anterior, la mínima diferencia es
--    s1 - s2
--    = s1 - ((2^n-1) - s1)
--    = 2*s1 - (2^n-1)
--    = 2*(2^(n-1) + (2^(m+1)-1)) - (2^n-1)
--    = 2^n + 2^(m+2) - 2 - 2^n + 1
--    = 2^(m+2) - 1

minimaDiferencia4 :: Integer -> Integer
minimaDiferencia4 n = 2^(m+2) - 1
  where m = n `div` 2 - 2

-- Comparación de eficiencia
-- =========================

-- La comparación es
--    λ> minimaDiferencia 22
--    2047
--    (7.75 secs, 6,597,330,816 bytes)
--    λ> minimaDiferencia2 22
--    2047
--    (0.00 secs, 126,344 bytes)
--    λ> minimaDiferencia3 22
--    2047
--    (0.01 secs, 107,192 bytes)
--    λ> minimaDiferencia4 22
--    2047
--    (0.01 secs, 102,544 bytes)
--
--    λ> minimaDiferencia2 (10^5) `mod` (10^50)
--    9602443968201967760613102289456131085235835109375
--    (8.18 secs, 2,915,200,064 bytes)
--    λ> minimaDiferencia3 (10^5) `mod` (10^50)
--    9602443968201967760613102289456131085235835109375
--    (0.01 secs, 293,640 bytes)
--    λ> minimaDiferencia4 (10^5) `mod` (10^50)
--    9602443968201967760613102289456131085235835109375
--    (0.03 secs, 167,176 bytes)
--
--    λ> minimaDiferencia3 (10^8) `mod` (10^50)
--    30521751870548886367615394702753936894129787109375
--    (2.08 secs, 149,075,824 bytes)
--    λ> minimaDiferencia4 (10^8) `mod` (10^50)
--    30521751870548886367615394702753936894129787109375
--    (0.41 secs, 24,929,696 bytes)

-- Comprobación de equivalencia
-- ============================

-- Como la primera sólo calcula hasta 22, se compara la primera con la
-- cuarta para dichos valores.
prop_equivalencia1 :: Bool
prop_equivalencia1 =
  and [minimaDiferencia n == minimaDiferencia4 n | n <- [0,2..22]]

-- La comprobación es
--    λ> prop_equivalencia1
--    True

-- La propiedad de la equivalencia de las definiciones 2, 3 y 4 es
prop_equivalencia :: Integer -> Bool
prop_equivalencia n =
  all (== (minimaDiferencia2 n'))
      [minimaDiferencia3 n',
       minimaDiferencia4 n']
  where n' = 2 + abs n

-- La comprobación es
--    λ> quickCheck prop_equivalencia
--    +++ OK, passed 100 tests.

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

import Test.QuickCheck

import Data.List ((\\))

-- 1ª solución

-- ===========

minimaDiferencia :: Integer -> Integer

minimaDiferencia n =

minimum [abs (sum xs - sum ys) | (xs,ys) <- particiones n]

-- (particiones n) es la lista de las particiones de las n (donde n es

-- un número par) de las n primeras potencias de 2 en dos conjuntos de

-- igual tamaño. Por ejemplo,

-- λ> particiones 4

-- [([1,2],[4,8]),([1,4],[2,8]),([1,8],[2,4]),

-- ([2,4],[1,8]),([2,8],[1,4]),([4,8],[1,2])]

particiones :: Integer -> [([Integer],[Integer])]

particiones n =

[(as,xs \\ as) | as <- kSubconjuntos xs (n `div` 2)]

where xs = [2^k | k <- [0..n-1]]

-- (kSubconjuntos xs k) es la lista de los subconjuntos de xs con k

-- elementos. Por ejemplo,

-- λ> kSubconjuntos "bcde" 2

-- ["bc","bd","be","cd","ce","de"]

-- λ> kSubconjuntos "bcde" 3

-- ["bcd","bce","bde","cde"]

-- λ> kSubconjuntos "abcde" 3

-- ["abc","abd","abe","acd","ace","ade","bcd","bce","bde","cde"]

kSubconjuntos :: [a] -> Integer -> [[a]]

kSubconjuntos _ 0 = [[]]

kSubconjuntos [] _ = []

kSubconjuntos (x:xs) k =

[x:ys | ys <- kSubconjuntos xs (k-1)] ++ kSubconjuntos xs k

-- 2ª solución

-- ===========

-- Nota: La suma de las primeras (n-1) potencias de 2 es

-- sum [2^i | i <- [0..n-2]] = 2^(n-1) - 1

-- que es menor que la n-ésima potencia de 2 (es decir, 2^(n-1) porque

-- se empieza a contar en 0). Por tanto, para que la diferencia de las

-- suma sea mínima hay que agrupar la última (2^(n-1) con las menores

-- (es decir, desde 0 hasta n/2-2).

minimaDiferencia2 :: Integer -> Integer

minimaDiferencia2 n =

2^(n-1) + sum [2^i | i <- [0..n `div` 2 - 2]] -

sum [2^i | i <- [n `div` 2 - 1.. n-2]]

-- 3ª solución

-- ===========

-- Nota: Sea m = n/2 - 2. Entonces la suma de la mayor con las menores

-- es

-- s1 = 2^(n-1) + sum [2^i | i <- [0..m]]

-- = 2^(n-1) + (2^(m+1)-1)

-- y, puesto que la suma de las n primeras potencias es 2^n-1, la suma

-- de las restantes es

-- s2 = (2^n-1) - s1

minimaDiferencia3 :: Integer -> Integer

minimaDiferencia3 n = s1 - s2

where m = n `div` 2 - 2

s1 = 2^(n-1) + (2^(m+1)-1)

s2 = (2^n-1) - s1

-- 4ª solución

-- ===========

-- Nota: Con la notación de la solución anterior, la mínima diferencia es

-- s1 - s2

-- = s1 - ((2^n-1) - s1)

-- = 2*s1 - (2^n-1)

-- = 2*(2^(n-1) + (2^(m+1)-1)) - (2^n-1)

-- = 2^n + 2^(m+2) - 2 - 2^n + 1

-- = 2^(m+2) - 1

minimaDiferencia4 :: Integer -> Integer

minimaDiferencia4 n = 2^(m+2) - 1

where m = n `div` 2 - 2

-- Comparación de eficiencia

-- =========================

-- La comparación es

-- λ> minimaDiferencia 22

-- 2047

-- (7.75 secs, 6,597,330,816 bytes)

-- λ> minimaDiferencia2 22

-- 2047

-- (0.00 secs, 126,344 bytes)

-- λ> minimaDiferencia3 22

-- 2047

-- (0.01 secs, 107,192 bytes)

-- λ> minimaDiferencia4 22

-- 2047

-- (0.01 secs, 102,544 bytes)

-- λ> minimaDiferencia2 (10^5) `mod` (10^50)

-- 9602443968201967760613102289456131085235835109375

-- (8.18 secs, 2,915,200,064 bytes)

-- λ> minimaDiferencia3 (10^5) `mod` (10^50)

-- 9602443968201967760613102289456131085235835109375

-- (0.01 secs, 293,640 bytes)

-- λ> minimaDiferencia4 (10^5) `mod` (10^50)

-- 9602443968201967760613102289456131085235835109375

-- (0.03 secs, 167,176 bytes)

-- λ> minimaDiferencia3 (10^8) `mod` (10^50)

-- 30521751870548886367615394702753936894129787109375

-- (2.08 secs, 149,075,824 bytes)

-- λ> minimaDiferencia4 (10^8) `mod` (10^50)

-- 30521751870548886367615394702753936894129787109375

-- (0.41 secs, 24,929,696 bytes)

-- Comprobación de equivalencia

-- ============================

-- Como la primera sólo calcula hasta 22, se compara la primera con la

-- cuarta para dichos valores.

prop_equivalencia1 :: Bool

prop_equivalencia1 =

and [minimaDiferencia n == minimaDiferencia4 n | n <- [0,2..22]]

-- La comprobación es

-- λ> prop_equivalencia1

-- True

-- La propiedad de la equivalencia de las definiciones 2, 3 y 4 es

prop_equivalencia :: Integer -> Bool

prop_equivalencia n =

all (== (minimaDiferencia2 n'))

[minimaDiferencia3 n',

minimaDiferencia4 n']

where n' = 2 + abs n

-- La comprobación es

-- λ> quickCheck prop_equivalencia

-- +++ OK, passed 100 tests.

Nuevas soluciones

En los comentarios se pueden escribir nuevas soluciones.
El código se debe escribir entre una línea con <pre lang="haskell"> y otra con </pre>

Índice del menor elemento a eliminar para que la suma sea divisible por K

PorJosé A. Alonso 1-marzo-20218-marzo-2021

Definir la función

   indice :: [Int] -> Int -> Maybe Int

1	indice :: [Int] -> Int -> Maybe Int

tal que (indice xs k) es el índice del menor elemento a eliminar de la lista de enteros positivos xs para que la suma de los restantes sea divisible por k o Nothing, si no existe dicho elemento. Por ejemplo,

   indice [1,8,4,1] 2         ==  Just 2
   indice [4,6,7,5,7] 11      ==  Just 2
   indice [4,6,7,5,7] 12      ==  Just 3
   indice [4,6,7,5,7] 13      ==  Nothing
   indice [1..10^7] 7         ==  Just 5
   indice [10^7,10^7-1..1] 7  ==  Just 9999994

indice [1,8,4,1] 2 == Just 2

indice [4,6,7,5,7] 11 == Just 2

indice [4,6,7,5,7] 12 == Just 3

indice [4,6,7,5,7] 13 == Nothing

indice [1..10^7] 7 == Just 5

indice [10^7,10^7-1..1] 7 == Just 9999994

Soluciones

import Test.QuickCheck
import Data.List (sort)
import Data.Maybe (listToMaybe)

-- 1ª solución
-- ===========

indice :: [Int] -> Int -> Maybe Int
indice xs k
  | null ys   = Nothing
  | otherwise = Just (head ys)
  where ys = [i | (_,i,zs) <- sort (eliminaciones xs),
                  sum zs `mod` k == 0]

-- (eliminaciones xs) es la lista de ternas (x,i,zs) tales que x es un
-- elemento de xs, i es la posición de x en xs y zs es la lista de los
-- restantes elementos de xs. Por ejemplo,
--    λ> eliminaciones [5,7,6,5]
--    [(5,0,[7,6,5]),(7,1,[5,6,5]),(6,2,[5,7,5]),(5,3,[5,7,6])]
eliminaciones :: [a] -> [(a,Int,[a])]
eliminaciones xs = [(z,i,zs) | ((z,zs),i) <- zip (aux xs) [0..]]
  where aux []       = []
        aux [x]      = [(x,[])]
        aux (x:y:zs) = (x,y:zs) : [(v,x:vs) | (v,vs) <- aux (y:zs)]

-- 2ª solución
-- ===========

indice2 :: [Int] -> Int -> Maybe Int
indice2 xs k
  | null ys   = Nothing
  | otherwise = Just (head ys)
  where d = sum xs `mod` k
        ys = [i | (x,i) <- sort (zip xs [0..]),
                  x `mod` k == d]

-- 3ª solución
-- ===========

indice3 :: [Int] -> Int -> Maybe Int
indice3 xs k = listToMaybe ys
  where d = sum xs `mod` k
        ys = [i | (x,i) <- sort (zip xs [0..]),
                  x `mod` k == d]

-- Comprobación de la equivalencia
-- ===============================

-- La propiedad es
prop_equivalencia :: [Int] -> Int -> Bool
prop_equivalencia xs k =
  indice  xs' k' == indice2 xs' k' &&
  indice2 xs' k' == indice3 xs' k'
  where xs' = map ((+1) . abs) xs
        k'  = 1 + abs k

-- La comprobación es
--    λ> quickCheck prop_equivalencia
--    +++ OK, passed 100 tests.

-- Comparación de eficiencia
-- =========================

-- La comparación es
--    λ> indice [1..5000] 7
--    Just 2
--    (2.82 secs, 2,458,555,104 bytes)
--    λ> indice2 [1..5000] 7
--    Just 2
--    (0.01 secs, 1,991,232 bytes)
--    λ> indice3 [1..5000] 7
--    Just 2
--    (0.01 secs, 1,991,072 bytes)

import Test.QuickCheck

import Data.List (sort)

import Data.Maybe (listToMaybe)

-- 1ª solución

-- ===========

indice :: [Int] -> Int -> Maybe Int

indice xs k

| null ys = Nothing

| otherwise = Just (head ys)

where ys = [i | (_,i,zs) <- sort (eliminaciones xs),

sum zs `mod` k == 0]

-- (eliminaciones xs) es la lista de ternas (x,i,zs) tales que x es un

-- elemento de xs, i es la posición de x en xs y zs es la lista de los

-- restantes elementos de xs. Por ejemplo,

-- λ> eliminaciones [5,7,6,5]

-- [(5,0,[7,6,5]),(7,1,[5,6,5]),(6,2,[5,7,5]),(5,3,[5,7,6])]

eliminaciones :: [a] -> [(a,Int,[a])]

eliminaciones xs = [(z,i,zs) | ((z,zs),i) <- zip (aux xs) [0..]]

where aux [] = []

aux [x] = [(x,[])]

aux (x:y:zs) = (x,y:zs) : [(v,x:vs) | (v,vs) <- aux (y:zs)]

-- 2ª solución

-- ===========

indice2 :: [Int] -> Int -> Maybe Int

indice2 xs k

| null ys = Nothing

| otherwise = Just (head ys)

where d = sum xs `mod` k

ys = [i | (x,i) <- sort (zip xs [0..]),

x `mod` k == d]

-- 3ª solución

-- ===========

indice3 :: [Int] -> Int -> Maybe Int

indice3 xs k = listToMaybe ys

where d = sum xs `mod` k

ys = [i | (x,i) <- sort (zip xs [0..]),

x `mod` k == d]

-- Comprobación de la equivalencia

-- ===============================

-- La propiedad es

prop_equivalencia :: [Int] -> Int -> Bool

prop_equivalencia xs k =

indice xs' k' == indice2 xs' k' &&

indice2 xs' k' == indice3 xs' k'

where xs' = map ((+1) . abs) xs

k' = 1 + abs k

-- La comprobación es

-- λ> quickCheck prop_equivalencia

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

-- =========================

-- La comparación es

-- λ> indice [1..5000] 7

-- Just 2

-- (2.82 secs, 2,458,555,104 bytes)

-- λ> indice2 [1..5000] 7

-- Just 2

-- (0.01 secs, 1,991,232 bytes)

-- λ> indice3 [1..5000] 7

-- Just 2

-- (0.01 secs, 1,991,072 bytes)

Nuevas soluciones

En los comentarios se pueden escribir nuevas soluciones.
El código se debe escribir entre una línea con <pre lang="haskell"> y otra con </pre>

Máximo de las rotaciones

PorJosé A. Alonso 24-febrero-20213-marzo-2021

Las rotaciones del número 3252 son [3252, 2523, 5232, 2325] y el mayor de dichos números es 5232.

Definir la función

   maximoRotaciones :: Integer -> Integer

1	maximoRotaciones :: Integer -> Integer

tal que (maximoRotaciones n) es el mayor número obtenido rotando los dígitos de n. Por ejemplo,

   maximoRotaciones 3252    ==  5232
   maximoRotaciones 913942  ==  942913
   maximoRotaciones (234 + 10^(10^6)) `div` (10^(10^6))  ==  4

maximoRotaciones 3252 == 5232

maximoRotaciones 913942 == 942913

maximoRotaciones (234 + 10^(10^6)) `div` (10^(10^6)) == 4

Soluciones

import Data.List (inits, tails)

-- 1ª solución
-- ===========

maximoRotaciones :: Integer -> Integer
maximoRotaciones = maximum . rotacionesNumero

-- (rotacionesNumero n) es la lista de las rotaciones obtenidas desplazando
-- el primer dígito de n al final. Por ejemplo,
--    rotacionesNumero 325  ==  [325,253,532]
rotacionesNumero :: Integer -> [Integer]
rotacionesNumero = map read . rotaciones . show

-- (rotaciones xs) es la lista de las rotaciones obtenidas desplazando
-- el primer elemento xs al final. Por ejemplo,
--    rotaciones [2,3,5]  ==  [[2,3,5],[3,5,2],[5,2,3]]
rotaciones :: [a] -> [[a]]
rotaciones xs = take (length xs) (iterate rota xs)

-- (rota xs) es la lista añadiendo el primer elemento de xs al
-- final. Por ejemplo,
--    rota [3,2,5,7]  ==  [2,5,7,3]
rota :: [a] -> [a]
rota (x:xs) = xs ++ [x]

-- 2ª solución
-- ===========

maximoRotaciones2 :: Integer -> Integer
maximoRotaciones2 n =
  maximum (rotacionesDigito n (maximoDigito n))

-- (maximoDigito n) es el máximo de los dígitos de n. Por ejemplo,
--    maximoDigito 291394  ==  9
maximoDigito :: Integer -> Integer
maximoDigito n =
  read [maximum (show n)]

-- (rotacionesDigito n k) es la lista de las rotaciones de n cuyo primer
-- dígito es k. Por ejemplo,
--    rotacionesDigito 291394 9  ==  [913942,942913]
rotacionesDigito :: Integer -> Integer -> [Integer]
rotacionesDigito n k =
  [read (vs ++ us) | (us,vs) <- particiones (show n) (head (show k))]

-- (particiones xs y) es la lista de las particiones de xs en dos partes
-- tales que el primer elemento de la segunda parte es y. Por
-- ejemplo,
--    particiones [2,9,1,3,9,4] 9   == [([2],[9,1,3,9,4]),([2,9,1,3],[9,4])]
--    particiones [2,9,1,3,9,4] 3   == [([2,9,1],[3,9,4])]
--    particiones [2,9,1,3,9,4] 7   == []
--    particiones "Particiones" 'i' == [("Part","iciones"),("Partic","iones")]
particiones :: Eq a => [a] -> a -> [([a],[a])]
particiones xs y =
  [(prefijoSufijo xs zs,zs) | zs <- sufijos xs y]

-- (sufijos xs y) es la lista de los sufijos de xs que empiezan por
-- y. Por ejemplo,
--   λ> sufijos "particiones" 'i'
--   ["iciones","iones"]
sufijos :: Eq a => [a] -> a -> [[a]]
sufijos xs y = filter ((== y) . head) (init (tails xs))

-- (prefijoSufijo xs zs) es el prefijo de xs que junto con el sufijo zs
-- forma la lista xs. Por ejemplo,
--   λ> prefijoSufijo "particiones" "iciones"
--   "part"
prefijoSufijo :: [a] -> [a] -> [a]
prefijoSufijo xs zs = (inits xs) !! (length xs - length zs)

-- Comprobación de equivalencia
-- ============================

-- La propiedad es
prop_equivalencia :: Integer -> Property
prop_equivalencia n =
  n > 0 ==>
  maximoRotaciones n == maximoRotaciones2 n

-- La comprobación es
--    λ> quickCheck prop_equivalencia
--    +++ OK, passed 100 tests.

-- Comparación de eficiencia
-- =========================

-- La comparación es
--    λ> maximoRotaciones (product [1..2000]) `mod` (10^20)
--    64970515522882052348
--    (4.59 secs, 13,275,801,696 bytes)
--    λ> maximoRotaciones2 (product [1..2000]) `mod` (10^20)
--    64970515522882052348
--    (0.41 secs, 1,132,544,240 bytes)
--
--    λ> read (take 9 (show (maximoRotaciones (234 + 10^(10^4))))) :: Integer
--    410000000
--    (12.53 secs, 36,326,102,416 bytes)
--    λ> read (take 9 (show (maximoRotaciones2 (234 + 10^(10^4))))) :: Integer
--    410000000
--    (0.03 secs, 6,227,024 bytes)

100

101

import Data.List (inits, tails)

-- 1ª solución

-- ===========

maximoRotaciones :: Integer -> Integer

maximoRotaciones = maximum . rotacionesNumero

-- (rotacionesNumero n) es la lista de las rotaciones obtenidas desplazando

-- el primer dígito de n al final. Por ejemplo,

-- rotacionesNumero 325 == [325,253,532]

rotacionesNumero :: Integer -> [Integer]

rotacionesNumero = map read . rotaciones . show

-- (rotaciones xs) es la lista de las rotaciones obtenidas desplazando

-- el primer elemento xs al final. Por ejemplo,

-- rotaciones [2,3,5] == [[2,3,5],[3,5,2],[5,2,3]]

rotaciones :: [a] -> [[a]]

rotaciones xs = take (length xs) (iterate rota xs)

-- (rota xs) es la lista añadiendo el primer elemento de xs al

-- final. Por ejemplo,

-- rota [3,2,5,7] == [2,5,7,3]

rota :: [a] -> [a]

rota (x:xs) = xs ++ [x]

-- 2ª solución

-- ===========

maximoRotaciones2 :: Integer -> Integer

maximoRotaciones2 n =

maximum (rotacionesDigito n (maximoDigito n))

-- (maximoDigito n) es el máximo de los dígitos de n. Por ejemplo,

-- maximoDigito 291394 == 9

maximoDigito :: Integer -> Integer

maximoDigito n =

read [maximum (show n)]

-- (rotacionesDigito n k) es la lista de las rotaciones de n cuyo primer

-- dígito es k. Por ejemplo,

-- rotacionesDigito 291394 9 == [913942,942913]

rotacionesDigito :: Integer -> Integer -> [Integer]

rotacionesDigito n k =

[read (vs ++ us) | (us,vs) <- particiones (show n) (head (show k))]

-- (particiones xs y) es la lista de las particiones de xs en dos partes

-- tales que el primer elemento de la segunda parte es y. Por

-- ejemplo,

-- particiones [2,9,1,3,9,4] 9 == [([2],[9,1,3,9,4]),([2,9,1,3],[9,4])]

-- particiones [2,9,1,3,9,4] 3 == [([2,9,1],[3,9,4])]

-- particiones [2,9,1,3,9,4] 7 == []

-- particiones "Particiones" 'i' == [("Part","iciones"),("Partic","iones")]

particiones :: Eq a => [a] -> a -> [([a],[a])]

particiones xs y =

[(prefijoSufijo xs zs,zs) | zs <- sufijos xs y]

-- (sufijos xs y) es la lista de los sufijos de xs que empiezan por

-- y. Por ejemplo,

-- λ> sufijos "particiones" 'i'

-- ["iciones","iones"]

sufijos :: Eq a => [a] -> a -> [[a]]

sufijos xs y = filter ((== y) . head) (init (tails xs))

-- (prefijoSufijo xs zs) es el prefijo de xs que junto con el sufijo zs

-- forma la lista xs. Por ejemplo,

-- λ> prefijoSufijo "particiones" "iciones"

-- "part"

prefijoSufijo :: [a] -> [a] -> [a]

prefijoSufijo xs zs = (inits xs) !! (length xs - length zs)

-- Comprobación de equivalencia

-- ============================

-- La propiedad es

prop_equivalencia :: Integer -> Property

prop_equivalencia n =

n > 0 ==>

maximoRotaciones n == maximoRotaciones2 n

-- La comprobación es

-- λ> quickCheck prop_equivalencia

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

-- =========================

-- La comparación es

-- λ> maximoRotaciones (product [1..2000]) `mod` (10^20)

-- 64970515522882052348

-- (4.59 secs, 13,275,801,696 bytes)

-- λ> maximoRotaciones2 (product [1..2000]) `mod` (10^20)

-- 64970515522882052348

-- (0.41 secs, 1,132,544,240 bytes)

-- λ> read (take 9 (show (maximoRotaciones (234 + 10^(10^4))))) :: Integer

-- 410000000

-- (12.53 secs, 36,326,102,416 bytes)

-- λ> read (take 9 (show (maximoRotaciones2 (234 + 10^(10^4))))) :: Integer

-- 410000000

-- (0.03 secs, 6,227,024 bytes)

Nuevas soluciones

En los comentarios se pueden escribir nuevas soluciones.
El código se debe escribir entre una línea con <pre lang="haskell"> y otra con </pre>

Particiones por un elemento

PorJosé A. Alonso 23-febrero-20212-marzo-2021

Definir la función

   particiones :: Eq a => [a] -> a -> [([a],[a])]

1	particiones :: Eq a => [a] -> a -> [([a],[a])]

tal que (particiones xs y) es la lista de las particiones de xs en dos partes tales que el primer elemento de la segunda parte es y. Por ejemplo,

   particiones [2,9,1,3,9,4] 9   == [([2],[9,1,3,9,4]),([2,9,1,3],[9,4])]
   particiones [2,9,1,3,9,4] 3   == [([2,9,1],[3,9,4])]
   particiones [2,9,1,3,9,4] 7   == []
   particiones "Particiones" 'i' == [("Part","iciones"),("Partic","iones")]

particiones [2,9,1,3,9,4] 9 == [([2],[9,1,3,9,4]),([2,9,1,3],[9,4])]

particiones [2,9,1,3,9,4] 3 == [([2,9,1],[3,9,4])]

particiones [2,9,1,3,9,4] 7 == []

particiones "Particiones" 'i' == [("Part","iciones"),("Partic","iones")]

Soluciones

import Data.List (tails, inits)

-- 1ª solución
-- ===========

particiones :: Eq a => [a] -> a -> [([a],[a])]
particiones [] _ = []
particiones xs y
  | null vs = []
  | otherwise = (us,vs) : [(us ++ y:us', vs')
                          | (us',vs') <- particiones (tail vs) y ]
  where (us,vs) = span (/=y) xs

-- 2ª solución
-- ===========

particiones2 :: Eq a => [a] -> a -> [([a],[a])]
particiones2 xs y =
  [(ys,z:zs) | (ys,z:zs) <- listaPares xs, z == y]

-- (listaPares xs) es la lista de los pares que resultan al dividir la
-- lista xs en dos partes. Por ejemplo,
--    λ> listaPares [2,9,1,3,9,4]
--    [([],[2,9,1,3,9,4]),([2],[9,1,3,9,4]),([2,9],[1,3,9,4]),([2,9,1],[3,9,4]),
--    ([2,9,1,3],[9,4]),([2,9,1,3,9],[4])]
listaPares :: [a] -> [([a],[a])]
listaPares xs = init (zip (inits xs) (tails xs))

-- 3ª solución
-- ===========

particiones3 :: Eq a => [a] -> a -> [([a],[a])]
particiones3 xs y =
  [(prefijoSufijo xs zs,zs) | zs <- sufijos xs y]

-- (sufijos xs y) es la lista de los sufijos de xs que empiezan por
-- y. Por ejemplo,
--   λ> sufijos "particiones" 'i'
--   ["iciones","iones"]
sufijos :: Eq a => [a] -> a -> [[a]]
sufijos xs y = filter ((== y) . head) (init (tails xs))

-- (prefijoSufijo xs zs) es el prefijo de xs que junto con el sufijo zs
-- forma la lista xs. Por ejemplo,
--   λ> prefijoSufijo "particiones" "iciones"
--   "part"
prefijoSufijo :: [a] -> [a] -> [a]
prefijoSufijo xs zs = (inits xs) !! (length xs - length zs)

-- Comprobación de la equivalencia
-- ===============================

-- La propiedad es
prop_equivalencia :: [Int] -> Int -> Bool
prop_equivalencia xs y =
  particiones xs y'  == particiones2 xs y' &&
  particiones2 xs y' == particiones3 xs y'
  where y' = y `mod` length xs

-- La comprobación es
--    λ> quickCheck prop_equivalencia
--    +++ OK, passed 100 tests.

-- Comparación de eficiencia
-- =========================

-- La comparación es
--    λ> length (particiones (take (10^5) (cycle [1..9])) 5)
--    11111
--    (9.10 secs, 13,375,324,416 bytes)
--    λ> length (particiones2 (take (10^5) (cycle [1..9])) 5)
--    11111
--    (0.08 secs, 44,107,672 bytes)
--    λ> length (particiones3 (take (10^5) (cycle [1..9])) 5)
--    11111
--    (0.07 secs, 21,524,936 bytes)
--
--    λ> length (particiones2 (take (10^7) (cycle [1..9])) 5)
--    1111111
--    (3.93 secs, 4,400,105,800 bytes)
--    λ> length (particiones3 (take (10^7) (cycle [1..9])) 5)
--    1111111
--    (1.88 secs, 2,142,328,800 bytes)

import Data.List (tails, inits)

-- 1ª solución

-- ===========

particiones :: Eq a => [a] -> a -> [([a],[a])]

particiones [] _ = []

particiones xs y

| null vs = []

| otherwise = (us,vs) : [(us ++ y:us', vs')

| (us',vs') <- particiones (tail vs) y ]

where (us,vs) = span (/=y) xs

-- 2ª solución

-- ===========

particiones2 :: Eq a => [a] -> a -> [([a],[a])]

particiones2 xs y =

[(ys,z:zs) | (ys,z:zs) <- listaPares xs, z == y]

-- (listaPares xs) es la lista de los pares que resultan al dividir la

-- lista xs en dos partes. Por ejemplo,

-- λ> listaPares [2,9,1,3,9,4]

-- [([],[2,9,1,3,9,4]),([2],[9,1,3,9,4]),([2,9],[1,3,9,4]),([2,9,1],[3,9,4]),

-- ([2,9,1,3],[9,4]),([2,9,1,3,9],[4])]

listaPares :: [a] -> [([a],[a])]

listaPares xs = init (zip (inits xs) (tails xs))

-- 3ª solución

-- ===========

particiones3 :: Eq a => [a] -> a -> [([a],[a])]

particiones3 xs y =

[(prefijoSufijo xs zs,zs) | zs <- sufijos xs y]

-- (sufijos xs y) es la lista de los sufijos de xs que empiezan por

-- y. Por ejemplo,

-- λ> sufijos "particiones" 'i'

-- ["iciones","iones"]

sufijos :: Eq a => [a] -> a -> [[a]]

sufijos xs y = filter ((== y) . head) (init (tails xs))

-- (prefijoSufijo xs zs) es el prefijo de xs que junto con el sufijo zs

-- forma la lista xs. Por ejemplo,

-- λ> prefijoSufijo "particiones" "iciones"

-- "part"

prefijoSufijo :: [a] -> [a] -> [a]

prefijoSufijo xs zs = (inits xs) !! (length xs - length zs)

-- Comprobación de la equivalencia

-- ===============================

-- La propiedad es

prop_equivalencia :: [Int] -> Int -> Bool

prop_equivalencia xs y =

particiones xs y' == particiones2 xs y' &&

particiones2 xs y' == particiones3 xs y'

where y' = y `mod` length xs

-- La comprobación es

-- λ> quickCheck prop_equivalencia

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

-- =========================

-- La comparación es

-- λ> length (particiones (take (10^5) (cycle [1..9])) 5)

-- 11111

-- (9.10 secs, 13,375,324,416 bytes)

-- λ> length (particiones2 (take (10^5) (cycle [1..9])) 5)

-- 11111

-- (0.08 secs, 44,107,672 bytes)

-- λ> length (particiones3 (take (10^5) (cycle [1..9])) 5)

-- 11111

-- (0.07 secs, 21,524,936 bytes)

-- λ> length (particiones2 (take (10^7) (cycle [1..9])) 5)

-- 1111111

-- (3.93 secs, 4,400,105,800 bytes)

-- λ> length (particiones3 (take (10^7) (cycle [1..9])) 5)

-- 1111111

-- (1.88 secs, 2,142,328,800 bytes)

Nuevas soluciones

En los comentarios se pueden escribir nuevas soluciones.
El código se debe escribir entre una línea con <pre lang="haskell"> y otra con </pre>

Sumas de potencias que son cuadrados perfectos

PorJosé A. Alonso 22-febrero-20211-marzo-2021

El 2º problema de la ONEM (Olimpíada Nacional Escolar de Matemática) de Mayo del 2020 dice

Determinar si existen enteros positivos a, b y c, no necesariamente distintos, tales que $a+b+c=2020$ y $2^a + 2^b + 2^c$ es un cuadrado perfecto.

Definir la función

   soluciones :: Integer -> Integer -> [(Integer,Integer,Integer)]

1	soluciones :: Integer -> Integer -> [(Integer,Integer,Integer)]

tales que (soluciones k n) es la lista de las ternas no decrecientes (a,b,c) tales que que a+b+c=n y k^a + k^b + k^c es un cuadrado perfecto. Por ejemplo,

   soluciones 2 19  ==  [(2,6,11),(2,7,10),(4,7,8),(5,5,9),(6,6,7)]
   soluciones 3 19  ==  []
   take 2 (soluciones 2 2020)  ==  [(2,674,1344),(4,674,1342)]

soluciones 2 19 == [(2,6,11),(2,7,10),(4,7,8),(5,5,9),(6,6,7)]

soluciones 3 19 == []

take 2 (soluciones 2 2020) == [(2,674,1344),(4,674,1342)]

Soluciones

soluciones :: Integer -> Integer -> [(Integer,Integer,Integer)]
soluciones k n =
  [(a,b,c) | a <- [1..n `div` 3],
             b <- [a..n-a],
             let c = n-a-b,
             c >= b,
             esCuadradoPerfecto (k^a + k^b + k^c)]

-- (esCuadradoPerfecto x) se verifica si x es un cuadrado perfecto. Por
-- ejemplo,
--    esCuadradoPerfecto 16  ==  True
--    esCuadradoPerfecto 27  ==  False
esCuadradoPerfecto :: Integer -> Bool
esCuadradoPerfecto x =
  (raizEntera x)^2 == x

-- (raizEntera x) es el mayor entero cuyo cuadrado es menor o igual que
-- x. Por ejemplo,
--    raizEntera 16  ==  4
--    raizEntera 27  ==  5
raizEntera :: Integer -> Integer
raizEntera x = aux (1,x)
    where aux (a,b) | d == x    = c
                    | c == a    = c
                    | d < x     = aux (c,b)
                    | otherwise = aux (a,c)
              where c = (a+b) `div` 2
                    d = c^2

soluciones :: Integer -> Integer -> [(Integer,Integer,Integer)]

soluciones k n =

[(a,b,c) | a <- [1..n `div` 3],

b <- [a..n-a],

let c = n-a-b,

c >= b,

esCuadradoPerfecto (k^a + k^b + k^c)]

-- (esCuadradoPerfecto x) se verifica si x es un cuadrado perfecto. Por

-- ejemplo,

-- esCuadradoPerfecto 16 == True

-- esCuadradoPerfecto 27 == False

esCuadradoPerfecto :: Integer -> Bool

esCuadradoPerfecto x =

(raizEntera x)^2 == x

-- (raizEntera x) es el mayor entero cuyo cuadrado es menor o igual que

-- x. Por ejemplo,

-- raizEntera 16 == 4

-- raizEntera 27 == 5

raizEntera :: Integer -> Integer

raizEntera x = aux (1,x)

where aux (a,b) | d == x = c

| c == a = c

| d < x = aux (c,b)

| otherwise = aux (a,c)

where c = (a+b) `div` 2

d = c^2

Nuevas soluciones

En los comentarios se pueden escribir nuevas soluciones.
El código se debe escribir entre una línea con <pre lang="haskell"> y otra con </pre>

Mínimo número de saltos para alcanzar el final

PorJosé A. Alonso 17-febrero-202124-febrero-2021

Dada una lista de enteros positivos, se interpreta cada elemento el máximo número de pasos que se puede avanzar desde dicho elemento. Por ejemplo, para la lista [1,3,5,8,9,2,6,7,6,8,9], desde sólo se puede avanzar un paso (hasta el 3), desde el 3 se puede avanzar 3 pasos (hasta el 5, 8 ó 9), y así sucesivamente. En dicha lista, el mínimo número de saltos que hay que dar para alcanzar el final es 3 (el recorrido es 1, 3, 8, 9).

Definir la función

   minimoSaltos :: [Int] -> Int

1	minimoSaltos :: [Int] -> Int

tal que (minimoSaltosxs) es el mínimo número de saltos que hay que dar en la lista xs para alcanzar el final. Por ejemplo,

   minimoSaltos [1,3,5,8,9,2,6,7,6,8,9]  ==  3
   minimoSaltos (replicate 10 1)         ==  9
   minimoSaltos [1..25]                  ==  5

minimoSaltos [1,3,5,8,9,2,6,7,6,8,9] == 3

minimoSaltos (replicate 10 1) == 9

minimoSaltos [1..25] == 5

Soluciones

import Data.List (tails)

minimoSaltos :: [Int] -> Int
minimoSaltos (x:y:xs) =
  1 + minimum [minimoSaltos ys | ys <- take x (tails (y:xs))]
minimoSaltos _ = 0

import Data.List (tails)

minimoSaltos :: [Int] -> Int

minimoSaltos (x:y:xs) =

1 + minimum [minimoSaltos ys | ys <- take x (tails (y:xs))]

minimoSaltos _ = 0

Nuevas soluciones

En los comentarios se pueden escribir nuevas soluciones.
El código se debe escribir entre una línea con <pre lang="haskell"> y otra con </pre>

Mínima suma borrando todas las ocurrencias de un dígito

PorJosé A. Alonso 15-febrero-202122-febrero-2021

Para la lista [23,12,77,82], las sumas obtenidas eliminando todas las ocurrencias de uno de sus dígitos son

+ Eliminando el 1: 23 +  2 + 77 + 82 = 184
+ Eliminando el 2:  3 + 1  + 77 + 8  =  89
+ Eliminando el 3: 2  + 12 + 77 + 82 = 173
+ Eliminando el 7: 23 + 12      + 82 = 117
+ Eliminando el 8: 23 + 12 + 77 +  2 = 114

+ Eliminando el 1: 23 + 2 + 77 + 82 = 184

+ Eliminando el 2: 3 + 1 + 77 + 8 = 89

+ Eliminando el 3: 2 + 12 + 77 + 82 = 173

+ Eliminando el 7: 23 + 12 + 82 = 117

+ Eliminando el 8: 23 + 12 + 77 + 2 = 114

El mínimo de las sumas es 89 (que se obtiene eliminando todas las ocurrencias del dígito 2).

Definir la función

   minimaSumaEliminandoDigito :: [Integer] -> Integer

1	minimaSumaEliminandoDigito :: [Integer] -> Integer

tal que (minimaSumaEliminandoDigito xs) es el mínimo de las sumas obtenidas eliminando todas las ocurrencias de uno de los dígitos de xs. Por ejemplo,

   minimaSumaEliminandoDigito [23,12,77,82]  ==  89
   minimaSumaEliminandoDigito [2312,7,4,82]  ==  50

1 2	minimaSumaEliminandoDigito [23,12,77,82] == 89 minimaSumaEliminandoDigito [2312,7,4,82] == 50

Soluciones

import Data.List ((\\), nub)

minimaSumaEliminandoDigito :: [Int] -> Int
minimaSumaEliminandoDigito xs =
  minimum [sumaSinDigito k xs | k <- digitosLista xs]

-- (digitosLista xs) es una lista, sin repeticiones, de los dígitos de
-- xs. Por ejemplo,
--    digitosLista [23,12,74,82]  ==  [2,3,1,7,4,8]
digitosLista :: [Int] -> [Int]
digitosLista = nub . concatMap digitos

-- (digitos x) es la lista de los dígitos de x. Por ejemplo,
--    digitos 3252  ==  [3,2,5,2]
digitos :: Int -> [Int]
digitos x = [read [c] | c <- show x]

-- (sumaSinDigito k xs) es la suma de los números de xs en los que se han
-- borrado todas las ocurrencias del dígito k. Por ejemplo,
--    sumaSinDigito 2 [23,12,22,82]  ==  12
sumaSinDigito :: Int -> [Int] -> Int
sumaSinDigito k xs = sum (listaSinDigito k xs)

-- (listaSinDigito k xs) es la lista de los números de xs en los que se han
-- borrado todas las ocurrencias del dígito k. Por ejemplo,
--    listaSinDigito 2 [23,12,22,82]  ==  [3,1,8]
listaSinDigito :: Int -> [Int] -> [Int]
listaSinDigito k xs =
  [read cs | x <- xs
           , let cs = filter (/=c) (show x)
           , not (null cs)]
  where [c] = show k

import Data.List ((\\), nub)

minimaSumaEliminandoDigito :: [Int] -> Int

minimaSumaEliminandoDigito xs =

minimum [sumaSinDigito k xs | k <- digitosLista xs]

-- (digitosLista xs) es una lista, sin repeticiones, de los dígitos de

-- xs. Por ejemplo,

-- digitosLista [23,12,74,82] == [2,3,1,7,4,8]

digitosLista :: [Int] -> [Int]

digitosLista = nub . concatMap digitos

-- (digitos x) es la lista de los dígitos de x. Por ejemplo,

-- digitos 3252 == [3,2,5,2]

digitos :: Int -> [Int]

digitos x = [read [c] | c <- show x]

-- (sumaSinDigito k xs) es la suma de los números de xs en los que se han

-- borrado todas las ocurrencias del dígito k. Por ejemplo,

-- sumaSinDigito 2 [23,12,22,82] == 12

sumaSinDigito :: Int -> [Int] -> Int

sumaSinDigito k xs = sum (listaSinDigito k xs)

-- (listaSinDigito k xs) es la lista de los números de xs en los que se han

-- borrado todas las ocurrencias del dígito k. Por ejemplo,

-- listaSinDigito 2 [23,12,22,82] == [3,1,8]

listaSinDigito :: Int -> [Int] -> [Int]

listaSinDigito k xs =

[read cs | x <- xs

, let cs = filter (/=c) (show x)

, not (null cs)]

where [c] = show k

Nuevas soluciones

En los comentarios se pueden escribir nuevas soluciones.
El código se debe escribir entre una línea con <pre lang="haskell"> y otra con </pre>

Descomposición de N en K sumandos pares distintos

PorJosé A. Alonso 12-febrero-202119-febrero-2021

Definir las funciones

   sumas  :: Integer -> Integer -> [[Integer]]
   esSuma :: Integer -> Integer -> Bool

1 2	sumas :: Integer -> Integer -> [[Integer]] esSuma :: Integer -> Integer -> Bool

tales que

(sumas n k) es la lista de las descomposiones de n en k sumandos pares y distintos. Por ejemplo,

     sumas 16 3  ==  [[2,4,10],[2,6,8]]
     sumas 18 4  ==  []

1 2	sumas 16 3 == [[2,4,10],[2,6,8]] sumas 18 4 == []

(esSuma n k) se verifica si n se puede escribir como suma de k sumandos pares y distintos. Por ejemplo,

     esSuma 16 3  ==  True
     esSuma 18 4  ==  False
     esSuma (10^5000) (10^7)  ==  True
     esSuma (11^5000) (10^7)  ==  False

esSuma 16 3 == True

esSuma 18 4 == False

esSuma (10^5000) (10^7) == True

esSuma (11^5000) (10^7) == False

Soluciones

import Test.QuickCheck

sumas :: Integer -> Integer -> [[Integer]]
sumas n k = sumasLista n k [2,4..n]

-- (sumasLista n k xs) es la lista de las descomposiciones de n como k
-- elementos de xs (cada uno una vez como máximo). Por ejemplo,
--    sumasLista 16 3 [2,4..15]  ==  [[2,4,10],[2,6,8]]
--    sumasLista 18 4 [2,4..15]  ==  []
sumasLista :: Integer -> Integer -> [Integer] -> [[Integer]]
sumasLista _ _ [] = []
sumasLista n 1 xs
  | n `elem` xs = [[n]]
  | otherwise   = []
sumasLista n k (x:xs)
  | x > n     = []
  | otherwise = [x:ys | ys <- sumasLista (n-x) (k-1) xs] ++
                sumasLista n k xs

-- 1ª definición de esSuma
-- =======================

esSuma :: Integer -> Integer -> Bool
esSuma n k = not (null (sumas n k))

-- 2ª definición de esSuma
-- =======================

-- Se observan las siguientes propiedades:
-- 1. Si n es impar, no se puede escribir como suma de pares.
-- 2. El menor número que se puede escribir como suma de k sumandos
--    impares distintos es 2 * sum [1..k] y su descomposición es
--    [2,4..2*k] (es decir, map (*2) [1..k]).
-- 3. Si n es un número par mayor o igual que (2 * sum [1..k])
--    entonces se puede escribir como suma de k sumandos pares distintos;
--    en efecto,
--       x = 2 + 4 + ··· + 2*(k-1) + (x - (2 + 4 + ··· + 2*(k-1))

esSuma2 :: Integer -> Integer -> Bool
esSuma2 n k
  | odd n               = False
  | 2 * sum [1..k] <= n = True
  | otherwise           = False

-- 3ª definición de esSuma
-- =======================

esSuma3 :: Integer -> Integer -> Bool
esSuma3 n k
  | odd n            = False
  | k * (k + 1) <= n = True
  | otherwise        = False

-- Comprobación de equivalencia
-- ============================

-- La propiedad es
prop_equiv_esSuma :: Integer -> Integer -> Property
prop_equiv_esSuma n k =
  n > 0 && k > 0 ==>
  all (== (esSuma3 n k)) [esSuma n k, esSuma2 n k]

-- La comprobación es
--    λ> quickCheck prop_equiv_esSuma
--    +++ OK, passed 100 tests.

-- Comparación de eficiencia
-- =========================

-- La comparación es
--    λ> esSuma 200 20
--    False
--    (6.12 secs, 3,079,059,560 bytes)
--    λ> esSuma2 200 20
--    False
--    (0.00 secs, 102,800 bytes)
--    λ> esSuma3 200 20
--    False
--    (0.01 secs, 102,760 bytes)
--
--    λ> esSuma2 (10^5000) (10^7)
--    True
--    (2.55 secs, 1,612,412,664 bytes)
--    λ> esSuma3 (10^5000) (10^7)
--    True
--    (0.03 secs, 109,200 bytes)

import Test.QuickCheck

sumas :: Integer -> Integer -> [[Integer]]

sumas n k = sumasLista n k [2,4..n]

-- (sumasLista n k xs) es la lista de las descomposiciones de n como k

-- elementos de xs (cada uno una vez como máximo). Por ejemplo,

-- sumasLista 16 3 [2,4..15] == [[2,4,10],[2,6,8]]

-- sumasLista 18 4 [2,4..15] == []

sumasLista :: Integer -> Integer -> [Integer] -> [[Integer]]

sumasLista _ _ [] = []

sumasLista n 1 xs

| n `elem` xs = [[n]]

| otherwise = []

sumasLista n k (x:xs)

| x > n = []

| otherwise = [x:ys | ys <- sumasLista (n-x) (k-1) xs] ++

sumasLista n k xs

-- 1ª definición de esSuma

-- =======================

esSuma :: Integer -> Integer -> Bool

esSuma n k = not (null (sumas n k))

-- 2ª definición de esSuma

-- =======================

-- Se observan las siguientes propiedades:

-- 1. Si n es impar, no se puede escribir como suma de pares.

-- 2. El menor número que se puede escribir como suma de k sumandos

-- impares distintos es 2 * sum [1..k] y su descomposición es

-- [2,4..2*k] (es decir, map (*2) [1..k]).

-- 3. Si n es un número par mayor o igual que (2 * sum [1..k])

-- entonces se puede escribir como suma de k sumandos pares distintos;

-- en efecto,

-- x = 2 + 4 + ··· + 2*(k-1) + (x - (2 + 4 + ··· + 2*(k-1))

esSuma2 :: Integer -> Integer -> Bool

esSuma2 n k

| odd n = False

| 2 * sum [1..k] <= n = True

| otherwise = False

-- 3ª definición de esSuma

-- =======================

esSuma3 :: Integer -> Integer -> Bool

esSuma3 n k

| odd n = False

| k * (k + 1) <= n = True

| otherwise = False

-- Comprobación de equivalencia

-- ============================

-- La propiedad es

prop_equiv_esSuma :: Integer -> Integer -> Property

prop_equiv_esSuma n k =

n > 0 && k > 0 ==>

all (== (esSuma3 n k)) [esSuma n k, esSuma2 n k]

-- La comprobación es

-- λ> quickCheck prop_equiv_esSuma

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

-- =========================

-- La comparación es

-- λ> esSuma 200 20

-- False

-- (6.12 secs, 3,079,059,560 bytes)

-- λ> esSuma2 200 20

-- False

-- (0.00 secs, 102,800 bytes)

-- λ> esSuma3 200 20

-- False

-- (0.01 secs, 102,760 bytes)

-- λ> esSuma2 (10^5000) (10^7)

-- True

-- (2.55 secs, 1,612,412,664 bytes)

-- λ> esSuma3 (10^5000) (10^7)

-- True

-- (0.03 secs, 109,200 bytes)

Nuevas soluciones

En los comentarios se pueden escribir nuevas soluciones.
El código se debe escribir entre una línea con <pre lang="haskell"> y otra con </pre>

Los números armónicos no son enteros

PorJosé A. Alonso 3-febrero-202110-febrero-2021

Los números armónicos son las sumas de los inversos de de los primeros números enteros positivos; es decir, el n-ésimo número armónico es

   H(n) = 1 + 1/2 + 1/3 + ··· + 1/n

1	H(n) = 1 + 1/2 + 1/3 + ··· + 1/n

Los primeros números armónicos son

   1, 3/2, 11/6, 25/12, 137/60, ..

1	1, 3/2, 11/6, 25/12, 137/60, ..

Definir, usando la librería de los números racionales (Data.Ratio), las funciones

   armonico  :: Integer -> Rational
   armonicos :: [Rational]
   esEntero  :: Rational -> Bool

armonico :: Integer -> Rational

armonicos :: [Rational]

esEntero :: Rational -> Bool

tales que

(armonico n) es el n-ésimo número armónico. Por ejemplo,

     armonico 2  ==    3 % 2
     armonico 3  ==   11 % 6
     armonico 4  ==   25 % 12
     armonico 5  ==  137 % 60

armonico 2 == 3 % 2

armonico 3 == 11 % 6

armonico 4 == 25 % 12

armonico 5 == 137 % 60

armonicos es la lista de los números armónicos. Por ejemplo,

     take 5 armonicos  ==  [1 % 1,3 % 2,11 % 6,25 % 12,137 % 60]

1	take 5 armonicos == [1 % 1,3 % 2,11 % 6,25 % 12,137 % 60]

(esEntero x) se verifica si x es un número entero. Por ejemplo,

     esEntero (1 % 7)           ==  False
     esEntero (1 % 7 + 20 % 7)  ==  True

1 2	esEntero (1 % 7) == False esEntero (1 % 7 + 20 % 7) == True

Comprobar con QuickCheck que

nigún número armónico, excepto el primero, es un número entero y
la diferencia de dos números armónicos distintos nunca es un número entero.

Nota: Este ejercicio está basado en el artículo Sums of consecutive reciprocals publicado por John D. Cook en su blog el 23 de enero de 2021.

Soluciones

import Data.List (genericIndex)
import Data.Ratio ((%), denominator)
import Test.QuickCheck (Property, (==>), quickCheck)

-- 1ª solución
-- ===========

armonico  :: Integer -> Rational
armonico 1 = 1
armonico n = 1 % n + armonico (n-1)

armonicos :: [Rational]
armonicos = map armonico [1..]

esEntero  :: Rational -> Bool
esEntero x = denominator x == 1

-- 2ª solución
-- ===========

armonicos2 :: [Rational]
armonicos2 = scanl1 (\ x y -> x + y) [1 % n | n <- [1..]]

armonico2  :: Integer -> Rational
armonico2 n = armonicos `genericIndex` n

-- Comparación de eficiencia
-- =========================

-- La comparación es
--    λ> fromRational (armonicos !! (10^4))
--    9.787706026045383
--    (9.17 secs, 29,293,137,856 bytes)
--    λ> fromRational (armonicos2 !! (10^4))
--    9.787706026045383
--    (9.42 secs, 29,292,225,904 bytes)

-- Propiedades
-- ===========

-- La 1ª propiedad es
prop_armonicos :: Integer -> Property
prop_armonicos n =
  n > 1 ==>
  not (esEntero (armonico n))

-- La comprobación de la 1ª propiedad es
--    λ> quickCheck prop_armonicos
--    +++ OK, passed 100 tests.

-- La 2ª propiedad es
prop_armonicos2 :: Integer -> Integer -> Property
prop_armonicos2 n m =
  n > 0 && m > 0 && n /= m ==>
  not (esEntero (armonico n - armonico m))

-- La comprobación de la segunda propiedad es
--   λ> quickCheck prop_armonicos2
--   +++ OK, passed 100 tests.

import Data.List (genericIndex)

import Data.Ratio ((%), denominator)

import Test.QuickCheck (Property, (==>), quickCheck)

-- 1ª solución

-- ===========

armonico :: Integer -> Rational

armonico 1 = 1

armonico n = 1 % n + armonico (n-1)

armonicos :: [Rational]

armonicos = map armonico [1..]

esEntero :: Rational -> Bool

esEntero x = denominator x == 1

-- 2ª solución

-- ===========

armonicos2 :: [Rational]

armonicos2 = scanl1 (\ x y -> x + y) [1 % n | n <- [1..]]

armonico2 :: Integer -> Rational

armonico2 n = armonicos `genericIndex` n

-- Comparación de eficiencia

-- =========================

-- La comparación es

-- λ> fromRational (armonicos !! (10^4))

-- 9.787706026045383

-- (9.17 secs, 29,293,137,856 bytes)

-- λ> fromRational (armonicos2 !! (10^4))

-- 9.787706026045383

-- (9.42 secs, 29,292,225,904 bytes)

-- Propiedades

-- ===========

-- La 1ª propiedad es

prop_armonicos :: Integer -> Property

prop_armonicos n =

n > 1 ==>

not (esEntero (armonico n))

-- La comprobación de la 1ª propiedad es

-- λ> quickCheck prop_armonicos

-- +++ OK, passed 100 tests.

-- La 2ª propiedad es

prop_armonicos2 :: Integer -> Integer -> Property

prop_armonicos2 n m =

n > 0 && m > 0 && n /= m ==>

not (esEntero (armonico n - armonico m))

-- La comprobación de la segunda propiedad es

-- λ> quickCheck prop_armonicos2

-- +++ OK, passed 100 tests.

Nuevas soluciones

En los comentarios se pueden escribir nuevas soluciones.
El código se debe escribir entre una línea con <pre lang="haskell"> y otra con </pre>

Partición por suma

PorJosé A. Alonso 2-febrero-20219-febrero-2021

Definir la función

   particion :: Int -> [Int] -> [[Int]]

1	particion :: Int -> [Int] -> [[Int]]

tal que (particion n xs) es la lista de los elementos de xs, en el mismo orden, agrupados en listas con sumas menores o iguales que n. Por ejemplo,

   particion 6 [1,1,1,3,2,2,2,1,2,2,3]   ==  [[1,1,1,3],[2,2,2],[1,2,2],[3]]
   particion 5 [1,1,1,3,2,2,2,1,2,2,3]   ==  [[1,1,1],[3,2],[2,2,1],[2,2],[3]]
   particion 4 [1,1,1,3,2,2,2,1,2,2,3]   ==  [[1,1,1],[3],[2,2],[2,1],[2,2],[3]]
   particion 3 [1,1,1,3,2,2,2,1,2,2,3]   ==  [[1,1,1],[3],[2],[2],[2,1],[2],[2],[3]]
   particion 2 [1,1,1,3,2,2,2,1,2,2,3]   ==  []

particion 6 [1,1,1,3,2,2,2,1,2,2,3] == [[1,1,1,3],[2,2,2],[1,2,2],[3]]

particion 5 [1,1,1,3,2,2,2,1,2,2,3] == [[1,1,1],[3,2],[2,2,1],[2,2],[3]]

particion 4 [1,1,1,3,2,2,2,1,2,2,3] == [[1,1,1],[3],[2,2],[2,1],[2,2],[3]]

particion 3 [1,1,1,3,2,2,2,1,2,2,3] == [[1,1,1],[3],[2],[2],[2,1],[2],[2],[3]]

particion 2 [1,1,1,3,2,2,2,1,2,2,3] == []

Soluciones

particion :: Int -> [Int] -> [[Int]]
particion n xs = reverse (map reverse (aux xs [[]]))
  where aux []     yss      = yss
        aux (x:xs) (ys:yss) | x > n           = []
                            | x + sum ys <= n = aux xs ((x:ys):yss)
                            | otherwise       = aux xs ([x]:ys:yss)

particion :: Int -> [Int] -> [[Int]]

particion n xs = reverse (map reverse (aux xs [[]]))

where aux [] yss = yss

aux (x:xs) (ys:yss) | x > n = []

| x + sum ys <= n = aux xs ((x:ys):yss)

| otherwise = aux xs ([x]:ys:yss)

Nuevas soluciones

En los comentarios se pueden escribir nuevas soluciones.
El código se debe escribir entre una línea con <pre lang="haskell"> y otra con </pre>

Con algún nueve

PorJosé A. Alonso 1-febrero-20218-febrero-2021

Definir las funciones

   numerosConNueve :: [Integer]
   conNueve :: Integer -> Integer

1 2	numerosConNueve :: [Integer] conNueve :: Integer -> Integer

tales que

numerosConNueve es la lista de los números con algún dígito igual a 9. Por ejemplo,

     λ> take 20 numerosConNueve
     [9,19,29,39,49,59,69,79,89,90,91,92,93,94,95,96,97,98,99,109]

1 2	λ> take 20 numerosConNueve [9,19,29,39,49,59,69,79,89,90,91,92,93,94,95,96,97,98,99,109]

(conNueve n) es la cantidad de números enteros no negativos menores o iguales que n con algún dígito igual a 9. Por ejemplo,

     conNueve 1   ==  0
     conNueve 10  ==  1
     conNueve 90  ==  10
     length (show (conNueve (10^3)))      ==  3
     length (show (conNueve (10^30)))     ==  30
     length (show (conNueve (10^300)))    ==  300
     length (show (conNueve (10^3000)))   ==  3000
     length (show (conNueve (10^30000)))  ==  30000

conNueve 1 == 0

conNueve 10 == 1

conNueve 90 == 10

length (show (conNueve (10^3))) == 3

length (show (conNueve (10^30))) == 30

length (show (conNueve (10^300))) == 300

length (show (conNueve (10^3000))) == 3000

length (show (conNueve (10^30000))) == 30000

Soluciones

import Data.List (genericLength)
import Test.QuickCheck (Property, (==>), quickCheck)

numerosConNueve :: [Integer]
numerosConNueve = filter tieneNueve [9..]

-- (tieneNueve n) se verifica si algún dígito de n es igual a 9. Por
-- ejemplo,
--    tieneNueve 2919  ==  True
--    tieneNueve 2717  ==  False
tieneNueve :: Integer -> Bool
tieneNueve n = '9' `elem` show n

-- 1ª definición de conNueve
-- =========================

conNueve :: Integer -> Integer
conNueve n =
  genericLength (takeWhile (<= n) numerosConNueve)

-- 2ª definición de conNueve
-- =========================

conNueve2 :: Integer -> Integer
conNueve2 0 = 0
conNueve2 n
  | tieneNueve n = 1 + conNueve2 (n-1)
  | otherwise   = conNueve2 (n-1)

-- 3ª definición de conNueve
-- =========================

conNueve3 :: Integer -> Integer
conNueve3 n = n + 1 - sinNueve n

-- (sinNueve n) es la cantidad de números enteros no negativos menores
-- o iguales que n con ningún dígito igual a 9. Por ejemplo,
--    sinNueve 1   ==  2
--    sinNueve 9   ==  9
--    sinNueve 90  ==  81
sinNueve :: Integer -> Integer
sinNueve n = aux (digitos n)
  where aux []     = 0
        aux [9]    = 9
        aux [x]    = x+1
        aux (9:xs) = 9^(1 + length xs)
        aux (x:xs) = x*9^(length xs) + aux xs

-- (digitos n) es la lista de los dígitod de n. Por ejemplo,
--    digitos 2021  ==  [2,0,2,1]
digitos :: Integer -> [Integer]
digitos n = [read [c] | c <- show n]

-- 4ª definición de conNueve
-- =========================

conNueve4 :: Integer -> Integer
conNueve4 n = n + 1 - sinNueve2 n

sinNueve2 :: Integer -> Integer
sinNueve2 n = aux ds (length ds)
  where ds = digitos n
        aux []     _ = 0
        aux [9]    _ = 9
        aux [x]    _ = x+1
        aux (9:xs) m = 9^m
        aux (x:xs) m = x*9^(m-1) + aux xs (m-1)

-- Comprobacion de equivalencia
-- ============================

-- La propiedad es
prop_conNueve_equiv :: Integer -> Property
prop_conNueve_equiv n =
  n >= 0 ==>
  all (== (conNueve n))
      [conNueve2 n,
       conNueve3 n,
       conNueve4 n]

-- La comprobación es
--    λ> quickCheck prop_conNueve_equiv
--    +++ OK, passed 100 tests.

-- Comparación de eficiencia
-- =========================

-- La comparación es
--    λ> conNueve (10^7)
--    5217031
--    (5.21 secs, 5,215,047,968 bytes)
--    λ> conNueve2 (10^7)
--    5217031
--    (8.25 secs, 5,651,944,872 bytes)
--    λ> conNueve3 (10^7)
--    5217031
--    (0.02 secs, 144,000 bytes)
--    λ> conNueve4 (10^7)
--    5217031
--    (0.02 secs, 145,904 bytes)
--
--    λ> length (show (conNueve3 (10^30000)))
--    30000
--    (3.24 secs, 776,076,072 bytes)
--    λ> length (show (conNueve4 (10^30000)))
--    30000
--    (2.00 secs, 786,452,856 bytes)

100

101

102

103

104

105

106

107

import Data.List (genericLength)

import Test.QuickCheck (Property, (==>), quickCheck)

numerosConNueve :: [Integer]

numerosConNueve = filter tieneNueve [9..]

-- (tieneNueve n) se verifica si algún dígito de n es igual a 9. Por

-- ejemplo,

-- tieneNueve 2919 == True

-- tieneNueve 2717 == False

tieneNueve :: Integer -> Bool

tieneNueve n = '9' `elem` show n

-- 1ª definición de conNueve

-- =========================

conNueve :: Integer -> Integer

conNueve n =

genericLength (takeWhile (<= n) numerosConNueve)

-- 2ª definición de conNueve

-- =========================

conNueve2 :: Integer -> Integer

conNueve2 0 = 0

conNueve2 n

| tieneNueve n = 1 + conNueve2 (n-1)

| otherwise = conNueve2 (n-1)

-- 3ª definición de conNueve

-- =========================

conNueve3 :: Integer -> Integer

conNueve3 n = n + 1 - sinNueve n

-- (sinNueve n) es la cantidad de números enteros no negativos menores

-- o iguales que n con ningún dígito igual a 9. Por ejemplo,

-- sinNueve 1 == 2

-- sinNueve 9 == 9

-- sinNueve 90 == 81

sinNueve :: Integer -> Integer

sinNueve n = aux (digitos n)

where aux [] = 0

aux [9] = 9

aux [x] = x+1

aux (9:xs) = 9^(1 + length xs)

aux (x:xs) = x*9^(length xs) + aux xs

-- (digitos n) es la lista de los dígitod de n. Por ejemplo,

-- digitos 2021 == [2,0,2,1]

digitos :: Integer -> [Integer]

digitos n = [read [c] | c <- show n]

-- 4ª definición de conNueve

-- =========================

conNueve4 :: Integer -> Integer

conNueve4 n = n + 1 - sinNueve2 n

sinNueve2 :: Integer -> Integer

sinNueve2 n = aux ds (length ds)

where ds = digitos n

aux [] _ = 0

aux [9] _ = 9

aux [x] _ = x+1

aux (9:xs) m = 9^m

aux (x:xs) m = x*9^(m-1) + aux xs (m-1)

-- Comprobacion de equivalencia

-- ============================

-- La propiedad es

prop_conNueve_equiv :: Integer -> Property

prop_conNueve_equiv n =

n >= 0 ==>

all (== (conNueve n))

[conNueve2 n,

conNueve3 n,

conNueve4 n]

-- La comprobación es

-- λ> quickCheck prop_conNueve_equiv

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

-- =========================

-- La comparación es

-- λ> conNueve (10^7)

-- 5217031

-- (5.21 secs, 5,215,047,968 bytes)

-- λ> conNueve2 (10^7)

-- 5217031

-- (8.25 secs, 5,651,944,872 bytes)

-- λ> conNueve3 (10^7)

-- 5217031

-- (0.02 secs, 144,000 bytes)

-- λ> conNueve4 (10^7)

-- 5217031

-- (0.02 secs, 145,904 bytes)

-- λ> length (show (conNueve3 (10^30000)))

-- 30000

-- (3.24 secs, 776,076,072 bytes)

-- λ> length (show (conNueve4 (10^30000)))

-- 30000

-- (2.00 secs, 786,452,856 bytes)

Nuevas soluciones

En los comentarios se pueden escribir nuevas soluciones.
El código se debe escribir entre una línea con <pre lang="haskell"> y otra con </pre>

Terna pitagórica en la que el perímetro es múltiplo de uno de los catetos

PorJosé A. Alonso 29-enero-20215-febrero-2021

La terna (n,a,b) es una terna pitagórica si n² = a²+b² y b < a < n. Por ejemplo, (5,4,3) y (10,8,6) son ternas pitagóricas.

Una terna pitagórica es primitiva si sus tres componentes son primos entre sí. Por ejemplo, (5,4,3) es una terna pitagórica primitiva y (10,8,6) es una terna pitagórica no primitiva (ya que sus tres lados son divisibles por 2).

Los elementos (n,a,b) de una terna pitagórica son las longitudes de los lados de un triágulo rectángulo; concretamente n es la longitud de la hipotenusa, a la del cateto mayor y b la del cateto menor. Su perímetro es n+a+b.

Definir la función

   ternasPPPDC :: [(Integer,Integer,Integer)]

1	ternasPPPDC :: [(Integer,Integer,Integer)]

tal que ternasPPPDC es la lista de las ternas pitagóricas primitivas tales que su perímetro es divisibe por alguno de los catetos. Por ejemplo,

   λ> take 5 ternasPPPDC
   [(5,4,3),(13,12,5),(17,15,8),(25,24,7),(37,35,12)]
   λ> [n | (n,a,b) <- take 15 ternasPPPDC]
   [5,13,17,25,37,41,61,65,85,101,113,145,145,181,197]
   λ> ternasPPPDC !! 80
   (4705,4704,97)

λ> take 5 ternasPPPDC

[(5,4,3),(13,12,5),(17,15,8),(25,24,7),(37,35,12)]

λ> [n | (n,a,b) <- take 15 ternasPPPDC]

[5,13,17,25,37,41,61,65,85,101,113,145,145,181,197]

λ> ternasPPPDC !! 80

(4705,4704,97)

Comprobar con QuickCheck que existen infinitas ternas pitagóricas primitivas tales que su perímetro es divisibe por alguno de los catetos; es decir, para todo x existe alguna terna (n,a,b) en ternasPPPDC tal que n es mayor que x.

Referencia: Este ejercicio está basado en el artículo Terna pitagórica en la que el perímetro es múltiplo de uno de los catetos publicado por Antonio Roldán en «Números y hoja de cálculo» el 21 de enero de 2021.

Soluciones

import Data.Numbers.Primes (primes)
import Test.QuickCheck (quickCheck)

-- 1ª solución
-- ===========

ternasPPPDC :: [(Integer,Integer,Integer)]
ternasPPPDC =
  [(n,a,b) | (n,a,b) <- ternasPitagoricasPrimitivas
           , (n+a+b) `mod` a == 0 || (n+a+b) `mod` b == 0]

-- ternasPitagoricasPrimitivas es la lista de las ternas pitagóricas
-- primitivas. Por ejemplo,
--    λ> take 5 ternasPitagoricasPrimitivas
--    [(5,4,3),(13,12,5),(17,15,8),(25,24,7),(29,21,20)]
ternasPitagoricasPrimitivas :: [(Integer,Integer,Integer)]
ternasPitagoricasPrimitivas =
  [(n,a,b) | (n,a,b) <- ternasPitagoricas
           , foldl1 gcd [n,a,b] == 1]

-- ternasPitagoricas es la lista de las ternas pitagóricas. Por ejemplo,
--    λ> take 5 ternasPitagoricas
--    [(5,4,3),(10,8,6),(13,12,5),(15,12,9),(17,15,8)]
ternasPitagoricas :: [(Integer,Integer,Integer)]
ternasPitagoricas =
    [(n,a,b) | n <- [1..],
               a <- [1..n-1],
               let b2 = n^2-a^2,
               let b = round (sqrt (fromIntegral b2)),
               b < a,
               b^2 == b2]

-- 2ª solución
-- ===========

ternasPPPDC2 :: [(Integer,Integer,Integer)]
ternasPPPDC2 =
  [(n,a,b) | (n,a,b) <- ternasPitagoricasPrimitivas2
           , (n+a+b) `mod` a == 0 || (n+a+b) `mod` b == 0]

ternasPitagoricasPrimitivas2 :: [(Integer,Integer,Integer)]
ternasPitagoricasPrimitivas2 =
  [(n,a,b) | (n,a,b) <- ternasPitagoricas2
           , foldl1 gcd [n,a,b] == 1]

ternasPitagoricas2 :: [(Integer,Integer,Integer)]
ternasPitagoricas2 =
    [(n,a,b) | n <- [5,9..],
               a <- [1..n-1],
               let b2 = n^2-a^2,
               let b = round (sqrt (fromIntegral b2)),
               b < a,
               b^2 == b2]

-- 3ª solución
-- ===========

ternasPPPDC3 :: [(Integer,Integer,Integer)]
ternasPPPDC3 =
  [(n,a,b) | (n,a,b) <- ternasPitagoricasPrimitivas3
           , (n+a+b) `mod` a == 0 || (n+a+b) `mod` b == 0]

ternasPitagoricasPrimitivas3 :: [(Integer,Integer,Integer)]
ternasPitagoricasPrimitivas3 =
  [(n,a,b) | (n,a,b) <- ternasPitagoricas3
           , foldl1 gcd [n,a,b] == 1]

ternasPitagoricas3 :: [(Integer,Integer,Integer)]
ternasPitagoricas3 =
    [(n,a,b) | n <- [5,9..],
               or [x `mod` 4 == 1 | x <- takeWhile (<=n) primes, n `mod` x == 0],
               a <- [1..n-1],
               let b2 = n^2-a^2,
               let b = round (sqrt (fromIntegral b2)),
               b < a,
               b^2 == b2]

-- Comparación de eficiencia
-- =========================

-- La comparación es
--    λ> ternasPPPDC !! 80
--    (4705,4704,97)
--    (19.66 secs, 21,249,420,072 bytes)
--    λ> ternasPPPDC2 !! 80
--    (4705,4704,97)
--    (5.00 secs, 5,316,680,464 bytes)
--    λ> ternasPPPDC3 !! 80
--    (4705,4704,97)
--    (3.68 secs, 4,234,492,416 bytes)

-- Propiedad
-- =========

-- La propiedad es
prop_ternasPPPDC :: Integer -> Bool
prop_ternasPPPDC x =
  not (null [(n,a,b) | (n,a,b) <- ternasPPPDC
                     , n > x])

-- La comprobación es
--    λ> quickCheck prop_ternasPPPDC
--    +++ OK, passed 100 tests.

100

101

102

103

import Data.Numbers.Primes (primes)

import Test.QuickCheck (quickCheck)

-- 1ª solución

-- ===========

ternasPPPDC :: [(Integer,Integer,Integer)]

ternasPPPDC =

[(n,a,b) | (n,a,b) <- ternasPitagoricasPrimitivas

, (n+a+b) `mod` a == 0 || (n+a+b) `mod` b == 0]

-- ternasPitagoricasPrimitivas es la lista de las ternas pitagóricas

-- primitivas. Por ejemplo,

-- λ> take 5 ternasPitagoricasPrimitivas

-- [(5,4,3),(13,12,5),(17,15,8),(25,24,7),(29,21,20)]

ternasPitagoricasPrimitivas :: [(Integer,Integer,Integer)]

ternasPitagoricasPrimitivas =

[(n,a,b) | (n,a,b) <- ternasPitagoricas

, foldl1 gcd [n,a,b] == 1]

-- ternasPitagoricas es la lista de las ternas pitagóricas. Por ejemplo,

-- λ> take 5 ternasPitagoricas

-- [(5,4,3),(10,8,6),(13,12,5),(15,12,9),(17,15,8)]

ternasPitagoricas :: [(Integer,Integer,Integer)]

ternasPitagoricas =

[(n,a,b) | n <- [1..],

a <- [1..n-1],

let b2 = n^2-a^2,

let b = round (sqrt (fromIntegral b2)),

b < a,

b^2 == b2]

-- 2ª solución

-- ===========

ternasPPPDC2 :: [(Integer,Integer,Integer)]

ternasPPPDC2 =

[(n,a,b) | (n,a,b) <- ternasPitagoricasPrimitivas2

, (n+a+b) `mod` a == 0 || (n+a+b) `mod` b == 0]

ternasPitagoricasPrimitivas2 :: [(Integer,Integer,Integer)]

ternasPitagoricasPrimitivas2 =

[(n,a,b) | (n,a,b) <- ternasPitagoricas2

, foldl1 gcd [n,a,b] == 1]

ternasPitagoricas2 :: [(Integer,Integer,Integer)]

ternasPitagoricas2 =

[(n,a,b) | n <- [5,9..],

a <- [1..n-1],

let b2 = n^2-a^2,

let b = round (sqrt (fromIntegral b2)),

b < a,

b^2 == b2]

-- 3ª solución

-- ===========

ternasPPPDC3 :: [(Integer,Integer,Integer)]

ternasPPPDC3 =

[(n,a,b) | (n,a,b) <- ternasPitagoricasPrimitivas3

, (n+a+b) `mod` a == 0 || (n+a+b) `mod` b == 0]

ternasPitagoricasPrimitivas3 :: [(Integer,Integer,Integer)]

ternasPitagoricasPrimitivas3 =

[(n,a,b) | (n,a,b) <- ternasPitagoricas3

, foldl1 gcd [n,a,b] == 1]

ternasPitagoricas3 :: [(Integer,Integer,Integer)]

ternasPitagoricas3 =

[(n,a,b) | n <- [5,9..],

or [x `mod` 4 == 1 | x <- takeWhile (<=n) primes, n `mod` x == 0],

a <- [1..n-1],

let b2 = n^2-a^2,

let b = round (sqrt (fromIntegral b2)),

b < a,

b^2 == b2]

-- Comparación de eficiencia

-- =========================

-- La comparación es

-- λ> ternasPPPDC !! 80

-- (4705,4704,97)

-- (19.66 secs, 21,249,420,072 bytes)

-- λ> ternasPPPDC2 !! 80

-- (4705,4704,97)

-- (5.00 secs, 5,316,680,464 bytes)

-- λ> ternasPPPDC3 !! 80

-- (4705,4704,97)

-- (3.68 secs, 4,234,492,416 bytes)

-- Propiedad

-- =========

-- La propiedad es

prop_ternasPPPDC :: Integer -> Bool

prop_ternasPPPDC x =

not (null [(n,a,b) | (n,a,b) <- ternasPPPDC

, n > x])

-- La comprobación es

-- λ> quickCheck prop_ternasPPPDC

-- +++ OK, passed 100 tests.

Nuevas soluciones

En los comentarios se pueden escribir nuevas soluciones.
El código se debe escribir entre una línea con <pre lang="haskell"> y otra con </pre>

El número de Dottie

PorJosé A. Alonso 28-enero-20214-febrero-2021

La sucesión de Dottie correspondiente a un número x se obtiene a partir de x aplicándole la función coseno al término anterior. Por ejemplo, empezando en el 2021 los términos de la sucesión de Dottie son

   d(0) = 2021
   d(1) = cos(2021)                = -0.5768544484396986
   d(2) = cos(-0.5768544484396986) = 0.8381823464377144
   d(3) = cos(0.8381823464377144)  = 0.6688152257126013
   d(4) = cos(0.6688152257126013)  = 0.7845568438177061
   d(5) = cos(0.7845568438177061)  = 0.7077014336446841
   d(6) = cos(0.7077014336446841)  = 0.7598581544800473
   d(7) = cos(0.7598581544800473)  = 0.7249337238692606
   d(8) = cos(0.7249337238692606)  = 0.7485433703735275

d(0) = 2021

d(1) = cos(2021) = -0.5768544484396986

d(2) = cos(-0.5768544484396986) = 0.8381823464377144

d(3) = cos(0.8381823464377144) = 0.6688152257126013

d(4) = cos(0.6688152257126013) = 0.7845568438177061

d(5) = cos(0.7845568438177061) = 0.7077014336446841

d(6) = cos(0.7077014336446841) = 0.7598581544800473

d(7) = cos(0.7598581544800473) = 0.7249337238692606

d(8) = cos(0.7249337238692606) = 0.7485433703735275

Definir las funciones

   sucesionDottie :: Double -> [Double]
   limite :: [Double] -> Double -> Int -> Double

1 2	sucesionDottie :: Double -> [Double] limite :: [Double] -> Double -> Int -> Double

tales que

(sucesionDottie x) es la lista de los términos de la sucesión de Dottie correspondiente a x. Por ejemplo,

     λ> mapM_ print (take 10 (sucesionDottie 2021))
     2021.0
     -0.5768544484396986
     0.8381823464377144
     0.6688152257126013
     0.7845568438177061
     0.7077014336446841
     0.7598581544800473
     0.7249337238692606
     0.7485433703735275
     0.7326809874975466
     λ> mapM_ print (take 10 (drop 85 (sucesionDottie 2021)))
     0.7390851332151601
     0.739085133215161
     0.7390851332151605
     0.7390851332151608
     0.7390851332151606
     0.7390851332151607
     0.7390851332151607
     0.7390851332151607
     0.7390851332151607
     0.7390851332151607

λ> mapM_ print (take 10 (sucesionDottie 2021))

2021.0

-0.5768544484396986

0.8381823464377144

0.6688152257126013

0.7845568438177061

0.7077014336446841

0.7598581544800473

0.7249337238692606

0.7485433703735275

0.7326809874975466

λ> mapM_ print (take 10 (drop 85 (sucesionDottie 2021)))

0.7390851332151601

0.739085133215161

0.7390851332151605

0.7390851332151608

0.7390851332151606

0.7390851332151607

(limite xs a n) es el límite de xs con aproximación a y amplitud n; es decir, el primer término x de la sucesión tal que el valor absoluto de x y cualquiera de sus n siguentes elementos es menor que a. Por ejemplo,

     λ> limite [(2*n+1)/(n+5) | n <- [1..]] 0.001 300
     1.993991989319092
     λ> limite [(2*n+1)/(n+5) | n <- [1..]] 1e-6 300
     1.9998260062637745
     λ> limite [(1+1/n)**n | n <- [1..]] 0.001 300
     2.7155953364173175
     λ> limite (sucesionDottie 2021) 1e-16 100
     0.7390851332151607
     λ> limite (sucesionDottie 27) 1e-16 100
     0.7390851332151607

λ> limite [(2*n+1)/(n+5) | n <- [1..]] 0.001 300

1.993991989319092

λ> limite [(2*n+1)/(n+5) | n <- [1..]] 1e-6 300

1.9998260062637745

λ> limite [(1+1/n)**n | n <- [1..]] 0.001 300

2.7155953364173175

λ> limite (sucesionDottie 2021) 1e-16 100

0.7390851332151607

λ> limite (sucesionDottie 27) 1e-16 100

0.7390851332151607

Comprobar con QuickCheck que, para todo número x, el límite de la
sucesión de Dottie generada por x es mismo; es decir, si x e y son
dos números cualesquiera, entonces

     limite (sucesionDottie x) 1e-16 100 ==
     limite (sucesionDottie y) 1e-16 100

1 2	limite (sucesionDottie x) 1e-16 100 == limite (sucesionDottie y) 1e-16 100

Dicho límite es el número de Dottie.

Referencia: Este ejercicio está basado en el artículo El número de Dottie publicado por Miguel Ángel Morales en Gaussianos el 20 de enero de 2021.

Soluciones

import Data.List (tails)
import Test.QuickCheck

-- 1ª definición de sucesionDottie
-- ===============================

sucesionDottie1 :: Double -> [Double]
sucesionDottie1 x  = map (terminoDottie x) [0..]

terminoDottie :: Double -> Int -> Double
terminoDottie x 0 = x
terminoDottie x n = cos (terminoDottie x (n-1))

-- 2ª definición de sucesionDottie
-- ===============================

sucesionDottie2 :: Double -> [Double]
sucesionDottie2 x = iterate cos x

-- Comparación de eficiencia de definiciones de sucesionDottie
-- ===========================================================

-- La comparación es
--    λ> sucesionDottie1 2021 !! (5*10^6)
--    0.7390851332151607
--    (2.13 secs, 1,894,864,000 bytes)
--    λ> sucesionDottie2 2021 !! (5*10^6)
--    0.7390851332151607
--    (0.95 secs, 644,703,256 bytes)

-- En lo que sigue, usaremos la 2ª definición
sucesionDottie :: Double -> [Double]
sucesionDottie = sucesionDottie2

-- 1ª definición de limite
-- =======================

limite1 :: [Double] -> Double -> Int -> Double
limite1 xs a n =
  head [ x | (x:ys) <- segmentos xs n
       , all (\y ->  abs (y - x) < a) ys]

-- (segmentos xs n) es la lista de los segmentos de la lista infinita xs
-- con n elementos. Por ejemplo,
--    λ> take 5 (segmentos [1..] 3)
--    [[1,2,3],[2,3,4],[3,4,5],[4,5,6],[5,6,7]]
segmentos :: [a] -> Int -> [[a]]
segmentos xs n = map (take n) (tails xs)

-- 2ª solución
-- ===========

limite2 :: [Double] -> Double -> Int -> Double
limite2 (n:ns) x a
  | abs (n - maximum (take (a-1) ns)) < x = n
  | otherwise                             = limite2 ns x a


-- Comparación de eficiencia
-- =========================

-- La comparación es
--    λ> limite1 [(1+1/n)**n | n <- [1..]] 1e-8 100
--    2.7182700737511185
--    (1.40 secs, 1,044,694,328 bytes)
--    λ> limite2 [(1+1/n)**n | n <- [1..]] 1e-8 100
--    2.7182700737511185
--    (0.47 secs, 1,185,073,072 bytes)

-- En lo que sigue, usaremos la 2ª definición
limite :: [Double] -> Double -> Int -> Double
limite = limite2

-- Propiedad
-- =========

-- La propiedad es
prop_Dottie :: Double -> Double -> Bool
prop_Dottie x y =
  limite (sucesionDottie x) 1e-16 100 ==
  limite (sucesionDottie y) 1e-16 100

-- La comprobación es
--    λ> quickCheck prop_Dottie
--    +++ OK, passed 100 tests.

import Data.List (tails)

import Test.QuickCheck

-- 1ª definición de sucesionDottie

-- ===============================

sucesionDottie1 :: Double -> [Double]

sucesionDottie1 x = map (terminoDottie x) [0..]

terminoDottie :: Double -> Int -> Double

terminoDottie x 0 = x

terminoDottie x n = cos (terminoDottie x (n-1))

-- 2ª definición de sucesionDottie

-- ===============================

sucesionDottie2 :: Double -> [Double]

sucesionDottie2 x = iterate cos x

-- Comparación de eficiencia de definiciones de sucesionDottie

-- ===========================================================

-- La comparación es

-- λ> sucesionDottie1 2021 !! (5*10^6)

-- 0.7390851332151607

-- (2.13 secs, 1,894,864,000 bytes)

-- λ> sucesionDottie2 2021 !! (5*10^6)

-- 0.7390851332151607

-- (0.95 secs, 644,703,256 bytes)

-- En lo que sigue, usaremos la 2ª definición

sucesionDottie :: Double -> [Double]

sucesionDottie = sucesionDottie2

-- 1ª definición de limite

-- =======================

limite1 :: [Double] -> Double -> Int -> Double

limite1 xs a n =

head [ x | (x:ys) <- segmentos xs n

, all (\y -> abs (y - x) < a) ys]

-- (segmentos xs n) es la lista de los segmentos de la lista infinita xs

-- con n elementos. Por ejemplo,

-- λ> take 5 (segmentos [1..] 3)

-- [[1,2,3],[2,3,4],[3,4,5],[4,5,6],[5,6,7]]

segmentos :: [a] -> Int -> [[a]]

segmentos xs n = map (take n) (tails xs)

-- 2ª solución

-- ===========

limite2 :: [Double] -> Double -> Int -> Double

limite2 (n:ns) x a

| abs (n - maximum (take (a-1) ns)) < x = n

| otherwise = limite2 ns x a

-- Comparación de eficiencia

-- =========================

-- La comparación es

-- λ> limite1 [(1+1/n)**n | n <- [1..]] 1e-8 100

-- 2.7182700737511185

-- (1.40 secs, 1,044,694,328 bytes)

-- λ> limite2 [(1+1/n)**n | n <- [1..]] 1e-8 100

-- 2.7182700737511185

-- (0.47 secs, 1,185,073,072 bytes)

-- En lo que sigue, usaremos la 2ª definición

limite :: [Double] -> Double -> Int -> Double

limite = limite2

-- Propiedad

-- =========

-- La propiedad es

prop_Dottie :: Double -> Double -> Bool

prop_Dottie x y =

limite (sucesionDottie x) 1e-16 100 ==

limite (sucesionDottie y) 1e-16 100

-- La comprobación es

-- λ> quickCheck prop_Dottie

-- +++ OK, passed 100 tests.

Nuevas soluciones

En los comentarios se pueden escribir nuevas soluciones.
El código se debe escribir entre una línea con <pre lang="haskell"> y otra con </pre>

Limitación del número de repeticiones

PorJosé A. Alonso 26-enero-20212-febrero-2021

Definir la función

   conRepeticionesAcotadas :: Eq a => [a] -> Int -> [a]

1	conRepeticionesAcotadas :: Eq a => [a] -> Int -> [a]

tal que (conRepeticionesAcotadas xs n) es una lista que contiene cada elemento de xs como máximo n veces sin reordenar (se supone que n es un número positivo).. Por ejemplo,

   conRepeticionesAcotadas [1,2,3,1,2,1,3,2,3,5] 1  ==  [1,2,3,5]
   conRepeticionesAcotadas [1,2,3,1,2,1,3,2,3,5] 2  ==  [1,2,3,1,2,3,5]
   conRepeticionesAcotadas [1,2,3,1,2,1,3,2,3,5] 3  ==  [1,2,3,1,2,1,3,2,3,5]
   conRepeticionesAcotadas [1,2,3,1,2,1,3,2,3,5] 4  ==  [1,2,3,1,2,1,3,2,3,5]

conRepeticionesAcotadas [1,2,3,1,2,1,3,2,3,5] 1 == [1,2,3,5]

conRepeticionesAcotadas [1,2,3,1,2,1,3,2,3,5] 2 == [1,2,3,1,2,3,5]

conRepeticionesAcotadas [1,2,3,1,2,1,3,2,3,5] 3 == [1,2,3,1,2,1,3,2,3,5]

conRepeticionesAcotadas [1,2,3,1,2,1,3,2,3,5] 4 == [1,2,3,1,2,1,3,2,3,5]

Soluciones

import Data.List (foldl')
import Data.Maybe (fromJust, isNothing)
import Test.QuickCheck (Property, (==>),quickCheck)

-- 1ª solución
-- ===========

conRepeticionesAcotadas :: Eq a => [a] -> Int -> [a]
conRepeticionesAcotadas xs n = reverse (aux [] xs)
  where aux zs []     = zs
        aux zs (y:ys) | m < n     = aux (y:zs) ys
                      | otherwise = aux zs ys
          where m = nOcurrencias y zs

-- (nOcurrencias x ys) es el número de ocurrencias de x en ys. Por
-- ejemplo,
--    nOcurrencias 7 [7,2,7,7,5]  ==  3
nOcurrencias :: Eq a => a -> [a] -> Int
nOcurrencias x ys = length (filter (== x) ys)

-- Se puede simplificar la definición de nOcurrencias:
nOcurrencias2 :: Eq a => a -> [a] -> Int
nOcurrencias2 x = length . filter (== x)

-- 2ª solución
-- ===========

conRepeticionesAcotadas2 :: Eq a => [a] -> Int -> [a]
conRepeticionesAcotadas2 xs n = reverse (foldl' aux [] xs)
  where aux zs y | m < n     = y:zs
                 | otherwise = zs
          where m = nOcurrencias y zs

-- 3ª solución
-- ===========

conRepeticionesAcotadas3 :: Eq a => [a] -> Int -> [a]
conRepeticionesAcotadas3 xs n = reverse (aux [] [] xs)
  where aux as _ []      = as
        aux as bs (y:ys) | y `elem` bs = aux as bs ys
                         | m < n       = aux (y:as) bs ys
                         | otherwise   = aux as (y:bs) ys
          where m = nOcurrencias y as

-- 4ª solución
-- ===========

conRepeticionesAcotadas4 :: Eq a => [a] -> Int -> [a]
conRepeticionesAcotadas4 xs n = aux xs []
  where aux [] _      = []
        aux (y:ys) ps | r == Nothing = y : aux ys ((y,1) : ps)
                      | m < n        = y : aux ys ((y,m+1) : ps)
                      | otherwise    = aux ys ps
                      where r = busca y ps
                            Just m = r

-- (busca x ps) es justamente la segunda componente del primer par de ps
-- cuya primera componente es xs, si ps tiene algún par cuya primera
-- componente es x; y Nothing en caso contrario. Por ejemplo,
--    busca 'a' [('b',2),('a',3),('a',1)]  ==  Just 3
--    busca 'c' [('b',2),('a',3),('a',1)]  ==  Nothing
busca :: Eq a => a -> [(a,b)] -> Maybe b
busca x ps
  | null ys   = Nothing
  | otherwise = Just (head ys)
  where ys = [n | (y,n) <- ps, y == x]

-- 5ª solución
-- ===========

conRepeticionesAcotadas5 :: Eq a => [a] -> Int -> [a]
conRepeticionesAcotadas5 xs n = aux xs []
  where aux [] _      = []
        aux (y:ys) ps | isNothing r = y : aux ys ((y,1) : ps)
                      | m < n       = y : aux ys ((y,m+1) : ps)
                      | otherwise   = aux ys ps
                      where r = lookup y ps
                            m = fromJust r

-- Equivalencia de las definiciones
-- ================================

-- La propiedad es
prop_conRepeticionesAcotadas :: [Int] -> Int -> Property
prop_conRepeticionesAcotadas xs n =
  n > 0 ==>
  all (==(conRepeticionesAcotadas xs n))
      [ conRepeticionesAcotadas2 xs n
      , conRepeticionesAcotadas3 xs n
      , conRepeticionesAcotadas4 xs n
      , conRepeticionesAcotadas5 xs n]

-- La comprobación es
--    λ> quickCheck prop_conRepeticionesAcotadas
--    +++ OK, passed 100 tests.

-- Comparación de eficiencia
-- =========================

-- La comparación es
--    λ> length (conRepeticionesAcotadas (concat [[1..n] | n <- [1..500]]) 2)
--    999
--    (5.14 secs, 64,372,768 bytes)
--    λ> length (conRepeticionesAcotadas2 (concat [[1..n] | n <- [1..500]]) 2)
--    999
--    (4.95 secs, 62,322,880 bytes)
--    λ> length (conRepeticionesAcotadas3 (concat [[1..n] | n <- [1..500]]) 2)
--    999
--    (0.38 secs, 38,764,952 bytes)
--    λ> length (conRepeticionesAcotadas4 (concat [[1..n] | n <- [1..500]]) 2)
--    999
--    (5.66 secs, 2,429,904,144 bytes)
--    λ> length (conRepeticionesAcotadas5 (concat [[1..n] | n <- [1..500]]) 2)
--    999
--    (0.68 secs, 48,536,872 bytes)

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

import Data.List (foldl')

import Data.Maybe (fromJust, isNothing)

import Test.QuickCheck (Property, (==>),quickCheck)

-- 1ª solución

-- ===========

conRepeticionesAcotadas :: Eq a => [a] -> Int -> [a]

conRepeticionesAcotadas xs n = reverse (aux [] xs)

where aux zs [] = zs

aux zs (y:ys) | m < n = aux (y:zs) ys

| otherwise = aux zs ys

where m = nOcurrencias y zs

-- (nOcurrencias x ys) es el número de ocurrencias de x en ys. Por

-- ejemplo,

-- nOcurrencias 7 [7,2,7,7,5] == 3

nOcurrencias :: Eq a => a -> [a] -> Int

nOcurrencias x ys = length (filter (== x) ys)

-- Se puede simplificar la definición de nOcurrencias:

nOcurrencias2 :: Eq a => a -> [a] -> Int

nOcurrencias2 x = length . filter (== x)

-- 2ª solución

-- ===========

conRepeticionesAcotadas2 :: Eq a => [a] -> Int -> [a]

conRepeticionesAcotadas2 xs n = reverse (foldl' aux [] xs)

where aux zs y | m < n = y:zs

| otherwise = zs

where m = nOcurrencias y zs

-- 3ª solución

-- ===========

conRepeticionesAcotadas3 :: Eq a => [a] -> Int -> [a]

conRepeticionesAcotadas3 xs n = reverse (aux [] [] xs)

where aux as _ [] = as

aux as bs (y:ys) | y `elem` bs = aux as bs ys

| m < n = aux (y:as) bs ys

| otherwise = aux as (y:bs) ys

where m = nOcurrencias y as

-- 4ª solución

-- ===========

conRepeticionesAcotadas4 :: Eq a => [a] -> Int -> [a]

conRepeticionesAcotadas4 xs n = aux xs []

where aux [] _ = []

aux (y:ys) ps | r == Nothing = y : aux ys ((y,1) : ps)

| m < n = y : aux ys ((y,m+1) : ps)

| otherwise = aux ys ps

where r = busca y ps

Just m = r

-- (busca x ps) es justamente la segunda componente del primer par de ps

-- cuya primera componente es xs, si ps tiene algún par cuya primera

-- componente es x; y Nothing en caso contrario. Por ejemplo,

-- busca 'a' [('b',2),('a',3),('a',1)] == Just 3

-- busca 'c' [('b',2),('a',3),('a',1)] == Nothing

busca :: Eq a => a -> [(a,b)] -> Maybe b

busca x ps

| null ys = Nothing

| otherwise = Just (head ys)

where ys = [n | (y,n) <- ps, y == x]

-- 5ª solución

-- ===========

conRepeticionesAcotadas5 :: Eq a => [a] -> Int -> [a]

conRepeticionesAcotadas5 xs n = aux xs []

where aux [] _ = []

aux (y:ys) ps | isNothing r = y : aux ys ((y,1) : ps)

| m < n = y : aux ys ((y,m+1) : ps)

| otherwise = aux ys ps

where r = lookup y ps

m = fromJust r

-- Equivalencia de las definiciones

-- ================================

-- La propiedad es

prop_conRepeticionesAcotadas :: [Int] -> Int -> Property

prop_conRepeticionesAcotadas xs n =

n > 0 ==>

all (==(conRepeticionesAcotadas xs n))

[ conRepeticionesAcotadas2 xs n

, conRepeticionesAcotadas3 xs n

, conRepeticionesAcotadas4 xs n

, conRepeticionesAcotadas5 xs n]

-- La comprobación es

-- λ> quickCheck prop_conRepeticionesAcotadas

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

-- =========================

-- La comparación es

-- λ> length (conRepeticionesAcotadas (concat [[1..n] | n <- [1..500]]) 2)

-- 999

-- (5.14 secs, 64,372,768 bytes)

-- λ> length (conRepeticionesAcotadas2 (concat [[1..n] | n <- [1..500]]) 2)

-- 999

-- (4.95 secs, 62,322,880 bytes)

-- λ> length (conRepeticionesAcotadas3 (concat [[1..n] | n <- [1..500]]) 2)

-- 999

-- (0.38 secs, 38,764,952 bytes)

-- λ> length (conRepeticionesAcotadas4 (concat [[1..n] | n <- [1..500]]) 2)

-- 999

-- (5.66 secs, 2,429,904,144 bytes)

-- λ> length (conRepeticionesAcotadas5 (concat [[1..n] | n <- [1..500]]) 2)

-- 999

-- (0.68 secs, 48,536,872 bytes)

Nuevas soluciones

En los comentarios se pueden escribir nuevas soluciones.
El código se debe escribir entre una línea con <pre lang="haskell"> y otra con </pre>

Clausura respecto del valor absoluto de las diferencias

PorJosé A. Alonso 21-enero-202128-enero-2021

Dado un conjunto de números enteros positivos S su clausura del valor absoluto de la diferencia de pares es el menor conjunto T tal que T contiene a S y para cualquier par de elementos x e y de T (con x distinto de y) el valor absoluto de (x-y) también es un elemento de T. Por ejemplo, si S = {12, 30}, entonces

12 ∈ T, porque 12 ∈ S
30 ∈ T, porque 20 ∈ S
18 = |12 – 30| ∈ T
6 = |18 – 12| ∈ T
24 = |30 – 6| ∈ T

Por tanto, T = {12, 30, 18, 6, 24}.

Definir las funciones

   clausura :: [Int] -> [Int]
   longitudClausura :: [Int] -> Int

1 2	clausura :: [Int] -> [Int] longitudClausura :: [Int] -> Int

tales que

(clausura xs) es la clausura del conjunto de enteros positivos xs respecto del valor absoluto de la diferencia de pares. Por ejemplo,

     clausura [12,30]  ==  [12,30,18,6,24]
     clausura [3,5,2]  ==  [3,5,2,1,4]

1 2	clausura [12,30] == [12,30,18,6,24] clausura [3,5,2] == [3,5,2,1,4]

(longitudClausura xs) es el número de elementos de la clausura del conjunto de enteros positivos xs respecto del valor absoluto de la diferencia de pares. Por ejemplo,

     longitudClausura [12,30]        ==  5
     longitudClausura [3,5,2]        ==  5
     longitudClausura [3,23..10^6]   ==  999983

longitudClausura [12,30] == 5

longitudClausura [3,5,2] == 5

longitudClausura [3,23..10^6] == 999983

Soluciones

import Data.List (nub, sort, union)
import Test.QuickCheck

-- Definición de clausura
-- ======================

clausura :: [Int] -> [Int]
clausura xs
  | contenida ys xs = xs
  | otherwise       = clausura (union xs ys)
  where ys = diferencias xs

-- (diferencias xs) es el conjunto de los valores absolutos de las
-- diferencias de pares de elementos distintos de xs. Por ejemplo,
--    diferencias [3,7,11]  ==  [4,8]
diferencias :: [Int] -> [Int]
diferencias xs =
  nub [x - y | x <- xs
             , y <- xs
             , x > y]

-- (contenida xs ys) se verifica si la lista xs esta contenida en
-- ys. Por ejemplo,
--    contenida [2,3] [3,5,2]  ==  True
--    contenida [2,3] [3,5,7]  ==  False
contenida :: [Int] -> [Int] -> Bool
contenida xs ys =
  all (`elem` ys) xs

-- 1ª definición de longitudClausura
-- =================================

longitudClausura :: [Int] -> Int
longitudClausura = length . clausura

-- 2ª definición de longitudClausura
-- =================================

--    longitudClausura2 [3,23..10^6]  ==  999983
longitudClausura2 :: [Int] -> Int
longitudClausura2 xs =
  maximum xs `div` mcd xs

-- (mcd xs) es el máximo común divisor de los elememtos de xs. Por
-- ejemplo,
--    mcd [12, 60]      ==  12
--    mcd [12, 60, 42]  ==  6
mcd :: [Int] -> Int
mcd = foldl1 gcd

-- Equivalencia
-- ============

-- La propiedd de equivalencia es
prop_clausura :: [Int] -> Property
prop_clausura xs =
  not (null xs) ==>
  longitudClausura ys == longitudClausura2 ys
  where ys = nub (map ((+1) . abs) xs)

-- La comprobación es
--    λ> quickCheck prop_clausura
--    +++ OK, passed 100 tests.

-- Comparación de eficiencia
-- =========================

-- La comparación es
--    λ> longitudClausura [3,23..10^3]
--    983
--    (2.22 secs, 239,761,904 bytes)
--    λ> longitudClausura2 [3,23..10^3]
--    983
--    (0.01 secs, 118,968 bytes)

import Data.List (nub, sort, union)

import Test.QuickCheck

-- Definición de clausura

-- ======================

clausura :: [Int] -> [Int]

clausura xs

| contenida ys xs = xs

| otherwise = clausura (union xs ys)

where ys = diferencias xs

-- (diferencias xs) es el conjunto de los valores absolutos de las

-- diferencias de pares de elementos distintos de xs. Por ejemplo,

-- diferencias [3,7,11] == [4,8]

diferencias :: [Int] -> [Int]

diferencias xs =

nub [x - y | x <- xs

, y <- xs

, x > y]

-- (contenida xs ys) se verifica si la lista xs esta contenida en

-- ys. Por ejemplo,

-- contenida [2,3] [3,5,2] == True

-- contenida [2,3] [3,5,7] == False

contenida :: [Int] -> [Int] -> Bool

contenida xs ys =

all (`elem` ys) xs

-- 1ª definición de longitudClausura

-- =================================

longitudClausura :: [Int] -> Int

longitudClausura = length . clausura

-- 2ª definición de longitudClausura

-- =================================

-- longitudClausura2 [3,23..10^6] == 999983

longitudClausura2 :: [Int] -> Int

longitudClausura2 xs =

maximum xs `div` mcd xs

-- (mcd xs) es el máximo común divisor de los elememtos de xs. Por

-- ejemplo,

-- mcd [12, 60] == 12

-- mcd [12, 60, 42] == 6

mcd :: [Int] -> Int

mcd = foldl1 gcd

-- Equivalencia

-- ============

-- La propiedd de equivalencia es

prop_clausura :: [Int] -> Property

prop_clausura xs =

not (null xs) ==>

longitudClausura ys == longitudClausura2 ys

where ys = nub (map ((+1) . abs) xs)

-- La comprobación es

-- λ> quickCheck prop_clausura

-- +++ OK, passed 100 tests.

-- Comparación de eficiencia

-- =========================

-- La comparación es

-- λ> longitudClausura [3,23..10^3]

-- 983

-- (2.22 secs, 239,761,904 bytes)

-- λ> longitudClausura2 [3,23..10^3]

-- 983

-- (0.01 secs, 118,968 bytes)

Buenos primos

PorJosé A. Alonso 19-enero-202126-enero-2021

La sucesión de los números primos es

   2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 53, ...

1	2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 53, ...

Las parejas de primos equidistantes de 5 en dicha sucesión son (3, 7) y (2, 11). Se observa que el cuadrado de 5 es mayor que el producto de los elementos de dichas parejas; es decir,

   5^2 = 25 > 21 = 3 x 7
   5^2 = 25 > 22 = 2 x 11

1 2	5^2 = 25 > 21 = 3 x 7 5^2 = 25 > 22 = 2 x 11

En cambio, el 7 tiene una pareja de primos equidistantes (la (5, 11)) cuyo producto es mayor que el cuadrado de 7.

   7^2 = 49 < 55 = 5 x 11

1	7^2 = 49 < 55 = 5 x 11

Un buen primo es un número primo cuyo cuadrado es mayor que el producto de dos primos cualesquiera equidistantes de él en la sucesión de primos. Por ejemplo, 5 es un buen primo pero 7 no lo es.

Definir las funciones

   esBuenPrimo  :: Integer -> Bool
   buenosPrimos :: [Integer]

1 2	esBuenPrimo :: Integer -> Bool buenosPrimos :: [Integer]

tales que

(esBuenPrimo n) se verifica si n es un buen primo. Por ejemplo,

     esBuenPrimo 5        ==  True
     esBuenPrimo 7        ==  False
     esBuenPrimo 8746811  ==  True

esBuenPrimo 5 == True

esBuenPrimo 7 == False

esBuenPrimo 8746811 == True

buenosPrimos es la lista de los buenos primos. Por ejemplo,

     λ> take 12 buenosPrimos
     [2,5,11,17,29,37,41,53,59,67,71,97]

1 2	λ> take 12 buenosPrimos [2,5,11,17,29,37,41,53,59,67,71,97]

Comprobar con QuickCheck que la lista de los buenos primos es infinita; es decir, para cualquier entero positivo n existe un número mayor que n que es un buen primo.

Soluciones

import Data.Numbers.Primes (primes)
import Test.QuickCheck (Property, (==>), quickCheck)

esBuenPrimo :: Integer -> Bool
esBuenPrimo n =
  n == y && and [n^2 > x * y | (x, y) <- zip (reverse xs) ys]
  where (xs,y:ys) = span (< n) primes

buenosPrimos :: [Integer]
buenosPrimos = filter esBuenPrimo [2..]

-- La propiedad es
prop_buenosPrimos :: Integer -> Property
prop_buenosPrimos n =
  n > 0 ==> any esBuenPrimo [n+1..]

-- La comprobación es
--    λ> quickCheck prop_buenosPrimos
--    +++ OK, passed 100 tests.

import Data.Numbers.Primes (primes)

import Test.QuickCheck (Property, (==>), quickCheck)

esBuenPrimo :: Integer -> Bool

esBuenPrimo n =

n == y && and [n^2 > x * y | (x, y) <- zip (reverse xs) ys]

where (xs,y:ys) = span (< n) primes

buenosPrimos :: [Integer]

buenosPrimos = filter esBuenPrimo [2..]

-- La propiedad es

prop_buenosPrimos :: Integer -> Property

prop_buenosPrimos n =

n > 0 ==> any esBuenPrimo [n+1..]

-- La comprobación es

-- λ> quickCheck prop_buenosPrimos

-- +++ OK, passed 100 tests.

Números compuestos persistentes

PorJosé A. Alonso 15-enero-202122-enero-2021

Un número compuesto persistente es un número compuesto que no se puede transformar en un número primo cambiando sólo uno de sus dígitos. Por ejemplo,

20 no es un compuesto persistente porque cambiando su último dígito por un 3 se transforma en 23 que es primo.
25 no es un compuesto persistente porque cambiando su primer dígito por un 0 se transforma en 5 que es primo.
200 es un compuesto persistente ya que al cambiar su útimo dígito por un impar se obtienen los números 201, 203, 207, 205 y 209 que no son primos y todos sus demás transformados son pares y, por tanto, tampoco son primos.

Definir las funciones

   esCompuestoPersistente :: Integer -> Bool
   compuestosPersistentes :: [Integer]

1 2	esCompuestoPersistente :: Integer -> Bool compuestosPersistentes :: [Integer]

tales que

(esCompuestoPersistente n) se verifica si n es un número compuesto persistente. Por ejemplo,

     esCompuestoPersistente 20    ==  False
     esCompuestoPersistente 200   ==  True
     esCompuestoPersistente 2021  ==  False

esCompuestoPersistente 20 == False

esCompuestoPersistente 200 == True

esCompuestoPersistente 2021 == False

compuestosPersistentes es la lista de los números compuestos persistentes. Por ejemplo,

     λ> take 10 compuestoPersistentes
     [200,204,206,208,320,322,324,325,326,328]

1 2	λ> take 10 compuestoPersistentes [200,204,206,208,320,322,324,325,326,328]

Comprobar con QuickCheck que todos los números de la forma 510+2310*k son números compuestos persistentes.

Soluciones

import Data.Numbers.Primes (isPrime, primes)
import Test.QuickCheck (Property, (==>), quickCheck)

-- 1ª solución
-- ===========

esCompuestoPersistente :: Integer -> Bool
esCompuestoPersistente n =
  esCompuesto n && all (not . isPrime) (transformados n)

-- (eCompuesto n) se verifica si n es un número compuesto. Por ejemplo,
--    esCompuesto 15  ==  True
--    esCompuesto 16  ==  True
--    esCompuesto 17  ==  False
esCompuesto :: Integer -> Bool
esCompuesto n =  n > 1 && not (isPrime n)

-- (transformados n) es la lista delos números obtenidos modificando uno
-- de los dígitos de n. Por ejemplo,
--    λ> transformados 27
--    [7,17,37,47,57,67,77,87,97,20,21,22,23,24,25,26,28,29]
transformados :: Integer -> [Integer]
transformados n = map read (aux (show n))
  where aux []     = []
        aux [x]    = [[y] | y <- ['0'..'9'], y /= x]
        aux (x:xs) = [y:xs | y <- ['0'..'9'], y /= x] ++
                     [x:ys | ys <- aux xs]

compuestosPersistentes :: [Integer]
compuestosPersistentes = filter esCompuestoPersistente [1..]

-- 2ª solución
-- ===========

esCompuestoPersistente2 :: Integer -> Bool
esCompuestoPersistente2 n =
  not (any (esTransformadoDe n) (takeWhile (<=10^m-1) primes))
  where m = length (show n)

-- (esTransformadoDe m n) se verifica si n se puede obtener modificando uno
-- de los dígitos de n. Por ejemplo,
--    esTransformadoDe 27 47  ==  True
--    esTransformadoDe 27 25  ==  True
--    esTransformadoDe 27 45  ==  False
--    esTransformadoDe 27 7   ==  True
--    esTransformadoDe 27 2   ==  False
esTransformadoDe :: Integer -> Integer -> Bool
esTransformadoDe m n =
  1 == length (filter (==False) (zipWith (==) xs zs))
  where xs = show m
        ys = show n
        zs = replicate (length xs - length ys) '0' ++ ys

compuestosPersistentes2 :: [Integer]
compuestosPersistentes2 = filter esCompuestoPersistente2 [1..]

-- 3ª solución
-- ===========

esCompuestoPersistente3 :: Integer -> Bool
esCompuestoPersistente3 n =
  null (primosTransformados n)

-- (primosTransformados n) es la lista de los números primos que se
-- puede obtener modificando uno de los dígitos de n. Por ejemplo,
--    primosTransformados 27   ==  [17,23,29,37,47,67,97,7]
--    primosTransformados 26   ==  [23,29]
--    primosTransformados 200  ==  []
--    primosTransformados 202  ==  [2]
primosTransformados :: Integer -> [Integer]
primosTransformados n =
  [x | x <- primosNdigitos p, difierenEnUnaPosicion n x] ++
  [x | x <- [read ('0' : tail ns)], isPrime x]
  where ns = show n
        p  = length ns

-- (difierenEnUnaPosicion m n) se verifica si los números m y n difieren
-- en una posición (suponiendo que m y n tienen el mismo número de
-- dígitos). Por ejemplo,
--    difierenEnUnaPosicion 325 375  ==  True
--    difierenEnUnaPosicion 325 357  ==  False
difierenEnUnaPosicion :: Integer -> Integer -> Bool
difierenEnUnaPosicion m n =
  1 == length (filter (==False) (zipWith (==) (show m) (show n)))

-- (primosNdigitos n) es la lista de los primos con n dígitos. Por
-- ejemplo,
--    λ> primosNdigitos 2
--    [11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97]
primosNdigitos :: Int -> [Integer]
primosNdigitos n = takeWhile (<=10^n-1) (dropWhile (<=10^(n-1)) primes)

compuestosPersistentes3 :: [Integer]
compuestosPersistentes3 = filter esCompuestoPersistente3 [1..]

-- 4ª solución
-- ===========

esCompuestoPersistente4 :: Integer -> Bool
esCompuestoPersistente4 n =
  null (primosTransformados2 n)

-- (primosTransformados2 n) es la lista de los números primos que se
-- puede obtener modificando uno de los dígitos de n. Por ejemplo,
--    primosTransformados2 27   ==  [17,23,29,37,47,67,97,7]
--    primosTransformados2 26   ==  [23,29]
--    primosTransformados2 200  ==  []
--    primosTransformados2 202  ==  [2]
primosTransformados2 :: Integer -> [Integer]
primosTransformados2 n =
  [x | x <- primosEntre (menorTransformado n) (mayorTransformado n)
     , difierenEnUnaPosicion n x] ++
  [x | x <- [read ('0' : tail ns)], isPrime x]
  where ns = show n
        p  = length ns

-- (primosEntre x y) lista de números prios mayores o iguales que x y
-- menores o iguales que y. Por ejemplo,
--    primosEntre 11 41  ==  [11,13,17,19,23,29,31,37,41]
primosEntre ::Integer -> Integer -> [Integer]
primosEntre x y = takeWhile (<= y) (dropWhile (< x) primes)

-- (menorTransformado x) es el menor número, con la misma cantidad de
-- dígitos que x, que se puede obtener modificando uno de los dígitos de
-- n. Por ejemplo,
--    menorTransformado 375   ==  175
--    menorTransformado 14    ==  11
--    menorTransformado 4     ==  1
--    menorTransformado 1145  ==  1115
menorTransformado :: Integer -> Integer
menorTransformado x
  | x <= 9    = 1
  | y > '1'   = read ('1' : ys)
  | otherwise = read ('1' : show (menorTransformado (read ys)))
  where (y:ys) = show x

-- (mayorTransformado x) es el mayor número, con la misma cantidad de
-- dígitos que x, que se puede obtener modificando uno de los dígitos de
-- n. Por ejemplo,
--    mayorTransformado 375   ==  975
--    mayorTransformado 93    ==  99
--    mayorTransformado 4     ==  9
--    mayorTransformado 9945  ==  9995
mayorTransformado :: Integer -> Integer
mayorTransformado x
  | x <= 9    = 9
  | y < '9'   = read ('9' : ys)
  | otherwise = read ('9' : show (mayorTransformado (read ys)))
  where (y:ys) = show x

compuestosPersistentes4 :: [Integer]
compuestosPersistentes4 = filter esCompuestoPersistente4 [1..]

-- Comparación de eficiencia
-- =========================

-- La comparación es
--    λ> compuestosPersistentes !! 1000
--    8180
--    (0.54 secs, 1,577,628,232 bytes)
--    λ> compuestosPersistentes2 !! 1000
--    8180
--    (10.13 secs, 15,883,929,392 bytes)
--    λ> compuestosPersistentes3 !! 1000
--    8180
--    (7.09 secs, 14,165,470,304 bytes)
--    λ> compuestosPersistentes4 !! 1000
--    8180
--    (6.54 secs, 13,332,608,480 bytes)

-- Propiedad
-- =========

-- La propiedad es
prop_compuestosPersistentes :: Integer -> Property
prop_compuestosPersistentes k =
  k > 0 ==> esCompuestoPersistente (510 + 2310 * k)

-- La comprobación de la propiedad es
--    λ> quickCheck prop_compuestosPersistentes
--    +++ OK, passed 100 tests.

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

import Data.Numbers.Primes (isPrime, primes)

import Test.QuickCheck (Property, (==>), quickCheck)

-- 1ª solución

-- ===========

esCompuestoPersistente :: Integer -> Bool

esCompuestoPersistente n =

esCompuesto n && all (not . isPrime) (transformados n)

-- (eCompuesto n) se verifica si n es un número compuesto. Por ejemplo,

-- esCompuesto 15 == True

-- esCompuesto 16 == True

-- esCompuesto 17 == False

esCompuesto :: Integer -> Bool

esCompuesto n = n > 1 && not (isPrime n)

-- (transformados n) es la lista delos números obtenidos modificando uno

-- de los dígitos de n. Por ejemplo,

-- λ> transformados 27

-- [7,17,37,47,57,67,77,87,97,20,21,22,23,24,25,26,28,29]

transformados :: Integer -> [Integer]

transformados n = map read (aux (show n))

where aux [] = []

aux [x] = [[y] | y <- ['0'..'9'], y /= x]

aux (x:xs) = [y:xs | y <- ['0'..'9'], y /= x] ++

[x:ys | ys <- aux xs]

compuestosPersistentes :: [Integer]

compuestosPersistentes = filter esCompuestoPersistente [1..]

-- 2ª solución

-- ===========

esCompuestoPersistente2 :: Integer -> Bool

esCompuestoPersistente2 n =

not (any (esTransformadoDe n) (takeWhile (<=10^m-1) primes))

where m = length (show n)

-- (esTransformadoDe m n) se verifica si n se puede obtener modificando uno

-- de los dígitos de n. Por ejemplo,

-- esTransformadoDe 27 47 == True

-- esTransformadoDe 27 25 == True

-- esTransformadoDe 27 45 == False

-- esTransformadoDe 27 7 == True

-- esTransformadoDe 27 2 == False

esTransformadoDe :: Integer -> Integer -> Bool

esTransformadoDe m n =

1 == length (filter (==False) (zipWith (==) xs zs))

where xs = show m

ys = show n

zs = replicate (length xs - length ys) '0' ++ ys

compuestosPersistentes2 :: [Integer]

compuestosPersistentes2 = filter esCompuestoPersistente2 [1..]

-- 3ª solución

-- ===========

esCompuestoPersistente3 :: Integer -> Bool

esCompuestoPersistente3 n =

null (primosTransformados n)

-- (primosTransformados n) es la lista de los números primos que se

-- puede obtener modificando uno de los dígitos de n. Por ejemplo,

-- primosTransformados 27 == [17,23,29,37,47,67,97,7]

-- primosTransformados 26 == [23,29]

-- primosTransformados 200 == []

-- primosTransformados 202 == [2]

primosTransformados :: Integer -> [Integer]

primosTransformados n =

[x | x <- primosNdigitos p, difierenEnUnaPosicion n x] ++

[x | x <- [read ('0' : tail ns)], isPrime x]

where ns = show n

p = length ns

-- (difierenEnUnaPosicion m n) se verifica si los números m y n difieren

-- en una posición (suponiendo que m y n tienen el mismo número de

-- dígitos). Por ejemplo,

-- difierenEnUnaPosicion 325 375 == True

-- difierenEnUnaPosicion 325 357 == False

difierenEnUnaPosicion :: Integer -> Integer -> Bool

difierenEnUnaPosicion m n =

1 == length (filter (==False) (zipWith (==) (show m) (show n)))

-- (primosNdigitos n) es la lista de los primos con n dígitos. Por

-- ejemplo,

-- λ> primosNdigitos 2

-- [11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97]

primosNdigitos :: Int -> [Integer]

primosNdigitos n = takeWhile (<=10^n-1) (dropWhile (<=10^(n-1)) primes)

compuestosPersistentes3 :: [Integer]

compuestosPersistentes3 = filter esCompuestoPersistente3 [1..]

-- 4ª solución

-- ===========

esCompuestoPersistente4 :: Integer -> Bool

esCompuestoPersistente4 n =

null (primosTransformados2 n)

-- (primosTransformados2 n) es la lista de los números primos que se

-- puede obtener modificando uno de los dígitos de n. Por ejemplo,

-- primosTransformados2 27 == [17,23,29,37,47,67,97,7]

-- primosTransformados2 26 == [23,29]

-- primosTransformados2 200 == []

-- primosTransformados2 202 == [2]

primosTransformados2 :: Integer -> [Integer]

primosTransformados2 n =

[x | x <- primosEntre (menorTransformado n) (mayorTransformado n)

, difierenEnUnaPosicion n x] ++

[x | x <- [read ('0' : tail ns)], isPrime x]

where ns = show n

p = length ns

-- (primosEntre x y) lista de números prios mayores o iguales que x y

-- menores o iguales que y. Por ejemplo,

-- primosEntre 11 41 == [11,13,17,19,23,29,31,37,41]

primosEntre ::Integer -> Integer -> [Integer]

primosEntre x y = takeWhile (<= y) (dropWhile (< x) primes)

-- (menorTransformado x) es el menor número, con la misma cantidad de

-- dígitos que x, que se puede obtener modificando uno de los dígitos de

-- n. Por ejemplo,

-- menorTransformado 375 == 175

-- menorTransformado 14 == 11

-- menorTransformado 4 == 1

-- menorTransformado 1145 == 1115

menorTransformado :: Integer -> Integer

menorTransformado x

| x <= 9 = 1

| y > '1' = read ('1' : ys)

| otherwise = read ('1' : show (menorTransformado (read ys)))

where (y:ys) = show x

-- (mayorTransformado x) es el mayor número, con la misma cantidad de

-- dígitos que x, que se puede obtener modificando uno de los dígitos de

-- n. Por ejemplo,

-- mayorTransformado 375 == 975

-- mayorTransformado 93 == 99

-- mayorTransformado 4 == 9

-- mayorTransformado 9945 == 9995

mayorTransformado :: Integer -> Integer

mayorTransformado x

| x <= 9 = 9

| y < '9' = read ('9' : ys)

| otherwise = read ('9' : show (mayorTransformado (read ys)))

where (y:ys) = show x

compuestosPersistentes4 :: [Integer]

compuestosPersistentes4 = filter esCompuestoPersistente4 [1..]

-- Comparación de eficiencia

-- =========================

-- La comparación es

-- λ> compuestosPersistentes !! 1000

-- 8180

-- (0.54 secs, 1,577,628,232 bytes)

-- λ> compuestosPersistentes2 !! 1000

-- 8180

-- (10.13 secs, 15,883,929,392 bytes)

-- λ> compuestosPersistentes3 !! 1000

-- 8180

-- (7.09 secs, 14,165,470,304 bytes)

-- λ> compuestosPersistentes4 !! 1000

-- 8180

-- (6.54 secs, 13,332,608,480 bytes)

-- Propiedad

-- =========

-- La propiedad es

prop_compuestosPersistentes :: Integer -> Property

prop_compuestosPersistentes k =

k > 0 ==> esCompuestoPersistente (510 + 2310 * k)

-- La comprobación de la propiedad es

-- λ> quickCheck prop_compuestosPersistentes

-- +++ OK, passed 100 tests.

Números bigenerados

PorJosé A. Alonso 14-enero-202121-enero-2021

Se dice que y es un generador de x si x es igual a la suma de y los dígitos de y. Por ejemplo, 1996 y 2014 son generadores de 2021 ya que

   2021 = 1996 + 1 + 9 + 9 + 6
   2021 = 2014 + 2 + 0 + 1 + 4

1 2	2021 = 1996 + 1 + 9 + 9 + 6 2021 = 2014 + 2 + 0 + 1 + 4

Un número bigenerado es un número que tiene exactamente 2 generadores. Por ejemplo,

2021 es un número bigenerados y sus generadores son 1996 y 2014
20 no es bigenerador porque no tiene ningún generador
21 no es bigenerador porque tiene sólo un generador (el 15).
101 es el menor número bigenerado ysus generadores son 91 y 100.

Definir las funciones

   esBigenerado :: Integer -> Bool
   bigenerados  :: [Integer]

1 2	esBigenerado :: Integer -> Bool bigenerados :: [Integer]

tales que

(esBigenerado x) se verifica si x es bigenerado. Por ejemplo,

     esBigenerado 2021  ==  True
     esBigenerado 20    ==  False
     esBigenerado 21    ==  False
     esBigenerado 101   ==  True

esBigenerado 2021 == True

esBigenerado 20 == False

esBigenerado 21 == False

esBigenerado 101 == True

bigenerados es la lista de los números bigenerados. Por ejemplo,

     λ> take 12 bigenerados
     [101,103,105,107,109,111,113,115,117,202,204,206]

1 2	λ> take 12 bigenerados [101,103,105,107,109,111,113,115,117,202,204,206]

Comprobar con QuickCheck que la lista de los números bigenerados es infinita; es decir, para cualquier número positivo n existe un y mayor que x que es bigenerado.

Soluciones

import Test.QuickCheck (Property, (==>), quickCheck)

esBigenerado :: Integer -> Bool
esBigenerado x = length (generadores x) == 2

-- (generadores x) es la lista de los generadores de x. Por ejemplo,
--    generadores 2021  ==  [1996,2014]
--    generadores 20    ==  []
--    generadores 21    ==  [15]
--    generadores 101   ==  [91,100]
generadores :: Integer -> [Integer]
generadores x = filter (esGenerador x) [1..x]

-- (esGenerador x y) se verifica si y es un generador de x. Por ejemplo,
--    esGenerador 818 796  ==  True
--    esGenerador 818 805  ==  True
esGenerador :: Integer -> Integer -> Bool
esGenerador x y = x == y + sumaDigitos y

-- (sumaDigitos n) es la suma de los dígitos de n. Por ejemplo,
--    sumaDigitos 2021  ==  5
sumaDigitos :: Integer -> Integer
sumaDigitos = sum . digitos

-- (digitos n) es la lista de los dígitos de n. Por ejemplo,
--    digitos 2021  ==  [2,0,2,1]
digitos :: Integer -> [Integer]
digitos x = [read [c] | c <- show x]

bigenerados :: [Integer]
bigenerados = filter esBigenerado [1..]

-- La propiedad es
prop_bigenerados :: Integer -> Property
prop_bigenerados n =
  n >= 0 ==> any esBigenerado [n+1..]

-- La comprobación es
--    λ> quickCheck prop_bigenerados
--    +++ OK, passed 100 tests.

import Test.QuickCheck (Property, (==>), quickCheck)

esBigenerado :: Integer -> Bool

esBigenerado x = length (generadores x) == 2

-- (generadores x) es la lista de los generadores de x. Por ejemplo,

-- generadores 2021 == [1996,2014]

-- generadores 20 == []

-- generadores 21 == [15]

-- generadores 101 == [91,100]

generadores :: Integer -> [Integer]

generadores x = filter (esGenerador x) [1..x]

-- (esGenerador x y) se verifica si y es un generador de x. Por ejemplo,

-- esGenerador 818 796 == True

-- esGenerador 818 805 == True

esGenerador :: Integer -> Integer -> Bool

esGenerador x y = x == y + sumaDigitos y

-- (sumaDigitos n) es la suma de los dígitos de n. Por ejemplo,

-- sumaDigitos 2021 == 5

sumaDigitos :: Integer -> Integer

sumaDigitos = sum . digitos

-- (digitos n) es la lista de los dígitos de n. Por ejemplo,

-- digitos 2021 == [2,0,2,1]

digitos :: Integer -> [Integer]

digitos x = [read [c] | c <- show x]

bigenerados :: [Integer]

bigenerados = filter esBigenerado [1..]

-- La propiedad es

prop_bigenerados :: Integer -> Property

prop_bigenerados n =

n >= 0 ==> any esBigenerado [n+1..]

-- La comprobación es

-- λ> quickCheck prop_bigenerados

-- +++ OK, passed 100 tests.

Nuevas soluciones

En los comentarios se pueden escribir nuevas soluciones.
El código se debe escribir entre una línea con <pre lang="haskell"> y otra con </pre>

Caminos reducidos

PorJosé A. Alonso 5-junio-20202-enero-2021

Un camino es una sucesión de pasos en una de las cuatros direcciones Norte, Sur, Este, Oeste. Ir en una dirección y a continuación en la opuesta es un esfuerzo que se puede reducir, Por ejemplo, el camino [Norte,Sur,Este,Sur] se puede reducir a [Este,Sur].

Un camino se dice que es reducido si no tiene dos pasos consecutivos en direcciones opuesta. Por ejemplo, [Este,Sur] es reducido y [Norte,Sur,Este,Sur] no lo es.

En Haskell, las direcciones y los caminos se pueden definir por

   data Direccion = N | S | E | O deriving (Show, Eq)
   type Camino = [Direccion]

1 2	data Direccion = N \| S \| E \| O deriving (Show, Eq) type Camino = [Direccion]

Definir la función

   reducido :: Camino -> Camino

1	reducido :: Camino -> Camino

tal que (reducido ds) es el camino reducido equivalente al camino ds. Por ejemplo,

   reducido []                              ==  []
   reducido [N]                             ==  [N]
   reducido [N,O]                           ==  [N,O]
   reducido [N,O,E]                         ==  [N]
   reducido [N,O,E,S]                       ==  [] 
   reducido [N,O,S,E]                       ==  [N,O,S,E]
   reducido [S,S,S,N,N,N]                   ==  []
   reducido [N,S,S,E,O,N]                   ==  []
   reducido [N,S,S,E,O,N,O]                 ==  [O]
   reducido (take (10^7) (cycle [N,E,O,S])) ==  []

reducido [] == []

reducido [N] == [N]

reducido [N,O] == [N,O]

reducido [N,O,E] == [N]

reducido [N,O,E,S] == []

reducido [N,O,S,E] == [N,O,S,E]

reducido [S,S,S,N,N,N] == []

reducido [N,S,S,E,O,N] == []

reducido [N,S,S,E,O,N,O] == [O]

reducido (take (10^7) (cycle [N,E,O,S])) == []

Nótese que en el penúltimo ejemplo las reducciones son

       [N,S,S,E,O,N,O]  
   --> [S,E,O,N,O]  
   --> [S,N,O]  
   --> [O]

[N,S,S,E,O,N,O]

--> [S,E,O,N,O]

--> [S,N,O]

--> [O]

Soluciones

data Direccion = N | S | E | O deriving (Show, Eq)

type Camino = [Direccion]

-- 1ª solución (por recursión):
reducido1 :: Camino -> Camino
reducido1 [] = []
reducido1 (d:ds) | null ds'                = [d]
                 | d == opuesta (head ds') = tail ds'
                 | otherwise               = d:ds'
    where ds' = reducido1 ds

opuesta :: Direccion -> Direccion
opuesta N = S
opuesta S = N
opuesta E = O
opuesta O = E

-- 2ª solución (por plegado)
reducido2 :: Camino -> Camino
reducido2 = foldr aux []
    where aux N (S:xs) = xs
          aux S (N:xs) = xs
          aux E (O:xs) = xs
          aux O (E:xs) = xs
          aux x xs     = x:xs

-- 3ª solución 
reducido3 :: Camino -> Camino
reducido3 []       = []
reducido3 (N:S:ds) = reducido3 ds
reducido3 (S:N:ds) = reducido3 ds
reducido3 (E:O:ds) = reducido3 ds
reducido3 (O:E:ds) = reducido3 ds
reducido3 (d:ds) | null ds'                = [d]
                 | d == opuesta (head ds') = tail ds'
                 | otherwise               = d:ds'
    where ds' = reducido3 ds

-- 4ª solución
reducido4 :: Camino -> Camino
reducido4 ds = reverse (aux ([],ds)) where 
    aux (N:xs, S:ys) = aux (xs,ys)
    aux (S:xs, N:ys) = aux (xs,ys)
    aux (E:xs, O:ys) = aux (xs,ys)
    aux (O:xs, E:ys) = aux (xs,ys)
    aux (  xs, y:ys) = aux (y:xs,ys)
    aux (  xs,   []) = xs

-- Comparación de eficiencia
--    ghci> reducido1 (take (10^6) (cycle [N,E,O,S]))
--    []
--    (3.87 secs, 460160736 bytes)
--    ghci> reducido2 (take (10^6) (cycle [N,E,O,S]))
--    []
--    (1.16 secs, 216582880 bytes)
--    ghci> reducido3 (take (10^6) (cycle [N,E,O,S]))
--    []
--    (0.58 secs, 98561872 bytes)
--    ghci> reducido4 (take (10^6) (cycle [N,E,O,S]))
--    []
--    (0.64 secs, 176154640 bytes)
--    
--    ghci> reducido3 (take (10^7) (cycle [N,E,O,S]))
--    []
--    (5.43 secs, 962694784 bytes)
--    ghci> reducido4 (take (10^7) (cycle [N,E,O,S]))
--    []
--    (9.29 secs, 1722601528 bytes)
-- 
--    ghci> length $ reducido3 (take 2000000 $ cycle [N,O,N,S,E,N,S,O,S,S])
--    400002
--    (4.52 secs, 547004960 bytes)
--    ghci> length $ reducido4 (take 2000000 $ cycle [N,O,N,S,E,N,S,O,S,S])
--    400002
--    
--    ghci> let n=10^6 in reducido1 (replicate n N ++ replicate n S)
--    []
--    (7.35 secs, 537797096 bytes)
--    ghci> let n=10^6 in reducido2 (replicate n N ++ replicate n S)
--    []
--    (2.30 secs, 244553404 bytes)
--    ghci> let n=10^6 in reducido3 (replicate n N ++ replicate n S)
--    []
--    (8.08 secs, 545043608 bytes)
--    ghci> let n=10^6 in reducido4 (replicate n N ++ replicate n S)
--    []
--    (1.96 secs, 205552240 bytes)

data Direccion = N | S | E | O deriving (Show, Eq)

type Camino = [Direccion]

-- 1ª solución (por recursión):

reducido1 :: Camino -> Camino

reducido1 [] = []

reducido1 (d:ds) | null ds' = [d]

| d == opuesta (head ds') = tail ds'

| otherwise = d:ds'

where ds' = reducido1 ds

opuesta :: Direccion -> Direccion

opuesta N = S

opuesta S = N

opuesta E = O

opuesta O = E

-- 2ª solución (por plegado)

reducido2 :: Camino -> Camino

reducido2 = foldr aux []

where aux N (S:xs) = xs

aux S (N:xs) = xs

aux E (O:xs) = xs

aux O (E:xs) = xs

aux x xs = x:xs

-- 3ª solución

reducido3 :: Camino -> Camino

reducido3 [] = []

reducido3 (N:S:ds) = reducido3 ds

reducido3 (S:N:ds) = reducido3 ds

reducido3 (E:O:ds) = reducido3 ds

reducido3 (O:E:ds) = reducido3 ds

reducido3 (d:ds) | null ds' = [d]

| d == opuesta (head ds') = tail ds'

| otherwise = d:ds'

where ds' = reducido3 ds

-- 4ª solución

reducido4 :: Camino -> Camino

reducido4 ds = reverse (aux ([],ds)) where

aux (N:xs, S:ys) = aux (xs,ys)

aux (S:xs, N:ys) = aux (xs,ys)

aux (E:xs, O:ys) = aux (xs,ys)

aux (O:xs, E:ys) = aux (xs,ys)

aux ( xs, y:ys) = aux (y:xs,ys)

aux ( xs, []) = xs

-- Comparación de eficiencia

-- ghci> reducido1 (take (10^6) (cycle [N,E,O,S]))

-- []

-- (3.87 secs, 460160736 bytes)

-- ghci> reducido2 (take (10^6) (cycle [N,E,O,S]))

-- []

-- (1.16 secs, 216582880 bytes)

-- ghci> reducido3 (take (10^6) (cycle [N,E,O,S]))

-- []

-- (0.58 secs, 98561872 bytes)

-- ghci> reducido4 (take (10^6) (cycle [N,E,O,S]))

-- []

-- (0.64 secs, 176154640 bytes)

-- ghci> reducido3 (take (10^7) (cycle [N,E,O,S]))

-- []

-- (5.43 secs, 962694784 bytes)

-- ghci> reducido4 (take (10^7) (cycle [N,E,O,S]))

-- []

-- (9.29 secs, 1722601528 bytes)

-- ghci> length $ reducido3 (take 2000000 $ cycle [N,O,N,S,E,N,S,O,S,S])

-- 400002

-- (4.52 secs, 547004960 bytes)

-- ghci> length $ reducido4 (take 2000000 $ cycle [N,O,N,S,E,N,S,O,S,S])

-- 400002

-- ghci> let n=10^6 in reducido1 (replicate n N ++ replicate n S)

-- []

-- (7.35 secs, 537797096 bytes)

-- ghci> let n=10^6 in reducido2 (replicate n N ++ replicate n S)

-- []

-- (2.30 secs, 244553404 bytes)

-- ghci> let n=10^6 in reducido3 (replicate n N ++ replicate n S)

-- []

-- (8.08 secs, 545043608 bytes)

-- ghci> let n=10^6 in reducido4 (replicate n N ++ replicate n S)

-- []

-- (1.96 secs, 205552240 bytes)

La sucesión ECG

PorJosé A. Alonso 1-junio-20202-enero-2021

La sucesión ECG estás definida por a(1) = 1, a(2) = 2 y, para n >= 3, a(n) es el menor natural que aún no está en la sucesión tal que a(n) tiene algún divisor común con a(n-1).

Los primeros términos de la sucesión son 1, 2, 4, 6, 3, 9, 12, 8, 10, 5, 15, …

Al dibujar su gráfica, se parece a la de los electrocardiogramas (abreviadamente, ECG). Por ello, la sucesión se conoce como la sucesión ECG.

Definir las funciones

   sucECG :: [Integer]
   graficaSucECG :: Int -> IO ()

1 2	sucECG :: [Integer] graficaSucECG :: Int -> IO ()

tales que

sucECG es la lista de los términos de la sucesión ECG. Por ejemplo,

     λ> take 20 sucECG
     [1,2,4,6,3,9,12,8,10,5,15,18,14,7,21,24,16,20,22,11]
     λ> sucECG !! 6000
     6237

λ> take 20 sucECG

[1,2,4,6,3,9,12,8,10,5,15,18,14,7,21,24,16,20,22,11]

λ> sucECG !! 6000

6237

(graficaSucECG n) dibuja la gráfica de los n primeros términos de la sucesión ECG. Por ejemplo, (graficaSucECG 160) dibuja

Soluciones

import Data.List (delete)
import Graphics.Gnuplot.Simple

sucECG :: [Integer]
sucECG = 1 : ecg 2 [2..]
  where ecg x zs = f zs
          where f (y:ys) | gcd x y > 1 = y : ecg y (delete y zs)
                         | otherwise   = f ys

graficaSucECG :: Int -> IO ()
graficaSucECG n =
  plotList [ Key Nothing
           , PNG "La_sucesion_ECG.png" 
           ]
           (take n sucECG)

import Data.List (delete)

import Graphics.Gnuplot.Simple

sucECG :: [Integer]

sucECG = 1 : ecg 2 [2..]

where ecg x zs = f zs

where f (y:ys) | gcd x y > 1 = y : ecg y (delete y zs)

| otherwise = f ys

graficaSucECG :: Int -> IO ()

graficaSucECG n =

plotList [ Key Nothing

, PNG "La_sucesion_ECG.png"

]

(take n sucECG)

Operaciones con series de potencias

PorJosé A. Alonso 29-mayo-202025-marzo-2022

Una serie de potencias es una serie de la forma

   a₀ + a₁x + a₂x² + a₃x³ + ...

1	a₀ + a₁x + a₂x² + a₃x³ + ...

Las series de potencias se pueden representar mediante listas infinitas. Por ejemplo, la serie de la función exponencial es

   e^x = 1 + x + x²/2! + x³/3! + ...

1	e^x = 1 + x + x²/2! + x³/3! + ...

y se puede representar por [1, 1, 1/2, 1/6, 1/24, 1/120, …]

Las operaciones con series se pueden ver como una generalización de las de los polinomios.

En lo que sigue, usaremos el tipo (Serie a) para representar las series de potencias con coeficientes en a y su definición es

   type Serie a = [a]

1	type Serie a = [a]

Definir las siguientes funciones

   opuesta      :: Num a => Serie a -> Serie a
   suma         :: Num a => Serie a -> Serie a -> Serie a
   resta        :: Num a => Serie a -> Serie a -> Serie a
   producto     :: Num a => Serie a -> Serie a -> Serie a
   cociente     :: Fractional a => Serie a -> Serie a -> Serie a
   derivada     :: (Num a, Enum a) => Serie a -> Serie a
   integral     :: (Fractional a, Enum a) => Serie a -> Serie a
   expx         :: Serie Rational

opuesta :: Num a => Serie a -> Serie a

suma :: Num a => Serie a -> Serie a -> Serie a

resta :: Num a => Serie a -> Serie a -> Serie a

producto :: Num a => Serie a -> Serie a -> Serie a

cociente :: Fractional a => Serie a -> Serie a -> Serie a

derivada :: (Num a, Enum a) => Serie a -> Serie a

integral :: (Fractional a, Enum a) => Serie a -> Serie a

expx :: Serie Rational

tales que

(opuesta xs) es la opuesta de la serie xs. Por ejemplo,

     λ> take 7 (opuesta [-6,-4..])
     [6,4,2,0,-2,-4,-6]

1 2	λ> take 7 (opuesta [-6,-4..]) [6,4,2,0,-2,-4,-6]

(suma xs ys) es la suma de las series xs e ys. Por ejemplo,

     λ> take 7 (suma [1,3..] [2,4..])
     [3,7,11,15,19,23,27]

1 2	λ> take 7 (suma [1,3..] [2,4..]) [3,7,11,15,19,23,27]

(resta xs ys) es la resta de las series xs es ys. Por ejemplo,

     λ> take 7 (resta [3,5..] [2,4..])
     [1,1,1,1,1,1,1]
     λ> take 7 (resta ([3,7,11,15,19,23,27] ++ repeat 0) [1,3..])
     [2,4,6,8,10,12,14]

λ> take 7 (resta [3,5..] [2,4..])

[1,1,1,1,1,1,1]

λ> take 7 (resta ([3,7,11,15,19,23,27] ++ repeat 0) [1,3..])

[2,4,6,8,10,12,14]

(producto xs ys) es el producto de las series xs e ys. Por ejemplo,

     λ> take 7 (producto [3,5..] [2,4..])
     [6,22,52,100,170,266,392]

1 2	λ> take 7 (producto [3,5..] [2,4..]) [6,22,52,100,170,266,392]

(cociente xs ys) es el cociente de las series xs e ys. Por ejemplo,

     λ> take 7 (cociente ([6,22,52,100,170,266,392] ++ repeat 0) [3,5..])
     [2.0,4.0,6.0,8.0,10.0,12.0,14.0]

1 2	λ> take 7 (cociente ([6,22,52,100,170,266,392] ++ repeat 0) [3,5..]) [2.0,4.0,6.0,8.0,10.0,12.0,14.0]

(derivada xs) es la derivada de la serie xs. Por ejemplo,

     λ> take 7 (derivada [2,4..])
     [4,12,24,40,60,84,112]

1 2	λ> take 7 (derivada [2,4..]) [4,12,24,40,60,84,112]

(integral xs) es la integral de la serie xs. Por ejemplo,

     λ> take 7 (integral ([4,12,24,40,60,84,112] ++ repeat 0))
     [0.0,4.0,6.0,8.0,10.0,12.0,14.0]

1 2	λ> take 7 (integral ([4,12,24,40,60,84,112] ++ repeat 0)) [0.0,4.0,6.0,8.0,10.0,12.0,14.0]

expx es la serie de la función exponencial. Por ejemplo,

     λ> take 8 expx
     [1 % 1,1 % 1,1 % 2,1 % 6,1 % 24,1 % 120,1 % 720,1 % 5040]
     λ> take 8 (derivada expx)
     [1 % 1,1 % 1,1 % 2,1 % 6,1 % 24,1 % 120,1 % 720,1 % 5040]
     λ> take 8 (integral expx)
     [0 % 1,1 % 1,1 % 2,1 % 6,1 % 24,1 % 120,1 % 720,1 % 5040]

λ> take 8 expx

[1 % 1,1 % 1,1 % 2,1 % 6,1 % 24,1 % 120,1 % 720,1 % 5040]

λ> take 8 (derivada expx)

[1 % 1,1 % 1,1 % 2,1 % 6,1 % 24,1 % 120,1 % 720,1 % 5040]

λ> take 8 (integral expx)

[0 % 1,1 % 1,1 % 2,1 % 6,1 % 24,1 % 120,1 % 720,1 % 5040]

Soluciones

type Serie a = [a] 

opuesta :: Num a => Serie a -> Serie a
opuesta = map negate

suma :: Num a => Serie a -> Serie a -> Serie a
suma = zipWith (+)

resta :: Num a => Serie a -> Serie a -> Serie a
resta xs ys = suma xs (opuesta ys)

producto :: Num a => Serie a -> Serie a -> Serie a
producto (x:xs) zs@(y:ys) = 
    x*y : suma (producto xs zs) (map (x*) ys)

cociente :: Fractional a => Serie a -> Serie a -> Serie a
cociente (x:xs) (y:ys) = zs 
    where zs = x/y : map (/y) (resta xs (producto zs ys))  

derivada :: (Num a, Enum a) => Serie a -> Serie a
derivada (_:xs) = zipWith (*) xs [1..]

integral :: (Fractional a, Enum a) => Serie a -> Serie a
integral xs = 0 : zipWith (/) xs [1..]

expx :: Serie Rational
expx = map (1/) (map fromIntegral factoriales)

-- factoriales es la lista de los factoriales. Por ejemplo, 
--    take 7 factoriales  ==  [1,1,2,6,24,120,720]
factoriales :: [Integer]
factoriales = 1 : scanl1 (*) [1..]

type Serie a = [a]

opuesta :: Num a => Serie a -> Serie a

opuesta = map negate

suma :: Num a => Serie a -> Serie a -> Serie a

suma = zipWith (+)

resta :: Num a => Serie a -> Serie a -> Serie a

resta xs ys = suma xs (opuesta ys)

producto :: Num a => Serie a -> Serie a -> Serie a

producto (x:xs) zs@(y:ys) =

x*y : suma (producto xs zs) (map (x*) ys)

cociente :: Fractional a => Serie a -> Serie a -> Serie a

cociente (x:xs) (y:ys) = zs

where zs = x/y : map (/y) (resta xs (producto zs ys))

derivada :: (Num a, Enum a) => Serie a -> Serie a

derivada (_:xs) = zipWith (*) xs [1..]

integral :: (Fractional a, Enum a) => Serie a -> Serie a

integral xs = 0 : zipWith (/) xs [1..]

expx :: Serie Rational

expx = map (1/) (map fromIntegral factoriales)

-- factoriales es la lista de los factoriales. Por ejemplo,

-- take 7 factoriales == [1,1,2,6,24,120,720]

factoriales :: [Integer]

factoriales = 1 : scanl1 (*) [1..]

Las sucesiones de Loomis

PorJosé A. Alonso 22-mayo-202029-mayo-2020

La sucesión de Loomis generada por un número entero positivo x es la sucesión cuyos términos se definen por

f(0) es x
f(n) es la suma de f(n-1) y el producto de los dígitos no nulos de f(n-1)

Los primeros términos de las primeras sucesiones de Loomis son

Generada por 1: 1, 2, 4, 8, 16, 22, 26, 38, 62, 74, 102, 104, 108, 116, 122, …
Generada por 2: 2, 4, 8, 16, 22, 26, 38, 62, 74, 102, 104, 108, 116, 122, 126, …
Generada por 3: 3, 6, 12, 14, 18, 26, 38, 62, 74, 102, 104, 108, 116, 122, 126, …
Generada por 4: 4, 8, 16, 22, 26, 38, 62, 74, 102, 104, 108, 116, 122, 126, 138, …
Generada por 5: 5, 10, 11, 12, 14, 18, 26, 38, 62, 74, 102, 104, 108, 116, 122, …

Se observa que a partir de un término todas coinciden con la generada por 1. Dicho término se llama el punto de convergencia. Por ejemplo,

la generada por 2 converge a 2
la generada por 3 converge a 26
la generada por 4 converge a 4
la generada por 5 converge a 26

Definir las siguientes funciones

   sucLoomis           :: Integer -> [Integer]
   convergencia        :: Integer -> Integer
   graficaConvergencia :: [Integer] -> IO ()

sucLoomis :: Integer -> [Integer]

convergencia :: Integer -> Integer

graficaConvergencia :: [Integer] -> IO ()

tales que

(sucLoomis x) es la sucesión de Loomis generada por x. Por ejemplo,

     λ> take 15 (sucLoomis 1)
     [1,2,4,8,16,22,26,38,62,74,102,104,108,116,122]
     λ> take 15 (sucLoomis 2)
     [2,4,8,16,22,26,38,62,74,102,104,108,116,122,126]
     λ> take 15 (sucLoomis 3)
     [3,6,12,14,18,26,38,62,74,102,104,108,116,122,126]
     λ> take 15 (sucLoomis 4)
     [4,8,16,22,26,38,62,74,102,104,108,116,122,126,138]
     λ> take 15 (sucLoomis 5)
     [5,10,11,12,14,18,26,38,62,74,102,104,108,116,122]
     λ> take 15 (sucLoomis 20)
     [20,22,26,38,62,74,102,104,108,116,122,126,138,162,174]
     λ> take 15 (sucLoomis 100)
     [100,101,102,104,108,116,122,126,138,162,174,202,206,218,234]
     λ> sucLoomis 1 !! (2*10^5)
     235180736652

λ> take 15 (sucLoomis 1)

[1,2,4,8,16,22,26,38,62,74,102,104,108,116,122]

λ> take 15 (sucLoomis 2)

[2,4,8,16,22,26,38,62,74,102,104,108,116,122,126]

λ> take 15 (sucLoomis 3)

[3,6,12,14,18,26,38,62,74,102,104,108,116,122,126]

λ> take 15 (sucLoomis 4)

[4,8,16,22,26,38,62,74,102,104,108,116,122,126,138]

λ> take 15 (sucLoomis 5)

[5,10,11,12,14,18,26,38,62,74,102,104,108,116,122]

λ> take 15 (sucLoomis 20)

[20,22,26,38,62,74,102,104,108,116,122,126,138,162,174]

λ> take 15 (sucLoomis 100)

[100,101,102,104,108,116,122,126,138,162,174,202,206,218,234]

λ> sucLoomis 1 !! (2*10^5)

235180736652

(convergencia x) es el término de convergencia de la sucesioń de Loomis generada por x xon la geerada por 1. Por ejemplo,

     convergencia  2      ==  2
     convergencia  3      ==  26
     convergencia  4      ==  4
     convergencia 17      ==  38
     convergencia 19      ==  102
     convergencia 43      ==  162
     convergencia 27      ==  202
     convergencia 58      ==  474
     convergencia 63      ==  150056
     convergencia 81      ==  150056
     convergencia 89      ==  150056
     convergencia (10^12) ==  1000101125092

convergencia 2 == 2

convergencia 3 == 26

convergencia 4 == 4

convergencia 17 == 38

convergencia 19 == 102

convergencia 43 == 162

convergencia 27 == 202

convergencia 58 == 474

convergencia 63 == 150056

convergencia 81 == 150056

convergencia 89 == 150056

convergencia (10^12) == 1000101125092

(graficaConvergencia xs) dibuja la gráfica de los términos de convergencia de las sucesiones de Loomis generadas por los elementos de xs. Por ejemplo, (graficaConvergencia ([1..50]) dibuja

y graficaConvergencia ([1..148] \ [63,81,89,137]) dibuja

Soluciones

import Data.List               ((\\))
import Data.Char               (digitToInt)
import Graphics.Gnuplot.Simple (plotList, Attribute (Key, Title, XRange, PNG))

-- 1ª definición de sucLoomis
-- ==========================

sucLoomis :: Integer -> [Integer]
sucLoomis x = map (loomis x) [0..]

loomis :: Integer -> Integer -> Integer
loomis x 0 = x
loomis x n = y + productoDigitosNoNulos y
  where y = loomis x (n-1)

productoDigitosNoNulos :: Integer -> Integer
productoDigitosNoNulos = product . digitosNoNulos

digitosNoNulos :: Integer -> [Integer]
digitosNoNulos x =
  [read [c] | c <- show x, c /= '0']

-- 2ª definición de sucLoomis
-- ==========================

sucLoomis2 :: Integer -> [Integer]
sucLoomis2 = iterate siguienteLoomis 

siguienteLoomis :: Integer -> Integer
siguienteLoomis y = y + productoDigitosNoNulos y

-- 3ª definición de sucLoomis
-- ==========================

sucLoomis3 :: Integer -> [Integer]
sucLoomis3 =
  iterate ((+) <*> product .
           map (toInteger . digitToInt) .
           filter (/= '0') . show)

-- Comparación de eficiencia
-- =========================

--    λ> sucLoomis 1 !! 30000
--    6571272766
--    (2.45 secs, 987,955,944 bytes)
--    λ> sucLoomis2 1 !! 30000
--    6571272766
--    (2.26 secs, 979,543,328 bytes)
--    λ> sucLoomis3 1 !! 30000
--    6571272766
--    (0.31 secs, 88,323,832 bytes)

-- 1ª definición de convergencia
-- =============================

convergencia1 :: Integer -> Integer
convergencia1 x =
  head (dropWhile noEnSucLoomisDe1 (sucLoomis x))

noEnSucLoomisDe1 :: Integer -> Bool
noEnSucLoomisDe1 x = not (pertenece x sucLoomisDe1)

sucLoomisDe1 :: [Integer]
sucLoomisDe1 = sucLoomis 1

pertenece :: Integer -> [Integer] -> Bool
pertenece x ys =
  x == head (dropWhile (<x) ys)

-- 2ª definición de convergencia
-- =============================

convergencia2 :: Integer -> Integer
convergencia2 = aux (sucLoomis3 1) . sucLoomis3
 where aux as@(x:xs) bs@(y:ys) | x == y    = x
                               | x < y     = aux xs bs
                               | otherwise = aux as ys

-- 3ª definición de convergencia
-- =============================

convergencia3 :: Integer -> Integer
convergencia3 = head . interseccion (sucLoomis3 1) . sucLoomis3
 
-- (interseccion xs ys) es la intersección entre las listas ordenadas xs
-- e ys. Por ejemplo,
--    λ> take 10 (interseccion (sucLoomis3 1) (sucLoomis3 2))
--    [2,4,8,16,22,26,38,62,74,102]
interseccion :: Ord a => [a] -> [a] -> [a]
interseccion = aux
  where aux as@(x:xs) bs@(y:ys) = case compare x y of
                                    LT ->     aux xs bs
                                    EQ -> x : aux xs ys
                                    GT ->     aux as ys
        aux _         _         = []                           

-- 4ª definición de convergencia
-- =============================

convergencia4 :: Integer -> Integer
convergencia4 x = perteneceA (sucLoomis3 x) 1
  where perteneceA (y:ys) n | y == c    = y
                            | otherwise = perteneceA ys c
          where c = head $ dropWhile (< y) $ sucLoomis3 n

-- Comparación de eficiencia
-- =========================

--    λ> convergencia1 (10^4)
--    150056
--    (2.94 secs, 1,260,809,808 bytes)
--    λ> convergencia2 (10^4)
--    150056
--    (0.03 secs, 700,240 bytes)
--    λ> convergencia3 (10^4)
--    150056
--    (0.03 secs, 1,165,496 bytes)
--    λ> convergencia4 (10^4)
--    150056
--    (0.02 secs, 1,119,648 bytes)
--    
--    λ> convergencia2 (10^12)
--    1000101125092
--    (1.81 secs, 714,901,080 bytes)
--    λ> convergencia3 (10^12)
--    1000101125092
--    (1.92 secs, 744,932,184 bytes)
--    λ> convergencia4 (10^12)
--    1000101125092
--    (1.82 secs, 941,053,328 bytes)

-- Definición de graficaConvergencia
-- ==================================

graficaConvergencia :: [Integer] -> IO ()
graficaConvergencia xs =
  plotList [ Key Nothing
           , Title "Convergencia de sucesiones de Loomis"
           , XRange (fromIntegral (minimum xs),fromIntegral (maximum xs))
           , PNG "Las_sucesiones_de_Loomis_2.png"
           ]
           [(x,convergencia2 x) | x <- xs]

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

import Data.List ((\\))

import Data.Char (digitToInt)

import Graphics.Gnuplot.Simple (plotList, Attribute (Key, Title, XRange, PNG))

-- 1ª definición de sucLoomis

-- ==========================

sucLoomis :: Integer -> [Integer]

sucLoomis x = map (loomis x) [0..]

loomis :: Integer -> Integer -> Integer

loomis x 0 = x

loomis x n = y + productoDigitosNoNulos y

where y = loomis x (n-1)

productoDigitosNoNulos :: Integer -> Integer

productoDigitosNoNulos = product . digitosNoNulos

digitosNoNulos :: Integer -> [Integer]

digitosNoNulos x =

[read [c] | c <- show x, c /= '0']

-- 2ª definición de sucLoomis

-- ==========================

sucLoomis2 :: Integer -> [Integer]

sucLoomis2 = iterate siguienteLoomis

siguienteLoomis :: Integer -> Integer

siguienteLoomis y = y + productoDigitosNoNulos y

-- 3ª definición de sucLoomis

-- ==========================

sucLoomis3 :: Integer -> [Integer]

sucLoomis3 =

iterate ((+) <*> product .

map (toInteger . digitToInt) .

filter (/= '0') . show)

-- Comparación de eficiencia

-- =========================

-- λ> sucLoomis 1 !! 30000

-- 6571272766

-- (2.45 secs, 987,955,944 bytes)

-- λ> sucLoomis2 1 !! 30000

-- 6571272766

-- (2.26 secs, 979,543,328 bytes)

-- λ> sucLoomis3 1 !! 30000

-- 6571272766

-- (0.31 secs, 88,323,832 bytes)

-- 1ª definición de convergencia

-- =============================

convergencia1 :: Integer -> Integer

convergencia1 x =

head (dropWhile noEnSucLoomisDe1 (sucLoomis x))

noEnSucLoomisDe1 :: Integer -> Bool

noEnSucLoomisDe1 x = not (pertenece x sucLoomisDe1)

sucLoomisDe1 :: [Integer]

sucLoomisDe1 = sucLoomis 1

pertenece :: Integer -> [Integer] -> Bool

pertenece x ys =

x == head (dropWhile (<x) ys)

-- 2ª definición de convergencia

-- =============================

convergencia2 :: Integer -> Integer

convergencia2 = aux (sucLoomis3 1) . sucLoomis3

where aux as@(x:xs) bs@(y:ys) | x == y = x

| x < y = aux xs bs

| otherwise = aux as ys

-- 3ª definición de convergencia

-- =============================

convergencia3 :: Integer -> Integer

convergencia3 = head . interseccion (sucLoomis3 1) . sucLoomis3

-- (interseccion xs ys) es la intersección entre las listas ordenadas xs

-- e ys. Por ejemplo,

-- λ> take 10 (interseccion (sucLoomis3 1) (sucLoomis3 2))

-- [2,4,8,16,22,26,38,62,74,102]

interseccion :: Ord a => [a] -> [a] -> [a]

interseccion = aux

where aux as@(x:xs) bs@(y:ys) = case compare x y of

LT -> aux xs bs

EQ -> x : aux xs ys

GT -> aux as ys

aux _ _ = []

-- 4ª definición de convergencia

-- =============================

convergencia4 :: Integer -> Integer

convergencia4 x = perteneceA (sucLoomis3 x) 1

where perteneceA (y:ys) n | y == c = y

| otherwise = perteneceA ys c

where c = head $ dropWhile (< y) $ sucLoomis3 n

-- Comparación de eficiencia

-- =========================

-- λ> convergencia1 (10^4)

-- 150056

-- (2.94 secs, 1,260,809,808 bytes)

-- λ> convergencia2 (10^4)

-- 150056

-- (0.03 secs, 700,240 bytes)

-- λ> convergencia3 (10^4)

-- 150056

-- (0.03 secs, 1,165,496 bytes)

-- λ> convergencia4 (10^4)

-- 150056

-- (0.02 secs, 1,119,648 bytes)

-- λ> convergencia2 (10^12)

-- 1000101125092

-- (1.81 secs, 714,901,080 bytes)

-- λ> convergencia3 (10^12)

-- 1000101125092

-- (1.92 secs, 744,932,184 bytes)

-- λ> convergencia4 (10^12)

-- 1000101125092

-- (1.82 secs, 941,053,328 bytes)

-- Definición de graficaConvergencia

-- ==================================

graficaConvergencia :: [Integer] -> IO ()

graficaConvergencia xs =

plotList [ Key Nothing

, Title "Convergencia de sucesiones de Loomis"

, XRange (fromIntegral (minimum xs),fromIntegral (maximum xs))

, PNG "Las_sucesiones_de_Loomis_2.png"

]

[(x,convergencia2 x) | x <- xs]

Operaciones con polinomios como diccionarios

PorJosé A. Alonso 15-mayo-202022-mayo-2020

Los polinomios se pueden representar mediante diccionarios con los exponentes como claves y los coeficientes como valores.

El tipo de los polinomios con coeficientes de tipo a se define por

   type Polinomio a = M.Map Int a

1	type Polinomio a = M.Map Int a

Dos ejemplos de polinomios (que usaremos en los ejemplos) son

   3 + 7x - 5x^3
   4 + 5x^3 + x^5

1 2	3 + 7x - 5x^3 4 + 5x^3 + x^5

se definen por

  ejPol1, ejPol2 :: Polinomio Int
  ejPol1 = M.fromList [(0,3),(1,7),(3,-5)]
  ejPol2 = M.fromList [(0,4),(3,5),(5,1)]

ejPol1, ejPol2 :: Polinomio Int

ejPol1 = M.fromList [(0,3),(1,7),(3,-5)]

ejPol2 = M.fromList [(0,4),(3,5),(5,1)]

Definir las funciones

   sumaPol :: (Num a, Eq a) => Polinomio a -> Polinomio a -> Polinomio a
   multPorTerm :: Num a => (Int,a) -> Polinomio a -> Polinomio a
   multPol :: (Eq a, Num a) => Polinomio a -> Polinomio a -> Polinomio a

sumaPol :: (Num a, Eq a) => Polinomio a -> Polinomio a -> Polinomio a

multPorTerm :: Num a => (Int,a) -> Polinomio a -> Polinomio a

multPol :: (Eq a, Num a) => Polinomio a -> Polinomio a -> Polinomio a

tales que

(sumaPol p q) es la suma de los polinomios p y q. Por ejemplo,

     λ> sumaPol ejPol1 ejPol2
     fromList [(0,7),(1,7),(5,1)]
     λ> sumaPol ejPol1 ejPol1
     fromList [(0,6),(1,14),(3,-10)]

λ> sumaPol ejPol1 ejPol2

fromList [(0,7),(1,7),(5,1)]

λ> sumaPol ejPol1 ejPol1

fromList [(0,6),(1,14),(3,-10)]

(multPorTerm (n,a) p) es el producto del término ax^n por p. Por ejemplo,

     λ> multPorTerm (2,3) (M.fromList [(0,4),(2,1)])
     fromList [(2,12),(4,3)]

1 2	λ> multPorTerm (2,3) (M.fromList [(0,4),(2,1)]) fromList [(2,12),(4,3)]

(multPol p q) es el producto de los polinomios p y q. Por ejemplo,

     λ> multPol ejPol1 ejPol2
     fromList [(0,12),(1,28),(3,-5),(4,35),(5,3),(6,-18),(8,-5)]
     λ> multPol ejPol1 ejPol1
     fromList [(0,9),(1,42),(2,49),(3,-30),(4,-70),(6,25)]
     λ> multPol ejPol2 ejPol2
     fromList [(0,16),(3,40),(5,8),(6,25),(8,10),(10,1)]

λ> multPol ejPol1 ejPol2

fromList [(0,12),(1,28),(3,-5),(4,35),(5,3),(6,-18),(8,-5)]

λ> multPol ejPol1 ejPol1

fromList [(0,9),(1,42),(2,49),(3,-30),(4,-70),(6,25)]

λ> multPol ejPol2 ejPol2

fromList [(0,16),(3,40),(5,8),(6,25),(8,10),(10,1)]

Soluciones

import qualified Data.Map as M

type Polinomio a = M.Map Int a 

ejPol1, ejPol2 :: Polinomio Int
ejPol1 = M.fromList [(0,3),(1,7),(3,-5)]
ejPol2 = M.fromList [(0,4),(3,5),(5,1)]

sumaPol :: (Num a, Eq a) => Polinomio a -> Polinomio a -> Polinomio a
sumaPol p q = 
    M.filter (/=0) (M.unionWith (+) p q)

multPorTerm :: Num a => (Int,a) -> Polinomio a -> Polinomio a
multPorTerm (n,a) p =
    M.map (*a) (M.mapKeys (+n) p)

multPol :: (Eq a, Num a) => Polinomio a -> Polinomio a -> Polinomio a
multPol p q
    | M.null p  = M.empty
    | otherwise = sumaPol (multPorTerm t q) (multPol r q)
    where (t,r) = M.deleteFindMin p

import qualified Data.Map as M

type Polinomio a = M.Map Int a

ejPol1, ejPol2 :: Polinomio Int

ejPol1 = M.fromList [(0,3),(1,7),(3,-5)]

ejPol2 = M.fromList [(0,4),(3,5),(5,1)]

sumaPol :: (Num a, Eq a) => Polinomio a -> Polinomio a -> Polinomio a

sumaPol p q =

M.filter (/=0) (M.unionWith (+) p q)

multPorTerm :: Num a => (Int,a) -> Polinomio a -> Polinomio a

multPorTerm (n,a) p =

M.map (*a) (M.mapKeys (+n) p)

multPol :: (Eq a, Num a) => Polinomio a -> Polinomio a -> Polinomio a

multPol p q

| M.null p = M.empty

| otherwise = sumaPol (multPorTerm t q) (multPol r q)

where (t,r) = M.deleteFindMin p

Cadenas de divisores

PorJosé A. Alonso 14-mayo-202021-mayo-2020

Una cadena de divisores de un número n es una lista donde cada elemento es un divisor de su siguiente elemento en la lista. Por ejemplo, las cadenas de divisores de 12 son [2,4,12], [2,6,12], [2,12], [3,6,12], [3,12], [4,12], [6,12] y [12].

Definir la función

   cadenasDivisores :: Int -> [[Int]]

1	cadenasDivisores :: Int -> [[Int]]

tal que (cadenasDivisores n) es la lista de las cadenas de divisores de n. Por ejemplo,

   λ> cadenasDivisores 12
   [[2,4,12],[2,6,12],[2,12],[3,6,12],[3,12],[4,12],[6,12],[12]]
   λ> length (cadenaDivisores 48)
   48
   λ> length (cadenaDivisores 120)
   132

λ> cadenasDivisores 12

[[2,4,12],[2,6,12],[2,12],[3,6,12],[3,12],[4,12],[6,12],[12]]

λ> length (cadenaDivisores 48)

λ> length (cadenaDivisores 120)

132

Soluciones

import Data.List (sort)
import Data.Numbers.Primes (isPrime)

-- 1ª definición
-- =============

cadenasDivisores :: Int -> [[Int]]
cadenasDivisores n = sort (extiendeLista [[n]])
    where extiendeLista []           = []
          extiendeLista ((1:xs):yss) = xs : extiendeLista yss
          extiendeLista ((x:xs):yss) =
              extiendeLista ([y:x:xs | y <- divisores x] ++ yss)

-- (divisores x) es la lista decreciente de los divisores de x distintos
-- de x. Por ejemplo,
--    divisores 12  ==  [6,4,3,2,1]
divisores :: Int -> [Int]
divisores x = 
    [y | y <- [a,a-1..1], x `mod` y == 0]
    where a = x `div` 2

-- 2ª definición
-- =============

cadenasDivisores2 :: Int -> [[Int]]
cadenasDivisores2 = sort . aux
    where aux 1 = [[]]
          aux n = [xs ++ [n] | xs <- concatMap aux (divisores n)]

-- 3ª definición
-- =============

cadenasDivisores3 :: Int -> [[Int]]
cadenasDivisores3 = sort . map reverse . aux
    where aux 1 = [[]]
          aux n = map (n:) (concatMap aux (divisores3 n))

-- (divisores3 x) es la lista creciente de los divisores de x distintos
-- de x. Por ejemplo,
--    divisores3 12  ==  [1,2,3,4,6]
divisores3 :: Int -> [Int]
divisores3 x = 
    [y | y <- [1..a], x `mod` y == 0]
    where a = x `div` 2

-- 1ª definición de nCadenasDivisores
-- ==================================

nCadenasDivisores1 :: Int -> Int
nCadenasDivisores1 = length . cadenasDivisores

-- 2ª definición de nCadenasDivisores
-- ==================================

nCadenasDivisores2 :: Int -> Int
nCadenasDivisores2 1 = 1
nCadenasDivisores2 n = 
    sum [nCadenasDivisores2 x | x <- divisores n]

import Data.List (sort)

import Data.Numbers.Primes (isPrime)

-- 1ª definición

-- =============

cadenasDivisores :: Int -> [[Int]]

cadenasDivisores n = sort (extiendeLista [[n]])

where extiendeLista [] = []

extiendeLista ((1:xs):yss) = xs : extiendeLista yss

extiendeLista ((x:xs):yss) =

extiendeLista ([y:x:xs | y <- divisores x] ++ yss)

-- (divisores x) es la lista decreciente de los divisores de x distintos

-- de x. Por ejemplo,

-- divisores 12 == [6,4,3,2,1]

divisores :: Int -> [Int]

divisores x =

[y | y <- [a,a-1..1], x `mod` y == 0]

where a = x `div` 2

-- 2ª definición

-- =============

cadenasDivisores2 :: Int -> [[Int]]

cadenasDivisores2 = sort . aux

where aux 1 = [[]]

aux n = [xs ++ [n] | xs <- concatMap aux (divisores n)]

-- 3ª definición

-- =============

cadenasDivisores3 :: Int -> [[Int]]

cadenasDivisores3 = sort . map reverse . aux

where aux 1 = [[]]

aux n = map (n:) (concatMap aux (divisores3 n))

-- (divisores3 x) es la lista creciente de los divisores de x distintos

-- de x. Por ejemplo,

-- divisores3 12 == [1,2,3,4,6]

divisores3 :: Int -> [Int]

divisores3 x =

[y | y <- [1..a], x `mod` y == 0]

where a = x `div` 2

-- 1ª definición de nCadenasDivisores

-- ==================================

nCadenasDivisores1 :: Int -> Int

nCadenasDivisores1 = length . cadenasDivisores

-- 2ª definición de nCadenasDivisores

-- ==================================

nCadenasDivisores2 :: Int -> Int

nCadenasDivisores2 1 = 1

nCadenasDivisores2 n =

sum [nCadenasDivisores2 x | x <- divisores n]

Sucesión fractal

PorJosé A. Alonso 13-mayo-202020-mayo-2020

La sucesión fractal

   0, 0, 1, 0, 2, 1, 3, 0, 4, 2, 5, 1, 6, 3, 7, 0, 8, 4, 9, 2, 
   10, 5, 11, 1, 12, 6, 13, 3, 14, 7, 15, ...

1 2	0, 0, 1, 0, 2, 1, 3, 0, 4, 2, 5, 1, 6, 3, 7, 0, 8, 4, 9, 2, 10, 5, 11, 1, 12, 6, 13, 3, 14, 7, 15, ...

está construida de la siguiente forma:

los términos pares forman la sucesión de los números naturales

     0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, ...

1	0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, ...

los términos impares forman la misma sucesión original

     0, 0, 1, 0, 2, 1, 3, 0, 4, 2, 5, 1, 6, 3, 7, ...

1	0, 0, 1, 0, 2, 1, 3, 0, 4, 2, 5, 1, 6, 3, 7, ...

Definir las funciones

   sucFractal     :: [Integer]
   sumaSucFractal :: Integer -> Integer

1 2	sucFractal :: [Integer] sumaSucFractal :: Integer -> Integer

tales que

sucFractal es la lista de los términos de la sucesión fractal. Por ejemplo,

     take 20 sucFractal   == [0,0,1,0,2,1,3,0,4,2,5,1,6,3,7,0,8,4,9,2]
     sucFractal !! 30     == 15
     sucFractal !! (10^7) == 5000000

take 20 sucFractal == [0,0,1,0,2,1,3,0,4,2,5,1,6,3,7,0,8,4,9,2]

sucFractal !! 30 == 15

sucFractal !! (10^7) == 5000000

(sumaSucFractal n) es la suma de los n primeros términos de la sucesión fractal. Por ejemplo,

     sumaSucFractal 10      == 13
     sumaSucFractal (10^5)  == 1666617368
     sumaSucFractal (10^10) == 16666666661668691669
     sumaSucFractal (10^15) == 166666666666666166673722792954
     sumaSucFractal (10^20) == 1666666666666666666616666684103392376198
     length (show (sumaSucFractal (10^15000))) == 30000
     sumaSucFractal (10^15000) `mod` (10^9)    == 455972157

sumaSucFractal 10 == 13

sumaSucFractal (10^5) == 1666617368

sumaSucFractal (10^10) == 16666666661668691669

sumaSucFractal (10^15) == 166666666666666166673722792954

sumaSucFractal (10^20) == 1666666666666666666616666684103392376198

length (show (sumaSucFractal (10^15000))) == 30000

sumaSucFractal (10^15000) `mod` (10^9) == 455972157

Soluciones

-- 1ª definición de sucFractal
-- ===========================

sucFractal1 :: [Integer]
sucFractal1 = 
  map termino [0..]

-- (termino n) es el término n de la secuencia anterior. Por ejemplo,
--   termino 0            ==  0
--   termino 1            ==  0
--   map termino [0..10]  ==  [0,0,1,0,2,1,3,0,4,2,5]
termino :: Integer -> Integer
termino 0 = 0
termino n 
  | even n    = n `div` 2
  | otherwise = termino (n `div` 2)

-- 2ª definición de sucFractal
-- ===========================

sucFractal2 :: [Integer]
sucFractal2 =
  0 : 0 : mezcla [1..] (tail sucFractal2)

-- (mezcla xs ys) es la lista obtenida intercalando las listas infinitas
-- xs e ys. Por ejemplo,
--    take 10 (mezcla [0,2..] [0,-2..])  ==  [0,0,2,-2,4,-4,6,-6,8,-8]
mezcla :: [Integer] -> [Integer] -> [Integer]
mezcla (x:xs) (y:ys) =
  x : y : mezcla xs ys

-- Comparación de eficiencia de definiciones de sucFractal
-- =======================================================

--    λ> sum (take (10^6) sucFractal1)
--    166666169612
--    (5.56 secs, 842,863,264 bytes)
--    λ> sum (take (10^6) sucFractal2)
--    166666169612
--    (1.81 secs, 306,262,616 bytes)

-- En lo que sigue usaremos la 2ª definición
sucFractal :: [Integer]
sucFractal = sucFractal2

-- 1ª definición de sumaSucFractal
-- ===============================

sumaSucFractal1 :: Integer -> Integer
sumaSucFractal1 n =
  sum (map termino [0..n-1])

-- 2ª definición de sumaSucFractal
-- ===============================

sumaSucFractal2 :: Integer -> Integer
sumaSucFractal2 n =
  sum (take (fromIntegral n) sucFractal)

-- 3ª definición de sumaSucFractal
-- ===============================

sumaSucFractal3 :: Integer -> Integer
sumaSucFractal3 0 = 0
sumaSucFractal3 1 = 0
sumaSucFractal3 n
  | even n    = sumaN (n `div` 2) + sumaSucFractal3 (n `div` 2)
  | otherwise = sumaN ((n+1) `div` 2) + sumaSucFractal3 (n `div` 2)
  where sumaN n = (n*(n-1)) `div` 2

-- Comparación de eficiencia de definiciones de sumaSucFractal
-- ===========================================================

--    λ> sumaSucFractal1 (10^6)
--    166666169612
--    (5.25 secs, 810,622,504 bytes)
--    λ> sumaSucFractal2 (10^6)
--    166666169612
--    (1.72 secs, 286,444,048 bytes)
--    λ> sumaSucFractal3 (10^6)
--    166666169612
--    (0.01 secs, 0 bytes)
--    
--    λ> sumaSucFractal2 (10^7)
--    16666661685034
--    (17.49 secs, 3,021,580,920 bytes)
--    λ> sumaSucFractal3 (10^7)
--    16666661685034
--    (0.01 secs, 0 bytes)

-- 1ª definición de sucFractal

-- ===========================

sucFractal1 :: [Integer]

sucFractal1 =

map termino [0..]

-- (termino n) es el término n de la secuencia anterior. Por ejemplo,

-- termino 0 == 0

-- termino 1 == 0

-- map termino [0..10] == [0,0,1,0,2,1,3,0,4,2,5]

termino :: Integer -> Integer

termino 0 = 0

termino n

| even n = n `div` 2

| otherwise = termino (n `div` 2)

-- 2ª definición de sucFractal

-- ===========================

sucFractal2 :: [Integer]

sucFractal2 =

0 : 0 : mezcla [1..] (tail sucFractal2)

-- (mezcla xs ys) es la lista obtenida intercalando las listas infinitas

-- xs e ys. Por ejemplo,

-- take 10 (mezcla [0,2..] [0,-2..]) == [0,0,2,-2,4,-4,6,-6,8,-8]

mezcla :: [Integer] -> [Integer] -> [Integer]

mezcla (x:xs) (y:ys) =

x : y : mezcla xs ys

-- Comparación de eficiencia de definiciones de sucFractal

-- =======================================================

-- λ> sum (take (10^6) sucFractal1)

-- 166666169612

-- (5.56 secs, 842,863,264 bytes)

-- λ> sum (take (10^6) sucFractal2)

-- 166666169612

-- (1.81 secs, 306,262,616 bytes)

-- En lo que sigue usaremos la 2ª definición

sucFractal :: [Integer]

sucFractal = sucFractal2

-- 1ª definición de sumaSucFractal

-- ===============================

sumaSucFractal1 :: Integer -> Integer

sumaSucFractal1 n =

sum (map termino [0..n-1])

-- 2ª definición de sumaSucFractal

-- ===============================

sumaSucFractal2 :: Integer -> Integer

sumaSucFractal2 n =

sum (take (fromIntegral n) sucFractal)

-- 3ª definición de sumaSucFractal

-- ===============================

sumaSucFractal3 :: Integer -> Integer

sumaSucFractal3 0 = 0

sumaSucFractal3 1 = 0

sumaSucFractal3 n

| even n = sumaN (n `div` 2) + sumaSucFractal3 (n `div` 2)

| otherwise = sumaN ((n+1) `div` 2) + sumaSucFractal3 (n `div` 2)

where sumaN n = (n*(n-1)) `div` 2

-- Comparación de eficiencia de definiciones de sumaSucFractal

-- ===========================================================

-- λ> sumaSucFractal1 (10^6)

-- 166666169612

-- (5.25 secs, 810,622,504 bytes)

-- λ> sumaSucFractal2 (10^6)

-- 166666169612

-- (1.72 secs, 286,444,048 bytes)

-- λ> sumaSucFractal3 (10^6)

-- 166666169612

-- (0.01 secs, 0 bytes)

-- λ> sumaSucFractal2 (10^7)

-- 16666661685034

-- (17.49 secs, 3,021,580,920 bytes)

-- λ> sumaSucFractal3 (10^7)

-- 16666661685034

-- (0.01 secs, 0 bytes)

Máximo de las sumas de los caminos en una matriz

PorJosé A. Alonso 11-mayo-202018-mayo-2020

Los caminos desde el extremo superior izquierdo (posición (1,1)) hasta el extremo inferior derecho (posición (3,4)) en la matriz

   (  1  6 11  2 )
   (  7 12  3  8 )
   (  3  8  4  9 )

( 1 6 11 2 )

( 7 12 3 8 )

( 3 8 4 9 )

moviéndose en cada paso una casilla hacia abajo o hacia la derecha, son los siguientes:

   1, 7,  3, 8, 4, 9
   1, 7, 12, 8, 4, 9
   1, 7, 12, 3, 4, 9
   1, 7, 12, 3, 8, 9
   1, 6, 12, 8, 4, 9
   1, 6, 12, 3, 4, 9
   1, 6, 12, 3, 8, 9
   1, 6, 11, 3, 4, 9
   1, 6, 11, 3, 8, 9
   1, 6, 11, 2, 8, 9

1, 7, 3, 8, 4, 9

1, 7, 12, 8, 4, 9

1, 7, 12, 3, 4, 9

1, 7, 12, 3, 8, 9

1, 6, 12, 8, 4, 9

1, 6, 12, 3, 4, 9

1, 6, 12, 3, 8, 9

1, 6, 11, 3, 4, 9

1, 6, 11, 3, 8, 9

1, 6, 11, 2, 8, 9

Las sumas de los caminos son 32, 41, 36, 40, 40, 35, 39, 34, 38 y 37, respectivamente. El máximo de las suma de los caminos es 41.

Definir la función

   maximaSuma :: Matrix Int -> Int

1	maximaSuma :: Matrix Int -> Int

tal que (maximaSuma m) es el máximo de las sumas de los caminos en la matriz m desde el extremo superior izquierdo hasta el extremo inferior derecho, moviéndose en cada paso una casilla hacia abajo o hacia la derecha. Por ejemplo,

   λ> maximaSuma (fromLists [[1,6,11,2],[7,12,3,8],[3,8,4,9]])
   41
   λ> maximaSuma (fromList 800 800 [1..])
   766721999

λ> maximaSuma (fromLists [[1,6,11,2],[7,12,3,8],[3,8,4,9]])

λ> maximaSuma (fromList 800 800 [1..])

766721999

Nota: Se recomienda usar programación dinámica.

Soluciones

import Data.Matrix

-- 1ª definición
-- =============

maximaSuma1 :: Matrix Int -> Int
maximaSuma1 =
  maximum . map sum . caminos1

caminos1 :: Matrix Int -> [[Int]]
caminos1 m =
  map reverse (caminos1Aux m (nf,nc))
  where nf = nrows m
        nc = ncols m

-- (caminos1Aux p x) es la lista de los caminos invertidos en la matriz p
-- desde la posición (1,1) hasta la posición x. Por ejemplo,
caminos1Aux :: Matrix Int -> (Int,Int) -> [[Int]]
caminos1Aux m (1,1) = [[m!(1,1)]]
caminos1Aux m (1,j) = [[m!(1,k) | k <- [j,j-1..1]]]
caminos1Aux m (i,1) = [[m!(k,1) | k <- [i,i-1..1]]]
caminos1Aux m (i,j) = [m!(i,j) : xs
                      | xs <- caminos1Aux m (i,j-1) ++
                              caminos1Aux m (i-1,j)]

-- 2ª definición
-- =============

maximaSuma2 :: Matrix Int -> Int
maximaSuma2 =
  maximum . map sum . caminos2

caminos2 :: Matrix Int -> [[Int]]
caminos2 m =
  map reverse (matrizCaminos m ! (nrows m, ncols m))

matrizCaminos :: Matrix Int -> Matrix [[Int]]
matrizCaminos m = q
  where
    q = matrix (nrows m) (ncols m) f
    f (1,y) = [[m!(1,z) | z <- [y,y-1..1]]]
    f (x,1) = [[m!(z,1) | z <- [x,x-1..1]]]
    f (x,y) = [m!(x,y) : cs | cs <- q!(x-1,y) ++ q!(x,y-1)]  

-- 3ª definicion (por recursión, sin calcular el camino)
-- =====================================================

maximaSuma3 :: Matrix Int -> Int
maximaSuma3 m = maximaSuma3Aux m (nf,nc)
  where nf = nrows m
        nc = ncols m

-- (maximaSuma3Aux m p) calcula la suma máxima de un camino hasta la
-- posición p. Por ejemplo,
--    λ> maximaSuma3Aux (fromLists [[1,6,11,2],[7,12,3,8],[3,8,4,9]]) (3,4)
--    41
--    λ> maximaSuma3Aux (fromLists [[1,6,11,2],[7,12,3,8],[3,8,4,9]]) (3,3)
--    32
--    λ> maximaSuma3Aux (fromLists [[1,6,11,2],[7,12,3,8],[3,8,4,9]]) (2,4)
--    31
maximaSuma3Aux :: Matrix Int -> (Int,Int) -> Int
maximaSuma3Aux m (1,1) = m ! (1,1)
maximaSuma3Aux m (1,j) = maximaSuma3Aux m (1,j-1) + m ! (1,j)
maximaSuma3Aux m (i,1) = maximaSuma3Aux m (i-1,1) + m ! (i,1)
maximaSuma3Aux m (i,j) =
  max (maximaSuma3Aux m (i,j-1)) (maximaSuma3Aux m (i-1,j)) + m ! (i,j)

-- 4ª solución (mediante programación dinámica)
-- ============================================

maximaSuma4 :: Matrix Int -> Int
maximaSuma4 m = q ! (nf,nc)
  where nf = nrows m
        nc = ncols m
        q  = matrizMaximaSuma m

-- (matrizMaximaSuma m) es la matriz donde en cada posición p se
-- encuentra el máxima de las sumas de los caminos desde (1,1) a p en la
-- matriz m. Por ejemplo,   
--    λ> matrizMaximaSuma (fromLists [[1,6,11,2],[7,12,3,8],[3,8,4,9]]) 
--    (  1  7 18 20 )
--    (  8 20 23 31 )
--    ( 11 28 32 41 )
matrizMaximaSuma :: Matrix Int -> Matrix Int
matrizMaximaSuma m = q 
  where nf = nrows m
        nc = ncols m
        q  = matrix nf nc f
          where  f (1,1) = m ! (1,1)
                 f (1,j) = q ! (1,j-1) + m ! (1,j)
                 f (i,1) = q ! (i-1,1) + m ! (i,1)
                 f (i,j) = max (q ! (i,j-1)) (q ! (i-1,j)) + m ! (i,j)

-- Comparación de eficiencia
-- =========================

--    λ> maximaSuma1 (fromList 8 8 [1..])
--    659
--    (0.11 secs, 31,853,136 bytes)
--    λ> maximaSuma1a (fromList 8 8 [1..])
--    659
--    (0.09 secs, 19,952,640 bytes)
-- 
--    λ> maximaSuma1 (fromList 10 10 [1..])
--    1324
--    (2.25 secs, 349,722,744 bytes)
--    λ> maximaSuma2 (fromList 10 10 [1..])
--    1324
--    (0.76 secs, 151,019,296 bytes)
--    
--    λ> maximaSuma2 (fromList 11 11 [1..])
--    1781
--    (3.02 secs, 545,659,632 bytes)
--    λ> maximaSuma3 (fromList 11 11 [1..])
--    1781
--    (1.57 secs, 210,124,912 bytes)
--    
--    λ> maximaSuma3 (fromList 12 12 [1..])
--    2333
--    (5.60 secs, 810,739,032 bytes)
--    λ> maximaSuma4 (fromList 12 12 [1..])
--    2333
--    (0.01 secs, 23,154,776 bytes)

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

import Data.Matrix

-- 1ª definición

-- =============

maximaSuma1 :: Matrix Int -> Int

maximaSuma1 =

maximum . map sum . caminos1

caminos1 :: Matrix Int -> [[Int]]

caminos1 m =

map reverse (caminos1Aux m (nf,nc))

where nf = nrows m

nc = ncols m

-- (caminos1Aux p x) es la lista de los caminos invertidos en la matriz p

-- desde la posición (1,1) hasta la posición x. Por ejemplo,

caminos1Aux :: Matrix Int -> (Int,Int) -> [[Int]]

caminos1Aux m (1,1) = [[m!(1,1)]]

caminos1Aux m (1,j) = [[m!(1,k) | k <- [j,j-1..1]]]

caminos1Aux m (i,1) = [[m!(k,1) | k <- [i,i-1..1]]]

caminos1Aux m (i,j) = [m!(i,j) : xs

| xs <- caminos1Aux m (i,j-1) ++

caminos1Aux m (i-1,j)]

-- 2ª definición

-- =============

maximaSuma2 :: Matrix Int -> Int

maximaSuma2 =

maximum . map sum . caminos2

caminos2 :: Matrix Int -> [[Int]]

caminos2 m =

map reverse (matrizCaminos m ! (nrows m, ncols m))

matrizCaminos :: Matrix Int -> Matrix [[Int]]

matrizCaminos m = q

where

q = matrix (nrows m) (ncols m) f

f (1,y) = [[m!(1,z) | z <- [y,y-1..1]]]

f (x,1) = [[m!(z,1) | z <- [x,x-1..1]]]

f (x,y) = [m!(x,y) : cs | cs <- q!(x-1,y) ++ q!(x,y-1)]

-- 3ª definicion (por recursión, sin calcular el camino)

-- =====================================================

maximaSuma3 :: Matrix Int -> Int

maximaSuma3 m = maximaSuma3Aux m (nf,nc)

where nf = nrows m

nc = ncols m

-- (maximaSuma3Aux m p) calcula la suma máxima de un camino hasta la

-- posición p. Por ejemplo,

-- λ> maximaSuma3Aux (fromLists [[1,6,11,2],[7,12,3,8],[3,8,4,9]]) (3,4)

-- 41

-- λ> maximaSuma3Aux (fromLists [[1,6,11,2],[7,12,3,8],[3,8,4,9]]) (3,3)

-- 32

-- λ> maximaSuma3Aux (fromLists [[1,6,11,2],[7,12,3,8],[3,8,4,9]]) (2,4)

-- 31

maximaSuma3Aux :: Matrix Int -> (Int,Int) -> Int

maximaSuma3Aux m (1,1) = m ! (1,1)

maximaSuma3Aux m (1,j) = maximaSuma3Aux m (1,j-1) + m ! (1,j)

maximaSuma3Aux m (i,1) = maximaSuma3Aux m (i-1,1) + m ! (i,1)

maximaSuma3Aux m (i,j) =

max (maximaSuma3Aux m (i,j-1)) (maximaSuma3Aux m (i-1,j)) + m ! (i,j)

-- 4ª solución (mediante programación dinámica)

-- ============================================

maximaSuma4 :: Matrix Int -> Int

maximaSuma4 m = q ! (nf,nc)

where nf = nrows m

nc = ncols m

q = matrizMaximaSuma m

-- (matrizMaximaSuma m) es la matriz donde en cada posición p se

-- encuentra el máxima de las sumas de los caminos desde (1,1) a p en la

-- matriz m. Por ejemplo,

-- λ> matrizMaximaSuma (fromLists [[1,6,11,2],[7,12,3,8],[3,8,4,9]])

-- ( 1 7 18 20 )

-- ( 8 20 23 31 )

-- ( 11 28 32 41 )

matrizMaximaSuma :: Matrix Int -> Matrix Int

matrizMaximaSuma m = q

where nf = nrows m

nc = ncols m

q = matrix nf nc f

where f (1,1) = m ! (1,1)

f (1,j) = q ! (1,j-1) + m ! (1,j)

f (i,1) = q ! (i-1,1) + m ! (i,1)

f (i,j) = max (q ! (i,j-1)) (q ! (i-1,j)) + m ! (i,j)

-- Comparación de eficiencia

-- =========================

-- λ> maximaSuma1 (fromList 8 8 [1..])

-- 659

-- (0.11 secs, 31,853,136 bytes)

-- λ> maximaSuma1a (fromList 8 8 [1..])

-- 659

-- (0.09 secs, 19,952,640 bytes)

-- λ> maximaSuma1 (fromList 10 10 [1..])

-- 1324

-- (2.25 secs, 349,722,744 bytes)

-- λ> maximaSuma2 (fromList 10 10 [1..])

-- 1324

-- (0.76 secs, 151,019,296 bytes)

-- λ> maximaSuma2 (fromList 11 11 [1..])

-- 1781

-- (3.02 secs, 545,659,632 bytes)

-- λ> maximaSuma3 (fromList 11 11 [1..])

-- 1781

-- (1.57 secs, 210,124,912 bytes)

-- λ> maximaSuma3 (fromList 12 12 [1..])

-- 2333

-- (5.60 secs, 810,739,032 bytes)

-- λ> maximaSuma4 (fromList 12 12 [1..])

-- 2333

-- (0.01 secs, 23,154,776 bytes)

Soluciones

Nuevas soluciones

Soluciones

Nuevas soluciones

Soluciones

Nuevas soluciones

Soluciones

Nuevas soluciones

Soluciones

Nuevas soluciones

Soluciones

Nuevas soluciones

Soluciones

Nuevas soluciones

Soluciones

Nuevas soluciones

Soluciones

Nuevas soluciones

Soluciones

Nuevas soluciones

Soluciones

Nuevas soluciones

Soluciones

Nuevas soluciones

Soluciones

Nuevas soluciones

Soluciones

Nuevas soluciones

Soluciones

Nuevas soluciones

Soluciones

Nuevas soluciones

Soluciones

Nuevas soluciones

Soluciones

Nuevas soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Nuevas soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Soluciones

Entradas recientes

Buscar

Correo electrónico